From fc84c27eac260dffd8f2fb1cb56d599f1e3486d9 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 9 Mar 2015 11:07:53 +0100 Subject: Initial commit --- mathcomp/.all.v.un~ | Bin 0 -> 3134 bytes mathcomp/algebra/all.v | 16 + mathcomp/algebra/finalg.v | 1297 +++++ mathcomp/algebra/fraction.v | 384 ++ mathcomp/algebra/intdiv.v | 1076 ++++ mathcomp/algebra/interval.v | 403 ++ mathcomp/algebra/matrix.v | 2872 +++++++++++ mathcomp/algebra/mxalgebra.v | 2764 ++++++++++ mathcomp/algebra/mxpoly.v | 1109 ++++ mathcomp/algebra/poly.v | 2591 ++++++++++ mathcomp/algebra/polyXY.v | 405 ++ mathcomp/algebra/polydiv.v | 3418 +++++++++++++ mathcomp/algebra/rat.v | 808 +++ mathcomp/algebra/ring_quotient.v | 650 +++ mathcomp/algebra/ssralg.v | 6230 +++++++++++++++++++++++ mathcomp/algebra/ssrint.v | 1782 +++++++ mathcomp/algebra/ssrnum.v | 4219 +++++++++++++++ mathcomp/algebra/vector.v | 2040 ++++++++ mathcomp/all.v | 10 + mathcomp/attic/algnum_basic.v | 535 ++ mathcomp/attic/all.v | 9 + mathcomp/attic/amodule.v | 417 ++ mathcomp/attic/fib.v | 340 ++ mathcomp/attic/forms.v | 193 + mathcomp/attic/galgebra.v | 227 + mathcomp/attic/multinom.v | 438 ++ mathcomp/attic/mxtens.v | 312 ++ mathcomp/attic/quote.v | 365 ++ mathcomp/attic/tutorial.v | 296 ++ mathcomp/character/all.v | 7 + mathcomp/character/character.v | 2976 +++++++++++ mathcomp/character/classfun.v | 2463 +++++++++ mathcomp/character/inertia.v | 1607 ++++++ mathcomp/character/integral_char.v | 708 +++ mathcomp/character/mxabelem.v | 1057 ++++ mathcomp/character/mxrepresentation.v | 5853 +++++++++++++++++++++ mathcomp/character/vcharacter.v | 987 ++++ mathcomp/discrete/all.v | 12 + mathcomp/discrete/bigop.v | 1770 +++++++ mathcomp/discrete/binomial.v | 524 ++ mathcomp/discrete/choice.v | 681 +++ mathcomp/discrete/div.v | 946 ++++ mathcomp/discrete/finfun.v | 302 ++ mathcomp/discrete/fingraph.v | 721 +++ mathcomp/discrete/finset.v | 2214 ++++++++ mathcomp/discrete/fintype.v | 2037 ++++++++ mathcomp/discrete/generic_quotient.v | 727 +++ mathcomp/discrete/path.v | 890 ++++ mathcomp/discrete/prime.v | 1404 +++++ mathcomp/discrete/tuple.v | 412 ++ mathcomp/field/algC.v | 1854 +++++++ mathcomp/field/algebraics_fundamentals.v | 867 ++++ mathcomp/field/algnum.v | 835 +++ mathcomp/field/all.v | 11 + mathcomp/field/closed_field.v | 634 +++ mathcomp/field/countalg.v | 1107 ++++ mathcomp/field/cyclotomic.v | 320 ++ mathcomp/field/falgebra.v | 1199 +++++ mathcomp/field/fieldext.v | 1626 ++++++ mathcomp/field/finfield.v | 585 +++ mathcomp/field/galois.v | 1628 ++++++ mathcomp/field/separable.v | 995 ++++ mathcomp/fingroup/action.v | 2719 ++++++++++ mathcomp/fingroup/all.v | 10 + mathcomp/fingroup/automorphism.v | 489 ++ mathcomp/fingroup/cyclic.v | 865 ++++ mathcomp/fingroup/fingroup.v | 3096 +++++++++++ mathcomp/fingroup/gproduct.v | 1703 +++++++ mathcomp/fingroup/morphism.v | 1539 ++++++ mathcomp/fingroup/perm.v | 576 +++ mathcomp/fingroup/presentation.v | 254 + mathcomp/fingroup/quotient.v | 972 ++++ mathcomp/fingroup/zmodp.v | 362 ++ mathcomp/odd_order/BGappendixAB.v | 508 ++ mathcomp/odd_order/BGappendixC.v | 749 +++ mathcomp/odd_order/BGsection1.v | 1340 +++++ mathcomp/odd_order/BGsection10.v | 1497 ++++++ mathcomp/odd_order/BGsection11.v | 438 ++ mathcomp/odd_order/BGsection12.v | 2688 ++++++++++ mathcomp/odd_order/BGsection13.v | 1116 ++++ mathcomp/odd_order/BGsection14.v | 2513 +++++++++ mathcomp/odd_order/BGsection15.v | 1509 ++++++ mathcomp/odd_order/BGsection16.v | 1359 +++++ mathcomp/odd_order/BGsection2.v | 1153 +++++ mathcomp/odd_order/BGsection3.v | 1831 +++++++ mathcomp/odd_order/BGsection4.v | 1413 +++++ mathcomp/odd_order/BGsection5.v | 536 ++ mathcomp/odd_order/BGsection6.v | 315 ++ mathcomp/odd_order/BGsection7.v | 979 ++++ mathcomp/odd_order/BGsection8.v | 404 ++ mathcomp/odd_order/BGsection9.v | 470 ++ mathcomp/odd_order/PFsection1.v | 809 +++ mathcomp/odd_order/PFsection10.v | 1215 +++++ mathcomp/odd_order/PFsection11.v | 1193 +++++ mathcomp/odd_order/PFsection12.v | 1371 +++++ mathcomp/odd_order/PFsection13.v | 2185 ++++++++ mathcomp/odd_order/PFsection14.v | 1257 +++++ mathcomp/odd_order/PFsection2.v | 822 +++ mathcomp/odd_order/PFsection3.v | 1854 +++++++ mathcomp/odd_order/PFsection4.v | 987 ++++ mathcomp/odd_order/PFsection5.v | 1607 ++++++ mathcomp/odd_order/PFsection6.v | 1649 ++++++ mathcomp/odd_order/PFsection7.v | 819 +++ mathcomp/odd_order/PFsection8.v | 1128 ++++ mathcomp/odd_order/PFsection9.v | 2205 ++++++++ mathcomp/odd_order/all.v | 33 + mathcomp/odd_order/stripped_odd_order_theorem.v | 204 + mathcomp/real_closed/all.v | 9 + mathcomp/real_closed/bigenough.v | 118 + mathcomp/real_closed/cauchyreals.v | 1681 ++++++ mathcomp/real_closed/complex.v | 1252 +++++ mathcomp/real_closed/ordered_qelim.v | 1180 +++++ mathcomp/real_closed/polyorder.v | 273 + mathcomp/real_closed/polyrcf.v | 1857 +++++++ mathcomp/real_closed/qe_rcf.v | 1008 ++++ mathcomp/real_closed/qe_rcf_th.v | 1293 +++++ mathcomp/real_closed/realalg.v | 1530 ++++++ mathcomp/solvable/abelian.v | 2161 ++++++++ mathcomp/solvable/all.v | 19 + mathcomp/solvable/alt.v | 528 ++ mathcomp/solvable/burnside_app.v | 1305 +++++ mathcomp/solvable/center.v | 652 +++ mathcomp/solvable/commutator.v | 362 ++ mathcomp/solvable/extraspecial.v | 833 +++ mathcomp/solvable/extremal.v | 2331 +++++++++ mathcomp/solvable/finmodule.v | 596 +++ mathcomp/solvable/frobenius.v | 794 +++ mathcomp/solvable/gfunctor.v | 484 ++ mathcomp/solvable/gseries.v | 546 ++ mathcomp/solvable/hall.v | 895 ++++ mathcomp/solvable/jordanholder.v | 681 +++ mathcomp/solvable/maximal.v | 1656 ++++++ mathcomp/solvable/nilpotent.v | 755 +++ mathcomp/solvable/pgroup.v | 1355 +++++ mathcomp/solvable/primitive_action.v | 347 ++ mathcomp/solvable/sylow.v | 661 +++ mathcomp/solvable/wielandt_fixpoint.v | 651 +++ mathcomp/ssreflect/Make | 8 + mathcomp/ssreflect/Makefile | 33 + mathcomp/ssreflect/all.v | 7 + mathcomp/ssreflect/eqtype.v | 860 ++++ mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 | 6138 ++++++++++++++++++++++ mathcomp/ssreflect/plugin/trunk/ssreflect.mllib | 2 + mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 | 1238 +++++ mathcomp/ssreflect/plugin/trunk/ssrmatching.mli | 238 + mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 | 6030 ++++++++++++++++++++++ mathcomp/ssreflect/plugin/v8.4/ssreflect.mllib | 2 + mathcomp/ssreflect/plugin/v8.4/ssrmatching.ml4 | 1223 +++++ mathcomp/ssreflect/plugin/v8.4/ssrmatching.mli | 256 + mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 | 6164 ++++++++++++++++++++++ mathcomp/ssreflect/plugin/v8.5/ssreflect.mllib | 2 + mathcomp/ssreflect/plugin/v8.5/ssrmatching.ml4 | 1290 +++++ mathcomp/ssreflect/plugin/v8.5/ssrmatching.mli | 239 + mathcomp/ssreflect/seq.v | 2552 ++++++++++ mathcomp/ssreflect/ssrbool.v | 1818 +++++++ mathcomp/ssreflect/ssreflect.v | 420 ++ mathcomp/ssreflect/ssrfun.v | 885 ++++ mathcomp/ssreflect/ssrmatching.v | 27 + mathcomp/ssreflect/ssrnat.v | 1598 ++++++ mathcomp/ssrtest/Make | 44 + mathcomp/ssrtest/Makefile | 26 + mathcomp/ssrtest/absevarprop.v | 86 + mathcomp/ssrtest/binders.v | 43 + mathcomp/ssrtest/binders_of.v | 12 + mathcomp/ssrtest/caseview.v | 4 + mathcomp/ssrtest/congr.v | 23 + mathcomp/ssrtest/deferclear.v | 26 + mathcomp/ssrtest/dependent_type_err.v | 7 + mathcomp/ssrtest/elim.v | 222 + mathcomp/ssrtest/elim2.v | 58 + mathcomp/ssrtest/elim_pattern.v | 14 + mathcomp/ssrtest/first_n.v | 9 + mathcomp/ssrtest/gen_have.v | 160 + mathcomp/ssrtest/gen_pattern.v | 20 + mathcomp/ssrtest/have_TC.v | 36 + mathcomp/ssrtest/have_transp.v | 37 + mathcomp/ssrtest/have_view_idiom.v | 6 + mathcomp/ssrtest/havesuff.v | 73 + mathcomp/ssrtest/if_isnt.v | 10 + mathcomp/ssrtest/indetLHS.v | 4 + mathcomp/ssrtest/intro_beta.v | 13 + mathcomp/ssrtest/intro_noop.v | 23 + mathcomp/ssrtest/ipatalternation.v | 6 + mathcomp/ssrtest/ltac_have.v | 28 + mathcomp/ssrtest/ltac_in.v | 14 + mathcomp/ssrtest/move_after.v | 6 + mathcomp/ssrtest/multiview.v | 56 + mathcomp/ssrtest/occarrow.v | 12 + mathcomp/ssrtest/patnoX.v | 5 + mathcomp/ssrtest/rewpatterns.v | 181 + mathcomp/ssrtest/set_lamda.v | 14 + mathcomp/ssrtest/set_pattern.v | 52 + mathcomp/ssrtest/ssrsyntax1.v | 25 + mathcomp/ssrtest/ssrsyntax2.v | 10 + mathcomp/ssrtest/tc.v | 29 + mathcomp/ssrtest/testmx.v | 33 + mathcomp/ssrtest/typeof.v | 9 + mathcomp/ssrtest/unkeyed.v | 18 + mathcomp/ssrtest/view_case.v | 18 + mathcomp/ssrtest/wlog_suff.v | 16 + mathcomp/ssrtest/wlogletin.v | 37 + mathcomp/ssrtest/wlong_intro.v | 6 + 202 files changed, 188280 insertions(+) create mode 100644 mathcomp/.all.v.un~ create mode 100644 mathcomp/algebra/all.v create mode 100644 mathcomp/algebra/finalg.v create mode 100644 mathcomp/algebra/fraction.v create mode 100644 mathcomp/algebra/intdiv.v create mode 100644 mathcomp/algebra/interval.v create mode 100644 mathcomp/algebra/matrix.v create mode 100644 mathcomp/algebra/mxalgebra.v create mode 100644 mathcomp/algebra/mxpoly.v create mode 100644 mathcomp/algebra/poly.v create mode 100644 mathcomp/algebra/polyXY.v create mode 100644 mathcomp/algebra/polydiv.v create mode 100644 mathcomp/algebra/rat.v create mode 100644 mathcomp/algebra/ring_quotient.v create mode 100644 mathcomp/algebra/ssralg.v create mode 100644 mathcomp/algebra/ssrint.v create mode 100644 mathcomp/algebra/ssrnum.v create mode 100644 mathcomp/algebra/vector.v create mode 100644 mathcomp/all.v create mode 100644 mathcomp/attic/algnum_basic.v create mode 100644 mathcomp/attic/all.v create mode 100644 mathcomp/attic/amodule.v create mode 100644 mathcomp/attic/fib.v create mode 100644 mathcomp/attic/forms.v create mode 100644 mathcomp/attic/galgebra.v create mode 100644 mathcomp/attic/multinom.v create mode 100644 mathcomp/attic/mxtens.v create mode 100644 mathcomp/attic/quote.v create mode 100644 mathcomp/attic/tutorial.v create mode 100644 mathcomp/character/all.v create mode 100644 mathcomp/character/character.v create mode 100644 mathcomp/character/classfun.v create mode 100644 mathcomp/character/inertia.v create mode 100644 mathcomp/character/integral_char.v create mode 100644 mathcomp/character/mxabelem.v create mode 100644 mathcomp/character/mxrepresentation.v create mode 100644 mathcomp/character/vcharacter.v create mode 100644 mathcomp/discrete/all.v create mode 100644 mathcomp/discrete/bigop.v create mode 100644 mathcomp/discrete/binomial.v create mode 100644 mathcomp/discrete/choice.v create mode 100644 mathcomp/discrete/div.v create mode 100644 mathcomp/discrete/finfun.v create mode 100644 mathcomp/discrete/fingraph.v create mode 100644 mathcomp/discrete/finset.v create mode 100644 mathcomp/discrete/fintype.v create mode 100644 mathcomp/discrete/generic_quotient.v create mode 100644 mathcomp/discrete/path.v create mode 100644 mathcomp/discrete/prime.v create mode 100644 mathcomp/discrete/tuple.v create mode 100644 mathcomp/field/algC.v create mode 100644 mathcomp/field/algebraics_fundamentals.v create mode 100644 mathcomp/field/algnum.v create mode 100644 mathcomp/field/all.v create mode 100644 mathcomp/field/closed_field.v create mode 100644 mathcomp/field/countalg.v create mode 100644 mathcomp/field/cyclotomic.v create mode 100644 mathcomp/field/falgebra.v create mode 100644 mathcomp/field/fieldext.v create mode 100644 mathcomp/field/finfield.v create mode 100644 mathcomp/field/galois.v create mode 100644 mathcomp/field/separable.v create mode 100644 mathcomp/fingroup/action.v create mode 100644 mathcomp/fingroup/all.v create mode 100644 mathcomp/fingroup/automorphism.v create mode 100644 mathcomp/fingroup/cyclic.v create mode 100644 mathcomp/fingroup/fingroup.v create mode 100644 mathcomp/fingroup/gproduct.v create mode 100644 mathcomp/fingroup/morphism.v create mode 100644 mathcomp/fingroup/perm.v create mode 100644 mathcomp/fingroup/presentation.v create mode 100644 mathcomp/fingroup/quotient.v create mode 100644 mathcomp/fingroup/zmodp.v create mode 100644 mathcomp/odd_order/BGappendixAB.v create mode 100644 mathcomp/odd_order/BGappendixC.v create mode 100644 mathcomp/odd_order/BGsection1.v create mode 100644 mathcomp/odd_order/BGsection10.v create mode 100644 mathcomp/odd_order/BGsection11.v create mode 100644 mathcomp/odd_order/BGsection12.v create mode 100644 mathcomp/odd_order/BGsection13.v create mode 100644 mathcomp/odd_order/BGsection14.v create mode 100644 mathcomp/odd_order/BGsection15.v create mode 100644 mathcomp/odd_order/BGsection16.v create mode 100644 mathcomp/odd_order/BGsection2.v create mode 100644 mathcomp/odd_order/BGsection3.v create mode 100644 mathcomp/odd_order/BGsection4.v create mode 100644 mathcomp/odd_order/BGsection5.v create mode 100644 mathcomp/odd_order/BGsection6.v create mode 100644 mathcomp/odd_order/BGsection7.v create mode 100644 mathcomp/odd_order/BGsection8.v create mode 100644 mathcomp/odd_order/BGsection9.v create mode 100644 mathcomp/odd_order/PFsection1.v create mode 100644 mathcomp/odd_order/PFsection10.v create mode 100644 mathcomp/odd_order/PFsection11.v create mode 100644 mathcomp/odd_order/PFsection12.v create mode 100644 mathcomp/odd_order/PFsection13.v create mode 100644 mathcomp/odd_order/PFsection14.v create mode 100644 mathcomp/odd_order/PFsection2.v create mode 100644 mathcomp/odd_order/PFsection3.v create mode 100644 mathcomp/odd_order/PFsection4.v create mode 100644 mathcomp/odd_order/PFsection5.v create mode 100644 mathcomp/odd_order/PFsection6.v create mode 100644 mathcomp/odd_order/PFsection7.v create mode 100644 mathcomp/odd_order/PFsection8.v create mode 100644 mathcomp/odd_order/PFsection9.v create mode 100644 mathcomp/odd_order/all.v create mode 100644 mathcomp/odd_order/stripped_odd_order_theorem.v create mode 100644 mathcomp/real_closed/all.v create mode 100644 mathcomp/real_closed/bigenough.v create mode 100644 mathcomp/real_closed/cauchyreals.v create mode 100644 mathcomp/real_closed/complex.v create mode 100644 mathcomp/real_closed/ordered_qelim.v create mode 100644 mathcomp/real_closed/polyorder.v create mode 100644 mathcomp/real_closed/polyrcf.v create mode 100644 mathcomp/real_closed/qe_rcf.v create mode 100644 mathcomp/real_closed/qe_rcf_th.v create mode 100644 mathcomp/real_closed/realalg.v create mode 100644 mathcomp/solvable/abelian.v create mode 100644 mathcomp/solvable/all.v create mode 100644 mathcomp/solvable/alt.v create mode 100644 mathcomp/solvable/burnside_app.v create mode 100644 mathcomp/solvable/center.v create mode 100644 mathcomp/solvable/commutator.v create mode 100644 mathcomp/solvable/extraspecial.v create mode 100644 mathcomp/solvable/extremal.v create mode 100644 mathcomp/solvable/finmodule.v create mode 100644 mathcomp/solvable/frobenius.v create mode 100644 mathcomp/solvable/gfunctor.v create mode 100644 mathcomp/solvable/gseries.v create mode 100644 mathcomp/solvable/hall.v create mode 100644 mathcomp/solvable/jordanholder.v create mode 100644 mathcomp/solvable/maximal.v create mode 100644 mathcomp/solvable/nilpotent.v create mode 100644 mathcomp/solvable/pgroup.v create mode 100644 mathcomp/solvable/primitive_action.v create mode 100644 mathcomp/solvable/sylow.v create mode 100644 mathcomp/solvable/wielandt_fixpoint.v create mode 100644 mathcomp/ssreflect/Make create mode 100644 mathcomp/ssreflect/Makefile create mode 100644 mathcomp/ssreflect/all.v create mode 100644 mathcomp/ssreflect/eqtype.v create mode 100644 mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 create mode 100644 mathcomp/ssreflect/plugin/trunk/ssreflect.mllib create mode 100644 mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 create mode 100644 mathcomp/ssreflect/plugin/trunk/ssrmatching.mli create mode 100644 mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 create mode 100644 mathcomp/ssreflect/plugin/v8.4/ssreflect.mllib create mode 100644 mathcomp/ssreflect/plugin/v8.4/ssrmatching.ml4 create mode 100644 mathcomp/ssreflect/plugin/v8.4/ssrmatching.mli create mode 100644 mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 create mode 100644 mathcomp/ssreflect/plugin/v8.5/ssreflect.mllib create mode 100644 mathcomp/ssreflect/plugin/v8.5/ssrmatching.ml4 create mode 100644 mathcomp/ssreflect/plugin/v8.5/ssrmatching.mli create mode 100644 mathcomp/ssreflect/seq.v create mode 100644 mathcomp/ssreflect/ssrbool.v create mode 100644 mathcomp/ssreflect/ssreflect.v create mode 100644 mathcomp/ssreflect/ssrfun.v create mode 100644 mathcomp/ssreflect/ssrmatching.v create mode 100644 mathcomp/ssreflect/ssrnat.v create mode 100644 mathcomp/ssrtest/Make create mode 100644 mathcomp/ssrtest/Makefile create mode 100644 mathcomp/ssrtest/absevarprop.v create mode 100644 mathcomp/ssrtest/binders.v create mode 100644 mathcomp/ssrtest/binders_of.v create mode 100644 mathcomp/ssrtest/caseview.v create mode 100644 mathcomp/ssrtest/congr.v create mode 100644 mathcomp/ssrtest/deferclear.v create mode 100644 mathcomp/ssrtest/dependent_type_err.v create mode 100644 mathcomp/ssrtest/elim.v create mode 100644 mathcomp/ssrtest/elim2.v create mode 100644 mathcomp/ssrtest/elim_pattern.v create mode 100644 mathcomp/ssrtest/first_n.v create mode 100644 mathcomp/ssrtest/gen_have.v create mode 100644 mathcomp/ssrtest/gen_pattern.v create mode 100644 mathcomp/ssrtest/have_TC.v create mode 100644 mathcomp/ssrtest/have_transp.v create mode 100644 mathcomp/ssrtest/have_view_idiom.v create mode 100644 mathcomp/ssrtest/havesuff.v create mode 100644 mathcomp/ssrtest/if_isnt.v create mode 100644 mathcomp/ssrtest/indetLHS.v create mode 100644 mathcomp/ssrtest/intro_beta.v create mode 100644 mathcomp/ssrtest/intro_noop.v create mode 100644 mathcomp/ssrtest/ipatalternation.v create mode 100644 mathcomp/ssrtest/ltac_have.v create mode 100644 mathcomp/ssrtest/ltac_in.v create mode 100644 mathcomp/ssrtest/move_after.v create mode 100644 mathcomp/ssrtest/multiview.v create mode 100644 mathcomp/ssrtest/occarrow.v create mode 100644 mathcomp/ssrtest/patnoX.v create mode 100644 mathcomp/ssrtest/rewpatterns.v create mode 100644 mathcomp/ssrtest/set_lamda.v create mode 100644 mathcomp/ssrtest/set_pattern.v create mode 100644 mathcomp/ssrtest/ssrsyntax1.v create mode 100644 mathcomp/ssrtest/ssrsyntax2.v create mode 100644 mathcomp/ssrtest/tc.v create mode 100644 mathcomp/ssrtest/testmx.v create mode 100644 mathcomp/ssrtest/typeof.v create mode 100644 mathcomp/ssrtest/unkeyed.v create mode 100644 mathcomp/ssrtest/view_case.v create mode 100644 mathcomp/ssrtest/wlog_suff.v create mode 100644 mathcomp/ssrtest/wlogletin.v create mode 100644 mathcomp/ssrtest/wlong_intro.v diff --git a/mathcomp/.all.v.un~ b/mathcomp/.all.v.un~ new file mode 100644 index 0000000..7dc2b13 Binary files /dev/null and b/mathcomp/.all.v.un~ differ diff --git a/mathcomp/algebra/all.v b/mathcomp/algebra/all.v new file mode 100644 index 0000000..f4406a9 --- /dev/null +++ b/mathcomp/algebra/all.v @@ -0,0 +1,16 @@ +Require Export finalg. +Require Export fraction. +Require Export intdiv. +Require Export interval. +Require Export matrix. +Require Export mxalgebra. +Require Export mxpoly. +Require Export polydiv. +Require Export poly. +Require Export polyXY. +Require Export rat. +Require Export ring_quotient. +Require Export ssralg. +Require Export ssrint. +Require Export ssrnum. +Require Export vector. diff --git a/mathcomp/algebra/finalg.v b/mathcomp/algebra/finalg.v new file mode 100644 index 0000000..b903577 --- /dev/null +++ b/mathcomp/algebra/finalg.v @@ -0,0 +1,1297 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype. +Require Import ssralg finset fingroup morphism perm action. + +(*****************************************************************************) +(* This file clones the entire ssralg hierachy for finite types; this allows *) +(* type inference to function properly on expressions that mix combinatorial *) +(* and algebraic operators (e.g., [set x + y | x in A, y in A]). *) +(* finZmodType, finRingType, finComRingType, finUnitRingType, *) +(* finComUnitRingType, finIdomType, finFieldType finLmodType, *) +(* finLalgType finAlgType finUnitAlgType *) +(* == the finite counterparts of zmodType, etc. *) +(* Note that a finFieldType is canonically decidable. All these structures *) +(* can be derived using [xxxType of T] forms, e.g., if R has both canonical *) +(* finType and ringType structures, then *) +(* Canonical R_finRingType := Eval hnf in [finRingType of R]. *) +(* declares the derived finRingType structure for R. As the implementation *) +(* of the derivation is somewhat involved, the Eval hnf normalization is *) +(* strongly recommended. *) +(* This file also provides direct tie-ins with finite group theory: *) +(* [baseFinGroupType of R for +%R] == the (canonical) additive group *) +(* [finGroupType of R for +%R] structures for R *) +(* {unit R} == the type of units of R, which has a *) +(* canonical group structure. *) +(* FinRing.unit R Ux == the element of {unit R} corresponding *) +(* to x, where Ux : x \in GRing.unit. *) +(* 'U%act == the action by right multiplication of *) +(* {unit R} on R, via FinRing.unit_act. *) +(* (This is also a group action.) *) +(*****************************************************************************) + +Local Open Scope ring_scope. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Module FinRing. + +Local Notation mixin_of T b := (Finite.mixin_of (EqType T b)). + +Section Generic. + +(* Implicits *) +Variables (type base_type : Type) (class_of base_of : Type -> Type). +Variable to_choice : forall T, base_of T -> Choice.class_of T. +Variable base_sort : base_type -> Type. + +(* Explicits *) +Variable Pack : forall T, class_of T -> Type -> type. +Variable Class : forall T b, mixin_of T (to_choice b) -> class_of T. +Variable base_class : forall bT, base_of (base_sort bT). + +Definition gen_pack T := + fun bT b & phant_id (base_class bT) b => + fun fT m & phant_id (Finite.class fT) (Finite.Class m) => + Pack (@Class T b m) T. + +End Generic. + +Implicit Arguments + gen_pack [type base_type class_of base_of to_choice base_sort]. +Local Notation fin_ c := (@Finite.Class _ c c). +Local Notation do_pack pack T := (pack T _ _ id _ _ id). +Import GRing.Theory. + +Definition groupMixin V := FinGroup.Mixin (@addrA V) (@add0r V) (@addNr V). +Local Notation base_group T vT fT := + (@FinGroup.PackBase T (groupMixin vT) (Finite.class fT)). +Local Notation fin_group B V := (@FinGroup.Pack B (@addNr V)). + +Module Zmodule. + +Section ClassDef. + +Record class_of M := + Class { base : GRing.Zmodule.class_of M; mixin : mixin_of M base }. +Local Coercion base : class_of >-> GRing.Zmodule.class_of. +Local Coercion mixin : class_of >-> mixin_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Definition pack := gen_pack Pack Class GRing.Zmodule.class. +Variable 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 eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (fin_ xclass) xT. +Definition finType := @Finite.Pack cT (fin_ xclass) xT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass xT. + +Definition join_finType := @Finite.Pack zmodType (fin_ xclass) xT. + +Definition baseFinGroupType := base_group cT zmodType finType. +Definition finGroupType := fin_group baseFinGroupType zmodType. +Definition join_baseFinGroupType := base_group zmodType zmodType finType. +Definition join_finGroupType := fin_group join_baseFinGroupType zmodType. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> GRing.Zmodule.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 countType : type >-> Countable.type. +Canonical countType. +Coercion finType : type >-> Finite.type. +Canonical finType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Canonical join_finType. +Notation finZmodType := type. +Notation "[ 'finZmodType' 'of' T ]" := (do_pack pack T) + (at level 0, format "[ 'finZmodType' 'of' T ]") : form_scope. +Coercion baseFinGroupType : type >-> FinGroup.base_type. +Canonical baseFinGroupType. +Coercion finGroupType : type >-> FinGroup.type. +Canonical finGroupType. +Canonical join_baseFinGroupType. +Canonical join_finGroupType. +Notation "[ 'baseFinGroupType' 'of' R 'for' +%R ]" := + (BaseFinGroupType R (groupMixin _)) + (at level 0, format "[ 'baseFinGroupType' 'of' R 'for' +%R ]") + : form_scope. +Notation "[ 'finGroupType' 'of' R 'for' +%R ]" := + (@FinGroup.clone R _ (finGroupType _) id _ id) + (at level 0, format "[ 'finGroupType' 'of' R 'for' +%R ]") : form_scope. +End Exports. + +End Zmodule. +Import Zmodule.Exports. + +Section AdditiveGroup. + +Variable U : finZmodType. +Implicit Types x y : U. + +Lemma zmod1gE : 1%g = 0 :> U. Proof. by []. Qed. +Lemma zmodVgE x : x^-1%g = - x. Proof. by []. Qed. +Lemma zmodMgE x y : (x * y)%g = x + y. Proof. by []. Qed. +Lemma zmodXgE n x : (x ^+ n)%g = x *+ n. Proof. by []. Qed. +Lemma zmod_mulgC x y : commute x y. Proof. exact: GRing.addrC. Qed. +Lemma zmod_abelian (A : {set U}) : abelian A. +Proof. by apply/centsP=> x _ y _; exact: zmod_mulgC. Qed. + +End AdditiveGroup. + +Module Ring. + +Section ClassDef. + +Record class_of R := + Class { base : GRing.Ring.class_of R; mixin : mixin_of R base }. +Definition base2 R (c : class_of R) := Zmodule.Class (mixin c). +Local Coercion base : class_of >-> GRing.Ring.class_of. +Local Coercion base2 : class_of >-> Zmodule.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Definition pack := gen_pack Pack Class GRing.Ring.class. +Variable 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 eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (fin_ xclass) xT. +Definition finType := @Finite.Pack cT (fin_ xclass) cT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass cT. +Definition finZmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @GRing.Ring.Pack cT xclass xT. +Definition join_finType := @Finite.Pack ringType (fin_ xclass) xT. +Definition join_finZmodType := @Zmodule.Pack ringType xclass xT. + +Definition baseFinGroupType := base_group cT zmodType finType. +Definition finGroupType := fin_group baseFinGroupType zmodType. +Definition join_baseFinGroupType := base_group zmodType zmodType finType. +Definition join_finGroupType := fin_group join_baseFinGroupType zmodType. + +End ClassDef. + +Module Import Exports. +Coercion base : class_of >-> GRing.Ring.class_of. +Coercion base2 : class_of >-> Zmodule.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 countType : type >-> Countable.type. +Canonical countType. +Coercion finType : type >-> Finite.type. +Canonical finType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Coercion finZmodType : type >-> Zmodule.type. +Canonical finZmodType. +Coercion ringType : type >-> GRing.Ring.type. +Canonical ringType. +Canonical join_finType. +Canonical join_finZmodType. +Notation finRingType := type. +Notation "[ 'finRingType' 'of' T ]" := (do_pack pack T) + (at level 0, format "[ 'finRingType' 'of' T ]") : form_scope. +Canonical baseFinGroupType. +Canonical finGroupType. +Canonical join_baseFinGroupType. +Canonical join_finGroupType. +End Exports. + +Section Unit. + +Variable R : finRingType. + +Definition is_inv (x y : R) := (x * y == 1) && (y * x == 1). +Definition unit := [qualify a x : R | [exists y, is_inv x y]]. +Definition inv x := odflt x (pick (is_inv x)). + +Lemma mulVr : {in unit, left_inverse 1 inv *%R}. +Proof. +rewrite /inv => x Ux; case: pickP => [y | no_y]; last by case/pred0P: Ux. +by case/andP=> _; move/eqP. +Qed. + +Lemma mulrV : {in unit, right_inverse 1 inv *%R}. +Proof. +rewrite /inv => x Ux; case: pickP => [y | no_y]; last by case/pred0P: Ux. +by case/andP; move/eqP. +Qed. + +Lemma intro_unit x y : y * x = 1 /\ x * y = 1 -> x \is a unit. +Proof. +by case=> yx1 xy1; apply/existsP; exists y; rewrite /is_inv xy1 yx1 !eqxx. +Qed. + +Lemma invr_out : {in [predC unit], inv =1 id}. +Proof. +rewrite /inv => x nUx; case: pickP => // y invxy. +by case/existsP: nUx; exists y. +Qed. + +Definition UnitMixin := GRing.UnitRing.Mixin mulVr mulrV intro_unit invr_out. + +End Unit. + +End Ring. +Import Ring.Exports. + +Module ComRing. + +Section ClassDef. + +Record class_of R := + Class { base : GRing.ComRing.class_of R; mixin : mixin_of R base }. +Definition base2 R (c : class_of R) := Ring.Class (mixin c). +Local Coercion base : class_of >-> GRing.ComRing.class_of. +Local Coercion base2 : class_of >-> Ring.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Definition pack := gen_pack Pack Class GRing.ComRing.class. +Variable 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 eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (fin_ xclass) xT. +Definition finType := @Finite.Pack cT (fin_ xclass) xT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass xT. +Definition finZmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @GRing.Ring.Pack cT xclass xT. +Definition finRingType := @Ring.Pack cT xclass xT. +Definition comRingType := @GRing.ComRing.Pack cT xclass xT. +Definition join_finType := @Finite.Pack comRingType (fin_ xclass) xT. +Definition join_finZmodType := @Zmodule.Pack comRingType xclass xT. +Definition join_finRingType := @Ring.Pack comRingType xclass xT. + +Definition baseFinGroupType := base_group cT zmodType finType. +Definition finGroupType := fin_group baseFinGroupType zmodType. +Definition join_baseFinGroupType := base_group zmodType zmodType finType. +Definition join_finGroupType := fin_group join_baseFinGroupType zmodType. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> GRing.ComRing.class_of. +Coercion base2 : class_of >-> Ring.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 countType : type >-> Countable.type. +Canonical countType. +Coercion finType : type >-> Finite.type. +Canonical finType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Coercion finZmodType : type >-> Zmodule.type. +Canonical finZmodType. +Coercion ringType : type >-> GRing.Ring.type. +Canonical ringType. +Coercion finRingType : type >-> Ring.type. +Canonical finRingType. +Coercion comRingType : type >-> GRing.ComRing.type. +Canonical comRingType. +Canonical join_finType. +Canonical join_finZmodType. +Canonical join_finRingType. +Notation finComRingType := FinRing.ComRing.type. +Notation "[ 'finComRingType' 'of' T ]" := (do_pack pack T) + (at level 0, format "[ 'finComRingType' 'of' T ]") : form_scope. +Canonical baseFinGroupType. +Canonical finGroupType. +Canonical join_baseFinGroupType. +Canonical join_finGroupType. +End Exports. + +End ComRing. +Import ComRing.Exports. + +Module UnitRing. + +Section ClassDef. + +Record class_of R := + Class { base : GRing.UnitRing.class_of R; mixin : mixin_of R base }. +Definition base2 R (c : class_of R) := Ring.Class (mixin c). +Local Coercion base : class_of >-> GRing.UnitRing.class_of. +Local Coercion base2 : class_of >-> Ring.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Definition pack := gen_pack Pack Class GRing.UnitRing.class. +Variable 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 eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (fin_ xclass) xT. +Definition finType := @Finite.Pack cT (fin_ xclass) xT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass xT. +Definition finZmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @GRing.Ring.Pack cT xclass xT. +Definition finRingType := @Ring.Pack cT xclass xT. +Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT. + +Definition join_finType := @Finite.Pack unitRingType (fin_ xclass) xT. +Definition join_finZmodType := @Zmodule.Pack unitRingType xclass xT. +Definition join_finRingType := @Ring.Pack unitRingType xclass xT. + +Definition baseFinGroupType := base_group cT zmodType finType. +Definition finGroupType := fin_group baseFinGroupType zmodType. +Definition join_baseFinGroupType := base_group zmodType zmodType finType. +Definition join_finGroupType := fin_group join_baseFinGroupType zmodType. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> GRing.UnitRing.class_of. +Coercion base2 : class_of >-> Ring.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 countType : type >-> Countable.type. +Canonical countType. +Coercion finType : type >-> Finite.type. +Canonical finType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Coercion finZmodType : type >-> Zmodule.type. +Canonical finZmodType. +Coercion ringType : type >-> GRing.Ring.type. +Canonical ringType. +Coercion finRingType : type >-> Ring.type. +Canonical finRingType. +Coercion unitRingType : type >-> GRing.UnitRing.type. +Canonical unitRingType. +Canonical join_finType. +Canonical join_finZmodType. +Canonical join_finRingType. +Notation finUnitRingType := FinRing.UnitRing.type. +Notation "[ 'finUnitRingType' 'of' T ]" := (do_pack pack T) + (at level 0, format "[ 'finUnitRingType' 'of' T ]") : form_scope. +Canonical baseFinGroupType. +Canonical finGroupType. +Canonical join_baseFinGroupType. +Canonical join_finGroupType. +End Exports. + +End UnitRing. +Import UnitRing.Exports. + +Section UnitsGroup. + +Variable R : finUnitRingType. + +Inductive unit_of (phR : phant R) := Unit (x : R) of x \is a GRing.unit. +Bind Scope group_scope with unit_of. + +Let phR := Phant R. +Local Notation uT := (unit_of phR). +Implicit Types u v : uT. +Definition uval u := let: Unit x _ := u in x. + +Canonical unit_subType := [subType for uval]. +Definition unit_eqMixin := Eval hnf in [eqMixin of uT by <:]. +Canonical unit_eqType := Eval hnf in EqType uT unit_eqMixin. +Definition unit_choiceMixin := [choiceMixin of uT by <:]. +Canonical unit_choiceType := Eval hnf in ChoiceType uT unit_choiceMixin. +Definition unit_countMixin := [countMixin of uT by <:]. +Canonical unit_countType := Eval hnf in CountType uT unit_countMixin. +Canonical unit_subCountType := Eval hnf in [subCountType of uT]. +Definition unit_finMixin := [finMixin of uT by <:]. +Canonical unit_finType := Eval hnf in FinType uT unit_finMixin. +Canonical unit_subFinType := Eval hnf in [subFinType of uT]. + +Definition unit1 := Unit phR (@GRing.unitr1 _). +Lemma unit_inv_proof u : (val u)^-1 \is a GRing.unit. +Proof. by rewrite GRing.unitrV ?(valP u). Qed. +Definition unit_inv u := Unit phR (unit_inv_proof u). +Lemma unit_mul_proof u v : val u * val v \is a GRing.unit. +Proof. by rewrite (GRing.unitrMr _ (valP u)) ?(valP v). Qed. +Definition unit_mul u v := Unit phR (unit_mul_proof u v). +Lemma unit_muluA : associative unit_mul. +Proof. move=> u v w; apply: val_inj; exact: GRing.mulrA. Qed. +Lemma unit_mul1u : left_id unit1 unit_mul. +Proof. move=> u; apply: val_inj; exact: GRing.mul1r. Qed. +Lemma unit_mulVu : left_inverse unit1 unit_inv unit_mul. +Proof. move=> u; apply: val_inj; exact: GRing.mulVr (valP u). Qed. + +Definition unit_GroupMixin := FinGroup.Mixin unit_muluA unit_mul1u unit_mulVu. +Canonical unit_baseFinGroupType := + Eval hnf in BaseFinGroupType uT unit_GroupMixin. +Canonical unit_finGroupType := Eval hnf in FinGroupType unit_mulVu. + +Lemma val_unit1 : val (1%g : uT) = 1. Proof. by []. Qed. +Lemma val_unitM x y : val (x * y : uT)%g = val x * val y. Proof. by []. Qed. +Lemma val_unitV x : val (x^-1 : uT)%g = (val x)^-1. Proof. by []. Qed. +Lemma val_unitX n x : val (x ^+ n : uT)%g = val x ^+ n. +Proof. by case: n; last by elim=> //= n ->. Qed. + +Definition unit_act x u := x * val u. +Lemma unit_actE x u : unit_act x u = x * val u. Proof. by []. Qed. + +Canonical unit_action := + @TotalAction _ _ unit_act (@GRing.mulr1 _) (fun _ _ _ => GRing.mulrA _ _ _). +Lemma unit_is_groupAction : @is_groupAction _ R setT setT unit_action. +Proof. +move=> u _ /=; rewrite inE; apply/andP; split. + by apply/subsetP=> x _; rewrite inE. +by apply/morphicP=> x y _ _; rewrite !actpermE /= [_ u]GRing.mulrDl. +Qed. +Canonical unit_groupAction := GroupAction unit_is_groupAction. + +End UnitsGroup. + +Module Import UnitsGroupExports. +Bind Scope group_scope with unit_of. +Canonical unit_subType. +Canonical unit_eqType. +Canonical unit_choiceType. +Canonical unit_countType. +Canonical unit_subCountType. +Canonical unit_finType. +Canonical unit_subFinType. +Canonical unit_baseFinGroupType. +Canonical unit_finGroupType. +Canonical unit_action. +Canonical unit_groupAction. +End UnitsGroupExports. + +Notation unit R Ux := (Unit (Phant R) Ux). + +Module ComUnitRing. + +Section ClassDef. + +Record class_of R := + Class { base : GRing.ComUnitRing.class_of R; mixin : mixin_of R base }. +Definition base2 R (c : class_of R) := ComRing.Class (mixin c). +Definition base3 R (c : class_of R) := @UnitRing.Class R (base c) (mixin c). +Local Coercion base : class_of >-> GRing.ComUnitRing.class_of. +Local Coercion base2 : class_of >-> ComRing.class_of. +Local Coercion base3 : class_of >-> UnitRing.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Definition pack := gen_pack Pack Class GRing.ComUnitRing.class. +Variable 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 eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (fin_ xclass) xT. +Definition finType := @Finite.Pack cT (fin_ xclass) xT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass xT. +Definition finZmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @GRing.Ring.Pack cT xclass xT. +Definition finRingType := @Ring.Pack cT xclass xT. +Definition comRingType := @GRing.ComRing.Pack cT xclass xT. +Definition finComRingType := @ComRing.Pack cT xclass xT. +Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT. +Definition finUnitRingType := @UnitRing.Pack cT xclass xT. +Definition comUnitRingType := @GRing.ComUnitRing.Pack cT xclass xT. + +Definition join_finType := @Finite.Pack comUnitRingType (fin_ xclass) xT. +Definition join_finZmodType := @Zmodule.Pack comUnitRingType xclass xT. +Definition join_finRingType := @Ring.Pack comUnitRingType xclass xT. +Definition join_finComRingType := @ComRing.Pack comUnitRingType xclass xT. +Definition join_finUnitRingType := @UnitRing.Pack comUnitRingType xclass xT. +Definition ujoin_finComRingType := @ComRing.Pack unitRingType xclass xT. +Definition cjoin_finUnitRingType := @UnitRing.Pack comRingType xclass xT. +Definition fcjoin_finUnitRingType := @UnitRing.Pack finComRingType xclass xT. + +Definition baseFinGroupType := base_group cT zmodType finType. +Definition finGroupType := fin_group baseFinGroupType zmodType. +Definition join_baseFinGroupType := base_group zmodType zmodType finType. +Definition join_finGroupType := fin_group join_baseFinGroupType zmodType. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> GRing.ComUnitRing.class_of. +Coercion base2 : class_of >-> ComRing.class_of. +Coercion base3 : class_of >-> UnitRing.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 countType : type >-> Countable.type. +Canonical countType. +Coercion finType : type >-> Finite.type. +Canonical finType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Coercion finZmodType : type >-> Zmodule.type. +Canonical finZmodType. +Coercion ringType : type >-> GRing.Ring.type. +Canonical ringType. +Coercion finRingType : type >-> Ring.type. +Canonical finRingType. +Coercion comRingType : type >-> GRing.ComRing.type. +Canonical comRingType. +Coercion finComRingType : type >-> ComRing.type. +Canonical finComRingType. +Coercion unitRingType : type >-> GRing.UnitRing.type. +Canonical unitRingType. +Coercion finUnitRingType : type >-> UnitRing.type. +Canonical finUnitRingType. +Coercion comUnitRingType : type >-> GRing.ComUnitRing.type. +Canonical comUnitRingType. +Canonical join_finType. +Canonical join_finZmodType. +Canonical join_finRingType. +Canonical join_finComRingType. +Canonical join_finUnitRingType. +Canonical ujoin_finComRingType. +Canonical cjoin_finUnitRingType. +Canonical fcjoin_finUnitRingType. +Notation finComUnitRingType := FinRing.ComUnitRing.type. +Notation "[ 'finComUnitRingType' 'of' T ]" := (do_pack pack T) + (at level 0, format "[ 'finComUnitRingType' 'of' T ]") : form_scope. +Canonical baseFinGroupType. +Canonical finGroupType. +Canonical join_baseFinGroupType. +Canonical join_finGroupType. +End Exports. + +End ComUnitRing. +Import ComUnitRing.Exports. + +Module IntegralDomain. + +Section ClassDef. + +Record class_of R := + Class { base : GRing.IntegralDomain.class_of R; mixin : mixin_of R base }. +Definition base2 R (c : class_of R) := ComUnitRing.Class (mixin c). +Local Coercion base : class_of >-> GRing.IntegralDomain.class_of. +Local Coercion base2 : class_of >-> ComUnitRing.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Definition pack := gen_pack Pack Class GRing.IntegralDomain.class. +Variable 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 eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (fin_ xclass) xT. +Definition finType := @Finite.Pack cT (fin_ xclass) xT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass xT. +Definition finZmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @GRing.Ring.Pack cT xclass xT. +Definition finRingType := @Ring.Pack cT xclass xT. +Definition comRingType := @GRing.ComRing.Pack cT xclass xT. +Definition finComRingType := @ComRing.Pack cT xclass xT. +Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT. +Definition finUnitRingType := @UnitRing.Pack cT xclass xT. +Definition comUnitRingType := @GRing.ComUnitRing.Pack cT xclass xT. +Definition finComUnitRingType := @ComUnitRing.Pack cT xclass xT. +Definition idomainType := @GRing.IntegralDomain.Pack cT xclass xT. + +Definition join_finType := @Finite.Pack idomainType (fin_ xclass) xT. +Definition join_finZmodType := @Zmodule.Pack idomainType xclass xT. +Definition join_finRingType := @Ring.Pack idomainType xclass xT. +Definition join_finUnitRingType := @UnitRing.Pack idomainType xclass xT. +Definition join_finComRingType := @ComRing.Pack idomainType xclass xT. +Definition join_finComUnitRingType := @ComUnitRing.Pack idomainType xclass xT. + +Definition baseFinGroupType := base_group cT zmodType finType. +Definition finGroupType := fin_group baseFinGroupType zmodType. +Definition join_baseFinGroupType := base_group zmodType zmodType finType. +Definition join_finGroupType := fin_group join_baseFinGroupType zmodType. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> GRing.IntegralDomain.class_of. +Coercion base2 : class_of >-> ComUnitRing.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 countType : type >-> Countable.type. +Canonical countType. +Coercion finType : type >-> Finite.type. +Canonical finType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Coercion finZmodType : type >-> Zmodule.type. +Canonical finZmodType. +Coercion ringType : type >-> GRing.Ring.type. +Canonical ringType. +Coercion finRingType : type >-> Ring.type. +Canonical finRingType. +Coercion comRingType : type >-> GRing.ComRing.type. +Canonical comRingType. +Coercion finComRingType : type >-> ComRing.type. +Canonical finComRingType. +Coercion unitRingType : type >-> GRing.UnitRing.type. +Canonical unitRingType. +Coercion finUnitRingType : type >-> UnitRing.type. +Canonical finUnitRingType. +Coercion comUnitRingType : type >-> GRing.ComUnitRing.type. +Canonical comUnitRingType. +Coercion finComUnitRingType : type >-> ComUnitRing.type. +Canonical finComUnitRingType. +Coercion idomainType : type >-> GRing.IntegralDomain.type. +Canonical idomainType. +Canonical join_finType. +Canonical join_finZmodType. +Canonical join_finRingType. +Canonical join_finComRingType. +Canonical join_finUnitRingType. +Canonical join_finComUnitRingType. +Notation finIdomainType := FinRing.IntegralDomain.type. +Notation "[ 'finIdomainType' 'of' T ]" := (do_pack pack T) + (at level 0, format "[ 'finIdomainType' 'of' T ]") : form_scope. +Canonical baseFinGroupType. +Canonical finGroupType. +Canonical join_baseFinGroupType. +Canonical join_finGroupType. +End Exports. + +End IntegralDomain. +Import IntegralDomain.Exports. + +Module Field. + +Section ClassDef. + +Record class_of R := + Class { base : GRing.Field.class_of R; mixin : mixin_of R base }. +Definition base2 R (c : class_of R) := IntegralDomain.Class (mixin c). +Local Coercion base : class_of >-> GRing.Field.class_of. +Local Coercion base2 : class_of >-> IntegralDomain.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Definition pack := gen_pack Pack Class GRing.Field.class. +Variable 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 eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (fin_ xclass) xT. +Definition finType := @Finite.Pack cT (fin_ xclass) xT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass xT. +Definition finZmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @GRing.Ring.Pack cT xclass xT. +Definition finRingType := @Ring.Pack cT xclass xT. +Definition comRingType := @GRing.ComRing.Pack cT xclass xT. +Definition finComRingType := @ComRing.Pack cT xclass xT. +Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT. +Definition finUnitRingType := @UnitRing.Pack cT xclass xT. +Definition comUnitRingType := @GRing.ComUnitRing.Pack cT xclass xT. +Definition finComUnitRingType := @ComUnitRing.Pack cT xclass xT. +Definition idomainType := @GRing.IntegralDomain.Pack cT xclass xT. +Definition finIdomainType := @IntegralDomain.Pack cT xclass xT. +Definition fieldType := @GRing.Field.Pack cT xclass xT. + +Definition join_finType := @Finite.Pack fieldType (fin_ xclass) xT. +Definition join_finZmodType := @Zmodule.Pack fieldType xclass xT. +Definition join_finRingType := @Ring.Pack fieldType xclass xT. +Definition join_finUnitRingType := @UnitRing.Pack fieldType xclass xT. +Definition join_finComRingType := @ComRing.Pack fieldType xclass xT. +Definition join_finComUnitRingType := @ComUnitRing.Pack fieldType xclass xT. +Definition join_finIdomainType := @IntegralDomain.Pack fieldType xclass xT. + +Definition baseFinGroupType := base_group cT zmodType finType. +Definition finGroupType := fin_group baseFinGroupType zmodType. +Definition join_baseFinGroupType := base_group zmodType zmodType finType. +Definition join_finGroupType := fin_group join_baseFinGroupType zmodType. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> GRing.Field.class_of. +Coercion base2 : class_of >-> IntegralDomain.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 countType : type >-> Countable.type. +Canonical countType. +Coercion finType : type >-> Finite.type. +Canonical finType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Coercion finZmodType : type >-> Zmodule.type. +Canonical finZmodType. +Coercion ringType : type >-> GRing.Ring.type. +Canonical ringType. +Coercion finRingType : type >-> Ring.type. +Canonical finRingType. +Coercion comRingType : type >-> GRing.ComRing.type. +Canonical comRingType. +Coercion finComRingType : type >-> ComRing.type. +Canonical finComRingType. +Coercion unitRingType : type >-> GRing.UnitRing.type. +Canonical unitRingType. +Coercion finUnitRingType : type >-> UnitRing.type. +Canonical finUnitRingType. +Coercion comUnitRingType : type >-> GRing.ComUnitRing.type. +Canonical comUnitRingType. +Coercion finComUnitRingType : type >-> ComUnitRing.type. +Canonical finComUnitRingType. +Coercion idomainType : type >-> GRing.IntegralDomain.type. +Canonical idomainType. +Coercion finIdomainType : type >-> IntegralDomain.type. +Canonical finIdomainType. +Coercion fieldType : type >-> GRing.Field.type. +Canonical fieldType. +Canonical join_finType. +Canonical join_finZmodType. +Canonical join_finRingType. +Canonical join_finComRingType. +Canonical join_finUnitRingType. +Canonical join_finComUnitRingType. +Canonical join_finIdomainType. +Notation finFieldType := FinRing.Field.type. +Notation "[ 'finFieldType' 'of' T ]" := (do_pack pack T) + (at level 0, format "[ 'finFieldType' 'of' T ]") : form_scope. +Canonical baseFinGroupType. +Canonical finGroupType. +Canonical join_baseFinGroupType. +Canonical join_finGroupType. +End Exports. + +End Field. +Import Field.Exports. + +Section DecideField. + +Variable F : Field.type. + +Fixpoint sat e f := + match f with + | GRing.Bool b => b + | t1 == t2 => (GRing.eval e t1 == GRing.eval e t2)%bool + | GRing.Unit t => GRing.eval e t \is a GRing.unit + | f1 /\ f2 => sat e f1 && sat e f2 + | f1 \/ f2 => sat e f1 || sat e f2 + | f1 ==> f2 => (sat e f1 ==> sat e f2)%bool + | ~ f1 => ~~ sat e f1 + | ('exists 'X_k, f1) => [exists x : F, sat (set_nth 0%R e k x) f1] + | ('forall 'X_k, f1) => [forall x : F, sat (set_nth 0%R e k x) f1] + end%T. + +Lemma decidable : GRing.DecidableField.axiom sat. +Proof. +move=> e f; elim: f e; + try by move=> f1 IH1 f2 IH2 e /=; case IH1; case IH2; constructor; tauto. +- by move=> b e; exact: idP. +- by move=> t1 t2 e; exact: eqP. +- by move=> t e; exact: idP. +- by move=> f IH e /=; case: IH; constructor. +- by move=> i f IH e; apply: (iffP existsP) => [] [x fx]; exists x; exact/IH. +by move=> i f IH e; apply: (iffP forallP) => f_ x; exact/IH. +Qed. + +Definition DecidableFieldMixin := DecFieldMixin decidable. + +End DecideField. + +Module DecField. + +Section Joins. + +Variable cT : Field.type. +Let xT := let: Field.Pack T _ _ := cT in T. +Let xclass : Field.class_of xT := Field.class cT. + +Definition type := Eval hnf in DecFieldType cT (DecidableFieldMixin cT). +Definition finType := @Finite.Pack type (fin_ xclass) xT. +Definition finZmodType := @Zmodule.Pack type xclass xT. +Definition finRingType := @Ring.Pack type xclass xT. +Definition finUnitRingType := @UnitRing.Pack type xclass xT. +Definition finComRingType := @ComRing.Pack type xclass xT. +Definition finComUnitRingType := @ComUnitRing.Pack type xclass xT. +Definition finIdomainType := @IntegralDomain.Pack type xclass xT. +Definition baseFinGroupType := base_group type finZmodType finZmodType. +Definition finGroupType := fin_group baseFinGroupType cT. + +End Joins. + +Module Exports. +Coercion type : Field.type >-> GRing.DecidableField.type. +Canonical type. +Canonical finType. +Canonical finZmodType. +Canonical finRingType. +Canonical finUnitRingType. +Canonical finComRingType. +Canonical finComUnitRingType. +Canonical finIdomainType. +Canonical baseFinGroupType. +Canonical finGroupType. +End Exports. + +End DecField. + +Module Lmodule. + +Section ClassDef. + +Variable R : ringType. + +Record class_of M := + Class { base : GRing.Lmodule.class_of R M ; mixin : mixin_of M base }. +Definition base2 R (c : class_of R) := Zmodule.Class (mixin c). +Local Coercion base : class_of >-> GRing.Lmodule.class_of. +Local Coercion base2 : class_of >-> Zmodule.class_of. + +Structure type (phR : phant R) := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variables (phR : phant R) (cT : type phR). +Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c. +Definition pack := gen_pack (Pack phR) Class (@GRing.Lmodule.class R phR). +Let xT := let: Pack T _ _ := cT in T. +Notation xclass := (class : class_of xT). + +Definition eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (fin_ xclass) xT. +Definition finType := @Finite.Pack cT (fin_ xclass) xT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass xT. +Definition finZmodType := @Zmodule.Pack cT xclass xT. +Definition lmodType := @GRing.Lmodule.Pack R phR cT xclass xT. +Definition join_finType := @Finite.Pack lmodType (fin_ xclass) xT. +Definition join_finZmodType := @Zmodule.Pack lmodType xclass xT. + +Definition baseFinGroupType := base_group cT zmodType finType. +Definition finGroupType := fin_group baseFinGroupType zmodType. +Definition join_baseFinGroupType := base_group zmodType zmodType finType. +Definition join_finGroupType := fin_group join_baseFinGroupType zmodType. + +End ClassDef. + +Module Import Exports. +Coercion base : class_of >-> GRing.Lmodule.class_of. +Coercion base2 : class_of >-> Zmodule.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 countType : type >-> Countable.type. +Canonical countType. +Coercion finType : type >-> Finite.type. +Canonical finType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Coercion finZmodType : type >-> Zmodule.type. +Canonical finZmodType. +Coercion lmodType : type >-> GRing.Lmodule.type. +Canonical lmodType. +Canonical join_finType. +Canonical join_finZmodType. +Notation finLmodType R := (FinRing.Lmodule.type (Phant R)). +Notation "[ 'finLmodType' R 'of' T ]" := (do_pack (@pack _ (Phant R)) T) + (at level 0, format "[ 'finLmodType' R 'of' T ]") : form_scope. +Canonical baseFinGroupType. +Canonical finGroupType. +Canonical join_baseFinGroupType. +Canonical join_finGroupType. +End Exports. + +End Lmodule. +Import Lmodule.Exports. + +Module Lalgebra. + +Section ClassDef. + +Variable R : ringType. + +Record class_of M := + Class { base : GRing.Lalgebra.class_of R M; mixin : mixin_of M base }. +Definition base2 M (c : class_of M) := Ring.Class (mixin c). +Definition base3 M (c : class_of M) := @Lmodule.Class _ _ (base c) (mixin c). +Local Coercion base : class_of >-> GRing.Lalgebra.class_of. +Local Coercion base2 : class_of >-> Ring.class_of. +Local Coercion base3 : class_of >-> Lmodule.class_of. + +Structure type (phR : phant R) := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variables (phR : phant R) (cT : type phR). +Definition pack := gen_pack (Pack phR) Class (@GRing.Lalgebra.class R phR). +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 eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (fin_ xclass) xT. +Definition finType := @Finite.Pack cT (fin_ xclass) xT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass xT. +Definition finZmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @GRing.Ring.Pack cT xclass xT. +Definition finRingType := @Ring.Pack cT xclass xT. +Definition lmodType := @GRing.Lmodule.Pack R phR cT xclass xT. +Definition finLmodType := @Lmodule.Pack R phR cT xclass xT. +Definition lalgType := @GRing.Lalgebra.Pack R phR cT xclass xT. + +Definition join_finType := @Finite.Pack lalgType (fin_ xclass) xT. +Definition join_finZmodType := @Zmodule.Pack lalgType xclass xT. +Definition join_finLmodType := @Lmodule.Pack R phR lalgType xclass xT. +Definition join_finRingType := @Ring.Pack lalgType xclass xT. +Definition rjoin_finLmodType := @Lmodule.Pack R phR ringType xclass xT. +Definition ljoin_finRingType := @Ring.Pack lmodType xclass xT. +Definition fljoin_finRingType := @Ring.Pack finLmodType xclass xT. + +Definition baseFinGroupType := base_group cT zmodType finType. +Definition finGroupType := fin_group baseFinGroupType zmodType. +Definition join_baseFinGroupType := base_group zmodType zmodType finType. +Definition join_finGroupType := fin_group join_baseFinGroupType zmodType. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> GRing.Lalgebra.class_of. +Coercion base2 : class_of >-> Ring.class_of. +Coercion base3 : class_of >-> Lmodule.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 countType : type >-> Countable.type. +Canonical countType. +Coercion finType : type >-> Finite.type. +Canonical finType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Coercion finZmodType : type >-> Zmodule.type. +Canonical finZmodType. +Coercion ringType : type >-> GRing.Ring.type. +Canonical ringType. +Coercion finRingType : type >-> Ring.type. +Canonical finRingType. +Coercion lmodType : type >-> GRing.Lmodule.type. +Canonical lmodType. +Coercion finLmodType : type >-> Lmodule.type. +Canonical finLmodType. +Coercion lalgType : type >-> GRing.Lalgebra.type. +Canonical lalgType. +Canonical join_finType. +Canonical join_finZmodType. +Canonical join_finLmodType. +Canonical join_finRingType. +Canonical rjoin_finLmodType. +Canonical ljoin_finRingType. +Canonical fljoin_finRingType. +Notation finLalgType R := (FinRing.Lalgebra.type (Phant R)). +Notation "[ 'finLalgType' R 'of' T ]" := (do_pack (@pack _ (Phant R)) T) + (at level 0, format "[ 'finLalgType' R 'of' T ]") : form_scope. +Canonical baseFinGroupType. +Canonical finGroupType. +Canonical join_baseFinGroupType. +Canonical join_finGroupType. +End Exports. + +End Lalgebra. +Import Lalgebra.Exports. + +Module Algebra. + +Section ClassDef. + +Variable R : ringType. + +Record class_of M := + Class { base : GRing.Algebra.class_of R M; mixin : mixin_of M base }. +Definition base2 M (c : class_of M) := Lalgebra.Class (mixin c). +Local Coercion base : class_of >-> GRing.Algebra.class_of. +Local Coercion base2 : class_of >->Lalgebra.class_of. + +Structure type (phR : phant R) := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variables (phR : phant R) (cT : type phR). +Definition pack := gen_pack (Pack phR) Class (@GRing.Algebra.class R phR). +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 eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (fin_ xclass) xT. +Definition finType := @Finite.Pack cT (fin_ xclass) xT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass xT. +Definition finZmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @GRing.Ring.Pack cT xclass xT. +Definition finRingType := @Ring.Pack cT xclass xT. +Definition lmodType := @GRing.Lmodule.Pack R phR cT xclass xT. +Definition finLmodType := @Lmodule.Pack R phR cT xclass xT. +Definition lalgType := @GRing.Lalgebra.Pack R phR cT xclass xT. +Definition finLalgType := @Lalgebra.Pack R phR cT xclass xT. +Definition algType := @GRing.Algebra.Pack R phR cT xclass xT. + +Definition join_finType := @Finite.Pack algType (fin_ xclass) xT. +Definition join_finZmodType := @Zmodule.Pack algType xclass xT. +Definition join_finRingType := @Ring.Pack algType xclass xT. +Definition join_finLmodType := @Lmodule.Pack R phR algType xclass xT. +Definition join_finLalgType := @Lalgebra.Pack R phR algType xclass xT. + +Definition baseFinGroupType := base_group cT zmodType finType. +Definition finGroupType := fin_group baseFinGroupType zmodType. +Definition join_baseFinGroupType := base_group zmodType zmodType finType. +Definition join_finGroupType := fin_group join_baseFinGroupType zmodType. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> GRing.Algebra.class_of. +Coercion base2 : class_of >-> Lalgebra.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 countType : type >-> Countable.type. +Canonical countType. +Coercion finType : type >-> Finite.type. +Canonical finType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Coercion finZmodType : type >-> Zmodule.type. +Canonical finZmodType. +Coercion ringType : type >-> GRing.Ring.type. +Canonical ringType. +Coercion finRingType : type >-> Ring.type. +Canonical finRingType. +Coercion lmodType : type >-> GRing.Lmodule.type. +Canonical lmodType. +Coercion finLmodType : type >-> Lmodule.type. +Canonical finLmodType. +Coercion lalgType : type >-> GRing.Lalgebra.type. +Canonical lalgType. +Coercion finLalgType : type >-> Lalgebra.type. +Canonical finLalgType. +Coercion algType : type >-> GRing.Algebra.type. +Canonical algType. +Canonical join_finType. +Canonical join_finZmodType. +Canonical join_finLmodType. +Canonical join_finRingType. +Canonical join_finLalgType. +Notation finAlgType R := (type (Phant R)). +Notation "[ 'finAlgType' R 'of' T ]" := (do_pack (@pack _ (Phant R)) T) + (at level 0, format "[ 'finAlgType' R 'of' T ]") : form_scope. +Canonical baseFinGroupType. +Canonical finGroupType. +Canonical join_baseFinGroupType. +Canonical join_finGroupType. +End Exports. + +End Algebra. +Import Algebra.Exports. + +Module UnitAlgebra. + +Section ClassDef. + +Variable R : unitRingType. + +Record class_of M := + Class { base : GRing.UnitAlgebra.class_of R M ; mixin : mixin_of M base }. +Definition base2 M (c : class_of M) := Algebra.Class (mixin c). +Definition base3 M (c : class_of M) := @UnitRing.Class _ (base c) (mixin c). + +Local Coercion base : class_of >-> GRing.UnitAlgebra.class_of. +Local Coercion base2 : class_of >-> Algebra.class_of. +Local Coercion base3 : class_of >-> UnitRing.class_of. + +Structure type (phR : phant R) := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variables (phR : phant R) (cT : type phR). +Definition pack := gen_pack (Pack phR) Class (@GRing.UnitAlgebra.class R phR). +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 eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (fin_ xclass) xT. +Definition finType := @Finite.Pack cT (fin_ xclass) xT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass xT. +Definition finZmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @GRing.Ring.Pack cT xclass xT. +Definition finRingType := @Ring.Pack cT xclass xT. +Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT. +Definition finUnitRingType := @UnitRing.Pack cT xclass xT. +Definition lmodType := @GRing.Lmodule.Pack R phR cT xclass xT. +Definition finLmodType := @Lmodule.Pack R phR cT xclass xT. +Definition lalgType := @GRing.Lalgebra.Pack R phR cT xclass xT. +Definition finLalgType := @Lalgebra.Pack R phR cT xclass xT. +Definition algType := @GRing.Algebra.Pack R phR cT xclass xT. +Definition finAlgType := @Algebra.Pack R phR cT xclass xT. +Definition unitAlgType := @GRing.UnitAlgebra.Pack R phR cT xclass xT. + +Definition join_finType := @Finite.Pack unitAlgType (fin_ xclass) xT. +Definition join_finZmodType := @Zmodule.Pack unitAlgType xclass xT. +Definition join_finRingType := @Ring.Pack unitAlgType xclass xT. +Definition join_finUnitRingType := @UnitRing.Pack unitAlgType xclass xT. +Definition join_finLmodType := @Lmodule.Pack R phR unitAlgType xclass xT. +Definition join_finLalgType := @Lalgebra.Pack R phR unitAlgType xclass xT. +Definition join_finAlgType := @Algebra.Pack R phR unitAlgType xclass xT. +Definition ljoin_finUnitRingType := @UnitRing.Pack lmodType xclass xT. +Definition fljoin_finUnitRingType := @UnitRing.Pack finLmodType xclass xT. +Definition njoin_finUnitRingType := @UnitRing.Pack lalgType xclass xT. +Definition fnjoin_finUnitRingType := @UnitRing.Pack finLalgType xclass xT. +Definition ajoin_finUnitRingType := @UnitRing.Pack algType xclass xT. +Definition fajoin_finUnitRingType := @UnitRing.Pack finAlgType xclass xT. +Definition ujoin_finLmodType := @Lmodule.Pack R phR unitRingType xclass xT. +Definition ujoin_finLalgType := @Lalgebra.Pack R phR unitRingType xclass xT. +Definition ujoin_finAlgType := @Algebra.Pack R phR unitRingType xclass xT. + +Definition baseFinGroupType := base_group cT zmodType finType. +Definition finGroupType := fin_group baseFinGroupType zmodType. +Definition join_baseFinGroupType := base_group zmodType zmodType finType. +Definition join_finGroupType := fin_group join_baseFinGroupType zmodType. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> GRing.UnitAlgebra.class_of. +Coercion base2 : class_of >-> Algebra.class_of. +Coercion base3 : class_of >-> UnitRing.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 countType : type >-> Countable.type. +Canonical countType. +Coercion finType : type >-> Finite.type. +Canonical finType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Coercion finZmodType : type >-> Zmodule.type. +Canonical finZmodType. +Coercion ringType : type >-> GRing.Ring.type. +Canonical ringType. +Coercion finRingType : type >-> Ring.type. +Canonical finRingType. +Coercion unitRingType : type >-> GRing.UnitRing.type. +Canonical unitRingType. +Coercion finUnitRingType : type >-> UnitRing.type. +Canonical finUnitRingType. +Coercion lmodType : type >-> GRing.Lmodule.type. +Canonical lmodType. +Coercion finLmodType : type >-> Lmodule.type. +Canonical finLmodType. +Coercion lalgType : type >-> GRing.Lalgebra.type. +Canonical lalgType. +Coercion finLalgType : type >-> Lalgebra.type. +Canonical finLalgType. +Coercion algType : type >-> GRing.Algebra.type. +Canonical algType. +Coercion finAlgType : type >-> Algebra.type. +Canonical finAlgType. +Coercion unitAlgType : type >-> GRing.UnitAlgebra.type. +Canonical unitAlgType. +Canonical join_finType. +Canonical join_finZmodType. +Canonical join_finLmodType. +Canonical join_finRingType. +Canonical join_finLalgType. +Canonical join_finAlgType. +Canonical ljoin_finUnitRingType. +Canonical fljoin_finUnitRingType. +Canonical njoin_finUnitRingType. +Canonical fnjoin_finUnitRingType. +Canonical ajoin_finUnitRingType. +Canonical fajoin_finUnitRingType. +Canonical ujoin_finLmodType. +Canonical ujoin_finLalgType. +Canonical ujoin_finAlgType. +Notation finUnitAlgType R := (type (Phant R)). +Notation "[ 'finUnitAlgType' R 'of' T ]" := (do_pack (@pack _ (Phant R)) T) + (at level 0, format "[ 'finUnitAlgType' R 'of' T ]") : form_scope. +Canonical baseFinGroupType. +Canonical finGroupType. +Canonical join_baseFinGroupType. +Canonical join_finGroupType. +End Exports. + +End UnitAlgebra. +Import UnitAlgebra.Exports. + +Module Theory. + +Definition zmod1gE := zmod1gE. +Definition zmodVgE := zmodVgE. +Definition zmodMgE := zmodMgE. +Definition zmodXgE := zmodXgE. +Definition zmod_mulgC := zmod_mulgC. +Definition zmod_abelian := zmod_abelian. +Definition val_unit1 := val_unit1. +Definition val_unitM := val_unitM. +Definition val_unitX := val_unitX. +Definition val_unitV := val_unitV. +Definition unit_actE := unit_actE. + +End Theory. + +End FinRing. + +Import FinRing. +Export Zmodule.Exports Ring.Exports ComRing.Exports. +Export UnitRing.Exports UnitsGroupExports ComUnitRing.Exports. +Export IntegralDomain.Exports Field.Exports DecField.Exports. +Export Lmodule.Exports Lalgebra.Exports Algebra.Exports UnitAlgebra.Exports. + +Notation "{ 'unit' R }" := (unit_of (Phant R)) + (at level 0, format "{ 'unit' R }") : type_scope. +Prenex Implicits FinRing.uval. +Notation "''U'" := (unit_action _) (at level 8) : action_scope. +Notation "''U'" := (unit_groupAction _) (at level 8) : groupAction_scope. + diff --git a/mathcomp/algebra/fraction.v b/mathcomp/algebra/fraction.v new file mode 100644 index 0000000..732cc19 --- /dev/null +++ b/mathcomp/algebra/fraction.v @@ -0,0 +1,384 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq choice tuple. +Require Import bigop ssralg poly polydiv generic_quotient. + +(* This file builds the field of fraction of any integral domain. *) +(* The main result of this file is the existence of the field *) +(* and of the tofrac function which is a injective ring morphism from R *) +(* to its fraction field {fraction R} *) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GRing.Theory. +Open Local Scope ring_scope. +Open Local Scope quotient_scope. + +Reserved Notation "{ 'ratio' T }" (at level 0, format "{ 'ratio' T }"). +Reserved Notation "{ 'fraction' T }" (at level 0, format "{ 'fraction' T }"). +Reserved Notation "x %:F" (at level 2, format "x %:F"). + +Section FracDomain. +Variable R : ringType. + +(* ratios are pairs of R, such that the second member is nonzero *) +Inductive ratio := mkRatio { frac :> R * R; _ : frac.2 != 0 }. +Definition ratio_of of phant R := ratio. +Local Notation "{ 'ratio' T }" := (ratio_of (Phant T)). + +Canonical ratio_subType := Eval hnf in [subType for frac]. +Canonical ratio_of_subType := Eval hnf in [subType of {ratio R}]. +Definition ratio_EqMixin := [eqMixin of ratio by <:]. +Canonical ratio_eqType := EqType ratio ratio_EqMixin. +Canonical ratio_of_eqType := Eval hnf in [eqType of {ratio R}]. +Definition ratio_ChoiceMixin := [choiceMixin of ratio by <:]. +Canonical ratio_choiceType := ChoiceType ratio ratio_ChoiceMixin. +Canonical ratio_of_choiceType := Eval hnf in [choiceType of {ratio R}]. + +Lemma denom_ratioP : forall f : ratio, f.2 != 0. Proof. by case. Qed. + +Definition ratio0 := (@mkRatio (0, 1) (oner_neq0 _)). +Definition Ratio x y : {ratio R} := insubd ratio0 (x, y). + +Lemma numer_Ratio x y : y != 0 -> (Ratio x y).1 = x. +Proof. by move=> ny0; rewrite /Ratio /insubd insubT. Qed. + +Lemma denom_Ratio x y : y != 0 -> (Ratio x y).2 = y. +Proof. by move=> ny0; rewrite /Ratio /insubd insubT. Qed. + +Definition numden_Ratio := (numer_Ratio, denom_Ratio). + +CoInductive Ratio_spec (n d : R) : {ratio R} -> R -> R -> Type := + | RatioNull of d = 0 : Ratio_spec n d ratio0 n 0 + | RatioNonNull (d_neq0 : d != 0) : + Ratio_spec n d (@mkRatio (n, d) d_neq0) n d. + +Lemma RatioP n d : Ratio_spec n d (Ratio n d) n d. +Proof. +rewrite /Ratio /insubd; case: insubP=> /= [x /= d_neq0 hx|]. + have ->: x = @mkRatio (n, d) d_neq0 by apply: val_inj. + by constructor. +by rewrite negbK=> /eqP hx; rewrite {2}hx; constructor. +Qed. + +Lemma Ratio0 x : Ratio x 0 = ratio0. +Proof. by rewrite /Ratio /insubd; case: insubP; rewrite //= eqxx. Qed. + +End FracDomain. + +Notation "{ 'ratio' T }" := (ratio_of (Phant T)). +Identity Coercion type_fracdomain_of : ratio_of >-> ratio. + +Notation "'\n_' x" := (frac x).1 + (at level 8, x at level 2, format "'\n_' x"). +Notation "'\d_' x" := (frac x).2 + (at level 8, x at level 2, format "'\d_' x"). + +Module FracField. +Section FracField. + +Variable R : idomainType. + +Local Notation frac := (R * R). +Local Notation dom := (ratio R). +Local Notation domP := denom_ratioP. + +Implicit Types x y z : dom. + +(* We define a relation in ratios *) +Local Notation equivf_notation x y := (\n_x * \d_y == \d_x * \n_y). +Definition equivf x y := equivf_notation x y. + +Lemma equivfE x y : equivf x y = equivf_notation x y. +Proof. by []. Qed. + +Lemma equivf_refl : reflexive equivf. +Proof. by move=> x; rewrite /equivf mulrC. Qed. + +Lemma equivf_sym : symmetric equivf. +Proof. by move=> x y; rewrite /equivf eq_sym; congr (_==_); rewrite mulrC. Qed. + +Lemma equivf_trans : transitive equivf. +Proof. +move=> [x Px] [y Py] [z Pz]; rewrite /equivf /= mulrC => /eqP xy /eqP yz. +by rewrite -(inj_eq (mulfI Px)) mulrA xy -mulrA yz mulrCA. +Qed. + +(* we show that equivf is an equivalence *) +Canonical equivf_equiv := EquivRel equivf equivf_refl equivf_sym equivf_trans. + +Definition type := {eq_quot equivf}. +Definition type_of of phant R := type. +Notation "{ 'fraction' T }" := (type_of (Phant T)). + +(* we recover some structure for the quotient *) +Canonical frac_quotType := [quotType of type]. +Canonical frac_eqType := [eqType of type]. +Canonical frac_choiceType := [choiceType of type]. +Canonical frac_eqQuotType := [eqQuotType equivf of type]. + +Canonical frac_of_quotType := [quotType of {fraction R}]. +Canonical frac_of_eqType := [eqType of {fraction R}]. +Canonical frac_of_choiceType := [choiceType of {fraction R}]. +Canonical frac_of_eqQuotType := [eqQuotType equivf of {fraction R}]. + +(* we explain what was the equivalence on the quotient *) +Lemma equivf_def (x y : ratio R) : x == y %[mod type] + = (\n_x * \d_y == \d_x * \n_y). +Proof. by rewrite eqmodE. Qed. + +Lemma equivf_r x : \n_x * \d_(repr (\pi_type x)) = \d_x * \n_(repr (\pi_type x)). +Proof. by apply/eqP; rewrite -equivf_def reprK. Qed. + +Lemma equivf_l x : \n_(repr (\pi_type x)) * \d_x = \d_(repr (\pi_type x)) * \n_x. +Proof. by apply/eqP; rewrite -equivf_def reprK. Qed. + +Lemma numer0 x : (\n_x == 0) = (x == (ratio0 R) %[mod_eq equivf]). +Proof. by rewrite eqmodE /= !equivfE // mulr1 mulr0. Qed. + +Lemma Ratio_numden : forall x, Ratio \n_x \d_x = x. +Proof. +case=> [[n d] /= nd]; rewrite /Ratio /insubd; apply: val_inj=> /=. +by case: insubP=> //=; rewrite nd. +Qed. + +Definition tofrac := lift_embed {fraction R} (fun x : R => Ratio x 1). +Canonical tofrac_pi_morph := PiEmbed tofrac. + +Notation "x %:F" := (@tofrac x). + +Implicit Types a b c : type. + +Definition addf x y : dom := Ratio (\n_x * \d_y + \n_y * \d_x) (\d_x * \d_y). +Definition add := lift_op2 {fraction R} addf. + +Lemma pi_add : {morph \pi : x y / addf x y >-> add x y}. +Proof. +move=> x y; unlock add; apply/eqmodP; rewrite /= equivfE. +rewrite /addf /= !numden_Ratio ?mulf_neq0 ?domP //. +rewrite mulrDr mulrDl eq_sym; apply/eqP. +rewrite !mulrA ![_ * \n__]mulrC !mulrA equivf_l. +congr (_ + _); first by rewrite -mulrA mulrCA !mulrA. +rewrite -!mulrA [X in _ * X]mulrCA !mulrA equivf_l. +by rewrite mulrC !mulrA -mulrA mulrC mulrA. +Qed. +Canonical pi_add_morph := PiMorph2 pi_add. + +Definition oppf x : dom := Ratio (- \n_x) \d_x. +Definition opp := lift_op1 {fraction R} oppf. +Lemma pi_opp : {morph \pi : x / oppf x >-> opp x}. +Proof. +move=> x; unlock opp; apply/eqmodP; rewrite /= /equivf /oppf /=. +by rewrite !numden_Ratio ?(domP,mulf_neq0) // mulNr mulrN -equivf_r. +Qed. +Canonical pi_opp_morph := PiMorph1 pi_opp. + +Definition mulf x y : dom := Ratio (\n_x * \n_y) (\d_x * \d_y). +Definition mul := lift_op2 {fraction R} mulf. + +Lemma pi_mul : {morph \pi : x y / mulf x y >-> mul x y}. +Proof. +move=> x y; unlock mul; apply/eqmodP=> /=. +rewrite equivfE /= /addf /= !numden_Ratio ?mulf_neq0 ?domP //. +rewrite mulrAC !mulrA -mulrA equivf_r -equivf_l. +by rewrite mulrA ![_ * \d_y]mulrC !mulrA. +Qed. +Canonical pi_mul_morph := PiMorph2 pi_mul. + +Definition invf x : dom := Ratio \d_x \n_x. +Definition inv := lift_op1 {fraction R} invf. + +Lemma pi_inv : {morph \pi : x / invf x >-> inv x}. +Proof. +move=> x; unlock inv; apply/eqmodP=> /=; rewrite equivfE /invf eq_sym. +do 2?case: RatioP=> /= [/eqP|]; + rewrite ?mul0r ?mul1r -?equivf_def ?numer0 ?reprK //. + by move=> hx /eqP hx'; rewrite hx' eqxx in hx. +by move=> /eqP ->; rewrite eqxx. +Qed. +Canonical pi_inv_morph := PiMorph1 pi_inv. + +Lemma addA : associative add. +Proof. +elim/quotW=> x; elim/quotW=> y; elim/quotW=> z; rewrite !piE. +rewrite /addf /= !numden_Ratio ?mulf_neq0 ?domP // !mulrDl !mulrA !addrA. +by congr (\pi (Ratio (_ + _ + _) _)); rewrite mulrAC. +Qed. + +Lemma addC : commutative add. +Proof. +by elim/quotW=> x; elim/quotW=> y; rewrite !piE /addf addrC [\d__ * _]mulrC. +Qed. + +Lemma add0_l : left_id 0%:F add. +Proof. +elim/quotW=> x; rewrite !piE /addf !numden_Ratio ?oner_eq0 //. +by rewrite mul0r mul1r mulr1 add0r Ratio_numden. +Qed. + +Lemma addN_l : left_inverse 0%:F opp add. +Proof. +elim/quotW=> x; apply/eqP; rewrite piE /equivf. +rewrite /addf /oppf !numden_Ratio ?(oner_eq0, mulf_neq0, domP) //. +by rewrite mulr1 mulr0 mulNr addNr. +Qed. + +(* fracions form an abelian group *) +Definition frac_zmodMixin := ZmodMixin addA addC add0_l addN_l. +Canonical frac_zmodType := Eval hnf in ZmodType type frac_zmodMixin. + +Lemma mulA : associative mul. +Proof. +elim/quotW=> x; elim/quotW=> y; elim/quotW=> z; rewrite !piE. +by rewrite /mulf !numden_Ratio ?mulf_neq0 ?domP // !mulrA. +Qed. + +Lemma mulC : commutative mul. +Proof. +elim/quotW=> x; elim/quotW=> y; rewrite !piE /mulf. +by rewrite [_ * (\d_x)]mulrC [_ * (\n_x)]mulrC. +Qed. + +Lemma mul1_l : left_id 1%:F mul. +Proof. +elim/quotW=> x; rewrite !piE /mulf. +by rewrite !numden_Ratio ?oner_eq0 // !mul1r Ratio_numden. +Qed. + +Lemma mul_addl : left_distributive mul add. +Proof. +elim/quotW=> x; elim/quotW=> y; elim/quotW=> z; apply/eqP. +rewrite !piE /equivf /mulf /addf !numden_Ratio ?mulf_neq0 ?domP //; apply/eqP. +rewrite !(mulrDr, mulrDl) !mulrA; congr (_ * _ + _ * _). + rewrite ![_ * \n_z]mulrC -!mulrA; congr (_ * _). + rewrite ![\d_y * _]mulrC !mulrA; congr (_ * _ * _). + by rewrite [X in _ = X]mulrC mulrA. +rewrite ![_ * \n_z]mulrC -!mulrA; congr (_ * _). +rewrite ![\d_x * _]mulrC !mulrA; congr (_ * _ * _). +by rewrite -mulrA mulrC [X in X * _] mulrC. +Qed. + +Lemma nonzero1 : 1%:F != 0%:F :> type. +Proof. by rewrite piE equivfE !numden_Ratio ?mul1r ?oner_eq0. Qed. + +(* fracions form a commutative ring *) +Definition frac_comRingMixin := ComRingMixin mulA mulC mul1_l mul_addl nonzero1. +Canonical frac_ringType := Eval hnf in RingType type frac_comRingMixin. +Canonical frac_comRingType := Eval hnf in ComRingType type mulC. + +Lemma mulV_l : forall a, a != 0%:F -> mul (inv a) a = 1%:F. +Proof. +elim/quotW=> x /=; rewrite !piE. +rewrite /equivf !numden_Ratio ?oner_eq0 // mulr1 mulr0=> nx0. +apply/eqmodP; rewrite /= equivfE. +by rewrite !numden_Ratio ?(oner_eq0, mulf_neq0, domP) // !mulr1 mulrC. +Qed. + +Lemma inv0 : inv 0%:F = 0%:F. +Proof. +rewrite !piE /invf !numden_Ratio ?oner_eq0 // /Ratio /insubd. +do 2?case: insubP; rewrite //= ?eqxx ?oner_eq0 // => u _ hu _. +by congr \pi; apply: val_inj; rewrite /= hu. +Qed. + +(* fractions form a ring with explicit unit *) +Definition RatFieldUnitMixin := FieldUnitMixin mulV_l inv0. +Canonical frac_unitRingType := Eval hnf in UnitRingType type RatFieldUnitMixin. +Canonical frac_comUnitRingType := [comUnitRingType of type]. + +Lemma field_axiom : GRing.Field.mixin_of frac_unitRingType. +Proof. exact. Qed. + +(* fractions form a field *) +Definition RatFieldIdomainMixin := (FieldIdomainMixin field_axiom). +Canonical frac_idomainType := + Eval hnf in IdomainType type (FieldIdomainMixin field_axiom). +Canonical frac_fieldType := FieldType type field_axiom. + +End FracField. +End FracField. + +Notation "{ 'fraction' T }" := (FracField.type_of (Phant T)). +Notation equivf := (@FracField.equivf _). +Hint Resolve denom_ratioP. + +Section Canonicals. + +Variable R : idomainType. + +(* reexporting the structures *) +Canonical FracField.frac_quotType. +Canonical FracField.frac_eqType. +Canonical FracField.frac_choiceType. +Canonical FracField.frac_zmodType. +Canonical FracField.frac_ringType. +Canonical FracField.frac_comRingType. +Canonical FracField.frac_unitRingType. +Canonical FracField.frac_comUnitRingType. +Canonical FracField.frac_idomainType. +Canonical FracField.frac_fieldType. +Canonical FracField.tofrac_pi_morph. +Canonical frac_of_quotType := Eval hnf in [quotType of {fraction R}]. +Canonical frac_of_eqType := Eval hnf in [eqType of {fraction R}]. +Canonical frac_of_choiceType := Eval hnf in [choiceType of {fraction R}]. +Canonical frac_of_zmodType := Eval hnf in [zmodType of {fraction R}]. +Canonical frac_of_ringType := Eval hnf in [ringType of {fraction R}]. +Canonical frac_of_comRingType := Eval hnf in [comRingType of {fraction R}]. +Canonical frac_of_unitRingType := Eval hnf in [unitRingType of {fraction R}]. +Canonical frac_of_comUnitRingType := Eval hnf in [comUnitRingType of {fraction R}]. +Canonical frac_of_idomainType := Eval hnf in [idomainType of {fraction R}]. +Canonical frac_of_fieldType := Eval hnf in [fieldType of {fraction R}]. + +End Canonicals. + +Section FracFieldTheory. + +Import FracField. + +Variable R : idomainType. + +Lemma Ratio_numden (x : {ratio R}) : Ratio \n_x \d_x = x. +Proof. exact: FracField.Ratio_numden. Qed. + +(* exporting the embeding from R to {fraction R} *) +Local Notation tofrac := (@FracField.tofrac R). +Local Notation "x %:F" := (tofrac x). + +Lemma tofrac_is_additive: additive tofrac. +Proof. +move=> p q /=; unlock tofrac. +rewrite -[X in _ = _ + X]pi_opp -[X in _ = X]pi_add. +by rewrite /addf /oppf /= !numden_Ratio ?(oner_neq0, mul1r, mulr1). +Qed. + +Canonical tofrac_additive := Additive tofrac_is_additive. + +Lemma tofrac_is_multiplicative: multiplicative tofrac. +Proof. +split=> [p q|//]; unlock tofrac; rewrite -[X in _ = X]pi_mul. +by rewrite /mulf /= !numden_Ratio ?(oner_neq0, mul1r, mulr1). +Qed. + +Canonical tofrac_rmorphism := AddRMorphism tofrac_is_multiplicative. + +(* tests *) +Lemma tofrac0 : 0%:F = 0. Proof. exact: rmorph0. Qed. +Lemma tofracN : {morph tofrac: x / - x}. Proof. exact: rmorphN. Qed. +Lemma tofracD : {morph tofrac: x y / x + y}. Proof. exact: rmorphD. Qed. +Lemma tofracB : {morph tofrac: x y / x - y}. Proof. exact: rmorphB. Qed. +Lemma tofracMn n : {morph tofrac: x / x *+ n}. Proof. exact: rmorphMn. Qed. +Lemma tofracMNn n : {morph tofrac: x / x *- n}. Proof. exact: rmorphMNn. Qed. +Lemma tofrac1 : 1%:F = 1. Proof. exact: rmorph1. Qed. +Lemma tofracM : {morph tofrac: x y / x * y}. Proof. exact: rmorphM. Qed. +Lemma tofracX n : {morph tofrac: x / x ^+ n}. Proof. exact: rmorphX. Qed. + +Lemma tofrac_eq (p q : R): (p%:F == q%:F) = (p == q). +Proof. +apply/eqP/eqP=> [|->//]; unlock tofrac=> /eqmodP /eqP /=. +by rewrite !numden_Ratio ?(oner_eq0, mul1r, mulr1). +Qed. + +Lemma tofrac_eq0 (p : R): (p%:F == 0) = (p == 0). +Proof. by rewrite tofrac_eq. Qed. +End FracFieldTheory. diff --git a/mathcomp/algebra/intdiv.v b/mathcomp/algebra/intdiv.v new file mode 100644 index 0000000..4f1ce95 --- /dev/null +++ b/mathcomp/algebra/intdiv.v @@ -0,0 +1,1076 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg poly ssrnum ssrint rat. +Require Import polydiv finalg perm zmodp matrix mxalgebra vector. + +(******************************************************************************) +(* This file provides various results on divisibility of integers. *) +(* It defines, for m, n, d : int, *) +(* (m %% d)%Z == the remainder of the Euclidean division of m by d; this is *) +(* the least non-negative element of the coset m + dZ when *) +(* d != 0, and m if d = 0. *) +(* (m %/ d)%Z == the quotient of the Euclidean division of m by d, such *) +(* that m = (m %/ d)%Z * d + (m %% d)%Z. Since for d != 0 the *) +(* remainder is non-negative, (m %/ d)%Z is non-zero for *) +(* (d %| m)%Z <=> m is divisible by d; dvdz d is the (collective) predicate *) +(* for integers divisible by d, and (d %| m)%Z is actually *) +(* (transposing) notation for m \in dvdz d. *) +(* (m = n %[mod d])%Z, (m == n %[mod d])%Z, (m != n %[mod d])%Z *) +(* m and n are (resp. compare, don't compare) equal mod d. *) +(* gcdz m n == the (non-negative) greatest common divisor of m and n, *) +(* with gcdz 0 0 = 0. *) +(* coprimez m n <=> m and n are coprime. *) +(* egcdz m n == the Bezout coefficients of the gcd of m and n: a pair *) +(* (u, v) of coprime integers such that u*m + v*n = gcdz m n. *) +(* Alternatively, a Bezoutz lemma states such u and v exist. *) +(* zchinese m1 m2 n1 n2 == for coprime m1 and m2, a solution to the Chinese *) +(* remainder problem for n1 and n2, i.e., and integer n such *) +(* that n = n1 %[mod m1] and n = n2 %[mod m2]. *) +(* zcontents p == the contents of p : {poly int}, that is, the gcd of the *) +(* coefficients of p, with the lead coefficient of p, *) +(* zprimitive p == the primitive part of p : {poly int}, i.e., p divided by *) +(* its contents. *) +(* inIntSpan X v <-> v is an integral linear combination of elements of *) +(* X : seq V, where V is a zmodType. We prove that this is a *) +(* decidable property for Q-vector spaces. *) +(* int_Smith_normal_form :: a theorem asserting the existence of the Smith *) +(* normal form for integer matrices. *) +(* Note that many of the concepts and results in this file could and perhaps *) +(* sould be generalized to the more general setting of integral, unique *) +(* factorization, principal ideal, or Euclidean domains. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GRing.Theory Num.Theory. +Local Open Scope ring_scope. + +Definition divz (m d : int) := + let: (K, n) := match m with Posz n => (Posz, n) | Negz n => (Negz, n) end in + sgz d * K (n %/ `|d|)%N. + +Definition modz (m d : int) : int := m - divz m d * d. + +Definition dvdz d m := (`|d| %| `|m|)%N. + +Definition gcdz m n := (gcdn `|m| `|n|)%:Z. + +Definition egcdz m n : int * int := + if m == 0 then (0, (-1) ^+ (n < 0)%R) else + let: (u, v) := egcdn `|m| `|n| in (sgz m * u, - (-1) ^+ (n < 0)%R * v%:Z). + +Definition coprimez m n := (gcdz m n == 1). + +Infix "%/" := divz : int_scope. +Infix "%%" := modz : int_scope. +Notation "d %| m" := (m \in dvdz d) : int_scope. +Notation "m = n %[mod d ]" := (modz m d = modz n d) : int_scope. +Notation "m == n %[mod d ]" := (modz m d == modz n d) : int_scope. +Notation "m <> n %[mod d ]" := (modz m d <> modz n d) : int_scope. +Notation "m != n %[mod d ]" := (modz m d != modz n d) : int_scope. + +Lemma divz_nat (n d : nat) : (n %/ d)%Z = (n %/ d)%N. +Proof. by case: d => // d; rewrite /divz /= mul1r. Qed. + +Lemma divzN m d : (m %/ - d)%Z = - (m %/ d)%Z. +Proof. by case: m => n; rewrite /divz /= sgzN abszN mulNr. Qed. + +Lemma divz_abs m d : (m %/ `|d|)%Z = (-1) ^+ (d < 0)%R * (m %/ d)%Z. +Proof. +by rewrite {3}[d]intEsign !mulr_sign; case: ifP => -> //; rewrite divzN opprK. +Qed. + +Lemma div0z d : (0 %/ d)%Z = 0. +Proof. +by rewrite -(canLR (signrMK _) (divz_abs _ _)) (divz_nat 0) div0n mulr0. +Qed. + +Lemma divNz_nat m d : (d > 0)%N -> (Negz m %/ d)%Z = - (m %/ d).+1%:Z. +Proof. by case: d => // d _; apply: mul1r. Qed. + +Lemma divz_eq m d : m = (m %/ d)%Z * d + (m %% d)%Z. +Proof. by rewrite addrC subrK. Qed. + +Lemma modzN m d : (m %% - d)%Z = (m %% d)%Z. +Proof. by rewrite /modz divzN mulrNN. Qed. + +Lemma modz_abs m d : (m %% `|d|%N)%Z = (m %% d)%Z. +Proof. by rewrite {2}[d]intEsign mulr_sign; case: ifP; rewrite ?modzN. Qed. + +Lemma modz_nat (m d : nat) : (m %% d)%Z = (m %% d)%N. +Proof. +by apply: (canLR (addrK _)); rewrite addrC divz_nat {1}(divn_eq m d). +Qed. + +Lemma modNz_nat m d : (d > 0)%N -> (Negz m %% d)%Z = d%:Z - 1 - (m %% d)%:Z. +Proof. +rewrite /modz => /divNz_nat->; apply: (canLR (addrK _)). +rewrite -!addrA -!opprD -!PoszD -opprB mulnSr !addnA PoszD addrK. +by rewrite addnAC -addnA mulnC -divn_eq. +Qed. + +Lemma modz_ge0 m d : d != 0 -> 0 <= (m %% d)%Z. +Proof. +rewrite -absz_gt0 -modz_abs => d_gt0. +case: m => n; rewrite ?modNz_nat ?modz_nat // -addrA -opprD subr_ge0. +by rewrite lez_nat ltn_mod. +Qed. + +Lemma divz0 m : (m %/ 0)%Z = 0. Proof. by case: m. Qed. +Lemma mod0z d : (0 %% d)%Z = 0. Proof. by rewrite /modz div0z mul0r subrr. Qed. +Lemma modz0 m : (m %% 0)%Z = m. Proof. by rewrite /modz mulr0 subr0. Qed. + +Lemma divz_small m d : 0 <= m < `|d|%:Z -> (m %/ d)%Z = 0. +Proof. +rewrite -(canLR (signrMK _) (divz_abs _ _)); case: m => // n /divn_small. +by rewrite divz_nat => ->; rewrite mulr0. +Qed. + +Lemma divzMDl q m d : d != 0 -> ((q * d + m) %/ d)%Z = q + (m %/ d)%Z. +Proof. +rewrite neqr_lt -oppr_gt0 => nz_d. +wlog{nz_d} d_gt0: q d / d > 0; last case: d => // d in d_gt0 *. + move=> IH; case/orP: nz_d => /IH// /(_ (- q)). + by rewrite mulrNN !divzN -opprD => /oppr_inj. +wlog q_gt0: q m / q >= 0; last case: q q_gt0 => // q _. + move=> IH; case: q => n; first exact: IH; rewrite NegzE mulNr. + by apply: canRL (addKr _) _; rewrite -IH ?addNKr. +case: m => n; first by rewrite !divz_nat divnMDl. +have [le_qd_n | lt_qd_n] := leqP (q * d) n. + rewrite divNz_nat // NegzE -(subnKC le_qd_n) divnMDl //. + by rewrite -!addnS !PoszD !opprD !addNKr divNz_nat. +rewrite divNz_nat // NegzE -PoszM subzn // divz_nat. +apply: canRL (addrK _) _; congr _%:Z; rewrite addnC -divnMDl // mulSnr. +rewrite -{3}(subnKC (ltn_pmod n d_gt0)) addnA addnS -divn_eq addnAC. +by rewrite subnKC // divnMDl // divn_small ?addn0 // subnSK ?ltn_mod ?leq_subr. +Qed. + +Lemma mulzK m d : d != 0 -> (m * d %/ d)%Z = m. +Proof. by move=> d_nz; rewrite -[m * d]addr0 divzMDl // div0z addr0. Qed. + +Lemma mulKz m d : d != 0 -> (d * m %/ d)%Z = m. +Proof. by move=> d_nz; rewrite mulrC mulzK. Qed. + +Lemma expzB p m n : p != 0 -> (m >= n)%N -> p ^+ (m - n) = (p ^+ m %/ p ^+ n)%Z. +Proof. by move=> p_nz /subnK{2}<-; rewrite exprD mulzK // expf_neq0. Qed. + +Lemma modz1 m : (m %% 1)%Z = 0. +Proof. by case: m => n; rewrite (modNz_nat, modz_nat) ?modn1. Qed. + +Lemma divn1 m : (m %/ 1)%Z = m. Proof. by rewrite -{1}[m]mulr1 mulzK. Qed. + +Lemma divzz d : (d %/ d)%Z = (d != 0). +Proof. by have [-> // | d_nz] := altP eqP; rewrite -{1}[d]mul1r mulzK. Qed. + +Lemma ltz_pmod m d : d > 0 -> (m %% d)%Z < d. +Proof. +case: m d => n [] // d d_gt0; first by rewrite modz_nat ltz_nat ltn_pmod. +by rewrite modNz_nat // -lez_addr1 addrAC subrK ger_addl oppr_le0. +Qed. + +Lemma ltz_mod m d : d != 0 -> (m %% d)%Z < `|d|. +Proof. by rewrite -absz_gt0 -modz_abs => d_gt0; apply: ltz_pmod. Qed. + +Lemma divzMpl p m d : p > 0 -> (p * m %/ (p * d) = m %/ d)%Z. +Proof. +case: p => // p p_gt0; wlog d_gt0: d / d > 0; last case: d => // d in d_gt0 *. + by move=> IH; case/intP: d => [|d|d]; rewrite ?mulr0 ?divz0 ?mulrN ?divzN ?IH. +rewrite {1}(divz_eq m d) mulrDr mulrCA divzMDl ?mulf_neq0 ?gtr_eqF // addrC. +rewrite divz_small ?add0r // PoszM pmulr_rge0 ?modz_ge0 ?gtr_eqF //=. +by rewrite ltr_pmul2l ?ltz_pmod. +Qed. +Implicit Arguments divzMpl [p m d]. + +Lemma divzMpr p m d : p > 0 -> (m * p %/ (d * p) = m %/ d)%Z. +Proof. by move=> p_gt0; rewrite -!(mulrC p) divzMpl. Qed. +Implicit Arguments divzMpr [p m d]. + +Lemma lez_floor m d : d != 0 -> (m %/ d)%Z * d <= m. +Proof. by rewrite -subr_ge0; apply: modz_ge0. Qed. + +(* leq_mod does not extend to negative m. *) +Lemma lez_div m d : (`|(m %/ d)%Z| <= `|m|)%N. +Proof. +wlog d_gt0: d / d > 0; last case: d d_gt0 => // d d_gt0. + by move=> IH; case/intP: d => [|n|n]; rewrite ?divz0 ?divzN ?abszN // IH. +case: m => n; first by rewrite divz_nat leq_div. +by rewrite divNz_nat // NegzE !abszN ltnS leq_div. +Qed. + +Lemma ltz_ceil m d : d > 0 -> m < ((m %/ d)%Z + 1) * d. +Proof. +by case: d => // d d_gt0; rewrite mulrDl mul1r -ltr_subl_addl ltz_mod ?gtr_eqF. +Qed. + +Lemma ltz_divLR m n d : d > 0 -> ((m %/ d)%Z < n) = (m < n * d). +Proof. +move=> d_gt0; apply/idP/idP. + by rewrite -lez_addr1 -(ler_pmul2r d_gt0); apply: ltr_le_trans (ltz_ceil _ _). +rewrite -(ltr_pmul2r d_gt0 _ n) //; apply: ler_lt_trans (lez_floor _ _). +by rewrite gtr_eqF. +Qed. + +Lemma lez_divRL m n d : d > 0 -> (m <= (n %/ d)%Z) = (m * d <= n). +Proof. by move=> d_gt0; rewrite !lerNgt ltz_divLR. Qed. + +Lemma divz_ge0 m d : d > 0 -> ((m %/ d)%Z >= 0) = (m >= 0). +Proof. by case: d m => // d [] n d_gt0; rewrite (divz_nat, divNz_nat). Qed. + +Lemma divzMA_ge0 m n p : n >= 0 -> (m %/ (n * p) = (m %/ n)%Z %/ p)%Z. +Proof. +case: n => // [[|n]] _; first by rewrite mul0r !divz0 div0z. +wlog p_gt0: p / p > 0; last case: p => // p in p_gt0 *. + by case/intP: p => [|p|p] IH; rewrite ?mulr0 ?divz0 ?mulrN ?divzN // IH. +rewrite {2}(divz_eq m (n.+1%:Z * p)) mulrA mulrAC !divzMDl // ?gtr_eqF //. +rewrite [rhs in _ + rhs]divz_small ?addr0 // ltz_divLR // divz_ge0 //. +by rewrite mulrC ltz_pmod ?modz_ge0 ?gtr_eqF ?pmulr_lgt0. +Qed. + +Lemma modz_small m d : 0 <= m < d -> (m %% d)%Z = m. +Proof. by case: m d => //= m [] // d; rewrite modz_nat => /modn_small->. Qed. + +Lemma modz_mod m d : ((m %% d)%Z = m %[mod d])%Z. +Proof. +rewrite -!(modz_abs _ d); case: {d}`|d|%N => [|d]; first by rewrite !modz0. +by rewrite modz_small ?modz_ge0 ?ltz_mod. +Qed. + +Lemma modzMDl p m d : (p * d + m = m %[mod d])%Z. +Proof. +have [-> | d_nz] := eqVneq d 0; first by rewrite mulr0 add0r. +by rewrite /modz divzMDl // mulrDl opprD addrACA subrr add0r. +Qed. + +Lemma mulz_modr {p m d} : 0 < p -> p * (m %% d)%Z = ((p * m) %% (p * d))%Z. +Proof. +case: p => // p p_gt0; rewrite mulrBr; apply: canLR (addrK _) _. +by rewrite mulrCA -(divzMpl p_gt0) subrK. +Qed. + +Lemma mulz_modl {p m d} : 0 < p -> (m %% d)%Z * p = ((m * p) %% (d * p))%Z. +Proof. by rewrite -!(mulrC p); apply: mulz_modr. Qed. + +Lemma modzDl m d : (d + m = m %[mod d])%Z. +Proof. by rewrite -{1}[d]mul1r modzMDl. Qed. + +Lemma modzDr m d : (m + d = m %[mod d])%Z. +Proof. by rewrite addrC modzDl. Qed. + +Lemma modzz d : (d %% d)%Z = 0. +Proof. by rewrite -{1}[d]addr0 modzDl mod0z. Qed. + +Lemma modzMl p d : (p * d %% d)%Z = 0. +Proof. by rewrite -[p * d]addr0 modzMDl mod0z. Qed. + +Lemma modzMr p d : (d * p %% d)%Z = 0. +Proof. by rewrite mulrC modzMl. Qed. + +Lemma modzDml m n d : ((m %% d)%Z + n = m + n %[mod d])%Z. +Proof. by rewrite {2}(divz_eq m d) -[_ * d + _ + n]addrA modzMDl. Qed. + +Lemma modzDmr m n d : (m + (n %% d)%Z = m + n %[mod d])%Z. +Proof. by rewrite !(addrC m) modzDml. Qed. + +Lemma modzDm m n d : ((m %% d)%Z + (n %% d)%Z = m + n %[mod d])%Z. +Proof. by rewrite modzDml modzDmr. Qed. + +Lemma eqz_modDl p m n d : (p + m == p + n %[mod d])%Z = (m == n %[mod d])%Z. +Proof. +have [-> | d_nz] := eqVneq d 0; first by rewrite !modz0 (inj_eq (addrI p)). +apply/eqP/eqP=> eq_mn; last by rewrite -modzDmr eq_mn modzDmr. +by rewrite -(addKr p m) -modzDmr eq_mn modzDmr addKr. +Qed. + +Lemma eqz_modDr p m n d : (m + p == n + p %[mod d])%Z = (m == n %[mod d])%Z. +Proof. by rewrite -!(addrC p) eqz_modDl. Qed. + +Lemma modzMml m n d : ((m %% d)%Z * n = m * n %[mod d])%Z. +Proof. by rewrite {2}(divz_eq m d) mulrDl mulrAC modzMDl. Qed. + +Lemma modzMmr m n d : (m * (n %% d)%Z = m * n %[mod d])%Z. +Proof. by rewrite !(mulrC m) modzMml. Qed. + +Lemma modzMm m n d : ((m %% d)%Z * (n %% d)%Z = m * n %[mod d])%Z. +Proof. by rewrite modzMml modzMmr. Qed. + +Lemma modzXm k m d : ((m %% d)%Z ^+ k = m ^+ k %[mod d])%Z. +Proof. by elim: k => // k IHk; rewrite !exprS -modzMmr IHk modzMm. Qed. + +Lemma modzNm m d : (- (m %% d)%Z = - m %[mod d])%Z. +Proof. by rewrite -mulN1r modzMmr mulN1r. Qed. + +Lemma modz_absm m d : ((-1) ^+ (m < 0)%R * (m %% d)%Z = `|m|%:Z %[mod d])%Z. +Proof. by rewrite modzMmr -abszEsign. Qed. + +(** Divisibility **) + +Fact dvdz_key d : pred_key (dvdz d). Proof. by []. Qed. +Canonical dvdz_keyed d := KeyedPred (dvdz_key d). + +Lemma dvdzE d m : (d %| m)%Z = (`|d| %| `|m|)%N. Proof. by []. Qed. +Lemma dvdz0 d : (d %| 0)%Z. Proof. exact: dvdn0. Qed. +Lemma dvd0z n : (0 %| n)%Z = (n == 0). Proof. by rewrite -absz_eq0 -dvd0n. Qed. +Lemma dvdz1 d : (d %| 1)%Z = (`|d|%N == 1%N). Proof. exact: dvdn1. Qed. +Lemma dvd1z m : (1 %| m)%Z. Proof. exact: dvd1n. Qed. +Lemma dvdzz m : (m %| m)%Z. Proof. exact: dvdnn. Qed. + +Lemma dvdz_mull d m n : (d %| n)%Z -> (d %| m * n)%Z. +Proof. by rewrite !dvdzE abszM; apply: dvdn_mull. Qed. + +Lemma dvdz_mulr d m n : (d %| m)%Z -> (d %| m * n)%Z. +Proof. by move=> d_m; rewrite mulrC dvdz_mull. Qed. +Hint Resolve dvdz0 dvd1z dvdzz dvdz_mull dvdz_mulr. + +Lemma dvdz_mul d1 d2 m1 m2 : (d1 %| m1 -> d2 %| m2 -> d1 * d2 %| m1 * m2)%Z. +Proof. by rewrite !dvdzE !abszM; apply: dvdn_mul. Qed. + +Lemma dvdz_trans n d m : (d %| n -> n %| m -> d %| m)%Z. +Proof. by rewrite !dvdzE; apply: dvdn_trans. Qed. + +Lemma dvdzP d m : reflect (exists q, m = q * d) (d %| m)%Z. +Proof. +apply: (iffP dvdnP) => [] [q Dm]; last by exists `|q|%N; rewrite Dm abszM. +exists ((-1) ^+ (m < 0)%R * q%:Z * (-1) ^+ (d < 0)%R). +by rewrite -!mulrA -abszEsign -PoszM -Dm -intEsign. +Qed. +Implicit Arguments dvdzP [d m]. + +Lemma dvdz_mod0P d m : reflect (m %% d = 0)%Z (d %| m)%Z. +Proof. +apply: (iffP dvdzP) => [[q ->] | md0]; first by rewrite modzMl. +by rewrite (divz_eq m d) md0 addr0; exists (m %/ d)%Z. +Qed. +Implicit Arguments dvdz_mod0P [d m]. + +Lemma dvdz_eq d m : (d %| m)%Z = ((m %/ d)%Z * d == m). +Proof. by rewrite (sameP dvdz_mod0P eqP) subr_eq0 eq_sym. Qed. + +Lemma divzK d m : (d %| m)%Z -> (m %/ d)%Z * d = m. +Proof. by rewrite dvdz_eq => /eqP. Qed. + +Lemma lez_divLR d m n : 0 < d -> (d %| m)%Z -> ((m %/ d)%Z <= n) = (m <= n * d). +Proof. by move=> /ler_pmul2r <- /divzK->. Qed. + +Lemma ltz_divRL d m n : 0 < d -> (d %| m)%Z -> (n < m %/ d)%Z = (n * d < m). +Proof. by move=> /ltr_pmul2r <- /divzK->. Qed. + +Lemma eqz_div d m n : d != 0 -> (d %| m)%Z -> (n == m %/ d)%Z = (n * d == m). +Proof. by move=> /mulIf/inj_eq <- /divzK->. Qed. + +Lemma eqz_mul d m n : d != 0 -> (d %| m)%Z -> (m == n * d) = (m %/ d == n)%Z. +Proof. by move=> d_gt0 dv_d_m; rewrite eq_sym -eqz_div // eq_sym. Qed. + +Lemma divz_mulAC d m n : (d %| m)%Z -> (m %/ d)%Z * n = (m * n %/ d)%Z. +Proof. +have [-> | d_nz] := eqVneq d 0; first by rewrite !divz0 mul0r. +by move/divzK=> {2} <-; rewrite mulrAC mulzK. +Qed. + +Lemma mulz_divA d m n : (d %| n)%Z -> m * (n %/ d)%Z = (m * n %/ d)%Z. +Proof. by move=> dv_d_m; rewrite !(mulrC m) divz_mulAC. Qed. + +Lemma mulz_divCA d m n : + (d %| m)%Z -> (d %| n)%Z -> m * (n %/ d)%Z = n * (m %/ d)%Z. +Proof. by move=> dv_d_m dv_d_n; rewrite mulrC divz_mulAC ?mulz_divA. Qed. + +Lemma divzA m n p : (p %| n -> n %| m * p -> m %/ (n %/ p)%Z = m * p %/ n)%Z. +Proof. +move/divzK=> p_dv_n; have [->|] := eqVneq n 0; first by rewrite div0z !divz0. +rewrite -{1 2}p_dv_n mulf_eq0 => /norP[pn_nz p_nz] /divzK; rewrite mulrA p_dv_n. +by move/mulIf=> {1} <- //; rewrite mulzK. +Qed. + +Lemma divzMA m n p : (n * p %| m -> m %/ (n * p) = (m %/ n)%Z %/ p)%Z. +Proof. +have [-> | nz_p] := eqVneq p 0; first by rewrite mulr0 !divz0. +have [-> | nz_n] := eqVneq n 0; first by rewrite mul0r !divz0 div0z. +by move/divzK=> {2} <-; rewrite mulrA mulrAC !mulzK. +Qed. + +Lemma divzAC m n p : (n * p %| m -> (m %/ n)%Z %/ p = (m %/ p)%Z %/ n)%Z. +Proof. by move=> np_dv_mn; rewrite -!divzMA // mulrC. Qed. + +Lemma divzMl p m d : p != 0 -> (d %| m -> p * m %/ (p * d) = m %/ d)%Z. +Proof. +have [-> | nz_d nz_p] := eqVneq d 0; first by rewrite mulr0 !divz0. +by move/divzK=> {1}<-; rewrite mulrCA mulzK ?mulf_neq0. +Qed. + +Lemma divzMr p m d : p != 0 -> (d %| m -> m * p %/ (d * p) = m %/ d)%Z. +Proof. by rewrite -!(mulrC p); apply: divzMl. Qed. + +Lemma dvdz_mul2l p d m : p != 0 -> (p * d %| p * m)%Z = (d %| m)%Z. +Proof. by rewrite !dvdzE -absz_gt0 !abszM; apply: dvdn_pmul2l. Qed. +Implicit Arguments dvdz_mul2l [p m d]. + +Lemma dvdz_mul2r p d m : p != 0 -> (d * p %| m * p)%Z = (d %| m)%Z. +Proof. by rewrite !dvdzE -absz_gt0 !abszM; apply: dvdn_pmul2r. Qed. +Implicit Arguments dvdz_mul2r [p m d]. + +Lemma dvdz_exp2l p m n : (m <= n)%N -> (p ^+ m %| p ^+ n)%Z. +Proof. by rewrite dvdzE !abszX; apply: dvdn_exp2l. Qed. + +Lemma dvdz_Pexp2l p m n : `|p| > 1 -> (p ^+ m %| p ^+ n)%Z = (m <= n)%N. +Proof. by rewrite dvdzE !abszX ltz_nat; apply: dvdn_Pexp2l. Qed. + +Lemma dvdz_exp2r m n k : (m %| n -> m ^+ k %| n ^+ k)%Z. +Proof. by rewrite !dvdzE !abszX; apply: dvdn_exp2r. Qed. + +Fact dvdz_zmod_closed d : zmod_closed (dvdz d). +Proof. +split=> [|_ _ /dvdzP[p ->] /dvdzP[q ->]]; first exact: dvdz0. +by rewrite -mulrBl dvdz_mull. +Qed. +Canonical dvdz_addPred d := AddrPred (dvdz_zmod_closed d). +Canonical dvdz_oppPred d := OpprPred (dvdz_zmod_closed d). +Canonical dvdz_zmodPred d := ZmodPred (dvdz_zmod_closed d). + +Lemma dvdz_exp k d m : (0 < k)%N -> (d %| m -> d %| m ^+ k)%Z. +Proof. by case: k => // k _ d_dv_m; rewrite exprS dvdz_mulr. Qed. + +Lemma eqz_mod_dvd d m n : (m == n %[mod d])%Z = (d %| m - n)%Z. +Proof. +apply/eqP/dvdz_mod0P=> eq_mn. + by rewrite -modzDml eq_mn modzDml subrr mod0z. +by rewrite -(subrK n m) -modzDml eq_mn add0r. +Qed. + +Lemma divzDl m n d : + (d %| m)%Z -> ((m + n) %/ d)%Z = (m %/ d)%Z + (n %/ d)%Z. +Proof. +have [-> | d_nz] := eqVneq d 0; first by rewrite !divz0. +by move/divzK=> {1}<-; rewrite divzMDl. +Qed. + +Lemma divzDr m n d : + (d %| n)%Z -> ((m + n) %/ d)%Z = (m %/ d)%Z + (n %/ d)%Z. +Proof. by move=> dv_n; rewrite addrC divzDl // addrC. Qed. + +Lemma Qint_dvdz (m d : int) : (d %| m)%Z -> ((m%:~R / d%:~R : rat) \is a Qint). +Proof. +case/dvdzP=> z ->; rewrite rmorphM /=; case: (altP (d =P 0)) => [->|dn0]. + by rewrite mulr0 mul0r. +by rewrite mulfK ?intr_eq0 // rpred_int. +Qed. + +Lemma Qnat_dvd (m d : nat) : (d %| m)%N -> ((m%:R / d%:R : rat) \is a Qnat). +Proof. +move=> h; rewrite Qnat_def divr_ge0 ?ler0n // -[m%:R]/(m%:~R) -[d%:R]/(d%:~R). +by rewrite Qint_dvdz. +Qed. + +(* Greatest common divisor *) + +Lemma gcdzz m : gcdz m m = `|m|%:Z. Proof. by rewrite /gcdz gcdnn. Qed. +Lemma gcdzC : commutative gcdz. Proof. by move=> m n; rewrite /gcdz gcdnC. Qed. +Lemma gcd0z m : gcdz 0 m = `|m|%:Z. Proof. by rewrite /gcdz gcd0n. Qed. +Lemma gcdz0 m : gcdz m 0 = `|m|%:Z. Proof. by rewrite /gcdz gcdn0. Qed. +Lemma gcd1z : left_zero 1 gcdz. Proof. by move=> m; rewrite /gcdz gcd1n. Qed. +Lemma gcdz1 : right_zero 1 gcdz. Proof. by move=> m; rewrite /gcdz gcdn1. Qed. +Lemma dvdz_gcdr m n : (gcdz m n %| n)%Z. Proof. exact: dvdn_gcdr. Qed. +Lemma dvdz_gcdl m n : (gcdz m n %| m)%Z. Proof. exact: dvdn_gcdl. Qed. +Lemma gcdz_eq0 m n : (gcdz m n == 0) = (m == 0) && (n == 0). +Proof. by rewrite -absz_eq0 eqn0Ngt gcdn_gt0 !negb_or -!eqn0Ngt !absz_eq0. Qed. +Lemma gcdNz m n : gcdz (- m) n = gcdz m n. Proof. by rewrite /gcdz abszN. Qed. +Lemma gcdzN m n : gcdz m (- n) = gcdz m n. Proof. by rewrite /gcdz abszN. Qed. + +Lemma gcdz_modr m n : gcdz m (n %% m)%Z = gcdz m n. +Proof. +rewrite -modz_abs /gcdz; move/absz: m => m. +have [-> | m_gt0] := posnP m; first by rewrite modz0. +case: n => n; first by rewrite modz_nat gcdn_modr. +rewrite modNz_nat // NegzE abszN {2}(divn_eq n m) -addnS gcdnMDl. +rewrite -addrA -opprD -intS /=; set m1 := _.+1. +have le_m1m: (m1 <= m)%N by exact: ltn_pmod. +by rewrite subzn // !(gcdnC m) -{2 3}(subnK le_m1m) gcdnDl gcdnDr gcdnC. +Qed. + +Lemma gcdz_modl m n : gcdz (m %% n)%Z n = gcdz m n. +Proof. by rewrite -!(gcdzC n) gcdz_modr. Qed. + +Lemma gcdzMDl q m n : gcdz m (q * m + n) = gcdz m n. +Proof. by rewrite -gcdz_modr modzMDl gcdz_modr. Qed. + +Lemma gcdzDl m n : gcdz m (m + n) = gcdz m n. +Proof. by rewrite -{2}(mul1r m) gcdzMDl. Qed. + +Lemma gcdzDr m n : gcdz m (n + m) = gcdz m n. +Proof. by rewrite addrC gcdzDl. Qed. + +Lemma gcdzMl n m : gcdz n (m * n) = `|n|%:Z. +Proof. by rewrite -[m * n]addr0 gcdzMDl gcdz0. Qed. + +Lemma gcdzMr n m : gcdz n (n * m) = `|n|%:Z. +Proof. by rewrite mulrC gcdzMl. Qed. + +Lemma gcdz_idPl {m n} : reflect (gcdz m n = `|m|%:Z) (m %| n)%Z. +Proof. by apply: (iffP gcdn_idPl) => [<- | []]. Qed. + +Lemma gcdz_idPr {m n} : reflect (gcdz m n = `|n|%:Z) (n %| m)%Z. +Proof. by rewrite gcdzC; apply: gcdz_idPl. Qed. + +Lemma expz_min e m n : e >= 0 -> e ^+ minn m n = gcdz (e ^+ m) (e ^+ n). +Proof. +by case: e => // e _; rewrite /gcdz !abszX -expn_min -natz -natrX !natz. +Qed. + +Lemma dvdz_gcd p m n : (p %| gcdz m n)%Z = (p %| m)%Z && (p %| n)%Z. +Proof. exact: dvdn_gcd. Qed. + +Lemma gcdzAC : right_commutative gcdz. +Proof. by move=> m n p; rewrite /gcdz gcdnAC. Qed. + +Lemma gcdzA : associative gcdz. +Proof. by move=> m n p; rewrite /gcdz gcdnA. Qed. + +Lemma gcdzCA : left_commutative gcdz. +Proof. by move=> m n p; rewrite /gcdz gcdnCA. Qed. + +Lemma gcdzACA : interchange gcdz gcdz. +Proof. by move=> m n p q; rewrite /gcdz gcdnACA. Qed. + +Lemma mulz_gcdr m n p : `|m|%:Z * gcdz n p = gcdz (m * n) (m * p). +Proof. by rewrite -PoszM muln_gcdr -!abszM. Qed. + +Lemma mulz_gcdl m n p : gcdz m n * `|p|%:Z = gcdz (m * p) (n * p). +Proof. by rewrite -PoszM muln_gcdl -!abszM. Qed. + +Lemma mulz_divCA_gcd n m : n * (m %/ gcdz n m)%Z = m * (n %/ gcdz n m)%Z. +Proof. by rewrite mulz_divCA ?dvdz_gcdl ?dvdz_gcdr. Qed. + +(* Not including lcm theory, for now. *) + +(* Coprime factors *) + +Lemma coprimezE m n : coprimez m n = coprime `|m| `|n|. Proof. by []. Qed. + +Lemma coprimez_sym : symmetric coprimez. +Proof. by move=> m n; apply: coprime_sym. Qed. + +Lemma coprimeNz m n : coprimez (- m) n = coprimez m n. +Proof. by rewrite coprimezE abszN. Qed. + +Lemma coprimezN m n : coprimez m (- n) = coprimez m n. +Proof. by rewrite coprimezE abszN. Qed. + +CoInductive egcdz_spec m n : int * int -> Type := + EgcdzSpec u v of u * m + v * n = gcdz m n & coprimez u v + : egcdz_spec m n (u, v). + +Lemma egcdzP m n : egcdz_spec m n (egcdz m n). +Proof. +rewrite /egcdz; have [-> | m_nz] := altP eqP. + by split; [rewrite -abszEsign gcd0z | rewrite coprimezE absz_sign]. +have m_gt0 : (`|m| > 0)%N by rewrite absz_gt0. +case: egcdnP (coprime_egcdn `|n| m_gt0) => //= u v Duv _ co_uv; split. + rewrite !mulNr -!mulrA mulrCA -abszEsg mulrCA -abszEsign. + by rewrite -!PoszM Duv addnC PoszD addrK. +by rewrite coprimezE abszM absz_sg m_nz mul1n mulNr abszN abszMsign. +Qed. + +Lemma Bezoutz m n : {u : int & {v : int | u * m + v * n = gcdz m n}}. +Proof. by exists (egcdz m n).1, (egcdz m n).2; case: egcdzP. Qed. + +Lemma coprimezP m n : + reflect (exists uv, uv.1 * m + uv.2 * n = 1) (coprimez m n). +Proof. +apply: (iffP eqP) => [<-| [[u v] /= Duv]]. + by exists (egcdz m n); case: egcdzP. +congr _%:Z; apply: gcdn_def; rewrite ?dvd1n // => d dv_d_n dv_d_m. +by rewrite -(dvdzE d 1) -Duv [m]intEsg [n]intEsg rpredD ?dvdz_mull. +Qed. + +Lemma Gauss_dvdz m n p : + coprimez m n -> (m * n %| p)%Z = (m %| p)%Z && (n %| p)%Z. +Proof. by move/Gauss_dvd <-; rewrite -abszM. Qed. + +Lemma Gauss_dvdzr m n p : coprimez m n -> (m %| n * p)%Z = (m %| p)%Z. +Proof. by rewrite dvdzE abszM => /Gauss_dvdr->. Qed. + +Lemma Gauss_dvdzl m n p : coprimez m p -> (m %| n * p)%Z = (m %| n)%Z. +Proof. by rewrite mulrC; apply: Gauss_dvdzr. Qed. + +Lemma Gauss_gcdzr p m n : coprimez p m -> gcdz p (m * n) = gcdz p n. +Proof. by rewrite /gcdz abszM => /Gauss_gcdr->. Qed. + +Lemma Gauss_gcdzl p m n : coprimez p n -> gcdz p (m * n) = gcdz p m. +Proof. by move=> co_pn; rewrite mulrC Gauss_gcdzr. Qed. + +Lemma coprimez_mulr p m n : coprimez p (m * n) = coprimez p m && coprimez p n. +Proof. by rewrite -coprime_mulr -abszM. Qed. + +Lemma coprimez_mull p m n : coprimez (m * n) p = coprimez m p && coprimez n p. +Proof. by rewrite -coprime_mull -abszM. Qed. + +Lemma coprimez_pexpl k m n : (0 < k)%N -> coprimez (m ^+ k) n = coprimez m n. +Proof. by rewrite /coprimez /gcdz abszX; apply: coprime_pexpl. Qed. + +Lemma coprimez_pexpr k m n : (0 < k)%N -> coprimez m (n ^+ k) = coprimez m n. +Proof. by move=> k_gt0; rewrite !(coprimez_sym m) coprimez_pexpl. Qed. + +Lemma coprimez_expl k m n : coprimez m n -> coprimez (m ^+ k) n. +Proof. by rewrite /coprimez /gcdz abszX; apply: coprime_expl. Qed. + +Lemma coprimez_expr k m n : coprimez m n -> coprimez m (n ^+ k). +Proof. by rewrite !(coprimez_sym m); apply: coprimez_expl. Qed. + +Lemma coprimez_dvdl m n p : (m %| n)%N -> coprimez n p -> coprimez m p. +Proof. exact: coprime_dvdl. Qed. + +Lemma coprimez_dvdr m n p : (m %| n)%N -> coprimez p n -> coprimez p m. +Proof. exact: coprime_dvdr. Qed. + +Lemma dvdz_pexp2r m n k : (k > 0)%N -> (m ^+ k %| n ^+ k)%Z = (m %| n)%Z. +Proof. by rewrite dvdzE !abszX; apply: dvdn_pexp2r. Qed. + +Section Chinese. + +(***********************************************************************) +(* The chinese remainder theorem *) +(***********************************************************************) + +Variables m1 m2 : int. +Hypothesis co_m12 : coprimez m1 m2. + +Lemma zchinese_remainder x y : + (x == y %[mod m1 * m2])%Z = (x == y %[mod m1])%Z && (x == y %[mod m2])%Z. +Proof. by rewrite !eqz_mod_dvd Gauss_dvdz. Qed. + +(***********************************************************************) +(* A function that solves the chinese remainder problem *) +(***********************************************************************) + +Definition zchinese r1 r2 := + r1 * m2 * (egcdz m1 m2).2 + r2 * m1 * (egcdz m1 m2).1. + +Lemma zchinese_modl r1 r2 : (zchinese r1 r2 = r1 %[mod m1])%Z. +Proof. +rewrite /zchinese; have [u v /= Duv _] := egcdzP m1 m2. +rewrite -{2}[r1]mulr1 -((gcdz _ _ =P 1) co_m12) -Duv. +by rewrite mulrDr mulrAC addrC (mulrAC r2) !mulrA !modzMDl. +Qed. + +Lemma zchinese_modr r1 r2 : (zchinese r1 r2 = r2 %[mod m2])%Z. +Proof. +rewrite /zchinese; have [u v /= Duv _] := egcdzP m1 m2. +rewrite -{2}[r2]mulr1 -((gcdz _ _ =P 1) co_m12) -Duv. +by rewrite mulrAC modzMDl mulrAC addrC mulrDr !mulrA modzMDl. +Qed. + +Lemma zchinese_mod x : (x = zchinese (x %% m1)%Z (x %% m2)%Z %[mod m1 * m2])%Z. +Proof. +apply/eqP; rewrite zchinese_remainder //. +by rewrite zchinese_modl zchinese_modr !modz_mod !eqxx. +Qed. + +End Chinese. + +Section ZpolyScale. + +Definition zcontents p := + sgz (lead_coef p) * \big[gcdn/0%N]_(i < size p) `|(p`_i)%R|%N. + +Lemma sgz_contents p : sgz (zcontents p) = sgz (lead_coef p). +Proof. +rewrite /zcontents mulrC sgzM sgz_id; set d := _%:Z. +have [-> | nz_p] := eqVneq p 0; first by rewrite lead_coef0 mulr0. +rewrite gtr0_sgz ?mul1r // ltz_nat polySpred ?big_ord_recr //= -lead_coefE. +by rewrite gcdn_gt0 orbC absz_gt0 lead_coef_eq0 nz_p. +Qed. + +Lemma zcontents_eq0 p : (zcontents p == 0) = (p == 0). +Proof. by rewrite -sgz_eq0 sgz_contents sgz_eq0 lead_coef_eq0. Qed. + +Lemma zcontents0 : zcontents 0 = 0. +Proof. by apply/eqP; rewrite zcontents_eq0. Qed. + +Lemma zcontentsZ a p : zcontents (a *: p) = a * zcontents p. +Proof. +have [-> | nz_a] := eqVneq a 0; first by rewrite scale0r mul0r zcontents0. +rewrite {2}[a]intEsg mulrCA -mulrA -PoszM big_distrr /= mulrCA mulrA -sgzM. +rewrite -lead_coefZ; congr (_ * _%:Z); rewrite size_scale //. +by apply: eq_bigr => i _; rewrite coefZ abszM. +Qed. + +Lemma zcontents_monic p : p \is monic -> zcontents p = 1. +Proof. +move=> mon_p; rewrite /zcontents polySpred ?monic_neq0 //. +by rewrite big_ord_recr /= -lead_coefE (monicP mon_p) gcdn1. +Qed. + +Lemma dvdz_contents a p : (a %| zcontents p)%Z = (p \is a polyOver (dvdz a)). +Proof. +rewrite dvdzE abszM absz_sg lead_coef_eq0. +have [-> | nz_p] := altP eqP; first by rewrite mul0n dvdn0 rpred0. +rewrite mul1n; apply/dvdn_biggcdP/(all_nthP 0)=> a_dv_p i ltip /=. + exact: (a_dv_p (Ordinal ltip)). +exact: a_dv_p. +Qed. + +Lemma map_poly_divzK a p : + p \is a polyOver (dvdz a) -> a *: map_poly (divz^~ a) p = p. +Proof. +move/polyOverP=> a_dv_p; apply/polyP=> i. +by rewrite coefZ coef_map_id0 ?div0z // mulrC divzK. +Qed. + +Lemma polyOver_dvdzP a p : + reflect (exists q, p = a *: q) (p \is a polyOver (dvdz a)). +Proof. +apply: (iffP idP) => [/map_poly_divzK | [q ->]]. + by exists (map_poly (divz^~ a) p). +by apply/polyOverP=> i; rewrite coefZ dvdz_mulr. +Qed. + +Definition zprimitive p := map_poly (divz^~ (zcontents p)) p. + +Lemma zpolyEprim p : p = zcontents p *: zprimitive p. +Proof. by rewrite map_poly_divzK // -dvdz_contents. Qed. + +Lemma zprimitive0 : zprimitive 0 = 0. +Proof. +by apply/polyP=> i; rewrite coef0 coef_map_id0 ?div0z // zcontents0 divz0. +Qed. + +Lemma zprimitive_eq0 p : (zprimitive p == 0) = (p == 0). +Proof. +apply/idP/idP=> /eqP p0; first by rewrite [p]zpolyEprim p0 scaler0. +by rewrite p0 zprimitive0. +Qed. + +Lemma size_zprimitive p : size (zprimitive p) = size p. +Proof. +have [-> | ] := eqVneq p 0; first by rewrite zprimitive0. +by rewrite {1 3}[p]zpolyEprim scale_poly_eq0 => /norP[/size_scale-> _]. +Qed. + +Lemma sgz_lead_primitive p : sgz (lead_coef (zprimitive p)) = (p != 0). +Proof. +have [-> | nz_p] := altP eqP; first by rewrite zprimitive0 lead_coef0. +apply: (@mulfI _ (sgz (zcontents p))); first by rewrite sgz_eq0 zcontents_eq0. +by rewrite -sgzM mulr1 -lead_coefZ -zpolyEprim sgz_contents. +Qed. + +Lemma zcontents_primitive p : zcontents (zprimitive p) = (p != 0). +Proof. +have [-> | nz_p] := altP eqP; first by rewrite zprimitive0 zcontents0. +apply: (@mulfI _ (zcontents p)); first by rewrite zcontents_eq0. +by rewrite mulr1 -zcontentsZ -zpolyEprim. +Qed. + +Lemma zprimitive_id p : zprimitive (zprimitive p) = zprimitive p. +Proof. +have [-> | nz_p] := eqVneq p 0; first by rewrite !zprimitive0. +by rewrite {2}[zprimitive p]zpolyEprim zcontents_primitive nz_p scale1r. +Qed. + +Lemma zprimitive_monic p : p \in monic -> zprimitive p = p. +Proof. by move=> mon_p; rewrite {2}[p]zpolyEprim zcontents_monic ?scale1r. Qed. + +Lemma zprimitiveZ a p : a != 0 -> zprimitive (a *: p) = zprimitive p. +Proof. +have [-> | nz_p nz_a] := eqVneq p 0; first by rewrite scaler0. +apply: (@mulfI _ (a * zcontents p)%:P). + by rewrite polyC_eq0 mulf_neq0 ?zcontents_eq0. +by rewrite -{1}zcontentsZ !mul_polyC -zpolyEprim -scalerA -zpolyEprim. +Qed. + +Lemma zprimitive_min p a q : + p != 0 -> p = a *: q -> + {b | sgz b = sgz (lead_coef q) & q = b *: zprimitive p}. +Proof. +move=> nz_p Dp; have /dvdzP/sig_eqW[b Db]: (a %| zcontents p)%Z. + by rewrite dvdz_contents; apply/polyOver_dvdzP; exists q. +suffices ->: q = b *: zprimitive p. + by rewrite lead_coefZ sgzM sgz_lead_primitive nz_p mulr1; exists b. +apply: (@mulfI _ a%:P). + by apply: contraNneq nz_p; rewrite Dp -mul_polyC => ->; rewrite mul0r. +by rewrite !mul_polyC -Dp scalerA mulrC -Db -zpolyEprim. +Qed. + +Lemma zprimitive_irr p a q : + p != 0 -> zprimitive p = a *: q -> a = sgz (lead_coef q). +Proof. +move=> nz_p Dp; have: p = (a * zcontents p) *: q. + by rewrite mulrC -scalerA -Dp -zpolyEprim. +case/zprimitive_min=> // b <- /eqP. +rewrite Dp -{1}[q]scale1r scalerA -subr_eq0 -scalerBl scale_poly_eq0 subr_eq0. +have{Dp} /negPf->: q != 0. + by apply: contraNneq nz_p; rewrite -zprimitive_eq0 Dp => ->; rewrite scaler0. +by case: b a => [[|[|b]] | [|b]] [[|[|a]] | [|a]] //; rewrite mulr0. +Qed. + +Lemma zcontentsM p q : zcontents (p * q) = zcontents p * zcontents q. +Proof. +have [-> | nz_p] := eqVneq p 0; first by rewrite !(mul0r, zcontents0). +have [-> | nz_q] := eqVneq q 0; first by rewrite !(mulr0, zcontents0). +rewrite -[zcontents q]mulr1 {1}[p]zpolyEprim {1}[q]zpolyEprim. +rewrite -scalerAl -scalerAr !zcontentsZ; congr (_ * (_ * _)). +rewrite [zcontents _]intEsg sgz_contents lead_coefM sgzM !sgz_lead_primitive. +apply/eqP; rewrite nz_p nz_q !mul1r [_ == _]eqn_leq absz_gt0 zcontents_eq0. +rewrite mulf_neq0 ?zprimitive_eq0 // andbT leqNgt. +apply/negP=> /pdivP[r r_pr r_dv_d]; pose to_r : int -> 'F_r := intr. +have nz_prim_r q1: q1 != 0 -> map_poly to_r (zprimitive q1) != 0. + move=> nz_q1; apply: contraTneq (prime_gt1 r_pr) => r_dv_q1. + rewrite -leqNgt dvdn_leq // -(dvdzE r true) -nz_q1 -zcontents_primitive. + rewrite dvdz_contents; apply/polyOverP=> i /=; rewrite dvdzE /=. + have /polyP/(_ i)/eqP := r_dv_q1; rewrite coef_map coef0 /=. + rewrite {1}[_`_i]intEsign rmorphM rmorph_sign /= mulf_eq0 signr_eq0 /=. + by rewrite -val_eqE /= val_Fp_nat. +suffices{nz_prim_r} /idPn[]: map_poly to_r (zprimitive p * zprimitive q) == 0. + by rewrite rmorphM mulf_neq0 ?nz_prim_r. +rewrite [_ * _]zpolyEprim [zcontents _]intEsign mulrC -scalerA map_polyZ /=. +by rewrite scale_poly_eq0 -val_eqE /= val_Fp_nat ?(eqnP r_dv_d). +Qed. + + +Lemma zprimitiveM p q : zprimitive (p * q) = zprimitive p * zprimitive q. +Proof. +have [pq_0|] := eqVneq (p * q) 0. + rewrite pq_0; move/eqP: pq_0; rewrite mulf_eq0. + by case/pred2P=> ->; rewrite !zprimitive0 (mul0r, mulr0). +rewrite -zcontents_eq0 -polyC_eq0 => /mulfI; apply; rewrite !mul_polyC. +by rewrite -zpolyEprim zcontentsM -scalerA scalerAr scalerAl -!zpolyEprim. +Qed. + +Lemma dvdpP_int p q : p %| q -> {r | q = zprimitive p * r}. +Proof. +case/Pdiv.Idomain.dvdpP/sig2_eqW=> [[c r] /= nz_c Dpr]. +exists (zcontents q *: zprimitive r); rewrite -scalerAr. +by rewrite -zprimitiveM mulrC -Dpr zprimitiveZ // -zpolyEprim. +Qed. + +Local Notation pZtoQ := (map_poly (intr : int -> rat)). + +Lemma size_rat_int_poly p : size (pZtoQ p) = size p. +Proof. by apply: size_map_inj_poly; first exact: intr_inj. Qed. + +Lemma rat_poly_scale (p : {poly rat}) : + {q : {poly int} & {a | a != 0 & p = a%:~R^-1 *: pZtoQ q}}. +Proof. +pose a := \prod_(i < size p) denq p`_i. +have nz_a: a != 0 by apply/prodf_neq0=> i _; exact: denq_neq0. +exists (map_poly numq (a%:~R *: p)), a => //. +apply: canRL (scalerK _) _; rewrite ?intr_eq0 //. +apply/polyP=> i; rewrite !(coefZ, coef_map_id0) // numqK // Qint_def mulrC. +have [ltip | /(nth_default 0)->] := ltnP i (size p); last by rewrite mul0r. +by rewrite [a](bigD1 (Ordinal ltip)) // rmorphM mulrA -numqE -rmorphM denq_int. +Qed. + +Lemma dvdp_rat_int p q : (pZtoQ p %| pZtoQ q) = (p %| q). +Proof. +apply/dvdpP/Pdiv.Idomain.dvdpP=> [[/= r1 Dq] | [[/= a r] nz_a Dq]]; last first. + exists (a%:~R^-1 *: pZtoQ r); rewrite -scalerAl -rmorphM -Dq. + by rewrite -{2}[a]intz scaler_int rmorphMz -scaler_int scalerK ?intr_eq0. +have [r [a nz_a Dr1]] := rat_poly_scale r1; exists (a, r) => //=. +apply: (map_inj_poly _ _ : injective pZtoQ) => //; first exact: intr_inj. +rewrite -[a]intz scaler_int rmorphMz -scaler_int /= Dq Dr1. +by rewrite -scalerAl -rmorphM scalerKV ?intr_eq0. +Qed. + +Lemma dvdpP_rat_int p q : + p %| pZtoQ q -> + {p1 : {poly int} & {a | a != 0 & p = a *: pZtoQ p1} & {r | q = p1 * r}}. +Proof. +have{p} [p [a nz_a ->]] := rat_poly_scale p. +rewrite dvdp_scalel ?invr_eq0 ?intr_eq0 // dvdp_rat_int => dv_p_q. +exists (zprimitive p); last exact: dvdpP_int. +have [-> | nz_p] := eqVneq p 0. + by exists 1; rewrite ?oner_eq0 // zprimitive0 map_poly0 !scaler0. +exists ((zcontents p)%:~R / a%:~R). + by rewrite mulf_neq0 ?invr_eq0 ?intr_eq0 ?zcontents_eq0. +by rewrite mulrC -scalerA -map_polyZ -zpolyEprim. +Qed. + +End ZpolyScale. + +(* Integral spans. *) + +Lemma int_Smith_normal_form m n (M : 'M[int]_(m, n)) : + {L : 'M[int]_m & L \in unitmx & + {R : 'M[int]_n & R \in unitmx & + {d : seq int | sorted dvdz d & + M = L *m (\matrix_(i, j) (d`_i *+ (i == j :> nat))) *m R}}}. +Proof. +move: {2}_.+1 (ltnSn (m + n)) => mn. +elim: mn => // mn IHmn in m n M *; rewrite ltnS => le_mn. +have [[i j] nzMij | no_ij] := pickP (fun k => M k.1 k.2 != 0%N); last first. + do 2![exists 1%:M; first exact: unitmx1]; exists nil => //=. + apply/matrixP=> i j; apply/eqP; rewrite mulmx1 mul1mx mxE nth_nil mul0rn. + exact: negbFE (no_ij (i, j)). +do [case: m i => [[]//|m] i; case: n j => [[]//|n] j /=] in M nzMij le_mn *. +wlog Dj: j M nzMij / j = 0; last rewrite {j}Dj in nzMij. + case/(_ 0 (xcol j 0 M)); rewrite ?mxE ?tpermR // => L uL [R uR [d dvD dM]]. + exists L => //; exists (xcol j 0 R); last exists d => //=. + by rewrite xcolE unitmx_mul uR unitmx_perm. + by rewrite xcolE !mulmxA -dM xcolE -mulmxA -perm_mxM tperm2 perm_mx1 mulmx1. +move Da: (M i 0) nzMij => a nz_a. +elim: {a}_.+1 {-2}a (ltnSn `|a|) => // A IHa a leA in m n M i Da nz_a le_mn *. +wlog [j a'Mij]: m n M i Da le_mn / {j | ~~ (a %| M i j)%Z}; last first. + have nz_j: j != 0 by apply: contraNneq a'Mij => ->; rewrite Da. + case: n => [[[]//]|n] in j le_mn nz_j M a'Mij Da *. + wlog{nz_j} Dj: j M a'Mij Da / j = 1; last rewrite {j}Dj in a'Mij. + case/(_ 1 (xcol j 1 M)); rewrite ?mxE ?tpermR ?tpermD //. + move=> L uL [R uR [d dvD dM]]; exists L => //. + exists (xcol j 1 R); first by rewrite xcolE unitmx_mul uR unitmx_perm. + exists d; rewrite //= xcolE !mulmxA -dM xcolE -mulmxA -perm_mxM tperm2. + by rewrite perm_mx1 mulmx1. + have [u [v]] := Bezoutz a (M i 1); set b := gcdz _ _ => Db. + have{leA} ltA: (`|b| < A)%N. + rewrite -ltnS (leq_trans _ leA) // ltnS ltn_neqAle andbC. + rewrite dvdn_leq ?absz_gt0 ? dvdn_gcdl //=. + by rewrite (contraNneq _ a'Mij) ?dvdzE // => <-; exact: dvdn_gcdr. + pose t2 := [fun j : 'I_2 => [tuple _; _]`_j : int]; pose a1 := M i 1. + pose Uul := \matrix_(k, j) t2 (t2 u (- (a1 %/ b)%Z) j) (t2 v (a %/ b)%Z j) k. + pose U : 'M_(2 + n) := block_mx Uul 0 0 1%:M; pose M1 := M *m U. + have{nz_a} nz_b: b != 0 by rewrite gcdz_eq0 (negPf nz_a). + have uU: U \in unitmx. + rewrite unitmxE det_ublock det1 (expand_det_col _ 0) big_ord_recl big_ord1. + do 2!rewrite /cofactor [row' _ _]mx11_scalar !mxE det_scalar1 /=. + rewrite mulr1 mul1r mulN1r opprK -[_ + _](mulzK _ nz_b) mulrDl. + by rewrite -!mulrA !divzK ?dvdz_gcdl ?dvdz_gcdr // Db divzz nz_b unitr1. + have{Db} Db: M1 i 0 = b. + rewrite /M1 -(lshift0 n 1) [U]block_mxEh mul_mx_row row_mxEl. + rewrite -[M](@hsubmxK _ _ 2) (@mul_row_col _ _ 2) mulmx0 addr0 !mxE /=. + rewrite big_ord_recl big_ord1 !mxE /= [lshift _ _]((_ =P 0) _) // Da. + by rewrite [lshift _ _]((_ =P 1) _) // mulrC -(mulrC v). + have [L uL [R uR [d dvD dM1]]] := IHa b ltA _ _ M1 i Db nz_b le_mn. + exists L => //; exists (R *m invmx U); last exists d => //. + by rewrite unitmx_mul uR unitmx_inv. + by rewrite mulmxA -dM1 mulmxK. +move=> {A leA IHa} IHa; wlog Di: i M Da / i = 0; last rewrite {i}Di in Da. + case/(_ 0 (xrow i 0 M)); rewrite ?mxE ?tpermR // => L uL [R uR [d dvD dM]]. + exists (xrow i 0 L); first by rewrite xrowE unitmx_mul unitmx_perm. + exists R => //; exists d; rewrite //= xrowE -!mulmxA (mulmxA L) -dM xrowE. + by rewrite mulmxA -perm_mxM tperm2 perm_mx1 mul1mx. +without loss /forallP a_dvM0: / [forall j, a %| M 0 j]%Z. + have [_|] := altP forallP; first exact; rewrite negb_forall => /existsP/sigW. + by move/IHa=> IH _; apply: IH. +without loss{Da a_dvM0} Da: M / forall j, M 0 j = a. + pose Uur := col' 0 (\row_j (1 - (M 0 j %/ a)%Z)). + pose U : 'M_(1 + n) := block_mx 1 Uur 0 1%:M; pose M1 := M *m U. + have uU: U \in unitmx by rewrite unitmxE det_ublock !det1 mulr1. + case/(_ (M *m U)) => [j | L uL [R uR [d dvD dM]]]. + rewrite -(lshift0 m 0) -[M](@submxK _ 1 _ 1) (@mulmx_block _ 1 m 1). + rewrite (@col_mxEu _ 1) !mulmx1 mulmx0 addr0 [ulsubmx _]mx11_scalar. + rewrite mul_scalar_mx !mxE !lshift0 Da. + case: splitP => [j0 _ | j1 Dj]; rewrite ?ord1 !mxE // lshift0 rshift1. + by rewrite mulrBr mulr1 mulrC divzK ?subrK. + exists L => //; exists (R * U^-1); first by rewrite unitmx_mul uR unitmx_inv. + by exists d; rewrite //= mulmxA -dM mulmxK. +without loss{IHa} /forallP/(_ (_, _))/= a_dvM: / [forall k, a %| M k.1 k.2]%Z. + have [_|] := altP forallP; first exact; rewrite negb_forall => /existsP/sigW. + case=> [[i j] /= a'Mij] _. + have [|||L uL [R uR [d dvD dM]]] := IHa _ _ M^T j; rewrite ?mxE 1?addnC //. + by exists i; rewrite mxE. + exists R^T; last exists L^T; rewrite ?unitmx_tr //; exists d => //. + rewrite -[M]trmxK dM !trmx_mul mulmxA; congr (_ *m _ *m _). + by apply/matrixP=> i1 j1; rewrite !mxE eq_sym; case: eqP => // ->. +without loss{nz_a a_dvM} a1: M a Da / a = 1. + pose M1 := map_mx (divz^~ a) M; case/(_ M1 1)=> // [k|L uL [R uR [d dvD dM]]]. + by rewrite !mxE Da divzz nz_a. + exists L => //; exists R => //; exists [seq a * x | x <- d]. + case: d dvD {dM} => //= x d; elim: d x => //= y d IHd x /andP[dv_xy /IHd]. + by rewrite [dvdz _ _]dvdz_mul2l ?[_ \in _]dv_xy. + have ->: M = a *: M1 by apply/matrixP=> i j; rewrite !mxE mulrC divzK ?a_dvM. + rewrite dM scalemxAl scalemxAr; congr (_ *m _ *m _). + apply/matrixP=> i j; rewrite !mxE mulrnAr; congr (_ *+ _). + have [lt_i_d | le_d_i] := ltnP i (size d); first by rewrite (nth_map 0). + by rewrite !nth_default ?size_map ?mulr0. +rewrite {a}a1 -[m.+1]/(1 + m)%N -[n.+1]/(1 + n)%N in M Da *. +pose Mu := ursubmx M; pose Ml := dlsubmx M. +have{Da} Da: ulsubmx M = 1 by rewrite [_ M]mx11_scalar !mxE !lshift0 Da. +pose M1 := - (Ml *m Mu) + drsubmx M. +have [|L uL [R uR [d dvD dM1]]] := IHmn m n M1; first by rewrite -addnS ltnW. +exists (block_mx 1 0 Ml L). + by rewrite unitmxE det_lblock det_scalar1 mul1r. +exists (block_mx 1 Mu 0 R). + by rewrite unitmxE det_ublock det_scalar1 mul1r. +exists (1 :: d); set D1 := \matrix_(i, j) _ in dM1. + by rewrite /= path_min_sorted // => g _; exact: dvd1n. +rewrite [D in _ *m D *m _](_ : _ = block_mx 1 0 0 D1); last first. + by apply/matrixP=> i j; do 3?[rewrite ?mxE ?ord1 //=; case: splitP => ? ->]. +rewrite !mulmx_block !(mul0mx, mulmx0, addr0) !mulmx1 add0r mul1mx -Da -dM1. +by rewrite addNKr submxK. +Qed. + +Definition inIntSpan (V : zmodType) m (s : m.-tuple V) v := + exists a : int ^ m, v = \sum_(i < m) s`_i *~ a i. + +Lemma dec_Qint_span (vT : vectType rat) m (s : m.-tuple vT) v : + decidable (inIntSpan s v). +Proof. +have s_s (i : 'I_m): s`_i \in <>%VS by rewrite memv_span ?memt_nth. +have s_Zs a: \sum_(i < m) s`_i *~ a i \in <>%VS. + by rewrite memv_suml // => i _; rewrite -scaler_int memvZ. +case s_v: (v \in <>%VS); last by right=> [[a Dv]]; rewrite Dv s_Zs in s_v. +pose S := \matrix_(i < m, j < _) coord (vbasis <>) j s`_i. +pose r := \rank S; pose k := (m - r)%N; pose Em := erefl m; pose Ek := erefl k. +have Dm: (m = k + r)%N by rewrite subnK ?rank_leq_row. +have [K kerK]: {K : 'M_(k, m) | map_mx intr K == kermx S}%MS. + pose B := row_base (kermx S); pose d := \prod_ij denq (B ij.1 ij.2). + exists (castmx (mxrank_ker S, Em) (map_mx numq (intr d *: B))). + rewrite /k; case: _ / (mxrank_ker S); set B1 := map_mx _ _. + have ->: B1 = (intr d *: B). + apply/matrixP=> i j; rewrite 3!mxE mulrC [d](bigD1 (i, j)) // rmorphM mulrA. + by rewrite -numqE -rmorphM numq_int. + suffices nz_d: d%:Q != 0 by rewrite !eqmx_scale // !eq_row_base andbb. + by rewrite intr_eq0; apply/prodf_neq0 => i _; exact: denq_neq0. +have [L _ [G uG [D _ defK]]] := int_Smith_normal_form K. +pose Gud := castmx (Dm, Em) G; pose G'lr := castmx (Em, Dm) (invmx G). +have{K L D defK kerK} kerGu: map_mx intr (usubmx Gud) *m S = 0. + pose Kl : 'M[rat]_k:= map_mx intr (lsubmx (castmx (Ek, Dm) (K *m invmx G))). + have{defK} defK: map_mx intr K = row_mx Kl 0 *m map_mx intr Gud. + rewrite -[K](mulmxKV uG) -{2}[G](castmxK Dm Em) -/Gud. + rewrite -[K *m _](castmxK Ek Dm) map_mxM map_castmx. + rewrite -(hsubmxK (castmx _ _)) map_row_mx -/Kl map_castmx /Em. + set Kr := map_mx _ _; case: _ / (esym Dm) (map_mx _ _) => /= GudQ. + congr (row_mx _ _ *m _); apply/matrixP=> i j; rewrite !mxE defK mulmxK //=. + rewrite castmxE mxE big1 //= => j1 _; rewrite mxE /= eqn_leq andbC. + by rewrite leqNgt (leq_trans (valP j1)) ?mulr0 ?leq_addr. + have /row_full_inj: row_full Kl; last apply. + rewrite /row_full eqn_leq rank_leq_row /= -{1}[k](mxrank_ker S). + rewrite -(eqmxP kerK) defK map_castmx mxrankMfree; last first. + case: _ / (Dm); apply/row_freeP; exists (map_mx intr (invmx G)). + by rewrite -map_mxM mulmxV ?map_mx1. + by rewrite -mxrank_tr tr_row_mx trmx0 -addsmxE addsmx0 mxrank_tr. + rewrite mulmx0 mulmxA (sub_kermxP _) // -(eqmxP kerK) defK. + by rewrite -{2}[Gud]vsubmxK map_col_mx mul_row_col mul0mx addr0. +pose T := map_mx intr (dsubmx Gud) *m S. +have{kerGu} defS: map_mx intr (rsubmx G'lr) *m T = S. + have: G'lr *m Gud = 1%:M by rewrite /G'lr /Gud; case: _ / (Dm); exact: mulVmx. + rewrite -{1}[G'lr]hsubmxK -[Gud]vsubmxK mulmxA mul_row_col -map_mxM. + move/(canRL (addKr _))->; rewrite -mulNmx raddfD /= map_mx1 map_mxM /=. + by rewrite mulmxDl -mulmxA kerGu mulmx0 add0r mul1mx. +pose vv := \row_j coord (vbasis <>) j v. +have uS: row_full S. + apply/row_fullP; exists (\matrix_(i, j) coord s j (vbasis <>)`_i). + apply/matrixP=> j1 j2; rewrite !mxE. + rewrite -(coord_free _ _ (basis_free (vbasisP _))). + rewrite -!tnth_nth (coord_span (vbasis_mem (mem_tnth j1 _))) linear_sum. + by apply: eq_bigr => i _; rewrite !mxE (tnth_nth 0) !linearZ. +have eqST: (S :=: T)%MS by apply/eqmxP; rewrite -{1}defS !submxMl. +case Zv: (map_mx denq (vv *m pinvmx T) == const_mx 1). + pose a := map_mx numq (vv *m pinvmx T) *m dsubmx Gud. + left; exists [ffun j => a 0 j]. + transitivity (\sum_j (map_mx intr a *m S) 0 j *: (vbasis <>)`_j). + rewrite {1}(coord_vbasis s_v); apply: eq_bigr => j _; congr (_ *: _). + have ->: map_mx intr a = vv *m pinvmx T *m map_mx intr (dsubmx Gud). + rewrite map_mxM /=; congr (_ *m _); apply/rowP=> i; rewrite 2!mxE numqE. + by have /eqP/rowP/(_ i) := Zv; rewrite !mxE => ->; rewrite mulr1. + by rewrite -(mulmxA _ _ S) mulmxKpV ?mxE // -eqST submx_full. + rewrite (coord_vbasis (s_Zs _)); apply: eq_bigr => j _; congr (_ *: _). + rewrite linear_sum mxE; apply: eq_bigr => i _. + by rewrite -scaler_int linearZ [a]lock !mxE ffunE. +right=> [[a Dv]]; case/eqP: Zv; apply/rowP. +have ->: vv = map_mx intr (\row_i a i) *m S. + apply/rowP=> j; rewrite !mxE Dv linear_sum. + by apply: eq_bigr => i _; rewrite -scaler_int linearZ !mxE. +rewrite -defS -2!mulmxA; have ->: T *m pinvmx T = 1%:M. + have uT: row_free T by rewrite /row_free -eqST. + by apply: (row_free_inj uT); rewrite mul1mx mulmxKpV. +by move=> i; rewrite mulmx1 -map_mxM 2!mxE denq_int mxE. +Qed. + diff --git a/mathcomp/algebra/interval.v b/mathcomp/algebra/interval.v new file mode 100644 index 0000000..1f59ce2 --- /dev/null +++ b/mathcomp/algebra/interval.v @@ -0,0 +1,403 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div choice fintype. +Require Import bigop ssralg finset fingroup zmodp ssrint ssrnum. + +(*****************************************************************************) +(* This file provide support for intervals in numerical and real domains. *) +(* The datatype (interval R) gives a formal characterization of an *) +(* interval, as the pair of its right and left bounds. *) +(* interval R == the type of formal intervals on R. *) +(* x \in i == when i is a formal interval on a numeric domain, *) +(* \in can be used to test membership. *) +(* itvP x_in_i == where x_in_i has type x \in i, if i is ground, *) +(* gives a set of rewrite rules that x_in_i imply. *) +(* x <= y ?< if c == x is smaller than y, and strictly if c is true *) +(* *) +(* We provide a set of notations to write intervals (see below) *) +(* `[a, b], `]a, b], ..., `]-oo, a], ..., `]-oo, +oo[ *) +(* We also provide the lemma subitvP which computes the inequalities one *) +(* needs to prove when trying to prove the inclusion of intervals. *) +(* *) +(* Remark that we cannot implement a boolean comparison test for intervals *) +(* on an arbitrary numeric domains, for this problem might be undecidable. *) +(* Note also that type (interval R) may contain several inhabitants coding *) +(* for the same interval. However, this pathological issues do nor arise *) +(* when R is a real domain: we could provide a specific theory for this *) +(* important case. *) +(* *) +(* See also "Formal proofs in real algebraic geometry: from ordered fields *) +(* to quantifier elimination", LMCS journal, 2012 *) +(* by Cyril Cohen and Assia Mahboubi *) +(* *) +(* And "Formalized algebraic numbers: construction and first-order theory" *) +(* Cyril Cohen, PhD, 2012, section 4.3. *) +(*****************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope ring_scope. +Import GRing.Theory Num.Theory. + +Local Notation mid x y := ((x + y) / 2%:R). + +Section IntervalPo. + +CoInductive itv_bound (T : Type) : Type := BOpen_if of bool & T | BInfty. +Notation BOpen := (BOpen_if true). +Notation BClose := (BOpen_if false). +CoInductive interval (T : Type) := Interval of itv_bound T & itv_bound T. + +Variable (R : numDomainType). + +Definition pred_of_itv (i : interval R) : pred R := + [pred x | let: Interval l u := i in + match l with + | BOpen a => a < x + | BClose a => a <= x + | BInfty => true + end && + match u with + | BOpen b => x < b + | BClose b => x <= b + | BInfty => true + end]. +Canonical Structure itvPredType := Eval hnf in mkPredType pred_of_itv. + +(* We provide the 9 following notations to help writing formal intervals *) +Notation "`[ a , b ]" := (Interval (BClose a) (BClose b)) + (at level 0, a, b at level 9 , format "`[ a , b ]") : ring_scope. +Notation "`] a , b ]" := (Interval (BOpen a) (BClose b)) + (at level 0, a, b at level 9 , format "`] a , b ]") : ring_scope. +Notation "`[ a , b [" := (Interval (BClose a) (BOpen b)) + (at level 0, a, b at level 9 , format "`[ a , b [") : ring_scope. +Notation "`] a , b [" := (Interval (BOpen a) (BOpen b)) + (at level 0, a, b at level 9 , format "`] a , b [") : ring_scope. +Notation "`] '-oo' , b ]" := (Interval (BInfty _) (BClose b)) + (at level 0, b at level 9 , format "`] '-oo' , b ]") : ring_scope. +Notation "`] '-oo' , b [" := (Interval (BInfty _) (BOpen b)) + (at level 0, b at level 9 , format "`] '-oo' , b [") : ring_scope. +Notation "`[ a , '+oo' [" := (Interval (BClose a) (BInfty _)) + (at level 0, a at level 9 , format "`[ a , '+oo' [") : ring_scope. +Notation "`] a , '+oo' [" := (Interval (BOpen a) (BInfty _)) + (at level 0, a at level 9 , format "`] a , '+oo' [") : ring_scope. +Notation "`] -oo , '+oo' [" := (Interval (BInfty _) (BInfty _)) + (at level 0, format "`] -oo , '+oo' [") : ring_scope. + +(* we compute a set of rewrite rules associated to an interval *) +Definition itv_rewrite (i : interval R) x : Type := + let: Interval l u := i in + (match l with + | BClose a => (a <= x) * (x < a = false) + | BOpen a => (a <= x) * (a < x) * (x <= a = false) + | BInfty => forall x : R, x == x + end * + match u with + | BClose b => (x <= b) * (b < x = false) + | BOpen b => (x <= b) * (x < b) * (b <= x = false) + | BInfty => forall x : R, x == x + end * + match l, u with + | BClose a, BClose b => + (a <= b) * (b < a = false) * (a \in `[a, b]) * (b \in `[a, b]) + | BClose a, BOpen b => + (a <= b) * (a < b) * (b <= a = false) + * (a \in `[a, b]) * (a \in `[a, b[)* (b \in `[a, b]) * (b \in `]a, b]) + | BOpen a, BClose b => + (a <= b) * (a < b) * (b <= a = false) + * (a \in `[a, b]) * (a \in `[a, b[)* (b \in `[a, b]) * (b \in `]a, b]) + | BOpen a, BOpen b => + (a <= b) * (a < b) * (b <= a = false) + * (a \in `[a, b]) * (a \in `[a, b[)* (b \in `[a, b]) * (b \in `]a, b]) + | _, _ => forall x : R, x == x + end)%type. + +Definition itv_decompose (i : interval R) x : Prop := + let: Interval l u := i in + ((match l with + | BClose a => (a <= x) : Prop + | BOpen a => (a < x) : Prop + | BInfty => True + end : Prop) * + (match u with + | BClose b => (x <= b) : Prop + | BOpen b => (x < b) : Prop + | BInfty => True + end : Prop))%type. + +Lemma itv_dec : forall (x : R) (i : interval R), + reflect (itv_decompose i x) (x \in i). +Proof. by move=> x [[[] a|] [[] b|]]; apply: (iffP andP); case. Qed. + +Implicit Arguments itv_dec [x i]. + +Definition lersif (x y : R) b := if b then x < y else x <= y. + +Local Notation "x <= y ?< 'if' b" := (lersif x y b) + (at level 70, y at next level, + format "x '[hv' <= y '/' ?< 'if' b ']'") : ring_scope. + +Lemma lersifxx x b: (x <= x ?< if b) = ~~ b. +Proof. by case: b; rewrite /= lterr. Qed. + +Lemma lersif_trans x y z b1 b2 : + x <= y ?< if b1 -> y <= z ?< if b2 -> x <= z ?< if b1 || b2. +Proof. +move: b1 b2 => [] [] //=; +by [exact: ler_trans|exact: ler_lt_trans|exact: ltr_le_trans|exact: ltr_trans]. +Qed. + +Lemma lersifW b x y : x <= y ?< if b -> x <= y. +Proof. by case: b => //; move/ltrW. Qed. + +Lemma lersifNF x y b : y <= x ?< if ~~ b -> x <= y ?< if b = false. +Proof. by case: b => /= [/ler_gtF|/ltr_geF]. Qed. + +Lemma lersifS x y b : x < y -> x <= y ?< if b. +Proof. by case: b => //= /ltrW. Qed. + +Lemma lersifT x y : x <= y ?< if true = (x < y). Proof. by []. Qed. + +Lemma lersifF x y : x <= y ?< if false = (x <= y). Proof. by []. Qed. + +Definition le_boundl b1 b2 := + match b1, b2 with + | BOpen_if b1 x1, BOpen_if b2 x2 => x1 <= x2 ?< if (~~ b2 && b1) + | BOpen_if _ _, BInfty => false + | _, _ => true + end. + +Definition le_boundr b1 b2 := + match b1, b2 with + | BOpen_if b1 x1, BOpen_if b2 x2 => x1 <= x2 ?< if (~~ b1 && b2) + | BInfty, BOpen_if _ _ => false + | _, _ => true + end. + +Lemma itv_boundlr bl br x : + (x \in Interval bl br) = + (le_boundl bl (BClose x)) && (le_boundr (BClose x) br). +Proof. by move: bl br => [[] a|] [[] b|]. Qed. + +Lemma le_boundr_refl : reflexive le_boundr. +Proof. by move=> [[] b|]; rewrite /le_boundr /= ?lerr. Qed. + +Hint Resolve le_boundr_refl. + +Lemma le_boundl_refl : reflexive le_boundl. +Proof. by move=> [[] b|]; rewrite /le_boundl /= ?lerr. Qed. + +Hint Resolve le_boundl_refl. + +Lemma le_boundl_bb x b1 b2 : + le_boundl (BOpen_if b1 x) (BOpen_if b2 x) = (b1 ==> b2). +Proof. by rewrite /le_boundl lersifxx andbC negb_and negbK implybE. Qed. + +Lemma le_boundr_bb x b1 b2 : + le_boundr (BOpen_if b1 x) (BOpen_if b2 x) = (b2 ==> b1). +Proof. by rewrite /le_boundr lersifxx andbC negb_and negbK implybE. Qed. + +Lemma itv_xx x bl br : + Interval (BOpen_if bl x) (BOpen_if br x) =i + if ~~ (bl || br) then pred1 x else pred0. +Proof. +by move: bl br => [] [] y /=; rewrite !inE 1?eq_sym (eqr_le, lter_anti). +Qed. + +Lemma itv_gte ba xa bb xb : xb <= xa ?< if ~~ (ba || bb) + -> Interval (BOpen_if ba xa) (BOpen_if bb xb) =i pred0. +Proof. +move=> hx y; rewrite itv_boundlr inE /=. +by apply/negP => /andP [] /lersif_trans hy /hy {hy}; rewrite lersifNF. +Qed. + +Lemma boundl_in_itv : forall ba xa b, + xa \in Interval (BOpen_if ba xa) b = + if ba then false else le_boundr (BClose xa) b. +Proof. by move=> [] xa [[] xb|] //=; rewrite inE lterr. Qed. + +Lemma boundr_in_itv : forall bb xb a, + xb \in Interval a (BOpen_if bb xb) = + if bb then false else le_boundl a (BClose xb). +Proof. by move=> [] xb [[] xa|] //=; rewrite inE lterr ?andbT ?andbF. Qed. + +Definition bound_in_itv := (boundl_in_itv, boundr_in_itv). + +Lemma itvP : forall (x : R) (i : interval R), (x \in i) -> itv_rewrite i x. +Proof. +move=> x [[[] a|] [[] b|]]; move/itv_dec=> //= [hl hu];do ?[split=> //; + do ?[by rewrite ltrW | by rewrite ltrWN | by rewrite ltrNW | + by rewrite (ltr_geF, ler_gtF)]]; + rewrite ?(bound_in_itv) /le_boundl /le_boundr //=; do ? + [ by rewrite (@ler_trans _ x) + | by rewrite 1?ltrW // (@ltr_le_trans _ x) + | by rewrite 1?ltrW // (@ler_lt_trans _ x) // 1?ltrW + | by apply: negbTE; rewrite ler_gtF // (@ler_trans _ x) + | by apply: negbTE; rewrite ltr_geF // (@ltr_le_trans _ x) // 1?ltrW + | by apply: negbTE; rewrite ltr_geF // (@ler_lt_trans _ x)]. +Qed. + +Hint Rewrite intP. +Implicit Arguments itvP [x i]. + +Definition subitv (i1 i2 : interval R) := + match i1, i2 with + | Interval a1 b1, Interval a2 b2 => le_boundl a2 a1 && le_boundr b1 b2 + end. + +Lemma subitvP : forall (i2 i1 : interval R), + (subitv i1 i2) -> {subset i1 <= i2}. +Proof. +by move=> [[[] a2|] [[] b2|]] [[[] a1|] [[] b1|]]; + rewrite /subitv //; case/andP=> /= ha hb; move=> x hx; rewrite ?inE; + rewrite ?(ler_trans ha) ?(ler_lt_trans ha) ?(ltr_le_trans ha) //; + rewrite ?(ler_trans _ hb) ?(ltr_le_trans _ hb) ?(ler_lt_trans _ hb) //; + rewrite ?(itvP hx) //. +Qed. + +Lemma subitvPr : forall (a b1 b2 : itv_bound R), + le_boundr b1 b2 -> {subset (Interval a b1) <= (Interval a b2)}. +Proof. by move=> a b1 b2 hb; apply: subitvP=> /=; rewrite hb andbT. Qed. + +Lemma subitvPl : forall (a1 a2 b : itv_bound R), + le_boundl a2 a1 -> {subset (Interval a1 b) <= (Interval a2 b)}. +Proof. by move=> a1 a2 b ha; apply: subitvP=> /=; rewrite ha /=. Qed. + +Lemma lersif_in_itv : forall ba bb xa xb x, + x \in Interval (BOpen_if ba xa) (BOpen_if bb xb) -> + xa <= xb ?< if ba || bb. +Proof. +by move=> ba bb xa xb y; rewrite itv_boundlr; case/andP; apply: lersif_trans. +Qed. + +Lemma ltr_in_itv : forall ba bb xa xb x, ba || bb -> + x \in Interval (BOpen_if ba xa) (BOpen_if bb xb) -> xa < xb. +Proof. +move=> ba bb xa xb x; case bab: (_ || _) => // _. +by move/lersif_in_itv; rewrite bab. +Qed. + +Lemma ler_in_itv : forall ba bb xa xb x, + x \in Interval (BOpen_if ba xa) (BOpen_if bb xb) -> xa <= xb. +Proof. by move=> ba bb xa xb x; move/lersif_in_itv; move/lersifW. Qed. + +Lemma mem0_itvcc_xNx : forall x, (0 \in `[-x, x]) = (0 <= x). +Proof. +by move=> x; rewrite !inE; case hx: (0 <= _); rewrite (andbT, andbF) ?ge0_cp. +Qed. + +Lemma mem0_itvoo_xNx : forall x, 0 \in `](-x), x[ = (0 < x). +Proof. +by move=> x; rewrite !inE; case hx: (0 < _); rewrite (andbT, andbF) ?gt0_cp. +Qed. + +Lemma itv_splitI : forall a b, forall x, + x \in Interval a b = (x \in Interval a (BInfty _)) && (x \in Interval (BInfty _) b). +Proof. by move=> [[] a|] [[] b|] x; rewrite ?inE ?andbT. Qed. + + +Lemma real_lersifN x y b : x \in Num.real -> y \in Num.real -> + x <= y ?< if ~~b = ~~ (y <= x ?< if b). +Proof. by case: b => [] xR yR /=; rewrite (real_ltrNge, real_lerNgt). Qed. + +Lemma oppr_itv ba bb (xa xb x : R) : + (-x \in Interval (BOpen_if ba xa) (BOpen_if bb xb)) = + (x \in Interval (BOpen_if bb (-xb)) (BOpen_if ba (-xa))). +Proof. by move: ba bb => [] []; rewrite ?inE lter_oppr andbC lter_oppl. Qed. + +Lemma oppr_itvoo (a b x : R) : (-x \in `]a, b[) = (x \in `](-b), (-a)[). +Proof. exact: oppr_itv. Qed. + +Lemma oppr_itvco (a b x : R) : (-x \in `[a, b[) = (x \in `](-b), (-a)]). +Proof. exact: oppr_itv. Qed. + +Lemma oppr_itvoc (a b x : R) : (-x \in `]a, b]) = (x \in `[(-b), (-a)[). +Proof. exact: oppr_itv. Qed. + +Lemma oppr_itvcc (a b x : R) : (-x \in `[a, b]) = (x \in `[(-b), (-a)]). +Proof. exact: oppr_itv. Qed. + +End IntervalPo. + +Notation BOpen := (BOpen_if true). +Notation BClose := (BOpen_if false). +Notation "`[ a , b ]" := (Interval (BClose a) (BClose b)) + (at level 0, a, b at level 9 , format "`[ a , b ]") : ring_scope. +Notation "`] a , b ]" := (Interval (BOpen a) (BClose b)) + (at level 0, a, b at level 9 , format "`] a , b ]") : ring_scope. +Notation "`[ a , b [" := (Interval (BClose a) (BOpen b)) + (at level 0, a, b at level 9 , format "`[ a , b [") : ring_scope. +Notation "`] a , b [" := (Interval (BOpen a) (BOpen b)) + (at level 0, a, b at level 9 , format "`] a , b [") : ring_scope. +Notation "`] '-oo' , b ]" := (Interval (BInfty _) (BClose b)) + (at level 0, b at level 9 , format "`] '-oo' , b ]") : ring_scope. +Notation "`] '-oo' , b [" := (Interval (BInfty _) (BOpen b)) + (at level 0, b at level 9 , format "`] '-oo' , b [") : ring_scope. +Notation "`[ a , '+oo' [" := (Interval (BClose a) (BInfty _)) + (at level 0, a at level 9 , format "`[ a , '+oo' [") : ring_scope. +Notation "`] a , '+oo' [" := (Interval (BOpen a) (BInfty _)) + (at level 0, a at level 9 , format "`] a , '+oo' [") : ring_scope. +Notation "`] -oo , '+oo' [" := (Interval (BInfty _) (BInfty _)) + (at level 0, format "`] -oo , '+oo' [") : ring_scope. + +Notation "x <= y ?< 'if' b" := (lersif x y b) + (at level 70, y at next level, + format "x '[hv' <= y '/' ?< 'if' b ']'") : ring_scope. + +Section IntervalOrdered. + +Variable R : realDomainType. + +Lemma lersifN (x y : R) b : (x <= y ?< if ~~ b) = ~~ (y <= x ?< if b). +Proof. by rewrite real_lersifN ?num_real. Qed. + +Lemma itv_splitU (xc : R) bc a b : xc \in Interval a b -> + forall y, y \in Interval a b = + (y \in Interval a (BOpen_if (~~ bc) xc)) + || (y \in Interval (BOpen_if bc xc) b). +Proof. +move=> hxc y; rewrite !itv_boundlr [le_boundr]lock /=. +have [la /=|nla /=] := boolP (le_boundl a _); rewrite -lock. + have [lb /=|nlb /=] := boolP (le_boundr _ b); rewrite ?andbT ?andbF ?orbF //. + by case: bc => //=; case: ltrgtP. + symmetry; apply: contraNF nlb; rewrite /le_boundr /=. + case: b hxc => // bb xb hxc hyc. + suff /(lersif_trans hyc) : xc <= xb ?< if bb. + by case: bc {hyc} => //= /lersifS. + by case: a bb hxc {la} => [[] ?|] [] /= /itvP->. +symmetry; apply: contraNF nla => /andP [hc _]. +case: a hxc hc => [[] xa|] hxc; rewrite /le_boundl //=. + by move=> /lersifW /(ltr_le_trans _) -> //; move: b hxc=> [[] ?|] /itvP->. +by move=> /lersifW /(ler_trans _) -> //; move: b hxc=> [[] ?|] /itvP->. +Qed. + +Lemma itv_splitU2 (x : R) a b : x \in Interval a b -> + forall y, y \in Interval a b = + [|| (y \in Interval a (BOpen x)), (y == x) + | (y \in Interval (BOpen x) b)]. +Proof. +move=> xab y; rewrite (itv_splitU false xab y); congr (_ || _). +rewrite (@itv_splitU x true _ _ _ y); first by rewrite itv_xx inE. +by move: xab; rewrite boundl_in_itv itv_boundlr => /andP []. +Qed. + +End IntervalOrdered. + +Section IntervalField. + +Variable R : realFieldType. + +Lemma mid_in_itv : forall ba bb (xa xb : R), xa <= xb ?< if (ba || bb) + -> mid xa xb \in Interval (BOpen_if ba xa) (BOpen_if bb xb). +Proof. +by move=> [] [] xa xb /= hx; apply/itv_dec=> /=; rewrite ?midf_lte // ?ltrW. +Qed. + +Lemma mid_in_itvoo : forall (xa xb : R), xa < xb -> mid xa xb \in `]xa, xb[. +Proof. by move=> xa xb hx; apply: mid_in_itv. Qed. + +Lemma mid_in_itvcc : forall (xa xb : R), xa <= xb -> mid xa xb \in `[xa, xb]. +Proof. by move=> xa xb hx; apply: mid_in_itv. Qed. + +End IntervalField. diff --git a/mathcomp/algebra/matrix.v b/mathcomp/algebra/matrix.v new file mode 100644 index 0000000..ecf5801 --- /dev/null +++ b/mathcomp/algebra/matrix.v @@ -0,0 +1,2872 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype. +Require Import finfun bigop prime binomial ssralg finset fingroup finalg. +Require Import perm zmodp. + +(******************************************************************************) +(* Basic concrete linear algebra : definition of type for matrices, and all *) +(* basic matrix operations including determinant, trace and support for block *) +(* decomposition. Matrices are represented by a row-major list of their *) +(* coefficients but this implementation is hidden by three levels of wrappers *) +(* (Matrix/Finfun/Tuple) so the matrix type should be treated as abstract and *) +(* handled using only the operations described below: *) +(* 'M[R]_(m, n) == the type of m rows by n columns matrices with *) +(* 'M_(m, n) coefficients in R; the [R] is optional and is usually *) +(* omitted. *) +(* 'M[R]_n, 'M_n == the type of n x n square matrices. *) +(* 'rV[R]_n, 'rV_n == the type of 1 x n row vectors. *) +(* 'cV[R]_n, 'cV_n == the type of n x 1 column vectors. *) +(* \matrix_(i < m, j < n) Expr(i, j) == *) +(* the m x n matrix with general coefficient Expr(i, j), *) +(* with i : 'I_m and j : 'I_n. the < m bound can be omitted *) +(* if it is equal to n, though usually both bounds are *) +(* omitted as they can be inferred from the context. *) +(* \row_(j < n) Expr(j), \col_(i < m) Expr(i) *) +(* the row / column vectors with general term Expr; the *) +(* parentheses can be omitted along with the bound. *) +(* \matrix_(i < m) RowExpr(i) == *) +(* the m x n matrix with row i given by RowExpr(i) : 'rV_n. *) +(* A i j == the coefficient of matrix A : 'M_(m, n) in column j of *) +(* row i, where i : 'I_m, and j : 'I_n (via the coercion *) +(* fun_of_matrix : matrix >-> Funclass). *) +(* const_mx a == the constant matrix whose entries are all a (dimensions *) +(* should be determined by context). *) +(* map_mx f A == the pointwise image of A by f, i.e., the matrix Af *) +(* congruent to A with Af i j = f (A i j) for all i and j. *) +(* A^T == the matrix transpose of A. *) +(* row i A == the i'th row of A (this is a row vector). *) +(* col j A == the j'th column of A (a column vector). *) +(* row' i A == A with the i'th row spliced out. *) +(* col' i A == A with the j'th column spliced out. *) +(* xrow i1 i2 A == A with rows i1 and i2 interchanged. *) +(* xcol j1 j2 A == A with columns j1 and j2 interchanged. *) +(* row_perm s A == A : 'M_(m, n) with rows permuted by s : 'S_m. *) +(* col_perm s A == A : 'M_(m, n) with columns permuted by s : 'S_n. *) +(* row_mx Al Ar == the row block matrix obtained by contatenating *) +(* two matrices Al and Ar of the same height. *) +(* col_mx Au Ad == the column block matrix / Au \ (Au and Ad must have the *) +(* same width). \ Ad / *) +(* block_mx Aul Aur Adl Adr == the block matrix / Aul Aur \ *) +(* \ Adl Adr / *) +(* [l|r]submx A == the left/right submatrices of a row block matrix A. *) +(* Note that the type of A, 'M_(m, n1 + n2) indicates how A *) +(* should be decomposed. *) +(* [u|d]submx A == the up/down submatrices of a column block matrix A. *) +(* [u|d][l|r]submx A == the upper left, etc submatrices of a block matrix A. *) +(* castmx eq_mn A == A : 'M_(m, n) cast to 'M_(m', n') using the equation *) +(* pair eq_mn : (m = m') * (n = n'). This is the usual *) +(* workaround for the syntactic limitations of dependent *) +(* types in Coq, and can be used to introduce a block *) +(* decomposition. It simplifies to A when eq_mn is the *) +(* pair (erefl m, erefl n) (using rewrite /castmx /=). *) +(* conform_mx B A == A if A and B have the same dimensions, else B. *) +(* mxvec A == a row vector of width m * n holding all the entries of *) +(* the m x n matrix A. *) +(* mxvec_index i j == the index of A i j in mxvec A. *) +(* vec_mx v == the inverse of mxvec, reshaping a vector of width m * n *) +(* back into into an m x n rectangular matrix. *) +(* In 'M[R]_(m, n), R can be any type, but 'M[R]_(m, n) inherits the eqType, *) +(* choiceType, countType, finType, zmodType structures of R; 'M[R]_(m, n) *) +(* also has a natural lmodType R structure when R has a ringType structure. *) +(* Because the type of matrices specifies their dimension, only non-trivial *) +(* square matrices (of type 'M[R]_n.+1) can inherit the ring structure of R; *) +(* indeed they then have an algebra structure (lalgType R, or algType R if R *) +(* is a comRingType, or even unitAlgType if R is a comUnitRingType). *) +(* We thus provide separate syntax for the general matrix multiplication, *) +(* and other operations for matrices over a ringType R: *) +(* A *m B == the matrix product of A and B; the width of A must be *) +(* equal to the height of B. *) +(* a%:M == the scalar matrix with a's on the main diagonal; in *) +(* particular 1%:M denotes the identity matrix, and is is *) +(* equal to 1%R when n is of the form n'.+1 (e.g., n >= 1). *) +(* is_scalar_mx A <=> A is a scalar matrix (A = a%:M for some A). *) +(* diag_mx d == the diagonal matrix whose main diagonal is d : 'rV_n. *) +(* delta_mx i j == the matrix with a 1 in row i, column j and 0 elsewhere. *) +(* pid_mx r == the partial identity matrix with 1s only on the r first *) +(* coefficients of the main diagonal; the dimensions of *) +(* pid_mx r are determined by the context, and pid_mx r can *) +(* be rectangular. *) +(* copid_mx r == the complement to 1%:M of pid_mx r: a square diagonal *) +(* matrix with 1s on all but the first r coefficients on *) +(* its main diagonal. *) +(* perm_mx s == the n x n permutation matrix for s : 'S_n. *) +(* tperm_mx i1 i2 == the permutation matrix that exchanges i1 i2 : 'I_n. *) +(* is_perm_mx A == A is a permutation matrix. *) +(* lift0_mx A == the 1 + n square matrix block_mx 1 0 0 A when A : 'M_n. *) +(* \tr A == the trace of a square matrix A. *) +(* \det A == the determinant of A, using the Leibnitz formula. *) +(* cofactor i j A == the i, j cofactor of A (the signed i, j minor of A), *) +(* \adj A == the adjugate matrix of A (\adj A i j = cofactor j i A). *) +(* A \in unitmx == A is invertible (R must be a comUnitRingType). *) +(* invmx A == the inverse matrix of A if A \in unitmx A, otherwise A. *) +(* The following operations provide a correspondance between linear functions *) +(* and matrices: *) +(* lin1_mx f == the m x n matrix that emulates via right product *) +(* a (linear) function f : 'rV_m -> 'rV_n on ROW VECTORS *) +(* lin_mx f == the (m1 * n1) x (m2 * n2) matrix that emulates, via the *) +(* right multiplication on the mxvec encodings, a linear *) +(* function f : 'M_(m1, n1) -> 'M_(m2, n2) *) +(* lin_mul_row u := lin1_mx (mulmx u \o vec_mx) (applies a row-encoded *) +(* function to the row-vector u). *) +(* mulmx A == partially applied matrix multiplication (mulmx A B is *) +(* displayed as A *m B), with, for A : 'M_(m, n), a *) +(* canonical {linear 'M_(n, p) -> 'M(m, p}} structure. *) +(* mulmxr A == self-simplifying right-hand matrix multiplication, i.e., *) +(* mulmxr A B simplifies to B *m A, with, for A : 'M_(n, p), *) +(* a canonical {linear 'M_(m, n) -> 'M(m, p}} structure. *) +(* lin_mulmx A := lin_mx (mulmx A). *) +(* lin_mulmxr A := lin_mx (mulmxr A). *) +(* We also extend any finType structure of R to 'M[R]_(m, n), and define: *) +(* {'GL_n[R]} == the finGroupType of units of 'M[R]_n.-1.+1. *) +(* 'GL_n[R] == the general linear group of all matrices in {'GL_n(R)}. *) +(* 'GL_n(p) == 'GL_n['F_p], the general linear group of a prime field. *) +(* GLval u == the coercion of u : {'GL_n(R)} to a matrix. *) +(* In addition to the lemmas relevant to these definitions, this file also *) +(* proves several classic results, including : *) +(* - The determinant is a multilinear alternate form. *) +(* - The Laplace determinant expansion formulas: expand_det_[row|col]. *) +(* - The Cramer rule : mul_mx_adj & mul_adj_mx. *) +(* Finally, as an example of the use of block products, we program and prove *) +(* the correctness of a classical linear algebra algorithm: *) +(* cormenLUP A == the triangular decomposition (L, U, P) of a nontrivial *) +(* square matrix A into a lower triagular matrix L with 1s *) +(* on the main diagonal, an upper matrix U, and a *) +(* permutation matrix P, such that P * A = L * U. *) +(* This is example only; we use a different, more precise algorithm to *) +(* develop the theory of matrix ranks and row spaces in mxalgebra.v *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. +Import GRing.Theory. +Open Local Scope ring_scope. + +Reserved Notation "''M_' n" (at level 8, n at level 2, format "''M_' n"). +Reserved Notation "''rV_' n" (at level 8, n at level 2, format "''rV_' n"). +Reserved Notation "''cV_' n" (at level 8, n at level 2, format "''cV_' n"). +Reserved Notation "''M_' ( n )" (at level 8, only parsing). +Reserved Notation "''M_' ( m , n )" (at level 8, format "''M_' ( m , n )"). +Reserved Notation "''M[' R ]_ n" (at level 8, n at level 2, only parsing). +Reserved Notation "''rV[' R ]_ n" (at level 8, n at level 2, only parsing). +Reserved Notation "''cV[' R ]_ n" (at level 8, n at level 2, only parsing). +Reserved Notation "''M[' R ]_ ( n )" (at level 8, only parsing). +Reserved Notation "''M[' R ]_ ( m , n )" (at level 8, only parsing). + +Reserved Notation "\matrix_ i E" + (at level 36, E at level 36, i at level 2, + format "\matrix_ i E"). +Reserved Notation "\matrix_ ( i < n ) E" + (at level 36, E at level 36, i, n at level 50, only parsing). +Reserved Notation "\matrix_ ( i , j ) E" + (at level 36, E at level 36, i, j at level 50, + format "\matrix_ ( i , j ) E"). +Reserved Notation "\matrix[ k ]_ ( i , j ) E" + (at level 36, E at level 36, i, j at level 50, + format "\matrix[ k ]_ ( i , j ) E"). +Reserved Notation "\matrix_ ( i < m , j < n ) E" + (at level 36, E at level 36, i, m, j, n at level 50, only parsing). +Reserved Notation "\matrix_ ( i , j < n ) E" + (at level 36, E at level 36, i, j, n at level 50, only parsing). +Reserved Notation "\row_ j E" + (at level 36, E at level 36, j at level 2, + format "\row_ j E"). +Reserved Notation "\row_ ( j < n ) E" + (at level 36, E at level 36, j, n at level 50, only parsing). +Reserved Notation "\col_ j E" + (at level 36, E at level 36, j at level 2, + format "\col_ j E"). +Reserved Notation "\col_ ( j < n ) E" + (at level 36, E at level 36, j, n at level 50, only parsing). + +Reserved Notation "x %:M" (at level 8, format "x %:M"). +Reserved Notation "A *m B" (at level 40, left associativity, format "A *m B"). +Reserved Notation "A ^T" (at level 8, format "A ^T"). +Reserved Notation "\tr A" (at level 10, A at level 8, format "\tr A"). +Reserved Notation "\det A" (at level 10, A at level 8, format "\det A"). +Reserved Notation "\adj A" (at level 10, A at level 8, format "\adj A"). + +Notation Local simp := (Monoid.Theory.simpm, oppr0). + +(*****************************************************************************) +(****************************Type Definition**********************************) +(*****************************************************************************) + +Section MatrixDef. + +Variable R : Type. +Variables m n : nat. + +(* Basic linear algebra (matrices). *) +(* We use dependent types (ordinals) for the indices so that ranges are *) +(* mostly inferred automatically *) + +Inductive matrix : predArgType := Matrix of {ffun 'I_m * 'I_n -> R}. + +Definition mx_val A := let: Matrix g := A in g. + +Canonical matrix_subType := Eval hnf in [newType for mx_val]. + +Fact matrix_key : unit. Proof. by []. Qed. +Definition matrix_of_fun_def F := Matrix [ffun ij => F ij.1 ij.2]. +Definition matrix_of_fun k := locked_with k matrix_of_fun_def. +Canonical matrix_unlockable k := [unlockable fun matrix_of_fun k]. + +Definition fun_of_matrix A (i : 'I_m) (j : 'I_n) := mx_val A (i, j). + +Coercion fun_of_matrix : matrix >-> Funclass. + +Lemma mxE k F : matrix_of_fun k F =2 F. +Proof. by move=> i j; rewrite unlock /fun_of_matrix /= ffunE. Qed. + +Lemma matrixP (A B : matrix) : A =2 B <-> A = B. +Proof. +rewrite /fun_of_matrix; split=> [/= eqAB | -> //]. +by apply/val_inj/ffunP=> [[i j]]; exact: eqAB. +Qed. + +End MatrixDef. + +Bind Scope ring_scope with matrix. + +Notation "''M[' R ]_ ( m , n )" := (matrix R m n) (only parsing): type_scope. +Notation "''rV[' R ]_ n" := 'M[R]_(1, n) (only parsing) : type_scope. +Notation "''cV[' R ]_ n" := 'M[R]_(n, 1) (only parsing) : type_scope. +Notation "''M[' R ]_ n" := 'M[R]_(n, n) (only parsing) : type_scope. +Notation "''M[' R ]_ ( n )" := 'M[R]_n (only parsing) : type_scope. +Notation "''M_' ( m , n )" := 'M[_]_(m, n) : type_scope. +Notation "''rV_' n" := 'M_(1, n) : type_scope. +Notation "''cV_' n" := 'M_(n, 1) : type_scope. +Notation "''M_' n" := 'M_(n, n) : type_scope. +Notation "''M_' ( n )" := 'M_n (only parsing) : type_scope. + +Notation "\matrix[ k ]_ ( i , j ) E" := (matrix_of_fun k (fun i j => E)) + (at level 36, E at level 36, i, j at level 50): ring_scope. + +Notation "\matrix_ ( i < m , j < n ) E" := + (@matrix_of_fun _ m n matrix_key (fun i j => E)) (only parsing) : ring_scope. + +Notation "\matrix_ ( i , j < n ) E" := + (\matrix_(i < n, j < n) E) (only parsing) : ring_scope. + +Notation "\matrix_ ( i , j ) E" := (\matrix_(i < _, j < _) E) : ring_scope. + +Notation "\matrix_ ( i < m ) E" := + (\matrix_(i < m, j < _) @fun_of_matrix _ 1 _ E 0 j) + (only parsing) : ring_scope. +Notation "\matrix_ i E" := (\matrix_(i < _) E) : ring_scope. + +Notation "\col_ ( i < n ) E" := (@matrix_of_fun _ n 1 matrix_key (fun i _ => E)) + (only parsing) : ring_scope. +Notation "\col_ i E" := (\col_(i < _) E) : ring_scope. + +Notation "\row_ ( j < n ) E" := (@matrix_of_fun _ 1 n matrix_key (fun _ j => E)) + (only parsing) : ring_scope. +Notation "\row_ j E" := (\row_(j < _) E) : ring_scope. + +Definition matrix_eqMixin (R : eqType) m n := + Eval hnf in [eqMixin of 'M[R]_(m, n) by <:]. +Canonical matrix_eqType (R : eqType) m n:= + Eval hnf in EqType 'M[R]_(m, n) (matrix_eqMixin R m n). +Definition matrix_choiceMixin (R : choiceType) m n := + [choiceMixin of 'M[R]_(m, n) by <:]. +Canonical matrix_choiceType (R : choiceType) m n := + Eval hnf in ChoiceType 'M[R]_(m, n) (matrix_choiceMixin R m n). +Definition matrix_countMixin (R : countType) m n := + [countMixin of 'M[R]_(m, n) by <:]. +Canonical matrix_countType (R : countType) m n := + Eval hnf in CountType 'M[R]_(m, n) (matrix_countMixin R m n). +Canonical matrix_subCountType (R : countType) m n := + Eval hnf in [subCountType of 'M[R]_(m, n)]. +Definition matrix_finMixin (R : finType) m n := + [finMixin of 'M[R]_(m, n) by <:]. +Canonical matrix_finType (R : finType) m n := + Eval hnf in FinType 'M[R]_(m, n) (matrix_finMixin R m n). +Canonical matrix_subFinType (R : finType) m n := + Eval hnf in [subFinType of 'M[R]_(m, n)]. + +Lemma card_matrix (F : finType) m n : (#|{: 'M[F]_(m, n)}| = #|F| ^ (m * n))%N. +Proof. by rewrite card_sub card_ffun card_prod !card_ord. Qed. + +(*****************************************************************************) +(****** Matrix structural operations (transpose, permutation, blocks) ********) +(*****************************************************************************) + +Section MatrixStructural. + +Variable R : Type. + +(* Constant matrix *) +Fact const_mx_key : unit. Proof. by []. Qed. +Definition const_mx m n a : 'M[R]_(m, n) := \matrix[const_mx_key]_(i, j) a. +Implicit Arguments const_mx [[m] [n]]. + +Section FixedDim. +(* Definitions and properties for which we can work with fixed dimensions. *) + +Variables m n : nat. +Implicit Type A : 'M[R]_(m, n). + +(* Reshape a matrix, to accomodate the block functions for instance. *) +Definition castmx m' n' (eq_mn : (m = m') * (n = n')) A : 'M_(m', n') := + let: erefl in _ = m' := eq_mn.1 return 'M_(m', n') in + let: erefl in _ = n' := eq_mn.2 return 'M_(m, n') in A. + +Definition conform_mx m' n' B A := + match m =P m', n =P n' with + | ReflectT eq_m, ReflectT eq_n => castmx (eq_m, eq_n) A + | _, _ => B + end. + +(* Transpose a matrix *) +Fact trmx_key : unit. Proof. by []. Qed. +Definition trmx A := \matrix[trmx_key]_(i, j) A j i. + +(* Permute a matrix vertically (rows) or horizontally (columns) *) +Fact row_perm_key : unit. Proof. by []. Qed. +Definition row_perm (s : 'S_m) A := \matrix[row_perm_key]_(i, j) A (s i) j. +Fact col_perm_key : unit. Proof. by []. Qed. +Definition col_perm (s : 'S_n) A := \matrix[col_perm_key]_(i, j) A i (s j). + +(* Exchange two rows/columns of a matrix *) +Definition xrow i1 i2 := row_perm (tperm i1 i2). +Definition xcol j1 j2 := col_perm (tperm j1 j2). + +(* Row/Column sub matrices of a matrix *) +Definition row i0 A := \row_j A i0 j. +Definition col j0 A := \col_i A i j0. + +(* Removing a row/column from a matrix *) +Definition row' i0 A := \matrix_(i, j) A (lift i0 i) j. +Definition col' j0 A := \matrix_(i, j) A i (lift j0 j). + +Lemma castmx_const m' n' (eq_mn : (m = m') * (n = n')) a : + castmx eq_mn (const_mx a) = const_mx a. +Proof. by case: eq_mn; case: m' /; case: n' /. Qed. + +Lemma trmx_const a : trmx (const_mx a) = const_mx a. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma row_perm_const s a : row_perm s (const_mx a) = const_mx a. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma col_perm_const s a : col_perm s (const_mx a) = const_mx a. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma xrow_const i1 i2 a : xrow i1 i2 (const_mx a) = const_mx a. +Proof. exact: row_perm_const. Qed. + +Lemma xcol_const j1 j2 a : xcol j1 j2 (const_mx a) = const_mx a. +Proof. exact: col_perm_const. Qed. + +Lemma rowP (u v : 'rV[R]_n) : u 0 =1 v 0 <-> u = v. +Proof. by split=> [eq_uv | -> //]; apply/matrixP=> i; rewrite ord1. Qed. + +Lemma rowK u_ i0 : row i0 (\matrix_i u_ i) = u_ i0. +Proof. by apply/rowP=> i'; rewrite !mxE. Qed. + +Lemma row_matrixP A B : (forall i, row i A = row i B) <-> A = B. +Proof. +split=> [eqAB | -> //]; apply/matrixP=> i j. +by move/rowP/(_ j): (eqAB i); rewrite !mxE. +Qed. + +Lemma colP (u v : 'cV[R]_m) : u^~ 0 =1 v^~ 0 <-> u = v. +Proof. by split=> [eq_uv | -> //]; apply/matrixP=> i j; rewrite ord1. Qed. + +Lemma row_const i0 a : row i0 (const_mx a) = const_mx a. +Proof. by apply/rowP=> j; rewrite !mxE. Qed. + +Lemma col_const j0 a : col j0 (const_mx a) = const_mx a. +Proof. by apply/colP=> i; rewrite !mxE. Qed. + +Lemma row'_const i0 a : row' i0 (const_mx a) = const_mx a. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma col'_const j0 a : col' j0 (const_mx a) = const_mx a. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma col_perm1 A : col_perm 1 A = A. +Proof. by apply/matrixP=> i j; rewrite mxE perm1. Qed. + +Lemma row_perm1 A : row_perm 1 A = A. +Proof. by apply/matrixP=> i j; rewrite mxE perm1. Qed. + +Lemma col_permM s t A : col_perm (s * t) A = col_perm s (col_perm t A). +Proof. by apply/matrixP=> i j; rewrite !mxE permM. Qed. + +Lemma row_permM s t A : row_perm (s * t) A = row_perm s (row_perm t A). +Proof. by apply/matrixP=> i j; rewrite !mxE permM. Qed. + +Lemma col_row_permC s t A : + col_perm s (row_perm t A) = row_perm t (col_perm s A). +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +End FixedDim. + +Local Notation "A ^T" := (trmx A) : ring_scope. + +Lemma castmx_id m n erefl_mn (A : 'M_(m, n)) : castmx erefl_mn A = A. +Proof. by case: erefl_mn => e_m e_n; rewrite [e_m]eq_axiomK [e_n]eq_axiomK. Qed. + +Lemma castmx_comp m1 n1 m2 n2 m3 n3 (eq_m1 : m1 = m2) (eq_n1 : n1 = n2) + (eq_m2 : m2 = m3) (eq_n2 : n2 = n3) A : + castmx (eq_m2, eq_n2) (castmx (eq_m1, eq_n1) A) + = castmx (etrans eq_m1 eq_m2, etrans eq_n1 eq_n2) A. +Proof. +by case: m2 / eq_m1 eq_m2; case: m3 /; case: n2 / eq_n1 eq_n2; case: n3 /. +Qed. + +Lemma castmxK m1 n1 m2 n2 (eq_m : m1 = m2) (eq_n : n1 = n2) : + cancel (castmx (eq_m, eq_n)) (castmx (esym eq_m, esym eq_n)). +Proof. by case: m2 / eq_m; case: n2 / eq_n. Qed. + +Lemma castmxKV m1 n1 m2 n2 (eq_m : m1 = m2) (eq_n : n1 = n2) : + cancel (castmx (esym eq_m, esym eq_n)) (castmx (eq_m, eq_n)). +Proof. by case: m2 / eq_m; case: n2 / eq_n. Qed. + +(* This can be use to reverse an equation that involves a cast. *) +Lemma castmx_sym m1 n1 m2 n2 (eq_m : m1 = m2) (eq_n : n1 = n2) A1 A2 : + A1 = castmx (eq_m, eq_n) A2 -> A2 = castmx (esym eq_m, esym eq_n) A1. +Proof. by move/(canLR (castmxK _ _)). Qed. + +Lemma castmxE m1 n1 m2 n2 (eq_mn : (m1 = m2) * (n1 = n2)) A i j : + castmx eq_mn A i j = + A (cast_ord (esym eq_mn.1) i) (cast_ord (esym eq_mn.2) j). +Proof. +by do [case: eq_mn; case: m2 /; case: n2 /] in A i j *; rewrite !cast_ord_id. +Qed. + +Lemma conform_mx_id m n (B A : 'M_(m, n)) : conform_mx B A = A. +Proof. by rewrite /conform_mx; do 2!case: eqP => // *; rewrite castmx_id. Qed. + +Lemma nonconform_mx m m' n n' (B : 'M_(m', n')) (A : 'M_(m, n)) : + (m != m') || (n != n') -> conform_mx B A = B. +Proof. by rewrite /conform_mx; do 2!case: eqP. Qed. + +Lemma conform_castmx m1 n1 m2 n2 m3 n3 + (e_mn : (m2 = m3) * (n2 = n3)) (B : 'M_(m1, n1)) A : + conform_mx B (castmx e_mn A) = conform_mx B A. +Proof. by do [case: e_mn; case: m3 /; case: n3 /] in A *. Qed. + +Lemma trmxK m n : cancel (@trmx m n) (@trmx n m). +Proof. by move=> A; apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma trmx_inj m n : injective (@trmx m n). +Proof. exact: can_inj (@trmxK m n). Qed. + +Lemma trmx_cast m1 n1 m2 n2 (eq_mn : (m1 = m2) * (n1 = n2)) A : + (castmx eq_mn A)^T = castmx (eq_mn.2, eq_mn.1) A^T. +Proof. +by case: eq_mn => eq_m eq_n; apply/matrixP=> i j; rewrite !(mxE, castmxE). +Qed. + +Lemma tr_row_perm m n s (A : 'M_(m, n)) : (row_perm s A)^T = col_perm s A^T. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma tr_col_perm m n s (A : 'M_(m, n)) : (col_perm s A)^T = row_perm s A^T. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma tr_xrow m n i1 i2 (A : 'M_(m, n)) : (xrow i1 i2 A)^T = xcol i1 i2 A^T. +Proof. exact: tr_row_perm. Qed. + +Lemma tr_xcol m n j1 j2 (A : 'M_(m, n)) : (xcol j1 j2 A)^T = xrow j1 j2 A^T. +Proof. exact: tr_col_perm. Qed. + +Lemma row_id n i (V : 'rV_n) : row i V = V. +Proof. by apply/rowP=> j; rewrite mxE [i]ord1. Qed. + +Lemma col_id n j (V : 'cV_n) : col j V = V. +Proof. by apply/colP=> i; rewrite mxE [j]ord1. Qed. + +Lemma row_eq m1 m2 n i1 i2 (A1 : 'M_(m1, n)) (A2 : 'M_(m2, n)) : + row i1 A1 = row i2 A2 -> A1 i1 =1 A2 i2. +Proof. by move/rowP=> eqA12 j; have:= eqA12 j; rewrite !mxE. Qed. + +Lemma col_eq m n1 n2 j1 j2 (A1 : 'M_(m, n1)) (A2 : 'M_(m, n2)) : + col j1 A1 = col j2 A2 -> A1^~ j1 =1 A2^~ j2. +Proof. by move/colP=> eqA12 i; have:= eqA12 i; rewrite !mxE. Qed. + +Lemma row'_eq m n i0 (A B : 'M_(m, n)) : + row' i0 A = row' i0 B -> {in predC1 i0, A =2 B}. +Proof. +move/matrixP=> eqAB' i; rewrite !inE eq_sym; case/unlift_some=> i' -> _ j. +by have:= eqAB' i' j; rewrite !mxE. +Qed. + +Lemma col'_eq m n j0 (A B : 'M_(m, n)) : + col' j0 A = col' j0 B -> forall i, {in predC1 j0, A i =1 B i}. +Proof. +move/matrixP=> eqAB' i j; rewrite !inE eq_sym; case/unlift_some=> j' -> _. +by have:= eqAB' i j'; rewrite !mxE. +Qed. + +Lemma tr_row m n i0 (A : 'M_(m, n)) : (row i0 A)^T = col i0 A^T. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma tr_row' m n i0 (A : 'M_(m, n)) : (row' i0 A)^T = col' i0 A^T. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma tr_col m n j0 (A : 'M_(m, n)) : (col j0 A)^T = row j0 A^T. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma tr_col' m n j0 (A : 'M_(m, n)) : (col' j0 A)^T = row' j0 A^T. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Ltac split_mxE := apply/matrixP=> i j; do ![rewrite mxE | case: split => ?]. + +Section CutPaste. + +Variables m m1 m2 n n1 n2 : nat. + +(* Concatenating two matrices, in either direction. *) + +Fact row_mx_key : unit. Proof. by []. Qed. +Definition row_mx (A1 : 'M_(m, n1)) (A2 : 'M_(m, n2)) : 'M[R]_(m, n1 + n2) := + \matrix[row_mx_key]_(i, j) + match split j with inl j1 => A1 i j1 | inr j2 => A2 i j2 end. + +Fact col_mx_key : unit. Proof. by []. Qed. +Definition col_mx (A1 : 'M_(m1, n)) (A2 : 'M_(m2, n)) : 'M[R]_(m1 + m2, n) := + \matrix[col_mx_key]_(i, j) + match split i with inl i1 => A1 i1 j | inr i2 => A2 i2 j end. + +(* Left/Right | Up/Down submatrices of a rows | columns matrix. *) +(* The shape of the (dependent) width parameters of the type of A *) +(* determines which submatrix is selected. *) + +Fact lsubmx_key : unit. Proof. by []. Qed. +Definition lsubmx (A : 'M[R]_(m, n1 + n2)) := + \matrix[lsubmx_key]_(i, j) A i (lshift n2 j). + +Fact rsubmx_key : unit. Proof. by []. Qed. +Definition rsubmx (A : 'M[R]_(m, n1 + n2)) := + \matrix[rsubmx_key]_(i, j) A i (rshift n1 j). + +Fact usubmx_key : unit. Proof. by []. Qed. +Definition usubmx (A : 'M[R]_(m1 + m2, n)) := + \matrix[usubmx_key]_(i, j) A (lshift m2 i) j. + +Fact dsubmx_key : unit. Proof. by []. Qed. +Definition dsubmx (A : 'M[R]_(m1 + m2, n)) := + \matrix[dsubmx_key]_(i, j) A (rshift m1 i) j. + +Lemma row_mxEl A1 A2 i j : row_mx A1 A2 i (lshift n2 j) = A1 i j. +Proof. by rewrite mxE (unsplitK (inl _ _)). Qed. + +Lemma row_mxKl A1 A2 : lsubmx (row_mx A1 A2) = A1. +Proof. by apply/matrixP=> i j; rewrite mxE row_mxEl. Qed. + +Lemma row_mxEr A1 A2 i j : row_mx A1 A2 i (rshift n1 j) = A2 i j. +Proof. by rewrite mxE (unsplitK (inr _ _)). Qed. + +Lemma row_mxKr A1 A2 : rsubmx (row_mx A1 A2) = A2. +Proof. by apply/matrixP=> i j; rewrite mxE row_mxEr. Qed. + +Lemma hsubmxK A : row_mx (lsubmx A) (rsubmx A) = A. +Proof. +apply/matrixP=> i j; rewrite !mxE. +case: splitP => k Dk //=; rewrite !mxE //=; congr (A _ _); exact: val_inj. +Qed. + +Lemma col_mxEu A1 A2 i j : col_mx A1 A2 (lshift m2 i) j = A1 i j. +Proof. by rewrite mxE (unsplitK (inl _ _)). Qed. + +Lemma col_mxKu A1 A2 : usubmx (col_mx A1 A2) = A1. +Proof. by apply/matrixP=> i j; rewrite mxE col_mxEu. Qed. + +Lemma col_mxEd A1 A2 i j : col_mx A1 A2 (rshift m1 i) j = A2 i j. +Proof. by rewrite mxE (unsplitK (inr _ _)). Qed. + +Lemma col_mxKd A1 A2 : dsubmx (col_mx A1 A2) = A2. +Proof. by apply/matrixP=> i j; rewrite mxE col_mxEd. Qed. + +Lemma eq_row_mx A1 A2 B1 B2 : row_mx A1 A2 = row_mx B1 B2 -> A1 = B1 /\ A2 = B2. +Proof. +move=> eqAB; move: (congr1 lsubmx eqAB) (congr1 rsubmx eqAB). +by rewrite !(row_mxKl, row_mxKr). +Qed. + +Lemma eq_col_mx A1 A2 B1 B2 : col_mx A1 A2 = col_mx B1 B2 -> A1 = B1 /\ A2 = B2. +Proof. +move=> eqAB; move: (congr1 usubmx eqAB) (congr1 dsubmx eqAB). +by rewrite !(col_mxKu, col_mxKd). +Qed. + +Lemma row_mx_const a : row_mx (const_mx a) (const_mx a) = const_mx a. +Proof. by split_mxE. Qed. + +Lemma col_mx_const a : col_mx (const_mx a) (const_mx a) = const_mx a. +Proof. by split_mxE. Qed. + +End CutPaste. + +Lemma trmx_lsub m n1 n2 (A : 'M_(m, n1 + n2)) : (lsubmx A)^T = usubmx A^T. +Proof. by split_mxE. Qed. + +Lemma trmx_rsub m n1 n2 (A : 'M_(m, n1 + n2)) : (rsubmx A)^T = dsubmx A^T. +Proof. by split_mxE. Qed. + +Lemma tr_row_mx m n1 n2 (A1 : 'M_(m, n1)) (A2 : 'M_(m, n2)) : + (row_mx A1 A2)^T = col_mx A1^T A2^T. +Proof. by split_mxE. Qed. + +Lemma tr_col_mx m1 m2 n (A1 : 'M_(m1, n)) (A2 : 'M_(m2, n)) : + (col_mx A1 A2)^T = row_mx A1^T A2^T. +Proof. by split_mxE. Qed. + +Lemma trmx_usub m1 m2 n (A : 'M_(m1 + m2, n)) : (usubmx A)^T = lsubmx A^T. +Proof. by split_mxE. Qed. + +Lemma trmx_dsub m1 m2 n (A : 'M_(m1 + m2, n)) : (dsubmx A)^T = rsubmx A^T. +Proof. by split_mxE. Qed. + +Lemma vsubmxK m1 m2 n (A : 'M_(m1 + m2, n)) : col_mx (usubmx A) (dsubmx A) = A. +Proof. by apply: trmx_inj; rewrite tr_col_mx trmx_usub trmx_dsub hsubmxK. Qed. + +Lemma cast_row_mx m m' n1 n2 (eq_m : m = m') A1 A2 : + castmx (eq_m, erefl _) (row_mx A1 A2) + = row_mx (castmx (eq_m, erefl n1) A1) (castmx (eq_m, erefl n2) A2). +Proof. by case: m' / eq_m. Qed. + +Lemma cast_col_mx m1 m2 n n' (eq_n : n = n') A1 A2 : + castmx (erefl _, eq_n) (col_mx A1 A2) + = col_mx (castmx (erefl m1, eq_n) A1) (castmx (erefl m2, eq_n) A2). +Proof. by case: n' / eq_n. Qed. + +(* This lemma has Prenex Implicits to help RL rewrititng with castmx_sym. *) +Lemma row_mxA m n1 n2 n3 (A1 : 'M_(m, n1)) (A2 : 'M_(m, n2)) (A3 : 'M_(m, n3)) : + let cast := (erefl m, esym (addnA n1 n2 n3)) in + row_mx A1 (row_mx A2 A3) = castmx cast (row_mx (row_mx A1 A2) A3). +Proof. +apply: (canRL (castmxKV _ _)); apply/matrixP=> i j. +rewrite castmxE !mxE cast_ord_id; case: splitP => j1 /= def_j. + have: (j < n1 + n2) && (j < n1) by rewrite def_j lshift_subproof /=. + by move: def_j; do 2![case: splitP => // ? ->; rewrite ?mxE] => /ord_inj->. +case: splitP def_j => j2 ->{j} def_j; rewrite !mxE. + have: ~~ (j2 < n1) by rewrite -leqNgt def_j leq_addr. + have: j1 < n2 by rewrite -(ltn_add2l n1) -def_j. + by move: def_j; do 2![case: splitP => // ? ->] => /addnI/val_inj->. +have: ~~ (j1 < n2) by rewrite -leqNgt -(leq_add2l n1) -def_j leq_addr. +by case: splitP def_j => // ? ->; rewrite addnA => /addnI/val_inj->. +Qed. +Definition row_mxAx := row_mxA. (* bypass Prenex Implicits. *) + +(* This lemma has Prenex Implicits to help RL rewrititng with castmx_sym. *) +Lemma col_mxA m1 m2 m3 n (A1 : 'M_(m1, n)) (A2 : 'M_(m2, n)) (A3 : 'M_(m3, n)) : + let cast := (esym (addnA m1 m2 m3), erefl n) in + col_mx A1 (col_mx A2 A3) = castmx cast (col_mx (col_mx A1 A2) A3). +Proof. by apply: trmx_inj; rewrite trmx_cast !tr_col_mx -row_mxA. Qed. +Definition col_mxAx := col_mxA. (* bypass Prenex Implicits. *) + +Lemma row_row_mx m n1 n2 i0 (A1 : 'M_(m, n1)) (A2 : 'M_(m, n2)) : + row i0 (row_mx A1 A2) = row_mx (row i0 A1) (row i0 A2). +Proof. +by apply/matrixP=> i j; rewrite !mxE; case: (split j) => j'; rewrite mxE. +Qed. + +Lemma col_col_mx m1 m2 n j0 (A1 : 'M_(m1, n)) (A2 : 'M_(m2, n)) : + col j0 (col_mx A1 A2) = col_mx (col j0 A1) (col j0 A2). +Proof. by apply: trmx_inj; rewrite !(tr_col, tr_col_mx, row_row_mx). Qed. + +Lemma row'_row_mx m n1 n2 i0 (A1 : 'M_(m, n1)) (A2 : 'M_(m, n2)) : + row' i0 (row_mx A1 A2) = row_mx (row' i0 A1) (row' i0 A2). +Proof. +by apply/matrixP=> i j; rewrite !mxE; case: (split j) => j'; rewrite mxE. +Qed. + +Lemma col'_col_mx m1 m2 n j0 (A1 : 'M_(m1, n)) (A2 : 'M_(m2, n)) : + col' j0 (col_mx A1 A2) = col_mx (col' j0 A1) (col' j0 A2). +Proof. by apply: trmx_inj; rewrite !(tr_col', tr_col_mx, row'_row_mx). Qed. + +Lemma colKl m n1 n2 j1 (A1 : 'M_(m, n1)) (A2 : 'M_(m, n2)) : + col (lshift n2 j1) (row_mx A1 A2) = col j1 A1. +Proof. by apply/matrixP=> i j; rewrite !(row_mxEl, mxE). Qed. + +Lemma colKr m n1 n2 j2 (A1 : 'M_(m, n1)) (A2 : 'M_(m, n2)) : + col (rshift n1 j2) (row_mx A1 A2) = col j2 A2. +Proof. by apply/matrixP=> i j; rewrite !(row_mxEr, mxE). Qed. + +Lemma rowKu m1 m2 n i1 (A1 : 'M_(m1, n)) (A2 : 'M_(m2, n)) : + row (lshift m2 i1) (col_mx A1 A2) = row i1 A1. +Proof. by apply/matrixP=> i j; rewrite !(col_mxEu, mxE). Qed. + +Lemma rowKd m1 m2 n i2 (A1 : 'M_(m1, n)) (A2 : 'M_(m2, n)) : + row (rshift m1 i2) (col_mx A1 A2) = row i2 A2. +Proof. by apply/matrixP=> i j; rewrite !(col_mxEd, mxE). Qed. + +Lemma col'Kl m n1 n2 j1 (A1 : 'M_(m, n1.+1)) (A2 : 'M_(m, n2)) : + col' (lshift n2 j1) (row_mx A1 A2) = row_mx (col' j1 A1) A2. +Proof. +apply/matrixP=> i /= j; symmetry; rewrite 2!mxE. +case: splitP => j' def_j'. + rewrite mxE -(row_mxEl _ A2); congr (row_mx _ _ _); apply: ord_inj. + by rewrite /= def_j'. +rewrite -(row_mxEr A1); congr (row_mx _ _ _); apply: ord_inj => /=. +by rewrite /bump def_j' -ltnS -addSn ltn_addr. +Qed. + +Lemma row'Ku m1 m2 n i1 (A1 : 'M_(m1.+1, n)) (A2 : 'M_(m2, n)) : + row' (lshift m2 i1) (@col_mx m1.+1 m2 n A1 A2) = col_mx (row' i1 A1) A2. +Proof. +by apply: trmx_inj; rewrite tr_col_mx !(@tr_row' _.+1) (@tr_col_mx _.+1) col'Kl. +Qed. + +Lemma mx'_cast m n : 'I_n -> (m + n.-1)%N = (m + n).-1. +Proof. by case=> j /ltn_predK <-; rewrite addnS. Qed. + +Lemma col'Kr m n1 n2 j2 (A1 : 'M_(m, n1)) (A2 : 'M_(m, n2)) : + col' (rshift n1 j2) (@row_mx m n1 n2 A1 A2) + = castmx (erefl m, mx'_cast n1 j2) (row_mx A1 (col' j2 A2)). +Proof. +apply/matrixP=> i j; symmetry; rewrite castmxE mxE cast_ord_id. +case: splitP => j' /= def_j. + rewrite mxE -(row_mxEl _ A2); congr (row_mx _ _ _); apply: ord_inj. + by rewrite /= def_j /bump leqNgt ltn_addr. +rewrite 2!mxE -(row_mxEr A1); congr (row_mx _ _ _ _); apply: ord_inj. +by rewrite /= def_j /bump leq_add2l addnCA. +Qed. + +Lemma row'Kd m1 m2 n i2 (A1 : 'M_(m1, n)) (A2 : 'M_(m2, n)) : + row' (rshift m1 i2) (col_mx A1 A2) + = castmx (mx'_cast m1 i2, erefl n) (col_mx A1 (row' i2 A2)). +Proof. by apply: trmx_inj; rewrite trmx_cast !(tr_row', tr_col_mx) col'Kr. Qed. + +Section Block. + +Variables m1 m2 n1 n2 : nat. + +(* Building a block matrix from 4 matrices : *) +(* up left, up right, down left and down right components *) + +Definition block_mx Aul Aur Adl Adr : 'M_(m1 + m2, n1 + n2) := + col_mx (row_mx Aul Aur) (row_mx Adl Adr). + +Lemma eq_block_mx Aul Aur Adl Adr Bul Bur Bdl Bdr : + block_mx Aul Aur Adl Adr = block_mx Bul Bur Bdl Bdr -> + [/\ Aul = Bul, Aur = Bur, Adl = Bdl & Adr = Bdr]. +Proof. by case/eq_col_mx; do 2!case/eq_row_mx=> -> ->. Qed. + +Lemma block_mx_const a : + block_mx (const_mx a) (const_mx a) (const_mx a) (const_mx a) = const_mx a. +Proof. by split_mxE. Qed. + +Section CutBlock. + +Variable A : matrix R (m1 + m2) (n1 + n2). + +Definition ulsubmx := lsubmx (usubmx A). +Definition ursubmx := rsubmx (usubmx A). +Definition dlsubmx := lsubmx (dsubmx A). +Definition drsubmx := rsubmx (dsubmx A). + +Lemma submxK : block_mx ulsubmx ursubmx dlsubmx drsubmx = A. +Proof. by rewrite /block_mx !hsubmxK vsubmxK. Qed. + +End CutBlock. + +Section CatBlock. + +Variables (Aul : 'M[R]_(m1, n1)) (Aur : 'M[R]_(m1, n2)). +Variables (Adl : 'M[R]_(m2, n1)) (Adr : 'M[R]_(m2, n2)). + +Let A := block_mx Aul Aur Adl Adr. + +Lemma block_mxEul i j : A (lshift m2 i) (lshift n2 j) = Aul i j. +Proof. by rewrite col_mxEu row_mxEl. Qed. +Lemma block_mxKul : ulsubmx A = Aul. +Proof. by rewrite /ulsubmx col_mxKu row_mxKl. Qed. + +Lemma block_mxEur i j : A (lshift m2 i) (rshift n1 j) = Aur i j. +Proof. by rewrite col_mxEu row_mxEr. Qed. +Lemma block_mxKur : ursubmx A = Aur. +Proof. by rewrite /ursubmx col_mxKu row_mxKr. Qed. + +Lemma block_mxEdl i j : A (rshift m1 i) (lshift n2 j) = Adl i j. +Proof. by rewrite col_mxEd row_mxEl. Qed. +Lemma block_mxKdl : dlsubmx A = Adl. +Proof. by rewrite /dlsubmx col_mxKd row_mxKl. Qed. + +Lemma block_mxEdr i j : A (rshift m1 i) (rshift n1 j) = Adr i j. +Proof. by rewrite col_mxEd row_mxEr. Qed. +Lemma block_mxKdr : drsubmx A = Adr. +Proof. by rewrite /drsubmx col_mxKd row_mxKr. Qed. + +Lemma block_mxEv : A = col_mx (row_mx Aul Aur) (row_mx Adl Adr). +Proof. by []. Qed. + +End CatBlock. + +End Block. + +Section TrCutBlock. + +Variables m1 m2 n1 n2 : nat. +Variable A : 'M[R]_(m1 + m2, n1 + n2). + +Lemma trmx_ulsub : (ulsubmx A)^T = ulsubmx A^T. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma trmx_ursub : (ursubmx A)^T = dlsubmx A^T. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma trmx_dlsub : (dlsubmx A)^T = ursubmx A^T. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma trmx_drsub : (drsubmx A)^T = drsubmx A^T. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +End TrCutBlock. + +Section TrBlock. +Variables m1 m2 n1 n2 : nat. +Variables (Aul : 'M[R]_(m1, n1)) (Aur : 'M[R]_(m1, n2)). +Variables (Adl : 'M[R]_(m2, n1)) (Adr : 'M[R]_(m2, n2)). + +Lemma tr_block_mx : + (block_mx Aul Aur Adl Adr)^T = block_mx Aul^T Adl^T Aur^T Adr^T. +Proof. +rewrite -[_^T]submxK -trmx_ulsub -trmx_ursub -trmx_dlsub -trmx_drsub. +by rewrite block_mxKul block_mxKur block_mxKdl block_mxKdr. +Qed. + +Lemma block_mxEh : + block_mx Aul Aur Adl Adr = row_mx (col_mx Aul Adl) (col_mx Aur Adr). +Proof. by apply: trmx_inj; rewrite tr_block_mx tr_row_mx 2!tr_col_mx. Qed. +End TrBlock. + +(* This lemma has Prenex Implicits to help RL rewrititng with castmx_sym. *) +Lemma block_mxA m1 m2 m3 n1 n2 n3 + (A11 : 'M_(m1, n1)) (A12 : 'M_(m1, n2)) (A13 : 'M_(m1, n3)) + (A21 : 'M_(m2, n1)) (A22 : 'M_(m2, n2)) (A23 : 'M_(m2, n3)) + (A31 : 'M_(m3, n1)) (A32 : 'M_(m3, n2)) (A33 : 'M_(m3, n3)) : + let cast := (esym (addnA m1 m2 m3), esym (addnA n1 n2 n3)) in + let row1 := row_mx A12 A13 in let col1 := col_mx A21 A31 in + let row3 := row_mx A31 A32 in let col3 := col_mx A13 A23 in + block_mx A11 row1 col1 (block_mx A22 A23 A32 A33) + = castmx cast (block_mx (block_mx A11 A12 A21 A22) col3 row3 A33). +Proof. +rewrite /= block_mxEh !col_mxA -cast_row_mx -block_mxEv -block_mxEh. +rewrite block_mxEv block_mxEh !row_mxA -cast_col_mx -block_mxEh -block_mxEv. +by rewrite castmx_comp etrans_id. +Qed. +Definition block_mxAx := block_mxA. (* Bypass Prenex Implicits *) + +(* Bijections mxvec : 'M_(m, n) <----> 'rV_(m * n) : vec_mx *) +Section VecMatrix. + +Variables m n : nat. + +Lemma mxvec_cast : #|{:'I_m * 'I_n}| = (m * n)%N. +Proof. by rewrite card_prod !card_ord. Qed. + +Definition mxvec_index (i : 'I_m) (j : 'I_n) := + cast_ord mxvec_cast (enum_rank (i, j)). + +CoInductive is_mxvec_index : 'I_(m * n) -> Type := + IsMxvecIndex i j : is_mxvec_index (mxvec_index i j). + +Lemma mxvec_indexP k : is_mxvec_index k. +Proof. +rewrite -[k](cast_ordK (esym mxvec_cast)) esymK. +by rewrite -[_ k]enum_valK; case: (enum_val _). +Qed. + +Coercion pair_of_mxvec_index k (i_k : is_mxvec_index k) := + let: IsMxvecIndex i j := i_k in (i, j). + +Definition mxvec (A : 'M[R]_(m, n)) := + castmx (erefl _, mxvec_cast) (\row_k A (enum_val k).1 (enum_val k).2). + +Fact vec_mx_key : unit. Proof. by []. Qed. +Definition vec_mx (u : 'rV[R]_(m * n)) := + \matrix[vec_mx_key]_(i, j) u 0 (mxvec_index i j). + +Lemma mxvecE A i j : mxvec A 0 (mxvec_index i j) = A i j. +Proof. by rewrite castmxE mxE cast_ordK enum_rankK. Qed. + +Lemma mxvecK : cancel mxvec vec_mx. +Proof. by move=> A; apply/matrixP=> i j; rewrite mxE mxvecE. Qed. + +Lemma vec_mxK : cancel vec_mx mxvec. +Proof. +by move=> u; apply/rowP=> k; case/mxvec_indexP: k => i j; rewrite mxvecE mxE. +Qed. + +Lemma curry_mxvec_bij : {on 'I_(m * n), bijective (prod_curry mxvec_index)}. +Proof. +exists (enum_val \o cast_ord (esym mxvec_cast)) => [[i j] _ | k _] /=. + by rewrite cast_ordK enum_rankK. +by case/mxvec_indexP: k => i j /=; rewrite cast_ordK enum_rankK. +Qed. + +End VecMatrix. + +End MatrixStructural. + +Implicit Arguments const_mx [R m n]. +Implicit Arguments row_mxA [R m n1 n2 n3 A1 A2 A3]. +Implicit Arguments col_mxA [R m1 m2 m3 n A1 A2 A3]. +Implicit Arguments block_mxA + [R m1 m2 m3 n1 n2 n3 A11 A12 A13 A21 A22 A23 A31 A32 A33]. +Prenex Implicits const_mx castmx trmx lsubmx rsubmx usubmx dsubmx row_mx col_mx. +Prenex Implicits block_mx ulsubmx ursubmx dlsubmx drsubmx. +Prenex Implicits row_mxA col_mxA block_mxA. +Prenex Implicits mxvec vec_mx mxvec_indexP mxvecK vec_mxK. + +Notation "A ^T" := (trmx A) : ring_scope. + +(* Matrix parametricity. *) +Section MapMatrix. + +Variables (aT rT : Type) (f : aT -> rT). + +Fact map_mx_key : unit. Proof. by []. Qed. +Definition map_mx m n (A : 'M_(m, n)) := \matrix[map_mx_key]_(i, j) f (A i j). + +Notation "A ^f" := (map_mx A) : ring_scope. + +Section OneMatrix. + +Variables (m n : nat) (A : 'M[aT]_(m, n)). + +Lemma map_trmx : A^f^T = A^T^f. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma map_const_mx a : (const_mx a)^f = const_mx (f a) :> 'M_(m, n). +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma map_row i : (row i A)^f = row i A^f. +Proof. by apply/rowP=> j; rewrite !mxE. Qed. + +Lemma map_col j : (col j A)^f = col j A^f. +Proof. by apply/colP=> i; rewrite !mxE. Qed. + +Lemma map_row' i0 : (row' i0 A)^f = row' i0 A^f. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma map_col' j0 : (col' j0 A)^f = col' j0 A^f. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma map_row_perm s : (row_perm s A)^f = row_perm s A^f. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma map_col_perm s : (col_perm s A)^f = col_perm s A^f. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma map_xrow i1 i2 : (xrow i1 i2 A)^f = xrow i1 i2 A^f. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma map_xcol j1 j2 : (xcol j1 j2 A)^f = xcol j1 j2 A^f. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma map_castmx m' n' c : (castmx c A)^f = castmx c A^f :> 'M_(m', n'). +Proof. by apply/matrixP=> i j; rewrite !(castmxE, mxE). Qed. + +Lemma map_conform_mx m' n' (B : 'M_(m', n')) : + (conform_mx B A)^f = conform_mx B^f A^f. +Proof. +move: B; have [[<- <-] B|] := eqVneq (m, n) (m', n'). + by rewrite !conform_mx_id. +by rewrite negb_and => neq_mn B; rewrite !nonconform_mx. +Qed. + +Lemma map_mxvec : (mxvec A)^f = mxvec A^f. +Proof. by apply/rowP=> i; rewrite !(castmxE, mxE). Qed. + +Lemma map_vec_mx (v : 'rV_(m * n)) : (vec_mx v)^f = vec_mx v^f. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +End OneMatrix. + +Section Block. + +Variables m1 m2 n1 n2 : nat. +Variables (Aul : 'M[aT]_(m1, n1)) (Aur : 'M[aT]_(m1, n2)). +Variables (Adl : 'M[aT]_(m2, n1)) (Adr : 'M[aT]_(m2, n2)). +Variables (Bh : 'M[aT]_(m1, n1 + n2)) (Bv : 'M[aT]_(m1 + m2, n1)). +Variable B : 'M[aT]_(m1 + m2, n1 + n2). + +Lemma map_row_mx : (row_mx Aul Aur)^f = row_mx Aul^f Aur^f. +Proof. by apply/matrixP=> i j; do 2![rewrite !mxE //; case: split => ?]. Qed. + +Lemma map_col_mx : (col_mx Aul Adl)^f = col_mx Aul^f Adl^f. +Proof. by apply/matrixP=> i j; do 2![rewrite !mxE //; case: split => ?]. Qed. + +Lemma map_block_mx : + (block_mx Aul Aur Adl Adr)^f = block_mx Aul^f Aur^f Adl^f Adr^f. +Proof. by apply/matrixP=> i j; do 3![rewrite !mxE //; case: split => ?]. Qed. + +Lemma map_lsubmx : (lsubmx Bh)^f = lsubmx Bh^f. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma map_rsubmx : (rsubmx Bh)^f = rsubmx Bh^f. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma map_usubmx : (usubmx Bv)^f = usubmx Bv^f. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma map_dsubmx : (dsubmx Bv)^f = dsubmx Bv^f. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma map_ulsubmx : (ulsubmx B)^f = ulsubmx B^f. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma map_ursubmx : (ursubmx B)^f = ursubmx B^f. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma map_dlsubmx : (dlsubmx B)^f = dlsubmx B^f. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma map_drsubmx : (drsubmx B)^f = drsubmx B^f. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +End Block. + +End MapMatrix. + +(*****************************************************************************) +(********************* Matrix Zmodule (additive) structure *******************) +(*****************************************************************************) + +Section MatrixZmodule. + +Variable V : zmodType. + +Section FixedDim. + +Variables m n : nat. +Implicit Types A B : 'M[V]_(m, n). + +Fact oppmx_key : unit. Proof. by []. Qed. +Fact addmx_key : unit. Proof. by []. Qed. +Definition oppmx A := \matrix[oppmx_key]_(i, j) (- A i j). +Definition addmx A B := \matrix[addmx_key]_(i, j) (A i j + B i j). +(* In principle, diag_mx and scalar_mx could be defined here, but since they *) +(* only make sense with the graded ring operations, we defer them to the *) +(* next section. *) + +Lemma addmxA : associative addmx. +Proof. by move=> A B C; apply/matrixP=> i j; rewrite !mxE addrA. Qed. + +Lemma addmxC : commutative addmx. +Proof. by move=> A B; apply/matrixP=> i j; rewrite !mxE addrC. Qed. + +Lemma add0mx : left_id (const_mx 0) addmx. +Proof. by move=> A; apply/matrixP=> i j; rewrite !mxE add0r. Qed. + +Lemma addNmx : left_inverse (const_mx 0) oppmx addmx. +Proof. by move=> A; apply/matrixP=> i j; rewrite !mxE addNr. Qed. + +Definition matrix_zmodMixin := ZmodMixin addmxA addmxC add0mx addNmx. + +Canonical matrix_zmodType := Eval hnf in ZmodType 'M[V]_(m, n) matrix_zmodMixin. + +Lemma mulmxnE A d i j : (A *+ d) i j = A i j *+ d. +Proof. by elim: d => [|d IHd]; rewrite ?mulrS mxE ?IHd. Qed. + +Lemma summxE I r (P : pred I) (E : I -> 'M_(m, n)) i j : + (\sum_(k <- r | P k) E k) i j = \sum_(k <- r | P k) E k i j. +Proof. by apply: (big_morph (fun A => A i j)) => [A B|]; rewrite mxE. Qed. + +Lemma const_mx_is_additive : additive const_mx. +Proof. by move=> a b; apply/matrixP=> i j; rewrite !mxE. Qed. +Canonical const_mx_additive := Additive const_mx_is_additive. + +End FixedDim. + +Section Additive. + +Variables (m n p q : nat) (f : 'I_p -> 'I_q -> 'I_m) (g : 'I_p -> 'I_q -> 'I_n). + +Definition swizzle_mx k (A : 'M[V]_(m, n)) := + \matrix[k]_(i, j) A (f i j) (g i j). + +Lemma swizzle_mx_is_additive k : additive (swizzle_mx k). +Proof. by move=> A B; apply/matrixP=> i j; rewrite !mxE. Qed. +Canonical swizzle_mx_additive k := Additive (swizzle_mx_is_additive k). + +End Additive. + +Local Notation SwizzleAdd op := [additive of op as swizzle_mx _ _ _]. + +Canonical trmx_additive m n := SwizzleAdd (@trmx V m n). +Canonical row_additive m n i := SwizzleAdd (@row V m n i). +Canonical col_additive m n j := SwizzleAdd (@col V m n j). +Canonical row'_additive m n i := SwizzleAdd (@row' V m n i). +Canonical col'_additive m n j := SwizzleAdd (@col' V m n j). +Canonical row_perm_additive m n s := SwizzleAdd (@row_perm V m n s). +Canonical col_perm_additive m n s := SwizzleAdd (@col_perm V m n s). +Canonical xrow_additive m n i1 i2 := SwizzleAdd (@xrow V m n i1 i2). +Canonical xcol_additive m n j1 j2 := SwizzleAdd (@xcol V m n j1 j2). +Canonical lsubmx_additive m n1 n2 := SwizzleAdd (@lsubmx V m n1 n2). +Canonical rsubmx_additive m n1 n2 := SwizzleAdd (@rsubmx V m n1 n2). +Canonical usubmx_additive m1 m2 n := SwizzleAdd (@usubmx V m1 m2 n). +Canonical dsubmx_additive m1 m2 n := SwizzleAdd (@dsubmx V m1 m2 n). +Canonical vec_mx_additive m n := SwizzleAdd (@vec_mx V m n). +Canonical mxvec_additive m n := + Additive (can2_additive (@vec_mxK V m n) mxvecK). + +Lemma flatmx0 n : all_equal_to (0 : 'M_(0, n)). +Proof. by move=> A; apply/matrixP=> [] []. Qed. + +Lemma thinmx0 n : all_equal_to (0 : 'M_(n, 0)). +Proof. by move=> A; apply/matrixP=> i []. Qed. + +Lemma trmx0 m n : (0 : 'M_(m, n))^T = 0. +Proof. exact: trmx_const. Qed. + +Lemma row0 m n i0 : row i0 (0 : 'M_(m, n)) = 0. +Proof. exact: row_const. Qed. + +Lemma col0 m n j0 : col j0 (0 : 'M_(m, n)) = 0. +Proof. exact: col_const. Qed. + +Lemma mxvec_eq0 m n (A : 'M_(m, n)) : (mxvec A == 0) = (A == 0). +Proof. by rewrite (can2_eq mxvecK vec_mxK) raddf0. Qed. + +Lemma vec_mx_eq0 m n (v : 'rV_(m * n)) : (vec_mx v == 0) = (v == 0). +Proof. by rewrite (can2_eq vec_mxK mxvecK) raddf0. Qed. + +Lemma row_mx0 m n1 n2 : row_mx 0 0 = 0 :> 'M_(m, n1 + n2). +Proof. exact: row_mx_const. Qed. + +Lemma col_mx0 m1 m2 n : col_mx 0 0 = 0 :> 'M_(m1 + m2, n). +Proof. exact: col_mx_const. Qed. + +Lemma block_mx0 m1 m2 n1 n2 : block_mx 0 0 0 0 = 0 :> 'M_(m1 + m2, n1 + n2). +Proof. exact: block_mx_const. Qed. + +Ltac split_mxE := apply/matrixP=> i j; do ![rewrite mxE | case: split => ?]. + +Lemma opp_row_mx m n1 n2 (A1 : 'M_(m, n1)) (A2 : 'M_(m, n2)) : + - row_mx A1 A2 = row_mx (- A1) (- A2). +Proof. by split_mxE. Qed. + +Lemma opp_col_mx m1 m2 n (A1 : 'M_(m1, n)) (A2 : 'M_(m2, n)) : + - col_mx A1 A2 = col_mx (- A1) (- A2). +Proof. by split_mxE. Qed. + +Lemma opp_block_mx m1 m2 n1 n2 (Aul : 'M_(m1, n1)) Aur Adl (Adr : 'M_(m2, n2)) : + - block_mx Aul Aur Adl Adr = block_mx (- Aul) (- Aur) (- Adl) (- Adr). +Proof. by rewrite opp_col_mx !opp_row_mx. Qed. + +Lemma add_row_mx m n1 n2 (A1 : 'M_(m, n1)) (A2 : 'M_(m, n2)) B1 B2 : + row_mx A1 A2 + row_mx B1 B2 = row_mx (A1 + B1) (A2 + B2). +Proof. by split_mxE. Qed. + +Lemma add_col_mx m1 m2 n (A1 : 'M_(m1, n)) (A2 : 'M_(m2, n)) B1 B2 : + col_mx A1 A2 + col_mx B1 B2 = col_mx (A1 + B1) (A2 + B2). +Proof. by split_mxE. Qed. + +Lemma add_block_mx m1 m2 n1 n2 (Aul : 'M_(m1, n1)) Aur Adl (Adr : 'M_(m2, n2)) + Bul Bur Bdl Bdr : + let A := block_mx Aul Aur Adl Adr in let B := block_mx Bul Bur Bdl Bdr in + A + B = block_mx (Aul + Bul) (Aur + Bur) (Adl + Bdl) (Adr + Bdr). +Proof. by rewrite /= add_col_mx !add_row_mx. Qed. + +Definition nz_row m n (A : 'M_(m, n)) := + oapp (fun i => row i A) 0 [pick i | row i A != 0]. + +Lemma nz_row_eq0 m n (A : 'M_(m, n)) : (nz_row A == 0) = (A == 0). +Proof. +rewrite /nz_row; symmetry; case: pickP => [i /= nzAi | Ai0]. + by rewrite (negbTE nzAi); apply: contraTF nzAi => /eqP->; rewrite row0 eqxx. +by rewrite eqxx; apply/eqP/row_matrixP=> i; move/eqP: (Ai0 i) ->; rewrite row0. +Qed. + +End MatrixZmodule. + +Section FinZmodMatrix. +Variables (V : finZmodType) (m n : nat). +Local Notation MV := 'M[V]_(m, n). + +Canonical matrix_finZmodType := Eval hnf in [finZmodType of MV]. +Canonical matrix_baseFinGroupType := + Eval hnf in [baseFinGroupType of MV for +%R]. +Canonical matrix_finGroupType := Eval hnf in [finGroupType of MV for +%R]. +End FinZmodMatrix. + +(* Parametricity over the additive structure. *) +Section MapZmodMatrix. + +Variables (aR rR : zmodType) (f : {additive aR -> rR}) (m n : nat). +Local Notation "A ^f" := (map_mx f A) : ring_scope. +Implicit Type A : 'M[aR]_(m, n). + +Lemma map_mx0 : 0^f = 0 :> 'M_(m, n). +Proof. by rewrite map_const_mx raddf0. Qed. + +Lemma map_mxN A : (- A)^f = - A^f. +Proof. by apply/matrixP=> i j; rewrite !mxE raddfN. Qed. + +Lemma map_mxD A B : (A + B)^f = A^f + B^f. +Proof. by apply/matrixP=> i j; rewrite !mxE raddfD. Qed. + +Lemma map_mx_sub A B : (A - B)^f = A^f - B^f. +Proof. by rewrite map_mxD map_mxN. Qed. + +Definition map_mx_sum := big_morph _ map_mxD map_mx0. + +Canonical map_mx_additive := Additive map_mx_sub. + +End MapZmodMatrix. + +(*****************************************************************************) +(*********** Matrix ring module, graded ring, and ring structures ************) +(*****************************************************************************) + +Section MatrixAlgebra. + +Variable R : ringType. + +Section RingModule. + +(* The ring module/vector space structure *) + +Variables m n : nat. +Implicit Types A B : 'M[R]_(m, n). + +Fact scalemx_key : unit. Proof. by []. Qed. +Definition scalemx x A := \matrix[scalemx_key]_(i, j) (x * A i j). + +(* Basis *) +Fact delta_mx_key : unit. Proof. by []. Qed. +Definition delta_mx i0 j0 : 'M[R]_(m, n) := + \matrix[delta_mx_key]_(i, j) ((i == i0) && (j == j0))%:R. + +Local Notation "x *m: A" := (scalemx x A) (at level 40) : ring_scope. + +Lemma scale1mx A : 1 *m: A = A. +Proof. by apply/matrixP=> i j; rewrite !mxE mul1r. Qed. + +Lemma scalemxDl A x y : (x + y) *m: A = x *m: A + y *m: A. +Proof. by apply/matrixP=> i j; rewrite !mxE mulrDl. Qed. + +Lemma scalemxDr x A B : x *m: (A + B) = x *m: A + x *m: B. +Proof. by apply/matrixP=> i j; rewrite !mxE mulrDr. Qed. + +Lemma scalemxA x y A : x *m: (y *m: A) = (x * y) *m: A. +Proof. by apply/matrixP=> i j; rewrite !mxE mulrA. Qed. + +Definition matrix_lmodMixin := + LmodMixin scalemxA scale1mx scalemxDr scalemxDl. + +Canonical matrix_lmodType := + Eval hnf in LmodType R 'M[R]_(m, n) matrix_lmodMixin. + +Lemma scalemx_const a b : a *: const_mx b = const_mx (a * b). +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma matrix_sum_delta A : + A = \sum_(i < m) \sum_(j < n) A i j *: delta_mx i j. +Proof. +apply/matrixP=> i j. +rewrite summxE (bigD1 i) // summxE (bigD1 j) //= !mxE !eqxx mulr1. +rewrite !big1 ?addr0 //= => [i' | j']; rewrite eq_sym => /negbTE diff. + by rewrite summxE big1 // => j' _; rewrite !mxE diff mulr0. +by rewrite !mxE eqxx diff mulr0. +Qed. + +End RingModule. + +Section StructuralLinear. + +Lemma swizzle_mx_is_scalable m n p q f g k : + scalable (@swizzle_mx R m n p q f g k). +Proof. by move=> a A; apply/matrixP=> i j; rewrite !mxE. Qed. +Canonical swizzle_mx_scalable m n p q f g k := + AddLinear (@swizzle_mx_is_scalable m n p q f g k). + +Local Notation SwizzleLin op := [linear of op as swizzle_mx _ _ _]. + +Canonical trmx_linear m n := SwizzleLin (@trmx R m n). +Canonical row_linear m n i := SwizzleLin (@row R m n i). +Canonical col_linear m n j := SwizzleLin (@col R m n j). +Canonical row'_linear m n i := SwizzleLin (@row' R m n i). +Canonical col'_linear m n j := SwizzleLin (@col' R m n j). +Canonical row_perm_linear m n s := SwizzleLin (@row_perm R m n s). +Canonical col_perm_linear m n s := SwizzleLin (@col_perm R m n s). +Canonical xrow_linear m n i1 i2 := SwizzleLin (@xrow R m n i1 i2). +Canonical xcol_linear m n j1 j2 := SwizzleLin (@xcol R m n j1 j2). +Canonical lsubmx_linear m n1 n2 := SwizzleLin (@lsubmx R m n1 n2). +Canonical rsubmx_linear m n1 n2 := SwizzleLin (@rsubmx R m n1 n2). +Canonical usubmx_linear m1 m2 n := SwizzleLin (@usubmx R m1 m2 n). +Canonical dsubmx_linear m1 m2 n := SwizzleLin (@dsubmx R m1 m2 n). +Canonical vec_mx_linear m n := SwizzleLin (@vec_mx R m n). +Definition mxvec_is_linear m n := can2_linear (@vec_mxK R m n) mxvecK. +Canonical mxvec_linear m n := AddLinear (@mxvec_is_linear m n). + +End StructuralLinear. + +Lemma trmx_delta m n i j : (delta_mx i j)^T = delta_mx j i :> 'M[R]_(n, m). +Proof. by apply/matrixP=> i' j'; rewrite !mxE andbC. Qed. + +Lemma row_sum_delta n (u : 'rV_n) : u = \sum_(j < n) u 0 j *: delta_mx 0 j. +Proof. by rewrite {1}[u]matrix_sum_delta big_ord1. Qed. + +Lemma delta_mx_lshift m n1 n2 i j : + delta_mx i (lshift n2 j) = row_mx (delta_mx i j) 0 :> 'M_(m, n1 + n2). +Proof. +apply/matrixP=> i' j'; rewrite !mxE -(can_eq (@splitK _ _)). +by rewrite (unsplitK (inl _ _)); case: split => ?; rewrite mxE ?andbF. +Qed. + +Lemma delta_mx_rshift m n1 n2 i j : + delta_mx i (rshift n1 j) = row_mx 0 (delta_mx i j) :> 'M_(m, n1 + n2). +Proof. +apply/matrixP=> i' j'; rewrite !mxE -(can_eq (@splitK _ _)). +by rewrite (unsplitK (inr _ _)); case: split => ?; rewrite mxE ?andbF. +Qed. + +Lemma delta_mx_ushift m1 m2 n i j : + delta_mx (lshift m2 i) j = col_mx (delta_mx i j) 0 :> 'M_(m1 + m2, n). +Proof. +apply/matrixP=> i' j'; rewrite !mxE -(can_eq (@splitK _ _)). +by rewrite (unsplitK (inl _ _)); case: split => ?; rewrite mxE. +Qed. + +Lemma delta_mx_dshift m1 m2 n i j : + delta_mx (rshift m1 i) j = col_mx 0 (delta_mx i j) :> 'M_(m1 + m2, n). +Proof. +apply/matrixP=> i' j'; rewrite !mxE -(can_eq (@splitK _ _)). +by rewrite (unsplitK (inr _ _)); case: split => ?; rewrite mxE. +Qed. + +Lemma vec_mx_delta m n i j : + vec_mx (delta_mx 0 (mxvec_index i j)) = delta_mx i j :> 'M_(m, n). +Proof. +by apply/matrixP=> i' j'; rewrite !mxE /= [_ == _](inj_eq enum_rank_inj). +Qed. + +Lemma mxvec_delta m n i j : + mxvec (delta_mx i j) = delta_mx 0 (mxvec_index i j) :> 'rV_(m * n). +Proof. by rewrite -vec_mx_delta vec_mxK. Qed. + +Ltac split_mxE := apply/matrixP=> i j; do ![rewrite mxE | case: split => ?]. + +Lemma scale_row_mx m n1 n2 a (A1 : 'M_(m, n1)) (A2 : 'M_(m, n2)) : + a *: row_mx A1 A2 = row_mx (a *: A1) (a *: A2). +Proof. by split_mxE. Qed. + +Lemma scale_col_mx m1 m2 n a (A1 : 'M_(m1, n)) (A2 : 'M_(m2, n)) : + a *: col_mx A1 A2 = col_mx (a *: A1) (a *: A2). +Proof. by split_mxE. Qed. + +Lemma scale_block_mx m1 m2 n1 n2 a (Aul : 'M_(m1, n1)) (Aur : 'M_(m1, n2)) + (Adl : 'M_(m2, n1)) (Adr : 'M_(m2, n2)) : + a *: block_mx Aul Aur Adl Adr + = block_mx (a *: Aul) (a *: Aur) (a *: Adl) (a *: Adr). +Proof. by rewrite scale_col_mx !scale_row_mx. Qed. + +(* Diagonal matrices *) + +Fact diag_mx_key : unit. Proof. by []. Qed. +Definition diag_mx n (d : 'rV[R]_n) := + \matrix[diag_mx_key]_(i, j) (d 0 i *+ (i == j)). + +Lemma tr_diag_mx n (d : 'rV_n) : (diag_mx d)^T = diag_mx d. +Proof. by apply/matrixP=> i j; rewrite !mxE eq_sym; case: eqP => // ->. Qed. + +Lemma diag_mx_is_linear n : linear (@diag_mx n). +Proof. +by move=> a A B; apply/matrixP=> i j; rewrite !mxE mulrnAr mulrnDl. +Qed. +Canonical diag_mx_additive n := Additive (@diag_mx_is_linear n). +Canonical diag_mx_linear n := Linear (@diag_mx_is_linear n). + +Lemma diag_mx_sum_delta n (d : 'rV_n) : + diag_mx d = \sum_i d 0 i *: delta_mx i i. +Proof. +apply/matrixP=> i j; rewrite summxE (bigD1 i) //= !mxE eqxx /=. +rewrite eq_sym mulr_natr big1 ?addr0 // => i' ne_i'i. +by rewrite !mxE eq_sym (negbTE ne_i'i) mulr0. +Qed. + +(* Scalar matrix : a diagonal matrix with a constant on the diagonal *) +Section ScalarMx. + +Variable n : nat. + +Fact scalar_mx_key : unit. Proof. by []. Qed. +Definition scalar_mx x : 'M[R]_n := + \matrix[scalar_mx_key]_(i , j) (x *+ (i == j)). +Notation "x %:M" := (scalar_mx x) : ring_scope. + +Lemma diag_const_mx a : diag_mx (const_mx a) = a%:M :> 'M_n. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma tr_scalar_mx a : (a%:M)^T = a%:M. +Proof. by apply/matrixP=> i j; rewrite !mxE eq_sym. Qed. + +Lemma trmx1 : (1%:M)^T = 1%:M. Proof. exact: tr_scalar_mx. Qed. + +Lemma scalar_mx_is_additive : additive scalar_mx. +Proof. by move=> a b; rewrite -!diag_const_mx !raddfB. Qed. +Canonical scalar_mx_additive := Additive scalar_mx_is_additive. + +Lemma scale_scalar_mx a1 a2 : a1 *: a2%:M = (a1 * a2)%:M :> 'M_n. +Proof. by apply/matrixP=> i j; rewrite !mxE mulrnAr. Qed. + +Lemma scalemx1 a : a *: 1%:M = a%:M. +Proof. by rewrite scale_scalar_mx mulr1. Qed. + +Lemma scalar_mx_sum_delta a : a%:M = \sum_i a *: delta_mx i i. +Proof. +by rewrite -diag_const_mx diag_mx_sum_delta; apply: eq_bigr => i _; rewrite mxE. +Qed. + +Lemma mx1_sum_delta : 1%:M = \sum_i delta_mx i i. +Proof. by rewrite [1%:M]scalar_mx_sum_delta -scaler_sumr scale1r. Qed. + +Lemma row1 i : row i 1%:M = delta_mx 0 i. +Proof. by apply/rowP=> j; rewrite !mxE eq_sym. Qed. + +Definition is_scalar_mx (A : 'M[R]_n) := + if insub 0%N is Some i then A == (A i i)%:M else true. + +Lemma is_scalar_mxP A : reflect (exists a, A = a%:M) (is_scalar_mx A). +Proof. +rewrite /is_scalar_mx; case: insubP => [i _ _ | ]. + by apply: (iffP eqP) => [|[a ->]]; [exists (A i i) | rewrite mxE eqxx]. +rewrite -eqn0Ngt => /eqP n0; left; exists 0. +by rewrite raddf0; rewrite n0 in A *; rewrite [A]flatmx0. +Qed. + +Lemma scalar_mx_is_scalar a : is_scalar_mx a%:M. +Proof. by apply/is_scalar_mxP; exists a. Qed. + +Lemma mx0_is_scalar : is_scalar_mx 0. +Proof. by apply/is_scalar_mxP; exists 0; rewrite raddf0. Qed. + +End ScalarMx. + +Notation "x %:M" := (scalar_mx _ x) : ring_scope. + +Lemma mx11_scalar (A : 'M_1) : A = (A 0 0)%:M. +Proof. by apply/rowP=> j; rewrite ord1 mxE. Qed. + +Lemma scalar_mx_block n1 n2 a : a%:M = block_mx a%:M 0 0 a%:M :> 'M_(n1 + n2). +Proof. +apply/matrixP=> i j; rewrite !mxE -val_eqE /=. +by do 2![case: splitP => ? ->; rewrite !mxE]; + rewrite ?eqn_add2l // -?(eq_sym (n1 + _)%N) eqn_leq leqNgt lshift_subproof. +Qed. + +(* Matrix multiplication using bigops. *) +Fact mulmx_key : unit. Proof. by []. Qed. +Definition mulmx {m n p} (A : 'M_(m, n)) (B : 'M_(n, p)) : 'M[R]_(m, p) := + \matrix[mulmx_key]_(i, k) \sum_j (A i j * B j k). + +Local Notation "A *m B" := (mulmx A B) : ring_scope. + +Lemma mulmxA m n p q (A : 'M_(m, n)) (B : 'M_(n, p)) (C : 'M_(p, q)) : + A *m (B *m C) = A *m B *m C. +Proof. +apply/matrixP=> i l; rewrite !mxE. +transitivity (\sum_j (\sum_k (A i j * (B j k * C k l)))). + by apply: eq_bigr => j _; rewrite mxE big_distrr. +rewrite exchange_big; apply: eq_bigr => j _; rewrite mxE big_distrl /=. +by apply: eq_bigr => k _; rewrite mulrA. +Qed. + +Lemma mul0mx m n p (A : 'M_(n, p)) : 0 *m A = 0 :> 'M_(m, p). +Proof. +by apply/matrixP=> i k; rewrite !mxE big1 //= => j _; rewrite mxE mul0r. +Qed. + +Lemma mulmx0 m n p (A : 'M_(m, n)) : A *m 0 = 0 :> 'M_(m, p). +Proof. +by apply/matrixP=> i k; rewrite !mxE big1 // => j _; rewrite mxE mulr0. +Qed. + +Lemma mulmxN m n p (A : 'M_(m, n)) (B : 'M_(n, p)) : A *m (- B) = - (A *m B). +Proof. +apply/matrixP=> i k; rewrite !mxE -sumrN. +by apply: eq_bigr => j _; rewrite mxE mulrN. +Qed. + +Lemma mulNmx m n p (A : 'M_(m, n)) (B : 'M_(n, p)) : - A *m B = - (A *m B). +Proof. +apply/matrixP=> i k; rewrite !mxE -sumrN. +by apply: eq_bigr => j _; rewrite mxE mulNr. +Qed. + +Lemma mulmxDl m n p (A1 A2 : 'M_(m, n)) (B : 'M_(n, p)) : + (A1 + A2) *m B = A1 *m B + A2 *m B. +Proof. +apply/matrixP=> i k; rewrite !mxE -big_split /=. +by apply: eq_bigr => j _; rewrite !mxE -mulrDl. +Qed. + +Lemma mulmxDr m n p (A : 'M_(m, n)) (B1 B2 : 'M_(n, p)) : + A *m (B1 + B2) = A *m B1 + A *m B2. +Proof. +apply/matrixP=> i k; rewrite !mxE -big_split /=. +by apply: eq_bigr => j _; rewrite mxE mulrDr. +Qed. + +Lemma mulmxBl m n p (A1 A2 : 'M_(m, n)) (B : 'M_(n, p)) : + (A1 - A2) *m B = A1 *m B - A2 *m B. +Proof. by rewrite mulmxDl mulNmx. Qed. + +Lemma mulmxBr m n p (A : 'M_(m, n)) (B1 B2 : 'M_(n, p)) : + A *m (B1 - B2) = A *m B1 - A *m B2. +Proof. by rewrite mulmxDr mulmxN. Qed. + +Lemma mulmx_suml m n p (A : 'M_(n, p)) I r P (B_ : I -> 'M_(m, n)) : + (\sum_(i <- r | P i) B_ i) *m A = \sum_(i <- r | P i) B_ i *m A. +Proof. +by apply: (big_morph (mulmx^~ A)) => [B C|]; rewrite ?mul0mx ?mulmxDl. +Qed. + +Lemma mulmx_sumr m n p (A : 'M_(m, n)) I r P (B_ : I -> 'M_(n, p)) : + A *m (\sum_(i <- r | P i) B_ i) = \sum_(i <- r | P i) A *m B_ i. +Proof. +by apply: (big_morph (mulmx A)) => [B C|]; rewrite ?mulmx0 ?mulmxDr. +Qed. + +Lemma scalemxAl m n p a (A : 'M_(m, n)) (B : 'M_(n, p)) : + a *: (A *m B) = (a *: A) *m B. +Proof. +apply/matrixP=> i k; rewrite !mxE big_distrr /=. +by apply: eq_bigr => j _; rewrite mulrA mxE. +Qed. +(* Right scaling associativity requires a commutative ring *) + +Lemma rowE m n i (A : 'M_(m, n)) : row i A = delta_mx 0 i *m A. +Proof. +apply/rowP=> j; rewrite !mxE (bigD1 i) //= mxE !eqxx mul1r. +by rewrite big1 ?addr0 // => i' ne_i'i; rewrite mxE /= (negbTE ne_i'i) mul0r. +Qed. + +Lemma row_mul m n p (i : 'I_m) A (B : 'M_(n, p)) : + row i (A *m B) = row i A *m B. +Proof. by rewrite !rowE mulmxA. Qed. + +Lemma mulmx_sum_row m n (u : 'rV_m) (A : 'M_(m, n)) : + u *m A = \sum_i u 0 i *: row i A. +Proof. +by apply/rowP=> j; rewrite mxE summxE; apply: eq_bigr => i _; rewrite !mxE. +Qed. + +Lemma mul_delta_mx_cond m n p (j1 j2 : 'I_n) (i1 : 'I_m) (k2 : 'I_p) : + delta_mx i1 j1 *m delta_mx j2 k2 = delta_mx i1 k2 *+ (j1 == j2). +Proof. +apply/matrixP=> i k; rewrite !mxE (bigD1 j1) //=. +rewrite mulmxnE !mxE !eqxx andbT -natrM -mulrnA !mulnb !andbA andbAC. +by rewrite big1 ?addr0 // => j; rewrite !mxE andbC -natrM; move/negbTE->. +Qed. + +Lemma mul_delta_mx m n p (j : 'I_n) (i : 'I_m) (k : 'I_p) : + delta_mx i j *m delta_mx j k = delta_mx i k. +Proof. by rewrite mul_delta_mx_cond eqxx. Qed. + +Lemma mul_delta_mx_0 m n p (j1 j2 : 'I_n) (i1 : 'I_m) (k2 : 'I_p) : + j1 != j2 -> delta_mx i1 j1 *m delta_mx j2 k2 = 0. +Proof. by rewrite mul_delta_mx_cond => /negbTE->. Qed. + +Lemma mul_diag_mx m n d (A : 'M_(m, n)) : + diag_mx d *m A = \matrix_(i, j) (d 0 i * A i j). +Proof. +apply/matrixP=> i j; rewrite !mxE (bigD1 i) //= mxE eqxx big1 ?addr0 // => i'. +by rewrite mxE eq_sym mulrnAl => /negbTE->. +Qed. + +Lemma mul_mx_diag m n (A : 'M_(m, n)) d : + A *m diag_mx d = \matrix_(i, j) (A i j * d 0 j). +Proof. +apply/matrixP=> i j; rewrite !mxE (bigD1 j) //= mxE eqxx big1 ?addr0 // => i'. +by rewrite mxE eq_sym mulrnAr; move/negbTE->. +Qed. + +Lemma mulmx_diag n (d e : 'rV_n) : + diag_mx d *m diag_mx e = diag_mx (\row_j (d 0 j * e 0 j)). +Proof. by apply/matrixP=> i j; rewrite mul_diag_mx !mxE mulrnAr. Qed. + +Lemma mul_scalar_mx m n a (A : 'M_(m, n)) : a%:M *m A = a *: A. +Proof. +by rewrite -diag_const_mx mul_diag_mx; apply/matrixP=> i j; rewrite !mxE. +Qed. + +Lemma scalar_mxM n a b : (a * b)%:M = a%:M *m b%:M :> 'M_n. +Proof. by rewrite mul_scalar_mx scale_scalar_mx. Qed. + +Lemma mul1mx m n (A : 'M_(m, n)) : 1%:M *m A = A. +Proof. by rewrite mul_scalar_mx scale1r. Qed. + +Lemma mulmx1 m n (A : 'M_(m, n)) : A *m 1%:M = A. +Proof. +rewrite -diag_const_mx mul_mx_diag. +by apply/matrixP=> i j; rewrite !mxE mulr1. +Qed. + +Lemma mul_col_perm m n p s (A : 'M_(m, n)) (B : 'M_(n, p)) : + col_perm s A *m B = A *m row_perm s^-1 B. +Proof. +apply/matrixP=> i k; rewrite !mxE (reindex_inj (@perm_inj _ s^-1)). +by apply: eq_bigr => j _ /=; rewrite !mxE permKV. +Qed. + +Lemma mul_row_perm m n p s (A : 'M_(m, n)) (B : 'M_(n, p)) : + A *m row_perm s B = col_perm s^-1 A *m B. +Proof. by rewrite mul_col_perm invgK. Qed. + +Lemma mul_xcol m n p j1 j2 (A : 'M_(m, n)) (B : 'M_(n, p)) : + xcol j1 j2 A *m B = A *m xrow j1 j2 B. +Proof. by rewrite mul_col_perm tpermV. Qed. + +(* Permutation matrix *) + +Definition perm_mx n s : 'M_n := row_perm s 1%:M. + +Definition tperm_mx n i1 i2 : 'M_n := perm_mx (tperm i1 i2). + +Lemma col_permE m n s (A : 'M_(m, n)) : col_perm s A = A *m perm_mx s^-1. +Proof. by rewrite mul_row_perm mulmx1 invgK. Qed. + +Lemma row_permE m n s (A : 'M_(m, n)) : row_perm s A = perm_mx s *m A. +Proof. +by rewrite -[perm_mx _]mul1mx mul_row_perm mulmx1 -mul_row_perm mul1mx. +Qed. + +Lemma xcolE m n j1 j2 (A : 'M_(m, n)) : xcol j1 j2 A = A *m tperm_mx j1 j2. +Proof. by rewrite /xcol col_permE tpermV. Qed. + +Lemma xrowE m n i1 i2 (A : 'M_(m, n)) : xrow i1 i2 A = tperm_mx i1 i2 *m A. +Proof. exact: row_permE. Qed. + +Lemma tr_perm_mx n (s : 'S_n) : (perm_mx s)^T = perm_mx s^-1. +Proof. by rewrite -[_^T]mulmx1 tr_row_perm mul_col_perm trmx1 mul1mx. Qed. + +Lemma tr_tperm_mx n i1 i2 : (tperm_mx i1 i2)^T = tperm_mx i1 i2 :> 'M_n. +Proof. by rewrite tr_perm_mx tpermV. Qed. + +Lemma perm_mx1 n : perm_mx 1 = 1%:M :> 'M_n. +Proof. exact: row_perm1. Qed. + +Lemma perm_mxM n (s t : 'S_n) : perm_mx (s * t) = perm_mx s *m perm_mx t. +Proof. by rewrite -row_permE -row_permM. Qed. + +Definition is_perm_mx n (A : 'M_n) := [exists s, A == perm_mx s]. + +Lemma is_perm_mxP n (A : 'M_n) : + reflect (exists s, A = perm_mx s) (is_perm_mx A). +Proof. by apply: (iffP existsP) => [] [s /eqP]; exists s. Qed. + +Lemma perm_mx_is_perm n (s : 'S_n) : is_perm_mx (perm_mx s). +Proof. by apply/is_perm_mxP; exists s. Qed. + +Lemma is_perm_mx1 n : is_perm_mx (1%:M : 'M_n). +Proof. by rewrite -perm_mx1 perm_mx_is_perm. Qed. + +Lemma is_perm_mxMl n (A B : 'M_n) : + is_perm_mx A -> is_perm_mx (A *m B) = is_perm_mx B. +Proof. +case/is_perm_mxP=> s ->. +apply/is_perm_mxP/is_perm_mxP=> [[t def_t] | [t ->]]; last first. + by exists (s * t)%g; rewrite perm_mxM. +exists (s^-1 * t)%g. +by rewrite perm_mxM -def_t -!row_permE -row_permM mulVg row_perm1. +Qed. + +Lemma is_perm_mx_tr n (A : 'M_n) : is_perm_mx A^T = is_perm_mx A. +Proof. +apply/is_perm_mxP/is_perm_mxP=> [[t def_t] | [t ->]]; exists t^-1%g. + by rewrite -tr_perm_mx -def_t trmxK. +by rewrite tr_perm_mx. +Qed. + +Lemma is_perm_mxMr n (A B : 'M_n) : + is_perm_mx B -> is_perm_mx (A *m B) = is_perm_mx A. +Proof. +case/is_perm_mxP=> s ->. +rewrite -[s]invgK -col_permE -is_perm_mx_tr tr_col_perm row_permE. +by rewrite is_perm_mxMl (perm_mx_is_perm, is_perm_mx_tr). +Qed. + +(* Partial identity matrix (used in rank decomposition). *) + +Fact pid_mx_key : unit. Proof. by []. Qed. +Definition pid_mx {m n} r : 'M[R]_(m, n) := + \matrix[pid_mx_key]_(i, j) ((i == j :> nat) && (i < r))%:R. + +Lemma pid_mx_0 m n : pid_mx 0 = 0 :> 'M_(m, n). +Proof. by apply/matrixP=> i j; rewrite !mxE andbF. Qed. + +Lemma pid_mx_1 r : pid_mx r = 1%:M :> 'M_r. +Proof. by apply/matrixP=> i j; rewrite !mxE ltn_ord andbT. Qed. + +Lemma pid_mx_row n r : pid_mx r = row_mx 1%:M 0 :> 'M_(r, r + n). +Proof. +apply/matrixP=> i j; rewrite !mxE ltn_ord andbT. +case: splitP => j' ->; rewrite !mxE // . +by rewrite eqn_leq andbC leqNgt lshift_subproof. +Qed. + +Lemma pid_mx_col m r : pid_mx r = col_mx 1%:M 0 :> 'M_(r + m, r). +Proof. +apply/matrixP=> i j; rewrite !mxE andbC. +by case: splitP => i' ->; rewrite !mxE // eq_sym. +Qed. + +Lemma pid_mx_block m n r : pid_mx r = block_mx 1%:M 0 0 0 :> 'M_(r + m, r + n). +Proof. +apply/matrixP=> i j; rewrite !mxE row_mx0 andbC. +case: splitP => i' ->; rewrite !mxE //; case: splitP => j' ->; rewrite !mxE //=. +by rewrite eqn_leq andbC leqNgt lshift_subproof. +Qed. + +Lemma tr_pid_mx m n r : (pid_mx r)^T = pid_mx r :> 'M_(n, m). +Proof. by apply/matrixP=> i j; rewrite !mxE eq_sym; case: eqP => // ->. Qed. + +Lemma pid_mx_minv m n r : pid_mx (minn m r) = pid_mx r :> 'M_(m, n). +Proof. by apply/matrixP=> i j; rewrite !mxE leq_min ltn_ord. Qed. + +Lemma pid_mx_minh m n r : pid_mx (minn n r) = pid_mx r :> 'M_(m, n). +Proof. by apply: trmx_inj; rewrite !tr_pid_mx pid_mx_minv. Qed. + +Lemma mul_pid_mx m n p q r : + (pid_mx q : 'M_(m, n)) *m (pid_mx r : 'M_(n, p)) = pid_mx (minn n (minn q r)). +Proof. +apply/matrixP=> i k; rewrite !mxE !leq_min. +have [le_n_i | lt_i_n] := leqP n i. + rewrite andbF big1 // => j _. + by rewrite -pid_mx_minh !mxE leq_min ltnNge le_n_i andbF mul0r. +rewrite (bigD1 (Ordinal lt_i_n)) //= big1 ?addr0 => [|j]. + by rewrite !mxE eqxx /= -natrM mulnb andbCA. +by rewrite -val_eqE /= !mxE eq_sym -natrM => /negbTE->. +Qed. + +Lemma pid_mx_id m n p r : + r <= n -> (pid_mx r : 'M_(m, n)) *m (pid_mx r : 'M_(n, p)) = pid_mx r. +Proof. by move=> le_r_n; rewrite mul_pid_mx minnn (minn_idPr _). Qed. + +Definition copid_mx {n} r : 'M_n := 1%:M - pid_mx r. + +Lemma mul_copid_mx_pid m n r : + r <= m -> copid_mx r *m pid_mx r = 0 :> 'M_(m, n). +Proof. by move=> le_r_m; rewrite mulmxBl mul1mx pid_mx_id ?subrr. Qed. + +Lemma mul_pid_mx_copid m n r : + r <= n -> pid_mx r *m copid_mx r = 0 :> 'M_(m, n). +Proof. by move=> le_r_n; rewrite mulmxBr mulmx1 pid_mx_id ?subrr. Qed. + +Lemma copid_mx_id n r : + r <= n -> copid_mx r *m copid_mx r = copid_mx r :> 'M_n. +Proof. +by move=> le_r_n; rewrite mulmxBl mul1mx mul_pid_mx_copid // oppr0 addr0. +Qed. + +(* Block products; we cover all 1 x 2, 2 x 1, and 2 x 2 block products. *) +Lemma mul_mx_row m n p1 p2 (A : 'M_(m, n)) (Bl : 'M_(n, p1)) (Br : 'M_(n, p2)) : + A *m row_mx Bl Br = row_mx (A *m Bl) (A *m Br). +Proof. +apply/matrixP=> i k; rewrite !mxE. +by case defk: (split k); rewrite mxE; apply: eq_bigr => j _; rewrite mxE defk. +Qed. + +Lemma mul_col_mx m1 m2 n p (Au : 'M_(m1, n)) (Ad : 'M_(m2, n)) (B : 'M_(n, p)) : + col_mx Au Ad *m B = col_mx (Au *m B) (Ad *m B). +Proof. +apply/matrixP=> i k; rewrite !mxE. +by case defi: (split i); rewrite mxE; apply: eq_bigr => j _; rewrite mxE defi. +Qed. + +Lemma mul_row_col m n1 n2 p (Al : 'M_(m, n1)) (Ar : 'M_(m, n2)) + (Bu : 'M_(n1, p)) (Bd : 'M_(n2, p)) : + row_mx Al Ar *m col_mx Bu Bd = Al *m Bu + Ar *m Bd. +Proof. +apply/matrixP=> i k; rewrite !mxE big_split_ord /=. +congr (_ + _); apply: eq_bigr => j _; first by rewrite row_mxEl col_mxEu. +by rewrite row_mxEr col_mxEd. +Qed. + +Lemma mul_col_row m1 m2 n p1 p2 (Au : 'M_(m1, n)) (Ad : 'M_(m2, n)) + (Bl : 'M_(n, p1)) (Br : 'M_(n, p2)) : + col_mx Au Ad *m row_mx Bl Br + = block_mx (Au *m Bl) (Au *m Br) (Ad *m Bl) (Ad *m Br). +Proof. by rewrite mul_col_mx !mul_mx_row. Qed. + +Lemma mul_row_block m n1 n2 p1 p2 (Al : 'M_(m, n1)) (Ar : 'M_(m, n2)) + (Bul : 'M_(n1, p1)) (Bur : 'M_(n1, p2)) + (Bdl : 'M_(n2, p1)) (Bdr : 'M_(n2, p2)) : + row_mx Al Ar *m block_mx Bul Bur Bdl Bdr + = row_mx (Al *m Bul + Ar *m Bdl) (Al *m Bur + Ar *m Bdr). +Proof. by rewrite block_mxEh mul_mx_row !mul_row_col. Qed. + +Lemma mul_block_col m1 m2 n1 n2 p (Aul : 'M_(m1, n1)) (Aur : 'M_(m1, n2)) + (Adl : 'M_(m2, n1)) (Adr : 'M_(m2, n2)) + (Bu : 'M_(n1, p)) (Bd : 'M_(n2, p)) : + block_mx Aul Aur Adl Adr *m col_mx Bu Bd + = col_mx (Aul *m Bu + Aur *m Bd) (Adl *m Bu + Adr *m Bd). +Proof. by rewrite mul_col_mx !mul_row_col. Qed. + +Lemma mulmx_block m1 m2 n1 n2 p1 p2 (Aul : 'M_(m1, n1)) (Aur : 'M_(m1, n2)) + (Adl : 'M_(m2, n1)) (Adr : 'M_(m2, n2)) + (Bul : 'M_(n1, p1)) (Bur : 'M_(n1, p2)) + (Bdl : 'M_(n2, p1)) (Bdr : 'M_(n2, p2)) : + block_mx Aul Aur Adl Adr *m block_mx Bul Bur Bdl Bdr + = block_mx (Aul *m Bul + Aur *m Bdl) (Aul *m Bur + Aur *m Bdr) + (Adl *m Bul + Adr *m Bdl) (Adl *m Bur + Adr *m Bdr). +Proof. by rewrite mul_col_mx !mul_row_block. Qed. + +(* Correspondance between matrices and linear function on row vectors. *) +Section LinRowVector. + +Variables m n : nat. + +Fact lin1_mx_key : unit. Proof. by []. Qed. +Definition lin1_mx (f : 'rV[R]_m -> 'rV[R]_n) := + \matrix[lin1_mx_key]_(i, j) f (delta_mx 0 i) 0 j. + +Variable f : {linear 'rV[R]_m -> 'rV[R]_n}. + +Lemma mul_rV_lin1 u : u *m lin1_mx f = f u. +Proof. +rewrite {2}[u]matrix_sum_delta big_ord1 linear_sum; apply/rowP=> i. +by rewrite mxE summxE; apply: eq_bigr => j _; rewrite linearZ !mxE. +Qed. + +End LinRowVector. + +(* Correspondance between matrices and linear function on matrices. *) +Section LinMatrix. + +Variables m1 n1 m2 n2 : nat. + +Definition lin_mx (f : 'M[R]_(m1, n1) -> 'M[R]_(m2, n2)) := + lin1_mx (mxvec \o f \o vec_mx). + +Variable f : {linear 'M[R]_(m1, n1) -> 'M[R]_(m2, n2)}. + +Lemma mul_rV_lin u : u *m lin_mx f = mxvec (f (vec_mx u)). +Proof. exact: mul_rV_lin1. Qed. + +Lemma mul_vec_lin A : mxvec A *m lin_mx f = mxvec (f A). +Proof. by rewrite mul_rV_lin mxvecK. Qed. + +Lemma mx_rV_lin u : vec_mx (u *m lin_mx f) = f (vec_mx u). +Proof. by rewrite mul_rV_lin mxvecK. Qed. + +Lemma mx_vec_lin A : vec_mx (mxvec A *m lin_mx f) = f A. +Proof. by rewrite mul_rV_lin !mxvecK. Qed. + +End LinMatrix. + +Canonical mulmx_additive m n p A := Additive (@mulmxBr m n p A). + +Section Mulmxr. + +Variables m n p : nat. +Implicit Type A : 'M[R]_(m, n). +Implicit Type B : 'M[R]_(n, p). + +Definition mulmxr_head t B A := let: tt := t in A *m B. +Local Notation mulmxr := (mulmxr_head tt). + +Definition lin_mulmxr B := lin_mx (mulmxr B). + +Lemma mulmxr_is_linear B : linear (mulmxr B). +Proof. by move=> a A1 A2; rewrite /= mulmxDl scalemxAl. Qed. +Canonical mulmxr_additive B := Additive (mulmxr_is_linear B). +Canonical mulmxr_linear B := Linear (mulmxr_is_linear B). + +Lemma lin_mulmxr_is_linear : linear lin_mulmxr. +Proof. +move=> a A B; apply/row_matrixP; case/mxvec_indexP=> i j. +rewrite linearP /= !rowE !mul_rV_lin /= vec_mx_delta -linearP mulmxDr. +congr (mxvec (_ + _)); apply/row_matrixP=> k. +rewrite linearZ /= !row_mul rowE mul_delta_mx_cond. +by case: (k == i); [rewrite -!rowE linearZ | rewrite !mul0mx raddf0]. +Qed. +Canonical lin_mulmxr_additive := Additive lin_mulmxr_is_linear. +Canonical lin_mulmxr_linear := Linear lin_mulmxr_is_linear. + +End Mulmxr. + +(* The trace. *) +Section Trace. + +Variable n : nat. + +Definition mxtrace (A : 'M[R]_n) := \sum_i A i i. +Local Notation "'\tr' A" := (mxtrace A) : ring_scope. + +Lemma mxtrace_tr A : \tr A^T = \tr A. +Proof. by apply: eq_bigr=> i _; rewrite mxE. Qed. + +Lemma mxtrace_is_scalar : scalar mxtrace. +Proof. +move=> a A B; rewrite mulr_sumr -big_split /=; apply: eq_bigr=> i _. +by rewrite !mxE. +Qed. +Canonical mxtrace_additive := Additive mxtrace_is_scalar. +Canonical mxtrace_linear := Linear mxtrace_is_scalar. + +Lemma mxtrace0 : \tr 0 = 0. Proof. exact: raddf0. Qed. +Lemma mxtraceD A B : \tr (A + B) = \tr A + \tr B. Proof. exact: raddfD. Qed. +Lemma mxtraceZ a A : \tr (a *: A) = a * \tr A. Proof. exact: scalarZ. Qed. + +Lemma mxtrace_diag D : \tr (diag_mx D) = \sum_j D 0 j. +Proof. by apply: eq_bigr => j _; rewrite mxE eqxx. Qed. + +Lemma mxtrace_scalar a : \tr a%:M = a *+ n. +Proof. +rewrite -diag_const_mx mxtrace_diag. +by rewrite (eq_bigr _ (fun j _ => mxE _ _ 0 j)) sumr_const card_ord. +Qed. + +Lemma mxtrace1 : \tr 1%:M = n%:R. Proof. exact: mxtrace_scalar. Qed. + +End Trace. +Local Notation "'\tr' A" := (mxtrace A) : ring_scope. + +Lemma trace_mx11 (A : 'M_1) : \tr A = A 0 0. +Proof. by rewrite {1}[A]mx11_scalar mxtrace_scalar. Qed. + +Lemma mxtrace_block n1 n2 (Aul : 'M_n1) Aur Adl (Adr : 'M_n2) : + \tr (block_mx Aul Aur Adl Adr) = \tr Aul + \tr Adr. +Proof. +rewrite /(\tr _) big_split_ord /=. +by congr (_ + _); apply: eq_bigr => i _; rewrite (block_mxEul, block_mxEdr). +Qed. + +(* The matrix ring structure requires a strutural condition (dimension of the *) +(* form n.+1) to statisfy the nontriviality condition we have imposed. *) +Section MatrixRing. + +Variable n' : nat. +Local Notation n := n'.+1. + +Lemma matrix_nonzero1 : 1%:M != 0 :> 'M_n. +Proof. by apply/eqP=> /matrixP/(_ 0 0)/eqP; rewrite !mxE oner_eq0. Qed. + +Definition matrix_ringMixin := + RingMixin (@mulmxA n n n n) (@mul1mx n n) (@mulmx1 n n) + (@mulmxDl n n n) (@mulmxDr n n n) matrix_nonzero1. + +Canonical matrix_ringType := Eval hnf in RingType 'M[R]_n matrix_ringMixin. +Canonical matrix_lAlgType := Eval hnf in LalgType R 'M[R]_n (@scalemxAl n n n). + +Lemma mulmxE : mulmx = *%R. Proof. by []. Qed. +Lemma idmxE : 1%:M = 1 :> 'M_n. Proof. by []. Qed. + +Lemma scalar_mx_is_multiplicative : multiplicative (@scalar_mx n). +Proof. by split=> //; exact: scalar_mxM. Qed. +Canonical scalar_mx_rmorphism := AddRMorphism scalar_mx_is_multiplicative. + +End MatrixRing. + +Section LiftPerm. + +(* Block expresssion of a lifted permutation matrix, for the Cormen LUP. *) + +Variable n : nat. + +(* These could be in zmodp, but that would introduce a dependency on perm. *) + +Definition lift0_perm s : 'S_n.+1 := lift_perm 0 0 s. + +Lemma lift0_perm0 s : lift0_perm s 0 = 0. +Proof. exact: lift_perm_id. Qed. + +Lemma lift0_perm_lift s k' : + lift0_perm s (lift 0 k') = lift (0 : 'I_n.+1) (s k'). +Proof. exact: lift_perm_lift. Qed. + +Lemma lift0_permK s : cancel (lift0_perm s) (lift0_perm s^-1). +Proof. by move=> i; rewrite /lift0_perm -lift_permV permK. Qed. + +Lemma lift0_perm_eq0 s i : (lift0_perm s i == 0) = (i == 0). +Proof. by rewrite (canF_eq (lift0_permK s)) lift0_perm0. Qed. + +(* Block expresssion of a lifted permutation matrix *) + +Definition lift0_mx A : 'M_(1 + n) := block_mx 1 0 0 A. + +Lemma lift0_mx_perm s : lift0_mx (perm_mx s) = perm_mx (lift0_perm s). +Proof. +apply/matrixP=> /= i j; rewrite !mxE split1 /=; case: unliftP => [i'|] -> /=. + rewrite lift0_perm_lift !mxE split1 /=. + by case: unliftP => [j'|] ->; rewrite ?(inj_eq (@lift_inj _ _)) /= !mxE. +rewrite lift0_perm0 !mxE split1 /=. +by case: unliftP => [j'|] ->; rewrite /= mxE. +Qed. + +Lemma lift0_mx_is_perm s : is_perm_mx (lift0_mx (perm_mx s)). +Proof. by rewrite lift0_mx_perm perm_mx_is_perm. Qed. + +End LiftPerm. + +(* Determinants and adjugates are defined here, but most of their properties *) +(* only hold for matrices over a commutative ring, so their theory is *) +(* deferred to that section. *) + +(* The determinant, in one line with the Leibniz Formula *) +Definition determinant n (A : 'M_n) : R := + \sum_(s : 'S_n) (-1) ^+ s * \prod_i A i (s i). + +(* The cofactor of a matrix on the indexes i and j *) +Definition cofactor n A (i j : 'I_n) : R := + (-1) ^+ (i + j) * determinant (row' i (col' j A)). + +(* The adjugate matrix : defined as the transpose of the matrix of cofactors *) +Fact adjugate_key : unit. Proof. by []. Qed. +Definition adjugate n (A : 'M_n) := \matrix[adjugate_key]_(i, j) cofactor A j i. + +End MatrixAlgebra. + +Implicit Arguments delta_mx [R m n]. +Implicit Arguments scalar_mx [R n]. +Implicit Arguments perm_mx [R n]. +Implicit Arguments tperm_mx [R n]. +Implicit Arguments pid_mx [R m n]. +Implicit Arguments copid_mx [R n]. +Implicit Arguments lin_mulmxr [R m n p]. +Prenex Implicits delta_mx diag_mx scalar_mx is_scalar_mx perm_mx tperm_mx. +Prenex Implicits pid_mx copid_mx mulmx lin_mulmxr. +Prenex Implicits mxtrace determinant cofactor adjugate. + +Implicit Arguments is_scalar_mxP [R n A]. +Implicit Arguments mul_delta_mx [R m n p]. +Prenex Implicits mul_delta_mx. + +Notation "a %:M" := (scalar_mx a) : ring_scope. +Notation "A *m B" := (mulmx A B) : ring_scope. +Notation mulmxr := (mulmxr_head tt). +Notation "\tr A" := (mxtrace A) : ring_scope. +Notation "'\det' A" := (determinant A) : ring_scope. +Notation "'\adj' A" := (adjugate A) : ring_scope. + +(* Non-commutative transpose requires multiplication in the converse ring. *) +Lemma trmx_mul_rev (R : ringType) m n p (A : 'M[R]_(m, n)) (B : 'M[R]_(n, p)) : + (A *m B)^T = (B : 'M[R^c]_(n, p))^T *m (A : 'M[R^c]_(m, n))^T. +Proof. +by apply/matrixP=> k i; rewrite !mxE; apply: eq_bigr => j _; rewrite !mxE. +Qed. + +Canonical matrix_finRingType (R : finRingType) n' := + Eval hnf in [finRingType of 'M[R]_n'.+1]. + +(* Parametricity over the algebra structure. *) +Section MapRingMatrix. + +Variables (aR rR : ringType) (f : {rmorphism aR -> rR}). +Local Notation "A ^f" := (map_mx f A) : ring_scope. + +Section FixedSize. + +Variables m n p : nat. +Implicit Type A : 'M[aR]_(m, n). + +Lemma map_mxZ a A : (a *: A)^f = f a *: A^f. +Proof. by apply/matrixP=> i j; rewrite !mxE rmorphM. Qed. + +Lemma map_mxM A B : (A *m B)^f = A^f *m B^f :> 'M_(m, p). +Proof. +apply/matrixP=> i k; rewrite !mxE rmorph_sum //. +by apply: eq_bigr => j; rewrite !mxE rmorphM. +Qed. + +Lemma map_delta_mx i j : (delta_mx i j)^f = delta_mx i j :> 'M_(m, n). +Proof. by apply/matrixP=> i' j'; rewrite !mxE rmorph_nat. Qed. + +Lemma map_diag_mx d : (diag_mx d)^f = diag_mx d^f :> 'M_n. +Proof. by apply/matrixP=> i j; rewrite !mxE rmorphMn. Qed. + +Lemma map_scalar_mx a : a%:M^f = (f a)%:M :> 'M_n. +Proof. by apply/matrixP=> i j; rewrite !mxE rmorphMn. Qed. + +Lemma map_mx1 : 1%:M^f = 1%:M :> 'M_n. +Proof. by rewrite map_scalar_mx rmorph1. Qed. + +Lemma map_perm_mx (s : 'S_n) : (perm_mx s)^f = perm_mx s. +Proof. by apply/matrixP=> i j; rewrite !mxE rmorph_nat. Qed. + +Lemma map_tperm_mx (i1 i2 : 'I_n) : (tperm_mx i1 i2)^f = tperm_mx i1 i2. +Proof. exact: map_perm_mx. Qed. + +Lemma map_pid_mx r : (pid_mx r)^f = pid_mx r :> 'M_(m, n). +Proof. by apply/matrixP=> i j; rewrite !mxE rmorph_nat. Qed. + +Lemma trace_map_mx (A : 'M_n) : \tr A^f = f (\tr A). +Proof. by rewrite rmorph_sum; apply: eq_bigr => i _; rewrite mxE. Qed. + +Lemma det_map_mx n' (A : 'M_n') : \det A^f = f (\det A). +Proof. +rewrite rmorph_sum //; apply: eq_bigr => s _. +rewrite rmorphM rmorph_sign rmorph_prod; congr (_ * _). +by apply: eq_bigr => i _; rewrite mxE. +Qed. + +Lemma cofactor_map_mx (A : 'M_n) i j : cofactor A^f i j = f (cofactor A i j). +Proof. by rewrite rmorphM rmorph_sign -det_map_mx map_row' map_col'. Qed. + +Lemma map_mx_adj (A : 'M_n) : (\adj A)^f = \adj A^f. +Proof. by apply/matrixP=> i j; rewrite !mxE cofactor_map_mx. Qed. + +End FixedSize. + +Lemma map_copid_mx n r : (copid_mx r)^f = copid_mx r :> 'M_n. +Proof. by rewrite map_mx_sub map_mx1 map_pid_mx. Qed. + +Lemma map_mx_is_multiplicative n' (n := n'.+1) : + multiplicative ((map_mx f) n n). +Proof. by split; [exact: map_mxM | exact: map_mx1]. Qed. + +Canonical map_mx_rmorphism n' := AddRMorphism (map_mx_is_multiplicative n'). + +Lemma map_lin1_mx m n (g : 'rV_m -> 'rV_n) gf : + (forall v, (g v)^f = gf v^f) -> (lin1_mx g)^f = lin1_mx gf. +Proof. +by move=> def_gf; apply/matrixP=> i j; rewrite !mxE -map_delta_mx -def_gf mxE. +Qed. + +Lemma map_lin_mx m1 n1 m2 n2 (g : 'M_(m1, n1) -> 'M_(m2, n2)) gf : + (forall A, (g A)^f = gf A^f) -> (lin_mx g)^f = lin_mx gf. +Proof. +move=> def_gf; apply: map_lin1_mx => A /=. +by rewrite map_mxvec def_gf map_vec_mx. +Qed. + +End MapRingMatrix. + +Section ComMatrix. +(* Lemmas for matrices with coefficients in a commutative ring *) +Variable R : comRingType. + +Section AssocLeft. + +Variables m n p : nat. +Implicit Type A : 'M[R]_(m, n). +Implicit Type B : 'M[R]_(n, p). + +Lemma trmx_mul A B : (A *m B)^T = B^T *m A^T. +Proof. +rewrite trmx_mul_rev; apply/matrixP=> k i; rewrite !mxE. +by apply: eq_bigr => j _; rewrite mulrC. +Qed. + +Lemma scalemxAr a A B : a *: (A *m B) = A *m (a *: B). +Proof. by apply: trmx_inj; rewrite trmx_mul !linearZ /= trmx_mul scalemxAl. Qed. + +Lemma mulmx_is_scalable A : scalable (@mulmx _ m n p A). +Proof. by move=> a B; rewrite scalemxAr. Qed. +Canonical mulmx_linear A := AddLinear (mulmx_is_scalable A). + +Definition lin_mulmx A : 'M[R]_(n * p, m * p) := lin_mx (mulmx A). + +Lemma lin_mulmx_is_linear : linear lin_mulmx. +Proof. +move=> a A B; apply/row_matrixP=> i; rewrite linearP /= !rowE !mul_rV_lin /=. +by rewrite [_ *m _](linearP (mulmxr_linear _ _)) linearP. +Qed. +Canonical lin_mulmx_additive := Additive lin_mulmx_is_linear. +Canonical lin_mulmx_linear := Linear lin_mulmx_is_linear. + +End AssocLeft. + +Section LinMulRow. + +Variables m n : nat. + +Definition lin_mul_row u : 'M[R]_(m * n, n) := lin1_mx (mulmx u \o vec_mx). + +Lemma lin_mul_row_is_linear : linear lin_mul_row. +Proof. +move=> a u v; apply/row_matrixP=> i; rewrite linearP /= !rowE !mul_rV_lin1 /=. +by rewrite [_ *m _](linearP (mulmxr_linear _ _)). +Qed. +Canonical lin_mul_row_additive := Additive lin_mul_row_is_linear. +Canonical lin_mul_row_linear := Linear lin_mul_row_is_linear. + +Lemma mul_vec_lin_row A u : mxvec A *m lin_mul_row u = u *m A. +Proof. by rewrite mul_rV_lin1 /= mxvecK. Qed. + +End LinMulRow. + +Lemma mxvec_dotmul m n (A : 'M[R]_(m, n)) u v : + mxvec (u^T *m v) *m (mxvec A)^T = u *m A *m v^T. +Proof. +transitivity (\sum_i \sum_j (u 0 i * A i j *: row j v^T)). + apply/rowP=> i; rewrite {i}ord1 mxE (reindex _ (curry_mxvec_bij _ _)) /=. + rewrite pair_bigA summxE; apply: eq_bigr => [[i j]] /= _. + by rewrite !mxE !mxvecE mxE big_ord1 mxE mulrAC. +rewrite mulmx_sum_row exchange_big; apply: eq_bigr => j _ /=. +by rewrite mxE -scaler_suml. +Qed. + +Section MatrixAlgType. + +Variable n' : nat. +Local Notation n := n'.+1. + +Canonical matrix_algType := + Eval hnf in AlgType R 'M[R]_n (fun k => scalemxAr k). + +End MatrixAlgType. + +Lemma diag_mxC n (d e : 'rV[R]_n) : + diag_mx d *m diag_mx e = diag_mx e *m diag_mx d. +Proof. +by rewrite !mulmx_diag; congr (diag_mx _); apply/rowP=> i; rewrite !mxE mulrC. +Qed. + +Lemma diag_mx_comm n' (d e : 'rV[R]_n'.+1) : GRing.comm (diag_mx d) (diag_mx e). +Proof. exact: diag_mxC. Qed. + +Lemma scalar_mxC m n a (A : 'M[R]_(m, n)) : A *m a%:M = a%:M *m A. +Proof. +by apply: trmx_inj; rewrite trmx_mul tr_scalar_mx !mul_scalar_mx linearZ. +Qed. + +Lemma scalar_mx_comm n' a (A : 'M[R]_n'.+1) : GRing.comm A a%:M. +Proof. exact: scalar_mxC. Qed. + +Lemma mul_mx_scalar m n a (A : 'M[R]_(m, n)) : A *m a%:M = a *: A. +Proof. by rewrite scalar_mxC mul_scalar_mx. Qed. + +Lemma mxtrace_mulC m n (A : 'M[R]_(m, n)) B : + \tr (A *m B) = \tr (B *m A). +Proof. +have expand_trM C D: \tr (C *m D) = \sum_i \sum_j C i j * D j i. + by apply: eq_bigr => i _; rewrite mxE. +rewrite !{}expand_trM exchange_big /=. +by do 2!apply: eq_bigr => ? _; apply: mulrC. +Qed. + +(* The theory of determinants *) + +Lemma determinant_multilinear n (A B C : 'M[R]_n) i0 b c : + row i0 A = b *: row i0 B + c *: row i0 C -> + row' i0 B = row' i0 A -> + row' i0 C = row' i0 A -> + \det A = b * \det B + c * \det C. +Proof. +rewrite -[_ + _](row_id 0); move/row_eq=> ABC. +move/row'_eq=> BA; move/row'_eq=> CA. +rewrite !big_distrr -big_split; apply: eq_bigr => s _ /=. +rewrite -!(mulrCA (_ ^+s)) -mulrDr; congr (_ * _). +rewrite !(bigD1 i0 (_ : predT i0)) //= {}ABC !mxE mulrDl !mulrA. +by congr (_ * _ + _ * _); apply: eq_bigr => i i0i; rewrite ?BA ?CA. +Qed. + +Lemma determinant_alternate n (A : 'M[R]_n) i1 i2 : + i1 != i2 -> A i1 =1 A i2 -> \det A = 0. +Proof. +move=> neq_i12 eqA12; pose t := tperm i1 i2. +have oddMt s: (t * s)%g = ~~ s :> bool by rewrite odd_permM odd_tperm neq_i12. +rewrite [\det A](bigID (@odd_perm _)) /=. +apply: canLR (subrK _) _; rewrite add0r -sumrN. +rewrite (reindex_inj (mulgI t)); apply: eq_big => //= s. +rewrite oddMt => /negPf->; rewrite mulN1r mul1r; congr (- _). +rewrite (reindex_inj (@perm_inj _ t)); apply: eq_bigr => /= i _. +by rewrite permM tpermK /t; case: tpermP => // ->; rewrite eqA12. +Qed. + +Lemma det_tr n (A : 'M[R]_n) : \det A^T = \det A. +Proof. +rewrite [\det A^T](reindex_inj (@invg_inj _)) /=. +apply: eq_bigr => s _ /=; rewrite !odd_permV (reindex_inj (@perm_inj _ s)) /=. +by congr (_ * _); apply: eq_bigr => i _; rewrite mxE permK. +Qed. + +Lemma det_perm n (s : 'S_n) : \det (perm_mx s) = (-1) ^+ s :> R. +Proof. +rewrite [\det _](bigD1 s) //= big1 => [|i _]; last by rewrite /= !mxE eqxx. +rewrite mulr1 big1 ?addr0 => //= t Dst. +case: (pickP (fun i => s i != t i)) => [i ist | Est]. + by rewrite (bigD1 i) // mulrCA /= !mxE (negbTE ist) mul0r. +by case/eqP: Dst; apply/permP => i; move/eqP: (Est i). +Qed. + +Lemma det1 n : \det (1%:M : 'M[R]_n) = 1. +Proof. by rewrite -perm_mx1 det_perm odd_perm1. Qed. + +Lemma det_mx00 (A : 'M[R]_0) : \det A = 1. +Proof. by rewrite flatmx0 -(flatmx0 1%:M) det1. Qed. + +Lemma detZ n a (A : 'M[R]_n) : \det (a *: A) = a ^+ n * \det A. +Proof. +rewrite big_distrr /=; apply: eq_bigr => s _; rewrite mulrCA; congr (_ * _). +rewrite -[n in a ^+ n]card_ord -prodr_const -big_split /=. +by apply: eq_bigr=> i _; rewrite mxE. +Qed. + +Lemma det0 n' : \det (0 : 'M[R]_n'.+1) = 0. +Proof. by rewrite -(scale0r 0) detZ exprS !mul0r. Qed. + +Lemma det_scalar n a : \det (a%:M : 'M[R]_n) = a ^+ n. +Proof. by rewrite -{1}(mulr1 a) -scale_scalar_mx detZ det1 mulr1. Qed. + +Lemma det_scalar1 a : \det (a%:M : 'M[R]_1) = a. +Proof. exact: det_scalar. Qed. + +Lemma det_mulmx n (A B : 'M[R]_n) : \det (A *m B) = \det A * \det B. +Proof. +rewrite big_distrl /=. +pose F := ('I_n ^ n)%type; pose AB s i j := A i j * B j (s i). +transitivity (\sum_(f : F) \sum_(s : 'S_n) (-1) ^+ s * \prod_i AB s i (f i)). + rewrite exchange_big; apply: eq_bigr => /= s _; rewrite -big_distrr /=. + congr (_ * _); rewrite -(bigA_distr_bigA (AB s)) /=. + by apply: eq_bigr => x _; rewrite mxE. +rewrite (bigID (fun f : F => injectiveb f)) /= addrC big1 ?add0r => [|f Uf]. + rewrite (reindex (@pval _)) /=; last first. + pose in_Sn := insubd (1%g : 'S_n). + by exists in_Sn => /= f Uf; first apply: val_inj; exact: insubdK. + apply: eq_big => /= [s | s _]; rewrite ?(valP s) // big_distrr /=. + rewrite (reindex_inj (mulgI s)); apply: eq_bigr => t _ /=. + rewrite big_split /= mulrA mulrCA mulrA mulrCA mulrA. + rewrite -signr_addb odd_permM !pvalE; congr (_ * _); symmetry. + by rewrite (reindex_inj (@perm_inj _ s)); apply: eq_bigr => i; rewrite permM. +transitivity (\det (\matrix_(i, j) B (f i) j) * \prod_i A i (f i)). + rewrite mulrC big_distrr /=; apply: eq_bigr => s _. + rewrite mulrCA big_split //=; congr (_ * (_ * _)). + by apply: eq_bigr => x _; rewrite mxE. +case/injectivePn: Uf => i1 [i2 Di12 Ef12]. +by rewrite (determinant_alternate Di12) ?simp //= => j; rewrite !mxE Ef12. +Qed. + +Lemma detM n' (A B : 'M[R]_n'.+1) : \det (A * B) = \det A * \det B. +Proof. exact: det_mulmx. Qed. + +Lemma det_diag n (d : 'rV[R]_n) : \det (diag_mx d) = \prod_i d 0 i. +Proof. +rewrite /(\det _) (bigD1 1%g) //= addrC big1 => [|p p1]. + by rewrite add0r odd_perm1 mul1r; apply: eq_bigr => i; rewrite perm1 mxE eqxx. +have{p1}: ~~ perm_on set0 p. + apply: contra p1; move/subsetP=> p1; apply/eqP; apply/permP=> i. + by rewrite perm1; apply/eqP; apply/idPn; move/p1; rewrite inE. +case/subsetPn=> i; rewrite !inE eq_sym; move/negbTE=> p_i _. +by rewrite (bigD1 i) //= mulrCA mxE p_i mul0r. +Qed. + +(* Laplace expansion lemma *) +Lemma expand_cofactor n (A : 'M[R]_n) i j : + cofactor A i j = + \sum_(s : 'S_n | s i == j) (-1) ^+ s * \prod_(k | i != k) A k (s k). +Proof. +case: n A i j => [|n] A i0 j0; first by case: i0. +rewrite (reindex (lift_perm i0 j0)); last first. + pose ulsf i (s : 'S_n.+1) k := odflt k (unlift (s i) (s (lift i k))). + have ulsfK i (s : 'S_n.+1) k: lift (s i) (ulsf i s k) = s (lift i k). + rewrite /ulsf; have:= neq_lift i k. + by rewrite -(inj_eq (@perm_inj _ s)) => /unlift_some[] ? ? ->. + have inj_ulsf: injective (ulsf i0 _). + move=> s; apply: can_inj (ulsf (s i0) s^-1%g) _ => k'. + by rewrite {1}/ulsf ulsfK !permK liftK. + exists (fun s => perm (inj_ulsf s)) => [s _ | s]. + by apply/permP=> k'; rewrite permE /ulsf lift_perm_lift lift_perm_id liftK. + move/(s _ =P _) => si0; apply/permP=> k. + case: (unliftP i0 k) => [k'|] ->; rewrite ?lift_perm_id //. + by rewrite lift_perm_lift -si0 permE ulsfK. +rewrite /cofactor big_distrr /=. +apply: eq_big => [s | s _]; first by rewrite lift_perm_id eqxx. +rewrite -signr_odd mulrA -signr_addb odd_add -odd_lift_perm; congr (_ * _). +case: (pickP 'I_n) => [k0 _ | n0]; last first. + by rewrite !big1 // => [j /unlift_some[i] | i _]; have:= n0 i. +rewrite (reindex (lift i0)). + by apply: eq_big => [k | k _] /=; rewrite ?neq_lift // !mxE lift_perm_lift. +exists (fun k => odflt k0 (unlift i0 k)) => k; first by rewrite liftK. +by case/unlift_some=> k' -> ->. +Qed. + +Lemma expand_det_row n (A : 'M[R]_n) i0 : + \det A = \sum_j A i0 j * cofactor A i0 j. +Proof. +rewrite /(\det A) (partition_big (fun s : 'S_n => s i0) predT) //=. +apply: eq_bigr => j0 _; rewrite expand_cofactor big_distrr /=. +apply: eq_bigr => s /eqP Dsi0. +rewrite mulrCA (bigID (pred1 i0)) /= big_pred1_eq Dsi0; congr (_ * (_ * _)). +by apply: eq_bigl => i; rewrite eq_sym. +Qed. + +Lemma cofactor_tr n (A : 'M[R]_n) i j : cofactor A^T i j = cofactor A j i. +Proof. +rewrite /cofactor addnC; congr (_ * _). +rewrite -tr_row' -tr_col' det_tr; congr (\det _). +by apply/matrixP=> ? ?; rewrite !mxE. +Qed. + +Lemma cofactorZ n a (A : 'M[R]_n) i j : + cofactor (a *: A) i j = a ^+ n.-1 * cofactor A i j. +Proof. by rewrite {1}/cofactor !linearZ detZ mulrCA mulrA. Qed. + +Lemma expand_det_col n (A : 'M[R]_n) j0 : + \det A = \sum_i (A i j0 * cofactor A i j0). +Proof. +rewrite -det_tr (expand_det_row _ j0). +by apply: eq_bigr => i _; rewrite cofactor_tr mxE. +Qed. + +Lemma trmx_adj n (A : 'M[R]_n) : (\adj A)^T = \adj A^T. +Proof. by apply/matrixP=> i j; rewrite !mxE cofactor_tr. Qed. + +Lemma adjZ n a (A : 'M[R]_n) : \adj (a *: A) = a^+n.-1 *: \adj A. +Proof. by apply/matrixP=> i j; rewrite !mxE cofactorZ. Qed. + +(* Cramer Rule : adjugate on the left *) +Lemma mul_mx_adj n (A : 'M[R]_n) : A *m \adj A = (\det A)%:M. +Proof. +apply/matrixP=> i1 i2; rewrite !mxE; case Di: (i1 == i2). + rewrite (eqP Di) (expand_det_row _ i2) //=. + by apply: eq_bigr => j _; congr (_ * _); rewrite mxE. +pose B := \matrix_(i, j) (if i == i2 then A i1 j else A i j). +have EBi12: B i1 =1 B i2 by move=> j; rewrite /= !mxE Di eq_refl. +rewrite -[_ *+ _](determinant_alternate (negbT Di) EBi12) (expand_det_row _ i2). +apply: eq_bigr => j _; rewrite !mxE eq_refl; congr (_ * (_ * _)). +apply: eq_bigr => s _; congr (_ * _); apply: eq_bigr => i _. +by rewrite !mxE eq_sym -if_neg neq_lift. +Qed. + +(* Cramer rule : adjugate on the right *) +Lemma mul_adj_mx n (A : 'M[R]_n) : \adj A *m A = (\det A)%:M. +Proof. +by apply: trmx_inj; rewrite trmx_mul trmx_adj mul_mx_adj det_tr tr_scalar_mx. +Qed. + +Lemma adj1 n : \adj (1%:M) = 1%:M :> 'M[R]_n. +Proof. by rewrite -{2}(det1 n) -mul_adj_mx mulmx1. Qed. + +(* Left inverses are right inverses. *) +Lemma mulmx1C n (A B : 'M[R]_n) : A *m B = 1%:M -> B *m A = 1%:M. +Proof. +move=> AB1; pose A' := \det B *: \adj A. +suffices kA: A' *m A = 1%:M by rewrite -[B]mul1mx -kA -(mulmxA A') AB1 mulmx1. +by rewrite -scalemxAl mul_adj_mx scale_scalar_mx mulrC -det_mulmx AB1 det1. +Qed. + +(* Only tall matrices have inverses. *) +Lemma mulmx1_min m n (A : 'M[R]_(m, n)) B : A *m B = 1%:M -> m <= n. +Proof. +move=> AB1; rewrite leqNgt; apply/negP=> /subnKC; rewrite addSnnS. +move: (_ - _)%N => m' def_m; move: AB1; rewrite -{m}def_m in A B *. +rewrite -(vsubmxK A) -(hsubmxK B) mul_col_row scalar_mx_block. +case/eq_block_mx=> /mulmx1C BlAu1 AuBr0 _ => /eqP/idPn[]. +by rewrite -[_ B]mul1mx -BlAu1 -mulmxA AuBr0 !mulmx0 eq_sym oner_neq0. +Qed. + +Lemma det_ublock n1 n2 Aul (Aur : 'M[R]_(n1, n2)) Adr : + \det (block_mx Aul Aur 0 Adr) = \det Aul * \det Adr. +Proof. +elim: n1 => [|n1 IHn1] in Aul Aur *. + have ->: Aul = 1%:M by apply/matrixP=> i []. + rewrite det1 mul1r; congr (\det _); apply/matrixP=> i j. + by do 2![rewrite !mxE; case: splitP => [[]|k] //=; move/val_inj=> <- {k}]. +rewrite (expand_det_col _ (lshift n2 0)) big_split_ord /=. +rewrite addrC big1 1?simp => [|i _]; last by rewrite block_mxEdl mxE simp. +rewrite (expand_det_col _ 0) big_distrl /=; apply eq_bigr=> i _. +rewrite block_mxEul -!mulrA; do 2!congr (_ * _). +by rewrite col'_col_mx !col'Kl raddf0 row'Ku row'_row_mx IHn1. +Qed. + +Lemma det_lblock n1 n2 Aul (Adl : 'M[R]_(n2, n1)) Adr : + \det (block_mx Aul 0 Adl Adr) = \det Aul * \det Adr. +Proof. by rewrite -det_tr tr_block_mx trmx0 det_ublock !det_tr. Qed. + +End ComMatrix. + +Implicit Arguments lin_mul_row [R m n]. +Implicit Arguments lin_mulmx [R m n p]. +Prenex Implicits lin_mul_row lin_mulmx. + +(*****************************************************************************) +(********************** Matrix unit ring and inverse matrices ****************) +(*****************************************************************************) + +Section MatrixInv. + +Variables R : comUnitRingType. + +Section Defs. + +Variable n : nat. +Implicit Type A : 'M[R]_n. + +Definition unitmx : pred 'M[R]_n := fun A => \det A \is a GRing.unit. +Definition invmx A := if A \in unitmx then (\det A)^-1 *: \adj A else A. + +Lemma unitmxE A : (A \in unitmx) = (\det A \is a GRing.unit). +Proof. by []. Qed. + +Lemma unitmx1 : 1%:M \in unitmx. Proof. by rewrite unitmxE det1 unitr1. Qed. + +Lemma unitmx_perm s : perm_mx s \in unitmx. +Proof. by rewrite unitmxE det_perm unitrX ?unitrN ?unitr1. Qed. + +Lemma unitmx_tr A : (A^T \in unitmx) = (A \in unitmx). +Proof. by rewrite unitmxE det_tr. Qed. + +Lemma unitmxZ a A : a \is a GRing.unit -> (a *: A \in unitmx) = (A \in unitmx). +Proof. by move=> Ua; rewrite !unitmxE detZ unitrM unitrX. Qed. + +Lemma invmx1 : invmx 1%:M = 1%:M. +Proof. by rewrite /invmx det1 invr1 scale1r adj1 if_same. Qed. + +Lemma invmxZ a A : a *: A \in unitmx -> invmx (a *: A) = a^-1 *: invmx A. +Proof. +rewrite /invmx !unitmxE detZ unitrM => /andP[Ua U_A]. +rewrite Ua U_A adjZ !scalerA invrM {U_A}//=. +case: (posnP n) A => [-> | n_gt0] A; first by rewrite flatmx0 [_ *: _]flatmx0. +rewrite unitrX_pos // in Ua; rewrite -[_ * _](mulrK Ua) mulrC -!mulrA. +by rewrite -exprSr prednK // !mulrA divrK ?unitrX. +Qed. + +Lemma invmx_scalar a : invmx (a%:M) = a^-1%:M. +Proof. +case Ua: (a%:M \in unitmx). + by rewrite -scalemx1 in Ua *; rewrite invmxZ // invmx1 scalemx1. +rewrite /invmx Ua; have [->|n_gt0] := posnP n; first by rewrite ![_%:M]flatmx0. +by rewrite unitmxE det_scalar unitrX_pos // in Ua; rewrite invr_out ?Ua. +Qed. + +Lemma mulVmx : {in unitmx, left_inverse 1%:M invmx mulmx}. +Proof. +by move=> A nsA; rewrite /invmx nsA -scalemxAl mul_adj_mx scale_scalar_mx mulVr. +Qed. + +Lemma mulmxV : {in unitmx, right_inverse 1%:M invmx mulmx}. +Proof. +by move=> A nsA; rewrite /invmx nsA -scalemxAr mul_mx_adj scale_scalar_mx mulVr. +Qed. + +Lemma mulKmx m : {in unitmx, @left_loop _ 'M_(n, m) invmx mulmx}. +Proof. by move=> A uA /= B; rewrite mulmxA mulVmx ?mul1mx. Qed. + +Lemma mulKVmx m : {in unitmx, @rev_left_loop _ 'M_(n, m) invmx mulmx}. +Proof. by move=> A uA /= B; rewrite mulmxA mulmxV ?mul1mx. Qed. + +Lemma mulmxK m : {in unitmx, @right_loop 'M_(m, n) _ invmx mulmx}. +Proof. by move=> A uA /= B; rewrite -mulmxA mulmxV ?mulmx1. Qed. + +Lemma mulmxKV m : {in unitmx, @rev_right_loop 'M_(m, n) _ invmx mulmx}. +Proof. by move=> A uA /= B; rewrite -mulmxA mulVmx ?mulmx1. Qed. + +Lemma det_inv A : \det (invmx A) = (\det A)^-1. +Proof. +case uA: (A \in unitmx); last by rewrite /invmx uA invr_out ?negbT. +by apply: (mulrI uA); rewrite -det_mulmx mulmxV ?divrr ?det1. +Qed. + +Lemma unitmx_inv A : (invmx A \in unitmx) = (A \in unitmx). +Proof. by rewrite !unitmxE det_inv unitrV. Qed. + +Lemma unitmx_mul A B : (A *m B \in unitmx) = (A \in unitmx) && (B \in unitmx). +Proof. by rewrite -unitrM -det_mulmx. Qed. + +Lemma trmx_inv (A : 'M_n) : (invmx A)^T = invmx (A^T). +Proof. by rewrite (fun_if trmx) linearZ /= trmx_adj -unitmx_tr -det_tr. Qed. + +Lemma invmxK : involutive invmx. +Proof. +move=> A; case uA : (A \in unitmx); last by rewrite /invmx !uA. +by apply: (can_inj (mulKVmx uA)); rewrite mulVmx // mulmxV ?unitmx_inv. +Qed. + +Lemma mulmx1_unit A B : A *m B = 1%:M -> A \in unitmx /\ B \in unitmx. +Proof. by move=> AB1; apply/andP; rewrite -unitmx_mul AB1 unitmx1. Qed. + +Lemma intro_unitmx A B : B *m A = 1%:M /\ A *m B = 1%:M -> unitmx A. +Proof. by case=> _ /mulmx1_unit[]. Qed. + +Lemma invmx_out : {in [predC unitmx], invmx =1 id}. +Proof. by move=> A; rewrite inE /= /invmx -if_neg => ->. Qed. + +End Defs. + +Variable n' : nat. +Local Notation n := n'.+1. + +Definition matrix_unitRingMixin := + UnitRingMixin (@mulVmx n) (@mulmxV n) (@intro_unitmx n) (@invmx_out n). +Canonical matrix_unitRing := + Eval hnf in UnitRingType 'M[R]_n matrix_unitRingMixin. +Canonical matrix_unitAlg := Eval hnf in [unitAlgType R of 'M[R]_n]. + +(* Lemmas requiring that the coefficients are in a unit ring *) + +Lemma detV (A : 'M_n) : \det A^-1 = (\det A)^-1. +Proof. exact: det_inv. Qed. + +Lemma unitr_trmx (A : 'M_n) : (A^T \is a GRing.unit) = (A \is a GRing.unit). +Proof. exact: unitmx_tr. Qed. + +Lemma trmxV (A : 'M_n) : A^-1^T = (A^T)^-1. +Proof. exact: trmx_inv. Qed. + +Lemma perm_mxV (s : 'S_n) : perm_mx s^-1 = (perm_mx s)^-1. +Proof. +rewrite -[_^-1]mul1r; apply: (canRL (mulmxK (unitmx_perm s))). +by rewrite -perm_mxM mulVg perm_mx1. +Qed. + +Lemma is_perm_mxV (A : 'M_n) : is_perm_mx A^-1 = is_perm_mx A. +Proof. +apply/is_perm_mxP/is_perm_mxP=> [] [s defA]; exists s^-1%g. + by rewrite -(invrK A) defA perm_mxV. +by rewrite defA perm_mxV. +Qed. + +End MatrixInv. + +Prenex Implicits unitmx invmx. + +(* Finite inversible matrices and the general linear group. *) +Section FinUnitMatrix. + +Variables (n : nat) (R : finComUnitRingType). + +Canonical matrix_finUnitRingType n' := + Eval hnf in [finUnitRingType of 'M[R]_n'.+1]. + +Definition GLtype of phant R := {unit 'M[R]_n.-1.+1}. + +Coercion GLval ph (u : GLtype ph) : 'M[R]_n.-1.+1 := + let: FinRing.Unit A _ := u in A. + +End FinUnitMatrix. + +Bind Scope group_scope with GLtype. +Arguments Scope GLval [nat_scope _ _ group_scope]. +Prenex Implicits GLval. + +Notation "{ ''GL_' n [ R ] }" := (GLtype n (Phant R)) + (at level 0, n at level 2, format "{ ''GL_' n [ R ] }") : type_scope. +Notation "{ ''GL_' n ( p ) }" := {'GL_n['F_p]} + (at level 0, n at level 2, p at level 10, + format "{ ''GL_' n ( p ) }") : type_scope. + +Section GL_unit. + +Variables (n : nat) (R : finComUnitRingType). + +Canonical GL_subType := [subType of {'GL_n[R]} for GLval]. +Definition GL_eqMixin := Eval hnf in [eqMixin of {'GL_n[R]} by <:]. +Canonical GL_eqType := Eval hnf in EqType {'GL_n[R]} GL_eqMixin. +Canonical GL_choiceType := Eval hnf in [choiceType of {'GL_n[R]}]. +Canonical GL_countType := Eval hnf in [countType of {'GL_n[R]}]. +Canonical GL_subCountType := Eval hnf in [subCountType of {'GL_n[R]}]. +Canonical GL_finType := Eval hnf in [finType of {'GL_n[R]}]. +Canonical GL_subFinType := Eval hnf in [subFinType of {'GL_n[R]}]. +Canonical GL_baseFinGroupType := Eval hnf in [baseFinGroupType of {'GL_n[R]}]. +Canonical GL_finGroupType := Eval hnf in [finGroupType of {'GL_n[R]}]. +Definition GLgroup of phant R := [set: {'GL_n[R]}]. +Canonical GLgroup_group ph := Eval hnf in [group of GLgroup ph]. + +Implicit Types u v : {'GL_n[R]}. + +Lemma GL_1E : GLval 1 = 1. Proof. by []. Qed. +Lemma GL_VE u : GLval u^-1 = (GLval u)^-1. Proof. by []. Qed. +Lemma GL_VxE u : GLval u^-1 = invmx u. Proof. by []. Qed. +Lemma GL_ME u v : GLval (u * v) = GLval u * GLval v. Proof. by []. Qed. +Lemma GL_MxE u v : GLval (u * v) = u *m v. Proof. by []. Qed. +Lemma GL_unit u : GLval u \is a GRing.unit. Proof. exact: valP. Qed. +Lemma GL_unitmx u : val u \in unitmx. Proof. exact: GL_unit. Qed. + +Lemma GL_det u : \det u != 0. +Proof. +by apply: contraL (GL_unitmx u); rewrite unitmxE => /eqP->; rewrite unitr0. +Qed. + +End GL_unit. + +Notation "''GL_' n [ R ]" := (GLgroup n (Phant R)) + (at level 8, n at level 2, format "''GL_' n [ R ]") : group_scope. +Notation "''GL_' n ( p )" := 'GL_n['F_p] + (at level 8, n at level 2, p at level 10, + format "''GL_' n ( p )") : group_scope. +Notation "''GL_' n [ R ]" := (GLgroup_group n (Phant R)) : Group_scope. +Notation "''GL_' n ( p )" := (GLgroup_group n (Phant 'F_p)) : Group_scope. + +(*****************************************************************************) +(********************** Matrices over a domain *******************************) +(*****************************************************************************) + +Section MatrixDomain. + +Variable R : idomainType. + +Lemma scalemx_eq0 m n a (A : 'M[R]_(m, n)) : + (a *: A == 0) = (a == 0) || (A == 0). +Proof. +case nz_a: (a == 0) / eqP => [-> | _]; first by rewrite scale0r eqxx. +apply/eqP/eqP=> [aA0 | ->]; last exact: scaler0. +apply/matrixP=> i j; apply/eqP; move/matrixP/(_ i j)/eqP: aA0. +by rewrite !mxE mulf_eq0 nz_a. +Qed. + +Lemma scalemx_inj m n a : + a != 0 -> injective ( *:%R a : 'M[R]_(m, n) -> 'M[R]_(m, n)). +Proof. +move=> nz_a A B eq_aAB; apply: contraNeq nz_a. +rewrite -[A == B]subr_eq0 -[a == 0]orbF => /negPf<-. +by rewrite -scalemx_eq0 linearB subr_eq0 /= eq_aAB. +Qed. + +Lemma det0P n (A : 'M[R]_n) : + reflect (exists2 v : 'rV[R]_n, v != 0 & v *m A = 0) (\det A == 0). +Proof. +apply: (iffP eqP) => [detA0 | [v n0v vA0]]; last first. + apply: contraNeq n0v => nz_detA; rewrite -(inj_eq (scalemx_inj nz_detA)). + by rewrite scaler0 -mul_mx_scalar -mul_mx_adj mulmxA vA0 mul0mx. +elim: n => [|n IHn] in A detA0 *. + by case/idP: (oner_eq0 R); rewrite -detA0 [A]thinmx0 -(thinmx0 1%:M) det1. +have [{detA0}A'0 | nzA'] := eqVneq (row 0 (\adj A)) 0; last first. + exists (row 0 (\adj A)) => //; rewrite rowE -mulmxA mul_adj_mx detA0. + by rewrite mul_mx_scalar scale0r. +pose A' := col' 0 A; pose vA := col 0 A. +have defA: A = row_mx vA A'. + apply/matrixP=> i j; rewrite !mxE. + case: splitP => j' def_j; rewrite mxE; congr (A i _); apply: val_inj => //=. + by rewrite def_j [j']ord1. +have{IHn} w_ j : exists w : 'rV_n.+1, [/\ w != 0, w 0 j = 0 & w *m A' = 0]. + have [|wj nzwj wjA'0] := IHn (row' j A'). + by apply/eqP; move/rowP/(_ j)/eqP: A'0; rewrite !mxE mulf_eq0 signr_eq0. + exists (\row_k oapp (wj 0) 0 (unlift j k)). + rewrite !mxE unlift_none -wjA'0; split=> //. + apply: contraNneq nzwj => w0; apply/eqP/rowP=> k'. + by move/rowP/(_ (lift j k')): w0; rewrite !mxE liftK. + apply/rowP=> k; rewrite !mxE (bigD1 j) //= mxE unlift_none mul0r add0r. + rewrite (reindex_onto (lift j) (odflt k \o unlift j)) /= => [|k']. + by apply: eq_big => k'; rewrite ?mxE liftK eq_sym neq_lift eqxx. + by rewrite eq_sym; case/unlift_some=> ? ? ->. +have [w0 [nz_w0 w00_0 w0A']] := w_ 0; pose a0 := (w0 *m vA) 0 0. +have [j {nz_w0}/= nz_w0j | w00] := pickP [pred j | w0 0 j != 0]; last first. + by case/eqP: nz_w0; apply/rowP=> j; rewrite mxE; move/eqP: (w00 j). +have{w_} [wj [nz_wj wj0_0 wjA']] := w_ j; pose aj := (wj *m vA) 0 0. +have [aj0 | nz_aj] := eqVneq aj 0. + exists wj => //; rewrite defA (@mul_mx_row _ _ _ 1) [_ *m _]mx11_scalar -/aj. + by rewrite aj0 raddf0 wjA' row_mx0. +exists (aj *: w0 - a0 *: wj). + apply: contraNneq nz_aj; move/rowP/(_ j)/eqP; rewrite !mxE wj0_0 mulr0 subr0. + by rewrite mulf_eq0 (negPf nz_w0j) orbF. +rewrite defA (@mul_mx_row _ _ _ 1) !mulmxBl -!scalemxAl w0A' wjA' !linear0. +by rewrite -mul_mx_scalar -mul_scalar_mx -!mx11_scalar subrr addr0 row_mx0. +Qed. + +End MatrixDomain. + +Implicit Arguments det0P [R n A]. + +(* Parametricity at the field level (mx_is_scalar, unit and inverse are only *) +(* mapped at this level). *) +Section MapFieldMatrix. + +Variables (aF : fieldType) (rF : comUnitRingType) (f : {rmorphism aF -> rF}). +Local Notation "A ^f" := (map_mx f A) : ring_scope. + +Lemma map_mx_inj m n : injective ((map_mx f) m n). +Proof. +move=> A B eq_AB; apply/matrixP=> i j. +by move/matrixP/(_ i j): eq_AB; rewrite !mxE; exact: fmorph_inj. +Qed. + +Lemma map_mx_is_scalar n (A : 'M_n) : is_scalar_mx A^f = is_scalar_mx A. +Proof. +rewrite /is_scalar_mx; case: (insub _) => // i. +by rewrite mxE -map_scalar_mx inj_eq //; exact: map_mx_inj. +Qed. + +Lemma map_unitmx n (A : 'M_n) : (A^f \in unitmx) = (A \in unitmx). +Proof. by rewrite unitmxE det_map_mx // fmorph_unit // -unitfE. Qed. + +Lemma map_mx_unit n' (A : 'M_n'.+1) : + (A^f \is a GRing.unit) = (A \is a GRing.unit). +Proof. exact: map_unitmx. Qed. + +Lemma map_invmx n (A : 'M_n) : (invmx A)^f = invmx A^f. +Proof. +rewrite /invmx map_unitmx (fun_if ((map_mx f) n n)). +by rewrite map_mxZ map_mx_adj det_map_mx fmorphV. +Qed. + +Lemma map_mx_inv n' (A : 'M_n'.+1) : A^-1^f = A^f^-1. +Proof. exact: map_invmx. Qed. + +Lemma map_mx_eq0 m n (A : 'M_(m, n)) : (A^f == 0) = (A == 0). +Proof. by rewrite -(inj_eq (@map_mx_inj m n)) raddf0. Qed. + +End MapFieldMatrix. + +(*****************************************************************************) +(****************************** LUP decomposion ******************************) +(*****************************************************************************) + +Section CormenLUP. + +Variable F : fieldType. + +(* Decomposition of the matrix A to P A = L U with *) +(* - P a permutation matrix *) +(* - L a unipotent lower triangular matrix *) +(* - U an upper triangular matrix *) + +Fixpoint cormen_lup {n} := + match n return let M := 'M[F]_n.+1 in M -> M * M * M with + | 0 => fun A => (1, 1, A) + | _.+1 => fun A => + let k := odflt 0 [pick k | A k 0 != 0] in + let A1 : 'M_(1 + _) := xrow 0 k A in + let P1 : 'M_(1 + _) := tperm_mx 0 k in + let Schur := ((A k 0)^-1 *: dlsubmx A1) *m ursubmx A1 in + let: (P2, L2, U2) := cormen_lup (drsubmx A1 - Schur) in + let P := block_mx 1 0 0 P2 *m P1 in + let L := block_mx 1 0 ((A k 0)^-1 *: (P2 *m dlsubmx A1)) L2 in + let U := block_mx (ulsubmx A1) (ursubmx A1) 0 U2 in + (P, L, U) + end. + +Lemma cormen_lup_perm n (A : 'M_n.+1) : is_perm_mx (cormen_lup A).1.1. +Proof. +elim: n => [|n IHn] /= in A *; first exact: is_perm_mx1. +set A' := _ - _; move/(_ A'): IHn; case: cormen_lup => [[P L U]] {A'}/=. +rewrite (is_perm_mxMr _ (perm_mx_is_perm _ _)). +case/is_perm_mxP => s ->; exact: lift0_mx_is_perm. +Qed. + +Lemma cormen_lup_correct n (A : 'M_n.+1) : + let: (P, L, U) := cormen_lup A in P * A = L * U. +Proof. +elim: n => [|n IHn] /= in A *; first by rewrite !mul1r. +set k := odflt _ _; set A1 : 'M_(1 + _) := xrow _ _ _. +set A' := _ - _; move/(_ A'): IHn; case: cormen_lup => [[P' L' U']] /= IHn. +rewrite -mulrA -!mulmxE -xrowE -/A1 /= -[n.+2]/(1 + n.+1)%N -{1}(submxK A1). +rewrite !mulmx_block !mul0mx !mulmx0 !add0r !addr0 !mul1mx -{L' U'}[L' *m _]IHn. +rewrite -scalemxAl !scalemxAr -!mulmxA addrC -mulrDr {A'}subrK. +congr (block_mx _ _ (_ *m _) _). +rewrite [_ *: _]mx11_scalar !mxE lshift0 tpermL {}/A1 {}/k. +case: pickP => /= [k nzAk0 | no_k]; first by rewrite mulVf ?mulmx1. +rewrite (_ : dlsubmx _ = 0) ?mul0mx //; apply/colP=> i. +by rewrite !mxE lshift0 (elimNf eqP (no_k _)). +Qed. + +Lemma cormen_lup_detL n (A : 'M_n.+1) : \det (cormen_lup A).1.2 = 1. +Proof. +elim: n => [|n IHn] /= in A *; first by rewrite det1. +set A' := _ - _; move/(_ A'): IHn; case: cormen_lup => [[P L U]] {A'}/= detL. +by rewrite (@det_lblock _ 1) det1 mul1r. +Qed. + +Lemma cormen_lup_lower n A (i j : 'I_n.+1) : + i <= j -> (cormen_lup A).1.2 i j = (i == j)%:R. +Proof. +elim: n => [|n IHn] /= in A i j *; first by rewrite [i]ord1 [j]ord1 mxE. +set A' := _ - _; move/(_ A'): IHn; case: cormen_lup => [[P L U]] {A'}/= Ll. +rewrite !mxE split1; case: unliftP => [i'|] -> /=; rewrite !mxE split1. + by case: unliftP => [j'|] -> //; exact: Ll. +by case: unliftP => [j'|] ->; rewrite /= mxE. +Qed. + +Lemma cormen_lup_upper n A (i j : 'I_n.+1) : + j < i -> (cormen_lup A).2 i j = 0 :> F. +Proof. +elim: n => [|n IHn] /= in A i j *; first by rewrite [i]ord1. +set A' := _ - _; move/(_ A'): IHn; case: cormen_lup => [[P L U]] {A'}/= Uu. +rewrite !mxE split1; case: unliftP => [i'|] -> //=; rewrite !mxE split1. +by case: unliftP => [j'|] ->; [exact: Uu | rewrite /= mxE]. +Qed. + +End CormenLUP. diff --git a/mathcomp/algebra/mxalgebra.v b/mathcomp/algebra/mxalgebra.v new file mode 100644 index 0000000..54d5588 --- /dev/null +++ b/mathcomp/algebra/mxalgebra.v @@ -0,0 +1,2764 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype. +Require Import finfun bigop prime binomial ssralg finset fingroup finalg. +Require Import perm zmodp matrix. + +(*****************************************************************************) +(* In this file we develop the rank and row space theory of matrices, based *) +(* on an extended Gaussian elimination procedure similar to LUP *) +(* decomposition. This provides us with a concrete but generic model of *) +(* finite dimensional vector spaces and F-algebras, in which vectors, linear *) +(* functions, families, bases, subspaces, ideals and subrings are all *) +(* represented using matrices. This model can be used as a foundation for *) +(* the usual theory of abstract linear algebra, but it can also be used to *) +(* develop directly substantial theories, such as the theory of finite group *) +(* linear representation. *) +(* Here we define the following concepts and notations: *) +(* Gaussian_elimination A == a permuted triangular decomposition (L, U, r) *) +(* of A, with L a column permutation of a lower triangular *) +(* invertible matrix, U a row permutation of an upper *) +(* triangular invertible matrix, and r the rank of A, all *) +(* satisfying the identity L *m pid_mx r *m U = A. *) +(* \rank A == the rank of A. *) +(* row_free A <=> the rows of A are linearly free (i.e., the rank and *) +(* height of A are equal). *) +(* row_full A <=> the row-space of A spans all row-vectors (i.e., the *) +(* rank and width of A are equal). *) +(* col_ebase A == the extended column basis of A (the first matrix L *) +(* returned by Gaussian_elimination A). *) +(* row_ebase A == the extended row base of A (the second matrix U *) +(* returned by Gaussian_elimination A). *) +(* col_base A == a basis for the columns of A: a row-full matrix *) +(* consisting of the first \rank A columns of col_ebase A. *) +(* row_base A == a basis for the rows of A: a row-free matrix consisting *) +(* of the first \rank A rows of row_ebase A. *) +(* pinvmx A == a partial inverse for A in its row space (or on its *) +(* column space, equivalently). In particular, if u is a *) +(* row vector in the row_space of A, then u *m pinvmx A is *) +(* the row vector of the coefficients of a decomposition *) +(* of u as a sub of rows of A. *) +(* kermx A == the row kernel of A : a square matrix whose row space *) +(* consists of all u such that u *m A = 0 (it consists of *) +(* the inverse of col_ebase A, with the top \rank A rows *) +(* zeroed out). Also, kermx A is a partial right inverse *) +(* to col_ebase A, in the row space anihilated by A. *) +(* cokermx A == the cokernel of A : a square matrix whose column space *) +(* consists of all v such that A *m v = 0 (it consists of *) +(* the inverse of row_ebase A, with the leftmost \rank A *) +(* columns zeroed out). *) +(* eigenvalue g a <=> a is an eigenvalue of the square matrix g. *) +(* eigenspace g a == a square matrix whose row space is the eigenspace of *) +(* the eigenvalue a of g (or 0 if a is not an eigenvalue). *) +(* We use a different scope %MS for matrix row-space set-like operations; to *) +(* avoid confusion, this scope should not be opened globally. Note that the *) +(* the arguments of \rank _ and the operations below have default scope %MS. *) +(* (A <= B)%MS <=> the row-space of A is included in the row-space of B. *) +(* We test for this by testing if cokermx B anihilates A. *) +(* (A < B)%MS <=> the row-space of A is properly included in the *) +(* row-space of B. *) +(* (A <= B <= C)%MS == (A <= B)%MS && (B <= C)%MS, and similarly for *) +(* (A < B <= C)%MS, (A < B <= C)%MS and (A < B < C)%MS. *) +(* (A == B)%MS == (A <= B <= A)%MS (A and B have the same row-space). *) +(* (A :=: B)%MS == A and B behave identically wrt. \rank and <=. This *) +(* triple rewrite rule is the Prop version of (A == B)%MS. *) +(* Note that :=: cannot be treated as a setoid-style *) +(* Equivalence because its arguments can have different *) +(* types: A and B need not have the same number of rows, *) +(* and often don't (e.g., in row_base A :=: A). *) +(* <>%MS == a square matrix with the same row-space as A; <>%MS *) +(* is a canonical representation of the subspace generated *) +(* by A, viewed as a list of row-vectors: if (A == B)%MS, *) +(* then <>%MS = <>%MS. *) +(* (A + B)%MS == a square matrix whose row-space is the sum of the *) +(* row-spaces of A and B; thus (A + B == col_mx A B)%MS. *) +(* (\sum_i )%MS == the "big" version of (_ + _)%MS; as the latter *) +(* has a canonical abelian monoid structure, most generic *) +(* bigop lemmas apply (the other bigop indexing notations *) +(* are also defined). *) +(* (A :&: B)%MS == a square matrix whose row-space is the intersection of *) +(* the row-spaces of A and B. *) +(* (\bigcap_i )%MS == the "big" version of (_ :&: _)%MS, which also *) +(* has a canonical abelian monoid structure. *) +(* A^C%MS == a square matrix whose row-space is a complement to the *) +(* the row-space of A (it consists of row_ebase A with the *) +(* top \rank A rows zeroed out). *) +(* (A :\: B)%MS == a square matrix whose row-space is a complement of the *) +(* the row-space of (A :&: B)%MS in the row-space of A. *) +(* We have (A :\: B := A :&: (capmx_gen A B)^C)%MS, where *) +(* capmx_gen A B is a rectangular matrix equivalent to *) +(* (A :&: B)%MS, i.e., (capmx_gen A B == A :&: B)%MS. *) +(* proj_mx A B == a square matrix that projects (A + B)%MS onto A *) +(* parellel to B, when (A :&: B)%MS = 0 (A and B must also *) +(* be square). *) +(* mxdirect S == the sum expression S is a direct sum. This is a NON *) +(* EXTENSIONAL notation: the exact boolean expression is *) +(* inferred from the syntactic form of S (expanding *) +(* definitions, however); both (\sum_(i | _) _)%MS and *) +(* (_ + _)%MS sums are recognized. This construct uses a *) +(* variant of the reflexive ("quote") canonical structure, *) +(* mxsum_expr. The structure also recognizes sums of *) +(* matrix ranks, so that lemmas concerning the rank of *) +(* direct sums can be used bidirectionally. *) +(* The next set of definitions let us represent F-algebras using matrices: *) +(* 'A[F]_(m, n) == the type of matrices encoding (sub)algebras of square *) +(* n x n matrices, via mxvec; as in the matrix type *) +(* notation, m and F can be omitted (m defaults to n ^ 2). *) +(* := 'M[F]_(m, n ^ 2). *) +(* (A \in R)%MS <=> the square matrix A belongs to the linear set of *) +(* matrices (most often, a sub-algebra) encoded by the *) +(* row space of R. This is simply notation, so all the *) +(* lemmas and rewrite rules for (_ <= _)%MS can apply. *) +(* := (mxvec A <= R)%MS. *) +(* (R * S)%MS == a square n^2 x n^2 matrix whose row-space encodes the *) +(* linear set of n x n matrices generated by the pointwise *) +(* product of the sets of matrices encoded by R and S. *) +(* 'C(R)%MS == a square matric encoding the centraliser of the set of *) +(* square matrices encoded by R. *) +(* 'C_S(R)%MS := (S :&: 'C(R))%MS (the centraliser of R in S). *) +(* 'Z(R)%MS == the center of R (i.e., 'C_R(R)%MS). *) +(* left_mx_ideal R S <=> S is a left ideal for R (R * S <= S)%MS. *) +(* right_mx_ideal R S <=> S is a right ideal for R (S * R <= S)%MS. *) +(* mx_ideal R S <=> S is a bilateral ideal for R. *) +(* mxring_id R e <-> e is an identity element for R (Prop predicate). *) +(* has_mxring_id R <=> R has a nonzero identity element (bool predicate). *) +(* mxring R <=> R encodes a nontrivial subring. *) +(*****************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. +Import GRing.Theory. +Open Local Scope ring_scope. + +Reserved Notation "\rank A" (at level 10, A at level 8, format "\rank A"). +Reserved Notation "A ^C" (at level 8, format "A ^C"). + +Notation "''A_' ( m , n )" := 'M_(m, n ^ 2) + (at level 8, format "''A_' ( m , n )") : type_scope. + +Notation "''A_' ( n )" := 'A_(n ^ 2, n) + (at level 8, only parsing) : type_scope. + +Notation "''A_' n" := 'A_(n) + (at level 8, n at next level, format "''A_' n") : type_scope. + +Notation "''A' [ F ]_ ( m , n )" := 'M[F]_(m, n ^ 2) + (at level 8, only parsing) : type_scope. + +Notation "''A' [ F ]_ ( n )" := 'A[F]_(n ^ 2, n) + (at level 8, only parsing) : type_scope. + +Notation "''A' [ F ]_ n" := 'A[F]_(n) + (at level 8, n at level 2, only parsing) : type_scope. + +Delimit Scope matrix_set_scope with MS. + +Notation Local simp := (Monoid.Theory.simpm, oppr0). + +(*****************************************************************************) +(******************** Rank and row-space theory ******************************) +(*****************************************************************************) + +Section RowSpaceTheory. + +Variable F : fieldType. +Implicit Types m n p r : nat. + +Local Notation "''M_' ( m , n )" := 'M[F]_(m, n) : type_scope. +Local Notation "''M_' n" := 'M[F]_(n, n) : type_scope. + +(* Decomposition with double pivoting; computes the rank, row and column *) +(* images, kernels, and complements of a matrix. *) + +Fixpoint Gaussian_elimination {m n} : 'M_(m, n) -> 'M_m * 'M_n * nat := + match m, n with + | _.+1, _.+1 => fun A : 'M_(1 + _, 1 + _) => + if [pick ij | A ij.1 ij.2 != 0] is Some (i, j) then + let a := A i j in let A1 := xrow i 0 (xcol j 0 A) in + let u := ursubmx A1 in let v := a^-1 *: dlsubmx A1 in + let: (L, U, r) := Gaussian_elimination (drsubmx A1 - v *m u) in + (xrow i 0 (block_mx 1 0 v L), xcol j 0 (block_mx a%:M u 0 U), r.+1) + else (1%:M, 1%:M, 0%N) + | _, _ => fun _ => (1%:M, 1%:M, 0%N) + end. + +Section Defs. + +Variables (m n : nat) (A : 'M_(m, n)). + +Fact Gaussian_elimination_key : unit. Proof. by []. Qed. + +Let LUr := locked_with Gaussian_elimination_key (@Gaussian_elimination) m n A. + +Definition col_ebase := LUr.1.1. +Definition row_ebase := LUr.1.2. +Definition mxrank := if [|| m == 0 | n == 0]%N then 0%N else LUr.2. + +Definition row_free := mxrank == m. +Definition row_full := mxrank == n. + +Definition row_base : 'M_(mxrank, n) := pid_mx mxrank *m row_ebase. +Definition col_base : 'M_(m, mxrank) := col_ebase *m pid_mx mxrank. + +Definition complmx : 'M_n := copid_mx mxrank *m row_ebase. +Definition kermx : 'M_m := copid_mx mxrank *m invmx col_ebase. +Definition cokermx : 'M_n := invmx row_ebase *m copid_mx mxrank. + +Definition pinvmx : 'M_(n, m) := + invmx row_ebase *m pid_mx mxrank *m invmx col_ebase. + +End Defs. + +Arguments Scope mxrank [nat_scope nat_scope matrix_set_scope]. +Local Notation "\rank A" := (mxrank A) : nat_scope. +Arguments Scope complmx [nat_scope nat_scope matrix_set_scope]. +Local Notation "A ^C" := (complmx A) : matrix_set_scope. + +Definition submx_def := idfun (fun m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) => + A *m cokermx B == 0). +Fact submx_key : unit. Proof. by []. Qed. +Definition submx := locked_with submx_key submx_def. +Canonical submx_unlockable := [unlockable fun submx]. + +Arguments Scope submx + [nat_scope nat_scope nat_scope matrix_set_scope matrix_set_scope]. +Prenex Implicits submx. +Local Notation "A <= B" := (submx A B) : matrix_set_scope. +Local Notation "A <= B <= C" := ((A <= B) && (B <= C))%MS : matrix_set_scope. +Local Notation "A == B" := (A <= B <= A)%MS : matrix_set_scope. + +Definition ltmx m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) := + (A <= B)%MS && ~~ (B <= A)%MS. +Arguments Scope ltmx + [nat_scope nat_scope nat_scope matrix_set_scope matrix_set_scope]. +Prenex Implicits ltmx. +Local Notation "A < B" := (ltmx A B) : matrix_set_scope. + +Definition eqmx m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) := + prod (\rank A = \rank B) + (forall m3 (C : 'M_(m3, n)), + ((A <= C) = (B <= C)) * ((C <= A) = (C <= B)))%MS. +Arguments Scope eqmx + [nat_scope nat_scope nat_scope matrix_set_scope matrix_set_scope]. +Local Notation "A :=: B" := (eqmx A B) : matrix_set_scope. + +Section LtmxIdentities. + +Variables (m1 m2 n : nat) (A : 'M_(m1, n)) (B : 'M_(m2, n)). + +Lemma ltmxE : (A < B)%MS = ((A <= B)%MS && ~~ (B <= A)%MS). Proof. by []. Qed. + +Lemma ltmxW : (A < B)%MS -> (A <= B)%MS. Proof. by case/andP. Qed. + +Lemma ltmxEneq : (A < B)%MS = (A <= B)%MS && ~~ (A == B)%MS. +Proof. by apply: andb_id2l => ->. Qed. + +Lemma submxElt : (A <= B)%MS = (A == B)%MS || (A < B)%MS. +Proof. by rewrite -andb_orr orbN andbT. Qed. + +End LtmxIdentities. + +(* The definition of the row-space operator is rigged to return the identity *) +(* matrix for full matrices. To allow for further tweaks that will make the *) +(* row-space intersection operator strictly commutative and monoidal, we *) +(* slightly generalize some auxiliary definitions: we parametrize the *) +(* "equivalent subspace and identity" choice predicate equivmx by a boolean *) +(* determining whether the matrix should be the identity (so for genmx A its *) +(* value is row_full A), and introduce a "quasi-identity" predicate qidmx *) +(* that selects non-square full matrices along with the identity matrix 1%:M *) +(* (this does not affect genmx, which chooses a square matrix). *) +(* The choice witness for genmx A is either 1%:M for a row-full A, or else *) +(* row_base A padded with null rows. *) +Let qidmx m n (A : 'M_(m, n)) := + if m == n then A == pid_mx n else row_full A. +Let equivmx m n (A : 'M_(m, n)) idA (B : 'M_n) := + (B == A)%MS && (qidmx B == idA). +Let equivmx_spec m n (A : 'M_(m, n)) idA (B : 'M_n) := + prod (B :=: A)%MS (qidmx B = idA). +Definition genmx_witness m n (A : 'M_(m, n)) : 'M_n := + if row_full A then 1%:M else pid_mx (\rank A) *m row_ebase A. +Definition genmx_def := idfun (fun m n (A : 'M_(m, n)) => + choose (equivmx A (row_full A)) (genmx_witness A) : 'M_n). +Fact genmx_key : unit. Proof. by []. Qed. +Definition genmx := locked_with genmx_key genmx_def. +Canonical genmx_unlockable := [unlockable fun genmx]. +Local Notation "<< A >>" := (genmx A) : matrix_set_scope. + +(* The setwise sum is tweaked so that 0 is a strict identity element for *) +(* square matrices, because this lets us use the bigop component. As a result *) +(* setwise sum is not quite strictly extensional. *) +Let addsmx_nop m n (A : 'M_(m, n)) := conform_mx <>%MS A. +Definition addsmx_def := idfun (fun m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) => + if A == 0 then addsmx_nop B else if B == 0 then addsmx_nop A else + <>%MS : 'M_n). +Fact addsmx_key : unit. Proof. by []. Qed. +Definition addsmx := locked_with addsmx_key addsmx_def. +Canonical addsmx_unlockable := [unlockable fun addsmx]. +Arguments Scope addsmx + [nat_scope nat_scope nat_scope matrix_set_scope matrix_set_scope]. +Prenex Implicits addsmx. +Local Notation "A + B" := (addsmx A B) : matrix_set_scope. +Local Notation "\sum_ ( i | P ) B" := (\big[addsmx/0]_(i | P) B%MS) + : matrix_set_scope. +Local Notation "\sum_ ( i <- r | P ) B" := (\big[addsmx/0]_(i <- r | P) B%MS) + : matrix_set_scope. + +(* The set intersection is similarly biased so that the identity matrix is a *) +(* strict identity. This is somewhat more delicate than for the sum, because *) +(* the test for the identity is non-extensional. This forces us to actually *) +(* bias the choice operator so that it does not accidentally map an *) +(* intersection of non-identity matrices to 1%:M; this would spoil *) +(* associativity: if B :&: C = 1%:M but B and C are not identity, then for a *) +(* square matrix A we have A :&: (B :&: C) = A != (A :&: B) :&: C in general. *) +(* To complicate matters there may not be a square non-singular matrix *) +(* different than 1%:M, since we could be dealing with 'M['F_2]_1. We *) +(* sidestep the issue by making all non-square row-full matrices identities, *) +(* and choosing a normal representative that preserves the qidmx property. *) +(* Thus A :&: B = 1%:M iff A and B are both identities, and this suffices for *) +(* showing that associativity is strict. *) +Let capmx_witness m n (A : 'M_(m, n)) := + if row_full A then conform_mx 1%:M A else <>%MS. +Let capmx_norm m n (A : 'M_(m, n)) := + choose (equivmx A (qidmx A)) (capmx_witness A). +Let capmx_nop m n (A : 'M_(m, n)) := conform_mx (capmx_norm A) A. +Definition capmx_gen m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) := + lsubmx (kermx (col_mx A B)) *m A. +Definition capmx_def := idfun (fun m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) => + if qidmx A then capmx_nop B else + if qidmx B then capmx_nop A else + if row_full B then capmx_norm A else capmx_norm (capmx_gen A B) : 'M_n). +Fact capmx_key : unit. Proof. by []. Qed. +Definition capmx := locked_with capmx_key capmx_def. +Canonical capmx_unlockable := [unlockable fun capmx]. +Arguments Scope capmx + [nat_scope nat_scope nat_scope matrix_set_scope matrix_set_scope]. +Prenex Implicits capmx. +Local Notation "A :&: B" := (capmx A B) : matrix_set_scope. +Local Notation "\bigcap_ ( i | P ) B" := (\big[capmx/1%:M]_(i | P) B) + : matrix_set_scope. + +Definition diffmx_def := idfun (fun m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) => + <>%MS : 'M_n). +Fact diffmx_key : unit. Proof. by []. Qed. +Definition diffmx := locked_with diffmx_key diffmx_def. +Canonical diffmx_unlockable := [unlockable fun diffmx]. +Arguments Scope diffmx + [nat_scope nat_scope nat_scope matrix_set_scope matrix_set_scope]. +Prenex Implicits diffmx. +Local Notation "A :\: B" := (diffmx A B) : matrix_set_scope. + +Definition proj_mx n (U V : 'M_n) : 'M_n := pinvmx (col_mx U V) *m col_mx U 0. + +Local Notation GaussE := Gaussian_elimination. + +Fact mxrankE m n (A : 'M_(m, n)) : \rank A = (GaussE A).2. +Proof. by rewrite /mxrank unlock /=; case: m n A => [|m] [|n]. Qed. + +Lemma rank_leq_row m n (A : 'M_(m, n)) : \rank A <= m. +Proof. +rewrite mxrankE. +elim: m n A => [|m IHm] [|n] //= A; case: pickP => [[i j] _|] //=. +by move: (_ - _) => B; case: GaussE (IHm _ B) => [[L U] r] /=. +Qed. + +Lemma row_leq_rank m n (A : 'M_(m, n)) : (m <= \rank A) = row_free A. +Proof. by rewrite /row_free eqn_leq rank_leq_row. Qed. + +Lemma rank_leq_col m n (A : 'M_(m, n)) : \rank A <= n. +Proof. +rewrite mxrankE. +elim: m n A => [|m IHm] [|n] //= A; case: pickP => [[i j] _|] //=. +by move: (_ - _) => B; case: GaussE (IHm _ B) => [[L U] r] /=. +Qed. + +Lemma col_leq_rank m n (A : 'M_(m, n)) : (n <= \rank A) = row_full A. +Proof. by rewrite /row_full eqn_leq rank_leq_col. Qed. + +Let unitmx1F := @unitmx1 F. +Lemma row_ebase_unit m n (A : 'M_(m, n)) : row_ebase A \in unitmx. +Proof. +rewrite /row_ebase unlock; elim: m n A => [|m IHm] [|n] //= A. +case: pickP => [[i j] /= nzAij | //=]; move: (_ - _) => B. +case: GaussE (IHm _ B) => [[L U] r] /= uU. +rewrite unitmxE xcolE det_mulmx (@det_ublock _ 1) det_scalar1 !unitrM. +by rewrite unitfE nzAij -!unitmxE uU unitmx_perm. +Qed. + +Lemma col_ebase_unit m n (A : 'M_(m, n)) : col_ebase A \in unitmx. +Proof. +rewrite /col_ebase unlock; elim: m n A => [|m IHm] [|n] //= A. +case: pickP => [[i j] _|] //=; move: (_ - _) => B. +case: GaussE (IHm _ B) => [[L U] r] /= uL. +rewrite unitmxE xrowE det_mulmx (@det_lblock _ 1) det1 mul1r unitrM. +by rewrite -unitmxE unitmx_perm. +Qed. +Hint Resolve rank_leq_row rank_leq_col row_ebase_unit col_ebase_unit. + +Lemma mulmx_ebase m n (A : 'M_(m, n)) : + col_ebase A *m pid_mx (\rank A) *m row_ebase A = A. +Proof. +rewrite mxrankE /col_ebase /row_ebase unlock. +elim: m n A => [n A | m IHm]; first by rewrite [A]flatmx0 [_ *m _]flatmx0. +case=> [A | n]; first by rewrite [_ *m _]thinmx0 [A]thinmx0. +rewrite -(add1n m) -?(add1n n) => A /=. +case: pickP => [[i0 j0] | A0] /=; last first. + apply/matrixP=> i j; rewrite pid_mx_0 mulmx0 mul0mx mxE. + by move/eqP: (A0 (i, j)). +set a := A i0 j0 => nz_a; set A1 := xrow _ _ _. +set u := ursubmx _; set v := _ *: _; set B : 'M_(m, n) := _ - _. +move: (rank_leq_col B) (rank_leq_row B) {IHm}(IHm n B); rewrite mxrankE. +case: (GaussE B) => [[L U] r] /= r_m r_n defB. +have ->: pid_mx (1 + r) = block_mx 1 0 0 (pid_mx r) :> 'M[F]_(1 + m, 1 + n). + rewrite -(subnKC r_m) -(subnKC r_n) pid_mx_block -col_mx0 -row_mx0. + by rewrite block_mxA castmx_id col_mx0 row_mx0 -scalar_mx_block -pid_mx_block. +rewrite xcolE xrowE mulmxA -xcolE -!mulmxA. +rewrite !(addr0, add0r, mulmx0, mul0mx, mulmx_block, mul1mx) mulmxA defB. +rewrite addrC subrK mul_mx_scalar scalerA divff // scale1r. +have ->: a%:M = ulsubmx A1 by rewrite [_ A1]mx11_scalar !mxE !lshift0 !tpermR. +rewrite submxK /A1 xrowE !xcolE -!mulmxA mulmxA -!perm_mxM !tperm2 !perm_mx1. +by rewrite mulmx1 mul1mx. +Qed. + +Lemma mulmx_base m n (A : 'M_(m, n)) : col_base A *m row_base A = A. +Proof. by rewrite mulmxA -[col_base A *m _]mulmxA pid_mx_id ?mulmx_ebase. Qed. + +Lemma mulmx1_min_rank r m n (A : 'M_(m, n)) M N : + M *m A *m N = 1%:M :> 'M_r -> r <= \rank A. +Proof. by rewrite -{1}(mulmx_base A) mulmxA -mulmxA; move/mulmx1_min. Qed. +Implicit Arguments mulmx1_min_rank [r m n A]. + +Lemma mulmx_max_rank r m n (M : 'M_(m, r)) (N : 'M_(r, n)) : + \rank (M *m N) <= r. +Proof. +set MN := M *m N; set rMN := \rank _. +pose L : 'M_(rMN, m) := pid_mx rMN *m invmx (col_ebase MN). +pose U : 'M_(n, rMN) := invmx (row_ebase MN) *m pid_mx rMN. +suffices: L *m M *m (N *m U) = 1%:M by exact: mulmx1_min. +rewrite mulmxA -(mulmxA L) -[M *m N]mulmx_ebase -/MN. +by rewrite !mulmxA mulmxKV // mulmxK // !pid_mx_id /rMN ?pid_mx_1. +Qed. +Implicit Arguments mulmx_max_rank [r m n]. + +Lemma mxrank_tr m n (A : 'M_(m, n)) : \rank A^T = \rank A. +Proof. +apply/eqP; rewrite eqn_leq -{3}[A]trmxK -{1}(mulmx_base A) -{1}(mulmx_base A^T). +by rewrite !trmx_mul !mulmx_max_rank. +Qed. + +Lemma mxrank_add m n (A B : 'M_(m, n)) : \rank (A + B)%R <= \rank A + \rank B. +Proof. +by rewrite -{1}(mulmx_base A) -{1}(mulmx_base B) -mul_row_col mulmx_max_rank. +Qed. + +Lemma mxrankM_maxl m n p (A : 'M_(m, n)) (B : 'M_(n, p)) : + \rank (A *m B) <= \rank A. +Proof. by rewrite -{1}(mulmx_base A) -mulmxA mulmx_max_rank. Qed. + +Lemma mxrankM_maxr m n p (A : 'M_(m, n)) (B : 'M_(n, p)) : + \rank (A *m B) <= \rank B. +Proof. by rewrite -mxrank_tr -(mxrank_tr B) trmx_mul mxrankM_maxl. Qed. + +Lemma mxrank_scale m n a (A : 'M_(m, n)) : \rank (a *: A) <= \rank A. +Proof. by rewrite -mul_scalar_mx mxrankM_maxr. Qed. + +Lemma mxrank_scale_nz m n a (A : 'M_(m, n)) : + a != 0 -> \rank (a *: A) = \rank A. +Proof. +move=> nza; apply/eqP; rewrite eqn_leq -{3}[A]scale1r -(mulVf nza). +by rewrite -scalerA !mxrank_scale. +Qed. + +Lemma mxrank_opp m n (A : 'M_(m, n)) : \rank (- A) = \rank A. +Proof. by rewrite -scaleN1r mxrank_scale_nz // oppr_eq0 oner_eq0. Qed. + +Lemma mxrank0 m n : \rank (0 : 'M_(m, n)) = 0%N. +Proof. by apply/eqP; rewrite -leqn0 -(@mulmx0 _ m 0 n 0) mulmx_max_rank. Qed. + +Lemma mxrank_eq0 m n (A : 'M_(m, n)) : (\rank A == 0%N) = (A == 0). +Proof. +apply/eqP/eqP=> [rA0 | ->{A}]; last exact: mxrank0. +move: (col_base A) (row_base A) (mulmx_base A); rewrite rA0 => Ac Ar <-. +by rewrite [Ac]thinmx0 mul0mx. +Qed. + +Lemma mulmx_coker m n (A : 'M_(m, n)) : A *m cokermx A = 0. +Proof. +by rewrite -{1}[A]mulmx_ebase -!mulmxA mulKVmx // mul_pid_mx_copid ?mulmx0. +Qed. + +Lemma submxE m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A <= B)%MS = (A *m cokermx B == 0). +Proof. by rewrite unlock. Qed. + +Lemma mulmxKpV m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A <= B)%MS -> A *m pinvmx B *m B = A. +Proof. +rewrite submxE !mulmxA mulmxBr mulmx1 subr_eq0 => /eqP defA. +rewrite -{4}[B]mulmx_ebase -!mulmxA mulKmx //. +by rewrite (mulmxA (pid_mx _)) pid_mx_id // !mulmxA -{}defA mulmxKV. +Qed. + +Lemma submxP m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + reflect (exists D, A = D *m B) (A <= B)%MS. +Proof. +apply: (iffP idP) => [/mulmxKpV | [D ->]]; first by exists (A *m pinvmx B). +by rewrite submxE -mulmxA mulmx_coker mulmx0. +Qed. +Implicit Arguments submxP [m1 m2 n A B]. + +Lemma submx_refl m n (A : 'M_(m, n)) : (A <= A)%MS. +Proof. by rewrite submxE mulmx_coker. Qed. +Hint Resolve submx_refl. + +Lemma submxMl m n p (D : 'M_(m, n)) (A : 'M_(n, p)) : (D *m A <= A)%MS. +Proof. by rewrite submxE -mulmxA mulmx_coker mulmx0. Qed. + +Lemma submxMr m1 m2 n p (A : 'M_(m1, n)) (B : 'M_(m2, n)) (C : 'M_(n, p)) : + (A <= B)%MS -> (A *m C <= B *m C)%MS. +Proof. by case/submxP=> D ->; rewrite -mulmxA submxMl. Qed. + +Lemma mulmx_sub m n1 n2 p (C : 'M_(m, n1)) A (B : 'M_(n2, p)) : + (A <= B -> C *m A <= B)%MS. +Proof. by case/submxP=> D ->; rewrite mulmxA submxMl. Qed. + +Lemma submx_trans m1 m2 m3 n + (A : 'M_(m1, n)) (B : 'M_(m2, n)) (C : 'M_(m3, n)) : + (A <= B -> B <= C -> A <= C)%MS. +Proof. by case/submxP=> D ->{A}; exact: mulmx_sub. Qed. + +Lemma ltmx_sub_trans m1 m2 m3 n + (A : 'M_(m1, n)) (B : 'M_(m2, n)) (C : 'M_(m3, n)) : + (A < B)%MS -> (B <= C)%MS -> (A < C)%MS. +Proof. +case/andP=> sAB ltAB sBC; rewrite ltmxE (submx_trans sAB) //. +by apply: contra ltAB; exact: submx_trans. +Qed. + +Lemma sub_ltmx_trans m1 m2 m3 n + (A : 'M_(m1, n)) (B : 'M_(m2, n)) (C : 'M_(m3, n)) : + (A <= B)%MS -> (B < C)%MS -> (A < C)%MS. +Proof. +move=> sAB /andP[sBC ltBC]; rewrite ltmxE (submx_trans sAB) //. +by apply: contra ltBC => sCA; exact: submx_trans sAB. +Qed. + +Lemma ltmx_trans m n : transitive (@ltmx m m n). +Proof. by move=> A B C; move/ltmxW; exact: sub_ltmx_trans. Qed. + +Lemma ltmx_irrefl m n : irreflexive (@ltmx m m n). +Proof. by move=> A; rewrite /ltmx submx_refl andbF. Qed. + +Lemma sub0mx m1 m2 n (A : 'M_(m2, n)) : ((0 : 'M_(m1, n)) <= A)%MS. +Proof. by rewrite submxE mul0mx. Qed. + +Lemma submx0null m1 m2 n (A : 'M[F]_(m1, n)) : + (A <= (0 : 'M_(m2, n)))%MS -> A = 0. +Proof. by case/submxP=> D; rewrite mulmx0. Qed. + +Lemma submx0 m n (A : 'M_(m, n)) : (A <= (0 : 'M_n))%MS = (A == 0). +Proof. by apply/idP/eqP=> [|->]; [exact: submx0null | exact: sub0mx]. Qed. + +Lemma lt0mx m n (A : 'M_(m, n)) : ((0 : 'M_n) < A)%MS = (A != 0). +Proof. by rewrite /ltmx sub0mx submx0. Qed. + +Lemma ltmx0 m n (A : 'M[F]_(m, n)) : (A < (0 : 'M_n))%MS = false. +Proof. by rewrite /ltmx sub0mx andbF. Qed. + +Lemma eqmx0P m n (A : 'M_(m, n)) : reflect (A = 0) (A == (0 : 'M_n))%MS. +Proof. by rewrite submx0 sub0mx andbT; exact: eqP. Qed. + +Lemma eqmx_eq0 m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A :=: B)%MS -> (A == 0) = (B == 0). +Proof. by move=> eqAB; rewrite -!submx0 eqAB. Qed. + +Lemma addmx_sub m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m1, n)) (C : 'M_(m2, n)) : + (A <= C)%MS -> (B <= C)%MS -> ((A + B)%R <= C)%MS. +Proof. +by case/submxP=> A' ->; case/submxP=> B' ->; rewrite -mulmxDl submxMl. +Qed. + +Lemma summx_sub m1 m2 n (B : 'M_(m2, n)) + I (r : seq I) (P : pred I) (A_ : I -> 'M_(m1, n)) : + (forall i, P i -> A_ i <= B)%MS -> ((\sum_(i <- r | P i) A_ i)%R <= B)%MS. +Proof. +move=> leAB; elim/big_ind: _ => // [|A1 A2]; [exact: sub0mx | exact: addmx_sub]. +Qed. + +Lemma scalemx_sub m1 m2 n a (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A <= B)%MS -> (a *: A <= B)%MS. +Proof. by case/submxP=> A' ->; rewrite scalemxAl submxMl. Qed. + +Lemma row_sub m n i (A : 'M_(m, n)) : (row i A <= A)%MS. +Proof. by rewrite rowE submxMl. Qed. + +Lemma eq_row_sub m n v (A : 'M_(m, n)) i : row i A = v -> (v <= A)%MS. +Proof. by move <-; rewrite row_sub. Qed. + +Lemma nz_row_sub m n (A : 'M_(m, n)) : (nz_row A <= A)%MS. +Proof. by rewrite /nz_row; case: pickP => [i|] _; rewrite ?row_sub ?sub0mx. Qed. + +Lemma row_subP m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + reflect (forall i, row i A <= B)%MS (A <= B)%MS. +Proof. +apply: (iffP idP) => [sAB i|sAB]. + by apply: submx_trans sAB; exact: row_sub. +rewrite submxE; apply/eqP/row_matrixP=> i; apply/eqP. +by rewrite row_mul row0 -submxE. +Qed. +Implicit Arguments row_subP [m1 m2 n A B]. + +Lemma rV_subP m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + reflect (forall v : 'rV_n, v <= A -> v <= B)%MS (A <= B)%MS. +Proof. +apply: (iffP idP) => [sAB v Av | sAB]; first exact: submx_trans sAB. +by apply/row_subP=> i; rewrite sAB ?row_sub. +Qed. +Implicit Arguments rV_subP [m1 m2 n A B]. + +Lemma row_subPn m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + reflect (exists i, ~~ (row i A <= B)%MS) (~~ (A <= B)%MS). +Proof. by rewrite (sameP row_subP forallP) negb_forall; exact: existsP. Qed. + +Lemma sub_rVP n (u v : 'rV_n) : reflect (exists a, u = a *: v) (u <= v)%MS. +Proof. +apply: (iffP submxP) => [[w ->] | [a ->]]. + by exists (w 0 0); rewrite -mul_scalar_mx -mx11_scalar. +by exists a%:M; rewrite mul_scalar_mx. +Qed. + +Lemma rank_rV n (v : 'rV_n) : \rank v = (v != 0). +Proof. +case: eqP => [-> | nz_v]; first by rewrite mxrank0. +by apply/eqP; rewrite eqn_leq rank_leq_row lt0n mxrank_eq0; exact/eqP. +Qed. + +Lemma rowV0Pn m n (A : 'M_(m, n)) : + reflect (exists2 v : 'rV_n, v <= A & v != 0)%MS (A != 0). +Proof. +rewrite -submx0; apply: (iffP idP) => [| [v svA]]; last first. + by rewrite -submx0; exact: contra (submx_trans _). +by case/row_subPn=> i; rewrite submx0; exists (row i A); rewrite ?row_sub. +Qed. + +Lemma rowV0P m n (A : 'M_(m, n)) : + reflect (forall v : 'rV_n, v <= A -> v = 0)%MS (A == 0). +Proof. +rewrite -[A == 0]negbK; case: rowV0Pn => IH. + by right; case: IH => v svA nzv IH; case/eqP: nzv; exact: IH. +by left=> v svA; apply/eqP; apply/idPn=> nzv; case: IH; exists v. +Qed. + +Lemma submx_full m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + row_full B -> (A <= B)%MS. +Proof. +by rewrite submxE /cokermx =>/eqnP->; rewrite /copid_mx pid_mx_1 subrr !mulmx0. +Qed. + +Lemma row_fullP m n (A : 'M_(m, n)) : + reflect (exists B, B *m A = 1%:M) (row_full A). +Proof. +apply: (iffP idP) => [Afull | [B kA]]. + by exists (1%:M *m pinvmx A); apply: mulmxKpV (submx_full _ Afull). +by rewrite [_ A]eqn_leq rank_leq_col (mulmx1_min_rank B 1%:M) ?mulmx1. +Qed. +Implicit Arguments row_fullP [m n A]. + +Lemma row_full_inj m n p A : row_full A -> injective (@mulmx _ m n p A). +Proof. +case/row_fullP=> A' A'K; apply: can_inj (mulmx A') _ => B. +by rewrite mulmxA A'K mul1mx. +Qed. + +Lemma row_freeP m n (A : 'M_(m, n)) : + reflect (exists B, A *m B = 1%:M) (row_free A). +Proof. +rewrite /row_free -mxrank_tr. +apply: (iffP row_fullP) => [] [B kA]; + by exists B^T; rewrite -trmx1 -kA trmx_mul ?trmxK. +Qed. + +Lemma row_free_inj m n p A : row_free A -> injective ((@mulmx _ m n p)^~ A). +Proof. +case/row_freeP=> A' AK; apply: can_inj (mulmx^~ A') _ => B. +by rewrite -mulmxA AK mulmx1. +Qed. + +Lemma row_free_unit n (A : 'M_n) : row_free A = (A \in unitmx). +Proof. +apply/row_fullP/idP=> [[A'] | uA]; first by case/mulmx1_unit. +by exists (invmx A); rewrite mulVmx. +Qed. + +Lemma row_full_unit n (A : 'M_n) : row_full A = (A \in unitmx). +Proof. exact: row_free_unit. Qed. + +Lemma mxrank_unit n (A : 'M_n) : A \in unitmx -> \rank A = n. +Proof. by rewrite -row_full_unit =>/eqnP. Qed. + +Lemma mxrank1 n : \rank (1%:M : 'M_n) = n. +Proof. by apply: mxrank_unit; exact: unitmx1. Qed. + +Lemma mxrank_delta m n i j : \rank (delta_mx i j : 'M_(m, n)) = 1%N. +Proof. +apply/eqP; rewrite eqn_leq lt0n mxrank_eq0. +rewrite -{1}(mul_delta_mx (0 : 'I_1)) mulmx_max_rank. +by apply/eqP; move/matrixP; move/(_ i j); move/eqP; rewrite !mxE !eqxx oner_eq0. +Qed. + +Lemma mxrankS m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A <= B)%MS -> \rank A <= \rank B. +Proof. by case/submxP=> D ->; rewrite mxrankM_maxr. Qed. + +Lemma submx1 m n (A : 'M_(m, n)) : (A <= 1%:M)%MS. +Proof. by rewrite submx_full // row_full_unit unitmx1. Qed. + +Lemma sub1mx m n (A : 'M_(m, n)) : (1%:M <= A)%MS = row_full A. +Proof. +apply/idP/idP; last exact: submx_full. +by move/mxrankS; rewrite mxrank1 col_leq_rank. +Qed. + +Lemma ltmx1 m n (A : 'M_(m, n)) : (A < 1%:M)%MS = ~~ row_full A. +Proof. by rewrite /ltmx sub1mx submx1. Qed. + +Lemma lt1mx m n (A : 'M_(m, n)) : (1%:M < A)%MS = false. +Proof. by rewrite /ltmx submx1 andbF. Qed. + +Lemma eqmxP m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + reflect (A :=: B)%MS (A == B)%MS. +Proof. +apply: (iffP andP) => [[sAB sBA] | eqAB]; last by rewrite !eqAB. +split=> [|m3 C]; first by apply/eqP; rewrite eqn_leq !mxrankS. +split; first by apply/idP/idP; exact: submx_trans. +by apply/idP/idP=> sC; exact: submx_trans sC _. +Qed. +Implicit Arguments eqmxP [m1 m2 n A B]. + +Lemma rV_eqP m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + reflect (forall u : 'rV_n, (u <= A) = (u <= B))%MS (A == B)%MS. +Proof. +apply: (iffP idP) => [eqAB u | eqAB]; first by rewrite (eqmxP eqAB). +by apply/andP; split; apply/rV_subP=> u; rewrite eqAB. +Qed. + +Lemma eqmx_refl m1 n (A : 'M_(m1, n)) : (A :=: A)%MS. +Proof. by []. Qed. + +Lemma eqmx_sym m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A :=: B)%MS -> (B :=: A)%MS. +Proof. by move=> eqAB; split=> [|m3 C]; rewrite !eqAB. Qed. + +Lemma eqmx_trans m1 m2 m3 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) (C : 'M_(m3, n)) : + (A :=: B)%MS -> (B :=: C)%MS -> (A :=: C)%MS. +Proof. by move=> eqAB eqBC; split=> [|m4 D]; rewrite !eqAB !eqBC. Qed. + +Lemma eqmx_rank m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A == B)%MS -> \rank A = \rank B. +Proof. by move/eqmxP->. Qed. + +Lemma lt_eqmx m1 m2 m3 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A :=: B)%MS -> + forall C : 'M_(m3, n), (((A < C) = (B < C))%MS * ((C < A) = (C < B))%MS)%type. +Proof. by move=> eqAB C; rewrite /ltmx !eqAB. Qed. + +Lemma eqmxMr m1 m2 n p (A : 'M_(m1, n)) (B : 'M_(m2, n)) (C : 'M_(n, p)) : + (A :=: B)%MS -> (A *m C :=: B *m C)%MS. +Proof. by move=> eqAB; apply/eqmxP; rewrite !submxMr ?eqAB. Qed. + +Lemma eqmxMfull m n p (A : 'M_(m, n)) (B : 'M_(n, p)) : + row_full A -> (A *m B :=: B)%MS. +Proof. +case/row_fullP=> A' A'A; apply/eqmxP; rewrite submxMl /=. +by apply/submxP; exists A'; rewrite mulmxA A'A mul1mx. +Qed. + +Lemma eqmx0 m n : ((0 : 'M[F]_(m, n)) :=: (0 : 'M_n))%MS. +Proof. by apply/eqmxP; rewrite !sub0mx. Qed. + +Lemma eqmx_scale m n a (A : 'M_(m, n)) : a != 0 -> (a *: A :=: A)%MS. +Proof. +move=> nz_a; apply/eqmxP; rewrite scalemx_sub //. +by rewrite -{1}[A]scale1r -(mulVf nz_a) -scalerA scalemx_sub. +Qed. + +Lemma eqmx_opp m n (A : 'M_(m, n)) : (- A :=: A)%MS. +Proof. +by rewrite -scaleN1r; apply: eqmx_scale => //; rewrite oppr_eq0 oner_eq0. +Qed. + +Lemma submxMfree m1 m2 n p (A : 'M_(m1, n)) (B : 'M_(m2, n)) (C : 'M_(n, p)) : + row_free C -> (A *m C <= B *m C)%MS = (A <= B)%MS. +Proof. +case/row_freeP=> C' C_C'_1; apply/idP/idP=> sAB; last exact: submxMr. +by rewrite -[A]mulmx1 -[B]mulmx1 -C_C'_1 !mulmxA submxMr. +Qed. + +Lemma eqmxMfree m1 m2 n p (A : 'M_(m1, n)) (B : 'M_(m2, n)) (C : 'M_(n, p)) : + row_free C -> (A *m C :=: B *m C)%MS -> (A :=: B)%MS. +Proof. +by move=> Cfree eqAB; apply/eqmxP; move/eqmxP: eqAB; rewrite !submxMfree. +Qed. + +Lemma mxrankMfree m n p (A : 'M_(m, n)) (B : 'M_(n, p)) : + row_free B -> \rank (A *m B) = \rank A. +Proof. +by move=> Bfree; rewrite -mxrank_tr trmx_mul eqmxMfull /row_full mxrank_tr. +Qed. + +Lemma eq_row_base m n (A : 'M_(m, n)) : (row_base A :=: A)%MS. +Proof. +apply/eqmxP; apply/andP; split; apply/submxP. + exists (pid_mx (\rank A) *m invmx (col_ebase A)). + by rewrite -{8}[A]mulmx_ebase !mulmxA mulmxKV // pid_mx_id. +exists (col_ebase A *m pid_mx (\rank A)). +by rewrite mulmxA -(mulmxA _ _ (pid_mx _)) pid_mx_id // mulmx_ebase. +Qed. + +Let qidmx_eq1 n (A : 'M_n) : qidmx A = (A == 1%:M). +Proof. by rewrite /qidmx eqxx pid_mx_1. Qed. + +Let genmx_witnessP m n (A : 'M_(m, n)) : + equivmx A (row_full A) (genmx_witness A). +Proof. +rewrite /equivmx qidmx_eq1 /genmx_witness. +case fullA: (row_full A); first by rewrite eqxx sub1mx submx1 fullA. +set B := _ *m _; have defB : (B == A)%MS. + apply/andP; split; apply/submxP. + exists (pid_mx (\rank A) *m invmx (col_ebase A)). + by rewrite -{3}[A]mulmx_ebase !mulmxA mulmxKV // pid_mx_id. + exists (col_ebase A *m pid_mx (\rank A)). + by rewrite mulmxA -(mulmxA _ _ (pid_mx _)) pid_mx_id // mulmx_ebase. +rewrite defB -negb_add addbF; case: eqP defB => // ->. +by rewrite sub1mx fullA. +Qed. + +Lemma genmxE m n (A : 'M_(m, n)) : (<> :=: A)%MS. +Proof. +by rewrite unlock; apply/eqmxP; case/andP: (chooseP (genmx_witnessP A)). +Qed. + +Lemma eq_genmx m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A :=: B -> <> = <>)%MS. +Proof. +move=> eqAB; rewrite unlock. +have{eqAB} eqAB: equivmx A (row_full A) =1 equivmx B (row_full B). + by move=> C; rewrite /row_full /equivmx !eqAB. +rewrite (eq_choose eqAB) (choose_id _ (genmx_witnessP B)) //. +by rewrite -eqAB genmx_witnessP. +Qed. + +Lemma genmxP m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + reflect (<> = <>)%MS (A == B)%MS. +Proof. +apply: (iffP idP) => eqAB; first exact: eq_genmx (eqmxP _). +by rewrite -!(genmxE A) eqAB !genmxE andbb. +Qed. +Implicit Arguments genmxP [m1 m2 n A B]. + +Lemma genmx0 m n : <<0 : 'M_(m, n)>>%MS = 0. +Proof. by apply/eqP; rewrite -submx0 genmxE sub0mx. Qed. + +Lemma genmx1 n : <<1%:M : 'M_n>>%MS = 1%:M. +Proof. +rewrite unlock; case/andP: (chooseP (@genmx_witnessP n n 1%:M)) => _ /eqP. +by rewrite qidmx_eq1 row_full_unit unitmx1 => /eqP. +Qed. + +Lemma genmx_id m n (A : 'M_(m, n)) : (<<<>>> = <>)%MS. +Proof. by apply: eq_genmx; exact: genmxE. Qed. + +Lemma row_base_free m n (A : 'M_(m, n)) : row_free (row_base A). +Proof. by apply/eqnP; rewrite eq_row_base. Qed. + +Lemma mxrank_gen m n (A : 'M_(m, n)) : \rank <> = \rank A. +Proof. by rewrite genmxE. Qed. + +Lemma col_base_full m n (A : 'M_(m, n)) : row_full (col_base A). +Proof. +apply/row_fullP; exists (pid_mx (\rank A) *m invmx (col_ebase A)). +by rewrite !mulmxA mulmxKV // pid_mx_id // pid_mx_1. +Qed. +Hint Resolve row_base_free col_base_full. + +Lemma mxrank_leqif_sup m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A <= B)%MS -> \rank A <= \rank B ?= iff (B <= A)%MS. +Proof. +move=> sAB; split; first by rewrite mxrankS. +apply/idP/idP=> [| sBA]; last by rewrite eqn_leq !mxrankS. +case/submxP: sAB => D ->; rewrite -{-2}(mulmx_base B) mulmxA. +rewrite mxrankMfree // => /row_fullP[E kE]. +by rewrite -{1}[row_base B]mul1mx -kE -(mulmxA E) (mulmxA _ E) submxMl. +Qed. + +Lemma mxrank_leqif_eq m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A <= B)%MS -> \rank A <= \rank B ?= iff (A == B)%MS. +Proof. by move=> sAB; rewrite sAB; exact: mxrank_leqif_sup. Qed. + +Lemma ltmxErank m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A < B)%MS = (A <= B)%MS && (\rank A < \rank B). +Proof. +by apply: andb_id2l => sAB; rewrite (ltn_leqif (mxrank_leqif_sup sAB)). +Qed. + +Lemma rank_ltmx m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A < B)%MS -> \rank A < \rank B. +Proof. by rewrite ltmxErank => /andP[]. Qed. + +Lemma eqmx_cast m1 m2 n (A : 'M_(m1, n)) e : + ((castmx e A : 'M_(m2, n)) :=: A)%MS. +Proof. by case: e A; case: m2 / => A e; rewrite castmx_id. Qed. + +Lemma eqmx_conform m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (conform_mx A B :=: A \/ conform_mx A B :=: B)%MS. +Proof. +case: (eqVneq m2 m1) => [-> | neqm12] in B *. + by right; rewrite conform_mx_id. +by left; rewrite nonconform_mx ?neqm12. +Qed. + +Let eqmx_sum_nop m n (A : 'M_(m, n)) : (addsmx_nop A :=: A)%MS. +Proof. +case: (eqmx_conform <>%MS A) => // eq_id_gen. +exact: eqmx_trans (genmxE A). +Qed. + +Section AddsmxSub. + +Variable (m1 m2 n : nat) (A : 'M[F]_(m1, n)) (B : 'M[F]_(m2, n)). + +Lemma col_mx_sub m3 (C : 'M_(m3, n)) : + (col_mx A B <= C)%MS = (A <= C)%MS && (B <= C)%MS. +Proof. +rewrite !submxE mul_col_mx -col_mx0. +by apply/eqP/andP; [case/eq_col_mx=> -> -> | case; do 2!move/eqP->]. +Qed. + +Lemma addsmxE : (A + B :=: col_mx A B)%MS. +Proof. +have:= submx_refl (col_mx A B); rewrite col_mx_sub; case/andP=> sAS sBS. +rewrite unlock; do 2?case: eqP => [AB0 | _]; last exact: genmxE. + by apply/eqmxP; rewrite !eqmx_sum_nop sBS col_mx_sub AB0 sub0mx /=. +by apply/eqmxP; rewrite !eqmx_sum_nop sAS col_mx_sub AB0 sub0mx andbT /=. +Qed. + +Lemma addsmx_sub m3 (C : 'M_(m3, n)) : + (A + B <= C)%MS = (A <= C)%MS && (B <= C)%MS. +Proof. by rewrite addsmxE col_mx_sub. Qed. + +Lemma addsmxSl : (A <= A + B)%MS. +Proof. by have:= submx_refl (A + B)%MS; rewrite addsmx_sub; case/andP. Qed. + +Lemma addsmxSr : (B <= A + B)%MS. +Proof. by have:= submx_refl (A + B)%MS; rewrite addsmx_sub; case/andP. Qed. + +Lemma addsmx_idPr : reflect (A + B :=: B)%MS (A <= B)%MS. +Proof. +have:= @eqmxP _ _ _ (A + B)%MS B. +by rewrite addsmxSr addsmx_sub submx_refl !andbT. +Qed. + +Lemma addsmx_idPl : reflect (A + B :=: A)%MS (B <= A)%MS. +Proof. +have:= @eqmxP _ _ _ (A + B)%MS A. +by rewrite addsmxSl addsmx_sub submx_refl !andbT. +Qed. + +End AddsmxSub. + +Lemma adds0mx m1 m2 n (B : 'M_(m2, n)) : ((0 : 'M_(m1, n)) + B :=: B)%MS. +Proof. by apply/eqmxP; rewrite addsmx_sub sub0mx addsmxSr /= andbT. Qed. + +Lemma addsmx0 m1 m2 n (A : 'M_(m1, n)) : (A + (0 : 'M_(m2, n)) :=: A)%MS. +Proof. by apply/eqmxP; rewrite addsmx_sub sub0mx addsmxSl /= !andbT. Qed. + +Let addsmx_nop_eq0 m n (A : 'M_(m, n)) : (addsmx_nop A == 0) = (A == 0). +Proof. by rewrite -!submx0 eqmx_sum_nop. Qed. + +Let addsmx_nop0 m n : addsmx_nop (0 : 'M_(m, n)) = 0. +Proof. by apply/eqP; rewrite addsmx_nop_eq0. Qed. + +Let addsmx_nop_id n (A : 'M_n) : addsmx_nop A = A. +Proof. exact: conform_mx_id. Qed. + +Lemma addsmxC m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : (A + B = B + A)%MS. +Proof. +have: (A + B == B + A)%MS. + by apply/andP; rewrite !addsmx_sub andbC -addsmx_sub andbC -addsmx_sub. +move/genmxP; rewrite [@addsmx]unlock -!submx0 !submx0. +by do 2!case: eqP => [// -> | _]; rewrite ?genmx_id ?addsmx_nop0. +Qed. + +Lemma adds0mx_id m1 n (B : 'M_n) : ((0 : 'M_(m1, n)) + B)%MS = B. +Proof. by rewrite unlock eqxx addsmx_nop_id. Qed. + +Lemma addsmx0_id m2 n (A : 'M_n) : (A + (0 : 'M_(m2, n)))%MS = A. +Proof. by rewrite addsmxC adds0mx_id. Qed. + +Lemma addsmxA m1 m2 m3 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) (C : 'M_(m3, n)) : + (A + (B + C) = A + B + C)%MS. +Proof. +have: (A + (B + C) :=: A + B + C)%MS. + by apply/eqmxP/andP; rewrite !addsmx_sub -andbA andbA -!addsmx_sub. +rewrite {1 3}[in @addsmx m1]unlock [in @addsmx n]unlock !addsmx_nop_id -!submx0. +rewrite !addsmx_sub ![@addsmx]unlock -!submx0; move/eq_genmx. +by do 3!case: (_ <= 0)%MS; rewrite //= !genmx_id. +Qed. + +Canonical addsmx_monoid n := + Monoid.Law (@addsmxA n n n n) (@adds0mx_id n n) (@addsmx0_id n n). +Canonical addsmx_comoid n := Monoid.ComLaw (@addsmxC n n n). + +Lemma addsmxMr m1 m2 n p (A : 'M_(m1, n)) (B : 'M_(m2, n)) (C : 'M_(n, p)) : + ((A + B)%MS *m C :=: A *m C + B *m C)%MS. +Proof. by apply/eqmxP; rewrite !addsmxE -!mul_col_mx !submxMr ?addsmxE. Qed. + +Lemma addsmxS m1 m2 m3 m4 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) + (C : 'M_(m3, n)) (D : 'M_(m4, n)) : + (A <= C -> B <= D -> A + B <= C + D)%MS. +Proof. +move=> sAC sBD. +by rewrite addsmx_sub {1}addsmxC !(submx_trans _ (addsmxSr _ _)). +Qed. + +Lemma addmx_sub_adds m m1 m2 n (A : 'M_(m, n)) (B : 'M_(m, n)) + (C : 'M_(m1, n)) (D : 'M_(m2, n)) : + (A <= C -> B <= D -> (A + B)%R <= C + D)%MS. +Proof. +move=> sAC; move/(addsmxS sAC); apply: submx_trans. +by rewrite addmx_sub ?addsmxSl ?addsmxSr. +Qed. + +Lemma addsmx_addKl n m1 m2 (A : 'M_(m1, n)) (B C : 'M_(m2, n)) : + (B <= A)%MS -> (A + (B + C)%R :=: A + C)%MS. +Proof. +move=> sBA; apply/eqmxP; rewrite !addsmx_sub !addsmxSl. +by rewrite -{3}[C](addKr B) !addmx_sub_adds ?eqmx_opp. +Qed. + +Lemma addsmx_addKr n m1 m2 (A B : 'M_(m1, n)) (C : 'M_(m2, n)) : + (B <= C)%MS -> ((A + B)%R + C :=: A + C)%MS. +Proof. by rewrite -!(addsmxC C) addrC; exact: addsmx_addKl. Qed. + +Lemma adds_eqmx m1 m2 m3 m4 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) + (C : 'M_(m3, n)) (D : 'M_(m4, n)) : + (A :=: C -> B :=: D -> A + B :=: C + D)%MS. +Proof. by move=> eqAC eqBD; apply/eqmxP; rewrite !addsmxS ?eqAC ?eqBD. Qed. + +Lemma genmx_adds m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (<<(A + B)%MS>> = <> + <>)%MS. +Proof. +rewrite -(eq_genmx (adds_eqmx (genmxE A) (genmxE B))). +by rewrite [@addsmx]unlock !addsmx_nop_id !(fun_if (@genmx _ _)) !genmx_id. +Qed. + +Lemma sub_addsmxP m1 m2 m3 n + (A : 'M_(m1, n)) (B : 'M_(m2, n)) (C : 'M_(m3, n)) : + reflect (exists u, A = u.1 *m B + u.2 *m C) (A <= B + C)%MS. +Proof. +apply: (iffP idP) => [|[u ->]]; last by rewrite addmx_sub_adds ?submxMl. +rewrite addsmxE; case/submxP=> u ->; exists (lsubmx u, rsubmx u). +by rewrite -mul_row_col hsubmxK. +Qed. +Implicit Arguments sub_addsmxP [m1 m2 m3 n A B C]. + +Variable I : finType. +Implicit Type P : pred I. + +Lemma genmx_sums P n (B_ : I -> 'M_n) : + <<(\sum_(i | P i) B_ i)%MS>>%MS = (\sum_(i | P i) <>)%MS. +Proof. exact: (big_morph _ (@genmx_adds n n n) (@genmx0 n n)). Qed. + +Lemma sumsmx_sup i0 P m n (A : 'M_(m, n)) (B_ : I -> 'M_n) : + P i0 -> (A <= B_ i0)%MS -> (A <= \sum_(i | P i) B_ i)%MS. +Proof. +by move=> Pi0 sAB; apply: submx_trans sAB _; rewrite (bigD1 i0) // addsmxSl. +Qed. +Implicit Arguments sumsmx_sup [P m n A B_]. + +Lemma sumsmx_subP P m n (A_ : I -> 'M_n) (B : 'M_(m, n)) : + reflect (forall i, P i -> A_ i <= B)%MS (\sum_(i | P i) A_ i <= B)%MS. +Proof. +apply: (iffP idP) => [sAB i Pi | sAB]. + by apply: submx_trans sAB; apply: sumsmx_sup Pi _. +by elim/big_rec: _ => [|i Ai Pi sAiB]; rewrite ?sub0mx // addsmx_sub sAB. +Qed. + +Lemma summx_sub_sums P m n (A : I -> 'M[F]_(m, n)) B : + (forall i, P i -> A i <= B i)%MS -> + ((\sum_(i | P i) A i)%R <= \sum_(i | P i) B i)%MS. +Proof. +by move=> sAB; apply: summx_sub => i Pi; rewrite (sumsmx_sup i) ?sAB. +Qed. + +Lemma sumsmxS P n (A B : I -> 'M[F]_n) : + (forall i, P i -> A i <= B i)%MS -> + (\sum_(i | P i) A i <= \sum_(i | P i) B i)%MS. +Proof. +by move=> sAB; apply/sumsmx_subP=> i Pi; rewrite (sumsmx_sup i) ?sAB. +Qed. + +Lemma eqmx_sums P n (A B : I -> 'M[F]_n) : + (forall i, P i -> A i :=: B i)%MS -> + (\sum_(i | P i) A i :=: \sum_(i | P i) B i)%MS. +Proof. by move=> eqAB; apply/eqmxP; rewrite !sumsmxS // => i; move/eqAB->. Qed. + +Lemma sub_sumsmxP P m n (A : 'M_(m, n)) (B_ : I -> 'M_n) : + reflect (exists u_, A = \sum_(i | P i) u_ i *m B_ i) + (A <= \sum_(i | P i) B_ i)%MS. +Proof. +apply: (iffP idP) => [| [u_ ->]]; last first. + by apply: summx_sub_sums => i _; exact: submxMl. +elim: {P}_.+1 {-2}P A (ltnSn #|P|) => // b IHb P A. +case: (pickP P) => [i Pi | P0 _]; last first. + rewrite big_pred0 //; move/submx0null->. + by exists (fun _ => 0); rewrite big_pred0. +rewrite (cardD1x Pi) (bigD1 i) //= => /IHb{b IHb} /= IHi /sub_addsmxP[u ->]. +have [u_ ->] := IHi _ (submxMl u.2 _). +exists [eta u_ with i |-> u.1]; rewrite (bigD1 i Pi) /= eqxx; congr (_ + _). +by apply: eq_bigr => j /andP[_ /negPf->]. +Qed. + +Lemma sumsmxMr_gen P m n A (B : 'M[F]_(m, n)) : + ((\sum_(i | P i) A i)%MS *m B :=: \sum_(i | P i) <>)%MS. +Proof. +apply/eqmxP/andP; split; last first. + by apply/sumsmx_subP=> i Pi; rewrite genmxE submxMr ?(sumsmx_sup i). +have [u ->] := sub_sumsmxP _ _ _ (submx_refl (\sum_(i | P i) A i)%MS). +by rewrite mulmx_suml summx_sub_sums // => i _; rewrite genmxE -mulmxA submxMl. +Qed. + +Lemma sumsmxMr P n (A_ : I -> 'M[F]_n) (B : 'M_n) : + ((\sum_(i | P i) A_ i)%MS *m B :=: \sum_(i | P i) (A_ i *m B))%MS. +Proof. +by apply: eqmx_trans (sumsmxMr_gen _ _ _) (eqmx_sums _) => i _; exact: genmxE. +Qed. + +Lemma rank_pid_mx m n r : r <= m -> r <= n -> \rank (pid_mx r : 'M_(m, n)) = r. +Proof. +do 2!move/subnKC <-; rewrite pid_mx_block block_mxEv row_mx0 -addsmxE addsmx0. +by rewrite -mxrank_tr tr_row_mx trmx0 trmx1 -addsmxE addsmx0 mxrank1. +Qed. + +Lemma rank_copid_mx n r : r <= n -> \rank (copid_mx r : 'M_n) = (n - r)%N. +Proof. +move/subnKC <-; rewrite /copid_mx pid_mx_block scalar_mx_block. +rewrite opp_block_mx !oppr0 add_block_mx !addr0 subrr block_mxEv row_mx0. +rewrite -addsmxE adds0mx -mxrank_tr tr_row_mx trmx0 trmx1. +by rewrite -addsmxE adds0mx mxrank1 addKn. +Qed. + +Lemma mxrank_compl m n (A : 'M_(m, n)) : \rank A^C = (n - \rank A)%N. +Proof. by rewrite mxrankMfree ?row_free_unit ?rank_copid_mx. Qed. + +Lemma mxrank_ker m n (A : 'M_(m, n)) : \rank (kermx A) = (m - \rank A)%N. +Proof. by rewrite mxrankMfree ?row_free_unit ?unitmx_inv ?rank_copid_mx. Qed. + +Lemma kermx_eq0 n m (A : 'M_(m, n)) : (kermx A == 0) = row_free A. +Proof. by rewrite -mxrank_eq0 mxrank_ker subn_eq0 row_leq_rank. Qed. + +Lemma mxrank_coker m n (A : 'M_(m, n)) : \rank (cokermx A) = (n - \rank A)%N. +Proof. by rewrite eqmxMfull ?row_full_unit ?unitmx_inv ?rank_copid_mx. Qed. + +Lemma cokermx_eq0 n m (A : 'M_(m, n)) : (cokermx A == 0) = row_full A. +Proof. by rewrite -mxrank_eq0 mxrank_coker subn_eq0 col_leq_rank. Qed. + +Lemma mulmx_ker m n (A : 'M_(m, n)) : kermx A *m A = 0. +Proof. +by rewrite -{2}[A]mulmx_ebase !mulmxA mulmxKV // mul_copid_mx_pid ?mul0mx. +Qed. + +Lemma mulmxKV_ker m n p (A : 'M_(n, p)) (B : 'M_(m, n)) : + B *m A = 0 -> B *m col_ebase A *m kermx A = B. +Proof. +rewrite mulmxA mulmxBr mulmx1 mulmxBl mulmxK //. +rewrite -{1}[A]mulmx_ebase !mulmxA => /(canRL (mulmxK (row_ebase_unit A))). +rewrite mul0mx // => BA0; apply: (canLR (addrK _)). +by rewrite -(pid_mx_id _ _ n (rank_leq_col A)) mulmxA BA0 !mul0mx addr0. +Qed. + +Lemma sub_kermxP p m n (A : 'M_(m, n)) (B : 'M_(p, m)) : + reflect (B *m A = 0) (B <= kermx A)%MS. +Proof. +apply: (iffP submxP) => [[D ->]|]; first by rewrite -mulmxA mulmx_ker mulmx0. +by move/mulmxKV_ker; exists (B *m col_ebase A). +Qed. + +Lemma mulmx0_rank_max m n p (A : 'M_(m, n)) (B : 'M_(n, p)) : + A *m B = 0 -> \rank A + \rank B <= n. +Proof. +move=> AB0; rewrite -{3}(subnK (rank_leq_row B)) leq_add2r. +rewrite -mxrank_ker mxrankS //; exact/sub_kermxP. +Qed. + +Lemma mxrank_Frobenius m n p q (A : 'M_(m, n)) B (C : 'M_(p, q)) : + \rank (A *m B) + \rank (B *m C) <= \rank B + \rank (A *m B *m C). +Proof. +rewrite -{2}(mulmx_base (A *m B)) -mulmxA (eqmxMfull _ (col_base_full _)). +set C2 := row_base _ *m C. +rewrite -{1}(subnK (rank_leq_row C2)) -(mxrank_ker C2) addnAC leq_add2r. +rewrite addnC -{1}(mulmx_base B) -mulmxA eqmxMfull //. +set C1 := _ *m C; rewrite -{2}(subnKC (rank_leq_row C1)) leq_add2l -mxrank_ker. +rewrite -(mxrankMfree _ (row_base_free (A *m B))). +have: (row_base (A *m B) <= row_base B)%MS by rewrite !eq_row_base submxMl. +case/submxP=> D defD; rewrite defD mulmxA mxrankMfree ?mxrankS //. +by apply/sub_kermxP; rewrite -mulmxA (mulmxA D) -defD -/C2 mulmx_ker. +Qed. + +Lemma mxrank_mul_min m n p (A : 'M_(m, n)) (B : 'M_(n, p)) : + \rank A + \rank B - n <= \rank (A *m B). +Proof. +by have:= mxrank_Frobenius A 1%:M B; rewrite mulmx1 mul1mx mxrank1 leq_subLR. +Qed. + +Lemma addsmx_compl_full m n (A : 'M_(m, n)) : row_full (A + A^C)%MS. +Proof. +rewrite /row_full addsmxE; apply/row_fullP. +exists (row_mx (pinvmx A) (cokermx A)); rewrite mul_row_col. +rewrite -{2}[A]mulmx_ebase -!mulmxA mulKmx // -mulmxDr !mulmxA. +by rewrite pid_mx_id ?copid_mx_id // -mulmxDl addrC subrK mul1mx mulVmx. +Qed. + +Lemma sub_capmx_gen m1 m2 m3 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) (C : 'M_(m3, n)) : + (A <= capmx_gen B C)%MS = (A <= B)%MS && (A <= C)%MS. +Proof. +apply/idP/andP=> [sAI | [/submxP[B' ->{A}] /submxP[C' eqBC']]]. + rewrite !(submx_trans sAI) ?submxMl // /capmx_gen. + have:= mulmx_ker (col_mx B C); set K := kermx _. + rewrite -{1}[K]hsubmxK mul_row_col; move/(canRL (addrK _))->. + by rewrite add0r -mulNmx submxMl. +have: (row_mx B' (- C') <= kermx (col_mx B C))%MS. + by apply/sub_kermxP; rewrite mul_row_col eqBC' mulNmx subrr. +case/submxP=> D; rewrite -[kermx _]hsubmxK mul_mx_row. +by case/eq_row_mx=> -> _; rewrite -mulmxA submxMl. +Qed. + +Let capmx_witnessP m n (A : 'M_(m, n)) : equivmx A (qidmx A) (capmx_witness A). +Proof. +rewrite /equivmx qidmx_eq1 /qidmx /capmx_witness. +rewrite -sub1mx; case s1A: (1%:M <= A)%MS => /=; last first. + rewrite !genmxE submx_refl /= -negb_add; apply: contra {s1A}(negbT s1A). + case: eqP => [<- _| _]; first by rewrite genmxE. + by case: eqP A => //= -> A; move/eqP->; rewrite pid_mx_1. +case: (m =P n) => [-> | ne_mn] in A s1A *. + by rewrite conform_mx_id submx_refl pid_mx_1 eqxx. +by rewrite nonconform_mx ?submx1 ?s1A ?eqxx //; case: eqP. +Qed. + +Let capmx_normP m n (A : 'M_(m, n)) : equivmx_spec A (qidmx A) (capmx_norm A). +Proof. by case/andP: (chooseP (capmx_witnessP A)) => /eqmxP defN /eqP. Qed. + +Let capmx_norm_eq m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + qidmx A = qidmx B -> (A == B)%MS -> capmx_norm A = capmx_norm B. +Proof. +move=> eqABid /eqmxP eqAB. +have{eqABid eqAB} eqAB: equivmx A (qidmx A) =1 equivmx B (qidmx B). + by move=> C; rewrite /equivmx eqABid !eqAB. +rewrite {1}/capmx_norm (eq_choose eqAB). +by apply: choose_id; first rewrite -eqAB; exact: capmx_witnessP. +Qed. + +Let capmx_nopP m n (A : 'M_(m, n)) : equivmx_spec A (qidmx A) (capmx_nop A). +Proof. +rewrite /capmx_nop; case: (eqVneq m n) => [-> | ne_mn] in A *. + by rewrite conform_mx_id. +rewrite nonconform_mx ?ne_mn //; exact: capmx_normP. +Qed. + +Let sub_qidmx m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + qidmx B -> (A <= B)%MS. +Proof. +rewrite /qidmx => idB; apply: {A}submx_trans (submx1 A) _. +by case: eqP B idB => [-> _ /eqP-> | _ B]; rewrite (=^~ sub1mx, pid_mx_1). +Qed. + +Let qidmx_cap m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + qidmx (A :&: B)%MS = qidmx A && qidmx B. +Proof. +rewrite unlock -sub1mx. +case idA: (qidmx A); case idB: (qidmx B); try by rewrite capmx_nopP. +case s1B: (_ <= B)%MS; first by rewrite capmx_normP. +apply/idP=> /(sub_qidmx 1%:M). +by rewrite capmx_normP sub_capmx_gen s1B andbF. +Qed. + +Let capmx_eq_norm m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + qidmx A = qidmx B -> (A :&: B)%MS = capmx_norm (A :&: B)%MS. +Proof. +move=> eqABid; rewrite unlock -sub1mx {}eqABid. +have norm_id m (C : 'M_(m, n)) (N := capmx_norm C) : capmx_norm N = N. + by apply: capmx_norm_eq; rewrite ?capmx_normP ?andbb. +case idB: (qidmx B); last by case: ifP; rewrite norm_id. +rewrite /capmx_nop; case: (eqVneq m2 n) => [-> | neqm2n] in B idB *. + have idN := idB; rewrite -{1}capmx_normP !qidmx_eq1 in idN idB. + by rewrite conform_mx_id (eqP idN) (eqP idB). +by rewrite nonconform_mx ?neqm2n ?norm_id. +Qed. + +Lemma capmxE m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A :&: B :=: capmx_gen A B)%MS. +Proof. +rewrite unlock -sub1mx; apply/eqmxP. +have:= submx_refl (capmx_gen A B); rewrite !sub_capmx_gen => /andP[sIA sIB]. +case idA: (qidmx A); first by rewrite !capmx_nopP submx_refl sub_qidmx. +case idB: (qidmx B); first by rewrite !capmx_nopP submx_refl sub_qidmx. +case s1B: (1%:M <= B)%MS; rewrite !capmx_normP ?sub_capmx_gen sIA ?sIB //=. +by rewrite submx_refl (submx_trans (submx1 _)). +Qed. + +Lemma capmxSl m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : (A :&: B <= A)%MS. +Proof. by rewrite capmxE submxMl. Qed. + +Lemma sub_capmx m m1 m2 n (A : 'M_(m, n)) (B : 'M_(m1, n)) (C : 'M_(m2, n)) : + (A <= B :&: C)%MS = (A <= B)%MS && (A <= C)%MS. +Proof. by rewrite capmxE sub_capmx_gen. Qed. + +Lemma capmxC m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : (A :&: B = B :&: A)%MS. +Proof. +have [eqAB|] := eqVneq (qidmx A) (qidmx B). + rewrite (capmx_eq_norm eqAB) (capmx_eq_norm (esym eqAB)). + apply: capmx_norm_eq; first by rewrite !qidmx_cap andbC. + by apply/andP; split; rewrite !sub_capmx andbC -sub_capmx. +by rewrite negb_eqb !unlock => /addbP <-; case: (qidmx A). +Qed. + +Lemma capmxSr m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : (A :&: B <= B)%MS. +Proof. by rewrite capmxC capmxSl. Qed. + +Lemma capmx_idPr n m1 m2 (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + reflect (A :&: B :=: B)%MS (B <= A)%MS. +Proof. +have:= @eqmxP _ _ _ (A :&: B)%MS B. +by rewrite capmxSr sub_capmx submx_refl !andbT. +Qed. + +Lemma capmx_idPl n m1 m2 (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + reflect (A :&: B :=: A)%MS (A <= B)%MS. +Proof. by rewrite capmxC; exact: capmx_idPr. Qed. + +Lemma capmxS m1 m2 m3 m4 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) + (C : 'M_(m3, n)) (D : 'M_(m4, n)) : + (A <= C -> B <= D -> A :&: B <= C :&: D)%MS. +Proof. +by move=> sAC sBD; rewrite sub_capmx {1}capmxC !(submx_trans (capmxSr _ _)). +Qed. + +Lemma cap_eqmx m1 m2 m3 m4 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) + (C : 'M_(m3, n)) (D : 'M_(m4, n)) : + (A :=: C -> B :=: D -> A :&: B :=: C :&: D)%MS. +Proof. by move=> eqAC eqBD; apply/eqmxP; rewrite !capmxS ?eqAC ?eqBD. Qed. + +Lemma capmxMr m1 m2 n p (A : 'M_(m1, n)) (B : 'M_(m2, n)) (C : 'M_(n, p)) : + ((A :&: B) *m C <= A *m C :&: B *m C)%MS. +Proof. by rewrite sub_capmx !submxMr ?capmxSl ?capmxSr. Qed. + +Lemma cap0mx m1 m2 n (A : 'M_(m2, n)) : ((0 : 'M_(m1, n)) :&: A)%MS = 0. +Proof. exact: submx0null (capmxSl _ _). Qed. + +Lemma capmx0 m1 m2 n (A : 'M_(m1, n)) : (A :&: (0 : 'M_(m2, n)))%MS = 0. +Proof. exact: submx0null (capmxSr _ _). Qed. + +Lemma capmxT m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + row_full B -> (A :&: B :=: A)%MS. +Proof. +rewrite -sub1mx => s1B; apply/eqmxP. +by rewrite capmxSl sub_capmx submx_refl (submx_trans (submx1 A)). +Qed. + +Lemma capTmx m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + row_full A -> (A :&: B :=: B)%MS. +Proof. by move=> Afull; apply/eqmxP; rewrite capmxC !capmxT ?andbb. Qed. + +Let capmx_nop_id n (A : 'M_n) : capmx_nop A = A. +Proof. by rewrite /capmx_nop conform_mx_id. Qed. + +Lemma cap1mx n (A : 'M_n) : (1%:M :&: A = A)%MS. +Proof. by rewrite unlock qidmx_eq1 eqxx capmx_nop_id. Qed. + +Lemma capmx1 n (A : 'M_n) : (A :&: 1%:M = A)%MS. +Proof. by rewrite capmxC cap1mx. Qed. + +Lemma genmx_cap m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + <>%MS = (<> :&: <>)%MS. +Proof. +rewrite -(eq_genmx (cap_eqmx (genmxE A) (genmxE B))). +case idAB: (qidmx <> || qidmx <>)%MS. + rewrite [@capmx]unlock !capmx_nop_id !(fun_if (@genmx _ _)) !genmx_id. + by case: (qidmx _) idAB => //= ->. +case idA: (qidmx _) idAB => //= idB; rewrite {2}capmx_eq_norm ?idA //. +set C := (_ :&: _)%MS; have eq_idC: row_full C = qidmx C. + rewrite qidmx_cap idA -sub1mx sub_capmx genmxE; apply/andP=> [[s1A]]. + by case/idP: idA; rewrite qidmx_eq1 -genmx1 (sameP eqP genmxP) submx1. +rewrite unlock /capmx_norm eq_idC. +by apply: choose_id (capmx_witnessP _); rewrite -eq_idC genmx_witnessP. +Qed. + +Lemma capmxA m1 m2 m3 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) (C : 'M_(m3, n)) : + (A :&: (B :&: C) = A :&: B :&: C)%MS. +Proof. +rewrite (capmxC A B) capmxC; wlog idA: m1 m3 A C / qidmx A. + move=> IH; case idA: (qidmx A); first exact: IH. + case idC: (qidmx C); first by rewrite -IH. + rewrite (@capmx_eq_norm n m3) ?qidmx_cap ?idA ?idC ?andbF //. + rewrite capmx_eq_norm ?qidmx_cap ?idA ?idC ?andbF //. + apply: capmx_norm_eq; first by rewrite !qidmx_cap andbAC. + by apply/andP; split; rewrite !sub_capmx andbAC -!sub_capmx. +rewrite -!(capmxC A) [in @capmx m1]unlock idA capmx_nop_id. +have [eqBC |] :=eqVneq (qidmx B) (qidmx C). + rewrite (@capmx_eq_norm n) ?capmx_nopP // capmx_eq_norm //. + by apply: capmx_norm_eq; rewrite ?qidmx_cap ?capmxS ?capmx_nopP. +by rewrite !unlock capmx_nopP capmx_nop_id; do 2?case: (qidmx _) => //. +Qed. + +Canonical capmx_monoid n := + Monoid.Law (@capmxA n n n n) (@cap1mx n) (@capmx1 n). +Canonical capmx_comoid n := Monoid.ComLaw (@capmxC n n n). + +Lemma bigcapmx_inf i0 P m n (A_ : I -> 'M_n) (B : 'M_(m, n)) : + P i0 -> (A_ i0 <= B -> \bigcap_(i | P i) A_ i <= B)%MS. +Proof. by move=> Pi0; apply: submx_trans; rewrite (bigD1 i0) // capmxSl. Qed. + +Lemma sub_bigcapmxP P m n (A : 'M_(m, n)) (B_ : I -> 'M_n) : + reflect (forall i, P i -> A <= B_ i)%MS (A <= \bigcap_(i | P i) B_ i)%MS. +Proof. +apply: (iffP idP) => [sAB i Pi | sAB]. + by apply: (submx_trans sAB); rewrite (bigcapmx_inf Pi). +by elim/big_rec: _ => [|i Pi C sAC]; rewrite ?submx1 // sub_capmx sAB. +Qed. + +Lemma genmx_bigcap P n (A_ : I -> 'M_n) : + (<<\bigcap_(i | P i) A_ i>> = \bigcap_(i | P i) <>)%MS. +Proof. exact: (big_morph _ (@genmx_cap n n n) (@genmx1 n)). Qed. + +Lemma matrix_modl m1 m2 m3 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) (C : 'M_(m3, n)) : + (A <= C -> A + (B :&: C) :=: (A + B) :&: C)%MS. +Proof. +move=> sAC; set D := ((A + B) :&: C)%MS; apply/eqmxP. +rewrite sub_capmx addsmxS ?capmxSl // addsmx_sub sAC capmxSr /=. +have: (D <= B + A)%MS by rewrite addsmxC capmxSl. +case/sub_addsmxP=> u defD; rewrite defD addrC addmx_sub_adds ?submxMl //. +rewrite sub_capmx submxMl -[_ *m B](addrK (u.2 *m A)) -defD. +by rewrite addmx_sub ?capmxSr // eqmx_opp mulmx_sub. +Qed. + +Lemma matrix_modr m1 m2 m3 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) (C : 'M_(m3, n)) : + (C <= A -> (A :&: B) + C :=: A :&: (B + C))%MS. +Proof. by rewrite !(capmxC A) -!(addsmxC C); exact: matrix_modl. Qed. + +Lemma capmx_compl m n (A : 'M_(m, n)) : (A :&: A^C)%MS = 0. +Proof. +set D := (A :&: A^C)%MS; have: (D <= D)%MS by []. +rewrite sub_capmx andbC => /andP[/submxP[B defB]]. +rewrite submxE => /eqP; rewrite defB -!mulmxA mulKVmx ?copid_mx_id //. +by rewrite mulmxA => ->; rewrite mul0mx. +Qed. + +Lemma mxrank_mul_ker m n p (A : 'M_(m, n)) (B : 'M_(n, p)) : + (\rank (A *m B) + \rank (A :&: kermx B))%N = \rank A. +Proof. +apply/eqP; set K := kermx B; set C := (A :&: K)%MS. +rewrite -(eqmxMr B (eq_row_base A)); set K' := _ *m B. +rewrite -{2}(subnKC (rank_leq_row K')) -mxrank_ker eqn_add2l. +rewrite -(mxrankMfree _ (row_base_free A)) mxrank_leqif_sup. + rewrite sub_capmx -(eq_row_base A) submxMl. + by apply/sub_kermxP; rewrite -mulmxA mulmx_ker. +have /submxP[C' defC]: (C <= row_base A)%MS by rewrite eq_row_base capmxSl. +rewrite defC submxMr //; apply/sub_kermxP. +by rewrite mulmxA -defC; apply/sub_kermxP; rewrite capmxSr. +Qed. + +Lemma mxrank_injP m n p (A : 'M_(m, n)) (f : 'M_(n, p)) : + reflect (\rank (A *m f) = \rank A) ((A :&: kermx f)%MS == 0). +Proof. +rewrite -mxrank_eq0 -(eqn_add2l (\rank (A *m f))). +by rewrite mxrank_mul_ker addn0 eq_sym; exact: eqP. +Qed. + +Lemma mxrank_disjoint_sum m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A :&: B)%MS = 0 -> \rank (A + B)%MS = (\rank A + \rank B)%N. +Proof. +move=> AB0; pose Ar := row_base A; pose Br := row_base B. +have [Afree Bfree]: row_free Ar /\ row_free Br by rewrite !row_base_free. +have: (Ar :&: Br <= A :&: B)%MS by rewrite capmxS ?eq_row_base. +rewrite {}AB0 submx0 -mxrank_eq0 capmxE mxrankMfree //. +set Cr := col_mx Ar Br; set Crl := lsubmx _; rewrite mxrank_eq0 => /eqP Crl0. +rewrite -(adds_eqmx (eq_row_base _) (eq_row_base _)) addsmxE -/Cr. +suffices K0: kermx Cr = 0. + by apply/eqP; rewrite eqn_leq rank_leq_row -subn_eq0 -mxrank_ker K0 mxrank0. +move/eqP: (mulmx_ker Cr); rewrite -[kermx Cr]hsubmxK mul_row_col -/Crl Crl0. +rewrite mul0mx add0r -mxrank_eq0 mxrankMfree // mxrank_eq0 => /eqP->. +exact: row_mx0. +Qed. + +Lemma diffmxE m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A :\: B :=: A :&: (capmx_gen A B)^C)%MS. +Proof. by rewrite unlock; apply/eqmxP; rewrite !genmxE !capmxE andbb. Qed. + +Lemma genmx_diff m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (<> = A :\: B)%MS. +Proof. by rewrite [@diffmx]unlock genmx_id. Qed. + +Lemma diffmxSl m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : (A :\: B <= A)%MS. +Proof. by rewrite diffmxE capmxSl. Qed. + +Lemma capmx_diff m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + ((A :\: B) :&: B)%MS = 0. +Proof. +apply/eqP; pose C := capmx_gen A B; rewrite -submx0 -(capmx_compl C). +by rewrite sub_capmx -capmxE sub_capmx andbAC -sub_capmx -diffmxE -sub_capmx. +Qed. + +Lemma addsmx_diff_cap_eq m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A :\: B + A :&: B :=: A)%MS. +Proof. +apply/eqmxP; rewrite addsmx_sub capmxSl diffmxSl /=. +set C := (A :\: B)%MS; set D := capmx_gen A B. +suffices sACD: (A <= C + D)%MS. + by rewrite (submx_trans sACD) ?addsmxS ?capmxE. +have:= addsmx_compl_full D; rewrite /row_full addsmxE. +case/row_fullP=> U /(congr1 (mulmx A)); rewrite mulmx1. +rewrite -[U]hsubmxK mul_row_col mulmxDr addrC 2!mulmxA. +set V := _ *m _ => defA; rewrite -defA; move/(canRL (addrK _)): defA => defV. +suffices /submxP[W ->]: (V <= C)%MS by rewrite -mul_row_col addsmxE submxMl. +rewrite diffmxE sub_capmx {1}defV -mulNmx addmx_sub 1?mulmx_sub //. +by rewrite -capmxE capmxSl. +Qed. + +Lemma mxrank_cap_compl m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (\rank (A :&: B) + \rank (A :\: B))%N = \rank A. +Proof. +rewrite addnC -mxrank_disjoint_sum ?addsmx_diff_cap_eq //. +by rewrite (capmxC A) capmxA capmx_diff cap0mx. +Qed. + +Lemma mxrank_sum_cap m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (\rank (A + B) + \rank (A :&: B) = \rank A + \rank B)%N. +Proof. +set C := (A :&: B)%MS; set D := (A :\: B)%MS. +have rDB: \rank (A + B)%MS = \rank (D + B)%MS. + apply/eqP; rewrite mxrank_leqif_sup; first by rewrite addsmxS ?diffmxSl. + by rewrite addsmx_sub addsmxSr -(addsmx_diff_cap_eq A B) addsmxS ?capmxSr. +rewrite {1}rDB mxrank_disjoint_sum ?capmx_diff //. +by rewrite addnC addnA mxrank_cap_compl. +Qed. + +Lemma mxrank_adds_leqif m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + \rank (A + B) <= \rank A + \rank B ?= iff (A :&: B <= (0 : 'M_n))%MS. +Proof. +rewrite -mxrank_sum_cap; split; first exact: leq_addr. +by rewrite addnC (@eqn_add2r _ 0) eq_sym mxrank_eq0 -submx0. +Qed. + +(* Subspace projection matrix *) + +Lemma proj_mx_sub m n U V (W : 'M_(m, n)) : (W *m proj_mx U V <= U)%MS. +Proof. by rewrite !mulmx_sub // -addsmxE addsmx0. Qed. + +Lemma proj_mx_compl_sub m n U V (W : 'M_(m, n)) : + (W <= U + V -> W - W *m proj_mx U V <= V)%MS. +Proof. +rewrite addsmxE => sWUV; rewrite mulmxA -{1}(mulmxKpV sWUV) -mulmxBr. +by rewrite mulmx_sub // opp_col_mx add_col_mx subrr subr0 -addsmxE adds0mx. +Qed. + +Lemma proj_mx_id m n U V (W : 'M_(m, n)) : + (U :&: V = 0)%MS -> (W <= U)%MS -> W *m proj_mx U V = W. +Proof. +move=> dxUV sWU; apply/eqP; rewrite -subr_eq0 -submx0 -dxUV. +rewrite sub_capmx addmx_sub ?eqmx_opp ?proj_mx_sub //= -eqmx_opp opprB. +by rewrite proj_mx_compl_sub // (submx_trans sWU) ?addsmxSl. +Qed. + +Lemma proj_mx_0 m n U V (W : 'M_(m, n)) : + (U :&: V = 0)%MS -> (W <= V)%MS -> W *m proj_mx U V = 0. +Proof. +move=> dxUV sWV; apply/eqP; rewrite -submx0 -dxUV. +rewrite sub_capmx proj_mx_sub /= -[_ *m _](subrK W) addmx_sub // -eqmx_opp. +by rewrite opprB proj_mx_compl_sub // (submx_trans sWV) ?addsmxSr. +Qed. + +Lemma add_proj_mx m n U V (W : 'M_(m, n)) : + (U :&: V = 0)%MS -> (W <= U + V)%MS -> + W *m proj_mx U V + W *m proj_mx V U = W. +Proof. +move=> dxUV sWUV; apply/eqP; rewrite -subr_eq0 -submx0 -dxUV. +rewrite -addrA sub_capmx {2}addrCA -!(opprB W). +by rewrite !{1}addmx_sub ?proj_mx_sub ?eqmx_opp ?proj_mx_compl_sub // addsmxC. +Qed. + +Lemma proj_mx_proj n (U V : 'M_n) : + let P := proj_mx U V in (U :&: V = 0)%MS -> P *m P = P. +Proof. by move=> P dxUV; rewrite -{-2}[P]mul1mx proj_mx_id ?proj_mx_sub. Qed. + +(* Completing a partially injective matrix to get a unit matrix. *) + +Lemma complete_unitmx m n (U : 'M_(m, n)) (f : 'M_n) : + \rank (U *m f) = \rank U -> {g : 'M_n | g \in unitmx & U *m f = U *m g}. +Proof. +move=> injfU; pose V := <>%MS; pose W := V *m f. +pose g := proj_mx V (V^C)%MS *m f + cokermx V *m row_ebase W. +have defW: V *m g = W. + rewrite mulmxDr mulmxA proj_mx_id ?genmxE ?capmx_compl //. + by rewrite mulmxA mulmx_coker mul0mx addr0. +exists g; last first. + have /submxP[u ->]: (U <= V)%MS by rewrite genmxE. + by rewrite -!mulmxA defW. +rewrite -row_full_unit -sub1mx; apply/submxP. +have: (invmx (col_ebase W) *m W <= V *m g)%MS by rewrite defW submxMl. +case/submxP=> v def_v; exists (invmx (row_ebase W) *m (v *m V + (V^C)%MS)). +rewrite -mulmxA mulmxDl -mulmxA -def_v -{3}[W]mulmx_ebase -mulmxA. +rewrite mulKmx ?col_ebase_unit // [_ *m g]mulmxDr mulmxA. +rewrite (proj_mx_0 (capmx_compl _)) // mul0mx add0r 2!mulmxA. +rewrite mulmxK ?row_ebase_unit // copid_mx_id ?rank_leq_row //. +rewrite (eqmxMr _ (genmxE U)) injfU genmxE addrC -mulmxDl subrK. +by rewrite mul1mx mulVmx ?row_ebase_unit. +Qed. + +(* Mapping between two subspaces with the same dimension. *) + +Lemma eq_rank_unitmx m1 m2 n (U : 'M_(m1, n)) (V : 'M_(m2, n)) : + \rank U = \rank V -> {f : 'M_n | f \in unitmx & V :=: U *m f}%MS. +Proof. +move=> eqrUV; pose f := invmx (row_ebase <>%MS) *m row_ebase <>%MS. +have defUf: (<> *m f :=: <>)%MS. + rewrite -[<>%MS]mulmx_ebase mulmxA mulmxK ?row_ebase_unit // -mulmxA. + rewrite genmxE eqrUV -genmxE -{3}[<>%MS]mulmx_ebase -mulmxA. + move: (pid_mx _ *m _) => W; apply/eqmxP. + by rewrite !eqmxMfull ?andbb // row_full_unit col_ebase_unit. +have{defUf} defV: (V :=: U *m f)%MS. + by apply/eqmxP; rewrite -!(eqmxMr f (genmxE U)) !defUf !genmxE andbb. +have injfU: \rank (U *m f) = \rank U by rewrite -defV eqrUV. +by have [g injg defUg] := complete_unitmx injfU; exists g; rewrite -?defUg. +Qed. + +Section SumExpr. + +(* This is the infrastructure to support the mxdirect predicate. We use a *) +(* bespoke canonical structure to decompose a matrix expression into binary *) +(* and n-ary products, using some of the "quote" technology. This lets us *) +(* characterize direct sums as set sums whose rank is equal to the sum of the *) +(* ranks of the individual terms. The mxsum_expr/proper_mxsum_expr structures *) +(* below supply both the decomposition and the calculation of the rank sum. *) +(* The mxsum_spec dependent predicate family expresses the consistency of *) +(* these two decompositions. *) +(* The main technical difficulty we need to overcome is the fact that *) +(* the "catch-all" case of canonical structures has a priority lower than *) +(* constant expansion. However, it is undesireable that local abbreviations *) +(* be opaque for the direct-sum predicate, e.g., not be able to handle *) +(* let S := (\sum_(i | P i) LargeExpression i)%MS in mxdirect S -> ...). *) +(* As in "quote", we use the interleaving of constant expansion and *) +(* canonical projection matching to achieve our goal: we use a "wrapper" type *) +(* (indeed, the wrapped T type defined in ssrfun.v) with a self-inserting *) +(* non-primitive constructor to gain finer control over the type and *) +(* structure inference process. The innermost, primitive, constructor flags *) +(* trivial sums; it is initially hidden by an eta-expansion, which has been *) +(* made into a (default) canonical structure -- this lets type inference *) +(* automatically insert this outer tag. *) +(* In detail, we define three types *) +(* mxsum_spec S r <-> There exists a finite list of matrices A1, ..., Ak *) +(* such that S is the set sum of the Ai, and r is the sum *) +(* of the ranks of the Ai, i.e., S = (A1 + ... + Ak)%MS *) +(* and r = \rank A1 + ... + \rank Ak. Note that *) +(* mxsum_spec is a recursive dependent predicate family *) +(* whose elimination rewrites simultaneaously S, r and *) +(* the height of S. *) +(* proper_mxsum_expr n == The interface for proper sum expressions; this is *) +(* a double-entry interface, keyed on both the matrix sum *) +(* value and the rank sum. The matrix value is restricted *) +(* to square matrices, as the "+"%MS operator always *) +(* returns a square matrix. This interface has two *) +(* canonical insances, for binary and n-ary sums. *) +(* mxsum_expr m n == The interface for general sum expressions, comprising *) +(* both proper sums and trivial sums consisting of a *) +(* single matrix. The key values are WRAPPED as this lets *) +(* us give priority to the "proper sum" interpretation *) +(* (see below). To allow for trivial sums, the matrix key *) +(* can have any dimension. The mxsum_expr interface has *) +(* two canonical instances, for trivial and proper sums, *) +(* keyed to the Wrap and wrap constructors, respectively. *) +(* The projections for the two interfaces above are *) +(* proper_mxsum_val, mxsum_val : these are respectively coercions to 'M_n *) +(* and wrapped 'M_(m, n); thus, the matrix sum for an *) +(* S : mxsum_expr m n can be written unwrap S. *) +(* proper_mxsum_rank, mxsum_rank : projections to the nat and wrapped nat, *) +(* respectively; the rank sum for S : mxsum_expr m n is *) +(* thus written unwrap (mxsum_rank S). *) +(* The mxdirect A predicate actually gets A in a phantom argument, which is *) +(* used to infer an (implicit) S : mxsum_expr such that unwrap S = A; the *) +(* actual definition is \rank (unwrap S) == unwrap (mxsum_rank S). *) +(* Note that the inference of S is inherently ambiguous: ANY matrix can be *) +(* viewed as a trivial sum, including one whose description is manifestly a *) +(* proper sum. We use the wrapped type and the interaction between delta *) +(* reduction and canonical structure inference to resolve this ambiguity in *) +(* favor of proper sums, as follows: *) +(* - The phantom type sets up a unification problem of the form *) +(* unwrap (mxsum_val ?S) = A *) +(* with unknown evar ?S : mxsum_expr m n. *) +(* - As the constructor wrap is also a default Canonical instance for the *) +(* wrapped type, so A is immediately replaced with unwrap (wrap A) and *) +(* we get the residual unification problem *) +(* mxsum_val ?S = wrap A *) +(* - Now Coq tries to apply the proper sum Canonical instance, which has *) +(* key projection wrap (proper_mxsum_val ?PS) where ?PS is a fresh evar *) +(* (of type proper_mxsum_expr n). This can only succeed if m = n, and if *) +(* a solution can be found to the recursive unification problem *) +(* proper_mxsum_val ?PS = A *) +(* This causes Coq to look for one of the two canonical constants for *) +(* proper_mxsum_val (addsmx or bigop) at the head of A, delta-expanding *) +(* A as needed, and then inferring recursively mxsum_expr structures for *) +(* the last argument(s) of that constant. *) +(* - If the above step fails then the wrap constant is expanded, revealing *) +(* the primitive Wrap constructor; the unification problem now becomes *) +(* mxsum_val ?S = Wrap A *) +(* which fits perfectly the trivial sum canonical structure, whose key *) +(* projection is Wrap ?B where ?B is a fresh evar. Thus the inference *) +(* succeeds, and returns the trivial sum. *) +(* Note that the rank projections also register canonical values, so that the *) +(* same process can be used to infer a sum structure from the rank sum. In *) +(* that case, however, there is no ambiguity and the inference can fail, *) +(* because the rank sum for a trivial sum is not an arbitrary integer -- it *) +(* must be of the form \rank ?B. It is nevertheless necessary to use the *) +(* wrapped nat type for the rank sums, because in the non-trivial case the *) +(* head constant of the nat expression is determined by the proper_mxsum_expr *) +(* canonical structure, so the mxsum_expr structure must use a generic *) +(* constant, namely wrap. *) + +Inductive mxsum_spec n : forall m, 'M[F]_(m, n) -> nat -> Prop := + | TrivialMxsum m A + : @mxsum_spec n m A (\rank A) + | ProperMxsum m1 m2 T1 T2 r1 r2 of + @mxsum_spec n m1 T1 r1 & @mxsum_spec n m2 T2 r2 + : mxsum_spec (T1 + T2)%MS (r1 + r2)%N. +Arguments Scope mxsum_spec [nat_scope nat_scope matrix_set_scope nat_scope]. + +Structure mxsum_expr m n := Mxsum { + mxsum_val :> wrapped 'M_(m, n); + mxsum_rank : wrapped nat; + _ : mxsum_spec (unwrap mxsum_val) (unwrap mxsum_rank) +}. + +Canonical trivial_mxsum m n A := + @Mxsum m n (Wrap A) (Wrap (\rank A)) (TrivialMxsum A). + +Structure proper_mxsum_expr n := ProperMxsumExpr { + proper_mxsum_val :> 'M_n; + proper_mxsum_rank : nat; + _ : mxsum_spec proper_mxsum_val proper_mxsum_rank +}. + +Definition proper_mxsumP n (S : proper_mxsum_expr n) := + let: ProperMxsumExpr _ _ termS := S return mxsum_spec S (proper_mxsum_rank S) + in termS. + +Canonical sum_mxsum n (S : proper_mxsum_expr n) := + @Mxsum n n (wrap (S : 'M_n)) (wrap (proper_mxsum_rank S)) (proper_mxsumP S). + +Section Binary. +Variable (m1 m2 n : nat) (S1 : mxsum_expr m1 n) (S2 : mxsum_expr m2 n). +Fact binary_mxsum_proof : + mxsum_spec (unwrap S1 + unwrap S2) + (unwrap (mxsum_rank S1) + unwrap (mxsum_rank S2)). +Proof. by case: S1 S2 => [A1 r1 A1P] [A2 r2 A2P]; right. Qed. +Canonical binary_mxsum_expr := ProperMxsumExpr binary_mxsum_proof. +End Binary. + +Section Nary. +Context J (r : seq J) (P : pred J) n (S_ : J -> mxsum_expr n n). +Fact nary_mxsum_proof : + mxsum_spec (\sum_(j <- r | P j) unwrap (S_ j)) + (\sum_(j <- r | P j) unwrap (mxsum_rank (S_ j))). +Proof. +elim/big_rec2: _ => [|j]; first by rewrite -(mxrank0 n n); left. +by case: (S_ j); right. +Qed. +Canonical nary_mxsum_expr := ProperMxsumExpr nary_mxsum_proof. +End Nary. + +Definition mxdirect_def m n T of phantom 'M_(m, n) (unwrap (mxsum_val T)) := + \rank (unwrap T) == unwrap (mxsum_rank T). + +End SumExpr. + +Notation mxdirect A := (mxdirect_def (Phantom 'M_(_,_) A%MS)). + +Lemma mxdirectP n (S : proper_mxsum_expr n) : + reflect (\rank S = proper_mxsum_rank S) (mxdirect S). +Proof. exact: eqnP. Qed. +Implicit Arguments mxdirectP [n S]. + +Lemma mxdirect_trivial m n A : mxdirect (unwrap (@trivial_mxsum m n A)). +Proof. exact: eqxx. Qed. + +Lemma mxrank_sum_leqif m n (S : mxsum_expr m n) : + \rank (unwrap S) <= unwrap (mxsum_rank S) ?= iff mxdirect (unwrap S). +Proof. +rewrite /mxdirect_def; case: S => [[A] [r] /= defAr]; split=> //=. +elim: m A r / defAr => // m1 m2 A1 A2 r1 r2 _ leAr1 _ leAr2. +by apply: leq_trans (leq_add leAr1 leAr2); rewrite mxrank_adds_leqif. +Qed. + +Lemma mxdirectE m n (S : mxsum_expr m n) : + mxdirect (unwrap S) = (\rank (unwrap S) == unwrap (mxsum_rank S)). +Proof. by []. Qed. + +Lemma mxdirectEgeq m n (S : mxsum_expr m n) : + mxdirect (unwrap S) = (\rank (unwrap S) >= unwrap (mxsum_rank S)). +Proof. by rewrite (geq_leqif (mxrank_sum_leqif S)). Qed. + +Section BinaryDirect. + +Variables m1 m2 n : nat. + +Lemma mxdirect_addsE (S1 : mxsum_expr m1 n) (S2 : mxsum_expr m2 n) : + mxdirect (unwrap S1 + unwrap S2) + = [&& mxdirect (unwrap S1), mxdirect (unwrap S2) + & unwrap S1 :&: unwrap S2 == 0]%MS. +Proof. +rewrite (@mxdirectE n) /=. +have:= leqif_add (mxrank_sum_leqif S1) (mxrank_sum_leqif S2). +move/(leqif_trans (mxrank_adds_leqif (unwrap S1) (unwrap S2)))=> ->. +by rewrite andbC -andbA submx0. +Qed. + +Lemma mxdirect_addsP (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + reflect (A :&: B = 0)%MS (mxdirect (A + B)). +Proof. by rewrite mxdirect_addsE !mxdirect_trivial; exact: eqP. Qed. + +End BinaryDirect. + +Section NaryDirect. + +Variables (P : pred I) (n : nat). + +Let TIsum A_ i := (A_ i :&: (\sum_(j | P j && (j != i)) A_ j) = 0 :> 'M_n)%MS. + +Let mxdirect_sums_recP (S_ : I -> mxsum_expr n n) : + reflect (forall i, P i -> mxdirect (unwrap (S_ i)) /\ TIsum (unwrap \o S_) i) + (mxdirect (\sum_(i | P i) (unwrap (S_ i)))). +Proof. +rewrite /TIsum; apply: (iffP eqnP) => /= [dxS i Pi | dxS]. + set Si' := (\sum_(j | _) unwrap (S_ j))%MS. + have: mxdirect (unwrap (S_ i) + Si') by apply/eqnP; rewrite /= -!(bigD1 i). + by rewrite mxdirect_addsE => /and3P[-> _ /eqP]. +elim: _.+1 {-2 4}P (subxx P) (ltnSn #|P|) => // m IHm Q; move/subsetP=> sQP. +case: (pickP Q) => [i Qi | Q0]; last by rewrite !big_pred0 ?mxrank0. +rewrite (cardD1x Qi) !((bigD1 i) Q) //=. +move/IHm=> <- {IHm}/=; last by apply/subsetP=> j /andP[/sQP]. +case: (dxS i (sQP i Qi)) => /eqnP=> <- TiQ_0; rewrite mxrank_disjoint_sum //. +apply/eqP; rewrite -submx0 -{2}TiQ_0 capmxS //=. +by apply/sumsmx_subP=> j /= /andP[Qj i'j]; rewrite (sumsmx_sup j) ?[P j]sQP. +Qed. + +Lemma mxdirect_sumsP (A_ : I -> 'M_n) : + reflect (forall i, P i -> A_ i :&: (\sum_(j | P j && (j != i)) A_ j) = 0)%MS + (mxdirect (\sum_(i | P i) A_ i)). +Proof. +apply: (iffP (mxdirect_sums_recP _)) => dxA i /dxA; first by case. +by rewrite mxdirect_trivial. +Qed. + +Lemma mxdirect_sumsE (S_ : I -> mxsum_expr n n) (xunwrap := unwrap) : + reflect (and (forall i, P i -> mxdirect (unwrap (S_ i))) + (mxdirect (\sum_(i | P i) (xunwrap (S_ i))))) + (mxdirect (\sum_(i | P i) (unwrap (S_ i)))). +Proof. +apply: (iffP (mxdirect_sums_recP _)) => [dxS | [dxS_ dxS] i Pi]. + by do [split; last apply/mxdirect_sumsP] => i; case/dxS. +by split; [exact: dxS_ | exact: mxdirect_sumsP Pi]. +Qed. + +End NaryDirect. + +Section SubDaddsmx. + +Variables m m1 m2 n : nat. +Variables (A : 'M[F]_(m, n)) (B1 : 'M[F]_(m1, n)) (B2 : 'M[F]_(m2, n)). + +CoInductive sub_daddsmx_spec : Prop := + SubDaddsmxSpec A1 A2 of (A1 <= B1)%MS & (A2 <= B2)%MS & A = A1 + A2 + & forall C1 C2, (C1 <= B1)%MS -> (C2 <= B2)%MS -> + A = C1 + C2 -> C1 = A1 /\ C2 = A2. + +Lemma sub_daddsmx : (B1 :&: B2 = 0)%MS -> (A <= B1 + B2)%MS -> sub_daddsmx_spec. +Proof. +move=> dxB /sub_addsmxP[u defA]. +exists (u.1 *m B1) (u.2 *m B2); rewrite ?submxMl // => C1 C2 sCB1 sCB2. +move/(canLR (addrK _)) => defC1. +suffices: (C2 - u.2 *m B2 <= B1 :&: B2)%MS. + by rewrite dxB submx0 subr_eq0 -defC1 defA; move/eqP->; rewrite addrK. +rewrite sub_capmx -opprB -{1}(canLR (addKr _) defA) -addrA defC1. +by rewrite !(eqmx_opp, addmx_sub) ?submxMl. +Qed. + +End SubDaddsmx. + +Section SubDsumsmx. + +Variables (P : pred I) (m n : nat) (A : 'M[F]_(m, n)) (B : I -> 'M[F]_n). + +CoInductive sub_dsumsmx_spec : Prop := + SubDsumsmxSpec A_ of forall i, P i -> (A_ i <= B i)%MS + & A = \sum_(i | P i) A_ i + & forall C, (forall i, P i -> C i <= B i)%MS -> + A = \sum_(i | P i) C i -> {in SimplPred P, C =1 A_}. + +Lemma sub_dsumsmx : + mxdirect (\sum_(i | P i) B i) -> (A <= \sum_(i | P i) B i)%MS -> + sub_dsumsmx_spec. +Proof. +move/mxdirect_sumsP=> dxB /sub_sumsmxP[u defA]. +pose A_ i := u i *m B i. +exists A_ => //= [i _ | C sCB defAC i Pi]; first exact: submxMl. +apply/eqP; rewrite -subr_eq0 -submx0 -{dxB}(dxB i Pi) /=. +rewrite sub_capmx addmx_sub ?eqmx_opp ?submxMl ?sCB //=. +rewrite -(subrK A (C i)) -addrA -opprB addmx_sub ?eqmx_opp //. + rewrite addrC defAC (bigD1 i) // addKr /= summx_sub // => j Pi'j. + by rewrite (sumsmx_sup j) ?sCB //; case/andP: Pi'j. +rewrite addrC defA (bigD1 i) // addKr /= summx_sub // => j Pi'j. +by rewrite (sumsmx_sup j) ?submxMl. +Qed. + +End SubDsumsmx. + +Section Eigenspace. + +Variables (n : nat) (g : 'M_n). + +Definition eigenspace a := kermx (g - a%:M). +Definition eigenvalue : pred F := fun a => eigenspace a != 0. + +Lemma eigenspaceP a m (W : 'M_(m, n)) : + reflect (W *m g = a *: W) (W <= eigenspace a)%MS. +Proof. +rewrite (sameP (sub_kermxP _ _) eqP). +by rewrite mulmxBr subr_eq0 mul_mx_scalar; exact: eqP. +Qed. + +Lemma eigenvalueP a : + reflect (exists2 v : 'rV_n, v *m g = a *: v & v != 0) (eigenvalue a). +Proof. by apply: (iffP (rowV0Pn _)) => [] [v]; move/eigenspaceP; exists v. Qed. + +Lemma mxdirect_sum_eigenspace (P : pred I) a_ : + {in P &, injective a_} -> mxdirect (\sum_(i | P i) eigenspace (a_ i)). +Proof. +elim: {P}_.+1 {-2}P (ltnSn #|P|) => // m IHm P lePm inj_a. +apply/mxdirect_sumsP=> i Pi; apply/eqP/rowV0P => v. +rewrite sub_capmx => /andP[/eigenspaceP def_vg]. +set Vi' := (\sum_(i | _) _)%MS => Vi'v. +have dxVi': mxdirect Vi'. + rewrite (cardD1x Pi) in lePm; apply: IHm => //. + by apply: sub_in2 inj_a => j /andP[]. +case/sub_dsumsmx: Vi'v => // u Vi'u def_v _. +rewrite def_v big1 // => j Pi'j; apply/eqP. +have nz_aij: a_ i - a_ j != 0. + by case/andP: Pi'j => Pj ne_ji; rewrite subr_eq0 eq_sym (inj_in_eq inj_a). +case: (sub_dsumsmx dxVi' (sub0mx 1 _)) => C _ _ uniqC. +rewrite -(eqmx_eq0 (eqmx_scale _ nz_aij)). +rewrite (uniqC (fun k => (a_ i - a_ k) *: u k)) => // [|k Pi'k|]. +- by rewrite -(uniqC (fun _ => 0)) ?big1 // => k Pi'k; exact: sub0mx. +- by rewrite scalemx_sub ?Vi'u. +rewrite -{1}(subrr (v *m g)) {1}def_vg def_v scaler_sumr mulmx_suml -sumrB. +by apply: eq_bigr => k /Vi'u/eigenspaceP->; rewrite scalerBl. +Qed. + +End Eigenspace. + +End RowSpaceTheory. + +Hint Resolve submx_refl. +Implicit Arguments submxP [F m1 m2 n A B]. +Implicit Arguments eq_row_sub [F m n v A]. +Implicit Arguments row_subP [F m1 m2 n A B]. +Implicit Arguments rV_subP [F m1 m2 n A B]. +Implicit Arguments row_subPn [F m1 m2 n A B]. +Implicit Arguments sub_rVP [F n u v]. +Implicit Arguments rV_eqP [F m1 m2 n A B]. +Implicit Arguments rowV0Pn [F m n A]. +Implicit Arguments rowV0P [F m n A]. +Implicit Arguments eqmx0P [F m n A]. +Implicit Arguments row_fullP [F m n A]. +Implicit Arguments row_freeP [F m n A]. +Implicit Arguments eqmxP [F m1 m2 n A B]. +Implicit Arguments genmxP [F m1 m2 n A B]. +Implicit Arguments addsmx_idPr [F m1 m2 n A B]. +Implicit Arguments addsmx_idPl [F m1 m2 n A B]. +Implicit Arguments sub_addsmxP [F m1 m2 m3 n A B C]. +Implicit Arguments sumsmx_sup [F I P m n A B_]. +Implicit Arguments sumsmx_subP [F I P m n A_ B]. +Implicit Arguments sub_sumsmxP [F I P m n A B_]. +Implicit Arguments sub_kermxP [F p m n A B]. +Implicit Arguments capmx_idPr [F m1 m2 n A B]. +Implicit Arguments capmx_idPl [F m1 m2 n A B]. +Implicit Arguments bigcapmx_inf [F I P m n A_ B]. +Implicit Arguments sub_bigcapmxP [F I P m n A B_]. +Implicit Arguments mxrank_injP [F m n A f]. +Implicit Arguments mxdirectP [F n S]. +Implicit Arguments mxdirect_addsP [F m1 m2 n A B]. +Implicit Arguments mxdirect_sumsP [F I P n A_]. +Implicit Arguments mxdirect_sumsE [F I P n S_]. +Implicit Arguments eigenspaceP [F n g a m W]. +Implicit Arguments eigenvalueP [F n g a]. + +Arguments Scope mxrank [_ nat_scope nat_scope matrix_set_scope]. +Arguments Scope complmx [_ nat_scope nat_scope matrix_set_scope]. +Arguments Scope row_full [_ nat_scope nat_scope matrix_set_scope]. +Arguments Scope submx + [_ nat_scope nat_scope nat_scope matrix_set_scope matrix_set_scope]. +Arguments Scope ltmx + [_ nat_scope nat_scope nat_scope matrix_set_scope matrix_set_scope]. +Arguments Scope eqmx + [_ nat_scope nat_scope nat_scope matrix_set_scope matrix_set_scope]. +Arguments Scope addsmx + [_ nat_scope nat_scope nat_scope matrix_set_scope matrix_set_scope]. +Arguments Scope capmx + [_ nat_scope nat_scope nat_scope matrix_set_scope matrix_set_scope]. +Arguments Scope diffmx + [_ nat_scope nat_scope nat_scope matrix_set_scope matrix_set_scope]. +Prenex Implicits mxrank genmx complmx submx ltmx addsmx capmx. +Notation "\rank A" := (mxrank A) : nat_scope. +Notation "<< A >>" := (genmx A) : matrix_set_scope. +Notation "A ^C" := (complmx A) : matrix_set_scope. +Notation "A <= B" := (submx A B) : matrix_set_scope. +Notation "A < B" := (ltmx A B) : matrix_set_scope. +Notation "A <= B <= C" := ((submx A B) && (submx B C)) : matrix_set_scope. +Notation "A < B <= C" := (ltmx A B && submx B C) : matrix_set_scope. +Notation "A <= B < C" := (submx A B && ltmx B C) : matrix_set_scope. +Notation "A < B < C" := (ltmx A B && ltmx B C) : matrix_set_scope. +Notation "A == B" := ((submx A B) && (submx B A)) : matrix_set_scope. +Notation "A :=: B" := (eqmx A B) : matrix_set_scope. +Notation "A + B" := (addsmx A B) : matrix_set_scope. +Notation "A :&: B" := (capmx A B) : matrix_set_scope. +Notation "A :\: B" := (diffmx A B) : matrix_set_scope. +Notation mxdirect S := (mxdirect_def (Phantom 'M_(_,_) S%MS)). + +Notation "\sum_ ( i <- r | P ) B" := + (\big[addsmx/0%R]_(i <- r | P%B) B%MS) : matrix_set_scope. +Notation "\sum_ ( i <- r ) B" := + (\big[addsmx/0%R]_(i <- r) B%MS) : matrix_set_scope. +Notation "\sum_ ( m <= i < n | P ) B" := + (\big[addsmx/0%R]_(m <= i < n | P%B) B%MS) : matrix_set_scope. +Notation "\sum_ ( m <= i < n ) B" := + (\big[addsmx/0%R]_(m <= i < n) B%MS) : matrix_set_scope. +Notation "\sum_ ( i | P ) B" := + (\big[addsmx/0%R]_(i | P%B) B%MS) : matrix_set_scope. +Notation "\sum_ i B" := + (\big[addsmx/0%R]_i B%MS) : matrix_set_scope. +Notation "\sum_ ( i : t | P ) B" := + (\big[addsmx/0%R]_(i : t | P%B) B%MS) (only parsing) : matrix_set_scope. +Notation "\sum_ ( i : t ) B" := + (\big[addsmx/0%R]_(i : t) B%MS) (only parsing) : matrix_set_scope. +Notation "\sum_ ( i < n | P ) B" := + (\big[addsmx/0%R]_(i < n | P%B) B%MS) : matrix_set_scope. +Notation "\sum_ ( i < n ) B" := + (\big[addsmx/0%R]_(i < n) B%MS) : matrix_set_scope. +Notation "\sum_ ( i 'in' A | P ) B" := + (\big[addsmx/0%R]_(i in A | P%B) B%MS) : matrix_set_scope. +Notation "\sum_ ( i 'in' A ) B" := + (\big[addsmx/0%R]_(i in A) B%MS) : matrix_set_scope. + +Notation "\bigcap_ ( i <- r | P ) B" := + (\big[capmx/1%:M]_(i <- r | P%B) B%MS) : matrix_set_scope. +Notation "\bigcap_ ( i <- r ) B" := + (\big[capmx/1%:M]_(i <- r) B%MS) : matrix_set_scope. +Notation "\bigcap_ ( m <= i < n | P ) B" := + (\big[capmx/1%:M]_(m <= i < n | P%B) B%MS) : matrix_set_scope. +Notation "\bigcap_ ( m <= i < n ) B" := + (\big[capmx/1%:M]_(m <= i < n) B%MS) : matrix_set_scope. +Notation "\bigcap_ ( i | P ) B" := + (\big[capmx/1%:M]_(i | P%B) B%MS) : matrix_set_scope. +Notation "\bigcap_ i B" := + (\big[capmx/1%:M]_i B%MS) : matrix_set_scope. +Notation "\bigcap_ ( i : t | P ) B" := + (\big[capmx/1%:M]_(i : t | P%B) B%MS) (only parsing) : matrix_set_scope. +Notation "\bigcap_ ( i : t ) B" := + (\big[capmx/1%:M]_(i : t) B%MS) (only parsing) : matrix_set_scope. +Notation "\bigcap_ ( i < n | P ) B" := + (\big[capmx/1%:M]_(i < n | P%B) B%MS) : matrix_set_scope. +Notation "\bigcap_ ( i < n ) B" := + (\big[capmx/1%:M]_(i < n) B%MS) : matrix_set_scope. +Notation "\bigcap_ ( i 'in' A | P ) B" := + (\big[capmx/1%:M]_(i in A | P%B) B%MS) : matrix_set_scope. +Notation "\bigcap_ ( i 'in' A ) B" := + (\big[capmx/1%:M]_(i in A) B%MS) : matrix_set_scope. + +Section CardGL. + +Variable F : finFieldType. + +Lemma card_GL n : n > 0 -> + #|'GL_n[F]| = (#|F| ^ 'C(n, 2) * \prod_(1 <= i < n.+1) (#|F| ^ i - 1))%N. +Proof. +case: n => // n' _; set n := n'.+1; set p := #|F|. +rewrite big_nat_rev big_add1 -triangular_sum expn_sum -big_split /=. +pose fr m := [pred A : 'M[F]_(m, n) | \rank A == m]. +set m := {-7}n; transitivity #|fr m|. + by rewrite cardsT /= card_sub; apply: eq_card => A; rewrite -row_free_unit. +elim: m (leqnn m : m <= n) => [_|m IHm]; last move/ltnW=> le_mn. + rewrite (@eq_card1 _ (0 : 'M_(0, n))) ?big_geq //= => A. + by rewrite flatmx0 !inE !eqxx. +rewrite big_nat_recr // -{}IHm //= !subSS mulnBr muln1 -expnD subnKC //. +rewrite -sum_nat_const /= -sum1_card -add1n. +rewrite (partition_big dsubmx (fr m)) /= => [|A]; last first. + rewrite !inE -{1}(vsubmxK A); move: {A}(_ A) (_ A) => Ad Au Afull. + rewrite eqn_leq rank_leq_row -(leq_add2l (\rank Au)) -mxrank_sum_cap. + rewrite {1 3}[@mxrank]lock addsmxE (eqnP Afull) -lock -addnA. + by rewrite leq_add ?rank_leq_row ?leq_addr. +apply: eq_bigr => A rAm; rewrite (reindex (col_mx^~ A)) /=; last first. + exists usubmx => [v _ | vA]; first by rewrite col_mxKu. + by case/andP=> _ /eqP <-; rewrite vsubmxK. +transitivity #|~: [set v *m A | v in 'rV_m]|; last first. + rewrite cardsCs setCK card_imset ?card_matrix ?card_ord ?mul1n //. + have [B AB1] := row_freeP rAm; apply: can_inj (mulmx^~ B) _ => v. + by rewrite -mulmxA AB1 mulmx1. +rewrite -sum1_card; apply: eq_bigl => v; rewrite !inE col_mxKd eqxx. +rewrite andbT eqn_leq rank_leq_row /= -(leq_add2r (\rank (v :&: A)%MS)). +rewrite -addsmxE mxrank_sum_cap (eqnP rAm) addnAC leq_add2r. +rewrite (ltn_leqif (mxrank_leqif_sup _)) ?capmxSl // sub_capmx submx_refl. +by congr (~~ _); apply/submxP/imsetP=> [] [u]; exists u. +Qed. + +(* An alternate, somewhat more elementary proof, that does not rely on the *) +(* row-space theory, but directly performs the LUP decomposition. *) +Lemma LUP_card_GL n : n > 0 -> + #|'GL_n[F]| = (#|F| ^ 'C(n, 2) * \prod_(1 <= i < n.+1) (#|F| ^ i - 1))%N. +Proof. +case: n => // n' _; set n := n'.+1; set p := #|F|. +rewrite cardsT /= card_sub /GRing.unit /= big_add1 /= -triangular_sum -/n. +elim: {n'}n => [|n IHn]. + rewrite !big_geq // mul1n (@eq_card _ _ predT) ?card_matrix //= => M. + by rewrite {1}[M]flatmx0 -(flatmx0 1%:M) unitmx1. +rewrite !big_nat_recr //= expnD mulnAC mulnA -{}IHn -mulnA mulnC. +set LHS := #|_|; rewrite -[n.+1]muln1 -{2}[n]mul1n {}/LHS. +rewrite -!card_matrix subn1 -(cardC1 0) -mulnA; set nzC := predC1 _. +rewrite -sum1_card (partition_big lsubmx nzC) => [|A]; last first. + rewrite unitmxE unitfE; apply: contra; move/eqP=> v0. + rewrite -[A]hsubmxK v0 -[n.+1]/(1 + n)%N -col_mx0. + rewrite -[rsubmx _]vsubmxK -det_tr tr_row_mx !tr_col_mx !trmx0. + by rewrite det_lblock [0]mx11_scalar det_scalar1 mxE mul0r. +rewrite -sum_nat_const; apply: eq_bigr; rewrite /= -[n.+1]/(1 + n)%N => v nzv. +case: (pickP (fun i => v i 0 != 0)) => [k nza | v0]; last first. + by case/eqP: nzv; apply/colP=> i; move/eqP: (v0 i); rewrite mxE. +have xrkK: involutive (@xrow F _ _ 0 k). + by move=> m A /=; rewrite /xrow -row_permM tperm2 row_perm1. +rewrite (reindex_inj (inv_inj (xrkK (1 + n)%N))) /= -[n.+1]/(1 + n)%N. +rewrite (partition_big ursubmx xpredT) //= -sum_nat_const. +apply: eq_bigr => u _; set a : F := v _ _ in nza. +set v1 : 'cV_(1 + n) := xrow 0 k v. +have def_a: usubmx v1 = a%:M. + by rewrite [_ v1]mx11_scalar mxE lshift0 mxE tpermL. +pose Schur := dsubmx v1 *m (a^-1 *: u). +pose L : 'M_(1 + n) := block_mx a%:M 0 (dsubmx v1) 1%:M. +pose U B : 'M_(1 + n) := block_mx 1 (a^-1 *: u) 0 B. +rewrite (reindex (fun B => L *m U B)); last first. + exists (fun A1 => drsubmx A1 - Schur) => [B _ | A1]. + by rewrite mulmx_block block_mxKdr mul1mx addrC addKr. + rewrite !inE mulmx_block !mulmx0 mul0mx !mulmx1 !addr0 mul1mx addrC subrK. + rewrite mul_scalar_mx scalerA divff // scale1r andbC; case/and3P => /eqP <- _. + rewrite -{1}(hsubmxK A1) xrowE mul_mx_row row_mxKl -xrowE => /eqP def_v. + rewrite -def_a block_mxEh vsubmxK /v1 -def_v xrkK. + apply: trmx_inj; rewrite tr_row_mx tr_col_mx trmx_ursub trmx_drsub trmx_lsub. + by rewrite hsubmxK vsubmxK. +rewrite -sum1_card; apply: eq_bigl => B; rewrite xrowE unitmxE. +rewrite !det_mulmx unitrM -unitmxE unitmx_perm det_lblock det_ublock. +rewrite !det_scalar1 det1 mulr1 mul1r unitrM unitfE nza -unitmxE. +rewrite mulmx_block !mulmx0 mul0mx !addr0 !mulmx1 mul1mx block_mxKur. +rewrite mul_scalar_mx scalerA divff // scale1r eqxx andbT. +by rewrite block_mxEh mul_mx_row row_mxKl -def_a vsubmxK -xrowE xrkK eqxx andbT. +Qed. + +Lemma card_GL_1 : #|'GL_1[F]| = #|F|.-1. +Proof. by rewrite card_GL // mul1n big_nat1 expn1 subn1. Qed. + +Lemma card_GL_2 : #|'GL_2[F]| = (#|F| * #|F|.-1 ^ 2 * #|F|.+1)%N. +Proof. +rewrite card_GL // big_ltn // big_nat1 expn1 -(addn1 #|F|) -subn1 -!mulnA. +by rewrite -subn_sqr. +Qed. + +End CardGL. + +Lemma logn_card_GL_p n p : prime p -> logn p #|'GL_n(p)| = 'C(n, 2). +Proof. +move=> p_pr; have p_gt1 := prime_gt1 p_pr. +have p_i_gt0: p ^ _ > 0 by move=> i; rewrite expn_gt0 ltnW. +rewrite (card_GL _ (ltn0Sn n.-1)) card_ord Fp_cast // big_add1 /=. +pose p'gt0 m := m > 0 /\ logn p m = 0%N. +suffices [Pgt0 p'P]: p'gt0 (\prod_(0 <= i < n.-1.+1) (p ^ i.+1 - 1))%N. + by rewrite lognM // p'P pfactorK //; case n. +apply big_ind => [|m1 m2 [m10 p'm1] [m20]|i _]; rewrite {}/p'gt0 ?logn1 //. + by rewrite muln_gt0 m10 lognM ?p'm1. +rewrite lognE -if_neg subn_gt0 p_pr /= -{1 2}(exp1n i.+1) ltn_exp2r // p_gt1. +by rewrite dvdn_subr ?dvdn_exp // gtnNdvd. +Qed. + +Section MatrixAlgebra. + +Variables F : fieldType. + +Local Notation "A \in R" := (@submx F _ _ _ (mxvec A) R). + +Lemma mem0mx m n (R : 'A_(m, n)) : 0 \in R. +Proof. by rewrite linear0 sub0mx. Qed. + +Lemma memmx0 n A : (A \in (0 : 'A_n)) -> A = 0. +Proof. by rewrite submx0 mxvec_eq0; move/eqP. Qed. + +Lemma memmx1 n (A : 'M_n) : (A \in mxvec 1%:M) = is_scalar_mx A. +Proof. +apply/sub_rVP/is_scalar_mxP=> [[a] | [a ->]]. + by rewrite -linearZ scale_scalar_mx mulr1 => /(can_inj mxvecK); exists a. +by exists a; rewrite -linearZ scale_scalar_mx mulr1. +Qed. + +Lemma memmx_subP m1 m2 n (R1 : 'A_(m1, n)) (R2 : 'A_(m2, n)) : + reflect (forall A, A \in R1 -> A \in R2) (R1 <= R2)%MS. +Proof. +apply: (iffP idP) => [sR12 A R1_A | sR12]; first exact: submx_trans sR12. +by apply/rV_subP=> vA; rewrite -(vec_mxK vA); exact: sR12. +Qed. +Implicit Arguments memmx_subP [m1 m2 n R1 R2]. + +Lemma memmx_eqP m1 m2 n (R1 : 'A_(m1, n)) (R2 : 'A_(m2, n)) : + reflect (forall A, (A \in R1) = (A \in R2)) (R1 == R2)%MS. +Proof. +apply: (iffP eqmxP) => [eqR12 A | eqR12]; first by rewrite eqR12. +by apply/eqmxP; apply/rV_eqP=> vA; rewrite -(vec_mxK vA) eqR12. +Qed. +Implicit Arguments memmx_eqP [m1 m2 n R1 R2]. + +Lemma memmx_addsP m1 m2 n A (R1 : 'A_(m1, n)) (R2 : 'A_(m2, n)) : + reflect (exists D, [/\ D.1 \in R1, D.2 \in R2 & A = D.1 + D.2]) + (A \in R1 + R2)%MS. +Proof. +apply: (iffP sub_addsmxP) => [[u /(canRL mxvecK)->] | [D []]]. + exists (vec_mx (u.1 *m R1), vec_mx (u.2 *m R2)). + by rewrite /= linearD !vec_mxK !submxMl. +case/submxP=> u1 defD1 /submxP[u2 defD2] ->. +by exists (u1, u2); rewrite linearD /= defD1 defD2. +Qed. +Implicit Arguments memmx_addsP [m1 m2 n A R1 R2]. + +Lemma memmx_sumsP (I : finType) (P : pred I) n (A : 'M_n) R_ : + reflect (exists2 A_, A = \sum_(i | P i) A_ i & forall i, A_ i \in R_ i) + (A \in \sum_(i | P i) R_ i)%MS. +Proof. +apply: (iffP sub_sumsmxP) => [[C defA] | [A_ -> R_A] {A}]. + exists (fun i => vec_mx (C i *m R_ i)) => [|i]. + by rewrite -linear_sum -defA /= mxvecK. + by rewrite vec_mxK submxMl. +exists (fun i => mxvec (A_ i) *m pinvmx (R_ i)). +by rewrite linear_sum; apply: eq_bigr => i _; rewrite mulmxKpV. +Qed. +Implicit Arguments memmx_sumsP [I P n A R_]. + +Lemma has_non_scalar_mxP m n (R : 'A_(m, n)) : + (1%:M \in R)%MS -> + reflect (exists2 A, A \in R & ~~ is_scalar_mx A)%MS (1 < \rank R). +Proof. +case: (posnP n) => [-> | n_gt0] in R *; set S := mxvec _ => sSR. + by rewrite [R]thinmx0 mxrank0; right; case; rewrite /is_scalar_mx ?insubF. +have rankS: \rank S = 1%N. + apply/eqP; rewrite eqn_leq rank_leq_row lt0n mxrank_eq0 mxvec_eq0. + by rewrite -mxrank_eq0 mxrank1 -lt0n. +rewrite -{2}rankS (ltn_leqif (mxrank_leqif_sup sSR)). +apply: (iffP idP) => [/row_subPn[i] | [A sAR]]. + rewrite -[row i R]vec_mxK memmx1; set A := vec_mx _ => nsA. + by exists A; rewrite // vec_mxK row_sub. +by rewrite -memmx1; apply: contra; exact: submx_trans. +Qed. + +Definition mulsmx m1 m2 n (R1 : 'A[F]_(m1, n)) (R2 : 'A_(m2, n)) := + (\sum_i <>)%MS. + +Arguments Scope mulsmx + [nat_scope nat_scope nat_scope matrix_set_scope matrix_set_scope]. + +Local Notation "R1 * R2" := (mulsmx R1 R2) : matrix_set_scope. + +Lemma genmx_muls m1 m2 n (R1 : 'A_(m1, n)) (R2 : 'A_(m2, n)) : + <<(R1 * R2)%MS>>%MS = (R1 * R2)%MS. +Proof. by rewrite genmx_sums; apply: eq_bigr => i; rewrite genmx_id. Qed. + +Lemma mem_mulsmx m1 m2 n (R1 : 'A_(m1, n)) (R2 : 'A_(m2, n)) A1 A2 : + (A1 \in R1 -> A2 \in R2 -> A1 *m A2 \in R1 * R2)%MS. +Proof. +move=> R_A1 R_A2; rewrite -[A2]mxvecK; case/submxP: R_A2 => a ->{A2}. +rewrite mulmx_sum_row !linear_sum summx_sub // => i _. +rewrite !linearZ scalemx_sub {a}//= (sumsmx_sup i) // genmxE. +rewrite -[A1]mxvecK; case/submxP: R_A1 => a ->{A1}. +by apply/submxP; exists a; rewrite mulmxA mul_rV_lin. +Qed. + +Lemma mulsmx_subP m1 m2 m n + (R1 : 'A_(m1, n)) (R2 : 'A_(m2, n)) (R : 'A_(m, n)) : + reflect (forall A1 A2, A1 \in R1 -> A2 \in R2 -> A1 *m A2 \in R) + (R1 * R2 <= R)%MS. +Proof. +apply: (iffP memmx_subP) => [sR12R A1 A2 R_A1 R_A2 | sR12R A]. + by rewrite sR12R ?mem_mulsmx. +case/memmx_sumsP=> A_ -> R_A; rewrite linear_sum summx_sub //= => j _. +rewrite (submx_trans (R_A _)) // genmxE; apply/row_subP=> i. +by rewrite row_mul mul_rV_lin sR12R ?vec_mxK ?row_sub. +Qed. +Implicit Arguments mulsmx_subP [m1 m2 m n R1 R2 R]. + +Lemma mulsmxS m1 m2 m3 m4 n (R1 : 'A_(m1, n)) (R2 : 'A_(m2, n)) + (R3 : 'A_(m3, n)) (R4 : 'A_(m4, n)) : + (R1 <= R3 -> R2 <= R4 -> R1 * R2 <= R3 * R4)%MS. +Proof. +move=> sR13 sR24; apply/mulsmx_subP=> A1 A2 R_A1 R_A2. +by apply: mem_mulsmx; [exact: submx_trans sR13 | exact: submx_trans sR24]. +Qed. + +Lemma muls_eqmx m1 m2 m3 m4 n (R1 : 'A_(m1, n)) (R2 : 'A_(m2, n)) + (R3 : 'A_(m3, n)) (R4 : 'A_(m4, n)) : + (R1 :=: R3 -> R2 :=: R4 -> R1 * R2 = R3 * R4)%MS. +Proof. +move=> eqR13 eqR24; rewrite -(genmx_muls R1 R2) -(genmx_muls R3 R4). +by apply/genmxP; rewrite !mulsmxS ?eqR13 ?eqR24. +Qed. + +Lemma mulsmxP m1 m2 n A (R1 : 'A_(m1, n)) (R2 : 'A_(m2, n)) : + reflect (exists2 A1, forall i, A1 i \in R1 + & exists2 A2, forall i, A2 i \in R2 + & A = \sum_(i < n ^ 2) A1 i *m A2 i) + (A \in R1 * R2)%MS. +Proof. +apply: (iffP idP) => [R_A|[A1 R_A1 [A2 R_A2 ->{A}]]]; last first. + by rewrite linear_sum summx_sub // => i _; rewrite mem_mulsmx. +have{R_A}: (A \in R1 * <>)%MS. + by apply: memmx_subP R_A; rewrite mulsmxS ?genmxE. +case/memmx_sumsP=> A_ -> R_A; pose A2_ i := vec_mx (row i <>%MS). +pose A1_ i := mxvec (A_ i) *m pinvmx (R1 *m lin_mx (mulmxr (A2_ i))) *m R1. +exists (vec_mx \o A1_) => [i|]; first by rewrite vec_mxK submxMl. +exists A2_ => [i|]; first by rewrite vec_mxK -(genmxE R2) row_sub. +apply: eq_bigr => i _; rewrite -[_ *m _](mx_rV_lin (mulmxr_linear _ _)). +by rewrite -mulmxA mulmxKpV ?mxvecK // -(genmxE (_ *m _)) R_A. +Qed. +Implicit Arguments mulsmxP [m1 m2 n A R1 R2]. + +Lemma mulsmxA m1 m2 m3 n (R1 : 'A_(m1, n)) (R2 : 'A_(m2, n)) (R3 : 'A_(m3, n)) : + (R1 * (R2 * R3) = R1 * R2 * R3)%MS. +Proof. +rewrite -(genmx_muls (_ * _)%MS) -genmx_muls; apply/genmxP; apply/andP; split. + apply/mulsmx_subP=> A1 A23 R_A1; case/mulsmxP=> A2 R_A2 [A3 R_A3 ->{A23}]. + by rewrite !linear_sum summx_sub //= => i _; rewrite mulmxA !mem_mulsmx. +apply/mulsmx_subP=> _ A3 /mulsmxP[A1 R_A1 [A2 R_A2 ->]] R_A3. +rewrite mulmx_suml linear_sum summx_sub //= => i _. +by rewrite -mulmxA !mem_mulsmx. +Qed. + +Lemma mulsmx_addl m1 m2 m3 n + (R1 : 'A_(m1, n)) (R2 : 'A_(m2, n)) (R3 : 'A_(m3, n)) : + ((R1 + R2) * R3 = R1 * R3 + R2 * R3)%MS. +Proof. +rewrite -(genmx_muls R2 R3) -(genmx_muls R1 R3) -genmx_muls -genmx_adds. +apply/genmxP; rewrite andbC addsmx_sub !mulsmxS ?addsmxSl ?addsmxSr //=. +apply/mulsmx_subP=> _ A3 /memmx_addsP[A [R_A1 R_A2 ->]] R_A3. +by rewrite mulmxDl linearD addmx_sub_adds ?mem_mulsmx. +Qed. + +Lemma mulsmx_addr m1 m2 m3 n + (R1 : 'A_(m1, n)) (R2 : 'A_(m2, n)) (R3 : 'A_(m3, n)) : + (R1 * (R2 + R3) = R1 * R2 + R1 * R3)%MS. +Proof. +rewrite -(genmx_muls R1 R3) -(genmx_muls R1 R2) -genmx_muls -genmx_adds. +apply/genmxP; rewrite andbC addsmx_sub !mulsmxS ?addsmxSl ?addsmxSr //=. +apply/mulsmx_subP=> A1 _ R_A1 /memmx_addsP[A [R_A2 R_A3 ->]]. +by rewrite mulmxDr linearD addmx_sub_adds ?mem_mulsmx. +Qed. + +Lemma mulsmx0 m1 m2 n (R1 : 'A_(m1, n)) : (R1 * (0 : 'A_(m2, n)) = 0)%MS. +Proof. +apply/eqP; rewrite -submx0; apply/mulsmx_subP=> A1 A0 _. +by rewrite [A0 \in 0]eqmx0 => /memmx0->; rewrite mulmx0 mem0mx. +Qed. + +Lemma muls0mx m1 m2 n (R2 : 'A_(m2, n)) : ((0 : 'A_(m1, n)) * R2 = 0)%MS. +Proof. +apply/eqP; rewrite -submx0; apply/mulsmx_subP=> A0 A2. +by rewrite [A0 \in 0]eqmx0 => /memmx0->; rewrite mul0mx mem0mx. +Qed. + +Definition left_mx_ideal m1 m2 n (R1 : 'A_(m1, n)) (R2 : 'A_(m2, n)) := + (R1 * R2 <= R2)%MS. + +Definition right_mx_ideal m1 m2 n (R1 : 'A_(m1, n)) (R2 : 'A_(m2, n)) := + (R2 * R1 <= R2)%MS. + +Definition mx_ideal m1 m2 n (R1 : 'A_(m1, n)) (R2 : 'A_(m2, n)) := + left_mx_ideal R1 R2 && right_mx_ideal R1 R2. + +Definition mxring_id m n (R : 'A_(m, n)) e := + [/\ e != 0, + e \in R, + forall A, A \in R -> e *m A = A + & forall A, A \in R -> A *m e = A]%MS. + +Definition has_mxring_id m n (R : 'A[F]_(m , n)) := + (R != 0) && + (row_mx 0 (row_mx (mxvec R) (mxvec R)) + <= row_mx (cokermx R) (row_mx (lin_mx (mulmx R \o lin_mulmx)) + (lin_mx (mulmx R \o lin_mulmxr))))%MS. + +Definition mxring m n (R : 'A_(m, n)) := + left_mx_ideal R R && has_mxring_id R. + +Lemma mxring_idP m n (R : 'A_(m, n)) : + reflect (exists e, mxring_id R e) (has_mxring_id R). +Proof. +apply: (iffP andP) => [[nzR] | [e [nz_e Re ideR idRe]]]. + case/submxP=> v; rewrite -[v]vec_mxK; move/vec_mx: v => e. + rewrite !mul_mx_row; case/eq_row_mx => /eqP. + rewrite eq_sym -submxE => Re. + case/eq_row_mx; rewrite !{1}mul_rV_lin1 /= mxvecK. + set u := (_ *m _) => /(can_inj mxvecK) idRe /(can_inj mxvecK) ideR. + exists e; split=> // [ | A /submxP[a defA] | A /submxP[a defA]]. + - by apply: contra nzR; rewrite ideR => /eqP->; rewrite !linear0. + - by rewrite -{2}[A]mxvecK defA idRe mulmxA mx_rV_lin -defA /= mxvecK. + by rewrite -{2}[A]mxvecK defA ideR mulmxA mx_rV_lin -defA /= mxvecK. +split. + by apply: contraNneq nz_e => R0; rewrite R0 eqmx0 in Re; rewrite (memmx0 Re). +apply/submxP; exists (mxvec e); rewrite !mul_mx_row !{1}mul_rV_lin1. +rewrite submxE in Re; rewrite {Re}(eqP Re). +congr (row_mx 0 (row_mx (mxvec _) (mxvec _))); apply/row_matrixP=> i. + by rewrite !row_mul !mul_rV_lin1 /= mxvecK ideR vec_mxK ?row_sub. +by rewrite !row_mul !mul_rV_lin1 /= mxvecK idRe vec_mxK ?row_sub. +Qed. +Implicit Arguments mxring_idP [m n R]. + +Section CentMxDef. + +Variables (m n : nat) (R : 'A[F]_(m, n)). + +Definition cent_mx_fun (B : 'M[F]_n) := R *m lin_mx (mulmxr B \- mulmx B). + +Lemma cent_mx_fun_is_linear : linear cent_mx_fun. +Proof. +move=> a A B; apply/row_matrixP=> i; rewrite linearP row_mul mul_rV_lin. +rewrite /= {-3}[row]lock row_mul mul_rV_lin -lock row_mul mul_rV_lin. +by rewrite -linearP -(linearP [linear of mulmx _ \- mulmxr _]). +Qed. +Canonical cent_mx_fun_additive := Additive cent_mx_fun_is_linear. +Canonical cent_mx_fun_linear := Linear cent_mx_fun_is_linear. + +Definition cent_mx := kermx (lin_mx cent_mx_fun). + +Definition center_mx := (R :&: cent_mx)%MS. + +End CentMxDef. + +Local Notation "''C' ( R )" := (cent_mx R) : matrix_set_scope. +Local Notation "''Z' ( R )" := (center_mx R) : matrix_set_scope. + +Lemma cent_rowP m n B (R : 'A_(m, n)) : + reflect (forall i (A := vec_mx (row i R)), A *m B = B *m A) (B \in 'C(R))%MS. +Proof. +apply: (iffP sub_kermxP); rewrite mul_vec_lin => cBE. + move/(canRL mxvecK): cBE => cBE i A /=; move/(congr1 (row i)): cBE. + rewrite row_mul mul_rV_lin -/A; move/(canRL mxvecK). + by move/(canRL (subrK _)); rewrite !linear0 add0r. +apply: (canLR vec_mxK); apply/row_matrixP=> i. +by rewrite row_mul mul_rV_lin /= cBE subrr !linear0. +Qed. +Implicit Arguments cent_rowP [m n B R]. + +Lemma cent_mxP m n B (R : 'A_(m, n)) : + reflect (forall A, A \in R -> A *m B = B *m A) (B \in 'C(R))%MS. +Proof. +apply: (iffP cent_rowP) => cEB => [A sAE | i A]. + rewrite -[A]mxvecK -(mulmxKpV sAE); move: (mxvec A *m _) => u. + rewrite !mulmx_sum_row !linear_sum mulmx_suml; apply: eq_bigr => i _ /=. + by rewrite !linearZ -scalemxAl /= cEB. +by rewrite cEB // vec_mxK row_sub. +Qed. +Implicit Arguments cent_mxP [m n B R]. + +Lemma scalar_mx_cent m n a (R : 'A_(m, n)) : (a%:M \in 'C(R))%MS. +Proof. by apply/cent_mxP=> A _; exact: scalar_mxC. Qed. + +Lemma center_mx_sub m n (R : 'A_(m, n)) : ('Z(R) <= R)%MS. +Proof. exact: capmxSl. Qed. + +Lemma center_mxP m n A (R : 'A_(m, n)) : + reflect (A \in R /\ forall B, B \in R -> B *m A = A *m B) + (A \in 'Z(R))%MS. +Proof. +rewrite sub_capmx; case R_A: (A \in R); last by right; case. +by apply: (iffP cent_mxP) => [cAR | [_ cAR]]. +Qed. +Implicit Arguments center_mxP [m n A R]. + +Lemma mxring_id_uniq m n (R : 'A_(m, n)) e1 e2 : + mxring_id R e1 -> mxring_id R e2 -> e1 = e2. +Proof. +by case=> [_ Re1 idRe1 _] [_ Re2 _ ide2R]; rewrite -(idRe1 _ Re2) ide2R. +Qed. + +Lemma cent_mx_ideal m n (R : 'A_(m, n)) : left_mx_ideal 'C(R)%MS 'C(R)%MS. +Proof. +apply/mulsmx_subP=> A1 A2 C_A1 C_A2; apply/cent_mxP=> B R_B. +by rewrite mulmxA (cent_mxP C_A1) // -!mulmxA (cent_mxP C_A2). +Qed. + +Lemma cent_mx_ring m n (R : 'A_(m, n)) : n > 0 -> mxring 'C(R)%MS. +Proof. +move=> n_gt0; rewrite /mxring cent_mx_ideal; apply/mxring_idP. +exists 1%:M; split=> [||A _|A _]; rewrite ?mulmx1 ?mul1mx ?scalar_mx_cent //. +by rewrite -mxrank_eq0 mxrank1 -lt0n. +Qed. + +Lemma mxdirect_adds_center m1 m2 n (R1 : 'A_(m1, n)) (R2 : 'A_(m2, n)) : + mx_ideal (R1 + R2)%MS R1 -> mx_ideal (R1 + R2)%MS R2 -> + mxdirect (R1 + R2) -> + ('Z((R1 + R2)%MS) :=: 'Z(R1) + 'Z(R2))%MS. +Proof. +case/andP=> idlR1 idrR1 /andP[idlR2 idrR2] /mxdirect_addsP dxR12. +apply/eqmxP/andP; split. + apply/memmx_subP=> z0; rewrite sub_capmx => /andP[]. + case/memmx_addsP=> z [R1z1 R2z2 ->{z0}] Cz. + rewrite linearD addmx_sub_adds //= ?sub_capmx ?R1z1 ?R2z2 /=. + apply/cent_mxP=> A R1_A; have R_A := submx_trans R1_A (addsmxSl R1 R2). + have Rz2 := submx_trans R2z2 (addsmxSr R1 R2). + rewrite -{1}[z.1](addrK z.2) mulmxBr (cent_mxP Cz) // mulmxDl. + rewrite [A *m z.2]memmx0 1?[z.2 *m A]memmx0 ?addrK //. + by rewrite -dxR12 sub_capmx (mulsmx_subP idlR1) // (mulsmx_subP idrR2). + by rewrite -dxR12 sub_capmx (mulsmx_subP idrR1) // (mulsmx_subP idlR2). + apply/cent_mxP=> A R2_A; have R_A := submx_trans R2_A (addsmxSr R1 R2). + have Rz1 := submx_trans R1z1 (addsmxSl R1 R2). + rewrite -{1}[z.2](addKr z.1) mulmxDr (cent_mxP Cz) // mulmxDl. + rewrite mulmxN [A *m z.1]memmx0 1?[z.1 *m A]memmx0 ?addKr //. + by rewrite -dxR12 sub_capmx (mulsmx_subP idrR1) // (mulsmx_subP idlR2). + by rewrite -dxR12 sub_capmx (mulsmx_subP idlR1) // (mulsmx_subP idrR2). +rewrite addsmx_sub; apply/andP; split. + apply/memmx_subP=> z; rewrite sub_capmx => /andP[R1z cR1z]. + have Rz := submx_trans R1z (addsmxSl R1 R2). + rewrite sub_capmx Rz; apply/cent_mxP=> A0. + case/memmx_addsP=> A [R1_A1 R2_A2] ->{A0}. + have R_A2 := submx_trans R2_A2 (addsmxSr R1 R2). + rewrite mulmxDl mulmxDr (cent_mxP cR1z) //; congr (_ + _). + rewrite [A.2 *m z]memmx0 1?[z *m A.2]memmx0 //. + by rewrite -dxR12 sub_capmx (mulsmx_subP idrR1) // (mulsmx_subP idlR2). + by rewrite -dxR12 sub_capmx (mulsmx_subP idlR1) // (mulsmx_subP idrR2). +apply/memmx_subP=> z; rewrite !sub_capmx => /andP[R2z cR2z]. +have Rz := submx_trans R2z (addsmxSr R1 R2); rewrite Rz. +apply/cent_mxP=> _ /memmx_addsP[A [R1_A1 R2_A2 ->]]. +rewrite mulmxDl mulmxDr (cent_mxP cR2z _ R2_A2) //; congr (_ + _). +have R_A1 := submx_trans R1_A1 (addsmxSl R1 R2). +rewrite [A.1 *m z]memmx0 1?[z *m A.1]memmx0 //. + by rewrite -dxR12 sub_capmx (mulsmx_subP idlR1) // (mulsmx_subP idrR2). +by rewrite -dxR12 sub_capmx (mulsmx_subP idrR1) // (mulsmx_subP idlR2). +Qed. + +Lemma mxdirect_sums_center (I : finType) m n (R : 'A_(m, n)) R_ : + (\sum_i R_ i :=: R)%MS -> mxdirect (\sum_i R_ i) -> + (forall i : I, mx_ideal R (R_ i)) -> + ('Z(R) :=: \sum_i 'Z(R_ i))%MS. +Proof. +move=> defR dxR idealR. +have sR_R: (R_ _ <= R)%MS by move=> i; rewrite -defR (sumsmx_sup i). +have anhR i j A B : i != j -> A \in R_ i -> B \in R_ j -> A *m B = 0. + move=> ne_ij RiA RjB; apply: memmx0. + have [[_ idRiR] [idRRj _]] := (andP (idealR i), andP (idealR j)). + rewrite -(mxdirect_sumsP dxR j) // sub_capmx (sumsmx_sup i) //. + by rewrite (mulsmx_subP idRRj) // (memmx_subP (sR_R i)). + by rewrite (mulsmx_subP idRiR) // (memmx_subP (sR_R j)). +apply/eqmxP/andP; split. + apply/memmx_subP=> Z; rewrite sub_capmx => /andP[]. + rewrite -{1}defR => /memmx_sumsP[z ->{Z} Rz cRz]. + apply/memmx_sumsP; exists z => // i; rewrite sub_capmx Rz. + apply/cent_mxP=> A RiA; have:= cent_mxP cRz A (memmx_subP (sR_R i) A RiA). + rewrite (bigD1 i) //= mulmxDl mulmxDr mulmx_suml mulmx_sumr. + by rewrite !big1 ?addr0 // => j; last rewrite eq_sym; move/anhR->. +apply/sumsmx_subP => i _; apply/memmx_subP=> z; rewrite sub_capmx. +case/andP=> Riz cRiz; rewrite sub_capmx (memmx_subP (sR_R i)) //=. +apply/cent_mxP=> A; rewrite -{1}defR; case/memmx_sumsP=> a -> R_a. +rewrite (bigD1 i) // mulmxDl mulmxDr mulmx_suml mulmx_sumr. +rewrite !big1 => [|j|j]; first by rewrite !addr0 (cent_mxP cRiz). + by rewrite eq_sym => /anhR->. +by move/anhR->. +Qed. + +End MatrixAlgebra. + +Arguments Scope mulsmx + [_ nat_scope nat_scope nat_scope matrix_set_scope matrix_set_scope]. +Arguments Scope left_mx_ideal + [_ nat_scope nat_scope nat_scope matrix_set_scope matrix_set_scope]. +Arguments Scope right_mx_ideal + [_ nat_scope nat_scope nat_scope matrix_set_scope matrix_set_scope]. +Arguments Scope mx_ideal + [_ nat_scope nat_scope nat_scope matrix_set_scope matrix_set_scope]. +Arguments Scope mxring_id + [_ nat_scope nat_scope ring_scope matrix_set_scope]. +Arguments Scope has_mxring_id + [_ nat_scope nat_scope ring_scope matrix_set_scope]. +Arguments Scope mxring + [_ nat_scope nat_scope matrix_set_scope]. +Arguments Scope cent_mx + [_ nat_scope nat_scope matrix_set_scope]. +Arguments Scope center_mx + [_ nat_scope nat_scope matrix_set_scope]. + +Prenex Implicits mulsmx. + +Notation "A \in R" := (submx (mxvec A) R) : matrix_set_scope. +Notation "R * S" := (mulsmx R S) : matrix_set_scope. +Notation "''C' ( R )" := (cent_mx R) : matrix_set_scope. +Notation "''C_' R ( S )" := (R :&: 'C(S))%MS : matrix_set_scope. +Notation "''C_' ( R ) ( S )" := ('C_R(S))%MS (only parsing) : matrix_set_scope. +Notation "''Z' ( R )" := (center_mx R) : matrix_set_scope. + +Implicit Arguments memmx_subP [F m1 m2 n R1 R2]. +Implicit Arguments memmx_eqP [F m1 m2 n R1 R2]. +Implicit Arguments memmx_addsP [F m1 m2 n R1 R2]. +Implicit Arguments memmx_sumsP [F I P n A R_]. +Implicit Arguments mulsmx_subP [F m1 m2 m n R1 R2 R]. +Implicit Arguments mulsmxP [F m1 m2 n A R1 R2]. +Implicit Arguments mxring_idP [m n R]. +Implicit Arguments cent_rowP [F m n B R]. +Implicit Arguments cent_mxP [F m n B R]. +Implicit Arguments center_mxP [F m n A R]. + +(* Parametricity for the row-space/F-algebra theory. *) +Section MapMatrixSpaces. + +Variables (aF rF : fieldType) (f : {rmorphism aF -> rF}). +Local Notation "A ^f" := (map_mx f A) : ring_scope. + +Lemma Gaussian_elimination_map m n (A : 'M_(m, n)) : + Gaussian_elimination A^f = ((col_ebase A)^f, (row_ebase A)^f, \rank A). +Proof. +rewrite mxrankE /row_ebase /col_ebase unlock. +elim: m n A => [|m IHm] [|n] A /=; rewrite ?map_mx1 //. +set pAnz := [pred k | A k.1 k.2 != 0]. +rewrite (@eq_pick _ _ pAnz) => [|k]; last by rewrite /= mxE fmorph_eq0. +case: {+}(pick _) => [[i j]|]; last by rewrite !map_mx1. +rewrite mxE -fmorphV -map_xcol -map_xrow -map_dlsubmx -map_drsubmx. +rewrite -map_ursubmx -map_mxZ -map_mxM -map_mx_sub {}IHm /=. +case: {+}(Gaussian_elimination _) => [[L U] r] /=; rewrite map_xrow map_xcol. +by rewrite !(@map_block_mx _ _ f 1 _ 1) !map_mx0 ?map_mx1 ?map_scalar_mx. +Qed. + +Lemma mxrank_map m n (A : 'M_(m, n)) : \rank A^f = \rank A. +Proof. by rewrite mxrankE Gaussian_elimination_map. Qed. + +Lemma row_free_map m n (A : 'M_(m, n)) : row_free A^f = row_free A. +Proof. by rewrite /row_free mxrank_map. Qed. + +Lemma row_full_map m n (A : 'M_(m, n)) : row_full A^f = row_full A. +Proof. by rewrite /row_full mxrank_map. Qed. + +Lemma map_row_ebase m n (A : 'M_(m, n)) : (row_ebase A)^f = row_ebase A^f. +Proof. by rewrite {2}/row_ebase unlock Gaussian_elimination_map. Qed. + +Lemma map_col_ebase m n (A : 'M_(m, n)) : (col_ebase A)^f = col_ebase A^f. +Proof. by rewrite {2}/col_ebase unlock Gaussian_elimination_map. Qed. + +Lemma map_row_base m n (A : 'M_(m, n)) : + (row_base A)^f = castmx (mxrank_map A, erefl n) (row_base A^f). +Proof. +move: (mxrank_map A); rewrite {2}/row_base mxrank_map => eqrr. +by rewrite castmx_id map_mxM map_pid_mx map_row_ebase. +Qed. + +Lemma map_col_base m n (A : 'M_(m, n)) : + (col_base A)^f = castmx (erefl m, mxrank_map A) (col_base A^f). +Proof. +move: (mxrank_map A); rewrite {2}/col_base mxrank_map => eqrr. +by rewrite castmx_id map_mxM map_pid_mx map_col_ebase. +Qed. + +Lemma map_pinvmx m n (A : 'M_(m, n)) : (pinvmx A)^f = pinvmx A^f. +Proof. +rewrite !map_mxM !map_invmx map_row_ebase map_col_ebase. +by rewrite map_pid_mx -mxrank_map. +Qed. + +Lemma map_kermx m n (A : 'M_(m, n)) : (kermx A)^f = kermx A^f. +Proof. +by rewrite !map_mxM map_invmx map_col_ebase -mxrank_map map_copid_mx. +Qed. + +Lemma map_cokermx m n (A : 'M_(m, n)) : (cokermx A)^f = cokermx A^f. +Proof. +by rewrite !map_mxM map_invmx map_row_ebase -mxrank_map map_copid_mx. +Qed. + +Lemma map_submx m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A^f <= B^f)%MS = (A <= B)%MS. +Proof. by rewrite !submxE -map_cokermx -map_mxM map_mx_eq0. Qed. + +Lemma map_ltmx m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A^f < B^f)%MS = (A < B)%MS. +Proof. by rewrite /ltmx !map_submx. Qed. + +Lemma map_eqmx m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A^f :=: B^f)%MS <-> (A :=: B)%MS. +Proof. +split=> [/eqmxP|eqAB]; first by rewrite !map_submx => /eqmxP. +by apply/eqmxP; rewrite !map_submx !eqAB !submx_refl. +Qed. + +Lemma map_genmx m n (A : 'M_(m, n)) : (<>^f :=: <>)%MS. +Proof. by apply/eqmxP; rewrite !(genmxE, map_submx) andbb. Qed. + +Lemma map_addsmx m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (((A + B)%MS)^f :=: A^f + B^f)%MS. +Proof. +by apply/eqmxP; rewrite !addsmxE -map_col_mx !map_submx !addsmxE andbb. +Qed. + +Lemma map_capmx_gen m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (capmx_gen A B)^f = capmx_gen A^f B^f. +Proof. by rewrite map_mxM map_lsubmx map_kermx map_col_mx. Qed. + +Lemma map_capmx m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + ((A :&: B)^f :=: A^f :&: B^f)%MS. +Proof. +by apply/eqmxP; rewrite !capmxE -map_capmx_gen !map_submx -!capmxE andbb. +Qed. + +Lemma map_complmx m n (A : 'M_(m, n)) : (A^C^f = A^f^C)%MS. +Proof. by rewrite map_mxM map_row_ebase -mxrank_map map_copid_mx. Qed. + +Lemma map_diffmx m1 m2 n (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + ((A :\: B)^f :=: A^f :\: B^f)%MS. +Proof. +apply/eqmxP; rewrite !diffmxE -map_capmx_gen -map_complmx. +by rewrite -!map_capmx !map_submx -!diffmxE andbb. +Qed. + +Lemma map_eigenspace n (g : 'M_n) a : (eigenspace g a)^f = eigenspace g^f (f a). +Proof. by rewrite map_kermx map_mx_sub ?map_scalar_mx. Qed. + +Lemma eigenvalue_map n (g : 'M_n) a : eigenvalue g^f (f a) = eigenvalue g a. +Proof. by rewrite /eigenvalue -map_eigenspace map_mx_eq0. Qed. + +Lemma memmx_map m n A (E : 'A_(m, n)) : (A^f \in E^f)%MS = (A \in E)%MS. +Proof. by rewrite -map_mxvec map_submx. Qed. + +Lemma map_mulsmx m1 m2 n (E1 : 'A_(m1, n)) (E2 : 'A_(m2, n)) : + ((E1 * E2)%MS^f :=: E1^f * E2^f)%MS. +Proof. +rewrite /mulsmx; elim/big_rec2: _ => [|i A Af _ eqA]; first by rewrite map_mx0. +apply: (eqmx_trans (map_addsmx _ _)); apply: adds_eqmx {A Af}eqA. +apply/eqmxP; rewrite !map_genmx !genmxE map_mxM. +apply/rV_eqP=> u; congr (u <= _ *m _)%MS. +by apply: map_lin_mx => //= A; rewrite map_mxM // map_vec_mx map_row. +Qed. + +Lemma map_cent_mx m n (E : 'A_(m, n)) : ('C(E)%MS)^f = 'C(E^f)%MS. +Proof. +rewrite map_kermx //; congr (kermx _); apply: map_lin_mx => // A. +rewrite map_mxM //; congr (_ *m _); apply: map_lin_mx => //= B. +by rewrite map_mx_sub ? map_mxM. +Qed. + +Lemma map_center_mx m n (E : 'A_(m, n)) : (('Z(E))^f :=: 'Z(E^f))%MS. +Proof. by rewrite /center_mx -map_cent_mx; exact: map_capmx. Qed. + +End MapMatrixSpaces. + + diff --git a/mathcomp/algebra/mxpoly.v b/mathcomp/algebra/mxpoly.v new file mode 100644 index 0000000..7e889a0 --- /dev/null +++ b/mathcomp/algebra/mxpoly.v @@ -0,0 +1,1109 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div fintype tuple. +Require Import finfun bigop fingroup perm ssralg zmodp matrix mxalgebra. +Require Import poly polydiv. + +(******************************************************************************) +(* This file provides basic support for formal computation with matrices, *) +(* mainly results combining matrices and univariate polynomials, such as the *) +(* Cayley-Hamilton theorem; it also contains an extension of the first order *) +(* representation of algebra introduced in ssralg (GRing.term/formula). *) +(* rVpoly v == the little-endian decoding of the row vector v as a *) +(* polynomial p = \sum_i (v 0 i)%:P * 'X^i. *) +(* poly_rV p == the partial inverse to rVpoly, for polynomials of degree *) +(* less than d to 'rV_d (d is inferred from the context). *) +(* Sylvester_mx p q == the Sylvester matrix of p and q. *) +(* resultant p q == the resultant of p and q, i.e., \det (Sylvester_mx p q). *) +(* horner_mx A == the morphism from {poly R} to 'M_n (n of the form n'.+1) *) +(* mapping a (scalar) polynomial p to the value of its *) +(* scalar matrix interpretation at A (this is an instance of *) +(* the generic horner_morph construct defined in poly). *) +(* powers_mx A d == the d x (n ^ 2) matrix whose rows are the mxvec encodings *) +(* of the first d powers of A (n of the form n'.+1). Thus, *) +(* vec_mx (v *m powers_mx A d) = horner_mx A (rVpoly v). *) +(* char_poly A == the characteristic polynomial of A. *) +(* char_poly_mx A == a matrix whose detereminant is char_poly A. *) +(* mxminpoly A == the minimal polynomial of A, i.e., the smallest monic *) +(* polynomial that annihilates A (A must be nontrivial). *) +(* degree_mxminpoly A == the (positive) degree of mxminpoly A. *) +(* mx_inv_horner A == the inverse of horner_mx A for polynomials of degree *) +(* smaller than degree_mxminpoly A. *) +(* integralOver RtoK u <-> u is in the integral closure of the image of R *) +(* under RtoK : R -> K, i.e. u is a root of the image of a *) +(* monic polynomial in R. *) +(* algebraicOver FtoE u <-> u : E is algebraic over E; it is a root of the *) +(* image of a nonzero polynomial under FtoE; as F must be a *) +(* fieldType, this is equivalent to integralOver FtoE u. *) +(* integralRange RtoK <-> the integral closure of the image of R contains *) +(* all of K (:= forall u, integralOver RtoK u). *) +(* This toolkit for building formal matrix expressions is packaged in the *) +(* MatrixFormula submodule, and comprises the following: *) +(* eval_mx e == GRing.eval lifted to matrices (:= map_mx (GRing.eval e)). *) +(* mx_term A == GRing.Const lifted to matrices. *) +(* mulmx_term A B == the formal product of two matrices of terms. *) +(* mxrank_form m A == a GRing.formula asserting that the interpretation of *) +(* the term matrix A has rank m. *) +(* submx_form A B == a GRing.formula asserting that the row space of the *) +(* interpretation of the term matrix A is included in the *) +(* row space of the interpretation of B. *) +(* seq_of_rV v == the seq corresponding to a row vector. *) +(* row_env e == the flattening of a tensored environment e : seq 'rV_d. *) +(* row_var F d k == the term vector of width d such that for e : seq 'rV[F]_d *) +(* we have eval e 'X_k = eval_mx (row_env e) (row_var d k). *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GRing.Theory. +Import Monoid.Theory. + +Open Local Scope ring_scope. + +Import Pdiv.Idomain. +(* Row vector <-> bounded degree polynomial bijection *) +Section RowPoly. + +Variables (R : ringType) (d : nat). +Implicit Types u v : 'rV[R]_d. +Implicit Types p q : {poly R}. + +Definition rVpoly v := \poly_(k < d) (if insub k is Some i then v 0 i else 0). +Definition poly_rV p := \row_(i < d) p`_i. + +Lemma coef_rVpoly v k : (rVpoly v)`_k = if insub k is Some i then v 0 i else 0. +Proof. by rewrite coef_poly; case: insubP => [i ->|]; rewrite ?if_same. Qed. + +Lemma coef_rVpoly_ord v (i : 'I_d) : (rVpoly v)`_i = v 0 i. +Proof. by rewrite coef_rVpoly valK. Qed. + +Lemma rVpoly_delta i : rVpoly (delta_mx 0 i) = 'X^i. +Proof. +apply/polyP=> j; rewrite coef_rVpoly coefXn. +case: insubP => [k _ <- | j_ge_d]; first by rewrite mxE. +by case: eqP j_ge_d => // ->; rewrite ltn_ord. +Qed. + +Lemma rVpolyK : cancel rVpoly poly_rV. +Proof. by move=> u; apply/rowP=> i; rewrite mxE coef_rVpoly_ord. Qed. + +Lemma poly_rV_K p : size p <= d -> rVpoly (poly_rV p) = p. +Proof. +move=> le_p_d; apply/polyP=> k; rewrite coef_rVpoly. +case: insubP => [i _ <- | ]; first by rewrite mxE. +by rewrite -ltnNge => le_d_l; rewrite nth_default ?(leq_trans le_p_d). +Qed. + +Lemma poly_rV_is_linear : linear poly_rV. +Proof. by move=> a p q; apply/rowP=> i; rewrite !mxE coefD coefZ. Qed. +Canonical poly_rV_additive := Additive poly_rV_is_linear. +Canonical poly_rV_linear := Linear poly_rV_is_linear. + +Lemma rVpoly_is_linear : linear rVpoly. +Proof. +move=> a u v; apply/polyP=> k; rewrite coefD coefZ !coef_rVpoly. +by case: insubP => [i _ _ | _]; rewrite ?mxE // mulr0 addr0. +Qed. +Canonical rVpoly_additive := Additive rVpoly_is_linear. +Canonical rVpoly_linear := Linear rVpoly_is_linear. + +End RowPoly. + +Implicit Arguments poly_rV [R d]. +Prenex Implicits rVpoly poly_rV. + +Section Resultant. + +Variables (R : ringType) (p q : {poly R}). + +Let dS := ((size q).-1 + (size p).-1)%N. +Local Notation band r := (lin1_mx (poly_rV \o r \o* rVpoly)). + +Definition Sylvester_mx : 'M[R]_dS := col_mx (band p) (band q). + +Lemma Sylvester_mxE (i j : 'I_dS) : + let S_ r k := r`_(j - k) *+ (k <= j) in + Sylvester_mx i j = match split i with inl k => S_ p k | inr k => S_ q k end. +Proof. +move=> S_; rewrite mxE; case: {i}(split i) => i; rewrite !mxE /=; + by rewrite rVpoly_delta coefXnM ltnNge if_neg -mulrb. +Qed. + +Definition resultant := \det Sylvester_mx. + +End Resultant. + +Lemma resultant_in_ideal (R : comRingType) (p q : {poly R}) : + size p > 1 -> size q > 1 -> + {uv : {poly R} * {poly R} | size uv.1 < size q /\ size uv.2 < size p + & (resultant p q)%:P = uv.1 * p + uv.2 * q}. +Proof. +move=> p_nc q_nc; pose dp := (size p).-1; pose dq := (size q).-1. +pose S := Sylvester_mx p q; pose dS := (dq + dp)%N. +have dS_gt0: dS > 0 by rewrite /dS /dq -(subnKC q_nc). +pose j0 := Ordinal dS_gt0. +pose Ss0 := col_mx (p *: \col_(i < dq) 'X^i) (q *: \col_(i < dp) 'X^i). +pose Ss := \matrix_(i, j) (if j == j0 then Ss0 i 0 else (S i j)%:P). +pose u ds s := \sum_(i < ds) cofactor Ss (s i) j0 * 'X^i. +exists (u _ (lshift dp), u _ ((rshift dq) _)). + suffices sz_u ds s: ds > 1 -> size (u ds.-1 s) < ds by rewrite !sz_u. + move/ltn_predK=> {2}<-; apply: leq_trans (size_sum _ _ _) _. + apply/bigmax_leqP=> i _. + have ->: cofactor Ss (s i) j0 = (cofactor S (s i) j0)%:P. + rewrite rmorphM rmorph_sign -det_map_mx; congr (_ * \det _). + by apply/matrixP=> i' j'; rewrite !mxE. + apply: leq_trans (size_mul_leq _ _) (leq_trans _ (valP i)). + by rewrite size_polyC size_polyXn addnS /= -add1n leq_add2r leq_b1. +transitivity (\det Ss); last first. + rewrite (expand_det_col Ss j0) big_split_ord !big_distrl /=. + by congr (_ + _); apply: eq_bigr => i _; + rewrite mxE eqxx (col_mxEu, col_mxEd) !mxE mulrC mulrA mulrAC. +pose S_ j1 := map_mx polyC (\matrix_(i, j) S i (if j == j0 then j1 else j)). +pose Ss0_ i dj := \poly_(j < dj) S i (insubd j0 j). +pose Ss_ dj := \matrix_(i, j) (if j == j0 then Ss0_ i dj else (S i j)%:P). +have{Ss u} ->: Ss = Ss_ dS. + apply/matrixP=> i j; rewrite mxE [in X in _ = X]mxE; case: (j == j0) => {j}//. + apply/polyP=> k; rewrite coef_poly Sylvester_mxE mxE. + have [k_ge_dS | k_lt_dS] := leqP dS k. + case: (split i) => {i}i; rewrite !mxE coefMXn; + case: ifP => // /negbT; rewrite -ltnNge ltnS => hi. + apply: (leq_sizeP _ _ (leqnn (size p))); rewrite -(ltn_predK p_nc). + by rewrite ltn_subRL (leq_trans _ k_ge_dS) // ltn_add2r. + - apply: (leq_sizeP _ _ (leqnn (size q))); rewrite -(ltn_predK q_nc). + by rewrite ltn_subRL (leq_trans _ k_ge_dS) // addnC ltn_add2l. + by rewrite insubdK //; case: (split i) => {i}i; + rewrite !mxE coefMXn; case: leqP. +elim: {-2}dS (leqnn dS) (dS_gt0) => // dj IHj dj_lt_dS _. +pose j1 := Ordinal dj_lt_dS; pose rj0T (A : 'M[{poly R}]_dS) := row j0 A^T. +have: rj0T (Ss_ dj.+1) = 'X^dj *: rj0T (S_ j1) + 1 *: rj0T (Ss_ dj). + apply/rowP=> i; apply/polyP=> k; rewrite scale1r !(Sylvester_mxE, mxE) eqxx. + rewrite coefD coefXnM coefC !coef_poly ltnS subn_eq0 ltn_neqAle andbC. + case: (leqP k dj) => [k_le_dj | k_gt_dj] /=; last by rewrite addr0. + rewrite Sylvester_mxE insubdK; last exact: leq_ltn_trans (dj_lt_dS). + by case: eqP => [-> | _]; rewrite (addr0, add0r). +rewrite -det_tr => /determinant_multilinear->; + try by apply/matrixP=> i j; rewrite !mxE eq_sym (negPf (neq_lift _ _)). +have [dj0 | dj_gt0] := posnP dj; rewrite ?dj0 !mul1r. + rewrite !det_tr det_map_mx addrC (expand_det_col _ j0) big1 => [|i _]. + rewrite add0r; congr (\det _)%:P. + apply/matrixP=> i j; rewrite [in X in _ = X]mxE; case: eqP => // ->. + by congr (S i _); apply: val_inj. + by rewrite mxE /= [Ss0_ _ _]poly_def big_ord0 mul0r. +have /determinant_alternate->: j1 != j0 by rewrite -val_eqE -lt0n. + by rewrite mulr0 add0r det_tr IHj // ltnW. +by move=> i; rewrite !mxE if_same. +Qed. + +Lemma resultant_eq0 (R : idomainType) (p q : {poly R}) : + (resultant p q == 0) = (size (gcdp p q) > 1). +Proof. +have dvdpp := dvdpp; set r := gcdp p q. +pose dp := (size p).-1; pose dq := (size q).-1. +have /andP[r_p r_q]: (r %| p) && (r %| q) by rewrite -dvdp_gcd. +apply/det0P/idP=> [[uv nz_uv] | r_nonC]. + have [p0 _ | p_nz] := eqVneq p 0. + have: dq + dp > 0. + rewrite lt0n; apply: contraNneq nz_uv => dqp0. + by rewrite dqp0 in uv *; rewrite [uv]thinmx0. + by rewrite /dp /dq /r p0 size_poly0 addn0 gcd0p -subn1 subn_gt0. + do [rewrite -[uv]hsubmxK -{1}row_mx0 mul_row_col !mul_rV_lin1 /=] in nz_uv *. + set u := rVpoly _; set v := rVpoly _; pose m := gcdp (v * p) (v * q). + have lt_vp: size v < size p by rewrite (polySpred p_nz) ltnS size_poly. + move/(congr1 rVpoly)/eqP; rewrite -linearD linear0 poly_rV_K; last first. + rewrite (leq_trans (size_add _ _)) // geq_max. + rewrite !(leq_trans (size_mul_leq _ _)) // -subn1 leq_subLR. + by rewrite addnC addnA leq_add ?leqSpred ?size_poly. + by rewrite addnCA leq_add ?leqSpred ?size_poly. + rewrite addrC addr_eq0 => /eqP vq_up. + have nz_v: v != 0. + apply: contraNneq nz_uv => v0; apply/eqP. + congr row_mx; apply: (can_inj (@rVpolyK _ _)); rewrite linear0 // -/u. + by apply: contra_eq vq_up; rewrite v0 mul0r -addr_eq0 add0r => /mulf_neq0->. + have r_nz: r != 0 := dvdpN0 r_p p_nz. + have /dvdpP [[c w] /= nz_c wv]: v %| m by rewrite dvdp_gcd !dvdp_mulr. + have m_wd d: m %| v * d -> w %| d. + case/dvdpP=> [[k f]] /= nz_k /(congr1 ( *:%R c)). + rewrite mulrC scalerA scalerAl scalerAr wv mulrA => /(mulIf nz_v)def_fw. + by apply/dvdpP; exists (c * k, f); rewrite //= mulf_neq0. + have w_r: w %| r by rewrite dvdp_gcd !m_wd ?dvdp_gcdl ?dvdp_gcdr. + have w_nz: w != 0 := dvdpN0 w_r r_nz. + have p_m: p %| m by rewrite dvdp_gcd vq_up -mulNr !dvdp_mull. + rewrite (leq_trans _ (dvdp_leq r_nz w_r)) // -(ltn_add2l (size v)). + rewrite addnC -ltn_subRL subn1 -size_mul // mulrC -wv size_scale //. + rewrite (leq_trans lt_vp) // dvdp_leq // -size_poly_eq0. + by rewrite -(size_scale _ nz_c) size_poly_eq0 wv mulf_neq0. +have [[c p'] /= nz_c p'r] := dvdpP _ _ r_p. +have [[k q'] /= nz_k q'r] := dvdpP _ _ r_q. +have def_r := subnKC r_nonC; have r_nz: r != 0 by rewrite -size_poly_eq0 -def_r. +have le_p'_dp: size p' <= dp. + have [-> | nz_p'] := eqVneq p' 0; first by rewrite size_poly0. + by rewrite /dp -(size_scale p nz_c) p'r size_mul // addnC -def_r leq_addl. +have le_q'_dq: size q' <= dq. + have [-> | nz_q'] := eqVneq q' 0; first by rewrite size_poly0. + by rewrite /dq -(size_scale q nz_k) q'r size_mul // addnC -def_r leq_addl. +exists (row_mx (- c *: poly_rV q') (k *: poly_rV p')). + apply: contraNneq r_nz; rewrite -row_mx0; case/eq_row_mx=> q0 p0. + have{p0} p0: p = 0. + apply/eqP; rewrite -size_poly_eq0 -(size_scale p nz_c) p'r. + rewrite -(size_scale _ nz_k) scalerAl -(poly_rV_K le_p'_dp) -linearZ p0. + by rewrite linear0 mul0r size_poly0. + rewrite /r p0 gcd0p -size_poly_eq0 -(size_scale q nz_k) q'r. + rewrite -(size_scale _ nz_c) scalerAl -(poly_rV_K le_q'_dq) -linearZ. + by rewrite -[c]opprK scaleNr q0 !linear0 mul0r size_poly0. +rewrite mul_row_col scaleNr mulNmx !mul_rV_lin1 /= !linearZ /= !poly_rV_K //. +by rewrite !scalerCA p'r q'r mulrCA addNr. +Qed. + +Section HornerMx. + +Variables (R : comRingType) (n' : nat). +Local Notation n := n'.+1. +Variable A : 'M[R]_n. +Implicit Types p q : {poly R}. + +Definition horner_mx := horner_morph (fun a => scalar_mx_comm a A). +Canonical horner_mx_additive := [additive of horner_mx]. +Canonical horner_mx_rmorphism := [rmorphism of horner_mx]. + +Lemma horner_mx_C a : horner_mx a%:P = a%:M. +Proof. exact: horner_morphC. Qed. + +Lemma horner_mx_X : horner_mx 'X = A. Proof. exact: horner_morphX. Qed. + +Lemma horner_mxZ : scalable horner_mx. +Proof. +move=> a p /=; rewrite -mul_polyC rmorphM /=. +by rewrite horner_mx_C [_ * _]mul_scalar_mx. +Qed. + +Canonical horner_mx_linear := AddLinear horner_mxZ. +Canonical horner_mx_lrmorphism := [lrmorphism of horner_mx]. + +Definition powers_mx d := \matrix_(i < d) mxvec (A ^+ i). + +Lemma horner_rVpoly m (u : 'rV_m) : + horner_mx (rVpoly u) = vec_mx (u *m powers_mx m). +Proof. +rewrite mulmx_sum_row linear_sum [rVpoly u]poly_def rmorph_sum. +apply: eq_bigr => i _. +by rewrite valK !linearZ rmorphX /= horner_mx_X rowK /= mxvecK. +Qed. + +End HornerMx. + +Section CharPoly. + +Variables (R : ringType) (n : nat) (A : 'M[R]_n). +Implicit Types p q : {poly R}. + +Definition char_poly_mx := 'X%:M - map_mx (@polyC R) A. +Definition char_poly := \det char_poly_mx. + +Let diagA := [seq A i i | i : 'I_n]. +Let size_diagA : size diagA = n. +Proof. by rewrite size_image card_ord. Qed. + +Let split_diagA : + exists2 q, \prod_(x <- diagA) ('X - x%:P) + q = char_poly & size q <= n.-1. +Proof. +rewrite [char_poly](bigD1 1%g) //=; set q := \sum_(s | _) _; exists q. + congr (_ + _); rewrite odd_perm1 mul1r big_map enumT; apply: eq_bigr => i _. + by rewrite !mxE perm1 eqxx. +apply: leq_trans {q}(size_sum _ _ _) _; apply/bigmax_leqP=> s nt_s. +have{nt_s} [i nfix_i]: exists i, s i != i. + apply/existsP; rewrite -negb_forall; apply: contra nt_s => s_1. + by apply/eqP; apply/permP=> i; apply/eqP; rewrite perm1 (forallP s_1). +apply: leq_trans (_ : #|[pred j | s j == j]|.+1 <= n.-1). + rewrite -sum1_card (@big_mkcond nat) /= size_Msign. + apply: (big_ind2 (fun p m => size p <= m.+1)) => [| p mp q mq IHp IHq | j _]. + - by rewrite size_poly1. + - apply: leq_trans (size_mul_leq _ _) _. + by rewrite -subn1 -addnS leq_subLR addnA leq_add. + rewrite !mxE eq_sym !inE; case: (s j == j); first by rewrite polyseqXsubC. + by rewrite sub0r size_opp size_polyC leq_b1. +rewrite -{8}[n]card_ord -(cardC (pred2 (s i) i)) card2 nfix_i !ltnS. +apply: subset_leq_card; apply/subsetP=> j; move/(_ =P j)=> fix_j. +rewrite !inE -{1}fix_j (inj_eq (@perm_inj _ s)) orbb. +by apply: contraNneq nfix_i => <-; rewrite fix_j. +Qed. + +Lemma size_char_poly : size char_poly = n.+1. +Proof. +have [q <- lt_q_n] := split_diagA; have le_q_n := leq_trans lt_q_n (leq_pred n). +by rewrite size_addl size_prod_XsubC size_diagA. +Qed. + +Lemma char_poly_monic : char_poly \is monic. +Proof. +rewrite monicE -(monicP (monic_prod_XsubC diagA xpredT id)). +rewrite !lead_coefE size_char_poly. +have [q <- lt_q_n] := split_diagA; have le_q_n := leq_trans lt_q_n (leq_pred n). +by rewrite size_prod_XsubC size_diagA coefD (nth_default 0 le_q_n) addr0. +Qed. + +Lemma char_poly_trace : n > 0 -> char_poly`_n.-1 = - \tr A. +Proof. +move=> n_gt0; have [q <- lt_q_n] := split_diagA; set p := \prod_(x <- _) _. +rewrite coefD {q lt_q_n}(nth_default 0 lt_q_n) addr0. +have{n_gt0} ->: p`_n.-1 = ('X * p)`_n by rewrite coefXM eqn0Ngt n_gt0. +have ->: \tr A = \sum_(x <- diagA) x by rewrite big_map enumT. +rewrite -size_diagA {}/p; elim: diagA => [|x d IHd]. + by rewrite !big_nil mulr1 coefX oppr0. +rewrite !big_cons coefXM mulrBl coefB IHd opprD addrC; congr (- _ + _). +rewrite mul_polyC coefZ [size _]/= -(size_prod_XsubC _ id) -lead_coefE. +by rewrite (monicP _) ?monic_prod_XsubC ?mulr1. +Qed. + +Lemma char_poly_det : char_poly`_0 = (- 1) ^+ n * \det A. +Proof. +rewrite big_distrr coef_sum [0%N]lock /=; apply: eq_bigr => s _. +rewrite -{1}rmorphN -rmorphX mul_polyC coefZ /=. +rewrite mulrA -exprD addnC exprD -mulrA -lock; congr (_ * _). +transitivity (\prod_(i < n) - A i (s i)); last by rewrite prodrN card_ord. +elim: (index_enum _) => [|i e IHe]; rewrite !(big_nil, big_cons) ?coef1 //. +by rewrite coefM big_ord1 IHe !mxE coefB coefC coefMn coefX mul0rn sub0r. +Qed. + +End CharPoly. + +Lemma mx_poly_ring_isom (R : ringType) n' (n := n'.+1) : + exists phi : {rmorphism 'M[{poly R}]_n -> {poly 'M[R]_n}}, + [/\ bijective phi, + forall p, phi p%:M = map_poly scalar_mx p, + forall A, phi (map_mx polyC A) = A%:P + & forall A i j k, (phi A)`_k i j = (A i j)`_k]. +Proof. +set M_RX := 'M[{poly R}]_n; set MR_X := ({poly 'M[R]_n}). +pose Msize (A : M_RX) := \max_i \max_j size (A i j). +pose phi (A : M_RX) := \poly_(k < Msize A) \matrix_(i, j) (A i j)`_k. +have coef_phi A i j k: (phi A)`_k i j = (A i j)`_k. + rewrite coef_poly; case: (ltnP k _) => le_m_k; rewrite mxE // nth_default //. + apply: leq_trans (leq_trans (leq_bigmax i) le_m_k); exact: (leq_bigmax j). +have phi_is_rmorphism : rmorphism phi. + do 2?[split=> [A B|]]; apply/polyP=> k; apply/matrixP=> i j; last 1 first. + - rewrite coef_phi mxE coefMn !coefC. + by case: (k == _); rewrite ?mxE ?mul0rn. + - by rewrite !(coef_phi, mxE, coefD, coefN). + rewrite !coef_phi !mxE !coefM summxE coef_sum. + pose F k1 k2 := (A i k1)`_k2 * (B k1 j)`_(k - k2). + transitivity (\sum_k1 \sum_(k2 < k.+1) F k1 k2); rewrite {}/F. + by apply: eq_bigr=> k1 _; rewrite coefM. + rewrite exchange_big /=; apply: eq_bigr => k2 _. + by rewrite mxE; apply: eq_bigr => k1 _; rewrite !coef_phi. +have bij_phi: bijective phi. + exists (fun P : MR_X => \matrix_(i, j) \poly_(k < size P) P`_k i j) => [A|P]. + apply/matrixP=> i j; rewrite mxE; apply/polyP=> k. + rewrite coef_poly -coef_phi. + by case: leqP => // P_le_k; rewrite nth_default ?mxE. + apply/polyP=> k; apply/matrixP=> i j; rewrite coef_phi mxE coef_poly. + by case: leqP => // P_le_k; rewrite nth_default ?mxE. +exists (RMorphism phi_is_rmorphism). +split=> // [p | A]; apply/polyP=> k; apply/matrixP=> i j. + by rewrite coef_phi coef_map !mxE coefMn. +by rewrite coef_phi !mxE !coefC; case k; last rewrite /= mxE. +Qed. + +Theorem Cayley_Hamilton (R : comRingType) n' (A : 'M[R]_n'.+1) : + horner_mx A (char_poly A) = 0. +Proof. +have [phi [_ phiZ phiC _]] := mx_poly_ring_isom R n'. +apply/rootP/factor_theorem; rewrite -phiZ -mul_adj_mx rmorphM. +by move: (phi _) => q; exists q; rewrite rmorphB phiC phiZ map_polyX. +Qed. + +Lemma eigenvalue_root_char (F : fieldType) n (A : 'M[F]_n) a : + eigenvalue A a = root (char_poly A) a. +Proof. +transitivity (\det (a%:M - A) == 0). + apply/eigenvalueP/det0P=> [[v Av_av v_nz] | [v v_nz Av_av]]; exists v => //. + by rewrite mulmxBr Av_av mul_mx_scalar subrr. + by apply/eqP; rewrite -mul_mx_scalar eq_sym -subr_eq0 -mulmxBr Av_av. +congr (_ == 0); rewrite horner_sum; apply: eq_bigr => s _. +rewrite hornerM horner_exp !hornerE; congr (_ * _). +rewrite (big_morph _ (fun p q => hornerM p q a) (hornerC 1 a)). +by apply: eq_bigr => i _; rewrite !mxE !(hornerE, hornerMn). +Qed. + +Section MinPoly. + +Variables (F : fieldType) (n' : nat). +Local Notation n := n'.+1. +Variable A : 'M[F]_n. +Implicit Types p q : {poly F}. + +Fact degree_mxminpoly_proof : exists d, \rank (powers_mx A d.+1) <= d. +Proof. by exists (n ^ 2)%N; rewrite rank_leq_col. Qed. +Definition degree_mxminpoly := ex_minn degree_mxminpoly_proof. +Local Notation d := degree_mxminpoly. +Local Notation Ad := (powers_mx A d). + +Lemma mxminpoly_nonconstant : d > 0. +Proof. +rewrite /d; case: ex_minnP; case=> //; rewrite leqn0 mxrank_eq0; move/eqP. +move/row_matrixP; move/(_ 0); move/eqP; rewrite rowK row0 mxvec_eq0. +by rewrite -mxrank_eq0 mxrank1. +Qed. + +Lemma minpoly_mx1 : (1%:M \in Ad)%MS. +Proof. +by apply: (eq_row_sub (Ordinal mxminpoly_nonconstant)); rewrite rowK. +Qed. + +Lemma minpoly_mx_free : row_free Ad. +Proof. +have:= mxminpoly_nonconstant; rewrite /d; case: ex_minnP; case=> // d' _. +move/(_ d'); move/implyP; rewrite ltnn implybF -ltnS ltn_neqAle. +by rewrite rank_leq_row andbT negbK. +Qed. + +Lemma horner_mx_mem p : (horner_mx A p \in Ad)%MS. +Proof. +elim/poly_ind: p => [|p a IHp]; first by rewrite rmorph0 // linear0 sub0mx. +rewrite rmorphD rmorphM /= horner_mx_C horner_mx_X. +rewrite addrC -scalemx1 linearP /= -(mul_vec_lin (mulmxr_linear _ A)). +case/submxP: IHp => u ->{p}. +have: (powers_mx A (1 + d) <= Ad)%MS. + rewrite -(geq_leqif (mxrank_leqif_sup _)). + by rewrite (eqnP minpoly_mx_free) /d; case: ex_minnP. + rewrite addnC; apply/row_subP=> i. + by apply: eq_row_sub (lshift 1 i) _; rewrite !rowK. +apply: submx_trans; rewrite addmx_sub ?scalemx_sub //. + by apply: (eq_row_sub 0); rewrite rowK. +rewrite -mulmxA mulmx_sub {u}//; apply/row_subP=> i. +rewrite row_mul rowK mul_vec_lin /= mulmxE -exprSr. +by apply: (eq_row_sub (rshift 1 i)); rewrite rowK. +Qed. + +Definition mx_inv_horner B := rVpoly (mxvec B *m pinvmx Ad). + +Lemma mx_inv_horner0 : mx_inv_horner 0 = 0. +Proof. by rewrite /mx_inv_horner !(linear0, mul0mx). Qed. + +Lemma mx_inv_hornerK B : (B \in Ad)%MS -> horner_mx A (mx_inv_horner B) = B. +Proof. by move=> sBAd; rewrite horner_rVpoly mulmxKpV ?mxvecK. Qed. + +Lemma minpoly_mxM B C : (B \in Ad -> C \in Ad -> B * C \in Ad)%MS. +Proof. +move=> AdB AdC; rewrite -(mx_inv_hornerK AdB) -(mx_inv_hornerK AdC). +by rewrite -rmorphM ?horner_mx_mem. +Qed. + +Lemma minpoly_mx_ring : mxring Ad. +Proof. +apply/andP; split; first by apply/mulsmx_subP; exact: minpoly_mxM. +apply/mxring_idP; exists 1%:M; split=> *; rewrite ?mulmx1 ?mul1mx //. + by rewrite -mxrank_eq0 mxrank1. +exact: minpoly_mx1. +Qed. + +Definition mxminpoly := 'X^d - mx_inv_horner (A ^+ d). +Local Notation p_A := mxminpoly. + +Lemma size_mxminpoly : size p_A = d.+1. +Proof. by rewrite size_addl ?size_polyXn // size_opp ltnS size_poly. Qed. + +Lemma mxminpoly_monic : p_A \is monic. +Proof. +rewrite monicE /lead_coef size_mxminpoly coefB coefXn eqxx /=. +by rewrite nth_default ?size_poly // subr0. +Qed. + +Lemma size_mod_mxminpoly p : size (p %% p_A) <= d. +Proof. +by rewrite -ltnS -size_mxminpoly ltn_modp // -size_poly_eq0 size_mxminpoly. +Qed. + +Lemma mx_root_minpoly : horner_mx A p_A = 0. +Proof. +rewrite rmorphB -{3}(horner_mx_X A) -rmorphX /=. +by rewrite mx_inv_hornerK ?subrr ?horner_mx_mem. +Qed. + +Lemma horner_rVpolyK (u : 'rV_d) : + mx_inv_horner (horner_mx A (rVpoly u)) = rVpoly u. +Proof. +congr rVpoly; rewrite horner_rVpoly vec_mxK. +by apply: (row_free_inj minpoly_mx_free); rewrite mulmxKpV ?submxMl. +Qed. + +Lemma horner_mxK p : mx_inv_horner (horner_mx A p) = p %% p_A. +Proof. +rewrite {1}(Pdiv.IdomainMonic.divp_eq mxminpoly_monic p) rmorphD rmorphM /=. +rewrite mx_root_minpoly mulr0 add0r. +by rewrite -(poly_rV_K (size_mod_mxminpoly _)) horner_rVpolyK. +Qed. + +Lemma mxminpoly_min p : horner_mx A p = 0 -> p_A %| p. +Proof. by move=> pA0; rewrite /dvdp -horner_mxK pA0 mx_inv_horner0. Qed. + +Lemma horner_rVpoly_inj : @injective 'M_n 'rV_d (horner_mx A \o rVpoly). +Proof. +apply: can_inj (poly_rV \o mx_inv_horner) _ => u. +by rewrite /= horner_rVpolyK rVpolyK. +Qed. + +Lemma mxminpoly_linear_is_scalar : (d <= 1) = is_scalar_mx A. +Proof. +have scalP := has_non_scalar_mxP minpoly_mx1. +rewrite leqNgt -(eqnP minpoly_mx_free); apply/scalP/idP=> [|[[B]]]. + case scalA: (is_scalar_mx A); [by right | left]. + by exists A; rewrite ?scalA // -{1}(horner_mx_X A) horner_mx_mem. +move/mx_inv_hornerK=> <- nsB; case/is_scalar_mxP=> a defA; case/negP: nsB. +move: {B}(_ B); apply: poly_ind => [|p c]. + by rewrite rmorph0 ?mx0_is_scalar. +rewrite rmorphD ?rmorphM /= horner_mx_X defA; case/is_scalar_mxP=> b ->. +by rewrite -rmorphM horner_mx_C -rmorphD /= scalar_mx_is_scalar. +Qed. + +Lemma mxminpoly_dvd_char : p_A %| char_poly A. +Proof. by apply: mxminpoly_min; exact: Cayley_Hamilton. Qed. + +Lemma eigenvalue_root_min a : eigenvalue A a = root p_A a. +Proof. +apply/idP/idP=> Aa; last first. + rewrite eigenvalue_root_char !root_factor_theorem in Aa *. + exact: dvdp_trans Aa mxminpoly_dvd_char. +have{Aa} [v Av_av v_nz] := eigenvalueP Aa. +apply: contraR v_nz => pa_nz; rewrite -{pa_nz}(eqmx_eq0 (eqmx_scale _ pa_nz)). +apply/eqP; rewrite -(mulmx0 _ v) -mx_root_minpoly. +elim/poly_ind: p_A => [|p c IHp]. + by rewrite rmorph0 horner0 scale0r mulmx0. +rewrite !hornerE rmorphD rmorphM /= horner_mx_X horner_mx_C scalerDl. +by rewrite -scalerA mulmxDr mul_mx_scalar mulmxA -IHp -scalemxAl Av_av. +Qed. + +End MinPoly. + +(* Parametricity. *) +Section MapRingMatrix. + +Variables (aR rR : ringType) (f : {rmorphism aR -> rR}). +Local Notation "A ^f" := (map_mx (GRing.RMorphism.apply f) A) : ring_scope. +Local Notation fp := (map_poly (GRing.RMorphism.apply f)). +Variables (d n : nat) (A : 'M[aR]_n). + +Lemma map_rVpoly (u : 'rV_d) : fp (rVpoly u) = rVpoly u^f. +Proof. +apply/polyP=> k; rewrite coef_map !coef_rVpoly. +by case: (insub k) => [i|]; rewrite /= ?rmorph0 // mxE. +Qed. + +Lemma map_poly_rV p : (poly_rV p)^f = poly_rV (fp p) :> 'rV_d. +Proof. by apply/rowP=> j; rewrite !mxE coef_map. Qed. + +Lemma map_char_poly_mx : map_mx fp (char_poly_mx A) = char_poly_mx A^f. +Proof. +rewrite raddfB /= map_scalar_mx /= map_polyX; congr (_ - _). +by apply/matrixP=> i j; rewrite !mxE map_polyC. +Qed. + +Lemma map_char_poly : fp (char_poly A) = char_poly A^f. +Proof. by rewrite -det_map_mx map_char_poly_mx. Qed. + +End MapRingMatrix. + +Section MapResultant. + +Lemma map_resultant (aR rR : ringType) (f : {rmorphism {poly aR} -> rR}) p q : + f (lead_coef p) != 0 -> f (lead_coef q) != 0 -> + f (resultant p q)= resultant (map_poly f p) (map_poly f q). +Proof. +move=> nz_fp nz_fq; rewrite /resultant /Sylvester_mx !size_map_poly_id0 //. +rewrite -det_map_mx /= map_col_mx; congr (\det (col_mx _ _)); + by apply: map_lin1_mx => v; rewrite map_poly_rV rmorphM /= map_rVpoly. +Qed. + +End MapResultant. + +Section MapComRing. + +Variables (aR rR : comRingType) (f : {rmorphism aR -> rR}). +Local Notation "A ^f" := (map_mx f A) : ring_scope. +Local Notation fp := (map_poly f). +Variables (n' : nat) (A : 'M[aR]_n'.+1). + +Lemma map_powers_mx e : (powers_mx A e)^f = powers_mx A^f e. +Proof. by apply/row_matrixP=> i; rewrite -map_row !rowK map_mxvec rmorphX. Qed. + +Lemma map_horner_mx p : (horner_mx A p)^f = horner_mx A^f (fp p). +Proof. +rewrite -[p](poly_rV_K (leqnn _)) map_rVpoly. +by rewrite !horner_rVpoly map_vec_mx map_mxM map_powers_mx. +Qed. + +End MapComRing. + +Section MapField. + +Variables (aF rF : fieldType) (f : {rmorphism aF -> rF}). +Local Notation "A ^f" := (map_mx f A) : ring_scope. +Local Notation fp := (map_poly f). +Variables (n' : nat) (A : 'M[aF]_n'.+1). + +Lemma degree_mxminpoly_map : degree_mxminpoly A^f = degree_mxminpoly A. +Proof. by apply: eq_ex_minn => e; rewrite -map_powers_mx mxrank_map. Qed. + +Lemma mxminpoly_map : mxminpoly A^f = fp (mxminpoly A). +Proof. +rewrite rmorphB; congr (_ - _). + by rewrite /= map_polyXn degree_mxminpoly_map. +rewrite degree_mxminpoly_map -rmorphX /=. +apply/polyP=> i; rewrite coef_map //= !coef_rVpoly degree_mxminpoly_map. +case/insub: i => [i|]; last by rewrite rmorph0. +by rewrite -map_powers_mx -map_pinvmx // -map_mxvec -map_mxM // mxE. +Qed. + +Lemma map_mx_inv_horner u : fp (mx_inv_horner A u) = mx_inv_horner A^f u^f. +Proof. +rewrite map_rVpoly map_mxM map_mxvec map_pinvmx map_powers_mx. +by rewrite /mx_inv_horner degree_mxminpoly_map. +Qed. + +End MapField. + +Section IntegralOverRing. + +Definition integralOver (R K : ringType) (RtoK : R -> K) (z : K) := + exists2 p, p \is monic & root (map_poly RtoK p) z. + +Definition integralRange R K RtoK := forall z, @integralOver R K RtoK z. + +Variables (B R K : ringType) (BtoR : B -> R) (RtoK : {rmorphism R -> K}). + +Lemma integral_rmorph x : + integralOver BtoR x -> integralOver (RtoK \o BtoR) (RtoK x). +Proof. by case=> p; exists p; rewrite // map_poly_comp rmorph_root. Qed. + +Lemma integral_id x : integralOver RtoK (RtoK x). +Proof. by exists ('X - x%:P); rewrite ?monicXsubC ?rmorph_root ?root_XsubC. Qed. + +Lemma integral_nat n : integralOver RtoK n%:R. +Proof. by rewrite -(rmorph_nat RtoK); apply: integral_id. Qed. + +Lemma integral0 : integralOver RtoK 0. Proof. exact: (integral_nat 0). Qed. + +Lemma integral1 : integralOver RtoK 1. Proof. exact: (integral_nat 1). Qed. + +Lemma integral_poly (p : {poly K}) : + (forall i, integralOver RtoK p`_i) <-> {in p : seq K, integralRange RtoK}. +Proof. +split=> intRp => [_ /(nthP 0)[i _ <-] // | i]; rewrite -[p]coefK coef_poly. +by case: ifP => [ltip | _]; [apply/intRp/mem_nth | apply: integral0]. +Qed. + +End IntegralOverRing. + +Section IntegralOverComRing. + +Variables (R K : comRingType) (RtoK : {rmorphism R -> K}). + +Lemma integral_horner_root w (p q : {poly K}) : + p \is monic -> root p w -> + {in p : seq K, integralRange RtoK} -> {in q : seq K, integralRange RtoK} -> + integralOver RtoK q.[w]. +Proof. +move=> mon_p pw0 intRp intRq. +pose memR y := exists x, y = RtoK x. +have memRid x: memR (RtoK x) by exists x. +have memR_nat n: memR n%:R by rewrite -(rmorph_nat RtoK). +have [memR0 memR1]: memR 0 * memR 1 := (memR_nat 0%N, memR_nat 1%N). +have memRN1: memR (- 1) by exists (- 1); rewrite rmorphN1. +pose rVin (E : K -> Prop) n (a : 'rV[K]_n) := forall i, E (a 0 i). +pose pXin (E : K -> Prop) (r : {poly K}) := forall i, E r`_i. +pose memM E n (X : 'rV_n) y := exists a, rVin E n a /\ y = (a *m X^T) 0 0. +pose finM E S := exists n, exists X, forall y, memM E n X y <-> S y. +have tensorM E n1 n2 X Y: finM E (memM (memM E n2 Y) n1 X). + exists (n1 * n2)%N, (mxvec (X^T *m Y)) => y. + split=> [[a [Ea Dy]] | [a1 [/fin_all_exists[a /all_and2[Ea Da1]] ->]]]. + exists (Y *m (vec_mx a)^T); split=> [i|]. + exists (row i (vec_mx a)); split=> [j|]; first by rewrite !mxE; apply: Ea. + by rewrite -row_mul -{1}[Y]trmxK -trmx_mul !mxE. + by rewrite -[Y]trmxK -!trmx_mul mulmxA -mxvec_dotmul trmx_mul trmxK vec_mxK. + exists (mxvec (\matrix_i a i)); split. + by case/mxvec_indexP=> i j; rewrite mxvecE mxE; apply: Ea. + rewrite -[mxvec _]trmxK -trmx_mul mxvec_dotmul -mulmxA trmx_mul !mxE. + apply: eq_bigr => i _; rewrite Da1 !mxE; congr (_ * _). + by apply: eq_bigr => j _; rewrite !mxE. +suffices [m [X [[u [_ Du]] idealM]]]: exists m, + exists X, let M := memM memR m X in M 1 /\ forall y, M y -> M (q.[w] * y). +- do [set M := memM _ m X; move: q.[w] => z] in idealM *. + have MX i: M (X 0 i). + by exists (delta_mx 0 i); split=> [j|]; rewrite -?rowE !mxE. + have /fin_all_exists[a /all_and2[Fa Da1]] i := idealM _ (MX i). + have /fin_all_exists[r Dr] i := fin_all_exists (Fa i). + pose A := \matrix_(i, j) r j i; pose B := z%:M - map_mx RtoK A. + have XB0: X *m B = 0. + apply/eqP; rewrite mulmxBr mul_mx_scalar subr_eq0; apply/eqP/rowP=> i. + by rewrite !mxE Da1 mxE; apply: eq_bigr=> j _; rewrite !mxE mulrC Dr. + exists (char_poly A); first exact: char_poly_monic. + have: (\det B *: (u *m X^T)) 0 0 == 0. + rewrite scalemxAr -linearZ -mul_mx_scalar -mul_mx_adj mulmxA XB0 /=. + by rewrite mul0mx trmx0 mulmx0 mxE. + rewrite mxE -Du mulr1 rootE -horner_evalE -!det_map_mx; congr (\det _ == 0). + rewrite !raddfB /= !map_scalar_mx /= map_polyX horner_evalE hornerX. + by apply/matrixP=> i j; rewrite !mxE map_polyC /horner_eval hornerC. +pose gen1 x E y := exists2 r, pXin E r & y = r.[x]; pose gen := foldr gen1 memR. +have gen1S (E : K -> Prop) x y: E 0 -> E y -> gen1 x E y. + by exists y%:P => [i|]; rewrite ?hornerC ?coefC //; case: ifP. +have genR S y: memR y -> gen S y. + by elim: S => //= x S IH in y * => /IH; apply: gen1S; apply: IH. +have gen0 := genR _ 0 memR0; have gen_1 := genR _ 1 memR1. +have{gen1S} genS S y: y \in S -> gen S y. + elim: S => //= x S IH /predU1P[-> | /IH//]; last exact: gen1S. + by exists 'X => [i|]; rewrite ?hornerX // coefX; apply: genR. +pose propD (R : K -> Prop) := forall x y, R x -> R y -> R (x + y). +have memRD: propD memR. + by move=> _ _ [a ->] [b ->]; exists (a + b); rewrite rmorphD. +have genD S: propD (gen S). + elim: S => //= x S IH _ _ [r1 Sr1 ->] [r2 Sr2 ->]; rewrite -hornerD. + by exists (r1 + r2) => // i; rewrite coefD; apply: IH. +have gen_sum S := big_ind _ (gen0 S) (genD S). +pose propM (R : K -> Prop) := forall x y, R x -> R y -> R (x * y). +have memRM: propM memR. + by move=> _ _ [a ->] [b ->]; exists (a * b); rewrite rmorphM. +have genM S: propM (gen S). + elim: S => //= x S IH _ _ [r1 Sr1 ->] [r2 Sr2 ->]; rewrite -hornerM. + by exists (r1 * r2) => // i; rewrite coefM; apply: gen_sum => j _; apply: IH. +have gen_horner S r y: pXin (gen S) r -> gen S y -> gen S r.[y]. + move=> Sq Sy; rewrite horner_coef; apply: gen_sum => [[i _] /= _]. + by elim: {2}i => [|n IHn]; rewrite ?mulr1 // exprSr mulrA; apply: genM. +pose S := w :: q ++ p; suffices [m [X defX]]: finM memR (gen S). + exists m, X => M; split=> [|y /defX Xy]; first exact/defX. + apply/defX/genM => //; apply: gen_horner => // [i|]; last exact/genS/mem_head. + rewrite -[q]coefK coef_poly; case: ifP => // lt_i_q. + by apply: genS; rewrite inE mem_cat mem_nth ?orbT. +pose intR R y := exists r, [/\ r \is monic, root r y & pXin R r]. +pose fix genI s := if s is y :: s1 then intR (gen s1) y /\ genI s1 else True. +have{mon_p pw0 intRp intRq}: genI S. + split; set S1 := _ ++ _; first exists p. + split=> // i; rewrite -[p]coefK coef_poly; case: ifP => // lt_i_p. + by apply: genS; rewrite mem_cat orbC mem_nth. + have: all (mem S1) S1 by exact/allP. + elim: {-1}S1 => //= y S2 IH /andP[S1y S12]; split; last exact: IH. + have{q S S1 IH S1y S12 intRp intRq} [q mon_q qx0]: integralOver RtoK y. + by move: S1y; rewrite mem_cat => /orP[]; [apply: intRq | apply: intRp]. + exists (map_poly RtoK q); split=> // [|i]; first exact: monic_map. + by rewrite coef_map /=; apply: genR. +elim: {w p q}S => /= [_|x S IH [[p [mon_p px0 Sp]] /IH{IH}[m2 [X2 defS]]]]. + exists 1%N, 1 => y; split=> [[a [Fa ->]] | Fy]. + by rewrite tr_scalar_mx mulmx1; apply: Fa. + by exists y%:M; split=> [i|]; rewrite 1?ord1 ?tr_scalar_mx ?mulmx1 mxE. +pose m1 := (size p).-1; pose X1 := \row_(i < m1) x ^+ i. +have [m [X defM]] := tensorM memR m1 m2 X1 X2; set M := memM _ _ _ in defM. +exists m, X => y; rewrite -/M; split=> [/defM[a [M2a]] | [q Sq]] -> {y}. + exists (rVpoly a) => [i|]. + by rewrite coef_rVpoly; case/insub: i => // i; apply/defS/M2a. + rewrite mxE (horner_coef_wide _ (size_poly _ _)) -/(rVpoly a). + by apply: eq_bigr => i _; rewrite coef_rVpoly_ord !mxE. +have M_0: M 0 by exists 0; split=> [i|]; rewrite ?mul0mx mxE. +have M_D: propD M. + move=> _ _ [a [Fa ->]] [b [Fb ->]]; exists (a + b). + by rewrite mulmxDl !mxE; split=> // i; rewrite mxE; apply: memRD. +have{M_0 M_D} Msum := big_ind _ M_0 M_D. +rewrite horner_coef; apply: (Msum) => i _; case: i q`_i {Sq}(Sq i) => /=. +elim: {q}(size q) => // n IHn i i_le_n y Sy. +have [i_lt_m1 | m1_le_i] := ltnP i m1. + apply/defM; exists (y *: delta_mx 0 (Ordinal i_lt_m1)); split=> [j|]. + by apply/defS; rewrite !mxE /= mulr_natr; case: eqP. + by rewrite -scalemxAl -rowE !mxE. +rewrite -(subnK m1_le_i) exprD -[x ^+ m1]subr0 -(rootP px0) horner_coef. +rewrite polySpred ?monic_neq0 // -/m1 big_ord_recr /= -lead_coefE. +rewrite opprD addrC (monicP mon_p) mul1r subrK !mulrN -mulNr !mulr_sumr. +apply: Msum => j _; rewrite mulrA mulrACA -exprD; apply: IHn. + by rewrite -addnS addnC addnBA // leq_subLR leq_add. +by rewrite -mulN1r; do 2!apply: (genM) => //; apply: genR. +Qed. + +Lemma integral_root_monic u p : + p \is monic -> root p u -> {in p : seq K, integralRange RtoK} -> + integralOver RtoK u. +Proof. +move=> mon_p pu0 intRp; rewrite -[u]hornerX. +apply: integral_horner_root mon_p pu0 intRp _. +by apply/integral_poly => i; rewrite coefX; apply: integral_nat. +Qed. + +Hint Resolve (integral0 RtoK) (integral1 RtoK) (@monicXsubC K). + +Let XsubC0 (u : K) : root ('X - u%:P) u. Proof. by rewrite root_XsubC. Qed. +Let intR_XsubC u : + integralOver RtoK (- u) -> {in 'X - u%:P : seq K, integralRange RtoK}. +Proof. by move=> intRu v; rewrite polyseqXsubC !inE => /pred2P[]->. Qed. + +Lemma integral_opp u : integralOver RtoK u -> integralOver RtoK (- u). +Proof. by rewrite -{1}[u]opprK => /intR_XsubC/integral_root_monic; apply. Qed. + +Lemma integral_horner (p : {poly K}) u : + {in p : seq K, integralRange RtoK} -> integralOver RtoK u -> + integralOver RtoK p.[u]. +Proof. by move=> ? /integral_opp/intR_XsubC/integral_horner_root; apply. Qed. + +Lemma integral_sub u v : + integralOver RtoK u -> integralOver RtoK v -> integralOver RtoK (u - v). +Proof. +move=> intRu /integral_opp/intR_XsubC/integral_horner/(_ intRu). +by rewrite !hornerE. +Qed. + +Lemma integral_add u v : + integralOver RtoK u -> integralOver RtoK v -> integralOver RtoK (u + v). +Proof. by rewrite -{2}[v]opprK => intRu /integral_opp; apply: integral_sub. Qed. + +Lemma integral_mul u v : + integralOver RtoK u -> integralOver RtoK v -> integralOver RtoK (u * v). +Proof. +rewrite -{2}[v]hornerX -hornerZ => intRu; apply: integral_horner. +by apply/integral_poly=> i; rewrite coefZ coefX mulr_natr mulrb; case: ifP. +Qed. + +End IntegralOverComRing. + +Section IntegralOverField. + +Variables (F E : fieldType) (FtoE : {rmorphism F -> E}). + +Definition algebraicOver (fFtoE : F -> E) u := + exists2 p, p != 0 & root (map_poly fFtoE p) u. + +Notation mk_mon p := ((lead_coef p)^-1 *: p). + +Lemma integral_algebraic u : algebraicOver FtoE u <-> integralOver FtoE u. +Proof. +split=> [] [p p_nz pu0]; last by exists p; rewrite ?monic_neq0. +exists (mk_mon p); first by rewrite monicE lead_coefZ mulVf ?lead_coef_eq0. +by rewrite linearZ rootE hornerZ (rootP pu0) mulr0. +Qed. + +Lemma algebraic_id a : algebraicOver FtoE (FtoE a). +Proof. exact/integral_algebraic/integral_id. Qed. + +Lemma algebraic0 : algebraicOver FtoE 0. +Proof. exact/integral_algebraic/integral0. Qed. + +Lemma algebraic1 : algebraicOver FtoE 1. +Proof. exact/integral_algebraic/integral1. Qed. + +Lemma algebraic_opp x : algebraicOver FtoE x -> algebraicOver FtoE (- x). +Proof. by move/integral_algebraic/integral_opp/integral_algebraic. Qed. + +Lemma algebraic_add x y : + algebraicOver FtoE x -> algebraicOver FtoE y -> algebraicOver FtoE (x + y). +Proof. +move/integral_algebraic=> intFx /integral_algebraic intFy. +exact/integral_algebraic/integral_add. +Qed. + +Lemma algebraic_sub x y : + algebraicOver FtoE x -> algebraicOver FtoE y -> algebraicOver FtoE (x - y). +Proof. by move=> algFx /algebraic_opp; apply: algebraic_add. Qed. + +Lemma algebraic_mul x y : + algebraicOver FtoE x -> algebraicOver FtoE y -> algebraicOver FtoE (x * y). +Proof. +move/integral_algebraic=> intFx /integral_algebraic intFy. +exact/integral_algebraic/integral_mul. +Qed. + +Lemma algebraic_inv u : algebraicOver FtoE u -> algebraicOver FtoE u^-1. +Proof. +have [-> | /expf_neq0 nz_u_n] := eqVneq u 0; first by rewrite invr0. +case=> p nz_p pu0; exists (Poly (rev p)). + apply/eqP=> /polyP/(_ 0%N); rewrite coef_Poly coef0 nth_rev ?size_poly_gt0 //. + by apply/eqP; rewrite subn1 lead_coef_eq0. +apply/eqP/(mulfI (nz_u_n (size p).-1)); rewrite mulr0 -(rootP pu0). +rewrite (@horner_coef_wide _ (size p)); last first. + by rewrite size_map_poly -(size_rev p) size_Poly. +rewrite horner_coef mulr_sumr size_map_poly. +rewrite [rhs in _ = rhs](reindex_inj rev_ord_inj) /=. +apply: eq_bigr => i _; rewrite !coef_map coef_Poly nth_rev // mulrCA. +by congr (_ * _); rewrite -{1}(subnKC (valP i)) addSn addnC exprD exprVn ?mulfK. +Qed. + +Lemma algebraic_div x y : + algebraicOver FtoE x -> algebraicOver FtoE y -> algebraicOver FtoE (x / y). +Proof. by move=> algFx /algebraic_inv; apply: algebraic_mul. Qed. + +Lemma integral_inv x : integralOver FtoE x -> integralOver FtoE x^-1. +Proof. by move/integral_algebraic/algebraic_inv/integral_algebraic. Qed. + +Lemma integral_div x y : + integralOver FtoE x -> integralOver FtoE y -> integralOver FtoE (x / y). +Proof. by move=> algFx /integral_inv; apply: integral_mul. Qed. + +Lemma integral_root p u : + p != 0 -> root p u -> {in p : seq E, integralRange FtoE} -> + integralOver FtoE u. +Proof. +move=> nz_p pu0 algFp. +have mon_p1: mk_mon p \is monic. + by rewrite monicE lead_coefZ mulVf ?lead_coef_eq0. +have p1u0: root (mk_mon p) u by rewrite rootE hornerZ (rootP pu0) mulr0. +apply: integral_root_monic mon_p1 p1u0 _ => _ /(nthP 0)[i ltip <-]. +rewrite coefZ mulrC; rewrite size_scale ?invr_eq0 ?lead_coef_eq0 // in ltip. +by apply: integral_div; apply/algFp/mem_nth; rewrite -?polySpred. +Qed. + +End IntegralOverField. + +(* Lifting term, formula, envs and eval to matrices. Wlog, and for the sake *) +(* of simplicity, we only lift (tensor) envs to row vectors; we can always *) +(* use mxvec/vec_mx to store and retrieve matrices. *) +(* We don't provide definitions for addition, subtraction, scaling, etc, *) +(* because they have simple matrix expressions. *) +Module MatrixFormula. + +Section MatrixFormula. + +Variable F : fieldType. + +Local Notation False := GRing.False. +Local Notation True := GRing.True. +Local Notation And := GRing.And (only parsing). +Local Notation Add := GRing.Add (only parsing). +Local Notation Bool b := (GRing.Bool b%bool). +Local Notation term := (GRing.term F). +Local Notation form := (GRing.formula F). +Local Notation eval := GRing.eval. +Local Notation holds := GRing.holds. +Local Notation qf_form := GRing.qf_form. +Local Notation qf_eval := GRing.qf_eval. + +Definition eval_mx (e : seq F) := map_mx (eval e). + +Definition mx_term := map_mx (@GRing.Const F). + +Lemma eval_mx_term e m n (A : 'M_(m, n)) : eval_mx e (mx_term A) = A. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Definition mulmx_term m n p (A : 'M[term]_(m, n)) (B : 'M_(n, p)) := + \matrix_(i, k) (\big[Add/0]_j (A i j * B j k))%T. + +Lemma eval_mulmx e m n p (A : 'M[term]_(m, n)) (B : 'M_(n, p)) : + eval_mx e (mulmx_term A B) = eval_mx e A *m eval_mx e B. +Proof. +apply/matrixP=> i k; rewrite !mxE /= ((big_morph (eval e)) 0 +%R) //=. +by apply: eq_bigr => j _; rewrite /= !mxE. +Qed. + +Local Notation morphAnd f := ((big_morph f) true andb). + +Let Schur m n (A : 'M[term]_(1 + m, 1 + n)) (a := A 0 0) := + \matrix_(i, j) (drsubmx A i j - a^-1 * dlsubmx A i 0%R * ursubmx A 0%R j)%T. + +Fixpoint mxrank_form (r m n : nat) : 'M_(m, n) -> form := + match m, n return 'M_(m, n) -> form with + | m'.+1, n'.+1 => fun A : 'M_(1 + m', 1 + n') => + let nzA k := A k.1 k.2 != 0 in + let xSchur k := Schur (xrow k.1 0%R (xcol k.2 0%R A)) in + let recf k := Bool (r > 0) /\ mxrank_form r.-1 (xSchur k) in + GRing.Pick nzA recf (Bool (r == 0%N)) + | _, _ => fun _ => Bool (r == 0%N) + end%T. + +Lemma mxrank_form_qf r m n (A : 'M_(m, n)) : qf_form (mxrank_form r A). +Proof. +by elim: m r n A => [|m IHm] r [|n] A //=; rewrite GRing.Pick_form_qf /=. +Qed. + +Lemma eval_mxrank e r m n (A : 'M_(m, n)) : + qf_eval e (mxrank_form r A) = (\rank (eval_mx e A) == r). +Proof. +elim: m r n A => [|m IHm] r [|n] A /=; try by case r. +rewrite GRing.eval_Pick /mxrank unlock /=; set pf := fun _ => _. +rewrite -(@eq_pick _ pf) => [|k]; rewrite {}/pf ?mxE // eq_sym. +case: pick => [[i j]|] //=; set B := _ - _; have:= mxrankE B. +case: (Gaussian_elimination B) r => [[_ _] _] [|r] //= <-; rewrite {}IHm eqSS. +by congr (\rank _ == r); apply/matrixP=> k l; rewrite !(mxE, big_ord1) !tpermR. +Qed. + +Lemma eval_vec_mx e m n (u : 'rV_(m * n)) : + eval_mx e (vec_mx u) = vec_mx (eval_mx e u). +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma eval_mxvec e m n (A : 'M_(m, n)) : + eval_mx e (mxvec A) = mxvec (eval_mx e A). +Proof. by rewrite -{2}[A]mxvecK eval_vec_mx vec_mxK. Qed. + +Section Subsetmx. + +Variables (m1 m2 n : nat) (A : 'M[term]_(m1, n)) (B : 'M[term]_(m2, n)). + +Definition submx_form := + \big[And/True]_(r < n.+1) (mxrank_form r (col_mx A B) ==> mxrank_form r B)%T. + +Lemma eval_col_mx e : + eval_mx e (col_mx A B) = col_mx (eval_mx e A) (eval_mx e B). +Proof. by apply/matrixP=> i j; do 2![rewrite !mxE //; case: split => ?]. Qed. + +Lemma submx_form_qf : qf_form submx_form. +Proof. +by rewrite (morphAnd (@qf_form _)) ?big1 //= => r _; rewrite !mxrank_form_qf. +Qed. + +Lemma eval_submx e : qf_eval e submx_form = (eval_mx e A <= eval_mx e B)%MS. +Proof. +rewrite (morphAnd (qf_eval e)) //= big_andE /=. +apply/forallP/idP=> /= [|sAB d]; last first. + rewrite !eval_mxrank eval_col_mx -addsmxE; apply/implyP=> /eqP <-. + by rewrite mxrank_leqif_sup ?addsmxSr // addsmx_sub sAB /=. +move/(_ (inord (\rank (eval_mx e (col_mx A B))))). +rewrite inordK ?ltnS ?rank_leq_col // !eval_mxrank eqxx /= eval_col_mx. +by rewrite -addsmxE mxrank_leqif_sup ?addsmxSr // addsmx_sub; case/andP. +Qed. + +End Subsetmx. + +Section Env. + +Variable d : nat. + +Definition seq_of_rV (v : 'rV_d) : seq F := fgraph [ffun i => v 0 i]. + +Lemma size_seq_of_rV v : size (seq_of_rV v) = d. +Proof. by rewrite tuple.size_tuple card_ord. Qed. + +Lemma nth_seq_of_rV x0 v (i : 'I_d) : nth x0 (seq_of_rV v) i = v 0 i. +Proof. by rewrite nth_fgraph_ord ffunE. Qed. + +Definition row_var k : 'rV[term]_d := \row_i ('X_(k * d + i))%T. + +Definition row_env (e : seq 'rV_d) := flatten (map seq_of_rV e). + +Lemma nth_row_env e k (i : 'I_d) : (row_env e)`_(k * d + i) = e`_k 0 i. +Proof. +elim: e k => [|v e IHe] k; first by rewrite !nth_nil mxE. +rewrite /row_env /= nth_cat size_seq_of_rV. +case: k => [|k]; first by rewrite (valP i) nth_seq_of_rV. +by rewrite mulSn -addnA -if_neg -leqNgt leq_addr addKn IHe. +Qed. + +Lemma eval_row_var e k : eval_mx (row_env e) (row_var k) = e`_k :> 'rV_d. +Proof. by apply/rowP=> i; rewrite !mxE /= nth_row_env. Qed. + +Definition Exists_row_form k (f : form) := + foldr GRing.Exists f (codom (fun i : 'I_d => k * d + i)%N). + +Lemma Exists_rowP e k f : + d > 0 -> + ((exists v : 'rV[F]_d, holds (row_env (set_nth 0 e k v)) f) + <-> holds (row_env e) (Exists_row_form k f)). +Proof. +move=> d_gt0; pose i_ j := Ordinal (ltn_pmod j d_gt0). +have d_eq j: (j = j %/ d * d + i_ j)%N := divn_eq j d. +split=> [[v f_v] | ]; last case/GRing.foldExistsP=> e' ee' f_e'. + apply/GRing.foldExistsP; exists (row_env (set_nth 0 e k v)) => {f f_v}// j. + rewrite [j]d_eq !nth_row_env nth_set_nth /=; case: eqP => // ->. + by case/imageP; exists (i_ j). +exists (\row_i e'`_(k * d + i)); apply: eq_holds f_e' => j /=. +move/(_ j): ee'; rewrite [j]d_eq !nth_row_env nth_set_nth /=. +case: eqP => [-> | ne_j_k -> //]; first by rewrite mxE. +apply/mapP=> [[r lt_r_d]]; rewrite -d_eq => def_j; case: ne_j_k. +by rewrite def_j divnMDl // divn_small ?addn0. +Qed. + +End Env. + +End MatrixFormula. + +End MatrixFormula. diff --git a/mathcomp/algebra/poly.v b/mathcomp/algebra/poly.v new file mode 100644 index 0000000..813f70d --- /dev/null +++ b/mathcomp/algebra/poly.v @@ -0,0 +1,2591 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype. +Require Import bigop ssralg binomial. + +(******************************************************************************) +(* This file provides a library for univariate polynomials over ring *) +(* structures; it also provides an extended theory for polynomials whose *) +(* coefficients range over commutative rings and integral domains. *) +(* *) +(* {poly R} == the type of polynomials with coefficients of type R, *) +(* represented as lists with a non zero last element *) +(* (big endian representation); the coeficient type R *) +(* must have a canonical ringType structure cR. In fact *) +(* {poly R} denotes the concrete type polynomial cR; R *) +(* is just a phantom argument that lets type inference *) +(* reconstruct the (hidden) ringType structure cR. *) +(* p : seq R == the big-endian sequence of coefficients of p, via *) +(* the coercion polyseq : polynomial >-> seq. *) +(* Poly s == the polynomial with coefficient sequence s (ignoring *) +(* trailing zeroes). *) +(* \poly_(i < n) E(i) == the polynomial of degree at most n - 1 whose *) +(* coefficients are given by the general term E(i) *) +(* 0, 1, - p, p + q, == the usual ring operations: {poly R} has a canonical *) +(* p * q, p ^+ n, ... ringType structure, which is commutative / integral *) +(* when R is commutative / integral, respectively. *) +(* polyC c, c%:P == the constant polynomial c *) +(* 'X == the (unique) variable *) +(* 'X^n == a power of 'X; 'X^0 is 1, 'X^1 is convertible to 'X *) +(* p`_i == the coefficient of 'X^i in p; this is in fact just *) +(* the ring_scope notation generic seq-indexing using *) +(* nth 0%R, combined with the polyseq coercion. *) +(* coefp i == the linear function p |-> p`_i (self-exapanding). *) +(* size p == 1 + the degree of p, or 0 if p = 0 (this is the *) +(* generic seq function combined with polyseq). *) +(* lead_coef p == the coefficient of the highest monomial in p, or 0 *) +(* if p = 0 (hence lead_coef p = 0 iff p = 0) *) +(* p \is monic <=> lead_coef p == 1 (0 is not monic). *) +(* p \is a polyOver S <=> the coefficients of p satisfy S; S should have a *) +(* key that should be (at least) an addrPred. *) +(* p.[x] == the evaluation of a polynomial p at a point x using *) +(* the Horner scheme *) +(* *** The multi-rule hornerE (resp., hornerE_comm) unwinds *) +(* horner evaluation of a polynomial expression (resp., *) +(* in a non commutative ring, with side conditions). *) +(* p^`() == formal derivative of p *) +(* p^`(n) == formal n-derivative of p *) +(* p^`N(n) == formal n-derivative of p divided by n! *) +(* p \Po q == polynomial composition; because this is naturally a *) +(* a linear morphism in the first argument, this *) +(* notation is transposed (q comes before p for redex *) +(* selection, etc). *) +(* := \sum(i < size p) p`_i *: q ^+ i *) +(* comm_poly p x == x and p.[x] commute; this is a sufficient condition *) +(* for evaluating (q * p).[x] as q.[x] * p.[x] when R *) +(* is not commutative. *) +(* comm_coef p x == x commutes with all the coefficients of p (clearly, *) +(* this implies comm_poly p x). *) +(* root p x == x is a root of p, i.e., p.[x] = 0 *) +(* n.-unity_root x == x is an nth root of unity, i.e., a root of 'X^n - 1 *) +(* n.-primitive_root x == x is a primitive nth root of unity, i.e., n is the *) +(* least positive integer m > 0 such that x ^+ m = 1. *) +(* *** The submodule poly.UnityRootTheory can be used to *) +(* import selectively the part of the theory of roots *) +(* of unity that doesn't mention polynomials explicitly *) +(* map_poly f p == the image of the polynomial by the function f (which *) +(* (locally, p^f) is usually a ring morphism). *) +(* p^:P == p lifted to {poly {poly R}} (:= map_poly polyC p). *) +(* commr_rmorph f u == u commutes with the image of f (i.e., with all f x). *) +(* horner_morph cfu == given cfu : commr_rmorph f u, the function mapping p *) +(* to the value of map_poly f p at u; this is a ring *) +(* morphism from {poly R} to the codomain of f when f *) +(* is a ring morphism. *) +(* horner_eval u == the function mapping p to p.[u]; this function can *) +(* only be used for u in a commutative ring, so it is *) +(* always a linear ring morphism from {poly R} to R. *) +(* diff_roots x y == x and y are distinct roots; if R is a field, this *) +(* just means x != y, but this concept is generalized *) +(* to the case where R is only a ring with units (i.e., *) +(* a unitRingType); in which case it means that x and y *) +(* commute, and that the difference x - y is a unit *) +(* (i.e., has a multiplicative inverse) in R. *) +(* to just x != y). *) +(* uniq_roots s == s is a sequence or pairwise distinct roots, in the *) +(* sense of diff_roots p above. *) +(* *** We only show that these operations and properties are transferred by *) +(* morphisms whose domain is a field (thus ensuring injectivity). *) +(* We prove the factor_theorem, and the max_poly_roots inequality relating *) +(* the number of distinct roots of a polynomial and its size. *) +(* The some polynomial lemmas use following suffix interpretation : *) +(* C - constant polynomial (as in polyseqC : a%:P = nseq (a != 0) a). *) +(* X - the polynomial variable 'X (as in coefX : 'X`_i = (i == 1%N)). *) +(* Xn - power of 'X (as in monicXn : monic 'X^n). *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GRing.Theory. +Open Local Scope ring_scope. + +Reserved Notation "{ 'poly' T }" (at level 0, format "{ 'poly' T }"). +Reserved Notation "c %:P" (at level 2, format "c %:P"). +Reserved Notation "p ^:P" (at level 2, format "p ^:P"). +Reserved Notation "'X" (at level 0). +Reserved Notation "''X^' n" (at level 3, n at level 2, format "''X^' n"). +Reserved Notation "\poly_ ( i < n ) E" + (at level 36, E at level 36, i, n at level 50, + format "\poly_ ( i < n ) E"). +Reserved Notation "p \Po q" (at level 50). +Reserved Notation "p ^`N ( n )" (at level 8, format "p ^`N ( n )"). +Reserved Notation "n .-unity_root" (at level 2, format "n .-unity_root"). +Reserved Notation "n .-primitive_root" + (at level 2, format "n .-primitive_root"). + +Local Notation simp := Monoid.simpm. + +Section Polynomial. + +Variable R : ringType. + +(* Defines a polynomial as a sequence with <> 0 last element *) +Record polynomial := Polynomial {polyseq :> seq R; _ : last 1 polyseq != 0}. + +Canonical polynomial_subType := Eval hnf in [subType for polyseq]. +Definition polynomial_eqMixin := Eval hnf in [eqMixin of polynomial by <:]. +Canonical polynomial_eqType := Eval hnf in EqType polynomial polynomial_eqMixin. +Definition polynomial_choiceMixin := [choiceMixin of polynomial by <:]. +Canonical polynomial_choiceType := + Eval hnf in ChoiceType polynomial polynomial_choiceMixin. + +Lemma poly_inj : injective polyseq. Proof. exact: val_inj. Qed. + +Definition poly_of of phant R := polynomial. +Identity Coercion type_poly_of : poly_of >-> polynomial. + +Definition coefp_head h i (p : poly_of (Phant R)) := let: tt := h in p`_i. + +End Polynomial. + +(* We need to break off the section here to let the argument scope *) +(* directives take effect. *) +Bind Scope ring_scope with poly_of. +Bind Scope ring_scope with polynomial. +Arguments Scope polyseq [_ ring_scope]. +Arguments Scope poly_inj [_ ring_scope ring_scope _]. +Arguments Scope coefp_head [_ _ nat_scope ring_scope _]. +Notation "{ 'poly' T }" := (poly_of (Phant T)). +Notation coefp i := (coefp_head tt i). + +Section PolynomialTheory. + +Variable R : ringType. +Implicit Types (a b c x y z : R) (p q r d : {poly R}). + +Canonical poly_subType := Eval hnf in [subType of {poly R}]. +Canonical poly_eqType := Eval hnf in [eqType of {poly R}]. +Canonical poly_choiceType := Eval hnf in [choiceType of {poly R}]. + +Definition lead_coef p := p`_(size p).-1. +Lemma lead_coefE p : lead_coef p = p`_(size p).-1. Proof. by []. Qed. + +Definition poly_nil := @Polynomial R [::] (oner_neq0 R). +Definition polyC c : {poly R} := insubd poly_nil [:: c]. + +Local Notation "c %:P" := (polyC c). + +(* Remember the boolean (c != 0) is coerced to 1 if true and 0 if false *) +Lemma polyseqC c : c%:P = nseq (c != 0) c :> seq R. +Proof. by rewrite val_insubd /=; case: (c == 0). Qed. + +Lemma size_polyC c : size c%:P = (c != 0). +Proof. by rewrite polyseqC size_nseq. Qed. + +Lemma coefC c i : c%:P`_i = if i == 0%N then c else 0. +Proof. by rewrite polyseqC; case: i => [|[]]; case: eqP. Qed. + +Lemma polyCK : cancel polyC (coefp 0). +Proof. by move=> c; rewrite [coefp 0 _]coefC. Qed. + +Lemma polyC_inj : injective polyC. +Proof. by move=> c1 c2 eqc12; have:= coefC c2 0; rewrite -eqc12 coefC. Qed. + +Lemma lead_coefC c : lead_coef c%:P = c. +Proof. by rewrite /lead_coef polyseqC; case: eqP. Qed. + +(* Extensional interpretation (poly <=> nat -> R) *) +Lemma polyP p q : nth 0 p =1 nth 0 q <-> p = q. +Proof. +split=> [eq_pq | -> //]; apply: poly_inj. +without loss lt_pq: p q eq_pq / size p < size q. + move=> IH; case: (ltngtP (size p) (size q)); try by move/IH->. + move/(@eq_from_nth _ 0); exact. +case: q => q nz_q /= in lt_pq eq_pq *; case/eqP: nz_q. +by rewrite (last_nth 0) -(subnKC lt_pq) /= -eq_pq nth_default ?leq_addr. +Qed. + +Lemma size1_polyC p : size p <= 1 -> p = (p`_0)%:P. +Proof. +move=> le_p_1; apply/polyP=> i; rewrite coefC. +by case: i => // i; rewrite nth_default // (leq_trans le_p_1). +Qed. + +(* Builds a polynomial by extension. *) +Definition cons_poly c p : {poly R} := + if p is Polynomial ((_ :: _) as s) ns then + @Polynomial R (c :: s) ns + else c%:P. + +Lemma polyseq_cons c p : + cons_poly c p = (if ~~ nilp p then c :: p else c%:P) :> seq R. +Proof. by case: p => [[]]. Qed. + +Lemma size_cons_poly c p : + size (cons_poly c p) = (if nilp p && (c == 0) then 0%N else (size p).+1). +Proof. by case: p => [[|c' s] _] //=; rewrite size_polyC; case: eqP. Qed. + +Lemma coef_cons c p i : (cons_poly c p)`_i = if i == 0%N then c else p`_i.-1. +Proof. +by case: p i => [[|c' s] _] [] //=; rewrite polyseqC; case: eqP => //= _ []. +Qed. + +(* Build a polynomial directly from a list of coefficients. *) +Definition Poly := foldr cons_poly 0%:P. + +Lemma PolyK c s : last c s != 0 -> Poly s = s :> seq R. +Proof. +case: s => {c}/= [_ |c s]; first by rewrite polyseqC eqxx. +elim: s c => /= [|a s IHs] c nz_c; rewrite polyseq_cons ?{}IHs //. +by rewrite !polyseqC !eqxx nz_c. +Qed. + +Lemma polyseqK p : Poly p = p. +Proof. by apply: poly_inj; exact: PolyK (valP p). Qed. + +Lemma size_Poly s : size (Poly s) <= size s. +Proof. +elim: s => [|c s IHs] /=; first by rewrite polyseqC eqxx. +by rewrite polyseq_cons; case: ifP => // _; rewrite size_polyC; case: (~~ _). +Qed. + +Lemma coef_Poly s i : (Poly s)`_i = s`_i. +Proof. +by elim: s i => [|c s IHs] /= [|i]; rewrite !(coefC, eqxx, coef_cons) /=. +Qed. + +(* Build a polynomial from an infinite sequence of coefficients and a bound. *) +Definition poly_expanded_def n E := Poly (mkseq E n). +Fact poly_key : unit. Proof. by []. Qed. +Definition poly := locked_with poly_key poly_expanded_def. +Canonical poly_unlockable := [unlockable fun poly]. +Local Notation "\poly_ ( i < n ) E" := (poly n (fun i : nat => E)). + +Lemma polyseq_poly n E : + E n.-1 != 0 -> \poly_(i < n) E i = mkseq [eta E] n :> seq R. +Proof. +rewrite unlock; case: n => [|n] nzEn; first by rewrite polyseqC eqxx. +by rewrite (@PolyK 0) // -nth_last nth_mkseq size_mkseq. +Qed. + +Lemma size_poly n E : size (\poly_(i < n) E i) <= n. +Proof. by rewrite unlock (leq_trans (size_Poly _)) ?size_mkseq. Qed. + +Lemma size_poly_eq n E : E n.-1 != 0 -> size (\poly_(i < n) E i) = n. +Proof. by move/polyseq_poly->; apply: size_mkseq. Qed. + +Lemma coef_poly n E k : (\poly_(i < n) E i)`_k = (if k < n then E k else 0). +Proof. +rewrite unlock coef_Poly. +have [lt_kn | le_nk] := ltnP k n; first by rewrite nth_mkseq. +by rewrite nth_default // size_mkseq. +Qed. + +Lemma lead_coef_poly n E : + n > 0 -> E n.-1 != 0 -> lead_coef (\poly_(i < n) E i) = E n.-1. +Proof. +by case: n => // n _ nzE; rewrite /lead_coef size_poly_eq // coef_poly leqnn. +Qed. + +Lemma coefK p : \poly_(i < size p) p`_i = p. +Proof. +by apply/polyP=> i; rewrite coef_poly; case: ltnP => // /(nth_default 0)->. +Qed. + +(* Zmodule structure for polynomial *) +Definition add_poly_def p q := \poly_(i < maxn (size p) (size q)) (p`_i + q`_i). +Fact add_poly_key : unit. Proof. by []. Qed. +Definition add_poly := locked_with add_poly_key add_poly_def. +Canonical add_poly_unlockable := [unlockable fun add_poly]. + +Definition opp_poly_def p := \poly_(i < size p) - p`_i. +Fact opp_poly_key : unit. Proof. by []. Qed. +Definition opp_poly := locked_with opp_poly_key opp_poly_def. +Canonical opp_poly_unlockable := [unlockable fun opp_poly]. + +Fact coef_add_poly p q i : (add_poly p q)`_i = p`_i + q`_i. +Proof. +rewrite unlock coef_poly; case: leqP => //. +by rewrite geq_max => /andP[le_p_i le_q_i]; rewrite !nth_default ?add0r. +Qed. + +Fact coef_opp_poly p i : (opp_poly p)`_i = - p`_i. +Proof. +rewrite unlock coef_poly /=. +by case: leqP => // le_p_i; rewrite nth_default ?oppr0. +Qed. + +Fact add_polyA : associative add_poly. +Proof. by move=> p q r; apply/polyP=> i; rewrite !coef_add_poly addrA. Qed. + +Fact add_polyC : commutative add_poly. +Proof. by move=> p q; apply/polyP=> i; rewrite !coef_add_poly addrC. Qed. + +Fact add_poly0 : left_id 0%:P add_poly. +Proof. +by move=> p; apply/polyP=> i; rewrite coef_add_poly coefC if_same add0r. +Qed. + +Fact add_polyN : left_inverse 0%:P opp_poly add_poly. +Proof. +move=> p; apply/polyP=> i. +by rewrite coef_add_poly coef_opp_poly coefC if_same addNr. +Qed. + +Definition poly_zmodMixin := + ZmodMixin add_polyA add_polyC add_poly0 add_polyN. + +Canonical poly_zmodType := Eval hnf in ZmodType {poly R} poly_zmodMixin. +Canonical polynomial_zmodType := + Eval hnf in ZmodType (polynomial R) poly_zmodMixin. + +(* Properties of the zero polynomial *) +Lemma polyC0 : 0%:P = 0 :> {poly R}. Proof. by []. Qed. + +Lemma polyseq0 : (0 : {poly R}) = [::] :> seq R. +Proof. by rewrite polyseqC eqxx. Qed. + +Lemma size_poly0 : size (0 : {poly R}) = 0%N. +Proof. by rewrite polyseq0. Qed. + +Lemma coef0 i : (0 : {poly R})`_i = 0. +Proof. by rewrite coefC if_same. Qed. + +Lemma lead_coef0 : lead_coef 0 = 0 :> R. Proof. exact: lead_coefC. Qed. + +Lemma size_poly_eq0 p : (size p == 0%N) = (p == 0). +Proof. by rewrite size_eq0 -polyseq0. Qed. + +Lemma size_poly_leq0 p : (size p <= 0) = (p == 0). +Proof. by rewrite leqn0 size_poly_eq0. Qed. + +Lemma size_poly_leq0P p : reflect (p = 0) (size p <= 0%N). +Proof. by apply: (iffP idP); rewrite size_poly_leq0; move/eqP. Qed. + +Lemma size_poly_gt0 p : (0 < size p) = (p != 0). +Proof. by rewrite lt0n size_poly_eq0. Qed. + +Lemma nil_poly p : nilp p = (p == 0). +Proof. exact: size_poly_eq0. Qed. + +Lemma poly0Vpos p : {p = 0} + {size p > 0}. +Proof. by rewrite lt0n size_poly_eq0; exact: eqVneq. Qed. + +Lemma polySpred p : p != 0 -> size p = (size p).-1.+1. +Proof. by rewrite -size_poly_eq0 -lt0n => /prednK. Qed. + +Lemma lead_coef_eq0 p : (lead_coef p == 0) = (p == 0). +Proof. +rewrite -nil_poly /lead_coef nth_last. +by case: p => [[|x s] /= /negbTE // _]; rewrite eqxx. +Qed. + +Lemma polyC_eq0 (c : R) : (c%:P == 0) = (c == 0). +Proof. by rewrite -nil_poly polyseqC; case: (c == 0). Qed. + +Lemma size_poly1P p : reflect (exists2 c, c != 0 & p = c%:P) (size p == 1%N). +Proof. +apply: (iffP eqP) => [pC | [c nz_c ->]]; last by rewrite size_polyC nz_c. +have def_p: p = (p`_0)%:P by rewrite -size1_polyC ?pC. +by exists p`_0; rewrite // -polyC_eq0 -def_p -size_poly_eq0 pC. +Qed. + +Lemma leq_sizeP p i : reflect (forall j, i <= j -> p`_j = 0) (size p <= i). +Proof. +apply: (iffP idP) => [hp j hij| hp]. + by apply: nth_default; apply: leq_trans hij. +case p0: (p == 0); first by rewrite (eqP p0) size_poly0. +move: (lead_coef_eq0 p); rewrite p0 leqNgt; move/negbT; apply: contra => hs. +by apply/eqP; apply: hp; rewrite -ltnS (ltn_predK hs). +Qed. + +(* Size, leading coef, morphism properties of coef *) + +Lemma coefD p q i : (p + q)`_i = p`_i + q`_i. +Proof. exact: coef_add_poly. Qed. + +Lemma coefN p i : (- p)`_i = - p`_i. +Proof. exact: coef_opp_poly. Qed. + +Lemma coefB p q i : (p - q)`_i = p`_i - q`_i. +Proof. by rewrite coefD coefN. Qed. + +Canonical coefp_additive i := + Additive ((fun p => (coefB p)^~ i) : additive (coefp i)). + +Lemma coefMn p n i : (p *+ n)`_i = p`_i *+ n. +Proof. exact: (raddfMn (coefp_additive i)). Qed. + +Lemma coefMNn p n i : (p *- n)`_i = p`_i *- n. +Proof. by rewrite coefN coefMn. Qed. + +Lemma coef_sum I (r : seq I) (P : pred I) (F : I -> {poly R}) k : + (\sum_(i <- r | P i) F i)`_k = \sum_(i <- r | P i) (F i)`_k. +Proof. exact: (raddf_sum (coefp_additive k)). Qed. + +Lemma polyC_add : {morph polyC : a b / a + b}. +Proof. by move=> a b; apply/polyP=> [[|i]]; rewrite coefD !coefC ?addr0. Qed. + +Lemma polyC_opp : {morph polyC : c / - c}. +Proof. by move=> c; apply/polyP=> [[|i]]; rewrite coefN !coefC ?oppr0. Qed. + +Lemma polyC_sub : {morph polyC : a b / a - b}. +Proof. by move=> a b; rewrite polyC_add polyC_opp. Qed. + +Canonical polyC_additive := Additive polyC_sub. + +Lemma polyC_muln n : {morph polyC : c / c *+ n}. +Proof. exact: raddfMn. Qed. + +Lemma size_opp p : size (- p) = size p. +Proof. +by apply/eqP; rewrite eqn_leq -{3}(opprK p) -[-%R]/opp_poly unlock !size_poly. +Qed. + +Lemma lead_coef_opp p : lead_coef (- p) = - lead_coef p. +Proof. by rewrite /lead_coef size_opp coefN. Qed. + +Lemma size_add p q : size (p + q) <= maxn (size p) (size q). +Proof. by rewrite -[+%R]/add_poly unlock; apply: size_poly. Qed. + +Lemma size_addl p q : size p > size q -> size (p + q) = size p. +Proof. +move=> ltqp; rewrite -[+%R]/add_poly unlock size_poly_eq (maxn_idPl (ltnW _))//. +by rewrite addrC nth_default ?simp ?nth_last //; case: p ltqp => [[]]. +Qed. + +Lemma size_sum I (r : seq I) (P : pred I) (F : I -> {poly R}) : + size (\sum_(i <- r | P i) F i) <= \max_(i <- r | P i) size (F i). +Proof. +elim/big_rec2: _ => [|i p q _ IHp]; first by rewrite size_poly0. +by rewrite -(maxn_idPr IHp) maxnA leq_max size_add. +Qed. + +Lemma lead_coefDl p q : size p > size q -> lead_coef (p + q) = lead_coef p. +Proof. +move=> ltqp; rewrite /lead_coef coefD size_addl //. +by rewrite addrC nth_default ?simp // -ltnS (ltn_predK ltqp). +Qed. + +(* Polynomial ring structure. *) + +Definition mul_poly_def p q := + \poly_(i < (size p + size q).-1) (\sum_(j < i.+1) p`_j * q`_(i - j)). +Fact mul_poly_key : unit. Proof. by []. Qed. +Definition mul_poly := locked_with mul_poly_key mul_poly_def. +Canonical mul_poly_unlockable := [unlockable fun mul_poly]. + +Fact coef_mul_poly p q i : + (mul_poly p q)`_i = \sum_(j < i.+1) p`_j * q`_(i - j)%N. +Proof. +rewrite unlock coef_poly -subn1 ltn_subRL add1n; case: leqP => // le_pq_i1. +rewrite big1 // => j _; have [lq_q_ij | gt_q_ij] := leqP (size q) (i - j). + by rewrite [q`__]nth_default ?mulr0. +rewrite nth_default ?mul0r // -(leq_add2r (size q)) (leq_trans le_pq_i1) //. +by rewrite -leq_subLR -subnSK. +Qed. + +Fact coef_mul_poly_rev p q i : + (mul_poly p q)`_i = \sum_(j < i.+1) p`_(i - j)%N * q`_j. +Proof. +rewrite coef_mul_poly (reindex_inj rev_ord_inj) /=. +by apply: eq_bigr => j _; rewrite (sub_ordK j). +Qed. + +Fact mul_polyA : associative mul_poly. +Proof. +move=> p q r; apply/polyP=> i; rewrite coef_mul_poly coef_mul_poly_rev. +pose coef3 j k := p`_j * (q`_(i - j - k)%N * r`_k). +transitivity (\sum_(j < i.+1) \sum_(k < i.+1 | k <= i - j) coef3 j k). + apply: eq_bigr => /= j _; rewrite coef_mul_poly_rev big_distrr /=. + by rewrite (big_ord_narrow_leq (leq_subr _ _)). +rewrite (exchange_big_dep predT) //=; apply: eq_bigr => k _. +transitivity (\sum_(j < i.+1 | j <= i - k) coef3 j k). + apply: eq_bigl => j; rewrite -ltnS -(ltnS j) -!subSn ?leq_ord //. + by rewrite -subn_gt0 -(subn_gt0 j) -!subnDA addnC. +rewrite (big_ord_narrow_leq (leq_subr _ _)) coef_mul_poly big_distrl /=. +by apply: eq_bigr => j _; rewrite /coef3 -!subnDA addnC mulrA. +Qed. + +Fact mul_1poly : left_id 1%:P mul_poly. +Proof. +move=> p; apply/polyP => i; rewrite coef_mul_poly big_ord_recl subn0. +by rewrite big1 => [|j _]; rewrite coefC !simp. +Qed. + +Fact mul_poly1 : right_id 1%:P mul_poly. +Proof. +move=> p; apply/polyP => i; rewrite coef_mul_poly_rev big_ord_recl subn0. +by rewrite big1 => [|j _]; rewrite coefC !simp. +Qed. + +Fact mul_polyDl : left_distributive mul_poly +%R. +Proof. +move=> p q r; apply/polyP=> i; rewrite coefD !coef_mul_poly -big_split. +by apply: eq_bigr => j _; rewrite coefD mulrDl. +Qed. + +Fact mul_polyDr : right_distributive mul_poly +%R. +Proof. +move=> p q r; apply/polyP=> i; rewrite coefD !coef_mul_poly -big_split. +by apply: eq_bigr => j _; rewrite coefD mulrDr. +Qed. + +Fact poly1_neq0 : 1%:P != 0 :> {poly R}. +Proof. by rewrite polyC_eq0 oner_neq0. Qed. + +Definition poly_ringMixin := + RingMixin mul_polyA mul_1poly mul_poly1 mul_polyDl mul_polyDr poly1_neq0. + +Canonical poly_ringType := Eval hnf in RingType {poly R} poly_ringMixin. +Canonical polynomial_ringType := + Eval hnf in RingType (polynomial R) poly_ringMixin. + +Lemma polyC1 : 1%:P = 1 :> {poly R}. Proof. by []. Qed. + +Lemma polyseq1 : (1 : {poly R}) = [:: 1] :> seq R. +Proof. by rewrite polyseqC oner_neq0. Qed. + +Lemma size_poly1 : size (1 : {poly R}) = 1%N. +Proof. by rewrite polyseq1. Qed. + +Lemma coef1 i : (1 : {poly R})`_i = (i == 0%N)%:R. +Proof. by case: i => [|i]; rewrite polyseq1 /= ?nth_nil. Qed. + +Lemma lead_coef1 : lead_coef 1 = 1 :> R. Proof. exact: lead_coefC. Qed. + +Lemma coefM p q i : (p * q)`_i = \sum_(j < i.+1) p`_j * q`_(i - j)%N. +Proof. exact: coef_mul_poly. Qed. + +Lemma coefMr p q i : (p * q)`_i = \sum_(j < i.+1) p`_(i - j)%N * q`_j. +Proof. exact: coef_mul_poly_rev. Qed. + +Lemma size_mul_leq p q : size (p * q) <= (size p + size q).-1. +Proof. by rewrite -[*%R]/mul_poly unlock size_poly. Qed. + +Lemma mul_lead_coef p q : + lead_coef p * lead_coef q = (p * q)`_(size p + size q).-2. +Proof. +pose dp := (size p).-1; pose dq := (size q).-1. +have [-> | nz_p] := eqVneq p 0; first by rewrite lead_coef0 !mul0r coef0. +have [-> | nz_q] := eqVneq q 0; first by rewrite lead_coef0 !mulr0 coef0. +have ->: (size p + size q).-2 = (dp + dq)%N. + by do 2! rewrite polySpred // addSn addnC. +have lt_p_pq: dp < (dp + dq).+1 by rewrite ltnS leq_addr. +rewrite coefM (bigD1 (Ordinal lt_p_pq)) ?big1 ?simp ?addKn //= => i. +rewrite -val_eqE neq_ltn /= => /orP[lt_i_p | gt_i_p]; last first. + by rewrite nth_default ?mul0r //; rewrite -polySpred in gt_i_p. +rewrite [q`__]nth_default ?mulr0 //= -subSS -{1}addnS -polySpred //. +by rewrite addnC -addnBA ?leq_addr. +Qed. + +Lemma size_proper_mul p q : + lead_coef p * lead_coef q != 0 -> size (p * q) = (size p + size q).-1. +Proof. +apply: contraNeq; rewrite mul_lead_coef eqn_leq size_mul_leq -ltnNge => lt_pq. +by rewrite nth_default // -subn1 -(leq_add2l 1) -leq_subLR leq_sub2r. +Qed. + +Lemma lead_coef_proper_mul p q : + let c := lead_coef p * lead_coef q in c != 0 -> lead_coef (p * q) = c. +Proof. by move=> /= nz_c; rewrite mul_lead_coef -size_proper_mul. Qed. + +Lemma size_prod_leq (I : finType) (P : pred I) (F : I -> {poly R}) : + size (\prod_(i | P i) F i) <= (\sum_(i | P i) size (F i)).+1 - #|P|. +Proof. +rewrite -sum1_card. +elim/big_rec3: _ => [|i n m p _ IHp]; first by rewrite size_poly1. +have [-> | nz_p] := eqVneq p 0; first by rewrite mulr0 size_poly0. +rewrite (leq_trans (size_mul_leq _ _)) // subnS -!subn1 leq_sub2r //. +rewrite -addnS -addnBA ?leq_add2l // ltnW // -subn_gt0 (leq_trans _ IHp) //. +by rewrite polySpred. +Qed. + +Lemma coefCM c p i : (c%:P * p)`_i = c * p`_i. +Proof. +rewrite coefM big_ord_recl subn0. +by rewrite big1 => [|j _]; rewrite coefC !simp. +Qed. + +Lemma coefMC c p i : (p * c%:P)`_i = p`_i * c. +Proof. +rewrite coefMr big_ord_recl subn0. +by rewrite big1 => [|j _]; rewrite coefC !simp. +Qed. + +Lemma polyC_mul : {morph polyC : a b / a * b}. +Proof. by move=> a b; apply/polyP=> [[|i]]; rewrite coefCM !coefC ?simp. Qed. + +Fact polyC_multiplicative : multiplicative polyC. +Proof. by split; first exact: polyC_mul. Qed. +Canonical polyC_rmorphism := AddRMorphism polyC_multiplicative. + +Lemma polyC_exp n : {morph polyC : c / c ^+ n}. +Proof. exact: rmorphX. Qed. + +Lemma size_exp_leq p n : size (p ^+ n) <= ((size p).-1 * n).+1. +Proof. +elim: n => [|n IHn]; first by rewrite size_poly1. +have [-> | nzp] := poly0Vpos p; first by rewrite exprS mul0r size_poly0. +rewrite exprS (leq_trans (size_mul_leq _ _)) //. +by rewrite -{1}(prednK nzp) mulnS -addnS leq_add2l. +Qed. + +Lemma size_Msign p n : size ((-1) ^+ n * p) = size p. +Proof. +by rewrite -signr_odd; case: (odd n); rewrite ?mul1r // mulN1r size_opp. +Qed. + +Fact coefp0_multiplicative : multiplicative (coefp 0 : {poly R} -> R). +Proof. +split=> [p q|]; last by rewrite polyCK. +by rewrite [coefp 0 _]coefM big_ord_recl big_ord0 addr0. +Qed. + +Canonical coefp0_rmorphism := AddRMorphism coefp0_multiplicative. + +(* Algebra structure of polynomials. *) +Definition scale_poly_def a (p : {poly R}) := \poly_(i < size p) (a * p`_i). +Fact scale_poly_key : unit. Proof. by []. Qed. +Definition scale_poly := locked_with scale_poly_key scale_poly_def. +Canonical scale_poly_unlockable := [unlockable fun scale_poly]. + +Fact scale_polyE a p : scale_poly a p = a%:P * p. +Proof. +apply/polyP=> n; rewrite unlock coef_poly coefCM. +by case: leqP => // le_p_n; rewrite nth_default ?mulr0. +Qed. + +Fact scale_polyA a b p : scale_poly a (scale_poly b p) = scale_poly (a * b) p. +Proof. by rewrite !scale_polyE mulrA polyC_mul. Qed. + +Fact scale_1poly : left_id 1 scale_poly. +Proof. by move=> p; rewrite scale_polyE mul1r. Qed. + +Fact scale_polyDr a : {morph scale_poly a : p q / p + q}. +Proof. by move=> p q; rewrite !scale_polyE mulrDr. Qed. + +Fact scale_polyDl p : {morph scale_poly^~ p : a b / a + b}. +Proof. by move=> a b /=; rewrite !scale_polyE raddfD mulrDl. Qed. + +Fact scale_polyAl a p q : scale_poly a (p * q) = scale_poly a p * q. +Proof. by rewrite !scale_polyE mulrA. Qed. + +Definition poly_lmodMixin := + LmodMixin scale_polyA scale_1poly scale_polyDr scale_polyDl. + +Canonical poly_lmodType := + Eval hnf in LmodType R {poly R} poly_lmodMixin. +Canonical polynomial_lmodType := + Eval hnf in LmodType R (polynomial R) poly_lmodMixin. +Canonical poly_lalgType := + Eval hnf in LalgType R {poly R} scale_polyAl. +Canonical polynomial_lalgType := + Eval hnf in LalgType R (polynomial R) scale_polyAl. + +Lemma mul_polyC a p : a%:P * p = a *: p. +Proof. by rewrite -scale_polyE. Qed. + +Lemma alg_polyC a : a%:A = a%:P :> {poly R}. +Proof. by rewrite -mul_polyC mulr1. Qed. + +Lemma coefZ a p i : (a *: p)`_i = a * p`_i. +Proof. +rewrite -[*:%R]/scale_poly unlock coef_poly. +by case: leqP => // le_p_n; rewrite nth_default ?mulr0. +Qed. + +Lemma size_scale_leq a p : size (a *: p) <= size p. +Proof. by rewrite -[*:%R]/scale_poly unlock size_poly. Qed. + +Canonical coefp_linear i : {scalar {poly R}} := + AddLinear ((fun a => (coefZ a) ^~ i) : scalable_for *%R (coefp i)). +Canonical coefp0_lrmorphism := [lrmorphism of coefp 0]. + +(* The indeterminate, at last! *) +Definition polyX_def := Poly [:: 0; 1]. +Fact polyX_key : unit. Proof. by []. Qed. +Definition polyX : {poly R} := locked_with polyX_key polyX_def. +Canonical polyX_unlockable := [unlockable of polyX]. +Local Notation "'X" := polyX. + +Lemma polyseqX : 'X = [:: 0; 1] :> seq R. +Proof. by rewrite unlock !polyseq_cons nil_poly eqxx /= polyseq1. Qed. + +Lemma size_polyX : size 'X = 2. Proof. by rewrite polyseqX. Qed. + +Lemma polyX_eq0 : ('X == 0) = false. +Proof. by rewrite -size_poly_eq0 size_polyX. Qed. + +Lemma coefX i : 'X`_i = (i == 1%N)%:R. +Proof. by case: i => [|[|i]]; rewrite polyseqX //= nth_nil. Qed. + +Lemma lead_coefX : lead_coef 'X = 1. +Proof. by rewrite /lead_coef polyseqX. Qed. + +Lemma commr_polyX p : GRing.comm p 'X. +Proof. +apply/polyP=> i; rewrite coefMr coefM. +by apply: eq_bigr => j _; rewrite coefX commr_nat. +Qed. + +Lemma coefMX p i : (p * 'X)`_i = (if (i == 0)%N then 0 else p`_i.-1). +Proof. +rewrite coefMr big_ord_recl coefX ?simp. +case: i => [|i]; rewrite ?big_ord0 //= big_ord_recl polyseqX subn1 /=. +by rewrite big1 ?simp // => j _; rewrite nth_nil !simp. +Qed. + +Lemma coefXM p i : ('X * p)`_i = (if (i == 0)%N then 0 else p`_i.-1). +Proof. by rewrite -commr_polyX coefMX. Qed. + +Lemma cons_poly_def p a : cons_poly a p = p * 'X + a%:P. +Proof. +apply/polyP=> i; rewrite coef_cons coefD coefMX coefC. +by case: ifP; rewrite !simp. +Qed. + +Lemma poly_ind (K : {poly R} -> Type) : + K 0 -> (forall p c, K p -> K (p * 'X + c%:P)) -> (forall p, K p). +Proof. +move=> K0 Kcons p; rewrite -[p]polyseqK. +elim: {p}(p : seq R) => //= p c IHp; rewrite cons_poly_def; exact: Kcons. +Qed. + +Lemma polyseqXsubC a : 'X - a%:P = [:: - a; 1] :> seq R. +Proof. +by rewrite -['X]mul1r -polyC_opp -cons_poly_def polyseq_cons polyseq1. +Qed. + +Lemma size_XsubC a : size ('X - a%:P) = 2%N. +Proof. by rewrite polyseqXsubC. Qed. + +Lemma size_XaddC b : size ('X + b%:P) = 2. +Proof. by rewrite -[b]opprK rmorphN size_XsubC. Qed. + +Lemma lead_coefXsubC a : lead_coef ('X - a%:P) = 1. +Proof. by rewrite lead_coefE polyseqXsubC. Qed. + +Lemma polyXsubC_eq0 a : ('X - a%:P == 0) = false. +Proof. by rewrite -nil_poly polyseqXsubC. Qed. + +Lemma size_MXaddC p c : + size (p * 'X + c%:P) = (if (p == 0) && (c == 0) then 0%N else (size p).+1). +Proof. by rewrite -cons_poly_def size_cons_poly nil_poly. Qed. + +Lemma polyseqMX p : p != 0 -> p * 'X = 0 :: p :> seq R. +Proof. +by move=> nz_p; rewrite -[p * _]addr0 -cons_poly_def polyseq_cons nil_poly nz_p. +Qed. + +Lemma size_mulX p : p != 0 -> size (p * 'X) = (size p).+1. +Proof. by move/polyseqMX->. Qed. + +Lemma lead_coefMX p : lead_coef (p * 'X) = lead_coef p. +Proof. +have [-> | nzp] := eqVneq p 0; first by rewrite mul0r. +by rewrite /lead_coef !nth_last polyseqMX. +Qed. + +Lemma size_XmulC a : a != 0 -> size ('X * a%:P) = 2. +Proof. +by move=> nz_a; rewrite -commr_polyX size_mulX ?polyC_eq0 ?size_polyC nz_a. +Qed. + +Local Notation "''X^' n" := ('X ^+ n). + +Lemma coefXn n i : 'X^n`_i = (i == n)%:R. +Proof. +by elim: n i => [|n IHn] [|i]; rewrite ?coef1 // exprS coefXM ?IHn. +Qed. + +Lemma polyseqXn n : 'X^n = rcons (nseq n 0) 1 :> seq R. +Proof. +elim: n => [|n IHn]; rewrite ?polyseq1 // exprSr. +by rewrite polyseqMX -?size_poly_eq0 IHn ?size_rcons. +Qed. + +Lemma size_polyXn n : size 'X^n = n.+1. +Proof. by rewrite polyseqXn size_rcons size_nseq. Qed. + +Lemma commr_polyXn p n : GRing.comm p 'X^n. +Proof. by apply: commrX; exact: commr_polyX. Qed. + +Lemma lead_coefXn n : lead_coef 'X^n = 1. +Proof. by rewrite /lead_coef nth_last polyseqXn last_rcons. Qed. + +Lemma polyseqMXn n p : p != 0 -> p * 'X^n = ncons n 0 p :> seq R. +Proof. +case: n => [|n] nz_p; first by rewrite mulr1. +elim: n => [|n IHn]; first exact: polyseqMX. +by rewrite exprSr mulrA polyseqMX -?nil_poly IHn. +Qed. + +Lemma coefMXn n p i : (p * 'X^n)`_i = if i < n then 0 else p`_(i - n). +Proof. +have [-> | /polyseqMXn->] := eqVneq p 0; last exact: nth_ncons. +by rewrite mul0r !coef0 if_same. +Qed. + +Lemma coefXnM n p i : ('X^n * p)`_i = if i < n then 0 else p`_(i - n). +Proof. by rewrite -commr_polyXn coefMXn. Qed. + +(* Expansion of a polynomial as an indexed sum *) +Lemma poly_def n E : \poly_(i < n) E i = \sum_(i < n) E i *: 'X^i. +Proof. +rewrite unlock; elim: n => [|n IHn] in E *; first by rewrite big_ord0. +rewrite big_ord_recl /= cons_poly_def addrC expr0 alg_polyC. +congr (_ + _); rewrite (iota_addl 1 0) -map_comp IHn big_distrl /=. +by apply: eq_bigr => i _; rewrite -scalerAl exprSr. +Qed. + +(* Monic predicate *) +Definition monic := [qualify p | lead_coef p == 1]. +Fact monic_key : pred_key monic. Proof. by []. Qed. +Canonical monic_keyed := KeyedQualifier monic_key. + +Lemma monicE p : (p \is monic) = (lead_coef p == 1). Proof. by []. Qed. +Lemma monicP p : reflect (lead_coef p = 1) (p \is monic). +Proof. exact: eqP. Qed. + +Lemma monic1 : 1 \is monic. Proof. exact/eqP/lead_coef1. Qed. +Lemma monicX : 'X \is monic. Proof. exact/eqP/lead_coefX. Qed. +Lemma monicXn n : 'X^n \is monic. Proof. exact/eqP/lead_coefXn. Qed. + +Lemma monic_neq0 p : p \is monic -> p != 0. +Proof. by rewrite -lead_coef_eq0 => /eqP->; exact: oner_neq0. Qed. + +Lemma lead_coef_monicM p q : p \is monic -> lead_coef (p * q) = lead_coef q. +Proof. +have [-> | nz_q] := eqVneq q 0; first by rewrite mulr0. +by move/monicP=> mon_p; rewrite lead_coef_proper_mul mon_p mul1r ?lead_coef_eq0. +Qed. + +Lemma lead_coef_Mmonic p q : q \is monic -> lead_coef (p * q) = lead_coef p. +Proof. +have [-> | nz_p] := eqVneq p 0; first by rewrite mul0r. +by move/monicP=> mon_q; rewrite lead_coef_proper_mul mon_q mulr1 ?lead_coef_eq0. +Qed. + +Lemma size_monicM p q : + p \is monic -> q != 0 -> size (p * q) = (size p + size q).-1. +Proof. +move/monicP=> mon_p nz_q. +by rewrite size_proper_mul // mon_p mul1r lead_coef_eq0. +Qed. + +Lemma size_Mmonic p q : + p != 0 -> q \is monic -> size (p * q) = (size p + size q).-1. +Proof. +move=> nz_p /monicP mon_q. +by rewrite size_proper_mul // mon_q mulr1 lead_coef_eq0. +Qed. + +Lemma monicMl p q : p \is monic -> (p * q \is monic) = (q \is monic). +Proof. by move=> mon_p; rewrite !monicE lead_coef_monicM. Qed. + +Lemma monicMr p q : q \is monic -> (p * q \is monic) = (p \is monic). +Proof. by move=> mon_q; rewrite !monicE lead_coef_Mmonic. Qed. + +Fact monic_mulr_closed : mulr_closed monic. +Proof. by split=> [|p q mon_p]; rewrite (monic1, monicMl). Qed. +Canonical monic_mulrPred := MulrPred monic_mulr_closed. + +Lemma monic_exp p n : p \is monic -> p ^+ n \is monic. +Proof. exact: rpredX. Qed. + +Lemma monic_prod I rI (P : pred I) (F : I -> {poly R}): + (forall i, P i -> F i \is monic) -> \prod_(i <- rI | P i) F i \is monic. +Proof. exact: rpred_prod. Qed. + +Lemma monicXsubC c : 'X - c%:P \is monic. +Proof. exact/eqP/lead_coefXsubC. Qed. + +Lemma monic_prod_XsubC I rI (P : pred I) (F : I -> R) : + \prod_(i <- rI | P i) ('X - (F i)%:P) \is monic. +Proof. by apply: monic_prod => i _; exact: monicXsubC. Qed. + +Lemma size_prod_XsubC I rI (F : I -> R) : + size (\prod_(i <- rI) ('X - (F i)%:P)) = (size rI).+1. +Proof. +elim: rI => [|i r /= <-]; rewrite ?big_nil ?size_poly1 // big_cons. +rewrite size_monicM ?monicXsubC ?monic_neq0 ?monic_prod_XsubC //. +by rewrite size_XsubC. +Qed. + +Lemma size_exp_XsubC n a : size (('X - a%:P) ^+ n) = n.+1. +Proof. by rewrite -[n]card_ord -prodr_const size_prod_XsubC cardE enumT. Qed. + +(* Some facts about regular elements. *) + +Lemma lreg_lead p : GRing.lreg (lead_coef p) -> GRing.lreg p. +Proof. +move/mulrI_eq0=> reg_p; apply: mulrI0_lreg => q /eqP; apply: contraTeq => nz_q. +by rewrite -lead_coef_eq0 lead_coef_proper_mul reg_p lead_coef_eq0. +Qed. + +Lemma rreg_lead p : GRing.rreg (lead_coef p) -> GRing.rreg p. +Proof. +move/mulIr_eq0=> reg_p; apply: mulIr0_rreg => q /eqP; apply: contraTeq => nz_q. +by rewrite -lead_coef_eq0 lead_coef_proper_mul reg_p lead_coef_eq0. +Qed. + +Lemma lreg_lead0 p : GRing.lreg (lead_coef p) -> p != 0. +Proof. by move/lreg_neq0; rewrite lead_coef_eq0. Qed. + +Lemma rreg_lead0 p : GRing.rreg (lead_coef p) -> p != 0. +Proof. by move/rreg_neq0; rewrite lead_coef_eq0. Qed. + +Lemma lreg_size c p : GRing.lreg c -> size (c *: p) = size p. +Proof. +move=> reg_c; have [-> | nz_p] := eqVneq p 0; first by rewrite scaler0. +rewrite -mul_polyC size_proper_mul; first by rewrite size_polyC lreg_neq0. +by rewrite lead_coefC mulrI_eq0 ?lead_coef_eq0. +Qed. + +Lemma lreg_polyZ_eq0 c p : GRing.lreg c -> (c *: p == 0) = (p == 0). +Proof. by rewrite -!size_poly_eq0 => /lreg_size->. Qed. + +Lemma lead_coef_lreg c p : + GRing.lreg c -> lead_coef (c *: p) = c * lead_coef p. +Proof. by move=> reg_c; rewrite !lead_coefE coefZ lreg_size. Qed. + +Lemma rreg_size c p : GRing.rreg c -> size (p * c%:P) = size p. +Proof. +move=> reg_c; have [-> | nz_p] := eqVneq p 0; first by rewrite mul0r. +rewrite size_proper_mul; first by rewrite size_polyC rreg_neq0 ?addn1. +by rewrite lead_coefC mulIr_eq0 ?lead_coef_eq0. +Qed. + +Lemma rreg_polyMC_eq0 c p : GRing.rreg c -> (p * c%:P == 0) = (p == 0). +Proof. by rewrite -!size_poly_eq0 => /rreg_size->. Qed. + +Lemma rreg_div0 q r d : + GRing.rreg (lead_coef d) -> size r < size d -> + (q * d + r == 0) = (q == 0) && (r == 0). +Proof. +move=> reg_d lt_r_d; rewrite addrC addr_eq0. +have [-> | nz_q] := altP (q =P 0); first by rewrite mul0r oppr0. +apply: contraTF lt_r_d => /eqP->; rewrite -leqNgt size_opp. +rewrite size_proper_mul ?mulIr_eq0 ?lead_coef_eq0 //. +by rewrite (polySpred nz_q) leq_addl. +Qed. + +Lemma monic_comreg p : + p \is monic -> GRing.comm p (lead_coef p)%:P /\ GRing.rreg (lead_coef p). +Proof. by move/monicP->; split; [exact: commr1 | exact: rreg1]. Qed. + +(* Horner evaluation of polynomials *) +Implicit Types s rs : seq R. +Fixpoint horner_rec s x := if s is a :: s' then horner_rec s' x * x + a else 0. +Definition horner p := horner_rec p. + +Local Notation "p .[ x ]" := (horner p x) : ring_scope. + +Lemma horner0 x : (0 : {poly R}).[x] = 0. +Proof. by rewrite /horner polyseq0. Qed. + +Lemma hornerC c x : (c%:P).[x] = c. +Proof. by rewrite /horner polyseqC; case: eqP; rewrite /= ?simp. Qed. + +Lemma hornerX x : 'X.[x] = x. +Proof. by rewrite /horner polyseqX /= !simp. Qed. + +Lemma horner_cons p c x : (cons_poly c p).[x] = p.[x] * x + c. +Proof. +rewrite /horner polyseq_cons; case: nilP => //= ->. +by rewrite !simp -/(_.[x]) hornerC. +Qed. + +Lemma horner_coef0 p : p.[0] = p`_0. +Proof. by rewrite /horner; case: (p : seq R) => //= c p'; rewrite !simp. Qed. + +Lemma hornerMXaddC p c x : (p * 'X + c%:P).[x] = p.[x] * x + c. +Proof. by rewrite -cons_poly_def horner_cons. Qed. + +Lemma hornerMX p x : (p * 'X).[x] = p.[x] * x. +Proof. by rewrite -[p * 'X]addr0 hornerMXaddC addr0. Qed. + +Lemma horner_Poly s x : (Poly s).[x] = horner_rec s x. +Proof. by elim: s => [|a s /= <-]; rewrite (horner0, horner_cons). Qed. + +Lemma horner_coef p x : p.[x] = \sum_(i < size p) p`_i * x ^+ i. +Proof. +rewrite /horner. +elim: {p}(p : seq R) => /= [|a s ->]; first by rewrite big_ord0. +rewrite big_ord_recl simp addrC big_distrl /=. +by congr (_ + _); apply: eq_bigr => i _; rewrite -mulrA exprSr. +Qed. + +Lemma horner_coef_wide n p x : + size p <= n -> p.[x] = \sum_(i < n) p`_i * x ^+ i. +Proof. +move=> le_p_n. +rewrite horner_coef (big_ord_widen n (fun i => p`_i * x ^+ i)) // big_mkcond. +by apply: eq_bigr => i _; case: ltnP => // le_p_i; rewrite nth_default ?simp. +Qed. + +Lemma horner_poly n E x : (\poly_(i < n) E i).[x] = \sum_(i < n) E i * x ^+ i. +Proof. +rewrite (@horner_coef_wide n) ?size_poly //. +by apply: eq_bigr => i _; rewrite coef_poly ltn_ord. +Qed. + +Lemma hornerN p x : (- p).[x] = - p.[x]. +Proof. +rewrite -[-%R]/opp_poly unlock horner_poly horner_coef -sumrN /=. +by apply: eq_bigr => i _; rewrite mulNr. +Qed. + +Lemma hornerD p q x : (p + q).[x] = p.[x] + q.[x]. +Proof. +rewrite -[+%R]/add_poly unlock horner_poly; set m := maxn _ _. +rewrite !(@horner_coef_wide m) ?leq_max ?leqnn ?orbT // -big_split /=. +by apply: eq_bigr => i _; rewrite -mulrDl. +Qed. + +Lemma hornerXsubC a x : ('X - a%:P).[x] = x - a. +Proof. by rewrite hornerD hornerN hornerC hornerX. Qed. + +Lemma horner_sum I (r : seq I) (P : pred I) F x : + (\sum_(i <- r | P i) F i).[x] = \sum_(i <- r | P i) (F i).[x]. +Proof. by elim/big_rec2: _ => [|i _ p _ <-]; rewrite (horner0, hornerD). Qed. + +Lemma hornerCM a p x : (a%:P * p).[x] = a * p.[x]. +Proof. +elim/poly_ind: p => [|p c IHp]; first by rewrite !(mulr0, horner0). +by rewrite mulrDr mulrA -polyC_mul !hornerMXaddC IHp mulrDr mulrA. +Qed. + +Lemma hornerZ c p x : (c *: p).[x] = c * p.[x]. +Proof. by rewrite -mul_polyC hornerCM. Qed. + +Lemma hornerMn n p x : (p *+ n).[x] = p.[x] *+ n. +Proof. by elim: n => [| n IHn]; rewrite ?horner0 // !mulrS hornerD IHn. Qed. + +Definition comm_coef p x := forall i, p`_i * x = x * p`_i. + +Definition comm_poly p x := x * p.[x] = p.[x] * x. + +Lemma comm_coef_poly p x : comm_coef p x -> comm_poly p x. +Proof. +move=> cpx; rewrite /comm_poly !horner_coef big_distrl big_distrr /=. +by apply: eq_bigr => i _; rewrite /= mulrA -cpx -!mulrA commrX. +Qed. + +Lemma comm_poly0 x : comm_poly 0 x. +Proof. by rewrite /comm_poly !horner0 !simp. Qed. + +Lemma comm_poly1 x : comm_poly 1 x. +Proof. by rewrite /comm_poly !hornerC !simp. Qed. + +Lemma comm_polyX x : comm_poly 'X x. +Proof. by rewrite /comm_poly !hornerX. Qed. + +Lemma hornerM_comm p q x : comm_poly q x -> (p * q).[x] = p.[x] * q.[x]. +Proof. +move=> comm_qx. +elim/poly_ind: p => [|p c IHp]; first by rewrite !(simp, horner0). +rewrite mulrDl hornerD hornerCM -mulrA -commr_polyX mulrA hornerMX. +by rewrite {}IHp -mulrA -comm_qx mulrA -mulrDl hornerMXaddC. +Qed. + +Lemma horner_exp_comm p x n : comm_poly p x -> (p ^+ n).[x] = p.[x] ^+ n. +Proof. +move=> comm_px; elim: n => [|n IHn]; first by rewrite hornerC. +by rewrite !exprSr -IHn hornerM_comm. +Qed. + +Lemma hornerXn x n : ('X^n).[x] = x ^+ n. +Proof. by rewrite horner_exp_comm /comm_poly hornerX. Qed. + +Definition hornerE_comm := + (hornerD, hornerN, hornerX, hornerC, horner_cons, + simp, hornerCM, hornerZ, + (fun p x => hornerM_comm p (comm_polyX x))). + +Definition root p : pred R := fun x => p.[x] == 0. + +Lemma mem_root p x : x \in root p = (p.[x] == 0). +Proof. by []. Qed. + +Lemma rootE p x : (root p x = (p.[x] == 0)) * ((x \in root p) = (p.[x] == 0)). +Proof. by []. Qed. + +Lemma rootP p x : reflect (p.[x] = 0) (root p x). +Proof. exact: eqP. Qed. + +Lemma rootPt p x : reflect (p.[x] == 0) (root p x). +Proof. exact: idP. Qed. + +Lemma rootPf p x : reflect ((p.[x] == 0) = false) (~~ root p x). +Proof. exact: negPf. Qed. + +Lemma rootC a x : root a%:P x = (a == 0). +Proof. by rewrite rootE hornerC. Qed. + +Lemma root0 x : root 0 x. +Proof. by rewrite rootC. Qed. + +Lemma root1 x : ~~ root 1 x. +Proof. by rewrite rootC oner_eq0. Qed. + +Lemma rootX x : root 'X x = (x == 0). +Proof. by rewrite rootE hornerX. Qed. + +Lemma rootN p x : root (- p) x = root p x. +Proof. by rewrite rootE hornerN oppr_eq0. Qed. + +Lemma root_size_gt1 a p : p != 0 -> root p a -> 1 < size p. +Proof. +rewrite ltnNge => nz_p; apply: contraL => /size1_polyC Dp. +by rewrite Dp rootC -polyC_eq0 -Dp. +Qed. + +Lemma root_XsubC a x : root ('X - a%:P) x = (x == a). +Proof. by rewrite rootE hornerXsubC subr_eq0. Qed. + +Lemma root_XaddC a x : root ('X + a%:P) x = (x == - a). +Proof. by rewrite -root_XsubC rmorphN opprK. Qed. + +Theorem factor_theorem p a : reflect (exists q, p = q * ('X - a%:P)) (root p a). +Proof. +apply: (iffP eqP) => [pa0 | [q ->]]; last first. + by rewrite hornerM_comm /comm_poly hornerXsubC subrr ?simp. +exists (\poly_(i < size p) horner_rec (drop i.+1 p) a). +apply/polyP=> i; rewrite mulrBr coefB coefMX coefMC !coef_poly. +apply: canRL (addrK _) _; rewrite addrC; have [le_p_i | lt_i_p] := leqP. + rewrite nth_default // !simp drop_oversize ?if_same //. + exact: leq_trans (leqSpred _). +case: i => [|i] in lt_i_p *; last by rewrite ltnW // (drop_nth 0 lt_i_p). +by rewrite drop1 /= -{}pa0 /horner; case: (p : seq R) lt_i_p. +Qed. + +Lemma multiplicity_XsubC p a : + {m | exists2 q, (p != 0) ==> ~~ root q a & p = q * ('X - a%:P) ^+ m}. +Proof. +elim: {p}(size p) {-2}p (eqxx (size p)) => [|n IHn] p. + by rewrite size_poly_eq0 => ->; exists 0%N, p; rewrite ?mulr1. +have [/sig_eqW[{p}p ->] sz_p | nz_pa] := altP (factor_theorem p a); last first. + by exists 0%N, p; rewrite ?mulr1 ?nz_pa ?implybT. +have nz_p: p != 0 by apply: contraTneq sz_p => ->; rewrite mul0r size_poly0. +rewrite size_Mmonic ?monicXsubC // size_XsubC addn2 eqSS in sz_p. +have [m /sig2_eqW[q nz_qa Dp]] := IHn p sz_p; rewrite nz_p /= in nz_qa. +by exists m.+1, q; rewrite ?nz_qa ?implybT // exprSr mulrA -Dp. +Qed. + +(* Roots of unity. *) + +Lemma size_Xn_sub_1 n : n > 0 -> size ('X^n - 1 : {poly R}) = n.+1. +Proof. +by move=> n_gt0; rewrite size_addl size_polyXn // size_opp size_poly1. +Qed. + +Lemma monic_Xn_sub_1 n : n > 0 -> 'X^n - 1 \is monic. +Proof. +move=> n_gt0; rewrite monicE lead_coefE size_Xn_sub_1 // coefB. +by rewrite coefXn coef1 eqxx eqn0Ngt n_gt0 subr0. +Qed. + +Definition root_of_unity n : pred R := root ('X^n - 1). +Local Notation "n .-unity_root" := (root_of_unity n) : ring_scope. + +Lemma unity_rootE n z : n.-unity_root z = (z ^+ n == 1). +Proof. +by rewrite /root_of_unity rootE hornerD hornerN hornerXn hornerC subr_eq0. +Qed. + +Lemma unity_rootP n z : reflect (z ^+ n = 1) (n.-unity_root z). +Proof. by rewrite unity_rootE; exact: eqP. Qed. + +Definition primitive_root_of_unity n z := + (n > 0) && [forall i : 'I_n, i.+1.-unity_root z == (i.+1 == n)]. +Local Notation "n .-primitive_root" := (primitive_root_of_unity n) : ring_scope. + +Lemma prim_order_exists n z : + n > 0 -> z ^+ n = 1 -> {m | m.-primitive_root z & (m %| n)}. +Proof. +move=> n_gt0 zn1. +have: exists m, (m > 0) && (z ^+ m == 1) by exists n; rewrite n_gt0 /= zn1. +case/ex_minnP=> m /andP[m_gt0 /eqP zm1] m_min. +exists m. + apply/andP; split=> //; apply/eqfunP=> [[i]] /=. + rewrite leq_eqVlt unity_rootE. + case: eqP => [-> _ | _]; first by rewrite zm1 eqxx. + by apply: contraTF => zi1; rewrite -leqNgt m_min. +have: n %% m < m by rewrite ltn_mod. +apply: contraLR; rewrite -lt0n -leqNgt => nm_gt0; apply: m_min. +by rewrite nm_gt0 /= expr_mod ?zn1. +Qed. + +Section OnePrimitive. + +Variables (n : nat) (z : R). +Hypothesis prim_z : n.-primitive_root z. + +Lemma prim_order_gt0 : n > 0. Proof. by case/andP: prim_z. Qed. +Let n_gt0 := prim_order_gt0. + +Lemma prim_expr_order : z ^+ n = 1. +Proof. +case/andP: prim_z => _; rewrite -(prednK n_gt0) => /forallP/(_ ord_max). +by rewrite unity_rootE eqxx eqb_id => /eqP. +Qed. + +Lemma prim_expr_mod i : z ^+ (i %% n) = z ^+ i. +Proof. exact: expr_mod prim_expr_order. Qed. + +Lemma prim_order_dvd i : (n %| i) = (z ^+ i == 1). +Proof. +move: n_gt0; rewrite -prim_expr_mod /dvdn -(ltn_mod i). +case: {i}(i %% n)%N => [|i] lt_i; first by rewrite !eqxx. +case/andP: prim_z => _ /forallP/(_ (Ordinal (ltnW lt_i))). +by move/eqP; rewrite unity_rootE eqn_leq andbC leqNgt lt_i. +Qed. + +Lemma eq_prim_root_expr i j : (z ^+ i == z ^+ j) = (i == j %[mod n]). +Proof. +wlog le_ji: i j / j <= i. + move=> IH; case: (leqP j i); last move/ltnW; move/IH=> //. + by rewrite eq_sym (eq_sym (j %% n)%N). +rewrite -{1}(subnKC le_ji) exprD -prim_expr_mod eqn_mod_dvd //. +rewrite prim_order_dvd; apply/eqP/eqP=> [|->]; last by rewrite mulr1. +move/(congr1 ( *%R (z ^+ (n - j %% n)))); rewrite mulrA -exprD. +by rewrite subnK ?prim_expr_order ?mul1r // ltnW ?ltn_mod. +Qed. + +Lemma exp_prim_root k : (n %/ gcdn k n).-primitive_root (z ^+ k). +Proof. +set d := gcdn k n; have d_gt0: (0 < d)%N by rewrite gcdn_gt0 orbC n_gt0. +have [d_dv_k d_dv_n]: (d %| k /\ d %| n)%N by rewrite dvdn_gcdl dvdn_gcdr. +set q := (n %/ d)%N; rewrite /q.-primitive_root ltn_divRL // n_gt0. +apply/forallP=> i; rewrite unity_rootE -exprM -prim_order_dvd. +rewrite -(divnK d_dv_n) -/q -(divnK d_dv_k) mulnAC dvdn_pmul2r //. +apply/eqP; apply/idP/idP=> [|/eqP->]; last by rewrite dvdn_mull. +rewrite Gauss_dvdr; first by rewrite eqn_leq ltn_ord; exact: dvdn_leq. +by rewrite /coprime gcdnC -(eqn_pmul2r d_gt0) mul1n muln_gcdl !divnK. +Qed. + +Lemma dvdn_prim_root m : (m %| n)%N -> m.-primitive_root (z ^+ (n %/ m)). +Proof. +set k := (n %/ m)%N => m_dv_n; rewrite -{1}(mulKn m n_gt0) -divnA // -/k. +by rewrite -{1}(@gcdn_idPl k n _) ?exp_prim_root // -(divnK m_dv_n) dvdn_mulr. +Qed. + +End OnePrimitive. + +Lemma prim_root_exp_coprime n z k : + n.-primitive_root z -> n.-primitive_root (z ^+ k) = coprime k n. +Proof. +move=> prim_z;have n_gt0 := prim_order_gt0 prim_z. +apply/idP/idP=> [prim_zk | co_k_n]. + set d := gcdn k n; have dv_d_n: (d %| n)%N := dvdn_gcdr _ _. + rewrite /coprime -/d -(eqn_pmul2r n_gt0) mul1n -{2}(gcdnMl n d). + rewrite -{2}(divnK dv_d_n) (mulnC _ d) -muln_gcdr (gcdn_idPr _) //. + rewrite (prim_order_dvd prim_zk) -exprM -(prim_order_dvd prim_z). + by rewrite muln_divCA_gcd dvdn_mulr. +have zkn_1: z ^+ k ^+ n = 1 by rewrite exprAC (prim_expr_order prim_z) expr1n. +have{zkn_1} [m prim_zk dv_m_n]:= prim_order_exists n_gt0 zkn_1. +suffices /eqP <-: m == n by []. +rewrite eqn_dvd dv_m_n -(@Gauss_dvdr n k m) 1?coprime_sym //=. +by rewrite (prim_order_dvd prim_z) exprM (prim_expr_order prim_zk). +Qed. + +(* Lifting a ring predicate to polynomials. *) + +Definition polyOver (S : pred_class) := + [qualify a p : {poly R} | all (mem S) p]. + +Fact polyOver_key S : pred_key (polyOver S). Proof. by []. Qed. +Canonical polyOver_keyed S := KeyedQualifier (polyOver_key S). + +Lemma polyOverS (S1 S2 : pred_class) : + {subset S1 <= S2} -> {subset polyOver S1 <= polyOver S2}. +Proof. +by move=> sS12 p /(all_nthP 0)S1p; apply/(all_nthP 0)=> i /S1p; apply: sS12. +Qed. + +Lemma polyOver0 S : 0 \is a polyOver S. +Proof. by rewrite qualifE polyseq0. Qed. + +Lemma polyOver_poly (S : pred_class) n E : + (forall i, i < n -> E i \in S) -> \poly_(i < n) E i \is a polyOver S. +Proof. +move=> S_E; apply/(all_nthP 0)=> i lt_i_p /=; rewrite coef_poly. +by case: ifP => [/S_E// | /idP[]]; apply: leq_trans lt_i_p (size_poly n E). +Qed. + +Section PolyOverAdd. + +Variables (S : predPredType R) (addS : addrPred S) (kS : keyed_pred addS). + +Lemma polyOverP {p} : reflect (forall i, p`_i \in kS) (p \in polyOver kS). +Proof. +apply: (iffP (all_nthP 0)) => [Sp i | Sp i _]; last exact: Sp. +by have [/Sp // | /(nth_default 0)->] := ltnP i (size p); apply: rpred0. +Qed. + +Lemma polyOverC c : (c%:P \in polyOver kS) = (c \in kS). +Proof. +by rewrite qualifE polyseqC; case: eqP => [->|] /=; rewrite ?andbT ?rpred0. +Qed. + +Fact polyOver_addr_closed : addr_closed (polyOver kS). +Proof. +split=> [|p q Sp Sq]; first exact: polyOver0. +by apply/polyOverP=> i; rewrite coefD rpredD ?(polyOverP _). +Qed. +Canonical polyOver_addrPred := AddrPred polyOver_addr_closed. + +End PolyOverAdd. + +Fact polyOverNr S (addS : zmodPred S) (kS : keyed_pred addS) : + oppr_closed (polyOver kS). +Proof. +by move=> p /polyOverP Sp; apply/polyOverP=> i; rewrite coefN rpredN. +Qed. +Canonical polyOver_opprPred S addS kS := OpprPred (@polyOverNr S addS kS). +Canonical polyOver_zmodPred S addS kS := ZmodPred (@polyOverNr S addS kS). + +Section PolyOverSemiring. + +Context (S : pred_class) (ringS : @semiringPred R S) (kS : keyed_pred ringS). + +Fact polyOver_mulr_closed : mulr_closed (polyOver kS). +Proof. +split=> [|p q /polyOverP Sp /polyOverP Sq]; first by rewrite polyOverC rpred1. +by apply/polyOverP=> i; rewrite coefM rpred_sum // => j _; apply: rpredM. +Qed. +Canonical polyOver_mulrPred := MulrPred polyOver_mulr_closed. +Canonical polyOver_semiringPred := SemiringPred polyOver_mulr_closed. + +Lemma polyOverZ : {in kS & polyOver kS, forall c p, c *: p \is a polyOver kS}. +Proof. +by move=> c p Sc /polyOverP Sp; apply/polyOverP=> i; rewrite coefZ rpredM ?Sp. +Qed. + +Lemma polyOverX : 'X \in polyOver kS. +Proof. by rewrite qualifE polyseqX /= rpred0 rpred1. Qed. + +Lemma rpred_horner : {in polyOver kS & kS, forall p x, p.[x] \in kS}. +Proof. +move=> p x /polyOverP Sp Sx; rewrite horner_coef rpred_sum // => i _. +by rewrite rpredM ?rpredX. +Qed. + +End PolyOverSemiring. + +Section PolyOverRing. + +Context (S : pred_class) (ringS : @subringPred R S) (kS : keyed_pred ringS). +Canonical polyOver_smulrPred := SmulrPred (polyOver_mulr_closed kS). +Canonical polyOver_subringPred := SubringPred (polyOver_mulr_closed kS). + +Lemma polyOverXsubC c : ('X - c%:P \in polyOver kS) = (c \in kS). +Proof. by rewrite rpredBl ?polyOverX ?polyOverC. Qed. + +End PolyOverRing. + +(* Single derivative. *) + +Definition deriv p := \poly_(i < (size p).-1) (p`_i.+1 *+ i.+1). + +Local Notation "a ^` ()" := (deriv a). + +Lemma coef_deriv p i : p^`()`_i = p`_i.+1 *+ i.+1. +Proof. +rewrite coef_poly -subn1 ltn_subRL. +by case: leqP => // /(nth_default 0) ->; rewrite mul0rn. +Qed. + +Lemma polyOver_deriv S (ringS : semiringPred S) (kS : keyed_pred ringS) : + {in polyOver kS, forall p, p^`() \is a polyOver kS}. +Proof. +by move=> p /polyOverP Kp; apply/polyOverP=> i; rewrite coef_deriv rpredMn ?Kp. +Qed. + +Lemma derivC c : c%:P^`() = 0. +Proof. by apply/polyP=> i; rewrite coef_deriv coef0 coefC mul0rn. Qed. + +Lemma derivX : ('X)^`() = 1. +Proof. by apply/polyP=> [[|i]]; rewrite coef_deriv coef1 coefX ?mul0rn. Qed. + +Lemma derivXn n : 'X^n^`() = 'X^n.-1 *+ n. +Proof. +case: n => [|n]; first exact: derivC. +apply/polyP=> i; rewrite coef_deriv coefMn !coefXn eqSS. +by case: eqP => [-> // | _]; rewrite !mul0rn. +Qed. + +Fact deriv_is_linear : linear deriv. +Proof. +move=> k p q; apply/polyP=> i. +by rewrite !(coef_deriv, coefD, coefZ) mulrnDl mulrnAr. +Qed. +Canonical deriv_additive := Additive deriv_is_linear. +Canonical deriv_linear := Linear deriv_is_linear. + +Lemma deriv0 : 0^`() = 0. +Proof. exact: linear0. Qed. + +Lemma derivD : {morph deriv : p q / p + q}. +Proof. exact: linearD. Qed. + +Lemma derivN : {morph deriv : p / - p}. +Proof. exact: linearN. Qed. + +Lemma derivB : {morph deriv : p q / p - q}. +Proof. exact: linearB. Qed. + +Lemma derivXsubC (a : R) : ('X - a%:P)^`() = 1. +Proof. by rewrite derivB derivX derivC subr0. Qed. + +Lemma derivMn n p : (p *+ n)^`() = p^`() *+ n. +Proof. exact: linearMn. Qed. + +Lemma derivMNn n p : (p *- n)^`() = p^`() *- n. +Proof. exact: linearMNn. Qed. + +Lemma derivZ c p : (c *: p)^`() = c *: p^`(). +Proof. by rewrite linearZ. Qed. + +Lemma deriv_mulC c p : (c%:P * p)^`() = c%:P * p^`(). +Proof. by rewrite !mul_polyC derivZ. Qed. + +Lemma derivMXaddC p c : (p * 'X + c%:P)^`() = p + p^`() * 'X. +Proof. +apply/polyP=> i; rewrite raddfD /= derivC addr0 coefD !(coefMX, coef_deriv). +by case: i; rewrite ?addr0. +Qed. + +Lemma derivM p q : (p * q)^`() = p^`() * q + p * q^`(). +Proof. +elim/poly_ind: p => [|p b IHp]; first by rewrite !(mul0r, add0r, derivC). +rewrite mulrDl -mulrA -commr_polyX mulrA -[_ * 'X]addr0 raddfD /= !derivMXaddC. +by rewrite deriv_mulC IHp !mulrDl -!mulrA !commr_polyX !addrA. +Qed. + +Definition derivE := Eval lazy beta delta [morphism_2 morphism_1] in + (derivZ, deriv_mulC, derivC, derivX, derivMXaddC, derivXsubC, derivM, derivB, + derivD, derivN, derivXn, derivM, derivMn). + +(* Iterated derivative. *) +Definition derivn n p := iter n deriv p. + +Local Notation "a ^` ( n )" := (derivn n a) : ring_scope. + +Lemma derivn0 p : p^`(0) = p. +Proof. by []. Qed. + +Lemma derivn1 p : p^`(1) = p^`(). +Proof. by []. Qed. + +Lemma derivnS p n : p^`(n.+1) = p^`(n)^`(). +Proof. by []. Qed. + +Lemma derivSn p n : p^`(n.+1) = p^`()^`(n). +Proof. exact: iterSr. Qed. + +Lemma coef_derivn n p i : p^`(n)`_i = p`_(n + i) *+ (n + i) ^_ n. +Proof. +elim: n i => [|n IHn] i; first by rewrite ffactn0 mulr1n. +by rewrite derivnS coef_deriv IHn -mulrnA ffactnSr addSnnS addKn. +Qed. + +Lemma polyOver_derivn S (ringS : semiringPred S) (kS : keyed_pred ringS) : + {in polyOver kS, forall p n, p^`(n) \is a polyOver kS}. +Proof. +move=> p /polyOverP Kp /= n; apply/polyOverP=> i. +by rewrite coef_derivn rpredMn. +Qed. + +Fact derivn_is_linear n : linear (derivn n). +Proof. by elim: n => // n IHn a p q; rewrite derivnS IHn linearP. Qed. +Canonical derivn_additive n := Additive (derivn_is_linear n). +Canonical derivn_linear n := Linear (derivn_is_linear n). + +Lemma derivnC c n : c%:P^`(n) = if n == 0%N then c%:P else 0. +Proof. by case: n => // n; rewrite derivSn derivC linear0. Qed. + +Lemma derivnD n : {morph derivn n : p q / p + q}. +Proof. exact: linearD. Qed. + +Lemma derivn_sub n : {morph derivn n : p q / p - q}. +Proof. exact: linearB. Qed. + +Lemma derivnMn n m p : (p *+ m)^`(n) = p^`(n) *+ m. +Proof. exact: linearMn. Qed. + +Lemma derivnMNn n m p : (p *- m)^`(n) = p^`(n) *- m. +Proof. exact: linearMNn. Qed. + +Lemma derivnN n : {morph derivn n : p / - p}. +Proof. exact: linearN. Qed. + +Lemma derivnZ n : scalable (derivn n). +Proof. exact: linearZZ. Qed. + +Lemma derivnXn m n : 'X^m^`(n) = 'X^(m - n) *+ m ^_ n. +Proof. +apply/polyP=>i; rewrite coef_derivn coefMn !coefXn. +case: (ltnP m n) => [lt_m_n | le_m_n]. + by rewrite eqn_leq leqNgt ltn_addr // mul0rn ffact_small. +by rewrite -{1 3}(subnKC le_m_n) eqn_add2l; case: eqP => [->|]; rewrite ?mul0rn. +Qed. + +Lemma derivnMXaddC n p c : + (p * 'X + c%:P)^`(n.+1) = p^`(n) *+ n.+1 + p^`(n.+1) * 'X. +Proof. +elim: n => [|n IHn]; first by rewrite derivn1 derivMXaddC. +rewrite derivnS IHn derivD derivM derivX mulr1 derivMn -!derivnS. +by rewrite addrA addrAC -mulrSr. +Qed. + +Lemma derivn_poly0 p n : size p <= n -> p^`(n) = 0. +Proof. +move=> le_p_n; apply/polyP=> i; rewrite coef_derivn. +rewrite nth_default; first by rewrite mul0rn coef0. +by apply: leq_trans le_p_n _; apply leq_addr. +Qed. + +Lemma lt_size_deriv (p : {poly R}) : p != 0 -> size p^`() < size p. +Proof. by move=> /polySpred->; exact: size_poly. Qed. + +(* A normalising version of derivation to get the division by n! in Taylor *) + +Definition nderivn n p := \poly_(i < size p - n) (p`_(n + i) *+ 'C(n + i, n)). + +Local Notation "a ^`N ( n )" := (nderivn n a) : ring_scope. + +Lemma coef_nderivn n p i : p^`N(n)`_i = p`_(n + i) *+ 'C(n + i, n). +Proof. +rewrite coef_poly ltn_subRL; case: leqP => // le_p_ni. +by rewrite nth_default ?mul0rn. +Qed. + +(* Here is the division by n! *) +Lemma nderivn_def n p : p^`(n) = p^`N(n) *+ n`!. +Proof. +by apply/polyP=> i; rewrite coefMn coef_nderivn coef_derivn -mulrnA bin_ffact. +Qed. + +Lemma polyOver_nderivn S (ringS : semiringPred S) (kS : keyed_pred ringS) : + {in polyOver kS, forall p n, p^`N(n) \in polyOver kS}. +Proof. +move=> p /polyOverP Sp /= n; apply/polyOverP=> i. +by rewrite coef_nderivn rpredMn. +Qed. + +Lemma nderivn0 p : p^`N(0) = p. +Proof. by rewrite -[p^`N(0)](nderivn_def 0). Qed. + +Lemma nderivn1 p : p^`N(1) = p^`(). +Proof. by rewrite -[p^`N(1)](nderivn_def 1). Qed. + +Lemma nderivnC c n : (c%:P)^`N(n) = if n == 0%N then c%:P else 0. +Proof. +apply/polyP=> i; rewrite coef_nderivn. +by case: n => [|n]; rewrite ?bin0 // coef0 coefC mul0rn. +Qed. + +Lemma nderivnXn m n : 'X^m^`N(n) = 'X^(m - n) *+ 'C(m, n). +Proof. +apply/polyP=> i; rewrite coef_nderivn coefMn !coefXn. +have [lt_m_n | le_n_m] := ltnP m n. + by rewrite eqn_leq leqNgt ltn_addr // mul0rn bin_small. +by rewrite -{1 3}(subnKC le_n_m) eqn_add2l; case: eqP => [->|]; rewrite ?mul0rn. +Qed. + +Fact nderivn_is_linear n : linear (nderivn n). +Proof. +move=> k p q; apply/polyP=> i. +by rewrite !(coef_nderivn, coefD, coefZ) mulrnDl mulrnAr. +Qed. +Canonical nderivn_additive n := Additive(nderivn_is_linear n). +Canonical nderivn_linear n := Linear (nderivn_is_linear n). + +Lemma nderivnD n : {morph nderivn n : p q / p + q}. +Proof. exact: linearD. Qed. + +Lemma nderivnB n : {morph nderivn n : p q / p - q}. +Proof. exact: linearB. Qed. + +Lemma nderivnMn n m p : (p *+ m)^`N(n) = p^`N(n) *+ m. +Proof. exact: linearMn. Qed. + +Lemma nderivnMNn n m p : (p *- m)^`N(n) = p^`N(n) *- m. +Proof. exact: linearMNn. Qed. + +Lemma nderivnN n : {morph nderivn n : p / - p}. +Proof. exact: linearN. Qed. + +Lemma nderivnZ n : scalable (nderivn n). +Proof. exact: linearZZ. Qed. + +Lemma nderivnMXaddC n p c : + (p * 'X + c%:P)^`N(n.+1) = p^`N(n) + p^`N(n.+1) * 'X. +Proof. +apply/polyP=> i; rewrite coef_nderivn !coefD !coefMX coefC. +rewrite !addSn /= !coef_nderivn addr0 binS mulrnDr addrC; congr (_ + _). +by rewrite addSnnS; case: i; rewrite // addn0 bin_small. +Qed. + +Lemma nderivn_poly0 p n : size p <= n -> p^`N(n) = 0. +Proof. +move=> le_p_n; apply/polyP=> i; rewrite coef_nderivn. +rewrite nth_default; first by rewrite mul0rn coef0. +by apply: leq_trans le_p_n _; apply leq_addr. +Qed. + +Lemma nderiv_taylor p x h : + GRing.comm x h -> p.[x + h] = \sum_(i < size p) p^`N(i).[x] * h ^+ i. +Proof. +move/commrX=> cxh; elim/poly_ind: p => [|p c IHp]. + by rewrite size_poly0 big_ord0 horner0. +rewrite hornerMXaddC size_MXaddC. +have [-> | nz_p] := altP (p =P 0). + rewrite horner0 !simp; have [-> | _] := c =P 0; first by rewrite big_ord0. + by rewrite size_poly0 big_ord_recl big_ord0 nderivn0 hornerC !simp. +rewrite big_ord_recl nderivn0 !simp hornerMXaddC addrAC; congr (_ + _). +rewrite mulrDr {}IHp !big_distrl polySpred //= big_ord_recl /= mulr1 -addrA. +rewrite nderivn0 /bump /(addn 1) /=; congr (_ + _). +rewrite !big_ord_recr /= nderivnMXaddC -mulrA -exprSr -polySpred // !addrA. +congr (_ + _); last by rewrite (nderivn_poly0 (leqnn _)) !simp. +rewrite addrC -big_split /=; apply: eq_bigr => i _. +by rewrite nderivnMXaddC !hornerE_comm /= mulrDl -!mulrA -exprSr cxh. +Qed. + +Lemma nderiv_taylor_wide n p x h : + GRing.comm x h -> size p <= n -> + p.[x + h] = \sum_(i < n) p^`N(i).[x] * h ^+ i. +Proof. +move/nderiv_taylor=> -> le_p_n. +rewrite (big_ord_widen n (fun i => p^`N(i).[x] * h ^+ i)) // big_mkcond. +apply: eq_bigr => i _; case: leqP => // /nderivn_poly0->. +by rewrite horner0 simp. +Qed. + +End PolynomialTheory. + +Prenex Implicits polyC Poly lead_coef root horner polyOver. +Implicit Arguments monic [[R]]. +Notation "\poly_ ( i < n ) E" := (poly n (fun i => E)) : ring_scope. +Notation "c %:P" := (polyC c) : ring_scope. +Notation "'X" := (polyX _) : ring_scope. +Notation "''X^' n" := ('X ^+ n) : ring_scope. +Notation "p .[ x ]" := (horner p x) : ring_scope. +Notation "n .-unity_root" := (root_of_unity n) : ring_scope. +Notation "n .-primitive_root" := (primitive_root_of_unity n) : ring_scope. +Notation "a ^` ()" := (deriv a) : ring_scope. +Notation "a ^` ( n )" := (derivn n a) : ring_scope. +Notation "a ^`N ( n )" := (nderivn n a) : ring_scope. + +Implicit Arguments monicP [R p]. +Implicit Arguments rootP [R p x]. +Implicit Arguments rootPf [R p x]. +Implicit Arguments rootPt [R p x]. +Implicit Arguments unity_rootP [R n z]. +Implicit Arguments polyOverP [[R] [S0] [addS] [kS] [p]]. + +(* Container morphism. *) +Section MapPoly. + +Section Definitions. + +Variables (aR rR : ringType) (f : aR -> rR). + +Definition map_poly (p : {poly aR}) := \poly_(i < size p) f p`_i. + +(* Alternative definition; the one above is more convenient because it lets *) +(* us use the lemmas on \poly, e.g., size (map_poly p) <= size p is an *) +(* instance of size_poly. *) +Lemma map_polyE p : map_poly p = Poly (map f p). +Proof. +rewrite /map_poly unlock; congr Poly. +apply: (@eq_from_nth _ 0); rewrite size_mkseq ?size_map // => i lt_i_p. +by rewrite (nth_map 0) ?nth_mkseq. +Qed. + +Definition commr_rmorph u := forall x, GRing.comm u (f x). + +Definition horner_morph u of commr_rmorph u := fun p => (map_poly p).[u]. + +End Definitions. + +Variables aR rR : ringType. + +Section Combinatorial. + +Variables (iR : ringType) (f : aR -> rR). +Local Notation "p ^f" := (map_poly f p) : ring_scope. + +Lemma map_poly0 : 0^f = 0. +Proof. by rewrite map_polyE polyseq0. Qed. + +Lemma eq_map_poly (g : aR -> rR) : f =1 g -> map_poly f =1 map_poly g. +Proof. by move=> eq_fg p; rewrite !map_polyE (eq_map eq_fg). Qed. + +Lemma map_poly_id g (p : {poly iR}) : + {in (p : seq iR), g =1 id} -> map_poly g p = p. +Proof. by move=> g_id; rewrite map_polyE map_id_in ?polyseqK. Qed. + +Lemma coef_map_id0 p i : f 0 = 0 -> (p^f)`_i = f p`_i. +Proof. +by move=> f0; rewrite coef_poly; case: ltnP => // le_p_i; rewrite nth_default. +Qed. + +Lemma map_Poly_id0 s : f 0 = 0 -> (Poly s)^f = Poly (map f s). +Proof. +move=> f0; apply/polyP=> j; rewrite coef_map_id0 ?coef_Poly //. +have [/(nth_map 0 0)->// | le_s_j] := ltnP j (size s). +by rewrite !nth_default ?size_map. +Qed. + +Lemma map_poly_comp_id0 (g : iR -> aR) p : + f 0 = 0 -> map_poly (f \o g) p = (map_poly g p)^f. +Proof. by move=> f0; rewrite map_polyE map_comp -map_Poly_id0 -?map_polyE. Qed. + +Lemma size_map_poly_id0 p : f (lead_coef p) != 0 -> size p^f = size p. +Proof. by move=> nz_fp; apply: size_poly_eq. Qed. + +Lemma map_poly_eq0_id0 p : f (lead_coef p) != 0 -> (p^f == 0) = (p == 0). +Proof. by rewrite -!size_poly_eq0 => /size_map_poly_id0->. Qed. + +Lemma lead_coef_map_id0 p : + f 0 = 0 -> f (lead_coef p) != 0 -> lead_coef p^f = f (lead_coef p). +Proof. +by move=> f0 nz_fp; rewrite lead_coefE coef_map_id0 ?size_map_poly_id0. +Qed. + +Hypotheses (inj_f : injective f) (f_0 : f 0 = 0). + +Lemma size_map_inj_poly p : size p^f = size p. +Proof. +have [-> | nz_p] := eqVneq p 0; first by rewrite map_poly0 !size_poly0. +by rewrite size_map_poly_id0 // -f_0 (inj_eq inj_f) lead_coef_eq0. +Qed. + +Lemma map_inj_poly : injective (map_poly f). +Proof. +move=> p q /polyP eq_pq; apply/polyP=> i; apply: inj_f. +by rewrite -!coef_map_id0 ?eq_pq. +Qed. + +Lemma lead_coef_map_inj p : lead_coef p^f = f (lead_coef p). +Proof. by rewrite !lead_coefE size_map_inj_poly coef_map_id0. Qed. + +End Combinatorial. + +Lemma map_polyK (f : aR -> rR) g : + cancel g f -> f 0 = 0 -> cancel (map_poly g) (map_poly f). +Proof. +by move=> gK f_0 p; rewrite /= -map_poly_comp_id0 ?map_poly_id // => x _ //=. +Qed. + +Section Additive. + +Variables (iR : ringType) (f : {additive aR -> rR}). + +Local Notation "p ^f" := (map_poly (GRing.Additive.apply f) p) : ring_scope. + +Lemma coef_map p i : p^f`_i = f p`_i. +Proof. exact: coef_map_id0 (raddf0 f). Qed. + +Lemma map_Poly s : (Poly s)^f = Poly (map f s). +Proof. exact: map_Poly_id0 (raddf0 f). Qed. + +Lemma map_poly_comp (g : iR -> aR) p : + map_poly (f \o g) p = map_poly f (map_poly g p). +Proof. exact: map_poly_comp_id0 (raddf0 f). Qed. + +Fact map_poly_is_additive : additive (map_poly f). +Proof. by move=> p q; apply/polyP=> i; rewrite !(coef_map, coefB) raddfB. Qed. +Canonical map_poly_additive := Additive map_poly_is_additive. + +Lemma map_polyC a : (a%:P)^f = (f a)%:P. +Proof. by apply/polyP=> i; rewrite !(coef_map, coefC) -!mulrb raddfMn. Qed. + +Lemma lead_coef_map_eq p : + f (lead_coef p) != 0 -> lead_coef p^f = f (lead_coef p). +Proof. exact: lead_coef_map_id0 (raddf0 f). Qed. + +End Additive. + +Variable f : {rmorphism aR -> rR}. +Implicit Types p : {poly aR}. + +Local Notation "p ^f" := (map_poly (GRing.RMorphism.apply f) p) : ring_scope. + +Fact map_poly_is_rmorphism : rmorphism (map_poly f). +Proof. +split; first exact: map_poly_is_additive. +split=> [p q|]; apply/polyP=> i; last first. + by rewrite !(coef_map, coef1) /= rmorph_nat. +rewrite coef_map /= !coefM /= !rmorph_sum; apply: eq_bigr => j _. +by rewrite !coef_map rmorphM. +Qed. +Canonical map_poly_rmorphism := RMorphism map_poly_is_rmorphism. + +Lemma map_polyZ c p : (c *: p)^f = f c *: p^f. +Proof. by apply/polyP=> i; rewrite !(coef_map, coefZ) /= rmorphM. Qed. +Canonical map_poly_linear := + AddLinear (map_polyZ : scalable_for (f \; *:%R) (map_poly f)). +Canonical map_poly_lrmorphism := [lrmorphism of map_poly f]. + +Lemma map_polyX : ('X)^f = 'X. +Proof. by apply/polyP=> i; rewrite coef_map !coefX /= rmorph_nat. Qed. + +Lemma map_polyXn n : ('X^n)^f = 'X^n. +Proof. by rewrite rmorphX /= map_polyX. Qed. + +Lemma monic_map p : p \is monic -> p^f \is monic. +Proof. +move/monicP=> mon_p; rewrite monicE. +by rewrite lead_coef_map_eq mon_p /= rmorph1 ?oner_neq0. +Qed. + +Lemma horner_map p x : p^f.[f x] = f p.[x]. +Proof. +elim/poly_ind: p => [|p c IHp]; first by rewrite !(rmorph0, horner0). +rewrite hornerMXaddC !rmorphD !rmorphM /=. +by rewrite map_polyX map_polyC hornerMXaddC IHp. +Qed. + +Lemma map_comm_poly p x : comm_poly p x -> comm_poly p^f (f x). +Proof. by rewrite /comm_poly horner_map -!rmorphM // => ->. Qed. + +Lemma map_comm_coef p x : comm_coef p x -> comm_coef p^f (f x). +Proof. by move=> cpx i; rewrite coef_map -!rmorphM ?cpx. Qed. + +Lemma rmorph_root p x : root p x -> root p^f (f x). +Proof. by move/eqP=> px0; rewrite rootE horner_map px0 rmorph0. Qed. + +Lemma rmorph_unity_root n z : n.-unity_root z -> n.-unity_root (f z). +Proof. +move/rmorph_root; rewrite rootE rmorphB hornerD hornerN. +by rewrite /= map_polyXn rmorph1 hornerC hornerXn subr_eq0 unity_rootE. +Qed. + +Section HornerMorph. + +Variable u : rR. +Hypothesis cfu : commr_rmorph f u. + +Lemma horner_morphC a : horner_morph cfu a%:P = f a. +Proof. by rewrite /horner_morph map_polyC hornerC. Qed. + +Lemma horner_morphX : horner_morph cfu 'X = u. +Proof. by rewrite /horner_morph map_polyX hornerX. Qed. + +Fact horner_is_lrmorphism : lrmorphism_for (f \; *%R) (horner_morph cfu). +Proof. +rewrite /horner_morph; split=> [|c p]; last by rewrite linearZ hornerZ. +split=> [p q|]; first by rewrite /horner_morph rmorphB hornerD hornerN. +split=> [p q|]; last by rewrite /horner_morph rmorph1 hornerC. +rewrite /horner_morph rmorphM /= hornerM_comm //. +by apply: comm_coef_poly => i; rewrite coef_map cfu. +Qed. +Canonical horner_additive := Additive horner_is_lrmorphism. +Canonical horner_rmorphism := RMorphism horner_is_lrmorphism. +Canonical horner_linear := AddLinear horner_is_lrmorphism. +Canonical horner_lrmorphism := [lrmorphism of horner_morph cfu]. + +End HornerMorph. + +Lemma deriv_map p : p^f^`() = (p^`())^f. +Proof. by apply/polyP => i; rewrite !(coef_map, coef_deriv) //= rmorphMn. Qed. + +Lemma derivn_map p n : p^f^`(n) = (p^`(n))^f. +Proof. by apply/polyP => i; rewrite !(coef_map, coef_derivn) //= rmorphMn. Qed. + +Lemma nderivn_map p n : p^f^`N(n) = (p^`N(n))^f. +Proof. by apply/polyP => i; rewrite !(coef_map, coef_nderivn) //= rmorphMn. Qed. + +End MapPoly. + +(* Morphisms from the polynomial ring, and the initiality of polynomials *) +(* with respect to these. *) +Section MorphPoly. + +Variable (aR rR : ringType) (pf : {rmorphism {poly aR} -> rR}). + +Lemma poly_morphX_comm : commr_rmorph (pf \o polyC) (pf 'X). +Proof. by move=> a; rewrite /GRing.comm /= -!rmorphM // commr_polyX. Qed. + +Lemma poly_initial : pf =1 horner_morph poly_morphX_comm. +Proof. +apply: poly_ind => [|p a IHp]; first by rewrite !rmorph0. +by rewrite !rmorphD !rmorphM /= -{}IHp horner_morphC ?horner_morphX. +Qed. + +End MorphPoly. + +Notation "p ^:P" := (map_poly polyC p) : ring_scope. + +Section PolyCompose. + +Variable R : ringType. +Implicit Types p q : {poly R}. + +Definition comp_poly q p := p^:P.[q]. + +Local Notation "p \Po q" := (comp_poly q p) : ring_scope. + +Lemma size_map_polyC p : size p^:P = size p. +Proof. exact: size_map_inj_poly (@polyC_inj R) _ _. Qed. + +Lemma map_polyC_eq0 p : (p^:P == 0) = (p == 0). +Proof. by rewrite -!size_poly_eq0 size_map_polyC. Qed. + +Lemma root_polyC p x : root p^:P x%:P = root p x. +Proof. by rewrite rootE horner_map polyC_eq0. Qed. + +Lemma comp_polyE p q : p \Po q = \sum_(i < size p) p`_i *: q^+i. +Proof. +by rewrite [p \Po q]horner_poly; apply: eq_bigr => i _; rewrite mul_polyC. +Qed. + +Lemma polyOver_comp S (ringS : semiringPred S) (kS : keyed_pred ringS) : + {in polyOver kS &, forall p q, p \Po q \in polyOver kS}. +Proof. +move=> p q /polyOverP Sp Sq; rewrite comp_polyE rpred_sum // => i _. +by rewrite polyOverZ ?rpredX. +Qed. + +Lemma comp_polyCr p c : p \Po c%:P = p.[c]%:P. +Proof. exact: horner_map. Qed. + +Lemma comp_poly0r p : p \Po 0 = (p`_0)%:P. +Proof. by rewrite comp_polyCr horner_coef0. Qed. + +Lemma comp_polyC c p : c%:P \Po p = c%:P. +Proof. by rewrite /(_ \Po p) map_polyC hornerC. Qed. + +Fact comp_poly_is_linear p : linear (comp_poly p). +Proof. +move=> a q r. +by rewrite /comp_poly rmorphD /= map_polyZ !hornerE_comm mul_polyC. +Qed. +Canonical comp_poly_additive p := Additive (comp_poly_is_linear p). +Canonical comp_poly_linear p := Linear (comp_poly_is_linear p). + +Lemma comp_poly0 p : 0 \Po p = 0. +Proof. exact: raddf0. Qed. + +Lemma comp_polyD p q r : (p + q) \Po r = (p \Po r) + (q \Po r). +Proof. exact: raddfD. Qed. + +Lemma comp_polyB p q r : (p - q) \Po r = (p \Po r) - (q \Po r). +Proof. exact: raddfB. Qed. + +Lemma comp_polyZ c p q : (c *: p) \Po q = c *: (p \Po q). +Proof. exact: linearZZ. Qed. + +Lemma comp_polyXr p : p \Po 'X = p. +Proof. by rewrite -{2}/(idfun p) poly_initial. Qed. + +Lemma comp_polyX p : 'X \Po p = p. +Proof. by rewrite /(_ \Po p) map_polyX hornerX. Qed. + +Lemma comp_poly_MXaddC c p q : (p * 'X + c%:P) \Po q = (p \Po q) * q + c%:P. +Proof. +by rewrite /(_ \Po q) rmorphD rmorphM /= map_polyX map_polyC hornerMXaddC. +Qed. + +Lemma comp_polyXaddC_K p z : (p \Po ('X + z%:P)) \Po ('X - z%:P) = p. +Proof. +have addzK: ('X + z%:P) \Po ('X - z%:P) = 'X. + by rewrite raddfD /= comp_polyC comp_polyX subrK. +elim/poly_ind: p => [|p c IHp]; first by rewrite !comp_poly0. +rewrite comp_poly_MXaddC linearD /= comp_polyC {1}/comp_poly rmorphM /=. +by rewrite hornerM_comm /comm_poly -!/(_ \Po _) ?IHp ?addzK ?commr_polyX. +Qed. + +Lemma size_comp_poly_leq p q : + size (p \Po q) <= ((size p).-1 * (size q).-1).+1. +Proof. +rewrite comp_polyE (leq_trans (size_sum _ _ _)) //; apply/bigmax_leqP => i _. +rewrite (leq_trans (size_scale_leq _ _)) // (leq_trans (size_exp_leq _ _)) //. +by rewrite ltnS mulnC leq_mul // -{2}(subnKC (valP i)) leq_addr. +Qed. + +End PolyCompose. + +Notation "p \Po q" := (comp_poly q p) : ring_scope. + +Lemma map_comp_poly (aR rR : ringType) (f : {rmorphism aR -> rR}) p q : + map_poly f (p \Po q) = map_poly f p \Po map_poly f q. +Proof. +elim/poly_ind: p => [|p a IHp]; first by rewrite !raddf0. +rewrite comp_poly_MXaddC !rmorphD !rmorphM /= !map_polyC map_polyX. +by rewrite comp_poly_MXaddC -IHp. +Qed. + +Section PolynomialComRing. + +Variable R : comRingType. +Implicit Types p q : {poly R}. + +Fact poly_mul_comm p q : p * q = q * p. +Proof. +apply/polyP=> i; rewrite coefM coefMr. +by apply: eq_bigr => j _; rewrite mulrC. +Qed. + +Canonical poly_comRingType := Eval hnf in ComRingType {poly R} poly_mul_comm. +Canonical polynomial_comRingType := + Eval hnf in ComRingType (polynomial R) poly_mul_comm. +Canonical poly_algType := Eval hnf in CommAlgType R {poly R}. +Canonical polynomial_algType := + Eval hnf in [algType R of polynomial R for poly_algType]. + +Lemma hornerM p q x : (p * q).[x] = p.[x] * q.[x]. +Proof. by rewrite hornerM_comm //; exact: mulrC. Qed. + +Lemma horner_exp p x n : (p ^+ n).[x] = p.[x] ^+ n. +Proof. by rewrite horner_exp_comm //; exact: mulrC. Qed. + +Lemma horner_prod I r (P : pred I) (F : I -> {poly R}) x : + (\prod_(i <- r | P i) F i).[x] = \prod_(i <- r | P i) (F i).[x]. +Proof. by elim/big_rec2: _ => [|i _ p _ <-]; rewrite (hornerM, hornerC). Qed. + +Definition hornerE := + (hornerD, hornerN, hornerX, hornerC, horner_cons, + simp, hornerCM, hornerZ, hornerM). + +Definition horner_eval (x : R) := horner^~ x. +Lemma horner_evalE x p : horner_eval x p = p.[x]. Proof. by []. Qed. + +Fact horner_eval_is_lrmorphism x : lrmorphism_for *%R (horner_eval x). +Proof. +have cxid: commr_rmorph idfun x by exact: mulrC. +have evalE : horner_eval x =1 horner_morph cxid. + by move=> p; congr _.[x]; rewrite map_poly_id. +split=> [|c p]; last by rewrite !evalE /= -linearZ. +by do 2?split=> [p q|]; rewrite !evalE (rmorphB, rmorphM, rmorph1). +Qed. +Canonical horner_eval_additive x := Additive (horner_eval_is_lrmorphism x). +Canonical horner_eval_rmorphism x := RMorphism (horner_eval_is_lrmorphism x). +Canonical horner_eval_linear x := AddLinear (horner_eval_is_lrmorphism x). +Canonical horner_eval_lrmorphism x := [lrmorphism of horner_eval x]. + +Fact comp_poly_multiplicative q : multiplicative (comp_poly q). +Proof. +split=> [p1 p2|]; last by rewrite comp_polyC. +by rewrite /comp_poly rmorphM hornerM_comm //; exact: mulrC. +Qed. +Canonical comp_poly_rmorphism q := AddRMorphism (comp_poly_multiplicative q). +Canonical comp_poly_lrmorphism q := [lrmorphism of comp_poly q]. + +Lemma comp_polyM p q r : (p * q) \Po r = (p \Po r) * (q \Po r). +Proof. exact: rmorphM. Qed. + +Lemma comp_polyA p q r : p \Po (q \Po r) = (p \Po q) \Po r. +Proof. +elim/poly_ind: p => [|p c IHp]; first by rewrite !comp_polyC. +by rewrite !comp_polyD !comp_polyM !comp_polyX IHp !comp_polyC. +Qed. + +Lemma horner_comp p q x : (p \Po q).[x] = p.[q.[x]]. +Proof. by apply: polyC_inj; rewrite -!comp_polyCr comp_polyA. Qed. + +Lemma root_comp p q x : root (p \Po q) x = root p (q.[x]). +Proof. by rewrite !rootE horner_comp. Qed. + +Lemma deriv_comp p q : (p \Po q) ^`() = (p ^`() \Po q) * q^`(). +Proof. +elim/poly_ind: p => [|p c IHp]; first by rewrite !(deriv0, comp_poly0) mul0r. +rewrite comp_poly_MXaddC derivD derivC derivM IHp derivMXaddC comp_polyD. +by rewrite comp_polyM comp_polyX addr0 addrC mulrAC -mulrDl. +Qed. + +Lemma deriv_exp p n : (p ^+ n)^`() = p^`() * p ^+ n.-1 *+ n. +Proof. +elim: n => [|n IHn]; first by rewrite expr0 mulr0n derivC. +by rewrite exprS derivM {}IHn (mulrC p) mulrnAl -mulrA -exprSr mulrS; case n. +Qed. + +Definition derivCE := (derivE, deriv_exp). + +End PolynomialComRing. + +Section PolynomialIdomain. + +(* Integral domain structure on poly *) +Variable R : idomainType. + +Implicit Types (a b x y : R) (p q r m : {poly R}). + +Lemma size_mul p q : p != 0 -> q != 0 -> size (p * q) = (size p + size q).-1. +Proof. +by move=> nz_p nz_q; rewrite -size_proper_mul ?mulf_neq0 ?lead_coef_eq0. +Qed. + +Fact poly_idomainAxiom p q : p * q = 0 -> (p == 0) || (q == 0). +Proof. +move=> pq0; apply/norP=> [[p_nz q_nz]]; move/eqP: (size_mul p_nz q_nz). +by rewrite eq_sym pq0 size_poly0 (polySpred p_nz) (polySpred q_nz) addnS. +Qed. + +Definition poly_unit : pred {poly R} := + fun p => (size p == 1%N) && (p`_0 \in GRing.unit). + +Definition poly_inv p := if p \in poly_unit then (p`_0)^-1%:P else p. + +Fact poly_mulVp : {in poly_unit, left_inverse 1 poly_inv *%R}. +Proof. +move=> p Up; rewrite /poly_inv Up. +by case/andP: Up => /size_poly1P[c _ ->]; rewrite coefC -polyC_mul => /mulVr->. +Qed. + +Fact poly_intro_unit p q : q * p = 1 -> p \in poly_unit. +Proof. +move=> pq1; apply/andP; split; last first. + apply/unitrP; exists q`_0. + by rewrite 2!mulrC -!/(coefp 0 _) -rmorphM pq1 rmorph1. +have: size (q * p) == 1%N by rewrite pq1 size_poly1. +have [-> | nz_p] := eqVneq p 0; first by rewrite mulr0 size_poly0. +have [-> | nz_q] := eqVneq q 0; first by rewrite mul0r size_poly0. +rewrite size_mul // (polySpred nz_p) (polySpred nz_q) addnS addSn !eqSS. +by rewrite addn_eq0 => /andP[]. +Qed. + +Fact poly_inv_out : {in [predC poly_unit], poly_inv =1 id}. +Proof. by rewrite /poly_inv => p /negbTE/= ->. Qed. + +Definition poly_comUnitMixin := + ComUnitRingMixin poly_mulVp poly_intro_unit poly_inv_out. + +Canonical poly_unitRingType := + Eval hnf in UnitRingType {poly R} poly_comUnitMixin. +Canonical polynomial_unitRingType := + Eval hnf in [unitRingType of polynomial R for poly_unitRingType]. + +Canonical poly_unitAlgType := Eval hnf in [unitAlgType R of {poly R}]. +Canonical polynomial_unitAlgType := Eval hnf in [unitAlgType R of polynomial R]. + +Canonical poly_comUnitRingType := Eval hnf in [comUnitRingType of {poly R}]. +Canonical polynomial_comUnitRingType := + Eval hnf in [comUnitRingType of polynomial R]. + +Canonical poly_idomainType := + Eval hnf in IdomainType {poly R} poly_idomainAxiom. +Canonical polynomial_idomainType := + Eval hnf in [idomainType of polynomial R for poly_idomainType]. + +Lemma poly_unitE p : + (p \in GRing.unit) = (size p == 1%N) && (p`_0 \in GRing.unit). +Proof. by []. Qed. + +Lemma poly_invE p : p ^-1 = if p \in GRing.unit then (p`_0)^-1%:P else p. +Proof. by []. Qed. + +Lemma polyC_inv c : c%:P^-1 = (c^-1)%:P. +Proof. +have [/rmorphV-> // | nUc] := boolP (c \in GRing.unit). +by rewrite !invr_out // poly_unitE coefC (negbTE nUc) andbF. +Qed. + +Lemma rootM p q x : root (p * q) x = root p x || root q x. +Proof. by rewrite !rootE hornerM mulf_eq0. Qed. + +Lemma rootZ x a p : a != 0 -> root (a *: p) x = root p x. +Proof. by move=> nz_a; rewrite -mul_polyC rootM rootC (negPf nz_a). Qed. + +Lemma size_scale a p : a != 0 -> size (a *: p) = size p. +Proof. by move/lregP/lreg_size->. Qed. + +Lemma size_Cmul a p : a != 0 -> size (a%:P * p) = size p. +Proof. by rewrite mul_polyC => /size_scale->. Qed. + +Lemma lead_coefM p q : lead_coef (p * q) = lead_coef p * lead_coef q. +Proof. +have [-> | nz_p] := eqVneq p 0; first by rewrite !(mul0r, lead_coef0). +have [-> | nz_q] := eqVneq q 0; first by rewrite !(mulr0, lead_coef0). +by rewrite lead_coef_proper_mul // mulf_neq0 ?lead_coef_eq0. +Qed. + +Lemma lead_coefZ a p : lead_coef (a *: p) = a * lead_coef p. +Proof. by rewrite -mul_polyC lead_coefM lead_coefC. Qed. + +Lemma scale_poly_eq0 a p : (a *: p == 0) = (a == 0) || (p == 0). +Proof. by rewrite -mul_polyC mulf_eq0 polyC_eq0. Qed. + +Lemma size_prod (I : finType) (P : pred I) (F : I -> {poly R}) : + (forall i, P i -> F i != 0) -> + size (\prod_(i | P i) F i) = ((\sum_(i | P i) size (F i)).+1 - #|P|)%N. +Proof. +move=> nzF; transitivity (\sum_(i | P i) (size (F i)).-1).+1; last first. + apply: canRL (addKn _) _; rewrite addnS -sum1_card -big_split /=. + by congr _.+1; apply: eq_bigr => i /nzF/polySpred. +elim/big_rec2: _ => [|i d p /nzF nzFi IHp]; first by rewrite size_poly1. +by rewrite size_mul // -?size_poly_eq0 IHp // addnS polySpred. +Qed. + +Lemma size_exp p n : (size (p ^+ n)).-1 = ((size p).-1 * n)%N. +Proof. +elim: n => [|n IHn]; first by rewrite size_poly1 muln0. +have [-> | nz_p] := eqVneq p 0; first by rewrite exprS mul0r size_poly0. +rewrite exprS size_mul ?expf_neq0 // mulnS -{}IHn. +by rewrite polySpred // [size (p ^+ n)]polySpred ?expf_neq0 ?addnS. +Qed. + +Lemma lead_coef_exp p n : lead_coef (p ^+ n) = lead_coef p ^+ n. +Proof. +elim: n => [|n IHn]; first by rewrite !expr0 lead_coef1. +by rewrite !exprS lead_coefM IHn. +Qed. + +Lemma root_prod_XsubC rs x : + root (\prod_(a <- rs) ('X - a%:P)) x = (x \in rs). +Proof. +elim: rs => [|a rs IHrs]; first by rewrite rootE big_nil hornerC oner_eq0. +by rewrite big_cons rootM IHrs root_XsubC. +Qed. + +Lemma root_exp_XsubC n a x : root (('X - a%:P) ^+ n.+1) x = (x == a). +Proof. by rewrite rootE horner_exp expf_eq0 [_ == 0]root_XsubC. Qed. + +Lemma size_comp_poly p q : + (size (p \Po q)).-1 = ((size p).-1 * (size q).-1)%N. +Proof. +have [-> | nz_p] := eqVneq p 0; first by rewrite comp_poly0 size_poly0. +have [/size1_polyC-> | nc_q] := leqP (size q) 1. + by rewrite comp_polyCr !size_polyC -!sub1b -!subnS muln0. +have nz_q: q != 0 by rewrite -size_poly_eq0 -(subnKC nc_q). +rewrite mulnC comp_polyE (polySpred nz_p) /= big_ord_recr /= addrC. +rewrite size_addl size_scale ?lead_coef_eq0 ?size_exp //=. +rewrite [X in _ < X]polySpred ?expf_neq0 // ltnS size_exp. +rewrite (leq_trans (size_sum _ _ _)) //; apply/bigmax_leqP => i _. +rewrite (leq_trans (size_scale_leq _ _)) // polySpred ?expf_neq0 //. +by rewrite size_exp -(subnKC nc_q) ltn_pmul2l. +Qed. + +Lemma size_comp_poly2 p q : size q = 2 -> size (p \Po q) = size p. +Proof. +have [/size1_polyC->| p_gt1] := leqP (size p) 1; first by rewrite comp_polyC. +move=> lin_q; have{lin_q} sz_pq: (size (p \Po q)).-1 = (size p).-1. + by rewrite size_comp_poly lin_q muln1. +rewrite -(ltn_predK p_gt1) -sz_pq -polySpred // -size_poly_gt0 ltnW //. +by rewrite -subn_gt0 subn1 sz_pq -subn1 subn_gt0. +Qed. + +Lemma comp_poly2_eq0 p q : size q = 2 -> (p \Po q == 0) = (p == 0). +Proof. by rewrite -!size_poly_eq0 => /size_comp_poly2->. Qed. + +Lemma lead_coef_comp p q : + size q > 1 -> lead_coef (p \Po q) = lead_coef p * lead_coef q ^+ (size p).-1. +Proof. +move=> q_gt1; have nz_q: q != 0 by rewrite -size_poly_gt0 ltnW. +have [-> | nz_p] := eqVneq p 0; first by rewrite comp_poly0 !lead_coef0 mul0r. +rewrite comp_polyE polySpred //= big_ord_recr /= addrC -lead_coefE. +rewrite lead_coefDl; first by rewrite lead_coefZ lead_coef_exp. +rewrite size_scale ?lead_coef_eq0 // (polySpred (expf_neq0 _ nz_q)) ltnS. +apply/leq_sizeP=> i le_qp_i; rewrite coef_sum big1 // => j _. +rewrite coefZ (nth_default 0 (leq_trans _ le_qp_i)) ?mulr0 //=. +by rewrite polySpred ?expf_neq0 // !size_exp -(subnKC q_gt1) ltn_pmul2l. +Qed. + +End PolynomialIdomain. + +Section MapFieldPoly. + +Variables (F : fieldType) (R : ringType) (f : {rmorphism F -> R}). + +Local Notation "p ^f" := (map_poly f p) : ring_scope. + +Lemma size_map_poly p : size p^f = size p. +Proof. +have [-> | nz_p] := eqVneq p 0; first by rewrite rmorph0 !size_poly0. +by rewrite size_poly_eq // fmorph_eq0 // lead_coef_eq0. +Qed. + +Lemma lead_coef_map p : lead_coef p^f = f (lead_coef p). +Proof. +have [-> | nz_p] := eqVneq p 0; first by rewrite !(rmorph0, lead_coef0). +by rewrite lead_coef_map_eq // fmorph_eq0 // lead_coef_eq0. +Qed. + +Lemma map_poly_eq0 p : (p^f == 0) = (p == 0). +Proof. by rewrite -!size_poly_eq0 size_map_poly. Qed. + +Lemma map_poly_inj : injective (map_poly f). +Proof. +move=> p q eqfpq; apply/eqP; rewrite -subr_eq0 -map_poly_eq0. +by rewrite rmorphB /= eqfpq subrr. +Qed. + +Lemma map_monic p : (p^f \is monic) = (p \is monic). +Proof. by rewrite monicE lead_coef_map fmorph_eq1. Qed. + +Lemma map_poly_com p x : comm_poly p^f (f x). +Proof. exact: map_comm_poly (mulrC x _). Qed. + +Lemma fmorph_root p x : root p^f (f x) = root p x. +Proof. by rewrite rootE horner_map // fmorph_eq0. Qed. + +Lemma fmorph_unity_root n z : n.-unity_root (f z) = n.-unity_root z. +Proof. by rewrite !unity_rootE -(inj_eq (fmorph_inj f)) rmorphX ?rmorph1. Qed. + +Lemma fmorph_primitive_root n z : + n.-primitive_root (f z) = n.-primitive_root z. +Proof. +by congr (_ && _); apply: eq_forallb => i; rewrite fmorph_unity_root. +Qed. + +End MapFieldPoly. + +Implicit Arguments map_poly_inj [[F] [R] x1 x2]. + +Section MaxRoots. + +Variable R : unitRingType. +Implicit Types (x y : R) (rs : seq R) (p : {poly R}). + +Definition diff_roots (x y : R) := (x * y == y * x) && (y - x \in GRing.unit). + +Fixpoint uniq_roots rs := + if rs is x :: rs' then all (diff_roots x) rs' && uniq_roots rs' else true. + +Lemma uniq_roots_prod_XsubC p rs : + all (root p) rs -> uniq_roots rs -> + exists q, p = q * \prod_(z <- rs) ('X - z%:P). +Proof. +elim: rs => [|z rs IHrs] /=; first by rewrite big_nil; exists p; rewrite mulr1. +case/andP=> rpz rprs /andP[drs urs]; case: IHrs => {urs rprs}// q def_p. +have [|q' def_q] := factor_theorem q z _; last first. + by exists q'; rewrite big_cons mulrA -def_q. +rewrite {p}def_p in rpz. +elim/last_ind: rs drs rpz => [|rs t IHrs] /=; first by rewrite big_nil mulr1. +rewrite all_rcons => /andP[/andP[/eqP czt Uzt] /IHrs {IHrs}IHrs]. +rewrite -cats1 big_cat big_seq1 /= mulrA rootE hornerM_comm; last first. + by rewrite /comm_poly hornerXsubC mulrBl mulrBr czt. +rewrite hornerXsubC -opprB mulrN oppr_eq0 -(mul0r (t - z)). +by rewrite (inj_eq (mulIr Uzt)) => /IHrs. +Qed. + +Theorem max_ring_poly_roots p rs : + p != 0 -> all (root p) rs -> uniq_roots rs -> size rs < size p. +Proof. +move=> nz_p _ /(@uniq_roots_prod_XsubC p)[// | q def_p]; rewrite def_p in nz_p *. +have nz_q: q != 0 by apply: contraNneq nz_p => ->; rewrite mul0r. +rewrite size_Mmonic ?monic_prod_XsubC // (polySpred nz_q) addSn /=. +by rewrite size_prod_XsubC leq_addl. +Qed. + +Lemma all_roots_prod_XsubC p rs : + size p = (size rs).+1 -> all (root p) rs -> uniq_roots rs -> + p = lead_coef p *: \prod_(z <- rs) ('X - z%:P). +Proof. +move=> size_p /uniq_roots_prod_XsubC def_p Urs. +case/def_p: Urs => q -> {p def_p} in size_p *. +have [q0 | nz_q] := eqVneq q 0; first by rewrite q0 mul0r size_poly0 in size_p. +have{q nz_q size_p} /size_poly1P[c _ ->]: size q == 1%N. + rewrite -(eqn_add2r (size rs)) add1n -size_p. + by rewrite size_Mmonic ?monic_prod_XsubC // size_prod_XsubC addnS. +by rewrite lead_coef_Mmonic ?monic_prod_XsubC // lead_coefC mul_polyC. +Qed. + +End MaxRoots. + +Section FieldRoots. + +Variable F : fieldType. +Implicit Types (p : {poly F}) (rs : seq F). + +Lemma poly2_root p : size p = 2 -> {r | root p r}. +Proof. +case: p => [[|p0 [|p1 []]] //= nz_p1]; exists (- p0 / p1). +by rewrite /root addr_eq0 /= mul0r add0r mulrC divfK ?opprK. +Qed. + +Lemma uniq_rootsE rs : uniq_roots rs = uniq rs. +Proof. +elim: rs => //= r rs ->; congr (_ && _); rewrite -has_pred1 -all_predC. +by apply: eq_all => t; rewrite /diff_roots mulrC eqxx unitfE subr_eq0. +Qed. + +Theorem max_poly_roots p rs : + p != 0 -> all (root p) rs -> uniq rs -> size rs < size p. +Proof. by rewrite -uniq_rootsE; exact: max_ring_poly_roots. Qed. + +Section UnityRoots. + +Variable n : nat. + +Lemma max_unity_roots rs : + n > 0 -> all n.-unity_root rs -> uniq rs -> size rs <= n. +Proof. +move=> n_gt0 rs_n_1 Urs; have szPn := size_Xn_sub_1 F n_gt0. +by rewrite -ltnS -szPn max_poly_roots -?size_poly_eq0 ?szPn. +Qed. + +Lemma mem_unity_roots rs : + n > 0 -> all n.-unity_root rs -> uniq rs -> size rs = n -> + n.-unity_root =i rs. +Proof. +move=> n_gt0 rs_n_1 Urs sz_rs_n x; rewrite -topredE /=. +apply/idP/idP=> xn1; last exact: (allP rs_n_1). +apply: contraFT (ltnn n) => not_rs_x. +by rewrite -{1}sz_rs_n (@max_unity_roots (x :: rs)) //= ?xn1 ?not_rs_x. +Qed. + +(* Showing the existence of a primitive root requires the theory in cyclic. *) + +Variable z : F. +Hypothesis prim_z : n.-primitive_root z. + +Let zn := [seq z ^+ i | i <- index_iota 0 n]. + +Lemma factor_Xn_sub_1 : \prod_(0 <= i < n) ('X - (z ^+ i)%:P) = 'X^n - 1. +Proof. +transitivity (\prod_(w <- zn) ('X - w%:P)); first by rewrite big_map. +have n_gt0: n > 0 := prim_order_gt0 prim_z. +rewrite (@all_roots_prod_XsubC _ ('X^n - 1) zn); first 1 last. +- by rewrite size_Xn_sub_1 // size_map size_iota subn0. +- apply/allP=> _ /mapP[i _ ->] /=; rewrite rootE !hornerE hornerXn. + by rewrite exprAC (prim_expr_order prim_z) expr1n subrr. +- rewrite uniq_rootsE map_inj_in_uniq ?iota_uniq // => i j. + rewrite !mem_index_iota => ltin ltjn /eqP. + by rewrite (eq_prim_root_expr prim_z) !modn_small // => /eqP. +by rewrite (monicP (monic_Xn_sub_1 F n_gt0)) scale1r. +Qed. + +Lemma prim_rootP x : x ^+ n = 1 -> {i : 'I_n | x = z ^+ i}. +Proof. +move=> xn1; pose logx := [pred i : 'I_n | x == z ^+ i]. +case: (pickP logx) => [i /eqP-> | no_i]; first by exists i. +case: notF; suffices{no_i}: x \in zn. + case/mapP=> i; rewrite mem_index_iota => lt_i_n def_x. + by rewrite -(no_i (Ordinal lt_i_n)) /= -def_x. +rewrite -root_prod_XsubC big_map factor_Xn_sub_1. +by rewrite [root _ x]unity_rootE xn1. +Qed. + +End UnityRoots. + +End FieldRoots. + +Section MapPolyRoots. + +Variables (F : fieldType) (R : unitRingType) (f : {rmorphism F -> R}). + +Lemma map_diff_roots x y : diff_roots (f x) (f y) = (x != y). +Proof. +rewrite /diff_roots -rmorphB // fmorph_unit // subr_eq0 //. +by rewrite rmorph_comm // eqxx eq_sym. +Qed. + +Lemma map_uniq_roots s : uniq_roots (map f s) = uniq s. +Proof. +elim: s => //= x s ->; congr (_ && _); elim: s => //= y s ->. +by rewrite map_diff_roots -negb_or. +Qed. + +End MapPolyRoots. + +Section AutPolyRoot. +(* The action of automorphisms on roots of unity. *) + +Variable F : fieldType. +Implicit Types u v : {rmorphism F -> F}. + +Lemma aut_prim_rootP u z n : + n.-primitive_root z -> {k | coprime k n & u z = z ^+ k}. +Proof. +move=> prim_z; have:= prim_z; rewrite -(fmorph_primitive_root u) => prim_uz. +have [[k _] /= def_uz] := prim_rootP prim_z (prim_expr_order prim_uz). +by exists k; rewrite // -(prim_root_exp_coprime _ prim_z) -def_uz. +Qed. + +Lemma aut_unity_rootP u z n : n > 0 -> z ^+ n = 1 -> {k | u z = z ^+ k}. +Proof. +by move=> _ /prim_order_exists[// | m /(aut_prim_rootP u)[k]]; exists k. +Qed. + +Lemma aut_unity_rootC u v z n : n > 0 -> z ^+ n = 1 -> u (v z) = v (u z). +Proof. +move=> n_gt0 /(aut_unity_rootP _ n_gt0) def_z. +have [[i def_uz] [j def_vz]] := (def_z u, def_z v). +by rewrite !(def_uz, def_vz, rmorphX) exprAC. +Qed. + +End AutPolyRoot. + +Module UnityRootTheory. + +Notation "n .-unity_root" := (root_of_unity n) : unity_root_scope. +Notation "n .-primitive_root" := (primitive_root_of_unity n) : unity_root_scope. +Open Scope unity_root_scope. + +Definition unity_rootE := unity_rootE. +Definition unity_rootP := @unity_rootP. +Implicit Arguments unity_rootP [R n z]. + +Definition prim_order_exists := prim_order_exists. +Notation prim_order_gt0 := prim_order_gt0. +Notation prim_expr_order := prim_expr_order. +Definition prim_expr_mod := prim_expr_mod. +Definition prim_order_dvd := prim_order_dvd. +Definition eq_prim_root_expr := eq_prim_root_expr. + +Definition rmorph_unity_root := rmorph_unity_root. +Definition fmorph_unity_root := fmorph_unity_root. +Definition fmorph_primitive_root := fmorph_primitive_root. +Definition max_unity_roots := max_unity_roots. +Definition mem_unity_roots := mem_unity_roots. +Definition prim_rootP := prim_rootP. + +End UnityRootTheory. + +Module PreClosedField. +Section UseAxiom. + +Variable F : fieldType. +Hypothesis closedF : GRing.ClosedField.axiom F. +Implicit Type p : {poly F}. + +Lemma closed_rootP p : reflect (exists x, root p x) (size p != 1%N). +Proof. +have [-> | nz_p] := eqVneq p 0. + by rewrite size_poly0; left; exists 0; rewrite root0. +rewrite neq_ltn {1}polySpred //=. +apply: (iffP idP) => [p_gt1 | [a]]; last exact: root_size_gt1. +pose n := (size p).-1; have n_gt0: n > 0 by rewrite -ltnS -polySpred. +have [a Dan] := closedF (fun i => - p`_i / lead_coef p) n_gt0. +exists a; apply/rootP; rewrite horner_coef polySpred // big_ord_recr /= -/n. +rewrite {}Dan mulr_sumr -big_split big1 //= => i _. +by rewrite -!mulrA mulrCA mulNr mulVKf ?subrr ?lead_coef_eq0. +Qed. + +Lemma closed_nonrootP p : reflect (exists x, ~~ root p x) (p != 0). +Proof. +apply: (iffP idP) => [nz_p | [x]]; last first. + by apply: contraNneq => ->; apply: root0. +have [[x /rootP p1x0]|] := altP (closed_rootP (p - 1)). + by exists x; rewrite -[p](subrK 1) /root hornerD p1x0 add0r hornerC oner_eq0. +rewrite negbK => /size_poly1P[c _ /(canRL (subrK 1)) Dp]. +by exists 0; rewrite Dp -raddfD polyC_eq0 rootC in nz_p *. +Qed. + +End UseAxiom. +End PreClosedField. + +Section ClosedField. + +Variable F : closedFieldType. +Implicit Type p : {poly F}. + +Let closedF := @solve_monicpoly F. + +Lemma closed_rootP p : reflect (exists x, root p x) (size p != 1%N). +Proof. exact: PreClosedField.closed_rootP. Qed. + +Lemma closed_nonrootP p : reflect (exists x, ~~ root p x) (p != 0). +Proof. exact: PreClosedField.closed_nonrootP. Qed. + +Lemma closed_field_poly_normal p : + {r : seq F | p = lead_coef p *: \prod_(z <- r) ('X - z%:P)}. +Proof. +apply: sig_eqW; elim: {p}_.+1 {-2}p (ltnSn (size p)) => // n IHn p le_p_n. +have [/size1_polyC-> | p_gt1] := leqP (size p) 1. + by exists nil; rewrite big_nil lead_coefC alg_polyC. +have [|x /factor_theorem[q Dp]] := closed_rootP p _; first by rewrite gtn_eqF. +have nz_p: p != 0 by rewrite -size_poly_eq0 -(subnKC p_gt1). +have:= nz_p; rewrite Dp mulf_eq0 lead_coefM => /norP[nz_q nz_Xx]. +rewrite ltnS polySpred // Dp size_mul // size_XsubC addn2 in le_p_n. +have [r {1}->] := IHn q le_p_n; exists (x :: r). +by rewrite lead_coefXsubC mulr1 big_cons -scalerAl mulrC. +Qed. + +End ClosedField. diff --git a/mathcomp/algebra/polyXY.v b/mathcomp/algebra/polyXY.v new file mode 100644 index 0000000..3d2292e --- /dev/null +++ b/mathcomp/algebra/polyXY.v @@ -0,0 +1,405 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool choice eqtype ssrnat seq div fintype. +Require Import tuple finfun bigop fingroup perm ssralg zmodp matrix mxalgebra. +Require Import poly polydiv mxpoly binomial. + +(******************************************************************************) +(* This file provides additional primitives and theory for bivariate *) +(* polynomials (polynomials of two variables), represented as polynomials *) +(* with (univariate) polynomial coefficients : *) +(* 'Y == the (generic) second variable (:= 'X%:P). *) +(* p^:P == the bivariate polynomial p['X], for p univariate. *) +(* := map_poly polyC p (this notation is defined in poly.v). *) +(* u.[x, y] == the bivariate polynomial u evaluated at 'X = x, 'Y = y. *) +(* := u.[x%:P].[y]. *) +(* sizeY u == the size of u in 'Y (1 + the 'Y-degree of u, if u != 0). *) +(* := \max_(i < size u) size u`_i. *) +(* swapXY u == the bivariate polynomial u['Y, 'X], for u bivariate. *) +(* poly_XaY p == the bivariate polynomial p['X + 'Y], for p univariate. *) +(* := p^:P \Po ('X + 'Y). *) +(* poly_XmY p == the bivariate polynomial p['X * 'Y], for p univariate. *) +(* := P^:P \Po ('X * 'Y). *) +(* sub_annihilant p q == for univariate p, q != 0, a nonzero polynomial whose *) +(* roots include all the differences of roots of p and q, in *) +(* all field extensions (:= resultant (poly_XaY p) q^:P). *) +(* div_annihilant p q == for polynomials p != 0, q with q.[0] != 0, a nonzero *) +(* polynomial whose roots include all the quotients of roots *) +(* of p by roots of q, in all field extensions *) +(* (:= resultant (poly_XmY p) q^:P). *) +(* The latter two "annhilants" provide uniform witnesses for an alternative *) +(* proof of the closure of the algebraicOver predicate (see mxpoly.v). The *) +(* fact that the annhilant does not depend on the particular choice of roots *) +(* of p and q is crucial for the proof of the Primitive Element Theorem (file *) +(* separable.v). *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope ring_scope. +Import GRing.Theory. + +Local Notation "p ^ f" := (map_poly f p) : ring_scope. +Local Notation eval := horner_eval. + +Notation "'Y" := 'X%:P : ring_scope. +Notation "p ^:P" := (p ^ polyC) (at level 2, format "p ^:P") : ring_scope. +Notation "p .[ x , y ]" := (p.[x%:P].[y]) + (at level 2, left associativity, format "p .[ x , y ]") : ring_scope. + +Section PolyXY_Ring. + +Variable R : ringType. +Implicit Types (u : {poly {poly R}}) (p q : {poly R}) (x : R). + +Fact swapXY_key : unit. Proof. by []. Qed. +Definition swapXY_def u : {poly {poly R}} := (u ^ map_poly polyC).['Y]. +Definition swapXY := locked_with swapXY_key swapXY_def. +Canonical swapXY_unlockable := [unlockable fun swapXY]. + +Definition sizeY u : nat := \max_(i < size u) (size u`_i). +Definition poly_XaY p : {poly {poly R}} := p^:P \Po ('X + 'Y). +Definition poly_XmY p : {poly {poly R}} := p^:P \Po ('X * 'Y). +Definition sub_annihilant p q := resultant (poly_XaY p) q^:P. +Definition div_annihilant p q := resultant (poly_XmY p) q^:P. + +Lemma swapXY_polyC p : swapXY p%:P = p^:P. +Proof. by rewrite unlock map_polyC hornerC. Qed. + +Lemma swapXY_X : swapXY 'X = 'Y. +Proof. by rewrite unlock map_polyX hornerX. Qed. + +Lemma swapXY_Y : swapXY 'Y = 'X. +Proof. by rewrite swapXY_polyC map_polyX. Qed. + +Lemma swapXY_is_additive : additive swapXY. +Proof. by move=> u v; rewrite unlock rmorphB !hornerE. Qed. +Canonical swapXY_addf := Additive swapXY_is_additive. + +Lemma coef_swapXY u i j : (swapXY u)`_i`_j = u`_j`_i. +Proof. +elim/poly_ind: u => [|u p IHu] in i j *; first by rewrite raddf0 !coef0. +rewrite raddfD !coefD /= swapXY_polyC coef_map /= !coefC coefMX. +rewrite !(fun_if (fun q : {poly R} => q`_i)) coef0 -IHu; congr (_ + _). +by rewrite unlock rmorphM /= map_polyX hornerMX coefMC coefMX. +Qed. + +Lemma swapXYK : involutive swapXY. +Proof. by move=> u; apply/polyP=> i; apply/polyP=> j; rewrite !coef_swapXY. Qed. + +Lemma swapXY_map_polyC p : swapXY p^:P = p%:P. +Proof. by rewrite -swapXY_polyC swapXYK. Qed. + +Lemma swapXY_eq0 u : (swapXY u == 0) = (u == 0). +Proof. by rewrite (inv_eq swapXYK) raddf0. Qed. + +Lemma swapXY_is_multiplicative : multiplicative swapXY. +Proof. +split=> [u v|]; last by rewrite swapXY_polyC map_polyC. +apply/polyP=> i; apply/polyP=> j; rewrite coef_swapXY !coefM !coef_sum. +rewrite (eq_bigr _ (fun _ _ => coefM _ _ _)) exchange_big /=. +apply: eq_bigr => j1 _; rewrite coefM; apply: eq_bigr=> i1 _. +by rewrite !coef_swapXY. +Qed. +Canonical swapXY_rmorphism := AddRMorphism swapXY_is_multiplicative. + +Lemma swapXY_is_scalable : scalable_for (map_poly polyC \; *%R) swapXY. +Proof. by move=> p u /=; rewrite -mul_polyC rmorphM /= swapXY_polyC. Qed. +Canonical swapXY_linear := AddLinear swapXY_is_scalable. +Canonical swapXY_lrmorphism := [lrmorphism of swapXY]. + +Lemma swapXY_comp_poly p u : swapXY (p^:P \Po u) = p^:P \Po swapXY u. +Proof. +rewrite -horner_map; congr _.[_]; rewrite -!map_poly_comp /=. +by apply: eq_map_poly => x; rewrite /= swapXY_polyC map_polyC. +Qed. + +Lemma max_size_coefXY u i : size u`_i <= sizeY u. +Proof. +have [ltiu | /(nth_default 0)->] := ltnP i (size u); last by rewrite size_poly0. +exact: (bigmax_sup (Ordinal ltiu)). +Qed. + +Lemma max_size_lead_coefXY u : size (lead_coef u) <= sizeY u. +Proof. by rewrite lead_coefE max_size_coefXY. Qed. + +Lemma max_size_evalX u : size u.['X] <= sizeY u + (size u).-1. +Proof. +rewrite horner_coef (leq_trans (size_sum _ _ _)) //; apply/bigmax_leqP=> i _. +rewrite (leq_trans (size_mul_leq _ _)) // size_polyXn addnS. +by rewrite leq_add ?max_size_coefXY //= -ltnS (leq_trans _ (leqSpred _)). +Qed. + +Lemma max_size_evalC u x : size u.[x%:P] <= sizeY u. +Proof. +rewrite horner_coef (leq_trans (size_sum _ _ _)) //; apply/bigmax_leqP=> i _. +rewrite (leq_trans (size_mul_leq _ _)) // -polyC_exp size_polyC addnC -subn1. +by rewrite (leq_trans _ (max_size_coefXY _ i)) // leq_subLR leq_add2r leq_b1. +Qed. + +Lemma sizeYE u : sizeY u = size (swapXY u). +Proof. +apply/eqP; rewrite eqn_leq; apply/andP; split. + apply/bigmax_leqP=> /= i _; apply/leq_sizeP => j /(nth_default 0) u_j_0. + by rewrite -coef_swapXY u_j_0 coef0. +apply/leq_sizeP=> j le_uY_j; apply/polyP=> i; rewrite coef_swapXY coef0. +by rewrite nth_default // (leq_trans _ le_uY_j) ?max_size_coefXY. +Qed. + +Lemma sizeY_eq0 u : (sizeY u == 0%N) = (u == 0). +Proof. by rewrite sizeYE size_poly_eq0 swapXY_eq0. Qed. + +Lemma sizeY_mulX u : sizeY (u * 'X) = sizeY u. +Proof. +rewrite !sizeYE rmorphM /= swapXY_X rreg_size //. +by have /monic_comreg[_ /rreg_lead] := monicX R. +Qed. + +Lemma swapXY_poly_XaY p : swapXY (poly_XaY p) = poly_XaY p. +Proof. by rewrite swapXY_comp_poly rmorphD /= swapXY_X swapXY_Y addrC. Qed. + +Lemma swapXY_poly_XmY p : swapXY (poly_XmY p) = poly_XmY p. +Proof. +by rewrite swapXY_comp_poly rmorphM /= swapXY_X swapXY_Y commr_polyX. +Qed. + +Lemma poly_XaY0 : poly_XaY 0 = 0. +Proof. by rewrite /poly_XaY rmorph0 comp_poly0. Qed. + +Lemma poly_XmY0 : poly_XmY 0 = 0. +Proof. by rewrite /poly_XmY rmorph0 comp_poly0. Qed. + +End PolyXY_Ring. + +Prenex Implicits swapXY sizeY poly_XaY poly_XmY sub_annihilant div_annihilant. +Prenex Implicits swapXYK. + +Lemma swapXY_map (R S : ringType) (f : {additive R -> S}) u : + swapXY (u ^ map_poly f) = swapXY u ^ map_poly f. +Proof. +by apply/polyP=> i; apply/polyP=> j; rewrite !(coef_map, coef_swapXY). +Qed. + +Section PolyXY_ComRing. + +Variable R : comRingType. +Implicit Types (u : {poly {poly R}}) (p : {poly R}) (x y : R). + +Lemma horner_swapXY u x : (swapXY u).[x%:P] = u ^ eval x. +Proof. +apply/polyP=> i /=; rewrite coef_map /= /eval horner_coef coef_sum -sizeYE. +rewrite (horner_coef_wide _ (max_size_coefXY u i)); apply: eq_bigr=> j _. +by rewrite -polyC_exp coefMC coef_swapXY. +Qed. + +Lemma horner_polyC u x : u.[x%:P] = swapXY u ^ eval x. +Proof. by rewrite -horner_swapXY swapXYK. Qed. + +Lemma horner2_swapXY u x y : (swapXY u).[x, y] = u.[y, x]. +Proof. by rewrite horner_swapXY -{1}(hornerC y x) horner_map. Qed. + +Lemma horner_poly_XaY p v : (poly_XaY p).[v] = p \Po (v + 'X). +Proof. by rewrite horner_comp !hornerE. Qed. + +Lemma horner_poly_XmY p v : (poly_XmY p).[v] = p \Po (v * 'X). +Proof. by rewrite horner_comp !hornerE. Qed. + +End PolyXY_ComRing. + +Section PolyXY_Idomain. + +Variable R : idomainType. +Implicit Types (p q : {poly R}) (x y : R). + +Lemma size_poly_XaY p : size (poly_XaY p) = size p. +Proof. by rewrite size_comp_poly2 ?size_XaddC // size_map_polyC. Qed. + +Lemma poly_XaY_eq0 p : (poly_XaY p == 0) = (p == 0). +Proof. by rewrite -!size_poly_eq0 size_poly_XaY. Qed. + +Lemma size_poly_XmY p : size (poly_XmY p) = size p. +Proof. by rewrite size_comp_poly2 ?size_XmulC ?polyX_eq0 ?size_map_polyC. Qed. + +Lemma poly_XmY_eq0 p : (poly_XmY p == 0) = (p == 0). +Proof. by rewrite -!size_poly_eq0 size_poly_XmY. Qed. + +Lemma lead_coef_poly_XaY p : lead_coef (poly_XaY p) = (lead_coef p)%:P. +Proof. +rewrite lead_coef_comp ?size_XaddC // -['Y]opprK -polyC_opp lead_coefXsubC. +by rewrite expr1n mulr1 lead_coef_map_inj //; apply: polyC_inj. +Qed. + +Lemma sub_annihilant_in_ideal p q : + 1 < size p -> 1 < size q -> + {uv : {poly {poly R}} * {poly {poly R}} + | size uv.1 < size q /\ size uv.2 < size p + & forall x y, + (sub_annihilant p q).[y] = uv.1.[x, y] * p.[x + y] + uv.2.[x, y] * q.[x]}. +Proof. +rewrite -size_poly_XaY -(size_map_polyC q) => p1_gt1 q1_gt1. +have [uv /= [ub_u ub_v Dr]] := resultant_in_ideal p1_gt1 q1_gt1. +exists uv => // x y; rewrite -[r in r.[y]](hornerC _ x%:P) Dr. +by rewrite !(hornerE, horner_comp). +Qed. + +Lemma sub_annihilantP p q x y : + p != 0 -> q != 0 -> p.[x] = 0 -> q.[y] = 0 -> + (sub_annihilant p q).[x - y] = 0. +Proof. +move=> nz_p nz_q px0 qy0. +have p_gt1: size p > 1 by have /rootP/root_size_gt1-> := px0. +have q_gt1: size q > 1 by have /rootP/root_size_gt1-> := qy0. +have [uv /= _ /(_ y)->] := sub_annihilant_in_ideal p_gt1 q_gt1. +by rewrite (addrC y) subrK px0 qy0 !mulr0 addr0. +Qed. + +Lemma sub_annihilant_neq0 p q : p != 0 -> q != 0 -> sub_annihilant p q != 0. +Proof. +rewrite resultant_eq0; set p1 := poly_XaY p => nz_p nz_q. +have [nz_p1 nz_q1]: p1 != 0 /\ q^:P != 0 by rewrite poly_XaY_eq0 map_polyC_eq0. +rewrite -leqNgt eq_leq //; apply/eqP/Bezout_coprimepPn=> // [[[u v]]] /=. +rewrite !size_poly_gt0 -andbA => /and4P[nz_u ltuq nz_v _] Duv. +have /eqP/= := congr1 (size \o (lead_coef \o swapXY)) Duv. +rewrite ltn_eqF // !rmorphM !lead_coefM (leq_trans (leq_ltn_trans _ ltuq)) //=. + rewrite -{2}[u]swapXYK -sizeYE swapXY_poly_XaY lead_coef_poly_XaY. + by rewrite mulrC mul_polyC size_scale ?max_size_lead_coefXY ?lead_coef_eq0. +rewrite swapXY_map_polyC lead_coefC size_map_polyC. +set v1 := lead_coef _; have nz_v1: v1 != 0 by rewrite lead_coef_eq0 swapXY_eq0. +rewrite [in rhs in _ <= rhs]polySpred ?mulf_neq0 // size_mul //. +by rewrite (polySpred nz_v1) addnC addnS polySpred // ltnS leq_addr. +Qed. + +Lemma div_annihilant_in_ideal p q : + 1 < size p -> 1 < size q -> + {uv : {poly {poly R}} * {poly {poly R}} + | size uv.1 < size q /\ size uv.2 < size p + & forall x y, + (div_annihilant p q).[y] = uv.1.[x, y] * p.[x * y] + uv.2.[x, y] * q.[x]}. +Proof. +rewrite -size_poly_XmY -(size_map_polyC q) => p1_gt1 q1_gt1. +have [uv /= [ub_u ub_v Dr]] := resultant_in_ideal p1_gt1 q1_gt1. +exists uv => // x y; rewrite -[r in r.[y]](hornerC _ x%:P) Dr. +by rewrite !(hornerE, horner_comp). +Qed. + +Lemma div_annihilant_neq0 p q : p != 0 -> q.[0] != 0 -> div_annihilant p q != 0. +Proof. +have factorX u: u != 0 -> root u 0 -> exists2 v, v != 0 & u = v * 'X. + move=> nz_u /factor_theorem[v]; rewrite subr0 => Du; exists v => //. + by apply: contraNneq nz_u => v0; rewrite Du v0 mul0r. +have nzX: 'X != 0 := monic_neq0 (monicX _); have rootC0 := root_polyC _ 0. +rewrite resultant_eq0 -leqNgt -rootE // => nz_p nz_q0; apply/eq_leq/eqP. +have nz_q: q != 0 by apply: contraNneq nz_q0 => ->; rewrite root0. +apply/Bezout_coprimepPn; rewrite ?map_polyC_eq0 ?poly_XmY_eq0 // => [[uv]]. +rewrite !size_poly_gt0 -andbA ltnNge => /and4P[nz_u /negP ltuq nz_v _] Duv. +pose u := swapXY uv.1; pose v := swapXY uv.2. +suffices{ltuq}: size q <= sizeY u by rewrite sizeYE swapXYK -size_map_polyC. +have{nz_u nz_v} [nz_u nz_v Dvu]: [/\ u != 0, v != 0 & q *: v = u * poly_XmY p]. + rewrite !swapXY_eq0; split=> //; apply: (can_inj swapXYK). + by rewrite linearZ rmorphM /= !swapXYK swapXY_poly_XmY Duv mulrC. +have{Duv} [n ltvn]: {n | size v < n} by exists (size v).+1. +elim: n {uv} => // n IHn in p (v) (u) nz_u nz_v Dvu nz_p ltvn *. +have Dp0: root (poly_XmY p) 0 = root p 0 by rewrite root_comp !hornerE rootC0. +have Dv0: root u 0 || root p 0 = root v 0 by rewrite -Dp0 -rootM -Dvu rootZ. +have [v0_0 | nz_v0] := boolP (root v 0); last first. + have nz_p0: ~~ root p 0 by apply: contra nz_v0; rewrite -Dv0 orbC => ->. + apply: (@leq_trans (size (q * v.[0]))). + by rewrite size_mul // (polySpred nz_v0) addnS leq_addr. + rewrite -hornerZ Dvu !(horner_comp, hornerE) horner_map mulrC size_Cmul //. + by rewrite horner_coef0 max_size_coefXY. +have [v1 nz_v1 Dv] := factorX _ _ nz_v v0_0; rewrite Dv size_mulX // in ltvn. +have /orP[/factorX[//|u1 nz_u1 Du] | p0_0]: root u 0 || root p 0 by rewrite Dv0. + rewrite Du sizeY_mulX; apply: IHn nz_u1 nz_v1 _ nz_p ltvn. + by apply: (mulIf (nzX _)); rewrite mulrAC -scalerAl -Du -Dv. +have /factorX[|v2 nz_v2 Dv1]: root (swapXY v1) 0; rewrite ?swapXY_eq0 //. + suffices: root (swapXY v1 * 'Y) 0 by rewrite mulrC mul_polyC rootZ ?polyX_eq0. + have: root (swapXY (q *: v)) 0. + by rewrite Dvu rmorphM rootM /= swapXY_poly_XmY Dp0 p0_0 orbT. + by rewrite linearZ rootM rootC0 (negPf nz_q0) /= Dv rmorphM /= swapXY_X. +rewrite ltnS (canRL swapXYK Dv1) -sizeYE sizeY_mulX sizeYE in ltvn. +have [p1 nz_p1 Dp] := factorX _ _ nz_p p0_0. +apply: IHn nz_u _ _ nz_p1 ltvn; first by rewrite swapXY_eq0. +apply: (@mulIf _ ('X * 'Y)); first by rewrite mulf_neq0 ?polyC_eq0 ?nzX. +rewrite -scalerAl mulrA mulrAC -{1}swapXY_X -rmorphM /= -Dv1 swapXYK -Dv Dvu. +by rewrite /poly_XmY Dp rmorphM /= map_polyX comp_polyM comp_polyX mulrA. +Qed. + +End PolyXY_Idomain. + +Section PolyXY_Field. + +Variables (F E : fieldType) (FtoE : {rmorphism F -> E}). + +Local Notation pFtoE := (map_poly (GRing.RMorphism.apply FtoE)). + +Lemma div_annihilantP (p q : {poly E}) (x y : E) : + p != 0 -> q != 0 -> y != 0 -> p.[x] = 0 -> q.[y] = 0 -> + (div_annihilant p q).[x / y] = 0. +Proof. +move=> nz_p nz_q nz_y px0 qy0. +have p_gt1: size p > 1 by have /rootP/root_size_gt1-> := px0. +have q_gt1: size q > 1 by have /rootP/root_size_gt1-> := qy0. +have [uv /= _ /(_ y)->] := div_annihilant_in_ideal p_gt1 q_gt1. +by rewrite (mulrC y) divfK // px0 qy0 !mulr0 addr0. +Qed. + +Lemma map_sub_annihilantP (p q : {poly F}) (x y : E) : + p != 0 -> q != 0 ->(p ^ FtoE).[x] = 0 -> (q ^ FtoE).[y] = 0 -> + (sub_annihilant p q ^ FtoE).[x - y] = 0. +Proof. +move=> nz_p nz_q px0 qy0; have pFto0 := map_poly_eq0 FtoE. +rewrite map_resultant ?pFto0 ?lead_coef_eq0 ?map_poly_eq0 ?poly_XaY_eq0 //. +rewrite map_comp_poly rmorphD /= map_polyC /= !map_polyX -!map_poly_comp /=. +by rewrite !(eq_map_poly (map_polyC _)) !map_poly_comp sub_annihilantP ?pFto0. +Qed. + +Lemma map_div_annihilantP (p q : {poly F}) (x y : E) : + p != 0 -> q != 0 -> y != 0 -> (p ^ FtoE).[x] = 0 -> (q ^ FtoE).[y] = 0 -> + (div_annihilant p q ^ FtoE).[x / y] = 0. +Proof. +move=> nz_p nz_q nz_y px0 qy0; have pFto0 := map_poly_eq0 FtoE. +rewrite map_resultant ?pFto0 ?lead_coef_eq0 ?map_poly_eq0 ?poly_XmY_eq0 //. +rewrite map_comp_poly rmorphM /= map_polyC /= !map_polyX -!map_poly_comp /=. +by rewrite !(eq_map_poly (map_polyC _)) !map_poly_comp div_annihilantP ?pFto0. +Qed. + +Lemma root_annihilant x p (pEx := (p ^ pFtoE).[x%:P]) : + pEx != 0 -> algebraicOver FtoE x -> + exists2 r : {poly F}, r != 0 & forall y, root pEx y -> root (r ^ FtoE) y. +Proof. +move=> nz_px [q nz_q qx0]. +have [/size1_polyC Dp | p_gt1] := leqP (size p) 1. + by rewrite {}/pEx Dp map_polyC hornerC map_poly_eq0 in nz_px *; exists p`_0. +have nz_p: p != 0 by rewrite -size_poly_gt0 ltnW. +elim: {q}_.+1 {-2}q (ltnSn (size q)) => // m IHm q le_qm in nz_q qx0 *. +have nz_q1: q^:P != 0 by rewrite map_poly_eq0. +have sz_q1: size q^:P = size q by rewrite size_map_polyC. +have q1_gt1: size q^:P > 1. + by rewrite sz_q1 -(size_map_poly FtoE) (root_size_gt1 _ qx0) ?map_poly_eq0. +have [uv _ Dr] := resultant_in_ideal p_gt1 q1_gt1; set r := resultant p _ in Dr. +have /eqP q1x0: (q^:P ^ pFtoE).[x%:P] == 0. + by rewrite -swapXY_polyC -swapXY_map horner_swapXY !map_polyC polyC_eq0. +have [|r_nz] := boolP (r == 0); last first. + exists r => // y pxy0; rewrite -[r ^ _](hornerC _ x%:P) -map_polyC Dr. + by rewrite rmorphD !rmorphM !hornerE q1x0 mulr0 addr0 rootM pxy0 orbT. +rewrite resultant_eq0 => /gtn_eqF/Bezout_coprimepPn[]// [q2 p1] /=. +rewrite size_poly_gt0 sz_q1 => /andP[/andP[nz_q2 ltq2] _] Dq. +pose n := (size (lead_coef q2)).-1; pose q3 := map_poly (coefp n) q2. +have nz_q3: q3 != 0 by rewrite map_poly_eq0_id0 ?lead_coef_eq0. +apply: (IHm q3); rewrite ?(leq_ltn_trans (size_poly _ _)) ?(leq_trans ltq2) //. +have /polyP/(_ n)/eqP: (q2 ^ pFtoE).[x%:P] = 0. +apply: (mulIf nz_px); rewrite -hornerM -rmorphM Dq rmorphM hornerM /= q1x0. + by rewrite mul0r mulr0. +rewrite coef0; congr (_ == 0); rewrite !horner_coef coef_sum. +rewrite size_map_poly !size_map_poly_id0 ?map_poly_eq0 ?lead_coef_eq0 //. +by apply: eq_bigr => i _; rewrite -rmorphX coefMC !coef_map. +Qed. + +Lemma algebraic_root_polyXY x y : + (let pEx p := (p ^ map_poly FtoE).[x%:P] in + exists2 p, pEx p != 0 & root (pEx p) y) -> + algebraicOver FtoE x -> algebraicOver FtoE y. +Proof. by case=> p nz_px pxy0 /(root_annihilant nz_px)[r]; exists r; auto. Qed. + +End PolyXY_Field. diff --git a/mathcomp/algebra/polydiv.v b/mathcomp/algebra/polydiv.v new file mode 100644 index 0000000..eca9a27 --- /dev/null +++ b/mathcomp/algebra/polydiv.v @@ -0,0 +1,3418 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype. +Require Import bigop ssralg poly. + +(******************************************************************************) +(* This file provides a library for the basic theory of Euclidean and pseudo- *) +(* Euclidean division for polynomials over ring structures. *) +(* The library defines two versions of the pseudo-euclidean division: one for *) +(* coefficients in a (not necessarily commutative) ring structure and one for *) +(* coefficients equipped with a structure of integral domain. From the latter *) +(* we derive the definition of the usual Euclidean division for coefficients *) +(* in a field. Only the definition of the pseudo-division for coefficients in *) +(* an integral domain is exported by default and benefits from notations. *) +(* Also, the only theory exported by default is the one of division for *) +(* polynomials with coefficients in a field. *) +(* Other definitions and facts are qualified using name spaces indicating the *) +(* hypotheses made on the structure of coefficients and the properties of the *) +(* polynomial one divides with. *) +(* *) +(* Pdiv.Field (exported by the present library): *) +(* edivp p q == pseudo-division of p by q with p q : {poly R} where *) +(* R is an idomainType. *) +(* Computes (k, quo, rem) : nat * {poly r} * {poly R}, *) +(* such that size rem < size q and: *) +(* + if lead_coef q is not a unit, then: *) +(* (lead_coef q ^+ k) *: p = q * quo + rem *) +(* + else if lead_coef q is a unit, then: *) +(* p = q * quo + rem and k = 0 *) +(* p %/ q == quotient (second component) computed by (edivp p q). *) +(* p %% q == remainder (third component) computed by (edivp p q). *) +(* scalp p q == exponent (first component) computed by (edivp p q). *) +(* p %| q == tests the nullity of the remainder of the *) +(* pseudo-division of p by q. *) +(* rgcdp p q == Pseudo-greater common divisor obtained by performing *) +(* the Euclidean algorithm on p and q using redivp as *) +(* Euclidean division. *) +(* p %= q == p and q are associate polynomials, i.e., p %| q and *) +(* q %| p, or equivalently, p = c *: q for some nonzero *) +(* constant c. *) +(* gcdp p q == Pseudo-greater common divisor obtained by performing *) +(* the Euclidean algorithm on p and q using edivp as *) +(* Euclidean division. *) +(* egcdp p q == The pair of Bezout coefficients: if e := egcdp p q, *) +(* then size e.1 <= size q, size e.2 <= size p, and *) +(* gcdp p q %= e.1 * p + e.2 * q *) +(* coprimep p q == p and q are coprime, i.e., (gcdp p q) is a nonzero *) +(* constant. *) +(* gdcop q p == greatest divisor of p which is coprime to q. *) +(* irreducible_poly p <-> p has only trivial (constant) divisors. *) +(* *) +(* Pdiv.Idomain: theory available for edivp and the related operation under *) +(* the sole assumption that the ring of coefficients is canonically an *) +(* integral domain (R : idomainType). *) +(* *) +(* Pdiv.IdomainMonic: theory available for edivp and the related operations *) +(* under the assumption that the ring of coefficients is canonically *) +(* and integral domain (R : idomainType) an the divisor is monic. *) +(* *) +(* Pdiv.IdomainUnit: theory available for edivp and the related operations *) +(* under the assumption that the ring of coefficients is canonically an *) +(* integral domain (R : idomainType) and the leading coefficient of the *) +(* divisor is a unit. *) +(* *) +(* Pdiv.ClosedField: theory available for edivp and the related operation *) +(* under the sole assumption that the ring of coefficients is canonically *) +(* an algebraically closed field (R : closedField). *) +(* *) +(* Pdiv.Ring : *) +(* redivp p q == pseudo-division of p by q with p q : {poly R} where R is *) +(* a ringType. *) +(* Computes (k, quo, rem) : nat * {poly r} * {poly R}, *) +(* such that if rem = 0 then quo * q = p * (lead_coef q ^+ k) *) +(* *) +(* rdivp p q == quotient (second component) computed by (redivp p q). *) +(* rmodp p q == remainder (third component) computed by (redivp p q). *) +(* rscalp p q == exponent (first component) computed by (redivp p q). *) +(* rdvdp p q == tests the nullity of the remainder of the pseudo-division *) +(* of p by q. *) +(* rgcdp p q == analogue of gcdp for coefficients in a ringType. *) +(* rgdcop p q == analogue of gdcop for coefficients in a ringType. *) +(*rcoprimep p q == analogue of coprimep p q for coefficients in a ringType. *) +(* *) +(* Pdiv.RingComRreg : theory of the operations defined in Pdiv.Ring, when the *) +(* ring of coefficients is canonically commutative (R : comRingType) and *) +(* the leading coefficient of the divisor is both right regular and *) +(* commutes as a constant polynomial with the divisor itself *) +(* *) +(* Pdiv.RingMonic : theory of the operations defined in Pdiv.Ring, under the *) +(* assumption that the divisor is monic. *) +(* *) +(* Pdiv.UnitRing: theory of the operations defined in Pdiv.Ring, when the *) +(* ring R of coefficients is canonically with units (R : unitRingType). *) +(* *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GRing.Theory. +Local Open Scope ring_scope. + +Reserved Notation "p %= q" (at level 70, no associativity). + +Local Notation simp := Monoid.simpm. + +Module Pdiv. + +Module CommonRing. + +Section RingPseudoDivision. + +Variable R : ringType. +Implicit Types d p q r : {poly R}. + +(* Pseudo division, defined on an arbitrary ring *) +Definition redivp_rec (q : {poly R}) := + let sq := size q in + let cq := lead_coef q in + fix loop (k : nat) (qq r : {poly R})(n : nat) {struct n} := + if size r < sq then (k, qq, r) else + let m := (lead_coef r) *: 'X^(size r - sq) in + let qq1 := qq * cq%:P + m in + let r1 := r * cq%:P - m * q in + if n is n1.+1 then loop k.+1 qq1 r1 n1 else (k.+1, qq1, r1). + +Definition redivp_expanded_def p q := + if q == 0 then (0%N, 0, p) else redivp_rec q 0 0 p (size p). +Fact redivp_key : unit. Proof. by []. Qed. +Definition redivp : {poly R} -> {poly R} -> nat * {poly R} * {poly R} := + locked_with redivp_key redivp_expanded_def. +Canonical redivp_unlockable := [unlockable fun redivp]. + +Definition rdivp p q := ((redivp p q).1).2. +Definition rmodp p q := (redivp p q).2. +Definition rscalp p q := ((redivp p q).1).1. +Definition rdvdp p q := rmodp q p == 0. +(*Definition rmultp := [rel m d | rdvdp d m].*) +Lemma redivp_def p q : redivp p q = (rscalp p q, rdivp p q, rmodp p q). +Proof. by rewrite /rscalp /rdivp /rmodp; case: (redivp p q) => [[]] /=. Qed. + +Lemma rdiv0p p : rdivp 0 p = 0. +Proof. +rewrite /rdivp unlock; case: ifP => // Hp; rewrite /redivp_rec !size_poly0. +by rewrite polySpred ?Hp. +Qed. + +Lemma rdivp0 p : rdivp p 0 = 0. +Proof. by rewrite /rdivp unlock eqxx. Qed. + +Lemma rdivp_small p q : size p < size q -> rdivp p q = 0. +Proof. +rewrite /rdivp unlock; case: eqP => Eq; first by rewrite Eq size_poly0. +by case sp: (size p) => [| s] hs /=; rewrite sp hs. +Qed. + +Lemma leq_rdivp p q : (size (rdivp p q) <= size p). +Proof. +case: (ltnP (size p) (size q)); first by move/rdivp_small->; rewrite size_poly0. +rewrite /rdivp /rmodp /rscalp unlock; case q0 : (q == 0) => /=. + by rewrite size_poly0. +have : (size (0 : {poly R})) <= size p by rewrite size_poly0. +move: (leqnn (size p)); move: {2 3 4 6}(size p)=> A. +elim: (size p) 0%N (0 : {poly R}) {1 3 4}p (leqnn (size p)) => [| n ihn] k q1 r. + by move/size_poly_leq0P->; rewrite /= size_poly0 lt0n size_poly_eq0 q0. +move=> /= hrn hr hq1 hq; case: ltnP=> //= hqr. +have sr: 0 < size r by apply: leq_trans hqr; rewrite size_poly_gt0 q0. +have sq: 0 < size q by rewrite size_poly_gt0 q0. +apply: ihn => //. +- apply/leq_sizeP => j hnj. + rewrite coefB -scalerAl coefZ coefXnM ltn_subRL ltnNge. + have hj : (size r).-1 <= j. + by apply: leq_trans hnj; move: hrn; rewrite -{1}(prednK sr) ltnS. + rewrite polySpred -?size_poly_gt0 // (leq_ltn_trans hj) /=; last first. + by rewrite -{1}(add0n j) ltn_add2r. + move: (hj); rewrite leq_eqVlt; case/orP. + move/eqP<-; rewrite (@polySpred _ q) ?q0 // subSS coefMC. + rewrite subKn; first by rewrite lead_coefE subrr. + by rewrite -ltnS -!polySpred // ?q0 -?size_poly_gt0. + move=> {hj} hj; move: (hj); rewrite prednK // coefMC; move/leq_sizeP=> -> //. + suff: size q <= j - (size r - size q). + by rewrite mul0r sub0r; move/leq_sizeP=> -> //; rewrite mulr0 oppr0. + rewrite subnBA // addnC -(prednK sq) -(prednK sr) addSn subSS. + by rewrite -addnBA ?(ltnW hj) // -{1}[_.-1]addn0 ltn_add2l subn_gt0. +- apply: leq_trans (size_add _ _) _; rewrite geq_max; apply/andP; split. + apply: leq_trans (size_mul_leq _ _) _. + by rewrite size_polyC lead_coef_eq0 q0 /= addn1. + rewrite size_opp; apply: leq_trans (size_mul_leq _ _) _. + apply: leq_trans hr; rewrite -subn1 leq_subLR -{2}(subnK hqr) addnA leq_add2r. + by rewrite add1n -(@size_polyXn R) size_scale_leq. +apply: leq_trans (size_add _ _) _; rewrite geq_max; apply/andP; split. + apply: leq_trans (size_mul_leq _ _) _. + by rewrite size_polyC lead_coef_eq0 q0 /= addnS addn0. +apply: leq_trans (size_scale_leq _ _) _; rewrite size_polyXn. +by rewrite -subSn // leq_subLR -add1n leq_add. +Qed. + +Lemma rmod0p p : rmodp 0 p = 0. +Proof. +rewrite /rmodp unlock; case: ifP => // Hp; rewrite /redivp_rec !size_poly0. +by rewrite polySpred ?Hp. +Qed. + +Lemma rmodp0 p : rmodp p 0 = p. +Proof. by rewrite /rmodp unlock eqxx. Qed. + +Lemma rscalp_small p q : size p < size q -> rscalp p q = 0%N. +Proof. +rewrite /rscalp unlock; case: eqP => Eq // spq. +by case sp: (size p) => [| s] /=; rewrite spq. +Qed. + +Lemma ltn_rmodp p q : (size (rmodp p q) < size q) = (q != 0). +Proof. +rewrite /rdivp /rmodp /rscalp unlock; case q0 : (q == 0). + by rewrite (eqP q0) /= size_poly0 ltn0. +elim: (size p) 0%N 0 {1 3}p (leqnn (size p)) => [|n ihn] k q1 r. + rewrite leqn0 size_poly_eq0; move/eqP->; rewrite /= size_poly0 /= lt0n. + by rewrite size_poly_eq0 q0 /= size_poly0 lt0n size_poly_eq0 q0. +move=> hr /=; case: (@ltnP (size r) _) => //= hsrq; rewrite ihn //. +apply/leq_sizeP => j hnj; rewrite coefB. +have sr: 0 < size r. + by apply: leq_trans hsrq; apply: neq0_lt0n; rewrite size_poly_eq0. +have sq: 0 < size q by rewrite size_poly_gt0 q0. +have hj : (size r).-1 <= j. + by apply: leq_trans hnj; move: hr; rewrite -{1}(prednK sr) ltnS. +rewrite -scalerAl !coefZ coefXnM ltn_subRL ltnNge; move: (sr). +move/prednK => {1}<-. +have -> /= : (size r).-1 < size q + j. + apply: (@leq_trans ((size q) + (size r).-1)); last by rewrite leq_add2l. + by rewrite -{1}[_.-1]add0n ltn_add2r. +move: (hj); rewrite leq_eqVlt; case/orP. + move/eqP<-; rewrite -{1}(prednK sq) -{3}(prednK sr) subSS. + rewrite subKn; first by rewrite coefMC !lead_coefE subrr. + by move: hsrq; rewrite -{1}(prednK sq) -{1}(prednK sr) ltnS. +move=> {hj} hj; move: (hj); rewrite prednK // coefMC; move/leq_sizeP=> -> //. +suff: size q <= j - (size r - size q). + by rewrite mul0r sub0r; move/leq_sizeP=> -> //; rewrite mulr0 oppr0. +rewrite subnBA // addnC -(prednK sq) -(prednK sr) addSn subSS. +by rewrite -addnBA ?(ltnW hj) // -{1}[_.-1]addn0 ltn_add2l subn_gt0. +Qed. + +Lemma ltn_rmodpN0 p q : q != 0 -> size (rmodp p q) < size q. +Proof. by rewrite ltn_rmodp. Qed. + +Lemma rmodp1 p : rmodp p 1 = 0. +Proof. +case p0: (p == 0); first by rewrite (eqP p0) rmod0p. +apply/eqP; rewrite -size_poly_eq0. +by have := (ltn_rmodp p 1); rewrite size_polyC !oner_neq0 ltnS leqn0. +Qed. + +Lemma rmodp_small p q : size p < size q -> rmodp p q = p. +Proof. +rewrite /rmodp unlock; case: eqP => Eq; first by rewrite Eq size_poly0. +by case sp: (size p) => [| s] Hs /=; rewrite sp Hs /=. +Qed. + +Lemma leq_rmodp m d : size (rmodp m d) <= size m. +Proof. +case: (ltnP (size m) (size d)) => [|h]; first by move/rmodp_small->. +case d0: (d == 0); first by rewrite (eqP d0) rmodp0. +by apply: leq_trans h; apply: ltnW; rewrite ltn_rmodp d0. +Qed. + +Lemma rmodpC p c : c != 0 -> rmodp p c%:P = 0. +Proof. +move=> Hc; apply/eqP; rewrite -size_poly_eq0 -leqn0 -ltnS. +have -> : 1%N = nat_of_bool (c != 0) by rewrite Hc. +by rewrite -size_polyC ltn_rmodp polyC_eq0. +Qed. + +Lemma rdvdp0 d : rdvdp d 0. +Proof. by rewrite /rdvdp rmod0p. Qed. + +Lemma rdvd0p n : (rdvdp 0 n) = (n == 0). +Proof. by rewrite /rdvdp rmodp0. Qed. + +Lemma rdvd0pP n : reflect (n = 0) (rdvdp 0 n). +Proof. by apply: (iffP idP); rewrite rdvd0p; move/eqP. Qed. + +Lemma rdvdpN0 p q : rdvdp p q -> q != 0 -> p != 0. +Proof. by move=> pq hq; apply: contraL pq => /eqP ->; rewrite rdvd0p. Qed. + +Lemma rdvdp1 d : (rdvdp d 1) = ((size d) == 1%N). +Proof. +rewrite /rdvdp; case d0: (d == 0). + by rewrite (eqP d0) rmodp0 size_poly0 (negPf (@oner_neq0 _)). +have:= (size_poly_eq0 d); rewrite d0; move/negbT; rewrite -lt0n. +rewrite leq_eqVlt; case/orP => hd; last first. + by rewrite rmodp_small ?size_poly1 // oner_eq0 -(subnKC hd). +rewrite eq_sym in hd; rewrite hd; have [c cn0 ->] := size_poly1P _ hd. +rewrite /rmodp unlock -size_poly_eq0 size_poly1 /= size_poly1 size_polyC cn0 /=. +by rewrite polyC_eq0 (negPf cn0) !lead_coefC !scale1r subrr !size_poly0. +Qed. + +Lemma rdvd1p m : rdvdp 1 m. +Proof. by rewrite /rdvdp rmodp1. Qed. + +Lemma Nrdvdp_small (n d : {poly R}) : + n != 0 -> size n < size d -> (rdvdp d n) = false. +Proof. +by move=> nn0 hs; rewrite /rdvdp; rewrite (rmodp_small hs); apply: negPf. +Qed. + +Lemma rmodp_eq0P p q : reflect (rmodp p q = 0) (rdvdp q p). +Proof. exact: (iffP eqP). Qed. + +Lemma rmodp_eq0 p q : rdvdp q p -> rmodp p q = 0. +Proof. by move/rmodp_eq0P. Qed. + +Lemma rdvdp_leq p q : rdvdp p q -> q != 0 -> size p <= size q. +Proof. by move=> dvd_pq; rewrite leqNgt; apply: contra => /rmodp_small <-. Qed. + +Definition rgcdp p q := + let: (p1, q1) := if size p < size q then (q, p) else (p, q) in + if p1 == 0 then q1 else + let fix loop (n : nat) (pp qq : {poly R}) {struct n} := + let rr := rmodp pp qq in + if rr == 0 then qq else + if n is n1.+1 then loop n1 qq rr else rr in + loop (size p1) p1 q1. + +Lemma rgcd0p : left_id 0 rgcdp. +Proof. +move=> p; rewrite /rgcdp size_poly0 size_poly_gt0 if_neg. +case: ifP => /= [_ | nzp]; first by rewrite eqxx. +by rewrite polySpred !(rmodp0, nzp) //; case: _.-1 => [|m]; rewrite rmod0p eqxx. +Qed. + +Lemma rgcdp0 : right_id 0 rgcdp. +Proof. +move=> p; have:= rgcd0p p; rewrite /rgcdp size_poly0 size_poly_gt0 if_neg. +by case: ifP => /= p0; rewrite ?(eqxx, p0) // (eqP p0). +Qed. + +Lemma rgcdpE p q : + rgcdp p q = if size p < size q + then rgcdp (rmodp q p) p else rgcdp (rmodp p q) q. +Proof. +pose rgcdp_rec := fix rgcdp_rec (n : nat) (pp qq : {poly R}) {struct n} := + let rr := rmodp pp qq in + if rr == 0 then qq else + if n is n1.+1 then rgcdp_rec n1 qq rr else rr. +have Irec: forall m n p q, size q <= m -> size q <= n + -> size q < size p -> rgcdp_rec m p q = rgcdp_rec n p q. + + elim=> [|m Hrec] [|n] //= p1 q1. + - rewrite leqn0 size_poly_eq0; move/eqP=> -> _. + rewrite size_poly0 size_poly_gt0 rmodp0 => nzp. + by rewrite (negPf nzp); case: n => [|n] /=; rewrite rmod0p eqxx. + - rewrite leqn0 size_poly_eq0 => _; move/eqP=> ->. + rewrite size_poly0 size_poly_gt0 rmodp0 => nzp. + by rewrite (negPf nzp); case: m {Hrec} => [|m] /=; rewrite rmod0p eqxx. + case: ifP => Epq Sm Sn Sq //; rewrite ?Epq //. + case: (eqVneq q1 0) => [->|nzq]. + by case: n m {Sm Sn Hrec} => [|m] [|n] //=; rewrite rmod0p eqxx. + apply: Hrec; last by rewrite ltn_rmodp. + by rewrite -ltnS (leq_trans _ Sm) // ltn_rmodp. + by rewrite -ltnS (leq_trans _ Sn) // ltn_rmodp. +case: (eqVneq p 0) => [-> | nzp]. + by rewrite rmod0p rmodp0 rgcd0p rgcdp0 if_same. +case: (eqVneq q 0) => [-> | nzq]. + by rewrite rmod0p rmodp0 rgcd0p rgcdp0 if_same. +rewrite /rgcdp -/rgcdp_rec. +case: ltnP; rewrite (negPf nzp, negPf nzq) //=. + move=> ltpq; rewrite ltn_rmodp (negPf nzp) //=. + rewrite -(ltn_predK ltpq) /=; case: eqP => [->|]. + by case: (size p) => [|[|s]]; rewrite /= rmodp0 (negPf nzp) // rmod0p eqxx. + move/eqP=> nzqp; rewrite (negPf nzp). + apply: Irec => //; last by rewrite ltn_rmodp. + by rewrite -ltnS (ltn_predK ltpq) (leq_trans _ ltpq) ?leqW // ltn_rmodp. + by rewrite ltnW // ltn_rmodp. +move=> leqp; rewrite ltn_rmodp (negPf nzq) //=. +have p_gt0: size p > 0 by rewrite size_poly_gt0. +rewrite -(prednK p_gt0) /=; case: eqP => [->|]. + by case: (size q) => [|[|s]]; rewrite /= rmodp0 (negPf nzq) // rmod0p eqxx. +move/eqP=> nzpq; rewrite (negPf nzq). +apply: Irec => //; last by rewrite ltn_rmodp. + by rewrite -ltnS (prednK p_gt0) (leq_trans _ leqp) // ltn_rmodp. +by rewrite ltnW // ltn_rmodp. +Qed. + +CoInductive comm_redivp_spec m d : nat * {poly R} * {poly R} -> Type := + ComEdivnSpec k (q r : {poly R}) of + (GRing.comm d (lead_coef d)%:P -> m * (lead_coef d ^+ k)%:P = q * d + r) & + (d != 0 -> size r < size d) : comm_redivp_spec m d (k, q, r). + +Lemma comm_redivpP m d : comm_redivp_spec m d (redivp m d). +Proof. +rewrite unlock; case: (altP (d =P 0))=> [->| Hd]. + by constructor; rewrite !(simp, eqxx). +have: GRing.comm d (lead_coef d)%:P -> m * (lead_coef d ^+ 0)%:P = 0 * d + m. + by rewrite !simp. +elim: (size m) 0%N 0 {1 4 6}m (leqnn (size m))=> + [|n IHn] k q r Hr /=. + have{Hr} ->: r = 0 by apply/eqP; rewrite -size_poly_eq0; move: Hr; case: size. + suff hsd: size (0: {poly R}) < size d by rewrite hsd => /= ?; constructor. + by rewrite size_polyC eqxx (polySpred Hd). +case: ltP=> Hlt Heq; first by constructor=> // _; apply/ltP. +apply: IHn=> [|Cda]; last first. + rewrite mulrDl addrAC -addrA subrK exprSr polyC_mul mulrA Heq //. + by rewrite mulrDl -mulrA Cda mulrA. +apply/leq_sizeP => j Hj. +rewrite coefD coefN coefMC -scalerAl coefZ coefXnM. +move/ltP: Hlt; rewrite -leqNgt=> Hlt. +move: Hj; rewrite leq_eqVlt; case/predU1P => [<-{j} | Hj]; last first. + rewrite nth_default ?(leq_trans Hqq) // ?simp; last by apply: (leq_trans Hr). + rewrite nth_default; first by rewrite if_same !simp oppr0. + by rewrite -{1}(subKn Hlt) leq_sub2r // (leq_trans Hr). +move: Hr; rewrite leq_eqVlt ltnS; case/predU1P=> Hqq; last first. + rewrite !nth_default ?if_same ?simp ?oppr0 //. + by rewrite -{1}(subKn Hlt) leq_sub2r // (leq_trans Hqq). +rewrite {2}/lead_coef Hqq polySpred // subSS ltnNge leq_subr /=. +by rewrite subKn ?addrN // -subn1 leq_subLR add1n -Hqq. +Qed. + +Lemma rmodpp p : GRing.comm p (lead_coef p)%:P -> rmodp p p = 0. +Proof. +move=> hC; rewrite /rmodp unlock; case: ifP => hp /=; first by rewrite (eqP hp). +move: (hp); rewrite -size_poly_eq0 /redivp_rec; case sp: (size p)=> [|n] // _. +rewrite mul0r sp ltnn add0r subnn expr0 hC alg_polyC subrr. +by case: n sp => [|n] sp; rewrite size_polyC /= eqxx. +Qed. + +Definition rcoprimep (p q : {poly R}) := size (rgcdp p q) == 1%N. + +Fixpoint rgdcop_rec q p n := + if n is m.+1 then + if rcoprimep p q then p + else rgdcop_rec q (rdivp p (rgcdp p q)) m + else (q == 0)%:R. + +Definition rgdcop q p := rgdcop_rec q p (size p). + +Lemma rgdcop0 q : rgdcop q 0 = (q == 0)%:R. +Proof. by rewrite /rgdcop size_poly0. Qed. + +End RingPseudoDivision. + +End CommonRing. + +Module RingComRreg. + +Import CommonRing. + +Section ComRegDivisor. + +Variable R : ringType. +Variable d : {poly R}. +Hypothesis Cdl : GRing.comm d (lead_coef d)%:P. +Hypothesis Rreg : GRing.rreg (lead_coef d). + +Implicit Types p q r : {poly R}. + +Lemma redivp_eq q r : + size r < size d -> + let k := (redivp (q * d + r) d).1.1 in + let c := (lead_coef d ^+ k)%:P in + redivp (q * d + r) d = (k, q * c, r * c). +Proof. +move=> lt_rd; case: comm_redivpP=> k q1 r1; move/(_ Cdl)=> Heq. +have: d != 0 by case: (size d) lt_rd (size_poly_eq0 d) => // n _ <-. +move=> dn0; move/(_ dn0)=> Hs. +have eC : q * d * (lead_coef d ^+ k)%:P = q * (lead_coef d ^+ k)%:P * d. + by rewrite -mulrA polyC_exp (GRing.commrX k Cdl) mulrA. +suff e1 : q1 = q * (lead_coef d ^+ k)%:P. + congr (_, _, _) => //=; move/eqP: Heq; rewrite [_ + r1]addrC. + rewrite -subr_eq; move/eqP<-; rewrite e1 mulrDl addrAC -{2}(add0r (r * _)). + by rewrite eC subrr add0r. +have : (q1 - q * (lead_coef d ^+ k)%:P) * d = r * (lead_coef d ^+ k)%:P - r1. + apply: (@addIr _ r1); rewrite subrK. + apply: (@addrI _ ((q * (lead_coef d ^+ k)%:P) * d)). + by rewrite mulrDl mulNr !addrA [_ + (q1 * d)]addrC addrK -eC -mulrDl. +move/eqP; rewrite -[_ == _ - _]subr_eq0 rreg_div0 //. + by case/andP; rewrite subr_eq0; move/eqP. +rewrite size_opp; apply: (leq_ltn_trans (size_add _ _)); rewrite size_opp. +rewrite gtn_max Hs (leq_ltn_trans (size_mul_leq _ _)) //. +rewrite size_polyC; case: (_ == _); last by rewrite addnS addn0. +by rewrite addn0; apply: leq_ltn_trans lt_rd; case: size. +Qed. + +(* this is a bad name *) +Lemma rdivp_eq p : + p * (lead_coef d ^+ (rscalp p d))%:P = (rdivp p d) * d + (rmodp p d). +Proof. +rewrite /rdivp /rmodp /rscalp; case: comm_redivpP=> k q1 r1 Hc _; exact: Hc. +Qed. + +(* section variables impose an inconvenient order on parameters *) +Lemma eq_rdvdp k q1 p: + p * ((lead_coef d)^+ k)%:P = q1 * d -> rdvdp d p. +Proof. +move=> he. +have Hnq0 := rreg_lead0 Rreg; set lq := lead_coef d. +pose v := rscalp p d; pose m := maxn v k. +rewrite /rdvdp -(rreg_polyMC_eq0 _ (@rregX _ _ (m - v) Rreg)). +suff: + ((rdivp p d) * (lq ^+ (m - v))%:P - q1 * (lq ^+ (m - k))%:P) * d + + (rmodp p d) * (lq ^+ (m - v))%:P == 0. + rewrite rreg_div0 //; first by case/andP. + by rewrite rreg_size ?ltn_rmodp //; apply rregX. +rewrite mulrDl addrAC mulNr -!mulrA polyC_exp -(GRing.commrX (m-v) Cdl). +rewrite -polyC_exp mulrA -mulrDl -rdivp_eq // [(_ ^+ (m - k))%:P]polyC_exp. +rewrite -(GRing.commrX (m-k) Cdl) -polyC_exp mulrA -he -!mulrA -!polyC_mul. +rewrite -/v -!exprD addnC subnK ?leq_maxl //. +by rewrite addnC subnK ?subrr ?leq_maxr. +Qed. + +CoInductive rdvdp_spec p q : {poly R} -> bool -> Type := + | Rdvdp k q1 & p * ((lead_coef q)^+ k)%:P = q1 * q : rdvdp_spec p q 0 true + | RdvdpN & rmodp p q != 0 : rdvdp_spec p q (rmodp p q) false. + +(* Is that version useable ? *) + +Lemma rdvdp_eqP p : rdvdp_spec p d (rmodp p d) (rdvdp d p). +Proof. +case hdvd: (rdvdp d p); last by apply: RdvdpN; move/rmodp_eq0P/eqP: hdvd. +move/rmodp_eq0P: (hdvd)->; apply: (@Rdvdp _ _ (rscalp p d) (rdivp p d)). +by rewrite rdivp_eq //; move/rmodp_eq0P: (hdvd)->; rewrite addr0. +Qed. + +Lemma rdvdp_mull p : rdvdp d (p * d). +Proof. by apply: (@eq_rdvdp 0%N p); rewrite expr0 mulr1. Qed. + +Lemma rmodp_mull p : rmodp (p * d) d = 0. +Proof. +case: (d =P 0)=> Hd; first by rewrite Hd simp rmod0p. +by apply/eqP; apply: rdvdp_mull. +Qed. + +Lemma rmodpp : rmodp d d = 0. +Proof. by rewrite -{1}(mul1r d) rmodp_mull. Qed. + +Lemma rdivpp : rdivp d d = (lead_coef d ^+ rscalp d d)%:P. +have dn0 : d != 0 by rewrite -lead_coef_eq0 rreg_neq0. +move: (rdivp_eq d); rewrite rmodpp addr0. +suff ->: GRing.comm d (lead_coef d ^+ rscalp d d)%:P by move/(rreg_lead Rreg)->. +by rewrite polyC_exp; apply: commrX. +Qed. + +Lemma rdvdpp : rdvdp d d. +Proof. apply/eqP; exact: rmodpp. Qed. + +Lemma rdivpK p : rdvdp d p -> + (rdivp p d) * d = p * (lead_coef d ^+ rscalp p d)%:P. +Proof. by rewrite rdivp_eq /rdvdp; move/eqP->; rewrite addr0. Qed. + +End ComRegDivisor. + +End RingComRreg. + +Module RingMonic. + +Import CommonRing. + +Import RingComRreg. + +Section MonicDivisor. + +Variable R : ringType. +Implicit Types p q r : {poly R}. + + +Variable d : {poly R}. +Hypothesis mond : d \is monic. + +Lemma redivp_eq q r : size r < size d -> + let k := (redivp (q * d + r) d).1.1 in + redivp (q * d + r) d = (k, q, r). +Proof. +case: (monic_comreg mond)=> Hc Hr; move/(redivp_eq Hc Hr q). +by rewrite (eqP mond); move=> -> /=; rewrite expr1n !mulr1. +Qed. + +Lemma rdivp_eq p : + p = (rdivp p d) * d + (rmodp p d). +Proof. +rewrite -rdivp_eq; rewrite (eqP mond); last exact: commr1. +by rewrite expr1n mulr1. +Qed. + +Lemma rdivpp : rdivp d d = 1. +Proof. +by case: (monic_comreg mond) => hc hr; rewrite rdivpp // (eqP mond) expr1n. +Qed. + +Lemma rdivp_addl_mul_small q r : + size r < size d -> rdivp (q * d + r) d = q. +Proof. +by move=> Hd; case: (monic_comreg mond)=> Hc Hr; rewrite /rdivp redivp_eq. +Qed. + +Lemma rdivp_addl_mul q r : rdivp (q * d + r) d = q + rdivp r d. +Proof. +case: (monic_comreg mond)=> Hc Hr; rewrite {1}(rdivp_eq r) addrA. +by rewrite -mulrDl rdivp_addl_mul_small // ltn_rmodp monic_neq0. +Qed. + +Lemma rdivp_addl q r : + rdvdp d q -> rdivp (q + r) d = rdivp q d + rdivp r d. +Proof. +case: (monic_comreg mond)=> Hc Hr; rewrite {1}(rdivp_eq r) addrA. +rewrite {2}(rdivp_eq q); move/rmodp_eq0P->; rewrite addr0. +by rewrite -mulrDl rdivp_addl_mul_small // ltn_rmodp monic_neq0. +Qed. + +Lemma rdivp_addr q r : + rdvdp d r -> rdivp (q + r) d = rdivp q d + rdivp r d. +Proof. by rewrite addrC; move/rdivp_addl->; rewrite addrC. Qed. + +Lemma rdivp_mull p : rdivp (p * d) d = p. +Proof. by rewrite -[p * d]addr0 rdivp_addl_mul rdiv0p addr0. Qed. + +Lemma rmodp_mull p : rmodp (p * d) d = 0. +Proof. +apply: rmodp_mull; rewrite (eqP mond); [exact: commr1 | exact: rreg1]. +Qed. + +Lemma rmodpp : rmodp d d = 0. +Proof. +apply: rmodpp; rewrite (eqP mond); [exact: commr1 | exact: rreg1]. +Qed. + +Lemma rmodp_addl_mul_small q r : + size r < size d -> rmodp (q * d + r) d = r. +Proof. +by move=> Hd; case: (monic_comreg mond)=> Hc Hr; rewrite /rmodp redivp_eq. +Qed. + +Lemma rmodp_add p q : rmodp (p + q) d = rmodp p d + rmodp q d. +Proof. +rewrite {1}(rdivp_eq p) {1}(rdivp_eq q). +rewrite addrCA 2!addrA -mulrDl (addrC (rdivp q d)) -addrA. +rewrite rmodp_addl_mul_small //; apply: (leq_ltn_trans (size_add _ _)). +by rewrite gtn_max !ltn_rmodp // monic_neq0. +Qed. + +Lemma rmodp_mulmr p q : rmodp (p * (rmodp q d)) d = rmodp (p * q) d. +Proof. +have -> : rmodp q d = q - (rdivp q d) * d. + by rewrite {2}(rdivp_eq q) addrAC subrr add0r. +rewrite mulrDr rmodp_add -mulNr mulrA. +rewrite -{2}[rmodp _ _]addr0; congr (_ + _); exact: rmodp_mull. +Qed. + +Lemma rdvdpp : rdvdp d d. +Proof. +apply: rdvdpp; rewrite (eqP mond); [exact: commr1 | exact: rreg1]. +Qed. + +(* section variables impose an inconvenient order on parameters *) +Lemma eq_rdvdp q1 p : p = q1 * d -> rdvdp d p. +Proof. +(* this probably means I need to specify impl args for comm_rref_rdvdp *) +move=> h; apply: (@eq_rdvdp _ _ _ _ 1%N q1); rewrite (eqP mond). +- exact: commr1. +- exact: rreg1. +by rewrite expr1n mulr1. +Qed. + +Lemma rdvdp_mull p : rdvdp d (p * d). +Proof. +apply: rdvdp_mull; rewrite (eqP mond) //; [exact: commr1 | exact: rreg1]. +Qed. + +Lemma rdvdpP p : reflect (exists qq, p = qq * d) (rdvdp d p). +Proof. +case: (monic_comreg mond)=> Hc Hr; apply: (iffP idP). + case: rdvdp_eqP=> // k qq; rewrite (eqP mond) expr1n mulr1; move=> -> _. + by exists qq. +by case=> [qq]; move/eq_rdvdp. +Qed. + +Lemma rdivpK p : rdvdp d p -> (rdivp p d) * d = p. +Proof. by move=> dvddp; rewrite {2}[p]rdivp_eq rmodp_eq0 ?addr0. Qed. + +End MonicDivisor. +End RingMonic. + +Module Ring. + +Include CommonRing. +Import RingMonic. + +Section ExtraMonicDivisor. + +Variable R : ringType. + +Implicit Types d p q r : {poly R}. + +Lemma rdivp1 p : rdivp p 1 = p. +Proof. by rewrite -{1}(mulr1 p) rdivp_mull // monic1. Qed. + +Lemma rdvdp_XsubCl p x : rdvdp ('X - x%:P) p = root p x. +Proof. +have [HcX Hr] := (monic_comreg (monicXsubC x)). +apply/rmodp_eq0P/factor_theorem; last first. + case=> p1 ->; apply: rmodp_mull; exact: monicXsubC. +move=> e0; exists (rdivp p ('X - x%:P)). +by rewrite {1}(rdivp_eq (monicXsubC x) p) e0 addr0. +Qed. + +Lemma polyXsubCP p x : reflect (p.[x] = 0) (rdvdp ('X - x%:P) p). +Proof. by apply: (iffP idP); rewrite rdvdp_XsubCl; move/rootP. Qed. + + +Lemma root_factor_theorem p x : root p x = (rdvdp ('X - x%:P) p). +Proof. by rewrite rdvdp_XsubCl. Qed. + +End ExtraMonicDivisor. + +End Ring. + +Module ComRing. + +Import Ring. + +Import RingComRreg. + +Section CommutativeRingPseudoDivision. + +Variable R : comRingType. + +Implicit Types d p q m n r : {poly R}. + +CoInductive redivp_spec (m d : {poly R}) : nat * {poly R} * {poly R} -> Type := + EdivnSpec k (q r: {poly R}) of + (lead_coef d ^+ k) *: m = q * d + r & + (d != 0 -> size r < size d) : redivp_spec m d (k, q, r). + + +Lemma redivpP m d : redivp_spec m d (redivp m d). +Proof. +rewrite redivp_def; constructor; last by move=> dn0; rewrite ltn_rmodp. +by rewrite -mul_polyC mulrC rdivp_eq //= /GRing.comm mulrC. +Qed. + +Lemma rdivp_eq d p : + (lead_coef d ^+ (rscalp p d)) *: p = (rdivp p d) * d + (rmodp p d). +Proof. +rewrite /rdivp /rmodp /rscalp; case: redivpP=> k q1 r1 Hc _; exact: Hc. +Qed. + +Lemma rdvdp_eqP d p : rdvdp_spec p d (rmodp p d) (rdvdp d p). +Proof. +case hdvd: (rdvdp d p); last by apply: RdvdpN; move/rmodp_eq0P/eqP: hdvd. +move/rmodp_eq0P: (hdvd)->; apply: (@Rdvdp _ _ _ (rscalp p d) (rdivp p d)). +by rewrite mulrC mul_polyC rdivp_eq; move/rmodp_eq0P: (hdvd)->; rewrite addr0. +Qed. + +Lemma rdvdp_eq q p : + (rdvdp q p) = ((lead_coef q) ^+ (rscalp p q) *: p == (rdivp p q) * q). +apply/rmodp_eq0P/eqP; rewrite rdivp_eq; first by move->; rewrite addr0. +by move/eqP; rewrite eq_sym addrC -subr_eq subrr; move/eqP->. +Qed. + +End CommutativeRingPseudoDivision. + +End ComRing. + +Module UnitRing. + +Import Ring. + +Section UnitRingPseudoDivision. + +Variable R : unitRingType. +Implicit Type p q r d : {poly R}. + +Lemma uniq_roots_rdvdp p rs : + all (root p) rs -> uniq_roots rs -> + rdvdp (\prod_(z <- rs) ('X - z%:P)) p. +Proof. +move=> rrs; case/(uniq_roots_prod_XsubC rrs)=> q ->; apply: RingMonic.rdvdp_mull. +exact: monic_prod_XsubC. +Qed. + +End UnitRingPseudoDivision. + +End UnitRing. + +Module IdomainDefs. + +Import Ring. + +Section IDomainPseudoDivisionDefs. + +Variable R : idomainType. +Implicit Type p q r d : {poly R}. + +Definition edivp_expanded_def p q := + let: (k, d, r) as edvpq := redivp p q in + if lead_coef q \in GRing.unit then + (0%N, (lead_coef q)^-k *: d, (lead_coef q)^-k *: r) + else edvpq. +Fact edivp_key : unit. Proof. by []. Qed. +Definition edivp := locked_with edivp_key edivp_expanded_def. +Canonical edivp_unlockable := [unlockable fun edivp]. + +Definition divp p q := ((edivp p q).1).2. +Definition modp p q := (edivp p q).2. +Definition scalp p q := ((edivp p q).1).1. +Definition dvdp p q := modp q p == 0. +Definition eqp p q := (dvdp p q) && (dvdp q p). + + +End IDomainPseudoDivisionDefs. + +Notation "m %/ d" := (divp m d) : ring_scope. +Notation "m %% d" := (modp m d) : ring_scope. +Notation "p %| q" := (dvdp p q) : ring_scope. +Notation "p %= q" := (eqp p q) : ring_scope. +End IdomainDefs. + +Module WeakIdomain. + +Import Ring ComRing UnitRing IdomainDefs. + +Section WeakTheoryForIDomainPseudoDivision. + +Variable R : idomainType. +Implicit Type p q r d : {poly R}. + + +Lemma edivp_def p q : edivp p q = (scalp p q, divp p q, modp p q). +Proof. by rewrite /scalp /divp /modp; case: (edivp p q) => [[]] /=. Qed. + +Lemma edivp_redivp p q : (lead_coef q \in GRing.unit) = false -> + edivp p q = redivp p q. +Proof. by move=> hu; rewrite unlock hu; case: (redivp p q) => [[? ?] ?]. Qed. + +Lemma divpE p q : + p %/ q = if lead_coef q \in GRing.unit + then (lead_coef q)^-(rscalp p q) *: (rdivp p q) + else rdivp p q. +Proof. +by case ulcq: (lead_coef q \in GRing.unit); rewrite /divp unlock redivp_def ulcq. +Qed. + +Lemma modpE p q : + p %% q = if lead_coef q \in GRing.unit + then (lead_coef q)^-(rscalp p q) *: (rmodp p q) + else rmodp p q. +Proof. +by case ulcq: (lead_coef q \in GRing.unit); rewrite /modp unlock redivp_def ulcq. +Qed. + +Lemma scalpE p q : + scalp p q = if lead_coef q \in GRing.unit then 0%N else rscalp p q. +Proof. +by case h: (lead_coef q \in GRing.unit); rewrite /scalp unlock redivp_def h. +Qed. + +Lemma dvdpE p q : p %| q = rdvdp p q. +Proof. +rewrite /dvdp modpE /rdvdp; case ulcq: (lead_coef p \in GRing.unit)=> //. +rewrite -[_ *: _ == 0]size_poly_eq0 size_scale ?size_poly_eq0 //. +by rewrite invr_eq0 expf_neq0 //; apply: contraTneq ulcq => ->; rewrite unitr0. +Qed. + +Lemma lc_expn_scalp_neq0 p q : lead_coef q ^+ scalp p q != 0. +Proof. +case: (eqVneq q 0) => [->|nzq]; last by rewrite expf_neq0 ?lead_coef_eq0. +by rewrite /scalp 2!unlock /= eqxx lead_coef0 unitr0 /= oner_neq0. +Qed. + +Hint Resolve lc_expn_scalp_neq0. + +CoInductive edivp_spec (m d : {poly R}) : + nat * {poly R} * {poly R} -> bool -> Type := +|Redivp_spec k (q r: {poly R}) of + (lead_coef d ^+ k) *: m = q * d + r & lead_coef d \notin GRing.unit & + (d != 0 -> size r < size d) : edivp_spec m d (k, q, r) false +|Fedivp_spec (q r: {poly R}) of m = q * d + r & (lead_coef d \in GRing.unit) & + (d != 0 -> size r < size d) : edivp_spec m d (0%N, q, r) true. + +(* There are several ways to state this fact. The most appropriate statement*) +(* might be polished in light of usage. *) +Lemma edivpP m d : edivp_spec m d (edivp m d) (lead_coef d \in GRing.unit). +Proof. +have hC : GRing.comm d (lead_coef d)%:P by rewrite /GRing.comm mulrC. +case ud: (lead_coef d \in GRing.unit); last first. + rewrite edivp_redivp // redivp_def; constructor; rewrite ?ltn_rmodp // ?ud //. + by rewrite rdivp_eq. +have cdn0: lead_coef d != 0 by apply: contraTneq ud => ->; rewrite unitr0. +rewrite unlock ud redivp_def; constructor => //. + rewrite -scalerAl -scalerDr -mul_polyC. + have hn0 : (lead_coef d ^+ rscalp m d)%:P != 0. + by rewrite polyC_eq0; apply: expf_neq0. + apply: (mulfI hn0); rewrite !mulrA -exprVn !polyC_exp -exprMn -polyC_mul. + by rewrite divrr // expr1n mul1r -polyC_exp mul_polyC rdivp_eq. +move=> dn0; rewrite size_scale ?ltn_rmodp // -exprVn expf_eq0 negb_and. +by rewrite invr_eq0 cdn0 orbT. +Qed. + +Lemma edivp_eq d q r : size r < size d -> lead_coef d \in GRing.unit -> + edivp (q * d + r) d = (0%N, q, r). +Proof. +have hC : GRing.comm d (lead_coef d)%:P by exact: mulrC. +move=> hsrd hu; rewrite unlock hu; case et: (redivp _ _) => [[s qq] rr]. +have cdn0 : lead_coef d != 0. + by move: hu; case d0: (lead_coef d == 0) => //; rewrite (eqP d0) unitr0. +move: (et); rewrite RingComRreg.redivp_eq //; last by apply/rregP. +rewrite et /=; case => e1 e2; rewrite -!mul_polyC -!exprVn !polyC_exp. +suff h x y: x * (lead_coef d ^+ s)%:P = y -> ((lead_coef d)^-1)%:P ^+ s * y = x. + by congr (_, _, _); apply: h. +have hn0 : (lead_coef d)%:P ^+ s != 0 by apply: expf_neq0; rewrite polyC_eq0. +move=> hh; apply: (mulfI hn0); rewrite mulrA -exprMn -polyC_mul divrr //. +by rewrite expr1n mul1r -polyC_exp mulrC; apply: sym_eq. +Qed. + +Lemma divp_eq p q : + (lead_coef q ^+ (scalp p q)) *: p = (p %/ q) * q + (p %% q). +Proof. +rewrite divpE modpE scalpE. +case uq: (lead_coef q \in GRing.unit); last by rewrite rdivp_eq. +rewrite expr0 scale1r; case: (altP (q =P 0)) => [-> | qn0]. + rewrite mulr0 add0r lead_coef0 rmodp0 /rscalp unlock eqxx expr0 invr1. + by rewrite scale1r. +have hn0 : (lead_coef q ^+ rscalp p q)%:P != 0. + by rewrite polyC_eq0 expf_neq0 // lead_coef_eq0. +apply: (mulfI hn0). +rewrite -scalerAl -scalerDr !mul_polyC scalerA mulrV ?unitrX //. +by rewrite scale1r rdivp_eq. +Qed. + + +Lemma dvdp_eq q p : + (q %| p) = ((lead_coef q) ^+ (scalp p q) *: p == (p %/ q) * q). +Proof. +rewrite dvdpE rdvdp_eq scalpE divpE; case: ifP => ulcq //. +rewrite expr0 scale1r; apply/eqP/eqP. + by rewrite -scalerAl; move<-; rewrite scalerA mulVr ?scale1r // unitrX. +by move=> {2}->; rewrite scalerAl scalerA mulrV ?scale1r // unitrX. +Qed. + +Lemma divpK d p : d %| p -> p %/ d * d = ((lead_coef d) ^+ (scalp p d)) *: p. +Proof. by rewrite dvdp_eq; move/eqP->. Qed. + +Lemma divpKC d p : d %| p -> d * (p %/ d) = ((lead_coef d) ^+ (scalp p d)) *: p. +Proof. by move=> ?; rewrite mulrC divpK. Qed. + +Lemma dvdpP q p : + reflect (exists2 cqq, cqq.1 != 0 & cqq.1 *: p = cqq.2 * q) (q %| p). +Proof. +rewrite dvdp_eq; apply: (iffP eqP) => [e | [[c qq] cn0 e]]. + by exists (lead_coef q ^+ scalp p q, p %/ q) => //=. +apply/eqP; rewrite -dvdp_eq dvdpE. +have Ecc: c%:P != 0 by rewrite polyC_eq0. +case: (eqVneq p 0) => [->|nz_p]; first by rewrite rdvdp0. +pose p1 : {poly R} := lead_coef q ^+ rscalp p q *: qq - c *: (rdivp p q). +have E1: c *: (rmodp p q) = p1 * q. + rewrite mulrDl {1}mulNr -scalerAl -e scalerA mulrC -scalerA -scalerAl. + by rewrite -scalerBr rdivp_eq addrC addKr. +rewrite /dvdp; apply/idPn=> m_nz. +have: p1 * q != 0 by rewrite -E1 -mul_polyC mulf_neq0 // -/(dvdp q p) dvdpE. +rewrite mulf_eq0; case/norP=> p1_nz q_nz; have:= ltn_rmodp p q. +rewrite q_nz -(size_scale _ cn0) E1 size_mul //. +by rewrite polySpred // ltnNge leq_addl. +Qed. + +Lemma mulpK p q : q != 0 -> + p * q %/ q = lead_coef q ^+ scalp (p * q) q *: p. +Proof. +move=> qn0; move/rregP: (qn0); apply; rewrite -scalerAl divp_eq. +suff -> : (p * q) %% q = 0 by rewrite addr0. +rewrite modpE RingComRreg.rmodp_mull ?scaler0 ?if_same //. + by red; rewrite mulrC. +by apply/rregP; rewrite lead_coef_eq0. +Qed. + +Lemma mulKp p q : q != 0 -> + q * p %/ q = lead_coef q ^+ scalp (p * q) q *: p. +Proof. move=> ?; rewrite mulrC; exact: mulpK. Qed. + +Lemma divpp p : p != 0 -> p %/ p = (lead_coef p ^+ scalp p p)%:P. +Proof. +move=> np0; have := (divp_eq p p). +suff -> : p %% p = 0. + by rewrite addr0; move/eqP; rewrite -mul_polyC (inj_eq (mulIf np0)); move/eqP. +rewrite modpE Ring.rmodpp; last by red; rewrite mulrC. +by rewrite scaler0 if_same. +Qed. + +End WeakTheoryForIDomainPseudoDivision. + +Hint Resolve lc_expn_scalp_neq0. + +End WeakIdomain. + +Module CommonIdomain. + +Import Ring ComRing UnitRing IdomainDefs WeakIdomain. + +Section IDomainPseudoDivision. + +Variable R : idomainType. +Implicit Type p q r d m n : {poly R}. + +Lemma scalp0 p : scalp p 0 = 0%N. +Proof. by rewrite /scalp unlock lead_coef0 unitr0 unlock eqxx. Qed. + +Lemma divp_small p q : size p < size q -> p %/ q = 0. +Proof. +move=> spq; rewrite /divp unlock redivp_def /=. +by case: ifP; rewrite rdivp_small // scaler0. +Qed. + +Lemma leq_divp p q : (size (p %/ q) <= size p). +Proof. +rewrite /divp unlock redivp_def /=; case: ifP=> /=; rewrite ?leq_rdivp //. +move=> ulcq; rewrite size_scale ?leq_rdivp //. +rewrite -exprVn expf_neq0 // invr_eq0. +by move: ulcq; case lcq0: (lead_coef q == 0) => //; rewrite (eqP lcq0) unitr0. +Qed. + +Lemma div0p p : 0 %/ p = 0. +Proof. +by rewrite /divp unlock redivp_def /=; case: ifP; rewrite rdiv0p // scaler0. +Qed. + +Lemma divp0 p : p %/ 0 = 0. +Proof. +by rewrite /divp unlock redivp_def /=; case: ifP; rewrite rdivp0 // scaler0. +Qed. + +Lemma divp1 m : m %/ 1 = m. +Proof. +by rewrite divpE lead_coefC unitr1 Ring.rdivp1 expr1n invr1 scale1r. +Qed. + +Lemma modp0 p : p %% 0 = p. +Proof. +rewrite /modp unlock redivp_def; case: ifP; rewrite rmodp0 //= lead_coef0. +by rewrite unitr0. +Qed. + +Lemma mod0p p : 0 %% p = 0. +Proof. +by rewrite /modp unlock redivp_def /=; case: ifP; rewrite rmod0p // scaler0. +Qed. + +Lemma modp1 p : p %% 1 = 0. +Proof. +by rewrite /modp unlock redivp_def /=; case: ifP; rewrite rmodp1 // scaler0. +Qed. + +Hint Resolve divp0 divp1 mod0p modp0 modp1. + +Lemma modp_small p q : size p < size q -> p %% q = p. +Proof. +move=> spq; rewrite /modp unlock redivp_def; case: ifP; rewrite rmodp_small //. +by rewrite /= rscalp_small // expr0 /= invr1 scale1r. +Qed. + +Lemma modpC p c : c != 0 -> p %% c%:P = 0. +Proof. +move=> cn0; rewrite /modp unlock redivp_def /=; case: ifP; rewrite ?rmodpC //. +by rewrite scaler0. +Qed. + +Lemma modp_mull p q : (p * q) %% q = 0. +Proof. +case: (altP (q =P 0)) => [-> | nq0]; first by rewrite modp0 mulr0. +have rlcq : (GRing.rreg (lead_coef q)) by apply/rregP; rewrite lead_coef_eq0. +have hC : GRing.comm q (lead_coef q)%:P by red; rewrite mulrC. +by rewrite modpE; case: ifP => ulcq; rewrite RingComRreg.rmodp_mull // scaler0. +Qed. + +Lemma modp_mulr d p : (d * p) %% d = 0. +Proof. by rewrite mulrC modp_mull. Qed. + +Lemma modpp d : d %% d = 0. +Proof. by rewrite -{1}(mul1r d) modp_mull. Qed. + +Lemma ltn_modp p q : (size (p %% q) < size q) = (q != 0). +Proof. +rewrite /modp unlock redivp_def /=; case: ifP=> /=; rewrite ?ltn_rmodp //. +move=> ulcq; rewrite size_scale ?ltn_rmodp //. +rewrite -exprVn expf_neq0 // invr_eq0. +by move: ulcq; case lcq0: (lead_coef q == 0) => //; rewrite (eqP lcq0) unitr0. +Qed. + +Lemma ltn_divpl d q p : d != 0 -> + (size (q %/ d) < size p) = (size q < size (p * d)). +Proof. +move=> dn0; have sd : size d > 0 by rewrite size_poly_gt0 dn0. +have: (lead_coef d) ^+ (scalp q d) != 0 by exact: lc_expn_scalp_neq0. +move/size_scale; move/(_ q)<-; rewrite divp_eq; case quo0 : (q %/ d == 0). + rewrite (eqP quo0) mul0r add0r size_poly0. + case p0 : (p == 0); first by rewrite (eqP p0) mul0r size_poly0 ltnn ltn0. + have sp : size p > 0 by rewrite size_poly_gt0 p0. + rewrite /= size_mul ?p0 // sp; apply: sym_eq; move/prednK:(sp)<-. + by rewrite addSn /= ltn_addl // ltn_modp. +rewrite size_addl; last first. + rewrite size_mul ?quo0 //; move/negbT: quo0; rewrite -size_poly_gt0. + by move/prednK<-; rewrite addSn /= ltn_addl // ltn_modp. +case: (altP (p =P 0)) => [-> | pn0]; first by rewrite mul0r size_poly0 !ltn0. +by rewrite !size_mul ?quo0 //; move/prednK: sd<-; rewrite !addnS ltn_add2r. +Qed. + +Lemma leq_divpr d p q : d != 0 -> + (size p <= size (q %/ d)) = (size (p * d) <= size q). +Proof. by move=> dn0; rewrite leqNgt ltn_divpl // -leqNgt. Qed. + +Lemma divpN0 d p : d != 0 -> (p %/ d != 0) = (size d <= size p). +Proof. +move=> dn0; rewrite -{2}(mul1r d) -leq_divpr // size_polyC oner_eq0 /=. +by rewrite size_poly_gt0. +Qed. + +Lemma size_divp p q : q != 0 -> size (p %/ q) = ((size p) - (size q).-1)%N. +Proof. +move=> nq0; case: (leqP (size q) (size p)) => sqp; last first. + move: (sqp); rewrite -{1}(ltn_predK sqp) ltnS -subn_eq0 divp_small //. + by move/eqP->; rewrite size_poly0. +move: (nq0); rewrite -size_poly_gt0 => lt0sq. +move: (sqp); move/(leq_trans lt0sq) => lt0sp. +move: (lt0sp); rewrite size_poly_gt0=> p0. +move: (divp_eq p q); move/(congr1 (size \o (@polyseq R)))=> /=. +rewrite size_scale; last by rewrite expf_eq0 lead_coef_eq0 (negPf nq0) andbF. +case: (eqVneq (p %/ q) 0) => [-> | qq0]. + by rewrite mul0r add0r=> es; move: nq0; rewrite -(ltn_modp p) -es ltnNge sqp. +move/negP:(qq0); move/negP; rewrite -size_poly_gt0 => lt0qq. +rewrite size_addl. + rewrite size_mul ?qq0 // => ->. + apply/eqP; rewrite -(eqn_add2r ((size q).-1)). + rewrite subnK; first by rewrite -subn1 addnBA // subn1. + rewrite /leq -(subnDl 1%N) !add1n prednK // (@ltn_predK (size q)) //. + by rewrite addnC subnDA subnn sub0n. + by rewrite -[size q]add0n ltn_add2r. +rewrite size_mul ?qq0 //. +move: nq0; rewrite -(ltn_modp p); move/leq_trans; apply; move/prednK: lt0qq<-. +by rewrite addSn /= leq_addl. +Qed. + +Lemma ltn_modpN0 p q : q != 0 -> size (p %% q) < size q. +Proof. by rewrite ltn_modp. Qed. + +Lemma modp_mod p q : (p %% q) %% q = p %% q. +Proof. +by case: (eqVneq q 0) => [-> | qn0]; rewrite ?modp0 // modp_small ?ltn_modp. +Qed. + +Lemma leq_modp m d : size (m %% d) <= size m. +Proof. +rewrite /modp unlock redivp_def /=; case: ifP; rewrite ?leq_rmodp //. +move=> ud; rewrite size_scale ?leq_rmodp // invr_eq0 expf_neq0 //. +by apply: contraTneq ud => ->; rewrite unitr0. +Qed. + +Lemma dvdp0 d : d %| 0. +Proof. by rewrite /dvdp mod0p. Qed. + +Hint Resolve dvdp0. + +Lemma dvd0p p : (0 %| p) = (p == 0). +Proof. by rewrite /dvdp modp0. Qed. + +Lemma dvd0pP p : reflect (p = 0) (0 %| p). +Proof. by apply: (iffP idP); rewrite dvd0p; move/eqP. Qed. + +Lemma dvdpN0 p q : p %| q -> q != 0 -> p != 0. +Proof. by move=> pq hq; apply: contraL pq=> /eqP ->; rewrite dvd0p. Qed. + +Lemma dvdp1 d : (d %| 1) = ((size d) == 1%N). +Proof. +rewrite /dvdp modpE; case ud: (lead_coef d \in GRing.unit); last exact: rdvdp1. +rewrite -size_poly_eq0 size_scale; first by rewrite size_poly_eq0; exact: rdvdp1. +by rewrite invr_eq0 expf_neq0 //; apply: contraTneq ud => ->; rewrite unitr0. +Qed. + +Lemma dvd1p m : 1 %| m. +Proof. by rewrite /dvdp modp1. Qed. + +Lemma gtNdvdp p q : p != 0 -> size p < size q -> (q %| p) = false. +Proof. +by move=> nn0 hs; rewrite /dvdp; rewrite (modp_small hs); apply: negPf. +Qed. + +Lemma modp_eq0P p q : reflect (p %% q = 0) (q %| p). +Proof. exact: (iffP eqP). Qed. + +Lemma modp_eq0 p q : (q %| p) -> p %% q = 0. +Proof. by move/modp_eq0P. Qed. + +Lemma leq_divpl d p q : + d %| p -> (size (p %/ d) <= size q) = (size p <= size (q * d)). +Proof. +case: (eqVneq d 0) => [-> | nd0]. + by move/dvd0pP->; rewrite divp0 size_poly0 !leq0n. +move=> hd; rewrite leq_eqVlt ltn_divpl // (leq_eqVlt (size p)). +case lhs: (size p < size (q * d)); rewrite ?orbT ?orbF //. +have: (lead_coef d) ^+ (scalp p d) != 0 by rewrite expf_neq0 // lead_coef_eq0. +move/size_scale; move/(_ p)<-; rewrite divp_eq. +move/modp_eq0P: hd->; rewrite addr0; case: (altP (p %/ d =P 0))=> [-> | quon0]. + rewrite mul0r size_poly0 eq_sym (eq_sym 0%N) size_poly_eq0. + case: (altP (q =P 0)) => [-> | nq0]; first by rewrite mul0r size_poly0 eqxx. + by rewrite size_poly_eq0 mulf_eq0 (negPf nq0) (negPf nd0). +case: (altP (q =P 0)) => [-> | nq0]. + by rewrite mul0r size_poly0 !size_poly_eq0 mulf_eq0 (negPf nd0) orbF. +rewrite !size_mul //; move: nd0; rewrite -size_poly_gt0; move/prednK<-. +by rewrite !addnS /= eqn_add2r. +Qed. + +Lemma dvdp_leq p q : q != 0 -> p %| q -> size p <= size q. +move=> nq0 /modp_eq0P => rpq; case: (ltnP (size p) (size q)). + by move/ltnW->. +rewrite leq_eqVlt; case/orP; first by move/eqP->. +by move/modp_small; rewrite rpq => h; move: nq0; rewrite h eqxx. +Qed. + +Lemma eq_dvdp c quo q p : c != 0 -> c *: p = quo * q -> q %| p. +Proof. +move=> cn0; case: (eqVneq p 0) => [->|nz_quo def_quo] //. +pose p1 : {poly R} := lead_coef q ^+ scalp p q *: quo - c *: (p %/ q). +have E1: c *: (p %% q) = p1 * q. + rewrite mulrDl {1}mulNr-scalerAl -def_quo scalerA mulrC -scalerA. + by rewrite -scalerAl -scalerBr divp_eq addrAC subrr add0r. +rewrite /dvdp; apply/idPn=> m_nz. +have: p1 * q != 0 by rewrite -E1 -mul_polyC mulf_neq0 // polyC_eq0. +rewrite mulf_eq0; case/norP=> p1_nz q_nz. +have := (ltn_modp p q); rewrite q_nz -(size_scale (p %% q) cn0) E1. +by rewrite size_mul // polySpred // ltnNge leq_addl. +Qed. + +Lemma dvdpp d : d %| d. +Proof. by rewrite /dvdp modpp. Qed. + +Hint Resolve dvdpp. + +Lemma divp_dvd p q : (p %| q) -> ((q %/ p) %| q). +Proof. +case: (eqVneq p 0) => [-> | np0]; first by rewrite divp0. +rewrite dvdp_eq => /eqP h. +apply: (@eq_dvdp ((lead_coef p)^+ (scalp q p)) p); last by rewrite mulrC. +by rewrite expf_neq0 // lead_coef_eq0. +Qed. + +Lemma dvdp_mull m d n : d %| n -> d %| m * n. +Proof. +case: (eqVneq d 0) => [-> |dn0]; first by move/dvd0pP->; rewrite mulr0 dvdpp. +rewrite dvdp_eq => /eqP e. +apply: (@eq_dvdp (lead_coef d ^+ scalp n d) (m * (n %/ d))). + by rewrite expf_neq0 // lead_coef_eq0. +by rewrite scalerAr e mulrA. +Qed. + +Lemma dvdp_mulr n d m : d %| m -> d %| m * n. +Proof. by move=> hdm; rewrite mulrC dvdp_mull. Qed. + +Hint Resolve dvdp_mull dvdp_mulr. + +Lemma dvdp_mul d1 d2 m1 m2 : d1 %| m1 -> d2 %| m2 -> d1 * d2 %| m1 * m2. +Proof. +case: (eqVneq d1 0) => [-> |d1n0]; first by move/dvd0pP->; rewrite !mul0r dvdpp. +case: (eqVneq d2 0) => [-> |d2n0]; first by move => _ /dvd0pP ->; rewrite !mulr0. +rewrite dvdp_eq; set c1 := _ ^+ _; set q1 := _ %/ _; move/eqP=> Hq1. +rewrite dvdp_eq; set c2 := _ ^+ _; set q2 := _ %/ _; move/eqP=> Hq2. +apply: (@eq_dvdp (c1 * c2) (q1 * q2)). + by rewrite mulf_neq0 // expf_neq0 // lead_coef_eq0. +rewrite -scalerA scalerAr scalerAl Hq1 Hq2 -!mulrA. +by rewrite [d1 * (q2 * _)]mulrCA. +Qed. + +Lemma dvdp_addr m d n : d %| m -> (d %| m + n) = (d %| n). +Proof. +case: (altP (d =P 0)) => [-> | dn0]; first by move/dvd0pP->; rewrite add0r. +rewrite dvdp_eq; set c1 := _ ^+ _; set q1 := _ %/ _; move/eqP=> Eq1. +apply/idP/idP; rewrite dvdp_eq; set c2 := _ ^+ _; set q2 := _ %/ _. + have sn0 : c1 * c2 != 0. + by rewrite !mulf_neq0 // expf_eq0 lead_coef_eq0 (negPf dn0) andbF. + move/eqP=> Eq2; apply: (@eq_dvdp _ (c1 *: q2 - c2 *: q1) _ _ sn0). + rewrite mulrDl -scaleNr -!scalerAl -Eq1 -Eq2 !scalerA. + by rewrite mulNr mulrC scaleNr -scalerBr addrC addKr. +have sn0 : c1 * c2 != 0. + by rewrite !mulf_neq0 // expf_eq0 lead_coef_eq0 (negPf dn0) andbF. +move/eqP=> Eq2; apply: (@eq_dvdp _ (c1 *: q2 + c2 *: q1) _ _ sn0). +by rewrite mulrDl -!scalerAl -Eq1 -Eq2 !scalerA mulrC addrC scalerDr. +Qed. + +Lemma dvdp_addl n d m : d %| n -> (d %| m + n) = (d %| m). +Proof. by rewrite addrC; exact: dvdp_addr. Qed. + +Lemma dvdp_add d m n : d %| m -> d %| n -> d %| m + n. +Proof. by move/dvdp_addr->. Qed. + +Lemma dvdp_add_eq d m n : d %| m + n -> (d %| m) = (d %| n). +Proof. by move=> ?; apply/idP/idP; [move/dvdp_addr <-| move/dvdp_addl <-]. Qed. + +Lemma dvdp_subr d m n : d %| m -> (d %| m - n) = (d %| n). +Proof. by move=> ?; apply dvdp_add_eq; rewrite -addrA addNr simp. Qed. + +Lemma dvdp_subl d m n : d %| n -> (d %| m - n) = (d %| m). +Proof. by move/dvdp_addl<-; rewrite subrK. Qed. + +Lemma dvdp_sub d m n : d %| m -> d %| n -> d %| m - n. +Proof. by move=> *; rewrite dvdp_subl. Qed. + +Lemma dvdp_mod d n m : d %| n -> (d %| m) = (d %| m %% n). +Proof. +case: (altP (n =P 0)) => [-> | nn0]; first by rewrite modp0. +case: (altP (d =P 0)) => [-> | dn0]; first by move/dvd0pP->; rewrite modp0. +rewrite dvdp_eq; set c1 := _ ^+ _; set q1 := _ %/ _; move/eqP=> Eq1. +apply/idP/idP; rewrite dvdp_eq; set c2 := _ ^+ _; set q2 := _ %/ _. + have sn0 : c1 * c2 != 0. + by rewrite !mulf_neq0 // expf_eq0 lead_coef_eq0 (negPf dn0) andbF. + pose quo := (c1 * lead_coef n ^+ scalp m n) *: q2 - c2 *: (m %/ n) * q1. + move/eqP=> Eq2; apply: (@eq_dvdp _ quo _ _ sn0). + rewrite mulrDl mulNr -!scalerAl -!mulrA -Eq1 -Eq2 -scalerAr !scalerA. + rewrite mulrC [_ * c2]mulrC mulrA -[((_ * _) * _) *: _]scalerA -scalerBr. + by rewrite divp_eq addrC addKr. +have sn0 : c1 * c2 * lead_coef n ^+ scalp m n != 0. + rewrite !mulf_neq0 // expf_eq0 lead_coef_eq0 ?(negPf dn0) ?andbF //. + by rewrite (negPf nn0) andbF. +move/eqP=> Eq2; apply: (@eq_dvdp _ (c2 *: (m %/ n) * q1 + c1 *: q2) _ _ sn0). +rewrite -scalerA divp_eq scalerDr -!scalerA Eq2 scalerAl scalerAr Eq1. +by rewrite scalerAl mulrDl mulrA. +Qed. + +Lemma dvdp_trans : transitive (@dvdp R). +Proof. +move=> n d m. +case: (altP (d =P 0)) => [-> | dn0]; first by move/dvd0pP->. +case: (altP (n =P 0)) => [-> | nn0]; first by move=> _ /dvd0pP ->. +rewrite dvdp_eq; set c1 := _ ^+ _; set q1 := _ %/ _; move/eqP=> Hq1. +rewrite dvdp_eq; set c2 := _ ^+ _; set q2 := _ %/ _; move/eqP=> Hq2. +have sn0 : c1 * c2 != 0 by rewrite mulf_neq0 // expf_neq0 // lead_coef_eq0. +by apply: (@eq_dvdp _ (q2 * q1) _ _ sn0); rewrite -scalerA Hq2 scalerAr Hq1 mulrA. +Qed. + +Lemma dvdp_mulIl p q : p %| p * q. +Proof. by apply: dvdp_mulr; exact: dvdpp. Qed. + +Lemma dvdp_mulIr p q : q %| p * q. +Proof. by apply: dvdp_mull; exact: dvdpp. Qed. + +Lemma dvdp_mul2r r p q : r != 0 -> (p * r %| q * r) = (p %| q). +Proof. +move => nzr. +case: (eqVneq p 0) => [-> | pn0]. + by rewrite mul0r !dvd0p mulf_eq0 (negPf nzr) orbF. +case: (eqVneq q 0) => [-> | qn0]; first by rewrite mul0r !dvdp0. +apply/idP/idP; last by move => ?; rewrite dvdp_mul ?dvdpp. +rewrite dvdp_eq; set c := _ ^+ _; set x := _ %/ _; move/eqP=> Hx. +apply: (@eq_dvdp c x). + by rewrite expf_neq0 // lead_coef_eq0 mulf_neq0. +by apply: (GRing.mulIf nzr); rewrite -GRing.mulrA -GRing.scalerAl. +Qed. + +Lemma dvdp_mul2l r p q: r != 0 -> (r * p %| r * q) = (p %| q). +Proof. by rewrite ![r * _]GRing.mulrC; apply: dvdp_mul2r. Qed. + +Lemma ltn_divpr d p q : + d %| q -> (size p < size (q %/ d)) = (size (p * d) < size q). +Proof. by move=> dv_d_q; rewrite !ltnNge leq_divpl. Qed. + +Lemma dvdp_exp d k p : 0 < k -> d %| p -> d %| (p ^+ k). +Proof. by case: k => // k _ d_dv_m; rewrite exprS dvdp_mulr. Qed. + +Lemma dvdp_exp2l d k l : k <= l -> d ^+ k %| d ^+ l. +Proof. +by move/subnK <-; rewrite exprD dvdp_mull // ?lead_coef_exp ?unitrX. +Qed. + +Lemma dvdp_Pexp2l d k l : 1 < size d -> (d ^+ k %| d ^+ l) = (k <= l). +Proof. +move=> sd; case: leqP => [|gt_n_m]; first exact: dvdp_exp2l. +have dn0 : d != 0 by rewrite -size_poly_gt0; apply: ltn_trans sd. +rewrite gtNdvdp ?expf_neq0 // polySpred ?expf_neq0 // size_exp /=. +rewrite [size (d ^+ k)]polySpred ?expf_neq0 // size_exp ltnS ltn_mul2l. +by move: sd; rewrite -subn_gt0 subn1; move->. +Qed. + +Lemma dvdp_exp2r p q k : p %| q -> p ^+ k %| q ^+ k. +Proof. +case: (eqVneq p 0) => [-> | pn0]; first by move/dvd0pP->. +rewrite dvdp_eq; set c := _ ^+ _; set t := _ %/ _; move/eqP=> e. +apply: (@eq_dvdp (c ^+ k) (t ^+ k)); first by rewrite !expf_neq0 ?lead_coef_eq0. +by rewrite -exprMn -exprZn; congr (_ ^+ k). +Qed. + +Lemma dvdp_exp_sub p q k l: p != 0 -> + (p ^+ k %| q * p ^+ l) = (p ^+ (k - l) %| q). +Proof. +move=> pn0; case: (leqP k l)=> hkl. + move:(hkl); rewrite -subn_eq0; move/eqP->; rewrite expr0 dvd1p. + apply: dvdp_mull; case: (ltnP 1%N (size p)) => sp. + by rewrite dvdp_Pexp2l. + move: sp; case esp: (size p) => [|sp]. + by move/eqP: esp; rewrite size_poly_eq0 (negPf pn0). + rewrite ltnS leqn0; move/eqP=> sp0; move/eqP: esp; rewrite sp0. + by case/size_poly1P => c cn0 ->; move/subnK: hkl<-; rewrite exprD dvdp_mulIr. +rewrite -{1}[k](@subnK l) 1?ltnW// exprD dvdp_mul2r//. +elim: l {hkl}=> [|l ihl]; first by rewrite expr0 oner_eq0. +by rewrite exprS mulf_neq0. +Qed. + +Lemma dvdp_XsubCl p x : ('X - x%:P) %| p = root p x. +Proof. rewrite dvdpE; exact: Ring.rdvdp_XsubCl. Qed. + +Lemma polyXsubCP p x : reflect (p.[x] = 0) (('X - x%:P) %| p). +Proof. rewrite dvdpE; exact: Ring.polyXsubCP. Qed. + +Lemma eqp_div_XsubC p c : + (p == (p %/ ('X - c%:P)) * ('X - c%:P)) = ('X - c%:P %| p). +Proof. by rewrite dvdp_eq lead_coefXsubC expr1n scale1r. Qed. + +Lemma root_factor_theorem p x : root p x = (('X - x%:P) %| p). +Proof. by rewrite dvdp_XsubCl. Qed. + +Lemma uniq_roots_dvdp p rs : all (root p) rs -> uniq_roots rs -> + (\prod_(z <- rs) ('X - z%:P)) %| p. +Proof. +move=> rrs; case/(uniq_roots_prod_XsubC rrs)=> q ->. +by apply: dvdp_mull; rewrite // (eqP (monic_prod_XsubC _)) unitr1. +Qed. + + +Lemma root_bigmul : forall x (ps : seq {poly R}), + ~~root (\big[*%R/1]_(p <- ps) p) x = all (fun p => ~~ root p x) ps. +Proof. +move=> x; elim; first by rewrite big_nil root1. +by move=> p ps ihp; rewrite big_cons /= rootM negb_or ihp. +Qed. + +Lemma eqpP m n : + reflect (exists2 c12, (c12.1 != 0) && (c12.2 != 0) & c12.1 *: m = c12.2 *: n) + (m %= n). +Proof. +apply: (iffP idP) => [| [[c1 c2]/andP[nz_c1 nz_c2 eq_cmn]]]; last first. + rewrite /eqp (@eq_dvdp c2 c1%:P) -?eq_cmn ?mul_polyC // (@eq_dvdp c1 c2%:P) //. + by rewrite eq_cmn mul_polyC. +case: (eqVneq m 0) => [-> | m_nz]. + by case/andP => /dvd0pP -> _; exists (1, 1); rewrite ?scaler0 // oner_eq0. +case: (eqVneq n 0) => [-> | n_nz]. + by case/andP => _ /dvd0pP ->; exists (1, 1); rewrite ?scaler0 // oner_eq0. +case/andP; rewrite !dvdp_eq; set c1 := _ ^+ _; set c2 := _ ^+ _. +set q1 := _ %/ _; set q2 := _ %/ _; move/eqP => Hq1 /eqP Hq2; +have Hc1 : c1 != 0 by rewrite expf_eq0 lead_coef_eq0 negb_and m_nz orbT. +have Hc2 : c2 != 0 by rewrite expf_eq0 lead_coef_eq0 negb_and n_nz orbT. +have def_q12: q1 * q2 = (c1 * c2)%:P. + apply: (mulIf m_nz); rewrite mulrAC mulrC -Hq1 -scalerAr -Hq2 scalerA. + by rewrite -mul_polyC. +have: q1 * q2 != 0 by rewrite def_q12 -size_poly_eq0 size_polyC mulf_neq0. +rewrite mulf_eq0; case/norP=> nz_q1 nz_q2. +have: size q2 <= 1%N. + have:= size_mul nz_q1 nz_q2; rewrite def_q12 size_polyC mulf_neq0 //=. + by rewrite polySpred // => ->; rewrite leq_addl. +rewrite leq_eqVlt ltnS leqn0 size_poly_eq0 (negPf nz_q2) orbF. +case/size_poly1P=> c cn0 cqe; exists (c2, c); first by rewrite Hc2. +by rewrite Hq2 -mul_polyC -cqe. +Qed. + +Lemma eqp_eq p q: p %= q -> (lead_coef q) *: p = (lead_coef p) *: q. +Proof. +move=> /eqpP [[c1 c2] /= /andP [nz_c1 nz_c2]] eq. +have/(congr1 lead_coef) := eq; rewrite !lead_coefZ. +move=> eqC; apply/(@mulfI _ c2%:P); rewrite ?polyC_eq0 //. +rewrite !mul_polyC scalerA -eqC mulrC -scalerA eq. +by rewrite !scalerA mulrC. +Qed. + +Lemma eqpxx : reflexive (@eqp R). +Proof. by move=> p; rewrite /eqp dvdpp. Qed. + +Hint Resolve eqpxx. + +Lemma eqp_sym : symmetric (@eqp R). +Proof. by move=> p q; rewrite /eqp andbC. Qed. + +Lemma eqp_trans : transitive (@eqp R). +Proof. +move=> p q r; case/andP=> Dp pD; case/andP=> Dq qD. +by rewrite /eqp (dvdp_trans Dp) // (dvdp_trans qD). +Qed. + +Lemma eqp_ltrans : left_transitive (@eqp R). +Proof. +move=> p q r pq. +by apply/idP/idP=> e; apply: eqp_trans e; rewrite // eqp_sym. +Qed. + +Lemma eqp_rtrans : right_transitive (@eqp R). +Proof. by move=> x y xy z; rewrite eqp_sym (eqp_ltrans xy) eqp_sym. Qed. + +Lemma eqp0 : forall p, (p %= 0) = (p == 0). +Proof. +move=> p; case: eqP; move/eqP=> Ep; first by rewrite (eqP Ep) eqpxx. +by apply/negP; case/andP=> _; rewrite /dvdp modp0 (negPf Ep). +Qed. + +Lemma eqp01 : 0 %= (1 : {poly R}) = false. +Proof. +case abs : (0 %= 1) => //; case/eqpP: abs=> [[c1 c2]] /andP [c1n0 c2n0] /=. +by rewrite scaler0 alg_polyC; move/eqP; rewrite eq_sym polyC_eq0 (negbTE c2n0). +Qed. + +Lemma eqp_scale p c : c != 0 -> c *: p %= p. +Proof. +move=> c0; apply/eqpP; exists (1, c); first by rewrite c0 oner_eq0. +by rewrite scale1r. +Qed. + +Lemma eqp_size p q : p %= q -> size p = size q. +Proof. +case: (q =P 0); move/eqP => Eq; first by rewrite (eqP Eq) eqp0; move/eqP->. +rewrite eqp_sym; case: (p =P 0); move/eqP => Ep. + by rewrite (eqP Ep) eqp0; move/eqP->. +by case/andP => Dp Dq; apply: anti_leq; rewrite !dvdp_leq. +Qed. + +Lemma size_poly_eq1 p : (size p == 1%N) = (p %= 1). +Proof. +apply/size_poly1P/idP=> [[c cn0 ep] |]. + by apply/eqpP; exists (1, c); rewrite ?oner_eq0 // alg_polyC scale1r. +by move/eqp_size; rewrite size_poly1; move/eqP; move/size_poly1P. +Qed. + +Lemma polyXsubC_eqp1 (x : R) : ('X - x%:P %= 1) = false. +Proof. by rewrite -size_poly_eq1 size_XsubC. Qed. + +Lemma dvdp_eqp1 p q : p %| q -> q %= 1 -> p %= 1. +Proof. +move=> dpq hq. +have sizeq : size q == 1%N by rewrite size_poly_eq1. +have n0q : q != 0. + by case abs: (q == 0) => //; move: hq; rewrite (eqP abs) eqp01. +rewrite -size_poly_eq1 eqn_leq -{1}(eqP sizeq) dvdp_leq //=. +case p0 : (size p == 0%N); last by rewrite neq0_lt0n. +by move: dpq; rewrite size_poly_eq0 in p0; rewrite (eqP p0) dvd0p (negbTE n0q). +Qed. + +Lemma eqp_dvdr q p d: p %= q -> d %| p = (d %| q). +Proof. +suff Hmn m n: m %= n -> (d %| m) -> (d %| n). + by move=> mn; apply/idP/idP; apply: Hmn=> //; rewrite eqp_sym. +by rewrite /eqp; case/andP=> pq qp dp; apply: (dvdp_trans dp). +Qed. + +Lemma eqp_dvdl d2 d1 p : d1 %= d2 -> d1 %| p = (d2 %| p). +suff Hmn m n: m %= n -> (m %| p) -> (n %| p). + by move=> ?; apply/idP/idP; apply: Hmn; rewrite // eqp_sym. +by rewrite /eqp; case/andP=> dd' d'd dp; apply: (dvdp_trans d'd). +Qed. + +Lemma dvdp_scaler c m n : c != 0 -> m %| c *: n = (m %| n). +Proof. move=> cn0; apply: eqp_dvdr; exact: eqp_scale. Qed. + +Lemma dvdp_scalel c m n : c != 0 -> (c *: m %| n) = (m %| n). +Proof. move=> cn0; apply: eqp_dvdl; exact: eqp_scale. Qed. + +Lemma dvdp_opp d p : d %| (- p) = (d %| p). +Proof. +by apply: eqp_dvdr; rewrite -scaleN1r eqp_scale // oppr_eq0 oner_eq0. +Qed. + +Lemma eqp_mul2r r p q : r != 0 -> (p * r %= q * r) = (p %= q). +Proof. by move => nz_r; rewrite /eqp !dvdp_mul2r. Qed. + +Lemma eqp_mul2l r p q: r != 0 -> (r * p %= r * q) = (p %= q). +Proof. by move => nz_r; rewrite /eqp !dvdp_mul2l. Qed. + +Lemma eqp_mull r p q: (q %= r) -> (p * q %= p * r). +Proof. +case/eqpP=> [[c d]] /andP [c0 d0 e]; apply/eqpP; exists (c, d); rewrite ?c0 //. +by rewrite scalerAr e -scalerAr. +Qed. + +Lemma eqp_mulr q p r : (p %= q) -> (p * r %= q * r). +Proof. by move=> epq; rewrite ![_ * r]mulrC eqp_mull. Qed. + +Lemma eqp_exp p q k : p %= q -> p ^+ k %= q ^+ k. +Proof. +move=> pq; elim: k=> [|k ihk]; first by rewrite !expr0 eqpxx. +by rewrite !exprS (@eqp_trans (q * p ^+ k)) // (eqp_mulr, eqp_mull). +Qed. + +Lemma polyC_eqp1 (c : R) : (c%:P %= 1) = (c != 0). +Proof. +apply/eqpP/idP => [[[x y]] |nc0] /=. + case c0: (c == 0); rewrite // alg_polyC (eqP c0) scaler0. + by case/andP=> _ /=; move/negbTE<-; move/eqP; rewrite eq_sym polyC_eq0. +exists (1, c); first by rewrite nc0 /= oner_neq0. +by rewrite alg_polyC scale1r. +Qed. + +Lemma dvdUp d p: d %= 1 -> d %| p. +Proof. by move/eqp_dvdl->; rewrite dvd1p. Qed. + +Lemma dvdp_size_eqp p q : p %| q -> size p == size q = (p %= q). +Proof. +move=> pq; apply/idP/idP; last by move/eqp_size->. +case (q =P 0)=> [->|]; [|move/eqP => Hq]. + by rewrite size_poly0 size_poly_eq0; move/eqP->; rewrite eqpxx. +case (p =P 0)=> [->|]; [|move/eqP => Hp]. + by rewrite size_poly0 eq_sym size_poly_eq0; move/eqP->; rewrite eqpxx. +move: pq; rewrite dvdp_eq; set c := _ ^+ _; set x := _ %/ _; move/eqP=> eqpq. +move:(eqpq); move/(congr1 (size \o (@polyseq R)))=> /=. +have cn0 : c != 0 by rewrite expf_neq0 // lead_coef_eq0. +rewrite (@eqp_size _ q); last by exact: eqp_scale. +rewrite size_mul ?p0 // => [-> HH|]; last first. + apply/eqP=> HH; move: eqpq; rewrite HH mul0r. + by move/eqP; rewrite scale_poly_eq0 (negPf Hq) (negPf cn0). +suff: size x == 1%N. + case/size_poly1P=> y H1y H2y. + by apply/eqpP; exists (y, c); rewrite ?H1y // eqpq H2y mul_polyC. +case: (size p) HH (size_poly_eq0 p)=> [|n]; first by case: eqP Hp. +by rewrite addnS -add1n eqn_add2r;move/eqP->. +Qed. + +Lemma eqp_root p q : p %= q -> root p =1 root q. +Proof. +move/eqpP=> [[c d]] /andP [c0 d0 e] x; move/negPf:c0=>c0; move/negPf:d0=>d0. +rewrite rootE -[_==_]orFb -c0 -mulf_eq0 -hornerZ e hornerZ. +by rewrite mulf_eq0 d0. +Qed. + +Lemma eqp_rmod_mod p q : rmodp p q %= modp p q. +Proof. +rewrite modpE eqp_sym; case: ifP => ulcq //. +apply: eqp_scale; rewrite invr_eq0 //. +by apply: expf_neq0; apply: contraTneq ulcq => ->; rewrite unitr0. +Qed. + +Lemma eqp_rdiv_div p q : rdivp p q %= divp p q. +Proof. +rewrite divpE eqp_sym; case: ifP=> ulcq //; apply: eqp_scale; rewrite invr_eq0 //. +by apply: expf_neq0; apply: contraTneq ulcq => ->; rewrite unitr0. +Qed. + +Lemma dvd_eqp_divl d p q (dvd_dp : d %| q) (eq_pq : p %= q) : + p %/ d %= q %/ d. +Proof. +case: (eqVneq q 0) eq_pq=> [->|q_neq0]; first by rewrite eqp0=> /eqP->. +have d_neq0: d != 0 by apply: contraL dvd_dp=> /eqP->; rewrite dvd0p. +move=> eq_pq; rewrite -(@eqp_mul2r d) // !divpK // ?(eqp_dvdr _ eq_pq) //. +rewrite (eqp_ltrans (eqp_scale _ _)) ?lc_expn_scalp_neq0 //. +by rewrite (eqp_rtrans (eqp_scale _ _)) ?lc_expn_scalp_neq0. +Qed. + +Definition gcdp_rec p q := + let: (p1, q1) := if size p < size q then (q, p) else (p, q) in + if p1 == 0 then q1 else + let fix loop (n : nat) (pp qq : {poly R}) {struct n} := + let rr := modp pp qq in + if rr == 0 then qq else + if n is n1.+1 then loop n1 qq rr else rr in + loop (size p1) p1 q1. + +Definition gcdp := nosimpl gcdp_rec. + +Lemma gcd0p : left_id 0 gcdp. +Proof. +move=> p; rewrite /gcdp /gcdp_rec size_poly0 size_poly_gt0 if_neg. +case: ifP => /= [_ | nzp]; first by rewrite eqxx. +by rewrite polySpred !(modp0, nzp) //; case: _.-1 => [|m]; rewrite mod0p eqxx. +Qed. + +Lemma gcdp0 : right_id 0 gcdp. +Proof. +move=> p; have:= gcd0p p; rewrite /gcdp /gcdp_rec size_poly0 size_poly_gt0. +by rewrite if_neg; case: ifP => /= p0; rewrite ?(eqxx, p0) // (eqP p0). +Qed. + +Lemma gcdpE p q : + gcdp p q = if size p < size q + then gcdp (modp q p) p else gcdp (modp p q) q. +Proof. +pose gcdpE_rec := fix gcdpE_rec (n : nat) (pp qq : {poly R}) {struct n} := + let rr := modp pp qq in + if rr == 0 then qq else + if n is n1.+1 then gcdpE_rec n1 qq rr else rr. +have Irec: forall k l p q, size q <= k -> size q <= l + -> size q < size p -> gcdpE_rec k p q = gcdpE_rec l p q. ++ elim=> [|m Hrec] [|n] //= p1 q1. + - rewrite leqn0 size_poly_eq0; move/eqP=> -> _. + rewrite size_poly0 size_poly_gt0 modp0 => nzp. + by rewrite (negPf nzp); case: n => [|n] /=; rewrite mod0p eqxx. + - rewrite leqn0 size_poly_eq0 => _; move/eqP=> ->. + rewrite size_poly0 size_poly_gt0 modp0 => nzp. + by rewrite (negPf nzp); case: m {Hrec} => [|m] /=; rewrite mod0p eqxx. + case: ifP => Epq Sm Sn Sq //; rewrite ?Epq //. + case: (eqVneq q1 0) => [->|nzq]. + by case: n m {Sm Sn Hrec} => [|m] [|n] //=; rewrite mod0p eqxx. + apply: Hrec; last by rewrite ltn_modp. + by rewrite -ltnS (leq_trans _ Sm) // ltn_modp. + by rewrite -ltnS (leq_trans _ Sn) // ltn_modp. +case: (eqVneq p 0) => [-> | nzp]. + by rewrite mod0p modp0 gcd0p gcdp0 if_same. +case: (eqVneq q 0) => [-> | nzq]. + by rewrite mod0p modp0 gcd0p gcdp0 if_same. +rewrite /gcdp /gcdp_rec. +case: ltnP; rewrite (negPf nzp, negPf nzq) //=. + move=> ltpq; rewrite ltn_modp (negPf nzp) //=. + rewrite -(ltn_predK ltpq) /=; case: eqP => [->|]. + by case: (size p) => [|[|s]]; rewrite /= modp0 (negPf nzp) // mod0p eqxx. + move/eqP=> nzqp; rewrite (negPf nzp). + apply: Irec => //; last by rewrite ltn_modp. + by rewrite -ltnS (ltn_predK ltpq) (leq_trans _ ltpq) ?leqW // ltn_modp. + by rewrite ltnW // ltn_modp. +move=> leqp; rewrite ltn_modp (negPf nzq) //=. +have p_gt0: size p > 0 by rewrite size_poly_gt0. +rewrite -(prednK p_gt0) /=; case: eqP => [->|]. + by case: (size q) => [|[|s]]; rewrite /= modp0 (negPf nzq) // mod0p eqxx. +move/eqP=> nzpq; rewrite (negPf nzq); apply: Irec => //; rewrite ?ltn_modp //. + by rewrite -ltnS (prednK p_gt0) (leq_trans _ leqp) // ltn_modp. +by rewrite ltnW // ltn_modp. +Qed. + +Lemma size_gcd1p p : size (gcdp 1 p) = 1%N. +Proof. +rewrite gcdpE size_polyC oner_eq0 /= modp1; case: ltnP. + by rewrite gcd0p size_polyC oner_eq0. +move/size1_polyC=> e; rewrite e. +case p00: (p`_0 == 0); first by rewrite (eqP p00) modp0 gcdp0 size_poly1. +by rewrite modpC ?p00 // gcd0p size_polyC p00. +Qed. + +Lemma size_gcdp1 p : size (gcdp p 1) = 1%N. +rewrite gcdpE size_polyC oner_eq0 /= modp1; case: ltnP; last first. + by rewrite gcd0p size_polyC oner_eq0. +rewrite ltnS leqn0 size_poly_eq0; move/eqP->; rewrite gcdp0 modp0 size_polyC. +by rewrite oner_eq0. +Qed. + +Lemma gcdpp : idempotent gcdp. +Proof. by move=> p; rewrite gcdpE ltnn modpp gcd0p. Qed. + +Lemma dvdp_gcdlr p q : (gcdp p q %| p) && (gcdp p q %| q). +Proof. +elim: {p q}minn {-2}p {-2}q (leqnn (minn (size q) (size p))) => [|r Hrec] p q. + rewrite geq_min !leqn0 !size_poly_eq0. + by case/pred2P=> ->; rewrite (gcdp0, gcd0p) dvdpp ?andbT /=. +case: (eqVneq p 0) => [-> _|nz_p]; first by rewrite gcd0p dvdpp andbT. +case: (eqVneq q 0) => [->|nz_q]; first by rewrite gcdp0 dvdpp /=. +rewrite gcdpE minnC /minn; case: ltnP => [lt_pq | le_pq] le_qr. + suffices: minn (size p) (size (q %% p)) <= r. + by move/Hrec; case/andP => E1 E2; rewrite E2 (dvdp_mod _ E2). + by rewrite geq_min orbC -ltnS (leq_trans _ le_qr) ?ltn_modp. +suffices: minn (size q) (size (p %% q)) <= r. + by move/Hrec; case/andP => E1 E2; rewrite E2 andbT (dvdp_mod _ E2). +by rewrite geq_min orbC -ltnS (leq_trans _ le_qr) ?ltn_modp. +Qed. + +Lemma dvdp_gcdl p q : gcdp p q %| p. +Proof. by case/andP: (dvdp_gcdlr p q). Qed. + +Lemma dvdp_gcdr p q :gcdp p q %| q. +Proof. by case/andP: (dvdp_gcdlr p q). Qed. + +Lemma leq_gcdpl p q : p != 0 -> size (gcdp p q) <= size p. +Proof. by move=> pn0; move: (dvdp_gcdl p q); apply: dvdp_leq. Qed. + +Lemma leq_gcdpr p q : q != 0 -> size (gcdp p q) <= size q. +Proof. by move=> qn0; move: (dvdp_gcdr p q); apply: dvdp_leq. Qed. + +Lemma dvdp_gcd p m n : p %| gcdp m n = (p %| m) && (p %| n). +Proof. +apply/idP/andP=> [dv_pmn | [dv_pm dv_pn]]. + by rewrite ?(dvdp_trans dv_pmn) ?dvdp_gcdl ?dvdp_gcdr. +move: (leqnn (minn (size n) (size m))) dv_pm dv_pn. +elim: {m n}minn {-2}m {-2}n => [|r Hrec] m n. + rewrite geq_min !leqn0 !size_poly_eq0. + by case/pred2P=> ->; rewrite (gcdp0, gcd0p). +case: (eqVneq m 0) => [-> _|nz_m]; first by rewrite gcd0p /=. +case: (eqVneq n 0) => [->|nz_n]; first by rewrite gcdp0 /=. +rewrite gcdpE minnC /minn; case: ltnP => Cnm le_r dv_m dv_n. + apply: Hrec => //; last by rewrite -(dvdp_mod _ dv_m). + by rewrite geq_min orbC -ltnS (leq_trans _ le_r) ?ltn_modp. +apply: Hrec => //; last by rewrite -(dvdp_mod _ dv_n). +by rewrite geq_min orbC -ltnS (leq_trans _ le_r) ?ltn_modp. +Qed. + + +Lemma gcdpC : forall p q, gcdp p q %= gcdp q p. +Proof. by move=> p q; rewrite /eqp !dvdp_gcd !dvdp_gcdl !dvdp_gcdr. Qed. + +Lemma gcd1p p : gcdp 1 p %= 1. +Proof. +rewrite -size_poly_eq1 gcdpE size_poly1; case: ltnP. + by rewrite modp1 gcd0p size_poly1 eqxx. +move/size1_polyC=> e; rewrite e. +case p00: (p`_0 == 0); first by rewrite (eqP p00) modp0 gcdp0 size_poly1. +by rewrite modpC ?p00 // gcd0p size_polyC p00. +Qed. + +Lemma gcdp1 p : gcdp p 1 %= 1. +Proof. by rewrite (eqp_ltrans (gcdpC _ _)) gcd1p. Qed. + +Lemma gcdp_addl_mul p q r: gcdp r (p * r + q) %= gcdp r q. +Proof. +suff h m n d : gcdp d n %| gcdp d (m * d + n). + apply/andP; split => //; rewrite {2}(_: q = (-p) * r + (p * r + q)) ?H //. + by rewrite GRing.mulNr GRing.addKr. +by rewrite dvdp_gcd dvdp_gcdl /= dvdp_addr ?dvdp_gcdr ?dvdp_mull ?dvdp_gcdl. +Qed. + +Lemma gcdp_addl m n : gcdp m (m + n) %= gcdp m n. +Proof. by rewrite -{2}(mul1r m) gcdp_addl_mul. Qed. + +Lemma gcdp_addr m n : gcdp m (n + m) %= gcdp m n. +Proof. by rewrite addrC gcdp_addl. Qed. + +Lemma gcdp_mull m n : gcdp n (m * n) %= n. +Proof. +case: (eqVneq n 0) => [-> | nn0]; first by rewrite gcd0p mulr0 eqpxx. +case: (eqVneq m 0) => [-> | mn0]; first by rewrite mul0r gcdp0 eqpxx. +rewrite gcdpE modp_mull gcd0p size_mul //; case: ifP; first by rewrite eqpxx. +rewrite (polySpred mn0) addSn /= -{1}[size n]add0n ltn_add2r; move/negbT. +rewrite -ltnNge prednK ?size_poly_gt0 // leq_eqVlt ltnS leqn0 size_poly_eq0. +rewrite (negPf mn0) orbF; case/size_poly1P=> c cn0 -> {mn0 m}; rewrite mul_polyC. +suff -> : n %% (c *: n) = 0 by rewrite gcd0p; exact: eqp_scale. +by apply/modp_eq0P; rewrite dvdp_scalel. +Qed. + +Lemma gcdp_mulr m n : gcdp n (n * m) %= n. +Proof. by rewrite mulrC gcdp_mull. Qed. + +Lemma gcdp_scalel c m n : c != 0 -> gcdp (c *: m) n %= gcdp m n. +Proof. +move=> cn0; rewrite /eqp dvdp_gcd [gcdp m n %| _]dvdp_gcd !dvdp_gcdr !andbT. +apply/andP; split; last first. + by apply: dvdp_trans (dvdp_gcdl _ _) _; rewrite dvdp_scaler. +by apply: dvdp_trans (dvdp_gcdl _ _) _; rewrite dvdp_scalel. +Qed. + +Lemma gcdp_scaler c m n : c != 0 -> gcdp m (c *: n) %= gcdp m n. +Proof. +move=> cn0; apply: eqp_trans (gcdpC _ _) _. +apply: eqp_trans (gcdp_scalel _ _ _) _ => //; exact: gcdpC. +Qed. + +Lemma dvdp_gcd_idl m n : m %| n -> gcdp m n %= m. +Proof. +case: (eqVneq m 0) => [-> | mn0]. + by rewrite dvd0p => /eqP ->; rewrite gcdp0 eqpxx. +rewrite dvdp_eq; move/eqP; move/(f_equal (gcdp m)) => h. +apply: eqp_trans (gcdp_mull (n %/ m) _); rewrite -h eqp_sym gcdp_scaler //. +by rewrite expf_neq0 // lead_coef_eq0. +Qed. + +Lemma dvdp_gcd_idr m n : n %| m -> gcdp m n %= n. +Proof. move/dvdp_gcd_idl => h; apply: eqp_trans h; exact: gcdpC. Qed. + +Lemma gcdp_exp p k l : gcdp (p ^+ k) (p ^+ l) %= p ^+ minn k l. +Proof. +wlog leqmn: k l / k <= l. + move=> hwlog; case: (leqP k l); first exact: hwlog. + move/ltnW; rewrite minnC; move/hwlog=> h; apply: eqp_trans h; exact: gcdpC. +rewrite (minn_idPl leqmn); move/subnK: leqmn<-; rewrite exprD. +apply: eqp_trans (gcdp_mull _ _) _; exact: eqpxx. +Qed. + +Lemma gcdp_eq0 p q : gcdp p q == 0 = (p == 0) && (q == 0). +Proof. +apply/idP/idP; last by case/andP => /eqP -> /eqP ->; rewrite gcdp0. +have h m n: gcdp m n == 0 -> (m == 0). + by rewrite -(dvd0p m); move/eqP<-; rewrite dvdp_gcdl. +by move=> ?; rewrite (h _ q) // (h _ p) // -eqp0 (eqp_ltrans (gcdpC _ _)) eqp0. +Qed. + +Lemma eqp_gcdr p q r : q %= r -> gcdp p q %= gcdp p r. +Proof. +move=> eqr; rewrite /eqp !(dvdp_gcd, dvdp_gcdl, andbT) /=. +by rewrite -(eqp_dvdr _ eqr) dvdp_gcdr (eqp_dvdr _ eqr) dvdp_gcdr. +Qed. + +Lemma eqp_gcdl r p q : p %= q -> gcdp p r %= gcdp q r. +move=> eqr; rewrite /eqp !(dvdp_gcd, dvdp_gcdr, andbT) /=. +by rewrite -(eqp_dvdr _ eqr) dvdp_gcdl (eqp_dvdr _ eqr) dvdp_gcdl. +Qed. + +Lemma eqp_gcd p1 p2 q1 q2 : p1 %= p2 -> q1 %= q2 -> gcdp p1 q1 %= gcdp p2 q2. +Proof. +move=> e1 e2. +by apply: eqp_trans (eqp_gcdr _ e2); apply: eqp_trans (eqp_gcdl _ e1). +Qed. + +Lemma eqp_rgcd_gcd p q : rgcdp p q %= gcdp p q. +Proof. +move: (leqnn (minn (size p) (size q))); move: {2}(minn (size p) (size q)) => n. +elim: n p q => [p q|n ihn p q hs]. + rewrite leqn0 /minn; case: ltnP => _; rewrite size_poly_eq0; move/eqP->. + by rewrite gcd0p rgcd0p eqpxx. + by rewrite gcdp0 rgcdp0 eqpxx. +case: (eqVneq p 0) => [-> | pn0]; first by rewrite gcd0p rgcd0p eqpxx. +case: (eqVneq q 0) => [-> | qn0]; first by rewrite gcdp0 rgcdp0 eqpxx. +rewrite gcdpE rgcdpE; case: ltnP => sp. + have e := (eqp_rmod_mod q p); move: (e); move/(eqp_gcdl p) => h. + apply: eqp_trans h; apply: ihn; rewrite (eqp_size e) geq_min. + by rewrite -ltnS (leq_trans _ hs) // (minn_idPl (ltnW _)) ?ltn_modp. +have e := (eqp_rmod_mod p q); move: (e); move/(eqp_gcdl q) => h. +apply: eqp_trans h; apply: ihn; rewrite (eqp_size e) geq_min. +by rewrite -ltnS (leq_trans _ hs) // (minn_idPr _) ?ltn_modp. +Qed. + +Lemma gcdp_modr m n : gcdp m (n %% m) %= gcdp m n. +Proof. +case: (eqVneq m 0) => [-> | mn0]; first by rewrite modp0 eqpxx. +have : (lead_coef m) ^+ (scalp n m) != 0 by rewrite expf_neq0 // lead_coef_eq0. +move/gcdp_scaler; move/(_ m n) => h; apply: eqp_trans h; rewrite divp_eq. +by rewrite eqp_sym gcdp_addl_mul. +Qed. + +Lemma gcdp_modl m n : gcdp (m %% n) n %= gcdp m n. +Proof. +apply: eqp_trans (gcdpC _ _) _; apply: eqp_trans (gcdp_modr _ _) _. +exact: gcdpC. +Qed. + +Lemma gcdp_def d m n : + d %| m -> d %| n -> (forall d', d' %| m -> d' %| n -> d' %| d) -> + gcdp m n %= d. +Proof. +move=> dm dn h; rewrite /eqp dvdp_gcd dm dn !andbT. +apply: h; [exact: dvdp_gcdl | exact: dvdp_gcdr]. +Qed. + +Definition coprimep p q := size (gcdp p q) == 1%N. + +Lemma coprimep_size_gcd p q : coprimep p q -> size (gcdp p q) = 1%N. +Proof. by rewrite /coprimep=> /eqP. Qed. + +Lemma coprimep_def p q : (coprimep p q) = (size (gcdp p q) == 1%N). +Proof. done. Qed. + +Lemma coprimep_scalel c m n : + c != 0 -> coprimep (c *: m) n = coprimep m n. +Proof. by move=> ?; rewrite !coprimep_def (eqp_size (gcdp_scalel _ _ _)). Qed. + +Lemma coprimep_scaler c m n: + c != 0 -> coprimep m (c *: n) = coprimep m n. +Proof. by move=> ?; rewrite !coprimep_def (eqp_size (gcdp_scaler _ _ _)). Qed. + +Lemma coprimepp p : coprimep p p = (size p == 1%N). +Proof. by rewrite coprimep_def gcdpp. Qed. + +Lemma gcdp_eqp1 p q : gcdp p q %= 1 = (coprimep p q). +Proof. by rewrite coprimep_def size_poly_eq1. Qed. + +Lemma coprimep_sym p q : coprimep p q = coprimep q p. +Proof. +by rewrite -!gcdp_eqp1; apply: eqp_ltrans; rewrite gcdpC. +Qed. + +Lemma coprime1p p : coprimep 1 p. +Proof. +rewrite /coprimep -[1%N](size_poly1 R); apply/eqP; apply: eqp_size. +exact: gcd1p. +Qed. + +Lemma coprimep1 p : coprimep p 1. +Proof. by rewrite coprimep_sym; apply: coprime1p. Qed. + +Lemma coprimep0 p : coprimep p 0 = (p %= 1). +Proof. by rewrite /coprimep gcdp0 size_poly_eq1. Qed. + +Lemma coprime0p p : coprimep 0 p = (p %= 1). +Proof. by rewrite coprimep_sym coprimep0. Qed. + +(* This is different from coprimeP in div. shall we keep this? *) +Lemma coprimepP p q : + reflect (forall d, d %| p -> d %| q -> d %= 1) (coprimep p q). +Proof. +apply: (iffP idP)=> [|h]. + rewrite /coprimep; move/eqP=> hs d dvddp dvddq. + have dvddg: d %| gcdp p q by rewrite dvdp_gcd dvddp dvddq. + by apply: (dvdp_eqp1 dvddg); rewrite -size_poly_eq1; apply/eqP. +case/andP: (dvdp_gcdlr p q)=> h1 h2. +by rewrite /coprimep size_poly_eq1; apply: h. +Qed. + +Lemma coprimepPn p q : p != 0 -> + reflect (exists d, (d %| gcdp p q) && ~~ (d %= 1)) (~~ coprimep p q). +Proof. +move=> p0; apply: (iffP idP). + by rewrite -gcdp_eqp1=> ng1; exists (gcdp p q); rewrite dvdpp /=. +case=> d; case/andP=> dg; apply: contra; rewrite -gcdp_eqp1=> g1. +by move: dg; rewrite (eqp_dvdr _ g1) dvdp1 size_poly_eq1. +Qed. + +Lemma coprimep_dvdl q p r : r %| q -> coprimep p q -> coprimep p r. +Proof. +move=> rq cpq; apply/coprimepP=> d dp dr; move/coprimepP:cpq=> cpq'. +by apply: cpq'; rewrite // (dvdp_trans dr). +Qed. + +Lemma coprimep_dvdr p q r : + r %| p -> coprimep p q -> coprimep r q. +Proof. +move=> rp; rewrite ![coprimep _ q]coprimep_sym. +by move/coprimep_dvdl; apply. +Qed. + + +Lemma coprimep_modl p q : coprimep (p %% q) q = coprimep p q. +Proof. +symmetry; rewrite !coprimep_def. +case: (ltnP (size p) (size q))=> hpq; first by rewrite modp_small. +by rewrite gcdpE ltnNge hpq. +Qed. + +Lemma coprimep_modr q p : coprimep q (p %% q) = coprimep q p. +Proof. by rewrite ![coprimep q _]coprimep_sym coprimep_modl. Qed. + +Lemma rcoprimep_coprimep q p : rcoprimep q p = coprimep q p. +Proof. +by rewrite /coprimep /rcoprimep; rewrite (eqp_size (eqp_rgcd_gcd _ _)). +Qed. + +Lemma eqp_coprimepr p q r : q %= r -> coprimep p q = coprimep p r. +Proof. +by rewrite -!gcdp_eqp1; move/(eqp_gcdr p) => h1; apply: (eqp_ltrans h1). +Qed. + +Lemma eqp_coprimepl p q r : q %= r -> coprimep q p = coprimep r p. +Proof. rewrite !(coprimep_sym _ p); exact: eqp_coprimepr. Qed. + +(* This should be implemented with an extended remainder sequence *) +Fixpoint egcdp_rec p q k {struct k} : {poly R} * {poly R} := + if k is k'.+1 then + if q == 0 then (1, 0) else + let: (u, v) := egcdp_rec q (p %% q) k' in + (lead_coef q ^+ scalp p q *: v, (u - v * (p %/ q))) + else (1, 0). + +Definition egcdp p q := + if size q <= size p then egcdp_rec p q (size q) + else let e := egcdp_rec q p (size p) in (e.2, e.1). + +(* No provable egcd0p *) +Lemma egcdp0 p : egcdp p 0 = (1, 0). +Proof. by rewrite /egcdp size_poly0. Qed. + +Lemma egcdp_recP : forall k p q, q != 0 -> size q <= k -> size q <= size p -> + let e := (egcdp_rec p q k) in + [/\ size e.1 <= size q, size e.2 <= size p & gcdp p q %= e.1 * p + e.2 * q]. +Proof. +elim=> [|k ihk] p q /= qn0; first by rewrite leqn0 size_poly_eq0 (negPf qn0). +move=> sqSn qsp; case: (eqVneq q 0)=> q0; first by rewrite q0 eqxx in qn0. +rewrite (negPf qn0). +have sp : size p > 0 by apply: leq_trans qsp; rewrite size_poly_gt0. +case: (eqVneq (p %% q) 0) => [r0 | rn0] /=. + rewrite r0 /egcdp_rec; case: k ihk sqSn => [|n] ihn sqSn /=. + rewrite !scaler0 !mul0r subr0 add0r mul1r size_poly0 size_poly1. + by rewrite dvdp_gcd_idr /dvdp ?r0. + rewrite !eqxx mul0r scaler0 /= mul0r add0r subr0 mul1r size_poly0 size_poly1. + by rewrite dvdp_gcd_idr /dvdp ?r0 //. +have h1 : size (p %% q) <= k. + by rewrite -ltnS; apply: leq_trans sqSn; rewrite ltn_modp. +have h2 : size (p %% q) <= size q by rewrite ltnW // ltn_modp. +have := (ihk q (p %% q) rn0 h1 h2). +case: (egcdp_rec _ _)=> u v /= => [[ihn'1 ihn'2 ihn'3]]. +rewrite gcdpE ltnNge qsp //= (eqp_ltrans (gcdpC _ _)); split; last first. +- apply: (eqp_trans ihn'3). + rewrite mulrBl addrCA -scalerAl scalerAr -mulrA -mulrBr. + by rewrite divp_eq addrAC subrr add0r eqpxx. +- apply: (leq_trans (size_add _ _)). + case: (eqVneq v 0)=> [-> | vn0]. + rewrite mul0r size_opp size_poly0 maxn0; apply: leq_trans ihn'1 _. + exact: leq_modp. + case: (eqVneq (p %/ q) 0)=> [-> | qqn0]. + rewrite mulr0 size_opp size_poly0 maxn0; apply: leq_trans ihn'1 _. + exact: leq_modp. + rewrite geq_max (leq_trans ihn'1) ?leq_modp //= size_opp size_mul //. + move: (ihn'2); rewrite -(leq_add2r (size (p %/ q))). + have : size v + size (p %/ q) > 0 by rewrite addn_gt0 size_poly_gt0 vn0. + have : size q + size (p %/ q) > 0 by rewrite addn_gt0 size_poly_gt0 qn0. + do 2! move/prednK=> {1}<-; rewrite ltnS => h; apply: leq_trans h _. + rewrite size_divp // addnBA; last by apply: leq_trans qsp; exact: leq_pred. + rewrite addnC -addnBA ?leq_pred //; move: qn0; rewrite -size_poly_eq0 -lt0n. + by move/prednK=> {1}<-; rewrite subSnn addn1. +- by rewrite size_scale // lc_expn_scalp_neq0. +Qed. + +Lemma egcdpP p q : p != 0 -> q != 0 -> forall (e := egcdp p q), + [/\ size e.1 <= size q, size e.2 <= size p & gcdp p q %= e.1 * p + e.2 * q]. +Proof. +move=> pn0 qn0; rewrite /egcdp; case: (leqP (size q) (size p)) => /= hp. + by apply: egcdp_recP. +move/ltnW: hp => hp; case: (egcdp_recP pn0 (leqnn (size p)) hp) => h1 h2 h3. +by split => //; rewrite (eqp_ltrans (gcdpC _ _)) addrC. +Qed. + +Lemma egcdpE p q (e := egcdp p q) : gcdp p q %= e.1 * p + e.2 * q. +Proof. +rewrite {}/e; have [-> /= | qn0] := eqVneq q 0. + by rewrite gcdp0 egcdp0 mul1r mulr0 addr0. +have [p0 | pn0] := eqVneq p 0; last by case: (egcdpP pn0 qn0). +rewrite p0 gcd0p mulr0 add0r /egcdp size_poly0 leqn0 size_poly_eq0 (negPf qn0). +by rewrite /= mul1r. +Qed. + +Lemma Bezoutp p q : exists u, u.1 * p + u.2 * q %= (gcdp p q). +Proof. +case: (eqVneq p 0) => [-> | pn0]. + by rewrite gcd0p; exists (0, 1); rewrite mul0r mul1r add0r. +case: (eqVneq q 0) => [-> | qn0]. + by rewrite gcdp0; exists (1, 0); rewrite mul0r mul1r addr0. +pose e := egcdp p q; exists e; rewrite eqp_sym. +by case: (egcdpP pn0 qn0). +Qed. + +Lemma Bezout_coprimepP : forall p q, + reflect (exists u, u.1 * p + u.2 * q %= 1) (coprimep p q). +Proof. +move=> p q; rewrite -gcdp_eqp1; apply:(iffP idP)=> [g1|]. + case: (Bezoutp p q) => [[u v] Puv]; exists (u, v); exact: eqp_trans g1. +case=>[[u v]]; rewrite eqp_sym=> Puv; rewrite /eqp (eqp_dvdr _ Puv). +by rewrite dvdp_addr dvdp_mull ?dvdp_gcdl ?dvdp_gcdr //= dvd1p. +Qed. + +Lemma coprimep_root p q x : coprimep p q -> root p x -> q.[x] != 0. +Proof. +case/Bezout_coprimepP=> [[u v] euv] px0. +move/eqpP: euv => [[c1 c2]] /andP /= [c1n0 c2n0 e]. +suffices: c1 * (v.[x] * q.[x]) != 0. + by rewrite !mulf_eq0 !negb_or c1n0 /=; case/andP. +move/(f_equal (fun t => horner t x)): e; rewrite /= !hornerZ hornerD. +by rewrite !hornerM (eqP px0) mulr0 add0r hornerC mulr1; move->. +Qed. + +Lemma Gauss_dvdpl p q d: coprimep d q -> (d %| p * q) = (d %| p). +Proof. +move/Bezout_coprimepP=>[[u v] Puv]; apply/idP/idP; last exact: dvdp_mulr. +move:Puv; move/(eqp_mull p); rewrite mulr1 mulrDr eqp_sym=> peq dpq. +rewrite (eqp_dvdr _ peq) dvdp_addr; first by rewrite mulrA mulrAC dvdp_mulr. +by rewrite mulrA dvdp_mull ?dvdpp. +Qed. + +Lemma Gauss_dvdpr p q d: coprimep d q -> (d %| q * p) = (d %| p). +Proof. rewrite mulrC; exact: Gauss_dvdpl. Qed. + +(* This could be simplified with the introduction of lcmp *) +Lemma Gauss_dvdp m n p : coprimep m n -> (m * n %| p) = (m %| p) && (n %| p). +Proof. +case: (eqVneq m 0) => [-> | mn0]. + by rewrite coprime0p; move/eqp_dvdl->; rewrite !mul0r dvd0p dvd1p andbT. +case: (eqVneq n 0) => [-> | nn0]. + by rewrite coprimep0; move/eqp_dvdl->; rewrite !mulr0 dvd1p. +move=> hc; apply/idP/idP. + move/Gauss_dvdpl: hc => <- h; move/(dvdp_mull m): (h); rewrite dvdp_mul2l //. + move->; move/(dvdp_mulr n): (h); rewrite dvdp_mul2r // andbT. + exact: dvdp_mulr. +case/andP => dmp dnp; move: (dnp); rewrite dvdp_eq. +set c2 := _ ^+ _; set q2 := _ %/ _; move/eqP=> e2. +have := (sym_eq (Gauss_dvdpl q2 hc)); rewrite -e2. +have -> : m %| c2 *: p by rewrite -mul_polyC dvdp_mull. +rewrite dvdp_eq; set c3 := _ ^+ _; set q3 := _ %/ _; move/eqP=> e3. +apply: (@eq_dvdp (c3 * c2) q3). + by rewrite mulf_neq0 // expf_neq0 // lead_coef_eq0. +by rewrite mulrA -e3 -scalerAl -e2 scalerA. +Qed. + +Lemma Gauss_gcdpr p m n : coprimep p m -> gcdp p (m * n) %= gcdp p n. +Proof. +move=> co_pm; apply/eqP; rewrite /eqp !dvdp_gcd !dvdp_gcdl /= andbC. +rewrite dvdp_mull ?dvdp_gcdr // -(@Gauss_dvdpl _ m). + by rewrite mulrC dvdp_gcdr. +apply/coprimepP=> d; rewrite dvdp_gcd; case/andP=> hdp _ hdm. +by move/coprimepP: co_pm; apply. +Qed. + +Lemma Gauss_gcdpl p m n : coprimep p n -> gcdp p (m * n) %= gcdp p m. +Proof. by move=> co_pn; rewrite mulrC Gauss_gcdpr. Qed. + +Lemma coprimep_mulr p q r : coprimep p (q * r) = (coprimep p q && coprimep p r). +Proof. +apply/coprimepP/andP=> [hp|[/coprimepP hq hr]]. + split; apply/coprimepP=> d dp dq; rewrite hp //; + [exact: dvdp_mulr|exact: dvdp_mull]. +move=> d dp dqr; move/(_ _ dp) in hq. +rewrite Gauss_dvdpl in dqr; first exact: hq. +by move/coprimep_dvdr:hr; apply. +Qed. + +Lemma coprimep_mull p q r: coprimep (q * r) p = (coprimep q p && coprimep r p). +Proof. by rewrite ![coprimep _ p]coprimep_sym coprimep_mulr. Qed. + +Lemma modp_coprime k u n : k != 0 -> (k * u) %% n %= 1 -> coprimep k n. +Proof. +move=> kn0 hmod; apply/Bezout_coprimepP. +exists (((lead_coef n)^+(scalp (k * u) n) *: u), (- (k * u %/ n))). +rewrite -scalerAl mulrC (divp_eq (u * k) n) mulNr -addrAC subrr add0r. +by rewrite mulrC. +Qed. + +Lemma coprimep_pexpl k m n : 0 < k -> coprimep (m ^+ k) n = coprimep m n. +Proof. +case: k => // k _; elim: k => [|k IHk]; first by rewrite expr1. +by rewrite exprS coprimep_mull -IHk andbb. +Qed. + +Lemma coprimep_pexpr k m n : 0 < k -> coprimep m (n ^+ k) = coprimep m n. +Proof. by move=> k_gt0; rewrite !(coprimep_sym m) coprimep_pexpl. Qed. + +Lemma coprimep_expl k m n : coprimep m n -> coprimep (m ^+ k) n. +Proof. by case: k => [|k] co_pm; rewrite ?coprime1p // coprimep_pexpl. Qed. + +Lemma coprimep_expr k m n : coprimep m n -> coprimep m (n ^+ k). +Proof. by rewrite !(coprimep_sym m); exact: coprimep_expl. Qed. + +Lemma gcdp_mul2l p q r : gcdp (p * q) (p * r) %= (p * gcdp q r). +Proof. +case: (eqVneq p 0)=> [->|hp]; first by rewrite !mul0r gcdp0 eqpxx. +rewrite /eqp !dvdp_gcd !dvdp_mul2l // dvdp_gcdr dvdp_gcdl !andbT. +move: (Bezoutp q r) => [[u v]] huv. +rewrite eqp_sym in huv; rewrite (eqp_dvdr _ (eqp_mull _ huv)). +rewrite mulrDr ![p * (_ * _)]mulrCA. +by apply: dvdp_add; rewrite dvdp_mull// (dvdp_gcdr, dvdp_gcdl). +Qed. + +Lemma gcdp_mul2r q r p : gcdp (q * p) (r * p) %= (gcdp q r * p). +Proof. by rewrite ![_ * p]GRing.mulrC gcdp_mul2l. Qed. + +Lemma mulp_gcdr p q r : r * (gcdp p q) %= gcdp (r * p) (r * q). +Proof. by rewrite eqp_sym gcdp_mul2l. Qed. + +Lemma mulp_gcdl p q r : (gcdp p q) * r %= gcdp (p * r) (q * r). +Proof. by rewrite eqp_sym gcdp_mul2r. Qed. + +Lemma coprimep_div_gcd p q : (p != 0) || (q != 0) -> + coprimep (p %/ (gcdp p q)) (q %/ gcdp p q). +Proof. +move=> hpq. +have gpq0: gcdp p q != 0 by rewrite gcdp_eq0 negb_and. +rewrite -gcdp_eqp1 -(@eqp_mul2r (gcdp p q)) // mul1r. +have: gcdp p q %| p by rewrite dvdp_gcdl. +have: gcdp p q %| q by rewrite dvdp_gcdr. +rewrite !dvdp_eq eq_sym; move/eqP=> hq; rewrite eq_sym; move/eqP=> hp. +rewrite (eqp_ltrans (mulp_gcdl _ _ _)) hq hp. +have lcn0 k : (lead_coef (gcdp p q)) ^+ k != 0. + by rewrite expf_neq0 ?lead_coef_eq0. +by apply: eqp_gcd; rewrite ?eqp_scale. +Qed. + +Lemma divp_eq0 p q : (p %/ q == 0) = [|| p == 0, q ==0 | size p < size q]. +Proof. +apply/eqP/idP=> [d0|]; last first. + case/or3P; [by move/eqP->; rewrite div0p| by move/eqP->; rewrite divp0|]. + by move/divp_small. +case: (eqVneq p 0) => [->|pn0]; first by rewrite eqxx. +case: (eqVneq q 0) => [-> | qn0]; first by rewrite eqxx orbT. +move: (divp_eq p q); rewrite d0 mul0r add0r. +move/(f_equal (fun x : {poly R} => size x)). +by rewrite size_scale ?lc_expn_scalp_neq0 // => ->; rewrite ltn_modp qn0 !orbT. +Qed. + +Lemma dvdp_div_eq0 p q : q %| p -> (p %/ q == 0) = (p == 0). +Proof. +move=> dvdp_qp; have [->|p_neq0] := altP (p =P 0); first by rewrite div0p eqxx. +rewrite divp_eq0 ltnNge dvdp_leq // (negPf p_neq0) orbF /=. +by apply: contraTF dvdp_qp=> /eqP ->; rewrite dvd0p. +Qed. + +Lemma Bezout_coprimepPn p q : p != 0 -> q != 0 -> + reflect (exists2 uv : {poly R} * {poly R}, + (0 < size uv.1 < size q) && (0 < size uv.2 < size p) & + uv.1 * p = uv.2 * q) + (~~ (coprimep p q)). +move=> pn0 qn0; apply: (iffP idP); last first. + case=> [[u v] /= /andP [/andP [ps1 s1] /andP [ps2 s2]] e]. + have: ~~(size (q * p) <= size (u * p)). + rewrite -ltnNge !size_mul // -?size_poly_gt0 // (polySpred pn0) !addnS. + by rewrite ltn_add2r. + apply: contra => ?; apply: dvdp_leq; rewrite ?mulf_neq0 // -?size_poly_gt0 //. + by rewrite mulrC Gauss_dvdp // dvdp_mull // e dvdp_mull. +rewrite coprimep_def neq_ltn. +case/orP; first by rewrite ltnS leqn0 size_poly_eq0 gcdp_eq0 -[p == 0]negbK pn0. +case sg: (size (gcdp p q)) => [|n] //; case: n sg=> [|n] // sg _. +move: (dvdp_gcdl p q); rewrite dvdp_eq; set c1 := _ ^+ _; move/eqP=> hu1. +move: (dvdp_gcdr p q); rewrite dvdp_eq; set c2 := _ ^+ _; move/eqP=> hv1. +exists (c1 *: (q %/ gcdp p q), c2 *: (p %/ gcdp p q)); last first. + by rewrite -!{1}scalerAl !scalerAr hu1 hv1 mulrCA. +rewrite !{1}size_scale ?lc_expn_scalp_neq0 //= !size_poly_gt0 !divp_eq0. +rewrite gcdp_eq0 !(negPf pn0) !(negPf qn0) /= -!leqNgt leq_gcdpl //. +rewrite leq_gcdpr //= !ltn_divpl -?size_poly_eq0 ?sg //. +rewrite !size_mul // -?size_poly_eq0 ?sg // ![(_ + n.+2)%N]addnS /=. +by rewrite -{1}(addn0 (size p)) -{1}(addn0 (size q)) !ltn_add2l. +Qed. + +Lemma dvdp_pexp2r m n k : k > 0 -> (m ^+ k %| n ^+ k) = (m %| n). +Proof. +move=> k_gt0; apply/idP/idP; last exact: dvdp_exp2r. +case: (eqVneq n 0) => [-> | nn0] //; case: (eqVneq m 0) => [-> | mn0]. + move/prednK: k_gt0=> {1}<-; rewrite exprS mul0r //= !dvd0p expf_eq0. + by case/andP=> _ ->. +set d := gcdp m n; have := (dvdp_gcdr m n); rewrite -/d dvdp_eq. +set c1 := _ ^+ _; set n' := _ %/ _; move/eqP=> def_n. +have := (dvdp_gcdl m n); rewrite -/d dvdp_eq. +set c2 := _ ^+ _; set m' := _ %/ _; move/eqP=> def_m. +have dn0 : d != 0 by rewrite gcdp_eq0 negb_and nn0 orbT. +have c1n0 : c1 != 0 by rewrite !expf_neq0 // lead_coef_eq0. +have c2n0 : c2 != 0 by rewrite !expf_neq0 // lead_coef_eq0. +rewrite -(@dvdp_scaler (c1 ^+ k)) ?expf_neq0 ?lead_coef_eq0 //. +have c2k_n0 : c2 ^+ k != 0 by rewrite !expf_neq0 // lead_coef_eq0. +rewrite -(@dvdp_scalel (c2 ^+k)) // -!exprZn def_m def_n !exprMn. +rewrite dvdp_mul2r ?expf_neq0 //. +have: coprimep (m' ^+ k) (n' ^+ k). + rewrite coprimep_pexpl // coprimep_pexpr //; apply: coprimep_div_gcd. + by rewrite nn0 orbT. +move/coprimepP=> hc hd. +have /size_poly1P [c cn0 em'] : size m' == 1%N. + case: (eqVneq m' 0) => [m'0 |m'_n0]. + move/eqP: def_m; rewrite m'0 mul0r scale_poly_eq0. + by rewrite (negPf mn0) (negPf c2n0). + have := (hc _ (dvdpp _) hd); rewrite -size_poly_eq1. + rewrite polySpred; last by rewrite expf_eq0 negb_and m'_n0 orbT. + rewrite size_exp eqSS muln_eq0; move: k_gt0; rewrite lt0n; move/negPf->. + by rewrite orbF -{2}(@prednK (size m')) ?lt0n // size_poly_eq0. +rewrite -(@dvdp_scalel c2) // def_m em' mul_polyC dvdp_scalel //. +by rewrite -(@dvdp_scaler c1) // def_n dvdp_mull. +Qed. + +Lemma root_gcd p q x : root (gcdp p q) x = root p x && root q x. +Proof. +rewrite /= !root_factor_theorem; apply/idP/andP=> [dg| [dp dq]]. + by split; apply: dvdp_trans dg _; rewrite ?(dvdp_gcdl, dvdp_gcdr). +have:= (Bezoutp p q)=> [[[u v]]]; rewrite eqp_sym=> e. +by rewrite (eqp_dvdr _ e) dvdp_addl dvdp_mull. +Qed. + +Lemma root_biggcd : forall x (ps : seq {poly R}), + root (\big[gcdp/0]_(p <- ps) p) x = all (fun p => root p x) ps. +Proof. +move=> x; elim; first by rewrite big_nil root0. +by move=> p ps ihp; rewrite big_cons /= root_gcd ihp. +Qed. + +(* "gdcop Q P" is the Greatest Divisor of P which is coprime to Q *) +(* if P null, we pose that gdcop returns 1 if Q null, 0 otherwise*) +Fixpoint gdcop_rec q p k := + if k is m.+1 then + if coprimep p q then p + else gdcop_rec q (divp p (gcdp p q)) m + else (q == 0)%:R. + +Definition gdcop q p := gdcop_rec q p (size p). + +CoInductive gdcop_spec q p : {poly R} -> Type := + GdcopSpec r of (dvdp r p) & ((coprimep r q) || (p == 0)) + & (forall d, dvdp d p -> coprimep d q -> dvdp d r) + : gdcop_spec q p r. + +Lemma gdcop0 q : gdcop q 0 = (q == 0)%:R. +Proof. by rewrite /gdcop size_poly0. Qed. + +Lemma gdcop_recP : forall q p k, + size p <= k -> gdcop_spec q p (gdcop_rec q p k). +Proof. +move=> q p k; elim: k p => [p | k ihk p] /=. + rewrite leqn0 size_poly_eq0; move/eqP->. + case q0: (_ == _); split; rewrite ?coprime1p // ?eqxx ?orbT //. + by move=> d _; rewrite (eqP q0) coprimep0 dvdp1 size_poly_eq1. +move=> hs; case cop : (coprimep _ _); first by split; rewrite ?dvdpp ?cop. +case (eqVneq p 0) => [-> | p0]. + by rewrite div0p; apply: ihk; rewrite size_poly0 leq0n. +case: (eqVneq q 0) => [-> | q0]. + rewrite gcdp0 divpp ?p0 //= => {hs ihk}; case: k=> /=. + rewrite eqxx; split; rewrite ?dvd1p ?coprimep0 ?eqpxx //=. + by move=> d _; rewrite coprimep0 dvdp1 size_poly_eq1. + move=> n; rewrite coprimep0 polyC_eqp1 //; rewrite lc_expn_scalp_neq0. + split; first by rewrite (@eqp_dvdl 1) ?dvd1p // polyC_eqp1 lc_expn_scalp_neq0. + by rewrite coprimep0 polyC_eqp1 // ?lc_expn_scalp_neq0. + by move=> d _; rewrite coprimep0; move/eqp_dvdl->; rewrite dvd1p. +move: (dvdp_gcdl p q); rewrite dvdp_eq; move/eqP=> e. +have sgp : size (gcdp p q) <= size p. + by apply: dvdp_leq; rewrite ?gcdp_eq0 ?p0 ?q0 // dvdp_gcdl. +have : p %/ gcdp p q != 0; last move/negPf=>p'n0. + move: (dvdp_mulIl (p %/ gcdp p q) (gcdp p q)); move/dvdpN0; apply; rewrite -e. + by rewrite scale_poly_eq0 negb_or lc_expn_scalp_neq0. +have gn0 : gcdp p q != 0. + move: (dvdp_mulIr (p %/ gcdp p q) (gcdp p q)); move/dvdpN0; apply; rewrite -e. + by rewrite scale_poly_eq0 negb_or lc_expn_scalp_neq0. +have sp' : size (p %/ (gcdp p q)) <= k. + rewrite size_divp ?sgp // leq_subLR (leq_trans hs)//. + rewrite -subn_gt0 addnK -subn1 ltn_subRL addn0 ltnNge leq_eqVlt. + by rewrite [_ == _]cop ltnS leqn0 size_poly_eq0 (negPf gn0). +case (ihk _ sp')=> r' dr'p'; first rewrite p'n0 orbF=> cr'q maxr'. +constructor=> //=; rewrite ?(negPf p0) ?orbF //. + apply: (dvdp_trans dr'p'); apply: divp_dvd; exact: dvdp_gcdl. +move=> d dp cdq; apply: maxr'; last by rewrite cdq. +case dpq: (d %| gcdp p q). + move: (dpq); rewrite dvdp_gcd dp /= => dq; apply: dvdUp; move: cdq. + apply: contraLR=> nd1; apply/coprimepPn; last first. + by exists d; rewrite dvdp_gcd dvdpp dq nd1. + move/negP: p0; move/negP; apply: contra=> d0; move:dp; rewrite (eqP d0). + by rewrite dvd0p. +move: (dp); apply: contraLR=> ndp'. +rewrite (@eqp_dvdr ((lead_coef (gcdp p q) ^+ scalp p (gcdp p q))*:p)). + by rewrite e; rewrite Gauss_dvdpl //; apply: (coprimep_dvdl (dvdp_gcdr _ _)). +by rewrite eqp_sym eqp_scale // lc_expn_scalp_neq0. +Qed. + +Lemma gdcopP q p : gdcop_spec q p (gdcop q p). +Proof. by rewrite /gdcop; apply: gdcop_recP. Qed. + +Lemma coprimep_gdco p q : (q != 0)%B -> coprimep (gdcop p q) p. +Proof. by move=> q_neq0; case: gdcopP=> d; rewrite (negPf q_neq0) orbF. Qed. + +Lemma size2_dvdp_gdco p q d : p != 0 -> size d = 2%N -> + (d %| (gdcop q p)) = (d %| p) && ~~(d %| q). +Proof. +case: (eqVneq d 0) => [-> | dn0]; first by rewrite size_poly0. +move=> p0 sd; apply/idP/idP. + case: gdcopP=> r rp crq maxr dr; move/negPf: (p0)=> p0f. + rewrite (dvdp_trans dr) //=. + move: crq; apply: contraL=> dq; rewrite p0f orbF; apply/coprimepPn. + by move:p0; apply: contra=> r0; move: rp; rewrite (eqP r0) dvd0p. + by exists d; rewrite dvdp_gcd dr dq -size_poly_eq1 sd. +case/andP=> dp dq; case: gdcopP=> r rp crq maxr; apply: maxr=> //. +apply/coprimepP=> x xd xq. +move: (dvdp_leq dn0 xd); rewrite leq_eqVlt sd; case/orP; last first. + rewrite ltnS leq_eqVlt; case/orP; first by rewrite -size_poly_eq1. + rewrite ltnS leqn0 size_poly_eq0; move/eqP=> x0; move: xd; rewrite x0 dvd0p. + by rewrite (negPf dn0). +by rewrite -sd dvdp_size_eqp //; move/(eqp_dvdl q); rewrite xq (negPf dq). +Qed. + +Lemma dvdp_gdco p q : (gdcop p q) %| q. +Proof. by case: gdcopP. Qed. + +Lemma root_gdco p q x : p != 0 -> root (gdcop q p) x = root p x && ~~(root q x). +Proof. +move=> p0 /=; rewrite !root_factor_theorem. +apply: size2_dvdp_gdco; rewrite ?p0 //. +by rewrite size_addl size_polyX // size_opp size_polyC ltnS; case: (x != 0). +Qed. + +Lemma dvdp_comp_poly r p q : (p %| q) -> (p \Po r) %| (q \Po r). +Proof. +case: (eqVneq p 0) => [-> | pn0]. + by rewrite comp_poly0 !dvd0p; move/eqP->; rewrite comp_poly0. +rewrite dvdp_eq; set c := _ ^+ _; set s := _ %/ _; move/eqP=> Hq. +apply: (@eq_dvdp c (s \Po r)); first by rewrite expf_neq0 // lead_coef_eq0. +by rewrite -comp_polyZ Hq comp_polyM. +Qed. + +Lemma gcdp_comp_poly r p q : gcdp p q \Po r %= gcdp (p \Po r) (q \Po r). +Proof. +apply/andP; split. + by rewrite dvdp_gcd !dvdp_comp_poly ?dvdp_gcdl ?dvdp_gcdr. +case: (Bezoutp p q) => [[u v]] /andP []. +move/(dvdp_comp_poly r) => Huv _. +rewrite (dvdp_trans _ Huv) // comp_polyD !comp_polyM. +by rewrite dvdp_add // dvdp_mull // (dvdp_gcdl,dvdp_gcdr). +Qed. + +Lemma coprimep_comp_poly r p q : coprimep p q -> coprimep (p \Po r) (q \Po r). +Proof. +rewrite -!gcdp_eqp1 -!size_poly_eq1 -!dvdp1; move/(dvdp_comp_poly r). +rewrite comp_polyC => Hgcd. +by apply: dvdp_trans Hgcd; case/andP: (gcdp_comp_poly r p q). +Qed. + +Lemma coprimep_addl_mul p q r : coprimep r (p * r + q) = coprimep r q. +Proof. by rewrite !coprimep_def (eqp_size (gcdp_addl_mul _ _ _)). Qed. + +Definition irreducible_poly p := + (size p > 1) * (forall q, size q != 1%N -> q %| p -> q %= p) : Prop. + +Lemma irredp_neq0 p : irreducible_poly p -> p != 0. +Proof. by rewrite -size_poly_eq0 -lt0n => [[/ltnW]]. Qed. + +Definition apply_irredp p (irr_p : irreducible_poly p) := irr_p.2. +Coercion apply_irredp : irreducible_poly >-> Funclass. + +Lemma modp_XsubC p c : p %% ('X - c%:P) = p.[c]%:P. +Proof. +have: root (p - p.[c]%:P) c by rewrite /root !hornerE subrr. +case/factor_theorem=> q /(canRL (subrK _)) Dp; rewrite modpE /= lead_coefXsubC. +rewrite GRing.unitr1 expr1n invr1 scale1r {1}Dp. +rewrite RingMonic.rmodp_addl_mul_small // ?monicXsubC // size_XsubC size_polyC. +by case: (p.[c] == 0). +Qed. + +Lemma coprimep_XsubC p c : coprimep p ('X - c%:P) = ~~ root p c. +Proof. +rewrite -coprimep_modl modp_XsubC /root -alg_polyC. +have [-> | /coprimep_scalel->] := altP eqP; last exact: coprime1p. +by rewrite scale0r /coprimep gcd0p size_XsubC. +Qed. + +Lemma coprimepX p : coprimep p 'X = ~~ root p 0. +Proof. by rewrite -['X]subr0 coprimep_XsubC. Qed. + +Lemma eqp_monic : {in monic &, forall p q, (p %= q) = (p == q)}. +Proof. +move=> p q monic_p monic_q; apply/idP/eqP=> [|-> //]. +case/eqpP=> [[a b] /= /andP[a_neq0 _] eq_pq]. +apply: (@mulfI _ a%:P); first by rewrite polyC_eq0. +rewrite !mul_polyC eq_pq; congr (_ *: q); apply: (mulIf (oner_neq0 _)). +by rewrite -{1}(monicP monic_q) -(monicP monic_p) -!lead_coefZ eq_pq. +Qed. + + +Lemma dvdp_mul_XsubC p q c : + (p %| ('X - c%:P) * q) = ((if root p c then p %/ ('X - c%:P) else p) %| q). +Proof. +case: ifPn => [| not_pc0]; last by rewrite Gauss_dvdpr ?coprimep_XsubC. +rewrite root_factor_theorem -eqp_div_XsubC mulrC => /eqP{1}->. +by rewrite dvdp_mul2l ?polyXsubC_eq0. +Qed. + +Lemma dvdp_prod_XsubC (I : Type) (r : seq I) (F : I -> R) p : + p %| \prod_(i <- r) ('X - (F i)%:P) -> + {m | p %= \prod_(i <- mask m r) ('X - (F i)%:P)}. +Proof. +elim: r => [|i r IHr] in p *. + by rewrite big_nil dvdp1; exists nil; rewrite // big_nil -size_poly_eq1. +rewrite big_cons dvdp_mul_XsubC root_factor_theorem -eqp_div_XsubC. +case: eqP => [{2}-> | _] /IHr[m Dp]; last by exists (false :: m). +by exists (true :: m); rewrite /= mulrC big_cons eqp_mul2l ?polyXsubC_eq0. +Qed. + +Lemma irredp_XsubC (x : R) : irreducible_poly ('X - x%:P). +Proof. +split=> [|d size_d d_dv_Xx]; first by rewrite size_XsubC. +have: ~ d %= 1 by apply/negP; rewrite -size_poly_eq1. +have [|m /=] := @dvdp_prod_XsubC _ [:: x] id d; first by rewrite big_seq1. +by case: m => [|[] [|_ _] /=]; rewrite (big_nil, big_seq1). +Qed. + +Lemma irredp_XsubCP d p : + irreducible_poly p -> d %| p -> {d %= 1} + {d %= p}. +Proof. +move=> irred_p dvd_dp; have [] := boolP (_ %= 1); first by left. +by rewrite -size_poly_eq1=> /irred_p /(_ dvd_dp); right. +Qed. + +End IDomainPseudoDivision. + +Hint Resolve eqpxx divp0 divp1 mod0p modp0 modp1 dvdp_mull dvdp_mulr dvdpp. +Hint Resolve dvdp0. + +End CommonIdomain. + +Module Idomain. + +Include IdomainDefs. +Export IdomainDefs. +Include WeakIdomain. +Include CommonIdomain. + +End Idomain. + +Module IdomainMonic. + +Import Ring ComRing UnitRing IdomainDefs Idomain. + +Section MonicDivisor. + +Variable R : idomainType. +Variable q : {poly R}. +Hypothesis monq : q \is monic. + +Implicit Type p d r : {poly R}. + +Lemma divpE p : p %/ q = rdivp p q. +Proof. by rewrite divpE (eqP monq) unitr1 expr1n invr1 scale1r. Qed. + +Lemma modpE p : p %% q = rmodp p q. +Proof. by rewrite modpE (eqP monq) unitr1 expr1n invr1 scale1r. Qed. + +Lemma scalpE p : scalp p q = 0%N. +Proof. by rewrite scalpE (eqP monq) unitr1. Qed. + +Lemma divp_eq p : p = (p %/ q) * q + (p %% q). +Proof. by rewrite -divp_eq (eqP monq) expr1n scale1r. Qed. + +Lemma divpp p : q %/ q = 1. +Proof. by rewrite divpp ?monic_neq0 // (eqP monq) expr1n. Qed. + +Lemma dvdp_eq p : (q %| p) = (p == (p %/ q) * q). +Proof. by rewrite dvdp_eq (eqP monq) expr1n scale1r. Qed. + +Lemma dvdpP p : reflect (exists qq, p = qq * q) (q %| p). +Proof. +apply: (iffP idP); first by rewrite dvdp_eq; move/eqP=> e; exists (p %/ q). +by case=> qq ->; rewrite dvdp_mull // dvdpp. +Qed. + +Lemma mulpK p : p * q %/ q = p. +Proof. by rewrite mulpK ?monic_neq0 // (eqP monq) expr1n scale1r. Qed. + +Lemma mulKp p : q * p %/ q = p. +Proof. by rewrite mulrC; exact: mulpK. Qed. + +End MonicDivisor. + +End IdomainMonic. + +Module IdomainUnit. + +Import Ring ComRing UnitRing IdomainDefs Idomain. + +Section UnitDivisor. + +Variable R : idomainType. +Variable d : {poly R}. + +Hypothesis ulcd : lead_coef d \in GRing.unit. + +Implicit Type p q r : {poly R}. + +Lemma divp_eq p : p = (p %/ d) * d + (p %% d). +Proof. by have := (divp_eq p d); rewrite scalpE ulcd expr0 scale1r. Qed. + +Lemma edivpP p q r : p = q * d + r -> size r < size d -> + q = (p %/ d) /\ r = p %% d. +Proof. +move=> ep srd; have := (divp_eq p); rewrite {1}ep. +move/eqP; rewrite -subr_eq -addrA addrC eq_sym -subr_eq -mulrBl; move/eqP. +have lcdn0 : lead_coef d != 0 by apply: contraTneq ulcd => ->; rewrite unitr0. +case abs: (p %/ d - q == 0). + move: abs; rewrite subr_eq0; move/eqP->; rewrite subrr mul0r; move/eqP. + by rewrite eq_sym subr_eq0; move/eqP->. +have hleq : size d <= size ((p %/ d - q) * d). + rewrite size_proper_mul; last first. + by rewrite mulf_eq0 (negPf lcdn0) orbF lead_coef_eq0 abs. + move: abs; rewrite -size_poly_eq0; move/negbT; rewrite -lt0n; move/prednK<-. + by rewrite addSn /= leq_addl. +have hlt : size (r - p %% d) < size d. + apply: leq_ltn_trans (size_add _ _) _; rewrite size_opp. + by rewrite gtn_max srd ltn_modp /= -lead_coef_eq0. +by move=> e; have:= (leq_trans hlt hleq); rewrite e ltnn. +Qed. + +Lemma divpP p q r : p = q * d + r -> size r < size d -> + q = (p %/ d). +Proof. by move/edivpP=> h; case/h. Qed. + +Lemma modpP p q r : p = q * d + r -> size r < size d -> r = (p %% d). +Proof. by move/edivpP=> h; case/h. Qed. + +Lemma ulc_eqpP p q : lead_coef q \is a GRing.unit -> + reflect (exists2 c : R, c != 0 & p = c *: q) (p %= q). +Proof. + case: (altP (lead_coef q =P 0)) => [->|]; first by rewrite unitr0. + rewrite lead_coef_eq0 => nz_q ulcq; apply: (iffP idP). + case: (altP (p =P 0)) => [->|nz_p]. + by rewrite eqp_sym eqp0 (negbTE nz_q). + move/eqp_eq=> eq; exists (lead_coef p / lead_coef q). + by rewrite mulf_neq0 // ?invr_eq0 lead_coef_eq0. + by apply/(scaler_injl ulcq); rewrite scalerA mulrCA divrr // mulr1. + by case=> c nz_c ->; apply/eqpP; exists (1, c); rewrite ?scale1r ?oner_eq0. +Qed. + +Lemma dvdp_eq p : (d %| p) = (p == p %/ d * d). +Proof. +apply/eqP/eqP=> [modp0 | ->]; last exact: modp_mull. +by rewrite {1}(divp_eq p) modp0 addr0. +Qed. + +Lemma ucl_eqp_eq p q : lead_coef q \is a GRing.unit -> + p %= q -> p = (lead_coef p / lead_coef q) *: q. +Proof. +move=> ulcq /eqp_eq; move/(congr1 ( *:%R (lead_coef q)^-1 )). +by rewrite !scalerA mulrC divrr // scale1r mulrC. +Qed. + +Lemma modp_scalel c p : (c *: p) %% d = c *: (p %% d). +Proof. +case: (altP (c =P 0)) => [-> | cn0]; first by rewrite !scale0r mod0p. +have e : (c *: p) = (c *: (p %/ d)) * d + c *: (p %% d). + by rewrite -scalerAl -scalerDr -divp_eq. +have s: size (c *: (p %% d)) < size d. + rewrite -mul_polyC; apply: leq_ltn_trans (size_mul_leq _ _) _. + rewrite size_polyC cn0 addSn add0n /= ltn_modp. + by rewrite -lead_coef_eq0; apply: contraTneq ulcd => ->; rewrite unitr0. +by case: (edivpP e s) => _ ->. +Qed. + +Lemma divp_scalel c p : (c *: p) %/ d = c *: (p %/ d). +Proof. +case: (altP (c =P 0)) => [-> | cn0]; first by rewrite !scale0r div0p. +have e : (c *: p) = (c *: (p %/ d)) * d + c *: (p %% d). + by rewrite -scalerAl -scalerDr -divp_eq. +have s: size (c *: (p %% d)) < size d. + rewrite -mul_polyC; apply: leq_ltn_trans (size_mul_leq _ _) _. + rewrite size_polyC cn0 addSn add0n /= ltn_modp. + by rewrite -lead_coef_eq0; apply: contraTneq ulcd => ->; rewrite unitr0. +by case: (edivpP e s) => ->. +Qed. + +Lemma eqp_modpl p q : p %= q -> (p %% d) %= (q %% d). +Proof. +case/eqpP=> [[c1 c2]] /andP /= [c1n0 c2n0 e]. +by apply/eqpP; exists (c1, c2); rewrite ?c1n0 //= -!modp_scalel e. +Qed. + +Lemma eqp_divl p q : p %= q -> (p %/ d) %= (q %/ d). +Proof. +case/eqpP=> [[c1 c2]] /andP /= [c1n0 c2n0 e]. +by apply/eqpP; exists (c1, c2); rewrite ?c1n0 // -!divp_scalel e. +Qed. + +Lemma modp_opp p : (- p) %% d = - (p %% d). +Proof. +by rewrite -mulN1r -[- (_ %% _)]mulN1r -polyC_opp !mul_polyC modp_scalel. +Qed. + +Lemma divp_opp p : (- p) %/ d = - (p %/ d). +Proof. +by rewrite -mulN1r -[- (_ %/ _)]mulN1r -polyC_opp !mul_polyC divp_scalel. +Qed. + +Lemma modp_add p q : (p + q) %% d = p %% d + q %% d. +Proof. +have hs : size (p %% d + q %% d) < size d. + apply: leq_ltn_trans (size_add _ _) _. + rewrite gtn_max !ltn_modp andbb -lead_coef_eq0. + by apply: contraTneq ulcd => ->; rewrite unitr0. +have he : (p + q) = (p %/ d + q %/ d) * d + (p %% d + q %% d). + rewrite {1}(divp_eq p) {1}(divp_eq q) addrAC addrA -mulrDl. + by rewrite [_ %% _ + _]addrC addrA. +by case: (edivpP he hs). +Qed. + +Lemma divp_add p q : (p + q) %/ d = p %/ d + q %/ d. +Proof. +have hs : size (p %% d + q %% d) < size d. + apply: leq_ltn_trans (size_add _ _) _. + rewrite gtn_max !ltn_modp andbb -lead_coef_eq0. + by apply: contraTneq ulcd => ->; rewrite unitr0. +have he : (p + q) = (p %/ d + q %/ d) * d + (p %% d + q %% d). + rewrite {1}(divp_eq p) {1}(divp_eq q) addrAC addrA -mulrDl. + by rewrite [_ %% _ + _]addrC addrA. +by case: (edivpP he hs). +Qed. + +Lemma mulpK q : (q * d) %/ d = q. +Proof. +case/edivpP: (sym_eq (addr0 (q * d))); rewrite // size_poly0 size_poly_gt0. +by rewrite -lead_coef_eq0; apply: contraTneq ulcd => ->; rewrite unitr0. +Qed. + +Lemma mulKp q : (d * q) %/ d = q. +Proof. rewrite mulrC; exact: mulpK. Qed. + +Lemma divp_addl_mul_small q r : + size r < size d -> (q * d + r) %/ d = q. +Proof. by move=> srd; rewrite divp_add (divp_small srd) addr0 mulpK. Qed. + +Lemma modp_addl_mul_small q r : + size r < size d -> (q * d + r) %% d = r. +Proof. by move=> srd; rewrite modp_add modp_mull add0r modp_small. Qed. + +Lemma divp_addl_mul q r : (q * d + r) %/ d = q + r %/ d. +Proof. by rewrite divp_add mulpK. Qed. + +Lemma divpp : d %/ d = 1. +Proof. by rewrite -{1}(mul1r d) mulpK. Qed. + +Lemma leq_trunc_divp m : size (m %/ d * d) <= size m. +Proof. +have dn0 : d != 0. + by rewrite -lead_coef_eq0; apply: contraTneq ulcd => ->; rewrite unitr0. +case q0 : (m %/ d == 0); first by rewrite (eqP q0) mul0r size_poly0 leq0n. +rewrite {2}(divp_eq m) size_addl // size_mul ?q0 //; move/negbT: q0. +rewrite -size_poly_gt0; move/prednK<-; rewrite addSn /=. +by move: dn0; rewrite -(ltn_modp m); move/ltn_addl->. +Qed. + +Lemma dvdpP p : reflect (exists q, p = q * d) (d %| p). +Proof. +apply: (iffP idP) => [| [k ->]]; last by apply/eqP; rewrite modp_mull. +by rewrite dvdp_eq; move/eqP->; exists (p %/ d). +Qed. + +Lemma divpK p : d %| p -> p %/ d * d = p. +Proof. by rewrite dvdp_eq; move/eqP. Qed. + +Lemma divpKC p : d %| p -> d * (p %/ d) = p. +Proof. by move=> ?; rewrite mulrC divpK. Qed. + +Lemma dvdp_eq_div p q : d %| p -> (q == p %/ d) = (q * d == p). +Proof. +move/divpK=> {2}<-; apply/eqP/eqP; first by move->. +suff dn0 : d != 0 by move/(mulIf dn0). +by rewrite -lead_coef_eq0; apply: contraTneq ulcd => ->; rewrite unitr0. +Qed. + +Lemma dvdp_eq_mul p q : d %| p -> (p == q * d) = (p %/ d == q). +Proof. by move=>dv_d_p; rewrite eq_sym -dvdp_eq_div // eq_sym. Qed. + +Lemma divp_mulA p q : d %| q -> p * (q %/ d) = p * q %/ d. +Proof. +move=> hdm; apply/eqP; rewrite eq_sym -dvdp_eq_mul. + by rewrite -mulrA divpK. +by move/divpK: hdm<-; rewrite mulrA dvdp_mull // dvdpp. +Qed. + +Lemma divp_mulAC m n : d %| m -> m %/ d * n = m * n %/ d. +Proof. by move=> hdm; rewrite mulrC (mulrC m); exact: divp_mulA. Qed. + +Lemma divp_mulCA p q : d %| p -> d %| q -> p * (q %/ d) = q * (p %/ d). +Proof. by move=> hdp hdq; rewrite mulrC divp_mulAC // divp_mulA. Qed. + +Lemma modp_mul p q : (p * (q %% d)) %% d = (p * q) %% d. +Proof. +have -> : q %% d = q - q %/ d * d by rewrite {2}(divp_eq q) -addrA addrC subrK. +rewrite mulrDr modp_add // -mulNr mulrA -{2}[_ %% _]addr0; congr (_ + _). +by apply/eqP; apply: dvdp_mull; exact: dvdpp. +Qed. + +End UnitDivisor. + +Section MoreUnitDivisor. + +Variable R : idomainType. +Variable d : {poly R}. +Hypothesis ulcd : lead_coef d \in GRing.unit. + +Implicit Types p q : {poly R}. + +Lemma expp_sub m n : n <= m -> (d ^+ (m - n))%N = d ^+ m %/ d ^+ n. +Proof. +by move/subnK=> {2}<-; rewrite exprD mulpK // lead_coef_exp unitrX. +Qed. + +Lemma divp_pmul2l p q : lead_coef q \in GRing.unit -> d * p %/ (d * q) = p %/ q. +Proof. +move=> uq. +have udq: lead_coef (d * q) \in GRing.unit. + by rewrite lead_coefM unitrM_comm ?ulcd //; red; rewrite mulrC. +rewrite {1}(divp_eq uq p) mulrDr mulrCA divp_addl_mul //. +have dn0 : d != 0. + by rewrite -lead_coef_eq0; apply: contraTneq ulcd => ->; rewrite unitr0. +have qn0 : q != 0. + by rewrite -lead_coef_eq0; apply: contraTneq uq => ->; rewrite unitr0. +have dqn0 : d * q != 0 by rewrite mulf_eq0 negb_or dn0. +suff : size (d * (p %% q)) < size (d * q). + by rewrite ltnNge -divpN0 // negbK => /eqP ->; rewrite addr0. +case: (altP ( (p %% q) =P 0)) => [-> | rn0]. + by rewrite mulr0 size_poly0 size_poly_gt0. +rewrite !size_mul //; move: dn0; rewrite -size_poly_gt0. +by move/prednK<-; rewrite !addSn /= ltn_add2l ltn_modp. +Qed. + +Lemma divp_pmul2r p q : + lead_coef p \in GRing.unit -> q * d %/ (p * d) = q %/ p. +Proof. by move=> uq; rewrite -!(mulrC d) divp_pmul2l. Qed. + +Lemma divp_divl r p q : + lead_coef r \in GRing.unit -> lead_coef p \in GRing.unit -> + q %/ p %/ r = q %/ (p * r). +Proof. +move=> ulcr ulcp. +have e : q = (q %/ p %/ r) * (p * r) + ((q %/ p) %% r * p + q %% p). + rewrite addrA (mulrC p) mulrA -mulrDl; rewrite -divp_eq //; exact: divp_eq. +have pn0 : p != 0. + by rewrite -lead_coef_eq0; apply: contraTneq ulcp => ->; rewrite unitr0. +have rn0 : r != 0. + by rewrite -lead_coef_eq0; apply: contraTneq ulcr => ->; rewrite unitr0. +have s : size ((q %/ p) %% r * p + q %% p) < size (p * r). + case: (altP ((q %/ p) %% r =P 0)) => [-> | qn0]. + rewrite mul0r add0r size_mul // (polySpred rn0) addnS /=. + by apply: leq_trans (leq_addr _ _); rewrite ltn_modp. + rewrite size_addl mulrC. + by rewrite !size_mul // (polySpred pn0) !addSn /= ltn_add2l ltn_modp. + rewrite size_mul // (polySpred qn0) addnS /=. + by apply: leq_trans (leq_addr _ _); rewrite ltn_modp. +case: (edivpP _ e s) => //; rewrite lead_coefM unitrM_comm ?ulcp //. +by red; rewrite mulrC. +Qed. + +Lemma divpAC p q : lead_coef p \in GRing.unit -> q %/ d %/ p = q %/ p %/ d. +Proof. by move=> ulcp; rewrite !divp_divl // mulrC. Qed. + +Lemma modp_scaler c p : c \in GRing.unit -> p %% (c *: d) = (p %% d). +Proof. +move=> cn0; case: (eqVneq d 0) => [-> | dn0]; first by rewrite scaler0 !modp0. +have e : p = (c^-1 *: (p %/ d)) * (c *: d) + (p %% d). + by rewrite scalerCA scalerA mulVr // scale1r -(divp_eq ulcd). +suff s : size (p %% d) < size (c *: d). + by rewrite (modpP _ e s) // -mul_polyC lead_coefM lead_coefC unitrM cn0. +by rewrite size_scale ?ltn_modp //; apply: contraTneq cn0 => ->; rewrite unitr0. +Qed. + +Lemma divp_scaler c p : c \in GRing.unit -> p %/ (c *: d) = c^-1 *: (p %/ d). +Proof. +move=> cn0; case: (eqVneq d 0) => [-> | dn0]. + by rewrite scaler0 !divp0 scaler0. +have e : p = (c^-1 *: (p %/ d)) * (c *: d) + (p %% d). + by rewrite scalerCA scalerA mulVr // scale1r -(divp_eq ulcd). +suff s : size (p %% d) < size (c *: d). + by rewrite (divpP _ e s) // -mul_polyC lead_coefM lead_coefC unitrM cn0. +by rewrite size_scale ?ltn_modp //; apply: contraTneq cn0 => ->; rewrite unitr0. +Qed. + +End MoreUnitDivisor. + +End IdomainUnit. + +Module Field. + +Import Ring ComRing UnitRing. +Include IdomainDefs. +Export IdomainDefs. +Include CommonIdomain. + +Section FieldDivision. + +Variable F : fieldType. + +Implicit Type p q r d : {poly F}. + +Lemma divp_eq p q : p = (p %/ q) * q + (p %% q). +Proof. +case: (eqVneq q 0) => [-> | qn0]; first by rewrite modp0 mulr0 add0r. +by apply: IdomainUnit.divp_eq; rewrite unitfE lead_coef_eq0. +Qed. + +Lemma divp_modpP p q d r : p = q * d + r -> size r < size d -> + q = (p %/ d) /\ r = p %% d. +Proof. +move=> he hs; apply: IdomainUnit.edivpP => //; rewrite unitfE lead_coef_eq0. +by rewrite -size_poly_gt0; apply: leq_trans hs. +Qed. + +Lemma divpP p q d r : p = q * d + r -> size r < size d -> + q = (p %/ d). +Proof. by move/divp_modpP=> h; case/h. Qed. + +Lemma modpP p q d r : p = q * d + r -> size r < size d -> r = (p %% d). +Proof. by move/divp_modpP=> h; case/h. Qed. + +Lemma eqpfP p q : p %= q -> p = (lead_coef p / lead_coef q) *: q. +Proof. +have [->|nz_q] := altP (q =P 0). + by rewrite eqp0 => /eqP ->; rewrite scaler0. +move/IdomainUnit.ucl_eqp_eq; apply; rewrite unitfE. +by move: nz_q; rewrite -lead_coef_eq0 => nz_qT. +Qed. + +Lemma dvdp_eq q p : (q %| p) = (p == p %/ q * q). +Proof. +case: (eqVneq q 0) => [-> | qn0]; first by rewrite dvd0p mulr0 eq_sym. +by apply: IdomainUnit.dvdp_eq; rewrite unitfE lead_coef_eq0. +Qed. + +Lemma eqpf_eq p q : reflect (exists2 c, c != 0 & p = c *: q) (p %= q). +Proof. +apply: (iffP idP); last first. + case=> c nz_c ->; apply/eqpP. + by exists (1, c); rewrite ?scale1r ?oner_eq0. +have [->|nz_q] := altP (q =P 0). + by rewrite eqp0=> /eqP ->; exists 1; rewrite ?scale1r ?oner_eq0. +case/IdomainUnit.ulc_eqpP; first by rewrite unitfE lead_coef_eq0. +by move=> c nz_c ->; exists c. +Qed. + +Lemma modp_scalel c p q : (c *: p) %% q = c *: (p %% q). +Proof. +case: (eqVneq q 0) => [-> | qn0]; first by rewrite !modp0. +by apply: IdomainUnit.modp_scalel; rewrite unitfE lead_coef_eq0. +Qed. + +Lemma mulpK p q : q != 0 -> p * q %/ q = p. +Proof. by move=> qn0; rewrite IdomainUnit.mulpK // unitfE lead_coef_eq0. Qed. + +Lemma mulKp p q : q != 0 -> q * p %/ q = p. +Proof. by rewrite mulrC; exact: mulpK. Qed. + +Lemma divp_scalel c p q : (c *: p) %/ q = c *: (p %/ q). +Proof. +case: (eqVneq q 0) => [-> | qn0]; first by rewrite !divp0 scaler0. +by apply: IdomainUnit.divp_scalel; rewrite unitfE lead_coef_eq0. +Qed. + +Lemma modp_scaler c p d : c != 0 -> p %% (c *: d) = (p %% d). +Proof. +move=> cn0; case: (eqVneq d 0) => [-> | dn0]; first by rewrite scaler0 !modp0. +have e : p = (c^-1 *: (p %/ d)) * (c *: d) + (p %% d). + by rewrite scalerCA scalerA mulVf // scale1r -divp_eq. +suff s : size (p %% d) < size (c *: d) by rewrite (modpP e s). +by rewrite size_scale ?ltn_modp. +Qed. + +Lemma divp_scaler c p d : c != 0 -> p %/ (c *: d) = c^-1 *: (p %/ d). +Proof. +move=> cn0; case: (eqVneq d 0) => [-> | dn0]. + by rewrite scaler0 !divp0 scaler0. +have e : p = (c^-1 *: (p %/ d)) * (c *: d) + (p %% d). + by rewrite scalerCA scalerA mulVf // scale1r -divp_eq. +suff s : size (p %% d) < size (c *: d) by rewrite (divpP e s). +by rewrite size_scale ?ltn_modp. +Qed. + +Lemma eqp_modpl d p q : p %= q -> (p %% d) %= (q %% d). +Proof. +case/eqpP=> [[c1 c2]] /andP /= [c1n0 c2n0 e]. +by apply/eqpP; exists (c1, c2); rewrite ?c1n0 // -!modp_scalel e. +Qed. + +Lemma eqp_divl d p q : p %= q -> (p %/ d) %= (q %/ d). +Proof. +case/eqpP=> [[c1 c2]] /andP /= [c1n0 c2n0 e]. +by apply/eqpP; exists (c1, c2); rewrite ?c1n0 // -!divp_scalel e. +Qed. + +Lemma eqp_modpr d p q : p %= q -> (d %% p) %= (d %% q). +Proof. +case/eqpP=> [[c1 c2]] /andP [c1n0 c2n0 e]. +have -> : p = (c1^-1 * c2) *: q by rewrite -scalerA -e scalerA mulVf // scale1r. +by rewrite modp_scaler ?eqpxx // mulf_eq0 negb_or invr_eq0 c1n0. +Qed. + +Lemma eqp_mod p1 p2 q1 q2 : p1 %= p2 -> q1 %= q2 -> p1 %% q1 %= p2 %% q2. +Proof. +move=> e1 e2; apply: eqp_trans (eqp_modpr _ e2). +apply: eqp_trans (eqp_modpl _ e1); exact: eqpxx. +Qed. + +Lemma eqp_divr (d m n : {poly F}) : m %= n -> (d %/ m) %= (d %/ n). +Proof. +case/eqpP=> [[c1 c2]] /andP [c1n0 c2n0 e]. +have -> : m = (c1^-1 * c2) *: n by rewrite -scalerA -e scalerA mulVf // scale1r. +by rewrite divp_scaler ?eqp_scale // ?invr_eq0 mulf_eq0 negb_or invr_eq0 c1n0. +Qed. + +Lemma eqp_div p1 p2 q1 q2 : p1 %= p2 -> q1 %= q2 -> p1 %/ q1 %= p2 %/ q2. +Proof. +move=> e1 e2; apply: eqp_trans (eqp_divr _ e2). +apply: eqp_trans (eqp_divl _ e1); exact: eqpxx. +Qed. + +Lemma eqp_gdcor p q r : q %= r -> gdcop p q %= gdcop p r. +Proof. +move=> eqr; rewrite /gdcop (eqp_size eqr). +move: (size r)=> n; elim: n p q r eqr => [|n ihn] p q r; first by rewrite eqpxx. +move=> eqr /=; rewrite (eqp_coprimepl p eqr); case: ifP => _ //; apply: ihn. +apply: eqp_div => //; exact: eqp_gcdl. +Qed. + +Lemma eqp_gdcol p q r : q %= r -> gdcop q p %= gdcop r p. +Proof. +move=> eqr; rewrite /gdcop; move: (size p)=> n. +elim: n p q r eqr {1 3}p (eqpxx p) => [|n ihn] p q r eqr s esp /=. + move: eqr; case: (eqVneq q 0)=> [-> | nq0 eqr] /=. + by rewrite eqp_sym eqp0; move->; rewrite eqxx eqpxx. + suff rn0 : r != 0 by rewrite (negPf nq0) (negPf rn0) eqpxx. + by apply: contraTneq eqr => ->; rewrite eqp0. +rewrite (eqp_coprimepr _ eqr) (eqp_coprimepl _ esp); case: ifP=> _ //. +apply: ihn => //; apply: eqp_div => //; exact: eqp_gcd. +Qed. + +Lemma eqp_rgdco_gdco q p : rgdcop q p %= gdcop q p. +Proof. +rewrite /rgdcop /gdcop; move: (size p)=> n. +elim: n p q {1 3}p {1 3}q (eqpxx p) (eqpxx q) => [|n ihn] p q s t /= sp tq. + move: tq; case: (eqVneq t 0)=> [-> | nt0 etq]. + by rewrite eqp_sym eqp0; move->; rewrite eqxx eqpxx. + suff qn0 : q != 0 by rewrite (negPf nt0) (negPf qn0) eqpxx. + by apply: contraTneq etq => ->; rewrite eqp0. +rewrite rcoprimep_coprimep (eqp_coprimepl t sp) (eqp_coprimepr p tq). +case: ifP=> // _; apply: ihn => //; apply: eqp_trans (eqp_rdiv_div _ _) _. +by apply: eqp_div => //; apply: eqp_trans (eqp_rgcd_gcd _ _) _; apply: eqp_gcd. +Qed. + +Lemma modp_opp p q : (- p) %% q = - (p %% q). +Proof. +case: (eqVneq q 0) => [-> | qn0]; first by rewrite !modp0. +by apply: IdomainUnit.modp_opp; rewrite unitfE lead_coef_eq0. +Qed. + +Lemma divp_opp p q : (- p) %/ q = - (p %/ q). +Proof. +case: (eqVneq q 0) => [-> | qn0]; first by rewrite !divp0 oppr0. +by apply: IdomainUnit.divp_opp; rewrite unitfE lead_coef_eq0. +Qed. + +Lemma modp_add d p q : (p + q) %% d = p %% d + q %% d. +Proof. +case: (eqVneq d 0) => [-> | dn0]; first by rewrite !modp0. +by apply: IdomainUnit.modp_add; rewrite unitfE lead_coef_eq0. +Qed. + +Lemma modNp p q : (- p) %% q = - (p %% q). +Proof. by apply/eqP; rewrite -addr_eq0 -modp_add addNr mod0p. Qed. + +Lemma divp_add d p q : (p + q) %/ d = p %/ d + q %/ d. +Proof. +case: (eqVneq d 0) => [-> | dn0]; first by rewrite !divp0 addr0. +by apply: IdomainUnit.divp_add; rewrite unitfE lead_coef_eq0. +Qed. + +Lemma divp_addl_mul_small d q r : + size r < size d -> (q * d + r) %/ d = q. +Proof. +move=> srd; rewrite divp_add (divp_small srd) addr0 mulpK //. +by rewrite -size_poly_gt0; apply: leq_trans srd. +Qed. + +Lemma modp_addl_mul_small d q r : + size r < size d -> (q * d + r) %% d = r. +Proof. by move=> srd; rewrite modp_add modp_mull add0r modp_small. Qed. + +Lemma divp_addl_mul d q r : d != 0 -> (q * d + r) %/ d = q + r %/ d. +Proof. by move=> dn0; rewrite divp_add mulpK. Qed. + +Lemma divpp d : d != 0 -> d %/ d = 1. +Proof. +by move=> dn0; apply: IdomainUnit.divpp; rewrite unitfE lead_coef_eq0. +Qed. + +Lemma leq_trunc_divp d m : size (m %/ d * d) <= size m. +Proof. +case: (eqVneq d 0) => [-> | dn0]; first by rewrite mulr0 size_poly0. +by apply: IdomainUnit.leq_trunc_divp; rewrite unitfE lead_coef_eq0. +Qed. + +Lemma divpK d p : d %| p -> p %/ d * d = p. +Proof. +case: (eqVneq d 0) => [-> | dn0]; first by move/dvd0pP->; rewrite mulr0. +by apply: IdomainUnit.divpK; rewrite unitfE lead_coef_eq0. +Qed. + +Lemma divpKC d p : d %| p -> d * (p %/ d) = p. +Proof. by move=> ?; rewrite mulrC divpK. Qed. + +Lemma dvdp_eq_div d p q : d != 0 -> d %| p -> (q == p %/ d) = (q * d == p). +Proof. +by move=> dn0; apply: IdomainUnit.dvdp_eq_div; rewrite unitfE lead_coef_eq0. +Qed. + +Lemma dvdp_eq_mul d p q : d != 0 -> d %| p -> (p == q * d) = (p %/ d == q). +Proof. by move=> dn0 dv_d_p; rewrite eq_sym -dvdp_eq_div // eq_sym. Qed. + +Lemma divp_mulA d p q : d %| q -> p * (q %/ d) = p * q %/ d. +Proof. +case: (eqVneq d 0) => [-> | dn0]; first by move/dvd0pP->; rewrite !divp0 mulr0. +by apply: IdomainUnit.divp_mulA; rewrite unitfE lead_coef_eq0. +Qed. + +Lemma divp_mulAC d m n : d %| m -> m %/ d * n = m * n %/ d. +Proof. by move=> hdm; rewrite mulrC (mulrC m); exact: divp_mulA. Qed. + +Lemma divp_mulCA d p q : d %| p -> d %| q -> p * (q %/ d) = q * (p %/ d). +Proof. by move=> hdp hdq; rewrite mulrC divp_mulAC // divp_mulA. Qed. + +Lemma expp_sub d m n : d != 0 -> m >= n -> (d ^+ (m - n))%N = d ^+ m %/ d ^+ n. +Proof. by move=> dn0 /subnK=> {2}<-; rewrite exprD mulpK // expf_neq0. Qed. + +Lemma divp_pmul2l d q p : d != 0 -> q != 0 -> d * p %/ (d * q) = p %/ q. +Proof. +by move=> dn0 qn0; apply: IdomainUnit.divp_pmul2l; rewrite unitfE lead_coef_eq0. +Qed. + +Lemma divp_pmul2r d p q : d != 0 -> p != 0 -> q * d %/ (p * d) = q %/ p. +Proof. by move=> dn0 qn0; rewrite -!(mulrC d) divp_pmul2l. Qed. + +Lemma divp_divl r p q : q %/ p %/ r = q %/ (p * r). +Proof. +case: (eqVneq r 0) => [-> | rn0]; first by rewrite mulr0 !divp0. +case: (eqVneq p 0) => [-> | pn0]; first by rewrite mul0r !divp0 div0p. +by apply: IdomainUnit.divp_divl; rewrite unitfE lead_coef_eq0. +Qed. + +Lemma divpAC d p q : q %/ d %/ p = q %/ p %/ d. +Proof. by rewrite !divp_divl // mulrC. Qed. + +Lemma edivp_def p q : edivp p q = (0%N, p %/ q, p %% q). +Proof. +rewrite Idomain.edivp_def; congr (_, _, _); rewrite /scalp 2!unlock /=. +case (eqVneq q 0) => [-> | qn0]; first by rewrite eqxx lead_coef0 unitr0. +rewrite (negPf qn0) /= unitfE lead_coef_eq0 qn0 /=. +by case: (redivp_rec _ _ _ _) => [[]]. +Qed. + +Lemma divpE p q : p %/ q = (lead_coef q)^-(rscalp p q) *: (rdivp p q). +Proof. +case: (eqVneq q 0) => [-> | qn0]; first by rewrite rdivp0 divp0 scaler0. +by rewrite Idomain.divpE unitfE lead_coef_eq0 qn0. +Qed. + +Lemma modpE p q : p %% q = (lead_coef q)^-(rscalp p q) *: (rmodp p q). +Proof. +case: (eqVneq q 0) => [-> | qn0]. + by rewrite rmodp0 modp0 /rscalp unlock eqxx lead_coef0 expr0 invr1 scale1r. +by rewrite Idomain.modpE unitfE lead_coef_eq0 qn0. +Qed. + +Lemma scalpE p q : scalp p q = 0%N. +Proof. +case: (eqVneq q 0) => [-> | qn0]; first by rewrite scalp0. +by rewrite Idomain.scalpE unitfE lead_coef_eq0 qn0. +Qed. + +(* Just to have it without importing the weak theory *) +Lemma dvdpE p q : p %| q = rdvdp p q. Proof. exact: Idomain.dvdpE. Qed. + +CoInductive edivp_spec m d : nat * {poly F} * {poly F} -> Type := + EdivpSpec n q r of + m = q * d + r & (d != 0) ==> (size r < size d) : edivp_spec m d (n, q, r). + +Lemma edivpP m d : edivp_spec m d (edivp m d). +Proof. +rewrite edivp_def; constructor; first exact: divp_eq. +by apply/implyP=> dn0; rewrite ltn_modp. +Qed. + +Lemma edivp_eq d q r : size r < size d -> edivp (q * d + r) d = (0%N, q, r). +Proof. +move=> srd; apply: Idomain.edivp_eq ; rewrite // unitfE lead_coef_eq0. +rewrite -size_poly_gt0; exact: leq_trans srd. +Qed. + +Lemma modp_mul p q m : (p * (q %% m)) %% m = (p * q) %% m. +Proof. +have ->: q %% m = q - q %/ m * m by rewrite {2}(divp_eq q m) -addrA addrC subrK. +rewrite mulrDr modp_add // -mulNr mulrA -{2}[_ %% _]addr0; congr (_ + _). +by apply/eqP; apply: dvdp_mull; exact: dvdpp. +Qed. + +Lemma dvdpP p q : reflect (exists qq, p = qq * q) (q %| p). +Proof. +case: (eqVneq q 0)=> [-> | qn0]; last first. + by apply: IdomainUnit.dvdpP; rewrite unitfE lead_coef_eq0. +rewrite dvd0p. +by apply: (iffP idP) => [/eqP->| [? ->]]; [exists 1|]; rewrite mulr0. +Qed. + +Lemma Bezout_eq1_coprimepP : forall p q, + reflect (exists u, u.1 * p + u.2 * q = 1) (coprimep p q). +Proof. +move=> p q; apply:(iffP idP)=> [hpq|]; last first. + by case=>[[u v]] /= e; apply/Bezout_coprimepP; exists (u, v); rewrite e eqpxx. +case/Bezout_coprimepP: hpq => [[u v]] /=. +case/eqpP=> [[c1 c2]] /andP /= [c1n0 c2n0] e. +exists (c2^-1 *: (c1 *: u), c2^-1 *: (c1 *: v)); rewrite /= -!scalerAl. +by rewrite -!scalerDr e scalerA mulVf // scale1r. +Qed. + +Lemma dvdp_gdcor p q : q != 0 -> p %| (gdcop q p) * (q ^+ size p). +Proof. +move=> q_neq0; rewrite /gdcop. +elim: (size p) {-2 5}p (leqnn (size p))=> {p} [|n ihn] p. + rewrite size_poly_leq0; move/eqP->. + by rewrite size_poly0 /= dvd0p expr0 mulr1 (negPf q_neq0). +move=> hsp /=; have [->|p_neq0] := altP (p =P 0). + rewrite size_poly0 /= dvd0p expr0 mulr1 div0p /=. + case: ifP=> // _; have := (ihn 0). + by rewrite size_poly0 expr0 mulr1 dvd0p=> /(_ isT). +have [|ncop_pq] := boolP (coprimep _ _); first by rewrite dvdp_mulr ?dvdpp. +have g_gt1: (1 < size (gcdp p q))%N. + have [|//|/eqP] := ltngtP; last by rewrite -coprimep_def (negPf ncop_pq). + by rewrite ltnS leqn0 size_poly_eq0 gcdp_eq0 (negPf p_neq0). +have sd : (size (p %/ gcdp p q) < size p)%N. + rewrite size_divp -?size_poly_eq0 -(subnKC g_gt1) // add2n /=. + by rewrite -[size _]prednK ?size_poly_gt0 // ltnS subSS leq_subr. +rewrite -{1}[p](divpK (dvdp_gcdl _ q)) -(subnKC sd) addSnnS exprD mulrA. +rewrite dvdp_mul ?ihn //; first by rewrite -ltnS (leq_trans sd). +by rewrite exprS dvdp_mulr // dvdp_gcdr. +Qed. + +Lemma reducible_cubic_root p q : + size p <= 4 -> 1 < size q < size p -> q %| p -> {r | root p r}. +Proof. +move=> p_le4 /andP[]; rewrite leq_eqVlt eq_sym. +have [/poly2_root[x qx0] _ _ | _ /= q_gt2 p_gt_q] := size q =P 2. + by exists x; rewrite -!dvdp_XsubCl in qx0 *; apply: (dvdp_trans qx0). +case/dvdpP/sig_eqW=> r def_p; rewrite def_p. +suffices /poly2_root[x rx0]: size r = 2 by exists x; rewrite rootM rx0. +have /norP[nz_r nz_q]: ~~ [|| r == 0 | q == 0]. + by rewrite -mulf_eq0 -def_p -size_poly_gt0 (leq_ltn_trans _ p_gt_q). +rewrite def_p size_mul // -subn1 leq_subLR ltn_subRL in p_gt_q p_le4. +by apply/eqP; rewrite -(eqn_add2r (size q)) eqn_leq (leq_trans p_le4). +Qed. + +Lemma cubic_irreducible p : + 1 < size p <= 4 -> (forall x, ~~ root p x) -> irreducible_poly p. +Proof. +move=> /andP[p_gt1 p_le4] root'p; split=> // q sz_q_neq1 q_dv_p. +have nz_p: p != 0 by rewrite -size_poly_gt0 ltnW. +have nz_q: q != 0 by apply: contraTneq q_dv_p => ->; rewrite dvd0p. +have q_gt1: size q > 1 by rewrite ltn_neqAle eq_sym sz_q_neq1 size_poly_gt0. +rewrite -dvdp_size_eqp // eqn_leq dvdp_leq //= leqNgt; apply/negP=> p_gt_q. +by have [|x /idPn//] := reducible_cubic_root p_le4 _ q_dv_p; rewrite q_gt1. +Qed. + +Section FieldRingMap. + +Variable rR : ringType. + +Variable f : {rmorphism F -> rR}. +Local Notation "p ^f" := (map_poly f p) : ring_scope. + +Implicit Type a b : {poly F}. + +Lemma redivp_map a b : + redivp a^f b^f = (rscalp a b, (rdivp a b)^f, (rmodp a b)^f). +Proof. +rewrite /rdivp /rscalp /rmodp !unlock map_poly_eq0 size_map_poly. +case: eqP; rewrite /= -(rmorph0 (map_poly_rmorphism f)) //; move/eqP=> q_nz. +move: (size a) => m; elim: m 0%N 0 a => [|m IHm] qq r a /=. + rewrite -!mul_polyC !size_map_poly !lead_coef_map // -(map_polyXn f). + by rewrite -!(map_polyC f) -!rmorphM -rmorphB -rmorphD; case: (_ < _). +rewrite -!mul_polyC !size_map_poly !lead_coef_map // -(map_polyXn f). +by rewrite -!(map_polyC f) -!rmorphM -rmorphB -rmorphD /= IHm; case: (_ < _). +Qed. + +End FieldRingMap. + +Section FieldMap. + +Variable rR : idomainType. + +Variable f : {rmorphism F -> rR}. +Local Notation "p ^f" := (map_poly f p) : ring_scope. + +Implicit Type a b : {poly F}. + +Lemma edivp_map a b : + edivp a^f b^f = (0%N, (a %/ b)^f, (a %% b)^f). +Proof. +case: (eqVneq b 0) => [-> | bn0]. + rewrite (rmorph0 (map_poly_rmorphism f)) WeakIdomain.edivp_def !modp0 !divp0. + by rewrite (rmorph0 (map_poly_rmorphism f)) scalp0. +rewrite unlock redivp_map lead_coef_map rmorph_unit; last first. + by rewrite unitfE lead_coef_eq0. +rewrite modpE divpE !map_polyZ !rmorphV ?rmorphX // unitfE. +by rewrite expf_neq0 // lead_coef_eq0. +Qed. + +Lemma scalp_map p q : scalp p^f q^f = scalp p q. +Proof. by rewrite /scalp edivp_map edivp_def. Qed. + +Lemma map_divp p q : (p %/ q)^f = p^f %/ q^f. +Proof. by rewrite /divp edivp_map edivp_def. Qed. + +Lemma map_modp p q : (p %% q)^f = p^f %% q^f. +Proof. by rewrite /modp edivp_map edivp_def. Qed. + +Lemma egcdp_map p q : + egcdp (map_poly f p) (map_poly f q) + = (map_poly f (egcdp p q).1, map_poly f (egcdp p q).2). +Proof. +wlog le_qp: p q / size q <= size p. + move=> IH; have [/IH// | lt_qp] := leqP (size q) (size p). + have /IH := ltnW lt_qp; rewrite /egcdp !size_map_poly ltnW // leqNgt lt_qp /=. + by case: (egcdp_rec _ _ _) => u v [-> ->]. +rewrite /egcdp !size_map_poly {}le_qp; move: (size q) => n. +elim: n => /= [|n IHn] in p q *; first by rewrite rmorph1 rmorph0. +rewrite map_poly_eq0; have [_ | nz_q] := ifPn; first by rewrite rmorph1 rmorph0. +rewrite -map_modp (IHn q (p %% q)); case: (egcdp_rec _ _ n) => u v /=. +by rewrite map_polyZ lead_coef_map -rmorphX scalp_map rmorphB rmorphM -map_divp. +Qed. + +Lemma dvdp_map p q : (p^f %| q^f) = (p %| q). +Proof. by rewrite /dvdp -map_modp map_poly_eq0. Qed. + +Lemma eqp_map p q : (p^f %= q^f) = (p %= q). +Proof. by rewrite /eqp !dvdp_map. Qed. + +Lemma gcdp_map p q : (gcdp p q)^f = gcdp p^f q^f. +Proof. +wlog lt_p_q: p q / size p < size q. + move=> IH; case: (ltnP (size p) (size q)) => [|le_q_p]; first exact: IH. + rewrite gcdpE (gcdpE p^f) !size_map_poly ltnNge le_q_p /= -map_modp. + case: (eqVneq q 0) => [-> | q_nz]; first by rewrite rmorph0 !gcdp0. + by rewrite IH ?ltn_modp. +elim: {q}_.+1 p {-2}q (ltnSn (size q)) lt_p_q => // m IHm p q le_q_m lt_p_q. +rewrite gcdpE (gcdpE p^f) !size_map_poly lt_p_q -map_modp. +case: (eqVneq p 0) => [-> | q_nz]; first by rewrite rmorph0 !gcdp0. +by rewrite IHm ?(leq_trans lt_p_q) ?ltn_modp. +Qed. + +Lemma coprimep_map p q : coprimep p^f q^f = coprimep p q. +Proof. by rewrite -!gcdp_eqp1 -eqp_map rmorph1 gcdp_map. Qed. + +Lemma gdcop_rec_map p q n : (gdcop_rec p q n)^f = (gdcop_rec p^f q^f n). +Proof. +elim: n p q => [|n IH] => /= p q. + by rewrite map_poly_eq0; case: eqP; rewrite ?rmorph1 ?rmorph0. +rewrite /coprimep -gcdp_map size_map_poly. +by case: eqP => Hq0 //; rewrite -map_divp -IH. +Qed. + +Lemma gdcop_map p q : (gdcop p q)^f = (gdcop p^f q^f). +Proof. by rewrite /gdcop gdcop_rec_map !size_map_poly. Qed. + +End FieldMap. + +End FieldDivision. + +End Field. + +Module ClosedField. + +Import Field. + +Section closed. + +Variable F : closedFieldType. + +Lemma root_coprimep (p q : {poly F}): + (forall x, root p x -> q.[x] != 0) -> coprimep p q. +Proof. +move=> Ncmn; rewrite -gcdp_eqp1 -size_poly_eq1; apply/closed_rootP. +by case=> r; rewrite root_gcd !rootE=> /andP [/Ncmn/negbTE->]. +Qed. + +Lemma coprimepP (p q : {poly F}): + reflect (forall x, root p x -> q.[x] != 0) (coprimep p q). +Proof. + by apply: (iffP idP)=> [/coprimep_root|/root_coprimep]. +Qed. + +End closed. + +End ClosedField. + +End Pdiv. + +Export Pdiv.Field. diff --git a/mathcomp/algebra/rat.v b/mathcomp/algebra/rat.v new file mode 100644 index 0000000..b2b88d9 --- /dev/null +++ b/mathcomp/algebra/rat.v @@ -0,0 +1,808 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype. +Require Import bigop ssralg div ssrnum ssrint. + +(******************************************************************************) +(* This file defines a datatype for rational numbers and equips it with a *) +(* structure of archimedean, real field, with int and nat declared as closed *) +(* subrings. *) +(* rat == the type of rational number, with single constructor Rat *) +(* Rat p h == the element of type rat build from p a pair of integers and*) +(* h a proof of (0 < p.2) && coprime `|p.1| `|p.2| *) +(* n%:Q == explicit cast from int to rat, postfix notation for the *) +(* ratz constant *) +(* numq r == numerator of (r : rat) *) +(* denq r == denominator of (r : rat) *) +(* x \is a Qint == x is an element of rat whose denominator is equal to 1 *) +(* x \is a Qnat == x is a positive element of rat whose denominator is equal *) +(* to 1 *) +(* ratr x == generic embedding of (r : R) into an arbitrary unitring. *) +(******************************************************************************) + +Import GRing.Theory. +Import Num.Theory. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope ring_scope. +Local Notation sgr := Num.sg. + +Record rat : Set := Rat { + valq : (int * int) ; + _ : (0 < valq.2) && coprime `|valq.1| `|valq.2| +}. + +Bind Scope ring_scope with rat. +Delimit Scope rat_scope with Q. + +Definition ratz (n : int) := @Rat (n, 1) (coprimen1 _). +(* Coercion ratz (n : int) := @Rat (n, 1) (coprimen1 _). *) + +Canonical rat_subType := Eval hnf in [subType for valq]. +Definition rat_eqMixin := [eqMixin of rat by <:]. +Canonical rat_eqType := EqType rat rat_eqMixin. +Definition rat_choiceMixin := [choiceMixin of rat by <:]. +Canonical rat_choiceType := ChoiceType rat rat_choiceMixin. +Definition rat_countMixin := [countMixin of rat by <:]. +Canonical rat_countType := CountType rat rat_countMixin. +Canonical rat_subCountType := [subCountType of rat]. + +Definition numq x := nosimpl ((valq x).1). +Definition denq x := nosimpl ((valq x).2). + +Lemma denq_gt0 x : 0 < denq x. +Proof. by rewrite /denq; case: x=> [[a b] /= /andP []]. Qed. +Hint Resolve denq_gt0. + +Definition denq_ge0 x := ltrW (denq_gt0 x). + +Lemma denq_lt0 x : (denq x < 0) = false. Proof. by rewrite ltr_gtF. Qed. + +Lemma denq_neq0 x : denq x != 0. +Proof. by rewrite /denq gtr_eqF ?denq_gt0. Qed. +Hint Resolve denq_neq0. + +Lemma denq_eq0 x : (denq x == 0) = false. +Proof. exact: negPf (denq_neq0 _). Qed. + +Lemma coprime_num_den x : coprime `|numq x| `|denq x|. +Proof. by rewrite /numq /denq; case: x=> [[a b] /= /andP []]. Qed. + +Fact RatK x P : @Rat (numq x, denq x) P = x. +Proof. by move:x P => [[a b] P'] P; apply: val_inj. Qed. + +Fact fracq_subproof : forall x : int * int, + let n := + if x.2 == 0 then 0 else + (-1) ^ ((x.2 < 0) (+) (x.1 < 0)) * (`|x.1| %/ gcdn `|x.1| `|x.2|)%:Z in + let d := if x.2 == 0 then 1 else (`|x.2| %/ gcdn `|x.1| `|x.2|)%:Z in + (0 < d) && (coprime `|n| `|d|). +Proof. +move=> [m n] /=; case: (altP (n =P 0))=> [//|n0]. +rewrite ltz_nat divn_gt0 ?gcdn_gt0 ?absz_gt0 ?n0 ?orbT //. +rewrite dvdn_leq ?absz_gt0 ?dvdn_gcdr //= !abszM absz_sign mul1n. +have [->|m0] := altP (m =P 0); first by rewrite div0n gcd0n divnn absz_gt0 n0. +move: n0 m0; rewrite -!absz_gt0 absz_nat. +move: `|_|%N `|_|%N => {m n} [|m] [|n] // _ _. +rewrite /coprime -(@eqn_pmul2l (gcdn m.+1 n.+1)) ?gcdn_gt0 //. +rewrite muln_gcdr; do 2!rewrite muln_divCA ?(dvdn_gcdl, dvdn_gcdr) ?divnn //. +by rewrite ?gcdn_gt0 ?muln1. +Qed. + +Definition fracq (x : int * int) := nosimpl (@Rat (_, _) (fracq_subproof x)). + +Fact ratz_frac n : ratz n = fracq (n, 1). +Proof. by apply: val_inj; rewrite /= gcdn1 !divn1 abszE mulr_sign_norm. Qed. + +Fact valqK x : fracq (valq x) = x. +Proof. +move:x => [[n d] /= Pnd]; apply: val_inj=> /=. +move: Pnd; rewrite /coprime /fracq /=; case/andP=> hd; move/eqP=> hnd. +by rewrite ltr_gtF ?gtr_eqF //= hnd !divn1 mulz_sign_abs abszE gtr0_norm. +Qed. + +Fact scalq_key : unit. Proof. by []. Qed. +Definition scalq_def x := sgr x.2 * (gcdn `|x.1| `|x.2|)%:Z. +Definition scalq := locked_with scalq_key scalq_def. +Canonical scalq_unlockable := [unlockable fun scalq]. + +Fact scalq_eq0 x : (scalq x == 0) = (x.2 == 0). +Proof. +case: x => n d; rewrite unlock /= mulf_eq0 sgr_eq0 /= eqz_nat. +rewrite -[gcdn _ _ == 0%N]negbK -lt0n gcdn_gt0 ?absz_gt0 [X in ~~ X]orbC. +by case: sgrP. +Qed. + +Lemma sgr_scalq x : sgr (scalq x) = sgr x.2. +Proof. +rewrite unlock sgrM sgr_id -[(gcdn _ _)%:Z]intz sgr_nat. +by rewrite -lt0n gcdn_gt0 ?absz_gt0 orbC; case: sgrP; rewrite // mul0r. +Qed. + +Lemma signr_scalq x : (scalq x < 0) = (x.2 < 0). +Proof. by rewrite -!sgr_cp0 sgr_scalq. Qed. + +Lemma scalqE x : + x.2 != 0 -> scalq x = (-1) ^+ (x.2 < 0)%R * (gcdn `|x.1| `|x.2|)%:Z. +Proof. by rewrite unlock; case: sgrP. Qed. + +Fact valq_frac x : + x.2 != 0 -> x = (scalq x * numq (fracq x), scalq x * denq (fracq x)). +Proof. +case: x => [n d] /= d_neq0; rewrite /denq /numq scalqE //= (negPf d_neq0). +rewrite mulr_signM -mulrA -!PoszM addKb. +do 2!rewrite muln_divCA ?(dvdn_gcdl, dvdn_gcdr) // divnn. +by rewrite gcdn_gt0 !absz_gt0 d_neq0 orbT !muln1 !mulz_sign_abs. +Qed. + +Definition zeroq := fracq (0, 1). +Definition oneq := fracq (1, 1). + +Fact frac0q x : fracq (0, x) = zeroq. +Proof. +apply: val_inj; rewrite //= div0n !gcd0n !mulr0 !divnn. +by have [//|x_neq0] := altP eqP; rewrite absz_gt0 x_neq0. +Qed. + +Fact fracq0 x : fracq (x, 0) = zeroq. Proof. exact/eqP. Qed. + +CoInductive fracq_spec (x : int * int) : int * int -> rat -> Type := + | FracqSpecN of x.2 = 0 : fracq_spec x (x.1, 0) zeroq + | FracqSpecP k fx of k != 0 : fracq_spec x (k * numq fx, k * denq fx) fx. + +Fact fracqP x : fracq_spec x x (fracq x). +Proof. +case: x => n d /=; have [d_eq0 | d_neq0] := eqVneq d 0. + by rewrite d_eq0 fracq0; constructor. +by rewrite {2}[(_, _)]valq_frac //; constructor; rewrite scalq_eq0. +Qed. + +Lemma rat_eqE x y : (x == y) = (numq x == numq y) && (denq x == denq y). +Proof. +rewrite -val_eqE [val x]surjective_pairing [val y]surjective_pairing /=. +by rewrite xpair_eqE. +Qed. + +Lemma sgr_denq x : sgr (denq x) = 1. Proof. by apply/eqP; rewrite sgr_cp0. Qed. + +Lemma normr_denq x : `|denq x| = denq x. Proof. by rewrite gtr0_norm. Qed. + +Lemma absz_denq x : `|denq x|%N = denq x :> int. +Proof. by rewrite abszE normr_denq. Qed. + +Lemma rat_eq x y : (x == y) = (numq x * denq y == numq y * denq x). +Proof. +symmetry; rewrite rat_eqE andbC. +have [->|] /= := altP (denq _ =P _); first by rewrite (inj_eq (mulIf _)). +apply: contraNF => /eqP hxy; rewrite -absz_denq -[X in _ == X]absz_denq. +rewrite eqz_nat /= eqn_dvd. +rewrite -(@Gauss_dvdr _ `|numq x|) 1?coprime_sym ?coprime_num_den // andbC. +rewrite -(@Gauss_dvdr _ `|numq y|) 1?coprime_sym ?coprime_num_den //. +by rewrite -!abszM hxy -{1}hxy !abszM !dvdn_mull ?dvdnn. +Qed. + +Fact fracq_eq x y : x.2 != 0 -> y.2 != 0 -> + (fracq x == fracq y) = (x.1 * y.2 == y.1 * x.2). +Proof. +case: fracqP=> //= u fx u_neq0 _; case: fracqP=> //= v fy v_neq0 _; symmetry. +rewrite [X in (_ == X)]mulrC mulrACA [X in (_ == X)]mulrACA. +by rewrite [denq _ * _]mulrC (inj_eq (mulfI _)) ?mulf_neq0 // rat_eq. +Qed. + +Fact fracq_eq0 x : (fracq x == zeroq) = (x.1 == 0) || (x.2 == 0). +Proof. +move: x=> [n d] /=; have [->|d0] := altP (d =P 0). + by rewrite fracq0 eqxx orbT. +by rewrite orbF fracq_eq ?d0 //= mulr1 mul0r. +Qed. + +Fact fracqMM x n d : x != 0 -> fracq (x * n, x * d) = fracq (n, d). +Proof. +move=> x_neq0; apply/eqP. +have [->|d_neq0] := eqVneq d 0; first by rewrite mulr0 !fracq0. +by rewrite fracq_eq ?mulf_neq0 //= mulrCA mulrA. +Qed. + +Definition addq_subdef (x y : int * int) := (x.1 * y.2 + y.1 * x.2, x.2 * y.2). +Definition addq (x y : rat) := nosimpl fracq (addq_subdef (valq x) (valq y)). + +Definition oppq_subdef (x : int * int) := (- x.1, x.2). +Definition oppq (x : rat) := nosimpl fracq (oppq_subdef (valq x)). + +Fact addq_subdefC : commutative addq_subdef. +Proof. by move=> x y; rewrite /addq_subdef addrC [_.2 * _]mulrC. Qed. + +Fact addq_subdefA : associative addq_subdef. +Proof. +move=> x y z; rewrite /addq_subdef. +by rewrite !mulrA !mulrDl addrA ![_ * x.2]mulrC !mulrA. +Qed. + +Fact addq_frac x y : x.2 != 0 -> y.2 != 0 -> + (addq (fracq x) (fracq y)) = fracq (addq_subdef x y). +Proof. +case: fracqP => // u fx u_neq0 _; case: fracqP => // v fy v_neq0 _. +rewrite /addq_subdef /= ![(_ * numq _) * _]mulrACA [(_ * denq _) * _]mulrACA. +by rewrite [v * _]mulrC -mulrDr fracqMM ?mulf_neq0. +Qed. + +Fact ratzD : {morph ratz : x y / x + y >-> addq x y}. +Proof. +by move=> x y /=; rewrite !ratz_frac addq_frac // /addq_subdef /= !mulr1. +Qed. + +Fact oppq_frac x : oppq (fracq x) = fracq (oppq_subdef x). +Proof. +rewrite /oppq_subdef; case: fracqP => /= [|u fx u_neq0]. + by rewrite fracq0. +by rewrite -mulrN fracqMM. +Qed. + +Fact ratzN : {morph ratz : x / - x >-> oppq x}. +Proof. by move=> x /=; rewrite !ratz_frac oppq_frac // /add /= !mulr1. Qed. + +Fact addqC : commutative addq. +Proof. by move=> x y; rewrite /addq /=; rewrite addq_subdefC. Qed. + +Fact addqA : associative addq. +Proof. +move=> x y z; rewrite -[x]valqK -[y]valqK -[z]valqK. +by rewrite !addq_frac ?mulf_neq0 ?denq_neq0 // addq_subdefA. +Qed. + +Fact add0q : left_id zeroq addq. +Proof. +move=> x; rewrite -[x]valqK addq_frac ?denq_neq0 // /addq_subdef /=. +by rewrite mul0r add0r mulr1 mul1r -surjective_pairing. +Qed. + +Fact addNq : left_inverse (fracq (0, 1)) oppq addq. +Proof. +move=> x; rewrite -[x]valqK !(addq_frac, oppq_frac) ?denq_neq0 //. +rewrite /addq_subdef /oppq_subdef //= mulNr addNr; apply/eqP. +by rewrite fracq_eq ?mulf_neq0 ?denq_neq0 //= !mul0r. +Qed. + +Definition rat_ZmodMixin := ZmodMixin addqA addqC add0q addNq. +Canonical rat_ZmodType := ZmodType rat rat_ZmodMixin. + +Definition mulq_subdef (x y : int * int) := nosimpl (x.1 * y.1, x.2 * y.2). +Definition mulq (x y : rat) := nosimpl fracq (mulq_subdef (valq x) (valq y)). + +Fact mulq_subdefC : commutative mulq_subdef. +Proof. by move=> x y; rewrite /mulq_subdef mulrC [_ * x.2]mulrC. Qed. + +Fact mul_subdefA : associative mulq_subdef. +Proof. by move=> x y z; rewrite /mulq_subdef !mulrA. Qed. + +Definition invq_subdef (x : int * int) := nosimpl (x.2, x.1). +Definition invq (x : rat) := nosimpl fracq (invq_subdef (valq x)). + +Fact mulq_frac x y : (mulq (fracq x) (fracq y)) = fracq (mulq_subdef x y). +Proof. +rewrite /mulq_subdef; case: fracqP => /= [|u fx u_neq0]. + by rewrite mul0r fracq0 /mulq /mulq_subdef /= mul0r frac0q. +case: fracqP=> /= [|v fy v_neq0]. + by rewrite mulr0 fracq0 /mulq /mulq_subdef /= mulr0 frac0q. +by rewrite ![_ * (v * _)]mulrACA fracqMM ?mulf_neq0. +Qed. + +Fact ratzM : {morph ratz : x y / x * y >-> mulq x y}. +Proof. by move=> x y /=; rewrite !ratz_frac mulq_frac // /= !mulr1. Qed. + +Fact invq_frac x : + x.1 != 0 -> x.2 != 0 -> invq (fracq x) = fracq (invq_subdef x). +Proof. +by rewrite /invq_subdef; case: fracqP => // k {x} x k0; rewrite fracqMM. +Qed. + +Fact mulqC : commutative mulq. +Proof. by move=> x y; rewrite /mulq mulq_subdefC. Qed. + +Fact mulqA : associative mulq. +Proof. +by move=> x y z; rewrite -[x]valqK -[y]valqK -[z]valqK !mulq_frac mul_subdefA. +Qed. + +Fact mul1q : left_id oneq mulq. +Proof. +move=> x; rewrite -[x]valqK; rewrite mulq_frac /mulq_subdef. +by rewrite !mul1r -surjective_pairing. +Qed. + +Fact mulq_addl : left_distributive mulq addq. +Proof. +move=> x y z; rewrite -[x]valqK -[y]valqK -[z]valqK /=. +rewrite !(mulq_frac, addq_frac) ?mulf_neq0 ?denq_neq0 //=. +apply/eqP; rewrite fracq_eq ?mulf_neq0 ?denq_neq0 //= !mulrDl; apply/eqP. +by rewrite !mulrA ![_ * (valq z).1]mulrC !mulrA ![_ * (valq x).2]mulrC !mulrA. +Qed. + +Fact nonzero1q : oneq != zeroq. Proof. by []. Qed. + +Definition rat_comRingMixin := + ComRingMixin mulqA mulqC mul1q mulq_addl nonzero1q. +Canonical rat_Ring := Eval hnf in RingType rat rat_comRingMixin. +Canonical rat_comRing := Eval hnf in ComRingType rat mulqC. + +Fact mulVq x : x != 0 -> mulq (invq x) x = 1. +Proof. +rewrite -[x]valqK fracq_eq ?denq_neq0 //= mulr1 mul0r=> nx0. +rewrite !(mulq_frac, invq_frac) ?denq_neq0 //. +by apply/eqP; rewrite fracq_eq ?mulf_neq0 ?denq_neq0 //= mulr1 mul1r mulrC. +Qed. + +Fact invq0 : invq 0 = 0. Proof. by apply/eqP. Qed. + +Definition RatFieldUnitMixin := FieldUnitMixin mulVq invq0. +Canonical rat_unitRing := + Eval hnf in UnitRingType rat RatFieldUnitMixin. +Canonical rat_comUnitRing := Eval hnf in [comUnitRingType of rat]. + +Fact rat_field_axiom : GRing.Field.mixin_of rat_unitRing. Proof. exact. Qed. + +Definition RatFieldIdomainMixin := (FieldIdomainMixin rat_field_axiom). +Canonical rat_iDomain := + Eval hnf in IdomainType rat (FieldIdomainMixin rat_field_axiom). +Canonical rat_fieldType := FieldType rat rat_field_axiom. + +Lemma numq_eq0 x : (numq x == 0) = (x == 0). +Proof. +rewrite -[x]valqK fracq_eq0; case: fracqP=> /= [|k {x} x k0]. + by rewrite eqxx orbT. +by rewrite !mulf_eq0 (negPf k0) /= denq_eq0 orbF. +Qed. + +Notation "n %:Q" := ((n : int)%:~R : rat) + (at level 2, left associativity, format "n %:Q") : ring_scope. + +Hint Resolve denq_neq0 denq_gt0 denq_ge0. + +Definition subq (x y : rat) : rat := (addq x (oppq y)). +Definition divq (x y : rat) : rat := (mulq x (invq y)). + +Notation "0" := zeroq : rat_scope. +Notation "1" := oneq : rat_scope. +Infix "+" := addq : rat_scope. +Notation "- x" := (oppq x) : rat_scope. +Infix "*" := mulq : rat_scope. +Notation "x ^-1" := (invq x) : rat_scope. +Infix "-" := subq : rat_scope. +Infix "/" := divq : rat_scope. + +(* ratz should not be used, %:Q should be used instead *) +Lemma ratzE n : ratz n = n%:Q. +Proof. +elim: n=> [|n ihn|n ihn]; first by rewrite mulr0z ratz_frac. + by rewrite intS mulrzDl ratzD ihn. +by rewrite intS opprD mulrzDl ratzD ihn. +Qed. + +Lemma numq_int n : numq n%:Q = n. Proof. by rewrite -ratzE. Qed. +Lemma denq_int n : denq n%:Q = 1. Proof. by rewrite -ratzE. Qed. + +Lemma rat0 : 0%:Q = 0. Proof. by []. Qed. +Lemma rat1 : 1%:Q = 1. Proof. by []. Qed. + +Lemma numqN x : numq (- x) = - numq x. +Proof. +rewrite /numq; case: x=> [[a b] /= /andP [hb]]; rewrite /coprime=> /eqP hab. +by rewrite ltr_gtF ?gtr_eqF // {2}abszN hab divn1 mulz_sign_abs. +Qed. + +Lemma denqN x : denq (- x) = denq x. +Proof. +rewrite /denq; case: x=> [[a b] /= /andP [hb]]; rewrite /coprime=> /eqP hab. +by rewrite gtr_eqF // abszN hab divn1 gtz0_abs. +Qed. + +(* Will be subsumed by pnatr_eq0 *) +Fact intq_eq0 n : (n%:~R == 0 :> rat) = (n == 0)%N. +Proof. by rewrite -ratzE /ratz rat_eqE /numq /denq /= mulr0 eqxx andbT. Qed. + +(* fracq should never appear, its canonical form is _%:Q / _%:Q *) +Lemma fracqE x : fracq x = x.1%:Q / x.2%:Q. +Proof. +move:x => [m n] /=. +case n0: (n == 0); first by rewrite (eqP n0) fracq0 rat0 invr0 mulr0. +rewrite -[m%:Q]valqK -[n%:Q]valqK. +rewrite [_^-1]invq_frac ?(denq_neq0, numq_eq0, n0, intq_eq0) //. +rewrite [_ / _]mulq_frac /= /invq_subdef /mulq_subdef /=. +by rewrite -!/(numq _) -!/(denq _) !numq_int !denq_int mul1r mulr1. +Qed. + +Lemma divq_num_den x : (numq x)%:Q / (denq x)%:Q = x. +Proof. by rewrite -{3}[x]valqK [valq _]surjective_pairing /= fracqE. Qed. + +CoInductive divq_spec (n d : int) : int -> int -> rat -> Type := +| DivqSpecN of d = 0 : divq_spec n d n 0 0 +| DivqSpecP k x of k != 0 : divq_spec n d (k * numq x) (k * denq x) x. + +(* replaces fracqP *) +Lemma divqP n d : divq_spec n d n d (n%:Q / d%:Q). +Proof. +set x := (n, d); rewrite -[n]/x.1 -[d]/x.2 -fracqE. +by case: fracqP => [_|k fx k_neq0] /=; constructor. +Qed. + +Lemma divq_eq (nx dx ny dy : rat) : + dx != 0 -> dy != 0 -> (nx / dx == ny / dy) = (nx * dy == ny * dx). +Proof. +move=> dx_neq0 dy_neq0; rewrite -(inj_eq (@mulIf _ (dx * dy) _)) ?mulf_neq0 //. +by rewrite mulrA divfK // mulrCA divfK // [dx * _ ]mulrC. +Qed. + +CoInductive rat_spec (* (x : rat) *) : rat -> int -> int -> Type := + Rat_spec (n : int) (d : nat) & coprime `|n| d.+1 + : rat_spec (* x *) (n%:Q / d.+1%:Q) n d.+1. + +Lemma ratP x : rat_spec x (numq x) (denq x). +Proof. +rewrite -{1}[x](divq_num_den); case hd: denq => [p|n]. + have: 0 < p%:Z by rewrite -hd denq_gt0. + case: p hd=> //= n hd; constructor; rewrite -?hd ?divq_num_den //. + by rewrite -[n.+1]/`|n.+1|%N -hd coprime_num_den. +by move: (denq_gt0 x); rewrite hd. +Qed. + +Lemma coprimeq_num n d : coprime `|n| `|d| -> numq (n%:~R / d%:~R) = sgr d * n. +Proof. +move=> cnd /=; have <- := fracqE (n, d). +rewrite /numq /= (eqP (cnd : _ == 1%N)) divn1. +have [|d_gt0|d_lt0] := sgrP d; +by rewrite (mul0r, mul1r, mulN1r) //= ?[_ ^ _]signrN ?mulNr mulz_sign_abs. +Qed. + +Lemma coprimeq_den n d : + coprime `|n| `|d| -> denq (n%:~R / d%:~R) = (if d == 0 then 1 else `|d|). +Proof. +move=> cnd; have <- := fracqE (n, d). +by rewrite /denq /= (eqP (cnd : _ == 1%N)) divn1; case: d {cnd}. +Qed. + +Lemma denqVz (i : int) : i != 0 -> denq (i%:~R^-1) = `|i|. +Proof. +by move=> h; rewrite -div1r -[1]/(1%:~R) coprimeq_den /= ?coprime1n // (negPf h). +Qed. + +Lemma numqE x : (numq x)%:~R = x * (denq x)%:~R. +Proof. by rewrite -{2}[x]divq_num_den divfK // intq_eq0 denq_eq0. Qed. + +Lemma denqP x : {d | denq x = d.+1}. +Proof. by rewrite /denq; case: x => [[_ [[|d]|]] //= _]; exists d. Qed. + +Definition normq (x : rat) : rat := `|numq x|%:~R / (denq x)%:~R. +Definition le_rat (x y : rat) := numq x * denq y <= numq y * denq x. +Definition lt_rat (x y : rat) := numq x * denq y < numq y * denq x. + +Lemma gt_rat0 x : lt_rat 0 x = (0 < numq x). +Proof. by rewrite /lt_rat mul0r mulr1. Qed. + +Lemma lt_rat0 x : lt_rat x 0 = (numq x < 0). +Proof. by rewrite /lt_rat mul0r mulr1. Qed. + +Lemma ge_rat0 x : le_rat 0 x = (0 <= numq x). +Proof. by rewrite /le_rat mul0r mulr1. Qed. + +Lemma le_rat0 x : le_rat x 0 = (numq x <= 0). +Proof. by rewrite /le_rat mul0r mulr1. Qed. + +Fact le_rat0D x y : le_rat 0 x -> le_rat 0 y -> le_rat 0 (x + y). +Proof. +rewrite !ge_rat0 => hnx hny. +have hxy: (0 <= numq x * denq y + numq y * denq x). + by rewrite addr_ge0 ?mulr_ge0. +by rewrite /numq /= -!/(denq _) ?mulf_eq0 ?denq_eq0 !ler_gtF ?mulr_ge0. +Qed. + +Fact le_rat0M x y : le_rat 0 x -> le_rat 0 y -> le_rat 0 (x * y). +Proof. +rewrite !ge_rat0 => hnx hny. +have hxy: (0 <= numq x * denq y + numq y * denq x). + by rewrite addr_ge0 ?mulr_ge0. +by rewrite /numq /= -!/(denq _) ?mulf_eq0 ?denq_eq0 !ler_gtF ?mulr_ge0. +Qed. + +Fact le_rat0_anti x : le_rat 0 x -> le_rat x 0 -> x = 0. +Proof. +by move=> hx hy; apply/eqP; rewrite -numq_eq0 eqr_le -ge_rat0 -le_rat0 hx hy. +Qed. + +Lemma sgr_numq_div (n d : int) : sgr (numq (n%:Q / d%:Q)) = sgr n * sgr d. +Proof. +set x := (n, d); rewrite -[n]/x.1 -[d]/x.2 -fracqE. +case: fracqP => [|k fx k_neq0] /=; first by rewrite mulr0. +by rewrite !sgrM mulrACA -expr2 sqr_sg k_neq0 sgr_denq mulr1 mul1r. +Qed. + +Fact subq_ge0 x y : le_rat 0 (y - x) = le_rat x y. +Proof. +symmetry; rewrite ge_rat0 /le_rat -subr_ge0. +case: ratP => nx dx cndx; case: ratP => ny dy cndy. +rewrite -!mulNr addf_div ?intq_eq0 // !mulNr -!rmorphM -rmorphB /=. +symmetry; rewrite !lerNgt -sgr_cp0 sgr_numq_div mulrC gtr0_sg //. +by rewrite mul1r sgr_cp0. +Qed. + +Fact le_rat_total : total le_rat. +Proof. by move=> x y; apply: ler_total. Qed. + +Fact numq_sign_mul (b : bool) x : numq ((-1) ^+ b * x) = (-1) ^+ b * numq x. +Proof. by case: b; rewrite ?(mul1r, mulN1r) // numqN. Qed. + +Fact numq_div_lt0 n d : n != 0 -> d != 0 -> + (numq (n%:~R / d%:~R) < 0)%R = (n < 0)%R (+) (d < 0)%R. +Proof. +move=> n0 d0; rewrite -sgr_cp0 sgr_numq_div !sgr_def n0 d0. +by rewrite !mulr1n -signr_addb; case: (_ (+) _). +Qed. + +Lemma normr_num_div n d : `|numq (n%:~R / d%:~R)| = numq (`|n|%:~R / `|d|%:~R). +Proof. +rewrite (normrEsg n) (normrEsg d) !rmorphM /= invfM mulrACA !sgr_def. +have [->|n_neq0] := altP eqP; first by rewrite mul0r mulr0. +have [->|d_neq0] := altP eqP; first by rewrite invr0 !mulr0. +rewrite !intr_sign invr_sign -signr_addb numq_sign_mul -numq_div_lt0 //. +by apply: (canRL (signrMK _)); rewrite mulz_sign_abs. +Qed. + +Fact norm_ratN x : normq (- x) = normq x. +Proof. by rewrite /normq numqN denqN normrN. Qed. + +Fact ge_rat0_norm x : le_rat 0 x -> normq x = x. +Proof. +rewrite ge_rat0; case: ratP=> [] // n d cnd n_ge0. +by rewrite /normq /= normr_num_div ?ger0_norm // divq_num_den. +Qed. + +Fact lt_rat_def x y : (lt_rat x y) = (y != x) && (le_rat x y). +Proof. by rewrite /lt_rat ltr_def rat_eq. Qed. + +Definition ratLeMixin := RealLeMixin le_rat0D le_rat0M le_rat0_anti + subq_ge0 (@le_rat_total 0) norm_ratN ge_rat0_norm lt_rat_def. + +Canonical rat_numDomainType := NumDomainType rat ratLeMixin. +Canonical rat_numFieldType := [numFieldType of rat]. +Canonical rat_realDomainType := RealDomainType rat (@le_rat_total 0). +Canonical rat_realFieldType := [realFieldType of rat]. + +Lemma numq_ge0 x : (0 <= numq x) = (0 <= x). +Proof. +by case: ratP => n d cnd; rewrite ?pmulr_lge0 ?invr_gt0 (ler0z, ltr0z). +Qed. + +Lemma numq_le0 x : (numq x <= 0) = (x <= 0). +Proof. by rewrite -oppr_ge0 -numqN numq_ge0 oppr_ge0. Qed. + +Lemma numq_gt0 x : (0 < numq x) = (0 < x). +Proof. by rewrite !ltrNge numq_le0. Qed. + +Lemma numq_lt0 x : (numq x < 0) = (x < 0). +Proof. by rewrite !ltrNge numq_ge0. Qed. + +Lemma sgr_numq x : sgz (numq x) = sgz x. +Proof. +apply/eqP; case: (sgzP x); rewrite sgz_cp0 ?(numq_gt0, numq_lt0) //. +by move->. +Qed. + +Lemma denq_mulr_sign (b : bool) x : denq ((-1) ^+ b * x) = denq x. +Proof. by case: b; rewrite ?(mul1r, mulN1r) // denqN. Qed. + +Lemma denq_norm x : denq `|x| = denq x. +Proof. by rewrite normrEsign denq_mulr_sign. Qed. + +Fact rat_archimedean : Num.archimedean_axiom [numDomainType of rat]. +Proof. +move=> x; exists `|numq x|.+1; rewrite mulrS ltr_spaddl //. +rewrite pmulrn abszE intr_norm numqE normrM ler_pemulr ?norm_ge0 //. +by rewrite -intr_norm ler1n absz_gt0 denq_eq0. +Qed. + +Canonical archiType := ArchiFieldType rat rat_archimedean. + +Section QintPred. + +Definition Qint := [qualify a x : rat | denq x == 1]. +Fact Qint_key : pred_key Qint. Proof. by []. Qed. +Canonical Qint_keyed := KeyedQualifier Qint_key. + +Lemma Qint_def x : (x \is a Qint) = (denq x == 1). Proof. by []. Qed. + +Lemma numqK : {in Qint, cancel (fun x => numq x) intr}. +Proof. by move=> x /(_ =P 1 :> int) Zx; rewrite numqE Zx rmorph1 mulr1. Qed. + +Lemma QintP x : reflect (exists z, x = z%:~R) (x \in Qint). +Proof. +apply: (iffP idP) => [/numqK <- | [z ->]]; first by exists (numq x). +by rewrite Qint_def denq_int. +Qed. + +Fact Qint_subring_closed : subring_closed Qint. +Proof. +split=> // _ _ /QintP[x ->] /QintP[y ->]; apply/QintP. + by exists (x - y); rewrite -rmorphB. +by exists (x * y); rewrite -rmorphM. +Qed. + +Canonical Qint_opprPred := OpprPred Qint_subring_closed. +Canonical Qint_addrPred := AddrPred Qint_subring_closed. +Canonical Qint_mulrPred := MulrPred Qint_subring_closed. +Canonical Qint_zmodPred := ZmodPred Qint_subring_closed. +Canonical Qint_semiringPred := SemiringPred Qint_subring_closed. +Canonical Qint_smulrPred := SmulrPred Qint_subring_closed. +Canonical Qint_subringPred := SubringPred Qint_subring_closed. + +End QintPred. + +Section QnatPred. + +Definition Qnat := [qualify a x : rat | (x \is a Qint) && (0 <= x)]. +Fact Qnat_key : pred_key Qnat. Proof. by []. Qed. +Canonical Qnat_keyed := KeyedQualifier Qnat_key. + +Lemma Qnat_def x : (x \is a Qnat) = (x \is a Qint) && (0 <= x). +Proof. by []. Qed. + +Lemma QnatP x : reflect (exists n : nat, x = n%:R) (x \in Qnat). +Proof. +rewrite Qnat_def; apply: (iffP idP) => [/andP []|[n ->]]; last first. + by rewrite Qint_def pmulrn denq_int eqxx ler0z. +by move=> /QintP [] [] n ->; rewrite ?ler0z // => _; exists n. +Qed. + +Fact Qnat_semiring_closed : semiring_closed Qnat. +Proof. +do 2?split; move => // x y; rewrite !Qnat_def => /andP[xQ hx] /andP[yQ hy]. + by rewrite rpredD // addr_ge0. +by rewrite rpredM // mulr_ge0. +Qed. + +Canonical Qnat_addrPred := AddrPred Qnat_semiring_closed. +Canonical Qnat_mulrPred := MulrPred Qnat_semiring_closed. +Canonical Qnat_semiringPred := SemiringPred Qnat_semiring_closed. + +End QnatPred. + +Lemma natq_div m n : n %| m -> (m %/ n)%:R = m%:R / n%:R :> rat. +Proof. by apply: char0_natf_div; apply: char_num. Qed. + +Section InRing. + +Variable R : unitRingType. + +Definition ratr x : R := (numq x)%:~R / (denq x)%:~R. + +Lemma ratr_int z : ratr z%:~R = z%:~R. +Proof. by rewrite /ratr numq_int denq_int divr1. Qed. + +Lemma ratr_nat n : ratr n%:R = n%:R. +Proof. exact: (ratr_int n). Qed. + +Lemma rpred_rat S (ringS : @divringPred R S) (kS : keyed_pred ringS) a : + ratr a \in kS. +Proof. by rewrite rpred_div ?rpred_int. Qed. + +End InRing. + +Section Fmorph. + +Implicit Type rR : unitRingType. + +Lemma fmorph_rat (aR : fieldType) rR (f : {rmorphism aR -> rR}) a : + f (ratr _ a) = ratr _ a. +Proof. by rewrite fmorph_div !rmorph_int. Qed. + +Lemma fmorph_eq_rat rR (f : {rmorphism rat -> rR}) : f =1 ratr _. +Proof. by move=> a; rewrite -{1}[a]divq_num_den fmorph_div !rmorph_int. Qed. + +End Fmorph. + +Section Linear. + +Implicit Types (U V : lmodType rat) (A B : lalgType rat). + +Lemma rat_linear U V (f : U -> V) : additive f -> linear f. +Proof. +move=> fB a u v; pose phi := Additive fB; rewrite [f _](raddfD phi). +congr (_ + _); rewrite -{2}[a]divq_num_den mulrC -scalerA. +apply: canRL (scalerK _) _; first by rewrite intr_eq0 denq_neq0. +by rewrite !scaler_int -raddfMz scalerMzl -mulrzr -numqE scaler_int raddfMz. +Qed. + +Lemma rat_lrmorphism A B (f : A -> B) : rmorphism f -> lrmorphism f. +Proof. by case=> /rat_linear fZ fM; do ?split=> //; apply: fZ. Qed. + +End Linear. + +Section InPrealField. + +Variable F : numFieldType. + +Fact ratr_is_rmorphism : rmorphism (@ratr F). +Proof. +have injZtoQ: @injective rat int intr by exact: intr_inj. +have nz_den x: (denq x)%:~R != 0 :> F by rewrite intr_eq0 denq_eq0. +do 2?split; rewrite /ratr ?divr1 // => x y; last first. + rewrite mulrC mulrAC; apply: canLR (mulKf (nz_den _)) _; rewrite !mulrA. + do 2!apply: canRL (mulfK (nz_den _)) _; rewrite -!rmorphM; congr _%:~R. + apply: injZtoQ; rewrite !rmorphM [x * y]lock /= !numqE -lock. + by rewrite -!mulrA mulrA mulrCA -!mulrA (mulrCA y). +apply: (canLR (mulfK (nz_den _))); apply: (mulIf (nz_den x)). +rewrite mulrAC mulrBl divfK ?nz_den // mulrAC -!rmorphM. +apply: (mulIf (nz_den y)); rewrite mulrAC mulrBl divfK ?nz_den //. +rewrite -!(rmorphM, rmorphB); congr _%:~R; apply: injZtoQ. +rewrite !(rmorphM, rmorphB) [_ - _]lock /= -lock !numqE. +by rewrite (mulrAC y) -!mulrBl -mulrA mulrAC !mulrA. +Qed. + +Canonical ratr_additive := Additive ratr_is_rmorphism. +Canonical ratr_rmorphism := RMorphism ratr_is_rmorphism. + +Lemma ler_rat : {mono (@ratr F) : x y / x <= y}. +Proof. +move=> x y /=; case: (ratP x) => nx dx cndx; case: (ratP y) => ny dy cndy. +rewrite !fmorph_div /= !ratr_int !ler_pdivl_mulr ?ltr0z //. +by rewrite ![_ / _ * _]mulrAC !ler_pdivr_mulr ?ltr0z // -!rmorphM /= !ler_int. +Qed. + +Lemma ltr_rat : {mono (@ratr F) : x y / x < y}. +Proof. exact: lerW_mono ler_rat. Qed. + +Lemma ler0q x : (0 <= ratr F x) = (0 <= x). +Proof. by rewrite (_ : 0 = ratr F 0) ?ler_rat ?rmorph0. Qed. + +Lemma lerq0 x : (ratr F x <= 0) = (x <= 0). +Proof. by rewrite (_ : 0 = ratr F 0) ?ler_rat ?rmorph0. Qed. + +Lemma ltr0q x : (0 < ratr F x) = (0 < x). +Proof. by rewrite (_ : 0 = ratr F 0) ?ltr_rat ?rmorph0. Qed. + +Lemma ltrq0 x : (ratr F x < 0) = (x < 0). +Proof. by rewrite (_ : 0 = ratr F 0) ?ltr_rat ?rmorph0. Qed. + +Lemma ratr_sg x : ratr F (sgr x) = sgr (ratr F x). +Proof. by rewrite !sgr_def fmorph_eq0 ltrq0 rmorphMn rmorph_sign. Qed. + +Lemma ratr_norm x : ratr F `|x| = `|ratr F x|. +Proof. +rewrite {2}[x]numEsign rmorphMsign normrMsign [`|ratr F _|]ger0_norm //. +by rewrite ler0q ?normr_ge0. +Qed. + +End InPrealField. + +Implicit Arguments ratr [[R]]. + +(* Conntecting rationals to the ring an field tactics *) + +Ltac rat_to_ring := + rewrite -?[0%Q]/(0 : rat)%R -?[1%Q]/(1 : rat)%R + -?[(_ - _)%Q]/(_ - _ : rat)%R -?[(_ / _)%Q]/(_ / _ : rat)%R + -?[(_ + _)%Q]/(_ + _ : rat)%R -?[(_ * _)%Q]/(_ * _ : rat)%R + -?[(- _)%Q]/(- _ : rat)%R -?[(_ ^-1)%Q]/(_ ^-1 : rat)%R /=. + +Ltac ring_to_rat := + rewrite -?[0%R]/0%Q -?[1%R]/1%Q + -?[(_ - _)%R]/(_ - _)%Q -?[(_ / _)%R]/(_ / _)%Q + -?[(_ + _)%R]/(_ + _)%Q -?[(_ * _)%R]/(_ * _)%Q + -?[(- _)%R]/(- _)%Q -?[(_ ^-1)%R]/(_ ^-1)%Q /=. + +Lemma rat_ring_theory : (ring_theory 0%Q 1%Q addq mulq subq oppq eq). +Proof. +split => * //; rat_to_ring; +by rewrite ?(add0r, addrA, mul1r, mulrA, mulrDl, subrr) // (addrC, mulrC). +Qed. + +Require setoid_ring.Field_theory setoid_ring.Field_tac. + +Lemma rat_field_theory : + Field_theory.field_theory 0%Q 1%Q addq mulq subq oppq divq invq eq. +Proof. +split => //; first exact rat_ring_theory. +by move=> p /eqP p_neq0; rat_to_ring; rewrite mulVf. +Qed. + +Add Field rat_field : rat_field_theory. diff --git a/mathcomp/algebra/ring_quotient.v b/mathcomp/algebra/ring_quotient.v new file mode 100644 index 0000000..479508c --- /dev/null +++ b/mathcomp/algebra/ring_quotient.v @@ -0,0 +1,650 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import eqtype choice ssreflect ssrbool ssrnat ssrfun seq. +Require Import ssralg generic_quotient. + + +(******************************************************************************) +(* This file describes quotients of algebraic structures. *) +(* *) +(* It defines a join hierarchy mxing the structures defined in file ssralg *) +(* (up to unit ring type) and the quotType quotient structure defined in *) +(* file generic_quotient. Every structure in that (join) hierarchy is *) +(* parametrized by a base type T and the constants and operations on the *) +(* base type that will be used to confer its algebraic structure to the *) +(* quotient. Note that T itself is in general not an instance of an *) +(* algebraic structure. The canonical surjection from T onto its quotient *) +(* should be compatible with the parameter operations. *) +(* *) +(* The second part of the file provides a definition of (non trivial) *) +(* decidable ideals (resp. prime ideals) of an arbitrary instance of ring *) +(* structure and a construction of the quotient of a ring by such an ideal. *) +(* These definitions extend the hierarchy of sub-structures defined in file *) +(* ssralg (see Module Pred in ssralg), following a similar methodology. *) +(* Although the definition of the (structure of) quotient of a ring by an *) +(* ideal is a general one, we do not provide infrastructure for the case of *) +(* non commutative ring and left or two-sided ideals. *) +(* *) +(* The file defines the following Structures: *) +(* zmodQuotType T e z n a == Z-module obtained by quotienting type T *) +(* with the relation e and whose neutral, *) +(* opposite and addition are the images in the *) +(* quotient of the parameters z, n and a, *) +(* respectively. *) +(* ringQuotType T e z n a o m == ring obtained by quotienting type T with *) +(* the relation e and whose zero opposite, *) +(* addition, one, and multiplication are the *) +(* images in the quotient of the parameters *) +(* z, n, a, o, m, respectively. *) +(* unitRingQuotType ... u i == As in the previous cases, instance of unit *) +(* ring whose unit predicate is obtained from *) +(* u and the inverse from i. *) +(* idealr R S == (S : pred R) is a non-trivial, decidable, *) +(* right ideal of the ring R. *) +(* prime_idealr R S == (S : pred R) is a non-trivial, decidable, *) +(* right, prime ideal of the ring R. *) +(* *) +(* The formalization of ideals features the following constructions: *) +(* nontrivial_ideal S == the collective predicate (S : pred R) on the *) +(* ring R is stable by the ring product and does *) +(* contain R's one. *) +(* prime_idealr_closed S := u * v \in S -> (u \in S) || (v \in S) *) +(* idealr_closed S == the collective predicate (S : pred R) on the *) +(* ring R represents a (right) ideal. This *) +(* implies its being a nontrivial_ideal. *) +(* *) +(* MkIdeal idealS == packs idealS : nontrivial_ideal S into an *) +(* idealr S interface structure associating the *) +(* idealr_closed property to the canonical *) +(* pred_key S (see ssrbool), which must already *) +(* be an zmodPred (see ssralg). *) +(* MkPrimeIdeal pidealS == packs pidealS : prime_idealr_closed S into a *) +(* prime_idealr S interface structure associating *) +(* the prime_idealr_closed property to the *) +(* canonical pred_key S (see ssrbool), which must *) +(* already be an idealr (see above). *) +(* {ideal_quot kI} == quotient by the keyed (right) ideal predicate *) +(* kI of a commutative ring R. Note that we indeed*) +(* only provide canonical structures of ring *) +(* quotients for the case of commutative rings, *) +(* for which a right ideal is obviously a *) +(* two-sided ideal. *) +(* *) +(* Note : *) +(* if (I : pred R) is a predicate over a ring R and (ideal : idealr I) is an *) +(* instance of (right) ideal, in order to quantify over an arbitrary (keyed) *) +(* predicate describing ideal, use type (keyed_pred ideal), as in: *) +(* forall (kI : keyed_pred ideal),... *) +(******************************************************************************) + + +Import GRing.Theory. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope ring_scope. +Local Open Scope quotient_scope. + +Reserved Notation "{ideal_quot I }" (at level 0, format "{ideal_quot I }"). +Reserved Notation "m = n %[mod_ideal I ]" (at level 70, n at next level, + format "'[hv ' m '/' = n '/' %[mod_ideal I ] ']'"). +Reserved Notation "m == n %[mod_ideal I ]" (at level 70, n at next level, + format "'[hv ' m '/' == n '/' %[mod_ideal I ] ']'"). +Reserved Notation "m <> n %[mod_ideal I ]" (at level 70, n at next level, + format "'[hv ' m '/' <> n '/' %[mod_ideal I ] ']'"). +Reserved Notation "m != n %[mod_ideal I ]" (at level 70, n at next level, + format "'[hv ' m '/' != n '/' %[mod_ideal I ] ']'"). + + +Section ZmodQuot. + +Variable (T : Type). +Variable eqT : rel T. +Variables (zeroT : T) (oppT : T -> T) (addT : T -> T -> T). + +Record zmod_quot_mixin_of (Q : Type) (qc : quot_class_of T Q) + (zc : GRing.Zmodule.class_of Q) := ZmodQuotMixinPack { + zmod_eq_quot_mixin :> eq_quot_mixin_of eqT qc zc; + _ : \pi_(QuotTypePack qc Q) zeroT = 0 :> GRing.Zmodule.Pack zc Q; + _ : {morph \pi_(QuotTypePack qc Q) : x / + oppT x >-> @GRing.opp (GRing.Zmodule.Pack zc Q) x}; + _ : {morph \pi_(QuotTypePack qc Q) : x y / + addT x y >-> @GRing.add (GRing.Zmodule.Pack zc Q) x y} +}. + +Record zmod_quot_class_of (Q : Type) : Type := ZmodQuotClass { + zmod_quot_quot_class :> quot_class_of T Q; + zmod_quot_zmod_class :> GRing.Zmodule.class_of Q; + zmod_quot_mixin :> zmod_quot_mixin_of + zmod_quot_quot_class zmod_quot_zmod_class +}. + +Structure zmodQuotType : Type := ZmodQuotTypePack { + zmod_quot_sort :> Type; + _ : zmod_quot_class_of zmod_quot_sort; + _ : Type +}. + +Implicit Type zqT : zmodQuotType. + +Definition zmod_quot_class zqT : zmod_quot_class_of zqT := + let: ZmodQuotTypePack _ cT _ as qT' := zqT return zmod_quot_class_of qT' in cT. + +Definition zmod_eq_quot_class zqT (zqc : zmod_quot_class_of zqT) : + eq_quot_class_of eqT zqT := EqQuotClass zqc. + +Canonical zmodQuotType_eqType zqT := Equality.Pack (zmod_quot_class zqT) zqT. +Canonical zmodQuotType_choiceType zqT := + Choice.Pack (zmod_quot_class zqT) zqT. +Canonical zmodQuotType_zmodType zqT := + GRing.Zmodule.Pack (zmod_quot_class zqT) zqT. +Canonical zmodQuotType_quotType zqT := QuotTypePack (zmod_quot_class zqT) zqT. +Canonical zmodQuotType_eqQuotType zqT := EqQuotTypePack + (zmod_eq_quot_class (zmod_quot_class zqT)) zqT. + +Coercion zmodQuotType_eqType : zmodQuotType >-> eqType. +Coercion zmodQuotType_choiceType : zmodQuotType >-> choiceType. +Coercion zmodQuotType_zmodType : zmodQuotType >-> zmodType. +Coercion zmodQuotType_quotType : zmodQuotType >-> quotType. +Coercion zmodQuotType_eqQuotType : zmodQuotType >-> eqQuotType. + +Definition ZmodQuotType_pack Q := + fun (qT : quotType T) (zT : zmodType) qc zc + of phant_id (quot_class qT) qc & phant_id (GRing.Zmodule.class zT) zc => + fun m => ZmodQuotTypePack (@ZmodQuotClass Q qc zc m) Q. + +Definition ZmodQuotMixin_pack Q := + fun (qT : eqQuotType eqT) (qc : eq_quot_class_of eqT Q) + of phant_id (eq_quot_class qT) qc => + fun (zT : zmodType) zc of phant_id (GRing.Zmodule.class zT) zc => + fun e m0 mN mD => @ZmodQuotMixinPack Q qc zc e m0 mN mD. + +Definition ZmodQuotType_clone (Q : Type) qT cT + of phant_id (zmod_quot_class qT) cT := @ZmodQuotTypePack Q cT Q. + +Lemma zmod_quot_mixinP zqT : + zmod_quot_mixin_of (zmod_quot_class zqT) (zmod_quot_class zqT). +Proof. by case: zqT => [] ? [] ? ? []. Qed. + +Lemma pi_zeror zqT : \pi_zqT zeroT = 0. +Proof. by case: zqT => [] ? [] ? ? []. Qed. + +Lemma pi_oppr zqT : {morph \pi_zqT : x / oppT x >-> - x}. +Proof. by case: zqT => [] ? [] ? ? []. Qed. + +Lemma pi_addr zqT : {morph \pi_zqT : x y / addT x y >-> x + y}. +Proof. by case: zqT => [] ? [] ? ? []. Qed. + +Canonical pi_zero_quot_morph zqT := PiMorph (pi_zeror zqT). +Canonical pi_opp_quot_morph zqT := PiMorph1 (pi_oppr zqT). +Canonical pi_add_quot_morph zqT := PiMorph2 (pi_addr zqT). + +End ZmodQuot. + +Notation ZmodQuotType z o a Q m := + (@ZmodQuotType_pack _ _ z o a Q _ _ _ _ id id m). +Notation "[ 'zmodQuotType' z , o & a 'of' Q ]" := + (@ZmodQuotType_clone _ _ z o a Q _ _ id) + (at level 0, format "[ 'zmodQuotType' z , o & a 'of' Q ]") : form_scope. +Notation ZmodQuotMixin Q m0 mN mD := + (@ZmodQuotMixin_pack _ _ _ _ _ Q _ _ id _ _ id (pi_eq_quot _) m0 mN mD). + +Section PiAdditive. + +Variables (V : zmodType) (equivV : rel V) (zeroV : V). +Variable Q : @zmodQuotType V equivV zeroV -%R +%R. + +Lemma pi_is_additive : additive \pi_Q. +Proof. by move=> x y /=; rewrite !piE. Qed. + +Canonical pi_additive := Additive pi_is_additive. + +End PiAdditive. + +Section RingQuot. + +Variable (T : Type). +Variable eqT : rel T. +Variables (zeroT : T) (oppT : T -> T) (addT : T -> T -> T). +Variables (oneT : T) (mulT : T -> T -> T). + +Record ring_quot_mixin_of (Q : Type) (qc : quot_class_of T Q) + (rc : GRing.Ring.class_of Q) := RingQuotMixinPack { + ring_zmod_quot_mixin :> zmod_quot_mixin_of eqT zeroT oppT addT qc rc; + _ : \pi_(QuotTypePack qc Q) oneT = 1 :> GRing.Ring.Pack rc Q; + _ : {morph \pi_(QuotTypePack qc Q) : x y / + mulT x y >-> @GRing.mul (GRing.Ring.Pack rc Q) x y} +}. + +Record ring_quot_class_of (Q : Type) : Type := RingQuotClass { + ring_quot_quot_class :> quot_class_of T Q; + ring_quot_ring_class :> GRing.Ring.class_of Q; + ring_quot_mixin :> ring_quot_mixin_of + ring_quot_quot_class ring_quot_ring_class +}. + +Structure ringQuotType : Type := RingQuotTypePack { + ring_quot_sort :> Type; + _ : ring_quot_class_of ring_quot_sort; + _ : Type +}. + +Implicit Type rqT : ringQuotType. + +Definition ring_quot_class rqT : ring_quot_class_of rqT := + let: RingQuotTypePack _ cT _ as qT' := rqT return ring_quot_class_of qT' in cT. + +Definition ring_zmod_quot_class rqT (rqc : ring_quot_class_of rqT) : + zmod_quot_class_of eqT zeroT oppT addT rqT := ZmodQuotClass rqc. +Definition ring_eq_quot_class rqT (rqc : ring_quot_class_of rqT) : + eq_quot_class_of eqT rqT := EqQuotClass rqc. + +Canonical ringQuotType_eqType rqT := Equality.Pack (ring_quot_class rqT) rqT. +Canonical ringQuotType_choiceType rqT := Choice.Pack (ring_quot_class rqT) rqT. +Canonical ringQuotType_zmodType rqT := + GRing.Zmodule.Pack (ring_quot_class rqT) rqT. +Canonical ringQuotType_ringType rqT := + GRing.Ring.Pack (ring_quot_class rqT) rqT. +Canonical ringQuotType_quotType rqT := QuotTypePack (ring_quot_class rqT) rqT. +Canonical ringQuotType_eqQuotType rqT := + EqQuotTypePack (ring_eq_quot_class (ring_quot_class rqT)) rqT. +Canonical ringQuotType_zmodQuotType rqT := + ZmodQuotTypePack (ring_zmod_quot_class (ring_quot_class rqT)) rqT. + +Coercion ringQuotType_eqType : ringQuotType >-> eqType. +Coercion ringQuotType_choiceType : ringQuotType >-> choiceType. +Coercion ringQuotType_zmodType : ringQuotType >-> zmodType. +Coercion ringQuotType_ringType : ringQuotType >-> ringType. +Coercion ringQuotType_quotType : ringQuotType >-> quotType. +Coercion ringQuotType_eqQuotType : ringQuotType >-> eqQuotType. +Coercion ringQuotType_zmodQuotType : ringQuotType >-> zmodQuotType. + +Definition RingQuotType_pack Q := + fun (qT : quotType T) (zT : ringType) qc rc + of phant_id (quot_class qT) qc & phant_id (GRing.Ring.class zT) rc => + fun m => RingQuotTypePack (@RingQuotClass Q qc rc m) Q. + +Definition RingQuotMixin_pack Q := + fun (qT : zmodQuotType eqT zeroT oppT addT) => + fun (qc : zmod_quot_class_of eqT zeroT oppT addT Q) + of phant_id (zmod_quot_class qT) qc => + fun (rT : ringType) rc of phant_id (GRing.Ring.class rT) rc => + fun mZ m1 mM => @RingQuotMixinPack Q qc rc mZ m1 mM. + +Definition RingQuotType_clone (Q : Type) qT cT + of phant_id (ring_quot_class qT) cT := @RingQuotTypePack Q cT Q. + +Lemma ring_quot_mixinP rqT : + ring_quot_mixin_of (ring_quot_class rqT) (ring_quot_class rqT). +Proof. by case: rqT => [] ? [] ? ? []. Qed. + +Lemma pi_oner rqT : \pi_rqT oneT = 1. +Proof. by case: rqT => [] ? [] ? ? []. Qed. + +Lemma pi_mulr rqT : {morph \pi_rqT : x y / mulT x y >-> x * y}. +Proof. by case: rqT => [] ? [] ? ? []. Qed. + +Canonical pi_one_quot_morph rqT := PiMorph (pi_oner rqT). +Canonical pi_mul_quot_morph rqT := PiMorph2 (pi_mulr rqT). + +End RingQuot. + +Notation RingQuotType o mul Q mix := + (@RingQuotType_pack _ _ _ _ _ o mul Q _ _ _ _ id id mix). +Notation "[ 'ringQuotType' o & m 'of' Q ]" := + (@RingQuotType_clone _ _ _ _ _ o m Q _ _ id) + (at level 0, format "[ 'ringQuotType' o & m 'of' Q ]") : form_scope. +Notation RingQuotMixin Q m1 mM := + (@RingQuotMixin_pack _ _ _ _ _ _ _ Q _ _ id _ _ id (zmod_quot_mixinP _) m1 mM). + +Section PiRMorphism. + +Variables (R : ringType) (equivR : rel R) (zeroR : R). + +Variable Q : @ringQuotType R equivR zeroR -%R +%R 1 *%R. + +Lemma pi_is_multiplicative : multiplicative \pi_Q. +Proof. by split; do ?move=> x y /=; rewrite !piE. Qed. + +Canonical pi_rmorphism := AddRMorphism pi_is_multiplicative. + +End PiRMorphism. + +Section UnitRingQuot. + +Variable (T : Type). +Variable eqT : rel T. +Variables (zeroT : T) (oppT : T -> T) (addT : T -> T -> T). +Variables (oneT : T) (mulT : T -> T -> T). +Variables (unitT : pred T) (invT : T -> T). + +Record unit_ring_quot_mixin_of (Q : Type) (qc : quot_class_of T Q) + (rc : GRing.UnitRing.class_of Q) := UnitRingQuotMixinPack { + unit_ring_zmod_quot_mixin :> + ring_quot_mixin_of eqT zeroT oppT addT oneT mulT qc rc; + _ : {mono \pi_(QuotTypePack qc Q) : x / + unitT x >-> x \in @GRing.unit (GRing.UnitRing.Pack rc Q)}; + _ : {morph \pi_(QuotTypePack qc Q) : x / + invT x >-> @GRing.inv (GRing.UnitRing.Pack rc Q) x} +}. + +Record unit_ring_quot_class_of (Q : Type) : Type := UnitRingQuotClass { + unit_ring_quot_quot_class :> quot_class_of T Q; + unit_ring_quot_ring_class :> GRing.UnitRing.class_of Q; + unit_ring_quot_mixin :> unit_ring_quot_mixin_of + unit_ring_quot_quot_class unit_ring_quot_ring_class +}. + +Structure unitRingQuotType : Type := UnitRingQuotTypePack { + unit_ring_quot_sort :> Type; + _ : unit_ring_quot_class_of unit_ring_quot_sort; + _ : Type +}. + +Implicit Type rqT : unitRingQuotType. + +Definition unit_ring_quot_class rqT : unit_ring_quot_class_of rqT := + let: UnitRingQuotTypePack _ cT _ as qT' := rqT + return unit_ring_quot_class_of qT' in cT. + +Definition unit_ring_ring_quot_class rqT (rqc : unit_ring_quot_class_of rqT) : + ring_quot_class_of eqT zeroT oppT addT oneT mulT rqT := RingQuotClass rqc. +Definition unit_ring_zmod_quot_class rqT (rqc : unit_ring_quot_class_of rqT) : + zmod_quot_class_of eqT zeroT oppT addT rqT := ZmodQuotClass rqc. +Definition unit_ring_eq_quot_class rqT (rqc : unit_ring_quot_class_of rqT) : + eq_quot_class_of eqT rqT := EqQuotClass rqc. + +Canonical unitRingQuotType_eqType rqT := + Equality.Pack (unit_ring_quot_class rqT) rqT. +Canonical unitRingQuotType_choiceType rqT := + Choice.Pack (unit_ring_quot_class rqT) rqT. +Canonical unitRingQuotType_zmodType rqT := + GRing.Zmodule.Pack (unit_ring_quot_class rqT) rqT. +Canonical unitRingQuotType_ringType rqT := + GRing.Ring.Pack (unit_ring_quot_class rqT) rqT. +Canonical unitRingQuotType_unitRingType rqT := + GRing.UnitRing.Pack (unit_ring_quot_class rqT) rqT. +Canonical unitRingQuotType_quotType rqT := + QuotTypePack (unit_ring_quot_class rqT) rqT. +Canonical unitRingQuotType_eqQuotType rqT := + EqQuotTypePack (unit_ring_eq_quot_class (unit_ring_quot_class rqT)) rqT. +Canonical unitRingQuotType_zmodQuotType rqT := + ZmodQuotTypePack (unit_ring_zmod_quot_class (unit_ring_quot_class rqT)) rqT. +Canonical unitRingQuotType_ringQuotType rqT := + RingQuotTypePack (unit_ring_ring_quot_class (unit_ring_quot_class rqT)) rqT. + +Coercion unitRingQuotType_eqType : unitRingQuotType >-> eqType. +Coercion unitRingQuotType_choiceType : unitRingQuotType >-> choiceType. +Coercion unitRingQuotType_zmodType : unitRingQuotType >-> zmodType. +Coercion unitRingQuotType_ringType : unitRingQuotType >-> ringType. +Coercion unitRingQuotType_unitRingType : unitRingQuotType >-> unitRingType. +Coercion unitRingQuotType_quotType : unitRingQuotType >-> quotType. +Coercion unitRingQuotType_eqQuotType : unitRingQuotType >-> eqQuotType. +Coercion unitRingQuotType_zmodQuotType : unitRingQuotType >-> zmodQuotType. +Coercion unitRingQuotType_ringQuotType : unitRingQuotType >-> ringQuotType. + +Definition UnitRingQuotType_pack Q := + fun (qT : quotType T) (rT : unitRingType) qc rc + of phant_id (quot_class qT) qc & phant_id (GRing.UnitRing.class rT) rc => + fun m => UnitRingQuotTypePack (@UnitRingQuotClass Q qc rc m) Q. + +Definition UnitRingQuotMixin_pack Q := + fun (qT : ringQuotType eqT zeroT oppT addT oneT mulT) => + fun (qc : ring_quot_class_of eqT zeroT oppT addT oneT mulT Q) + of phant_id (zmod_quot_class qT) qc => + fun (rT : unitRingType) rc of phant_id (GRing.UnitRing.class rT) rc => + fun mR mU mV => @UnitRingQuotMixinPack Q qc rc mR mU mV. + +Definition UnitRingQuotType_clone (Q : Type) qT cT + of phant_id (unit_ring_quot_class qT) cT := @UnitRingQuotTypePack Q cT Q. + +Lemma unit_ring_quot_mixinP rqT : + unit_ring_quot_mixin_of (unit_ring_quot_class rqT) (unit_ring_quot_class rqT). +Proof. by case: rqT => [] ? [] ? ? []. Qed. + +Lemma pi_unitr rqT : {mono \pi_rqT : x / unitT x >-> x \in GRing.unit}. +Proof. by case: rqT => [] ? [] ? ? []. Qed. + +Lemma pi_invr rqT : {morph \pi_rqT : x / invT x >-> x^-1}. +Proof. by case: rqT => [] ? [] ? ? []. Qed. + +Canonical pi_unit_quot_morph rqT := PiMono1 (pi_unitr rqT). +Canonical pi_inv_quot_morph rqT := PiMorph1 (pi_invr rqT). + +End UnitRingQuot. + +Notation UnitRingQuotType u i Q mix := + (@UnitRingQuotType_pack _ _ _ _ _ _ _ u i Q _ _ _ _ id id mix). +Notation "[ 'unitRingQuotType' u & i 'of' Q ]" := + (@UnitRingQuotType_clone _ _ _ _ _ _ _ u i Q _ _ id) + (at level 0, format "[ 'unitRingQuotType' u & i 'of' Q ]") : form_scope. +Notation UnitRingQuotMixin Q mU mV := + (@UnitRingQuotMixin_pack _ _ _ _ _ _ _ _ _ Q + _ _ id _ _ id (zmod_quot_mixinP _) mU mV). + +Section IdealDef. + +Definition nontrivial_ideal (R : ringType) (S : predPredType R) : Prop := + 1 \notin S /\ forall a, {in S, forall u, a * u \in S}. + +Definition prime_idealr_closed (R : ringType) (S : predPredType R) : Prop := + forall u v, u * v \in S -> (u \in S) || (v \in S). + +Definition idealr_closed (R : ringType) (S : predPredType R) := + [/\ 0 \in S, 1 \notin S & forall a, {in S &, forall u v, a * u + v \in S}]. + +Lemma idealr_closed_nontrivial R S : @idealr_closed R S -> nontrivial_ideal S. +Proof. by case=> S0 S1 hS; split => // a x xS; rewrite -[_ * _]addr0 hS. Qed. + +Lemma idealr_closedB R S : @idealr_closed R S -> zmod_closed S. +Proof. by case=> S0 _ hS; split=> // x y xS yS; rewrite -mulN1r addrC hS. Qed. + +Coercion idealr_closedB : idealr_closed >-> zmod_closed. +Coercion idealr_closed_nontrivial : idealr_closed >-> nontrivial_ideal. + +Structure idealr (R : ringType) (S : predPredType R) := MkIdeal { + idealr_zmod :> zmodPred S; + _ : nontrivial_ideal S +}. + +Structure prime_idealr (R : ringType) (S : predPredType R) := MkPrimeIdeal { + prime_idealr_zmod :> idealr S; + _ : prime_idealr_closed S +}. + +Definition Idealr (R : ringType) (I : predPredType R) (zmodI : zmodPred I) + (kI : keyed_pred zmodI) : nontrivial_ideal I -> idealr I. +Proof. by move=> kI1; split => //. Qed. + +Section IdealTheory. +Variables (R : ringType) (I : predPredType R) + (idealrI : idealr I) (kI : keyed_pred idealrI). + +Lemma idealr1 : 1 \in kI = false. +Proof. by apply: negPf; case: idealrI kI => ? /= [? _] [] /= _ ->. Qed. + +Lemma idealMr a u : u \in kI -> a * u \in kI. +Proof. +by case: idealrI kI=> ? /= [? hI] [] /= ? hkI; rewrite !hkI; apply: hI. +Qed. + +Lemma idealr0 : 0 \in kI. Proof. exact: rpred0. Qed. + +End IdealTheory. + +Section PrimeIdealTheory. + +Variables (R : comRingType) (I : predPredType R) + (pidealrI : prime_idealr I) (kI : keyed_pred pidealrI). + +Lemma prime_idealrM u v : (u * v \in kI) = (u \in kI) || (v \in kI). +Proof. +apply/idP/idP; last by case/orP => /idealMr hI; rewrite // mulrC. +by case: pidealrI kI=> ? /= hI [] /= ? hkI; rewrite !hkI; apply: hI. +Qed. + +End PrimeIdealTheory. + +End IdealDef. + +Module Quotient. +Section ZmodQuotient. +Variables (R : zmodType) (I : predPredType R) + (zmodI : zmodPred I) (kI : keyed_pred zmodI). + +Definition equiv (x y : R) := (x - y) \in kI. + +Lemma equivE x y : (equiv x y) = (x - y \in kI). Proof. by []. Qed. + +Lemma equiv_is_equiv : equiv_class_of equiv. +Proof. +split=> [x|x y|y x z]; rewrite !equivE ?subrr ?rpred0 //. + by rewrite -opprB rpredN. +by move=> *; rewrite -[x](addrNK y) -addrA rpredD. +Qed. + +Canonical equiv_equiv := EquivRelPack equiv_is_equiv. +Canonical equiv_encModRel := defaultEncModRel equiv. + +Definition type := {eq_quot equiv}. +Definition type_of of phant R := type. + +Canonical rquot_quotType := [quotType of type]. +Canonical rquot_eqType := [eqType of type]. +Canonical rquot_choiceType := [choiceType of type]. +Canonical rquot_eqQuotType := [eqQuotType equiv of type]. + +Lemma idealrBE x y : (x - y) \in kI = (x == y %[mod type]). +Proof. by rewrite piE equivE. Qed. + +Lemma idealrDE x y : (x + y) \in kI = (x == - y %[mod type]). +Proof. by rewrite -idealrBE opprK. Qed. + +Definition zero : type := lift_cst type 0. +Definition add := lift_op2 type +%R. +Definition opp := lift_op1 type -%R. + +Canonical pi_zero_morph := PiConst zero. + +Lemma pi_opp : {morph \pi : x / - x >-> opp x}. +Proof. +move=> x; unlock opp; apply/eqP; rewrite piE equivE. +by rewrite -opprD rpredN idealrDE opprK reprK. +Qed. + +Canonical pi_opp_morph := PiMorph1 pi_opp. + +Lemma pi_add : {morph \pi : x y / x + y >-> add x y}. +Proof. +move=> x y /=; unlock add; apply/eqP; rewrite piE equivE. +rewrite opprD addrAC addrA -addrA. +by rewrite rpredD // (idealrBE, idealrDE) ?pi_opp ?reprK. +Qed. +Canonical pi_add_morph := PiMorph2 pi_add. + +Lemma addqA: associative add. +Proof. by move=> x y z; rewrite -[x]reprK -[y]reprK -[z]reprK !piE addrA. Qed. + +Lemma addqC: commutative add. +Proof. by move=> x y; rewrite -[x]reprK -[y]reprK !piE addrC. Qed. + +Lemma add0q: left_id zero add. +Proof. by move=> x; rewrite -[x]reprK !piE add0r. Qed. + +Lemma addNq: left_inverse zero opp add. +Proof. by move=> x; rewrite -[x]reprK !piE addNr. Qed. + +Definition rquot_zmodMixin := ZmodMixin addqA addqC add0q addNq. +Canonical rquot_zmodType := Eval hnf in ZmodType type rquot_zmodMixin. + +Definition rquot_zmodQuotMixin := ZmodQuotMixin type (lock _) pi_opp pi_add. +Canonical rquot_zmodQuotType := ZmodQuotType 0 -%R +%R type rquot_zmodQuotMixin. + +End ZmodQuotient. + +Notation "{quot I }" := (@type_of _ _ _ I (Phant _)). + +Section RingQuotient. + +Variables (R : comRingType) (I : predPredType R) + (idealI : idealr I) (kI : keyed_pred idealI). + +Local Notation type := {quot kI}. + +Definition one: type := lift_cst type 1. +Definition mul := lift_op2 type *%R. + +Canonical pi_one_morph := PiConst one. + +Lemma pi_mul: {morph \pi : x y / x * y >-> mul x y}. +Proof. +move=> x y; unlock mul; apply/eqP; rewrite piE equivE. +rewrite -[_ * _](addrNK (x * repr (\pi_type y))) -mulrBr. +rewrite -addrA -mulrBl rpredD //. + by rewrite idealMr // idealrDE opprK reprK. +by rewrite mulrC idealMr // idealrDE opprK reprK. +Qed. +Canonical pi_mul_morph := PiMorph2 pi_mul. + +Lemma mulqA: associative mul. +Proof. by move=> x y z; rewrite -[x]reprK -[y]reprK -[z]reprK !piE mulrA. Qed. + +Lemma mulqC: commutative mul. +Proof. by move=> x y; rewrite -[x]reprK -[y]reprK !piE mulrC. Qed. + +Lemma mul1q: left_id one mul. +Proof. by move=> x; rewrite -[x]reprK !piE mul1r. Qed. + +Lemma mulq_addl: left_distributive mul +%R. +Proof. +move=> x y z; rewrite -[x]reprK -[y]reprK -[z]reprK. +by apply/eqP; rewrite piE /= mulrDl equiv_refl. +Qed. + +Lemma nonzero1q: one != 0. +Proof. by rewrite piE equivE subr0 idealr1. Qed. + +Definition rquot_comRingMixin := + ComRingMixin mulqA mulqC mul1q mulq_addl nonzero1q. + +Canonical rquot_ringType := Eval hnf in RingType type rquot_comRingMixin. +Canonical rquot_comRingType := Eval hnf in ComRingType type mulqC. + +Definition rquot_ringQuotMixin := RingQuotMixin type (lock _) pi_mul. +Canonical rquot_ringQuotType := RingQuotType 1 *%R type rquot_ringQuotMixin. + +End RingQuotient. + +Section IDomainQuotient. + +Variables (R : comRingType) (I : predPredType R) + (pidealI : prime_idealr I) (kI : keyed_pred pidealI). + +Lemma rquot_IdomainAxiom (x y : {quot kI}): x * y = 0 -> (x == 0) || (y == 0). +Proof. +by move=> /eqP; rewrite -[x]reprK -[y]reprK !piE !equivE !subr0 prime_idealrM. +Qed. + +End IDomainQuotient. + +End Quotient. + +Notation "{ideal_quot I }" := (@Quotient.type_of _ _ _ I (Phant _)). +Notation "x == y %[mod_ideal I ]" := + (x == y %[mod {ideal_quot I}]) : quotient_scope. +Notation "x = y %[mod_ideal I ]" := + (x = y %[mod {ideal_quot I}]) : quotient_scope. +Notation "x != y %[mod_ideal I ]" := + (x != y %[mod {ideal_quot I}]) : quotient_scope. +Notation "x <> y %[mod_ideal I ]" := + (x <> y %[mod {ideal_quot I}]) : quotient_scope. + +Canonical Quotient.rquot_eqType. +Canonical Quotient.rquot_choiceType. +Canonical Quotient.rquot_zmodType. +Canonical Quotient.rquot_ringType. +Canonical Quotient.rquot_quotType. +Canonical Quotient.rquot_eqQuotType. +Canonical Quotient.rquot_zmodQuotType. +Canonical Quotient.rquot_ringQuotType. diff --git a/mathcomp/algebra/ssralg.v b/mathcomp/algebra/ssralg.v new file mode 100644 index 0000000..5f4592b --- /dev/null +++ b/mathcomp/algebra/ssralg.v @@ -0,0 +1,6230 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq choice fintype. +Require Import finfun bigop prime binomial. + +(******************************************************************************) +(* The algebraic part of the Algebraic Hierarchy, as described in *) +(* ``Packaging mathematical structures'', TPHOLs09, by *) +(* Francois Garillot, Georges Gonthier, Assia Mahboubi, Laurence Rideau *) +(* *) +(* This file defines for each Structure (Zmodule, Ring, etc ...) its type, *) +(* its packers and its canonical properties : *) +(* *) +(* * Zmodule (additive abelian groups): *) +(* zmodType == interface type for Zmodule structure. *) +(* ZmodMixin addA addC add0x addNx == builds the mixin for a Zmodule from the *) +(* algebraic properties of its operations. *) +(* ZmodType V m == packs the mixin m to build a Zmodule of type *) +(* zmodType. The carrier type V must have a *) +(* choiceType canonical structure. *) +(* [zmodType of V for S] == V-clone of the zmodType structure S: a copy of S *) +(* where the sort carrier has been replaced by V, *) +(* and which is therefore a zmodType structure on V. *) +(* The sort carrier for S must be convertible to V. *) +(* [zmodType of V] == clone of a canonical zmodType structure on V. *) +(* Similar to the above, except S is inferred, but *) +(* possibly with a syntactically different carrier. *) +(* 0 == the zero (additive identity) of a Zmodule. *) +(* x + y == the sum of x and y (in a Zmodule). *) +(* - x == the opposite (additive inverse) of x. *) +(* x - y == the difference of x and y; this is only notation *) +(* for x + (- y). *) +(* x *+ n == n times x, with n in nat (non-negative), i.e., *) +(* x + (x + .. (x + x)..) (n terms); x *+ 1 is thus *) +(* convertible to x, and x *+ 2 to x + x. *) +(* x *- n == notation for - (x *+ n), the opposite of x *+ n. *) +(* \sum_ e == iterated sum for a Zmodule (cf bigop.v). *) +(* e`_i == nth 0 e i, when e : seq M and M has a zmodType *) +(* structure. *) +(* support f == 0.-support f, i.e., [pred x | f x != 0]. *) +(* oppr_closed S <-> collective predicate S is closed under opposite. *) +(* addr_closed S <-> collective predicate S is closed under finite *) +(* sums (0 and x + y in S, for x, y in S). *) +(* zmod_closed S <-> collective predicate S is closed under zmodType *) +(* operations (0 and x - y in S, for x, y in S). *) +(* This property coerces to oppr_pred and addr_pred. *) +(* OpprPred oppS == packs oppS : oppr_closed S into an opprPred S *) +(* interface structure associating this property to *) +(* the canonical pred_key S, i.e. the k for which S *) +(* has a Canonical keyed_pred k structure (see file *) +(* ssrbool.v). *) +(* AddrPred addS == packs addS : addr_closed S into an addrPred S *) +(* interface structure associating this property to *) +(* the canonical pred_key S (see above). *) +(* ZmodPred oppS == packs oppS : oppr_closed S into an zmodPred S *) +(* interface structure associating the zmod_closed *) +(* property to the canonical pred_key S (see above), *) +(* which must already be an addrPred. *) +(* [zmodMixin of M by <:] == zmodType mixin for a subType whose base type is *) +(* a zmodType and whose predicate's canonical *) +(* pred_key is a zmodPred. *) +(* --> Coq can be made to behave as if all predicates had canonical zmodPred *) +(* keys by executing Import DefaultKeying GRing.DefaultPred. The required *) +(* oppr_closed and addr_closed assumptions will be either abstracted, *) +(* resolved or issued as separate proof obligations by the ssreflect *) +(* plugin abstraction and Prop-irrelevance functions. *) +(* * Ring (non-commutative rings): *) +(* ringType == interface type for a Ring structure. *) +(* RingMixin mulA mul1x mulx1 mulDx mulxD == builds the mixin for a Ring from *) +(* the algebraic properties of its multiplicative *) +(* operators; the carrier type must have a zmodType *) +(* structure. *) +(* RingType R m == packs the ring mixin m into a ringType. *) +(* R^c == the converse Ring for R: R^c is convertible to R *) +(* but when R has a canonical ringType structure *) +(* R^c has the converse one: if x y : R^c, then *) +(* x * y = (y : R) * (x : R). *) +(* [ringType of R for S] == R-clone of the ringType structure S. *) +(* [ringType of R] == clone of a canonical ringType structure on R. *) +(* 1 == the multiplicative identity element of a Ring. *) +(* n%:R == the ring image of an n in nat; this is just *) +(* notation for 1 *+ n, so 1%:R is convertible to 1 *) +(* and 2%:R to 1 + 1. *) +(* x * y == the ring product of x and y. *) +(* \prod_ e == iterated product for a ring (cf bigop.v). *) +(* x ^+ n == x to the nth power with n in nat (non-negative), *) +(* i.e., x * (x * .. (x * x)..) (n factors); x ^+ 1 *) +(* is thus convertible to x, and x ^+ 2 to x * x. *) +(* GRing.sign R b := (-1) ^+ b in R : ringType, with b : bool. *) +(* This is a parsing-only helper notation, to be *) +(* used for defining more specific instances. *) +(* GRing.comm x y <-> x and y commute, i.e., x * y = y * x. *) +(* GRing.lreg x <-> x if left-regular, i.e., *%R x is injective. *) +(* GRing.rreg x <-> x if right-regular, i.e., *%R x is injective. *) +(* [char R] == the characteristic of R, defined as the set of *) +(* prime numbers p such that p%:R = 0 in R. The set *) +(* [char p] has a most one element, and is *) +(* implemented as a pred_nat collective predicate *) +(* (see prime.v); thus the statement p \in [char R] *) +(* can be read as `R has characteristic p', while *) +(* [char R] =i pred0 means `R has characteristic 0' *) +(* when R is a field. *) +(* Frobenius_aut chRp == the Frobenius automorphism mapping x in R to *) +(* x ^+ p, where chRp : p \in [char R] is a proof *) +(* that R has (non-zero) characteristic p. *) +(* mulr_closed S <-> collective predicate S is closed under finite *) +(* products (1 and x * y in S for x, y in S). *) +(* smulr_closed S <-> collective predicate S is closed under products *) +(* and opposite (-1 and x * y in S for x, y in S). *) +(* semiring_closed S <-> collective predicate S is closed under semiring *) +(* operations (0, 1, x + y and x * y in S). *) +(* subring_closed S <-> collective predicate S is closed under ring *) +(* operations (1, x - y and x * y in S). *) +(* MulrPred mulS == packs mulS : mulr_closed S into a mulrPred S, *) +(* SmulrPred mulS smulrPred S, semiringPred S, or subringPred S *) +(* SemiringPred mulS interface structure, corresponding to the above *) +(* SubRingPred mulS properties, respectively, provided S already has *) +(* the supplementary zmodType closure properties. *) +(* The properties above coerce to subproperties so, *) +(* e.g., ringS : subring_closed S can be used for *) +(* the proof obligations of all prerequisites. *) +(* [ringMixin of R by <:] == ringType mixin for a subType whose base type is *) +(* a ringType and whose predicate's canonical key *) +(* is a SubringPred. *) +(* --> As for zmodType predicates, Import DefaultKeying GRing.DefaultPred *) +(* turns unresolved GRing.Pred unification constraints into proof *) +(* obligations for basic closure assumptions. *) +(* *) +(* * ComRing (commutative Rings): *) +(* comRingType == interface type for commutative ring structure. *) +(* ComRingType R mulC == packs mulC into a comRingType; the carrier type *) +(* R must have a ringType canonical structure. *) +(* ComRingMixin mulA mulC mul1x mulDx == builds the mixin for a Ring (i.e., a *) +(* *non commutative* ring), using the commutativity *) +(* to reduce the number of proof obligations. *) +(* [comRingType of R for S] == R-clone of the comRingType structure S. *) +(* [comRingType of R] == clone of a canonical comRingType structure on R. *) +(* [comRingMixin of R by <:] == comutativity mixin axiom for R when it is a *) +(* subType of a commutative ring. *) +(* *) +(* * UnitRing (Rings whose units have computable inverses): *) +(* unitRingType == interface type for the UnitRing structure. *) +(* UnitRingMixin mulVr mulrV unitP inv0id == builds the mixin for a UnitRing *) +(* from the properties of the inverse operation and *) +(* the boolean test for being a unit (invertible). *) +(* The inverse of a non-unit x is constrained to be *) +(* x itself (property inv0id). The carrier type *) +(* must have a ringType canonical structure. *) +(* UnitRingType R m == packs the unit ring mixin m into a unitRingType. *) +(* WARNING: while it is possible to omit R for most of the *) +(* XxxType functions, R MUST be explicitly given *) +(* when UnitRingType is used with a mixin produced *) +(* by ComUnitRingMixin, otherwise the resulting *) +(* structure will have the WRONG sort key and will *) +(* NOT BE USED during type inference. *) +(* [unitRingType of R for S] == R-clone of the unitRingType structure S. *) +(* [unitRingType of R] == clones a canonical unitRingType structure on R. *) +(* x \is a GRing.unit <=> x is a unit (i.e., has an inverse). *) +(* x^-1 == the ring inverse of x, if x is a unit, else x. *) +(* x / y == x divided by y (notation for x * y^-1). *) +(* x ^- n := notation for (x ^+ n)^-1, the inverse of x ^+ n. *) +(* invr_closed S <-> collective predicate S is closed under inverse. *) +(* divr_closed S <-> collective predicate S is closed under division *) +(* (1 and x / y in S). *) +(* sdivr_closed S <-> collective predicate S is closed under division *) +(* and opposite (-1 and x / y in S, for x, y in S). *) +(* divring_closed S <-> collective predicate S is closed under unitRing *) +(* operations (1, x - y and x / y in S). *) +(* DivrPred invS == packs invS : mulr_closed S into a divrPred S, *) +(* SdivrPred invS sdivrPred S or divringPred S interface structure, *) +(* DivringPred invS corresponding to the above properties, resp., *) +(* provided S already has the supplementary ringType *) +(* closure properties. The properties above coerce *) +(* to subproperties, as explained above. *) +(* [unitRingMixin of R by <:] == unitRingType mixin for a subType whose base *) +(* type is a unitRingType and whose predicate's *) +(* canonical key is a divringPred and whose ring *) +(* structure is compatible with the base type's. *) +(* *) +(* * ComUnitRing (commutative rings with computable inverses): *) +(* comUnitRingType == interface type for ComUnitRing structure. *) +(* ComUnitRingMixin mulVr unitP inv0id == builds the mixin for a UnitRing (a *) +(* *non commutative* unit ring, using commutativity *) +(* to simplify the proof obligations; the carrier *) +(* type must have a comRingType structure. *) +(* WARNING: ALWAYS give an explicit type argument *) +(* to UnitRingType along with a mixin produced by *) +(* ComUnitRingMixin (see above). *) +(* [comUnitRingType of R] == a comUnitRingType structure for R created by *) +(* merging canonical comRingType and unitRingType *) +(* structures on R. *) +(* *) +(* * IntegralDomain (integral, commutative, ring with partial inverses): *) +(* idomainType == interface type for the IntegralDomain structure. *) +(* IdomainType R mulf_eq0 == packs the integrality property into an *) +(* idomainType integral domain structure; R must *) +(* have a comUnitRingType canonical structure. *) +(* [idomainType of R for S] == R-clone of the idomainType structure S. *) +(* [idomainType of R] == clone of a canonical idomainType structure on R. *) +(* [idomainMixin of R by <:] == mixin axiom for a idomain subType. *) +(* *) +(* * Field (commutative fields): *) +(* fieldType == interface type for fields. *) +(* GRing.Field.axiom inv == the field axiom (x != 0 -> inv x * x = 1). *) +(* FieldUnitMixin mulVx unitP inv0id == builds a *non commutative unit ring* *) +(* mixin, using the field axiom to simplify proof *) +(* obligations. The carrier type must have a *) +(* comRingType canonical structure. *) +(* FieldMixin mulVx == builds the field mixin from the field axiom. The *) +(* carrier type must have a comRingType structure. *) +(* FieldIdomainMixin m == builds an *idomain* mixin from a field mixin m. *) +(* FieldType R m == packs the field mixin M into a fieldType. The *) +(* carrier type R must be an idomainType. *) +(* [fieldType of F for S] == F-clone of the fieldType structure S. *) +(* [fieldType of F] == clone of a canonical fieldType structure on F. *) +(* [fieldMixin of R by <:] == mixin axiom for a field subType. *) +(* *) +(* * DecidableField (fields with a decidable first order theory): *) +(* decFieldType == interface type for DecidableField structure. *) +(* DecFieldMixin satP == builds the mixin for a DecidableField from the *) +(* correctness of its satisfiability predicate. The *) +(* carrier type must have a unitRingType structure. *) +(* DecFieldType F m == packs the decidable field mixin m into a *) +(* decFieldType; the carrier type F must have a *) +(* fieldType structure. *) +(* [decFieldType of F for S] == F-clone of the decFieldType structure S. *) +(* [decFieldType of F] == clone of a canonical decFieldType structure on F *) +(* GRing.term R == the type of formal expressions in a unit ring R *) +(* with formal variables 'X_k, k : nat, and *) +(* manifest constants x%:T, x : R. The notation of *) +(* all the ring operations is redefined for terms, *) +(* in scope %T. *) +(* GRing.formula R == the type of first order formulas over R; the %T *) +(* scope binds the logical connectives /\, \/, ~, *) +(* ==>, ==, and != to formulae; GRing.True/False *) +(* and GRing.Bool b denote constant formulae, and *) +(* quantifiers are written 'forall/'exists 'X_k, f. *) +(* GRing.Unit x tests for ring units *) +(* GRing.If p_f t_f e_f emulates if-then-else *) +(* GRing.Pick p_f t_f e_f emulates fintype.pick *) +(* foldr GRing.Exists/Forall q_f xs can be used *) +(* to write iterated quantifiers. *) +(* GRing.eval e t == the value of term t with valuation e : seq R *) +(* (e maps 'X_i to e`_i). *) +(* GRing.same_env e1 e2 <-> environments e1 and e2 are extensionally equal. *) +(* GRing.qf_form f == f is quantifier-free. *) +(* GRing.holds e f == the intuitionistic CiC interpretation of the *) +(* formula f holds with valuation e. *) +(* GRing.qf_eval e f == the value (in bool) of a quantifier-free f. *) +(* GRing.sat e f == valuation e satisfies f (only in a decField). *) +(* GRing.sol n f == a sequence e of size n such that e satisfies f, *) +(* if one exists, or [::] if there is no such e. *) +(* QEdecFieldMixin wfP okP == a decidable field Mixin built from a quantifier *) +(* eliminator p and proofs wfP : GRing.wf_QE_proj p *) +(* and okP : GRing.valid_QE_proj p that p returns *) +(* well-formed and valid formulae, i.e., p i (u, v) *) +(* is a quantifier-free formula equivalent to *) +(* 'exists 'X_i, u1 == 0 /\ ... /\ u_m == 0 /\ v1 != 0 ... /\ v_n != 0 *) +(* *) +(* * ClosedField (algebraically closed fields): *) +(* closedFieldType == interface type for the ClosedField structure. *) +(* ClosedFieldType F m == packs the closed field mixin m into a *) +(* closedFieldType. The carrier F must have a *) +(* decFieldType structure. *) +(* [closedFieldType of F on S] == F-clone of a closedFieldType structure S. *) +(* [closedFieldType of F] == clone of a canonicalclosedFieldType structure *) +(* on F. *) +(* *) +(* * Lmodule (module with left multiplication by external scalars). *) +(* lmodType R == interface type for an Lmodule structure with *) +(* scalars of type R; R must have a ringType *) +(* structure. *) +(* LmodMixin scalA scal1v scalxD scalDv == builds an Lmodule mixin from the *) +(* algebraic properties of the scaling operation; *) +(* the module carrier type must have a zmodType *) +(* structure, and the scalar carrier must have a *) +(* ringType structure. *) +(* LmodType R V m == packs the mixin v to build an Lmodule of type *) +(* lmodType R. The carrier type V must have a *) +(* zmodType structure. *) +(* [lmodType R of V for S] == V-clone of an lmodType R structure S. *) +(* [lmodType R of V] == clone of a canonical lmodType R structure on V. *) +(* a *: v == v scaled by a, when v is in an Lmodule V and a *) +(* is in the scalar Ring of V. *) +(* scaler_closed S <-> collective predicate S is closed under scaling. *) +(* linear_closed S <-> collective predicate S is closed under linear *) +(* combinations (a *: u + v in S when u, v in S). *) +(* submod_closed S <-> collective predicate S is closed under lmodType *) +(* operations (0 and a *: u + v in S). *) +(* SubmodPred scaleS == packs scaleS : scaler_closed S in a submodPred S *) +(* interface structure corresponding to the above *) +(* property, provided S's key is a zmodPred; *) +(* submod_closed coerces to all the prerequisites. *) +(* [lmodMixin of V by <:] == mixin for a subType of an lmodType, whose *) +(* predicate's key is a submodPred. *) +(* *) +(* * Lalgebra (left algebra, ring with scaling that associates on the left): *) +(* lalgType R == interface type for Lalgebra structures with *) +(* scalars in R; R must have ringType structure. *) +(* LalgType R V scalAl == packs scalAl : k (x y) = (k x) y into an *) +(* Lalgebra of type lalgType R. The carrier type V *) +(* must have both lmodType R and ringType canonical *) +(* structures. *) +(* R^o == the regular algebra of R: R^o is convertible to *) +(* R, but when R has a ringType structure then R^o *) +(* extends it to an lalgType structure by letting R *) +(* act on itself: if x : R and y : R^o then *) +(* x *: y = x * (y : R). *) +(* k%:A == the image of the scalar k in an L-algebra; this *) +(* is simply notation for k *: 1. *) +(* [lalgType R of V for S] == V-clone the lalgType R structure S. *) +(* [lalgType R of V] == clone of a canonical lalgType R structure on V. *) +(* subalg_closed S <-> collective predicate S is closed under lalgType *) +(* operations (1, a *: u + v and u * v in S). *) +(* SubalgPred scaleS == packs scaleS : scaler_closed S in a subalgPred S *) +(* interface structure corresponding to the above *) +(* property, provided S's key is a subringPred; *) +(* subalg_closed coerces to all the prerequisites. *) +(* [lalgMixin of V by <:] == mixin axiom for a subType of an lalgType. *) +(* *) +(* * Algebra (ring with scaling that associates both left and right): *) +(* algType R == type for Algebra structure with scalars in R. *) +(* R should be a commutative ring. *) +(* AlgType R A scalAr == packs scalAr : k (x y) = x (k y) into an Algebra *) +(* Structure of type algType R. The carrier type A *) +(* must have an lalgType R structure. *) +(* CommAlgType R A == creates an Algebra structure for an A that has *) +(* both lalgType R and comRingType structures. *) +(* [algType R of V for S] == V-clone of an algType R structure on S. *) +(* [algType R of V] == clone of a canonical algType R structure on V. *) +(* [algMixin of V by <:] == mixin axiom for a subType of an algType. *) +(* *) +(* * UnitAlgebra (algebra with computable inverses): *) +(* unitAlgType R == interface type for UnitAlgebra structure with *) +(* scalars in R; R should have a unitRingType *) +(* structure. *) +(* [unitAlgType R of V] == a unitAlgType R structure for V created by *) +(* merging canonical algType and unitRingType on V. *) +(* divalg_closed S <-> collective predicate S is closed under all *) +(* unitAlgType operations (1, a *: u + v and u / v *) +(* are in S fo u, v in S). *) +(* DivalgPred scaleS == packs scaleS : scaler_closed S in a divalgPred S *) +(* interface structure corresponding to the above *) +(* property, provided S's key is a divringPred; *) +(* divalg_closed coerces to all the prerequisites. *) +(* *) +(* In addition to this structure hierarchy, we also develop a separate, *) +(* parallel hierarchy for morphisms linking these structures: *) +(* *) +(* * Additive (additive functions): *) +(* additive f <-> f of type U -> V is additive, i.e., f maps the *) +(* Zmodule structure of U to that of V, 0 to 0, *) +(* - to - and + to + (equivalently, binary - to -). *) +(* := {morph f : u v / u + v}. *) +(* {additive U -> V} == the interface type for a Structure (keyed on *) +(* a function f : U -> V) that encapsulates the *) +(* additive property; both U and V must have *) +(* zmodType canonical structures. *) +(* Additive add_f == packs add_f : additive f into an additive *) +(* function structure of type {additive U -> V}. *) +(* [additive of f as g] == an f-clone of the additive structure on the *) +(* function g -- f and g must be convertible. *) +(* [additive of f] == a clone of an existing additive structure on f. *) +(* *) +(* * RMorphism (ring morphisms): *) +(* multiplicative f <-> f of type R -> S is multiplicative, i.e., f *) +(* maps 1 and * in R to 1 and * in S, respectively, *) +(* R ans S must have canonical ringType structures. *) +(* rmorphism f <-> f is a ring morphism, i.e., f is both additive *) +(* and multiplicative. *) +(* {rmorphism R -> S} == the interface type for ring morphisms, i.e., *) +(* a Structure that encapsulates the rmorphism *) +(* property for functions f : R -> S; both R and S *) +(* must have ringType structures. *) +(* RMorphism morph_f == packs morph_f : rmorphism f into a Ring morphism *) +(* structure of type {rmorphism R -> S}. *) +(* AddRMorphism mul_f == packs mul_f : multiplicative f into an rmorphism *) +(* structure of type {rmorphism R -> S}; f must *) +(* already have an {additive R -> S} structure. *) +(* [rmorphism of f as g] == an f-clone of the rmorphism structure of g. *) +(* [rmorphism of f] == a clone of an existing additive structure on f. *) +(* -> If R and S are UnitRings the f also maps units to units and inverses *) +(* of units to inverses; if R is a field then f if a field isomorphism *) +(* between R and its image. *) +(* -> As rmorphism coerces to both additive and multiplicative, all *) +(* structures for f can be built from a single proof of rmorphism f. *) +(* -> Additive properties (raddf_suffix, see below) are duplicated and *) +(* specialised for RMorphism (as rmorph_suffix). This allows more *) +(* precise rewriting and cleaner chaining: although raddf lemmas will *) +(* recognize RMorphism functions, the converse will not hold (we cannot *) +(* add reverse inheritance rules because of incomplete backtracking in *) +(* the Canonical Projection unification), so one would have to insert a *) +(* /= every time one switched from additive to multiplicative rules. *) +(* -> The property duplication also means that it is not strictly necessary *) +(* to declare all Additive instances. *) +(* *) +(* * Linear (linear functions): *) +(* scalable f <-> f of type U -> V is scalable, i.e., f morphs *) +(* scaling on U to scaling on V, a *: _ to a *: _. *) +(* U and V must both have lmodType R structures, *) +(* for the same ringType R. *) +(* scalable_for s f <-> f is scalable for scaling operator s, i.e., *) +(* f morphs a *: _ to s a _; the range of f only *) +(* need to be a zmodType. The scaling operator s *) +(* should be one of *:%R (see scalable, above), *%R *) +(* or a combination nu \; *%R or nu \; *:%R with *) +(* nu : {rmorphism _}; otherwise some of the theory *) +(* (e.g., the linearZ rule) will not apply. *) +(* linear f <-> f of type U -> V is linear, i.e., f morphs *) +(* linear combinations a *: u + v in U to similar *) +(* linear combinations in V; U and V must both have *) +(* lmodType R structures, for the same ringType R. *) +(* := forall a, {morph f: u v / a *: u + v}. *) +(* scalar f <-> f of type U -> R is a scalar function, i.e., *) +(* f (a *: u + v) = a * f u + f v. *) +(* linear_for s f <-> f is linear for the scaling operator s, i.e., *) +(* f (a *: u + v) = s a (f u) + f v. The range of f *) +(* only needs to be a zmodType, but s MUST be of *) +(* the form described in in scalable_for paragraph *) +(* for this predicate to type check. *) +(* lmorphism f <-> f is both additive and scalable. This is in *) +(* fact equivalent to linear f, although somewhat *) +(* less convenient to prove. *) +(* lmorphism_for s f <-> f is both additive and scalable for s. *) +(* {linear U -> V} == the interface type for linear functions, i.e., a *) +(* Structure that encapsulates the linear property *) +(* for functions f : U -> V; both U and V must have *) +(* lmodType R structures, for the same R. *) +(* {scalar U} == the interface type for scalar functions, of type *) +(* U -> R where U has an lmodType R structure. *) +(* {linear U -> V | s} == the interface type for functions linear for s. *) +(* Linear lin_f == packs lin_f : lmorphism_for s f into a linear *) +(* function structure of type {linear U -> V | s}. *) +(* As linear_for s f coerces to lmorphism_for s f, *) +(* Linear can be used with lin_f : linear_for s f *) +(* (indeed, that is the recommended usage). Note *) +(* that as linear f, scalar f, {linear U -> V} and *) +(* {scalar U} are simply notation for corresponding *) +(* generic "_for" forms, Linear can be used for any *) +(* of these special cases, transparently. *) +(* AddLinear scal_f == packs scal_f : scalable_for s f into a *) +(* {linear U -> V | s} structure; f must already *) +(* have an additive structure; as with Linear, *) +(* AddLinear can be used with lin_f : linear f, etc *) +(* [linear of f as g] == an f-clone of the linear structure of g. *) +(* [linear of f] == a clone of an existing linear structure on f. *) +(* (a *: u)%Rlin == transient forms that simplify to a *: u, a * u, *) +(* (a * u)%Rlin nu a *: u, and nu a * u, respectively, and are *) +(* (a *:^nu u)%Rlin created by rewriting with the linearZ lemma. The *) +(* (a *^nu u)%Rlin forms allows the RHS of linearZ to be matched *) +(* reliably, using the GRing.Scale.law structure. *) +(* -> Similarly to Ring morphisms, additive properties are specialized for *) +(* linear functions. *) +(* -> Although {scalar U} is convertible to {linear U -> R^o}, it does not *) +(* actually use R^o, so that rewriting preserves the canonical structure *) +(* of the range of scalar functions. *) +(* -> The generic linearZ lemma uses a set of bespoke interface structures to *) +(* ensure that both left-to-right and right-to-left rewriting work even in *) +(* the presence of scaling functions that simplify non-trivially (e.g., *) +(* idfun \; *%R). Because most of the canonical instances and projections *) +(* are coercions the machinery will be mostly invisible (with only the *) +(* {linear ...} structure and %Rlin notations showing), but users should *) +(* beware that in (a *: f u)%Rlin, a actually occurs in the f u subterm. *) +(* -> The simpler linear_LR, or more specialized linearZZ and scalarZ rules *) +(* should be used instead of linearZ if there are complexity issues, as *) +(* well as for explicit forward and backward application, as the main *) +(* parameter of linearZ is a proper sub-interface of {linear fUV | s}. *) +(* *) +(* * LRMorphism (linear ring morphisms, i.e., algebra morphisms): *) +(* lrmorphism f <-> f of type A -> B is a linear Ring (Algebra) *) +(* morphism: f is both additive, multiplicative and *) +(* scalable. A and B must both have lalgType R *) +(* canonical structures, for the same ringType R. *) +(* lrmorphism_for s f <-> f a linear Ring morphism for the scaling *) +(* operator s: f is additive, multiplicative and *) +(* scalable for s. A must be an lalgType R, but B *) +(* only needs to have a ringType structure. *) +(* {lrmorphism A -> B} == the interface type for linear morphisms, i.e., a *) +(* Structure that encapsulates the lrmorphism *) +(* property for functions f : A -> B; both A and B *) +(* must have lalgType R structures, for the same R. *) +(* {lrmorphism A -> B | s} == the interface type for morphisms linear for s. *) +(* LRmorphism lrmorph_f == packs lrmorph_f : lrmorphism_for s f into a *) +(* linear morphism structure of type *) +(* {lrmorphism A -> B | s}. Like Linear, LRmorphism *) +(* can be used transparently for lrmorphism f. *) +(* AddLRmorphism scal_f == packs scal_f : scalable_for s f into a linear *) +(* morphism structure of type *) +(* {lrmorphism A -> B | s}; f must already have an *) +(* {rmorphism A -> B} structure, and AddLRmorphism *) +(* can be applied to a linear_for s f, linear f, *) +(* scalar f, etc argument, like AddLinear. *) +(* [lrmorphism of f] == creates an lrmorphism structure from existing *) +(* rmorphism and linear structures on f; this is *) +(* the preferred way of creating lrmorphism *) +(* structures. *) +(* -> Linear and rmorphism properties do not need to be specialized for *) +(* as we supply inheritance join instances in both directions. *) +(* Finally we supply some helper notation for morphisms: *) +(* x^f == the image of x under some morphism. This *) +(* notation is only reserved (not defined) here; *) +(* it is bound locally in sections where some *) +(* morphism is used heavily (e.g., the container *) +(* morphism in the parametricity sections of poly *) +(* and matrix, or the Frobenius section here). *) +(* \0 == the constant null function, which has a *) +(* canonical linear structure, and simplifies on *) +(* application (see ssrfun.v). *) +(* f \+ g == the additive composition of f and g, i.e., the *) +(* function x |-> f x + g x; f \+ g is canonically *) +(* linear when f and g are, and simplifies on *) +(* application (see ssrfun.v). *) +(* f \- g == the function x |-> f x - g x, canonically *) +(* linear when f and g are, and simplifies on *) +(* application. *) +(* k \*: f == the function x |-> k *: f x, which is *) +(* canonically linear when f is and simplifies on *) +(* application (this is a shorter alternative to *) +(* *:%R k \o f). *) +(* GRing.in_alg A == the ring morphism that injects R into A, where A *) +(* has an lalgType R structure; GRing.in_alg A k *) +(* simplifies to k%:A. *) +(* a \*o f == the function x |-> a * f x, canonically linear *) +(* linear when f is and its codomain is an algType *) +(* and which simplifies on application. *) +(* a \o* f == the function x |-> f x * a, canonically linear *) +(* linear when f is and its codomain is an lalgType *) +(* and which simplifies on application. *) +(* The Lemmas about these structures are contained in both the GRing module *) +(* and in the submodule GRing.Theory, which can be imported when unqualified *) +(* access to the theory is needed (GRing.Theory also allows the unqualified *) +(* use of additive, linear, Linear, etc). The main GRing module should NOT be *) +(* imported. *) +(* Notations are defined in scope ring_scope (delimiter %R), except term *) +(* and formula notations, which are in term_scope (delimiter %T). *) +(* This library also extends the conventional suffixes described in library *) +(* ssrbool.v with the following: *) +(* 0 -- ring 0, as in addr0 : x + 0 = x. *) +(* 1 -- ring 1, as in mulr1 : x * 1 = x. *) +(* D -- ring addition, as in linearD : f (u + v) = f u + f v. *) +(* B -- ring subtraction, as in opprB : - (x - y) = y - x. *) +(* M -- ring multiplication, as in invfM : (x * y)^-1 = x^-1 * y^-1. *) +(* Mn -- ring by nat multiplication, as in raddfMn : f (x *+ n) = f x *+ n. *) +(* N -- ring opposite, as in mulNr : (- x) * y = - (x * y). *) +(* V -- ring inverse, as in mulVr : x^-1 * x = 1. *) +(* X -- ring exponentiation, as in rmorphX : f (x ^+ n) = f x ^+ n. *) +(* Z -- (left) module scaling, as in linearZ : f (a *: v) = s *: f v. *) +(* The operator suffixes D, B, M and X are also used for the corresponding *) +(* operations on nat, as in natrX : (m ^ n)%:R = m%:R ^+ n. For the binary *) +(* power operator, a trailing "n" suffix is used to indicate the operator *) +(* suffix applies to the left-hand ring argument, as in *) +(* expr1n : 1 ^+ n = 1 vs. expr1 : x ^+ 1 = x. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Reserved Notation "+%R" (at level 0). +Reserved Notation "-%R" (at level 0). +Reserved Notation "*%R" (at level 0, format " *%R"). +Reserved Notation "*:%R" (at level 0, format " *:%R"). +Reserved Notation "n %:R" (at level 2, left associativity, format "n %:R"). +Reserved Notation "k %:A" (at level 2, left associativity, format "k %:A"). +Reserved Notation "[ 'char' F ]" (at level 0, format "[ 'char' F ]"). + +Reserved Notation "x %:T" (at level 2, left associativity, format "x %:T"). +Reserved Notation "''X_' i" (at level 8, i at level 2, format "''X_' i"). +(* Patch for recurring Coq parser bug: Coq seg faults when a level 200 *) +(* notation is used as a pattern. *) +Reserved Notation "''exists' ''X_' i , f" + (at level 199, i at level 2, right associativity, + format "'[hv' ''exists' ''X_' i , '/ ' f ']'"). +Reserved Notation "''forall' ''X_' i , f" + (at level 199, i at level 2, right associativity, + format "'[hv' ''forall' ''X_' i , '/ ' f ']'"). + +Reserved Notation "x ^f" (at level 2, left associativity, format "x ^f"). + +Reserved Notation "\0" (at level 0). +Reserved Notation "f \+ g" (at level 50, left associativity). +Reserved Notation "f \- g" (at level 50, left associativity). +Reserved Notation "a \*o f" (at level 40). +Reserved Notation "a \o* f" (at level 40). +Reserved Notation "a \*: f" (at level 40). + +Delimit Scope ring_scope with R. +Delimit Scope term_scope with T. +Local Open Scope ring_scope. + +Module Import GRing. + +Import Monoid.Theory. + +Module Zmodule. + +Record mixin_of (V : Type) : Type := Mixin { + zero : V; + opp : V -> V; + add : V -> V -> V; + _ : associative add; + _ : commutative add; + _ : left_id zero add; + _ : left_inverse zero opp add +}. + +Section ClassDef. + +Record class_of T := Class { base : Choice.class_of T; mixin : mixin_of T }. +Local Coercion base : class_of >-> Choice.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. +Definition clone c of phant_id class c := @Pack T c T. +Let xT := let: Pack T _ _ := cT in T. +Notation xclass := (class : class_of xT). + +Definition pack m := + fun bT b & phant_id (Choice.class bT) b => Pack (@Class T b m) T. + +Definition eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> Choice.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. +Notation zmodType := type. +Notation ZmodType T m := (@pack T m _ _ id). +Notation ZmodMixin := Mixin. +Notation "[ 'zmodType' 'of' T 'for' cT ]" := (@clone T cT _ idfun) + (at level 0, format "[ 'zmodType' 'of' T 'for' cT ]") : form_scope. +Notation "[ 'zmodType' 'of' T ]" := (@clone T _ _ id) + (at level 0, format "[ 'zmodType' 'of' T ]") : form_scope. +End Exports. + +End Zmodule. +Import Zmodule.Exports. + +Definition zero V := Zmodule.zero (Zmodule.class V). +Definition opp V := Zmodule.opp (Zmodule.class V). +Definition add V := Zmodule.add (Zmodule.class V). + +Local Notation "0" := (zero _) : ring_scope. +Local Notation "-%R" := (@opp _) : ring_scope. +Local Notation "- x" := (opp x) : ring_scope. +Local Notation "+%R" := (@add _) : ring_scope. +Local Notation "x + y" := (add x y) : ring_scope. +Local Notation "x - y" := (x + - y) : ring_scope. + +Definition natmul V x n := nosimpl iterop _ n +%R x (zero V). + +Local Notation "x *+ n" := (natmul x n) : ring_scope. +Local Notation "x *- n" := (- (x *+ n)) : ring_scope. + +Local Notation "\sum_ ( i <- r | P ) F" := (\big[+%R/0]_(i <- r | P) F). +Local Notation "\sum_ ( m <= i < n ) F" := (\big[+%R/0]_(m <= i < n) F). +Local Notation "\sum_ ( i < n ) F" := (\big[+%R/0]_(i < n) F). +Local Notation "\sum_ ( i 'in' A ) F" := (\big[+%R/0]_(i in A) F). + +Local Notation "s `_ i" := (nth 0 s i) : ring_scope. + +Section ZmoduleTheory. + +Variable V : zmodType. +Implicit Types x y : V. + +Lemma addrA : @associative V +%R. Proof. by case V => T [? []]. Qed. +Lemma addrC : @commutative V V +%R. Proof. by case V => T [? []]. Qed. +Lemma add0r : @left_id V V 0 +%R. Proof. by case V => T [? []]. Qed. +Lemma addNr : @left_inverse V V V 0 -%R +%R. Proof. by case V => T [? []]. Qed. + +Lemma addr0 : @right_id V V 0 +%R. +Proof. by move=> x; rewrite addrC add0r. Qed. +Lemma addrN : @right_inverse V V V 0 -%R +%R. +Proof. by move=> x; rewrite addrC addNr. Qed. +Definition subrr := addrN. + +Canonical add_monoid := Monoid.Law addrA add0r addr0. +Canonical add_comoid := Monoid.ComLaw addrC. + +Lemma addrCA : @left_commutative V V +%R. Proof. exact: mulmCA. Qed. +Lemma addrAC : @right_commutative V V +%R. Proof. exact: mulmAC. Qed. +Lemma addrACA : @interchange V +%R +%R. Proof. exact: mulmACA. Qed. + +Lemma addKr : @left_loop V V -%R +%R. +Proof. by move=> x y; rewrite addrA addNr add0r. Qed. +Lemma addNKr : @rev_left_loop V V -%R +%R. +Proof. by move=> x y; rewrite addrA addrN add0r. Qed. +Lemma addrK : @right_loop V V -%R +%R. +Proof. by move=> x y; rewrite -addrA addrN addr0. Qed. +Lemma addrNK : @rev_right_loop V V -%R +%R. +Proof. by move=> x y; rewrite -addrA addNr addr0. Qed. +Definition subrK := addrNK. +Lemma addrI : @right_injective V V V +%R. +Proof. move=> x; exact: can_inj (addKr x). Qed. +Lemma addIr : @left_injective V V V +%R. +Proof. move=> y; exact: can_inj (addrK y). Qed. +Lemma opprK : @involutive V -%R. +Proof. by move=> x; apply: (@addIr (- x)); rewrite addNr addrN. Qed. +Lemma oppr_inj : @injective V V -%R. +Proof. exact: inv_inj opprK. Qed. +Lemma oppr0 : -0 = 0 :> V. +Proof. by rewrite -[-0]add0r subrr. Qed. +Lemma oppr_eq0 x : (- x == 0) = (x == 0). +Proof. by rewrite (inv_eq opprK) oppr0. Qed. + +Lemma subr0 x : x - 0 = x. Proof. by rewrite oppr0 addr0. Qed. +Lemma sub0r x : 0 - x = - x. Proof. by rewrite add0r. Qed. + +Lemma opprD : {morph -%R: x y / x + y : V}. +Proof. +by move=> x y; apply: (@addrI (x + y)); rewrite addrA subrr addrAC addrK subrr. +Qed. + +Lemma opprB x y : - (x - y) = y - x. +Proof. by rewrite opprD addrC opprK. Qed. + +Lemma subr_eq x y z : (x - z == y) = (x == y + z). +Proof. exact: can2_eq (subrK z) (addrK z) x y. Qed. + +Lemma subr_eq0 x y : (x - y == 0) = (x == y). +Proof. by rewrite subr_eq add0r. Qed. + +Lemma addr_eq0 x y : (x + y == 0) = (x == - y). +Proof. by rewrite -[x == _]subr_eq0 opprK. Qed. + +Lemma eqr_opp x y : (- x == - y) = (x == y). +Proof. exact: can_eq opprK x y. Qed. + +Lemma eqr_oppLR x y : (- x == y) = (x == - y). +Proof. exact: inv_eq opprK x y. Qed. + +Lemma mulr0n x : x *+ 0 = 0. Proof. by []. Qed. +Lemma mulr1n x : x *+ 1 = x. Proof. by []. Qed. +Lemma mulr2n x : x *+ 2 = x + x. Proof. by []. Qed. + +Lemma mulrS x n : x *+ n.+1 = x + x *+ n. +Proof. by case: n => //=; rewrite addr0. Qed. + +Lemma mulrSr x n : x *+ n.+1 = x *+ n + x. +Proof. by rewrite addrC mulrS. Qed. + +Lemma mulrb x (b : bool) : x *+ b = (if b then x else 0). +Proof. by case: b. Qed. + +Lemma mul0rn n : 0 *+ n = 0 :> V. +Proof. by elim: n => // n IHn; rewrite mulrS add0r. Qed. + +Lemma mulNrn x n : (- x) *+ n = x *- n. +Proof. by elim: n => [|n IHn]; rewrite ?oppr0 // !mulrS opprD IHn. Qed. + +Lemma mulrnDl n : {morph (fun x => x *+ n) : x y / x + y}. +Proof. +move=> x y; elim: n => [|n IHn]; rewrite ?addr0 // !mulrS. +by rewrite addrCA -!addrA -IHn -addrCA. +Qed. + +Lemma mulrnDr x m n : x *+ (m + n) = x *+ m + x *+ n. +Proof. +elim: m => [|m IHm]; first by rewrite add0r. +by rewrite !mulrS IHm addrA. +Qed. + +Lemma mulrnBl n : {morph (fun x => x *+ n) : x y / x - y}. +Proof. +move=> x y; elim: n => [|n IHn]; rewrite ?subr0 // !mulrS -!addrA; congr(_ + _). +by rewrite addrC IHn -!addrA opprD [_ - y]addrC. +Qed. + +Lemma mulrnBr x m n : n <= m -> x *+ (m - n) = x *+ m - x *+ n. +Proof. +elim: m n => [|m IHm] [|n le_n_m]; rewrite ?subr0 // {}IHm //. +by rewrite mulrSr mulrS opprD addrA addrK. +Qed. + +Lemma mulrnA x m n : x *+ (m * n) = x *+ m *+ n. +Proof. +by rewrite mulnC; elim: n => //= n IHn; rewrite mulrS mulrnDr IHn. +Qed. + +Lemma mulrnAC x m n : x *+ m *+ n = x *+ n *+ m. +Proof. by rewrite -!mulrnA mulnC. Qed. + +Lemma sumrN I r P (F : I -> V) : + (\sum_(i <- r | P i) - F i = - (\sum_(i <- r | P i) F i)). +Proof. by rewrite (big_morph _ opprD oppr0). Qed. + +Lemma sumrB I r (P : pred I) (F1 F2 : I -> V) : + \sum_(i <- r | P i) (F1 i - F2 i) + = \sum_(i <- r | P i) F1 i - \sum_(i <- r | P i) F2 i. +Proof. by rewrite -sumrN -big_split /=. Qed. + +Lemma sumrMnl I r P (F : I -> V) n : + \sum_(i <- r | P i) F i *+ n = (\sum_(i <- r | P i) F i) *+ n. +Proof. by rewrite (big_morph _ (mulrnDl n) (mul0rn _)). Qed. + +Lemma sumrMnr x I r P (F : I -> nat) : + \sum_(i <- r | P i) x *+ F i = x *+ (\sum_(i <- r | P i) F i). +Proof. by rewrite (big_morph _ (mulrnDr x) (erefl _)). Qed. + +Lemma sumr_const (I : finType) (A : pred I) (x : V) : + \sum_(i in A) x = x *+ #|A|. +Proof. by rewrite big_const -iteropE. Qed. + +Lemma telescope_sumr n m (f : nat -> V) : n <= m -> + \sum_(n <= k < m) (f k.+1 - f k) = f m - f n. +Proof. +rewrite leq_eqVlt => /predU1P[-> | ]; first by rewrite subrr big_geq. +case: m => // m lenm; rewrite sumrB big_nat_recr // big_nat_recl //=. +by rewrite addrC opprD addrA subrK addrC. +Qed. + +Section ClosedPredicates. + +Variable S : predPredType V. + +Definition addr_closed := 0 \in S /\ {in S &, forall u v, u + v \in S}. +Definition oppr_closed := {in S, forall u, - u \in S}. +Definition subr_2closed := {in S &, forall u v, u - v \in S}. +Definition zmod_closed := 0 \in S /\ subr_2closed. + +Lemma zmod_closedN : zmod_closed -> oppr_closed. +Proof. by case=> S0 SB y Sy; rewrite -sub0r !SB. Qed. + +Lemma zmod_closedD : zmod_closed -> addr_closed. +Proof. +by case=> S0 SB; split=> // y z Sy Sz; rewrite -[z]opprK -[- z]sub0r !SB. +Qed. + +End ClosedPredicates. + +End ZmoduleTheory. + +Implicit Arguments addrI [[V] x1 x2]. +Implicit Arguments addIr [[V] x1 x2]. +Implicit Arguments oppr_inj [[V] x1 x2]. + +Module Ring. + +Record mixin_of (R : zmodType) : Type := Mixin { + one : R; + mul : R -> R -> R; + _ : associative mul; + _ : left_id one mul; + _ : right_id one mul; + _ : left_distributive mul +%R; + _ : right_distributive mul +%R; + _ : one != 0 +}. + +Definition EtaMixin R one mul mulA mul1x mulx1 mul_addl mul_addr nz1 := + let _ := @Mixin R one mul mulA mul1x mulx1 mul_addl mul_addr nz1 in + @Mixin (Zmodule.Pack (Zmodule.class R) R) _ _ + mulA mul1x mulx1 mul_addl mul_addr nz1. + +Section ClassDef. + +Record class_of (R : Type) : Type := Class { + base : Zmodule.class_of R; + mixin : mixin_of (Zmodule.Pack base R) +}. +Local Coercion base : class_of >-> Zmodule.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. +Definition clone c of phant_id class c := @Pack T c T. +Let xT := let: Pack T _ _ := cT in T. +Notation xclass := (class : class_of xT). + + +Definition pack b0 (m0 : mixin_of (@Zmodule.Pack T b0 T)) := + fun bT b & phant_id (Zmodule.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 := @Zmodule.Pack cT xclass xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> Zmodule.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 >-> Zmodule.type. +Canonical zmodType. +Notation ringType := type. +Notation RingType T m := (@pack T _ m _ _ id _ id). +Notation RingMixin := Mixin. +Notation "[ 'ringType' 'of' T 'for' cT ]" := (@clone T cT _ idfun) + (at level 0, format "[ 'ringType' 'of' T 'for' cT ]") : form_scope. +Notation "[ 'ringType' 'of' T ]" := (@clone T _ _ id) + (at level 0, format "[ 'ringType' 'of' T ]") : form_scope. +End Exports. + +End Ring. +Import Ring.Exports. + +Definition one (R : ringType) : R := Ring.one (Ring.class R). +Definition mul (R : ringType) : R -> R -> R := Ring.mul (Ring.class R). +Definition exp R x n := nosimpl iterop _ n (@mul R) x (one R). +Notation sign R b := (exp (- one R) (nat_of_bool b)) (only parsing). +Definition comm R x y := @mul R x y = mul y x. +Definition lreg R x := injective (@mul R x). +Definition rreg R x := injective ((@mul R)^~ x). + +Local Notation "1" := (one _) : ring_scope. +Local Notation "- 1" := (- (1)) : ring_scope. +Local Notation "n %:R" := (1 *+ n) : ring_scope. +Local Notation "*%R" := (@mul _). +Local Notation "x * y" := (mul x y) : ring_scope. +Local Notation "x ^+ n" := (exp x n) : ring_scope. + +Local Notation "\prod_ ( i <- r | P ) F" := (\big[*%R/1]_(i <- r | P) F). +Local Notation "\prod_ ( i | P ) F" := (\big[*%R/1]_(i | P) F). +Local Notation "\prod_ ( i 'in' A ) F" := (\big[*%R/1]_(i in A) F). +Local Notation "\prod_ ( m <= i < n ) F" := (\big[*%R/1%R]_(m <= i < n) F%R). + +(* The ``field'' characteristic; the definition, and many of the theorems, *) +(* has to apply to rings as well; indeed, we need the Frobenius automorphism *) +(* results for a non commutative ring in the proof of Gorenstein 2.6.3. *) +Definition char (R : Ring.type) of phant R : nat_pred := + [pred p | prime p & p%:R == 0 :> R]. + +Local Notation "[ 'char' R ]" := (char (Phant R)) : ring_scope. + +(* Converse ring tag. *) +Definition converse R : Type := R. +Local Notation "R ^c" := (converse R) (at level 2, format "R ^c") : type_scope. + +Section RingTheory. + +Variable R : ringType. +Implicit Types x y : R. + +Lemma mulrA : @associative R *%R. Proof. by case R => T [? []]. Qed. +Lemma mul1r : @left_id R R 1 *%R. Proof. by case R => T [? []]. Qed. +Lemma mulr1 : @right_id R R 1 *%R. Proof. by case R => T [? []]. Qed. +Lemma mulrDl : @left_distributive R R *%R +%R. +Proof. by case R => T [? []]. Qed. +Lemma mulrDr : @right_distributive R R *%R +%R. +Proof. by case R => T [? []]. Qed. +Lemma oner_neq0 : 1 != 0 :> R. Proof. by case R => T [? []]. Qed. +Lemma oner_eq0 : (1 == 0 :> R) = false. Proof. exact: negbTE oner_neq0. Qed. + +Lemma mul0r : @left_zero R R 0 *%R. +Proof. +by move=> x; apply: (addIr (1 * x)); rewrite -mulrDl !add0r mul1r. +Qed. +Lemma mulr0 : @right_zero R R 0 *%R. +Proof. +by move=> x; apply: (addIr (x * 1)); rewrite -mulrDr !add0r mulr1. +Qed. +Lemma mulrN x y : x * (- y) = - (x * y). +Proof. by apply: (addrI (x * y)); rewrite -mulrDr !subrr mulr0. Qed. +Lemma mulNr x y : (- x) * y = - (x * y). +Proof. by apply: (addrI (x * y)); rewrite -mulrDl !subrr mul0r. Qed. +Lemma mulrNN x y : (- x) * (- y) = x * y. +Proof. by rewrite mulrN mulNr opprK. Qed. +Lemma mulN1r x : -1 * x = - x. +Proof. by rewrite mulNr mul1r. Qed. +Lemma mulrN1 x : x * -1 = - x. +Proof. by rewrite mulrN mulr1. Qed. + +Canonical mul_monoid := Monoid.Law mulrA mul1r mulr1. +Canonical muloid := Monoid.MulLaw mul0r mulr0. +Canonical addoid := Monoid.AddLaw mulrDl mulrDr. + +Lemma mulr_suml I r P (F : I -> R) x : + (\sum_(i <- r | P i) F i) * x = \sum_(i <- r | P i) F i * x. +Proof. exact: big_distrl. Qed. + +Lemma mulr_sumr I r P (F : I -> R) x : + x * (\sum_(i <- r | P i) F i) = \sum_(i <- r | P i) x * F i. +Proof. exact: big_distrr. Qed. + +Lemma mulrBl x y z : (y - z) * x = y * x - z * x. +Proof. by rewrite mulrDl mulNr. Qed. + +Lemma mulrBr x y z : x * (y - z) = x * y - x * z. +Proof. by rewrite mulrDr mulrN. Qed. + +Lemma mulrnAl x y n : (x *+ n) * y = (x * y) *+ n. +Proof. by elim: n => [|n IHn]; rewrite ?mul0r // !mulrS mulrDl IHn. Qed. + +Lemma mulrnAr x y n : x * (y *+ n) = (x * y) *+ n. +Proof. by elim: n => [|n IHn]; rewrite ?mulr0 // !mulrS mulrDr IHn. Qed. + +Lemma mulr_natl x n : n%:R * x = x *+ n. +Proof. by rewrite mulrnAl mul1r. Qed. + +Lemma mulr_natr x n : x * n%:R = x *+ n. +Proof. by rewrite mulrnAr mulr1. Qed. + +Lemma natrD m n : (m + n)%:R = m%:R + n%:R :> R. +Proof. exact: mulrnDr. Qed. + +Lemma natrB m n : n <= m -> (m - n)%:R = m%:R - n%:R :> R. +Proof. exact: mulrnBr. Qed. + +Definition natr_sum := big_morph (natmul 1) natrD (mulr0n 1). + +Lemma natrM m n : (m * n)%:R = m%:R * n%:R :> R. +Proof. by rewrite mulrnA -mulr_natr. Qed. + +Lemma expr0 x : x ^+ 0 = 1. Proof. by []. Qed. +Lemma expr1 x : x ^+ 1 = x. Proof. by []. Qed. +Lemma expr2 x : x ^+ 2 = x * x. Proof. by []. Qed. + +Lemma exprS x n : x ^+ n.+1 = x * x ^+ n. +Proof. by case: n => //; rewrite mulr1. Qed. + +Lemma expr0n n : 0 ^+ n = (n == 0%N)%:R :> R. +Proof. by case: n => // n; rewrite exprS mul0r. Qed. + +Lemma expr1n n : 1 ^+ n = 1 :> R. +Proof. by elim: n => // n IHn; rewrite exprS mul1r. Qed. + +Lemma exprD x m n : x ^+ (m + n) = x ^+ m * x ^+ n. +Proof. by elim: m => [|m IHm]; rewrite ?mul1r // !exprS -mulrA -IHm. Qed. + +Lemma exprSr x n : x ^+ n.+1 = x ^+ n * x. +Proof. by rewrite -addn1 exprD expr1. Qed. + +Lemma commr_sym x y : comm x y -> comm y x. Proof. by []. Qed. +Lemma commr_refl x : comm x x. Proof. by []. Qed. + +Lemma commr0 x : comm x 0. +Proof. by rewrite /comm mulr0 mul0r. Qed. + +Lemma commr1 x : comm x 1. +Proof. by rewrite /comm mulr1 mul1r. Qed. + +Lemma commrN x y : comm x y -> comm x (- y). +Proof. by move=> com_xy; rewrite /comm mulrN com_xy mulNr. Qed. + +Lemma commrN1 x : comm x (-1). +Proof. apply: commrN; exact: commr1. Qed. + +Lemma commrD x y z : comm x y -> comm x z -> comm x (y + z). +Proof. by rewrite /comm mulrDl mulrDr => -> ->. Qed. + +Lemma commrMn x y n : comm x y -> comm x (y *+ n). +Proof. +rewrite /comm => com_xy. +by elim: n => [|n IHn]; rewrite ?commr0 // mulrS commrD. +Qed. + +Lemma commrM x y z : comm x y -> comm x z -> comm x (y * z). +Proof. by move=> com_xy; rewrite /comm mulrA com_xy -!mulrA => ->. Qed. + +Lemma commr_nat x n : comm x n%:R. +Proof. by apply: commrMn; exact: commr1. Qed. + +Lemma commrX x y n : comm x y -> comm x (y ^+ n). +Proof. +rewrite /comm => com_xy. +by elim: n => [|n IHn]; rewrite ?commr1 // exprS commrM. +Qed. + +Lemma exprMn_comm x y n : comm x y -> (x * y) ^+ n = x ^+ n * y ^+ n. +Proof. +move=> com_xy; elim: n => /= [|n IHn]; first by rewrite mulr1. +by rewrite !exprS IHn !mulrA; congr (_ * _); rewrite -!mulrA -commrX. +Qed. + +Lemma commr_sign x n : comm x ((-1) ^+ n). +Proof. exact: (commrX n (commrN1 x)). Qed. + +Lemma exprMn_n x m n : (x *+ m) ^+ n = x ^+ n *+ (m ^ n) :> R. +Proof. +elim: n => [|n IHn]; first by rewrite mulr1n. +rewrite exprS IHn -mulr_natr -mulrA -commr_nat mulr_natr -mulrnA -expnSr. +by rewrite -mulr_natr mulrA -exprS mulr_natr. +Qed. + +Lemma exprM x m n : x ^+ (m * n) = x ^+ m ^+ n. +Proof. +elim: m => [|m IHm]; first by rewrite expr1n. +by rewrite mulSn exprD IHm exprS exprMn_comm //; exact: commrX. +Qed. + +Lemma exprAC x m n : (x ^+ m) ^+ n = (x ^+ n) ^+ m. +Proof. by rewrite -!exprM mulnC. Qed. + +Lemma expr_mod n x i : x ^+ n = 1 -> x ^+ (i %% n) = x ^+ i. +Proof. +move=> xn1; rewrite {2}(divn_eq i n) exprD mulnC exprM xn1. +by rewrite expr1n mul1r. +Qed. + +Lemma expr_dvd n x i : x ^+ n = 1 -> n %| i -> x ^+ i = 1. +Proof. +by move=> xn1 dvd_n_i; rewrite -(expr_mod i xn1) (eqnP dvd_n_i). +Qed. + +Lemma natrX n k : (n ^ k)%:R = n%:R ^+ k :> R. +Proof. by rewrite exprMn_n expr1n. Qed. + +Lemma signr_odd n : (-1) ^+ (odd n) = (-1) ^+ n :> R. +Proof. +elim: n => //= n IHn; rewrite exprS -{}IHn. +by case/odd: n; rewrite !mulN1r ?opprK. +Qed. + +Lemma signr_eq0 n : ((-1) ^+ n == 0 :> R) = false. +Proof. by rewrite -signr_odd; case: odd; rewrite ?oppr_eq0 oner_eq0. Qed. + +Lemma mulr_sign (b : bool) x : (-1) ^+ b * x = (if b then - x else x). +Proof. by case: b; rewrite ?mulNr mul1r. Qed. + +Lemma signr_addb b1 b2 : (-1) ^+ (b1 (+) b2) = (-1) ^+ b1 * (-1) ^+ b2 :> R. +Proof. by rewrite mulr_sign; case: b1 b2 => [] []; rewrite ?opprK. Qed. + +Lemma signrE (b : bool) : (-1) ^+ b = 1 - b.*2%:R :> R. +Proof. by case: b; rewrite ?subr0 // opprD addNKr. Qed. + +Lemma signrN b : (-1) ^+ (~~ b) = - (-1) ^+ b :> R. +Proof. by case: b; rewrite ?opprK. Qed. + +Lemma mulr_signM (b1 b2 : bool) x1 x2 : + ((-1) ^+ b1 * x1) * ((-1) ^+ b2 * x2) = (-1) ^+ (b1 (+) b2) * (x1 * x2). +Proof. +by rewrite signr_addb -!mulrA; congr (_ * _); rewrite !mulrA commr_sign. +Qed. + +Lemma exprNn x n : (- x) ^+ n = (-1) ^+ n * x ^+ n :> R. +Proof. by rewrite -mulN1r exprMn_comm // /comm mulN1r mulrN mulr1. Qed. + +Lemma sqrrN x : (- x) ^+ 2 = x ^+ 2. +Proof. exact: mulrNN. Qed. + +Lemma sqrr_sign n : ((-1) ^+ n) ^+ 2 = 1 :> R. +Proof. by rewrite exprAC sqrrN !expr1n. Qed. + +Lemma signrMK n : @involutive R ( *%R ((-1) ^+ n)). +Proof. by move=> x; rewrite mulrA -expr2 sqrr_sign mul1r. Qed. + +Lemma mulrI_eq0 x y : lreg x -> (x * y == 0) = (y == 0). +Proof. by move=> reg_x; rewrite -{1}(mulr0 x) (inj_eq reg_x). Qed. + +Lemma lreg_neq0 x : lreg x -> x != 0. +Proof. by move=> reg_x; rewrite -[x]mulr1 mulrI_eq0 ?oner_eq0. Qed. + +Lemma mulrI0_lreg x : (forall y, x * y = 0 -> y = 0) -> lreg x. +Proof. +move=> reg_x y z eq_xy_xz; apply/eqP; rewrite -subr_eq0 [y - z]reg_x //. +by rewrite mulrBr eq_xy_xz subrr. +Qed. + +Lemma lregN x : lreg x -> lreg (- x). +Proof. by move=> reg_x y z; rewrite !mulNr => /oppr_inj/reg_x. Qed. + +Lemma lreg1 : lreg (1 : R). +Proof. by move=> x y; rewrite !mul1r. Qed. + +Lemma lregM x y : lreg x -> lreg y -> lreg (x * y). +Proof. by move=> reg_x reg_y z t; rewrite -!mulrA => /reg_x/reg_y. Qed. + +Lemma lregX x n : lreg x -> lreg (x ^+ n). +Proof. +by move=> reg_x; elim: n => [|n]; [exact: lreg1 | rewrite exprS; exact: lregM]. +Qed. + +Lemma lreg_sign n : lreg ((-1) ^+ n : R). +Proof. by apply: lregX; apply: lregN; apply: lreg1. Qed. + +Lemma prodr_const (I : finType) (A : pred I) (x : R) : + \prod_(i in A) x = x ^+ #|A|. +Proof. by rewrite big_const -iteropE. Qed. + +Lemma prodrXr x I r P (F : I -> nat) : + \prod_(i <- r | P i) x ^+ F i = x ^+ (\sum_(i <- r | P i) F i). +Proof. by rewrite (big_morph _ (exprD _) (erefl _)). Qed. + +Lemma prodrN (I : finType) (A : pred I) (F : I -> R) : + \prod_(i in A) - F i = (- 1) ^+ #|A| * \prod_(i in A) F i. +Proof. +rewrite -sum1_card; elim/big_rec3: _ => [|i x n _ _ ->]; first by rewrite mulr1. +by rewrite exprS !mulrA mulN1r !mulNr commrX //; apply: commrN1. +Qed. + +Lemma prodrMn n (I : finType) (A : pred I) (F : I -> R) : + \prod_(i in A) (F i *+ n) = \prod_(i in A) F i *+ n ^ #|A|. +Proof. +rewrite -sum1_card; elim/big_rec3: _ => // i x m _ _ ->. +by rewrite mulrnAr mulrnAl expnS mulrnA. +Qed. + +Lemma natr_prod I r P (F : I -> nat) : + (\prod_(i <- r | P i) F i)%:R = \prod_(i <- r | P i) (F i)%:R :> R. +Proof. exact: (big_morph _ natrM). Qed. + +Lemma exprDn_comm x y n (cxy : comm x y) : + (x + y) ^+ n = \sum_(i < n.+1) (x ^+ (n - i) * y ^+ i) *+ 'C(n, i). +Proof. +elim: n => [|n IHn]; rewrite big_ord_recl mulr1 ?big_ord0 ?addr0 //=. +rewrite exprS {}IHn /= mulrDl !big_distrr /= big_ord_recl mulr1 subn0. +rewrite !big_ord_recr /= !binn !subnn !mul1r !subn0 bin0 !exprS -addrA. +congr (_ + _); rewrite addrA -big_split /=; congr (_ + _). +apply: eq_bigr => i _; rewrite !mulrnAr !mulrA -exprS -subSn ?(valP i) //. +by rewrite subSS (commrX _ (commr_sym cxy)) -mulrA -exprS -mulrnDr. +Qed. + +Lemma exprBn_comm x y n (cxy : comm x y) : + (x - y) ^+ n = + \sum_(i < n.+1) ((-1) ^+ i * x ^+ (n - i) * y ^+ i) *+ 'C(n, i). +Proof. +rewrite exprDn_comm; last exact: commrN. +by apply: eq_bigr => i _; congr (_ *+ _); rewrite -commr_sign -mulrA -exprNn. +Qed. + +Lemma subrXX_comm x y n (cxy : comm x y) : + x ^+ n - y ^+ n = (x - y) * (\sum_(i < n) x ^+ (n.-1 - i) * y ^+ i). +Proof. +case: n => [|n]; first by rewrite big_ord0 mulr0 subrr. +rewrite mulrBl !big_distrr big_ord_recl big_ord_recr /= subnn mulr1 mul1r. +rewrite subn0 -!exprS opprD -!addrA; congr (_ + _); rewrite addrA -sumrB. +rewrite big1 ?add0r // => i _; rewrite !mulrA -exprS -subSn ?(valP i) //. +by rewrite subSS (commrX _ (commr_sym cxy)) -mulrA -exprS subrr. +Qed. + +Lemma exprD1n x n : (x + 1) ^+ n = \sum_(i < n.+1) x ^+ i *+ 'C(n, i). +Proof. +rewrite addrC (exprDn_comm n (commr_sym (commr1 x))). +by apply: eq_bigr => i _; rewrite expr1n mul1r. +Qed. + +Lemma subrX1 x n : x ^+ n - 1 = (x - 1) * (\sum_(i < n) x ^+ i). +Proof. +rewrite -!(opprB 1) mulNr -{1}(expr1n n). +rewrite (subrXX_comm _ (commr_sym (commr1 x))); congr (- (_ * _)). +by apply: eq_bigr => i _; rewrite expr1n mul1r. +Qed. + +Lemma sqrrD1 x : (x + 1) ^+ 2 = x ^+ 2 + x *+ 2 + 1. +Proof. +rewrite exprD1n !big_ord_recr big_ord0 /= add0r. +by rewrite addrC addrA addrAC. +Qed. + +Lemma sqrrB1 x : (x - 1) ^+ 2 = x ^+ 2 - x *+ 2 + 1. +Proof. by rewrite -sqrrN opprB addrC sqrrD1 sqrrN mulNrn. Qed. + +Lemma subr_sqr_1 x : x ^+ 2 - 1 = (x - 1) * (x + 1). +Proof. by rewrite subrX1 !big_ord_recr big_ord0 /= addrAC add0r. Qed. + +Definition Frobenius_aut p of p \in [char R] := fun x => x ^+ p. + +Section FrobeniusAutomorphism. + +Variable p : nat. +Hypothesis charFp : p \in [char R]. + +Lemma charf0 : p%:R = 0 :> R. Proof. by apply/eqP; case/andP: charFp. Qed. +Lemma charf_prime : prime p. Proof. by case/andP: charFp. Qed. +Hint Resolve charf_prime. + +Lemma mulrn_char x : x *+ p = 0. Proof. by rewrite -mulr_natl charf0 mul0r. Qed. + +Lemma natr_mod_char n : (n %% p)%:R = n%:R :> R. +Proof. by rewrite {2}(divn_eq n p) natrD mulrnA mulrn_char add0r. Qed. + +Lemma dvdn_charf n : (p %| n)%N = (n%:R == 0 :> R). +Proof. +apply/idP/eqP=> [/dvdnP[n' ->]|n0]; first by rewrite natrM charf0 mulr0. +apply/idPn; rewrite -prime_coprime // => /eqnP pn1. +have [a _ /dvdnP[b]] := Bezoutl n (prime_gt0 charf_prime). +move/(congr1 (fun m => m%:R : R))/eqP. +by rewrite natrD !natrM charf0 n0 !mulr0 pn1 addr0 oner_eq0. +Qed. + +Lemma charf_eq : [char R] =i (p : nat_pred). +Proof. +move=> q; apply/andP/eqP=> [[q_pr q0] | ->]; last by rewrite charf0. +by apply/eqP; rewrite eq_sym -dvdn_prime2 // dvdn_charf. +Qed. + +Lemma bin_lt_charf_0 k : 0 < k < p -> 'C(p, k)%:R = 0 :> R. +Proof. by move=> lt0kp; apply/eqP; rewrite -dvdn_charf prime_dvd_bin. Qed. + +Local Notation "x ^f" := (Frobenius_aut charFp x). + +Lemma Frobenius_autE x : x^f = x ^+ p. Proof. by []. Qed. +Local Notation fE := Frobenius_autE. + +Lemma Frobenius_aut0 : 0^f = 0. +Proof. by rewrite fE -(prednK (prime_gt0 charf_prime)) exprS mul0r. Qed. + +Lemma Frobenius_aut1 : 1^f = 1. +Proof. by rewrite fE expr1n. Qed. + +Lemma Frobenius_autD_comm x y (cxy : comm x y) : (x + y)^f = x^f + y^f. +Proof. +have defp := prednK (prime_gt0 charf_prime). +rewrite !fE exprDn_comm // big_ord_recr subnn -defp big_ord_recl /= defp. +rewrite subn0 mulr1 mul1r bin0 binn big1 ?addr0 // => i _. +by rewrite -mulr_natl bin_lt_charf_0 ?mul0r //= -{2}defp ltnS (valP i). +Qed. + +Lemma Frobenius_autMn x n : (x *+ n)^f = x^f *+ n. +Proof. +elim: n => [|n IHn]; first exact: Frobenius_aut0. +rewrite !mulrS Frobenius_autD_comm ?IHn //; exact: commrMn. +Qed. + +Lemma Frobenius_aut_nat n : (n%:R)^f = n%:R. +Proof. by rewrite Frobenius_autMn Frobenius_aut1. Qed. + +Lemma Frobenius_autM_comm x y : comm x y -> (x * y)^f = x^f * y^f. +Proof. by exact: exprMn_comm. Qed. + +Lemma Frobenius_autX x n : (x ^+ n)^f = x^f ^+ n. +Proof. by rewrite !fE -!exprM mulnC. Qed. + +Lemma Frobenius_autN x : (- x)^f = - x^f. +Proof. +apply/eqP; rewrite -subr_eq0 opprK addrC. +by rewrite -(Frobenius_autD_comm (commrN _)) // subrr Frobenius_aut0. +Qed. + +Lemma Frobenius_autB_comm x y : comm x y -> (x - y)^f = x^f - y^f. +Proof. +by move/commrN/Frobenius_autD_comm->; rewrite Frobenius_autN. +Qed. + +End FrobeniusAutomorphism. + +Lemma exprNn_char x n : [char R].-nat n -> (- x) ^+ n = - (x ^+ n). +Proof. +pose p := pdiv n; have [|n_gt1 charRn] := leqP n 1; first by case: (n) => [|[]]. +have charRp: p \in [char R] by rewrite (pnatPpi charRn) // pi_pdiv. +have /p_natP[e ->]: p.-nat n by rewrite -(eq_pnat _ (charf_eq charRp)). +elim: e => // e IHe; rewrite expnSr !exprM {}IHe. +by rewrite -Frobenius_autE Frobenius_autN. +Qed. + +Section Char2. + +Hypothesis charR2 : 2 \in [char R]. + +Lemma addrr_char2 x : x + x = 0. Proof. by rewrite -mulr2n mulrn_char. Qed. + +Lemma oppr_char2 x : - x = x. +Proof. by apply/esym/eqP; rewrite -addr_eq0 addrr_char2. Qed. + +Lemma subr_char2 x y : x - y = x + y. Proof. by rewrite oppr_char2. Qed. + +Lemma addrK_char2 x : involutive (+%R^~ x). +Proof. by move=> y; rewrite /= -subr_char2 addrK. Qed. + +Lemma addKr_char2 x : involutive (+%R x). +Proof. by move=> y; rewrite -{1}[x]oppr_char2 addKr. Qed. + +End Char2. + +Canonical converse_eqType := [eqType of R^c]. +Canonical converse_choiceType := [choiceType of R^c]. +Canonical converse_zmodType := [zmodType of R^c]. + +Definition converse_ringMixin := + let mul' x y := y * x in + let mulrA' x y z := esym (mulrA z y x) in + let mulrDl' x y z := mulrDr z x y in + let mulrDr' x y z := mulrDl y z x in + @Ring.Mixin converse_zmodType + 1 mul' mulrA' mulr1 mul1r mulrDl' mulrDr' oner_neq0. +Canonical converse_ringType := RingType R^c converse_ringMixin. + +Section ClosedPredicates. + +Variable S : predPredType R. + +Definition mulr_2closed := {in S &, forall u v, u * v \in S}. +Definition mulr_closed := 1 \in S /\ mulr_2closed. +Definition smulr_closed := -1 \in S /\ mulr_2closed. +Definition semiring_closed := addr_closed S /\ mulr_closed. +Definition subring_closed := [/\ 1 \in S, subr_2closed S & mulr_2closed]. + +Lemma smulr_closedM : smulr_closed -> mulr_closed. +Proof. by case=> SN1 SM; split=> //; rewrite -[1]mulr1 -mulrNN SM. Qed. + +Lemma smulr_closedN : smulr_closed -> oppr_closed S. +Proof. by case=> SN1 SM x Sx; rewrite -mulN1r SM. Qed. + +Lemma semiring_closedD : semiring_closed -> addr_closed S. Proof. by case. Qed. + +Lemma semiring_closedM : semiring_closed -> mulr_closed. Proof. by case. Qed. + +Lemma subring_closedB : subring_closed -> zmod_closed S. +Proof. by case=> S1 SB _; split; rewrite // -(subrr 1) SB. Qed. + +Lemma subring_closedM : subring_closed -> smulr_closed. +Proof. +by case=> S1 SB SM; split; rewrite ?(zmod_closedN (subring_closedB _)). +Qed. + +Lemma subring_closed_semi : subring_closed -> semiring_closed. +Proof. +by move=> ringS; split; [apply/zmod_closedD/subring_closedB | case: ringS]. +Qed. + +End ClosedPredicates. + +End RingTheory. + +Section RightRegular. + +Variable R : ringType. +Implicit Types x y : R. +Let Rc := converse_ringType R. + +Lemma mulIr_eq0 x y : rreg x -> (y * x == 0) = (y == 0). +Proof. exact: (@mulrI_eq0 Rc). Qed. + +Lemma mulIr0_rreg x : (forall y, y * x = 0 -> y = 0) -> rreg x. +Proof. exact: (@mulrI0_lreg Rc). Qed. + +Lemma rreg_neq0 x : rreg x -> x != 0. +Proof. exact: (@lreg_neq0 Rc). Qed. + +Lemma rregN x : rreg x -> rreg (- x). +Proof. exact: (@lregN Rc). Qed. + +Lemma rreg1 : rreg (1 : R). +Proof. exact: (@lreg1 Rc). Qed. + +Lemma rregM x y : rreg x -> rreg y -> rreg (x * y). +Proof. by move=> reg_x reg_y; exact: (@lregM Rc). Qed. + +Lemma revrX x n : (x : Rc) ^+ n = (x : R) ^+ n. +Proof. by elim: n => // n IHn; rewrite exprS exprSr IHn. Qed. + +Lemma rregX x n : rreg x -> rreg (x ^+ n). +Proof. by move/(@lregX Rc x n); rewrite revrX. Qed. + +End RightRegular. + +Module Lmodule. + +Structure mixin_of (R : ringType) (V : zmodType) : Type := Mixin { + scale : R -> V -> V; + _ : forall a b v, scale a (scale b v) = scale (a * b) v; + _ : left_id 1 scale; + _ : right_distributive scale +%R; + _ : forall v, {morph scale^~ v: a b / a + b} +}. + +Section ClassDef. + +Variable R : ringType. + +Structure class_of V := Class { + base : Zmodule.class_of V; + mixin : mixin_of R (Zmodule.Pack base V) +}. +Local Coercion base : class_of >-> Zmodule.class_of. + +Structure type (phR : phant R) := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variable (phR : phant R) (T : Type) (cT : type phR). +Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c. +Definition clone c of phant_id class c := @Pack phR T c T. +Let xT := let: Pack T _ _ := cT in T. +Notation xclass := (class : class_of xT). + + +Definition pack b0 (m0 : mixin_of R (@Zmodule.Pack T b0 T)) := + fun bT b & phant_id (Zmodule.class bT) b => + fun m & phant_id m0 m => Pack phR (@Class T b m) T. + +Definition eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition zmodType := @Zmodule.Pack cT xclass xT. + +End ClassDef. + +Module Import Exports. +Coercion base : class_of >-> Zmodule.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 >-> Zmodule.type. +Canonical zmodType. +Notation lmodType R := (type (Phant R)). +Notation LmodType R T m := (@pack _ (Phant R) T _ m _ _ id _ id). +Notation LmodMixin := Mixin. +Notation "[ 'lmodType' R 'of' T 'for' cT ]" := (@clone _ (Phant R) T cT _ idfun) + (at level 0, format "[ 'lmodType' R 'of' T 'for' cT ]") : form_scope. +Notation "[ 'lmodType' R 'of' T ]" := (@clone _ (Phant R) T _ _ id) + (at level 0, format "[ 'lmodType' R 'of' T ]") : form_scope. +End Exports. + +End Lmodule. +Import Lmodule.Exports. + +Definition scale (R : ringType) (V : lmodType R) := + Lmodule.scale (Lmodule.class V). + +Local Notation "*:%R" := (@scale _ _). +Local Notation "a *: v" := (scale a v) : ring_scope. + +Section LmoduleTheory. + +Variables (R : ringType) (V : lmodType R). +Implicit Types (a b c : R) (u v : V). + +Local Notation "*:%R" := (@scale R V). + +Lemma scalerA a b v : a *: (b *: v) = a * b *: v. +Proof. by case: V v => ? [] ? []. Qed. + +Lemma scale1r : @left_id R V 1 *:%R. +Proof. by case: V => ? [] ? []. Qed. + +Lemma scalerDr a : {morph *:%R a : u v / u + v}. +Proof. by case: V a => ? [] ? []. Qed. + +Lemma scalerDl v : {morph *:%R^~ v : a b / a + b}. +Proof. by case: V v => ? [] ? []. Qed. + +Lemma scale0r v : 0 *: v = 0. +Proof. by apply: (addIr (1 *: v)); rewrite -scalerDl !add0r. Qed. + +Lemma scaler0 a : a *: 0 = 0 :> V. +Proof. by rewrite -{1}(scale0r 0) scalerA mulr0 scale0r. Qed. + +Lemma scaleNr a v : - a *: v = - (a *: v). +Proof. by apply: (addIr (a *: v)); rewrite -scalerDl !addNr scale0r. Qed. + +Lemma scaleN1r v : (- 1) *: v = - v. +Proof. by rewrite scaleNr scale1r. Qed. + +Lemma scalerN a v : a *: (- v) = - (a *: v). +Proof. by apply: (addIr (a *: v)); rewrite -scalerDr !addNr scaler0. Qed. + +Lemma scalerBl a b v : (a - b) *: v = a *: v - b *: v. +Proof. by rewrite scalerDl scaleNr. Qed. + +Lemma scalerBr a u v : a *: (u - v) = a *: u - a *: v. +Proof. by rewrite scalerDr scalerN. Qed. + +Lemma scaler_nat n v : n%:R *: v = v *+ n. +Proof. +elim: n => /= [|n ]; first by rewrite scale0r. +by rewrite !mulrS scalerDl ?scale1r => ->. +Qed. + +Lemma scaler_sign (b : bool) v: (-1) ^+ b *: v = (if b then - v else v). +Proof. by case: b; rewrite ?scaleNr scale1r. Qed. + +Lemma signrZK n : @involutive V ( *:%R ((-1) ^+ n)). +Proof. by move=> u; rewrite scalerA -expr2 sqrr_sign scale1r. Qed. + +Lemma scalerMnl a v n : a *: v *+ n = (a *+ n) *: v. +Proof. +elim: n => [|n IHn]; first by rewrite !mulr0n scale0r. +by rewrite !mulrSr IHn scalerDl. +Qed. + +Lemma scalerMnr a v n : a *: v *+ n = a *: (v *+ n). +Proof. +elim: n => [|n IHn]; first by rewrite !mulr0n scaler0. +by rewrite !mulrSr IHn scalerDr. +Qed. + +Lemma scaler_suml v I r (P : pred I) F : + (\sum_(i <- r | P i) F i) *: v = \sum_(i <- r | P i) F i *: v. +Proof. exact: (big_morph _ (scalerDl v) (scale0r v)). Qed. + +Lemma scaler_sumr a I r (P : pred I) (F : I -> V) : + a *: (\sum_(i <- r | P i) F i) = \sum_(i <- r | P i) a *: F i. +Proof. exact: big_endo (scalerDr a) (scaler0 a) I r P F. Qed. + +Section ClosedPredicates. + +Variable S : predPredType V. + +Definition scaler_closed := forall a, {in S, forall v, a *: v \in S}. +Definition linear_closed := forall a, {in S &, forall u v, a *: u + v \in S}. +Definition submod_closed := 0 \in S /\ linear_closed. + +Lemma linear_closedB : linear_closed -> subr_2closed S. +Proof. by move=> Slin u v Su Sv; rewrite addrC -scaleN1r Slin. Qed. + +Lemma submod_closedB : submod_closed -> zmod_closed S. +Proof. by case=> S0 /linear_closedB. Qed. + +Lemma submod_closedZ : submod_closed -> scaler_closed. +Proof. by case=> S0 Slin a v Sv; rewrite -[a *: v]addr0 Slin. Qed. + +End ClosedPredicates. + +End LmoduleTheory. + +Module Lalgebra. + +Definition axiom (R : ringType) (V : lmodType R) (mul : V -> V -> V) := + forall a u v, a *: mul u v = mul (a *: u) v. + +Section ClassDef. + +Variable R : ringType. + +Record class_of (T : Type) : Type := Class { + base : Ring.class_of T; + mixin : Lmodule.mixin_of R (Zmodule.Pack base T); + ext : @axiom R (Lmodule.Pack _ (Lmodule.Class mixin) T) (Ring.mul base) +}. +Definition base2 R m := Lmodule.Class (@mixin R m). +Local Coercion base : class_of >-> Ring.class_of. +Local Coercion base2 : class_of >-> Lmodule.class_of. + +Structure type (phR : phant R) := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variable (phR : phant R) (T : Type) (cT : type phR). +Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c. +Definition clone c of phant_id class c := @Pack phR T c T. +Let xT := let: Pack T _ _ := cT in T. +Notation xclass := (class : class_of xT). + +Definition pack T b0 mul0 (axT : @axiom R (@Lmodule.Pack R _ T b0 T) mul0) := + fun bT b & phant_id (Ring.class bT) (b : Ring.class_of T) => + fun mT m & phant_id (@Lmodule.class R phR mT) (@Lmodule.Class R T b m) => + fun ax & phant_id axT ax => + Pack (Phant R) (@Class T b m ax) T. + +Definition eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition zmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @Ring.Pack cT xclass xT. +Definition lmodType := @Lmodule.Pack R phR cT xclass xT. +Definition lmod_ringType := @Lmodule.Pack R phR ringType xclass xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> Ring.class_of. +Coercion base2 : class_of >-> Lmodule.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 >-> Zmodule.type. +Canonical zmodType. +Coercion ringType : type >-> Ring.type. +Canonical ringType. +Coercion lmodType : type >-> Lmodule.type. +Canonical lmodType. +Canonical lmod_ringType. +Notation lalgType R := (type (Phant R)). +Notation LalgType R T a := (@pack _ (Phant R) T _ _ a _ _ id _ _ id _ id). +Notation "[ 'lalgType' R 'of' T 'for' cT ]" := (@clone _ (Phant R) T cT _ idfun) + (at level 0, format "[ 'lalgType' R 'of' T 'for' cT ]") + : form_scope. +Notation "[ 'lalgType' R 'of' T ]" := (@clone _ (Phant R) T _ _ id) + (at level 0, format "[ 'lalgType' R 'of' T ]") : form_scope. +End Exports. + +End Lalgebra. +Import Lalgebra.Exports. + +(* Scalar injection (see the definition of in_alg A below). *) +Local Notation "k %:A" := (k *: 1) : ring_scope. + +(* Regular ring algebra tag. *) +Definition regular R : Type := R. +Local Notation "R ^o" := (regular R) (at level 2, format "R ^o") : type_scope. + +Section LalgebraTheory. + +Variables (R : ringType) (A : lalgType R). +Implicit Types x y : A. + +Lemma scalerAl k (x y : A) : k *: (x * y) = k *: x * y. +Proof. by case: A k x y => ? []. Qed. + +Lemma mulr_algl a x : a%:A * x = a *: x. +Proof. by rewrite -scalerAl mul1r. Qed. + +Canonical regular_eqType := [eqType of R^o]. +Canonical regular_choiceType := [choiceType of R^o]. +Canonical regular_zmodType := [zmodType of R^o]. +Canonical regular_ringType := [ringType of R^o]. + +Definition regular_lmodMixin := + let mkMixin := @Lmodule.Mixin R regular_zmodType (@mul R) in + mkMixin (@mulrA R) (@mul1r R) (@mulrDr R) (fun v a b => mulrDl a b v). + +Canonical regular_lmodType := LmodType R R^o regular_lmodMixin. +Canonical regular_lalgType := LalgType R R^o (@mulrA regular_ringType). + +Section ClosedPredicates. + +Variable S : predPredType A. + +Definition subalg_closed := [/\ 1 \in S, linear_closed S & mulr_2closed S]. + +Lemma subalg_closedZ : subalg_closed -> submod_closed S. +Proof. by case=> S1 Slin _; split; rewrite // -(subrr 1) linear_closedB. Qed. + +Lemma subalg_closedBM : subalg_closed -> subring_closed S. +Proof. by case=> S1 Slin SM; split=> //; apply: linear_closedB. Qed. + +End ClosedPredicates. + +End LalgebraTheory. + +(* Morphism hierarchy. *) + +Module Additive. + +Section ClassDef. + +Variables U V : zmodType. + +Definition axiom (f : U -> V) := {morph f : x y / x - y}. + +Structure map (phUV : phant (U -> V)) := Pack {apply; _ : axiom apply}. +Local Coercion apply : map >-> Funclass. + +Variables (phUV : phant (U -> V)) (f g : U -> V) (cF : map phUV). +Definition class := let: Pack _ c as cF' := cF return axiom cF' in c. +Definition clone fA of phant_id g (apply cF) & phant_id fA class := + @Pack phUV f fA. + +End ClassDef. + +Module Exports. +Notation additive f := (axiom f). +Coercion apply : map >-> Funclass. +Notation Additive fA := (Pack (Phant _) fA). +Notation "{ 'additive' fUV }" := (map (Phant fUV)) + (at level 0, format "{ 'additive' fUV }") : ring_scope. +Notation "[ 'additive' 'of' f 'as' g ]" := (@clone _ _ _ f g _ _ idfun id) + (at level 0, format "[ 'additive' 'of' f 'as' g ]") : form_scope. +Notation "[ 'additive' 'of' f ]" := (@clone _ _ _ f f _ _ id id) + (at level 0, format "[ 'additive' 'of' f ]") : form_scope. +End Exports. + +End Additive. +Include Additive.Exports. (* Allows GRing.additive to resolve conflicts. *) + +(* Lifted additive operations. *) +Section LiftedZmod. +Variables (U : Type) (V : zmodType). +Definition null_fun_head (phV : phant V) of U : V := let: Phant := phV in 0. +Definition add_fun_head t (f g : U -> V) x := let: tt := t in f x + g x. +Definition sub_fun_head t (f g : U -> V) x := let: tt := t in f x - g x. +End LiftedZmod. + +(* Lifted multiplication. *) +Section LiftedRing. +Variables (R : ringType) (T : Type). +Implicit Type f : T -> R. +Definition mull_fun_head t a f x := let: tt := t in a * f x. +Definition mulr_fun_head t a f x := let: tt := t in f x * a. +End LiftedRing. + +(* Lifted linear operations. *) +Section LiftedScale. +Variables (R : ringType) (U : Type) (V : lmodType R) (A : lalgType R). +Definition scale_fun_head t a (f : U -> V) x := let: tt := t in a *: f x. +Definition in_alg_head (phA : phant A) k : A := let: Phant := phA in k%:A. +End LiftedScale. + +Notation null_fun V := (null_fun_head (Phant V)) (only parsing). +(* The real in_alg notation is declared after GRing.Theory so that at least *) +(* in Coq 8.2 it gets precedence when GRing.Theory is not imported. *) +Local Notation in_alg_loc A := (in_alg_head (Phant A)) (only parsing). + +Local Notation "\0" := (null_fun _) : ring_scope. +Local Notation "f \+ g" := (add_fun_head tt f g) : ring_scope. +Local Notation "f \- g" := (sub_fun_head tt f g) : ring_scope. +Local Notation "a \*: f" := (scale_fun_head tt a f) : ring_scope. +Local Notation "x \*o f" := (mull_fun_head tt x f) : ring_scope. +Local Notation "x \o* f" := (mulr_fun_head tt x f) : ring_scope. + +Section AdditiveTheory. + +Section Properties. + +Variables (U V : zmodType) (k : unit) (f : {additive U -> V}). + +Lemma raddfB : {morph f : x y / x - y}. Proof. exact: Additive.class. Qed. + +Lemma raddf0 : f 0 = 0. +Proof. by rewrite -[0]subr0 raddfB subrr. Qed. + +Lemma raddf_eq0 x : injective f -> (f x == 0) = (x == 0). +Proof. by move=> /inj_eq <-; rewrite raddf0. Qed. + +Lemma raddfN : {morph f : x / - x}. +Proof. by move=> x /=; rewrite -sub0r raddfB raddf0 sub0r. Qed. + +Lemma raddfD : {morph f : x y / x + y}. +Proof. by move=> x y; rewrite -[y]opprK raddfB -raddfN. Qed. + +Lemma raddfMn n : {morph f : x / x *+ n}. +Proof. by elim: n => [|n IHn] x /=; rewrite ?raddf0 // !mulrS raddfD IHn. Qed. + +Lemma raddfMNn n : {morph f : x / x *- n}. +Proof. by move=> x /=; rewrite raddfN raddfMn. Qed. + +Lemma raddf_sum I r (P : pred I) E : + f (\sum_(i <- r | P i) E i) = \sum_(i <- r | P i) f (E i). +Proof. exact: (big_morph f raddfD raddf0). Qed. + +Lemma can2_additive f' : cancel f f' -> cancel f' f -> additive f'. +Proof. by move=> fK f'K x y /=; apply: (canLR fK); rewrite raddfB !f'K. Qed. + +Lemma bij_additive : + bijective f -> exists2 f' : {additive V -> U}, cancel f f' & cancel f' f. +Proof. by case=> f' fK f'K; exists (Additive (can2_additive fK f'K)). Qed. + +Fact locked_is_additive : additive (locked_with k (f : U -> V)). +Proof. by case: k f => [] []. Qed. +Canonical locked_additive := Additive locked_is_additive. + +End Properties. + +Section RingProperties. + +Variables (R S : ringType) (f : {additive R -> S}). + +Lemma raddfMnat n x : f (n%:R * x) = n%:R * f x. +Proof. by rewrite !mulr_natl raddfMn. Qed. + +Lemma raddfMsign n x : f ((-1) ^+ n * x) = (-1) ^+ n * f x. +Proof. by rewrite !(mulr_sign, =^~ signr_odd) (fun_if f) raddfN. Qed. + +Variables (U : lmodType R) (V : lmodType S) (h : {additive U -> V}). + +Lemma raddfZnat n u : h (n%:R *: u) = n%:R *: h u. +Proof. by rewrite !scaler_nat raddfMn. Qed. + +Lemma raddfZsign n u : h ((-1) ^+ n *: u) = (-1) ^+ n *: h u. +Proof. by rewrite !(scaler_sign, =^~ signr_odd) (fun_if h) raddfN. Qed. + +End RingProperties. + +Section AddFun. + +Variables (U V W : zmodType) (f g : {additive V -> W}) (h : {additive U -> V}). + +Fact idfun_is_additive : additive (@idfun U). +Proof. by []. Qed. +Canonical idfun_additive := Additive idfun_is_additive. + +Fact comp_is_additive : additive (f \o h). +Proof. by move=> x y /=; rewrite !raddfB. Qed. +Canonical comp_additive := Additive comp_is_additive. + +Fact opp_is_additive : additive (-%R : U -> U). +Proof. by move=> x y; rewrite /= opprD. Qed. +Canonical opp_additive := Additive opp_is_additive. + +Fact null_fun_is_additive : additive (\0 : U -> V). +Proof. by move=> /=; rewrite subr0. Qed. +Canonical null_fun_additive := Additive null_fun_is_additive. + +Fact add_fun_is_additive : additive (f \+ g). +Proof. +by move=> x y /=; rewrite !raddfB addrCA -!addrA addrCA -opprD. +Qed. +Canonical add_fun_additive := Additive add_fun_is_additive. + +Fact sub_fun_is_additive : additive (f \- g). +Proof. +by move=> x y /=; rewrite !raddfB addrAC -!addrA -!opprD addrAC addrA. +Qed. +Canonical sub_fun_additive := Additive sub_fun_is_additive. + +End AddFun. + +Section MulFun. + +Variables (R : ringType) (U : zmodType). +Variables (a : R) (f : {additive U -> R}). + +Fact mull_fun_is_additive : additive (a \*o f). +Proof. by move=> x y /=; rewrite raddfB mulrBr. Qed. +Canonical mull_fun_additive := Additive mull_fun_is_additive. + +Fact mulr_fun_is_additive : additive (a \o* f). +Proof. by move=> x y /=; rewrite raddfB mulrBl. Qed. +Canonical mulr_fun_additive := Additive mulr_fun_is_additive. + +End MulFun. + +Section ScaleFun. + +Variables (R : ringType) (U : zmodType) (V : lmodType R). +Variables (a : R) (f : {additive U -> V}). + +Canonical scale_additive := Additive (@scalerBr R V a). +Canonical scale_fun_additive := [additive of a \*: f as f \; *:%R a]. + +End ScaleFun. + +End AdditiveTheory. + +Module RMorphism. + +Section ClassDef. + +Variables R S : ringType. + +Definition mixin_of (f : R -> S) := + {morph f : x y / x * y}%R * (f 1 = 1) : Prop. + +Record class_of f : Prop := Class {base : additive f; mixin : mixin_of f}. +Local Coercion base : class_of >-> additive. + +Structure map (phRS : phant (R -> S)) := Pack {apply; _ : class_of apply}. +Local Coercion apply : map >-> Funclass. +Variables (phRS : phant (R -> S)) (f g : R -> S) (cF : map phRS). + +Definition class := let: Pack _ c as cF' := cF return class_of cF' in c. + +Definition clone fM of phant_id g (apply cF) & phant_id fM class := + @Pack phRS f fM. + +Definition pack (fM : mixin_of f) := + fun (bF : Additive.map phRS) fA & phant_id (Additive.class bF) fA => + Pack phRS (Class fA fM). + +Canonical additive := Additive.Pack phRS class. + +End ClassDef. + +Module Exports. +Notation multiplicative f := (mixin_of f). +Notation rmorphism f := (class_of f). +Coercion base : rmorphism >-> Additive.axiom. +Coercion mixin : rmorphism >-> multiplicative. +Coercion apply : map >-> Funclass. +Notation RMorphism fM := (Pack (Phant _) fM). +Notation AddRMorphism fM := (pack fM id). +Notation "{ 'rmorphism' fRS }" := (map (Phant fRS)) + (at level 0, format "{ 'rmorphism' fRS }") : ring_scope. +Notation "[ 'rmorphism' 'of' f 'as' g ]" := (@clone _ _ _ f g _ _ idfun id) + (at level 0, format "[ 'rmorphism' 'of' f 'as' g ]") : form_scope. +Notation "[ 'rmorphism' 'of' f ]" := (@clone _ _ _ f f _ _ id id) + (at level 0, format "[ 'rmorphism' 'of' f ]") : form_scope. +Coercion additive : map >-> Additive.map. +Canonical additive. +End Exports. + +End RMorphism. +Include RMorphism.Exports. + +Section RmorphismTheory. + +Section Properties. + +Variables (R S : ringType) (k : unit) (f : {rmorphism R -> S}). + +Lemma rmorph0 : f 0 = 0. Proof. exact: raddf0. Qed. +Lemma rmorphN : {morph f : x / - x}. Proof. exact: raddfN. Qed. +Lemma rmorphD : {morph f : x y / x + y}. Proof. exact: raddfD. Qed. +Lemma rmorphB : {morph f: x y / x - y}. Proof. exact: raddfB. Qed. +Lemma rmorphMn n : {morph f : x / x *+ n}. Proof. exact: raddfMn. Qed. +Lemma rmorphMNn n : {morph f : x / x *- n}. Proof. exact: raddfMNn. Qed. +Lemma rmorph_sum I r (P : pred I) E : + f (\sum_(i <- r | P i) E i) = \sum_(i <- r | P i) f (E i). +Proof. exact: raddf_sum. Qed. +Lemma rmorphMsign n : {morph f : x / (- 1) ^+ n * x}. +Proof. exact: raddfMsign. Qed. + +Lemma rmorphismP : rmorphism f. Proof. exact: RMorphism.class. Qed. +Lemma rmorphismMP : multiplicative f. Proof. exact: rmorphismP. Qed. +Lemma rmorph1 : f 1 = 1. Proof. by case: rmorphismMP. Qed. +Lemma rmorphM : {morph f: x y / x * y}. Proof. by case: rmorphismMP. Qed. + +Lemma rmorph_prod I r (P : pred I) E : + f (\prod_(i <- r | P i) E i) = \prod_(i <- r | P i) f (E i). +Proof. exact: (big_morph f rmorphM rmorph1). Qed. + +Lemma rmorphX n : {morph f: x / x ^+ n}. +Proof. by elim: n => [|n IHn] x; rewrite ?rmorph1 // !exprS rmorphM IHn. Qed. + +Lemma rmorph_nat n : f n%:R = n%:R. Proof. by rewrite rmorphMn rmorph1. Qed. +Lemma rmorphN1 : f (- 1) = (- 1). Proof. by rewrite rmorphN rmorph1. Qed. + +Lemma rmorph_sign n : f ((- 1) ^+ n) = (- 1) ^+ n. +Proof. by rewrite rmorphX rmorphN1. Qed. + +Lemma rmorph_char p : p \in [char R] -> p \in [char S]. +Proof. by rewrite !inE -rmorph_nat => /andP[-> /= /eqP->]; rewrite rmorph0. Qed. + +Lemma rmorph_eq_nat x n : injective f -> (f x == n%:R) = (x == n%:R). +Proof. by move/inj_eq <-; rewrite rmorph_nat. Qed. + +Lemma rmorph_eq1 x : injective f -> (f x == 1) = (x == 1). +Proof. exact: rmorph_eq_nat 1%N. Qed. + +Lemma can2_rmorphism f' : cancel f f' -> cancel f' f -> rmorphism f'. +Proof. +move=> fK f'K; split; first exact: can2_additive fK f'K. +by split=> [x y|]; apply: (canLR fK); rewrite /= (rmorphM, rmorph1) ?f'K. +Qed. + +Lemma bij_rmorphism : + bijective f -> exists2 f' : {rmorphism S -> R}, cancel f f' & cancel f' f. +Proof. by case=> f' fK f'K; exists (RMorphism (can2_rmorphism fK f'K)). Qed. + +Fact locked_is_multiplicative : multiplicative (locked_with k (f : R -> S)). +Proof. by case: k f => [] [? []]. Qed. +Canonical locked_rmorphism := AddRMorphism locked_is_multiplicative. + +End Properties. + +Section Projections. + +Variables (R S T : ringType) (f : {rmorphism S -> T}) (g : {rmorphism R -> S}). + +Fact idfun_is_multiplicative : multiplicative (@idfun R). +Proof. by []. Qed. +Canonical idfun_rmorphism := AddRMorphism idfun_is_multiplicative. + +Fact comp_is_multiplicative : multiplicative (f \o g). +Proof. by split=> [x y|] /=; rewrite ?rmorph1 ?rmorphM. Qed. +Canonical comp_rmorphism := AddRMorphism comp_is_multiplicative. + +End Projections. + +Section InAlgebra. + +Variables (R : ringType) (A : lalgType R). + +Fact in_alg_is_rmorphism : rmorphism (in_alg_loc A). +Proof. +split=> [x y|]; first exact: scalerBl. +by split=> [x y|] /=; rewrite ?scale1r // -scalerAl mul1r scalerA. +Qed. +Canonical in_alg_additive := Additive in_alg_is_rmorphism. +Canonical in_alg_rmorphism := RMorphism in_alg_is_rmorphism. + +Lemma in_algE a : in_alg_loc A a = a%:A. Proof. by []. Qed. + +End InAlgebra. + +End RmorphismTheory. + +Module Scale. + +Section ScaleLaw. + +Structure law (R : ringType) (V : zmodType) (s : R -> V -> V) := Law { + op : R -> V -> V; + _ : op = s; + _ : op (-1) =1 -%R; + _ : forall a, additive (op a) +}. + +Definition mul_law R := Law (erefl *%R) (@mulN1r R) (@mulrBr R). +Definition scale_law R U := Law (erefl *:%R) (@scaleN1r R U) (@scalerBr R U). + +Variables (R : ringType) (V : zmodType) (s : R -> V -> V) (s_law : law s). +Local Notation s_op := (op s_law). + +Lemma opE : s_op = s. Proof. by case: s_law. Qed. +Lemma N1op : s_op (-1) =1 -%R. Proof. by case: s_law. Qed. +Fact opB a : additive (s_op a). Proof. by case: s_law. Qed. +Definition op_additive a := Additive (opB a). + +Variables (aR : ringType) (nu : {rmorphism aR -> R}). +Fact comp_opE : nu \; s_op = nu \; s. Proof. exact: congr1 opE. Qed. +Fact compN1op : (nu \; s_op) (-1) =1 -%R. +Proof. by move=> v; rewrite /= rmorphN1 N1op. Qed. +Definition comp_law : law (nu \; s) := Law comp_opE compN1op (fun a => opB _). + +End ScaleLaw. + +End Scale. + +Module Linear. + +Section ClassDef. + +Variables (R : ringType) (U : lmodType R) (V : zmodType) (s : R -> V -> V). +Implicit Type phUV : phant (U -> V). + +Local Coercion Scale.op : Scale.law >-> Funclass. +Definition axiom (f : U -> V) (s_law : Scale.law s) of s = s_law := + forall a, {morph f : u v / a *: u + v >-> s a u + v}. +Definition mixin_of (f : U -> V) := + forall a, {morph f : v / a *: v >-> s a v}. + +Record class_of f : Prop := Class {base : additive f; mixin : mixin_of f}. +Local Coercion base : class_of >-> additive. + +Lemma class_of_axiom f s_law Ds : @axiom f s_law Ds -> class_of f. +Proof. +move=> fL; have fB: additive f. + by move=> x y /=; rewrite -scaleN1r addrC fL Ds Scale.N1op addrC. +by split=> // a v /=; rewrite -[a *: v](addrK v) fB fL addrK Ds. +Qed. + +Structure map (phUV : phant (U -> V)) := Pack {apply; _ : class_of apply}. +Local Coercion apply : map >-> Funclass. + +Variables (phUV : phant (U -> V)) (f g : U -> V) (cF : map phUV). +Definition class := let: Pack _ c as cF' := cF return class_of cF' in c. +Definition clone fL of phant_id g (apply cF) & phant_id fL class := + @Pack phUV f fL. + +Definition pack (fZ : mixin_of f) := + fun (bF : Additive.map phUV) fA & phant_id (Additive.class bF) fA => + Pack phUV (Class fA fZ). + +Canonical additive := Additive.Pack phUV class. + +(* Support for right-to-left rewriting with the generic linearZ rule. *) +Notation mapUV := (map (Phant (U -> V))). +Definition map_class := mapUV. +Definition map_at (a : R) := mapUV. +Structure map_for a s_a := MapFor {map_for_map : mapUV; _ : s a = s_a}. +Definition unify_map_at a (f : map_at a) := MapFor f (erefl (s a)). +Structure wrapped := Wrap {unwrap : mapUV}. +Definition wrap (f : map_class) := Wrap f. + +End ClassDef. + +Module Exports. +Canonical Scale.mul_law. +Canonical Scale.scale_law. +Canonical Scale.comp_law. +Canonical Scale.op_additive. +Delimit Scope linear_ring_scope with linR. +Notation "a *: u" := (@Scale.op _ _ *:%R _ a u) : linear_ring_scope. +Notation "a * u" := (@Scale.op _ _ *%R _ a u) : linear_ring_scope. +Notation "a *:^ nu u" := (@Scale.op _ _ (nu \; *:%R) _ a u) + (at level 40, nu at level 1, format "a *:^ nu u") : linear_ring_scope. +Notation "a *^ nu u" := (@Scale.op _ _ (nu \; *%R) _ a u) + (at level 40, nu at level 1, format "a *^ nu u") : linear_ring_scope. +Notation scalable_for s f := (mixin_of s f). +Notation scalable f := (scalable_for *:%R f). +Notation linear_for s f := (axiom f (erefl s)). +Notation linear f := (linear_for *:%R f). +Notation scalar f := (linear_for *%R f). +Notation lmorphism_for s f := (class_of s f). +Notation lmorphism f := (lmorphism_for *:%R f). +Coercion class_of_axiom : axiom >-> lmorphism_for. +Coercion base : lmorphism_for >-> Additive.axiom. +Coercion mixin : lmorphism_for >-> scalable. +Coercion apply : map >-> Funclass. +Notation Linear fL := (Pack (Phant _) fL). +Notation AddLinear fZ := (pack fZ id). +Notation "{ 'linear' fUV | s }" := (map s (Phant fUV)) + (at level 0, format "{ 'linear' fUV | s }") : ring_scope. +Notation "{ 'linear' fUV }" := {linear fUV | *:%R} + (at level 0, format "{ 'linear' fUV }") : ring_scope. +Notation "{ 'scalar' U }" := {linear U -> _ | *%R} + (at level 0, format "{ 'scalar' U }") : ring_scope. +Notation "[ 'linear' 'of' f 'as' g ]" := (@clone _ _ _ _ _ f g _ _ idfun id) + (at level 0, format "[ 'linear' 'of' f 'as' g ]") : form_scope. +Notation "[ 'linear' 'of' f ]" := (@clone _ _ _ _ _ f f _ _ id id) + (at level 0, format "[ 'linear' 'of' f ]") : form_scope. +Coercion additive : map >-> Additive.map. +Canonical additive. +(* Support for right-to-left rewriting with the generic linearZ rule. *) +Coercion map_for_map : map_for >-> map. +Coercion unify_map_at : map_at >-> map_for. +Canonical unify_map_at. +Coercion unwrap : wrapped >-> map. +Coercion wrap : map_class >-> wrapped. +Canonical wrap. +End Exports. + +End Linear. +Include Linear.Exports. + +Section LinearTheory. + +Variable R : ringType. + +Section GenericProperties. + +Variables (U : lmodType R) (V : zmodType) (s : R -> V -> V) (k : unit). +Variable f : {linear U -> V | s}. + +Lemma linear0 : f 0 = 0. Proof. exact: raddf0. Qed. +Lemma linearN : {morph f : x / - x}. Proof. exact: raddfN. Qed. +Lemma linearD : {morph f : x y / x + y}. Proof. exact: raddfD. Qed. +Lemma linearB : {morph f : x y / x - y}. Proof. exact: raddfB. Qed. +Lemma linearMn n : {morph f : x / x *+ n}. Proof. exact: raddfMn. Qed. +Lemma linearMNn n : {morph f : x / x *- n}. Proof. exact: raddfMNn. Qed. +Lemma linear_sum I r (P : pred I) E : + f (\sum_(i <- r | P i) E i) = \sum_(i <- r | P i) f (E i). +Proof. exact: raddf_sum. Qed. + +Lemma linearZ_LR : scalable_for s f. Proof. by case: f => ? []. Qed. +Lemma linearP a : {morph f : u v / a *: u + v >-> s a u + v}. +Proof. by move=> u v /=; rewrite linearD linearZ_LR. Qed. + +Fact locked_is_scalable : scalable_for s (locked_with k (f : U -> V)). +Proof. by case: k f => [] [? []]. Qed. +Canonical locked_linear := AddLinear locked_is_scalable. + +End GenericProperties. + +Section BidirectionalLinearZ. + +Variables (U : lmodType R) (V : zmodType) (s : R -> V -> V). + +(* The general form of the linearZ lemma uses some bespoke interfaces to *) +(* allow right-to-left rewriting when a composite scaling operation such as *) +(* conjC \; *%R has been expanded, say in a^* * f u. This redex is matched *) +(* by using the Scale.law interface to recognize a "head" scaling operation *) +(* h (here *%R), stow away its "scalar" c, then reconcile h c and s a, once *) +(* s is known, that is, once the Linear.map structure for f has been found. *) +(* In general, s and a need not be equal to h and c; indeed they need not *) +(* have the same type! The unification is performed by the unify_map_at *) +(* default instance for the Linear.map_for U s a h_c sub-interface of *) +(* Linear.map; the h_c pattern uses the Scale.law structure to insure it is *) +(* inferred when rewriting right-to-left. *) +(* The wrap on the rhs allows rewriting f (a *: b *: u) into a *: b *: f u *) +(* with rewrite !linearZ /= instead of rewrite linearZ /= linearZ /=. *) +(* Without it, the first rewrite linearZ would produce *) +(* (a *: apply (map_for_map (@check_map_at .. a f)) (b *: u)%R)%Rlin *) +(* and matching the second rewrite LHS would bypass the unify_map_at default *) +(* instance for b, reuse the one for a, and subsequently fail to match the *) +(* b *: u argument. The extra wrap / unwrap ensures that this can't happen. *) +(* In the RL direction, the wrap / unwrap will be inserted on the redex side *) +(* as needed, without causing unnecessary delta-expansion: using an explicit *) +(* identity function would have Coq normalize the redex to head normal, then *) +(* reduce the identity to expose the map_for_map projection, and the *) +(* expanded Linear.map structure would then be exposed in the result. *) +(* Most of this machinery will be invisible to a casual user, because all *) +(* the projections and default instances involved are declared as coercions. *) + +Variables (S : ringType) (h : S -> V -> V) (h_law : Scale.law h). + +Lemma linearZ c a (h_c := Scale.op h_law c) (f : Linear.map_for U s a h_c) u : + f (a *: u) = h_c (Linear.wrap f u). +Proof. by rewrite linearZ_LR; case: f => f /= ->. Qed. + +End BidirectionalLinearZ. + +Section LmodProperties. + +Variables (U V : lmodType R) (f : {linear U -> V}). + +Lemma linearZZ : scalable f. Proof. exact: linearZ_LR. Qed. +Lemma linearPZ : linear f. Proof. exact: linearP. Qed. + +Lemma can2_linear f' : cancel f f' -> cancel f' f -> linear f'. +Proof. by move=> fK f'K a x y /=; apply: (canLR fK); rewrite linearP !f'K. Qed. + +Lemma bij_linear : + bijective f -> exists2 f' : {linear V -> U}, cancel f f' & cancel f' f. +Proof. by case=> f' fK f'K; exists (Linear (can2_linear fK f'K)). Qed. + +End LmodProperties. + +Section ScalarProperties. + +Variable (U : lmodType R) (f : {scalar U}). + +Lemma scalarZ : scalable_for *%R f. Proof. exact: linearZ_LR. Qed. +Lemma scalarP : scalar f. Proof. exact: linearP. Qed. + +End ScalarProperties. + +Section LinearLmod. + +Variables (W U : lmodType R) (V : zmodType) (s : R -> V -> V). +Variables (f : {linear U -> V | s}) (h : {linear W -> U}). + +Lemma idfun_is_scalable : scalable (@idfun U). Proof. by []. Qed. +Canonical idfun_linear := AddLinear idfun_is_scalable. + +Lemma opp_is_scalable : scalable (-%R : U -> U). +Proof. by move=> a v /=; rewrite scalerN. Qed. +Canonical opp_linear := AddLinear opp_is_scalable. + +Lemma comp_is_scalable : scalable_for s (f \o h). +Proof. by move=> a v /=; rewrite !linearZ_LR. Qed. +Canonical comp_linear := AddLinear comp_is_scalable. + +Variables (s_law : Scale.law s) (g : {linear U -> V | Scale.op s_law}). +Let Ds : s =1 Scale.op s_law. Proof. by rewrite Scale.opE. Qed. + +Lemma null_fun_is_scalable : scalable_for (Scale.op s_law) (\0 : U -> V). +Proof. by move=> a v /=; rewrite raddf0. Qed. +Canonical null_fun_linear := AddLinear null_fun_is_scalable. + +Lemma add_fun_is_scalable : scalable_for s (f \+ g). +Proof. by move=> a u; rewrite /= !linearZ_LR !Ds raddfD. Qed. +Canonical add_fun_linear := AddLinear add_fun_is_scalable. + +Lemma sub_fun_is_scalable : scalable_for s (f \- g). +Proof. by move=> a u; rewrite /= !linearZ_LR !Ds raddfB. Qed. +Canonical sub_fun_linear := AddLinear sub_fun_is_scalable. + +End LinearLmod. + +Section LinearLalg. + +Variables (A : lalgType R) (U : lmodType R). + +Variables (a : A) (f : {linear U -> A}). + +Fact mulr_fun_is_scalable : scalable (a \o* f). +Proof. by move=> k x /=; rewrite linearZ scalerAl. Qed. +Canonical mulr_fun_linear := AddLinear mulr_fun_is_scalable. + +End LinearLalg. + +End LinearTheory. + +Module LRMorphism. + +Section ClassDef. + +Variables (R : ringType) (A : lalgType R) (B : ringType) (s : R -> B -> B). + +Record class_of (f : A -> B) : Prop := + Class {base : rmorphism f; mixin : scalable_for s f}. +Local Coercion base : class_of >-> rmorphism. +Definition base2 f (fLM : class_of f) := Linear.Class fLM (mixin fLM). +Local Coercion base2 : class_of >-> lmorphism. + +Structure map (phAB : phant (A -> B)) := Pack {apply; _ : class_of apply}. +Local Coercion apply : map >-> Funclass. + +Variables (phAB : phant (A -> B)) (f : A -> B) (cF : map phAB). +Definition class := let: Pack _ c as cF' := cF return class_of cF' in c. + +Definition clone := + fun (g : RMorphism.map phAB) fM & phant_id (RMorphism.class g) fM => + fun (h : Linear.map s phAB) fZ & + phant_id (Linear.mixin (Linear.class h)) fZ => + Pack phAB (@Class f fM fZ). + +Definition pack (fZ : scalable_for s f) := + fun (g : RMorphism.map phAB) fM & phant_id (RMorphism.class g) fM => + Pack phAB (Class fM fZ). + +Canonical additive := Additive.Pack phAB class. +Canonical rmorphism := RMorphism.Pack phAB class. +Canonical linear := Linear.Pack phAB class. +Canonical join_rmorphism := @RMorphism.Pack _ _ phAB linear class. +Canonical join_linear := @Linear.Pack R A B s phAB rmorphism class. + +End ClassDef. + +Module Exports. +Notation lrmorphism_for s f := (class_of s f). +Notation lrmorphism f := (lrmorphism_for *:%R f). +Coercion base : lrmorphism_for >-> RMorphism.class_of. +Coercion base2 : lrmorphism_for >-> lmorphism_for. +Coercion apply : map >-> Funclass. +Notation LRMorphism f_lrM := (Pack (Phant _) (Class f_lrM f_lrM)). +Notation AddLRMorphism fZ := (pack fZ id). +Notation "{ 'lrmorphism' fAB | s }" := (map s (Phant fAB)) + (at level 0, format "{ 'lrmorphism' fAB | s }") : ring_scope. +Notation "{ 'lrmorphism' fAB }" := {lrmorphism fAB | *:%R} + (at level 0, format "{ 'lrmorphism' fAB }") : ring_scope. +Notation "[ 'lrmorphism' 'of' f ]" := (@clone _ _ _ _ _ f _ _ id _ _ id) + (at level 0, format "[ 'lrmorphism' 'of' f ]") : form_scope. +Coercion additive : map >-> Additive.map. +Canonical additive. +Coercion rmorphism : map >-> RMorphism.map. +Canonical rmorphism. +Coercion linear : map >-> Linear.map. +Canonical linear. +Canonical join_rmorphism. +Canonical join_linear. +End Exports. + +End LRMorphism. +Include LRMorphism.Exports. + +Section LRMorphismTheory. + +Variables (R : ringType) (A B : lalgType R) (C : ringType) (s : R -> C -> C). +Variables (k : unit) (f : {lrmorphism A -> B}) (g : {lrmorphism B -> C | s}). + +Definition idfun_lrmorphism := [lrmorphism of @idfun A]. +Definition comp_lrmorphism := [lrmorphism of g \o f]. +Definition locked_lrmorphism := [lrmorphism of locked_with k (f : A -> B)]. + +Lemma rmorph_alg a : f a%:A = a%:A. +Proof. by rewrite linearZ rmorph1. Qed. + +Lemma lrmorphismP : lrmorphism f. Proof. exact: LRMorphism.class. Qed. + +Lemma can2_lrmorphism f' : cancel f f' -> cancel f' f -> lrmorphism f'. +Proof. +move=> fK f'K; split; [exact: (can2_rmorphism fK) | exact: (can2_linear fK)]. +Qed. + +Lemma bij_lrmorphism : + bijective f -> exists2 f' : {lrmorphism B -> A}, cancel f f' & cancel f' f. +Proof. +by case/bij_rmorphism=> f' fK f'K; exists (AddLRMorphism (can2_linear fK f'K)). +Qed. + +End LRMorphismTheory. + +Module ComRing. + +Definition RingMixin R one mul mulA mulC mul1x mul_addl := + let mulx1 := Monoid.mulC_id mulC mul1x in + let mul_addr := Monoid.mulC_dist mulC mul_addl in + @Ring.EtaMixin R one mul mulA mul1x mulx1 mul_addl mul_addr. + +Section ClassDef. + +Record class_of R := + Class {base : Ring.class_of R; mixin : commutative (Ring.mul base)}. +Local Coercion base : class_of >-> Ring.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variable (T : Type) (cT : type). +Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c. +Definition clone c of phant_id class c := @Pack T c T. +Let xT := let: Pack T _ _ := cT in T. +Notation xclass := (class : class_of xT). + +Definition pack mul0 (m0 : @commutative T T mul0) := + fun bT b & phant_id (Ring.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 := @Zmodule.Pack cT xclass xT. +Definition ringType := @Ring.Pack cT xclass xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> Ring.class_of. +Implicit Arguments mixin [R]. +Coercion mixin : class_of >-> commutative. +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 >-> Zmodule.type. +Canonical zmodType. +Coercion ringType : type >-> Ring.type. +Canonical ringType. +Notation comRingType := type. +Notation ComRingType T m := (@pack T _ m _ _ id _ id). +Notation ComRingMixin := RingMixin. +Notation "[ 'comRingType' 'of' T 'for' cT ]" := (@clone T cT _ idfun) + (at level 0, format "[ 'comRingType' 'of' T 'for' cT ]") : form_scope. +Notation "[ 'comRingType' 'of' T ]" := (@clone T _ _ id) + (at level 0, format "[ 'comRingType' 'of' T ]") : form_scope. +End Exports. + +End ComRing. +Import ComRing.Exports. + +Section ComRingTheory. + +Variable R : comRingType. +Implicit Types x y : R. + +Lemma mulrC : @commutative R R *%R. Proof. by case: R => T []. Qed. +Canonical mul_comoid := Monoid.ComLaw mulrC. +Lemma mulrCA : @left_commutative R R *%R. Proof. exact: mulmCA. Qed. +Lemma mulrAC : @right_commutative R R *%R. Proof. exact: mulmAC. Qed. +Lemma mulrACA : @interchange R *%R *%R. Proof. exact: mulmACA. Qed. + +Lemma exprMn n : {morph (fun x => x ^+ n) : x y / x * y}. +Proof. move=> x y; apply: exprMn_comm; exact: mulrC. Qed. + +Lemma prodrXl n I r (P : pred I) (F : I -> R) : + \prod_(i <- r | P i) F i ^+ n = (\prod_(i <- r | P i) F i) ^+ n. +Proof. by rewrite (big_morph _ (exprMn n) (expr1n _ n)). Qed. + +Lemma prodr_undup_exp_count (I : eqType) r (P : pred I) (F : I -> R) : + \prod_(i <- undup r | P i) F i ^+ count_mem i r = \prod_(i <- r | P i) F i. +Proof. exact: big_undup_iterop_count. Qed. + +Lemma exprDn x y n : + (x + y) ^+ n = \sum_(i < n.+1) (x ^+ (n - i) * y ^+ i) *+ 'C(n, i). +Proof. by rewrite exprDn_comm //; exact: mulrC. Qed. + +Lemma exprBn x y n : + (x - y) ^+ n = + \sum_(i < n.+1) ((-1) ^+ i * x ^+ (n - i) * y ^+ i) *+ 'C(n, i). +Proof. by rewrite exprBn_comm //; exact: mulrC. Qed. + +Lemma subrXX x y n : + x ^+ n - y ^+ n = (x - y) * (\sum_(i < n) x ^+ (n.-1 - i) * y ^+ i). +Proof. by rewrite -subrXX_comm //; exact: mulrC. Qed. + +Lemma sqrrD x y : (x + y) ^+ 2 = x ^+ 2 + x * y *+ 2 + y ^+ 2. +Proof. by rewrite exprDn !big_ord_recr big_ord0 /= add0r mulr1 mul1r. Qed. + +Lemma sqrrB x y : (x - y) ^+ 2 = x ^+ 2 - x * y *+ 2 + y ^+ 2. +Proof. by rewrite sqrrD mulrN mulNrn sqrrN. Qed. + +Lemma subr_sqr x y : x ^+ 2 - y ^+ 2 = (x - y) * (x + y). +Proof. by rewrite subrXX !big_ord_recr big_ord0 /= add0r mulr1 mul1r. Qed. + +Lemma subr_sqrDB x y : (x + y) ^+ 2 - (x - y) ^+ 2 = x * y *+ 4. +Proof. +rewrite sqrrD sqrrB -!(addrAC _ (y ^+ 2)) opprB. +by rewrite addrC addrA subrK -mulrnDr. +Qed. + +Section FrobeniusAutomorphism. + +Variables (p : nat) (charRp : p \in [char R]). + +Lemma Frobenius_aut_is_rmorphism : rmorphism (Frobenius_aut charRp). +Proof. +split=> [x y|]; first exact: Frobenius_autB_comm (mulrC _ _). +split=> [x y|]; first exact: Frobenius_autM_comm (mulrC _ _). +exact: Frobenius_aut1. +Qed. + +Canonical Frobenius_aut_additive := Additive Frobenius_aut_is_rmorphism. +Canonical Frobenius_aut_rmorphism := RMorphism Frobenius_aut_is_rmorphism. + +End FrobeniusAutomorphism. + +Lemma exprDn_char x y n : [char R].-nat n -> (x + y) ^+ n = x ^+ n + y ^+ n. +Proof. +pose p := pdiv n; have [|n_gt1 charRn] := leqP n 1; first by case: (n) => [|[]]. +have charRp: p \in [char R] by rewrite (pnatPpi charRn) ?pi_pdiv. +have{charRn} /p_natP[e ->]: p.-nat n by rewrite -(eq_pnat _ (charf_eq charRp)). +by elim: e => // e IHe; rewrite !expnSr !exprM IHe -Frobenius_autE rmorphD. +Qed. + +Lemma rmorph_comm (S : ringType) (f : {rmorphism R -> S}) x y : + comm (f x) (f y). +Proof. by red; rewrite -!rmorphM mulrC. Qed. + +Section ScaleLinear. + +Variables (U V : lmodType R) (b : R) (f : {linear U -> V}). + +Lemma scale_is_scalable : scalable ( *:%R b : V -> V). +Proof. by move=> a v /=; rewrite !scalerA mulrC. Qed. +Canonical scale_linear := AddLinear scale_is_scalable. + +Lemma scale_fun_is_scalable : scalable (b \*: f). +Proof. by move=> a v /=; rewrite !linearZ. Qed. +Canonical scale_fun_linear := AddLinear scale_fun_is_scalable. + +End ScaleLinear. + +End ComRingTheory. + +Module Algebra. + +Section Mixin. + +Variables (R : ringType) (A : lalgType R). + +Definition axiom := forall k (x y : A), k *: (x * y) = x * (k *: y). + +Lemma comm_axiom : phant A -> commutative (@mul A) -> axiom. +Proof. by move=> _ commA k x y; rewrite commA scalerAl commA. Qed. + +End Mixin. + +Section ClassDef. + +Variable R : ringType. + +Record class_of (T : Type) : Type := Class { + base : Lalgebra.class_of R T; + mixin : axiom (Lalgebra.Pack _ base T) +}. +Local Coercion base : class_of >-> Lalgebra.class_of. + +Structure type (phR : phant R) := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variable (phR : phant R) (T : Type) (cT : type phR). +Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c. +Definition clone c of phant_id class c := @Pack phR T c T. +Let xT := let: Pack T _ _ := cT in T. +Notation xclass := (class : class_of xT). + +Definition pack b0 (ax0 : @axiom R b0) := + fun bT b & phant_id (@Lalgebra.class R phR bT) b => + fun ax & phant_id ax0 ax => Pack phR (@Class T b ax) T. + +Definition eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition zmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @Ring.Pack cT xclass xT. +Definition lmodType := @Lmodule.Pack R phR cT xclass xT. +Definition lalgType := @Lalgebra.Pack R phR cT xclass xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> Lalgebra.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 >-> Zmodule.type. +Canonical zmodType. +Coercion ringType : type >-> Ring.type. +Canonical ringType. +Coercion lmodType : type >-> Lmodule.type. +Canonical lmodType. +Coercion lalgType : type >-> Lalgebra.type. +Canonical lalgType. +Notation algType R := (type (Phant R)). +Notation AlgType R A ax := (@pack _ (Phant R) A _ ax _ _ id _ id). +Notation CommAlgType R A := (AlgType R A (comm_axiom (Phant A) (@mulrC _))). +Notation "[ 'algType' R 'of' T 'for' cT ]" := (@clone _ (Phant R) T cT _ idfun) + (at level 0, format "[ 'algType' R 'of' T 'for' cT ]") + : form_scope. +Notation "[ 'algType' R 'of' T ]" := (@clone _ (Phant R) T _ _ id) + (at level 0, format "[ 'algType' R 'of' T ]") : form_scope. +End Exports. + +End Algebra. +Import Algebra.Exports. + +Section AlgebraTheory. + +Variables (R : comRingType) (A : algType R). +Implicit Types (k : R) (x y : A). + +Lemma scalerAr k x y : k *: (x * y) = x * (k *: y). +Proof. by case: A k x y => T []. Qed. + +Lemma scalerCA k x y : k *: x * y = x * (k *: y). +Proof. by rewrite -scalerAl scalerAr. Qed. + +Lemma mulr_algr a x : x * a%:A = a *: x. +Proof. by rewrite -scalerAr mulr1. Qed. + +Lemma exprZn k x n : (k *: x) ^+ n = k ^+ n *: x ^+ n. +Proof. +elim: n => [|n IHn]; first by rewrite !expr0 scale1r. +by rewrite !exprS IHn -scalerA scalerAr scalerAl. +Qed. + +Lemma scaler_prod I r (P : pred I) (F : I -> R) (G : I -> A) : + \prod_(i <- r | P i) (F i *: G i) = + \prod_(i <- r | P i) F i *: \prod_(i <- r | P i) G i. +Proof. +elim/big_rec3: _ => [|i x a _ _ ->]; first by rewrite scale1r. +by rewrite -scalerAl -scalerAr scalerA. +Qed. + +Lemma scaler_prodl (I : finType) (S : pred I) (F : I -> A) k : + \prod_(i in S) (k *: F i) = k ^+ #|S| *: \prod_(i in S) F i. +Proof. by rewrite scaler_prod prodr_const. Qed. + +Lemma scaler_prodr (I : finType) (S : pred I) (F : I -> R) x : + \prod_(i in S) (F i *: x) = \prod_(i in S) F i *: x ^+ #|S|. +Proof. by rewrite scaler_prod prodr_const. Qed. + +Canonical regular_comRingType := [comRingType of R^o]. +Canonical regular_algType := CommAlgType R R^o. + +Variables (U : lmodType R) (a : A) (f : {linear U -> A}). + +Lemma mull_fun_is_scalable : scalable (a \*o f). +Proof. by move=> k x /=; rewrite linearZ scalerAr. Qed. +Canonical mull_fun_linear := AddLinear mull_fun_is_scalable. + +End AlgebraTheory. + +Module UnitRing. + +Record mixin_of (R : ringType) : Type := Mixin { + unit : pred R; + inv : R -> R; + _ : {in unit, left_inverse 1 inv *%R}; + _ : {in unit, right_inverse 1 inv *%R}; + _ : forall x y, y * x = 1 /\ x * y = 1 -> unit x; + _ : {in [predC unit], inv =1 id} +}. + +Definition EtaMixin R unit inv mulVr mulrV unitP inv_out := + let _ := @Mixin R unit inv mulVr mulrV unitP inv_out in + @Mixin (Ring.Pack (Ring.class R) R) unit inv mulVr mulrV unitP inv_out. + +Section ClassDef. + +Record class_of (R : Type) : Type := Class { + base : Ring.class_of R; + mixin : mixin_of (Ring.Pack base R) +}. +Local Coercion base : class_of >-> Ring.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. +Definition clone c of phant_id class c := @Pack T c T. +Let xT := let: Pack T _ _ := cT in T. +Notation xclass := (class : class_of xT). + +Definition pack b0 (m0 : mixin_of (@Ring.Pack T b0 T)) := + fun bT b & phant_id (Ring.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 := @Zmodule.Pack cT xclass xT. +Definition ringType := @Ring.Pack cT xclass xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> Ring.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 >-> Zmodule.type. +Canonical zmodType. +Coercion ringType : type >-> Ring.type. +Canonical ringType. +Notation unitRingType := type. +Notation UnitRingType T m := (@pack T _ m _ _ id _ id). +Notation UnitRingMixin := EtaMixin. +Notation "[ 'unitRingType' 'of' T 'for' cT ]" := (@clone T cT _ idfun) + (at level 0, format "[ 'unitRingType' 'of' T 'for' cT ]") : form_scope. +Notation "[ 'unitRingType' 'of' T ]" := (@clone T _ _ id) + (at level 0, format "[ 'unitRingType' 'of' T ]") : form_scope. +End Exports. + +End UnitRing. +Import UnitRing.Exports. + +Definition unit {R : unitRingType} := + [qualify a u : R | UnitRing.unit (UnitRing.class R) u]. +Fact unit_key R : pred_key (@unit R). Proof. by []. Qed. +Canonical unit_keyed R := KeyedQualifier (@unit_key R). +Definition inv {R : unitRingType} : R -> R := UnitRing.inv (UnitRing.class R). + +Local Notation "x ^-1" := (inv x). +Local Notation "x / y" := (x * y^-1). +Local Notation "x ^- n" := ((x ^+ n)^-1). + +Section UnitRingTheory. + +Variable R : unitRingType. +Implicit Types x y : R. + +Lemma divrr : {in unit, right_inverse 1 (@inv R) *%R}. +Proof. by case: R => T [? []]. Qed. +Definition mulrV := divrr. + +Lemma mulVr : {in unit, left_inverse 1 (@inv R) *%R}. +Proof. by case: R => T [? []]. Qed. + +Lemma invr_out x : x \isn't a unit -> x^-1 = x. +Proof. by case: R x => T [? []]. Qed. + +Lemma unitrP x : reflect (exists y, y * x = 1 /\ x * y = 1) (x \is a unit). +Proof. +apply: (iffP idP) => [Ux | []]; last by case: R x => T [? []]. +by exists x^-1; rewrite divrr ?mulVr. +Qed. + +Lemma mulKr : {in unit, left_loop (@inv R) *%R}. +Proof. by move=> x Ux y; rewrite mulrA mulVr ?mul1r. Qed. + +Lemma mulVKr : {in unit, rev_left_loop (@inv R) *%R}. +Proof. by move=> x Ux y; rewrite mulrA mulrV ?mul1r. Qed. + +Lemma mulrK : {in unit, right_loop (@inv R) *%R}. +Proof. by move=> x Ux y; rewrite -mulrA divrr ?mulr1. Qed. + +Lemma mulrVK : {in unit, rev_right_loop (@inv R) *%R}. +Proof. by move=> x Ux y; rewrite -mulrA mulVr ?mulr1. Qed. +Definition divrK := mulrVK. + +Lemma mulrI : {in @unit R, right_injective *%R}. +Proof. by move=> x Ux; exact: can_inj (mulKr Ux). Qed. + +Lemma mulIr : {in @unit R, left_injective *%R}. +Proof. by move=> x Ux; exact: can_inj (mulrK Ux). Qed. + +(* Due to noncommutativity, fractions are inverted. *) +Lemma telescope_prodr n m (f : nat -> R) : + (forall k, n < k < m -> f k \is a unit) -> n < m -> + \prod_(n <= k < m) (f k / f k.+1) = f n / f m. +Proof. +move=> Uf /subnK-Dm; do [rewrite -{}Dm; move: {m}(m - _)%N => m] in Uf *. +rewrite unlock /index_iota -addSnnS addnK /= -mulrA; congr (_ * _). +have{Uf}: all [preim f of unit] (iota n.+1 m). + by apply/allP=> k; rewrite mem_iota addnC => /Uf. +elim: m n => [|m IHm] n /=; first by rewrite mulr1. +by rewrite -mulrA addSnnS => /andP[/mulKr-> /IHm]. +Qed. + +Lemma commrV x y : comm x y -> comm x y^-1. +Proof. +have [Uy cxy | /invr_out-> //] := boolP (y \in unit). +by apply: (canLR (mulrK Uy)); rewrite -mulrA cxy mulKr. +Qed. + +Lemma unitrE x : (x \is a unit) = (x / x == 1). +Proof. +apply/idP/eqP=> [Ux | xx1]; first exact: divrr. +by apply/unitrP; exists x^-1; rewrite -commrV. +Qed. + +Lemma invrK : involutive (@inv R). +Proof. +move=> x; case Ux: (x \in unit); last by rewrite !invr_out ?Ux. +rewrite -(mulrK Ux _^-1) -mulrA commrV ?mulKr //. +by apply/unitrP; exists x; rewrite divrr ?mulVr. +Qed. + +Lemma invr_inj : injective (@inv R). +Proof. exact: inv_inj invrK. Qed. + +Lemma unitrV x : (x^-1 \in unit) = (x \in unit). +Proof. by rewrite !unitrE invrK commrV. Qed. + +Lemma unitr1 : 1 \in @unit R. +Proof. by apply/unitrP; exists 1; rewrite mulr1. Qed. + +Lemma invr1 : 1^-1 = 1 :> R. +Proof. by rewrite -{2}(mulVr unitr1) mulr1. Qed. + +Lemma div1r x : 1 / x = x^-1. Proof. by rewrite mul1r. Qed. +Lemma divr1 x : x / 1 = x. Proof. by rewrite invr1 mulr1. Qed. + +Lemma natr_div m d : + d %| m -> d%:R \is a @unit R -> (m %/ d)%:R = m%:R / d%:R :> R. +Proof. +by rewrite dvdn_eq => /eqP def_m unit_d; rewrite -{2}def_m natrM mulrK. +Qed. + +Lemma unitr0 : (0 \is a @unit R) = false. +Proof. +by apply/unitrP=> [[x [_]]]; apply/eqP; rewrite mul0r eq_sym oner_neq0. +Qed. + +Lemma invr0 : 0^-1 = 0 :> R. +Proof. by rewrite invr_out ?unitr0. Qed. + +Lemma unitrN1 : -1 \is a @unit R. +Proof. by apply/unitrP; exists (-1); rewrite mulrNN mulr1. Qed. + +Lemma invrN1 : (-1)^-1 = -1 :> R. +Proof. by rewrite -{2}(divrr unitrN1) mulN1r opprK. Qed. + +Lemma invr_sign n : ((-1) ^- n) = (-1) ^+ n :> R. +Proof. by rewrite -signr_odd; case: (odd n); rewrite (invr1, invrN1). Qed. + +Lemma unitrMl x y : y \is a unit -> (x * y \is a unit) = (x \is a unit). +Proof. +move=> Uy; wlog Ux: x y Uy / x \is a unit => [WHxy|]. + by apply/idP/idP=> Ux; first rewrite -(mulrK Uy x); rewrite WHxy ?unitrV. +rewrite Ux; apply/unitrP; exists (y^-1 * x^-1). +by rewrite -!mulrA mulKr ?mulrA ?mulrK ?divrr ?mulVr. +Qed. + +Lemma unitrMr x y : x \is a unit -> (x * y \is a unit) = (y \is a unit). +Proof. +move=> Ux; apply/idP/idP=> [Uxy | Uy]; last by rewrite unitrMl. +by rewrite -(mulKr Ux y) unitrMl ?unitrV. +Qed. + +Lemma invrM : {in unit &, forall x y, (x * y)^-1 = y^-1 * x^-1}. +Proof. +move=> x y Ux Uy; have Uxy: (x * y \in unit) by rewrite unitrMl. +by apply: (mulrI Uxy); rewrite divrr ?mulrA ?mulrK ?divrr. +Qed. + +Lemma unitrM_comm x y : + comm x y -> (x * y \is a unit) = (x \is a unit) && (y \is a unit). +Proof. +move=> cxy; apply/idP/andP=> [Uxy | [Ux Uy]]; last by rewrite unitrMl. +suffices Ux: x \in unit by rewrite unitrMr in Uxy. +apply/unitrP; case/unitrP: Uxy => z [zxy xyz]; exists (y * z). +rewrite mulrA xyz -{1}[y]mul1r -{1}zxy cxy -!mulrA (mulrA x) (mulrA _ z) xyz. +by rewrite mul1r -cxy. +Qed. + +Lemma unitrX x n : x \is a unit -> x ^+ n \is a unit. +Proof. +by move=> Ux; elim: n => [|n IHn]; rewrite ?unitr1 // exprS unitrMl. +Qed. + +Lemma unitrX_pos x n : n > 0 -> (x ^+ n \in unit) = (x \in unit). +Proof. +case: n => // n _; rewrite exprS unitrM_comm; last exact: commrX. +by case Ux: (x \is a unit); rewrite // unitrX. +Qed. + +Lemma exprVn x n : x^-1 ^+ n = x ^- n. +Proof. +elim: n => [|n IHn]; first by rewrite !expr0 ?invr1. +case Ux: (x \is a unit); first by rewrite exprSr exprS IHn -invrM // unitrX. +by rewrite !invr_out ?unitrX_pos ?Ux. +Qed. + +Lemma exprB m n x : n <= m -> x \is a unit -> x ^+ (m - n) = x ^+ m / x ^+ n. +Proof. by move/subnK=> {2}<- Ux; rewrite exprD mulrK ?unitrX. Qed. + +Lemma invr_neq0 x : x != 0 -> x^-1 != 0. +Proof. +move=> nx0; case Ux: (x \is a unit); last by rewrite invr_out ?Ux. +by apply/eqP=> x'0; rewrite -unitrV x'0 unitr0 in Ux. +Qed. + +Lemma invr_eq0 x : (x^-1 == 0) = (x == 0). +Proof. by apply: negb_inj; apply/idP/idP; move/invr_neq0; rewrite ?invrK. Qed. + +Lemma invr_eq1 x : (x^-1 == 1) = (x == 1). +Proof. by rewrite (inv_eq invrK) invr1. Qed. + +Lemma rev_unitrP (x y : R^c) : y * x = 1 /\ x * y = 1 -> x \is a unit. +Proof. by case=> [yx1 xy1]; apply/unitrP; exists y. Qed. + +Definition converse_unitRingMixin := + @UnitRing.Mixin _ ((unit : pred_class) : pred R^c) _ + mulrV mulVr rev_unitrP invr_out. +Canonical converse_unitRingType := UnitRingType R^c converse_unitRingMixin. +Canonical regular_unitRingType := [unitRingType of R^o]. + +Section ClosedPredicates. + +Variables S : predPredType R. + +Definition invr_closed := {in S, forall x, x^-1 \in S}. +Definition divr_2closed := {in S &, forall x y, x / y \in S}. +Definition divr_closed := 1 \in S /\ divr_2closed. +Definition sdivr_closed := -1 \in S /\ divr_2closed. +Definition divring_closed := [/\ 1 \in S, subr_2closed S & divr_2closed]. + +Lemma divr_closedV : divr_closed -> invr_closed. +Proof. by case=> S1 Sdiv x Sx; rewrite -[x^-1]mul1r Sdiv. Qed. + +Lemma divr_closedM : divr_closed -> mulr_closed S. +Proof. +by case=> S1 Sdiv; split=> // x y Sx Sy; rewrite -[y]invrK -[y^-1]mul1r !Sdiv. +Qed. + +Lemma sdivr_closed_div : sdivr_closed -> divr_closed. +Proof. by case=> SN1 Sdiv; split; rewrite // -(divrr unitrN1) Sdiv. Qed. + +Lemma sdivr_closedM : sdivr_closed -> smulr_closed S. +Proof. +by move=> Sdiv; have [_ SM] := divr_closedM (sdivr_closed_div Sdiv); case: Sdiv. +Qed. + +Lemma divring_closedBM : divring_closed -> subring_closed S. +Proof. by case=> S1 SB Sdiv; split=> //; case: divr_closedM. Qed. + +Lemma divring_closed_div : divring_closed -> sdivr_closed. +Proof. +case=> S1 SB Sdiv; split; rewrite ?zmod_closedN //. +exact/subring_closedB/divring_closedBM. +Qed. + +End ClosedPredicates. + +End UnitRingTheory. + +Implicit Arguments invr_inj [[R] x1 x2]. + +Section UnitRingMorphism. + +Variables (R S : unitRingType) (f : {rmorphism R -> S}). + +Lemma rmorph_unit x : x \in unit -> f x \in unit. +Proof. +case/unitrP=> y [yx1 xy1]; apply/unitrP. +by exists (f y); rewrite -!rmorphM // yx1 xy1 rmorph1. +Qed. + +Lemma rmorphV : {in unit, {morph f: x / x^-1}}. +Proof. +move=> x Ux; rewrite /= -[(f x)^-1]mul1r. +by apply: (canRL (mulrK (rmorph_unit Ux))); rewrite -rmorphM mulVr ?rmorph1. +Qed. + +Lemma rmorph_div x y : y \in unit -> f (x / y) = f x / f y. +Proof. by move=> Uy; rewrite rmorphM rmorphV. Qed. + +End UnitRingMorphism. + +Module ComUnitRing. + +Section Mixin. + +Variables (R : comRingType) (unit : pred R) (inv : R -> R). +Hypothesis mulVx : {in unit, left_inverse 1 inv *%R}. +Hypothesis unitPl : forall x y, y * x = 1 -> unit x. + +Fact mulC_mulrV : {in unit, right_inverse 1 inv *%R}. +Proof. by move=> x Ux /=; rewrite mulrC mulVx. Qed. + +Fact mulC_unitP x y : y * x = 1 /\ x * y = 1 -> unit x. +Proof. case=> yx _; exact: unitPl yx. Qed. + +Definition Mixin := UnitRingMixin mulVx mulC_mulrV mulC_unitP. + +End Mixin. + +Section ClassDef. + +Record class_of (R : Type) : Type := Class { + base : ComRing.class_of R; + mixin : UnitRing.mixin_of (Ring.Pack base R) +}. +Local Coercion base : class_of >-> ComRing.class_of. +Definition base2 R m := UnitRing.Class (@mixin R m). +Local Coercion base2 : class_of >-> UnitRing.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 (ComRing.class bT) (b : ComRing.class_of T) => + fun mT m & phant_id (UnitRing.class mT) (@UnitRing.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 := @Zmodule.Pack cT xclass xT. +Definition ringType := @Ring.Pack cT xclass xT. +Definition comRingType := @ComRing.Pack cT xclass xT. +Definition unitRingType := @UnitRing.Pack cT xclass xT. +Definition com_unitRingType := @UnitRing.Pack comRingType xclass xT. + +End ClassDef. + +Module Import Exports. +Coercion base : class_of >-> ComRing.class_of. +Coercion mixin : class_of >-> UnitRing.mixin_of. +Coercion base2 : class_of >-> UnitRing.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 >-> Zmodule.type. +Canonical zmodType. +Coercion ringType : type >-> Ring.type. +Canonical ringType. +Coercion comRingType : type >-> ComRing.type. +Canonical comRingType. +Coercion unitRingType : type >-> UnitRing.type. +Canonical unitRingType. +Canonical com_unitRingType. +Notation comUnitRingType := type. +Notation ComUnitRingMixin := Mixin. +Notation "[ 'comUnitRingType' 'of' T ]" := (@pack T _ _ id _ _ id) + (at level 0, format "[ 'comUnitRingType' 'of' T ]") : form_scope. +End Exports. + +End ComUnitRing. +Import ComUnitRing.Exports. + +Module UnitAlgebra. + +Section ClassDef. + +Variable R : ringType. + +Record class_of (T : Type) : Type := Class { + base : Algebra.class_of R T; + mixin : GRing.UnitRing.mixin_of (Ring.Pack base T) +}. +Definition base2 R m := UnitRing.Class (@mixin R m). +Local Coercion base : class_of >-> Algebra.class_of. +Local Coercion base2 : class_of >-> UnitRing.class_of. + +Structure type (phR : phant R) := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variable (phR : phant R) (T : Type) (cT : type phR). +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 (@Algebra.class R phR bT) (b : Algebra.class_of R T) => + fun mT m & phant_id (UnitRing.mixin (UnitRing.class mT)) m => + Pack (Phant R) (@Class T b m) T. + +Definition eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition zmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @Ring.Pack cT xclass xT. +Definition unitRingType := @UnitRing.Pack cT xclass xT. +Definition lmodType := @Lmodule.Pack R phR cT xclass xT. +Definition lalgType := @Lalgebra.Pack R phR cT xclass xT. +Definition algType := @Algebra.Pack R phR cT xclass xT. +Definition lmod_unitRingType := @Lmodule.Pack R phR unitRingType xclass xT. +Definition lalg_unitRingType := @Lalgebra.Pack R phR unitRingType xclass xT. +Definition alg_unitRingType := @Algebra.Pack R phR unitRingType xclass xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> Algebra.class_of. +Coercion base2 : class_of >-> UnitRing.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 >-> Zmodule.type. +Canonical zmodType. +Coercion ringType : type >-> Ring.type. +Canonical ringType. +Coercion unitRingType : type >-> UnitRing.type. +Canonical unitRingType. +Coercion lmodType : type >-> Lmodule.type. +Canonical lmodType. +Coercion lalgType : type >-> Lalgebra.type. +Canonical lalgType. +Coercion algType : type >-> Algebra.type. +Canonical algType. +Canonical lmod_unitRingType. +Canonical lalg_unitRingType. +Canonical alg_unitRingType. +Notation unitAlgType R := (type (Phant R)). +Notation "[ 'unitAlgType' R 'of' T ]" := (@pack _ (Phant R) T _ _ id _ _ id) + (at level 0, format "[ 'unitAlgType' R 'of' T ]") : form_scope. +End Exports. + +End UnitAlgebra. +Import UnitAlgebra.Exports. + +Section ComUnitRingTheory. + +Variable R : comUnitRingType. +Implicit Types x y : R. + +Lemma unitrM x y : (x * y \in unit) = (x \in unit) && (y \in unit). +Proof. by apply: unitrM_comm; exact: mulrC. Qed. + +Lemma unitrPr x : reflect (exists y, x * y = 1) (x \in unit). +Proof. +by apply: (iffP (unitrP x)) => [[y []] | [y]]; exists y; rewrite // mulrC. +Qed. + +Lemma expr_div_n x y n : (x / y) ^+ n = x ^+ n / y ^+ n. +Proof. by rewrite exprMn exprVn. Qed. + +Canonical regular_comUnitRingType := [comUnitRingType of R^o]. +Canonical regular_unitAlgType := [unitAlgType R of R^o]. + +End ComUnitRingTheory. + +Section UnitAlgebraTheory. + +Variable (R : comUnitRingType) (A : unitAlgType R). +Implicit Types (k : R) (x y : A). + +Lemma scaler_injl : {in unit, @right_injective R A A *:%R}. +Proof. +move=> k Uk x1 x2 Hx1x2. +by rewrite -[x1]scale1r -(mulVr Uk) -scalerA Hx1x2 scalerA mulVr // scale1r. +Qed. + +Lemma scaler_unit k x : k \in unit -> (k *: x \in unit) = (x \in unit). +Proof. +move=> Uk; apply/idP/idP=> [Ukx | Ux]; apply/unitrP; last first. + exists (k^-1 *: x^-1). + by rewrite -!scalerAl -!scalerAr !scalerA !mulVr // !mulrV // scale1r. +exists (k *: (k *: x)^-1); split. + apply: (mulrI Ukx). + by rewrite mulr1 mulrA -scalerAr mulrV // -scalerAl mul1r. +apply: (mulIr Ukx). +by rewrite mul1r -mulrA -scalerAl mulVr // -scalerAr mulr1. +Qed. + +Lemma invrZ k x : k \in unit -> x \in unit -> (k *: x)^-1 = k^-1 *: x^-1. +Proof. +move=> Uk Ux; have Ukx: (k *: x \in unit) by rewrite scaler_unit. +apply: (mulIr Ukx). +by rewrite mulVr // -scalerAl -scalerAr scalerA !mulVr // scale1r. +Qed. + +Section ClosedPredicates. + +Variables S : predPredType A. + +Definition divalg_closed := [/\ 1 \in S, linear_closed S & divr_2closed S]. + +Lemma divalg_closedBdiv : divalg_closed -> divring_closed S. +Proof. by case=> S1 /linear_closedB. Qed. + +Lemma divalg_closedZ : divalg_closed -> subalg_closed S. +Proof. by case=> S1 Slin Sdiv; split=> //; have [] := @divr_closedM A S. Qed. + +End ClosedPredicates. + +End UnitAlgebraTheory. + +(* Interface structures for algebraically closed predicates. *) +Module Pred. + +Structure opp V S := Opp {opp_key : pred_key S; _ : @oppr_closed V S}. +Structure add V S := Add {add_key : pred_key S; _ : @addr_closed V S}. +Structure mul R S := Mul {mul_key : pred_key S; _ : @mulr_closed R S}. +Structure zmod V S := Zmod {zmod_add : add S; _ : @oppr_closed V S}. +Structure semiring R S := Semiring {semiring_add : add S; _ : @mulr_closed R S}. +Structure smul R S := Smul {smul_opp : opp S; _ : @mulr_closed R S}. +Structure div R S := Div {div_mul : mul S; _ : @invr_closed R S}. +Structure submod R V S := + Submod {submod_zmod : zmod S; _ : @scaler_closed R V S}. +Structure subring R S := Subring {subring_zmod : zmod S; _ : @mulr_closed R S}. +Structure sdiv R S := Sdiv {sdiv_smul : smul S; _ : @invr_closed R S}. +Structure subalg (R : ringType) (A : lalgType R) S := + Subalg {subalg_ring : subring S; _ : @scaler_closed R A S}. +Structure divring R S := + Divring {divring_ring : subring S; _ : @invr_closed R S}. +Structure divalg (R : ringType) (A : unitAlgType R) S := + Divalg {divalg_ring : divring S; _ : @scaler_closed R A S}. + +Section Subtyping. + +Ltac done := case=> *; assumption. +Fact zmod_oppr R S : @zmod R S -> oppr_closed S. Proof. by []. Qed. +Fact semiring_mulr R S : @semiring R S -> mulr_closed S. Proof. by []. Qed. +Fact smul_mulr R S : @smul R S -> mulr_closed S. Proof. by []. Qed. +Fact submod_scaler R V S : @submod R V S -> scaler_closed S. Proof. by []. Qed. +Fact subring_mulr R S : @subring R S -> mulr_closed S. Proof. by []. Qed. +Fact sdiv_invr R S : @sdiv R S -> invr_closed S. Proof. by []. Qed. +Fact subalg_scaler R A S : @subalg R A S -> scaler_closed S. Proof. by []. Qed. +Fact divring_invr R S : @divring R S -> invr_closed S. Proof. by []. Qed. +Fact divalg_scaler R A S : @divalg R A S -> scaler_closed S. Proof. by []. Qed. + +Definition zmod_opp R S (addS : @zmod R S) := + Opp (add_key (zmod_add addS)) (zmod_oppr addS). +Definition semiring_mul R S (ringS : @semiring R S) := + Mul (add_key (semiring_add ringS)) (semiring_mulr ringS). +Definition smul_mul R S (mulS : @smul R S) := + Mul (opp_key (smul_opp mulS)) (smul_mulr mulS). +Definition subring_semi R S (ringS : @subring R S) := + Semiring (zmod_add (subring_zmod ringS)) (subring_mulr ringS). +Definition subring_smul R S (ringS : @subring R S) := + Smul (zmod_opp (subring_zmod ringS)) (subring_mulr ringS). +Definition sdiv_div R S (divS : @sdiv R S) := + Div (smul_mul (sdiv_smul divS)) (sdiv_invr divS). +Definition subalg_submod R A S (algS : @subalg R A S) := + Submod (subring_zmod (subalg_ring algS)) (subalg_scaler algS). +Definition divring_sdiv R S (ringS : @divring R S) := + Sdiv (subring_smul (divring_ring ringS)) (divring_invr ringS). +Definition divalg_alg R A S (algS : @divalg R A S) := + Subalg (divring_ring (divalg_ring algS)) (divalg_scaler algS). + +End Subtyping. + +Section Extensionality. +(* This could be avoided by exploiting the Coq 8.4 eta-convertibility. *) + +Lemma opp_ext (U : zmodType) S k (kS : @keyed_pred U S k) : + oppr_closed kS -> oppr_closed S. +Proof. by move=> oppS x; rewrite -!(keyed_predE kS); apply: oppS. Qed. + +Lemma add_ext (U : zmodType) S k (kS : @keyed_pred U S k) : + addr_closed kS -> addr_closed S. +Proof. +by case=> S0 addS; split=> [|x y]; rewrite -!(keyed_predE kS) //; apply: addS. +Qed. + +Lemma mul_ext (R : ringType) S k (kS : @keyed_pred R S k) : + mulr_closed kS -> mulr_closed S. +Proof. +by case=> S1 mulS; split=> [|x y]; rewrite -!(keyed_predE kS) //; apply: mulS. +Qed. + +Lemma scale_ext (R : ringType) (U : lmodType R) S k (kS : @keyed_pred U S k) : + scaler_closed kS -> scaler_closed S. +Proof. by move=> linS a x; rewrite -!(keyed_predE kS); apply: linS. Qed. + +Lemma inv_ext (R : unitRingType) S k (kS : @keyed_pred R S k) : + invr_closed kS -> invr_closed S. +Proof. by move=> invS x; rewrite -!(keyed_predE kS); apply: invS. Qed. + +End Extensionality. + +Module Default. +Definition opp V S oppS := @Opp V S (DefaultPredKey S) oppS. +Definition add V S addS := @Add V S (DefaultPredKey S) addS. +Definition mul R S mulS := @Mul R S (DefaultPredKey S) mulS. +Definition zmod V S addS oppS := @Zmod V S (add addS) oppS. +Definition semiring R S addS mulS := @Semiring R S (add addS) mulS. +Definition smul R S oppS mulS := @Smul R S (opp oppS) mulS. +Definition div R S mulS invS := @Div R S (mul mulS) invS. +Definition submod R V S addS oppS linS := @Submod R V S (zmod addS oppS) linS. +Definition subring R S addS oppS mulS := @Subring R S (zmod addS oppS) mulS. +Definition sdiv R S oppS mulS invS := @Sdiv R S (smul oppS mulS) invS. +Definition subalg R A S addS oppS mulS linS := + @Subalg R A S (subring addS oppS mulS) linS. +Definition divring R S addS oppS mulS invS := + @Divring R S (subring addS oppS mulS) invS. +Definition divalg R A S addS oppS mulS invS linS := + @Divalg R A S (divring addS oppS mulS invS) linS. +End Default. + +Module Exports. + +Notation oppr_closed := oppr_closed. +Notation addr_closed := addr_closed. +Notation mulr_closed := mulr_closed. +Notation zmod_closed := zmod_closed. +Notation smulr_closed := smulr_closed. +Notation invr_closed := invr_closed. +Notation divr_closed := divr_closed. +Notation linear_closed := linear_closed. +Notation submod_closed := submod_closed. +Notation semiring_closed := semiring_closed. +Notation subring_closed := subring_closed. +Notation sdivr_closed := sdivr_closed. +Notation subalg_closed := subalg_closed. +Notation divring_closed := divring_closed. +Notation divalg_closed := divalg_closed. + +Coercion zmod_closedD : zmod_closed >-> addr_closed. +Coercion zmod_closedN : zmod_closed >-> oppr_closed. +Coercion smulr_closedN : smulr_closed >-> oppr_closed. +Coercion smulr_closedM : smulr_closed >-> mulr_closed. +Coercion divr_closedV : divr_closed >-> invr_closed. +Coercion divr_closedM : divr_closed >-> mulr_closed. +Coercion submod_closedZ : submod_closed >-> scaler_closed. +Coercion submod_closedB : submod_closed >-> zmod_closed. +Coercion semiring_closedD : semiring_closed >-> addr_closed. +Coercion semiring_closedM : semiring_closed >-> mulr_closed. +Coercion subring_closedB : subring_closed >-> zmod_closed. +Coercion subring_closedM : subring_closed >-> smulr_closed. +Coercion subring_closed_semi : subring_closed >-> semiring_closed. +Coercion sdivr_closedM : sdivr_closed >-> smulr_closed. +Coercion sdivr_closed_div : sdivr_closed >-> divr_closed. +Coercion subalg_closedZ : subalg_closed >-> submod_closed. +Coercion subalg_closedBM : subalg_closed >-> subring_closed. +Coercion divring_closedBM : divring_closed >-> subring_closed. +Coercion divring_closed_div : divring_closed >-> sdivr_closed. +Coercion divalg_closedZ : divalg_closed >-> subalg_closed. +Coercion divalg_closedBdiv : divalg_closed >-> divring_closed. + +Coercion opp_key : opp >-> pred_key. +Coercion add_key : add >-> pred_key. +Coercion mul_key : mul >-> pred_key. +Coercion zmod_opp : zmod >-> opp. +Canonical zmod_opp. +Coercion zmod_add : zmod >-> add. +Coercion semiring_add : semiring >-> add. +Coercion semiring_mul : semiring >-> mul. +Canonical semiring_mul. +Coercion smul_opp : smul >-> opp. +Coercion smul_mul : smul >-> mul. +Canonical smul_mul. +Coercion div_mul : div >-> mul. +Coercion submod_zmod : submod >-> zmod. +Coercion subring_zmod : subring >-> zmod. +Coercion subring_semi : subring >-> semiring. +Canonical subring_semi. +Coercion subring_smul : subring >-> smul. +Canonical subring_smul. +Coercion sdiv_smul : sdiv >-> smul. +Coercion sdiv_div : sdiv >-> div. +Canonical sdiv_div. +Coercion subalg_submod : subalg >-> submod. +Canonical subalg_submod. +Coercion subalg_ring : subalg >-> subring. +Coercion divring_ring : divring >-> subring. +Coercion divring_sdiv : divring >-> sdiv. +Canonical divring_sdiv. +Coercion divalg_alg : divalg >-> subalg. +Canonical divalg_alg. +Coercion divalg_ring : divalg >-> divring. + +Notation opprPred := opp. +Notation addrPred := add. +Notation mulrPred := mul. +Notation zmodPred := zmod. +Notation semiringPred := semiring. +Notation smulrPred := smul. +Notation divrPred := div. +Notation submodPred := submod. +Notation subringPred := subring. +Notation sdivrPred := sdiv. +Notation subalgPred := subalg. +Notation divringPred := divring. +Notation divalgPred := divalg. + +Definition OpprPred U S k kS NkS := Opp k (@opp_ext U S k kS NkS). +Definition AddrPred U S k kS DkS := Add k (@add_ext U S k kS DkS). +Definition MulrPred R S k kS MkS := Mul k (@mul_ext R S k kS MkS). +Definition ZmodPred U S k kS NkS := Zmod k (@opp_ext U S k kS NkS). +Definition SemiringPred R S k kS MkS := Semiring k (@mul_ext R S k kS MkS). +Definition SmulrPred R S k kS MkS := Smul k (@mul_ext R S k kS MkS). +Definition DivrPred R S k kS VkS := Div k (@inv_ext R S k kS VkS). +Definition SubmodPred R U S k kS ZkS := Submod k (@scale_ext R U S k kS ZkS). +Definition SubringPred R S k kS MkS := Subring k (@mul_ext R S k kS MkS). +Definition SdivrPred R S k kS VkS := Sdiv k (@inv_ext R S k kS VkS). +Definition SubalgPred (R : ringType) (A : lalgType R) S k kS ZkS := + Subalg k (@scale_ext R A S k kS ZkS). +Definition DivringPred R S k kS VkS := Divring k (@inv_ext R S k kS VkS). +Definition DivalgPred (R : ringType) (A : unitAlgType R) S k kS ZkS := + Divalg k (@scale_ext R A S k kS ZkS). + +End Exports. + +End Pred. +Import Pred.Exports. + +Module DefaultPred. + +Canonical Pred.Default.opp. +Canonical Pred.Default.add. +Canonical Pred.Default.mul. +Canonical Pred.Default.zmod. +Canonical Pred.Default.semiring. +Canonical Pred.Default.smul. +Canonical Pred.Default.div. +Canonical Pred.Default.submod. +Canonical Pred.Default.subring. +Canonical Pred.Default.sdiv. +Canonical Pred.Default.subalg. +Canonical Pred.Default.divring. +Canonical Pred.Default.divalg. + +End DefaultPred. + +Section ZmodulePred. + +Variables (V : zmodType) (S : predPredType V). + +Section Add. + +Variables (addS : addrPred S) (kS : keyed_pred addS). + +Lemma rpred0D : addr_closed kS. +Proof. +by split=> [|x y]; rewrite !keyed_predE; case: addS => _ [_]//; apply. +Qed. + +Lemma rpred0 : 0 \in kS. +Proof. by case: rpred0D. Qed. + +Lemma rpredD : {in kS &, forall u v, u + v \in kS}. +Proof. by case: rpred0D. Qed. + +Lemma rpred_sum I r (P : pred I) F : + (forall i, P i -> F i \in kS) -> \sum_(i <- r | P i) F i \in kS. +Proof. by move=> IH; elim/big_ind: _; [exact: rpred0 | exact: rpredD |]. Qed. + +Lemma rpredMn n : {in kS, forall u, u *+ n \in kS}. +Proof. by move=> u Su; rewrite -(card_ord n) -sumr_const rpred_sum. Qed. + +End Add. + +Section Opp. + +Variables (oppS : opprPred S) (kS : keyed_pred oppS). + +Lemma rpredNr : oppr_closed kS. +Proof. by move=> x; rewrite !keyed_predE; case: oppS => _; apply. Qed. + +Lemma rpredN : {mono -%R: u / u \in kS}. +Proof. by move=> u; apply/idP/idP=> /rpredNr; rewrite ?opprK; apply. Qed. + +End Opp. + +Section Sub. + +Variables (subS : zmodPred S) (kS : keyed_pred subS). + +Lemma rpredB : {in kS &, forall u v, u - v \in kS}. +Proof. by move=> u v Su Sv; rewrite /= rpredD ?rpredN. Qed. + +Lemma rpredMNn n : {in kS, forall u, u *- n \in kS}. +Proof. by move=> u Su; rewrite /= rpredN rpredMn. Qed. + +Lemma rpredDr x y : x \in kS -> (y + x \in kS) = (y \in kS). +Proof. +move=> Sx; apply/idP/idP=> [Sxy | /rpredD-> //]. +by rewrite -(addrK x y) rpredB. +Qed. + +Lemma rpredDl x y : x \in kS -> (x + y \in kS) = (y \in kS). +Proof. by rewrite addrC; apply: rpredDr. Qed. + +Lemma rpredBr x y : x \in kS -> (y - x \in kS) = (y \in kS). +Proof. by rewrite -rpredN; apply: rpredDr. Qed. + +Lemma rpredBl x y : x \in kS -> (x - y \in kS) = (y \in kS). +Proof. by rewrite -(rpredN _ y); apply: rpredDl. Qed. + +End Sub. + +End ZmodulePred. + +Section RingPred. + +Variables (R : ringType) (S : predPredType R). + +Lemma rpredMsign (oppS : opprPred S) (kS : keyed_pred oppS) n x : + ((-1) ^+ n * x \in kS) = (x \in kS). +Proof. by rewrite -signr_odd mulr_sign; case: ifP => // _; rewrite rpredN. Qed. + +Section Mul. + +Variables (mulS : mulrPred S) (kS : keyed_pred mulS). + +Lemma rpred1M : mulr_closed kS. +Proof. +by split=> [|x y]; rewrite !keyed_predE; case: mulS => _ [_] //; apply. +Qed. + +Lemma rpred1 : 1 \in kS. +Proof. by case: rpred1M. Qed. + +Lemma rpredM : {in kS &, forall u v, u * v \in kS}. +Proof. by case: rpred1M. Qed. + +Lemma rpred_prod I r (P : pred I) F : + (forall i, P i -> F i \in kS) -> \prod_(i <- r | P i) F i \in kS. +Proof. by move=> IH; elim/big_ind: _; [exact: rpred1 | exact: rpredM |]. Qed. + +Lemma rpredX n : {in kS, forall u, u ^+ n \in kS}. +Proof. by move=> u Su; rewrite -(card_ord n) -prodr_const rpred_prod. Qed. + +End Mul. + +Lemma rpred_nat (rngS : semiringPred S) (kS : keyed_pred rngS) n : n%:R \in kS. +Proof. by rewrite rpredMn ?rpred1. Qed. + +Lemma rpredN1 (mulS : smulrPred S) (kS : keyed_pred mulS) : -1 \in kS. +Proof. by rewrite rpredN rpred1. Qed. + +Lemma rpred_sign (mulS : smulrPred S) (kS : keyed_pred mulS) n : + (-1) ^+ n \in kS. +Proof. by rewrite rpredX ?rpredN1. Qed. + +End RingPred. + +Section LmodPred. + +Variables (R : ringType) (V : lmodType R) (S : predPredType V). + +Lemma rpredZsign (oppS : opprPred S) (kS : keyed_pred oppS) n u : + ((-1) ^+ n *: u \in kS) = (u \in kS). +Proof. by rewrite -signr_odd scaler_sign fun_if if_arg rpredN if_same. Qed. + +Lemma rpredZnat (addS : addrPred S) (kS : keyed_pred addS) n : + {in kS, forall u, n%:R *: u \in kS}. +Proof. by move=> u Su; rewrite /= scaler_nat rpredMn. Qed. + +Lemma rpredZ (linS : submodPred S) (kS : keyed_pred linS) : scaler_closed kS. +Proof. by move=> a u; rewrite !keyed_predE; case: {kS}linS => _; apply. Qed. + +End LmodPred. + +Section UnitRingPred. + +Variable R : unitRingType. + +Section Div. + +Variables (S : predPredType R) (divS : divrPred S) (kS : keyed_pred divS). + +Lemma rpredVr x : x \in kS -> x^-1 \in kS. +Proof. by rewrite !keyed_predE; case: divS x. Qed. + +Lemma rpredV x : (x^-1 \in kS) = (x \in kS). +Proof. by apply/idP/idP=> /rpredVr; rewrite ?invrK. Qed. + +Lemma rpred_div : {in kS &, forall x y, x / y \in kS}. +Proof. by move=> x y Sx Sy; rewrite /= rpredM ?rpredV. Qed. + +Lemma rpredXN n : {in kS, forall x, x ^- n \in kS}. +Proof. by move=> x Sx; rewrite /= rpredV rpredX. Qed. + +Lemma rpredMl x y : x \in kS -> x \is a unit-> (x * y \in kS) = (y \in kS). +Proof. +move=> Sx Ux; apply/idP/idP=> [Sxy | /(rpredM Sx)-> //]. +by rewrite -(mulKr Ux y); rewrite rpredM ?rpredV. +Qed. + +Lemma rpredMr x y : x \in kS -> x \is a unit -> (y * x \in kS) = (y \in kS). +Proof. +move=> Sx Ux; apply/idP/idP=> [Sxy | /rpredM-> //]. +by rewrite -(mulrK Ux y); rewrite rpred_div. +Qed. + +Lemma rpred_divr x y : x \in kS -> x \is a unit -> (y / x \in kS) = (y \in kS). +Proof. by rewrite -rpredV -unitrV; apply: rpredMr. Qed. + +Lemma rpred_divl x y : x \in kS -> x \is a unit -> (x / y \in kS) = (y \in kS). +Proof. by rewrite -(rpredV y); apply: rpredMl. Qed. + +End Div. + +Fact unitr_sdivr_closed : @sdivr_closed R unit. +Proof. by split=> [|x y Ux Uy]; rewrite ?unitrN1 // unitrMl ?unitrV. Qed. + +Canonical unit_opprPred := OpprPred unitr_sdivr_closed. +Canonical unit_mulrPred := MulrPred unitr_sdivr_closed. +Canonical unit_divrPred := DivrPred unitr_sdivr_closed. +Canonical unit_smulrPred := SmulrPred unitr_sdivr_closed. +Canonical unit_sdivrPred := SdivrPred unitr_sdivr_closed. + +Implicit Type x : R. + +Lemma unitrN x : (- x \is a unit) = (x \is a unit). Proof. exact: rpredN. Qed. + +Lemma invrN x : (- x)^-1 = - x^-1. +Proof. +have [Ux | U'x] := boolP (x \is a unit); last by rewrite !invr_out ?unitrN. +by rewrite -mulN1r invrM ?unitrN1 // invrN1 mulrN1. +Qed. + +Lemma invr_signM n x : ((-1) ^+ n * x)^-1 = (-1) ^+ n * x^-1. +Proof. by rewrite -signr_odd !mulr_sign; case: ifP => // _; rewrite invrN. Qed. + +Lemma divr_signM (b1 b2 : bool) x1 x2: + ((-1) ^+ b1 * x1) / ((-1) ^+ b2 * x2) = (-1) ^+ (b1 (+) b2) * (x1 / x2). +Proof. by rewrite invr_signM mulr_signM. Qed. + +End UnitRingPred. + +(* Reification of the theory of rings with units, in named style *) +Section TermDef. + +Variable R : Type. + +Inductive term : Type := +| Var of nat +| Const of R +| NatConst of nat +| Add of term & term +| Opp of term +| NatMul of term & nat +| Mul of term & term +| Inv of term +| Exp of term & nat. + +Inductive formula : Type := +| Bool of bool +| Equal of term & term +| Unit of term +| And of formula & formula +| Or of formula & formula +| Implies of formula & formula +| Not of formula +| Exists of nat & formula +| Forall of nat & formula. + +End TermDef. + +Bind Scope term_scope with term. +Bind Scope term_scope with formula. +Arguments Scope Add [_ term_scope term_scope]. +Arguments Scope Opp [_ term_scope]. +Arguments Scope NatMul [_ term_scope nat_scope]. +Arguments Scope Mul [_ term_scope term_scope]. +Arguments Scope Mul [_ term_scope term_scope]. +Arguments Scope Inv [_ term_scope]. +Arguments Scope Exp [_ term_scope nat_scope]. +Arguments Scope Equal [_ term_scope term_scope]. +Arguments Scope Unit [_ term_scope]. +Arguments Scope And [_ term_scope term_scope]. +Arguments Scope Or [_ term_scope term_scope]. +Arguments Scope Implies [_ term_scope term_scope]. +Arguments Scope Not [_ term_scope]. +Arguments Scope Exists [_ nat_scope term_scope]. +Arguments Scope Forall [_ nat_scope term_scope]. + +Implicit Arguments Bool [R]. +Prenex Implicits Const Add Opp NatMul Mul Exp Bool Unit And Or Implies Not. +Prenex Implicits Exists Forall. + +Notation True := (Bool true). +Notation False := (Bool false). + +Local Notation "''X_' i" := (Var _ i) : term_scope. +Local Notation "n %:R" := (NatConst _ n) : term_scope. +Local Notation "x %:T" := (Const x) : term_scope. +Local Notation "0" := 0%:R%T : term_scope. +Local Notation "1" := 1%:R%T : term_scope. +Local Infix "+" := Add : term_scope. +Local Notation "- t" := (Opp t) : term_scope. +Local Notation "t - u" := (Add t (- u)) : term_scope. +Local Infix "*" := Mul : term_scope. +Local Infix "*+" := NatMul : term_scope. +Local Notation "t ^-1" := (Inv t) : term_scope. +Local Notation "t / u" := (Mul t u^-1) : term_scope. +Local Infix "^+" := Exp : term_scope. +Local Infix "==" := Equal : term_scope. +Local Infix "/\" := And : term_scope. +Local Infix "\/" := Or : term_scope. +Local Infix "==>" := Implies : term_scope. +Local Notation "~ f" := (Not f) : term_scope. +Local Notation "x != y" := (Not (x == y)) : term_scope. +Local Notation "''exists' ''X_' i , f" := (Exists i f) : term_scope. +Local Notation "''forall' ''X_' i , f" := (Forall i f) : term_scope. + +Section Substitution. + +Variable R : Type. + +Fixpoint tsubst (t : term R) (s : nat * term R) := + match t with + | 'X_i => if i == s.1 then s.2 else t + | _%:T | _%:R => t + | t1 + t2 => tsubst t1 s + tsubst t2 s + | - t1 => - tsubst t1 s + | t1 *+ n => tsubst t1 s *+ n + | t1 * t2 => tsubst t1 s * tsubst t2 s + | t1^-1 => (tsubst t1 s)^-1 + | t1 ^+ n => tsubst t1 s ^+ n + end%T. + +Fixpoint fsubst (f : formula R) (s : nat * term R) := + match f with + | Bool _ => f + | t1 == t2 => tsubst t1 s == tsubst t2 s + | Unit t1 => Unit (tsubst t1 s) + | f1 /\ f2 => fsubst f1 s /\ fsubst f2 s + | f1 \/ f2 => fsubst f1 s \/ fsubst f2 s + | f1 ==> f2 => fsubst f1 s ==> fsubst f2 s + | ~ f1 => ~ fsubst f1 s + | ('exists 'X_i, f1) => 'exists 'X_i, if i == s.1 then f1 else fsubst f1 s + | ('forall 'X_i, f1) => 'forall 'X_i, if i == s.1 then f1 else fsubst f1 s + end%T. + +End Substitution. + +Section EvalTerm. + +Variable R : unitRingType. + +(* Evaluation of a reified term into R a ring with units *) +Fixpoint eval (e : seq R) (t : term R) {struct t} : R := + match t with + | ('X_i)%T => e`_i + | (x%:T)%T => x + | (n%:R)%T => n%:R + | (t1 + t2)%T => eval e t1 + eval e t2 + | (- t1)%T => - eval e t1 + | (t1 *+ n)%T => eval e t1 *+ n + | (t1 * t2)%T => eval e t1 * eval e t2 + | t1^-1%T => (eval e t1)^-1 + | (t1 ^+ n)%T => eval e t1 ^+ n + end. + +Definition same_env (e e' : seq R) := nth 0 e =1 nth 0 e'. + +Lemma eq_eval e e' t : same_env e e' -> eval e t = eval e' t. +Proof. by move=> eq_e; elim: t => //= t1 -> // t2 ->. Qed. + +Lemma eval_tsubst e t s : + eval e (tsubst t s) = eval (set_nth 0 e s.1 (eval e s.2)) t. +Proof. +case: s => i u; elim: t => //=; do 2?[move=> ? -> //] => j. +by rewrite nth_set_nth /=; case: (_ == _). +Qed. + +(* Evaluation of a reified formula *) +Fixpoint holds (e : seq R) (f : formula R) {struct f} : Prop := + match f with + | Bool b => b + | (t1 == t2)%T => eval e t1 = eval e t2 + | Unit t1 => eval e t1 \in unit + | (f1 /\ f2)%T => holds e f1 /\ holds e f2 + | (f1 \/ f2)%T => holds e f1 \/ holds e f2 + | (f1 ==> f2)%T => holds e f1 -> holds e f2 + | (~ f1)%T => ~ holds e f1 + | ('exists 'X_i, f1)%T => exists x, holds (set_nth 0 e i x) f1 + | ('forall 'X_i, f1)%T => forall x, holds (set_nth 0 e i x) f1 + end. + +Lemma same_env_sym e e' : same_env e e' -> same_env e' e. +Proof. exact: fsym. Qed. + +(* Extensionality of formula evaluation *) +Lemma eq_holds e e' f : same_env e e' -> holds e f -> holds e' f. +Proof. +pose sv := set_nth (0 : R). +have eq_i i v e1 e2: same_env e1 e2 -> same_env (sv e1 i v) (sv e2 i v). + by move=> eq_e j; rewrite !nth_set_nth /= eq_e. +elim: f e e' => //=. +- by move=> t1 t2 e e' eq_e; rewrite !(eq_eval _ eq_e). +- by move=> t e e' eq_e; rewrite (eq_eval _ eq_e). +- by move=> f1 IH1 f2 IH2 e e' eq_e; move/IH2: (eq_e); move/IH1: eq_e; tauto. +- by move=> f1 IH1 f2 IH2 e e' eq_e; move/IH2: (eq_e); move/IH1: eq_e; tauto. +- by move=> f1 IH1 f2 IH2 e e' eq_e f12; move/IH1: (same_env_sym eq_e); eauto. +- by move=> f1 IH1 e e'; move/same_env_sym; move/IH1; tauto. +- by move=> i f1 IH1 e e'; move/(eq_i i)=> eq_e [x f_ex]; exists x; eauto. +by move=> i f1 IH1 e e'; move/(eq_i i); eauto. +Qed. + +(* Evaluation and substitution by a constant *) +Lemma holds_fsubst e f i v : + holds e (fsubst f (i, v%:T)%T) <-> holds (set_nth 0 e i v) f. +Proof. +elim: f e => //=; do [ + by move=> *; rewrite !eval_tsubst +| move=> f1 IHf1 f2 IHf2 e; move: (IHf1 e) (IHf2 e); tauto +| move=> f IHf e; move: (IHf e); tauto +| move=> j f IHf e]. +- case eq_ji: (j == i); first rewrite (eqP eq_ji). + by split=> [] [x f_x]; exists x; rewrite set_set_nth eqxx in f_x *. + split=> [] [x f_x]; exists x; move: f_x; rewrite set_set_nth eq_sym eq_ji; + have:= IHf (set_nth 0 e j x); tauto. +case eq_ji: (j == i); first rewrite (eqP eq_ji). + by split=> [] f_ x; move: (f_ x); rewrite set_set_nth eqxx. +split=> [] f_ x; move: (IHf (set_nth 0 e j x)) (f_ x); + by rewrite set_set_nth eq_sym eq_ji; tauto. +Qed. + +(* Boolean test selecting terms in the language of rings *) +Fixpoint rterm (t : term R) := + match t with + | _^-1 => false + | t1 + t2 | t1 * t2 => rterm t1 && rterm t2 + | - t1 | t1 *+ _ | t1 ^+ _ => rterm t1 + | _ => true + end%T. + +(* Boolean test selecting formulas in the theory of rings *) +Fixpoint rformula (f : formula R) := + match f with + | Bool _ => true + | t1 == t2 => rterm t1 && rterm t2 + | Unit t1 => false + | f1 /\ f2 | f1 \/ f2 | f1 ==> f2 => rformula f1 && rformula f2 + | ~ f1 | ('exists 'X__, f1) | ('forall 'X__, f1) => rformula f1 + end%T. + +(* Upper bound of the names used in a term *) +Fixpoint ub_var (t : term R) := + match t with + | 'X_i => i.+1 + | t1 + t2 | t1 * t2 => maxn (ub_var t1) (ub_var t2) + | - t1 | t1 *+ _ | t1 ^+ _ | t1^-1 => ub_var t1 + | _ => 0%N + end%T. + +(* Replaces inverses in the term t by fresh variables, accumulating the *) +(* substitution. *) +Fixpoint to_rterm (t : term R) (r : seq (term R)) (n : nat) {struct t} := + match t with + | t1^-1 => + let: (t1', r1) := to_rterm t1 r n in + ('X_(n + size r1), rcons r1 t1') + | t1 + t2 => + let: (t1', r1) := to_rterm t1 r n in + let: (t2', r2) := to_rterm t2 r1 n in + (t1' + t2', r2) + | - t1 => + let: (t1', r1) := to_rterm t1 r n in + (- t1', r1) + | t1 *+ m => + let: (t1', r1) := to_rterm t1 r n in + (t1' *+ m, r1) + | t1 * t2 => + let: (t1', r1) := to_rterm t1 r n in + let: (t2', r2) := to_rterm t2 r1 n in + (Mul t1' t2', r2) + | t1 ^+ m => + let: (t1', r1) := to_rterm t1 r n in + (t1' ^+ m, r1) + | _ => (t, r) + end%T. + +Lemma to_rterm_id t r n : rterm t -> to_rterm t r n = (t, r). +Proof. +elim: t r n => //. +- by move=> t1 IHt1 t2 IHt2 r n /= /andP[rt1 rt2]; rewrite {}IHt1 // IHt2. +- by move=> t IHt r n /= rt; rewrite {}IHt. +- by move=> t IHt r n m /= rt; rewrite {}IHt. +- by move=> t1 IHt1 t2 IHt2 r n /= /andP[rt1 rt2]; rewrite {}IHt1 // IHt2. +- by move=> t IHt r n m /= rt; rewrite {}IHt. +Qed. + +(* A ring formula stating that t1 is equal to 0 in the ring theory. *) +(* Also applies to non commutative rings. *) +Definition eq0_rform t1 := + let m := ub_var t1 in + let: (t1', r1) := to_rterm t1 [::] m in + let fix loop r i := match r with + | [::] => t1' == 0 + | t :: r' => + let f := 'X_i * t == 1 /\ t * 'X_i == 1 in + 'forall 'X_i, (f \/ 'X_i == t /\ ~ ('exists 'X_i, f)) ==> loop r' i.+1 + end%T + in loop r1 m. + +(* Transformation of a formula in the theory of rings with units into an *) +(* equivalent formula in the sub-theory of rings. *) +Fixpoint to_rform f := + match f with + | Bool b => f + | t1 == t2 => eq0_rform (t1 - t2) + | Unit t1 => eq0_rform (t1 * t1^-1 - 1) + | f1 /\ f2 => to_rform f1 /\ to_rform f2 + | f1 \/ f2 => to_rform f1 \/ to_rform f2 + | f1 ==> f2 => to_rform f1 ==> to_rform f2 + | ~ f1 => ~ to_rform f1 + | ('exists 'X_i, f1) => 'exists 'X_i, to_rform f1 + | ('forall 'X_i, f1) => 'forall 'X_i, to_rform f1 + end%T. + +(* The transformation gives a ring formula. *) +Lemma to_rform_rformula f : rformula (to_rform f). +Proof. +suffices eq0_ring t1: rformula (eq0_rform t1) by elim: f => //= => f1 ->. +rewrite /eq0_rform; move: (ub_var t1) => m; set tr := _ m. +suffices: all rterm (tr.1 :: tr.2). + case: tr => {t1} t1 r /= /andP[t1_r]. + by elim: r m => [|t r IHr] m; rewrite /= ?andbT // => /andP[->]; exact: IHr. +have: all rterm [::] by []. +rewrite {}/tr; elim: t1 [::] => //=. +- move=> t1 IHt1 t2 IHt2 r. + move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /= /andP[t1_r]. + move/IHt2; case: to_rterm => {t2 r IHt2} t2 r /= /andP[t2_r]. + by rewrite t1_r t2_r. +- by move=> t1 IHt1 r /IHt1; case: to_rterm. +- by move=> t1 IHt1 n r /IHt1; case: to_rterm. +- move=> t1 IHt1 t2 IHt2 r. + move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /= /andP[t1_r]. + move/IHt2; case: to_rterm => {t2 r IHt2} t2 r /= /andP[t2_r]. + by rewrite t1_r t2_r. +- move=> t1 IHt1 r. + by move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /=; rewrite all_rcons. +- by move=> t1 IHt1 n r /IHt1; case: to_rterm. +Qed. + +(* Correctness of the transformation. *) +Lemma to_rformP e f : holds e (to_rform f) <-> holds e f. +Proof. +suffices{e f} equal0_equiv e t1 t2: + holds e (eq0_rform (t1 - t2)) <-> (eval e t1 == eval e t2). +- elim: f e => /=; try tauto. + + move=> t1 t2 e. + by split; [move/equal0_equiv/eqP | move/eqP/equal0_equiv]. + + move=> t1 e; rewrite unitrE; exact: equal0_equiv. + + move=> f1 IHf1 f2 IHf2 e; move: (IHf1 e) (IHf2 e); tauto. + + move=> f1 IHf1 f2 IHf2 e; move: (IHf1 e) (IHf2 e); tauto. + + move=> f1 IHf1 f2 IHf2 e; move: (IHf1 e) (IHf2 e); tauto. + + move=> f1 IHf1 e; move: (IHf1 e); tauto. + + by move=> n f1 IHf1 e; split=> [] [x] /IHf1; exists x. + + by move=> n f1 IHf1 e; split=> Hx x; apply/IHf1. +rewrite -(add0r (eval e t2)) -(can2_eq (subrK _) (addrK _)). +rewrite -/(eval e (t1 - t2)); move: (t1 - t2)%T => {t1 t2} t. +have sub_var_tsubst s t0: s.1 >= ub_var t0 -> tsubst t0 s = t0. + elim: t0 {t} => //=. + - by move=> n; case: ltngtP. + - by move=> t1 IHt1 t2 IHt2; rewrite geq_max => /andP[/IHt1-> /IHt2->]. + - by move=> t1 IHt1 /IHt1->. + - by move=> t1 IHt1 n /IHt1->. + - by move=> t1 IHt1 t2 IHt2; rewrite geq_max => /andP[/IHt1-> /IHt2->]. + - by move=> t1 IHt1 /IHt1->. + - by move=> t1 IHt1 n /IHt1->. +pose fix rsub t' m r : term R := + if r is u :: r' then tsubst (rsub t' m.+1 r') (m, u^-1)%T else t'. +pose fix ub_sub m r : Prop := + if r is u :: r' then ub_var u <= m /\ ub_sub m.+1 r' else true. +suffices{t} rsub_to_r t r0 m: m >= ub_var t -> ub_sub m r0 -> + let: (t', r) := to_rterm t r0 m in + [/\ take (size r0) r = r0, + ub_var t' <= m + size r, ub_sub m r & rsub t' m r = t]. +- have:= rsub_to_r t [::] _ (leqnn _); rewrite /eq0_rform. + case: (to_rterm _ _ _) => [t1' r1] [//|_ _ ub_r1 def_t]. + rewrite -{2}def_t {def_t}. + elim: r1 (ub_var t) e ub_r1 => [|u r1 IHr1] m e /= => [_|[ub_u ub_r1]]. + by split=> /eqP. + rewrite eval_tsubst /=; set y := eval e u; split=> t_eq0. + apply/IHr1=> //; apply: t_eq0. + rewrite nth_set_nth /= eqxx -(eval_tsubst e u (m, Const _)). + rewrite sub_var_tsubst //= -/y. + case Uy: (y \in unit); [left | right]; first by rewrite mulVr ?divrr. + split=> [|[z]]; first by rewrite invr_out ?Uy. + rewrite nth_set_nth /= eqxx. + rewrite -!(eval_tsubst _ _ (m, Const _)) !sub_var_tsubst // -/y => yz1. + by case/unitrP: Uy; exists z. + move=> x def_x; apply/IHr1=> //; suff ->: x = y^-1 by []; move: def_x. + rewrite nth_set_nth /= eqxx -(eval_tsubst e u (m, Const _)). + rewrite sub_var_tsubst //= -/y; case=> [[xy1 yx1] | [xy nUy]]. + by rewrite -[y^-1]mul1r -[1]xy1 mulrK //; apply/unitrP; exists x. + rewrite invr_out //; apply/unitrP=> [[z yz1]]; case: nUy; exists z. + rewrite nth_set_nth /= eqxx -!(eval_tsubst _ _ (m, _%:T)%T). + by rewrite !sub_var_tsubst. +have rsub_id r t0 n: ub_var t0 <= n -> rsub t0 n r = t0. + by elim: r n => //= t1 r IHr n let0n; rewrite IHr ?sub_var_tsubst ?leqW. +have rsub_acc r s t1 m1: + ub_var t1 <= m1 + size r -> rsub t1 m1 (r ++ s) = rsub t1 m1 r. + elim: r t1 m1 => [|t1 r IHr] t2 m1 /=; first by rewrite addn0; apply: rsub_id. + by move=> letmr; rewrite IHr ?addSnnS. +elim: t r0 m => /=; try do [ + by move=> n r m hlt hub; rewrite take_size (ltn_addr _ hlt) rsub_id +| by move=> n r m hlt hub; rewrite leq0n take_size rsub_id +| move=> t1 IHt1 t2 IHt2 r m; rewrite geq_max; case/andP=> hub1 hub2 hmr; + case: to_rterm {IHt1 hub1 hmr}(IHt1 r m hub1 hmr) => t1' r1; + case=> htake1 hub1' hsub1 <-; + case: to_rterm {IHt2 hub2 hsub1}(IHt2 r1 m hub2 hsub1) => t2' r2 /=; + rewrite geq_max; case=> htake2 -> hsub2 /= <-; + rewrite -{1 2}(cat_take_drop (size r1) r2) htake2; set r3 := drop _ _; + rewrite size_cat addnA (leq_trans _ (leq_addr _ _)) //; + split=> {hsub2}//; + first by [rewrite takel_cat // -htake1 size_take geq_min leqnn orbT]; + rewrite -(rsub_acc r1 r3 t1') {hub1'}// -{htake1}htake2 {r3}cat_take_drop; + by elim: r2 m => //= u r2 IHr2 m; rewrite IHr2 +| do [ move=> t1 IHt1 r m; do 2!move/IHt1=> {IHt1}IHt1 + | move=> t1 IHt1 n r m; do 2!move/IHt1=> {IHt1}IHt1]; + case: to_rterm IHt1 => t1' r1 [-> -> hsub1 <-]; split=> {hsub1}//; + by elim: r1 m => //= u r1 IHr1 m; rewrite IHr1]. +move=> t1 IH r m letm /IH {IH} /(_ letm) {letm}. +case: to_rterm => t1' r1 /= [def_r ub_t1' ub_r1 <-]. +rewrite size_rcons addnS leqnn -{1}cats1 takel_cat ?def_r; last first. + by rewrite -def_r size_take geq_min leqnn orbT. +elim: r1 m ub_r1 ub_t1' {def_r} => /= [|u r1 IHr1] m => [_|[->]]. + by rewrite addn0 eqxx. +by rewrite -addSnnS => /IHr1 IH /IH[_ _ ub_r1 ->]. +Qed. + +(* Boolean test selecting formulas which describe a constructible set, *) +(* i.e. formulas without quantifiers. *) + +(* The quantifier elimination check. *) +Fixpoint qf_form (f : formula R) := + match f with + | Bool _ | _ == _ | Unit _ => true + | f1 /\ f2 | f1 \/ f2 | f1 ==> f2 => qf_form f1 && qf_form f2 + | ~ f1 => qf_form f1 + | _ => false + end%T. + +(* Boolean holds predicate for quantifier free formulas *) +Definition qf_eval e := fix loop (f : formula R) : bool := + match f with + | Bool b => b + | t1 == t2 => (eval e t1 == eval e t2)%bool + | Unit t1 => eval e t1 \in unit + | f1 /\ f2 => loop f1 && loop f2 + | f1 \/ f2 => loop f1 || loop f2 + | f1 ==> f2 => (loop f1 ==> loop f2)%bool + | ~ f1 => ~~ loop f1 + |_ => false + end%T. + +(* qf_eval is equivalent to holds *) +Lemma qf_evalP e f : qf_form f -> reflect (holds e f) (qf_eval e f). +Proof. +elim: f => //=; try by move=> *; exact: idP. +- move=> t1 t2 _; exact: eqP. +- move=> f1 IHf1 f2 IHf2 /= /andP[/IHf1[] f1T]; last by right; case. + by case/IHf2; [left | right; case]. +- move=> f1 IHf1 f2 IHf2 /= /andP[/IHf1[] f1F]; first by do 2 left. + by case/IHf2; [left; right | right; case]. +- move=> f1 IHf1 f2 IHf2 /= /andP[/IHf1[] f1T]; last by left. + by case/IHf2; [left | right; move/(_ f1T)]. +by move=> f1 IHf1 /IHf1[]; [right | left]. +Qed. + +Implicit Type bc : seq (term R) * seq (term R). + +(* Quantifier-free formula are normalized into DNF. A DNF is *) +(* represented by the type seq (seq (term R) * seq (term R)), where we *) +(* separate positive and negative literals *) + +(* DNF preserving conjunction *) +Definition and_dnf bcs1 bcs2 := + \big[cat/nil]_(bc1 <- bcs1) + map (fun bc2 => (bc1.1 ++ bc2.1, bc1.2 ++ bc2.2)) bcs2. + +(* Computes a DNF from a qf ring formula *) +Fixpoint qf_to_dnf (f : formula R) (neg : bool) {struct f} := + match f with + | Bool b => if b (+) neg then [:: ([::], [::])] else [::] + | t1 == t2 => [:: if neg then ([::], [:: t1 - t2]) else ([:: t1 - t2], [::])] + | f1 /\ f2 => (if neg then cat else and_dnf) [rec f1, neg] [rec f2, neg] + | f1 \/ f2 => (if neg then and_dnf else cat) [rec f1, neg] [rec f2, neg] + | f1 ==> f2 => (if neg then and_dnf else cat) [rec f1, ~~ neg] [rec f2, neg] + | ~ f1 => [rec f1, ~~ neg] + | _ => if neg then [:: ([::], [::])] else [::] + end%T where "[ 'rec' f , neg ]" := (qf_to_dnf f neg). + +(* Conversely, transforms a DNF into a formula *) +Definition dnf_to_form := + let pos_lit t := And (t == 0) in let neg_lit t := And (t != 0) in + let cls bc := Or (foldr pos_lit True bc.1 /\ foldr neg_lit True bc.2) in + foldr cls False. + +(* Catenation of dnf is the Or of formulas *) +Lemma cat_dnfP e bcs1 bcs2 : + qf_eval e (dnf_to_form (bcs1 ++ bcs2)) + = qf_eval e (dnf_to_form bcs1 \/ dnf_to_form bcs2). +Proof. +by elim: bcs1 => //= bc1 bcs1 IH1; rewrite -orbA; congr orb; rewrite IH1. +Qed. + +(* and_dnf is the And of formulas *) +Lemma and_dnfP e bcs1 bcs2 : + qf_eval e (dnf_to_form (and_dnf bcs1 bcs2)) + = qf_eval e (dnf_to_form bcs1 /\ dnf_to_form bcs2). +Proof. +elim: bcs1 => [|bc1 bcs1 IH1] /=; first by rewrite /and_dnf big_nil. +rewrite /and_dnf big_cons -/(and_dnf bcs1 bcs2) cat_dnfP /=. +rewrite {}IH1 /= andb_orl; congr orb. +elim: bcs2 bc1 {bcs1} => [|bc2 bcs2 IH] bc1 /=; first by rewrite andbF. +rewrite {}IH /= andb_orr; congr orb => {bcs2}. +suffices aux (l1 l2 : seq (term R)) g : let redg := foldr (And \o g) True in + qf_eval e (redg (l1 ++ l2)) = qf_eval e (redg l1 /\ redg l2)%T. ++ by rewrite 2!aux /= 2!andbA -andbA -andbCA andbA andbCA andbA. +by elim: l1 => [| t1 l1 IHl1] //=; rewrite -andbA IHl1. +Qed. + +Lemma qf_to_dnfP e : + let qev f b := qf_eval e (dnf_to_form (qf_to_dnf f b)) in + forall f, qf_form f && rformula f -> qev f false = qf_eval e f. +Proof. +move=> qev; have qevT f: qev f true = ~~ qev f false. + rewrite {}/qev; elim: f => //=; do [by case | move=> f1 IH1 f2 IH2 | ]. + - by move=> t1 t2; rewrite !andbT !orbF. + - by rewrite and_dnfP cat_dnfP negb_and -IH1 -IH2. + - by rewrite and_dnfP cat_dnfP negb_or -IH1 -IH2. + - by rewrite and_dnfP cat_dnfP /= negb_or IH1 -IH2 negbK. + by move=> t1 ->; rewrite negbK. +rewrite /qev; elim=> //=; first by case. +- by move=> t1 t2 _; rewrite subr_eq0 !andbT orbF. +- move=> f1 IH1 f2 IH2; rewrite andbCA -andbA andbCA andbA; case/andP. + by rewrite and_dnfP /= => /IH1-> /IH2->. +- move=> f1 IH1 f2 IH2; rewrite andbCA -andbA andbCA andbA; case/andP. + by rewrite cat_dnfP /= => /IH1-> => /IH2->. +- move=> f1 IH1 f2 IH2; rewrite andbCA -andbA andbCA andbA; case/andP. + by rewrite cat_dnfP /= [qf_eval _ _]qevT -implybE => /IH1 <- /IH2->. +by move=> f1 IH1 /IH1 <-; rewrite -qevT. +Qed. + +Lemma dnf_to_form_qf bcs : qf_form (dnf_to_form bcs). +Proof. +by elim: bcs => //= [[clT clF] _ ->] /=; elim: clT => //=; elim: clF. +Qed. + +Definition dnf_rterm cl := all rterm cl.1 && all rterm cl.2. + +Lemma qf_to_dnf_rterm f b : rformula f -> all dnf_rterm (qf_to_dnf f b). +Proof. +set ok := all dnf_rterm. +have cat_ok bcs1 bcs2: ok bcs1 -> ok bcs2 -> ok (bcs1 ++ bcs2). + by move=> ok1 ok2; rewrite [ok _]all_cat; exact/andP. +have and_ok bcs1 bcs2: ok bcs1 -> ok bcs2 -> ok (and_dnf bcs1 bcs2). + rewrite /and_dnf unlock; elim: bcs1 => //= cl1 bcs1 IH1; rewrite -andbA. + case/and3P=> ok11 ok12 ok1 ok2; rewrite cat_ok ?{}IH1 {bcs1 ok1}//. + elim: bcs2 ok2 => //= cl2 bcs2 IH2 /andP[ok2 /IH2->]. + by rewrite /dnf_rterm !all_cat ok11 ok12 /= !andbT. +elim: f b => //=; [ by do 2!case | | | | | by auto | | ]; + try by repeat case/andP || intro; case: ifP; auto. +by rewrite /dnf_rterm => ?? [] /= ->. +Qed. + +Lemma dnf_to_rform bcs : rformula (dnf_to_form bcs) = all dnf_rterm bcs. +Proof. +elim: bcs => //= [[cl1 cl2] bcs ->]; rewrite {2}/dnf_rterm /=; congr (_ && _). +by congr andb; [elim: cl1 | elim: cl2] => //= t cl ->; rewrite andbT. +Qed. + +Section If. + +Variables (pred_f then_f else_f : formula R). + +Definition If := (pred_f /\ then_f \/ ~ pred_f /\ else_f)%T. + +Lemma If_form_qf : + qf_form pred_f -> qf_form then_f -> qf_form else_f -> qf_form If. +Proof. by move=> /= -> -> ->. Qed. + +Lemma If_form_rf : + rformula pred_f -> rformula then_f -> rformula else_f -> rformula If. +Proof. by move=> /= -> -> ->. Qed. + +Lemma eval_If e : + let ev := qf_eval e in ev If = (if ev pred_f then ev then_f else ev else_f). +Proof. by rewrite /=; case: ifP => _; rewrite ?orbF. Qed. + +End If. + +Section Pick. + +Variables (I : finType) (pred_f then_f : I -> formula R) (else_f : formula R). + +Definition Pick := + \big[Or/False]_(p : {ffun pred I}) + ((\big[And/True]_i (if p i then pred_f i else ~ pred_f i)) + /\ (if pick p is Some i then then_f i else else_f))%T. + +Lemma Pick_form_qf : + (forall i, qf_form (pred_f i)) -> + (forall i, qf_form (then_f i)) -> + qf_form else_f -> + qf_form Pick. +Proof. +move=> qfp qft qfe; have mA := (big_morph qf_form) true andb. +rewrite mA // big1 //= => p _. +rewrite mA // big1 => [|i _]; first by case: pick. +by rewrite fun_if if_same /= qfp. +Qed. + +Lemma eval_Pick e (qev := qf_eval e) : + let P i := qev (pred_f i) in + qev Pick = (if pick P is Some i then qev (then_f i) else qev else_f). +Proof. +move=> P; rewrite ((big_morph qev) false orb) //= big_orE /=. +apply/existsP/idP=> [[p] | true_at_P]. + rewrite ((big_morph qev) true andb) //= big_andE /=. + case/andP=> /forallP-eq_p_P. + rewrite (@eq_pick _ _ P) => [|i]; first by case: pick. + by move/(_ i): eq_p_P => /=; case: (p i) => //=; move/negbTE. +exists [ffun i => P i] => /=; apply/andP; split. + rewrite ((big_morph qev) true andb) //= big_andE /=. + by apply/forallP=> i; rewrite /= ffunE; case Pi: (P i) => //=; apply: negbT. +rewrite (@eq_pick _ _ P) => [|i]; first by case: pick true_at_P. +by rewrite ffunE. +Qed. + +End Pick. + +Section MultiQuant. + +Variable f : formula R. +Implicit Types (I : seq nat) (e : seq R). + +Lemma foldExistsP I e : + (exists2 e', {in [predC I], same_env e e'} & holds e' f) + <-> holds e (foldr Exists f I). +Proof. +elim: I e => /= [|i I IHi] e. + by split=> [[e' eq_e] |]; [apply: eq_holds => i; rewrite eq_e | exists e]. +split=> [[e' eq_e f_e'] | [x]]; last set e_x := set_nth 0 e i x. + exists e'`_i; apply/IHi; exists e' => // j. + by have:= eq_e j; rewrite nth_set_nth /= !inE; case: eqP => // ->. +case/IHi=> e' eq_e f_e'; exists e' => // j. +by have:= eq_e j; rewrite nth_set_nth /= !inE; case: eqP. +Qed. + +Lemma foldForallP I e : + (forall e', {in [predC I], same_env e e'} -> holds e' f) + <-> holds e (foldr Forall f I). +Proof. +elim: I e => /= [|i I IHi] e. + by split=> [|f_e e' eq_e]; [exact | apply: eq_holds f_e => i; rewrite eq_e]. +split=> [f_e' x | f_e e' eq_e]; first set e_x := set_nth 0 e i x. + apply/IHi=> e' eq_e; apply: f_e' => j. + by have:= eq_e j; rewrite nth_set_nth /= !inE; case: eqP. +move/IHi: (f_e e'`_i); apply=> j. +by have:= eq_e j; rewrite nth_set_nth /= !inE; case: eqP => // ->. +Qed. + +End MultiQuant. + +End EvalTerm. + +Prenex Implicits dnf_rterm. + +Module IntegralDomain. + +Definition axiom (R : ringType) := + forall x y : R, x * y = 0 -> (x == 0) || (y == 0). + +Section ClassDef. + +Record class_of (R : Type) : Type := + Class {base : ComUnitRing.class_of R; mixin : axiom (Ring.Pack base R)}. +Local Coercion base : class_of >-> ComUnitRing.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variable (T : Type) (cT : type). +Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c. +Definition clone c of phant_id class c := @Pack T c T. +Let xT := let: Pack T _ _ := cT in T. +Notation xclass := (class : class_of xT). + +Definition pack b0 (m0 : axiom (@Ring.Pack T b0 T)) := + fun bT b & phant_id (ComUnitRing.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 := @Zmodule.Pack cT xclass xT. +Definition ringType := @Ring.Pack cT xclass xT. +Definition comRingType := @ComRing.Pack cT xclass xT. +Definition unitRingType := @UnitRing.Pack cT xclass xT. +Definition comUnitRingType := @ComUnitRing.Pack cT xclass xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> ComUnitRing.class_of. +Implicit Arguments mixin [R x y]. +Coercion mixin : class_of >-> axiom. +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 >-> Zmodule.type. +Canonical zmodType. +Coercion ringType : type >-> Ring.type. +Canonical ringType. +Coercion comRingType : type >-> ComRing.type. +Canonical comRingType. +Coercion unitRingType : type >-> UnitRing.type. +Canonical unitRingType. +Coercion comUnitRingType : type >-> ComUnitRing.type. +Canonical comUnitRingType. +Notation idomainType := type. +Notation IdomainType T m := (@pack T _ m _ _ id _ id). +Notation "[ 'idomainType' 'of' T 'for' cT ]" := (@clone T cT _ idfun) + (at level 0, format "[ 'idomainType' 'of' T 'for' cT ]") : form_scope. +Notation "[ 'idomainType' 'of' T ]" := (@clone T _ _ id) + (at level 0, format "[ 'idomainType' 'of' T ]") : form_scope. +End Exports. + +End IntegralDomain. +Import IntegralDomain.Exports. + +Section IntegralDomainTheory. + +Variable R : idomainType. +Implicit Types x y : R. + +Lemma mulf_eq0 x y : (x * y == 0) = (x == 0) || (y == 0). +Proof. +apply/eqP/idP; first by case: R x y => T []. +by case/pred2P=> ->; rewrite (mulr0, mul0r). +Qed. + +Lemma prodf_eq0 (I : finType) (P : pred I) (F : I -> R) : + reflect (exists2 i, P i & (F i == 0)) (\prod_(i | P i) F i == 0). +Proof. +apply: (iffP idP) => [|[i Pi /eqP Fi0]]; last first. + by rewrite (bigD1 i) //= Fi0 mul0r. +elim: (index_enum _) => [|i r IHr]; first by rewrite big_nil oner_eq0. +rewrite big_cons /=; have [Pi | _] := ifP; last exact: IHr. +by rewrite mulf_eq0; case/orP=> // Fi0; exists i. +Qed. + +Lemma prodf_seq_eq0 I r (P : pred I) (F : I -> R) : + (\prod_(i <- r | P i) F i == 0) = has (fun i => P i && (F i == 0)) r. +Proof. by rewrite (big_morph _ mulf_eq0 (oner_eq0 _)) big_has_cond. Qed. + +Lemma mulf_neq0 x y : x != 0 -> y != 0 -> x * y != 0. +Proof. move=> x0 y0; rewrite mulf_eq0; exact/norP. Qed. + +Lemma prodf_neq0 (I : finType) (P : pred I) (F : I -> R) : + reflect (forall i, P i -> (F i != 0)) (\prod_(i | P i) F i != 0). +Proof. +by rewrite (sameP (prodf_eq0 _ _) exists_inP) negb_exists_in; exact: forall_inP. +Qed. + +Lemma prodf_seq_neq0 I r (P : pred I) (F : I -> R) : + (\prod_(i <- r | P i) F i != 0) = all (fun i => P i ==> (F i != 0)) r. +Proof. +rewrite prodf_seq_eq0 -all_predC; apply: eq_all => i /=. +by rewrite implybE negb_and. +Qed. + +Lemma expf_eq0 x n : (x ^+ n == 0) = (n > 0) && (x == 0). +Proof. +elim: n => [|n IHn]; first by rewrite oner_eq0. +by rewrite exprS mulf_eq0 IHn andKb. +Qed. + +Lemma sqrf_eq0 x : (x ^+ 2 == 0) = (x == 0). Proof. exact: expf_eq0. Qed. + +Lemma expf_neq0 x m : x != 0 -> x ^+ m != 0. +Proof. by move=> x_nz; rewrite expf_eq0; apply/nandP; right. Qed. + +Lemma natf_neq0 n : (n%:R != 0 :> R) = [char R]^'.-nat n. +Proof. +have [-> | /prod_prime_decomp->] := posnP n; first by rewrite eqxx. +rewrite !big_seq; elim/big_rec: _ => [|[p e] s /=]; first by rewrite oner_eq0. +case/mem_prime_decomp=> p_pr _ _; rewrite pnat_mul pnat_exp eqn0Ngt orbC => <-. +by rewrite natrM natrX mulf_eq0 expf_eq0 negb_or negb_and pnatE ?inE p_pr. +Qed. + +Lemma natf0_char n : n > 0 -> n%:R == 0 :> R -> exists p, p \in [char R]. +Proof. +move=> n_gt0 nR_0; exists (pdiv n`_[char R]). +apply: pnatP (pdiv_dvd _); rewrite ?part_pnat // ?pdiv_prime //. +by rewrite ltn_neqAle eq_sym partn_eq1 // -natf_neq0 nR_0 /=. +Qed. + +Lemma charf'_nat n : [char R]^'.-nat n = (n%:R != 0 :> R). +Proof. +have [-> | n_gt0] := posnP n; first by rewrite eqxx. +apply/idP/idP => [|nz_n]; last first. + by apply/pnatP=> // p p_pr p_dvd_n; apply: contra nz_n => /dvdn_charf <-. +apply: contraL => n0; have [// | p charRp] := natf0_char _ n0. +have [p_pr _] := andP charRp; rewrite (eq_pnat _ (eq_negn (charf_eq charRp))). +by rewrite p'natE // (dvdn_charf charRp) n0. +Qed. + +Lemma charf0P : [char R] =i pred0 <-> (forall n, (n%:R == 0 :> R) = (n == 0)%N). +Proof. +split=> charF0 n; last by rewrite !inE charF0 andbC; case: eqP => // ->. +have [-> | n_gt0] := posnP; first exact: eqxx. +by apply/negP; case/natf0_char=> // p; rewrite charF0. +Qed. + +Lemma eqf_sqr x y : (x ^+ 2 == y ^+ 2) = (x == y) || (x == - y). +Proof. by rewrite -subr_eq0 subr_sqr mulf_eq0 subr_eq0 addr_eq0. Qed. + +Lemma mulfI x : x != 0 -> injective ( *%R x). +Proof. +move=> nz_x y z; rewrite -[x * z]add0r; move/(canLR (addrK _))/eqP. +rewrite -mulrN -mulrDr mulf_eq0 (negbTE nz_x) /=. +by move/eqP/(canRL (subrK _)); rewrite add0r. +Qed. + +Lemma mulIf x : x != 0 -> injective ( *%R^~ x). +Proof. by move=> nz_x y z; rewrite -!(mulrC x); exact: mulfI. Qed. + +Lemma sqrf_eq1 x : (x ^+ 2 == 1) = (x == 1) || (x == -1). +Proof. by rewrite -subr_eq0 subr_sqr_1 mulf_eq0 subr_eq0 addr_eq0. Qed. + +Lemma expfS_eq1 x n : + (x ^+ n.+1 == 1) = (x == 1) || (\sum_(i < n.+1) x ^+ i == 0). +Proof. by rewrite -![_ == 1]subr_eq0 subrX1 mulf_eq0. Qed. + +Lemma lregP x : reflect (lreg x) (x != 0). +Proof. by apply: (iffP idP) => [/mulfI | /lreg_neq0]. Qed. + +Lemma rregP x : reflect (rreg x) (x != 0). +Proof. by apply: (iffP idP) => [/mulIf | /rreg_neq0]. Qed. + +Canonical regular_idomainType := [idomainType of R^o]. + +End IntegralDomainTheory. + +Implicit Arguments lregP [[R] [x]]. +Implicit Arguments rregP [[R] [x]]. + +Module Field. + +Definition mixin_of (F : unitRingType) := forall x : F, x != 0 -> x \in unit. + +Lemma IdomainMixin R : mixin_of R -> IntegralDomain.axiom R. +Proof. +move=> m x y xy0; apply/norP=> [[]] /m Ux /m. +by rewrite -(unitrMr _ Ux) xy0 unitr0. +Qed. + +Section Mixins. + +Variables (R : comRingType) (inv : R -> R). + +Definition axiom := forall x, x != 0 -> inv x * x = 1. +Hypothesis mulVx : axiom. +Hypothesis inv0 : inv 0 = 0. + +Fact intro_unit (x y : R) : y * x = 1 -> x != 0. +Proof. +by move=> yx1; apply: contraNneq (oner_neq0 R) => x0; rewrite -yx1 x0 mulr0. +Qed. + +Fact inv_out : {in predC (predC1 0), inv =1 id}. +Proof. by move=> x /negbNE/eqP->. Qed. + +Definition UnitMixin := ComUnitRing.Mixin mulVx intro_unit inv_out. + +Lemma Mixin : mixin_of (UnitRing.Pack (UnitRing.Class UnitMixin) R). +Proof. by []. Qed. + +End Mixins. + +Section ClassDef. + +Record class_of (F : Type) : Type := Class { + base : IntegralDomain.class_of F; + mixin : mixin_of (UnitRing.Pack base F) +}. +Local Coercion base : class_of >-> IntegralDomain.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variable (T : Type) (cT : type). +Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c. +Definition clone c of phant_id class c := @Pack T c T. +Let xT := let: Pack T _ _ := cT in T. +Notation xclass := (class : class_of xT). + +Definition pack b0 (m0 : mixin_of (@UnitRing.Pack T b0 T)) := + fun bT b & phant_id (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 := @Zmodule.Pack cT xclass xT. +Definition ringType := @Ring.Pack cT xclass xT. +Definition comRingType := @ComRing.Pack cT xclass xT. +Definition unitRingType := @UnitRing.Pack cT xclass xT. +Definition comUnitRingType := @ComUnitRing.Pack cT xclass xT. +Definition idomainType := @IntegralDomain.Pack cT xclass xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> IntegralDomain.class_of. +Implicit Arguments mixin [F x]. +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 >-> Zmodule.type. +Canonical zmodType. +Coercion ringType : type >-> Ring.type. +Canonical ringType. +Coercion comRingType : type >-> ComRing.type. +Canonical comRingType. +Coercion unitRingType : type >-> UnitRing.type. +Canonical unitRingType. +Coercion comUnitRingType : type >-> ComUnitRing.type. +Canonical comUnitRingType. +Coercion idomainType : type >-> IntegralDomain.type. +Canonical idomainType. +Notation fieldType := type. +Notation FieldType T m := (@pack T _ m _ _ id _ id). +Notation FieldUnitMixin := UnitMixin. +Notation FieldIdomainMixin := IdomainMixin. +Notation FieldMixin := Mixin. +Notation "[ 'fieldType' 'of' T 'for' cT ]" := (@clone T cT _ idfun) + (at level 0, format "[ 'fieldType' 'of' T 'for' cT ]") : form_scope. +Notation "[ 'fieldType' 'of' T ]" := (@clone T _ _ id) + (at level 0, format "[ 'fieldType' 'of' T ]") : form_scope. +End Exports. + +End Field. +Import Field.Exports. + +Section FieldTheory. + +Variable F : fieldType. +Implicit Types x y : F. + +Lemma fieldP : Field.mixin_of F. Proof. by case: F => T []. Qed. + +Lemma unitfE x : (x \in unit) = (x != 0). +Proof. by apply/idP/idP=> [/(memPn _)-> | /fieldP]; rewrite ?unitr0. Qed. + +Lemma mulVf x : x != 0 -> x^-1 * x = 1. +Proof. by rewrite -unitfE; exact: mulVr. Qed. +Lemma divff x : x != 0 -> x / x = 1. +Proof. by rewrite -unitfE; exact: divrr. Qed. +Definition mulfV := divff. +Lemma mulKf x : x != 0 -> cancel ( *%R x) ( *%R x^-1). +Proof. by rewrite -unitfE; exact: mulKr. Qed. +Lemma mulVKf x : x != 0 -> cancel ( *%R x^-1) ( *%R x). +Proof. by rewrite -unitfE; exact: mulVKr. Qed. +Lemma mulfK x : x != 0 -> cancel ( *%R^~ x) ( *%R^~ x^-1). +Proof. by rewrite -unitfE; exact: mulrK. Qed. +Lemma mulfVK x : x != 0 -> cancel ( *%R^~ x^-1) ( *%R^~ x). +Proof. by rewrite -unitfE; exact: divrK. Qed. +Definition divfK := mulfVK. + +Lemma invfM : {morph @inv F : x y / x * y}. +Proof. +move=> x y; case: (eqVneq x 0) => [-> |nzx]; first by rewrite !(mul0r, invr0). +case: (eqVneq y 0) => [-> |nzy]; first by rewrite !(mulr0, invr0). +by rewrite mulrC invrM ?unitfE. +Qed. + +Lemma invf_div x y : (x / y)^-1 = y / x. +Proof. by rewrite invfM invrK mulrC. Qed. + +Lemma expfB_cond m n x : (x == 0) + n <= m -> x ^+ (m - n) = x ^+ m / x ^+ n. +Proof. +move/subnK=> <-; rewrite addnA addnK !exprD. +have [-> | nz_x] := altP eqP; first by rewrite !mulr0 !mul0r. +by rewrite mulfK ?expf_neq0. +Qed. + +Lemma expfB m n x : n < m -> x ^+ (m - n) = x ^+ m / x ^+ n. +Proof. by move=> lt_n_m; apply: expfB_cond; case: eqP => // _; apply: ltnW. Qed. + +Lemma prodfV I r (P : pred I) (E : I -> F) : + \prod_(i <- r | P i) (E i)^-1 = (\prod_(i <- r | P i) E i)^-1. +Proof. by rewrite (big_morph _ invfM (invr1 F)). Qed. + +Lemma prodf_div I r (P : pred I) (E D : I -> F) : + \prod_(i <- r | P i) (E i / D i) = + \prod_(i <- r | P i) E i / \prod_(i <- r | P i) D i. +Proof. by rewrite big_split prodfV. Qed. + +Lemma telescope_prodf n m (f : nat -> F) : + (forall k, n < k < m -> f k != 0) -> n < m -> + \prod_(n <= k < m) (f k.+1 / f k) = f m / f n. +Proof. +move=> nz_f ltnm; apply: invr_inj; rewrite prodf_div !invf_div -prodf_div. +by apply: telescope_prodr => // k /nz_f; rewrite unitfE. +Qed. + +Lemma addf_div x1 y1 x2 y2 : + y1 != 0 -> y2 != 0 -> x1 / y1 + x2 / y2 = (x1 * y2 + x2 * y1) / (y1 * y2). +Proof. by move=> nzy1 nzy2; rewrite invfM mulrDl !mulrA mulrAC !mulfK. Qed. + +Lemma mulf_div x1 y1 x2 y2 : (x1 / y1) * (x2 / y2) = (x1 * x2) / (y1 * y2). +Proof. by rewrite mulrACA -invfM. Qed. + + +Lemma char0_natf_div : + [char F] =i pred0 -> forall m d, d %| m -> (m %/ d)%:R = m%:R / d%:R :> F. +Proof. +move/charf0P=> char0F m [|d] d_dv_m; first by rewrite divn0 invr0 mulr0. +by rewrite natr_div // unitfE char0F. +Qed. + +Section FieldMorphismInj. + +Variables (R : ringType) (f : {rmorphism F -> R}). + +Lemma fmorph_eq0 x : (f x == 0) = (x == 0). +Proof. +have [-> | nz_x] := altP (x =P _); first by rewrite rmorph0 eqxx. +apply/eqP; move/(congr1 ( *%R (f x^-1)))/eqP. +by rewrite -rmorphM mulVf // mulr0 rmorph1 ?oner_eq0. +Qed. + +Lemma fmorph_inj : injective f. +Proof. +move=> x y eqfxy; apply/eqP; rewrite -subr_eq0 -fmorph_eq0 rmorphB //. +by rewrite eqfxy subrr. +Qed. + +Lemma fmorph_eq1 x : (f x == 1) = (x == 1). +Proof. by rewrite -(inj_eq fmorph_inj) rmorph1. Qed. + +Lemma fmorph_char : [char R] =i [char F]. +Proof. by move=> p; rewrite !inE -fmorph_eq0 rmorph_nat. Qed. + +End FieldMorphismInj. + +Section FieldMorphismInv. + +Variables (R : unitRingType) (f : {rmorphism F -> R}). + +Lemma fmorph_unit x : (f x \in unit) = (x != 0). +Proof. +have [-> |] := altP (x =P _); first by rewrite rmorph0 unitr0. +by rewrite -unitfE; exact: rmorph_unit. +Qed. + +Lemma fmorphV : {morph f: x / x^-1}. +Proof. +move=> x; have [-> | nz_x] := eqVneq x 0; first by rewrite !(invr0, rmorph0). +by rewrite rmorphV ?unitfE. +Qed. + +Lemma fmorph_div : {morph f : x y / x / y}. +Proof. by move=> x y; rewrite rmorphM fmorphV. Qed. + +End FieldMorphismInv. + +Canonical regular_fieldType := [fieldType of F^o]. + +Section ModuleTheory. + +Variable V : lmodType F. +Implicit Types (a : F) (v : V). + +Lemma scalerK a : a != 0 -> cancel ( *:%R a : V -> V) ( *:%R a^-1). +Proof. by move=> nz_a v; rewrite scalerA mulVf // scale1r. Qed. + +Lemma scalerKV a : a != 0 -> cancel ( *:%R a^-1 : V -> V) ( *:%R a). +Proof. by rewrite -invr_eq0 -{3}[a]invrK; exact: scalerK. Qed. + +Lemma scalerI a : a != 0 -> injective ( *:%R a : V -> V). +Proof. move=> nz_a; exact: can_inj (scalerK nz_a). Qed. + +Lemma scaler_eq0 a v : (a *: v == 0) = (a == 0) || (v == 0). +Proof. +have [-> | nz_a] := altP (a =P _); first by rewrite scale0r eqxx. +by rewrite (can2_eq (scalerK nz_a) (scalerKV nz_a)) scaler0. +Qed. + +Lemma rpredZeq S (modS : submodPred S) (kS : keyed_pred modS) a v : + (a *: v \in kS) = (a == 0) || (v \in kS). +Proof. +have [-> | nz_a] := altP eqP; first by rewrite scale0r rpred0. +by apply/idP/idP; first rewrite -{2}(scalerK nz_a v); apply: rpredZ. +Qed. + +End ModuleTheory. + +Lemma char_lalg (A : lalgType F) : [char A] =i [char F]. +Proof. by move=> p; rewrite inE -scaler_nat scaler_eq0 oner_eq0 orbF. Qed. + +Section Predicates. + +Context (S : pred_class) (divS : @divrPred F S) (kS : keyed_pred divS). + +Lemma fpredMl x y : x \in kS -> x != 0 -> (x * y \in kS) = (y \in kS). +Proof. by rewrite -!unitfE; exact: rpredMl. Qed. + +Lemma fpredMr x y : x \in kS -> x != 0 -> (y * x \in kS) = (y \in kS). +Proof. by rewrite -!unitfE; exact: rpredMr. Qed. + +Lemma fpred_divl x y : x \in kS -> x != 0 -> (x / y \in kS) = (y \in kS). +Proof. by rewrite -!unitfE; exact: rpred_divl. Qed. + +Lemma fpred_divr x y : x \in kS -> x != 0 -> (y / x \in kS) = (y \in kS). +Proof. by rewrite -!unitfE; exact: rpred_divr. Qed. + +End Predicates. + +End FieldTheory. + +Implicit Arguments fmorph_inj [[F] [R] x1 x2]. + +Module DecidableField. + +Definition axiom (R : unitRingType) (s : seq R -> pred (formula R)) := + forall e f, reflect (holds e f) (s e f). + +Record mixin_of (R : unitRingType) : Type := + Mixin { sat : seq R -> pred (formula R); satP : axiom sat}. + +Section ClassDef. + +Record class_of (F : Type) : Type := + Class {base : Field.class_of F; mixin : mixin_of (UnitRing.Pack base F)}. +Local Coercion base : class_of >-> Field.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variable (T : Type) (cT : type). +Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c. +Definition clone c of phant_id class c := @Pack T c T. +Let xT := let: Pack T _ _ := cT in T. +Notation xclass := (class : class_of xT). + +Definition pack b0 (m0 : mixin_of (@UnitRing.Pack T b0 T)) := + fun bT b & phant_id (Field.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 := @Zmodule.Pack cT xclass xT. +Definition ringType := @Ring.Pack cT xclass xT. +Definition comRingType := @ComRing.Pack cT xclass xT. +Definition unitRingType := @UnitRing.Pack cT xclass xT. +Definition comUnitRingType := @ComUnitRing.Pack cT xclass xT. +Definition idomainType := @IntegralDomain.Pack cT xclass xT. +Definition fieldType := @Field.Pack cT xclass xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> Field.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 >-> Zmodule.type. +Canonical zmodType. +Coercion ringType : type >-> Ring.type. +Canonical ringType. +Coercion comRingType : type >-> ComRing.type. +Canonical comRingType. +Coercion unitRingType : type >-> UnitRing.type. +Canonical unitRingType. +Coercion comUnitRingType : type >-> ComUnitRing.type. +Canonical comUnitRingType. +Coercion idomainType : type >-> IntegralDomain.type. +Canonical idomainType. +Coercion fieldType : type >-> Field.type. +Canonical fieldType. +Notation decFieldType := type. +Notation DecFieldType T m := (@pack T _ m _ _ id _ id). +Notation DecFieldMixin := Mixin. +Notation "[ 'decFieldType' 'of' T 'for' cT ]" := (@clone T cT _ idfun) + (at level 0, format "[ 'decFieldType' 'of' T 'for' cT ]") : form_scope. +Notation "[ 'decFieldType' 'of' T ]" := (@clone T _ _ id) + (at level 0, format "[ 'decFieldType' 'of' T ]") : form_scope. +End Exports. + +End DecidableField. +Import DecidableField.Exports. + +Section DecidableFieldTheory. + +Variable F : decFieldType. + +Definition sat := DecidableField.sat (DecidableField.class F). + +Lemma satP : DecidableField.axiom sat. +Proof. exact: DecidableField.satP. Qed. + +Fact sol_subproof n f : + reflect (exists s, (size s == n) && sat s f) + (sat [::] (foldr Exists f (iota 0 n))). +Proof. +apply: (iffP (satP _ _)) => [|[s]]; last first. + case/andP=> /eqP sz_s /satP f_s; apply/foldExistsP. + exists s => // i; rewrite !inE mem_iota -leqNgt add0n => le_n_i. + by rewrite !nth_default ?sz_s. +case/foldExistsP=> e e0 f_e; set s := take n (set_nth 0 e n 0). +have sz_s: size s = n by rewrite size_take size_set_nth leq_max leqnn. +exists s; rewrite sz_s eqxx; apply/satP; apply: eq_holds f_e => i. +case: (leqP n i) => [le_n_i | lt_i_n]. + by rewrite -e0 ?nth_default ?sz_s // !inE mem_iota -leqNgt. +by rewrite nth_take // nth_set_nth /= eq_sym eqn_leq leqNgt lt_i_n. +Qed. + +Definition sol n f := + if sol_subproof n f is ReflectT sP then xchoose sP else nseq n 0. + +Lemma size_sol n f : size (sol n f) = n. +Proof. +rewrite /sol; case: sol_subproof => [sP | _]; last exact: size_nseq. +by case/andP: (xchooseP sP) => /eqP. +Qed. + +Lemma solP n f : reflect (exists2 s, size s = n & holds s f) (sat (sol n f) f). +Proof. +rewrite /sol; case: sol_subproof => [sP | sPn]. + case/andP: (xchooseP sP) => _ ->; left. + by case: sP => s; case/andP; move/eqP=> <-; move/satP; exists s. +apply: (iffP (satP _ _)); first by exists (nseq n 0); rewrite ?size_nseq. +by case=> s sz_s; move/satP=> f_s; case: sPn; exists s; rewrite sz_s eqxx. +Qed. + +Lemma eq_sat f1 f2 : + (forall e, holds e f1 <-> holds e f2) -> sat^~ f1 =1 sat^~ f2. +Proof. by move=> eqf12 e; apply/satP/satP; case: (eqf12 e). Qed. + +Lemma eq_sol f1 f2 : + (forall e, holds e f1 <-> holds e f2) -> sol^~ f1 =1 sol^~ f2. +Proof. +rewrite /sol => /eq_sat eqf12 n. +do 2![case: sol_subproof] => //= [f1s f2s | ns1 [s f2s] | [s f1s] []]. +- by apply: eq_xchoose => s; rewrite eqf12. +- by case: ns1; exists s; rewrite -eqf12. +by exists s; rewrite eqf12. +Qed. + +End DecidableFieldTheory. + +Implicit Arguments satP [[F] [e] [f]]. +Implicit Arguments solP [[F] [n] [f]]. + +Section QE_Mixin. + +Variable F : Field.type. +Implicit Type f : formula F. + +Variable proj : nat -> seq (term F) * seq (term F) -> formula F. +(* proj is the elimination of a single existential quantifier *) + +(* The elimination projector is well_formed. *) +Definition wf_QE_proj := + forall i bc (bc_i := proj i bc), + dnf_rterm bc -> qf_form bc_i && rformula bc_i. + +(* The elimination projector is valid *) +Definition valid_QE_proj := + forall i bc (ex_i_bc := ('exists 'X_i, dnf_to_form [:: bc])%T) e, + dnf_rterm bc -> reflect (holds e ex_i_bc) (qf_eval e (proj i bc)). + +Hypotheses (wf_proj : wf_QE_proj) (ok_proj : valid_QE_proj). + +Let elim_aux f n := foldr Or False (map (proj n) (qf_to_dnf f false)). + +Fixpoint quantifier_elim f := + match f with + | f1 /\ f2 => (quantifier_elim f1) /\ (quantifier_elim f2) + | f1 \/ f2 => (quantifier_elim f1) \/ (quantifier_elim f2) + | f1 ==> f2 => (~ quantifier_elim f1) \/ (quantifier_elim f2) + | ~ f => ~ quantifier_elim f + | ('exists 'X_n, f) => elim_aux (quantifier_elim f) n + | ('forall 'X_n, f) => ~ elim_aux (~ quantifier_elim f) n + | _ => f + end%T. + +Lemma quantifier_elim_wf f : + let qf := quantifier_elim f in rformula f -> qf_form qf && rformula qf. +Proof. +suffices aux_wf f0 n : let qf := elim_aux f0 n in + rformula f0 -> qf_form qf && rformula qf. +- by elim: f => //=; do ?[ move=> f1 IH1 f2 IH2; + case/andP=> rf1 rf2; + case/andP:(IH1 rf1)=> -> ->; + case/andP:(IH2 rf2)=> -> -> // + | move=> n f1 IH rf1; + case/andP: (IH rf1)=> qff rf; + rewrite aux_wf ]. +rewrite /elim_aux => rf. +suffices or_wf fs : let ofs := foldr Or False fs in + all (@qf_form F) fs && all (@rformula F) fs -> qf_form ofs && rformula ofs. +- apply: or_wf. + suffices map_proj_wf bcs: let mbcs := map (proj n) bcs in + all dnf_rterm bcs -> all (@qf_form _) mbcs && all (@rformula _) mbcs. + by apply: map_proj_wf; exact: qf_to_dnf_rterm. + elim: bcs => [|bc bcs ihb] bcsr //= /andP[rbc rbcs]. + by rewrite andbAC andbA wf_proj //= andbC ihb. +elim: fs => //= g gs ihg; rewrite -andbA => /and4P[-> qgs -> rgs] /=. +by apply: ihg; rewrite qgs rgs. +Qed. + +Lemma quantifier_elim_rformP e f : + rformula f -> reflect (holds e f) (qf_eval e (quantifier_elim f)). +Proof. +pose rc e n f := exists x, qf_eval (set_nth 0 e n x) f. +have auxP f0 e0 n0: qf_form f0 && rformula f0 -> + reflect (rc e0 n0 f0) (qf_eval e0 (elim_aux f0 n0)). ++ rewrite /elim_aux => cf; set bcs := qf_to_dnf f0 false. + apply: (@iffP (rc e0 n0 (dnf_to_form bcs))); last first. + - by case=> x; rewrite -qf_to_dnfP //; exists x. + - by case=> x; rewrite qf_to_dnfP //; exists x. + have: all dnf_rterm bcs by case/andP: cf => _; exact: qf_to_dnf_rterm. + elim: {f0 cf}bcs => [|bc bcs IHbcs] /=; first by right; case. + case/andP=> r_bc /IHbcs {IHbcs}bcsP. + have f_qf := dnf_to_form_qf [:: bc]. + case: ok_proj => //= [ex_x|no_x]. + left; case: ex_x => x /(qf_evalP _ f_qf); rewrite /= orbF => bc_x. + by exists x; rewrite /= bc_x. + apply: (iffP bcsP) => [[x bcs_x] | [x]] /=. + by exists x; rewrite /= bcs_x orbT. + case/orP => [bc_x|]; last by exists x. + by case: no_x; exists x; apply/(qf_evalP _ f_qf); rewrite /= bc_x. +elim: f e => //. +- move=> b e _; exact: idP. +- move=> t1 t2 e _; exact: eqP. +- move=> f1 IH1 f2 IH2 e /= /andP[/IH1[] f1e]; last by right; case. + by case/IH2; [left | right; case]. +- move=> f1 IH1 f2 IH2 e /= /andP[/IH1[] f1e]; first by do 2!left. + by case/IH2; [left; right | right; case]. +- move=> f1 IH1 f2 IH2 e /= /andP[/IH1[] f1e]; last by left. + by case/IH2; [left | right; move/(_ f1e)]. +- by move=> f IHf e /= /IHf[]; [right | left]. +- move=> n f IHf e /= rf; have rqf := quantifier_elim_wf rf. + by apply: (iffP (auxP _ _ _ rqf)) => [] [x]; exists x; exact/IHf. +move=> n f IHf e /= rf; have rqf := quantifier_elim_wf rf. +case: auxP => // [f_x|no_x]; first by right=> no_x; case: f_x => x /IHf[]. +by left=> x; apply/IHf=> //; apply/idPn=> f_x; case: no_x; exists x. +Qed. + +Definition proj_sat e f := qf_eval e (quantifier_elim (to_rform f)). + +Lemma proj_satP : DecidableField.axiom proj_sat. +Proof. +move=> e f; have fP := quantifier_elim_rformP e (to_rform_rformula f). +by apply: (iffP fP); move/to_rformP. +Qed. + +Definition QEdecFieldMixin := DecidableField.Mixin proj_satP. + +End QE_Mixin. + +Module ClosedField. + +(* Axiom == all non-constant monic polynomials have a root *) +Definition axiom (R : ringType) := + forall n (P : nat -> R), n > 0 -> + exists x : R, x ^+ n = \sum_(i < n) P i * (x ^+ i). + +Section ClassDef. + +Record class_of (F : Type) : Type := + Class {base : DecidableField.class_of F; _ : axiom (Ring.Pack base F)}. +Local Coercion base : class_of >-> DecidableField.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variable (T : Type) (cT : type). +Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c. +Definition clone c of phant_id class c := @Pack T c T. +Let xT := let: Pack T _ _ := cT in T. +Notation xclass := (class : class_of xT). + +Definition pack b0 (m0 : axiom (@Ring.Pack T b0 T)) := + fun bT b & phant_id (DecidableField.class bT) b => + fun m & phant_id m0 m => Pack (@Class T b m) T. + +(* There should eventually be a constructor from polynomial resolution *) +(* that builds the DecidableField mixin using QE. *) + +Definition eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition zmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @Ring.Pack cT xclass xT. +Definition comRingType := @ComRing.Pack cT xclass xT. +Definition unitRingType := @UnitRing.Pack cT xclass xT. +Definition comUnitRingType := @ComUnitRing.Pack cT xclass xT. +Definition idomainType := @IntegralDomain.Pack cT xclass xT. +Definition fieldType := @Field.Pack cT xclass xT. +Definition decFieldType := @DecidableField.Pack cT class xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> DecidableField.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 >-> Zmodule.type. +Canonical zmodType. +Coercion ringType : type >-> Ring.type. +Canonical ringType. +Coercion comRingType : type >-> ComRing.type. +Canonical comRingType. +Coercion unitRingType : type >-> UnitRing.type. +Canonical unitRingType. +Coercion comUnitRingType : type >-> ComUnitRing.type. +Canonical comUnitRingType. +Coercion idomainType : type >-> IntegralDomain.type. +Canonical idomainType. +Coercion fieldType : type >-> Field.type. +Canonical fieldType. +Coercion decFieldType : type >-> DecidableField.type. +Canonical decFieldType. +Notation closedFieldType := type. +Notation ClosedFieldType T m := (@pack T _ m _ _ id _ id). +Notation "[ 'closedFieldType' 'of' T 'for' cT ]" := (@clone T cT _ idfun) + (at level 0, format "[ 'closedFieldType' 'of' T 'for' cT ]") : form_scope. +Notation "[ 'closedFieldType' 'of' T ]" := (@clone T _ _ id) + (at level 0, format "[ 'closedFieldType' 'of' T ]") : form_scope. +End Exports. + +End ClosedField. +Import ClosedField.Exports. + +Section ClosedFieldTheory. + +Variable F : closedFieldType. + +Lemma solve_monicpoly : ClosedField.axiom F. +Proof. by case: F => ? []. Qed. + +End ClosedFieldTheory. + +Module SubType. + +Section Zmodule. + +Variables (V : zmodType) (S : predPredType V). +Variables (subS : zmodPred S) (kS : keyed_pred subS). +Variable U : subType (mem kS). + +Let inU v Sv : U := Sub v Sv. +Let zeroU := inU (rpred0 kS). + +Let oppU (u : U) := inU (rpredNr (valP u)). +Let addU (u1 u2 : U) := inU (rpredD (valP u1) (valP u2)). + +Fact addA : associative addU. +Proof. by move=> u1 u2 u3; apply: val_inj; rewrite !SubK addrA. Qed. +Fact addC : commutative addU. +Proof. by move=> u1 u2; apply: val_inj; rewrite !SubK addrC. Qed. +Fact add0 : left_id zeroU addU. +Proof. by move=> u; apply: val_inj; rewrite !SubK add0r. Qed. +Fact addN : left_inverse zeroU oppU addU. +Proof. by move=> u; apply: val_inj; rewrite !SubK addNr. Qed. + +Definition zmodMixin of phant U := ZmodMixin addA addC add0 addN. + +End Zmodule. + +Section Ring. + +Variables (R : ringType) (S : predPredType R). +Variables (ringS : subringPred S) (kS : keyed_pred ringS). + +Definition cast_zmodType (V : zmodType) T (VeqT : V = T :> Type) := + let cast mV := let: erefl in _ = T := VeqT return Zmodule.class_of T in mV in + Zmodule.Pack (cast (Zmodule.class V)) T. + +Variable (T : subType (mem kS)) (V : zmodType) (VeqT: V = T :> Type). + +Let inT x Sx : T := Sub x Sx. +Let oneT := inT (rpred1 kS). +Let mulT (u1 u2 : T) := inT (rpredM (valP u1) (valP u2)). +Let T' := cast_zmodType VeqT. + +Hypothesis valM : {morph (val : T' -> R) : x y / x - y}. + +Let val0 : val (0 : T') = 0. +Proof. by rewrite -(subrr (0 : T')) valM subrr. Qed. +Let valD : {morph (val : T' -> R): x y / x + y}. +Proof. +by move=> u v; rewrite -{1}[v]opprK -[- v]sub0r !valM val0 sub0r opprK. +Qed. + +Fact mulA : @associative T' mulT. +Proof. by move=> u1 u2 u3; apply: val_inj; rewrite !SubK mulrA. Qed. +Fact mul1l : left_id oneT mulT. +Proof. by move=> u; apply: val_inj; rewrite !SubK mul1r. Qed. +Fact mul1r : right_id oneT mulT. +Proof. by move=> u; apply: val_inj; rewrite !SubK mulr1. Qed. +Fact mulDl : @left_distributive T' T' mulT +%R. +Proof. by move=> u1 u2 u3; apply: val_inj; rewrite !(SubK, valD) mulrDl. Qed. +Fact mulDr : @right_distributive T' T' mulT +%R. +Proof. by move=> u1 u2 u3; apply: val_inj; rewrite !(SubK, valD) mulrDr. Qed. +Fact nz1 : oneT != 0 :> T'. +Proof. +by apply: contraNneq (oner_neq0 R) => eq10; rewrite -val0 -eq10 SubK. +Qed. + +Definition ringMixin := RingMixin mulA mul1l mul1r mulDl mulDr nz1. + +End Ring. + +Section Lmodule. + +Variables (R : ringType) (V : lmodType R) (S : predPredType V). +Variables (linS : submodPred S) (kS : keyed_pred linS). +Variables (W : subType (mem kS)) (Z : zmodType) (ZeqW : Z = W :> Type). + +Let scaleW a (w : W) := (Sub _ : _ -> W) (rpredZ a (valP w)). +Let W' := cast_zmodType ZeqW. + +Hypothesis valD : {morph (val : W' -> V) : x y / x + y}. + +Fact scaleA a b (w : W') : scaleW a (scaleW b w) = scaleW (a * b) w. +Proof. by apply: val_inj; rewrite !SubK scalerA. Qed. +Fact scale1 : left_id 1 scaleW. +Proof. by move=> w; apply: val_inj; rewrite !SubK scale1r. Qed. +Fact scaleDr : @right_distributive R W' scaleW +%R. +Proof. by move=> a w w2; apply: val_inj; rewrite !(SubK, valD) scalerDr. Qed. +Fact scaleDl w : {morph (scaleW^~ w : R -> W') : a b / a + b}. +Proof. by move=> a b; apply: val_inj; rewrite !(SubK, valD) scalerDl. Qed. + +Definition lmodMixin := LmodMixin scaleA scale1 scaleDr scaleDl. + +End Lmodule. + +Lemma lalgMixin (R : ringType) (A : lalgType R) (B : lmodType R) (f : B -> A) : + phant B -> injective f -> scalable f -> + forall mulB, {morph f : x y / mulB x y >-> x * y} -> Lalgebra.axiom mulB. +Proof. +by move=> _ injf fZ mulB fM a x y; apply: injf; rewrite !(fZ, fM) scalerAl. +Qed. + +Lemma comRingMixin (R : comRingType) (T : ringType) (f : T -> R) : + phant T -> injective f -> {morph f : x y / x * y} -> commutative (@mul T). +Proof. by move=> _ inj_f fM x y; apply: inj_f; rewrite !fM mulrC. Qed. + +Lemma algMixin (R : comRingType) (A : algType R) (B : lalgType R) (f : B -> A) : + phant B -> injective f -> {morph f : x y / x * y} -> scalable f -> + @Algebra.axiom R B. +Proof. +by move=> _ inj_f fM fZ a x y; apply: inj_f; rewrite !(fM, fZ) scalerAr. +Qed. + +Section UnitRing. + +Definition cast_ringType (Q : ringType) T (QeqT : Q = T :> Type) := + let cast rQ := let: erefl in _ = T := QeqT return Ring.class_of T in rQ in + Ring.Pack (cast (Ring.class Q)) T. + +Variables (R : unitRingType) (S : predPredType R). +Variables (ringS : divringPred S) (kS : keyed_pred ringS). + +Variables (T : subType (mem kS)) (Q : ringType) (QeqT : Q = T :> Type). + +Let inT x Sx : T := Sub x Sx. +Let invT (u : T) := inT (rpredVr (valP u)). +Let unitT := [qualify a u : T | val u \is a unit]. +Let T' := cast_ringType QeqT. + +Hypothesis val1 : val (1 : T') = 1. +Hypothesis valM : {morph (val : T' -> R) : x y / x * y}. + +Fact mulVr : + {in (unitT : predPredType T'), left_inverse (1 : T') invT (@mul T')}. +Proof. by move=> u Uu; apply: val_inj; rewrite val1 valM SubK mulVr. Qed. + +Fact mulrV : {in unitT, right_inverse (1 : T') invT (@mul T')}. +Proof. by move=> u Uu; apply: val_inj; rewrite val1 valM SubK mulrV. Qed. + +Fact unitP (u v : T') : v * u = 1 /\ u * v = 1 -> u \in unitT. +Proof. +by case=> vu1 uv1; apply/unitrP; exists (val v); rewrite -!valM vu1 uv1. +Qed. + +Fact unit_id : {in [predC unitT], invT =1 id}. +Proof. by move=> u /invr_out def_u1; apply: val_inj; rewrite SubK. Qed. + +Definition unitRingMixin := UnitRingMixin mulVr mulrV unitP unit_id. + +End UnitRing. + +Lemma idomainMixin (R : idomainType) (T : ringType) (f : T -> R) : + phant T -> injective f -> f 0 = 0 -> {morph f : u v / u * v} -> + @IntegralDomain.axiom T. +Proof. +move=> _ injf f0 fM u v uv0. +by rewrite -!(inj_eq injf) !f0 -mulf_eq0 -fM uv0 f0. +Qed. + +Lemma fieldMixin (F : fieldType) (K : unitRingType) (f : K -> F) : + phant K -> injective f -> f 0 = 0 -> {mono f : u / u \in unit} -> + @Field.mixin_of K. +Proof. by move=> _ injf f0 fU u; rewrite -fU unitfE -f0 inj_eq. Qed. + +Module Exports. + +Notation "[ 'zmodMixin' 'of' U 'by' <: ]" := (zmodMixin (Phant U)) + (at level 0, format "[ 'zmodMixin' 'of' U 'by' <: ]") : form_scope. +Notation "[ 'ringMixin' 'of' R 'by' <: ]" := + (@ringMixin _ _ _ _ _ _ (@erefl Type R%type) (rrefl _)) + (at level 0, format "[ 'ringMixin' 'of' R 'by' <: ]") : form_scope. +Notation "[ 'lmodMixin' 'of' U 'by' <: ]" := + (@lmodMixin _ _ _ _ _ _ _ (@erefl Type U%type) (rrefl _)) + (at level 0, format "[ 'lmodMixin' 'of' U 'by' <: ]") : form_scope. +Notation "[ 'lalgMixin' 'of' A 'by' <: ]" := + ((lalgMixin (Phant A) val_inj (rrefl _)) *%R (rrefl _)) + (at level 0, format "[ 'lalgMixin' 'of' A 'by' <: ]") : form_scope. +Notation "[ 'comRingMixin' 'of' R 'by' <: ]" := + (comRingMixin (Phant R) val_inj (rrefl _)) + (at level 0, format "[ 'comRingMixin' 'of' R 'by' <: ]") : form_scope. +Notation "[ 'algMixin' 'of' A 'by' <: ]" := + (algMixin (Phant A) val_inj (rrefl _) (rrefl _)) + (at level 0, format "[ 'algMixin' 'of' A 'by' <: ]") : form_scope. +Notation "[ 'unitRingMixin' 'of' R 'by' <: ]" := + (@unitRingMixin _ _ _ _ _ _ (@erefl Type R%type) (erefl _) (rrefl _)) + (at level 0, format "[ 'unitRingMixin' 'of' R 'by' <: ]") : form_scope. +Notation "[ 'idomainMixin' 'of' R 'by' <: ]" := + (idomainMixin (Phant R) val_inj (erefl _) (rrefl _)) + (at level 0, format "[ 'idomainMixin' 'of' R 'by' <: ]") : form_scope. +Notation "[ 'fieldMixin' 'of' F 'by' <: ]" := + (fieldMixin (Phant F) val_inj (erefl _) (frefl _)) + (at level 0, format "[ 'fieldMixin' 'of' F 'by' <: ]") : form_scope. + +End Exports. + +End SubType. + +Module Theory. + +Definition addrA := addrA. +Definition addrC := addrC. +Definition add0r := add0r. +Definition addNr := addNr. +Definition addr0 := addr0. +Definition addrN := addrN. +Definition subrr := subrr. +Definition addrCA := addrCA. +Definition addrAC := addrAC. +Definition addrACA := addrACA. +Definition addKr := addKr. +Definition addNKr := addNKr. +Definition addrK := addrK. +Definition addrNK := addrNK. +Definition subrK := subrK. +Definition addrI := @addrI. +Definition addIr := @addIr. +Implicit Arguments addrI [[V] x1 x2]. +Implicit Arguments addIr [[V] x1 x2]. +Definition opprK := opprK. +Definition oppr_inj := @oppr_inj. +Implicit Arguments oppr_inj [[V] x1 x2]. +Definition oppr0 := oppr0. +Definition oppr_eq0 := oppr_eq0. +Definition opprD := opprD. +Definition opprB := opprB. +Definition subr0 := subr0. +Definition sub0r := sub0r. +Definition subr_eq := subr_eq. +Definition subr_eq0 := subr_eq0. +Definition addr_eq0 := addr_eq0. +Definition eqr_opp := eqr_opp. +Definition eqr_oppLR := eqr_oppLR. +Definition sumrN := sumrN. +Definition sumrB := sumrB. +Definition sumrMnl := sumrMnl. +Definition sumrMnr := sumrMnr. +Definition sumr_const := sumr_const. +Definition telescope_sumr := telescope_sumr. +Definition mulr0n := mulr0n. +Definition mulr1n := mulr1n. +Definition mulr2n := mulr2n. +Definition mulrS := mulrS. +Definition mulrSr := mulrSr. +Definition mulrb := mulrb. +Definition mul0rn := mul0rn. +Definition mulNrn := mulNrn. +Definition mulrnDl := mulrnDl. +Definition mulrnDr := mulrnDr. +Definition mulrnBl := mulrnBl. +Definition mulrnBr := mulrnBr. +Definition mulrnA := mulrnA. +Definition mulrnAC := mulrnAC. +Definition mulrA := mulrA. +Definition mul1r := mul1r. +Definition mulr1 := mulr1. +Definition mulrDl := mulrDl. +Definition mulrDr := mulrDr. +Definition oner_neq0 := oner_neq0. +Definition oner_eq0 := oner_eq0. +Definition mul0r := mul0r. +Definition mulr0 := mulr0. +Definition mulrN := mulrN. +Definition mulNr := mulNr. +Definition mulrNN := mulrNN. +Definition mulN1r := mulN1r. +Definition mulrN1 := mulrN1. +Definition mulr_suml := mulr_suml. +Definition mulr_sumr := mulr_sumr. +Definition mulrBl := mulrBl. +Definition mulrBr := mulrBr. +Definition mulrnAl := mulrnAl. +Definition mulrnAr := mulrnAr. +Definition mulr_natl := mulr_natl. +Definition mulr_natr := mulr_natr. +Definition natrD := natrD. +Definition natrB := natrB. +Definition natr_sum := natr_sum. +Definition natrM := natrM. +Definition natrX := natrX. +Definition expr0 := expr0. +Definition exprS := exprS. +Definition expr1 := expr1. +Definition expr2 := expr2. +Definition expr0n := expr0n. +Definition expr1n := expr1n. +Definition exprD := exprD. +Definition exprSr := exprSr. +Definition commr_sym := commr_sym. +Definition commr_refl := commr_refl. +Definition commr0 := commr0. +Definition commr1 := commr1. +Definition commrN := commrN. +Definition commrN1 := commrN1. +Definition commrD := commrD. +Definition commrMn := commrMn. +Definition commrM := commrM. +Definition commr_nat := commr_nat. +Definition commrX := commrX. +Definition exprMn_comm := exprMn_comm. +Definition commr_sign := commr_sign. +Definition exprMn_n := exprMn_n. +Definition exprM := exprM. +Definition exprAC := exprAC. +Definition expr_mod := expr_mod. +Definition expr_dvd := expr_dvd. +Definition signr_odd := signr_odd. +Definition signr_eq0 := signr_eq0. +Definition mulr_sign := mulr_sign. +Definition signr_addb := signr_addb. +Definition signrN := signrN. +Definition signrE := signrE. +Definition mulr_signM := mulr_signM. +Definition exprNn := exprNn. +Definition sqrrN := sqrrN. +Definition sqrr_sign := sqrr_sign. +Definition signrMK := signrMK. +Definition mulrI_eq0 := mulrI_eq0. +Definition lreg_neq0 := lreg_neq0. +Definition mulrI0_lreg := mulrI0_lreg. +Definition lregN := lregN. +Definition lreg1 := lreg1. +Definition lregM := lregM. +Definition lregX := lregX. +Definition lreg_sign := lreg_sign. +Definition lregP {R x} := @lregP R x. +Definition mulIr_eq0 := mulIr_eq0. +Definition mulIr0_rreg := mulIr0_rreg. +Definition rreg_neq0 := rreg_neq0. +Definition rregN := rregN. +Definition rreg1 := rreg1. +Definition rregM := rregM. +Definition revrX := revrX. +Definition rregX := rregX. +Definition rregP {R x} := @rregP R x. +Definition exprDn_comm := exprDn_comm. +Definition exprBn_comm := exprBn_comm. +Definition subrXX_comm := subrXX_comm. +Definition exprD1n := exprD1n. +Definition subrX1 := subrX1. +Definition sqrrD1 := sqrrD1. +Definition sqrrB1 := sqrrB1. +Definition subr_sqr_1 := subr_sqr_1. +Definition charf0 := charf0. +Definition charf_prime := charf_prime. +Definition mulrn_char := mulrn_char. +Definition dvdn_charf := dvdn_charf. +Definition charf_eq := charf_eq. +Definition bin_lt_charf_0 := bin_lt_charf_0. +Definition Frobenius_autE := Frobenius_autE. +Definition Frobenius_aut0 := Frobenius_aut0. +Definition Frobenius_aut1 := Frobenius_aut1. +Definition Frobenius_autD_comm := Frobenius_autD_comm. +Definition Frobenius_autMn := Frobenius_autMn. +Definition Frobenius_aut_nat := Frobenius_aut_nat. +Definition Frobenius_autM_comm := Frobenius_autM_comm. +Definition Frobenius_autX := Frobenius_autX. +Definition Frobenius_autN := Frobenius_autN. +Definition Frobenius_autB_comm := Frobenius_autB_comm. +Definition exprNn_char := exprNn_char. +Definition addrr_char2 := addrr_char2. +Definition oppr_char2 := oppr_char2. +Definition addrK_char2 := addrK_char2. +Definition addKr_char2 := addKr_char2. +Definition prodr_const := prodr_const. +Definition mulrC := mulrC. +Definition mulrCA := mulrCA. +Definition mulrAC := mulrAC. +Definition mulrACA := mulrACA. +Definition exprMn := exprMn. +Definition prodrXl := prodrXl. +Definition prodrXr := prodrXr. +Definition prodrN := prodrN. +Definition prodrMn := prodrMn. +Definition natr_prod := natr_prod. +Definition prodr_undup_exp_count := prodr_undup_exp_count. +Definition exprDn := exprDn. +Definition exprBn := exprBn. +Definition subrXX := subrXX. +Definition sqrrD := sqrrD. +Definition sqrrB := sqrrB. +Definition subr_sqr := subr_sqr. +Definition subr_sqrDB := subr_sqrDB. +Definition exprDn_char := exprDn_char. +Definition mulrV := mulrV. +Definition divrr := divrr. +Definition mulVr := mulVr. +Definition invr_out := invr_out. +Definition unitrP {R x} := @unitrP R x. +Definition mulKr := mulKr. +Definition mulVKr := mulVKr. +Definition mulrK := mulrK. +Definition mulrVK := mulrVK. +Definition divrK := divrK. +Definition mulrI := mulrI. +Definition mulIr := mulIr. +Definition telescope_prodr := telescope_prodr. +Definition commrV := commrV. +Definition unitrE := unitrE. +Definition invrK := invrK. +Definition invr_inj := @invr_inj. +Implicit Arguments invr_inj [[R] x1 x2]. +Definition unitrV := unitrV. +Definition unitr1 := unitr1. +Definition invr1 := invr1. +Definition divr1 := divr1. +Definition div1r := div1r. +Definition natr_div := natr_div. +Definition unitr0 := unitr0. +Definition invr0 := invr0. +Definition unitrN1 := unitrN1. +Definition unitrN := unitrN. +Definition invrN1 := invrN1. +Definition invrN := invrN. +Definition invr_sign := invr_sign. +Definition unitrMl := unitrMl. +Definition unitrMr := unitrMr. +Definition invrM := invrM. +Definition invr_eq0 := invr_eq0. +Definition invr_eq1 := invr_eq1. +Definition invr_neq0 := invr_neq0. +Definition unitrM_comm := unitrM_comm. +Definition unitrX := unitrX. +Definition unitrX_pos := unitrX_pos. +Definition exprVn := exprVn. +Definition exprB := exprB. +Definition invr_signM := invr_signM. +Definition divr_signM := divr_signM. +Definition rpred0D := rpred0D. +Definition rpred0 := rpred0. +Definition rpredD := rpredD. +Definition rpredNr := rpredNr. +Definition rpred_sum := rpred_sum. +Definition rpredMn := rpredMn. +Definition rpredN := rpredN. +Definition rpredB := rpredB. +Definition rpredMNn := rpredMNn. +Definition rpredDr := rpredDr. +Definition rpredDl := rpredDl. +Definition rpredBr := rpredBr. +Definition rpredBl := rpredBl. +Definition rpredMsign := rpredMsign. +Definition rpred1M := rpred1M. +Definition rpred1 := rpred1. +Definition rpredM := rpredM. +Definition rpred_prod := rpred_prod. +Definition rpredX := rpredX. +Definition rpred_nat := rpred_nat. +Definition rpredN1 := rpredN1. +Definition rpred_sign := rpred_sign. +Definition rpredZsign := rpredZsign. +Definition rpredZnat := rpredZnat. +Definition rpredZ := rpredZ. +Definition rpredVr := rpredVr. +Definition rpredV := rpredV. +Definition rpred_div := rpred_div. +Definition rpredXN := rpredXN. +Definition rpredZeq := rpredZeq. +Definition char_lalg := char_lalg. +Definition rpredMr := rpredMr. +Definition rpredMl := rpredMl. +Definition rpred_divr := rpred_divr. +Definition rpred_divl := rpred_divl. +Definition eq_eval := eq_eval. +Definition eval_tsubst := eval_tsubst. +Definition eq_holds := eq_holds. +Definition holds_fsubst := holds_fsubst. +Definition unitrM := unitrM. +Definition unitrPr {R x} := @unitrPr R x. +Definition expr_div_n := expr_div_n. +Definition mulf_eq0 := mulf_eq0. +Definition prodf_eq0 := prodf_eq0. +Definition prodf_seq_eq0 := prodf_seq_eq0. +Definition mulf_neq0 := mulf_neq0. +Definition prodf_neq0 := prodf_neq0. +Definition prodf_seq_neq0 := prodf_seq_neq0. +Definition expf_eq0 := expf_eq0. +Definition sqrf_eq0 := sqrf_eq0. +Definition expf_neq0 := expf_neq0. +Definition natf_neq0 := natf_neq0. +Definition natf0_char := natf0_char. +Definition charf'_nat := charf'_nat. +Definition charf0P := charf0P. +Definition eqf_sqr := eqf_sqr. +Definition mulfI := mulfI. +Definition mulIf := mulIf. +Definition sqrf_eq1 := sqrf_eq1. +Definition expfS_eq1 := expfS_eq1. +Definition fieldP := fieldP. +Definition unitfE := unitfE. +Definition mulVf := mulVf. +Definition mulfV := mulfV. +Definition divff := divff. +Definition mulKf := mulKf. +Definition mulVKf := mulVKf. +Definition mulfK := mulfK. +Definition mulfVK := mulfVK. +Definition divfK := divfK. +Definition invfM := invfM. +Definition invf_div := invf_div. +Definition expfB_cond := expfB_cond. +Definition expfB := expfB. +Definition prodfV := prodfV. +Definition prodf_div := prodf_div. +Definition telescope_prodf := telescope_prodf. +Definition addf_div := addf_div. +Definition mulf_div := mulf_div. +Definition char0_natf_div := char0_natf_div. +Definition fpredMr := fpredMr. +Definition fpredMl := fpredMl. +Definition fpred_divr := fpred_divr. +Definition fpred_divl := fpred_divl. +Definition satP {F e f} := @satP F e f. +Definition eq_sat := eq_sat. +Definition solP {F n f} := @solP F n f. +Definition eq_sol := eq_sol. +Definition size_sol := size_sol. +Definition solve_monicpoly := solve_monicpoly. +Definition raddf0 := raddf0. +Definition raddf_eq0 := raddf_eq0. +Definition raddfN := raddfN. +Definition raddfD := raddfD. +Definition raddfB := raddfB. +Definition raddf_sum := raddf_sum. +Definition raddfMn := raddfMn. +Definition raddfMNn := raddfMNn. +Definition raddfMnat := raddfMnat. +Definition raddfMsign := raddfMsign. +Definition can2_additive := can2_additive. +Definition bij_additive := bij_additive. +Definition rmorph0 := rmorph0. +Definition rmorphN := rmorphN. +Definition rmorphD := rmorphD. +Definition rmorphB := rmorphB. +Definition rmorph_sum := rmorph_sum. +Definition rmorphMn := rmorphMn. +Definition rmorphMNn := rmorphMNn. +Definition rmorphismP := rmorphismP. +Definition rmorphismMP := rmorphismMP. +Definition rmorph1 := rmorph1. +Definition rmorph_eq1 := rmorph_eq1. +Definition rmorphM := rmorphM. +Definition rmorphMsign := rmorphMsign. +Definition rmorph_nat := rmorph_nat. +Definition rmorph_eq_nat := rmorph_eq_nat. +Definition rmorph_prod := rmorph_prod. +Definition rmorphX := rmorphX. +Definition rmorphN1 := rmorphN1. +Definition rmorph_sign := rmorph_sign. +Definition rmorph_char := rmorph_char. +Definition can2_rmorphism := can2_rmorphism. +Definition bij_rmorphism := bij_rmorphism. +Definition rmorph_comm := rmorph_comm. +Definition rmorph_unit := rmorph_unit. +Definition rmorphV := rmorphV. +Definition rmorph_div := rmorph_div. +Definition fmorph_eq0 := fmorph_eq0. +Definition fmorph_inj := @fmorph_inj. +Implicit Arguments fmorph_inj [[F] [R] x1 x2]. +Definition fmorph_eq1 := fmorph_eq1. +Definition fmorph_char := fmorph_char. +Definition fmorph_unit := fmorph_unit. +Definition fmorphV := fmorphV. +Definition fmorph_div := fmorph_div. +Definition scalerA := scalerA. +Definition scale1r := scale1r. +Definition scalerDr := scalerDr. +Definition scalerDl := scalerDl. +Definition scaler0 := scaler0. +Definition scale0r := scale0r. +Definition scaleNr := scaleNr. +Definition scaleN1r := scaleN1r. +Definition scalerN := scalerN. +Definition scalerBl := scalerBl. +Definition scalerBr := scalerBr. +Definition scaler_nat := scaler_nat. +Definition scalerMnl := scalerMnl. +Definition scalerMnr := scalerMnr. +Definition scaler_suml := scaler_suml. +Definition scaler_sumr := scaler_sumr. +Definition scaler_eq0 := scaler_eq0. +Definition scalerK := scalerK. +Definition scalerKV := scalerKV. +Definition scalerI := scalerI. +Definition scalerAl := scalerAl. +Definition mulr_algl := mulr_algl. +Definition scaler_sign := scaler_sign. +Definition signrZK := signrZK. +Definition scalerCA := scalerCA. +Definition scalerAr := scalerAr. +Definition mulr_algr := mulr_algr. +Definition exprZn := exprZn. +Definition scaler_prodl := scaler_prodl. +Definition scaler_prodr := scaler_prodr. +Definition scaler_prod := scaler_prod. +Definition scaler_injl := scaler_injl. +Definition scaler_unit := scaler_unit. +Definition invrZ := invrZ. +Definition raddfZnat := raddfZnat. +Definition raddfZsign := raddfZsign. +Definition in_algE := in_algE. +Definition linear0 := linear0. +Definition linearN := linearN. +Definition linearD := linearD. +Definition linearB := linearB. +Definition linear_sum := linear_sum. +Definition linearMn := linearMn. +Definition linearMNn := linearMNn. +Definition linearP := linearP. +Definition linearZ_LR := linearZ_LR. +Definition linearZ := linearZ. +Definition linearPZ := linearPZ. +Definition linearZZ := linearZZ. +Definition scalarP := scalarP. +Definition scalarZ := scalarZ. +Definition can2_linear := can2_linear. +Definition bij_linear := bij_linear. +Definition rmorph_alg := rmorph_alg. +Definition lrmorphismP := lrmorphismP. +Definition can2_lrmorphism := can2_lrmorphism. +Definition bij_lrmorphism := bij_lrmorphism. + +Notation null_fun V := (null_fun V) (only parsing). +Notation in_alg A := (in_alg_loc A). + +End Theory. + +Notation in_alg A := (in_alg_loc A). + +End GRing. + +Export Zmodule.Exports Ring.Exports Lmodule.Exports Lalgebra.Exports. +Export Additive.Exports RMorphism.Exports Linear.Exports LRMorphism.Exports. +Export ComRing.Exports Algebra.Exports UnitRing.Exports UnitAlgebra.Exports. +Export ComUnitRing.Exports IntegralDomain.Exports Field.Exports. +Export DecidableField.Exports ClosedField.Exports. +Export Pred.Exports SubType.Exports. +Notation QEdecFieldMixin := QEdecFieldMixin. + +Notation "0" := (zero _) : ring_scope. +Notation "-%R" := (@opp _) : ring_scope. +Notation "- x" := (opp x) : ring_scope. +Notation "+%R" := (@add _). +Notation "x + y" := (add x y) : ring_scope. +Notation "x - y" := (add x (- y)) : ring_scope. +Notation "x *+ n" := (natmul x n) : ring_scope. +Notation "x *- n" := (opp (x *+ n)) : ring_scope. +Notation "s `_ i" := (seq.nth 0%R s%R i) : ring_scope. +Notation support := 0.-support. + +Notation "1" := (one _) : ring_scope. +Notation "- 1" := (opp 1) : ring_scope. + +Notation "n %:R" := (natmul 1 n) : ring_scope. +Notation "[ 'char' R ]" := (char (Phant R)) : ring_scope. +Notation Frobenius_aut chRp := (Frobenius_aut chRp). +Notation "*%R" := (@mul _). +Notation "x * y" := (mul x y) : ring_scope. +Notation "x ^+ n" := (exp x n) : ring_scope. +Notation "x ^-1" := (inv x) : ring_scope. +Notation "x ^- n" := (inv (x ^+ n)) : ring_scope. +Notation "x / y" := (mul x y^-1) : ring_scope. + +Notation "*:%R" := (@scale _ _). +Notation "a *: m" := (scale a m) : ring_scope. +Notation "k %:A" := (scale k 1) : ring_scope. +Notation "\0" := (null_fun _) : ring_scope. +Notation "f \+ g" := (add_fun_head tt f g) : ring_scope. +Notation "f \- g" := (sub_fun_head tt f g) : ring_scope. +Notation "a \*: f" := (scale_fun_head tt a f) : ring_scope. +Notation "x \*o f" := (mull_fun_head tt x f) : ring_scope. +Notation "x \o* f" := (mulr_fun_head tt x f) : ring_scope. + +Notation "\sum_ ( i <- r | P ) F" := + (\big[+%R/0%R]_(i <- r | P%B) F%R) : ring_scope. +Notation "\sum_ ( i <- r ) F" := + (\big[+%R/0%R]_(i <- r) F%R) : ring_scope. +Notation "\sum_ ( m <= i < n | P ) F" := + (\big[+%R/0%R]_(m <= i < n | P%B) F%R) : ring_scope. +Notation "\sum_ ( m <= i < n ) F" := + (\big[+%R/0%R]_(m <= i < n) F%R) : ring_scope. +Notation "\sum_ ( i | P ) F" := + (\big[+%R/0%R]_(i | P%B) F%R) : ring_scope. +Notation "\sum_ i F" := + (\big[+%R/0%R]_i F%R) : ring_scope. +Notation "\sum_ ( i : t | P ) F" := + (\big[+%R/0%R]_(i : t | P%B) F%R) (only parsing) : ring_scope. +Notation "\sum_ ( i : t ) F" := + (\big[+%R/0%R]_(i : t) F%R) (only parsing) : ring_scope. +Notation "\sum_ ( i < n | P ) F" := + (\big[+%R/0%R]_(i < n | P%B) F%R) : ring_scope. +Notation "\sum_ ( i < n ) F" := + (\big[+%R/0%R]_(i < n) F%R) : ring_scope. +Notation "\sum_ ( i 'in' A | P ) F" := + (\big[+%R/0%R]_(i in A | P%B) F%R) : ring_scope. +Notation "\sum_ ( i 'in' A ) F" := + (\big[+%R/0%R]_(i in A) F%R) : ring_scope. + +Notation "\prod_ ( i <- r | P ) F" := + (\big[*%R/1%R]_(i <- r | P%B) F%R) : ring_scope. +Notation "\prod_ ( i <- r ) F" := + (\big[*%R/1%R]_(i <- r) F%R) : ring_scope. +Notation "\prod_ ( m <= i < n | P ) F" := + (\big[*%R/1%R]_(m <= i < n | P%B) F%R) : ring_scope. +Notation "\prod_ ( m <= i < n ) F" := + (\big[*%R/1%R]_(m <= i < n) F%R) : ring_scope. +Notation "\prod_ ( i | P ) F" := + (\big[*%R/1%R]_(i | P%B) F%R) : ring_scope. +Notation "\prod_ i F" := + (\big[*%R/1%R]_i F%R) : ring_scope. +Notation "\prod_ ( i : t | P ) F" := + (\big[*%R/1%R]_(i : t | P%B) F%R) (only parsing) : ring_scope. +Notation "\prod_ ( i : t ) F" := + (\big[*%R/1%R]_(i : t) F%R) (only parsing) : ring_scope. +Notation "\prod_ ( i < n | P ) F" := + (\big[*%R/1%R]_(i < n | P%B) F%R) : ring_scope. +Notation "\prod_ ( i < n ) F" := + (\big[*%R/1%R]_(i < n) F%R) : ring_scope. +Notation "\prod_ ( i 'in' A | P ) F" := + (\big[*%R/1%R]_(i in A | P%B) F%R) : ring_scope. +Notation "\prod_ ( i 'in' A ) F" := + (\big[*%R/1%R]_(i in A) F%R) : ring_scope. + +Canonical add_monoid. +Canonical add_comoid. +Canonical mul_monoid. +Canonical mul_comoid. +Canonical muloid. +Canonical addoid. + +Canonical locked_additive. +Canonical locked_rmorphism. +Canonical locked_linear. +Canonical locked_lrmorphism. +Canonical idfun_additive. +Canonical idfun_rmorphism. +Canonical idfun_linear. +Canonical idfun_lrmorphism. +Canonical comp_additive. +Canonical comp_rmorphism. +Canonical comp_linear. +Canonical comp_lrmorphism. +Canonical opp_additive. +Canonical opp_linear. +Canonical scale_additive. +Canonical scale_linear. +Canonical null_fun_additive. +Canonical null_fun_linear. +Canonical scale_fun_additive. +Canonical scale_fun_linear. +Canonical add_fun_additive. +Canonical add_fun_linear. +Canonical sub_fun_additive. +Canonical sub_fun_linear. +Canonical mull_fun_additive. +Canonical mull_fun_linear. +Canonical mulr_fun_additive. +Canonical mulr_fun_linear. +Canonical Frobenius_aut_additive. +Canonical Frobenius_aut_rmorphism. +Canonical in_alg_additive. +Canonical in_alg_rmorphism. + +Notation "R ^c" := (converse R) (at level 2, format "R ^c") : type_scope. +Canonical converse_eqType. +Canonical converse_choiceType. +Canonical converse_zmodType. +Canonical converse_ringType. +Canonical converse_unitRingType. + +Notation "R ^o" := (regular R) (at level 2, format "R ^o") : type_scope. +Canonical regular_eqType. +Canonical regular_choiceType. +Canonical regular_zmodType. +Canonical regular_ringType. +Canonical regular_lmodType. +Canonical regular_lalgType. +Canonical regular_comRingType. +Canonical regular_algType. +Canonical regular_unitRingType. +Canonical regular_comUnitRingType. +Canonical regular_unitAlgType. +Canonical regular_idomainType. +Canonical regular_fieldType. + +Canonical unit_keyed. +Canonical unit_opprPred. +Canonical unit_mulrPred. +Canonical unit_smulrPred. +Canonical unit_divrPred. +Canonical unit_sdivrPred. + +Bind Scope term_scope with term. +Bind Scope term_scope with formula. + +Notation "''X_' i" := (Var _ i) : term_scope. +Notation "n %:R" := (NatConst _ n) : term_scope. +Notation "0" := 0%:R%T : term_scope. +Notation "1" := 1%:R%T : term_scope. +Notation "x %:T" := (Const x) : term_scope. +Infix "+" := Add : term_scope. +Notation "- t" := (Opp t) : term_scope. +Notation "t - u" := (Add t (- u)) : term_scope. +Infix "*" := Mul : term_scope. +Infix "*+" := NatMul : term_scope. +Notation "t ^-1" := (Inv t) : term_scope. +Notation "t / u" := (Mul t u^-1) : term_scope. +Infix "^+" := Exp : term_scope. +Infix "==" := Equal : term_scope. +Notation "x != y" := (GRing.Not (x == y)) : term_scope. +Infix "/\" := And : term_scope. +Infix "\/" := Or : term_scope. +Infix "==>" := Implies : term_scope. +Notation "~ f" := (Not f) : term_scope. +Notation "''exists' ''X_' i , f" := (Exists i f) : term_scope. +Notation "''forall' ''X_' i , f" := (Forall i f) : term_scope. + +(* Lifting Structure from the codomain of finfuns. *) +Section FinFunZmod. + +Variable (aT : finType) (rT : zmodType). +Implicit Types f g : {ffun aT -> rT}. + +Definition ffun_zero := [ffun a : aT => (0 : rT)]. +Definition ffun_opp f := [ffun a => - f a]. +Definition ffun_add f g := [ffun a => f a + g a]. + +Fact ffun_addA : associative ffun_add. +Proof. by move=> f1 f2 f3; apply/ffunP=> a; rewrite !ffunE addrA. Qed. +Fact ffun_addC : commutative ffun_add. +Proof. by move=> f1 f2; apply/ffunP=> a; rewrite !ffunE addrC. Qed. +Fact ffun_add0 : left_id ffun_zero ffun_add. +Proof. by move=> f; apply/ffunP=> a; rewrite !ffunE add0r. Qed. +Fact ffun_addN : left_inverse ffun_zero ffun_opp ffun_add. +Proof. by move=> f; apply/ffunP=> a; rewrite !ffunE addNr. Qed. + +Definition ffun_zmodMixin := + Zmodule.Mixin ffun_addA ffun_addC ffun_add0 ffun_addN. +Canonical ffun_zmodType := Eval hnf in ZmodType _ ffun_zmodMixin. + +Section Sum. + +Variables (I : Type) (r : seq I) (P : pred I) (F : I -> {ffun aT -> rT}). + +Lemma sum_ffunE x : (\sum_(i <- r | P i) F i) x = \sum_(i <- r | P i) F i x. +Proof. by elim/big_rec2: _ => // [|i _ y _ <-]; rewrite !ffunE. Qed. + +Lemma sum_ffun : + \sum_(i <- r | P i) F i = [ffun x => \sum_(i <- r | P i) F i x]. +Proof. by apply/ffunP=> i; rewrite sum_ffunE ffunE. Qed. + +End Sum. + +Lemma ffunMnE f n x : (f *+ n) x = f x *+ n. +Proof. by rewrite -[n]card_ord -!sumr_const sum_ffunE. Qed. + +End FinFunZmod. +Canonical exp_zmodType (M : zmodType) n := [zmodType of M ^ n]. + +Section FinFunRing. + +(* As rings require 1 != 0 in order to lift a ring structure over finfuns *) +(* we need evidence that the domain is non-empty. *) + +Variable (aT : finType) (R : ringType) (a : aT). + +Definition ffun_one : {ffun aT -> R} := [ffun => 1]. +Definition ffun_mul (f g : {ffun aT -> R}) := [ffun x => f x * g x]. + +Fact ffun_mulA : associative ffun_mul. +Proof. by move=> f1 f2 f3; apply/ffunP=> i; rewrite !ffunE mulrA. Qed. +Fact ffun_mul_1l : left_id ffun_one ffun_mul. +Proof. by move=> f; apply/ffunP=> i; rewrite !ffunE mul1r. Qed. +Fact ffun_mul_1r : right_id ffun_one ffun_mul. +Proof. by move=> f; apply/ffunP=> i; rewrite !ffunE mulr1. Qed. +Fact ffun_mul_addl : left_distributive ffun_mul (@ffun_add _ _). +Proof. by move=> f1 f2 f3; apply/ffunP=> i; rewrite !ffunE mulrDl. Qed. +Fact ffun_mul_addr : right_distributive ffun_mul (@ffun_add _ _). +Proof. by move=> f1 f2 f3; apply/ffunP=> i; rewrite !ffunE mulrDr. Qed. +Fact ffun1_nonzero : ffun_one != 0. +Proof. by apply/eqP => /ffunP/(_ a)/eqP; rewrite !ffunE oner_eq0. Qed. + +Definition ffun_ringMixin := + RingMixin ffun_mulA ffun_mul_1l ffun_mul_1r ffun_mul_addl ffun_mul_addr + ffun1_nonzero. +Definition ffun_ringType := + Eval hnf in RingType {ffun aT -> R} ffun_ringMixin. + +End FinFunRing. + +Section FinFunComRing. + +Variable (aT : finType) (R : comRingType) (a : aT). + +Fact ffun_mulC : commutative (@ffun_mul aT R). +Proof. by move=> f1 f2; apply/ffunP=> i; rewrite !ffunE mulrC. Qed. + +Definition ffun_comRingType := + Eval hnf in ComRingType (ffun_ringType R a) ffun_mulC. + +End FinFunComRing. + +Section FinFunLmod. + +Variable (R : ringType) (aT : finType) (rT : lmodType R). + +Implicit Types f g : {ffun aT -> rT}. + +Definition ffun_scale k f := [ffun a => k *: f a]. + +Fact ffun_scaleA k1 k2 f : + ffun_scale k1 (ffun_scale k2 f) = ffun_scale (k1 * k2) f. +Proof. by apply/ffunP=> a; rewrite !ffunE scalerA. Qed. +Fact ffun_scale1 : left_id 1 ffun_scale. +Proof. by move=> f; apply/ffunP=> a; rewrite !ffunE scale1r. Qed. +Fact ffun_scale_addr k : {morph (ffun_scale k) : x y / x + y}. +Proof. by move=> f g; apply/ffunP=> a; rewrite !ffunE scalerDr. Qed. +Fact ffun_scale_addl u : {morph (ffun_scale)^~ u : k1 k2 / k1 + k2}. +Proof. by move=> k1 k2; apply/ffunP=> a; rewrite !ffunE scalerDl. Qed. + +Definition ffun_lmodMixin := + LmodMixin ffun_scaleA ffun_scale1 ffun_scale_addr ffun_scale_addl. +Canonical ffun_lmodType := + Eval hnf in LmodType R {ffun aT -> rT} ffun_lmodMixin. + +End FinFunLmod. +Canonical exp_lmodType (R : ringType) (M : lmodType R) n := + [lmodType R of M ^ n]. + +(* External direct product. *) +Section PairZmod. + +Variables M1 M2 : zmodType. + +Definition opp_pair (x : M1 * M2) := (- x.1, - x.2). +Definition add_pair (x y : M1 * M2) := (x.1 + y.1, x.2 + y.2). + +Fact pair_addA : associative add_pair. +Proof. by move=> x y z; congr (_, _); apply: addrA. Qed. + +Fact pair_addC : commutative add_pair. +Proof. by move=> x y; congr (_, _); apply: addrC. Qed. + +Fact pair_add0 : left_id (0, 0) add_pair. +Proof. by case=> x1 x2; congr (_, _); apply: add0r. Qed. + +Fact pair_addN : left_inverse (0, 0) opp_pair add_pair. +Proof. by move=> x; congr (_, _); apply: addNr. Qed. + +Definition pair_zmodMixin := ZmodMixin pair_addA pair_addC pair_add0 pair_addN. +Canonical pair_zmodType := Eval hnf in ZmodType (M1 * M2) pair_zmodMixin. + +End PairZmod. + +Section PairRing. + +Variables R1 R2 : ringType. + +Definition mul_pair (x y : R1 * R2) := (x.1 * y.1, x.2 * y.2). + +Fact pair_mulA : associative mul_pair. +Proof. by move=> x y z; congr (_, _); apply: mulrA. Qed. + +Fact pair_mul1l : left_id (1, 1) mul_pair. +Proof. by case=> x1 x2; congr (_, _); apply: mul1r. Qed. + +Fact pair_mul1r : right_id (1, 1) mul_pair. +Proof. by case=> x1 x2; congr (_, _); apply: mulr1. Qed. + +Fact pair_mulDl : left_distributive mul_pair +%R. +Proof. by move=> x y z; congr (_, _); apply: mulrDl. Qed. + +Fact pair_mulDr : right_distributive mul_pair +%R. +Proof. by move=> x y z; congr (_, _); apply: mulrDr. Qed. + +Fact pair_one_neq0 : (1, 1) != 0 :> R1 * R2. +Proof. by rewrite xpair_eqE oner_eq0. Qed. + +Definition pair_ringMixin := + RingMixin pair_mulA pair_mul1l pair_mul1r pair_mulDl pair_mulDr pair_one_neq0. +Canonical pair_ringType := Eval hnf in RingType (R1 * R2) pair_ringMixin. + +End PairRing. + +Section PairComRing. + +Variables R1 R2 : comRingType. + +Fact pair_mulC : commutative (@mul_pair R1 R2). +Proof. by move=> x y; congr (_, _); apply: mulrC. Qed. + +Canonical pair_comRingType := Eval hnf in ComRingType (R1 * R2) pair_mulC. + +End PairComRing. + +Section PairLmod. + +Variables (R : ringType) (V1 V2 : lmodType R). + +Definition scale_pair a (v : V1 * V2) : V1 * V2 := (a *: v.1, a *: v.2). + +Fact pair_scaleA a b u : scale_pair a (scale_pair b u) = scale_pair (a * b) u. +Proof. by congr (_, _); apply: scalerA. Qed. + +Fact pair_scale1 u : scale_pair 1 u = u. +Proof. by case: u => u1 u2; congr (_, _); apply: scale1r. Qed. + +Fact pair_scaleDr : right_distributive scale_pair +%R. +Proof. by move=> a u v; congr (_, _); apply: scalerDr. Qed. + +Fact pair_scaleDl u : {morph scale_pair^~ u: a b / a + b}. +Proof. by move=> a b; congr (_, _); apply: scalerDl. Qed. + +Definition pair_lmodMixin := + LmodMixin pair_scaleA pair_scale1 pair_scaleDr pair_scaleDl. +Canonical pair_lmodType := Eval hnf in LmodType R (V1 * V2) pair_lmodMixin. + +End PairLmod. + +Section PairLalg. + +Variables (R : ringType) (A1 A2 : lalgType R). + +Fact pair_scaleAl a (u v : A1 * A2) : a *: (u * v) = (a *: u) * v. +Proof. by congr (_, _); apply: scalerAl. Qed. +Canonical pair_lalgType := Eval hnf in LalgType R (A1 * A2) pair_scaleAl. + +End PairLalg. + +Section PairAlg. + +Variables (R : comRingType) (A1 A2 : algType R). + +Fact pair_scaleAr a (u v : A1 * A2) : a *: (u * v) = u * (a *: v). +Proof. by congr (_, _); apply: scalerAr. Qed. +Canonical pair_algType := Eval hnf in AlgType R (A1 * A2) pair_scaleAr. + +End PairAlg. + +Section PairUnitRing. + +Variables R1 R2 : unitRingType. + +Definition pair_unitr := + [qualify a x : R1 * R2 | (x.1 \is a GRing.unit) && (x.2 \is a GRing.unit)]. +Definition pair_invr x := + if x \is a pair_unitr then (x.1^-1, x.2^-1) else x. + +Lemma pair_mulVl : {in pair_unitr, left_inverse 1 pair_invr *%R}. +Proof. +rewrite /pair_invr=> x; case: ifP => // /andP[Ux1 Ux2] _. +by congr (_, _); apply: mulVr. +Qed. + +Lemma pair_mulVr : {in pair_unitr, right_inverse 1 pair_invr *%R}. +Proof. +rewrite /pair_invr=> x; case: ifP => // /andP[Ux1 Ux2] _. +by congr (_, _); apply: mulrV. +Qed. + +Lemma pair_unitP x y : y * x = 1 /\ x * y = 1 -> x \is a pair_unitr. +Proof. +case=> [[y1x y2x] [x1y x2y]]; apply/andP. +by split; apply/unitrP; [exists y.1 | exists y.2]. +Qed. + +Lemma pair_invr_out : {in [predC pair_unitr], pair_invr =1 id}. +Proof. by rewrite /pair_invr => x /negPf/= ->. Qed. + +Definition pair_unitRingMixin := + UnitRingMixin pair_mulVl pair_mulVr pair_unitP pair_invr_out. +Canonical pair_unitRingType := + Eval hnf in UnitRingType (R1 * R2) pair_unitRingMixin. + +End PairUnitRing. + +Canonical pair_comUnitRingType (R1 R2 : comUnitRingType) := + Eval hnf in [comUnitRingType of R1 * R2]. + +Canonical pair_unitAlgType (R : comUnitRingType) (A1 A2 : unitAlgType R) := + Eval hnf in [unitAlgType R of A1 * A2]. + +(* begin hide *) + +(* Testing subtype hierarchy +Section Test0. + +Variables (T : choiceType) (S : predPredType T). + +Inductive B := mkB x & x \in S. +Definition vB u := let: mkB x _ := u in x. + +Canonical B_subType := [subType for vB]. +Definition B_eqMixin := [eqMixin of B by <:]. +Canonical B_eqType := EqType B B_eqMixin. +Definition B_choiceMixin := [choiceMixin of B by <:]. +Canonical B_choiceType := ChoiceType B B_choiceMixin. + +End Test0. + +Section Test1. + +Variables (R : unitRingType) (S : pred R). +Variables (ringS : divringPred S) (kS : keyed_pred ringS). + +Definition B_zmodMixin := [zmodMixin of B kS by <:]. +Canonical B_zmodType := ZmodType (B kS) B_zmodMixin. +Definition B_ringMixin := [ringMixin of B kS by <:]. +Canonical B_ringType := RingType (B kS) B_ringMixin. +Definition B_unitRingMixin := [unitRingMixin of B kS by <:]. +Canonical B_unitRingType := UnitRingType (B kS) B_unitRingMixin. + +End Test1. + +Section Test2. + +Variables (R : comUnitRingType) (A : unitAlgType R) (S : pred A). +Variables (algS : divalgPred S) (kS : keyed_pred algS). + +Definition B_lmodMixin := [lmodMixin of B kS by <:]. +Canonical B_lmodType := LmodType R (B kS) B_lmodMixin. +Definition B_lalgMixin := [lalgMixin of B kS by <:]. +Canonical B_lalgType := LalgType R (B kS) B_lalgMixin. +Definition B_algMixin := [algMixin of B kS by <:]. +Canonical B_algType := AlgType R (B kS) B_algMixin. +Canonical B_unitAlgType := [unitAlgType R of B kS]. + +End Test2. + +Section Test3. + +Variables (F : fieldType) (S : pred F). +Variables (ringS : divringPred S) (kS : keyed_pred ringS). + +Definition B_comRingMixin := [comRingMixin of B kS by <:]. +Canonical B_comRingType := ComRingType (B kS) B_comRingMixin. +Canonical B_comUnitRingType := [comUnitRingType of B kS]. +Definition B_idomainMixin := [idomainMixin of B kS by <:]. +Canonical B_idomainType := IdomainType (B kS) B_idomainMixin. +Definition B_fieldMixin := [fieldMixin of B kS by <:]. +Canonical B_fieldType := FieldType (B kS) B_fieldMixin. + +End Test3. + +*) + +(* end hide *) diff --git a/mathcomp/algebra/ssrint.v b/mathcomp/algebra/ssrint.v new file mode 100644 index 0000000..cbf726e --- /dev/null +++ b/mathcomp/algebra/ssrint.v @@ -0,0 +1,1782 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat choice seq. +Require Import fintype finfun bigop ssralg ssrnum poly. +Import GRing.Theory Num.Theory. + +(******************************************************************************) +(* This file develops a basic theory of signed integers, defining: *) +(* int == the type of signed integers, with two constructors Posz for *) +(* non-negative integers and Negz for negative integers. It *) +(* supports the realDomainType interface (and its parents). *) +(* n%:Z == explicit cast from nat to int (:= Posz n); displayed as n. *) +(* However (Posz m = Posz n) is displayed as (m = n :> int) *) +(* (and so are ==, != and <>) *) +(* Lemma NegzE : turns (Negz n) into - n.+1%:Z. *) +(* x *~ m == m times x, with m : int; *) +(* convertible to x *+ n if m is Posz n *) +(* convertible to x *- n.+1 if m is Negz n. *) +(* m%:~R == the image of m : int in a generic ring (:= 1 *~ m). *) +(* x ^ m == x to the m, with m : int; *) +(* convertible to x ^+ n if m is Posz n *) +(* convertible to x ^- n.+1 if m is Negz n. *) +(* sgz x == sign of x : R, *) +(* equals (0 : int) if and only x == 0, *) +(* equals (1 : int) if x is positive *) +(* and (-1 : int) otherwise. *) +(* `|m|%N == the n : nat such that `|m|%R = n%:Z, for m : int. *) +(* `|m - n|%N == the distance between m and n; the '-' is specialized to *) +(* the int type, so m and n can be either of type nat or int *) +(* thanks to the Posz coercion; m and n are however parsed in *) +(* the %N scope. The IntDist submodule provides this notation *) +(* and the corresponding theory independently of the rest of *) +(* of the int and ssralg libraries (and notations). *) +(* Warning: due to the declaration of Posz as a coercion, two terms might be *) +(* displayed the same while not being convertible, for instance: *) +(* (Posz (x - y)) and (Posz x) - (Posz y) for x, y : nat. *) +(******************************************************************************) + + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Delimit Scope int_scope with Z. +Local Open Scope int_scope. + +(* Defining int *) +CoInductive int : Set := Posz of nat | Negz of nat. +(* This must be deferred to module DistInt to work around the design flaws of *) +(* the Coq module system. *) +(* Coercion Posz : nat >-> int. *) + +Notation "n %:Z" := (Posz n) + (at level 2, left associativity, format "n %:Z", only parsing) : int_scope. +Notation "n %:Z" := (Posz n) + (at level 2, left associativity, format "n %:Z", only parsing) : ring_scope. + +Notation "n = m :> 'in' 't'" := (Posz n = Posz m) + (at level 70, m at next level, format "n = m :> 'in' 't'") : ring_scope. +Notation "n == m :> 'in' 't'" := (Posz n == Posz m) + (at level 70, m at next level, format "n == m :> 'in' 't'") : ring_scope. +Notation "n != m :> 'in' 't'" := (Posz n != Posz m) + (at level 70, m at next level, format "n != m :> 'in' 't'") : ring_scope. +Notation "n <> m :> 'in' 't'" := (Posz n <> Posz m) + (at level 70, m at next level, format "n <> m :> 'in' 't'") : ring_scope. + +Definition natsum_of_int (m : int) : nat + nat := + match m with Posz p => inl _ p | Negz n => inr _ n end. + +Definition int_of_natsum (m : nat + nat) := + match m with inl p => Posz p | inr n => Negz n end. + +Lemma natsum_of_intK : cancel natsum_of_int int_of_natsum. +Proof. by case. Qed. + +Definition int_eqMixin := CanEqMixin natsum_of_intK. +Definition int_countMixin := CanCountMixin natsum_of_intK. +Definition int_choiceMixin := CountChoiceMixin int_countMixin. +Canonical int_eqType := Eval hnf in EqType int int_eqMixin. +Canonical int_choiceType := Eval hnf in ChoiceType int int_choiceMixin. +Canonical int_countType := Eval hnf in CountType int int_countMixin. + +Lemma eqz_nat (m n : nat) : (m%:Z == n%:Z) = (m == n). Proof. by []. Qed. + +Module intZmod. +Section intZmod. + +Definition addz (m n : int) := + match m, n with + | Posz m', Posz n' => Posz (m' + n') + | Negz m', Negz n' => Negz (m' + n').+1 + | Posz m', Negz n' => if n' < m' then Posz (m' - n'.+1) else Negz (n' - m') + | Negz n', Posz m' => if n' < m' then Posz (m' - n'.+1) else Negz (n' - m') + end. + +Definition oppz m := nosimpl + match m with + | Posz n => if n is (n'.+1)%N then Negz n' else Posz 0 + | Negz n => Posz (n.+1)%N + end. + +Local Notation "0" := (Posz 0) : int_scope. +Local Notation "-%Z" := (@oppz) : int_scope. +Local Notation "- x" := (oppz x) : int_scope. +Local Notation "+%Z" := (@addz) : int_scope. +Local Notation "x + y" := (addz x y) : int_scope. +Local Notation "x - y" := (x + - y) : int_scope. + +Lemma PoszD : {morph Posz : m n / (m + n)%N >-> m + n}. Proof. by []. Qed. + +Local Coercion Posz : nat >-> int. + +Lemma NegzE (n : nat) : Negz n = - n.+1. Proof. by []. Qed. + +Lemma int_rect (P : int -> Type) : + P 0 -> (forall n : nat, P n -> P (n.+1)) + -> (forall n : nat, P (- n) -> P (- (n.+1))) + -> forall n : int, P n. +Proof. +by move=> P0 hPp hPn []; elim=> [|n ihn]//; do? [apply: hPn | apply: hPp]. +Qed. + +Definition int_rec := int_rect. +Definition int_ind := int_rect. + +CoInductive int_spec (x : int) : int -> Type := +| ZintNull of x = 0 : int_spec x 0 +| ZintPos n of x = n.+1 : int_spec x n.+1 +| ZintNeg n of x = - (n.+1)%:Z : int_spec x (- n.+1). + +Lemma intP x : int_spec x x. Proof. by move: x=> [] []; constructor. Qed. + +Lemma addzC : commutative addz. +Proof. by move=> [] m [] n //=; rewrite addnC. Qed. + +Lemma add0z : left_id 0 addz. Proof. by move=> [] [|]. Qed. + +Lemma oppzK : involutive oppz. Proof. by do 2?case. Qed. + +Lemma oppz_add : {morph oppz : m n / m + n}. +Proof. +move=> [[|n]|n] [[|m]|m] /=; rewrite ?NegzE ?oppzK ?addnS ?addn0 ?subn0 //; + rewrite ?ltnS[m <= n]leqNgt [n <= m]leqNgt; case: ltngtP=> hmn /=; + by rewrite ?hmn ?subnn // ?oppzK ?subSS ?subnS ?prednK // ?subn_gt0. +Qed. + +Lemma add1Pz (n : int) : 1 + (n - 1) = n. +Proof. by case: (intP n)=> // n' /= _; rewrite ?(subn1, addn0). Qed. + +Lemma subSz1 (n : int) : 1 + n - 1 = n. +Proof. +by apply: (inv_inj oppzK); rewrite addzC !oppz_add oppzK [_ - n]addzC add1Pz. +Qed. + +Lemma addSnz (m : nat) (n : int) : (m.+1%N) + n = 1 + (m + n). +Proof. +move: m n=> [|m] [] [|n] //=; rewrite ?add1n ?subn1 // !(ltnS, subSS). +rewrite [n <= m]leqNgt; case: ltngtP=> hmn /=; rewrite ?hmn ?subnn //. + by rewrite subnS add1n prednK ?subn_gt0. +by rewrite ltnS leqn0 subn_eq0 leqNgt hmn /= subnS subn1. +Qed. + +Lemma addSz (m n : int) : (1 + m) + n = 1 + (m + n). +Proof. +case: m => [] m; first by rewrite -PoszD add1n addSnz. +rewrite !NegzE; apply: (inv_inj oppzK). +rewrite !oppz_add !oppzK addSnz [-1%:Z + _]addzC addSnz add1Pz. +by rewrite [-1%:Z + _]addzC subSz1. +Qed. + +Lemma addPz (m n : int) : (m - 1) + n = (m + n) - 1. +Proof. +by apply: (inv_inj oppzK); rewrite !oppz_add oppzK [_ + 1]addzC addSz addzC. +Qed. + +Lemma addzA : associative addz. +Proof. +elim=> [|m ihm|m ihm] n p; first by rewrite !add0z. + by rewrite -add1n PoszD !addSz ihm. +by rewrite -add1n addnC PoszD oppz_add !addPz ihm. +Qed. + +Lemma addNz : left_inverse (0:int) oppz addz. Proof. by do 3?elim. Qed. + +Lemma predn_int (n : nat) : 0 < n -> n.-1%:Z = n - 1. +Proof. by case: n=> // n _ /=; rewrite subn1. Qed. + +Definition Mixin := ZmodMixin addzA addzC add0z addNz. + +End intZmod. +End intZmod. + +Canonical int_ZmodType := ZmodType int intZmod.Mixin. + +Local Open Scope ring_scope. + +Section intZmoduleTheory. + +Local Coercion Posz : nat >-> int. + +Lemma PoszD : {morph Posz : n m / (n + m)%N >-> n + m}. Proof. by []. Qed. + +Lemma NegzE (n : nat) : Negz n = -(n.+1)%:Z. Proof. by []. Qed. + +Lemma int_rect (P : int -> Type) : + P 0 -> (forall n : nat, P n -> P (n.+1)%N) + -> (forall n : nat, P (- (n%:Z)) -> P (- (n.+1%N%:Z))) + -> forall n : int, P n. +Proof. +by move=> P0 hPp hPn []; elim=> [|n ihn]//; do? [apply: hPn | apply: hPp]. +Qed. + +Definition int_rec := int_rect. +Definition int_ind := int_rect. + +CoInductive int_spec (x : int) : int -> Type := +| ZintNull : int_spec x 0 +| ZintPos n : int_spec x n.+1 +| ZintNeg n : int_spec x (- (n.+1)%:Z). + +Lemma intP x : int_spec x x. +Proof. by move: x=> [] [] *; rewrite ?NegzE; constructor. Qed. + +Definition oppz_add := (@opprD [zmodType of int]). + +Lemma subzn (m n : nat) : (n <= m)%N -> m%:Z - n%:Z = (m - n)%N. +Proof. +elim: n=> //= [|n ihn] hmn; first by rewrite subr0 subn0. +rewrite subnS -addn1 !PoszD opprD addrA ihn 1?ltnW //. +by rewrite intZmod.predn_int // subn_gt0. +Qed. + +Lemma subzSS (m n : nat) : m.+1%:Z - n.+1%:Z = m%:Z - n%:Z. +Proof. by elim: n m=> [|n ihn] m //; rewrite !subzn. Qed. + +End intZmoduleTheory. + +Module intRing. +Section intRing. + +Local Coercion Posz : nat >-> int. + +Definition mulz (m n : int) := + match m, n with + | Posz m', Posz n' => (m' * n')%N%:Z + | Negz m', Negz n' => (m'.+1%N * n'.+1%N)%N%:Z + | Posz m', Negz n' => - (m' * (n'.+1%N))%N%:Z + | Negz n', Posz m' => - (m' * (n'.+1%N))%N%:Z + end. + +Local Notation "1" := (1%N:int) : int_scope. +Local Notation "*%Z" := (@mulz) : int_scope. +Local Notation "x * y" := (mulz x y) : int_scope. + +Lemma mul0z : left_zero 0 *%Z. +Proof. by case=> [n|[|n]] //=; rewrite muln0. Qed. + +Lemma mulzC : commutative mulz. +Proof. by move=> [] m [] n //=; rewrite mulnC. Qed. + +Lemma mulz0 : right_zero 0 *%Z. +Proof. by move=> x; rewrite mulzC mul0z. Qed. + +Lemma mulzN (m n : int) : (m * (- n))%Z = - (m * n)%Z. +Proof. +by case: (intP m)=> {m} [|m|m]; rewrite ?mul0z //; +case: (intP n)=> {n} [|n|n]; rewrite ?mulz0 //= mulnC. +Qed. + +Lemma mulNz (m n : int) : ((- m) * n)%Z = - (m * n)%Z. +Proof. by rewrite mulzC mulzN mulzC. Qed. + +Lemma mulzA : associative mulz. +Proof. +by move=> [] m [] n [] p; rewrite ?NegzE ?(mulnA,mulNz,mulzN,opprK) //= ?mulnA. +Qed. + +Lemma mul1z : left_id 1%Z mulz. +Proof. by case=> [[|n]|n] //=; rewrite ?mul1n// plusE addn0. Qed. + +Lemma mulzS (x : int) (n : nat) : (x * n.+1%:Z)%Z = x + (x * n)%Z. +Proof. +by case: (intP x)=> [|m'|m'] //=; [rewrite mulnS|rewrite mulSn -opprD]. +Qed. + +Lemma mulz_addl : left_distributive mulz (+%R). +Proof. +move=> x y z; elim: z=> [|n|n]; first by rewrite !(mul0z,mulzC). + by rewrite !mulzS=> ->; rewrite !addrA [X in X + _]addrAC. +rewrite !mulzN !mulzS -!opprD=> /(inv_inj (@opprK _))->. +by rewrite !addrA [X in X + _]addrAC. +Qed. + +Lemma nonzero1z : 1%Z != 0. Proof. by []. Qed. + +Definition comMixin := ComRingMixin mulzA mulzC mul1z mulz_addl nonzero1z. + +End intRing. +End intRing. + +Canonical int_Ring := Eval hnf in RingType int intRing.comMixin. +Canonical int_comRing := Eval hnf in ComRingType int intRing.mulzC. + +Section intRingTheory. + +Implicit Types m n : int. +Local Coercion Posz : nat >-> int. + +Lemma PoszM : {morph Posz : n m / (n * m)%N >-> n * m}. Proof. by []. Qed. + +Lemma intS (n : nat) : n.+1%:Z = 1 + n%:Z. Proof. by rewrite -PoszD. Qed. + +Lemma predn_int (n : nat) : (0 < n)%N -> n.-1%:Z = n%:Z - 1. +Proof. exact: intZmod.predn_int. Qed. + +End intRingTheory. + +Module intUnitRing. +Section intUnitRing. +Implicit Types m n : int. +Local Coercion Posz : nat >-> int. + +Definition unitz := [qualify a n : int | (n == 1) || (n == -1)]. +Definition invz n : int := n. + +Lemma mulVz : {in unitz, left_inverse 1%R invz *%R}. +Proof. by move=> n /pred2P[] ->. Qed. + +Lemma mulzn_eq1 m (n : nat) : (m * n == 1) = (m == 1) && (n == 1%N). +Proof. by case: m=> m /=; [rewrite -PoszM [_==_]muln_eq1 | case: n]. Qed. + +Lemma unitzPl m n : n * m = 1 -> m \is a unitz. +Proof. +case: m => m; move/eqP; rewrite qualifE. +* by rewrite mulzn_eq1; case/andP=> _; move/eqP->. +* by rewrite NegzE intS mulrN -mulNr mulzn_eq1; case/andP=> _. +Qed. + +Lemma invz_out : {in [predC unitz], invz =1 id}. +Proof. exact. Qed. + +Lemma idomain_axiomz m n : m * n = 0 -> (m == 0) || (n == 0). +Proof. +by case: m n => m [] n //=; move/eqP; rewrite ?(NegzE,mulrN,mulNr); + rewrite ?(inv_eq (@opprK _)) -PoszM [_==_]muln_eq0. +Qed. + +Definition comMixin := ComUnitRingMixin mulVz unitzPl invz_out. + +End intUnitRing. +End intUnitRing. + +Canonical int_unitRingType := + Eval hnf in UnitRingType int intUnitRing.comMixin. +Canonical int_comUnitRing := Eval hnf in [comUnitRingType of int]. +Canonical int_iDomain := + Eval hnf in IdomainType int intUnitRing.idomain_axiomz. + +Definition absz m := match m with Posz p => p | Negz n => n.+1 end. +Notation "m - n" := + (@GRing.add int_ZmodType m%N (@GRing.opp int_ZmodType n%N)) : distn_scope. +Arguments Scope absz [distn_scope]. +Local Notation "`| m |" := (absz m) : nat_scope. + +Module intOrdered. +Section intOrdered. +Implicit Types m n p : int. +Local Coercion Posz : nat >-> int. + +Local Notation normz m := (absz m)%:Z. + +Definition lez m n := + match m, n with + | Posz m', Posz n' => (m' <= n')%N + | Posz m', Negz n' => false + | Negz m', Posz n' => true + | Negz m', Negz n' => (n' <= m')%N + end. + +Definition ltz m n := + match m, n with + | Posz m', Posz n' => (m' < n')%N + | Posz m', Negz n' => false + | Negz m', Posz n' => true + | Negz m', Negz n' => (n' < m')%N + end. + +Fact lez_norm_add x y : lez (normz (x + y)) (normz x + normz y). +Proof. +move: x y=> [] m [] n; rewrite /= ?addnS //=; +rewrite /GRing.add /GRing.Zmodule.add /=; case: ltnP=> //=; +rewrite ?addSn ?ltnS ?leq_subLR ?(addnS, addSn) ?(leq_trans _ (leqnSn _)) //; +by rewrite 1?addnCA ?leq_addr ?addnA ?leq_addl. +Qed. + +Fact ltz_add x y : ltz 0 x -> ltz 0 y -> ltz 0 (x + y). +Proof. by move: x y => [] x [] y //= hx hy; rewrite ltn_addr. Qed. + +Fact eq0_normz x : normz x = 0 -> x = 0. Proof. by case: x. Qed. + +Fact lez_total x y : lez x y || lez y x. +Proof. by move: x y => [] x [] y //=; apply: leq_total. Qed. + +Lemma abszN (n : nat) : absz (- n%:Z) = n. Proof. by case: n. Qed. + +Fact normzM : {morph (fun n => normz n) : x y / x * y}. +Proof. by move=> [] x [] y; rewrite // abszN // mulnC. Qed. + +Lemma subz_ge0 m n : lez 0 (n - m) = lez m n. +Proof. +case: (intP m); case: (intP n)=> // {m n} m n /=; +rewrite ?ltnS -?opprD ?opprB ?subzSS; case: leqP=> // hmn; +by [ rewrite subzn // + | rewrite -opprB subzn ?(ltnW hmn) //; + move: hmn; rewrite -subn_gt0; case: (_ - _)%N]. +Qed. + +Fact lez_def x y : (lez x y) = (normz (y - x) == y - x). +Proof. by rewrite -subz_ge0; move: (_ - _) => [] n //=; rewrite eqxx. Qed. + +Fact ltz_def x y : (ltz x y) = (y != x) && (lez x y). +Proof. +by move: x y=> [] x [] y //=; rewrite (ltn_neqAle, leq_eqVlt) // eq_sym. +Qed. + +Definition Mixin := + NumMixin lez_norm_add ltz_add eq0_normz (in2W lez_total) normzM + lez_def ltz_def. + +End intOrdered. +End intOrdered. + +Canonical int_numDomainType := NumDomainType int intOrdered.Mixin. +Canonical int_realDomainType := RealDomainType int (intOrdered.lez_total 0). + +Section intOrderedTheory. + +Local Coercion Posz : nat >-> int. +Implicit Types m n p : nat. +Implicit Types x y z : int. + +Lemma lez_nat m n : (m <= n :> int) = (m <= n)%N. +Proof. by []. Qed. + +Lemma ltz_nat m n : (m < n :> int) = (m < n)%N. +Proof. by rewrite ltnNge ltrNge lez_nat. Qed. + +Definition ltez_nat := (lez_nat, ltz_nat). + +Lemma leNz_nat m n : (- m%:Z <= n). Proof. by case: m. Qed. + +Lemma ltNz_nat m n : (- m%:Z < n) = (m != 0%N) || (n != 0%N). +Proof. by move: m n=> [|?] []. Qed. + +Definition lteNz_nat := (leNz_nat, ltNz_nat). + +Lemma lezN_nat m n : (m%:Z <= - n%:Z) = (m == 0%N) && (n == 0%N). +Proof. by move: m n=> [|?] []. Qed. + +Lemma ltzN_nat m n : (m%:Z < - n%:Z) = false. +Proof. by move: m n=> [|?] []. Qed. + +Lemma le0z_nat n : 0 <= n :> int. Proof. by []. Qed. + +Lemma lez0_nat n : n <= 0 :> int = (n == 0%N :> nat). Proof. by elim: n. Qed. + +Definition ltezN_nat := (lezN_nat, ltzN_nat). +Definition ltez_natE := (ltez_nat, lteNz_nat, ltezN_nat, le0z_nat, lez0_nat). + +Lemma gtz0_ge1 x : (0 < x) = (1 <= x). Proof. by case: (intP x). Qed. + +Lemma lez_add1r x y : (1 + x <= y) = (x < y). +Proof. by rewrite -subr_gt0 gtz0_ge1 lter_sub_addr. Qed. + +Lemma lez_addr1 x y : (x + 1 <= y) = (x < y). +Proof. by rewrite addrC lez_add1r. Qed. + +Lemma ltz_add1r x y : (x < 1 + y) = (x <= y). +Proof. by rewrite -lez_add1r ler_add2l. Qed. + +Lemma ltz_addr1 x y : (x < y + 1) = (x <= y). +Proof. by rewrite -lez_addr1 ler_add2r. Qed. + +End intOrderedTheory. + +Bind Scope ring_scope with int. + +(* definition of intmul *) +Definition intmul (R : zmodType) (x : R) (n : int) := nosimpl + match n with + | Posz n => (x *+ n)%R + | Negz n => (x *- (n.+1))%R + end. + +Notation "*~%R" := (@intmul _) (at level 0, format " *~%R") : ring_scope. +Notation "x *~ n" := (intmul x n) + (at level 40, left associativity, format "x *~ n") : ring_scope. +Notation intr := ( *~%R 1). +Notation "n %:~R" := (1 *~ n)%R + (at level 2, left associativity, format "n %:~R") : ring_scope. + +Lemma pmulrn (R : zmodType) (x : R) (n : nat) : x *+ n = x *~ n%:Z. +Proof. by []. Qed. + +Lemma nmulrn (R : zmodType) (x : R) (n : nat) : x *- n = x *~ - n%:Z. +Proof. by case: n=> [] //; rewrite ?oppr0. Qed. + +Section ZintLmod. + +Definition zmodule (M : Type) : Type := M. +Local Notation "M ^z" := (zmodule M) (at level 2, format "M ^z") : type_scope. +Local Coercion Posz : nat >-> int. + +Variable M : zmodType. + +Implicit Types m n : int. +Implicit Types x y z : M. + +Fact mulrzA_C m n x : (x *~ n) *~ m = x *~ (m * n). +Proof. +elim: m=> [|m _|m _]; elim: n=> [|n _|n _]; rewrite /intmul //=; +rewrite ?(muln0, mulr0n, mul0rn, oppr0, mulNrn, opprK) //; + do ?by rewrite mulnC mulrnA. +* by rewrite -mulrnA mulnC. +* by rewrite -mulrnA. +Qed. + +Fact mulrzAC m n x : (x *~ n) *~ m = (x *~ m) *~ n. +Proof. by rewrite !mulrzA_C mulrC. Qed. + +Fact mulr1z (x : M) : x *~ 1 = x. Proof. by []. Qed. + +Fact mulrzDr m : {morph ( *~%R^~ m : M -> M) : x y / x + y}. +Proof. +by elim: m=> [|m _|m _] x y; + rewrite ?addr0 /intmul //= ?mulrnDl // opprD. +Qed. + +Lemma mulrzBl_nat (m n : nat) x : x *~ (m%:Z - n%:Z) = x *~ m - x *~ n. +Proof. +case: (leqP m n)=> hmn; rewrite /intmul //=. + rewrite addrC -{1}[m:int]opprK -opprD subzn //. + rewrite -{2}[n](@subnKC m)// mulrnDr opprD addrA subrr sub0r. + by case hdmn: (_ - _)%N=> [|dmn] /=; first by rewrite mulr0n oppr0. +have hnm := ltnW hmn. +rewrite -{2}[m](@subnKC n)// mulrnDr addrAC subrr add0r. +by rewrite subzn. +Qed. + +Fact mulrzDl x : {morph *~%R x : m n / m + n}. +Proof. +elim=> [|m _|m _]; elim=> [|n _|n _]; rewrite /intmul //=; +rewrite -?(opprD) ?(add0r, addr0, mulrnDr, subn0) //. +* by rewrite -/(intmul _ _) mulrzBl_nat. +* by rewrite -/(intmul _ _) addrC mulrzBl_nat addrC. +* by rewrite -addnS -addSn mulrnDr. +Qed. + +Definition Mint_LmodMixin := + @LmodMixin _ [zmodType of M] (fun n x => x *~ n) + mulrzA_C mulr1z mulrzDr mulrzDl. +Canonical Mint_LmodType := LmodType int M^z Mint_LmodMixin. + +Lemma scalezrE n x : n *: (x : M^z) = x *~ n. Proof. by []. Qed. + +Lemma mulrzA x m n : x *~ (m * n) = x *~ m *~ n. +Proof. by rewrite -!scalezrE scalerA mulrC. Qed. + +Lemma mulr0z x : x *~ 0 = 0. Proof. by []. Qed. + +Lemma mul0rz n : 0 *~ n = 0 :> M. +Proof. by rewrite -scalezrE scaler0. Qed. + +Lemma mulrNz x n : x *~ (- n) = - (x *~ n). +Proof. by rewrite -scalezrE scaleNr. Qed. + +Lemma mulrN1z x : x *~ (- 1) = - x. Proof. by rewrite -scalezrE scaleN1r. Qed. + +Lemma mulNrz x n : (- x) *~ n = - (x *~ n). +Proof. by rewrite -scalezrE scalerN. Qed. + +Lemma mulrzBr x m n : x *~ (m - n) = x *~ m - x *~ n. +Proof. by rewrite -scalezrE scalerBl. Qed. + +Lemma mulrzBl x y n : (x - y) *~ n = x *~ n - y *~ n. +Proof. by rewrite -scalezrE scalerBr. Qed. + +Lemma mulrz_nat (n : nat) x : x *~ n%:R = x *+ n. +Proof. by rewrite -scalezrE scaler_nat. Qed. + +Lemma mulrz_sumr : forall x I r (P : pred I) F, + x *~ (\sum_(i <- r | P i) F i) = \sum_(i <- r | P i) x *~ F i. +Proof. by rewrite -/M^z; exact: scaler_suml. Qed. + +Lemma mulrz_suml : forall n I r (P : pred I) (F : I -> M), + (\sum_(i <- r | P i) F i) *~ n= \sum_(i <- r | P i) F i *~ n. +Proof. by rewrite -/M^z; exact: scaler_sumr. Qed. + +Canonical intmul_additive x := Additive (@mulrzBr x). + +End ZintLmod. + +Lemma ffunMzE (I : finType) (M : zmodType) (f : {ffun I -> M}) z x : + (f *~ z) x = f x *~ z. +Proof. by case: z => n; rewrite ?ffunE ffunMnE. Qed. + +Lemma intz (n : int) : n%:~R = n. +Proof. +elim: n=> //= n ihn; rewrite /intmul /=. + by rewrite -addn1 mulrnDr /= PoszD -ihn. +by rewrite nmulrn intS opprD mulrzDl ihn. +Qed. + +Lemma natz (n : nat) : n%:R = n%:Z :> int. +Proof. by rewrite pmulrn intz. Qed. + +Section RintMod. + +Local Coercion Posz : nat >-> int. +Variable R : ringType. + +Implicit Types m n : int. +Implicit Types x y z : R. + +Lemma mulrzAl n x y : (x *~ n) * y = (x * y) *~ n. +Proof. +by elim: n=> //= *; rewrite ?mul0r ?mulr0z // /intmul /= -mulrnAl -?mulNr. +Qed. + +Lemma mulrzAr n x y : x * (y *~ n) = (x * y) *~ n. +Proof. +by elim: n=> //= *; rewrite ?mulr0 ?mulr0z // /intmul /= -mulrnAr -?mulrN. +Qed. + +Lemma mulrzl x n : n%:~R * x = x *~ n. +Proof. by rewrite mulrzAl mul1r. Qed. + +Lemma mulrzr x n : x * n%:~R = x *~ n. +Proof. by rewrite mulrzAr mulr1. Qed. + +Lemma mulNrNz n x : (-x) *~ (-n) = x *~ n. +Proof. by rewrite mulNrz mulrNz opprK. Qed. + +Lemma mulrbz x (b : bool) : x *~ b = (if b then x else 0). +Proof. by case: b. Qed. + +Lemma intrD m n : (m + n)%:~R = m%:~R + n%:~R :> R. +Proof. exact: mulrzDl. Qed. + +Lemma intrM m n : (m * n)%:~R = m%:~R * n%:~R :> R. +Proof. by rewrite mulrzA -mulrzr. Qed. + +Lemma intmul1_is_rmorphism : rmorphism ( *~%R (1 : R)). +Proof. +by do ?split; move=> // x y /=; rewrite ?intrD ?mulrNz ?intrM. +Qed. +Canonical intmul1_rmorphism := RMorphism intmul1_is_rmorphism. + +Lemma mulr2z n : n *~ 2 = n + n. Proof. exact: mulr2n. Qed. + +End RintMod. + +Lemma mulrzz m n : m *~ n = m * n. Proof. by rewrite -mulrzr intz. Qed. + +Lemma mulz2 n : n * 2%:Z = n + n. Proof. by rewrite -mulrzz. Qed. + +Lemma mul2z n : 2%:Z * n = n + n. Proof. by rewrite mulrC -mulrzz. Qed. + +Section LMod. + +Variable R : ringType. +Variable V : (lmodType R). +Local Coercion Posz : nat >-> int. + +Implicit Types m n : int. +Implicit Types x y z : R. +Implicit Types u v w : V. + +Lemma scaler_int n v : n%:~R *: v = v *~ n. +Proof. +elim: n=> [|n ihn|n ihn]; first by rewrite scale0r. + by rewrite intS !mulrzDl scalerDl ihn scale1r. +by rewrite intS opprD !mulrzDl scalerDl ihn scaleN1r. +Qed. + +Lemma scalerMzl a v n : (a *: v) *~ n = (a *~ n) *: v. +Proof. by rewrite -mulrzl -scaler_int scalerA. Qed. + +Lemma scalerMzr a v n : (a *: v) *~ n = a *: (v *~ n). +Proof. by rewrite -!scaler_int !scalerA mulrzr mulrzl. Qed. + +End LMod. + +Lemma mulrz_int (M : zmodType) (n : int) (x : M) : x *~ n%:~R = x *~ n. +Proof. by rewrite -scalezrE scaler_int. Qed. + +Section MorphTheory. +Local Coercion Posz : nat >-> int. +Section Additive. +Variables (U V : zmodType) (f : {additive U -> V}). + +Lemma raddfMz n : {morph f : x / x *~ n}. +Proof. +case: n=> n x /=; first exact: raddfMn. +by rewrite NegzE !mulrNz; apply: raddfMNn. +Qed. + +End Additive. + +Section Multiplicative. + +Variables (R S : ringType) (f : {rmorphism R -> S}). + +Lemma rmorphMz : forall n, {morph f : x / x *~ n}. Proof. exact: raddfMz. Qed. + +Lemma rmorph_int : forall n, f n%:~R = n%:~R. +Proof. by move=> n; rewrite rmorphMz rmorph1. Qed. + +End Multiplicative. + +Section Linear. + +Variable R : ringType. +Variables (U V : lmodType R) (f : {linear U -> V}). + +Lemma linearMn : forall n, {morph f : x / x *~ n}. Proof. exact: raddfMz. Qed. + +End Linear. + +Lemma raddf_int_scalable (aV rV : lmodType int) (f : {additive aV -> rV}) : + scalable f. +Proof. by move=> z u; rewrite -[z]intz !scaler_int raddfMz. Qed. + +Section Zintmul1rMorph. + +Variable R : ringType. + +Lemma commrMz (x y : R) n : GRing.comm x y -> GRing.comm x (y *~ n). +Proof. by rewrite /GRing.comm=> com_xy; rewrite mulrzAr mulrzAl com_xy. Qed. + +Lemma commr_int (x : R) n : GRing.comm x n%:~R. +Proof. by apply: commrMz; apply: commr1. Qed. + +End Zintmul1rMorph. + +Section ZintBigMorphism. + +Variable R : ringType. + +Lemma sumMz : forall I r (P : pred I) F, + (\sum_(i <- r | P i) F i)%N%:~R = \sum_(i <- r | P i) ((F i)%:~R) :> R. +Proof. by apply: big_morph=> // x y; rewrite !pmulrn -rmorphD. Qed. + +Lemma prodMz : forall I r (P : pred I) F, + (\prod_(i <- r | P i) F i)%N%:~R = \prod_(i <- r | P i) ((F i)%:~R) :> R. +Proof. by apply: big_morph=> // x y; rewrite !pmulrn PoszM -rmorphM. Qed. + +End ZintBigMorphism. + +Section Frobenius. + +Variable R : ringType. +Implicit Types x y : R. + +Variable p : nat. +Hypothesis charFp : p \in [char R]. + +Local Notation "x ^f" := (Frobenius_aut charFp x). + +Lemma Frobenius_autMz x n : (x *~ n)^f = x^f *~ n. +Proof. +case: n=> n /=; first exact: Frobenius_autMn. +by rewrite !NegzE !mulrNz Frobenius_autN Frobenius_autMn. +Qed. + +Lemma Frobenius_aut_int n : (n%:~R)^f = n%:~R. +Proof. by rewrite Frobenius_autMz Frobenius_aut1. Qed. + +End Frobenius. + +Section NumMorphism. + +Section PO. + +Variables (R : numDomainType). + +Implicit Types n m : int. +Implicit Types x y : R. + +Lemma rmorphzP (f : {rmorphism int -> R}) : f =1 ( *~%R 1). +Proof. +move=> n; wlog : n / 0 <= n; case: n=> [] n //; do ?exact. + by rewrite NegzE !rmorphN=>->. +move=> _; elim: n=> [|n ihn]; first by rewrite rmorph0. +by rewrite intS !rmorphD !rmorph1 ihn. +Qed. + +(* intmul and ler/ltr *) +Lemma ler_pmulz2r n (hn : 0 < n) : {mono *~%R^~ n :x y / x <= y :> R}. +Proof. by move=> x y; case: n hn=> [[]|] // n _; rewrite ler_pmuln2r. Qed. + +Lemma ltr_pmulz2r n (hn : 0 < n) : {mono *~%R^~ n : x y / x < y :> R}. +Proof. exact: lerW_mono (ler_pmulz2r _). Qed. + +Lemma ler_nmulz2r n (hn : n < 0) : {mono *~%R^~ n : x y /~ x <= y :> R}. +Proof. +move=> x y /=; rewrite -![_ *~ n]mulNrNz. +by rewrite ler_pmulz2r (oppr_cp0, ler_opp2). +Qed. + +Lemma ltr_nmulz2r n (hn : n < 0) : {mono *~%R^~ n : x y /~ x < y :> R}. +Proof. exact: lerW_nmono (ler_nmulz2r _). Qed. + +Lemma ler_wpmulz2r n (hn : 0 <= n) : {homo *~%R^~ n : x y / x <= y :> R}. +Proof. by move=> x y xy; case: n hn=> [] // n _; rewrite ler_wmuln2r. Qed. + +Lemma ler_wnmulz2r n (hn : n <= 0) : {homo *~%R^~ n : x y /~ x <= y :> R}. +Proof. +by move=> x y xy /=; rewrite -ler_opp2 -!mulrNz ler_wpmulz2r // oppr_ge0. +Qed. + +Lemma mulrz_ge0 x n (x0 : 0 <= x) (n0 : 0 <= n) : 0 <= x *~ n. +Proof. by rewrite -(mul0rz _ n) ler_wpmulz2r. Qed. + +Lemma mulrz_le0 x n (x0 : x <= 0) (n0 : n <= 0) : 0 <= x *~ n. +Proof. by rewrite -(mul0rz _ n) ler_wnmulz2r. Qed. + +Lemma mulrz_ge0_le0 x n (x0 : 0 <= x) (n0 : n <= 0) : x *~ n <= 0. +Proof. by rewrite -(mul0rz _ n) ler_wnmulz2r. Qed. + +Lemma mulrz_le0_ge0 x n (x0 : x <= 0) (n0 : 0 <= n) : x *~ n <= 0. +Proof. by rewrite -(mul0rz _ n) ler_wpmulz2r. Qed. + +Lemma pmulrz_lgt0 x n (n0 : 0 < n) : 0 < x *~ n = (0 < x). +Proof. by rewrite -(mul0rz _ n) ltr_pmulz2r // mul0rz. Qed. + +Lemma nmulrz_lgt0 x n (n0 : n < 0) : 0 < x *~ n = (x < 0). +Proof. by rewrite -(mul0rz _ n) ltr_nmulz2r // mul0rz. Qed. + +Lemma pmulrz_llt0 x n (n0 : 0 < n) : x *~ n < 0 = (x < 0). +Proof. by rewrite -(mul0rz _ n) ltr_pmulz2r // mul0rz. Qed. + +Lemma nmulrz_llt0 x n (n0 : n < 0) : x *~ n < 0 = (0 < x). +Proof. by rewrite -(mul0rz _ n) ltr_nmulz2r // mul0rz. Qed. + +Lemma pmulrz_lge0 x n (n0 : 0 < n) : 0 <= x *~ n = (0 <= x). +Proof. by rewrite -(mul0rz _ n) ler_pmulz2r // mul0rz. Qed. + +Lemma nmulrz_lge0 x n (n0 : n < 0) : 0 <= x *~ n = (x <= 0). +Proof. by rewrite -(mul0rz _ n) ler_nmulz2r // mul0rz. Qed. + +Lemma pmulrz_lle0 x n (n0 : 0 < n) : x *~ n <= 0 = (x <= 0). +Proof. by rewrite -(mul0rz _ n) ler_pmulz2r // mul0rz. Qed. + +Lemma nmulrz_lle0 x n (n0 : n < 0) : x *~ n <= 0 = (0 <= x). +Proof. by rewrite -(mul0rz _ n) ler_nmulz2r // mul0rz. Qed. + +Lemma ler_wpmulz2l x (hx : 0 <= x) : {homo *~%R x : x y / x <= y}. +Proof. +by move=> m n /= hmn; rewrite -subr_ge0 -mulrzBr mulrz_ge0 // subr_ge0. +Qed. + +Lemma ler_wnmulz2l x (hx : x <= 0) : {homo *~%R x : x y /~ x <= y}. +Proof. +by move=> m n /= hmn; rewrite -subr_ge0 -mulrzBr mulrz_le0 // subr_le0. +Qed. + +Lemma ler_pmulz2l x (hx : 0 < x) : {mono *~%R x : x y / x <= y}. +Proof. +move=> m n /=; rewrite real_mono ?num_real // => {m n}. +by move=> m n /= hmn; rewrite -subr_gt0 -mulrzBr pmulrz_lgt0 // subr_gt0. +Qed. + +Lemma ler_nmulz2l x (hx : x < 0) : {mono *~%R x : x y /~ x <= y}. +Proof. +move=> m n /=; rewrite real_nmono ?num_real // => {m n}. +by move=> m n /= hmn; rewrite -subr_gt0 -mulrzBr nmulrz_lgt0 // subr_lt0. +Qed. + +Lemma ltr_pmulz2l x (hx : 0 < x) : {mono *~%R x : x y / x < y}. +Proof. exact: lerW_mono (ler_pmulz2l _). Qed. + +Lemma ltr_nmulz2l x (hx : x < 0) : {mono *~%R x : x y /~ x < y}. +Proof. exact: lerW_nmono (ler_nmulz2l _). Qed. + +Lemma pmulrz_rgt0 x n (x0 : 0 < x) : 0 < x *~ n = (0 < n). +Proof. by rewrite -(mulr0z x) ltr_pmulz2l. Qed. + +Lemma nmulrz_rgt0 x n (x0 : x < 0) : 0 < x *~ n = (n < 0). +Proof. by rewrite -(mulr0z x) ltr_nmulz2l. Qed. + +Lemma pmulrz_rlt0 x n (x0 : 0 < x) : x *~ n < 0 = (n < 0). +Proof. by rewrite -(mulr0z x) ltr_pmulz2l. Qed. + +Lemma nmulrz_rlt0 x n (x0 : x < 0) : x *~ n < 0 = (0 < n). +Proof. by rewrite -(mulr0z x) ltr_nmulz2l. Qed. + +Lemma pmulrz_rge0 x n (x0 : 0 < x) : 0 <= x *~ n = (0 <= n). +Proof. by rewrite -(mulr0z x) ler_pmulz2l. Qed. + +Lemma nmulrz_rge0 x n (x0 : x < 0) : 0 <= x *~ n = (n <= 0). +Proof. by rewrite -(mulr0z x) ler_nmulz2l. Qed. + +Lemma pmulrz_rle0 x n (x0 : 0 < x) : x *~ n <= 0 = (n <= 0). +Proof. by rewrite -(mulr0z x) ler_pmulz2l. Qed. + +Lemma nmulrz_rle0 x n (x0 : x < 0) : x *~ n <= 0 = (0 <= n). +Proof. by rewrite -(mulr0z x) ler_nmulz2l. Qed. + +Lemma mulrIz x (hx : x != 0) : injective ( *~%R x). +Proof. +move=> y z; rewrite -![x *~ _]mulrzr => /(mulfI hx). +by apply: mono_inj y z; apply: ler_pmulz2l. +Qed. + +Lemma ler_int m n : (m%:~R <= n%:~R :> R) = (m <= n). +Proof. by rewrite ler_pmulz2l. Qed. + +Lemma ltr_int m n : (m%:~R < n%:~R :> R) = (m < n). +Proof. by rewrite ltr_pmulz2l. Qed. + +Lemma eqr_int m n : (m%:~R == n%:~R :> R) = (m == n). +Proof. by rewrite (inj_eq (mulrIz _)) ?oner_eq0. Qed. + +Lemma ler0z n : (0 <= n%:~R :> R) = (0 <= n). +Proof. by rewrite pmulrz_rge0. Qed. + +Lemma ltr0z n : (0 < n%:~R :> R) = (0 < n). +Proof. by rewrite pmulrz_rgt0. Qed. + +Lemma lerz0 n : (n%:~R <= 0 :> R) = (n <= 0). +Proof. by rewrite pmulrz_rle0. Qed. + +Lemma ltrz0 n : (n%:~R < 0 :> R) = (n < 0). +Proof. by rewrite pmulrz_rlt0. Qed. + +Lemma ler1z (n : int) : (1 <= n%:~R :> R) = (1 <= n). +Proof. by rewrite -[1]/(1%:~R) ler_int. Qed. + +Lemma ltr1z (n : int) : (1 < n%:~R :> R) = (1 < n). +Proof. by rewrite -[1]/(1%:~R) ltr_int. Qed. + +Lemma lerz1 n : (n%:~R <= 1 :> R) = (n <= 1). +Proof. by rewrite -[1]/(1%:~R) ler_int. Qed. + +Lemma ltrz1 n : (n%:~R < 1 :> R) = (n < 1). +Proof. by rewrite -[1]/(1%:~R) ltr_int. Qed. + +Lemma intr_eq0 n : (n%:~R == 0 :> R) = (n == 0). +Proof. by rewrite -(mulr0z 1) (inj_eq (mulrIz _)) // oner_eq0. Qed. + +Lemma mulrz_eq0 x n : (x *~ n == 0) = ((n == 0) || (x == 0)). +Proof. by rewrite -mulrzl mulf_eq0 intr_eq0. Qed. + +Lemma mulrz_neq0 x n : x *~ n != 0 = ((n != 0) && (x != 0)). +Proof. by rewrite mulrz_eq0 negb_or. Qed. + +Lemma realz n : (n%:~R : R) \in Num.real. +Proof. by rewrite -topredE /Num.real /= ler0z lerz0 ler_total. Qed. +Hint Resolve realz. + +Definition intr_inj := @mulrIz 1 (oner_neq0 R). + +End PO. + +End NumMorphism. + +End MorphTheory. + +Implicit Arguments intr_inj [[R] x1 x2]. + +Definition exprz (R : unitRingType) (x : R) (n : int) := nosimpl + match n with + | Posz n => x ^+ n + | Negz n => x ^- (n.+1) + end. + +Notation "x ^ n" := (exprz x n) : ring_scope. + +Section ExprzUnitRing. + +Variable R : unitRingType. +Implicit Types x y : R. +Implicit Types m n : int. +Local Coercion Posz : nat >-> int. + +Lemma exprnP x (n : nat) : x ^+ n = x ^ n. Proof. by []. Qed. + +Lemma exprnN x (n : nat) : x ^- n = x ^ -n%:Z. +Proof. by case: n=> //; rewrite oppr0 expr0 invr1. Qed. + +Lemma expr0z x : x ^ 0 = 1. Proof. by []. Qed. + +Lemma expr1z x : x ^ 1 = x. Proof. by []. Qed. + +Lemma exprN1 x : x ^ (-1) = x^-1. Proof. by []. Qed. + +Lemma invr_expz x n : (x ^ n)^-1 = x ^ (- n). +Proof. +by case: (intP n)=> // [|m]; rewrite ?opprK ?expr0z ?invr1 // invrK. +Qed. + +Lemma exprz_inv x n : (x^-1) ^ n = x ^ (- n). +Proof. +by case: (intP n)=> // m; rewrite -[_ ^ (- _)]exprVn ?opprK ?invrK. +Qed. + +Lemma exp1rz n : 1 ^ n = 1 :> R. +Proof. +by case: (intP n)=> // m; rewrite -?exprz_inv ?invr1; apply: expr1n. +Qed. + +Lemma exprSz x (n : nat) : x ^ n.+1 = x * x ^ n. Proof. exact: exprS. Qed. + +Lemma exprSzr x (n : nat) : x ^ n.+1 = x ^ n * x. +Proof. exact: exprSr. Qed. + +Fact exprzD_nat x (m n : nat) : x ^ (m%:Z + n) = x ^ m * x ^ n. +Proof. exact: exprD. Qed. + +Fact exprzD_Nnat x (m n : nat) : x ^ (-m%:Z + -n%:Z) = x ^ (-m%:Z) * x ^ (-n%:Z). +Proof. by rewrite -opprD -!exprz_inv exprzD_nat. Qed. + +Lemma exprzD_ss x m n : (0 <= m) && (0 <= n) || (m <= 0) && (n <= 0) + -> x ^ (m + n) = x ^ m * x ^ n. +Proof. +case: (intP m)=> {m} [|m|m]; case: (intP n)=> {n} [|n|n] //= _; +by rewrite ?expr0z ?mul1r ?exprzD_nat ?exprzD_Nnat ?sub0r ?addr0 ?mulr1. +Qed. + +Lemma exp0rz n : 0 ^ n = (n == 0)%:~R :> R. +Proof. by case: (intP n)=> // m; rewrite -?exprz_inv ?invr0 exprSz mul0r. Qed. + +Lemma commrXz x y n : GRing.comm x y -> GRing.comm x (y ^ n). +Proof. +rewrite /GRing.comm; elim: n x y=> [|n ihn|n ihn] x y com_xy //=. +* by rewrite expr0z mul1r mulr1. +* by rewrite -exprnP commrX //. +rewrite -exprz_inv -exprnP commrX //. +case: (boolP (y \is a GRing.unit))=> uy; last by rewrite invr_out. +by apply/eqP; rewrite (can2_eq (mulrVK _) (mulrK _)) // -mulrA com_xy mulKr. +Qed. + +Lemma exprMz_comm x y n : x \is a GRing.unit -> y \is a GRing.unit -> + GRing.comm x y -> (x * y) ^ n = x ^ n * y ^ n. +Proof. +move=> ux uy com_xy; elim: n => [|n _|n _]; first by rewrite expr0z mulr1. + by rewrite -!exprnP exprMn_comm. +rewrite -!exprnN -!exprVn com_xy -exprMn_comm ?invrM//. +exact/commrV/commr_sym/commrV. +Qed. + +Lemma commrXz_wmulls x y n : + 0 <= n -> GRing.comm x y -> (x * y) ^ n = x ^ n * y ^ n. +Proof. +move=> n0 com_xy; elim: n n0 => [|n _|n _] //; first by rewrite expr0z mulr1. +by rewrite -!exprnP exprMn_comm. +Qed. + +Lemma unitrXz x n (ux : x \is a GRing.unit) : x ^ n \is a GRing.unit. +Proof. +case: (intP n)=> {n} [|n|n]; rewrite ?expr0z ?unitr1 ?unitrX //. +by rewrite -invr_expz unitrV unitrX. +Qed. + +Lemma exprzDr x (ux : x \is a GRing.unit) m n : x ^ (m + n) = x ^ m * x ^ n. +Proof. +move: n m; apply: wlog_ler=> n m hnm. + by rewrite addrC hnm commrXz //; apply: commr_sym; apply: commrXz. +case: (intP m) hnm=> {m} [|m|m]; rewrite ?mul1r ?add0r //; + case: (intP n)=> {n} [|n|n _]; rewrite ?mulr1 ?addr0 //; + do ?by rewrite exprzD_ss. +rewrite -invr_expz subzSS !exprSzr invrM ?unitrX // -mulrA mulVKr //. +case: (leqP n m)=> [|/ltnW] hmn; rewrite -{2}(subnK hmn) exprzD_nat -subzn //. + by rewrite mulrK ?unitrX. +by rewrite invrM ?unitrXz // mulVKr ?unitrXz // -opprB -invr_expz. +Qed. + +Lemma exprz_exp x m n : (x ^ m) ^ n = (x ^ (m * n)). +Proof. +wlog: n / 0 <= n. + by case: n=> [n -> //|n]; rewrite ?NegzE mulrN -?invr_expz=> -> /=. +elim: n x m=> [|n ihn|n ihn] x m // _; first by rewrite mulr0 !expr0z. +rewrite exprSz ihn // intS mulrDr mulr1 exprzD_ss //. +by case: (intP m)=> // m'; rewrite ?oppr_le0 //. +Qed. + +Lemma exprzAC x m n : (x ^ m) ^ n = (x ^ n) ^ m. +Proof. by rewrite !exprz_exp mulrC. Qed. + +Lemma exprz_out x n (nux : x \isn't a GRing.unit) (hn : 0 <= n) : + x ^ (- n) = x ^ n. +Proof. by case: (intP n) hn=> //= m; rewrite -exprnN -exprVn invr_out. Qed. + +End ExprzUnitRing. + +Section Exprz_Zint_UnitRing. + +Variable R : unitRingType. +Implicit Types x y : R. +Implicit Types m n : int. +Local Coercion Posz : nat >-> int. + +Lemma exprz_pmulzl x m n : 0 <= n -> (x *~ m) ^ n = x ^ n *~ (m ^ n). +Proof. +by elim: n=> [|n ihn|n _] // _; rewrite !exprSz ihn // mulrzAr mulrzAl -mulrzA. +Qed. + +Lemma exprz_pintl m n (hn : 0 <= n) : m%:~R ^ n = (m ^ n)%:~R :> R. +Proof. by rewrite exprz_pmulzl // exp1rz. Qed. + +Lemma exprzMzl x m n (ux : x \is a GRing.unit) (um : m%:~R \is a @GRing.unit R): + (x *~ m) ^ n = (m%:~R ^ n) * x ^ n :> R. +Proof. +rewrite -[x *~ _]mulrzl exprMz_comm //. +by apply: commr_sym; apply: commr_int. +Qed. + +Lemma expNrz x n : (- x) ^ n = (-1) ^ n * x ^ n :> R. +Proof. +case: n=> [] n; rewrite ?NegzE; first by apply: exprNn. +by rewrite -!exprz_inv !invrN invr1; apply: exprNn. +Qed. + +Lemma unitr_n0expz x n : + n != 0 -> (x ^ n \is a GRing.unit) = (x \is a GRing.unit). +Proof. +by case: n => *; rewrite ?NegzE -?exprz_inv ?unitrX_pos ?unitrV ?lt0n. +Qed. + +Lemma intrV (n : int) : + n \in [:: 0; 1; -1] -> n%:~R ^-1 = n%:~R :> R. +Proof. +by case: (intP n)=> // [|[]|[]] //; rewrite ?rmorphN ?invrN (invr0, invr1). +Qed. + +Lemma rmorphXz (R' : unitRingType) (f : {rmorphism R -> R'}) n : + {in GRing.unit, {morph f : x / x ^ n}}. +Proof. by case: n => n x Ux; rewrite ?rmorphV ?rpredX ?rmorphX. Qed. + +End Exprz_Zint_UnitRing. + +Section ExprzIdomain. + +Variable R : idomainType. +Implicit Types x y : R. +Implicit Types m n : int. +Local Coercion Posz : nat >-> int. + +Lemma expfz_eq0 x n : (x ^ n == 0) = (n != 0) && (x == 0). +Proof. +by case: n=> n; rewrite ?NegzE -?exprz_inv ?expf_eq0 ?lt0n ?invr_eq0. +Qed. + +Lemma expfz_neq0 x n : x != 0 -> x ^ n != 0. +Proof. by move=> x_nz; rewrite expfz_eq0; apply/nandP; right. Qed. + +Lemma exprzMl x y n (ux : x \is a GRing.unit) (uy : y \is a GRing.unit) : + (x * y) ^ n = x ^ n * y ^ n. +Proof. by rewrite exprMz_comm //; apply: mulrC. Qed. + +Lemma expfV (x : R) (i : int) : (x ^ i) ^-1 = (x ^-1) ^ i. +Proof. by rewrite invr_expz exprz_inv. Qed. + +End ExprzIdomain. + +Section ExprzField. + +Variable F : fieldType. +Implicit Types x y : F. +Implicit Types m n : int. +Local Coercion Posz : nat >-> int. + +Lemma expfzDr x m n : x != 0 -> x ^ (m + n) = x ^ m * x ^ n. +Proof. by move=> hx; rewrite exprzDr ?unitfE. Qed. + +Lemma expfz_n0addr x m n : m + n != 0 -> x ^ (m + n) = x ^ m * x ^ n. +Proof. +have [-> hmn|nx0 _] := eqVneq x 0; last exact: expfzDr. +rewrite !exp0rz (negPf hmn). +case: (altP (m =P 0)) hmn=> [->|]; rewrite (mul0r, mul1r) //. +by rewrite add0r=> /negPf->. +Qed. + +Lemma expfzMl x y n : (x * y) ^ n = x ^ n * y ^ n. +Proof. +have [->|/negPf n0] := eqVneq n 0; first by rewrite !expr0z mulr1. +case: (boolP ((x * y) == 0)); rewrite ?mulf_eq0. + by case/orP=> /eqP->; rewrite ?(mul0r, mulr0, exp0rz, n0). +by case/norP=> x0 y0; rewrite exprzMl ?unitfE. +Qed. + +Lemma fmorphXz (R : unitRingType) (f : {rmorphism F -> R}) n : + {morph f : x / x ^ n}. +Proof. by case: n => n x; rewrite ?fmorphV rmorphX. Qed. + +End ExprzField. + +Section ExprzOrder. + +Variable R : realFieldType. +Implicit Types x y : R. +Implicit Types m n : int. +Local Coercion Posz : nat >-> int. + +(* ler and exprz *) +Lemma exprz_ge0 n x (hx : 0 <= x) : (0 <= x ^ n). +Proof. by case: n=> n; rewrite ?NegzE -?invr_expz ?invr_ge0 ?exprn_ge0. Qed. + +Lemma exprz_gt0 n x (hx : 0 < x) : (0 < x ^ n). +Proof. by case: n=> n; rewrite ?NegzE -?invr_expz ?invr_gt0 ?exprn_gt0. Qed. + +Definition exprz_gte0 := (exprz_ge0, exprz_gt0). + +Lemma ler_wpiexpz2l x (x0 : 0 <= x) (x1 : x <= 1) : + {in >= 0 &, {homo (exprz x) : x y /~ x <= y}}. +Proof. +move=> [] m [] n; rewrite -!topredE /= ?oppr_cp0 ?ltz_nat // => _ _. +by rewrite lez_nat -?exprnP=> /ler_wiexpn2l; apply. +Qed. + +Lemma ler_wniexpz2l x (x0 : 0 <= x) (x1 : x <= 1) : + {in < 0 &, {homo (exprz x) : x y /~ x <= y}}. +Proof. +move=> [] m [] n; rewrite ?NegzE -!topredE /= ?oppr_cp0 ?ltz_nat // => _ _. +rewrite ler_opp2 lez_nat -?invr_expz=> hmn; move: (x0). +rewrite le0r=> /orP [/eqP->|lx0]; first by rewrite !exp0rz invr0. +by rewrite lef_pinv -?topredE /= ?exprz_gt0 // ler_wiexpn2l. +Qed. + +Fact ler_wpeexpz2l x (x1 : 1 <= x) : + {in >= 0 &, {homo (exprz x) : x y / x <= y}}. +Proof. +move=> [] m [] n; rewrite -!topredE /= ?oppr_cp0 ?ltz_nat // => _ _. +by rewrite lez_nat -?exprnP=> /ler_weexpn2l; apply. +Qed. + +Fact ler_wneexpz2l x (x1 : 1 <= x) : + {in <= 0 &, {homo (exprz x) : x y / x <= y}}. +Proof. +move=> m n hm hn /= hmn. +rewrite -lef_pinv -?topredE /= ?exprz_gt0 ?(ltr_le_trans ltr01) //. +by rewrite !invr_expz ler_wpeexpz2l ?ler_opp2 -?topredE //= oppr_cp0. +Qed. + +Lemma ler_weexpz2l x (x1 : 1 <= x) : {homo (exprz x) : x y / x <= y}. +Proof. +move=> m n /= hmn; case: (lerP 0 m)=> [|/ltrW] hm. + by rewrite ler_wpeexpz2l // [_ \in _](ler_trans hm). +case: (lerP n 0)=> [|/ltrW] hn. + by rewrite ler_wneexpz2l // [_ \in _](ler_trans hmn). +apply: (@ler_trans _ (x ^ 0)); first by rewrite ler_wneexpz2l. +by rewrite ler_wpeexpz2l. +Qed. + +Lemma pexprz_eq1 x n (x0 : 0 <= x) : (x ^ n == 1) = ((n == 0) || (x == 1)). +Proof. +case: n=> n; rewrite ?NegzE -?exprz_inv ?oppr_eq0 pexprn_eq1 // ?invr_eq1 //. +by rewrite invr_ge0. +Qed. + +Lemma ieexprIz x (x0 : 0 < x) (nx1 : x != 1) : injective (exprz x). +Proof. +apply: wlog_ltr=> // m n hmn; first by move=> hmn'; rewrite hmn. +move=> /(f_equal ( *%R^~ (x ^ (- n)))). +rewrite -!expfzDr ?gtr_eqF // subrr expr0z=> /eqP. +by rewrite pexprz_eq1 ?(ltrW x0) // (negPf nx1) subr_eq0 orbF=> /eqP. +Qed. + +Lemma ler_piexpz2l x (x0 : 0 < x) (x1 : x < 1) : + {in >= 0 &, {mono (exprz x) : x y /~ x <= y}}. +Proof. +apply: (nhomo_mono_in (nhomo_inj_in_lt _ _)). + by move=> n m hn hm /=; apply: ieexprIz; rewrite // ltr_eqF. +by apply: ler_wpiexpz2l; rewrite ?ltrW. +Qed. + +Lemma ltr_piexpz2l x (x0 : 0 < x) (x1 : x < 1) : + {in >= 0 &, {mono (exprz x) : x y /~ x < y}}. +Proof. exact: (lerW_nmono_in (ler_piexpz2l _ _)). Qed. + +Lemma ler_niexpz2l x (x0 : 0 < x) (x1 : x < 1) : + {in < 0 &, {mono (exprz x) : x y /~ x <= y}}. +Proof. +apply: (nhomo_mono_in (nhomo_inj_in_lt _ _)). + by move=> n m hn hm /=; apply: ieexprIz; rewrite // ltr_eqF. +by apply: ler_wniexpz2l; rewrite ?ltrW. +Qed. + +Lemma ltr_niexpz2l x (x0 : 0 < x) (x1 : x < 1) : + {in < 0 &, {mono (exprz x) : x y /~ x < y}}. +Proof. exact: (lerW_nmono_in (ler_niexpz2l _ _)). Qed. + +Lemma ler_eexpz2l x (x1 : 1 < x) : {mono (exprz x) : x y / x <= y}. +Proof. +apply: (homo_mono (homo_inj_lt _ _)). + by apply: ieexprIz; rewrite ?(ltr_trans ltr01) // gtr_eqF. +by apply: ler_weexpz2l; rewrite ?ltrW. +Qed. + +Lemma ltr_eexpz2l x (x1 : 1 < x) : {mono (exprz x) : x y / x < y}. +Proof. exact: (lerW_mono (ler_eexpz2l _)). Qed. + +Lemma ler_wpexpz2r n (hn : 0 <= n) : +{in >= 0 & , {homo ((@exprz R)^~ n) : x y / x <= y}}. +Proof. by case: n hn=> // n _; apply: ler_expn2r. Qed. + +Lemma ler_wnexpz2r n (hn : n <= 0) : +{in > 0 & , {homo ((@exprz R)^~ n) : x y /~ x <= y}}. +Proof. +move=> x y /= hx hy hxy; rewrite -lef_pinv ?[_ \in _]exprz_gt0 //. +by rewrite !invr_expz ler_wpexpz2r ?[_ \in _]ltrW // oppr_cp0. +Qed. + +Lemma pexpIrz n (n0 : n != 0) : {in >= 0 &, injective ((@exprz R)^~ n)}. +Proof. +move=> x y; rewrite ![_ \in _]le0r=> /orP [/eqP-> _ /eqP|hx]. + by rewrite exp0rz ?(negPf n0) eq_sym expfz_eq0=> /andP [_ /eqP->]. +case/orP=> [/eqP-> /eqP|hy]. + by rewrite exp0rz ?(negPf n0) expfz_eq0=> /andP [_ /eqP]. +move=> /(f_equal ( *%R^~ (y ^ (- n)))) /eqP. +rewrite -expfzDr ?(gtr_eqF hy) // subrr expr0z -exprz_inv -expfzMl. +rewrite pexprz_eq1 ?(negPf n0) /= ?mulr_ge0 ?invr_ge0 ?ltrW //. +by rewrite (can2_eq (mulrVK _) (mulrK _)) ?unitfE ?(gtr_eqF hy) // mul1r=> /eqP. +Qed. + +Lemma nexpIrz n (n0 : n != 0) : {in <= 0 &, injective ((@exprz R)^~ n)}. +Proof. +move=> x y; rewrite ![_ \in _]ler_eqVlt => /orP [/eqP -> _ /eqP|hx]. + by rewrite exp0rz ?(negPf n0) eq_sym expfz_eq0=> /andP [_ /eqP->]. +case/orP=> [/eqP -> /eqP|hy]. + by rewrite exp0rz ?(negPf n0) expfz_eq0=> /andP [_ /eqP]. +move=> /(f_equal ( *%R^~ (y ^ (- n)))) /eqP. +rewrite -expfzDr ?(ltr_eqF hy) // subrr expr0z -exprz_inv -expfzMl. +rewrite pexprz_eq1 ?(negPf n0) /= ?mulr_le0 ?invr_le0 ?ltrW //. +by rewrite (can2_eq (mulrVK _) (mulrK _)) ?unitfE ?(ltr_eqF hy) // mul1r=> /eqP. +Qed. + +Lemma ler_pexpz2r n (hn : 0 < n) : + {in >= 0 & , {mono ((@exprz R)^~ n) : x y / x <= y}}. +Proof. +apply: homo_mono_in (homo_inj_in_lt _ _). + by move=> x y hx hy /=; apply: pexpIrz; rewrite // gtr_eqF. +by apply: ler_wpexpz2r; rewrite ltrW. +Qed. + +Lemma ltr_pexpz2r n (hn : 0 < n) : + {in >= 0 & , {mono ((@exprz R)^~ n) : x y / x < y}}. +Proof. exact: lerW_mono_in (ler_pexpz2r _). Qed. + +Lemma ler_nexpz2r n (hn : n < 0) : + {in > 0 & , {mono ((@exprz R)^~ n) : x y /~ x <= y}}. +Proof. +apply: nhomo_mono_in (nhomo_inj_in_lt _ _); last first. + by apply: ler_wnexpz2r; rewrite ltrW. +by move=> x y hx hy /=; apply: pexpIrz; rewrite ?[_ \in _]ltrW ?ltr_eqF. +Qed. + +Lemma ltr_nexpz2r n (hn : n < 0) : + {in > 0 & , {mono ((@exprz R)^~ n) : x y /~ x < y}}. +Proof. exact: lerW_nmono_in (ler_nexpz2r _). Qed. + +Lemma eqr_expz2 n x y : n != 0 -> 0 <= x -> 0 <= y -> + (x ^ n == y ^ n) = (x == y). +Proof. by move=> *; rewrite (inj_in_eq (pexpIrz _)). Qed. + +End ExprzOrder. + +Local Notation sgr := Num.sg. + +Section Sgz. + +Variable R : numDomainType. +Implicit Types x y z : R. +Implicit Types m n p : int. +Local Coercion Posz : nat >-> int. + +Definition sgz x : int := if x == 0 then 0 else if x < 0 then -1 else 1. + +Lemma sgz_def x : sgz x = (-1) ^+ (x < 0)%R *+ (x != 0). +Proof. by rewrite /sgz; case: (_ == _); case: (_ < _). Qed. + +Lemma sgrEz x : sgr x = (sgz x)%:~R. Proof. by rewrite !(fun_if intr). Qed. + +Lemma gtr0_sgz x : 0 < x -> sgz x = 1. +Proof. by move=> x_gt0; rewrite /sgz ltr_neqAle andbC eqr_le ltr_geF //. Qed. + +Lemma ltr0_sgz x : x < 0 -> sgz x = -1. +Proof. by move=> x_lt0; rewrite /sgz eq_sym eqr_le x_lt0 ltr_geF. Qed. + +Lemma sgz0 : sgz (0 : R) = 0. Proof. by rewrite /sgz eqxx. Qed. +Lemma sgz1 : sgz (1 : R) = 1. Proof. by rewrite gtr0_sgz // ltr01. Qed. +Lemma sgzN1 : sgz (-1 : R) = -1. Proof. by rewrite ltr0_sgz // ltrN10. Qed. + +Definition sgzE := (sgz0, sgz1, sgzN1). + +Lemma sgz_sgr x : sgz (sgr x) = sgz x. +Proof. by rewrite !(fun_if sgz) !sgzE. Qed. + +Lemma normr_sgz x : `|sgz x| = (x != 0). +Proof. by rewrite sgz_def -mulr_natr normrMsign normr_nat natz. Qed. + +Lemma normr_sg x : `|sgr x| = (x != 0)%:~R. +Proof. by rewrite sgr_def -mulr_natr normrMsign normr_nat. Qed. + +End Sgz. + +Section MoreSgz. + +Variable R : numDomainType. + +Lemma sgz_int m : sgz (m%:~R : R) = sgz m. +Proof. by rewrite /sgz intr_eq0 ltrz0. Qed. + +Lemma sgrz (n : int) : sgr n = sgz n. Proof. by rewrite sgrEz intz. Qed. + +Lemma intr_sg m : (sgr m)%:~R = sgr (m%:~R) :> R. +Proof. by rewrite sgrz -sgz_int -sgrEz. Qed. + +Lemma sgz_id (x : R) : sgz (sgz x) = sgz x. +Proof. by rewrite !(fun_if (@sgz _)). Qed. + +End MoreSgz. + +Section SgzReal. + +Variable R : realDomainType. +Implicit Types x y z : R. +Implicit Types m n p : int. +Local Coercion Posz : nat >-> int. + +Lemma sgz_cp0 x : + ((sgz x == 1) = (0 < x)) * + ((sgz x == -1) = (x < 0)) * + ((sgz x == 0) = (x == 0)). +Proof. by rewrite /sgz; case: ltrgtP. Qed. + +CoInductive sgz_val x : bool -> bool -> bool -> bool -> bool -> bool + -> bool -> bool -> bool -> bool -> bool -> bool + -> bool -> bool -> bool -> bool -> bool -> bool + -> R -> R -> int -> Set := + | SgzNull of x = 0 : sgz_val x true true true true false false + true false false true false false true false false true false false 0 0 0 + | SgzPos of x > 0 : sgz_val x false false true false false true + false false true false false true false false true false false true x 1 1 + | SgzNeg of x < 0 : sgz_val x false true false false true false + false true false false true false false true false false true false (-x) (-1) (-1). + +Lemma sgzP x : + sgz_val x (0 == x) (x <= 0) (0 <= x) (x == 0) (x < 0) (0 < x) + (0 == sgr x) (-1 == sgr x) (1 == sgr x) + (sgr x == 0) (sgr x == -1) (sgr x == 1) + (0 == sgz x) (-1 == sgz x) (1 == sgz x) + (sgz x == 0) (sgz x == -1) (sgz x == 1) `|x| (sgr x) (sgz x). +Proof. +rewrite ![_ == sgz _]eq_sym ![_ == sgr _]eq_sym !sgr_cp0 !sgz_cp0. +by rewrite /sgr /sgz !lerNgt; case: ltrgt0P; constructor. +Qed. + +Lemma sgzN x : sgz (- x) = - sgz x. +Proof. by rewrite /sgz oppr_eq0 oppr_lt0; case: ltrgtP. Qed. + +Lemma mulz_sg x : sgz x * sgz x = (x != 0)%:~R. +Proof. by case: sgzP; rewrite ?(mulr0, mulr1, mulrNN). Qed. + +Lemma mulz_sg_eq1 x y : (sgz x * sgz y == 1) = (x != 0) && (sgz x == sgz y). +Proof. +do 2?case: sgzP=> _; rewrite ?(mulr0, mulr1, mulrN1, opprK, oppr0, eqxx); + by rewrite ?[0 == 1]eq_sym ?oner_eq0 //= eqr_oppLR oppr0 oner_eq0. +Qed. + +Lemma mulz_sg_eqN1 x y : (sgz x * sgz y == -1) = (x != 0) && (sgz x == - sgz y). +Proof. by rewrite -eqr_oppLR -mulrN -sgzN mulz_sg_eq1. Qed. + +(* Lemma muls_eqA x y z : sgr x != 0 -> *) +(* (sgr y * sgr z == sgr x) = ((sgr y * sgr x == sgr z) && (sgr z != 0)). *) +(* Proof. by do 3!case: sgrP=> _. Qed. *) + +Lemma sgzM x y : sgz (x * y) = sgz x * sgz y. +Proof. +case: (sgzP x)=> hx; first by rewrite hx ?mul0r sgz0. + case: (sgzP y)=> hy; first by rewrite hy !mulr0 sgz0. + by apply/eqP; rewrite mul1r sgz_cp0 pmulr_rgt0. + by apply/eqP; rewrite mul1r sgz_cp0 nmulr_llt0. +case: (sgzP y)=> hy; first by rewrite hy !mulr0 sgz0. + by apply/eqP; rewrite mulr1 sgz_cp0 nmulr_rlt0. +by apply/eqP; rewrite mulN1r opprK sgz_cp0 nmulr_rgt0. +Qed. + +Lemma sgzX (n : nat) x : sgz (x ^+ n) = (sgz x) ^+ n. +Proof. by elim: n => [|n IHn]; rewrite ?sgz1 // !exprS sgzM IHn. Qed. + +Lemma sgz_eq0 x : (sgz x == 0) = (x == 0). +Proof. by rewrite sgz_cp0. Qed. + +Lemma sgz_odd (n : nat) x : x != 0 -> (sgz x) ^+ n = (sgz x) ^+ (odd n). +Proof. by case: sgzP => //=; rewrite ?expr1n // signr_odd. Qed. + +Lemma sgz_gt0 x : (sgz x > 0) = (x > 0). +Proof. by case: sgzP. Qed. + +Lemma sgz_lt0 x : (sgz x < 0) = (x < 0). +Proof. by case: sgzP. Qed. + +Lemma sgz_ge0 x : (sgz x >= 0) = (x >= 0). +Proof. by case: sgzP. Qed. + +Lemma sgz_le0 x : (sgz x <= 0) = (x <= 0). +Proof. by case: sgzP. Qed. + +Lemma sgz_smul x y : sgz (y *~ (sgz x)) = (sgz x) * (sgz y). +Proof. by rewrite -mulrzl sgzM -sgrEz sgz_sgr. Qed. + +Lemma sgrMz m x : sgr (x *~ m) = sgr x *~ sgr m. +Proof. by rewrite -mulrzr sgrM -intr_sg mulrzr. Qed. + +End SgzReal. + +Lemma sgz_eq (R R' : realDomainType) (x : R) (y : R') : + (sgz x == sgz y) = ((x == 0) == (y == 0)) && ((0 < x) == (0 < y)). +Proof. by do 2!case: sgzP. Qed. + +Lemma intr_sign (R : ringType) s : ((-1) ^+ s)%:~R = (-1) ^+ s :> R. +Proof. exact: rmorph_sign. Qed. + +Section Absz. + +Implicit Types m n p : int. +Open Scope nat_scope. +Local Coercion Posz : nat >-> int. + +Lemma absz_nat (n : nat) : `|n| = n. Proof. by []. Qed. + +Lemma abszE (m : int) : `|m| = `|m|%R :> int. Proof. by []. Qed. + +Lemma absz0 : `|0%R| = 0. Proof. by []. Qed. + +Lemma abszN m : `|- m| = `|m|. Proof. by case: (normrN m). Qed. + +Lemma absz_eq0 m : (`|m| == 0) = (m == 0%R). Proof. by case: (intP m). Qed. + +Lemma absz_gt0 m : (`|m| > 0) = (m != 0%R). Proof. by case: (intP m). Qed. + +Lemma absz1 : `|1%R| = 1. Proof. by []. Qed. + +Lemma abszN1 : `|-1%R| = 1. Proof. by []. Qed. + +Lemma absz_id m : `|(`|m|)| = `|m|. Proof. by []. Qed. + +Lemma abszM m1 m2 : `|(m1 * m2)%R| = `|m1| * `|m2|. +Proof. by case: m1 m2 => [[|m1]|m1] [[|m2]|m2]; rewrite //= mulnS mulnC. Qed. + +Lemma abszX (n : nat) m : `|m ^+ n| = `|m| ^ n. +Proof. by elim: n => // n ihn; rewrite exprS expnS abszM ihn. Qed. + +Lemma absz_sg m : `|sgr m| = (m != 0%R). Proof. by case: (intP m). Qed. + +Lemma gez0_abs m : (0 <= m)%R -> `|m| = m :> int. +Proof. by case: (intP m). Qed. + +Lemma gtz0_abs m : (0 < m)%R -> `|m| = m :> int. +Proof. by case: (intP m). Qed. + +Lemma lez0_abs m : (m <= 0)%R -> `|m| = - m :> int. +Proof. by case: (intP m). Qed. + +Lemma ltz0_abs m : (m < 0)%R -> `|m| = - m :> int. +Proof. by case: (intP m). Qed. + +Lemma absz_sign s : `|(-1) ^+ s| = 1. +Proof. by rewrite abszX exp1n. Qed. + +Lemma abszMsign s m : `|((-1) ^+ s * m)%R| = `|m|. +Proof. by rewrite abszM absz_sign mul1n. Qed. + +Lemma mulz_sign_abs m : ((-1) ^+ (m < 0)%R * `|m|%:Z)%R = m. +Proof. by rewrite abszE mulr_sign_norm. Qed. + +Lemma mulz_Nsign_abs m : ((-1) ^+ (0 < m)%R * `|m|%:Z)%R = - m. +Proof. by rewrite abszE mulr_Nsign_norm. Qed. + +Lemma intEsign m : m = ((-1) ^+ (m < 0)%R * `|m|%:Z)%R. +Proof. exact: numEsign. Qed. + +Lemma abszEsign m : `|m|%:Z = ((-1) ^+ (m < 0)%R * m)%R. +Proof. exact: normrEsign. Qed. + +Lemma intEsg m : m = (sgz m * `|m|%:Z)%R. +Proof. by rewrite -sgrz -numEsg. Qed. + +Lemma abszEsg m : (`|m|%:Z = sgz m * m)%R. +Proof. by rewrite -sgrz -normrEsg. Qed. + +End Absz. + +Module Export IntDist. + +Notation "m - n" := + (@GRing.add int_ZmodType m%N (@GRing.opp int_ZmodType n%N)) : distn_scope. +Arguments Scope absz [distn_scope]. +Notation "`| m |" := (absz m) : nat_scope. +Coercion Posz : nat >-> int. + +Section Distn. + +Open Scope nat_scope. +Implicit Type m : int. +Implicit Types n d : nat. + +Lemma distnC m1 m2 : `|m1 - m2| = `|m2 - m1|. +Proof. by rewrite -opprB abszN. Qed. + +Lemma distnDl d n1 n2 : `|d + n1 - (d + n2)| = `|n1 - n2|. +Proof. by rewrite !PoszD opprD addrCA -addrA addKr. Qed. + +Lemma distnDr d n1 n2 : `|n1 + d - (n2 + d)| = `|n1 - n2|. +Proof. by rewrite -!(addnC d) distnDl. Qed. + +Lemma distnEr n1 n2 : n1 <= n2 -> `|n1 - n2| = n2 - n1. +Proof. by move/subnK=> {1}<-; rewrite distnC PoszD addrK absz_nat. Qed. + +Lemma distnEl n1 n2 : n2 <= n1 -> `|n1 - n2| = n1 - n2. +Proof. by move/distnEr <-; rewrite distnC. Qed. + +Lemma distn0 n : `|n - 0| = n. +Proof. by rewrite subr0 absz_nat. Qed. + +Lemma dist0n n : `|0 - n| = n. +Proof. by rewrite distnC distn0. Qed. + +Lemma distnn m : `|m - m| = 0. +Proof. by rewrite subrr. Qed. + +Lemma distn_eq0 n1 n2 : (`|n1 - n2| == 0) = (n1 == n2). +Proof. by rewrite absz_eq0 subr_eq0. Qed. + +Lemma distnS n : `|n - n.+1| = 1. +Proof. exact: distnDr n 0 1. Qed. + +Lemma distSn n : `|n.+1 - n| = 1. +Proof. exact: distnDr n 1 0. Qed. + +Lemma distn_eq1 n1 n2 : + (`|n1 - n2| == 1) = (if n1 < n2 then n1.+1 == n2 else n1 == n2.+1). +Proof. +case: ltnP => [lt_n12 | le_n21]. + by rewrite eq_sym -(eqn_add2r n1) distnEr ?subnK // ltnW. +by rewrite -(eqn_add2r n2) distnEl ?subnK. +Qed. + +Lemma leq_add_dist m1 m2 m3 : `|m1 - m3| <= `|m1 - m2| + `|m2 - m3|. +Proof. by rewrite -lez_nat PoszD !abszE ler_dist_add. Qed. + +(* Most of this proof generalizes to all real-ordered rings. *) +Lemma leqif_add_distz m1 m2 m3 : + `|m1 - m3| <= `|m1 - m2| + `|m2 - m3| + ?= iff (m1 <= m2 <= m3)%R || (m3 <= m2 <= m1)%R. +Proof. +apply/leqifP; rewrite -ltz_nat -eqz_nat PoszD !abszE; apply/lerifP. +wlog le_m31 : m1 m3 / (m3 <= m1)%R. + move=> IH; case/orP: (ler_total m1 m3) => /IH //. + by rewrite (addrC `|_|)%R orbC !(distrC m1) !(distrC m3). +rewrite ger0_norm ?subr_ge0 // orb_idl => [|/andP[le_m12 le_m23]]; last first. + by have /eqP->: m2 == m3; rewrite ?lerr // eqr_le le_m23 (ler_trans le_m31). +rewrite -{1}(subrK m2 m1) -addrA -subr_ge0 andbC -subr_ge0. +by apply: lerif_add; apply/real_lerif_norm/num_real. +Qed. + +Lemma leqif_add_dist n1 n2 n3 : + `|n1 - n3| <= `|n1 - n2| + `|n2 - n3| + ?= iff (n1 <= n2 <= n3) || (n3 <= n2 <= n1). +Proof. exact: leqif_add_distz. Qed. + +Lemma sqrn_dist n1 n2 : `|n1 - n2| ^ 2 + 2 * (n1 * n2) = n1 ^ 2 + n2 ^ 2. +Proof. +wlog le_n21: n1 n2 / n2 <= n1. + move=> IH; case/orP: (leq_total n2 n1) => /IH //. + by rewrite (addnC (n2 ^ 2)) (mulnC n2) distnC. +by rewrite distnEl ?sqrn_sub ?subnK ?nat_Cauchy. +Qed. + +End Distn. + +End IntDist. + +Section NormInt. + +Variable R : numDomainType. + +Lemma intr_norm m : `|m|%:~R = `|m%:~R| :> R. +Proof. by rewrite {2}[m]intEsign rmorphMsign normrMsign abszE normr_nat. Qed. + +Lemma normrMz m (x : R) : `|x *~ m| = `|x| *~ `|m|. +Proof. by rewrite -mulrzl normrM -intr_norm mulrzl. Qed. + +Lemma expN1r (i : int) : (-1 : R) ^ i = (-1) ^+ `|i|. +Proof. +case: i => n; first by rewrite exprnP absz_nat. +by rewrite NegzE abszN absz_nat -invr_expz expfV invrN1. +Qed. + +End NormInt. + +Section PolyZintRing. + +Variable R : ringType. +Implicit Types x y z: R. +Implicit Types m n : int. +Implicit Types i j k : nat. +Implicit Types p q r : {poly R}. + +Lemma coefMrz : forall p n i, (p *~ n)`_i = (p`_i *~ n). +Proof. by move=> p [] n i; rewrite ?NegzE (coefMNn, coefMn). Qed. + +Lemma polyC_mulrz : forall n, {morph (@polyC R) : c / c *~ n}. +Proof. +move=> [] n c; rewrite ?NegzE -?pmulrn ?polyC_muln //. +by rewrite polyC_opp mulrNz polyC_muln nmulrn. +Qed. + +Lemma hornerMz : forall n (p : {poly R}) x, (p *~ n).[x] = p.[x] *~ n. +Proof. by case=> *; rewrite ?NegzE ?mulNzr ?(hornerN, hornerMn). Qed. + +Lemma horner_int : forall n x, (n%:~R : {poly R}).[x] = n%:~R. +Proof. by move=> n x; rewrite hornerMz hornerC. Qed. + +Lemma derivMz : forall n p, (p *~ n)^`() = p^`() *~ n. +Proof. by move=> [] n p; rewrite ?NegzE -?pmulrn (derivMn, derivMNn). Qed. + +End PolyZintRing. + +Section PolyZintOIdom. + +Variable R : realDomainType. + +Lemma mulpz (p : {poly R}) (n : int) : p *~ n = n%:~R *: p. +Proof. by rewrite -[p *~ n]mulrzl -mul_polyC polyC_mulrz polyC1. Qed. + +End PolyZintOIdom. + +Section ZnatPred. + +Definition Znat := [qualify a n : int | 0 <= n]. +Fact Znat_key : pred_key Znat. by []. Qed. +Canonical Znat_keyd := KeyedQualifier Znat_key. + +Lemma Znat_def n : (n \is a Znat) = (0 <= n). Proof. by []. Qed. + +Lemma Znat_semiring_closed : semiring_closed Znat. +Proof. by do 2?split => //; [exact: addr_ge0 | exact: mulr_ge0]. Qed. +Canonical Znat_addrPred := AddrPred Znat_semiring_closed. +Canonical Znat_mulrPred := MulrPred Znat_semiring_closed. +Canonical Znat_semiringPred := SemiringPred Znat_semiring_closed. + +Lemma ZnatP (m : int) : reflect (exists n : nat, m = n) (m \is a Znat). +Proof. by apply: (iffP idP) => [|[n -> //]]; case: m => // n; exists n. Qed. + +End ZnatPred. + +Section rpred. + +Lemma rpredMz M S (addS : @zmodPred M S) (kS : keyed_pred addS) m : + {in kS, forall u, u *~ m \in kS}. +Proof. by case: m => n u Su; rewrite ?rpredN ?rpredMn. Qed. + +Lemma rpred_int R S (ringS : @subringPred R S) (kS : keyed_pred ringS) m : + m%:~R \in kS. +Proof. by rewrite rpredMz ?rpred1. Qed. + +Lemma rpredZint (R : ringType) (M : lmodType R) S + (addS : @zmodPred M S) (kS : keyed_pred addS) m : + {in kS, forall u, m%:~R *: u \in kS}. +Proof. by move=> u Su; rewrite /= scaler_int rpredMz. Qed. + +Lemma rpredXz R S (divS : @divrPred R S) (kS : keyed_pred divS) m : + {in kS, forall x, x ^ m \in kS}. +Proof. by case: m => n x Sx; rewrite ?rpredV rpredX. Qed. + +Lemma rpredXsign R S (divS : @divrPred R S) (kS : keyed_pred divS) n x : + (x ^ ((-1) ^+ n) \in kS) = (x \in kS). +Proof. by rewrite -signr_odd; case: (odd n); rewrite ?rpredV. Qed. + +End rpred. \ No newline at end of file diff --git a/mathcomp/algebra/ssrnum.v b/mathcomp/algebra/ssrnum.v new file mode 100644 index 0000000..ab7afd0 --- /dev/null +++ b/mathcomp/algebra/ssrnum.v @@ -0,0 +1,4219 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +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, subtraction 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) (n := #|A|) : + {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 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) E i; 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 1, has_cmp_mu 0)%N. +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 -ltr_subl_addl -mulrBl. +by rewrite mulrC ltr_pmul2r ?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 _)). diff --git a/mathcomp/algebra/vector.v b/mathcomp/algebra/vector.v new file mode 100644 index 0000000..2cb59e9 --- /dev/null +++ b/mathcomp/algebra/vector.v @@ -0,0 +1,2040 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype bigop. +Require Import finfun tuple ssralg matrix mxalgebra zmodp. + +(******************************************************************************) +(* * Finite dimensional vector spaces *) +(* vectType R == interface structure for finite dimensional (more *) +(* precisely, detachable) vector spaces over R, which *) +(* should be at least a ringType. *) +(* Vector.axiom n M <-> type M is linearly isomorphic to 'rV_n. *) +(* := {v2r : M -> 'rV_n| linear v2r & bijective v2r}. *) +(* VectMixin isoM == packages a proof isoV of Vector.axiom n M as the *) +(* vectType mixin for an n-dimensional R-space *) +(* structure on a type M that is an lmodType R. *) +(* VectType K M mT == packs the vectType mixin mT to into a vectType K *) +(* instance for T; T should have an lmodType K *) +(* canonical instance. *) +(* [vectType R of T for vS] == a copy of the vS : vectType R structure where *) +(* the sort is replaced by T; vS : lmodType R should *) +(* be convertible to a canonical lmodType for T. *) +(* [vectType R of V] == a clone of an existing vectType R structure on V. *) +(* {vspace vT} == the type of (detachable) subspaces of vT; vT *) +(* should have a vectType structure over a fieldType. *) +(* subvs_of U == the subtype of elements of V in the subspace U. *) +(* This is canonically a vectType. *) +(* vsval u == linear injection of u : subvs_of U into V. *) +(* vsproj U v == linear projection of v : V in subvs U. *) +(* 'Hom(aT, rT) == the type of linear functions (homomorphisms) from *) +(* aT to rT, where aT and rT ARE vectType structures. *) +(* Elements of 'Hom(aT, rT) coerce to Coq functions. *) +(* --> Caveat: aT and rT must denote actual vectType structures, not their *) +(* projections on Type. *) +(* linfun f == a vector linear function in 'Hom(aT, rT) that *) +(* coincides with f : aT -> rT when f is linear. *) +(* 'End(vT) == endomorphisms of vT (:= 'Hom(vT, vT)). *) +(* --> The types subvs_of U, 'Hom(aT, rT), 'End(vT), K^o, 'M[K]_(m, n), *) +(* vT * wT, {ffun I -> vT}, vT ^ n all have canonical vectType instances. *) +(* *) +(* Functions: *) +(* <[v]>%VS == the vector space generated by v (a line if v != 0).*) +(* 0%VS == the trivial vector subspace. *) +(* fullv, {:vT} == the complete vector subspace (displays as fullv). *) +(* (U + V)%VS == the join (sum) of two subspaces U and V. *) +(* (U :&: V)%VS == intersection of vector subspaces U and V. *) +(* (U^C)%VS == a complement of the vector subspace U. *) +(* (U :\: V)%VS == a local complement to U :& V in the subspace U. *) +(* \dim U == dimension of a vector space U. *) +(* span X, <>%VS == the subspace spanned by the vector sequence X. *) +(* coord X i v == i'th coordinate of v on X, when v \in <>%VS and *) +(* where X : n.-tuple vT and i : 'I_n. Note that *) +(* coord X i is a scalar function. *) +(* vpick U == a nonzero element of U if U= 0%VS, or 0 if U = 0. *) +(* vbasis U == a (\dim U).-tuple that is a basis of U. *) +(* \1%VF == the identity linear function. *) +(* (f \o g)%VF == the composite of two linear functions f and g. *) +(* (f^-1)%VF == a linear function that is a right inverse to the *) +(* linear function f on the codomain of f. *) +(* (f @: U)%VS == the image of vs by the linear function f. *) +(* (f @^-1: U)%VS == the pre-image of vs by the linear function f. *) +(* lker f == the kernel of the linear function f. *) +(* limg f == the image of the linear function f. *) +(* fixedSpace f == the fixed space of a linear endomorphism f *) +(* daddv_pi U V == projection onto U along V if U and V are disjoint; *) +(* daddv_pi U V + daddv_pi V U is then a projection *) +(* onto the direct sum (U + V)%VS. *) +(* projv U == projection onto U (along U^C, := daddv_pi U U^C). *) +(* addv_pi1 U V == projection onto the subspace U :\: V of U along V. *) +(* addv_pi2 U V == projection onto V along U :\: V; note that *) +(* addv_pi1 U V and addv_pi2 U V are (asymmetrical) *) +(* complementary projections on (U + V)%VS. *) +(* sumv_pi_for defV i == for defV : V = (V \sum_(j <- r | P j) Vs j)%VS, *) +(* j ranging over an eqType, this is a projection on *) +(* a subspace of Vs i, along a complement in V, such *) +(* that \sum_(j <- r | P j) sumv_pi_for defV j is a *) +(* projection onto V if filter P r is duplicate-free *) +(* (e.g., when V := \sum_(j | P j) Vs j). *) +(* sumv_pi V i == notation the above when defV == erefl V, and V is *) +(* convertible to \sum_(j <- r | P j) Vs j)%VS. *) +(* *) +(* Predicates: *) +(* v \in U == v belongs to U (:= (<[v]> <= U)%VS). *) +(* (U <= V)%VS == U is a subspace of V. *) +(* free B == B is a sequence of nonzero linearly independent *) +(* vectors. *) +(* basis_of U b == b is a basis of the subspace U. *) +(* directv S == S is the expression for a direct sum of subspaces. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. +Open Local Scope ring_scope. + +Reserved Notation "{ 'vspace' T }" (at level 0, format "{ 'vspace' T }"). +Reserved Notation "''Hom' ( T , rT )" (at level 8, format "''Hom' ( T , rT )"). +Reserved Notation "''End' ( T )" (at level 8, format "''End' ( T )"). +Reserved Notation "\dim A" (at level 10, A at level 8, format "\dim A"). + +Delimit Scope vspace_scope with VS. + +Import GRing.Theory. + +(* Finite dimension vector space *) +Module Vector. + +Section ClassDef. +Variable R : ringType. + +Definition axiom_def n (V : lmodType R) of phant V := + {v2r : V -> 'rV[R]_n | linear v2r & bijective v2r}. + +Inductive mixin_of (V : lmodType R) := Mixin dim & axiom_def dim (Phant V). + +Structure class_of V := Class { + base : GRing.Lmodule.class_of R V; + mixin : mixin_of (GRing.Lmodule.Pack _ base V) +}. +Local Coercion base : class_of >-> GRing.Lmodule.class_of. + +Structure type (phR : phant R) := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variables (phR : phant R) (T : Type) (cT : type phR). +Definition class := let: Pack _ c _ := cT return class_of cT in c. +Definition clone c of phant_id class c := @Pack phR T c T. +Let xT := let: Pack T _ _ := cT in T. +Notation xclass := (class : class_of xT). +Definition dim := let: Mixin n _ := mixin class in n. + +Definition pack b0 (m0 : mixin_of (@GRing.Lmodule.Pack R _ T b0 T)) := + fun bT b & phant_id (@GRing.Lmodule.class _ phR bT) b => + fun m & phant_id m0 m => Pack phR (@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 lmodType := @GRing.Lmodule.Pack R phR cT xclass xT. + +End ClassDef. +Notation axiom n V := (axiom_def n (Phant V)). + +Section OtherDefs. +Local Coercion sort : type >-> Sortclass. +Local Coercion dim : type >-> nat. +Inductive space (K : fieldType) (vT : type (Phant K)) (phV : phant vT) := + Space (mx : 'M[K]_vT) & <>%MS == mx. +Inductive hom (R : ringType) (vT wT : type (Phant R)) := + Hom of 'M[R]_(vT, wT). +End OtherDefs. + +Module Import Exports. + +Coercion base : class_of >-> GRing.Lmodule.class_of. +Coercion mixin : class_of >-> mixin_of. +Coercion sort : type >-> Sortclass. +Coercion eqType: type >-> Equality.type. +Bind Scope ring_scope with sort. +Canonical eqType. +Coercion choiceType: type >-> Choice.type. +Canonical choiceType. +Coercion zmodType: type >-> GRing.Zmodule.type. +Canonical zmodType. +Coercion lmodType: type>-> GRing.Lmodule.type. +Canonical lmodType. +Notation vectType R := (@type _ (Phant R)). +Notation VectType R V mV := + (@pack _ (Phant R) V _ mV _ _ id _ id). +Notation VectMixin := Mixin. +Notation "[ 'vectType' R 'of' T 'for' cT ]" := (@clone _ (Phant R) T cT _ idfun) + (at level 0, format "[ 'vectType' R 'of' T 'for' cT ]") : form_scope. +Notation "[ 'vectType' R 'of' T ]" := (@clone _ (Phant R) T _ _ idfun) + (at level 0, format "[ 'vectType' R 'of' T ]") : form_scope. + +Notation "{ 'vspace' vT }" := (space (Phant vT)) : type_scope. +Notation "''Hom' ( aT , rT )" := (hom aT rT) : type_scope. +Notation "''End' ( vT )" := (hom vT vT) : type_scope. + +Prenex Implicits Hom. + +Delimit Scope vspace_scope with VS. +Bind Scope vspace_scope with space. +Delimit Scope lfun_scope with VF. +Bind Scope lfun_scope with hom. + +End Exports. + +(* The contents of this module exposes the matrix encodings, and should *) +(* therefore not be used outside of the vector library implementation. *) +Module InternalTheory. + +Section Iso. +Variables (R : ringType) (vT rT : vectType R). +Local Coercion dim : vectType >-> nat. + +Fact v2r_subproof : axiom vT vT. Proof. by case: vT => T [bT []]. Qed. +Definition v2r := s2val v2r_subproof. + +Let v2r_bij : bijective v2r := s2valP' v2r_subproof. +Fact r2v_subproof : {r2v | cancel r2v v2r}. +Proof. +have r2vP r: {v | v2r v = r}. + by apply: sig_eqW; have [v _ vK] := v2r_bij; exists (v r). +by exists (fun r => sval (r2vP r)) => r; case: (r2vP r). +Qed. +Definition r2v := sval r2v_subproof. + +Lemma r2vK : cancel r2v v2r. Proof. exact: (svalP r2v_subproof). Qed. +Lemma r2v_inj : injective r2v. Proof. exact: can_inj r2vK. Qed. +Lemma v2rK : cancel v2r r2v. Proof. by have/bij_can_sym:= r2vK; apply. Qed. +Lemma v2r_inj : injective v2r. Proof. exact: can_inj v2rK. Qed. + +Canonical v2r_linear := Linear (s2valP v2r_subproof : linear v2r). +Canonical r2v_linear := Linear (can2_linear v2rK r2vK). +End Iso. + +Section Vspace. +Variables (K : fieldType) (vT : vectType K). +Local Coercion dim : vectType >-> nat. + +Definition b2mx n (X : n.-tuple vT) := \matrix_i v2r (tnth X i). +Lemma b2mxK n (X : n.-tuple vT) i : r2v (row i (b2mx X)) = X`_i. +Proof. by rewrite rowK v2rK -tnth_nth. Qed. + +Definition vs2mx {phV} (U : @space K vT phV) := let: Space mx _ := U in mx. +Lemma gen_vs2mx (U : {vspace vT}) : <>%MS = vs2mx U. +Proof. by apply/eqP; rewrite /vs2mx; case: U. Qed. + +Fact mx2vs_subproof m (A : 'M[K]_(m, vT)) : <<(<>)>>%MS == <>%MS. +Proof. by rewrite genmx_id. Qed. +Definition mx2vs {m} A : {vspace vT} := Space _ (@mx2vs_subproof m A). + +Canonical space_subType := [subType for @vs2mx (Phant vT)]. +Lemma vs2mxK : cancel vs2mx mx2vs. +Proof. by move=> v; apply: val_inj; rewrite /= gen_vs2mx. Qed. +Lemma mx2vsK m (M : 'M_(m, vT)) : (vs2mx (mx2vs M) :=: M)%MS. +Proof. exact: genmxE. Qed. +End Vspace. + +Section Hom. +Variables (R : ringType) (aT rT : vectType R). +Definition f2mx (f : 'Hom(aT, rT)) := let: Hom A := f in A. +Canonical hom_subType := [newType for f2mx]. +End Hom. + +Arguments Scope mx2vs [_ _ nat_scope matrix_set_scope]. +Prenex Implicits v2r r2v v2rK r2vK b2mx vs2mx vs2mxK f2mx. + +End InternalTheory. + +End Vector. +Export Vector.Exports. +Import Vector.InternalTheory. + +Section VspaceDefs. + +Variables (K : fieldType) (vT : vectType K). +Implicit Types (u : vT) (X : seq vT) (U V : {vspace vT}). + +Definition space_eqMixin := Eval hnf in [eqMixin of {vspace vT} by <:]. +Canonical space_eqType := EqType {vspace vT} space_eqMixin. +Definition space_choiceMixin := Eval hnf in [choiceMixin of {vspace vT} by <:]. +Canonical space_choiceType := ChoiceType {vspace vT} space_choiceMixin. + +Definition dimv U := \rank (vs2mx U). +Definition subsetv U V := (vs2mx U <= vs2mx V)%MS. +Definition vline u := mx2vs (v2r u). + +(* Vspace membership is defined as line inclusion. *) +Definition pred_of_vspace phV (U : Vector.space phV) : pred_class := + fun v => (vs2mx (vline v) <= vs2mx U)%MS. +Canonical vspace_predType := + @mkPredType _ (unkeyed {vspace vT}) (@pred_of_vspace _). + +Definition fullv : {vspace vT} := mx2vs 1%:M. +Definition addv U V := mx2vs (vs2mx U + vs2mx V). +Definition capv U V := mx2vs (vs2mx U :&: vs2mx V). +Definition complv U := mx2vs (vs2mx U)^C. +Definition diffv U V := mx2vs (vs2mx U :\: vs2mx V). +Definition vpick U := r2v (nz_row (vs2mx U)). +Fact span_key : unit. Proof. by []. Qed. +Definition span_expanded_def X := mx2vs (b2mx (in_tuple X)). +Definition span := locked_with span_key span_expanded_def. +Canonical span_unlockable := [unlockable fun span]. +Definition vbasis_def U := + [tuple r2v (row i (row_base (vs2mx U))) | i < dimv U]. +Definition vbasis := locked_with span_key vbasis_def. +Canonical vbasis_unlockable := [unlockable fun vbasis]. + +(* coord and directv are defined in the VectorTheory section. *) + +Definition free X := dimv (span X) == size X. +Definition basis_of U X := (span X == U) && free X. + +End VspaceDefs. + +Coercion pred_of_vspace : Vector.space >-> pred_class. +Notation "\dim U" := (dimv U) : nat_scope. +Notation "U <= V" := (subsetv U V) : vspace_scope. +Notation "U <= V <= W" := (subsetv U V && subsetv V W) : vspace_scope. +Notation "<[ v ] >" := (vline v) : vspace_scope. +Notation "<< X >>" := (span X) : vspace_scope. +Notation "0" := (vline 0) : vspace_scope. +Implicit Arguments fullv [[K] [vT]]. +Prenex Implicits subsetv addv capv complv diffv span free basis_of. + +Notation "U + V" := (addv U V) : vspace_scope. +Notation "U :&: V" := (capv U V) : vspace_scope. +Notation "U ^C" := (complv U) (at level 8, format "U ^C") : vspace_scope. +Notation "U :\: V" := (diffv U V) : vspace_scope. +Notation "{ : vT }" := (@fullv _ vT) (only parsing) : vspace_scope. + +Notation "\sum_ ( i <- r | P ) U" := + (\big[addv/0%VS]_(i <- r | P%B) U%VS) : vspace_scope. +Notation "\sum_ ( i <- r ) U" := + (\big[addv/0%VS]_(i <- r) U%VS) : vspace_scope. +Notation "\sum_ ( m <= i < n | P ) U" := + (\big[addv/0%VS]_(m <= i < n | P%B) U%VS) : vspace_scope. +Notation "\sum_ ( m <= i < n ) U" := + (\big[addv/0%VS]_(m <= i < n) U%VS) : vspace_scope. +Notation "\sum_ ( i | P ) U" := + (\big[addv/0%VS]_(i | P%B) U%VS) : vspace_scope. +Notation "\sum_ i U" := + (\big[addv/0%VS]_i U%VS) : vspace_scope. +Notation "\sum_ ( i : t | P ) U" := + (\big[addv/0%VS]_(i : t | P%B) U%VS) (only parsing) : vspace_scope. +Notation "\sum_ ( i : t ) U" := + (\big[addv/0%VS]_(i : t) U%VS) (only parsing) : vspace_scope. +Notation "\sum_ ( i < n | P ) U" := + (\big[addv/0%VS]_(i < n | P%B) U%VS) : vspace_scope. +Notation "\sum_ ( i < n ) U" := + (\big[addv/0%VS]_(i < n) U%VS) : vspace_scope. +Notation "\sum_ ( i 'in' A | P ) U" := + (\big[addv/0%VS]_(i in A | P%B) U%VS) : vspace_scope. +Notation "\sum_ ( i 'in' A ) U" := + (\big[addv/0%VS]_(i in A) U%VS) : vspace_scope. + +Notation "\bigcap_ ( i <- r | P ) U" := + (\big[capv/fullv]_(i <- r | P%B) U%VS) : vspace_scope. +Notation "\bigcap_ ( i <- r ) U" := + (\big[capv/fullv]_(i <- r) U%VS) : vspace_scope. +Notation "\bigcap_ ( m <= i < n | P ) U" := + (\big[capv/fullv]_(m <= i < n | P%B) U%VS) : vspace_scope. +Notation "\bigcap_ ( m <= i < n ) U" := + (\big[capv/fullv]_(m <= i < n) U%VS) : vspace_scope. +Notation "\bigcap_ ( i | P ) U" := + (\big[capv/fullv]_(i | P%B) U%VS) : vspace_scope. +Notation "\bigcap_ i U" := + (\big[capv/fullv]_i U%VS) : vspace_scope. +Notation "\bigcap_ ( i : t | P ) U" := + (\big[capv/fullv]_(i : t | P%B) U%VS) (only parsing) : vspace_scope. +Notation "\bigcap_ ( i : t ) U" := + (\big[capv/fullv]_(i : t) U%VS) (only parsing) : vspace_scope. +Notation "\bigcap_ ( i < n | P ) U" := + (\big[capv/fullv]_(i < n | P%B) U%VS) : vspace_scope. +Notation "\bigcap_ ( i < n ) U" := + (\big[capv/fullv]_(i < n) U%VS) : vspace_scope. +Notation "\bigcap_ ( i 'in' A | P ) U" := + (\big[capv/fullv]_(i in A | P%B) U%VS) : vspace_scope. +Notation "\bigcap_ ( i 'in' A ) U" := + (\big[capv/fullv]_(i in A) U%VS) : vspace_scope. + +Section VectorTheory. + +Variables (K : fieldType) (vT : vectType K). +Implicit Types (a : K) (u v w : vT) (X Y : seq vT) (U V W : {vspace vT}). + +Local Notation subV := (@subsetv K vT) (only parsing). +Local Notation addV := (@addv K vT) (only parsing). +Local Notation capV := (@capv K vT) (only parsing). + +(* begin hide *) + +(* Internal theory facts *) +Let vs2mxP U V : reflect (U = V) (vs2mx U == vs2mx V)%MS. +Proof. by rewrite (sameP genmxP eqP) !gen_vs2mx; apply: eqP. Qed. + +Let memvK v U : (v \in U) = (v2r v <= vs2mx U)%MS. +Proof. by rewrite -genmxE. Qed. + +Let mem_r2v rv U : (r2v rv \in U) = (rv <= vs2mx U)%MS. +Proof. by rewrite memvK r2vK. Qed. + +Let vs2mx0 : @vs2mx K vT _ 0 = 0. +Proof. by rewrite /= linear0 genmx0. Qed. + +Let vs2mxD U V : vs2mx (U + V) = (vs2mx U + vs2mx V)%MS. +Proof. by rewrite /= genmx_adds !gen_vs2mx. Qed. + +Let vs2mx_sum := big_morph _ vs2mxD vs2mx0. + +Let vs2mxI U V : vs2mx (U :&: V) = (vs2mx U :&: vs2mx V)%MS. +Proof. by rewrite /= genmx_cap !gen_vs2mx. Qed. + +Let vs2mxF : vs2mx {:vT} = 1%:M. +Proof. by rewrite /= genmx1. Qed. + +Let row_b2mx n (X : n.-tuple vT) i : row i (b2mx X) = v2r X`_i. +Proof. by rewrite -tnth_nth rowK. Qed. + +Let span_b2mx n (X : n.-tuple vT) : span X = mx2vs (b2mx X). +Proof. by rewrite unlock tvalK; case: _ / (esym _). Qed. + +Let mul_b2mx n (X : n.-tuple vT) (rk : 'rV_n) : + \sum_i rk 0 i *: X`_i = r2v (rk *m b2mx X). +Proof. +rewrite mulmx_sum_row linear_sum; apply: eq_bigr => i _. +by rewrite row_b2mx linearZ /= v2rK. +Qed. + +Let lin_b2mx n (X : n.-tuple vT) k : + \sum_(i < n) k i *: X`_i = r2v (\row_i k i *m b2mx X). +Proof. by rewrite -mul_b2mx; apply: eq_bigr => i _; rewrite mxE. Qed. + +Let free_b2mx n (X : n.-tuple vT) : free X = row_free (b2mx X). +Proof. by rewrite /free /dimv span_b2mx genmxE size_tuple. Qed. +(* end hide *) + +Fact vspace_key U : pred_key U. Proof. by []. Qed. +Canonical vspace_keyed U := KeyedPred (vspace_key U). + +Lemma memvE v U : (v \in U) = (<[v]> <= U)%VS. Proof. by []. Qed. + +Lemma vlineP v1 v2 : reflect (exists k, v1 = k *: v2) (v1 \in <[v2]>)%VS. +Proof. +apply: (iffP idP) => [|[k ->]]; rewrite memvK genmxE ?linearZ ?scalemx_sub //. +by case/sub_rVP=> k; rewrite -linearZ => /v2r_inj->; exists k. +Qed. + +Fact memv_submod_closed U : submod_closed U. +Proof. +split=> [|a u v]; rewrite !memvK ?linear0 ?sub0mx // => Uu Uv. +by rewrite linearP addmx_sub ?scalemx_sub. +Qed. +Canonical memv_opprPred U := OpprPred (memv_submod_closed U). +Canonical memv_addrPred U := AddrPred (memv_submod_closed U). +Canonical memv_zmodPred U := ZmodPred (memv_submod_closed U). +Canonical memv_submodPred U := SubmodPred (memv_submod_closed U). + +Lemma mem0v U : 0 \in U. Proof. exact : rpred0. Qed. +Lemma memvN U v : (- v \in U) = (v \in U). Proof. exact: rpredN. Qed. +Lemma memvD U : {in U &, forall u v, u + v \in U}. Proof. exact : rpredD. Qed. +Lemma memvB U : {in U &, forall u v, u - v \in U}. Proof. exact : rpredB. Qed. +Lemma memvZ U k : {in U, forall v, k *: v \in U}. Proof. exact : rpredZ. Qed. + +Lemma memv_suml I r (P : pred I) vs U : + (forall i, P i -> vs i \in U) -> \sum_(i <- r | P i) vs i \in U. +Proof. exact: rpred_sum. Qed. + +Lemma memv_line u : u \in <[u]>%VS. +Proof. by apply/vlineP; exists 1; rewrite scale1r. Qed. + +Lemma subvP U V : reflect {subset U <= V} (U <= V)%VS. +Proof. +apply: (iffP rV_subP) => sU12 u. + by rewrite !memvE /subsetv !genmxE => /sU12. +by have:= sU12 (r2v u); rewrite !memvE /subsetv !genmxE r2vK. +Qed. + +Lemma subvv U : (U <= U)%VS. Proof. exact/subvP. Qed. +Hint Resolve subvv. + +Lemma subv_trans : transitive subV. +Proof. by move=> U V W /subvP sUV /subvP sVW; apply/subvP=> u /sUV/sVW. Qed. + +Lemma subv_anti : antisymmetric subV. +Proof. by move=> U V; apply/vs2mxP. Qed. + +Lemma eqEsubv U V : (U == V) = (U <= V <= U)%VS. +Proof. by apply/eqP/idP=> [-> | /subv_anti//]; rewrite subvv. Qed. + +Lemma vspaceP U V : U =i V <-> U = V. +Proof. +split=> [eqUV | -> //]; apply/subv_anti/andP. +by split; apply/subvP=> v; rewrite eqUV. +Qed. + +Lemma subvPn {U V} : reflect (exists2 u, u \in U & u \notin V) (~~ (U <= V)%VS). +Proof. +apply: (iffP idP) => [|[u Uu]]; last by apply: contra => /subvP->. +case/row_subPn=> i; set vi := row i _ => V'vi. +by exists (r2v vi); rewrite memvK r2vK ?row_sub. +Qed. + +(* Empty space. *) +Lemma sub0v U : (0 <= U)%VS. +Proof. exact: mem0v. Qed. + +Lemma subv0 U : (U <= 0)%VS = (U == 0%VS). +Proof. by rewrite eqEsubv sub0v andbT. Qed. + +Lemma memv0 v : v \in 0%VS = (v == 0). +Proof. by apply/idP/eqP=> [/vlineP[k ->] | ->]; rewrite (scaler0, mem0v). Qed. + +(* Full space *) + +Lemma subvf U : (U <= fullv)%VS. Proof. by rewrite /subsetv vs2mxF submx1. Qed. +Lemma memvf v : v \in fullv. Proof. exact: subvf. Qed. + +(* Picking a non-zero vector in a subspace. *) +Lemma memv_pick U : vpick U \in U. Proof. by rewrite mem_r2v nz_row_sub. Qed. + +Lemma vpick0 U : (vpick U == 0) = (U == 0%VS). +Proof. by rewrite -memv0 mem_r2v -subv0 /subV vs2mx0 !submx0 nz_row_eq0. Qed. + +(* Sum of subspaces. *) +Lemma subv_add U V W : (U + V <= W)%VS = (U <= W)%VS && (V <= W)%VS. +Proof. by rewrite /subV vs2mxD addsmx_sub. Qed. + +Lemma addvS U1 U2 V1 V2 : (U1 <= U2 -> V1 <= V2 -> U1 + V1 <= U2 + V2)%VS. +Proof. by rewrite /subV !vs2mxD; apply: addsmxS. Qed. + +Lemma addvSl U V : (U <= U + V)%VS. +Proof. by rewrite /subV vs2mxD addsmxSl. Qed. + +Lemma addvSr U V : (V <= U + V)%VS. +Proof. by rewrite /subV vs2mxD addsmxSr. Qed. + +Lemma addvC : commutative addV. +Proof. by move=> U V; apply/vs2mxP; rewrite !vs2mxD addsmxC submx_refl. Qed. + +Lemma addvA : associative addV. +Proof. by move=> U V W; apply/vs2mxP; rewrite !vs2mxD addsmxA submx_refl. Qed. + +Lemma addv_idPl {U V}: reflect (U + V = U)%VS (V <= U)%VS. +Proof. by rewrite /subV (sameP addsmx_idPl eqmxP) -vs2mxD; apply: vs2mxP. Qed. + +Lemma addv_idPr {U V} : reflect (U + V = V)%VS (U <= V)%VS. +Proof. by rewrite addvC; apply: addv_idPl. Qed. + +Lemma addvv : idempotent addV. +Proof. by move=> U; apply/addv_idPl. Qed. + +Lemma add0v : left_id 0%VS addV. +Proof. by move=> U; apply/addv_idPr/sub0v. Qed. + +Lemma addv0 : right_id 0%VS addV. +Proof. by move=> U; apply/addv_idPl/sub0v. Qed. + +Lemma sumfv : left_zero fullv addV. +Proof. by move=> U; apply/addv_idPl/subvf. Qed. + +Lemma addvf : right_zero fullv addV. +Proof. by move=> U; apply/addv_idPr/subvf. Qed. + +Canonical addv_monoid := Monoid.Law addvA add0v addv0. +Canonical addv_comoid := Monoid.ComLaw addvC. + +Lemma memv_add u v U V : u \in U -> v \in V -> u + v \in (U + V)%VS. +Proof. by rewrite !memvK genmxE linearD; apply: addmx_sub_adds. Qed. + +Lemma memv_addP {w U V} : + reflect (exists2 u, u \in U & exists2 v, v \in V & w = u + v) + (w \in U + V)%VS. +Proof. +apply: (iffP idP) => [|[u Uu [v Vv ->]]]; last exact: memv_add. +rewrite memvK genmxE => /sub_addsmxP[r /(canRL v2rK)->]. +rewrite linearD /=; set u := r2v _; set v := r2v _. +by exists u; last exists v; rewrite // mem_r2v submxMl. +Qed. + +Section BigSum. +Variable I : finType. +Implicit Type P : pred I. + +Lemma sumv_sup i0 P U Vs : + P i0 -> (U <= Vs i0)%VS -> (U <= \sum_(i | P i) Vs i)%VS. +Proof. by move=> Pi0 /subv_trans-> //; rewrite (bigD1 i0) ?addvSl. Qed. +Implicit Arguments sumv_sup [P U Vs]. + +Lemma subv_sumP {P Us V} : + reflect (forall i, P i -> Us i <= V)%VS (\sum_(i | P i) Us i <= V)%VS. +Proof. +apply: (iffP idP) => [sUV i Pi | sUV]. + by apply: subv_trans sUV; apply: sumv_sup Pi _. +by elim/big_rec: _ => [|i W Pi sWV]; rewrite ?sub0v // subv_add sUV. +Qed. + +Lemma memv_sumr P vs (Us : I -> {vspace vT}) : + (forall i, P i -> vs i \in Us i) -> + \sum_(i | P i) vs i \in (\sum_(i | P i) Us i)%VS. +Proof. by move=> Uv; apply/rpred_sum=> i Pi; apply/(sumv_sup i Pi)/Uv. Qed. + +Lemma memv_sumP {P} {Us : I -> {vspace vT}} {v} : + reflect (exists2 vs, forall i, P i -> vs i \in Us i + & v = \sum_(i | P i) vs i) + (v \in \sum_(i | P i) Us i)%VS. +Proof. +apply: (iffP idP) => [|[vs Uv ->]]; last exact: memv_sumr. +rewrite memvK vs2mx_sum => /sub_sumsmxP[r /(canRL v2rK)->]. +pose f i := r2v (r i *m vs2mx (Us i)); rewrite linear_sum /=. +by exists f => //= i _; rewrite mem_r2v submxMl. +Qed. + +End BigSum. + +(* Intersection *) + +Lemma subv_cap U V W : (U <= V :&: W)%VS = (U <= V)%VS && (U <= W)%VS. +Proof. by rewrite /subV vs2mxI sub_capmx. Qed. + +Lemma capvS U1 U2 V1 V2 : (U1 <= U2 -> V1 <= V2 -> U1 :&: V1 <= U2 :&: V2)%VS. +Proof. by rewrite /subV !vs2mxI; apply: capmxS. Qed. + +Lemma capvSl U V : (U :&: V <= U)%VS. +Proof. by rewrite /subV vs2mxI capmxSl. Qed. + +Lemma capvSr U V : (U :&: V <= V)%VS. +Proof. by rewrite /subV vs2mxI capmxSr. Qed. + +Lemma capvC : commutative capV. +Proof. by move=> U V; apply/vs2mxP; rewrite !vs2mxI capmxC submx_refl. Qed. + +Lemma capvA : associative capV. +Proof. by move=> U V W; apply/vs2mxP; rewrite !vs2mxI capmxA submx_refl. Qed. + +Lemma capv_idPl {U V} : reflect (U :&: V = U)%VS (U <= V)%VS. +Proof. by rewrite /subV(sameP capmx_idPl eqmxP) -vs2mxI; apply: vs2mxP. Qed. + +Lemma capv_idPr {U V} : reflect (U :&: V = V)%VS (V <= U)%VS. +Proof. by rewrite capvC; apply: capv_idPl. Qed. + +Lemma capvv : idempotent capV. +Proof. by move=> U; apply/capv_idPl. Qed. + +Lemma cap0v : left_zero 0%VS capV. +Proof. by move=> U; apply/capv_idPl/sub0v. Qed. + +Lemma capv0 : right_zero 0%VS capV. +Proof. by move=> U; apply/capv_idPr/sub0v. Qed. + +Lemma capfv : left_id fullv capV. +Proof. by move=> U; apply/capv_idPr/subvf. Qed. + +Lemma capvf : right_id fullv capV. +Proof. by move=> U; apply/capv_idPl/subvf. Qed. + +Canonical capv_monoid := Monoid.Law capvA capfv capvf. +Canonical capv_comoid := Monoid.ComLaw capvC. + +Lemma memv_cap w U V : (w \in U :&: V)%VS = (w \in U) && (w \in V). +Proof. by rewrite !memvE subv_cap. Qed. + +Lemma memv_capP {w U V} : reflect (w \in U /\ w \in V) (w \in U :&: V)%VS. +Proof. by rewrite memv_cap; apply: andP. Qed. + +Lemma vspace_modl U V W : (U <= W -> U + (V :&: W) = (U + V) :&: W)%VS. +Proof. +by move=> sUV; apply/vs2mxP; rewrite !(vs2mxD, vs2mxI); exact/eqmxP/matrix_modl. +Qed. + +Lemma vspace_modr U V W : (W <= U -> (U :&: V) + W = U :&: (V + W))%VS. +Proof. by rewrite -!(addvC W) !(capvC U); apply: vspace_modl. Qed. + +Section BigCap. +Variable I : finType. +Implicit Type P : pred I. + +Lemma bigcapv_inf i0 P Us V : + P i0 -> (Us i0 <= V -> \bigcap_(i | P i) Us i <= V)%VS. +Proof. by move=> Pi0; apply: subv_trans; rewrite (bigD1 i0) ?capvSl. Qed. + +Lemma subv_bigcapP {P U Vs} : + reflect (forall i, P i -> U <= Vs i)%VS (U <= \bigcap_(i | P i) Vs i)%VS. +Proof. +apply: (iffP idP) => [sUV i Pi | sUV]. + by rewrite (subv_trans sUV) ?(bigcapv_inf Pi). +by elim/big_rec: _ => [|i W Pi]; rewrite ?subvf // subv_cap sUV. +Qed. + +End BigCap. + +(* Complement *) +Lemma addv_complf U : (U + U^C)%VS = fullv. +Proof. +apply/vs2mxP; rewrite vs2mxD -gen_vs2mx -genmx_adds !genmxE submx1 sub1mx. +exact: addsmx_compl_full. +Qed. + +Lemma capv_compl U : (U :&: U^C = 0)%VS. +Proof. +apply/val_inj; rewrite [val]/= vs2mx0 vs2mxI -gen_vs2mx -genmx_cap. +by rewrite capmx_compl genmx0. +Qed. + +(* Difference *) +Lemma diffvSl U V : (U :\: V <= U)%VS. +Proof. by rewrite /subV genmxE diffmxSl. Qed. + +Lemma capv_diff U V : ((U :\: V) :&: V = 0)%VS. +Proof. +apply/val_inj; rewrite [val]/= vs2mx0 vs2mxI -(gen_vs2mx V) -genmx_cap. +by rewrite capmx_diff genmx0. +Qed. + +Lemma addv_diff_cap U V : (U :\: V + U :&: V)%VS = U. +Proof. +apply/vs2mxP; rewrite vs2mxD -genmx_adds !genmxE. +exact/eqmxP/addsmx_diff_cap_eq. +Qed. + +Lemma addv_diff U V : (U :\: V + V = U + V)%VS. +Proof. by rewrite -{2}(addv_diff_cap U V) -addvA (addv_idPr (capvSr U V)). Qed. + +(* Subspace dimension. *) +Lemma dimv0 : \dim (0%VS : {vspace vT}) = 0%N. +Proof. by rewrite /dimv vs2mx0 mxrank0. Qed. + +Lemma dimv_eq0 U : (\dim U == 0%N) = (U == 0%VS). +Proof. by rewrite /dimv /= mxrank_eq0 {2}/eq_op /= linear0 genmx0. Qed. + +Lemma dimvf : \dim {:vT} = Vector.dim vT. +Proof. by rewrite /dimv vs2mxF mxrank1. Qed. + +Lemma dim_vline v : \dim <[v]> = (v != 0). +Proof. by rewrite /dimv mxrank_gen rank_rV (can2_eq v2rK r2vK) linear0. Qed. + +Lemma dimvS U V : (U <= V)%VS -> \dim U <= \dim V. +Proof. exact: mxrankS. Qed. + +Lemma dimv_leqif_sup U V : (U <= V)%VS -> \dim U <= \dim V ?= iff (V <= U)%VS. +Proof. exact: mxrank_leqif_sup. Qed. + +Lemma dimv_leqif_eq U V : (U <= V)%VS -> \dim U <= \dim V ?= iff (U == V). +Proof. by rewrite eqEsubv; apply: mxrank_leqif_eq. Qed. + +Lemma eqEdim U V : (U == V) = (U <= V)%VS && (\dim V <= \dim U). +Proof. by apply/idP/andP=> [/eqP | [/dimv_leqif_eq/geq_leqif]] ->. Qed. + +Lemma dimv_compl U : \dim U^C = (\dim {:vT} - \dim U)%N. +Proof. by rewrite dimvf /dimv mxrank_gen mxrank_compl. Qed. + +Lemma dimv_cap_compl U V : (\dim (U :&: V) + \dim (U :\: V))%N = \dim U. +Proof. by rewrite /dimv !mxrank_gen mxrank_cap_compl. Qed. + +Lemma dimv_sum_cap U V : (\dim (U + V) + \dim (U :&: V) = \dim U + \dim V)%N. +Proof. by rewrite /dimv !mxrank_gen mxrank_sum_cap. Qed. + +Lemma dimv_disjoint_sum U V : + (U :&: V = 0)%VS -> \dim (U + V) = (\dim U + \dim V)%N. +Proof. by move=> dxUV; rewrite -dimv_sum_cap dxUV dimv0 addn0. Qed. + +Lemma dimv_add_leqif U V : + \dim (U + V) <= \dim U + \dim V ?= iff (U :&: V <= 0)%VS. +Proof. +by rewrite /dimv /subV !mxrank_gen vs2mx0 genmxE; apply: mxrank_adds_leqif. +Qed. + +Lemma diffv_eq0 U V : (U :\: V == 0)%VS = (U <= V)%VS. +Proof. +rewrite -dimv_eq0 -(eqn_add2l (\dim (U :&: V))) addn0 dimv_cap_compl eq_sym. +by rewrite (dimv_leqif_eq (capvSl _ _)) (sameP capv_idPl eqP). +Qed. + +Lemma dimv_leq_sum I r (P : pred I) (Us : I -> {vspace vT}) : + \dim (\sum_(i <- r | P i) Us i) <= \sum_(i <- r | P i) \dim (Us i). +Proof. +elim/big_rec2: _ => [|i d vs _ le_vs_d]; first by rewrite dim_vline eqxx. +by apply: (leq_trans (dimv_add_leqif _ _)); rewrite leq_add2l. +Qed. + +Section SumExpr. + +(* The vector direct sum theory clones the interface types of the matrix *) +(* direct sum theory (see mxalgebra for the technical details), but *) +(* nevetheless reuses much of the matrix theory. *) +Structure addv_expr := Sumv { + addv_val :> wrapped {vspace vT}; + addv_dim : wrapped nat; + _ : mxsum_spec (vs2mx (unwrap addv_val)) (unwrap addv_dim) +}. + +(* Piggyback on mxalgebra theory. *) +Definition vs2mx_sum_expr_subproof (S : addv_expr) : + mxsum_spec (vs2mx (unwrap S)) (unwrap (addv_dim S)). +Proof. by case: S. Qed. +Canonical vs2mx_sum_expr S := ProperMxsumExpr (vs2mx_sum_expr_subproof S). + +Canonical trivial_addv U := @Sumv (Wrap U) (Wrap (\dim U)) (TrivialMxsum _). + +Structure proper_addv_expr := ProperSumvExpr { + proper_addv_val :> {vspace vT}; + proper_addv_dim :> nat; + _ : mxsum_spec (vs2mx proper_addv_val) proper_addv_dim +}. + +Definition proper_addvP (S : proper_addv_expr) := + let: ProperSumvExpr _ _ termS := S return mxsum_spec (vs2mx S) S in termS. + +Canonical proper_addv (S : proper_addv_expr) := + @Sumv (wrap (S : {vspace vT})) (wrap (S : nat)) (proper_addvP S). + +Section Binary. +Variables S1 S2 : addv_expr. +Fact binary_addv_subproof : + mxsum_spec (vs2mx (unwrap S1 + unwrap S2)) + (unwrap (addv_dim S1) + unwrap (addv_dim S2)). +Proof. by rewrite vs2mxD; apply: proper_mxsumP. Qed. +Canonical binary_addv_expr := ProperSumvExpr binary_addv_subproof. +End Binary. + +Section Nary. +Variables (I : Type) (r : seq I) (P : pred I) (S_ : I -> addv_expr). +Fact nary_addv_subproof : + mxsum_spec (vs2mx (\sum_(i <- r | P i) unwrap (S_ i))) + (\sum_(i <- r | P i) unwrap (addv_dim (S_ i))). +Proof. by rewrite vs2mx_sum; apply: proper_mxsumP. Qed. +Canonical nary_addv_expr := ProperSumvExpr nary_addv_subproof. +End Nary. + +Definition directv_def S of phantom {vspace vT} (unwrap (addv_val S)) := + \dim (unwrap S) == unwrap (addv_dim S). + +End SumExpr. + +Local Notation directv A := (directv_def (Phantom {vspace _} A%VS)). + +Lemma directvE (S : addv_expr) : + directv (unwrap S) = (\dim (unwrap S) == unwrap (addv_dim S)). +Proof. by []. Qed. + +Lemma directvP {S : proper_addv_expr} : reflect (\dim S = S :> nat) (directv S). +Proof. exact: eqnP. Qed. + +Lemma directv_trivial U : directv (unwrap (@trivial_addv U)). +Proof. exact: eqxx. Qed. + +Lemma dimv_sum_leqif (S : addv_expr) : + \dim (unwrap S) <= unwrap (addv_dim S) ?= iff directv (unwrap S). +Proof. +rewrite directvE; case: S => [[U] [d] /= defUd]; split=> //=. +rewrite /dimv; elim: {1}_ {U}_ d / defUd => // m1 m2 A1 A2 r1 r2 _ leA1 _ leA2. +by apply: leq_trans (leq_add leA1 leA2); rewrite mxrank_adds_leqif. +Qed. + +Lemma directvEgeq (S : addv_expr) : + directv (unwrap S) = (\dim (unwrap S) >= unwrap (addv_dim S)). +Proof. by rewrite leq_eqVlt ltnNge eq_sym !dimv_sum_leqif orbF. Qed. + +Section BinaryDirect. + +Lemma directv_addE (S1 S2 : addv_expr) : + directv (unwrap S1 + unwrap S2) + = [&& directv (unwrap S1), directv (unwrap S2) + & unwrap S1 :&: unwrap S2 == 0]%VS. +Proof. +by rewrite /directv_def /dimv vs2mxD -mxdirectE mxdirect_addsE -vs2mxI -vs2mx0. +Qed. + +Lemma directv_addP {U V} : reflect (U :&: V = 0)%VS (directv (U + V)). +Proof. by rewrite directv_addE !directv_trivial; apply: eqP. Qed. + +Lemma directv_add_unique {U V} : + reflect (forall u1 u2 v1 v2, u1 \in U -> u2 \in U -> v1 \in V -> v2 \in V -> + (u1 + v1 == u2 + v2) = ((u1, v1) == (u2, v2))) + (directv (U + V)). +Proof. +apply: (iffP directv_addP) => [dxUV u1 u2 v1 v2 Uu1 Uu2 Vv1 Vv2 | dxUV]. + apply/idP/idP=> [| /eqP[-> ->] //]; rewrite -subr_eq0 opprD addrACA addr_eq0. + move/eqP=> eq_uv; rewrite xpair_eqE -subr_eq0 eq_uv oppr_eq0 subr_eq0 andbb. + by rewrite -subr_eq0 -memv0 -dxUV memv_cap -memvN -eq_uv !memvB. +apply/eqP; rewrite -subv0; apply/subvP=> v /memv_capP[U1v U2v]. +by rewrite memv0 -[v == 0]andbb {1}eq_sym -xpair_eqE -dxUV ?mem0v // addrC. +Qed. + +End BinaryDirect. + +Section NaryDirect. + +Context {I : finType} {P : pred I}. + +Lemma directv_sumP {Us : I -> {vspace vT}} : + reflect (forall i, P i -> Us i :&: (\sum_(j | P j && (j != i)) Us j) = 0)%VS + (directv (\sum_(i | P i) Us i)). +Proof. +rewrite directvE /= /dimv vs2mx_sum -mxdirectE; apply: (equivP mxdirect_sumsP). +by do [split=> dxU i /dxU; rewrite -vs2mx_sum -vs2mxI -vs2mx0] => [/val_inj|->]. +Qed. + +Lemma directv_sumE {Ss : I -> addv_expr} (xunwrap := unwrap) : + reflect [/\ forall i, P i -> directv (unwrap (Ss i)) + & directv (\sum_(i | P i) xunwrap (Ss i))] + (directv (\sum_(i | P i) unwrap (Ss i))). +Proof. +by rewrite !directvE /= /dimv 2!{1}vs2mx_sum -!mxdirectE; apply: mxdirect_sumsE. +Qed. + +Lemma directv_sum_independent {Us : I -> {vspace vT}} : + reflect (forall us, + (forall i, P i -> us i \in Us i) -> \sum_(i | P i) us i = 0 -> + (forall i, P i -> us i = 0)) + (directv (\sum_(i | P i) Us i)). +Proof. +apply: (iffP directv_sumP) => [dxU us Uu u_0 i Pi | dxU i Pi]. + apply/eqP; rewrite -memv0 -(dxU i Pi) memv_cap Uu //= -memvN -sub0r -{1}u_0. + by rewrite (bigD1 i) //= addrC addKr memv_sumr // => j /andP[/Uu]. +apply/eqP; rewrite -subv0; apply/subvP=> v. +rewrite memv_cap memv0 => /andP[Uiv /memv_sumP[us Uu Dv]]. +have: \sum_(j | P j) [eta us with i |-> - v] j = 0. + rewrite (bigD1 i) //= eqxx {1}Dv addrC -sumrB big1 // => j /andP[_ i'j]. + by rewrite (negPf i'j) subrr. +move/dxU/(_ i Pi); rewrite /= eqxx -oppr_eq0 => -> // j Pj. +by have [-> | i'j] := altP eqP; rewrite ?memvN // Uu ?Pj. +Qed. + +Lemma directv_sum_unique {Us : I -> {vspace vT}} : + reflect (forall us vs, + (forall i, P i -> us i \in Us i) -> + (forall i, P i -> vs i \in Us i) -> + (\sum_(i | P i) us i == \sum_(i | P i) vs i) + = [forall (i | P i), us i == vs i]) + (directv (\sum_(i | P i) Us i)). +Proof. +apply: (iffP directv_sum_independent) => [dxU us vs Uu Uv | dxU us Uu u_0 i Pi]. + apply/idP/forall_inP=> [|eq_uv]; last by apply/eqP/eq_bigr => i /eq_uv/eqP. + rewrite -subr_eq0 -sumrB => /eqP/dxU eq_uv i Pi. + by rewrite -subr_eq0 eq_uv // => j Pj; apply: memvB; move: j Pj. +apply/eqP; have:= esym (dxU us \0 Uu _); rewrite u_0 big1_eq eqxx. +by move/(_ _)/forall_inP=> -> // j _; apply: mem0v. +Qed. + +End NaryDirect. + +(* Linear span generated by a list of vectors *) +Lemma memv_span X v : v \in X -> v \in <>%VS. +Proof. +by case/seq_tnthP=> i {v}->; rewrite unlock memvK genmxE (eq_row_sub i) // rowK. +Qed. + +Lemma memv_span1 v : v \in <<[:: v]>>%VS. +Proof. by rewrite memv_span ?mem_head. Qed. + +Lemma dim_span X : \dim <> <= size X. +Proof. by rewrite unlock /dimv genmxE rank_leq_row. Qed. + +Lemma span_subvP {X U} : reflect {subset X <= U} (<> <= U)%VS. +Proof. +rewrite /subV [@span _ _]unlock genmxE. +apply: (iffP row_subP) => /= [sXU | sXU i]. + by move=> _ /seq_tnthP[i ->]; have:= sXU i; rewrite rowK memvK. +by rewrite rowK -memvK sXU ?mem_tnth. +Qed. + +Lemma sub_span X Y : {subset X <= Y} -> (<> <= <>)%VS. +Proof. by move=> sXY; apply/span_subvP=> v /sXY/memv_span. Qed. + +Lemma eq_span X Y : X =i Y -> (<> = <>)%VS. +Proof. +by move=> eqXY; apply: subv_anti; rewrite !sub_span // => u; rewrite eqXY. +Qed. + +Lemma span_def X : span X = (\sum_(u <- X) <[u]>)%VS. +Proof. +apply/subv_anti/andP; split. + by apply/span_subvP=> v Xv; rewrite (big_rem v) // memvE addvSl. +by rewrite big_tnth; apply/subv_sumP=> i _; rewrite -memvE memv_span ?mem_tnth. +Qed. + +Lemma span_nil : (<> = 0)%VS. +Proof. by rewrite span_def big_nil. Qed. + +Lemma span_seq1 v : (<<[:: v]>> = <[v]>)%VS. +Proof. by rewrite span_def big_seq1. Qed. + +Lemma span_cons v X : (<> = <[v]> + <>)%VS. +Proof. by rewrite !span_def big_cons. Qed. + +Lemma span_cat X Y : (<> = <> + <>)%VS. +Proof. by rewrite !span_def big_cat. Qed. + +(* Coordinates function; should perhaps be generalized to nat indices. *) + +Definition coord_expanded_def n (X : n.-tuple vT) i v := + (v2r v *m pinvmx (b2mx X)) 0 i. +Definition coord := locked_with span_key coord_expanded_def. +Canonical coord_unlockable := [unlockable fun coord]. + +Fact coord_is_scalar n (X : n.-tuple vT) i : scalar (coord X i). +Proof. by move=> k u v; rewrite unlock linearP mulmxDl -scalemxAl !mxE. Qed. +Canonical coord_addidive n Xn i := Additive (@coord_is_scalar n Xn i). +Canonical coord_linear n Xn i := AddLinear (@coord_is_scalar n Xn i). + +Lemma coord_span n (X : n.-tuple vT) v : + v \in span X -> v = \sum_i coord X i v *: X`_i. +Proof. +rewrite memvK span_b2mx genmxE => Xv. +by rewrite unlock_with mul_b2mx mulmxKpV ?v2rK. +Qed. + +Lemma coord0 i v : coord [tuple 0] i v = 0. +Proof. +rewrite unlock /pinvmx rank_rV; case: negP => [[] | _]. + by apply/eqP/rowP=> j; rewrite !mxE (tnth_nth 0) /= linear0 mxE. +by rewrite pid_mx_0 !(mulmx0, mul0mx) mxE. +Qed. + +(* Free generator sequences. *) + +Lemma nil_free : free (Nil vT). +Proof. by rewrite /free span_nil dimv0. Qed. + +Lemma seq1_free v : free [:: v] = (v != 0). +Proof. by rewrite /free span_seq1 dim_vline; case: (~~ _). Qed. + +Lemma perm_free X Y : perm_eq X Y -> free X = free Y. +Proof. +by move=> eqX; rewrite /free (perm_eq_size eqX) (eq_span (perm_eq_mem eqX)). +Qed. + +Lemma free_directv X : free X = (0 \notin X) && directv (\sum_(v <- X) <[v]>). +Proof. +have leXi i (v := tnth (in_tuple X) i): true -> \dim <[v]> <= 1 ?= iff (v != 0). + by rewrite -seq1_free -span_seq1 => _; apply/leqif_eq/dim_span. +have [_ /=] := leqif_trans (dimv_sum_leqif _) (leqif_sum leXi). +rewrite sum1_card card_ord !directvE /= /free andbC span_def !(big_tnth _ _ X). +by congr (_ = _ && _); rewrite -has_pred1 -all_predC -big_all big_tnth big_andE. +Qed. + +Lemma free_not0 v X : free X -> v \in X -> v != 0. +Proof. by rewrite free_directv andbC => /andP[_ /memPn]; apply. Qed. + +Lemma freeP n (X : n.-tuple vT) : + reflect (forall k, \sum_(i < n) k i *: X`_i = 0 -> (forall i, k i = 0)) + (free X). +Proof. +rewrite free_b2mx; apply: (iffP idP) => [t_free k kt0 i | t_free]. + suffices /rowP/(_ i): \row_i k i = 0 by rewrite !mxE. + by apply/(row_free_inj t_free)/r2v_inj; rewrite mul0mx -lin_b2mx kt0 linear0. +rewrite -kermx_eq0; apply/rowV0P=> rk /sub_kermxP kt0. +by apply/rowP=> i; rewrite mxE {}t_free // mul_b2mx kt0 linear0. +Qed. + +Lemma coord_free n (X : n.-tuple vT) (i j : 'I_n) : + free X -> coord X j (X`_i) = (i == j)%:R. +Proof. +rewrite unlock free_b2mx => /row_freeP[Ct CtK]; rewrite -row_b2mx. +by rewrite -row_mul -[pinvmx _]mulmx1 -CtK 2!mulmxA mulmxKpV // CtK !mxE. +Qed. + +Lemma coord_sum_free n (X : n.-tuple vT) k j : + free X -> coord X j (\sum_(i < n) k i *: X`_i) = k j. +Proof. +move=> Xfree; rewrite linear_sum (bigD1 j) ?linearZ //= coord_free // eqxx. +rewrite mulr1 big1 ?addr0 // => i /negPf j'i. +by rewrite linearZ /= coord_free // j'i mulr0. +Qed. + +Lemma cat_free X Y : + free (X ++ Y) = [&& free X, free Y & directv (<> + <>)]. +Proof. +rewrite !free_directv mem_cat directvE /= !big_cat -directvE directv_addE /=. +rewrite negb_or -!andbA; do !bool_congr; rewrite -!span_def. +by rewrite (sameP eqP directv_addP). +Qed. + +Lemma catl_free Y X : free (X ++ Y) -> free X. +Proof. by rewrite cat_free => /and3P[]. Qed. + +Lemma catr_free X Y : free (X ++ Y) -> free Y. +Proof. by rewrite cat_free => /and3P[]. Qed. + +Lemma filter_free p X : free X -> free (filter p X). +Proof. +rewrite -(perm_free (etrans (perm_filterC p X _) (perm_eq_refl X))). +exact: catl_free. +Qed. + +Lemma free_cons v X : free (v :: X) = (v \notin <>)%VS && free X. +Proof. +rewrite (cat_free [:: v]) seq1_free directvEgeq /= span_seq1 dim_vline. +case: eqP => [-> | _] /=; first by rewrite mem0v. +rewrite andbC ltnNge (geq_leqif (dimv_leqif_sup _)) ?addvSr //. +by rewrite subv_add subvv andbT -memvE. +Qed. + +Lemma freeE n (X : n.-tuple vT) : + free X = [forall i : 'I_n, X`_i \notin <>%VS]. +Proof. +case: X => X /= /eqP <-{n}; rewrite -(big_andE xpredT) /=. +elim: X => [|v X IH_X] /=; first by rewrite nil_free big_ord0. +by rewrite free_cons IH_X big_ord_recl drop0. +Qed. + +Lemma freeNE n (X : n.-tuple vT) : + ~~ free X = [exists i : 'I_n, X`_i \in <>%VS]. +Proof. by rewrite freeE -negb_exists negbK. Qed. + +Lemma free_uniq X : free X -> uniq X. +Proof. +elim: X => //= v b IH_X; rewrite free_cons => /andP[X'v /IH_X->]. +by rewrite (contra _ X'v) // => /memv_span. +Qed. + +Lemma free_span X v (sumX := fun k => \sum_(x <- X) k x *: x) : + free X -> v \in <>%VS -> + {k | v = sumX k & forall k1, v = sumX k1 -> {in X, k1 =1 k}}. +Proof. +rewrite -{2}[X]in_tupleE => freeX /coord_span def_v. +pose k x := oapp (fun i => coord (in_tuple X) i v) 0 (insub (index x X)). +exists k => [|k1 {def_v}def_v _ /(nthP 0)[i ltiX <-]]. + rewrite /sumX (big_nth 0) big_mkord def_v; apply: eq_bigr => i _. + by rewrite /k index_uniq ?free_uniq // valK. +rewrite /k /= index_uniq ?free_uniq // insubT //= def_v. +by rewrite /sumX (big_nth 0) big_mkord coord_sum_free. +Qed. + +Lemma linear_of_free (rT : lmodType K) X (fX : seq rT) : + {f : {linear vT -> rT} | free X -> size fX = size X -> map f X = fX}. +Proof. +pose f u := \sum_i coord (in_tuple X) i u *: fX`_i. +have lin_f: linear f. + move=> k u v; rewrite scaler_sumr -big_split; apply: eq_bigr => i _. + by rewrite /= scalerA -scalerDl linearP. +exists (Linear lin_f) => freeX eq_szX. +apply/esym/(@eq_from_nth _ 0); rewrite ?size_map eq_szX // => i ltiX. +rewrite (nth_map 0) //= /f (bigD1 (Ordinal ltiX)) //=. +rewrite big1 => [|j /negbTE neqji]; rewrite (coord_free (Ordinal _)) //. + by rewrite eqxx scale1r addr0. +by rewrite eq_sym neqji scale0r. +Qed. + +(* Subspace bases *) + +Lemma span_basis U X : basis_of U X -> <>%VS = U. +Proof. by case/andP=> /eqP. Qed. + +Lemma basis_free U X : basis_of U X -> free X. +Proof. by case/andP. Qed. + +Lemma coord_basis U n (X : n.-tuple vT) v : + basis_of U X -> v \in U -> v = \sum_i coord X i v *: X`_i. +Proof. by move/span_basis <-; apply: coord_span. Qed. + +Lemma nil_basis : basis_of 0 (Nil vT). +Proof. by rewrite /basis_of span_nil eqxx nil_free. Qed. + +Lemma seq1_basis v : v != 0 -> basis_of <[v]> [:: v]. +Proof. by move=> nz_v; rewrite /basis_of span_seq1 // eqxx seq1_free. Qed. + +Lemma basis_not0 x U X : basis_of U X -> x \in X -> x != 0. +Proof. by move/basis_free/free_not0; apply. Qed. + +Lemma basis_mem x U X : basis_of U X -> x \in X -> x \in U. +Proof. by move/span_basis=> <- /memv_span. Qed. + +Lemma cat_basis U V X Y : + directv (U + V) -> basis_of U X -> basis_of V Y -> basis_of (U + V) (X ++ Y). +Proof. +move=> dxUV /andP[/eqP defU freeX] /andP[/eqP defV freeY]. +by rewrite /basis_of span_cat cat_free defU defV // eqxx freeX freeY. +Qed. + +Lemma size_basis U n (X : n.-tuple vT) : basis_of U X -> \dim U = n. +Proof. by case/andP=> /eqP <- /eqnP->; apply: size_tuple. Qed. + +Lemma basisEdim X U : basis_of U X = (U <= <>)%VS && (size X <= \dim U). +Proof. +apply/andP/idP=> [[defU /eqnP <-]| ]; first by rewrite -eqEdim eq_sym. +case/andP=> sUX leXU; have leXX := dim_span X. +rewrite /free eq_sym eqEdim sUX eqn_leq !(leq_trans leXX) //. +by rewrite (leq_trans leXU) ?dimvS. +Qed. + +Lemma basisEfree X U : + basis_of U X = [&& free X, (<> <= U)%VS & \dim U <= size X]. +Proof. +by rewrite andbC; apply: andb_id2r => freeX; rewrite eqEdim (eqnP freeX). +Qed. + +Lemma perm_basis X Y U : perm_eq X Y -> basis_of U X = basis_of U Y. +Proof. +move=> eqXY; congr ((_ == _) && _); last exact: perm_free. +by apply/eq_span; apply: perm_eq_mem. +Qed. + +Lemma vbasisP U : basis_of U (vbasis U). +Proof. +rewrite /basis_of free_b2mx span_b2mx (sameP eqP (vs2mxP _ _)) !genmxE. +have ->: b2mx (vbasis U) = row_base (vs2mx U). + by apply/row_matrixP=> i; rewrite unlock rowK tnth_mktuple r2vK. +by rewrite row_base_free !eq_row_base submx_refl. +Qed. + +Lemma vbasis_mem v U : v \in (vbasis U) -> v \in U. +Proof. exact: (basis_mem (vbasisP _)). Qed. + +Lemma coord_vbasis v U : + v \in U -> v = \sum_(i < \dim U) coord (vbasis U) i v *: (vbasis U)`_i. +Proof. exact: coord_basis (vbasisP U). Qed. + +Section BigSumBasis. + +Variables (I : finType) (P : pred I) (Xs : I -> seq vT). + +Lemma span_bigcat : + (<<\big[cat/[::]]_(i | P i) Xs i>> = \sum_(i | P i) <>)%VS. +Proof. by rewrite (big_morph _ span_cat span_nil). Qed. + +Lemma bigcat_free : + directv (\sum_(i | P i) <>) -> + (forall i, P i -> free (Xs i)) -> free (\big[cat/[::]]_(i | P i) Xs i). +Proof. +rewrite /free directvE /= span_bigcat => /directvP-> /= freeXs. +rewrite (big_morph _ (@size_cat _) (erefl _)) /=. +by apply/eqP/eq_bigr=> i /freeXs/eqP. +Qed. + +Lemma bigcat_basis Us (U := (\sum_(i | P i) Us i)%VS) : + directv U -> (forall i, P i -> basis_of (Us i) (Xs i)) -> + basis_of U (\big[cat/[::]]_(i | P i) Xs i). +Proof. +move=> dxU XsUs; rewrite /basis_of span_bigcat. +have defUs i: P i -> span (Xs i) = Us i by case/XsUs/andP=> /eqP. +rewrite (eq_bigr _ defUs) eqxx bigcat_free // => [|_ /XsUs/andP[]//]. +apply/directvP; rewrite /= (eq_bigr _ defUs) (directvP dxU) /=. +by apply/eq_bigr=> i /defUs->. +Qed. + +End BigSumBasis. + +End VectorTheory. + +Hint Resolve subvv. +Implicit Arguments subvP [K vT U V]. +Implicit Arguments addv_idPl [K vT U V]. +Implicit Arguments addv_idPr [K vT U V]. +Implicit Arguments memv_addP [K vT U V w]. +Implicit Arguments sumv_sup [K vT I P U Vs]. +Implicit Arguments memv_sumP [K vT I P Us v]. +Implicit Arguments subv_sumP [K vT I P Us V]. +Implicit Arguments capv_idPl [K vT U V]. +Implicit Arguments capv_idPr [K vT U V]. +Implicit Arguments memv_capP [K vT U V w]. +Implicit Arguments bigcapv_inf [K vT I P Us V]. +Implicit Arguments subv_bigcapP [K vT I P U Vs]. +Implicit Arguments directvP [K vT S]. +Implicit Arguments directv_addP [K vT U V]. +Implicit Arguments directv_add_unique [K vT U V]. +Implicit Arguments directv_sumP [K vT I P Us]. +Implicit Arguments directv_sumE [K vT I P Ss]. +Implicit Arguments directv_sum_independent [K vT I P Us]. +Implicit Arguments directv_sum_unique [K vT I P Us]. +Implicit Arguments span_subvP [K vT X U]. +Implicit Arguments freeP [K vT n X]. + +Prenex Implicits coord. +Notation directv S := (directv_def (Phantom _ S%VS)). + +(* Linear functions over a vectType *) +Section LfunDefs. + +Variable R : ringType. +Implicit Types aT vT rT : vectType R. + +Fact lfun_key : unit. Proof. by []. Qed. +Definition fun_of_lfun_def aT rT (f : 'Hom(aT, rT)) := + r2v \o mulmxr (f2mx f) \o v2r. +Definition fun_of_lfun := locked_with lfun_key fun_of_lfun_def. +Canonical fun_of_lfun_unlockable := [unlockable fun fun_of_lfun]. +Definition linfun_def aT rT (f : aT -> rT) := + Vector.Hom (lin1_mx (v2r \o f \o r2v)). +Definition linfun := locked_with lfun_key linfun_def. +Canonical linfun_unlockable := [unlockable fun linfun]. + +Definition id_lfun vT := @linfun vT vT idfun. +Definition comp_lfun aT vT rT (f : 'Hom(vT, rT)) (g : 'Hom(aT, vT)) := + linfun (fun_of_lfun f \o fun_of_lfun g). + +End LfunDefs. + +Coercion fun_of_lfun : Vector.hom >-> Funclass. +Notation "\1" := (@id_lfun _ _) : lfun_scope. +Notation "f \o g" := (comp_lfun f g) : lfun_scope. + +Section LfunVspaceDefs. + +Variable K : fieldType. +Implicit Types aT rT : vectType K. + +Definition inv_lfun aT rT (f : 'Hom(aT, rT)) := Vector.Hom (pinvmx (f2mx f)). +Definition lker aT rT (f : 'Hom(aT, rT)) := mx2vs (kermx (f2mx f)). +Fact lfun_img_key : unit. Proof. by []. Qed. +Definition lfun_img_def aT rT f (U : {vspace aT}) : {vspace rT} := + mx2vs (vs2mx U *m f2mx f). +Definition lfun_img := locked_with lfun_img_key lfun_img_def. +Canonical lfun_img_unlockable := [unlockable fun lfun_img]. +Definition lfun_preim aT rT (f : 'Hom(aT, rT)) W := + (lfun_img (inv_lfun f) (W :&: lfun_img f fullv) + lker f)%VS. + +End LfunVspaceDefs. + +Prenex Implicits linfun lfun_img lker lfun_preim. +Notation "f ^-1" := (inv_lfun f) : lfun_scope. +Notation "f @: U" := (lfun_img f%VF%R U) (at level 24) : vspace_scope. +Notation "f @^-1: W" := (lfun_preim f%VF%R W) (at level 24) : vspace_scope. +Notation limg f := (lfun_img f fullv). + +Section LfunZmodType. + +Variables (R : ringType) (aT rT : vectType R). +Implicit Types f g h : 'Hom(aT, rT). + +Canonical lfun_eqMixin := Eval hnf in [eqMixin of 'Hom(aT, rT) by <:]. +Canonical lfun_eqType := EqType 'Hom(aT, rT) lfun_eqMixin. +Definition lfun_choiceMixin := [choiceMixin of 'Hom(aT, rT) by <:]. +Canonical lfun_choiceType := ChoiceType 'Hom(aT, rT) lfun_choiceMixin. + +Fact lfun_is_linear f : linear f. +Proof. by rewrite unlock; apply: linearP. Qed. +Canonical lfun_additive f := Additive (lfun_is_linear f). +Canonical lfun_linear f := AddLinear (lfun_is_linear f). + +Lemma lfunE (ff : {linear aT -> rT}) : linfun ff =1 ff. +Proof. by move=> v; rewrite 2!unlock /= mul_rV_lin1 /= !v2rK. Qed. + +Lemma fun_of_lfunK : cancel (@fun_of_lfun R aT rT) linfun. +Proof. +move=> f; apply/val_inj/row_matrixP=> i. +by rewrite 2!unlock /= !rowE mul_rV_lin1 /= !r2vK. +Qed. + +Lemma lfunP f g : f =1 g <-> f = g. +Proof. +split=> [eq_fg | -> //]; rewrite -[f]fun_of_lfunK -[g]fun_of_lfunK unlock. +by apply/val_inj/row_matrixP=> i; rewrite !rowE !mul_rV_lin1 /= eq_fg. +Qed. + +Definition zero_lfun : 'Hom(aT, rT) := linfun \0. +Definition add_lfun f g := linfun (f \+ g). +Definition opp_lfun f := linfun (-%R \o f). + +Fact lfun_addA : associative add_lfun. +Proof. by move=> f g h; apply/lfunP=> v; rewrite !lfunE /= !lfunE addrA. Qed. + +Fact lfun_addC : commutative add_lfun. +Proof. by move=> f g; apply/lfunP=> v; rewrite !lfunE /= addrC. Qed. + +Fact lfun_add0 : left_id zero_lfun add_lfun. +Proof. by move=> f; apply/lfunP=> v; rewrite lfunE /= lfunE add0r. Qed. + +Lemma lfun_addN : left_inverse zero_lfun opp_lfun add_lfun. +Proof. by move=> f; apply/lfunP=> v; rewrite !lfunE /= lfunE addNr. Qed. + +Definition lfun_zmodMixin := ZmodMixin lfun_addA lfun_addC lfun_add0 lfun_addN. +Canonical lfun_zmodType := Eval hnf in ZmodType 'Hom(aT, rT) lfun_zmodMixin. + +Lemma zero_lfunE x : (0 : 'Hom(aT, rT)) x = 0. Proof. exact: lfunE. Qed. +Lemma add_lfunE f g x : (f + g) x = f x + g x. Proof. exact: lfunE. Qed. +Lemma opp_lfunE f x : (- f) x = - f x. Proof. exact: lfunE. Qed. +Lemma sum_lfunE I (r : seq I) (P : pred I) (fs : I -> 'Hom(aT, rT)) x : + (\sum_(i <- r | P i) fs i) x = \sum_(i <- r | P i) fs i x. +Proof. by elim/big_rec2: _ => [|i _ f _ <-]; rewrite lfunE. Qed. + +End LfunZmodType. + +Section LfunVectType. + +Variables (R : comRingType) (aT rT : vectType R). +Implicit Types f : 'Hom(aT, rT). + +Definition scale_lfun k f := linfun (k \*: f). +Local Infix "*:l" := scale_lfun (at level 40). + +Fact lfun_scaleA k1 k2 f : k1 *:l (k2 *:l f) = (k1 * k2) *:l f. +Proof. by apply/lfunP=> v; rewrite !lfunE /= lfunE scalerA. Qed. + +Fact lfun_scale1 f : 1 *:l f = f. +Proof. by apply/lfunP=> v; rewrite lfunE /= scale1r. Qed. + +Fact lfun_scaleDr k f1 f2 : k *:l (f1 + f2) = k *:l f1 + k *:l f2. +Proof. by apply/lfunP=> v; rewrite !lfunE /= !lfunE scalerDr. Qed. + +Fact lfun_scaleDl f k1 k2 : (k1 + k2) *:l f = k1 *:l f + k2 *:l f. +Proof. by apply/lfunP=> v; rewrite !lfunE /= !lfunE scalerDl. Qed. + +Definition lfun_lmodMixin := + LmodMixin lfun_scaleA lfun_scale1 lfun_scaleDr lfun_scaleDl. +Canonical lfun_lmodType := Eval hnf in LmodType R 'Hom(aT, rT) lfun_lmodMixin. + +Lemma scale_lfunE k f x : (k *: f) x = k *: f x. Proof. exact: lfunE. Qed. + +(* GG: exists (Vector.Hom \o vec_mx) fails in the proof below in 8.3, *) +(* probably because of incomplete type unification. Will it work in 8.4? *) +Fact lfun_vect_iso : Vector.axiom (Vector.dim aT * Vector.dim rT) 'Hom(aT, rT). +Proof. +exists (mxvec \o f2mx) => [a f g|]. + rewrite /= -linearP /= -[A in _ = mxvec A]/(f2mx (Vector.Hom _)). + congr (mxvec (f2mx _)); apply/lfunP=> v; do 2!rewrite lfunE /=. + by rewrite unlock /= -linearP mulmxDr scalemxAr. +apply: Bijective (Vector.Hom \o vec_mx) _ _ => [[A]|A] /=; last exact: vec_mxK. +by rewrite mxvecK. +Qed. + +Definition lfun_vectMixin := VectMixin lfun_vect_iso. +Canonical lfun_vectType := VectType R 'Hom(aT, rT) lfun_vectMixin. + +End LfunVectType. + +Section CompLfun. + +Variables (R : ringType) (wT aT vT rT : vectType R). +Implicit Types (f : 'Hom(vT, rT)) (g : 'Hom(aT, vT)) (h : 'Hom(wT, aT)). + +Lemma id_lfunE u: \1%VF u = u :> aT. Proof. exact: lfunE. Qed. +Lemma comp_lfunE f g u : (f \o g)%VF u = f (g u). Proof. exact: lfunE. Qed. + +Lemma comp_lfunA f g h : (f \o (g \o h) = (f \o g) \o h)%VF. +Proof. by apply/lfunP=> u; do !rewrite lfunE /=. Qed. + +Lemma comp_lfun1l f : (\1 \o f)%VF = f. +Proof. by apply/lfunP=> u; do !rewrite lfunE /=. Qed. + +Lemma comp_lfun1r f : (f \o \1)%VF = f. +Proof. by apply/lfunP=> u; do !rewrite lfunE /=. Qed. + +Lemma comp_lfun0l g : (0 \o g)%VF = 0 :> 'Hom(aT, rT). +Proof. by apply/lfunP=> u; do !rewrite lfunE /=. Qed. + +Lemma comp_lfun0r f : (f \o 0)%VF = 0 :> 'Hom(aT, rT). +Proof. by apply/lfunP=> u; do !rewrite lfunE /=; rewrite linear0. Qed. + +Lemma comp_lfunDl f1 f2 g : ((f1 + f2) \o g = (f1 \o g) + (f2 \o g))%VF. +Proof. by apply/lfunP=> u; do !rewrite lfunE /=. Qed. + +Lemma comp_lfunDr f g1 g2 : (f \o (g1 + g2) = (f \o g1) + (f \o g2))%VF. +Proof. by apply/lfunP=> u; do !rewrite lfunE /=; rewrite linearD. Qed. + +Lemma comp_lfunNl f g : ((- f) \o g = - (f \o g))%VF. +Proof. by apply/lfunP=> u; do !rewrite lfunE /=. Qed. + +Lemma comp_lfunNr f g : (f \o (- g) = - (f \o g))%VF. +Proof. by apply/lfunP=> u; do !rewrite lfunE /=; rewrite linearN. Qed. + +End CompLfun. + +Definition lfun_simp := + (comp_lfunE, scale_lfunE, opp_lfunE, add_lfunE, sum_lfunE, lfunE). + +Section ScaleCompLfun. + +Variables (R : comRingType) (aT vT rT : vectType R). +Implicit Types (f : 'Hom(vT, rT)) (g : 'Hom(aT, vT)). + +Lemma comp_lfunZl k f g : (k *: (f \o g) = (k *: f) \o g)%VF. +Proof. by apply/lfunP=> u; do !rewrite lfunE /=. Qed. + +Lemma comp_lfunZr k f g : (k *: (f \o g) = f \o (k *: g))%VF. +Proof. by apply/lfunP=> u; do !rewrite lfunE /=; rewrite linearZ. Qed. + +End ScaleCompLfun. + +Section LinearImage. + +Variables (K : fieldType) (aT rT : vectType K). +Implicit Types (f g : 'Hom(aT, rT)) (U V : {vspace aT}) (W : {vspace rT}). + +Lemma limgS f U V : (U <= V)%VS -> (f @: U <= f @: V)%VS. +Proof. by rewrite unlock /subsetv !genmxE; apply: submxMr. Qed. + +Lemma limg_line f v : (f @: <[v]> = <[f v]>)%VS. +Proof. +apply/eqP; rewrite 2!unlock eqEsubv /subsetv /= r2vK !genmxE. +by rewrite !(eqmxMr _ (genmxE _)) submx_refl. +Qed. + +Lemma limg0 f : (f @: 0 = 0)%VS. Proof. by rewrite limg_line linear0. Qed. + +Lemma memv_img f v U : v \in U -> f v \in (f @: U)%VS. +Proof. by move=> Uv; rewrite memvE -limg_line limgS. Qed. + +Lemma memv_imgP f w U : + reflect (exists2 u, u \in U & w = f u) (w \in f @: U)%VS. +Proof. +apply: (iffP idP) => [|[u Uu ->]]; last exact: memv_img. +rewrite 2!unlock memvE /subsetv !genmxE => /submxP[ku Drw]. +exists (r2v (ku *m vs2mx U)); last by rewrite /= r2vK -mulmxA -Drw v2rK. +by rewrite memvE /subsetv !genmxE r2vK submxMl. +Qed. + +Lemma lim0g U : (0 @: U = 0 :> {vspace rT})%VS. +Proof. +apply/eqP; rewrite -subv0; apply/subvP=> _ /memv_imgP[u _ ->]. +by rewrite lfunE rpred0. +Qed. + +Lemma eq_in_limg V f g : {in V, f =1 g} -> (f @: V = g @: V)%VS. +Proof. +move=> eq_fg; apply/vspaceP=> y. +by apply/memv_imgP/memv_imgP=> [][x Vx ->]; exists x; rewrite ?eq_fg. +Qed. + +Lemma limg_add f : {morph lfun_img f : U V / U + V}%VS. +Proof. +move=> U V; apply/eqP; rewrite unlock eqEsubv /subsetv /= -genmx_adds. +by rewrite !genmxE !(eqmxMr _ (genmxE _)) !addsmxMr submx_refl. +Qed. + +Lemma limg_sum f I r (P : pred I) Us : + (f @: (\sum_(i <- r | P i) Us i) = \sum_(i <- r | P i) f @: Us i)%VS. +Proof. exact: (big_morph _ (limg_add f) (limg0 f)). Qed. + +Lemma limg_cap f U V : (f @: (U :&: V) <= f @: U :&: f @: V)%VS. +Proof. by rewrite subv_cap !limgS ?capvSl ?capvSr. Qed. + +Lemma limg_bigcap f I r (P : pred I) Us : + (f @: (\bigcap_(i <- r | P i) Us i) <= \bigcap_(i <- r | P i) f @: Us i)%VS. +Proof. +elim/big_rec2: _ => [|i V U _ sUV]; first exact: subvf. +by rewrite (subv_trans (limg_cap f _ U)) ?capvS. +Qed. + +Lemma limg_span f X : (f @: <> = <>)%VS. +Proof. +by rewrite !span_def big_map limg_sum; apply: eq_bigr => x _; rewrite limg_line. +Qed. + +Lemma lfunPn f g : reflect (exists u, f u != g u) (f != g). +Proof. +apply: (iffP idP) => [f'g|[x]]; last by apply: contraNneq => /lfunP->. +suffices /subvPn[_ /memv_imgP[u _ ->]]: ~~ (limg (f - g) <= 0)%VS. + by rewrite lfunE /= lfunE /= memv0 subr_eq0; exists u. +apply: contra f'g => /subvP fg0; apply/eqP/lfunP=> u; apply/eqP. +by rewrite -subr_eq0 -opp_lfunE -add_lfunE -memv0 fg0 ?memv_img ?memvf. +Qed. + +Lemma inv_lfun_def f : (f \o f^-1 \o f)%VF = f. +Proof. +apply/lfunP=> u; do !rewrite lfunE /=; rewrite unlock /= !r2vK. +by rewrite mulmxKpV ?submxMl. +Qed. + +Lemma limg_lfunVK f : {in limg f, cancel f^-1%VF f}. +Proof. by move=> _ /memv_imgP[u _ ->]; rewrite -!comp_lfunE inv_lfun_def. Qed. + +Lemma lkerE f U : (U <= lker f)%VS = (f @: U == 0)%VS. +Proof. +rewrite unlock -dimv_eq0 /dimv /subsetv !genmxE mxrank_eq0. +by rewrite (sameP sub_kermxP eqP). +Qed. + +Lemma memv_ker f v : (v \in lker f) = (f v == 0). +Proof. by rewrite -memv0 !memvE subv0 lkerE limg_line. Qed. + +Lemma eqlfunP f g v : reflect (f v = g v) (v \in lker (f - g)). +Proof. by rewrite memv_ker !lfun_simp subr_eq0; apply: eqP. Qed. + +Lemma eqlfun_inP V f g : reflect {in V, f =1 g} (V <= lker (f - g))%VS. +Proof. by apply: (iffP subvP) => E x /E/eqlfunP. Qed. + +Lemma limg_ker_compl f U : (f @: (U :\: lker f) = f @: U)%VS. +Proof. +rewrite -{2}(addv_diff_cap U (lker f)) limg_add; apply/esym/addv_idPl. +by rewrite (subv_trans _ (sub0v _)) // subv0 -lkerE capvSr. +Qed. + +Lemma limg_ker_dim f U : (\dim (U :&: lker f) + \dim (f @: U) = \dim U)%N. +Proof. +rewrite unlock /dimv /= genmx_cap genmx_id -genmx_cap !genmxE. +by rewrite addnC mxrank_mul_ker. +Qed. + +Lemma limg_dim_eq f U : (U :&: lker f = 0)%VS -> \dim (f @: U) = \dim U. +Proof. by rewrite -(limg_ker_dim f U) => ->; rewrite dimv0. Qed. + +Lemma limg_basis_of f U X : + (U :&: lker f = 0)%VS -> basis_of U X -> basis_of (f @: U) (map f X). +Proof. +move=> injUf /andP[/eqP defU /eqnP freeX]. +by rewrite /basis_of /free size_map -limg_span -freeX defU limg_dim_eq ?eqxx. +Qed. + +Lemma lker0P f : reflect (injective f) (lker f == 0%VS). +Proof. +rewrite -subv0; apply: (iffP subvP) => [injf u v eq_fuv | injf u]. + apply/eqP; rewrite -subr_eq0 -memv0 injf //. + by rewrite memv_ker linearB /= eq_fuv subrr. +by rewrite memv_ker memv0 -(inj_eq injf) linear0. +Qed. + +Lemma limg_ker0 f U V : lker f == 0%VS -> (f @: U <= f @: V)%VS = (U <= V)%VS. +Proof. +move/lker0P=> injf; apply/idP/idP=> [/subvP sfUV | ]; last exact: limgS. +by apply/subvP=> u Uu; have /memv_imgP[v Vv /injf->] := sfUV _ (memv_img f Uu). +Qed. + +Lemma eq_limg_ker0 f U V : lker f == 0%VS -> (f @: U == f @: V)%VS = (U == V). +Proof. by move=> injf; rewrite !eqEsubv !limg_ker0. Qed. + +Lemma lker0_lfunK f : lker f == 0%VS -> cancel f f^-1%VF. +Proof. +by move/lker0P=> injf u; apply: injf; rewrite limg_lfunVK ?memv_img ?memvf. +Qed. + +Lemma lker0_compVf f : lker f == 0%VS -> (f^-1 \o f = \1)%VF. +Proof. by move/lker0_lfunK=> fK; apply/lfunP=> u; rewrite !lfunE /= fK. Qed. + +End LinearImage. + +Implicit Arguments memv_imgP [K aT rT f U w]. +Implicit Arguments lfunPn [K aT rT f g]. +Implicit Arguments lker0P [K aT rT f]. +Implicit Arguments eqlfunP [K aT rT f g v]. +Implicit Arguments eqlfun_inP [K aT rT f g V]. + +Section FixedSpace. + +Variables (K : fieldType) (vT : vectType K). +Implicit Types (f : 'End(vT)) (U : {vspace vT}). + +Definition fixedSpace f : {vspace vT} := lker (f - \1%VF). + +Lemma fixedSpaceP f a : reflect (f a = a) (a \in fixedSpace f). +Proof. +by rewrite memv_ker add_lfunE opp_lfunE id_lfunE subr_eq0; apply: eqP. +Qed. + +Lemma fixedSpacesP f U : reflect {in U, f =1 id} (U <= fixedSpace f)%VS. +Proof. by apply: (iffP subvP) => cUf x /cUf/fixedSpaceP. Qed. + +Lemma fixedSpace_limg f U : (U <= fixedSpace f -> f @: U = U)%VS. +Proof. +move/fixedSpacesP=> cUf; apply/vspaceP=> x. +by apply/memv_imgP/idP=> [[{x} x Ux ->] | Ux]; last exists x; rewrite ?cUf. +Qed. + +Lemma fixedSpace_id : fixedSpace \1 = {:vT}%VS. +Proof. +by apply/vspaceP=> x; rewrite memvf; apply/fixedSpaceP; rewrite lfunE. +Qed. + +End FixedSpace. + +Implicit Arguments fixedSpaceP [K vT f a]. +Implicit Arguments fixedSpacesP [K vT f U]. + +Section LinAut. + +Variables (K : fieldType) (vT : vectType K) (f : 'End(vT)). +Hypothesis kerf0 : lker f == 0%VS. + +Lemma lker0_limgf : limg f = fullv. +Proof. +by apply/eqP; rewrite eqEdim subvf limg_dim_eq //= (eqP kerf0) capv0. +Qed. + +Lemma lker0_lfunVK : cancel f^-1%VF f. +Proof. by move=> u; rewrite limg_lfunVK // lker0_limgf memvf. Qed. + +Lemma lker0_compfV : (f \o f^-1 = \1)%VF. +Proof. by apply/lfunP=> u; rewrite !lfunE /= lker0_lfunVK. Qed. + +Lemma lker0_compVKf aT g : (f \o (f^-1 \o g))%VF = g :> 'Hom(aT, vT). +Proof. by rewrite comp_lfunA lker0_compfV comp_lfun1l. Qed. + +Lemma lker0_compKf aT g : (f^-1 \o (f \o g))%VF = g :> 'Hom(aT, vT). +Proof. by rewrite comp_lfunA lker0_compVf ?comp_lfun1l. Qed. + +Lemma lker0_compfK rT h : ((h \o f) \o f^-1)%VF = h :> 'Hom(vT, rT). +Proof. by rewrite -comp_lfunA lker0_compfV comp_lfun1r. Qed. + +Lemma lker0_compfVK rT h : ((h \o f^-1) \o f)%VF = h :> 'Hom(vT, rT). +Proof. by rewrite -comp_lfunA lker0_compVf ?comp_lfun1r. Qed. + +End LinAut. + +Section LinearImageComp. + +Variables (K : fieldType) (aT vT rT : vectType K). +Implicit Types (f : 'Hom(aT, vT)) (g : 'Hom(vT, rT)) (U : {vspace aT}). + +Lemma lim1g U : (\1 @: U)%VS = U. +Proof. +have /andP[/eqP <- _] := vbasisP U; rewrite limg_span map_id_in // => u _. +by rewrite lfunE. +Qed. + +Lemma limg_comp f g U : ((g \o f) @: U = g @: (f @: U))%VS. +Proof. +have /andP[/eqP <- _] := vbasisP U; rewrite !limg_span; congr (span _). +by rewrite -map_comp; apply/eq_map => u; rewrite lfunE. +Qed. + +End LinearImageComp. + +Section LinearPreimage. + +Variables (K : fieldType) (aT rT : vectType K). +Implicit Types (f : 'Hom(aT, rT)) (U : {vspace aT}) (V W : {vspace rT}). + +Lemma lpreim_cap_limg f W : (f @^-1: (W :&: limg f))%VS = (f @^-1: W)%VS. +Proof. by rewrite /lfun_preim -capvA capvv. Qed. + +Lemma lpreim0 f : (f @^-1: 0)%VS = lker f. +Proof. by rewrite /lfun_preim cap0v limg0 add0v. Qed. + +Lemma lpreimS f V W : (V <= W)%VS-> (f @^-1: V <= f @^-1: W)%VS. +Proof. by move=> sVW; rewrite addvS // limgS // capvS. Qed. + +Lemma lpreimK f W : (W <= limg f)%VS -> (f @: (f @^-1: W))%VS = W. +Proof. +move=> sWf; rewrite limg_add (capv_idPl sWf) // -limg_comp. +have /eqP->: (f @: lker f == 0)%VS by rewrite -lkerE. +have /andP[/eqP defW _] := vbasisP W; rewrite addv0 -defW limg_span. +rewrite map_id_in // => x Xx; rewrite lfunE /= limg_lfunVK //. +by apply: span_subvP Xx; rewrite defW. +Qed. + +Lemma memv_preim f u W : (f u \in W) = (u \in f @^-1: W)%VS. +Proof. +apply/idP/idP=> [Wfu | /(memv_img f)]; last first. + by rewrite -lpreim_cap_limg lpreimK ?capvSr // => /memv_capP[]. +rewrite -[u](addNKr (f^-1%VF (f u))) memv_add ?memv_img //. + by rewrite memv_cap Wfu memv_img ?memvf. +by rewrite memv_ker addrC linearB /= subr_eq0 limg_lfunVK ?memv_img ?memvf. +Qed. + +End LinearPreimage. + +Section LfunAlgebra. +(* This section is a bit of a place holder: the instances we build here can't *) +(* be canonical because we are missing an interface for proper vectTypes, *) +(* would sit between Vector and Falgebra. For now, we just supply structure *) +(* definitions here and supply actual instances for F-algebras in a submodule *) +(* of the algebra library (there is currently no actual use of the End(vT) *) +(* algebra structure). Also note that the unit ring structure is missing. *) + +Variables (R : comRingType) (vT : vectType R). +Hypothesis vT_proper : Vector.dim vT > 0. + +Fact lfun1_neq0 : \1%VF != 0 :> 'End(vT). +Proof. +apply/eqP=> /lfunP/(_ (r2v (const_mx 1))); rewrite !lfunE /= => /(canRL r2vK). +by move=> /rowP/(_ (Ordinal vT_proper))/eqP; rewrite linear0 !mxE oner_eq0. +Qed. + +Prenex Implicits comp_lfunA comp_lfun1l comp_lfun1r comp_lfunDl comp_lfunDr. + +Definition lfun_comp_ringMixin := + RingMixin comp_lfunA comp_lfun1l comp_lfun1r comp_lfunDl comp_lfunDr + lfun1_neq0. +Definition lfun_comp_ringType := RingType 'End(vT) lfun_comp_ringMixin. + +(* In the standard endomorphism ring product is categorical composition. *) +Definition lfun_ringMixin : GRing.Ring.mixin_of (lfun_zmodType vT vT) := + GRing.converse_ringMixin lfun_comp_ringType. +Definition lfun_ringType := Eval hnf in RingType 'End(vT) lfun_ringMixin. +Definition lfun_lalgType := Eval hnf in [lalgType R of 'End(vT) + for LalgType R lfun_ringType (fun k x y => comp_lfunZr k y x)]. +Definition lfun_algType := Eval hnf in [algType R of 'End(vT) + for AlgType R _ (fun k (x y : lfun_lalgType) => comp_lfunZl k y x)]. + +End LfunAlgebra. + +Section Projection. + +Variables (K : fieldType) (vT : vectType K). +Implicit Types U V : {vspace vT}. + +Definition daddv_pi U V := Vector.Hom (proj_mx (vs2mx U) (vs2mx V)). +Definition projv U := daddv_pi U U^C. +Definition addv_pi1 U V := daddv_pi (U :\: V) V. +Definition addv_pi2 U V := daddv_pi V (U :\: V). + +Lemma memv_pi U V w : (daddv_pi U V) w \in U. +Proof. by rewrite unlock memvE /subsetv genmxE /= r2vK proj_mx_sub. Qed. + +Lemma memv_proj U w : projv U w \in U. Proof. exact: memv_pi. Qed. + +Lemma memv_pi1 U V w : (addv_pi1 U V) w \in U. +Proof. by rewrite (subvP (diffvSl U V)) ?memv_pi. Qed. + +Lemma memv_pi2 U V w : (addv_pi2 U V) w \in V. Proof. exact: memv_pi. Qed. + +Lemma daddv_pi_id U V u : (U :&: V = 0)%VS -> u \in U -> daddv_pi U V u = u. +Proof. +move/eqP; rewrite -dimv_eq0 memvE /subsetv /dimv !genmxE mxrank_eq0 => /eqP. +by move=> dxUV Uu; rewrite unlock /= proj_mx_id ?v2rK. +Qed. + +Lemma daddv_pi_proj U V w (pi := daddv_pi U V) : + (U :&: V = 0)%VS -> pi (pi w) = pi w. +Proof. by move/daddv_pi_id=> -> //; apply: memv_pi. Qed. + +Lemma daddv_pi_add U V w : + (U :&: V = 0)%VS -> (w \in U + V)%VS -> daddv_pi U V w + daddv_pi V U w = w. +Proof. +move/eqP; rewrite -dimv_eq0 memvE /subsetv /dimv !genmxE mxrank_eq0 => /eqP. +by move=> dxUW UVw; rewrite unlock /= -linearD /= add_proj_mx ?v2rK. +Qed. + +Lemma projv_id U u : u \in U -> projv U u = u. +Proof. exact: daddv_pi_id (capv_compl _). Qed. + +Lemma projv_proj U w : projv U (projv U w) = projv U w. +Proof. exact: daddv_pi_proj (capv_compl _). Qed. + +Lemma memv_projC U w : w - projv U w \in (U^C)%VS. +Proof. +rewrite -{1}[w](daddv_pi_add (capv_compl U)) ?addv_complf ?memvf //. +by rewrite addrC addKr memv_pi. +Qed. + +Lemma limg_proj U : limg (projv U) = U. +Proof. +apply/vspaceP=> u; apply/memv_imgP/idP=> [[u1 _ ->] | ]; first exact: memv_proj. +by exists (projv U u); rewrite ?projv_id ?memv_img ?memvf. +Qed. + +Lemma lker_proj U : lker (projv U) = (U^C)%VS. +Proof. +apply/eqP; rewrite eqEdim andbC; apply/andP; split. + by rewrite dimv_compl -(limg_ker_dim (projv U) fullv) limg_proj addnK capfv. +by apply/subvP=> v; rewrite memv_ker -{2}[v]subr0 => /eqP <-; apply: memv_projC. +Qed. + +Lemma addv_pi1_proj U V w (pi1 := addv_pi1 U V) : pi1 (pi1 w) = pi1 w. +Proof. by rewrite daddv_pi_proj // capv_diff. Qed. + +Lemma addv_pi2_id U V v : v \in V -> addv_pi2 U V v = v. +Proof. by apply: daddv_pi_id; rewrite capvC capv_diff. Qed. + +Lemma addv_pi2_proj U V w (pi2 := addv_pi2 U V) : pi2 (pi2 w) = pi2 w. +Proof. by rewrite addv_pi2_id ?memv_pi2. Qed. + +Lemma addv_pi1_pi2 U V w : + w \in (U + V)%VS -> addv_pi1 U V w + addv_pi2 U V w = w. +Proof. by rewrite -addv_diff; apply: daddv_pi_add; apply: capv_diff. Qed. + +Section Sumv_Pi. + +Variables (I : eqType) (r0 : seq I) (P : pred I) (Vs : I -> {vspace vT}). + +Let sumv_pi_rec i := + fix loop r := if r is j :: r1 then + let V1 := (\sum_(k <- r1) Vs k)%VS in + if j == i then addv_pi1 (Vs j) V1 else (loop r1 \o addv_pi2 (Vs j) V1)%VF + else 0. + +Notation sumV := (\sum_(i <- r0 | P i) Vs i)%VS. +Definition sumv_pi_for V of V = sumV := fun i => sumv_pi_rec i (filter P r0). + +Variables (V : {vspace vT}) (defV : V = sumV). + +Lemma memv_sum_pi i v : sumv_pi_for defV i v \in Vs i. +Proof. +rewrite /sumv_pi_for. +elim: (filter P r0) v => [|j r IHr] v /=; first by rewrite lfunE mem0v. +by case: eqP => [->|_]; rewrite ?lfunE ?memv_pi1 /=. +Qed. + +Lemma sumv_pi_uniq_sum v : + uniq (filter P r0) -> v \in V -> + \sum_(i <- r0 | P i) sumv_pi_for defV i v = v. +Proof. +rewrite /sumv_pi_for defV -!(big_filter r0 P). +elim: (filter P r0) v => [|i r IHr] v /= => [_ | /andP[r'i /IHr{IHr}IHr]]. + by rewrite !big_nil memv0 => /eqP. +rewrite !big_cons eqxx => /addv_pi1_pi2; congr (_ + _ = v). +rewrite -[_ v]IHr ?memv_pi2 //; apply: eq_big_seq => j /=. +by case: eqP => [<- /idPn | _]; rewrite ?lfunE. +Qed. + +End Sumv_Pi. + +End Projection. + +Prenex Implicits daddv_pi projv addv_pi1 addv_pi2. +Notation sumv_pi V := (sumv_pi_for (erefl V)). + +Section SumvPi. + +Variable (K : fieldType) (vT : vectType K). + +Lemma sumv_pi_sum (I : finType) (P : pred I) Vs v (V : {vspace vT}) + (defV : V = (\sum_(i | P i) Vs i)%VS) : + v \in V -> \sum_(i | P i) sumv_pi_for defV i v = v :> vT. +Proof. by apply: sumv_pi_uniq_sum; apply: enum_uniq. Qed. + +Lemma sumv_pi_nat_sum m n (P : pred nat) Vs v (V : {vspace vT}) + (defV : V = (\sum_(m <= i < n | P i) Vs i)%VS) : + v \in V -> \sum_(m <= i < n | P i) sumv_pi_for defV i v = v :> vT. +Proof. by apply: sumv_pi_uniq_sum; apply/filter_uniq/iota_uniq. Qed. + +End SumvPi. + +Section SubVector. + +(* Turn a {vspace V} into a vectType *) +Variable (K : fieldType) (vT : vectType K) (U : {vspace vT}). + +Inductive subvs_of : predArgType := Subvs u & u \in U. + +Definition vsval w := let: Subvs u _ := w in u. +Canonical subvs_subType := Eval hnf in [subType for vsval]. +Definition subvs_eqMixin := Eval hnf in [eqMixin of subvs_of by <:]. +Canonical subvs_eqType := Eval hnf in EqType subvs_of subvs_eqMixin. +Definition subvs_choiceMixin := [choiceMixin of subvs_of by <:]. +Canonical subvs_choiceType := ChoiceType subvs_of subvs_choiceMixin. +Definition subvs_zmodMixin := [zmodMixin of subvs_of by <:]. +Canonical subvs_zmodType := ZmodType subvs_of subvs_zmodMixin. +Definition subvs_lmodMixin := [lmodMixin of subvs_of by <:]. +Canonical subvs_lmodType := LmodType K subvs_of subvs_lmodMixin. + +Lemma subvsP w : vsval w \in U. Proof. exact: valP. Qed. +Lemma subvs_inj : injective vsval. Proof. exact: val_inj. Qed. +Lemma congr_subvs u v : u = v -> vsval u = vsval v. Proof. exact: congr1. Qed. + +Lemma vsval_is_linear : linear vsval. Proof. by []. Qed. +Canonical vsval_additive := Additive vsval_is_linear. +Canonical vsval_linear := AddLinear vsval_is_linear. + +Fact vsproj_key : unit. Proof. by []. Qed. +Definition vsproj_def u := Subvs (memv_proj U u). +Definition vsproj := locked_with vsproj_key vsproj_def. +Canonical vsproj_unlockable := [unlockable fun vsproj]. + +Lemma vsprojK : {in U, cancel vsproj vsval}. +Proof. by rewrite unlock; apply: projv_id. Qed. +Lemma vsvalK : cancel vsval vsproj. +Proof. by move=> w; exact/val_inj/vsprojK/subvsP. Qed. + +Lemma vsproj_is_linear : linear vsproj. +Proof. by move=> k w1 w2; apply: val_inj; rewrite unlock /= linearP. Qed. +Canonical vsproj_additive := Additive vsproj_is_linear. +Canonical vsproj_linear := AddLinear vsproj_is_linear. + +Fact subvs_vect_iso : Vector.axiom (\dim U) subvs_of. +Proof. +exists (fun w => \row_i coord (vbasis U) i (vsval w)). + by move=> k w1 w2; apply/rowP=> i; rewrite !mxE linearP. +exists (fun rw : 'rV_(\dim U) => vsproj (\sum_i rw 0 i *: (vbasis U)`_i)). + move=> w /=; congr (vsproj _ = w): (vsvalK w). + by rewrite {1}(coord_vbasis (subvsP w)); apply: eq_bigr => i _; rewrite mxE. +move=> rw; apply/rowP=> i; rewrite mxE vsprojK. + by rewrite coord_sum_free ?(basis_free (vbasisP U)). +by apply: rpred_sum => j _; rewrite rpredZ ?vbasis_mem ?memt_nth. +Qed. + +Definition subvs_vectMixin := VectMixin subvs_vect_iso. +Canonical subvs_vectType := VectType K subvs_of subvs_vectMixin. + +End SubVector. +Prenex Implicits vsval vsproj vsvalK. +Implicit Arguments subvs_inj [[K] [vT] [U] x1 x2]. +Implicit Arguments vsprojK [[K] [vT] [U] x]. + +Section MatrixVectType. + +Variables (R : ringType) (m n : nat). + +(* The apparently useless => /= in line 1 of the proof performs some evar *) +(* expansions that the Ltac interpretation of exists is incapable of doing. *) +Fact matrix_vect_iso : Vector.axiom (m * n) 'M[R]_(m, n). +Proof. +exists mxvec => /=; first exact: linearP. +by exists vec_mx; [apply: mxvecK | apply: vec_mxK]. +Qed. +Definition matrix_vectMixin := VectMixin matrix_vect_iso. +Canonical matrix_vectType := VectType R 'M[R]_(m, n) matrix_vectMixin. + +End MatrixVectType. + +(* A ring is a one-dimension vector space *) +Section RegularVectType. + +Variable R : ringType. + +Fact regular_vect_iso : Vector.axiom 1 R^o. +Proof. +exists (fun a => a%:M) => [a b c|]; first by rewrite rmorphD scale_scalar_mx. +by exists (fun A : 'M_1 => A 0 0) => [a | A]; rewrite ?mxE // -mx11_scalar. +Qed. +Definition regular_vectMixin := VectMixin regular_vect_iso. +Canonical regular_vectType := VectType R R^o regular_vectMixin. + +End RegularVectType. + +(* External direct product of two vectTypes. *) +Section ProdVector. + +Variables (R : ringType) (vT1 vT2 : vectType R). + +Fact pair_vect_iso : Vector.axiom (Vector.dim vT1 + Vector.dim vT2) (vT1 * vT2). +Proof. +pose p2r (u : vT1 * vT2) := row_mx (v2r u.1) (v2r u.2). +pose r2p w := (r2v (lsubmx w) : vT1, r2v (rsubmx w) : vT2). +have r2pK : cancel r2p p2r by move=> w; rewrite /p2r !r2vK hsubmxK. +have p2rK : cancel p2r r2p by case=> u v; rewrite /r2p row_mxKl row_mxKr !v2rK. +have r2p_lin: linear r2p by move=> a u v; congr (_ , _); rewrite /= !linearP. +by exists p2r; [apply: (@can2_linear _ _ _ (Linear r2p_lin)) | exists r2p]. +Qed. +Definition pair_vectMixin := VectMixin pair_vect_iso. +Canonical pair_vectType := VectType R (vT1 * vT2) pair_vectMixin. + +End ProdVector. + +(* Function from a finType into a ring form a vectype. *) +Section FunVectType. + +Variable (I : finType) (R : ringType) (vT : vectType R). + +(* Type unification with exist is again a problem in this proof. *) +Fact ffun_vect_iso : Vector.axiom (#|I| * Vector.dim vT) {ffun I -> vT}. +Proof. +pose fr (f : {ffun I -> vT}) := mxvec (\matrix_(i < #|I|) v2r (f (enum_val i))). +exists fr => /= [k f g|]. + rewrite /fr -linearP; congr (mxvec _); apply/matrixP=> i j. + by rewrite !mxE /= !ffunE linearP !mxE. +exists (fun r => [ffun i => r2v (row (enum_rank i) (vec_mx r)) : vT]) => [g|r]. + by apply/ffunP=> i; rewrite ffunE mxvecK rowK v2rK enum_rankK. +by apply/(canLR vec_mxK)/matrixP=> i j; rewrite mxE ffunE r2vK enum_valK mxE. +Qed. + +Definition ffun_vectMixin := VectMixin ffun_vect_iso. +Canonical ffun_vectType := VectType R {ffun I -> vT} ffun_vectMixin. + +End FunVectType. + +Canonical exp_vectType (K : fieldType) (vT : vectType K) n := + [vectType K of vT ^ n]. + +(* Solving a tuple of linear equations. *) +Section Solver. + +Variable (K : fieldType) (vT : vectType K). +Variables (n : nat) (lhs : n.-tuple 'End(vT)) (rhs : n.-tuple vT). + +Let lhsf u := finfun ((tnth lhs)^~ u). +Definition vsolve_eq U := finfun (tnth rhs) \in (linfun lhsf @: U)%VS. + +Lemma vsolve_eqP (U : {vspace vT}) : + reflect (exists2 u, u \in U & forall i, tnth lhs i u = tnth rhs i) + (vsolve_eq U). +Proof. +have lhsZ: linear lhsf by move=> a u v; apply/ffunP=> i; rewrite !ffunE linearP. +apply: (iffP memv_imgP) => [] [u Uu sol_u]; exists u => //. + by move=> i; rewrite -[tnth rhs i]ffunE sol_u (lfunE (Linear lhsZ)) ffunE. +by apply/ffunP=> i; rewrite (lfunE (Linear lhsZ)) !ffunE sol_u. +Qed. + +End Solver. + diff --git a/mathcomp/all.v b/mathcomp/all.v new file mode 100644 index 0000000..9be65b2 --- /dev/null +++ b/mathcomp/all.v @@ -0,0 +1,10 @@ +Require Export mathcomp.algebra.all. +Require Export mathcomp.attic.all. +Require Export mathcomp.character.all. +Require Export mathcomp.discrete.all. +Require Export mathcomp.field.all. +Require Export mathcomp.fingroup.all. +Require Export mathcomp.odd_order.all. +Require Export mathcomp.real_closed.all. +Require Export mathcomp.solvable.all. +Require Export mathcomp.ssreflect.all. diff --git a/mathcomp/attic/algnum_basic.v b/mathcomp/attic/algnum_basic.v new file mode 100644 index 0000000..a302e7a --- /dev/null +++ b/mathcomp/attic/algnum_basic.v @@ -0,0 +1,535 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype tuple div. +Require Import bigop prime finset fingroup ssralg finalg zmodp abelian. +Require Import matrix vector falgebra finfield action poly ssrint cyclotomic. +Require Import fieldext mxalgebra mxpoly. + +(************************************************************************************************) +(* Basic algebraic number theory concepts from Milne, J.S.: Algebraic Number Theory. *) +(* We work in the setting of an extension field L0 : fieldextType F. At this point, *) +(* an integral domain is represented as a collective predicate on L0 closed under *) +(* subring operations. A module over the integral domain A is represented as a *) +(* Prop-valued predicate closed under the operations (0, x + y, x - y, x * y). It *) +(* is not a-priori made a collective predicate since we first need to establish the *) +(* Basis Lemma in order to show decidability. *) +(* *) +(* integral A l <-> l is integral over the domain A, i.e., it satisfies a polynomial *) +(* over A. This is currently a Prop-valued predicate since we *) +(* quantify over all polynomials over A. An alternative definition *) +(* would be to say that the minimal polynomial of l over the field *) +(* of fractions of A is itself a polynomial over A. The latter is *) +(* a decidable property and the equivalence of the two definitions *) +(* is provided by Prop. 2.11 in Milne. *) +(* int_closed A <-> A is integrally closed. *) +(* int_closure A L == The integral closure of A in L. This is currently a Prop-valued *) +(* predicate. *) +(* is_frac_field A K <-> K is the field of fractions of A. The condition of every k \in K *) +(* arising as a quotient a / b for a,b \in K is skolemized. This is *) +(* not strictly necessary since L0 has a canonical choiceType *) +(* structure but it facilitates some of the later proofs. *) +(* frac_field_alg_int A == Every element l arises as a quotient b / a, where a is in A and b *) +(* is integral over A. The statement of the theorem is skolemized, *) +(* which is not strictly necessary. *) +(* int_clos_incl A == Every element of A is integral over A. *) +(* int_subring_closed A == The integral closure of A is closed under the subring operations *) +(* (a - b, a * b). The proof of this lemma uses an equivalent *) +(* characterization of integrality, cf. Prop. 2.4 in Milne, which is *) +(* captured by the Lemmas intPl and intPr. The former states that *) +(* if there exists a nonzero finitely-generated A-module closed under *) +(* multiplication by l, then l is integral over A. The latter states *) +(* that if l is integral over A, then the A-algebra generated by l is *) +(* closed under multiplication by l. Note: These lemmas probably need *) +(* better names. *) +(* int_zmod_closed A == The integral closure of A is closed under subtraction. *) +(* int_mulr_closed A == The integral closure of A is closed under multiplication. *) +(* tr L l k == The trace of l * k on L; the result is in the field of scalars F. *) +(* The function tr is scalar in its first argument. *) +(* tr_sym == The trace function is commutative. *) +(* ndeg Q V <-> The binary function Q : vT -> vT -> rT is nondegenerate on the *) +(* subspace V. *) +(* dual_basis U X == The dual basis of U for X, with respect to the trace bilinear form. *) +(* trK K L == The trace function on L viewed as a subfield over K. *) +(* trK_int A K L == If k and l are integral over A then their trace is in A, provided *) +(* A is an integrally closed domain, K is its field of fractions, and *) +(* L extends K. *) +(* module A M <-> M is an A-module. *) +(* span_mod A X == The A-module generated by X. *) +(* submod A M N <-> M is a submodule of N over A. *) +(* basis_of_mod A M X <-> X is the basis of the A-module M. *) +(* ideal A N <-> N is an A-ideal. *) +(* PID A <-> Every ideal in A is principal. *) +(* int_mod_closed A L == The integral closure of A in L is an A-module. *) +(* basis_lemma I Ifr K == The integral closure of I in K is a free module, provided I is an *) +(* integrally-closed principal ideal domain contained in K, Ifr is the *) +(* field of fractions of I, and the trace function trK Ifr K is *) +(* nondegenerate on K. *) +(************************************************************************************************) + +Import GRing.Theory. +Import DefaultKeying GRing.DefaultPred. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope ring_scope. + +Section Integral. + +Variable (F : fieldType) (L0 : fieldExtType F) (A : pred L0) (K L : {subfield L0}). + +Hypothesis Asubr : subring_closed A. + +Definition integral l := exists p, [/\ p \is monic, p \is a polyOver A & root p l]. +Definition int_closed := {in A, forall a b, integral (a / b) -> (a / b) \in A}. +Definition int_closure l := l \in L /\ integral l. +Definition is_frac_field := {subset A <= K} /\ exists f, forall k, f k != 0 /\ + (k \in K -> f k \in A /\ f k * k \in A). + +Hypothesis AfracK : is_frac_field. + +Lemma frac_field_alg_int : exists f, forall l, [/\ f l != 0, f l \in A & integral (f l * l)]. +Proof. +have [Aid _ Amcl] := Asubr; have Amulr : mulr_closed A := Asubr. +have [AsubK [f /all_and2-[fH0 /(_ _)/all_and2-/all_and2-[fHa fHk]]]] := AfracK. +pose g := fun l => let p := minPoly K l in \prod_(i < size p) f p`_i; exists g => l. +pose p := minPoly K l; pose n := (size p).-1. +pose s := mkseq (fun i => p`_i * (g l) ^+ (n - i)%N) (size p). +have kI (i : 'I_(size p)) : p`_i \in K by apply/all_nthP => //; apply/minPolyOver. +have glA : g l \in A by rewrite/g; elim/big_ind: _ => // i _; apply/fHa. +have pmon: p`_n = 1 by have /monicP := monic_minPoly K l. +have an1: nth 0 s n = 1 by rewrite /n nth_mkseq ?pmon ?mul1r ?subnn ?size_minPoly. +have eqPs: (Poly s) = s :> seq L0. + by rewrite (PolyK (c := 0)) // -nth_last size_mkseq an1 oner_neq0. +have ilen i : i < size p -> i <= n by move => iB; rewrite /n -ltnS prednK // size_minPoly. +split => //; first by apply/prodf_neq0 => i _. +exists (Poly s); split; last first; last by rewrite monicE lead_coefE eqPs // size_mkseq an1. + rewrite /root -(mulr0 ((g l) ^+ n)); have <- := minPolyxx K l. + rewrite !horner_coef eqPs size_mkseq big_distrr; apply/eqP/eq_bigr => i _. + rewrite nth_mkseq // exprMn //=; rewrite !mulrA; congr (_ * _); rewrite -mulrA mulrC. + by congr (_ * _); rewrite -exprD subnK ?ilen. +apply/(all_nthP 0) => i; rewrite eqPs size_mkseq => iB; rewrite nth_mkseq //. + have := ilen _ iB; rewrite leq_eqVlt => /orP. + case; first by move /eqP ->; rewrite subnn pmon mulr1. + rewrite -subn_gt0 => {pmon ilen eqPs an1} /prednK <-; rewrite exprS mulrA /= Amcl ?rpredX //. + rewrite /g (bigD1 (Ordinal iB)) //= mulrA; apply/Amcl. + by rewrite mulrC; apply/fHk/(kI (Ordinal iB)). + by rewrite rpred_prod => // j _; apply/fHa. +Qed. + +Lemma int_clos_incl a : a \in A -> integral a. +Proof. +move=> ainA; exists ('X - a%:P); rewrite monicXsubC root_XsubC. +rewrite polyOverXsubC => //; by exact Asubr. +Qed. + +Lemma intPl (I : eqType) G (r : seq I) l : has (fun x => G x != 0) r -> + (forall e, e \in r -> {f | \sum_(e' <- r) f e' * G e' = l * G e & forall e', f e' \in A}) -> + integral l. +Proof. +have Aaddr : addr_closed A := Asubr; have Amulr : mulr_closed A := Asubr. +have Aoppr : oppr_closed A := Asubr; have [Aid _ _] := Asubr. +move => rn gen; pose s := in_tuple r; pose g j := gen (tnth s j) (mem_tnth j s). +pose f j := sval (g j); pose fH j := svalP (g j). +pose M := \matrix_(i, j < size r) f j (tnth s i). +exists (char_poly M); rewrite char_poly_monic; split => //. + apply/rpred_sum => p _; apply/rpredM; first by apply/rpredX; rewrite rpredN polyOverC. + apply/rpred_prod => i _; rewrite !mxE /= rpredB ?rpredMn ?polyOverX ?polyOverC ?/f //. + by have [_ fH2] := fH (perm.PermDef.fun_of_perm p i). +rewrite -eigenvalue_root_char; apply/eigenvalueP; move: rn => /hasP[x] /(nthP x)[k kB <- xn]. +exists (\row_(i < size r) G (tnth s i)); last first. + move: xn; apply/contra => /eqP/matrixP-v0; have := v0 0 (Ordinal kB). + by rewrite !mxE (tnth_nth x) => <-. +rewrite -rowP => j; rewrite !mxE; have [fH1 _] := fH j; rewrite -fH1 (big_nth x) big_mkord. +by apply/eq_bigr => /= i _; rewrite /M !mxE (tnth_nth x) mulrC. +Qed. + +Lemma intPr l : integral l -> exists r : seq L0, + [/\ r != nil, all A r & \sum_(i < size r) r`_i * l ^+ i = l ^+ (size r)]. +Proof. +move => [p [pm pA pr]]; pose n := size p; pose r := take n.-1 (- p). +have ps : n > 1. + rewrite ltnNge; apply/negP => /size1_polyC pc; rewrite pc in pr pm => {pc}. + move: pr => /rootP; rewrite hornerC => pc0. + by move: pm; rewrite monicE lead_coefC pc0 eq_sym oner_eq0. +have rs : size r = n.-1 by rewrite /r size_takel // size_opp leq_pred. +exists r; split. + apply/eqP => /nilP; rewrite /nilp /r size_takel; last by rewrite size_opp leq_pred. + by rewrite -subn1 subn_eq0 leqNgt ps. + have : - p \is a polyOver A by rewrite rpredN //; exact Asubr. + by move => /allP-popA; apply/allP => x /mem_take /popA. +move: pr => /rootP; rewrite horner_coef -(prednK (n := size p)); last by rewrite ltnW. +rewrite big_ord_recr /= rs; have := monicP pm; rewrite /lead_coef => ->; rewrite mul1r => /eqP. +rewrite addrC addr_eq0 -sumrN => /eqP => ->; apply/eq_bigr => i _; rewrite /r nth_take //. +by rewrite coefN mulNr. +Qed. + +Lemma int_subring_closed a b : integral a -> integral b -> + integral (a - b) /\ integral (a * b). +Proof. +have [A0 _ ] := (Asubr : zmod_closed A); have [A1 Asubr2 Amulr2] := Asubr. +move => /intPr[ra [/negbTE-ran raA raS]] /intPr[rb [/negbTE-rbn rbA rbS]]. +pose n := size ra; pose m := size rb; pose r := Finite.enum [finType of 'I_n * 'I_m]. +pose G (z : 'I_n * 'I_m) := let (k, l) := z in a ^ k * b ^l. +have [nz mz] : 0 < n /\ 0 < m. + by rewrite !lt0n; split; apply/negP; move => /nilP/eqP; rewrite ?ran ?rbn. +have rnn : has (fun x => G x != 0) r. + apply/hasP; exists (Ordinal nz, Ordinal mz); first by rewrite /r -enumT mem_enum. + by rewrite /G mulr1 oner_neq0. +pose h s i : 'I_(size s) -> L0 := fun k => if (i != size s) then (i == k)%:R else s`_k. +pose f i j (z : 'I_n * 'I_m) : L0 := let (k, l) := z in h ra i k * h rb j l. +have fA i j : forall z, f i j z \in A. + have hA s k l : all A s -> h s k l \in A. + move => /allP-sa; rewrite /h; case (eqVneq k (size s)) => [/eqP ->|->]. + by apply/sa/mem_nth. + by case (eqVneq k l) => [/eqP ->|/negbTE ->]. + by move => [k l]; rewrite /f; apply/Amulr2; apply/hA. +have fS i j : (i <= n) -> (j <= m) -> \sum_(z <- r) f i j z * G z = a ^ i * b ^ j. + have hS s k c : (k <= size s) -> \sum_(l < size s) s`_l * c ^ l = c ^ (size s) -> + \sum_(l < size s) h s k l * c ^ l = c ^ k. + move => kB sS; rewrite /h; case (eqVneq k (size s)) => [->|kn {sS}]; first by rewrite eqxx. + rewrite kn; rewrite leq_eqVlt (negbTE kn) /= in kB => {kn}. + rewrite (bigD1 (Ordinal kB)) //= eqxx mul1r /= -[RHS]addr0; congr (_ + _). + by apply/big1 => l; rewrite eq_sym => kl; have : k != l := kl => /negbTE ->; rewrite mul0r. + move => iB jB; rewrite -(hS ra i a) // -(hS rb j b) // mulr_suml. + rewrite (eq_bigr (fun k => \sum_(l < m) (h ra i k * a ^ k) * (h rb j l * b ^ l))). + rewrite pair_bigA; apply eq_bigr => [[k l] _]; rewrite !mulrA; congr (_ * _). + by rewrite -!mulrA [in h rb j l * a ^ k] mulrC. + by move => k _; rewrite mulr_sumr. +pose fB i j z := f i.+1 j z - f i j.+1 z; pose fM i j z := f i.+1 j.+1 z. +have fBA i j z : fB i j z \in A by rewrite /fB Asubr2. +have fBM i j z : fM i j z \in A by rewrite /fM. +split; apply/(@intPl _ G r) => //= [[i j] _]; [exists (fB i j) | exists (fM i j)] => //. + rewrite /fB [in RHS]/G mulrBl mulrA -exprS [in b * (a ^ i * b ^ j)] mulrC -mulrA -exprSr. + rewrite -(fS _ _ (ltnW (ltn_ord i))) // -(fS _ _ _ (ltnW (ltn_ord j))) //. + by rewrite -sumrB; apply/eq_bigr => [[k l] _]; apply/mulrBl. +by rewrite /fM [in RHS]/G mulrA [in (a * b) * a ^ i] mulrC mulrA -exprSr -mulrA -exprS -!fS. +Qed. + +Lemma int_zmod_closed a b : integral a -> integral b -> integral (a - b). +Proof. by move => aI bI; have [Azmod] := int_subring_closed aI bI. Qed. + +Lemma int_mulr_closed a b : integral a -> integral b -> integral (a * b). +Proof. by move => aI bI; have [_] := int_subring_closed aI bI. Qed. + +End Integral. + +Section Trace. + +Variable (F : fieldType) (L0 : fieldExtType F) (A : pred L0) (L : {subfield L0}). + +Implicit Types k l : L0. + +Definition tr : L0 -> L0 -> F := fun l k => + let X := vbasis L in + let M := \matrix_(i, j) coord X i (l * k * X`_j) + in \tr M. + +Fact tr_is_scalar l : scalar (tr l). +Proof. +move => c a b; rewrite /tr -!linearP /=; congr (\tr _); apply/matrixP => i j; rewrite !mxE. +by rewrite mulrDr mulrDl linearD /= -scalerAr -scalerAl linearZ. +Qed. + +Canonical tr_additive l := Additive (@tr_is_scalar l). +Canonical tr_linear l := AddLinear (@tr_is_scalar l). + +Lemma tr_sym : commutative tr. +Proof. by move => a b; rewrite /tr mulrC. Qed. + +Hypothesis Asubr : subring_closed A. +Hypothesis Aint : int_closed A. +Hypothesis Afrac : is_frac_field A 1%AS. + +Lemma tr_int k l : integral A k -> integral A l -> (tr k l)%:A \in A. +Proof. admit. Qed. + +Section NDeg. + +Variable (vT : vectType F) (rT : ringType) (Q : vT -> vT -> rT) (V : {vspace vT}). + +Definition ndeg := forall (l : vT), l != 0 -> l \in V -> exists (k : vT), k \in V /\ Q l k != 0. + +End NDeg. + +Variable (U : {vspace L0}). +Let m := \dim U. +Variable (X : m.-tuple L0). + +Lemma dual_basis_def : + {Y : m.-tuple L0 | ndeg tr U -> basis_of U X -> basis_of U Y /\ + forall (i : 'I_m), tr X`_i Y`_i = 1 /\ + forall (j : 'I_m), j != i -> tr X`_i Y`_j = 0}. +Proof. +pose Uv := subvs_vectType U; pose Fv := subvs_FalgType (1%AS : {aspace L0}); +pose HomV := [vectType _ of 'Hom(Uv, Fv)]. +pose tr_sub : Uv -> Uv -> Fv := fun u v => (tr (vsval u) (vsval v))%:A. +have HomVdim : \dim {:HomV} = m by rewrite dimvf /Vector.dim /= /Vector.dim /= dimv1 muln1. +have [f fH] : {f : 'Hom(Uv, HomV) | forall u, f u =1 tr_sub u}. + have lf1 u : linear (tr_sub u) by move => c x y; rewrite /tr_sub linearP scalerDl scalerA. + have lf2 : linear (fun u => linfun (Linear (lf1 u))). + move => c x y; rewrite -lfunP => v; rewrite add_lfunE scale_lfunE !lfunE /= /tr_sub. + by rewrite tr_sym linearP scalerDl scalerA /=; congr (_ + _); rewrite tr_sym. + by exists (linfun (Linear lf2)) => u v; rewrite !lfunE. +have [Xdual XdualH] : {Xdual : m.-tuple HomV | + forall (i : 'I_m) u, Xdual`_i u = (coord X i (vsval u))%:A}. + have lg (i : 'I_m) : linear (fun u : Uv => (coord X i (vsval u))%:A : Fv). + by move => c x y; rewrite linearP /= scalerDl scalerA. + exists (mktuple (fun i => linfun (Linear (lg i)))) => i u. + by rewrite -tnth_nth tnth_mktuple !lfunE. +have [finv finvH] : {finv : 'Hom(HomV, L0) | finv =1 vsval \o (f^-1)%VF}. + by exists (linfun vsval \o f^-1)%VF => u; rewrite comp_lfunE lfunE. +pose Y := map_tuple finv Xdual; exists Y => Und Xb. +have Ydef (i : 'I_m) : Y`_i = finv Xdual`_i by rewrite -!tnth_nth tnth_map. +have XiU (i : 'I_m) : X`_i \in U by apply/(basis_mem Xb)/mem_nth; rewrite size_tuple. +have Xii (i : 'I_m) : coord X i X`_i = 1%:R. + by rewrite coord_free ?eqxx //; exact (basis_free Xb). +have Xij (i j : 'I_m) : j != i -> coord X i X`_j = 0%:R. + by rewrite coord_free; [move => /negbTE -> | exact (basis_free Xb)]. +have Xdualb : basis_of fullv Xdual. + suffices Xdualf : free Xdual. + rewrite /basis_of Xdualf andbC /= -dimv_leqif_eq ?subvf // eq_sym HomVdim. + by move: Xdualf; rewrite /free => /eqP => ->; rewrite size_tuple. + apply/freeP => k sX i. + suffices: (\sum_(i < m) k i *: Xdual`_i) (vsproj U X`_i) = (k i)%:A. + by rewrite sX zero_lfunE => /esym /eqP; rewrite scaler_eq0 oner_eq0 orbF => /eqP. + rewrite sum_lfunE (bigD1 i) //= scale_lfunE XdualH vsprojK // Xii. + rewrite scaler_nat -[RHS]addr0; congr (_ + _); apply/big1 => j; rewrite eq_sym => ineqj. + by rewrite scale_lfunE XdualH vsprojK ?Xij // scaler_nat scaler0. +have finj : (lker f = 0)%VS. + apply/eqP; rewrite -subv0; apply/subvP=> u; rewrite memv_ker memv0 => /eqP-f0. + apply/contraT => un0; have {un0} [k [kiU /negP[]]] := Und (vsval u) un0 (subvsP u). + have /eqP := fH u (vsproj U k). + by rewrite /tr_sub vsprojK // f0 zero_lfunE eq_sym scaler_eq0 oner_eq0 orbF. +have flimg : limg f = fullv. + apply/eqP; rewrite -dimv_leqif_eq ?subvf // limg_dim_eq; last by rewrite finj capv0. + by rewrite HomVdim dimvf /Vector.dim. +have finvK : cancel finv (f \o vsproj U). + by move => u; rewrite finvH /= vsvalK; apply/limg_lfunVK; rewrite flimg memvf. +have finv_inj : (lker finv = 0)%VS by apply/eqP/lker0P/(can_inj finvK). +have finv_limg : limg finv = U. + apply/eqP; rewrite -dimv_leqif_eq; first by rewrite limg_dim_eq ?HomVdim ?finv_inj ?capv0. + by apply/subvP => u /memv_imgP [h _] ->; rewrite finvH subvsP. +have Xt (i j : 'I_m) : (f \o vsproj U) Y`_j (vsproj U X`_i) = (tr Y`_j X`_i)%:A. + by rewrite fH /tr_sub !vsprojK // Ydef finvH subvsP. +have Xd (i j : 'I_m) : (f \o vsproj U) Y`_j (vsproj U X`_i) = Xdual`_j (vsproj U X`_i). + by rewrite Ydef finvK. +have Ainj := fmorph_inj [rmorphism of in_alg Fv]. +split => [| i]; first by rewrite -{1}finv_limg limg_basis_of // capfv finv_inj. +split => [| j]; first by have := Xt i i; rewrite tr_sym Xd XdualH vsprojK // Xii => /Ainj. +by rewrite eq_sym => inj; have := Xt i j; rewrite tr_sym Xd XdualH vsprojK // Xij // => /Ainj. +Qed. + +Definition dual_basis : m.-tuple L0 := sval dual_basis_def. + +Hypothesis Und : ndeg tr U. +Hypothesis Xb : basis_of U X. + +Lemma dualb_basis : basis_of U dual_basis. +Proof. have [Yb _] := svalP dual_basis_def Und Xb; exact Yb. Qed. + +Lemma dualb_orth : + forall (i : 'I_m), tr X`_i dual_basis`_i = 1 /\ + forall (j : 'I_m), j != i -> tr X`_i dual_basis`_j = 0. +Proof. by have [_] := svalP dual_basis_def Und Xb. Qed. + +End Trace. + +Section TraceFieldOver. + +Variable (F : fieldType) (L0 : fieldExtType F) (A : pred L0) (K L : {subfield L0}). + +Implicit Types k l : L0. + +Let K' := subvs_fieldType K. +Let L0' := fieldOver_fieldExtType K. + +Definition trK : L0 -> L0 -> K' := tr (aspaceOver K L). + +Lemma trK_ndeg (U : {aspace L0}) : (K <= U)%VS -> + (ndeg trK U <-> ndeg (tr (aspaceOver K L)) (aspaceOver K U)). +Proof. +move => UsubL; have UU' : aspaceOver K U =i U := mem_aspaceOver UsubL. +split => [ndK l lnz | nd l lnz]. + by rewrite UU' => liU; have [k] := ndK l lnz liU; exists k; rewrite UU'. +by rewrite -UU' => liU'; have [k] := nd l lnz liU'; exists k; rewrite -UU'. +Qed. + +Hypothesis Asubr : subring_closed A. +Hypothesis Aint : int_closed A. +Hypothesis Afrac : is_frac_field A K. +Hypothesis AsubL : {subset A <= L}. + +Lemma trK_int k l : integral A k -> integral A l -> ((trK k l)%:A : L0') \in A. +Proof. admit. Qed. + +End TraceFieldOver. + +Section BasisLemma. + +Section Modules. + +Variable (F : fieldType) (L0 : fieldExtType F) (A : pred L0). + +Implicit Types M N : L0 -> Prop. + +Definition module M := M 0 /\ forall a k l, a \in A -> M k -> M l -> M (a * k - l). +Definition span_mod X m := exists2 r : (size X).-tuple L0, + all A r & m = \sum_(i < size X) r`_i * X`_i. +Definition submod M N := forall m, M m -> N m. +Definition basis_of_mod M X := free X /\ submod M (span_mod X) /\ forall m, m \in X -> M m. +Definition ideal N := submod N A /\ module N. +Definition PID := forall (N : L0 -> Prop), ideal N -> + exists2 a, N a & forall v, N v -> exists2 d, d \in A & d * a = v. + +Variable L : {subfield L0}. + +Hypothesis Asubr : subring_closed A. +Hypothesis AsubL : {subset A <= L}. + +Lemma int_mod_closed : module (int_closure A L). +Proof. +have [A0 _] : zmod_closed A := Asubr; split. + by rewrite /int_closure mem0v; split => //; apply/int_clos_incl. +move => a k l aA [kI kL] [lI lL]; split; first by rewrite rpredB ?rpredM //; apply/AsubL. +by apply/int_zmod_closed => //; apply/int_mulr_closed => //; apply/int_clos_incl. +Qed. + +End Modules. + +Variable (F0 : fieldType) (E : fieldExtType F0) (I : pred E) (Ifr K : {subfield E}). + +Hypothesis Isubr : subring_closed I. +Hypothesis Iint : int_closed I. +Hypothesis Ipid : PID I. +Hypothesis Ifrac : is_frac_field I Ifr. +Hypothesis IsubK : {subset I <= K}. +Hypothesis Knd : ndeg (trK Ifr K) K. + +Lemma basis_lemma : exists X : (\dim_Ifr K).-tuple E, basis_of_mod I (int_closure I K) X. +Proof. +suffices FisK (F : fieldType) (L0 : fieldExtType F) (A : pred L0) (L : {subfield L0}) : + subring_closed A -> int_closed A -> PID A -> is_frac_field A 1 -> ndeg (tr L) L -> + exists2 X, size X == \dim L & basis_of_mod A (int_closure A L) X. + have [Isub [f /all_and2[fH0 fHk]]] := Ifrac; pose F := subvs_fieldType Ifr; + pose L0 := fieldOver_fieldExtType Ifr; pose L := aspaceOver Ifr K. + have Ifrsub : (Ifr <= K)%VS. + apply/subvP=> x /fHk-[fHx fHxx]; rewrite -(mulKf (fH0 x) x). + by apply/memvM; rewrite ?memvV; apply/IsubK. + have LK : L =i K := mem_aspaceOver Ifrsub; have Lnd : ndeg (tr L) L by rewrite -trK_ndeg. + have Ifrac1 : is_frac_field (I : pred L0) 1. + split; first by move => a; rewrite /= trivial_fieldOver; apply/Isub. + by exists f => k; split => //; rewrite trivial_fieldOver => /fHk. + have [X Xsize [Xf [Xs Xi]]] := FisK _ L0 _ _ Isubr Iint Ipid Ifrac1 Lnd. + rewrite -dim_aspaceOver => //; have /eqP <- := Xsize; exists (in_tuple X); split; last first. + split => m; last by move => /Xi; rewrite /int_closure LK. + by rewrite /int_closure -LK; move => /Xs. + move: Xf; rewrite -{1}(in_tupleE X); move => /freeP-XfL0; apply/freeP => k. + have [k' kk'] : exists k' : 'I_(size X) -> F, forall i, (k i)%:A = vsval (k' i). + by exists (fun i => vsproj Ifr (k i)%:A) => i; rewrite vsprojK ?rpredZ ?mem1v. + pose Ainj := fmorph_inj [rmorphism of in_alg E]. + move => kS i; apply/Ainj => {Ainj} /=; rewrite scale0r kk'; apply/eqP. + rewrite raddf_eq0; last by apply/subvs_inj. + by apply/eqP/XfL0; rewrite -{3}kS => {i}; apply/eq_bigr => i _; rewrite -[RHS]mulr_algl kk'. +move => Asubr Aint Apid Afrac1 Lnd; pose n := \dim L; have Amulr : mulr_closed A := Asubr. +have [A0 _] : zmod_closed A := Asubr; have [Asub1 _] := Afrac1. +have AsubL : {subset A <= L} by move => a /Asub1; exact (subvP (sub1v L) a). +have [b1 [b1B b1H]] : exists (b1 : n.-tuple L0), [/\ basis_of L b1 & + forall i : 'I_n, integral A b1`_i]. + pose b0 := vbasis L; have [f /all_and3-[fH0 fHa fHi]] := frac_field_alg_int Asubr Afrac1. + pose d := \prod_(i < n) f b0`_i; pose b1 := map_tuple (amulr d) b0. + exists b1; split; last first => [i|]. + rewrite (nth_map 0) /d; last by rewrite size_tuple. + rewrite lfunE /= (bigD1 i) //= mulrA; apply/int_mulr_closed => //; first by rewrite mulrC. + by apply/int_clos_incl => //; rewrite rpred_prod. + have dun : d \is a GRing.unit by rewrite unitfE /d; apply/prodf_neq0 => i _. + have lim : (amulr d @: L = L)%VS. + have dinA : d \in A by rewrite rpred_prod. + rewrite limg_amulr; apply/eqP; rewrite -dimv_leqif_eq; first by rewrite dim_cosetv_unit. + by apply/prodv_sub => //; apply/AsubL. + rewrite -lim limg_basis_of //; last by apply/vbasisP. + by have /eqP -> := lker0_amulr dun; rewrite capv0. +have [b2 [/andP[/eqP-b2s b2f] b2H]] : exists (b2 : n.-tuple L0), [/\ basis_of L b2 & + forall b, b \in L -> integral A b -> forall i, (coord b2 i b)%:A \in A]. + pose b2 := dual_basis L b1; have b2B := dualb_basis Lnd b1B; exists b2; rewrite b2B. + split => // b biL bint i; suffices <-: tr L b1`_i b = coord b2 i b by rewrite tr_int. + have -> : tr L b1`_i b = \sum_(j < n) coord b2 j b * tr L b1`_i b2`_j. + by rewrite {1}(coord_basis b2B biL) linear_sum; apply/eq_bigr => j _; rewrite linearZ. + rewrite (bigD1 i); have [oi oj //] := dualb_orth Lnd b1B i; rewrite /= oi mulr1 -[RHS]addr0. + by congr (_ + _); apply/big1 => j jneqi; rewrite (oj j jneqi) mulr0. +have Mbasis k (X : k.-tuple L0) M : free X -> module A M -> submod M (span_mod A X) -> + exists B, basis_of_mod A M B. + move: k X M; elim => [X M _ _ Ms | k IH X M Xf [M0 Mm] Ms]. + by exists [::]; rewrite /basis_of_mod nil_free; move: Ms; rewrite tuple0. + pose X1 := [tuple of behead X]; pose v := thead X. + pose M1 := fun m => M m /\ coord X ord0 m = 0. + pose M2 := fun (a : L0) => exists2 m, M m & (coord X ord0 m)%:A = a. + have scr r m : r \in A -> exists c, r * m = c *: m. + by move => /Asub1/vlineP[c ->]; exists c; rewrite mulr_algl. + have span_coord m : M m -> exists r : (k.+1).-tuple L0, + [/\ all A r, m = \sum_(i < k.+1) r`_i * X`_i & forall i, (coord X i m)%:A = r`_i]. + have seqF (s : seq L0) : all A s -> exists s', s = [seq c%:A | c <- s']. + elim: s => [_| a l IHl /= /andP[/Asub1/vlineP[c ->]]]; first by exists [::]. + by move => /IHl[s' ->]; exists (c :: s'). + move => mM; have := Ms m mM; rewrite /span_mod !size_tuple; move => [r rA rS]. + exists r; split => //; have [rF rFr] := seqF r rA => {seqF}; rewrite rFr in rA. + have rFs : size rF = k.+1 by rewrite -(size_tuple r) rFr size_map. + have -> : m = \sum_(i < k.+1) rF`_i *: X`_i. + by rewrite rS; apply/eq_bigr => i _; rewrite rFr (nth_map 0) ?rFs // mulr_algl. + by move => i; rewrite coord_sum_free // rFr (nth_map 0) ?rFs. + have [B1 [B1f [B1s B1A]]] : exists B1, basis_of_mod A M1 B1. + have X1f : free X1 by move: Xf; rewrite (tuple_eta X) free_cons => /andP[_]. + apply/(IH X1) => //. + rewrite /module /M1 linear0; split => // a x y aA [xM xfc0] [yM yfc0]. + have := Mm a x y aA xM yM; move: aA => /Asub1/vlineP[r] ->; rewrite mulr_algl => msc. + by rewrite /M1 linearB linearZ /= xfc0 yfc0 subr0 mulr0. + move => m [mM mfc0]; have := span_coord m mM; move => [r [rA rS rC]]. + move: mfc0 (rC 0) ->; rewrite scale0r; move => r0; rewrite /span_mod size_tuple. + exists [tuple of behead r]; first by apply/allP => a /mem_behead/(allP rA). + by rewrite rS big_ord_recl -r0 mul0r add0r; apply/eq_bigr => i _; rewrite !nth_behead. + have [a [w wM wC] aG] : exists2 a, M2 a & forall v, M2 v -> exists2 d, d \in A & d * a = v. + apply/Apid; split. + move => c [m mM <-]; have := span_coord m mM; move => [r [/all_nthP-rA _ rC]]. + by move: rC ->; apply/rA; rewrite size_tuple. + split; first by exists 0 => //; rewrite linear0 scale0r. + move => c x y cA [mx mxM mxC] [my myM myC]; have := Mm c mx my cA mxM myM. + move: cA => /Asub1/vlineP[r] ->; rewrite !mulr_algl => mC. + by exists (r *: mx - my) => //; rewrite linearB linearZ /= scalerBl -scalerA mxC myC. + pose Ainj := fmorph_inj [rmorphism of in_alg L0]. + have mcM1 m : M m -> exists2 d, d \in A & d * a = (coord X 0 m)%:A. + by move => mM; apply/aG; exists m. + case: (eqVneq a 0) => [| an0]. + exists B1; split => //; split => [m mM |]; last by move => m /B1A[mM]. + apply/B1s; split => //; apply/Ainj => /=; have [d _ <-] := mcM1 m mM. + by rewrite a0 mulr0 scale0r. + exists (w :: B1); split. + rewrite free_cons B1f andbT; move: an0; apply/contra; move: wC <-. + rewrite -(in_tupleE B1); move => /coord_span ->; apply/eqP. + rewrite linear_sum big1 ?scale0r => //= i _; rewrite linearZ /=. + by have [_] := B1A B1`_i (mem_nth 0 (ltn_ord _)) => ->; rewrite mulr0. + split => [m mM | m]; last by rewrite in_cons; move => /orP; case => [/eqP ->|/B1A[mM]]. + have [d dA dam] := mcM1 m mM; have mdwM1 : M1 (m - d * w). + split; [have Mdwm := Mm d w m dA wM mM; have := Mm _ _ _ A0 Mdwm Mdwm |]. + by rewrite mul0r sub0r opprB. + move: dA dam => /Asub1/vlineP[r] -> {d}; rewrite !mulr_algl linearB linearZ /= => rac. + by apply/Ainj => /=; rewrite scalerBl -scalerA wC rac subrr scale0r. + have [r rA rS] := B1s _ mdwM1; exists [tuple of d :: r]; first by rewrite /= rA andbT. + by move: rS => /eqP; rewrite subr_eq addrC => /eqP ->; rewrite /= big_ord_recl. +have [X Xb] : exists X, basis_of_mod A (int_closure A L) X. + apply/(Mbasis _ b2 _ b2f) => [| m [mL mI]]; first by apply/int_mod_closed. + pose r : n.-tuple L0 := [tuple (coord b2 i m)%:A | i < n]; rewrite /span_mod size_tuple. + exists r; have rci (i : 'I_n) : r`_i = (coord b2 i m)%:A by rewrite -tnth_nth tnth_mktuple. + apply/(all_nthP 0) => i; rewrite size_tuple; move => iB. + by have -> := rci (Ordinal iB); apply/b2H. + move: mL; rewrite -b2s; move => /coord_span ->; apply/eq_bigr => i _. + by rewrite rci mulr_algl. +exists X => //; move: Xb => [/eqP-Xf [Xs Xg]]; rewrite -Xf eqn_leq; apply/andP; split. + by apply/dimvS/span_subvP => m /Xg[mL _]. +have /andP[/eqP-b1s _] := b1B; rewrite -b1s; apply/dimvS/span_subvP => b /tnthP-[i ->] {b}. +rewrite (tnth_nth 0); have [r /all_tnthP-rA ->] : span_mod A X b1`_i. + by apply/Xs; rewrite /int_closure (basis_mem b1B) ?mem_nth ?size_tuple => //. +apply/rpred_sum => j _; have := rA j; rewrite (tnth_nth 0); move => /Asub1/vlineP[c ->]. +by rewrite mulr_algl; apply/rpredZ/memv_span/mem_nth. +Qed. + +End BasisLemma. \ No newline at end of file diff --git a/mathcomp/attic/all.v b/mathcomp/attic/all.v new file mode 100644 index 0000000..41badbb --- /dev/null +++ b/mathcomp/attic/all.v @@ -0,0 +1,9 @@ +Require Export algnum_basic. +Require Export amodule. +Require Export fib. +Require Export forms. +Require Export galgebra. +Require Export multinom. +Require Export mxtens. +Require Export quote. +Require Export tutorial. diff --git a/mathcomp/attic/amodule.v b/mathcomp/attic/amodule.v new file mode 100644 index 0000000..f23ed60 --- /dev/null +++ b/mathcomp/attic/amodule.v @@ -0,0 +1,417 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype fintype finfun finset ssralg. +Require Import bigop seq tuple choice ssrnat prime ssralg fingroup pgroup. +Require Import zmodp matrix vector falgebra galgebra. + +(*****************************************************************************) +(* * Module over an algebra *) +(* amoduleType A == type for finite dimension module structure. *) +(* *) +(* v :* x == right product of the module *) +(* (M :* A)%VS == the smallest vector space that contains *) +(* {v :* x | v \in M & x \in A} *) +(* (modv M A) == M is a module for A *) +(* (modf f M A) == f is a module homomorphism on M for A *) +(*****************************************************************************) +(*****************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. +Open Local Scope ring_scope. + +Delimit Scope amodule_scope with aMS. + +Import GRing.Theory. + +Module AModuleType. +Section ClassDef. + +Variable R : ringType. +Variable V: vectType R. +Variable A: FalgType R. + +Structure mixin_of (V : vectType R) : Type := Mixin { + action: A -> 'End(V); + action_morph: forall x a b, action (a * b) x = action b (action a x); + action_linear: forall x , linear (action^~ x); + action1: forall x , action 1 x = x +}. + +Structure class_of (V : Type) : Type := Class { + base : Vector.class_of R V; + mixin : mixin_of (Vector.Pack _ base V) +}. +Local Coercion base : class_of >-> Vector.class_of. + +Implicit Type phA : phant A. + +Structure type phA : Type := Pack {sort : Type; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. + +Definition class phA (cT : type phA):= + let: Pack _ c _ := cT return class_of cT in c. +Definition clone phA T cT c of phant_id (@class phA cT) c := @Pack phA T c T. + +Definition pack phA V V0 (m0 : mixin_of (@Vector.Pack R _ V V0 V)) := + fun bT b & phant_id (@Vector.class _ (Phant R) bT) b => + fun m & phant_id m0 m => Pack phA (@Class V b m) V. + +Definition eqType phA cT := Equality.Pack (@class phA cT) cT. +Definition choiceType phA cT := choice.Choice.Pack (@class phA cT) cT. +Definition zmodType phA cT := GRing.Zmodule.Pack (@class phA cT) cT. +Definition lmodType phA cT := GRing.Lmodule.Pack (Phant R) (@class phA cT) cT. +Definition vectType phA cT := Vector.Pack (Phant R) (@class phA cT) cT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> Vector.class_of. +Coercion mixin : class_of >-> mixin_of. +Coercion sort : type >-> Sortclass. + +Coercion eqType : type >-> Equality.type. +Canonical Structure eqType. +Coercion choiceType : type >-> Choice.type. +Canonical Structure choiceType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical Structure zmodType. +Coercion lmodType : type>-> GRing.Lmodule.type. +Canonical Structure lmodType. +Coercion vectType : type >-> Vector.type. +Canonical Structure vectType. + +Notation amoduleType A := (@type _ _ (Phant A)). +Notation AModuleType A m := (@pack _ _ (Phant A) _ _ m _ _ id _ id). +Notation AModuleMixin := Mixin. + +Bind Scope ring_scope with sort. +End Exports. + +End AModuleType. +Import AModuleType.Exports. + +Section AModuleDef. +Variables (F : fieldType) (A: FalgType F) (M: amoduleType A). + +Definition rmorph (a: A) := AModuleType.action (AModuleType.class M) a. +Definition rmul (a: M) (b: A) : M := rmorph b a. +Notation "a :* b" := (rmul a b): ring_scope. + +Implicit Types x y: A. +Implicit Types v w: M. +Implicit Types c: F. + +Lemma rmulD x: {morph (rmul^~ x): v1 v2 / v1 + v2}. +Proof. move=> *; exact: linearD. Qed. + +Lemma rmul_linear_proof : forall v, linear (rmul v). +Proof. by rewrite /rmul /rmorph; case: M => s [] b []. Qed. +Canonical Structure rmul_linear v := GRing.Linear (rmul_linear_proof v). + +Lemma rmulA v x y: v :* (x * y) = (v :* x) :* y. +Proof. exact: AModuleType.action_morph. Qed. + +Lemma rmulZ : forall c v x, (c *: v) :* x = c *: (v :* x). +Proof. move=> c v x; exact: linearZZ. Qed. + +Lemma rmul0 : left_zero 0 rmul. +Proof. move=> x; exact: linear0. Qed. + +Lemma rmul1 : forall v , v :* 1 = v. +Proof. by rewrite /rmul /rmorph; case: M => s [] b []. Qed. + +Lemma rmul_sum : forall I r P (f : I -> M) x, + \sum_(i <- r | P i) f i :* x = (\sum_(i <- r | P i) f i) :* x. +Proof. +by move=> I r P f x; rewrite -linear_sum. +Qed. + +Implicit Types vs: {vspace M}. +Implicit Types ws: {vspace A}. + +Lemma size_eprodv : forall vs ws, + size (allpairs rmul (vbasis vs) (vbasis ws)) == (\dim vs * \dim ws)%N. +Proof. by move=> *; rewrite size_allpairs !size_tuple. Qed. + +Definition eprodv vs ws := span (Tuple (size_eprodv vs ws)). +Local Notation "A :* B" := (eprodv A B) : vspace_scope. + +Lemma memv_eprod vs ws a b : a \in vs -> b \in ws -> a :* b \in (vs :* ws)%VS. +Proof. +move=> Ha Hb. +rewrite (coord_vbasis Ha) (coord_vbasis Hb). +rewrite linear_sum /=; apply: memv_suml => j _. +rewrite -rmul_sum; apply: memv_suml => i _ /=. +rewrite linearZ memvZ //= rmulZ memvZ //=. +apply: memv_span; apply/allpairsP; exists ((vbasis vs)`_i, (vbasis ws)`_j)=> //. +by rewrite !mem_nth //= size_tuple. +Qed. + +Lemma eprodvP : forall vs1 ws vs2, + reflect (forall a b, a \in vs1 -> b \in ws -> a :* b \in vs2) + (vs1 :* ws <= vs2)%VS. +Proof. +move=> vs1 ws vs2; apply: (iffP idP). + move=> Hs a b Ha Hb. + by apply: subv_trans Hs; exact: memv_eprod. +move=> Ha; apply/subvP=> v. +move/coord_span->; apply: memv_suml=> i _ /=. +apply: memvZ. +set u := allpairs _ _ _. +have: i < size u by rewrite (eqP (size_eprodv _ _)). +move/(mem_nth 0); case/allpairsP=> [[x1 x2] [I1 I2 ->]]. +by apply Ha; apply: vbasis_mem. +Qed. + +Lemma eprod0v: left_zero 0%VS eprodv. +Proof. +move=> vs; apply subv_anti; rewrite sub0v andbT. +apply/eprodvP=> a b; case/vlineP=> k1 -> Hb. +by rewrite scaler0 rmul0 mem0v. +Qed. + +Lemma eprodv0 : forall vs, (vs :* 0 = 0)%VS. +Proof. +move=> vs; apply subv_anti; rewrite sub0v andbT. +apply/eprodvP=> a b Ha; case/vlineP=> k1 ->. +by rewrite scaler0 linear0 mem0v. +Qed. + +Lemma eprodv1 : forall vs, (vs :* 1 = vs)%VS. +Proof. +case: (vbasis1 A) => k Hk He /=. +move=> vs; apply subv_anti; apply/andP; split. + apply/eprodvP=> a b Ha; case/vlineP=> k1 ->. + by rewrite linearZ /= rmul1 memvZ. +apply/subvP=> v Hv. +rewrite (coord_vbasis Hv); apply: memv_suml=> [] [i Hi] _ /=. +apply: memvZ. +rewrite -[_`_i]rmul1; apply: memv_eprod; last by apply: memv_line. +by apply: vbasis_mem; apply: mem_nth; rewrite size_tuple. +Qed. + +Lemma eprodvSl ws vs1 vs2 : (vs1 <= vs2 -> vs1 :* ws <= vs2 :* ws)%VS. +Proof. +move=> Hvs; apply/eprodvP=> a b Ha Hb; apply: memv_eprod=> //. +by apply: subv_trans Hvs. +Qed. + +Lemma eprodvSr vs ws1 ws2 : (ws1 <= ws2 -> vs :* ws1 <= vs :* ws2)%VS. +Proof. +move=> Hvs; apply/eprodvP=> a b Ha Hb; apply: memv_eprod=> //. +by apply: subv_trans Hvs. +Qed. + +Lemma eprodv_addl: left_distributive eprodv addv. +Proof. +move=> vs1 vs2 ws; apply subv_anti; apply/andP; split. + apply/eprodvP=> a b;case/memv_addP=> v1 Hv1 [v2 Hv2 ->] Hb. + by rewrite rmulD; apply: memv_add; apply: memv_eprod. +apply/subvP=> v; case/memv_addP=> v1 Hv1 [v2 Hv2 ->]. +apply: memvD. + move: v1 Hv1; apply/subvP; apply: eprodvSl; exact: addvSl. +move: v2 Hv2; apply/subvP; apply: eprodvSl; exact: addvSr. +Qed. + +Lemma eprodv_sumr vs ws1 ws2 : (vs :* (ws1 + ws2) = vs :* ws1 + vs :* ws2)%VS. +Proof. +apply subv_anti; apply/andP; split. + apply/eprodvP=> a b Ha;case/memv_addP=> v1 Hv1 [v2 Hv2 ->]. + by rewrite linearD; apply: memv_add; apply: memv_eprod. +apply/subvP=> v; case/memv_addP=> v1 Hv1 [v2 Hv2 ->]. +apply: memvD. + move: v1 Hv1; apply/subvP; apply: eprodvSr; exact: addvSl. +move: v2 Hv2; apply/subvP; apply: eprodvSr; exact: addvSr. +Qed. + +Definition modv (vs: {vspace M}) (al: {aspace A}) := + (vs :* al <= vs)%VS. + +Lemma mod0v : forall al, modv 0 al. +Proof. by move=> al; rewrite /modv eprod0v subvv. Qed. + +Lemma modv1 : forall vs, modv vs (aspace1 A). +Proof. by move=> vs; rewrite /modv eprodv1 subvv. Qed. + +Lemma modfv : forall al, modv fullv al. +Proof. by move=> al; exact: subvf. Qed. + +Lemma memv_mod_mul : forall ms al m a, + modv ms al -> m \in ms -> a \in al -> m :* a \in ms. +Proof. +move=> ms al m a Hmo Hm Ha; apply: subv_trans Hmo. +by apply: memv_eprod. +Qed. + +Lemma modvD : forall ms1 ms2 al , + modv ms1 al -> modv ms2 al -> modv (ms1 + ms2) al. +Proof. +move=> ms1 ms2 al Hm1 Hm2; rewrite /modv eprodv_addl. +apply: (subv_trans (addvS Hm1 (subvv _))). +exact: (addvS (subvv _) Hm2). +Qed. + +Lemma modv_cap : forall ms1 ms2 al , + modv ms1 al -> modv ms2 al -> modv (ms1:&: ms2) al. +Proof. +move=> ms1 ms2 al Hm1 Hm2. +by rewrite /modv subv_cap; apply/andP; split; + [apply: subv_trans Hm1 | apply: subv_trans Hm2]; + apply: eprodvSl; rewrite (capvSr,capvSl). +Qed. + +Definition irreducible ms al := + [/\ modv ms al, ms != 0%VS & + forall ms1, modv ms1 al -> (ms1 <= ms)%VS -> ms != 0%VS -> ms1 = ms]. + +Definition completely_reducible ms al := + forall ms1, modv ms1 al -> (ms1 <= ms)%VS -> + exists ms2, + [/\ modv ms2 al, (ms1 :&: ms2 = 0)%VS & (ms1 + ms2)%VS = ms]. + +Lemma completely_reducible0 : forall al, completely_reducible 0 al. +Proof. +move=> al ms1 Hms1; rewrite subv0; move/eqP->. +by exists 0%VS; split; [exact: mod0v | exact: cap0v | exact: add0v]. +Qed. + +End AModuleDef. + +Notation "a :* b" := (rmul a b): ring_scope. +Notation "A :* B" := (eprodv A B) : vspace_scope. + +Section HomMorphism. + +Variable (K: fieldType) (A: FalgType K) (M1 M2: amoduleType A). + +Implicit Types ms : {vspace M1}. +Implicit Types f : 'Hom(M1, M2). +Implicit Types al : {aspace A}. + +Definition modf f ms al := + all (fun p => f (p.1 :* p.2) == f p.1 :* p.2) + (allpairs (fun x y => (x,y)) (vbasis ms) (vbasis al)). + +Lemma modfP : forall f ms al, + reflect (forall x v, v \in ms -> x \in al -> f (v :* x) = f v :* x) + (modf f ms al). +Proof. +move=> f ms al; apply: (iffP idP)=> H; last first. + apply/allP=> [] [v x]; case/allpairsP=> [[x1 x2] [I1 I2 ->]]. + by apply/eqP; apply: H; apply: vbasis_mem. +move=> x v Hv Hx; rewrite (coord_vbasis Hv) (coord_vbasis Hx). +rewrite !linear_sum; apply: eq_big=> //= i _. +rewrite !linearZ /=; congr (_ *: _). +rewrite -!rmul_sum linear_sum; apply: eq_big=> //= j _. +rewrite rmulZ !linearZ /= rmulZ; congr (_ *: _). +set x1 := _`_ _; set y1 := _ `_ _. +case: f H => f /=; move/allP; move/(_ (x1,y1))=> HH. +apply/eqP; apply: HH; apply/allpairsP; exists (x1, y1). +by rewrite !mem_nth //= size_tuple. +Qed. + +Lemma modf_zero : forall ms al, modf 0 ms al. +Proof. by move=> ms al; apply/allP=> i _; rewrite !lfunE rmul0. Qed. + +Lemma modf_add : forall f1 f2 ms al, + modf f1 ms al -> modf f2 ms al -> modf (f1 + f2) ms al. +Proof. +move=> f1 f2 ms al Hm1 Hm2; apply/allP=> [] [v x]. +case/allpairsP=> [[x1 x2] [I1 I2 ->]]; rewrite !lfunE rmulD /=. +move/modfP: Hm1->; try apply: vbasis_mem=>//. +by move/modfP: Hm2->; try apply: vbasis_mem. +Qed. + +Lemma modf_scale : forall k f ms al, modf f ms al -> modf (k *: f) ms al. +Proof. +move=> k f ms al Hm; apply/allP=> [] [v x]. +case/allpairsP=> [[x1 x2] [I1 I2 ->]]; rewrite !lfunE rmulZ /=. +by move/modfP: Hm->; try apply: vbasis_mem. +Qed. + +Lemma modv_ker : forall f ms al, + modv ms al -> modf f ms al -> modv (ms :&: lker f) al. +Proof. +move=> f ms al Hmd Hmf; apply/eprodvP=> x v. +rewrite memv_cap !memv_ker. +case/andP=> Hx Hf Hv. +rewrite memv_cap (memv_mod_mul Hmd) // memv_ker. +by move/modfP: Hmf=> ->; rewrite // (eqP Hf) rmul0 eqxx. +Qed. + +Lemma modv_img : forall f ms al, + modv ms al -> modf f ms al -> modv (f @: ms) al. +Proof. +move=> f ms al Hmv Hmf; apply/eprodvP=> v x. +case/memv_imgP=> u Hu -> Hx. +move/modfP: Hmf<-=> //. +apply: memv_img. +by apply: (memv_mod_mul Hmv). +Qed. + +End HomMorphism. + +Section ModuleRepresentation. + +Variable (F: fieldType) (gT: finGroupType) + (G: {group gT}) (M: amoduleType (galg F gT)). +Hypothesis CG: ([char F]^'.-group G)%g. +Implicit Types ms : {vspace M}. + +Let FG := gaspace F G. +Local Notation " g %:FG " := (injG _ g). + +Lemma Maschke : forall ms, modv ms FG -> completely_reducible ms FG. +Proof. +move=> ms Hmv ms1 Hms1 Hsub; rewrite /completely_reducible. +pose act g : 'End(M) := rmorph M (g%:FG). +have actE: forall g v, act g v = v :* g%:FG by done. +pose f: 'End(M) := #|G|%:R^-1 *: + \sum_(i in G) (act (i^-1)%g \o projv ms1 \o act i)%VF. +have Cf: forall v x, x \in FG -> f (v :* x) = f v :* x. + move=> v x; case/memv_sumP=> g_ Hg_ ->. + rewrite !linear_sum; apply: eq_big => //= i Hi. + move: (Hg_ _ Hi); case/vlineP=> k ->. + rewrite !linearZ /=; congr (_ *: _). + rewrite /f /= !lfunE /= !sum_lfunE rmulZ /=; congr (_ *: _). + rewrite -rmul_sum (reindex (fun g => (i^-1 * g)%g)); last first. + by exists (fun g => (i * g)%g)=> h; rewrite mulgA (mulVg, mulgV) mul1g. + apply: eq_big=> g; first by rewrite groupMl // groupV. + rewrite !lfunE /= !lfunE /= !actE -rmulA=> Hig. + have Hg: g \in G by rewrite -[g]mul1g -[1%g](mulgV i) -mulgA groupM. + by rewrite -injGM // mulgA mulgV mul1g invMg invgK !injGM + ?groupV // rmulA. +have Himf: forall v, v \in ms1 -> f v = v. + move=> v Hv. + rewrite /f !lfunE /= sum_lfunE (eq_bigr (fun x => v)); last move=> i Hi. + by rewrite sumr_const -scaler_nat scalerA mulVf // ?scale1r // -?charf'_nat. + rewrite !lfunE /= !lfunE /= projv_id !actE; last first. + by rewrite (memv_mod_mul Hms1) //= /gvspace (bigD1 i) // memvE addvSl. + by rewrite -rmulA -injGM // ?groupV // mulgV rmul1. +have If: limg f = ms1. + apply: subv_anti; apply/andP; split; last first. + by apply/subvP=> v Hv; rewrite -(Himf _ Hv) memv_img // memvf. + apply/subvP=> i; case/memv_imgP=> x _ ->. + rewrite !lfunE memvZ //= sum_lfunE memv_suml=> // j Hj. + rewrite lfunE /= lfunE (memv_mod_mul Hms1) //; first by exact: memv_proj. + by rewrite memvE /= /gvspace (bigD1 (j^-1)%g) ?addvSl // groupV. +exists (ms :&: lker f)%VS; split. + - apply: modv_ker=> //; apply/modfP=> *; exact: Cf. + apply/eqP; rewrite -subv0; apply/subvP=> v; rewrite memv0. + rewrite !memv_cap; case/andP=> Hv1; case/andP=> Hv2 Hv3. + by move: Hv3; rewrite memv_ker Himf. +apply: subv_anti; rewrite subv_add Hsub capvSl. +apply/subvP=> v Hv. +have->: v = f v + (v - f v) by rewrite addrC -addrA addNr addr0. +apply: memv_add; first by rewrite -If memv_img // memvf. +rewrite memv_cap; apply/andP; split. + apply: memvB=> //; apply: subv_trans Hsub. + by rewrite -If; apply: memv_img; exact: memvf. +rewrite memv_ker linearB /= (Himf (f v)) ?subrr // /in_mem /= -If. +by apply: memv_img; exact: memvf. +Qed. + +End ModuleRepresentation. + +Export AModuleType.Exports. diff --git a/mathcomp/attic/fib.v b/mathcomp/attic/fib.v new file mode 100644 index 0000000..e002a72 --- /dev/null +++ b/mathcomp/attic/fib.v @@ -0,0 +1,340 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype. +Require Import bigop div prime finfun tuple ssralg zmodp matrix binomial. + +(*****************************************************************************) +(* This files contains the definitions of: *) +(* fib n == n.+1 th fibonacci number *) +(* *) +(* lucas n == n.+1 lucas number *) +(* *) +(* and some of their standard properties *) +(*****************************************************************************) + +Fixpoint fib_rec (n : nat) {struct n} : nat := + if n is n1.+1 then + if n1 is n2.+1 then fib_rec n1 + fib_rec n2 + else 1 + else 0. + +Definition fib := nosimpl fib_rec. + +Lemma fibE : fib = fib_rec. +Proof. by []. Qed. + +Lemma fib0 : fib 0 = 0. +Proof. by []. Qed. + +Lemma fib1 : fib 1 = 1. +Proof. by []. Qed. + +Lemma fibSS : forall n, fib n.+2 = fib n.+1 + fib n. +Proof. by []. Qed. + +Fixpoint lin_fib_rec (a b n : nat) {struct n} : nat := + if n is n1.+1 then + if n1 is n2.+1 + then lin_fib_rec b (b + a) n1 + else b + else a. + +Definition lin_fib := nosimpl lin_fib_rec. + +Lemma lin_fibE : lin_fib = lin_fib_rec. +Proof. by []. Qed. + +Lemma lin_fib0 : forall a b, lin_fib a b 0 = a. +Proof. by []. Qed. + +Lemma lin_fib1 : forall a b, lin_fib a b 1 = b. +Proof. by []. Qed. + +Lemma lin_fibSS : forall a b n, lin_fib a b n.+2 = lin_fib b (b + a) n.+1. +Proof. by []. Qed. + +Lemma lin_fib_alt : forall n a b, + lin_fib a b n.+2 = lin_fib a b n.+1 + lin_fib a b n. +Proof. +case=>//; elim => [//|n IHn] a b. +by rewrite lin_fibSS (IHn b (b + a)) lin_fibE. +Qed. + +Lemma fib_is_linear : fib =1 lin_fib 0 1. +Proof. +move=>n; elim: n {-2}n (leqnn n)=> [n|n IHn]. + by rewrite leqn0; move/eqP=>->. +case=>//; case=>// n0; rewrite ltnS=> ltn0n; rewrite fibSS lin_fib_alt. +by rewrite (IHn _ ltn0n) (IHn _ (ltnW ltn0n)). +Qed. + +Lemma fib_add : forall m n, + m != 0 -> fib (m + n) = fib m.-1 * fib n + fib m * fib n.+1. +Proof. +move=> m; elim: m {-2}m (leqnn m)=> [[] // _ |m IH]. +move=> m1; rewrite leq_eqVlt; case/orP=> [|Hm]; last first. + by apply: IH; rewrite -ltnS. +move/eqP->; case: m IH=> [|[|m]] IH n _. +- by case: n=> [|n] //; rewrite fibSS mul1n. +- by rewrite add2n fibSS addnC !mul1n. +rewrite 2!addSn fibSS -addSn !IH // addnA [fib _ * _ + _ + _]addnAC. +by rewrite -addnA -!mulnDl -!fibSS. +Qed. + +Theorem dvdn_fib: forall m n, m %| n -> fib m %| fib n. +Proof. +move=> m n; case/dvdnP=> n1 ->. +elim: {n}n1 m=> [|m IH] // [|n]; first by rewrite muln0. +by rewrite mulSn fib_add // dvdn_add //; [apply dvdn_mull | apply dvdn_mulr]. +Qed. + +Lemma fib_gt0 : forall m, 0 < m -> 0 < fib m. +Proof. +by elim=> [|[|m] IH _] //; rewrite fibSS addn_gt0 IH. +Qed. + +Lemma fib_smonotone : forall m n, 1 < m < n -> fib m < fib n. +Proof. +move=> m n; elim: n=> [|[|n] IH]; first by rewrite andbF. + by rewrite ltnNge leq_eqVlt orbC andbC; case: leq. +rewrite fibSS andbC; case/andP; rewrite leq_eqVlt; case/orP. + by rewrite eqSS; move/eqP=> -> H1m; rewrite -addn1 leq_add // fib_gt0. +by move=> H1m H2m; apply: ltn_addr; apply: IH; rewrite // H2m. +Qed. + +Lemma fib_monotone : forall m n, m <= n -> fib m <= fib n. +Proof. +move=> m n; elim: n=> [|[|n] IH]; first by case: m. + by case: m{IH}=> [|[]]. +rewrite fibSS leq_eqVlt; case/orP=>[|Hm]; first by move/eqP->. +by apply: (leq_trans (IH _)) => //; exact: leq_addr. +Qed. + +Lemma fib_eq1 : forall n, (fib n == 1) = ((n == 1) || (n == 2)). +Proof. +case=> [|[|[|n]]] //; case: eqP=> // Hm; have: 1 < 2 < n.+3 by []. +by move/fib_smonotone; rewrite Hm. +Qed. + +Lemma fib_eq : forall m n, + (fib m == fib n) = [|| m == n, (m == 1) && (n == 2) | (m == 2) && (n == 1)]. +Proof. +move=> m n; wlog: m n/ m <= n=> [HH|]. + case/orP: (leq_total m n)=> Hm; first by exact: HH. + by rewrite eq_sym HH // eq_sym ![(_ == 1) && _]andbC [(_ && _) || _] orbC. +rewrite leq_eqVlt; case/orP=>[|]; first by move/eqP->; rewrite !eqxx. +case: m=> [|[|m]] Hm. +- by move: (fib_gt0 _ Hm); rewrite orbF [0 == _]eq_sym !eqn0Ngt Hm; + case: (fib n). +- by rewrite eq_sym fib_eq1 orbF [1==_]eq_sym; case: eqP. +have: 1 < m.+2 < n by []. +move/fib_smonotone; rewrite ltn_neqAle; case/andP; move/negPf=> -> _. +case: n Hm=> [|[|n]] //;rewrite ltn_neqAle; case/andP; move/negPf=> ->. +by rewrite andbF. +Qed. + +Lemma fib_prime : forall p, p != 4 -> prime (fib p) -> prime p. +Proof. +move=> p Dp4 Pp. +apply/primeP; split; first by case: (p) Pp => [|[]]. +move=> d; case/dvdnP=> k Hp. +have F: forall u, (fib u == 1) = ((u == 1) || (u == 2)). + case=> [|[|[|n]]] //; case: eqP=> // Hm; have: 1 < 2 < n.+3 by []. + by move/fib_smonotone; rewrite Hm. +case/primeP: (Pp); rewrite Hp => _ Hf. +case/orP: (Hf _ (dvdn_fib _ _ (dvdn_mulr d (dvdnn k)))). + rewrite fib_eq1; case/orP; first by move/eqP->; rewrite mul1n eqxx orbT. + move/eqP=> Hk. + case/orP: (Hf _ (dvdn_fib _ _ (dvdn_mull k (dvdnn d)))). + rewrite fib_eq1; case/orP; first by move->. + by move/eqP=>Hd; case/negP: Dp4; rewrite Hp Hd Hk. + rewrite fib_eq; case/or3P; first by move/eqP<-; rewrite eqxx orbT. + by case/andP=>->. + by rewrite Hk; case: (d)=> [|[|[|]]]. +rewrite fib_eq; case/or3P; last by case/andP;move/eqP->; case: (d)=> [|[|]]. + rewrite -{1}[k]muln1; rewrite eqn_mul2l; case/orP; move/eqP=> HH. + by move: Pp; rewrite Hp HH. + by rewrite -HH eqxx. +by case/andP; move/eqP->; rewrite mul1n eqxx orbT. +Qed. + +Lemma fib_sub : forall m n, n <= m -> + fib (m - n) = if odd n then fib m.+1 * fib n - fib m * fib n.+1 + else fib m * fib n.+1 - fib m.+1 * fib n. +Proof. +elim=> [|m IH]; first by case=> /=. +case=> [|n Hn]; first by rewrite muln0 muln1 !subn0. +by rewrite -{2}[n.+1]add1n odd_add (addTb (odd n)) subSS IH //; case: odd; + rewrite !fibSS !mulnDr !mulnDl !subnDA !addKn. +Qed. + +Lemma gcdn_fib: forall m n, gcdn (fib m) (fib n) = fib (gcdn m n). +Proof. +move=> m n; apply: gcdn_def. +- by apply: dvdn_fib; exact: dvdn_gcdl. +- by apply: dvdn_fib; exact: dvdn_gcdr. +move=> d' Hdm Hdn. +case: m Hdm=> [|m Hdm]; first by rewrite gcdnE eqxx. +have F: 0 < m.+1 by []. +case: (egcdnP n F)=> km kn Hg Hl. +have->: gcdn m.+1 n = km * m.+1 - kn * n by rewrite Hg addKn. +rewrite fib_sub; last by rewrite Hg leq_addr. +by case: odd; apply: dvdn_sub; + try (by apply: (dvdn_trans Hdn); apply: dvdn_mull; + apply: dvdn_fib; apply: dvdn_mull); + apply: (dvdn_trans Hdm); apply: dvdn_mulr; + apply: dvdn_fib; apply: dvdn_mull. +Qed. + +Lemma coprimeSn_fib: forall n, coprime (fib n.+1) (fib n). +Proof. +by move=> n; move: (coprimeSn n); rewrite /coprime gcdn_fib; move/eqP->. +Qed. + +Fixpoint lucas_rec (n : nat) {struct n} : nat := + if n is n1.+1 then + if n1 is n2.+1 then lucas_rec n1 + lucas_rec n2 + else 1 + else 2. + +Definition lucas := nosimpl lucas_rec. + +Lemma lucasE : lucas = lucas_rec. +Proof. by []. Qed. + +Lemma lucas0 : lucas 0 = 2. +Proof. by []. Qed. + +Lemma lucas1 : lucas 1 = 1. +Proof. by []. Qed. + +Lemma lucasSS : forall n, lucas n.+2 = lucas n.+1 + lucas n. +Proof. by []. Qed. + +Lemma lucas_is_linear : lucas =1 lin_fib 2 1. +Proof. +move=>n; elim: n {-2}n (leqnn n)=> [n|n IHn]. + by rewrite leqn0; move/eqP=>->. +case=>//; case=>// n0; rewrite ltnS=> ltn0n; rewrite lucasSS lin_fib_alt. +by rewrite (IHn _ ltn0n) (IHn _ (ltnW ltn0n)). +Qed. + +Lemma lucas_fib: forall n, n != 0 -> lucas n = fib n.+1 + fib n.-1. +Proof. +move=> n; elim: n {-2}n (leqnn n)=> [[] // _ |n IH]. +move=> n1; rewrite leq_eqVlt; case/orP=> [|Hn1]; last first. + by apply: IH; rewrite -ltnS. +move/eqP->; case: n IH=> [|[|n] IH _] //. +by rewrite lucasSS !IH // addnCA -addnA -fibSS addnC. +Qed. + +Lemma lucas_gt0 : forall m, 0 < lucas m. +Proof. +by elim=> [|[|m] IH] //; rewrite lucasSS addn_gt0 IH. +Qed. + +Lemma double_lucas: forall n, 3 <= n -> (lucas n).*2 = fib (n.+3) + fib (n-3). +Proof. +case=> [|[|[|n]]] // _; rewrite !subSS subn0. +apply/eqP; rewrite -(eqn_add2l (lucas n.+4)) {2}lucasSS addnC -addnn. +rewrite -2![lucas _ + _ + _]addnA eqn_add2l addnC -lucasSS. +rewrite !lucas_fib // [_ + (_ + _)]addnC -[fib _ + _ + _]addnA eqn_add2l. +by rewrite [_ + (_ + _)]addnC -addnA -fibSS. +Qed. + +Lemma fib_double_lucas : forall n, fib (n.*2) = fib n * lucas n. +Proof. +case=> [|n]; rewrite // -addnn fib_add // lucas_fib // mulnDr addnC. +by apply/eqP; rewrite eqn_add2l mulnC. +Qed. + +Lemma fib_doubleS: forall n, fib (n.*2.+1) = fib n.+1 ^ 2 + fib n ^ 2. +Proof. +by move=> n; rewrite -addnn -addSn fib_add // addnC. +Qed. + +Lemma fib_square: forall n, (fib n)^2 = if odd n then (fib n.+1 * fib n.-1).+1 + else (fib n.+1 * fib n.-1).-1. +Proof. +case=> [|n] //; move: (fib_sub (n.+1) n (leqnSn _)). +rewrite subSn // subnn fib1 -{8}[n.+1]add1n odd_add addTb. +case: odd=> H1; last first. + by rewrite -[(_ * _).+1]addn1 {2}H1 addnC subnK // ltnW // -subn_gt0 -H1. +by apply/eqP; rewrite -subn1 {2}H1 subKn // ltnW // -subn_gt0 -H1. +Qed. + +Lemma fib_sum : forall n, \sum_(i < n) fib i = (fib n.+1).-1. +Proof. +elim=> [|n IH]; first by rewrite big_ord0. +by rewrite big_ord_recr /= IH fibSS; case: fib (fib_gt0 _ (ltn0Sn n)). +Qed. + +Lemma fib_sum_even : forall n, \sum_(i < n) fib i.*2 = (fib n.*2.-1).-1. +Proof. +elim=> [|n IH]; first by rewrite big_ord0. +rewrite big_ord_recr IH; case: (n)=> [|n1] //. +rewrite (fibSS (n1.*2.+1)) addnC -[(n1.+1).*2.-1]/n1.*2.+1. +by case: fib (fib_gt0 _ (ltn0Sn ((n1.*2)))). +Qed. + +Lemma fib_sum_odd: forall n, \sum_(i < n) fib i.*2.+1 = fib n.*2. +Proof. +elim=> [|n IH]; first by rewrite big_ord0. +by rewrite big_ord_recr IH /= addnC -fibSS. +Qed. + +Lemma fib_sum_square: forall n, \sum_(i < n) (fib i)^2 = fib n * fib n.-1. +Proof. +elim=> [|n IH]; first by rewrite big_ord0. +rewrite big_ord_recr /= IH. +by rewrite -mulnDr addnC; case: (n)=> // n1; rewrite -fibSS mulnC. +Qed. + +Lemma bin_sum_diag: forall n, \sum_(i < n) 'C(n.-1-i,i) = fib n. +Proof. +move=> n; elim: n {-2}n (leqnn n)=> [[] // _ |n IH]; first by rewrite big_ord0. +move=> n1; rewrite leq_eqVlt; case/orP=> [|Hn]; last first. + by apply: IH; rewrite -ltnS. +move/eqP->; case: n IH=> [|[|n]] IH. +- by rewrite big_ord_recr big_ord0. +- by rewrite !big_ord_recr big_ord0. +rewrite fibSS -!IH // big_ord_recl bin0 big_ord_recr /= subnn bin0n addn0. +set ss := \sum_(i < _) _. +rewrite big_ord_recl bin0 -addnA -big_split; congr (_ + _). +by apply eq_bigr=> i _ /=; rewrite -binS subSn //; case: i. +Qed. + + +(* The matrix *) + +Section Matrix. + +Open Local Scope ring_scope. +Import GRing.Theory. + +Variable R: ringType. + +(* Equivalence ^ n.+1 *) +(* fib n.+2 fib n.+1 1 1 *) +(* = *) +(* fib n.+1 fib n 1 0 *) + +Definition seq2matrix m n (l: seq (seq R)) := + \matrix_(i 'M[R]_(2,2). +Proof. +elim=> [|n IH]. + by apply/matrixP=> [[[|[|]] // _] [[|[|]] // _]]; rewrite !mxE. +rewrite exprS -IH; apply/matrixP=> i j. +by rewrite !mxE !big_ord_recl big_ord0 !mxE; + case: i=> [[|[|]]] //= _; case: j=> [[|[|]]] //= _; + rewrite !mul1r ?mul0r !addr0 // fibSS natrD. +Qed. + +End Matrix. diff --git a/mathcomp/attic/forms.v b/mathcomp/attic/forms.v new file mode 100644 index 0000000..1c88af5 --- /dev/null +++ b/mathcomp/attic/forms.v @@ -0,0 +1,193 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype bigop. +Require Import finfun tuple ssralg matrix zmodp vector. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. +Open Local Scope ring_scope. + +Import GRing.Theory. + +Section RingLmodule. + +Variable (R : fieldType). + +Definition r2rv x: 'rV[R^o]_1 := \row_(i < 1) x . + +Lemma r2rv_morph_p : linear r2rv. +Proof. by move=> k x y; apply/matrixP=> [] [[|i] Hi] j;rewrite !mxE. Qed. + +Canonical Structure r2rv_morph := Linear r2rv_morph_p. + +Definition rv2r (A: 'rV[R]_1): R^o := A 0 0. + +Lemma r2rv_bij : bijective r2rv. +Proof. +exists rv2r; first by move => x; rewrite /r2rv /rv2r /= mxE. +by move => x; apply/matrixP=> i j; rewrite [i]ord1 [j]ord1 /r2rv /rv2r !mxE /=. +Qed. + +Canonical Structure RVMixin := Eval hnf in VectMixin r2rv_morph_p r2rv_bij. +Canonical Structure RVVectType := VectType R RVMixin. + +Lemma dimR : vdim RVVectType = 1%nat. +Proof. by rewrite /vdim /=. Qed. + +End RingLmodule. + +(* BiLinear & Sesquilinear & Quadratic Forms over a vectType *) +Section LinearForm. + +Variable (F : fieldType) (V : vectType F). + +Section SesquiLinearFormDef. + +Structure fautomorphism:= FautoMorph {fval :> F -> F; + _ : rmorphism fval; + _ : bijective fval}. +Variable theta: fautomorphism. + +Lemma fval_rmorph : rmorphism theta. +Proof. by case: theta. Qed. + +Canonical Structure fautomorh_additive := Additive fval_rmorph. +Canonical Structure fautomorph_rmorphism := RMorphism fval_rmorph. + +Local Notation vvf:= (V -> V -> F). + +Structure sesquilinear_form := + SesqlinearForm {formv :> vvf; + _ : forall x, {morph formv x : y z / y + z}; + _ : forall x, {morph formv ^~ x : y z / y + z}; + _ : forall a x y, formv (a *: x) y = a * formv x y; + _ : forall a x y , formv x (a *: y) = (theta a) * (formv x y)}. + +Variable f : sesquilinear_form. + +Lemma bilin1 : forall x, {morph f x : y z / y + z}. Proof. by case f. Qed. +Lemma bilin2 : forall x, {morph f ^~ x : y z / y + z}. Proof. by case f. Qed. +Lemma bilina1 : forall a x y, f (a *: x) y = a * f x y. Proof. by case f. Qed. +Lemma bilina2 : forall a x y, f x (a *: y) = (theta a) * (f x y). +Proof. by case f. Qed. + +End SesquiLinearFormDef. + +Section SesquiLinearFormTheory. + +Variable theta: fautomorphism. +Local Notation sqlf := (sesquilinear_form theta). + +Definition symmetric (f : sqlf):= (forall a, (theta a = a)) /\ + forall x y, (f x y = f y x). +Definition skewsymmetric (f : sqlf) := (forall a , theta a = a) /\ + forall x y, f x y = -(f y x). + +Definition hermitian_sym (f : sqlf) := (forall x y, f x y = (theta (f y x))). + +Inductive symmetricf (f : sqlf): Prop := + Symmetric : symmetric f -> symmetricf f +| Skewsymmetric: skewsymmetric f -> symmetricf f +| Hermitian_sym : hermitian_sym f -> symmetricf f . + +Lemma fsym_f0: forall (f: sqlf) x y, (symmetricf f) -> + (f x y = 0 <-> f y x = 0). +Proof. +move => f x y ;case; first by move=> [Htheta Hf];split; rewrite Hf. + by move=> [Htheta Hf];split; rewrite Hf; move/eqP;rewrite oppr_eq0; move/eqP->. +move=> Htheta;split; first by rewrite (Htheta y x) => ->; rewrite rmorph0. +by rewrite (Htheta x y) => ->; rewrite rmorph0. +Qed. + +End SesquiLinearFormTheory. + +Variable theta: fautomorphism. +Variable f: (sesquilinear_form theta). +Hypothesis fsym: symmetricf f. + +Section orthogonal. + +Definition orthogonal x y := f x y = 0. + +Lemma ortho_sym: forall x y, orthogonal x y <-> orthogonal y x. +Proof. by move=> x y; apply:fsym_f0. Qed. + +Theorem Pythagore: forall u v, orthogonal u v -> f (u+v) (u+v) = f u u + f v v. +Proof. +move => u v Huv; case:(ortho_sym u v ) => Hvu _. +by rewrite !bilin1 !bilin2 Huv (Hvu Huv) add0r addr0. +Qed. + +Lemma orthoD : forall u v w , orthogonal u v -> orthogonal u w -> orthogonal u (v + w). +Proof. +by move => u v w Huv Huw; rewrite /orthogonal bilin1 Huv Huw add0r. +Qed. + +Lemma orthoZ: forall u v a, orthogonal u v -> orthogonal (a *: u) v. +Proof. by move => u v a Huv; rewrite /orthogonal bilina1 Huv mulr0. Qed. + +Variable x:V. + +Definition alpha : V-> (RVVectType F) := fun y => f y x. + +Definition alpha_lfun := (lfun_of_fun alpha). + +Definition xbar := lker alpha_lfun . + +Lemma alpha_lin: linear alpha. +Proof. by move => a b c; rewrite /alpha bilin2 bilina1. Qed. + + + +Lemma xbarP: forall e1, reflect (orthogonal e1 x ) (e1 \in xbar). +move=> e1; rewrite memv_ker lfun_of_funK //=. + by apply: (iffP eqP). +by apply alpha_lin. +Qed. + + +Lemma dim_xbar :forall vs,(\dim vs ) - 1 <= \dim (vs :&: xbar). +Proof. +move=> vs; rewrite -(addKn 1 (\dim (vs :&: xbar))) addnC leq_sub2r //. +have H :\dim (alpha_lfun @: vs )<= 1 by rewrite -(dimR F) -dimvf dimvS // subvf. +by rewrite -(limg_ker_dim alpha_lfun vs)(leq_add (leqnn (\dim(vs :&: xbar)))). +Qed. + +(* to be improved*) +Lemma xbar_eqvs: forall vs, (forall v , v \in vs -> orthogonal v x )-> \dim (vs :&: xbar)= (\dim vs ). +move=> vs Hvs. +rewrite -(limg_ker_dim alpha_lfun vs). +suff-> : \dim (alpha_lfun @: vs) = 0%nat by rewrite addn0. +apply/eqP; rewrite dimv_eq0; apply /vspaceP => w. +rewrite memv0;apply/memv_imgP. +case e: (w==0). + exists 0; split ;first by rewrite mem0v. + apply sym_eq; rewrite (eqP e). + rewrite (lfun_of_funK alpha_lin 0). + rewrite /alpha_lfun /alpha /=. + by move:(bilina1 f 0 x x); rewrite scale0r mul0r. +move/eqP:e =>H2;case=> x0 [Hx0 Hw]. +apply H2;rewrite Hw;move: (Hvs x0 Hx0). +rewrite /orthogonal. +by rewrite (lfun_of_funK alpha_lin x0). +Qed. + + +End orthogonal. + +Definition quadraticf (Q: V -> F) := + (forall x a, Q (a *: x) = a ^+ 2 * (Q x))%R * + (forall x y, Q (x + y) = Q x + Q y + f x y)%R : Prop. +Variable Q : V -> F. +Hypothesis quadQ : quadraticf Q. +Import GRing.Theory. + + +Lemma f2Q: forall x, Q x + Q x = f x x. +Proof. +move=> x; apply:(@addrI _ (Q x + Q x)). +rewrite !addrA -quadQ -[x + x](scaler_nat 2) quadQ. +by rewrite -mulrA !mulr_natl -addrA. +Qed. + +End LinearForm. diff --git a/mathcomp/attic/galgebra.v b/mathcomp/attic/galgebra.v new file mode 100644 index 0000000..411fb6a --- /dev/null +++ b/mathcomp/attic/galgebra.v @@ -0,0 +1,227 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype finfun. +Require Import bigop finset ssralg fingroup zmodp matrix vector falgebra. + +(*****************************************************************************) +(* * Finite Group as an algebra *) +(* (galg F gT) == the algebra generated by gT on F *) +(*****************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Reserved Notation "g %:FG" + (at level 2, left associativity, format "g %:FG"). + +Open Local Scope ring_scope. +Import GRing.Theory. + +Section GroupAlgebraDef. +Variables (F : fieldType) (gT : finGroupType). + +Inductive galg : predArgType := GAlg of {ffun gT -> F}. + +Definition galg_val A := let: GAlg f := A in f. + +Canonical galg_subType := Eval hnf in [newType for galg_val]. +Definition galg_eqMixin := Eval hnf in [eqMixin of galg by <:]. +Canonical galg_eqType := Eval hnf in EqType galg galg_eqMixin. +Definition galg_choiceMixin := [choiceMixin of galg by <:]. +Canonical galg_choiceType := Eval hnf in ChoiceType galg galg_choiceMixin. + +Definition fun_of_galg A (i : gT) := galg_val A i. + +Coercion fun_of_galg : galg >-> Funclass. + +Lemma galgE : forall f, GAlg (finfun f) =1 f. +Proof. by move=> f i; rewrite /fun_of_galg ffunE. Qed. + +Definition injG (g : gT) := GAlg ([ffun k => (k == g)%:R]). +Notation Local "g %:FG" := (injG g). + +Implicit Types v: galg. + +Definition g0 := GAlg 0. +Definition g1 := 1%g %:FG. +Definition opprg v := GAlg (-galg_val v). +Definition addrg v1 v2 := GAlg (galg_val v1 + galg_val v2). +Definition mulvg a v := GAlg ([ffun k => a * galg_val v k]). +Definition mulrg v1 v2 := + GAlg ([ffun g => \sum_(k : gT) (v1 k) * (v2 ((k^-1) * g)%g)]). + +Lemma addrgA : associative addrg. +Proof. +by move=> *; apply: val_inj; apply/ffunP=> ?; rewrite !ffunE addrA. +Qed. +Lemma addrgC : commutative addrg. +Proof. +by move=> *; apply: val_inj; apply/ffunP=> ?; rewrite !ffunE addrC. +Qed. +Lemma addr0g : left_id g0 addrg. +Proof. +by move=> *; apply: val_inj; apply/ffunP=> ?; rewrite !ffunE add0r. +Qed. +Lemma addrNg : left_inverse g0 opprg addrg. +Proof. +by move=> *; apply: val_inj; apply/ffunP=> ?; rewrite !ffunE addNr. +Qed. + +(* abelian group structure *) +Definition gAlgZmodMixin := ZmodMixin addrgA addrgC addr0g addrNg. +Canonical Structure gAlgZmodType := + Eval hnf in ZmodType galg gAlgZmodMixin. + +Lemma GAlg_morph : {morph GAlg: x y / x + y}. +Proof. by move=> f1 f2; apply/eqP. Qed. + +Lemma mulvgA : forall a b v, mulvg a (mulvg b v) = mulvg (a * b) v. +Proof. +by move=> *; apply: val_inj; apply/ffunP=> g; rewrite !ffunE mulrA. +Qed. + +Lemma mulvg1 : forall v, mulvg 1 v = v. +Proof. by move=> v; apply: val_inj; apply/ffunP=> g; rewrite ffunE mul1r. Qed. + +Lemma mulvg_addr : forall a u v, mulvg a (u + v) = (mulvg a u) + (mulvg a v). +Proof. +by move=> *; apply: val_inj; apply/ffunP=> g; rewrite !ffunE mulrDr. +Qed. + +Lemma mulvg_addl : forall u a b, mulvg (a + b) u = (mulvg a u) + (mulvg b u). +Proof. +by move=> *; apply: val_inj; apply/ffunP=> g; rewrite !ffunE mulrDl. +Qed. + +Definition gAlgLmodMixin := LmodMixin mulvgA mulvg1 mulvg_addr mulvg_addl. +Canonical gAlgLmodType := Eval hnf in LmodType F galg gAlgLmodMixin. + +Lemma sum_fgE : forall I r (P : pred I) (E : I -> galg) i, + (\sum_(k <- r | P k) E k) i = \sum_(k <- r | P k) E k i. +Proof. +move=> I r P E i. +by apply: (big_morph (fun A : galg => A i)) => [A B|]; rewrite galgE. +Qed. + +Lemma mulrgA : associative mulrg. +Proof. +move=> x y z; apply: val_inj; apply/ffunP=> g; rewrite !ffunE; symmetry. +rewrite (eq_bigr (fun k => \sum_i x i * (y (i^-1 * k)%g * z (k^-1 * g)%g))) + => [| *]; last by rewrite galgE big_distrl; apply: eq_bigr => *; rewrite mulrA. +rewrite exchange_big /=. +transitivity (\sum_j x j * \sum_i y (j^-1 * i)%g * z (i^-1 * g)%g). + by apply: eq_bigr => i _; rewrite big_distrr /=. +apply: eq_bigr => i _; rewrite galgE (reindex (fun j => (i * j)%g)); last first. + by exists [eta mulg i^-1] => /= j _; rewrite mulgA 1?mulgV 1?mulVg mul1g. +by congr (_ * _); apply: eq_bigr => *; rewrite mulgA mulVg mul1g invMg mulgA. +Qed. + +Lemma mulr1g : left_id g1 mulrg. +Proof. +move=> x; apply: val_inj; apply/ffunP=> g. +rewrite ffunE (bigD1 1%g) //= galgE eqxx invg1. +by rewrite mul1g mul1r big1 1?addr0 // => i Hi; rewrite galgE (negbTE Hi) mul0r. +Qed. + +Lemma mulrg1 : right_id g1 mulrg. +Proof. +move=> x; apply: val_inj; apply/ffunP=> g. +rewrite ffunE (bigD1 g) //= galgE mulVg eqxx mulr1. +by rewrite big1 1?addr0 // => i Hi; rewrite galgE -eq_mulVg1 (negbTE Hi) mulr0. +Qed. + +Lemma mulrg_addl : left_distributive mulrg addrg. +Proof. +move=> x y z; apply: val_inj; apply/ffunP=> g; rewrite !ffunE -big_split /=. +by apply: eq_bigr => i _; rewrite galgE mulrDl. +Qed. + +Lemma mulrg_addr : right_distributive mulrg addrg. +Proof. +move=> x y z; apply: val_inj; apply/ffunP=> g; rewrite !ffunE -big_split /=. +by apply: eq_bigr => i _; rewrite galgE mulrDr. +Qed. + +Lemma nong0g1 : g1 != 0 :> galg. +Proof. +apply/eqP; case. +move/ffunP; move/(_ 1%g); rewrite !ffunE eqxx. +by move/eqP; rewrite oner_eq0. +Qed. + +Definition gAlgRingMixin := + RingMixin mulrgA mulr1g mulrg1 mulrg_addl mulrg_addr nong0g1. +Canonical gAlgRingType := Eval hnf in RingType galg gAlgRingMixin. + +Implicit Types x y : galg. + +Lemma mulg_mulvl : forall a x y, a *: (x * y) = (a *: x) * y. +Proof. +move=> a x y; apply: val_inj; apply/ffunP=> g. +rewrite !ffunE big_distrr /=. +by apply: eq_bigr => i _; rewrite mulrA galgE. +Qed. + +Lemma mulg_mulvr : forall a x y, a *: (x * y) = x * (a *: y). +Proof. +move=> a x y; apply: val_inj; apply/ffunP=> g. +rewrite !ffunE big_distrr /=. +by apply: eq_bigr => i _; rewrite galgE mulrCA. +Qed. + +Canonical gAlgLalgType := Eval hnf in LalgType F galg mulg_mulvl. +Canonical gAlgAlgType := Eval hnf in AlgType F galg mulg_mulvr. + +Lemma injGM : forall g h, (g * h)%g %:FG = (g %:FG) * (h %:FG). +Proof. +move=> g h; apply: val_inj; apply/ffunP=> k. +rewrite !ffunE (bigD1 g) //= !galgE eqxx mul1r. +rewrite big1 1?addr0 => [| i Hi]; last by rewrite !galgE (negbTE Hi) mul0r. +by rewrite -(inj_eq (mulgI (g^-1)%g)) mulgA mulVg mul1g. +Qed. + +Fact gAlg_iso_vect : Vector.axiom #|gT| galg. +Proof. +exists (fun x => \row_(i < #|gT|) x (enum_val i)) => [k x y | ]. + by apply/rowP=> i; rewrite !mxE !galgE !ffunE. +exists (fun x : 'rV[F]_#|gT| => GAlg ([ffun k => (x 0 (enum_rank k))])) => x. + by apply: val_inj; apply/ffunP=> i; rewrite ffunE mxE enum_rankK. +by apply/rowP=> i; rewrite // !mxE galgE enum_valK. +Qed. + +Definition galg_vectMixin := VectMixin gAlg_iso_vect. +Canonical galg_vectType := VectType F galg galg_vectMixin. + +Canonical galg_unitRingType := FalgUnitRingType galg. +Canonical galg_unitAlgFType := [unitAlgType F of galg]. +Canonical gAlgAlgFType := [FalgType F of galg]. + + +Variable G : {group gT}. + +Definition gvspace: {vspace galg} := (\sum_(g in G) <[g%:FG]>)%VS. + +Fact gspace_subproof : has_algid gvspace && (gvspace * gvspace <= gvspace)%VS. +Proof. +apply/andP; split. + apply: has_algid1. + rewrite /gvspace (bigD1 (1)%g) //=. + apply: subv_trans (addvSl _ _). + by apply/vlineP; exists 1; rewrite scale1r. +apply/prodvP=> u v Hu Hv. +case/memv_sumP: Hu => u_ Hu ->; rewrite big_distrl /=. +apply: memv_suml=> i Hi. +case/memv_sumP: Hv => v_ Hv ->; rewrite big_distrr /=. +apply: memv_suml=> j Hj. +rewrite /gvspace (bigD1 (i*j)%g) /=; last by exact: groupM. +apply: subv_trans (addvSl _ _). +case/vlineP: (Hu _ Hi)=> k ->; case/vlineP: (Hv _ Hj)=> l ->. +apply/vlineP; exists (k * l). +by rewrite -scalerAl -scalerAr scalerA injGM. +Qed. + +Definition gaspace : {aspace galg} := ASpace gspace_subproof. + +End GroupAlgebraDef. + +Notation " g %:FG " := (injG _ g). diff --git a/mathcomp/attic/multinom.v b/mathcomp/attic/multinom.v new file mode 100644 index 0000000..b203381 --- /dev/null +++ b/mathcomp/attic/multinom.v @@ -0,0 +1,438 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype. +Require Import tuple finfun bigop ssralg poly generic_quotient bigenough. + +(* We build the ring of multinomials with an arbitrary (countable) *) +(* number of indeterminates. We show it is a ring when the base field *) +(* is a ring, and a commutative ring when the base field is commutative *) + +(* TODO: + - when the base field is an integral domain, so are multinomials (WIP) + - replace the countable type of indeterminates by an arbitrary choice type + - do the theory of symmetric polynomials +*) + + + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope ring_scope. +Local Open Scope quotient_scope. + +Import GRing.Theory BigEnough. + +Module Multinomial. + +Section Multinomial. + +Variable X : countType. + +Section MultinomialRing. + +Variable R : ringType. + +(* Definining the free algebra of multinomial terms *) +Inductive multi_term := +| Coef of R +| Var of X +| Oper of bool & multi_term & multi_term. + +Notation Sum := (Oper false). +Notation Prod := (Oper true). + +(* Encoding to a tree structure in order to recover equality and choice *) +Fixpoint to_tree m : GenTree.tree (X + R) := +match m with +| Coef x => GenTree.Node 0 [:: GenTree.Leaf (inr _ x)] +| Var x => GenTree.Node 0 [:: GenTree.Leaf (inl _ x)] +| Oper b m1 m2 => GenTree.Node (b.+1) [:: to_tree m1; to_tree m2] +end. + +Fixpoint from_tree t := +match t with +| GenTree.Node 0 [:: GenTree.Leaf (inr x)] => Some (Coef x) +| GenTree.Node 0 [:: GenTree.Leaf (inl x)] => Some (Var x) +| GenTree.Node n.+1 [:: t1; t2] => + if (from_tree t1, from_tree t2) is (Some m1, Some m2) + then Some (Oper (n == 1)%N m1 m2) else None +| _ => None +end. + +Lemma to_treeK : pcancel to_tree from_tree. +Proof. by elim=> //=; case=> ? -> ? ->. Qed. + +Definition multi_term_eqMixin := PcanEqMixin to_treeK. +Canonical multi_term_eqType := EqType multi_term multi_term_eqMixin. +Definition multi_term_choiceMixin := PcanChoiceMixin to_treeK. +Canonical multi_term_choiceType := ChoiceType multi_term multi_term_choiceMixin. + +(* counting the variables, in order to know how to interpret multi_term *) +Fixpoint nbvar_term t := + match t with + | Coef _ => 0%N + | Var x => (pickle x).+1 + | Sum u v => maxn (nbvar_term u) (nbvar_term v) + | Prod u v => maxn (nbvar_term u) (nbvar_term v) + end. + +(* Iterated polynomials over a ring *) +Fixpoint multi n := if n is n.+1 then [ringType of {poly multi n}] else R. + +Fixpoint inject n m (p : multi n) {struct m} : multi (m + n) := + if m is m'.+1 return multi (m + n) then (inject m' p)%:P else p. + +Lemma inject_inj : forall i m, injective (@inject i m). +Proof. by move=> i; elim=> //= m IHm p q; move/polyC_inj; move/IHm. Qed. + +Lemma inject0 : forall i m, @inject i m 0 = 0. +Proof. by move=> i; elim=> //= m ->. Qed. + +Lemma inject_eq0 : forall i m p, (@inject i m p == 0) = (p == 0). +Proof. by move=> i m p; rewrite -(inj_eq (@inject_inj i m)) inject0. Qed. + +Lemma size_inject : forall i m p, size (@inject i m.+1 p) = (p != 0 : nat). +Proof. by move=> i m p; rewrite size_polyC inject_eq0. Qed. + +Definition cast_multi i m n Emn : multi i -> multi n := + let: erefl in _ = n' := Emn return _ -> multi n' in inject m. + +Definition multi_var n (i : 'I_n) := cast_multi (subnK (valP i)) 'X. + +Notation "'X_ i" := (multi_var i). + +Lemma inject_is_rmorphism : forall m n, rmorphism (@inject n m). +Proof. +elim=> // m ihm n /=; have ->: inject m = RMorphism (ihm n) by []. +by rewrite -/(_ \o _); apply: rmorphismP. +Qed. +Canonical inject_rmorphism m n := RMorphism (inject_is_rmorphism m n). +Canonical inject_additive m n := Additive (inject_is_rmorphism m n). + +Lemma cast_multi_is_rmorphism i m n Enm : rmorphism (@cast_multi i m n Enm). +Proof. by case: n / Enm; apply: rmorphismP. Qed. +Canonical cast_multi_rmorphism i m n e := + RMorphism (@cast_multi_is_rmorphism i m n e). +Canonical cast_multi_additive i m n e := + Additive (@cast_multi_is_rmorphism i m n e). + +Definition multiC n : R -> multi n := cast_multi (addn0 n). +Lemma multiC_is_rmorphism n : rmorphism (multiC n). +Proof. by rewrite /multiC -[R]/(multi 0); apply: rmorphismP. Qed. +Canonical multiC_rmorphism n := RMorphism (multiC_is_rmorphism n). +Canonical multiC_additive n := Additive (multiC_is_rmorphism n). + +Lemma cast_multi_inj n i i' n' (m1 m2 : multi n) + (p1: (i + n)%N=n') (p2: (i' + n)%N=n') : + cast_multi p1 m1 == cast_multi p2 m2 = (m1 == m2). +Proof. +have := p2; rewrite -{1}[n']p1; move/eqP; rewrite eqn_add2r. +move=> /eqP /= Eii; move:p2; rewrite Eii=> p2 {Eii}. +have <-: p1 = p2; first exact: nat_irrelevance. +apply/idP/idP; last by move/eqP->. +move => Hm {p2}. +have : inject i m1 = inject i m2; last first. + by move/eqP; rewrite (inj_eq (@inject_inj _ _)). +move: Hm; move:(p1); rewrite -p1 => p2. +rewrite (_ : p2 = erefl (i+n)%N); last exact: nat_irrelevance. +by move/eqP. +Qed. + +Lemma Emj_Enk i j k m n : + forall (Emj : (m + i)%N = j) (Enk : (n + j)%N = k), (n + m + i)%N = k. +Proof. by move<-; rewrite addnA. Qed. + +Lemma cast_multi_id n (e : (0 + n)%N = n) m : cast_multi e m = m. +Proof. by rewrite (_ : e = erefl _) //; apply: nat_irrelevance. Qed. + +Lemma cast_multiS n i n' (m : multi n) + (p: (i + n)%N = n') (pS: ((i.+1) + n)%N = n'.+1) : + (cast_multi pS m) = (cast_multi p m)%:P. +Proof. by case: _ / p in pS *; rewrite [pS](nat_irrelevance _ (erefl _)). Qed. + +Lemma injectnm_cast_multi i m n p : + inject (n + m)%N p = + ((@cast_multi (m + i)%N n ((n + m) + i)%N (addnA _ _ _)) \o (inject m)) p. +Proof. +elim: n => [|n /= -> /=]. + by rewrite [addnA 0%N m i](nat_irrelevance _ (erefl _)). +by rewrite cast_multiS; congr (cast_multi _ _)%:P; apply: nat_irrelevance. +Qed. + +Lemma cast_multi_add i j k m n Emj Enk p : + @cast_multi j n k Enk (@cast_multi i m j Emj p) = + @cast_multi i (n + m)%N k (Emj_Enk Emj Enk) p. +Proof. +move: (Emj) (Enk) (Emj_Enk Emj Enk); rewrite -Enk -Emj. +change (addn_rec n (addn_rec m i)) with (n+m+i)%N. +rewrite {-1}[(n+(m+i))%N]addnA=> Emj0 Enk0 Enmi. +have ->: (Emj0 = erefl (m+i)%N); first exact: nat_irrelevance. +have ->: (Enmi = erefl (n+m+i)%N); first exact: nat_irrelevance. +rewrite /= injectnm_cast_multi /=. +by apply/eqP; rewrite cast_multi_inj. +Qed. + +(* Interpretation of a multi_term in iterated polynomials, + for a given number of variables n *) +Fixpoint interp n m : multi n := + match m with + | Coef x => multiC n x + | Var x => let i := pickle x in + (if i < n as b return (i < n) = b -> multi n + then fun iltn => cast_multi (subnK iltn) 'X_(Ordinal (leqnn i.+1)) + else fun _ => 0) (refl_equal (i < n)) + | Sum p q => interp n p + interp n q + | Prod p q => interp n p * interp n q +end. + +Lemma interp_cast_multi n n' m (nltn' : n <= n') : + nbvar_term m <= n -> interp n' m = cast_multi (subnK nltn') (interp n m). +Proof. +move=> dmltn; have dmltn' := (leq_trans dmltn nltn'). +elim: m nltn' dmltn dmltn'. ++ move=> a /= nltn' dmltn dmltn'. + apply/eqP; rewrite /multiC. + by rewrite cast_multi_add /= cast_multi_inj. ++ move=> N /= nltn' dmltn dmltn'. + move: (refl_equal (_ N < n')) (refl_equal (_ N < n)). + rewrite {2 3}[_ N < n]dmltn {2 3}[_ N < n']dmltn' => Nn' Nn. + by apply/eqP; rewrite cast_multi_add cast_multi_inj. +move=> [] m1 Hm1 m2 Hm2 nltn' /=; +rewrite !geq_max => /andP [dm1n dm1n'] /andP [dm2n dm2n']; +by rewrite (Hm1 nltn') // (Hm2 nltn') // (rmorphM, rmorphD). +Qed. + +(* identification of to multi_terms modulo equality of iterated polynomials *) +Definition equivm m1 m2 := let n := maxn (nbvar_term m1) (nbvar_term m2) in + interp n m1 == interp n m2. + +(* it works even for a bigger n *) +Lemma interp_gtn n m1 m2 : maxn (nbvar_term m1) (nbvar_term m2) <= n -> + equivm m1 m2 = (interp n m1 == interp n m2). +Proof. +move=> hn; rewrite !(interp_cast_multi hn) ?leq_max ?leqnn ?orbT //. +by rewrite cast_multi_inj. +Qed. + +Lemma equivm_refl : reflexive equivm. Proof. by move=> x; rewrite /equivm. Qed. + +Lemma equivm_sym : symmetric equivm. +Proof. by move=> x y; rewrite /equivm eq_sym maxnC. Qed. + +Lemma equivm_trans : transitive equivm. +Proof. +move=> x y z; pose_big_enough n. + by rewrite !(@interp_gtn n) => // /eqP-> /eqP->. +by close. +Qed. + +(* equivm is an equivalence *) +Canonical equivm_equivRel := EquivRel equivm + equivm_refl equivm_sym equivm_trans. + +(* we quotient by the equivalence *) +Definition multinom := {eq_quot equivm}. +Definition multinom_of of phant X & phant R := multinom. + +Local Notation "{ 'multinom' R }" := (multinom_of (Phant X) (Phant R)) + (at level 0, format "{ 'multinom' R }"). +(* We recover a lot of structure *) +Canonical multinom_quotType := [quotType of multinom]. +Canonical multinom_eqType := [eqType of multinom]. +Canonical multinom_eqQuotType := [eqQuotType equivm of multinom]. +Canonical multinom_choiceType := [choiceType of multinom]. +Canonical multinom_of_quotType := [quotType of {multinom R}]. +Canonical multinom_of_eqType := [eqType of {multinom R}]. +Canonical multinom_of_eqQuotType := [eqQuotType equivm of {multinom R}]. +Canonical multinom_of_choiceType := [choiceType of {multinom R}]. + +Lemma eqm_interp n m1 m2 : maxn (nbvar_term m1) (nbvar_term m2) <= n -> + (interp n m1 == interp n m2) = (m1 == m2 %[mod {multinom R}]). +Proof. by move=> hn; rewrite eqmodE /= -interp_gtn. Qed. + +Definition cstm := lift_embed {multinom R} Coef. +Notation "c %:M" := (cstm c) (at level 2, format "c %:M"). +Canonical pi_cstm_morph := PiEmbed cstm. + +Definition varm := lift_embed {multinom R} Var. +Notation "n %:X" := (varm n) (at level 2, format "n %:X"). +Canonical pi_varm_morph := PiEmbed varm. + +(* addition is defined by lifting Sum *) +Definition addm := lift_op2 {multinom R} Sum. +Lemma pi_addm : {morph \pi : x y / Sum x y >-> addm x y}. +Proof. +move=> x y /=; unlock addm; apply/eqmodP => /=. +pose_big_enough n. + rewrite (@interp_gtn n) //=; apply/eqP; congr (_ + _); + by apply/eqP; rewrite eqm_interp // reprK. +by close. +Qed. +Canonical pi_addm_morph := PiMorph2 pi_addm. + +Definition Opp := Prod (Coef (-1)). +Definition oppm := lift_op1 {multinom R} Opp. +Lemma pi_oppm : {morph \pi : x / Opp x >-> oppm x}. +Proof. +move=> x; unlock oppm; apply/eqmodP => /=. +rewrite /equivm /= !max0n; apply/eqP; congr (_ * _). +by apply/eqP; rewrite eqm_interp ?reprK. +Qed. +Canonical pi_oppm_morph := PiMorph1 pi_oppm. + +(* addition is defined by lifting Prod *) +Definition mulm := lift_op2 {multinom R} Prod. +Lemma pi_mulm : {morph \pi : x y / Prod x y >-> mulm x y}. +Proof. +move=> x y; unlock mulm; apply/eqP; set x' := repr _; set y' := repr _. +rewrite -(@eqm_interp (nbvar_term (Sum (Sum x y) (Sum x' y')))) /=. + apply/eqP; congr (_ * _); apply/eqP; + by rewrite eqm_interp ?reprK // !(geq_max, leq_max, leqnn, orbT). +by rewrite maxnC. +Qed. +Canonical pi_mulm_morph := PiMorph2 pi_mulm. + +(* Ring properties are obtained from iterated polynomials *) +Lemma addmA : associative addm. +Proof. +elim/quotW=> x; elim/quotW=> y; elim/quotW=> z; apply/eqP. +by rewrite !piE /equivm /= addrA. +Qed. + +Lemma addmC : commutative addm. +Proof. +by elim/quotW=> x; elim/quotW=> y; apply/eqP; rewrite !piE /equivm /= addrC. +Qed. + +Lemma add0m : left_id 0%:M addm. +Proof. by elim/quotW=> x; apply/eqP; rewrite piE /equivm /= rmorph0 add0r. Qed. + +Lemma addmN : left_inverse 0%:M oppm addm. +Proof. +elim/quotW=> x; apply/eqP; rewrite piE /equivm /=. +by rewrite !rmorph0 rmorphN rmorph1 mulN1r addNr. +Qed. + +Definition multinom_zmodMixin := ZmodMixin addmA addmC add0m addmN. +Canonical multinom_zmodType := ZmodType multinom multinom_zmodMixin. +Canonical multinom_of_zmodType := ZmodType {multinom R} multinom_zmodMixin. + +Lemma mulmA : associative mulm. +Proof. +elim/quotW=> x; elim/quotW=> y; elim/quotW=> z; apply/eqP. +by rewrite piE /equivm /= mulrA. +Qed. + +Lemma mul1m : left_id 1%:M mulm. +Proof. by elim/quotW=> x; apply/eqP; rewrite piE /equivm /= rmorph1 mul1r. Qed. + +Lemma mulm1 : right_id 1%:M mulm. +Proof. +elim/quotW=> x; rewrite !piE /=; apply/eqmodP; rewrite /= /equivm /=. +by rewrite rmorph1 mulr1. +Qed. + +Lemma mulm_addl : left_distributive mulm addm. +Proof. +elim/quotW=> x; elim/quotW=> y; elim/quotW=> z; apply/eqP. +by rewrite !piE /equivm /= mulrDl. +Qed. + +Lemma mulm_addr : right_distributive mulm addm. +Proof. +elim/quotW=> x; elim/quotW=> y; elim/quotW=> z; apply/eqP. +by rewrite !piE /equivm /= mulrDr. +Qed. + +Lemma nonzero1m : 1%:M != 0%:M. +Proof. by rewrite piE /equivm /= rmorph1 rmorph0 oner_neq0. Qed. + +Definition multinom_ringMixin := RingMixin mulmA mul1m mulm1 mulm_addl mulm_addr nonzero1m. +Canonical multinom_ringType := RingType multinom multinom_ringMixin. +Canonical multinom_of_ringType := RingType {multinom R} multinom_ringMixin. + +End MultinomialRing. + +Notation "{ 'multinom' R }" := (@multinom_of _ (Phant X) (Phant R)) + (at level 0, format "{ 'multinom' R }"). + +Notation "c %:M" := (cstm c) (at level 2, format "c %:M"). +Notation "n %:X" := (varm n) (at level 2, format "n %:X"). + +Section MultinomialComRing. + +Variable R : comRingType. + +Lemma mul_multiC n : commutative (@GRing.mul (multi R n)). +Proof. +suff [M IH_CR] : {CR : comRingType | [ringType of CR] = multi R n}. + by case: _ / IH_CR => x y; rewrite mulrC. +elim: n => [|n [CR IH_CR]] //=; first by exists R. +by exists [comRingType of {poly CR}]; rewrite -IH_CR. +Qed. + +Lemma mulmC : commutative (@mulm R). +Proof. +elim/quotW=> x; elim/quotW=> y; apply/eqP. +by rewrite piE /equivm /= mul_multiC. +Qed. + +(* if R is commutative, so is {multinom R} *) +Canonical multinom_comRing := Eval hnf in ComRingType (@multinom R) mulmC. +Canonical multinom_of_comRing := Eval hnf in ComRingType {multinom R} mulmC. + +End MultinomialComRing. + +Section MultinomialIdomain. + +Variable R : idomainType. + +(* if R is an integral domain, {multinom R} should also be one, + but the developpment is unfinished *) +Lemma multi_unitClass n : GRing.UnitRing.class_of (multi R n). +Proof. +suff [D IH_D] : {D : idomainType | [ringType of D] = multi R n}. + by case: _ / IH_D; case: D => [sort [[[rc /= _ um _ _]]]]; exists rc. +elim: n => [|n [D IH_D]] //=; first by exists R. +by exists [idomainType of {poly D}]; case: _ / IH_D. +Qed. + +Canonical multi_unitRing n := GRing.UnitRing.Pack + (multi_unitClass n) (multi R n). + +(* Definition Unit (m : multi_term R) := *) +(* let n := nbvar_term m in interp n m \in GRing.unit. *) +(* Definition unitm := lift_fun1 {multinom R} Unit. *) +(* Lemma pi_unitm : {mono \pi : x / Unit x >-> unitm x}. *) +(* Proof. *) +(* move=> x; unlock unitm; rewrite /Unit /=. *) +(* Admitted. *) +(* Canonical pi_unitm_morph := PiMono1 pi_unitm. *) + +Lemma multi_idomain n : GRing.IntegralDomain.axiom (multi R n). +Proof. +suff [D IH_D] : {D : idomainType | [ringType of D] = multi R n}. + by case: _ / IH_D => x y /eqP; rewrite mulf_eq0. +elim: n => [|n [D IH_D]] //=; first by exists R. +by exists [idomainType of {poly D}]; rewrite -IH_D. +Qed. + +Lemma multinom_idomain : GRing.IntegralDomain.axiom [ringType of multinom R]. +Proof. +elim/quotW=> x; elim/quotW=> y /eqP; rewrite -[_ * _]pi_mulm !piE. +pose_big_enough n. + by rewrite !(@interp_gtn _ n) //= !rmorph0 => /eqP /multi_idomain. +by close. +Qed. + +(* Work in progress *) + +End MultinomialIdomain. + +End Multinomial. +End Multinomial. + + + + diff --git a/mathcomp/attic/mxtens.v b/mathcomp/attic/mxtens.v new file mode 100644 index 0000000..c52039f --- /dev/null +++ b/mathcomp/attic/mxtens.v @@ -0,0 +1,312 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype. +Require Import bigop ssralg matrix zmodp div. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GRing.Theory. +Local Open Scope nat_scope. +Local Open Scope ring_scope. + +Section ExtraBigOp. + +Lemma sumr_add : forall (R : ringType) m n (F : 'I_(m + n) -> R), + \sum_(i < m + n) F i = \sum_(i < m) F (lshift _ i) + + \sum_(i < n) F (rshift _ i). +Proof. +move=> R; elim=> [|m ihm] n F. + rewrite !big_ord0 add0r; apply: congr_big=> // [[i hi]] _. + by rewrite /rshift /=; congr F; apply: val_inj. +rewrite !big_ord_recl ihm -addrA. +congr (_ + _); first by congr F; apply: val_inj. +congr (_ + _); by apply: congr_big=> // i _ /=; congr F; apply: val_inj. +Qed. + +Lemma mxtens_index_proof m n (ij : 'I_m * 'I_n) : ij.1 * n + ij.2 < m * n. +Proof. +case: m ij=> [[[] //]|] m ij; rewrite mulSn addnC -addSn leq_add //. +by rewrite leq_mul2r; case: n ij=> // n ij; rewrite leq_ord orbT. +Qed. + +Definition mxtens_index m n ij := Ordinal (@mxtens_index_proof m n ij). + +Lemma mxtens_index_proof1 m n (k : 'I_(m * n)) : k %/ n < m. +Proof. by move: m n k=> [_ [] //|m] [|n] k; rewrite ?divn0 // ltn_divLR. Qed. +Lemma mxtens_index_proof2 m n (k : 'I_(m * n)) : k %% n < n. +Proof. by rewrite ltn_mod; case: n k=> //; rewrite muln0=> [] []. Qed. + +Definition mxtens_unindex m n k := + (Ordinal (@mxtens_index_proof1 m n k), Ordinal (@mxtens_index_proof2 m n k)). + +Implicit Arguments mxtens_index [[m] [n]]. +Implicit Arguments mxtens_unindex [[m] [n]]. + +Lemma mxtens_indexK m n : cancel (@mxtens_index m n) (@mxtens_unindex m n). +Proof. +case: m=> [[[] //]|m]; case: n=> [[_ [] //]|n]. +move=> [i j]; congr (_, _); apply: val_inj=> /=. + by rewrite divnMDl // divn_small. +by rewrite modnMDl // modn_small. +Qed. + +Lemma mxtens_unindexK m n : cancel (@mxtens_unindex m n) (@mxtens_index m n). +Proof. +case: m=> [[[] //]|m]. case: n=> [|n] k. + by suff: False by []; move: k; rewrite muln0=> [] []. +by apply: val_inj=> /=; rewrite -divn_eq. +Qed. + +CoInductive is_mxtens_index (m n : nat) : 'I_(m * n) -> Type := + IsMxtensIndex : forall (i : 'I_m) (j : 'I_n), + is_mxtens_index (mxtens_index (i, j)). + +Lemma mxtens_indexP (m n : nat) (k : 'I_(m * n)) : is_mxtens_index k. +Proof. by rewrite -[k]mxtens_unindexK; constructor. Qed. + +Lemma mulr_sum (R : ringType) m n (Fm : 'I_m -> R) (Fn : 'I_n -> R) : + (\sum_(i < m) Fm i) * (\sum_(i < n) Fn i) + = \sum_(i < m * n) ((Fm (mxtens_unindex i).1) * (Fn (mxtens_unindex i).2)). +Proof. +rewrite mulr_suml; transitivity (\sum_i (\sum_(j < n) Fm i * Fn j)). + by apply: eq_big=> //= i _; rewrite -mulr_sumr. +rewrite pair_big; apply: reindex=> //=. +by exists mxtens_index=> i; rewrite (mxtens_indexK, mxtens_unindexK). +Qed. + +End ExtraBigOp. + +Section ExtraMx. + +Lemma castmx_mul (R : ringType) + (m m' n p p': nat) (em : m = m') (ep : p = p') + (M : 'M[R]_(m, n)) (N : 'M[R]_(n, p)) : + castmx (em, ep) (M *m N) = castmx (em, erefl _) M *m castmx (erefl _, ep) N. +Proof. by case: m' / em; case: p' / ep. Qed. + +Lemma mulmx_cast (R : ringType) + (m n n' p p' : nat) (en : n' = n) (ep : p' = p) + (M : 'M[R]_(m, n)) (N : 'M[R]_(n', p')) : + M *m (castmx (en, ep) N) = + (castmx (erefl _, (esym en)) M) *m (castmx (erefl _, ep) N). +Proof. by case: n / en in M *; case: p / ep in N *. Qed. + +Lemma castmx_row (R : Type) (m m' n1 n2 n1' n2' : nat) + (eq_n1 : n1 = n1') (eq_n2 : n2 = n2') (eq_n12 : (n1 + n2 = n1' + n2')%N) + (eq_m : m = m') (A1 : 'M[R]_(m, n1)) (A2 : 'M_(m, n2)) : + castmx (eq_m, eq_n12) (row_mx A1 A2) = + row_mx (castmx (eq_m, eq_n1) A1) (castmx (eq_m, eq_n2) A2). +Proof. +case: _ / eq_n1 in eq_n12 *; case: _ / eq_n2 in eq_n12 *. +by case: _ / eq_m; rewrite castmx_id. +Qed. + +Lemma castmx_col (R : Type) (m m' n1 n2 n1' n2' : nat) + (eq_n1 : n1 = n1') (eq_n2 : n2 = n2') (eq_n12 : (n1 + n2 = n1' + n2')%N) + (eq_m : m = m') (A1 : 'M[R]_(n1, m)) (A2 : 'M_(n2, m)) : + castmx (eq_n12, eq_m) (col_mx A1 A2) = + col_mx (castmx (eq_n1, eq_m) A1) (castmx (eq_n2, eq_m) A2). +Proof. +case: _ / eq_n1 in eq_n12 *; case: _ / eq_n2 in eq_n12 *. +by case: _ / eq_m; rewrite castmx_id. +Qed. + +Lemma castmx_block (R : Type) (m1 m1' m2 m2' n1 n2 n1' n2' : nat) + (eq_m1 : m1 = m1') (eq_n1 : n1 = n1') (eq_m2 : m2 = m2') (eq_n2 : n2 = n2') + (eq_m12 : (m1 + m2 = m1' + m2')%N) (eq_n12 : (n1 + n2 = n1' + n2')%N) + (ul : 'M[R]_(m1, n1)) (ur : 'M[R]_(m1, n2)) + (dl : 'M[R]_(m2, n1)) (dr : 'M[R]_(m2, n2)) : + castmx (eq_m12, eq_n12) (block_mx ul ur dl dr) = + block_mx (castmx (eq_m1, eq_n1) ul) (castmx (eq_m1, eq_n2) ur) + (castmx (eq_m2, eq_n1) dl) (castmx (eq_m2, eq_n2) dr). +Proof. +case: _ / eq_m1 in eq_m12 *; case: _ / eq_m2 in eq_m12 *. +case: _ / eq_n1 in eq_n12 *; case: _ / eq_n2 in eq_n12 *. +by rewrite !castmx_id. +Qed. + +End ExtraMx. + +Section MxTens. + +Variable R : ringType. + +Definition tensmx {m n p q : nat} + (A : 'M_(m, n)) (B : 'M_(p, q)) : 'M[R]_(_,_) := nosimpl + (\matrix_(i, j) (A (mxtens_unindex i).1 (mxtens_unindex j).1 + * B (mxtens_unindex i).2 (mxtens_unindex j).2)). + +Notation "A *t B" := (tensmx A B) + (at level 40, left associativity, format "A *t B"). + +Lemma tensmxE {m n p q} (A : 'M_(m, n)) (B : 'M_(p, q)) i j k l : + (A *t B) (mxtens_index (i, j)) (mxtens_index (k, l)) = A i k * B j l. +Proof. by rewrite !mxE !mxtens_indexK. Qed. + +Lemma tens0mx {m n p q} (M : 'M[R]_(p,q)) : (0 : 'M_(m,n)) *t M = 0. +Proof. by apply/matrixP=> i j; rewrite !mxE mul0r. Qed. + +Lemma tensmx0 {m n p q} (M : 'M[R]_(m,n)) : M *t (0 : 'M_(p,q)) = 0. +Proof. by apply/matrixP=> i j; rewrite !mxE mulr0. Qed. + +Lemma tens_scalar_mx (m n : nat) (c : R) (M : 'M_(m,n)): + c%:M *t M = castmx (esym (mul1n _), esym (mul1n _)) (c *: M). +Proof. +apply/matrixP=> i j. +case: (mxtens_indexP i)=> i0 i1; case: (mxtens_indexP j)=> j0 j1. +rewrite tensmxE [i0]ord1 [j0]ord1 !castmxE !mxE /= mulr1n. +by congr (_ * M _ _); apply: val_inj. +Qed. + +Lemma tens_scalar1mx (m n : nat) (M : 'M_(m,n)) : + 1 *t M = castmx (esym (mul1n _), esym (mul1n _)) M. +Proof. by rewrite tens_scalar_mx scale1r. Qed. + +Lemma tens_scalarN1mx (m n : nat) (M : 'M_(m,n)) : + (-1) *t M = castmx (esym (mul1n _), esym (mul1n _)) (-M). +Proof. by rewrite [-1]mx11_scalar /= tens_scalar_mx !mxE scaleNr scale1r. Qed. + +Lemma trmx_tens {m n p q} (M :'M[R]_(m,n)) (N : 'M[R]_(p,q)) : + (M *t N)^T = M^T *t N^T. +Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. + +Lemma tens_col_mx {m n p q} (r : 'rV[R]_n) + (M :'M[R]_(m, n)) (N : 'M[R]_(p, q)) : + (col_mx r M) *t N = + castmx (esym (mulnDl _ _ _), erefl _) (col_mx (r *t N) (M *t N)). +Proof. +apply/matrixP=> i j. +case: (mxtens_indexP i)=> i0 i1; case: (mxtens_indexP j)=> j0 j1. +rewrite !tensmxE castmxE /= cast_ord_id esymK !mxE /=. +case: splitP=> i0' /= hi0'; case: splitP=> k /= hk. ++ case: (mxtens_indexP k) hk=> k0 k1 /=; rewrite tensmxE. + move=> /(f_equal (edivn^~ p)); rewrite !edivn_eq // => [] [h0 h1]. + by congr (r _ _ * N _ _); apply:val_inj; rewrite /= -?h0 ?h1. ++ move: hk (ltn_ord i1); rewrite hi0'. + by rewrite [i0']ord1 mul0n mul1n add0n ltnNge=> ->; rewrite leq_addr. ++ move: (ltn_ord k); rewrite -hk hi0' ltnNge {1}mul1n. + by rewrite mulnDl {1}mul1n -addnA leq_addr. +case: (mxtens_indexP k) hk=> k0 k1 /=; rewrite tensmxE. +rewrite hi0' mulnDl -addnA=> /addnI. + move=> /(f_equal (edivn^~ p)); rewrite !edivn_eq // => [] [h0 h1]. +by congr (M _ _ * N _ _); apply:val_inj; rewrite /= -?h0 ?h1. +Qed. + +Lemma tens_row_mx {m n p q} (r : 'cV[R]_m) (M :'M[R]_(m,n)) (N : 'M[R]_(p,q)) : + (row_mx r M) *t N = + castmx (erefl _, esym (mulnDl _ _ _)) (row_mx (r *t N) (M *t N)). +Proof. +rewrite -[_ *t _]trmxK trmx_tens tr_row_mx tens_col_mx. +apply/eqP; rewrite -(can2_eq (castmxKV _ _) (castmxK _ _)); apply/eqP. +by rewrite trmx_cast castmx_comp castmx_id tr_col_mx -!trmx_tens !trmxK. +Qed. + +Lemma tens_block_mx {m n p q} + (ul : 'M[R]_1) (ur : 'rV[R]_n) (dl : 'cV[R]_m) + (M :'M[R]_(m,n)) (N : 'M[R]_(p,q)) : + (block_mx ul ur dl M) *t N = + castmx (esym (mulnDl _ _ _), esym (mulnDl _ _ _)) + (block_mx (ul *t N) (ur *t N) (dl *t N) (M *t N)). +Proof. +rewrite !block_mxEv tens_col_mx !tens_row_mx -!cast_col_mx castmx_comp. +by congr (castmx (_,_)); apply nat_irrelevance. +Qed. + + +Fixpoint ntensmx_rec {m n} (A : 'M_(m,n)) k : 'M_(m ^ k.+1,n ^ k.+1) := + if k is k'.+1 then (A *t (ntensmx_rec A k')) else A. + +Definition ntensmx {m n} (A : 'M_(m, n)) k := nosimpl + (if k is k'.+1 return 'M[R]_(m ^ k,n ^ k) then ntensmx_rec A k' else 1). + +Notation "A ^t k" := (ntensmx A k) + (at level 39, left associativity, format "A ^t k"). + +Lemma ntensmx0 : forall {m n} (A : 'M_(m,n)) , A ^t 0 = 1. +Proof. by []. Qed. + +Lemma ntensmx1 : forall {m n} (A : 'M_(m,n)) , A ^t 1 = A. +Proof. by []. Qed. + +Lemma ntensmx2 : forall {m n} (A : 'M_(m,n)) , A ^t 2 = A *t A. +Proof. by []. Qed. + +Lemma ntensmxSS : forall {m n} (A : 'M_(m,n)) k, A ^t k.+2 = A *t A ^t k.+1. +Proof. by []. Qed. + +Definition ntensmxS := (@ntensmx1, @ntensmx2, @ntensmxSS). + +End MxTens. + +Notation "A *t B" := (tensmx A B) + (at level 40, left associativity, format "A *t B"). + +Notation "A ^t k" := (ntensmx A k) + (at level 39, left associativity, format "A ^t k"). + +Section MapMx. +Variables (aR rR : ringType). +Hypothesis f : {rmorphism aR -> rR}. +Local Notation "A ^f" := (map_mx f A) : ring_scope. + +Variables m n p q: nat. +Implicit Type A : 'M[aR]_(m, n). +Implicit Type B : 'M[aR]_(p, q). + +Lemma map_mxT A B : (A *t B)^f = A^f *t B^f :> 'M_(m*p, n*q). +Proof. by apply/matrixP=> i j; rewrite !mxE /= rmorphM. Qed. + +End MapMx. + +Section Misc. + +Lemma tensmx_mul (R : comRingType) m n p q r s + (A : 'M[R]_(m,n)) (B : 'M[R]_(p,q)) (C : 'M[R]_(n, r)) (D : 'M[R]_(q, s)) : + (A *t B) *m (C *t D) = (A *m C) *t (B *m D). +Proof. +apply/matrixP=> /= i j. +case (mxtens_indexP i)=> [im ip] {i}; case (mxtens_indexP j)=> [jr js] {j}. +rewrite !mxE !mxtens_indexK mulr_sum; apply: congr_big=> // k _. +by rewrite !mxE !mxtens_indexK mulrCA !mulrA [C _ _ * A _ _]mulrC. +Qed. + +(* Todo : move to div ? *) +Lemma eq_addl_mul q q' m m' d : m < d -> m' < d -> + (q * d + m == q' * d + m')%N = ((q, m) == (q', m')). +Proof. +move=> lt_md lt_m'd; apply/eqP/eqP; last by move=> [-> ->]. +by move=> /(f_equal (edivn^~ d)); rewrite !edivn_eq. +Qed. + +Lemma tensmx_unit (R : fieldType) m n (A : 'M[R]_m%N) (B : 'M[R]_n%N) : + m != 0%N -> n != 0%N -> A \in unitmx -> B \in unitmx -> (A *t B) \in unitmx. +Proof. +move: m n A B => [|m] [|n] // A B _ _ uA uB. +suff : (A^-1 *t B^-1) *m (A *t B) = 1 by case/mulmx1_unit. +rewrite tensmx_mul !mulVmx //; apply/matrixP=> /= i j. +rewrite !mxE /=; symmetry; rewrite -natrM -!val_eqE /=. +rewrite {1}(divn_eq i n.+1) {1}(divn_eq j n.+1). +by rewrite eq_addl_mul ?ltn_mod // xpair_eqE mulnb. +Qed. + + +Lemma tens_mx_scalar : forall (R : comRingType) + (m n : nat) (c : R) (M : 'M[R]_(m,n)), + M *t c%:M = castmx (esym (muln1 _), esym (muln1 _)) (c *: M). +Proof. +move=> R0 m n c M; apply/matrixP=> i j. +case: (mxtens_indexP i)=> i0 i1; case: (mxtens_indexP j)=> j0 j1. +rewrite tensmxE [i1]ord1 [j1]ord1 !castmxE !mxE /= mulr1n mulrC. +by congr (_ * M _ _); apply: val_inj=> /=; rewrite muln1 addn0. +Qed. + +Lemma tensmx_decr : forall (R : comRingType) m n (M :'M[R]_m) (N : 'M[R]_n), + M *t N = (M *t 1%:M) *m (1%:M *t N). +Proof. by move=> R0 m n M N; rewrite tensmx_mul mul1mx mulmx1. Qed. + +Lemma tensmx_decl : forall (R : comRingType) m n (M :'M[R]_m) (N : 'M[R]_n), + M *t N = (1%:M *t N) *m (M *t 1%:M). +Proof. by move=> R0 m n M N; rewrite tensmx_mul mul1mx mulmx1. Qed. + +End Misc. diff --git a/mathcomp/attic/quote.v b/mathcomp/attic/quote.v new file mode 100644 index 0000000..bde7fac --- /dev/null +++ b/mathcomp/attic/quote.v @@ -0,0 +1,365 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Structure tProp := TProp {tProp_statement :> Prop; _ : tProp_statement}. +Lemma claim : forall tP : tProp, tP. Proof. by case. Qed. +Hint Resolve claim. + +Canonical Structure True_tProp := TProp Logic.I. +Canonical Structure eq_tProp T (x : T) := TProp (erefl x). +Canonical Structure true_tProp := @TProp true (erefl _). +Canonical Structure and_tProp (P Q : tProp) := + TProp (conj (claim P) (claim Q)). + +Structure postProp (P : Prop) := PostProp {postProp_statement :> tProp; _ : P}. +Canonical Structure tProp_postProp P claimP pP := + PostProp (@TProp P claimP) (claim pP). + +Delimit Scope n_ary_op_scope with QOP. +Delimit Scope quote_scope with QT. + +Fixpoint n_ary n T := if n is n'.+1 then T -> n_ary n' T else T. +Notation "n .-ary" := (n_ary n) (at level 2, format "n .-ary") : type_scope. + +Module Quotation. + +CoInductive n_ary_op T := NaryOp n of n.-ary T. +Notation "f / n" := (@NaryOp _ n f) : n_ary_op_scope. +Definition bind_op T R (op : n_ary_op T) ifun : R := + let: NaryOp n f := op in ifun n f. +Definition arity T op := @bind_op T nat op (fun n _ => n). + +Structure type := Pack {sort :> Type; sym; _ : sym -> n_ary_op sort}. +Notation QuoteType sf := (Pack sf%QOP). +Definition symop T := let: Pack _ _ ops := T return sym T -> n_ary_op T in ops. + +Inductive term S := Var of nat | App of S & seq (term S). + +Lemma term_ind' : forall S (P : term S -> Type), + (forall i, P (Var S i)) -> + (forall s a, foldr prod True (map P a) -> P (App s a)) -> + (forall t, P t). +Proof. +move=> S P P_V P_A; pose fix sz (t : term S) := + if t is App _ a then (foldr maxn 0 (map sz a)).+1 else 0. +move=> t; elim: {t}(sz t) {-2}t (leqnn (sz t)) => [|n IHn] [i | s a] //=. +rewrite ltnS => sz_a; apply: P_A; elim: a sz_a => //= t a IHa. +by rewrite geq_max; case/andP; move/IHn=> Pt; move/IHa. +Qed. + +Bind Scope quote_scope with term. +Notation "''K_' i" := (Var _ i) + (at level 8, i at level 2, format "''K_' i") : quote_scope. +Notation "''[' s x1 .. xn ]" := (App s (x1%QT :: .. [:: xn%QT] ..)) + (at level 0, s at level 2, x1, xn at level 8, + format "''[' '[hv' s x1 .. xn ']' ]") : quote_scope. +Notation "''[' s ]" := (App s [::]) + (at level 0, s at level 2, format "''[' s ]") : quote_scope. + +Section OneType. + +Variable T : type. +Implicit Type P : Prop. +Implicit Type tP : tProp. + +Definition Env := @id (seq T). + +Fixpoint lookup i e : option T := + if i is i'.+1 then lookup i' (behead e) else ohead e. + +Definition interp_app (iarg : term (sym T) -> option T) := + fix loop a n {struct a} : n.-ary T -> option T := + if n is n'.+1 return n.-ary T -> option T + then fun f => if a is t :: a' then obind (loop a' n' \o f) (iarg t) else None + else fun x => if a is [::] then Some x else None. + +Fixpoint interp e t := match t with + | Var i => lookup i e + | App s a => bind_op (symop s) (interp_app (interp e) a) + end. + +Fixpoint wf (t : term (sym T)) := + match t with + | App s a => let: NaryOp n _ := symop s in (n == size a) && all wf a + | Var _ => true + end. + +Fixpoint eval x0 e t := + match t with + | Var i => nth x0 e i + | App s a => + odflt x0 (bind_op (symop s) (interp_app (fun x => Some (eval x0 e x)) a)) + end. + +Lemma interp_wf_eval : forall y0 e t y, + interp e t = Some y -> wf t /\ eval y0 e t = y. +Proof. +move=> y0 e t; elim/term_ind': t => [i|s a IHa] y /=. + by elim: i e => [|i IHi] [|z e] //=; [case | elim: i {IHi} | exact: IHi]. +case: symop => /= n x1. +elim: n x1 a IHa => [|n IHn] x1 [|f a] //=; first by move=> _ []. +case: (interp e f) => //= x []; case/(_ x)=> // -> ->; exact: IHn. +Qed. + +Definition var_val := @id T. +Definition op_val := var_val. + +Structure form e t P := Form {fval; _ : P -> interp e t = Some fval}. +Lemma formP : forall e t tP f, interp e t = Some (@fval e t tP f). +Proof. by move=> e t tP [x <-]. Qed. + +Structure store i x P := Store {stval; _ : P -> lookup i stval = Some x}. +Canonical Structure head_store x e := + @Store 0 x True (Env (x :: Env e)) (fun _ => erefl _). +Lemma tail_store_subproof : forall i x y e tP s, + e = @stval i x tP s -> lookup i.+1 (y :: e) = Some x. +Proof. by move=> i x y _ tP [e /= <- //] ->. Qed. +Canonical Structure tail_store i x y e tP s := + Store (@tail_store_subproof i x y e tP s). + +Lemma var_form_subproof : forall i x P (s : store i x P), + P -> interp (stval s) 'K_i = Some (var_val x). +Proof. by move=> i x P []. Qed. +Canonical Structure var_form i x P s := Form (@var_form_subproof i x P s). + +Lemma op_form_subproof : forall e t tP (f : form e t tP) x, + x = @fval e t tP f -> interp e t = Some (op_val x). +Proof. by move=> e t tP f _ ->; exact: formP. Qed. + +Canonical Structure op_form e t tP f x := + Form (@op_form_subproof e t tP f x). + +Section OpForm. + +Variables (s : sym T) (e : seq T). + +Fixpoint OpForm_type a xa fa n := + if n is n'.+1 then + forall x t tP f, OpForm_type (t :: a) (x :: xa) (@fval e t tP f :: fa) n' + else form e (App s (rev a)) (map op_val (rev xa) = rev fa). + +Definition OpForm_rechyp a (xa fa : seq T) n (x : n.-ary T) := + forall a', map op_val (rev xa) = rev fa -> + interp e (App s (catrev a' a)) = interp_app (interp e) a' x. + +Definition OpForm_rectype a xa fa n (x : n.-ary T) := + OpForm_rechyp a xa fa x -> OpForm_type a xa fa n. + +Definition OpForm_basetype P x a := + (P -> interp e (App s a) = Some x) -> form e (App s a) P. + +Lemma OpForm_recproof : forall a xa fa n (x1 : n.+1.-ary T), + forall x t tP f, OpForm_rechyp a xa fa x1 -> + OpForm_rechyp (t :: a) (x :: xa) (@fval e t tP f :: fa) (x1 x). +Proof. +move=> a xa fa n x1 x t tP f IHx a'; move/(_ (t :: a')): IHx => /=. +rewrite !map_id (formP f) /= => IHx; case/(can_inj (@revK _)) => -> eq_xa. +by rewrite {}IHx ?eq_xa. +Qed. + +Fixpoint OpForm_rec a xa fa n : forall x, @OpForm_rectype a xa fa n x := + if n is _.+1 return forall x, @OpForm_rectype a xa fa n x then + fun _ IHx _ _ _ _ => OpForm_rec (OpForm_recproof IHx) else + fun x IHx => + (if rev a is (t :: a') as rev_a return OpForm_basetype _ _ rev_a then + fun IHx => Form IHx else fun IHx => Form IHx) (IHx [::]). + +Lemma OpForm_subproof : bind_op (symop s) (OpForm_rechyp [::] [::] [::]). +Proof. by case def_s: (symop s) => [n x] a _; rewrite /= def_s. Qed. + +Definition OpForm := + (let: (op/n)%QOP as op_n := symop s + return (bind_op op_n _ : Prop) -> @OpForm_type _ _ _ (arity op_n) in + @OpForm_rec _ _ _ n op) + OpForm_subproof. + +End OpForm. + +Section GenSimp. + +Variable simp : seq T -> term (sym T) -> option T. + +Definition simp_axiom := forall e t x y, + interp e t = Some x -> simp e t = Some y -> x = y. + +Hypothesis simpP : simp_axiom. + +Structure closed := Closed {closed_val :> seq T}. +Canonical Structure head_closed := Closed (Env [::]). +Canonical Structure tail_closed x (ce : closed) := Closed (x :: ce). +Inductive close : seq T -> Prop := Close (ce : closed) : close ce. +Canonical Structure close_tProp ce := TProp (Close ce). + +Lemma simp_form : forall e t y ptP, + forall f : form (Env e) t + (@postProp_statement (close (Env e) /\ simp e t = Some y) ptP), + fval f = y. +Proof. +move=> e t y [tP [_ def_y]] [x /= def_x]; apply: simpP def_y; exact: def_x. +Qed. + +End GenSimp. + +Definition Econs := Cons. +Definition Etag of nat := @idfun. +Definition Enil := Nil. + +Fixpoint simp_env {T'} e i := + if e is x :: e' then omap (Econs (Etag i x)) (simp_env e' i.+1) + else Some (Enil T'). + +Notation "' 'K_' i := x" := (Etag i x) + (at level 200, format "' 'K_' i := x") : quote_tag_scope. +Arguments Scope Econs [type_scope quote_tag_scope _]. + +Notation "[ 'env' d1 ; .. ; d_n ]" := (Econs d1 .. (Econs d_n (Enil _)) ..) + (at level 0, format "[ 'env' '[' d1 ; '/' .. ; '/' d_n ] ']'") + : quote_scope. + +Notation "[ 'env' ]" := (Enil _) + (at level 0, format "[ 'env' ]") : quote_scope. + +Lemma unquote_default : false -> T. Proof. by []. Qed. +Definition unquote e t := + if interp e t is Some x as ox return ox -> T then fun _ => x else + unquote_default. + +Arguments Scope unquote [quote_scope quote_scope _]. + +Lemma end_unquote : true. Proof. by []. Qed. +Definition simp_quote e t := + obind (fun e' => + (if interp e' t as b return (b -> _) -> _ then + fun wf_t' => Some (unquote (wf_t' end_unquote)) + else fun _ => None) id) + (simp_env e 0). + +Lemma simp_quoteP : simp_axiom simp_quote. +Proof. +rewrite /simp_quote => e t x y def_x. +suff ->: simp_env e 0 = Some e by rewrite /unquote /= def_x; case. +by elim: e {def_x} 0 => //= z e IHe i; rewrite IHe. +Qed. + +Definition quote := simp_form simp_quoteP. + +End OneType. + +End Quotation. + +Canonical Structure Quotation.head_store. +Canonical Structure Quotation.tail_store. +Canonical Structure Quotation.var_form. +Canonical Structure Quotation.op_form. +Canonical Structure Quotation.head_closed. +Canonical Structure Quotation.tail_closed. +Canonical Structure Quotation.close_tProp. + +Notation QuoteType sf := (Quotation.Pack sf%QOP). +Notation "f / n" := (@Quotation.NaryOp _ n f) : n_ary_op_scope. + +Notation OpForm := Quotation.OpForm. + +Notation "''K_' i" := (Quotation.Var _ i) + (at level 8, i at level 2, format "''K_' i") : quote_scope. +Notation "''[' s x1 .. xn ]" := + (Quotation.App s (x1%QT :: .. [:: xn%QT] ..)) + (at level 0, s at level 2, x1, xn at level 8, + format "''[' s '[hv' x1 '/' .. '/' xn ']' ]") : quote_scope. +Notation "''[' s ]" := (Quotation.App s [::]) + (at level 0, s at level 2, format "''[' s ]") : quote_scope. +Notation "' 'K_' i := x" := (Quotation.Etag i x) + (at level 200, format "' 'K_' i := x") : quote_tag_scope. +Arguments Scope Quotation.Econs [type_scope quote_tag_scope _]. +Notation "[ 'env' d1 ; .. ; d_n ]" := + (Quotation.Econs d1 .. (Quotation.Econs d_n (Quotation.Enil _)) ..) + (at level 0, format "[ 'env' '[' d1 ; '/' .. ; '/' d_n ] ']'") + : quote_scope. +Notation "[ 'env' ]" := (Quotation.Enil _) + (at level 0, format "[ 'env' ]") : quote_scope. + +Arguments Scope Quotation.unquote [_ quote_scope quote_scope _]. +Notation unquote e t := (@Quotation.unquote _ e t%QT _). + +CoInductive bool_sym := bTrue | bAnd. +Canonical Structure bool_quoteType := + QuoteType (fun s => match s with bTrue => true/0 | bAnd => andb/2 end). +Canonical Structure and_form := Eval hnf in OpForm bAnd. +Canonical Structure true_form := Eval hnf in OpForm bTrue. + +Lemma try_bquote : forall b1 b2 b3, + false && b1 && (b2 && true && b3) && (b2 && b1 && b2) = false && b2. +Proof. +move=> b1 b2 b3. +Time rewrite Quotation.quote. +Time rewrite !Quotation.quote. +by []. +Qed. + +Fixpoint bstore s bt := match bt with +| 'K_i => set_nth false s i true +| '[bAnd t1 t2] => bstore (bstore s t1) t2 +| _ => s +end%QT. + +Fixpoint bread ot i s := match s with +| [::] => odflt '[bTrue] ot +| true :: s' => bread (Some (oapp (fun t => '[bAnd t 'K_i]) 'K_i ot)) i.+1 s' +| false :: s' => bread ot i.+1 s' +end%QT. + +Fixpoint bnormed t i := match t with +| '[bAnd t' 'K_j] => bnormed t' 1 +| 'K_j => i > 0 +| '[bTrue] => i == 0 +| _ => false +end%QT. + +Definition bsimp_fn e t := + if bnormed t 0 then None else + Quotation.interp e (bread None 0 (bstore [::] t)). + +Lemma bsimpP : Quotation.simp_axiom bsimp_fn. +Proof. +pose oand ob1 ob2 := obind (fun b1 => omap (andb b1) ob2) ob1. +have [oaC oaA oaI]: [/\ commutative oand, associative oand & idempotent oand]. + by split; do 6?case=> //. +have oa1: left_id (Some true) oand by case=> [[]|]. +rewrite /bsimp_fn => e t b b'; case: bnormed => //=. +set ie := Quotation.interp e; set s := [::] => def_b. +pose ir j s := ie (bread None j s). +suff{b'} storeP: ir 0 (bstore s t) = oand (ir 0 s) (Some b). + by rewrite [ie _]storeP => [[]]. +elim/Quotation.term_ind': t s => [i | op a IHa] /= s in b def_b *; last first. + case: op def_b; first by case: a {IHa} => //= <-; rewrite oaC oa1. + case: a IHa => //= t1; rewrite /ie /= -/ie; case: (ie _) => //= b1 [] //= t2. + case: (ie t2) => //= b2 [] //= [IHb1 [IHb2 _]] [<-]. + by rewrite (IHb2 _ b2) // (IHb1 _ b1) // -oaA. +have irT: forall s' j, ir j (true :: s') = oand (ie 'K_j)%QT (ir j.+1 s'). + rewrite /ir /= => s' j; move: s' j ('K_j)%QT. + by elim=> [|[|] s' IHs] j u; first 1 [rewrite oaC oa1] || rewrite !IHs -?oaA. +rewrite -{}def_b -{2}[i]addn0; elim: i 0 s => [|i IHi] j. + case=> [|bj s]; first by rewrite oa1. + by case: bj; rewrite !irT oaC // -oaA oaI. +rewrite addSnnS; case=> [|[|] s]; last exact: IHi. + by rewrite /= -set_nth_nil [ir _ _]IHi. +by rewrite !irT IHi oaA. +Qed. + +Definition bsimp := Quotation.simp_form bsimpP. + +Lemma try_bsimp : forall b1 b2 b3, + true && b1 && (b2 && b3) && (b2 && b1 && b2) = b1 && b2 && true && b3. +Proof. +move=> b1 b2 b3. +Time rewrite bsimp. +Time rewrite !bsimp. +by []. +Qed. +Print try_bsimp. + + diff --git a/mathcomp/attic/tutorial.v b/mathcomp/attic/tutorial.v new file mode 100644 index 0000000..3326c90 --- /dev/null +++ b/mathcomp/attic/tutorial.v @@ -0,0 +1,296 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq. + + +Section HilbertSaxiom. + +Variables A B C : Prop. + +Lemma HilbertS : (A -> B -> C) -> (A -> B) -> A -> C. +Proof. +move=> hAiBiC hAiB hA. +move: hAiBiC. +apply. + by []. +by apply: hAiB. +Qed. + +Hypotheses (hAiBiC : A -> B -> C) (hAiB : A -> B) (hA : A). + +Lemma HilbertS2 : C. +Proof. +apply: hAiBiC; first by apply: hA. +exact: hAiB. +Qed. + +Check (hAiB hA). + +Lemma HilbertS3 : C. +Proof. by apply: hAiBiC; last exact: hAiB. Qed. + +Lemma HilbertS4 : C. +Proof. exact: (hAiBiC _ (hAiB _)). Qed. + +Lemma HilbertS5 : C. +Proof. exact: hAiBiC (hAiB _). Qed. + +Lemma HilbertS6 : C. +Proof. exact HilbertS5. Qed. + +End HilbertSaxiom. + + + +Section Symmetric_Conjunction_Disjunction. + +Print bool. + +Lemma andb_sym : forall A B : bool, A && B -> B && A. +Proof. +case. + by case. +by []. +Qed. + +Lemma andb_sym2 : forall A B : bool, A && B -> B && A. +Proof. by case; case. Qed. + +Lemma andb_sym3 : forall A B : bool, A && B -> B && A. +Proof. by do 2! case. Qed. + +Variables (C D : Prop) (hC : C) (hD : D). +Check (and C D). +Print and. +Check conj. +Check (conj hC hD). + +Lemma and_sym : forall A B : Prop, A /\ B -> B /\ A. +Proof. by move=> A1 B []. Qed. + +Print or. + +Check or_introl. + +Lemma or_sym : forall A B : Prop, A \/ B -> B \/ A. +Proof. by move=> A B [hA | hB]; [apply: or_intror | apply: or_introl]. Qed. + +Lemma or_sym2 : forall A B : bool, A \/ B -> B \/ A. +Proof. by move=> [] [] AorB; apply/orP; move/orP : AorB. Qed. + +End Symmetric_Conjunction_Disjunction. + + + +Section R_sym_trans. + +Variables (D : Type) (R : D -> D -> Prop). + +Hypothesis R_sym : forall x y, R x y -> R y x. + +Hypothesis R_trans : forall x y z, R x y -> R y z -> R x z. + +Lemma refl_if : forall x : D, (exists y, R x y) -> R x x. +Proof. +move=> x [y Rxy]. +exact: R_trans (R_sym _ y _). +Qed. + +End R_sym_trans. + + + +Section Smullyan_drinker. + +Variables (D : Type) (P : D -> Prop). +Hypotheses (d : D) (EM : forall A, A \/ ~A). + +Lemma drinker : exists x, P x -> forall y, P y. +Proof. +(* case: (EM (exists y, ~P y)) => [[y notPy]| nonotPy] *) +have [[y notPy]| nonotPy] := EM (exists y, ~P y); first by exists y. +exists d => _ y; case: (EM (P y)) => // notPy. +by case: nonotPy; exists y. +Qed. + +End Smullyan_drinker. + + + +Section Equality. + +Variable f : nat -> nat. +Hypothesis f00 : f 0 = 0. + +Lemma fkk : forall k, k = 0 -> f k = k. +Proof. by move=> k k0; rewrite k0. Qed. + +Lemma fkk2 : forall k, k = 0 -> f k = k. +Proof. by move=> k ->. Qed. + +Variable f10 : f 1 = f 0. + +Lemma ff10 : f (f 1) = 0. +Proof. by rewrite f10 f00. Qed. + +Variables (D : eqType) (x y : D). + +Lemma eq_prop_bool : x = y -> x == y. +Proof. by move/eqP. Qed. + +Lemma eq_bool_prop : x == y -> x = y. +Proof. by move/eqP. Qed. + +End Equality. + + + +Section Using_Definition. + +Variable U : Type. + +Definition set := U -> Prop. + +Definition subset (A B : set) := forall x, A x -> B x. + +Definition transitive (T : Type) (R : T -> T -> Prop) := + forall x y z, R x y -> R y z -> R x z. + +Lemma subset_trans : transitive set subset. +Proof. +rewrite /transitive /subset => x y z subxy subyz t xt. +by apply: subyz; apply: subxy. +Qed. + +Lemma subset_trans2 : transitive set subset. +Proof. +move=> x y z subxy subyz t. +by move/subxy; move/subyz. +Qed. + +End Using_Definition. + + +Section Basic_ssrnat. + + +Lemma three : S (S (S O)) = 3 /\ 3 = 0.+1.+1.+1. +Proof. by []. Qed. + +Lemma concrete_plus : plus 16 64 = 80. +Proof. (*simpl.*) by []. Qed. + +Lemma concrete_addn : 16 + 64 = 80. +Proof. (*simpl.*) by []. Qed. + +Lemma concrete_le : le 1 3. +Proof. by apply: (Le.le_trans _ 2); apply: Le.le_n_Sn. Qed. + +Lemma concrete_big_le : le 16 64. +Proof. by auto 47 with arith. Qed. + +Lemma concrete_big_leq : 0 <= 51. +Proof. by []. Qed. + +Lemma semi_concrete_leq : forall n m, n <= m -> 51 + n <= 51 + m. +Proof. by []. Qed. + +Lemma concrete_arith : (50 < 100) && (3 + 4 < 3 * 4 <= 17 - 2). +Proof. by []. Qed. + +Lemma plus_com : forall m1 n1, n1 + m1 = m1 + n1. +Proof. +by elim=> [| n IHn m]; [elim | rewrite -[n.+1 + m]/(n + m).+1 -IHn; elim: m]. +Qed. + +End Basic_ssrnat. + + +Section Euclidean_division. + + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Definition edivn_rec d := fix loop (m q : nat) {struct m} := + if m - d is m'.+1 then loop m' q.+1 else (q, m). + +Definition edivn m d := if d is d'.+1 then edivn_rec d' m 0 else (0, m). + +CoInductive edivn_spec (m d : nat) : nat * nat -> Type := + EdivnSpec q r of m = q * d + r & (d > 0) ==> (r < d) : edivn_spec m d (q, r). + +Lemma edivnP : forall m d, edivn_spec m d (edivn m d). +Proof. +move=> m [|d] //=; rewrite -{1}[m]/(0 * d.+1 + m). +elim: m {-2}m 0 (leqnn m) => [|n IHn] [|m] q //=; rewrite ltnS => le_mn. +rewrite subn_if_gt; case: ltnP => // le_dm. +rewrite -{1}(subnKC le_dm) -addSn addnA -mulSnr; apply: IHn. +apply: leq_trans le_mn; exact: leq_subr. +Qed. + +Lemma edivn_eq : forall d q r, r < d -> edivn (q * d + r) d = (q, r). +Proof. +move=> d q r lt_rd; have d_gt0: 0 < d by exact: leq_trans lt_rd. +case: edivnP lt_rd => q' r'; rewrite d_gt0 /=. +wlog: q q' r r' / q <= q' by case (ltnP q q'); last symmetry; eauto. +rewrite leq_eqVlt; case: eqP => [-> _|_] /=; first by move/addnI->. +rewrite -(leq_pmul2r d_gt0); move/leq_add=> Hqr Eqr _; move/Hqr {Hqr}. +by rewrite addnS ltnNge mulSn -addnA Eqr addnCA addnA leq_addr. +Qed. + +CoInductive edivn_spec_right : nat -> nat -> nat * nat -> Type := + EdivnSpec_right m d q r of m = q * d + r & (d > 0) ==> (r < d) : + edivn_spec_right m d (q, r). + +CoInductive edivn_spec_left (m d : nat)(qr : nat * nat) : Type := +EdivnSpec_left of m = (fst qr) * d + (snd qr) & (d > 0) ==> (snd qr < d) : + edivn_spec_left m d qr. + + +Lemma edivnP_left : forall m d, edivn_spec_left m d (edivn m d). +Proof. +move=> m [|d] //=; rewrite -{1}[m]/(0 * d.+1 + m). +elim: m {-2}m 0 (leqnn m) => [|n IHn] [|m] q //=; rewrite ltnS => le_mn. +rewrite subn_if_gt; case: ltnP => // le_dm. +rewrite -{1}(subnKC le_dm) -addSn addnA -mulSnr; apply: IHn. +apply: leq_trans le_mn; exact: leq_subr. +Qed. + +Lemma edivnP_right : forall m d, edivn_spec_right m d (edivn m d). +Proof. +move=> m [|d] //=; rewrite -{1}[m]/(0 * d.+1 + m). +elim: m {-2}m 0 (leqnn m) => [|n IHn] [|m] q //=; rewrite ltnS => le_mn. +rewrite subn_if_gt; case: ltnP => // le_dm. +rewrite -{1}(subnKC le_dm) -addSn addnA -mulSnr; apply: IHn. +apply: leq_trans le_mn; exact: leq_subr. +Qed. + +Lemma edivn_eq_right : forall d q r, r < d -> edivn (q * d + r) d = (q, r). +Proof. +move=> d q r lt_rd; have d_gt0: 0 < d by exact: leq_trans lt_rd. +set m := q * d + r; have: m = q * d + r by []. +set d' := d; have: d' = d by []. +case: (edivnP_right m d') => {m d'} m d' q' r' -> lt_r'd' d'd q'd'r'. +move: q'd'r' lt_r'd' lt_rd; rewrite d'd d_gt0 {d'd m} /=. +wlog: q q' r r' / q <= q' by case (ltnP q q'); last symmetry; eauto. +rewrite leq_eqVlt; case: eqP => [-> _|_] /=; first by move/addnI->. +rewrite -(leq_pmul2r d_gt0); move/leq_add=> Hqr Eqr _; move/Hqr {Hqr}. +by rewrite addnS ltnNge mulSn -addnA -Eqr addnCA addnA leq_addr. +Qed. + + +Lemma edivn_eq_left : forall d q r, r < d -> edivn (q * d + r) d = (q, r). +Proof. +move=> d q r lt_rd; have d_gt0: 0 < d by exact: leq_trans lt_rd. +case: (edivnP_left (q * d + r) d) lt_rd; rewrite d_gt0 /=. +set q':= (edivn (q * d + r) d).1; set r':= (edivn (q * d + r) d).2. +rewrite (surjective_pairing (edivn (q * d + r) d)) -/q' -/r'. +wlog: q r q' r' / q <= q' by case (ltnP q q'); last symmetry; eauto. +rewrite leq_eqVlt; case: eqP => [-> _|_] /=; first by move/addnI->. +rewrite -(leq_pmul2r d_gt0); move/leq_add=> Hqr Eqr _; move/Hqr {Hqr}. +by rewrite addnS ltnNge mulSn -addnA Eqr addnCA addnA leq_addr. +Qed. + + +End Euclidean_division. \ No newline at end of file diff --git a/mathcomp/character/all.v b/mathcomp/character/all.v new file mode 100644 index 0000000..936fa6c --- /dev/null +++ b/mathcomp/character/all.v @@ -0,0 +1,7 @@ +Require Export character. +Require Export classfun. +Require Export inertia. +Require Export integral_char. +Require Export mxabelem. +Require Export mxrepresentation. +Require Export vcharacter. diff --git a/mathcomp/character/character.v b/mathcomp/character/character.v new file mode 100644 index 0000000..ac2f491 --- /dev/null +++ b/mathcomp/character/character.v @@ -0,0 +1,2976 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg poly finset gproduct. +Require Import fingroup morphism perm automorphism quotient finalg action. +Require Import zmodp commutator cyclic center pgroup nilpotent sylow abelian. +Require Import matrix mxalgebra mxpoly mxrepresentation vector ssrnum algC. +Require Import classfun. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory Num.Theory. +Local Open Scope ring_scope. + +(******************************************************************************) +(* This file contains the basic notions of character theory, based on Isaacs. *) +(* irr G == tuple of the elements of 'CF(G) that are irreducible *) +(* characters of G. *) +(* Nirr G == number of irreducible characters of G. *) +(* Iirr G == index type for the irreducible characters of G. *) +(* := 'I_(Nirr G). *) +(* 'chi_i == the i-th element of irr G, for i : Iirr G. *) +(* 'chi[G]_i Note that 'chi_0 = 1, the principal character of G. *) +(* 'Chi_i == an irreducible representation that affords 'chi_i. *) +(* socle_of_Iirr i == the Wedderburn component of the regular representation *) +(* of G, corresponding to 'Chi_i. *) +(* Iirr_of_socle == the inverse of socle_of_Iirr (which is one-to-one). *) +(* phi.[A]%CF == the image of A \in group_ring G under phi : 'CF(G). *) +(* cfRepr rG == the character afforded by the representation rG of G. *) +(* cfReg G == the regular character, afforded by the regular *) +(* representation of G. *) +(* detRepr rG == the linear character afforded by the determinant of rG. *) +(* cfDet phi == the linear character afforded by the determinant of a *) +(* representation affording phi. *) +(* 'o(phi) == the "determinential order" of phi (the multiplicative *) +(* order of cfDet phi. *) +(* phi \is a character <=> phi : 'CF(G) is a character of G or 0. *) +(* i \in irr_constt phi <=> 'chi_i is an irreducible constituent of phi: phi *) +(* has a non-zero coordinate on 'chi_i over the basis irr G. *) +(* xi \is a linear_char xi <=> xi : 'CF(G) is a linear character of G. *) +(* 'Z(chi)%CF == the center of chi when chi is a character of G, i.e., *) +(* rcenter rG where rG is a representation that affords phi. *) +(* If phi is not a character then 'Z(chi)%CF = cfker phi. *) +(* aut_Iirr u i == the index of cfAut u 'chi_i in irr G. *) +(* conjC_Iirr i == the index of 'chi_i^*%CF in irr G. *) +(* morph_Iirr i == the index of cfMorph 'chi[f @* G]_i in irr G. *) +(* isom_Iirr isoG i == the index of cfIsom isoG 'chi[G]_i in irr R. *) +(* mod_Iirr i == the index of ('chi[G / H]_i %% H)%CF in irr G. *) +(* quo_Iirr i == the index of ('chi[G]_i / H)%CF in irr (G / H). *) +(* Ind_Iirr G i == the index of 'Ind[G, H] 'chi_i, provided it is an *) +(* irreducible character (such as when if H is the inertia *) +(* group of 'chi_i). *) +(* Res_Iirr H i == the index of 'Res[H, G] 'chi_i, provided it is an *) +(* irreducible character (such as when 'chi_i is linear). *) +(* sdprod_Iirr defG i == the index of cfSdprod defG 'chi_i in irr G, given *) +(* defG : K ><| H = G. *) +(* And, for KxK : K \x H = G. *) +(* dprodl_Iirr KxH i == the index of cfDprodl KxH 'chi[K]_i in irr G. *) +(* dprodr_Iirr KxH j == the index of cfDprodr KxH 'chi[H]_j in irr G. *) +(* dprod_Iirr KxH (i, j) == the index of cfDprod KxH 'chi[K]_i 'chi[H]_j. *) +(* inv_dprod_Iirr KxH == the inverse of dprod_Iirr KxH. *) +(* The following are used to define and exploit the character table: *) +(* character_table G == the character table of G, whose i-th row lists the *) +(* values taken by 'chi_i on the conjugacy classes *) +(* of G; this is a square Nirr G x NirrG matrix. *) +(* irr_class i == the conjugacy class of G with index i : Iirr G. *) +(* class_Iirr xG == the index of xG \in classes G, in Iirr G. *) +(******************************************************************************) + +Local Notation algCF := [fieldType of algC]. + +Section AlgC. + +Variable (gT : finGroupType). + +Lemma groupC : group_closure_field algCF gT. +Proof. exact: group_closure_closed_field. Qed. + +End AlgC. + +Section Tensor. + +Variable (F : fieldType). + +Fixpoint trow (n1 : nat) : + forall (A : 'rV[F]_n1) m2 n2 (B : 'M[F]_(m2,n2)), 'M[F]_(m2,n1 * n2) := + if n1 is n'1.+1 + then + fun (A : 'M[F]_(1,(1 + n'1))) m2 n2 (B : 'M[F]_(m2,n2)) => + (row_mx (lsubmx A 0 0 *: B) (trow (rsubmx A) B)) + else (fun _ _ _ _ => 0). + +Lemma trow0 n1 m2 n2 B : @trow n1 0 m2 n2 B = 0. +Proof. +elim: n1=> //= n1 IH. +rewrite !mxE scale0r linear0. +rewrite IH //; apply/matrixP=> i j; rewrite !mxE. +by case: split=> *; rewrite mxE. +Qed. + +Definition trowb n1 m2 n2 B A := @trow n1 A m2 n2 B. + +Lemma trowbE n1 m2 n2 A B : trowb B A = @trow n1 A m2 n2 B. +Proof. by []. Qed. + +Lemma trowb_is_linear n1 m2 n2 (B : 'M_(m2,n2)) : linear (@trowb n1 m2 n2 B). +Proof. +elim: n1=> [|n1 IH] //= k A1 A2 /=; first by rewrite scaler0 add0r. +rewrite linearD /= linearZ. +apply/matrixP=> i j. +rewrite !mxE. +case: split=> a. + by rewrite !mxE mulrDl mulrA. +by rewrite linearD /= linearZ IH !mxE. +Qed. + +Canonical Structure trowb_linear n1 m2 n2 B := + Linear (@trowb_is_linear n1 m2 n2 B). + +Lemma trow_is_linear n1 m2 n2 (A : 'rV_n1) : linear (@trow n1 A m2 n2). +Proof. +elim: n1 A => [|n1 IH] //= A k A1 A2 /=; first by rewrite scaler0 add0r. +rewrite linearD /= linearZ /=. +apply/matrixP=> i j; rewrite !mxE. +by case: split=> a; rewrite ?IH !mxE. +Qed. + +Canonical Structure trow_linear n1 m2 n2 A := + Linear (@trow_is_linear n1 m2 n2 A). + +Fixpoint tprod (m1 : nat) : + forall n1 (A : 'M[F]_(m1,n1)) m2 n2 (B : 'M[F]_(m2,n2)), + 'M[F]_(m1 * m2,n1 * n2) := + if m1 is m'1.+1 + return forall n1 (A : 'M[F]_(m1,n1)) m2 n2 (B : 'M[F]_(m2,n2)), + 'M[F]_(m1 * m2,n1 * n2) + then + fun n1 (A : 'M[F]_(1 + m'1,n1)) m2 n2 B => + (col_mx (trow (usubmx A) B) (tprod (dsubmx A) B)) + else (fun _ _ _ _ _ => 0). + +Lemma dsumx_mul m1 m2 n p A B : + dsubmx ((A *m B) : 'M[F]_(m1 + m2, n)) = dsubmx (A : 'M_(m1 + m2, p)) *m B. +Proof. +apply/matrixP=> i j; rewrite !mxE; apply: eq_bigr=> k _. +by rewrite !mxE. +Qed. + +Lemma usumx_mul m1 m2 n p A B : + usubmx ((A *m B) : 'M[F]_(m1 + m2, n)) = usubmx (A : 'M_(m1 + m2, p)) *m B. +Proof. +by apply/matrixP=> i j; rewrite !mxE; apply: eq_bigr=> k _; rewrite !mxE. +Qed. + +Let trow_mul (m1 m2 n2 p2 : nat) + (A : 'rV_m1) (B1: 'M[F]_(m2,n2)) (B2 :'M[F]_(n2,p2)) : + trow A (B1 *m B2) = B1 *m trow A B2. +Proof. +elim: m1 A => [|m1 IH] A /=; first by rewrite mulmx0. +by rewrite IH mul_mx_row -scalemxAr. +Qed. + +Lemma tprodE m1 n1 p1 (A1 :'M[F]_(m1,n1)) (A2 :'M[F]_(n1,p1)) + m2 n2 p2 (B1 :'M[F]_(m2,n2)) (B2 :'M[F]_(n2,p2)) : + tprod (A1 *m A2) (B1 *m B2) = (tprod A1 B1) *m (tprod A2 B2). +Proof. +elim: m1 n1 p1 A1 A2 m2 n2 p2 B1 B2 => /= [|m1 IH]. + by move=> *; rewrite mul0mx. +move=> n1 p1 A1 A2 m2 n2 p2 B1 B2. +rewrite mul_col_mx -IH. +congr col_mx; last by rewrite dsumx_mul. +rewrite usumx_mul. +elim: n1 {A1}(usubmx (A1: 'M_(1 + m1, n1))) p1 A2=> //= [u p1 A2|]. + by rewrite [A2](flatmx0) !mulmx0 -trowbE linear0. +move=> n1 IH1 A p1 A2 //=. +set Al := lsubmx _; set Ar := rsubmx _. +set Su := usubmx _; set Sd := dsubmx _. +rewrite mul_row_col -IH1. +rewrite -{1}(@hsubmxK F 1 1 n1 A). +rewrite -{1}(@vsubmxK F 1 n1 p1 A2). +rewrite (@mul_row_col F 1 1 n1 p1). +rewrite -trowbE linearD /= trowbE -/Al. +congr (_ + _). +rewrite {1}[Al]mx11_scalar mul_scalar_mx. +by rewrite -trowbE linearZ /= trowbE -/Su trow_mul scalemxAl. +Qed. + +Let tprod_tr m1 n1 (A :'M[F]_(m1, 1 + n1)) m2 n2 (B :'M[F]_(m2, n2)) : + tprod A B = row_mx (trow (lsubmx A)^T B^T)^T (tprod (rsubmx A) B). +Proof. +elim: m1 n1 A m2 n2 B=> [|m1 IH] n1 A m2 n2 B //=. + by rewrite trmx0 row_mx0. +rewrite !IH. +pose A1 := A : 'M_(1 + m1, 1 + n1). +have F1: dsubmx (rsubmx A1) = rsubmx (dsubmx A1). + by apply/matrixP=> i j; rewrite !mxE. +have F2: rsubmx (usubmx A1) = usubmx (rsubmx A1). + by apply/matrixP=> i j; rewrite !mxE. +have F3: lsubmx (dsubmx A1) = dsubmx (lsubmx A1). + by apply/matrixP=> i j; rewrite !mxE. +rewrite tr_row_mx -block_mxEv -block_mxEh !(F1,F2,F3); congr block_mx. +- by rewrite !mxE linearZ /= trmxK. +by rewrite -trmx_dsub. +Qed. + +Lemma tprod1 m n : tprod (1%:M : 'M[F]_(m,m)) (1%:M : 'M[F]_(n,n)) = 1%:M. +Proof. +elim: m n => [|m IH] n //=; first by rewrite [1%:M]flatmx0. +rewrite tprod_tr. +set u := rsubmx _; have->: u = 0. + apply/matrixP=> i j; rewrite !mxE. + by case: i; case: j=> /= j Hj; case. +set v := lsubmx (dsubmx _); have->: v = 0. + apply/matrixP=> i j; rewrite !mxE. + by case: i; case: j; case. +set w := rsubmx _; have->: w = 1%:M. + apply/matrixP=> i j; rewrite !mxE. + by case: i; case: j; case. +rewrite IH -!trowbE !linear0. +rewrite -block_mxEv. +set z := (lsubmx _) 0 0; have->: z = 1. + by rewrite /z !mxE eqxx. +by rewrite scale1r scalar_mx_block. +Qed. + +Lemma mxtrace_prod m n (A :'M[F]_(m)) (B :'M[F]_(n)) : + \tr (tprod A B) = \tr A * \tr B. +Proof. +elim: m n A B => [|m IH] n A B //=. + by rewrite [A]flatmx0 mxtrace0 mul0r. +rewrite tprod_tr -block_mxEv mxtrace_block IH. +rewrite linearZ /= -mulrDl; congr (_ * _). +rewrite -trace_mx11 . +pose A1 := A : 'M_(1 + m). +rewrite -{3}[A](@submxK _ 1 m 1 m A1). +by rewrite (@mxtrace_block _ _ _ (ulsubmx A1)). +Qed. + +End Tensor. + +(* Representation sigma type and standard representations. *) +Section StandardRepresentation. + +Variables (R : fieldType) (gT : finGroupType) (G : {group gT}). +Local Notation reprG := (mx_representation R G). + +Record representation := + Representation {rdegree; mx_repr_of_repr :> reprG rdegree}. + +Lemma mx_repr0 : mx_repr G (fun _ : gT => 1%:M : 'M[R]_0). +Proof. by split=> // g h Hg Hx; rewrite mulmx1. Qed. + +Definition grepr0 := Representation (MxRepresentation mx_repr0). + +Lemma add_mx_repr (rG1 rG2 : representation) : + mx_repr G (fun g => block_mx (rG1 g) 0 0 (rG2 g)). +Proof. +split=> [|x y Hx Hy]; first by rewrite !repr_mx1 -scalar_mx_block. +by rewrite mulmx_block !(mulmx0, mul0mx, addr0, add0r, repr_mxM). +Qed. + +Definition dadd_grepr rG1 rG2 := + Representation (MxRepresentation (add_mx_repr rG1 rG2)). + +Section DsumRepr. + +Variables (n : nat) (rG : reprG n). + +Lemma mx_rsim_dadd (U V W : 'M_n) (rU rV : representation) + (modU : mxmodule rG U) (modV : mxmodule rG V) (modW : mxmodule rG W) : + (U + V :=: W)%MS -> mxdirect (U + V) -> + mx_rsim (submod_repr modU) rU -> mx_rsim (submod_repr modV) rV -> + mx_rsim (submod_repr modW) (dadd_grepr rU rV). +Proof. +case: rU; case: rV=> nV rV nU rU defW dxUV /=. +have tiUV := mxdirect_addsP dxUV. +move=> [fU def_nU]; rewrite -{nU}def_nU in rU fU * => inv_fU hom_fU. +move=> [fV def_nV]; rewrite -{nV}def_nV in rV fV * => inv_fV hom_fV. +pose pU := in_submod U (proj_mx U V) *m fU. +pose pV := in_submod V (proj_mx V U) *m fV. +exists (val_submod 1%:M *m row_mx pU pV) => [||g Gg]. +- by rewrite -defW (mxdirectP dxUV). +- apply/row_freeP. + pose pU' := invmx fU *m val_submod 1%:M. + pose pV' := invmx fV *m val_submod 1%:M. + exists (in_submod _ (col_mx pU' pV')). + rewrite in_submodE mulmxA -in_submodE -mulmxA mul_row_col mulmxDr. + rewrite -[pU *m _]mulmxA -[pV *m _]mulmxA !mulKVmx -?row_free_unit //. + rewrite addrC (in_submodE V) 2![val_submod 1%:M *m _]mulmxA -in_submodE. + rewrite addrC (in_submodE U) 2![val_submod 1%:M *m _]mulmxA -in_submodE. + rewrite -!val_submodE !in_submodK ?proj_mx_sub //. + by rewrite add_proj_mx ?val_submodK // val_submod1 defW. +rewrite mulmxA -val_submodE -[submod_repr _ g]mul1mx val_submodJ //. +rewrite -(mulmxA _ (rG g)) mul_mx_row -mulmxA mul_row_block !mulmx0 addr0 add0r. +rewrite !mul_mx_row; set W' := val_submod 1%:M; congr (row_mx _ _). + rewrite 3!mulmxA in_submodE mulmxA. + have hom_pU: (W' <= dom_hom_mx rG (proj_mx U V))%MS. + by rewrite val_submod1 -defW proj_mx_hom. + rewrite (hom_mxP hom_pU) // -in_submodE (in_submodJ modU) ?proj_mx_sub //. + rewrite -(mulmxA _ _ fU) hom_fU // in_submodE -2!(mulmxA W') -in_submodE. + by rewrite -mulmxA (mulmxA _ fU). +rewrite 3!mulmxA in_submodE mulmxA. +have hom_pV: (W' <= dom_hom_mx rG (proj_mx V U))%MS. + by rewrite val_submod1 -defW addsmxC proj_mx_hom // capmxC. +rewrite (hom_mxP hom_pV) // -in_submodE (in_submodJ modV) ?proj_mx_sub //. +rewrite -(mulmxA _ _ fV) hom_fV // in_submodE -2!(mulmxA W') -in_submodE. +by rewrite -mulmxA (mulmxA _ fV). +Qed. + +Lemma mx_rsim_dsum (I : finType) (P : pred I) U rU (W : 'M_n) + (modU : forall i, mxmodule rG (U i)) (modW : mxmodule rG W) : + let S := (\sum_(i | P i) U i)%MS in (S :=: W)%MS -> mxdirect S -> + (forall i, mx_rsim (submod_repr (modU i)) (rU i : representation)) -> + mx_rsim (submod_repr modW) (\big[dadd_grepr/grepr0]_(i | P i) rU i). +Proof. +move=> /= defW dxW rsimU. +rewrite mxdirectE /= -!(big_filter _ P) in dxW defW *. +elim: {P}(filter P _) => [|i e IHe] in W modW dxW defW *. + rewrite !big_nil /= in defW *. + by exists 0 => [||? _]; rewrite ?mul0mx ?mulmx0 // /row_free -defW !mxrank0. +rewrite !big_cons /= in dxW defW *. +rewrite 2!(big_nth i) !big_mkord /= in IHe dxW defW. +set Wi := (\sum_i _)%MS in defW dxW IHe. +rewrite -mxdirectE mxdirect_addsE !mxdirectE eqxx /= -/Wi in dxW. +have modWi: mxmodule rG Wi by exact: sumsmx_module. +case/andP: dxW; move/(IHe Wi modWi) {IHe}; move/(_ (eqmx_refl _))=> rsimWi. +by move/eqP; move/mxdirect_addsP=> dxUiWi; exact: mx_rsim_dadd (rsimU i) rsimWi. +Qed. + +Definition muln_grepr rW k := \big[dadd_grepr/grepr0]_(i < k) rW. + +Lemma mx_rsim_socle (sG : socleType rG) (W : sG) (rW : representation) : + let modW : mxmodule rG W := component_mx_module rG (socle_base W) in + mx_rsim (socle_repr W) rW -> + mx_rsim (submod_repr modW) (muln_grepr rW (socle_mult W)). +Proof. +set M := socle_base W => modW rsimM. +have simM: mxsimple rG M := socle_simple W. +have rankM_gt0: (\rank M > 0)%N by rewrite lt0n mxrank_eq0; case: simM. +have [I /= U_I simU]: mxsemisimple rG W by exact: component_mx_semisimple. +pose U (i : 'I_#|I|) := U_I (enum_val i). +have reindexI := reindex _ (onW_bij I (enum_val_bij I)). +rewrite mxdirectE /= !reindexI -mxdirectE /= => defW dxW. +have isoU: forall i, mx_iso rG M (U i). + move=> i; have sUiW: (U i <= W)%MS by rewrite -defW (sumsmx_sup i). + exact: component_mx_iso (simU _) sUiW. +have ->: socle_mult W = #|I|. + rewrite -(mulnK #|I| rankM_gt0); congr (_ %/ _)%N. + rewrite -defW (mxdirectP dxW) /= -sum_nat_const reindexI /=. + by apply: eq_bigr => i _; rewrite -(mxrank_iso (isoU i)). +have modU: mxmodule rG (U _) := mxsimple_module (simU _). +suff: mx_rsim (submod_repr (modU _)) rW by exact: mx_rsim_dsum defW dxW. +by move=> i; apply: mx_rsim_trans (mx_rsim_sym _) rsimM; exact/mx_rsim_iso. +Qed. + +End DsumRepr. + +Section ProdRepr. + +Variables (n1 n2 : nat) (rG1 : reprG n1) (rG2 : reprG n2). + +Lemma prod_mx_repr : mx_repr G (fun g => tprod (rG1 g) (rG2 g)). +Proof. +split=>[|i j InG JnG]; first by rewrite !repr_mx1 tprod1. +by rewrite !repr_mxM // tprodE. +Qed. + +Definition prod_repr := MxRepresentation prod_mx_repr. + +End ProdRepr. + +Lemma prod_repr_lin n2 (rG1 : reprG 1) (rG2 : reprG n2) : + {in G, forall x, let cast_n2 := esym (mul1n n2) in + prod_repr rG1 rG2 x = castmx (cast_n2, cast_n2) (rG1 x 0 0 *: rG2 x)}. +Proof. +move=> x Gx /=; set cast_n2 := esym _; rewrite /prod_repr /= !mxE !lshift0. +apply/matrixP=> i j; rewrite castmxE /=. +do 2![rewrite mxE; case: splitP => [? ? | []//]]. +by congr ((_ *: rG2 x) _ _); apply: val_inj. +Qed. + +End StandardRepresentation. + +Implicit Arguments grepr0 [R gT G]. +Prenex Implicits grepr0 dadd_grepr. + +Section Char. + +Variables (gT : finGroupType) (G : {group gT}). + +Fact cfRepr_subproof n (rG : mx_representation algCF G n) : + is_class_fun <> [ffun x => \tr (rG x) *+ (x \in G)]. +Proof. +rewrite genGid; apply: intro_class_fun => [x y Gx Gy | _ /negbTE-> //]. +by rewrite groupJr // !repr_mxM ?groupM ?groupV // mxtrace_mulC repr_mxK. +Qed. +Definition cfRepr n rG := Cfun 0 (@cfRepr_subproof n rG). + +Lemma cfRepr1 n rG : @cfRepr n rG 1%g = n%:R. +Proof. by rewrite cfunE group1 repr_mx1 mxtrace1. Qed. + +Lemma cfRepr_sim n1 n2 rG1 rG2 : + mx_rsim rG1 rG2 -> @cfRepr n1 rG1 = @cfRepr n2 rG2. +Proof. +case/mx_rsim_def=> f12 [f21] fK def_rG1; apply/cfun_inP=> x Gx. +by rewrite !cfunE def_rG1 // mxtrace_mulC mulmxA fK mul1mx. +Qed. + +Lemma cfRepr0 : cfRepr grepr0 = 0. +Proof. by apply/cfun_inP=> x Gx; rewrite !cfunE Gx mxtrace1. Qed. + +Lemma cfRepr_dadd rG1 rG2 : + cfRepr (dadd_grepr rG1 rG2) = cfRepr rG1 + cfRepr rG2. +Proof. by apply/cfun_inP=> x Gx; rewrite !cfunE Gx mxtrace_block. Qed. + +Lemma cfRepr_dsum I r (P : pred I) rG : + cfRepr (\big[dadd_grepr/grepr0]_(i <- r | P i) rG i) + = \sum_(i <- r | P i) cfRepr (rG i). +Proof. exact: (big_morph _ cfRepr_dadd cfRepr0). Qed. + +Lemma cfRepr_muln rG k : cfRepr (muln_grepr rG k) = cfRepr rG *+ k. +Proof. by rewrite cfRepr_dsum /= sumr_const card_ord. Qed. + +Section StandardRepr. + +Variables (n : nat) (rG : mx_representation algCF G n). +Let sG := DecSocleType rG. +Let iG : irrType algCF G := DecSocleType _. + +Definition standard_irr (W : sG) := irr_comp iG (socle_repr W). + +Definition standard_socle i := pick [pred W | standard_irr W == i]. +Local Notation soc := standard_socle. + +Definition standard_irr_coef i := oapp (fun W => socle_mult W) 0%N (soc i). + +Definition standard_grepr := + \big[dadd_grepr/grepr0]_i + muln_grepr (Representation (socle_repr i)) (standard_irr_coef i). + +Lemma mx_rsim_standard : mx_rsim rG standard_grepr. +Proof. +pose W i := oapp val 0 (soc i); pose S := (\sum_i W i)%MS. +have C'G: [char algC]^'.-group G := algC'G G. +have [defS dxS]: (S :=: 1%:M)%MS /\ mxdirect S. + rewrite /S mxdirectE /= !(bigID soc xpredT) /=. + rewrite addsmxC big1 => [|i]; last by rewrite /W; case (soc i). + rewrite adds0mx_id addnC (@big1 nat) ?add0n => [|i]; last first. + by rewrite /W; case: (soc i); rewrite ?mxrank0. + have <-: Socle sG = 1%:M := reducible_Socle1 sG (mx_Maschke rG C'G). + have [W0 _ | noW] := pickP sG; last first. + suff no_i: (soc : pred iG) =1 xpred0 by rewrite /Socle !big_pred0 ?mxrank0. + by move=> i; rewrite /soc; case: pickP => // W0; have:= noW W0. + have irrK Wi: soc (standard_irr Wi) = Some Wi. + rewrite /soc; case: pickP => [W' | /(_ Wi)] /= /eqP // eqWi. + apply/eqP/socle_rsimP. + apply: mx_rsim_trans (rsim_irr_comp iG C'G (socle_irr _)) (mx_rsim_sym _). + by rewrite [irr_comp _ _]eqWi; exact: rsim_irr_comp (socle_irr _). + have bij_irr: {on [pred i | soc i], bijective standard_irr}. + exists (odflt W0 \o soc) => [Wi _ | i]; first by rewrite /= irrK. + by rewrite inE /soc /=; case: pickP => //= Wi; move/eqP. + rewrite !(reindex standard_irr) {bij_irr}//=. + have all_soc Wi: soc (standard_irr Wi) by rewrite irrK. + rewrite (eq_bigr val) => [|Wi _]; last by rewrite /W irrK. + rewrite !(eq_bigl _ _ all_soc); split=> //. + rewrite (eq_bigr (mxrank \o val)) => [|Wi _]; last by rewrite /W irrK. + by rewrite -mxdirectE /= Socle_direct. +pose modW i : mxmodule rG (W i) := + if soc i is Some Wi as oWi return mxmodule rG (oapp val 0 oWi) then + component_mx_module rG (socle_base Wi) + else mxmodule0 rG n. +apply: mx_rsim_trans (mx_rsim_sym (rsim_submod1 (mxmodule1 rG) _)) _ => //. +apply: mx_rsim_dsum (modW) _ defS dxS _ => i. +rewrite /W /standard_irr_coef /modW /soc; case: pickP => [Wi|_] /=; last first. + rewrite /muln_grepr big_ord0. + by exists 0 => [||x _]; rewrite ?mxrank0 ?mulmx0 ?mul0mx. +by move/eqP=> <-; apply: mx_rsim_socle; exact: rsim_irr_comp (socle_irr Wi). +Qed. + +End StandardRepr. + +Definition cfReg (B : {set gT}) : 'CF(B) := #|B|%:R *: '1_[1]. + +Lemma cfRegE x : @cfReg G x = #|G|%:R *+ (x == 1%g). +Proof. by rewrite cfunE cfuniE ?normal1 // inE mulr_natr. Qed. + +(* This is Isaacs, Lemma (2.10). *) +Lemma cfReprReg : cfRepr (regular_repr algCF G) = cfReg G. +Proof. +apply/cfun_inP=> x Gx; rewrite cfRegE. +have [-> | ntx] := altP (x =P 1%g); first by rewrite cfRepr1. +rewrite cfunE Gx [\tr _]big1 // => i _; rewrite 2!mxE /=. +rewrite -(inj_eq enum_val_inj) gring_indexK ?groupM ?enum_valP //. +by rewrite eq_mulVg1 mulKg (negbTE ntx). +Qed. + +Definition xcfun (chi : 'CF(G)) A := + (gring_row A *m (\col_(i < #|G|) chi (enum_val i))) 0 0. + +Lemma xcfun_is_additive phi : additive (xcfun phi). +Proof. by move=> A B; rewrite /xcfun linearB mulmxBl !mxE. Qed. +Canonical xcfun_additive phi := Additive (xcfun_is_additive phi). + +Lemma xcfunZr a phi A : xcfun phi (a *: A) = a * xcfun phi A. +Proof. by rewrite /xcfun linearZ -scalemxAl mxE. Qed. + +(* In order to add a second canonical structure on xcfun *) +Definition xcfun_r_head k A phi := let: tt := k in xcfun phi A. +Local Notation xcfun_r A := (xcfun_r_head tt A). + +Lemma xcfun_rE A chi : xcfun_r A chi = xcfun chi A. Proof. by []. Qed. + +Fact xcfun_r_is_additive A : additive (xcfun_r A). +Proof. +move=> phi psi; rewrite /= /xcfun !mxE -sumrB; apply: eq_bigr => i _. +by rewrite !mxE !cfunE mulrBr. +Qed. +Canonical xcfun_r_additive A := Additive (xcfun_r_is_additive A). + +Lemma xcfunZl a phi A : xcfun (a *: phi) A = a * xcfun phi A. +Proof. +rewrite /xcfun !mxE big_distrr; apply: eq_bigr => i _ /=. +by rewrite !mxE cfunE mulrCA. +Qed. + +Lemma xcfun_repr n rG A : xcfun (@cfRepr n rG) A = \tr (gring_op rG A). +Proof. +rewrite gring_opE [gring_row A]row_sum_delta !linear_sum /xcfun !mxE. +apply: eq_bigr => i _; rewrite !mxE /= !linearZ cfunE enum_valP /=. +by congr (_ * \tr _) => {A} /=; rewrite /gring_mx /= -rowE rowK mxvecK. +Qed. + +End Char. +Notation xcfun_r A := (xcfun_r_head tt A). +Notation "phi .[ A ]" := (xcfun phi A) : cfun_scope. + +Definition pred_Nirr gT B := #|@classes gT B|.-1. +Arguments Scope pred_Nirr [_ group_scope]. +Notation Nirr G := (pred_Nirr G).+1. +Notation Iirr G := 'I_(Nirr G). + +Section IrrClassDef. + +Variables (gT : finGroupType) (G : {group gT}). + +Let sG := DecSocleType (regular_repr algCF G). + +Lemma NirrE : Nirr G = #|classes G|. +Proof. by rewrite /pred_Nirr (cardD1 [1]) classes1. Qed. + +Fact Iirr_cast : Nirr G = #|sG|. +Proof. by rewrite NirrE ?card_irr ?algC'G //; exact: groupC. Qed. + +Let offset := cast_ord (esym Iirr_cast) (enum_rank [1 sG]%irr). + +Definition socle_of_Iirr (i : Iirr G) : sG := + enum_val (cast_ord Iirr_cast (i + offset)). +Definition irr_of_socle (Wi : sG) : Iirr G := + cast_ord (esym Iirr_cast) (enum_rank Wi) - offset. +Local Notation W := socle_of_Iirr. + +Lemma socle_Iirr0 : W 0 = [1 sG]%irr. +Proof. by rewrite /W add0r cast_ordKV enum_rankK. Qed. + +Lemma socle_of_IirrK : cancel W irr_of_socle. +Proof. by move=> i; rewrite /irr_of_socle enum_valK cast_ordK addrK. Qed. + +Lemma irr_of_socleK : cancel irr_of_socle W. +Proof. by move=> Wi; rewrite /W subrK cast_ordKV enum_rankK. Qed. +Hint Resolve socle_of_IirrK irr_of_socleK. + +Lemma irr_of_socle_bij (A : pred (Iirr G)) : {on A, bijective irr_of_socle}. +Proof. by apply: onW_bij; exists W. Qed. + +Lemma socle_of_Iirr_bij (A : pred sG) : {on A, bijective W}. +Proof. by apply: onW_bij; exists irr_of_socle. Qed. + +End IrrClassDef. + +Prenex Implicits socle_of_IirrK irr_of_socleK. +Arguments Scope socle_of_Iirr [_ ring_scope]. + +Notation "''Chi_' i" := (irr_repr (socle_of_Iirr i)) + (at level 8, i at level 2, format "''Chi_' i"). + +Fact irr_key : unit. Proof. by []. Qed. +Definition irr_def gT B : (Nirr B).-tuple 'CF(B) := + let irr_of i := 'Res[B, <>] (@cfRepr gT _ _ 'Chi_(inord i)) in + [tuple of mkseq irr_of (Nirr B)]. +Definition irr := locked_with irr_key irr_def. + +Arguments Scope irr [_ group_scope]. + +Notation "''chi_' i" := (tnth (irr _) i%R) + (at level 8, i at level 2, format "''chi_' i") : ring_scope. +Notation "''chi[' G ]_ i" := (tnth (irr G) i%R) + (at level 8, i at level 2, only parsing) : ring_scope. + +Section IrrClass. + +Variable (gT : finGroupType) (G : {group gT}). +Implicit Types (i : Iirr G) (B : {set gT}). +Open Scope group_ring_scope. + +Lemma congr_irr i1 i2 : i1 = i2 -> 'chi_i1 = 'chi_i2. Proof. by move->. Qed. + +Lemma Iirr1_neq0 : G :!=: 1%g -> inord 1 != 0 :> Iirr G. +Proof. by rewrite -classes_gt1 -NirrE -val_eqE /= => /inordK->. Qed. + +Lemma has_nonprincipal_irr : G :!=: 1%g -> {i : Iirr G | i != 0}. +Proof. by move/Iirr1_neq0; exists (inord 1). Qed. + +Lemma irrRepr i : cfRepr 'Chi_i = 'chi_i. +Proof. +rewrite [irr]unlock (tnth_nth 0) nth_mkseq // -[<>]/(gval _) genGidG. +by rewrite cfRes_id inord_val. +Qed. + +Lemma irr0 : 'chi[G]_0 = 1. +Proof. +apply/cfun_inP=> x Gx; rewrite -irrRepr cfun1E cfunE Gx. +by rewrite socle_Iirr0 irr1_repr // mxtrace1 degree_irr1. +Qed. + +Lemma cfun1_irr : 1 \in irr G. +Proof. by rewrite -irr0 mem_tnth. Qed. + +Lemma mem_irr i : 'chi_i \in irr G. +Proof. exact: mem_tnth. Qed. + +Lemma irrP xi : reflect (exists i, xi = 'chi_i) (xi \in irr G). +Proof. +apply: (iffP idP) => [/(nthP 0)[i] | [i ->]]; last exact: mem_irr. +rewrite size_tuple => lt_i_G <-. +by exists (Ordinal lt_i_G); rewrite (tnth_nth 0). +Qed. + +Let sG := DecSocleType (regular_repr algCF G). +Let C'G := algC'G G. +Let closG := @groupC _ G. +Local Notation W i := (@socle_of_Iirr _ G i). +Local Notation "''n_' i" := 'n_(W i). +Local Notation "''R_' i" := 'R_(W i). +Local Notation "''e_' i" := 'e_(W i). + +Lemma irr1_degree i : 'chi_i 1%g = ('n_i)%:R. +Proof. by rewrite -irrRepr cfRepr1. Qed. + +Lemma Cnat_irr1 i : 'chi_i 1%g \in Cnat. +Proof. by rewrite irr1_degree rpred_nat. Qed. + +Lemma irr1_gt0 i : 0 < 'chi_i 1%g. +Proof. by rewrite irr1_degree ltr0n irr_degree_gt0. Qed. + +Lemma irr1_neq0 i : 'chi_i 1%g != 0. +Proof. by rewrite eqr_le ltr_geF ?irr1_gt0. Qed. + +Lemma irr_neq0 i : 'chi_i != 0. +Proof. by apply: contraNneq (irr1_neq0 i) => ->; rewrite cfunE. Qed. + +Definition cfIirr B (chi : 'CF(B)) : Iirr B := inord (index chi (irr B)). + +Lemma cfIirrE chi : chi \in irr G -> 'chi_(cfIirr chi) = chi. +Proof. +move=> chi_irr; rewrite (tnth_nth 0) inordK ?nth_index //. +by rewrite -index_mem size_tuple in chi_irr. +Qed. + +Lemma cfIirrPE J (f : J -> 'CF(G)) (P : pred J) : + (forall j, P j -> f j \in irr G) -> + forall j, P j -> 'chi_(cfIirr (f j)) = f j. +Proof. by move=> irr_f j /irr_f; apply: cfIirrE. Qed. + +(* This is Isaacs, Corollary (2.7). *) +Corollary irr_sum_square : \sum_i ('chi[G]_i 1%g) ^+ 2 = #|G|%:R. +Proof. +rewrite -(sum_irr_degree sG) // natr_sum (reindex _ (socle_of_Iirr_bij _)) /=. +by apply: eq_bigr => i _; rewrite irr1_degree natrX. +Qed. + +(* This is Isaacs, Lemma (2.11). *) +Lemma cfReg_sum : cfReg G = \sum_i 'chi_i 1%g *: 'chi_i. +Proof. +apply/cfun_inP=> x Gx; rewrite -cfReprReg cfunE Gx (mxtrace_regular sG) //=. +rewrite sum_cfunE (reindex _ (socle_of_Iirr_bij _)); apply: eq_bigr => i _. +by rewrite -irrRepr cfRepr1 !cfunE Gx mulr_natl. +Qed. + +Let aG := regular_repr algCF G. +Let R_G := group_ring algCF G. + +Lemma xcfun_annihilate i j A : i != j -> (A \in 'R_j)%MS -> ('chi_i).[A]%CF = 0. +Proof. +move=> neq_ij RjA; rewrite -irrRepr xcfun_repr. +by rewrite (irr_repr'_op0 _ _ RjA) ?raddf0 // eq_sym (can_eq socle_of_IirrK). +Qed. + +Lemma xcfunG phi x : x \in G -> phi.[aG x]%CF = phi x. +Proof. +by move=> Gx; rewrite /xcfun /gring_row rowK -rowE !mxE !(gring_indexK, mul1g). +Qed. + +Lemma xcfun_mul_id i A : + (A \in R_G)%MS -> ('chi_i).['e_i *m A]%CF = ('chi_i).[A]%CF. +Proof. +move=> RG_A; rewrite -irrRepr !xcfun_repr gring_opM //. +by rewrite op_Wedderburn_id ?mul1mx. +Qed. + +Lemma xcfun_id i j : ('chi_i).['e_j]%CF = 'chi_i 1%g *+ (i == j). +Proof. +have [<-{j} | /xcfun_annihilate->//] := altP eqP; last exact: Wedderburn_id_mem. +by rewrite -xcfunG // repr_mx1 -(xcfun_mul_id _ (envelop_mx1 _)) mulmx1. +Qed. + +Lemma irr_free : free (irr G). +Proof. +apply/freeP=> s s0 i; apply: (mulIf (irr1_neq0 i)). +rewrite mul0r -(raddf0 (xcfun_r_additive 'e_i)) -{}s0 raddf_sum /=. +rewrite (bigD1 i) //= -tnth_nth xcfunZl xcfun_id eqxx big1 ?addr0 // => j ne_ji. +by rewrite -tnth_nth xcfunZl xcfun_id (negbTE ne_ji) mulr0. +Qed. + +Lemma irr_inj : injective (tnth (irr G)). +Proof. by apply/injectiveP/free_uniq; rewrite map_tnth_enum irr_free. Qed. + +Lemma irrK : cancel (tnth (irr G)) (@cfIirr G). +Proof. by move=> i; apply: irr_inj; rewrite cfIirrE ?mem_irr. Qed. + +Lemma irr_eq1 i : ('chi_i == 1) = (i == 0). +Proof. by rewrite -irr0 (inj_eq irr_inj). Qed. + +Lemma cforder_irr_eq1 i : (#['chi_i]%CF == 1%N) = (i == 0). +Proof. by rewrite -dvdn1 dvdn_cforder irr_eq1. Qed. + +Lemma irr_basis : basis_of 'CF(G)%VS (irr G). +Proof. +rewrite /basis_of irr_free andbT -dimv_leqif_eq ?subvf //. +by rewrite dim_cfun (eqnP irr_free) size_tuple NirrE. +Qed. + +Lemma eq_sum_nth_irr a : \sum_i a i *: 'chi[G]_i = \sum_i a i *: (irr G)`_i. +Proof. by apply: eq_bigr => i; rewrite -tnth_nth. Qed. + +(* This is Isaacs, Theorem (2.8). *) +Theorem cfun_irr_sum phi : {a | phi = \sum_i a i *: 'chi[G]_i}. +Proof. +rewrite (coord_basis irr_basis (memvf phi)) -eq_sum_nth_irr. +by exists ((coord (irr G))^~ phi). +Qed. + +Lemma cfRepr_standard n (rG : mx_representation algCF G n) : + cfRepr (standard_grepr rG) + = \sum_i (standard_irr_coef rG (W i))%:R *: 'chi_i. +Proof. +rewrite cfRepr_dsum (reindex _ (socle_of_Iirr_bij _)). +by apply: eq_bigr => i _; rewrite scaler_nat cfRepr_muln irrRepr. +Qed. + +Lemma cfRepr_inj n1 n2 rG1 rG2 : + @cfRepr _ G n1 rG1 = @cfRepr _ G n2 rG2 -> mx_rsim rG1 rG2. +Proof. +move=> eq_repr12; pose c i : algC := (standard_irr_coef _ (W i))%:R. +have [rsim1 rsim2] := (mx_rsim_standard rG1, mx_rsim_standard rG2). +apply: mx_rsim_trans (rsim1) (mx_rsim_sym _). +suffices ->: standard_grepr rG1 = standard_grepr rG2 by []. +apply: eq_bigr => Wi _; congr (muln_grepr _ _); apply/eqP; rewrite -eqC_nat. +rewrite -[Wi]irr_of_socleK -!/(c _ _ _) -!(coord_sum_free (c _ _) _ irr_free). +rewrite -!eq_sum_nth_irr -!cfRepr_standard. +by rewrite -(cfRepr_sim rsim1) -(cfRepr_sim rsim2) eq_repr12. +Qed. + +Lemma cfRepr_rsimP n1 n2 rG1 rG2 : + reflect (mx_rsim rG1 rG2) (@cfRepr _ G n1 rG1 == @cfRepr _ G n2 rG2). +Proof. by apply: (iffP eqP) => [/cfRepr_inj | /cfRepr_sim]. Qed. + +Lemma irr_reprP xi : + reflect (exists2 rG : representation _ G, mx_irreducible rG & xi = cfRepr rG) + (xi \in irr G). +Proof. +apply: (iffP (irrP xi)) => [[i ->] | [[n rG] irr_rG ->]]. + by exists (Representation 'Chi_i); [exact: socle_irr | rewrite irrRepr]. +exists (irr_of_socle (irr_comp sG rG)); rewrite -irrRepr irr_of_socleK /=. +exact/cfRepr_sim/rsim_irr_comp. +Qed. + +(* This is Isaacs, Theorem (2.12). *) +Lemma Wedderburn_id_expansion i : + 'e_i = #|G|%:R^-1 *: \sum_(x in G) 'chi_i 1%g * 'chi_i x^-1%g *: aG x. +Proof. +have Rei: ('e_i \in 'R_i)%MS by exact: Wedderburn_id_mem. +have /envelop_mxP[a def_e]: ('e_i \in R_G)%MS; last rewrite -/aG in def_e. + by move: Rei; rewrite genmxE mem_sub_gring => /andP[]. +apply: canRL (scalerK (neq0CG _)) _; rewrite def_e linear_sum /=. +apply: eq_bigr => x Gx; have Gx' := groupVr Gx; rewrite scalerA; congr (_ *: _). +transitivity (cfReg G).['e_i *m aG x^-1%g]%CF. + rewrite def_e mulmx_suml raddf_sum (bigD1 x) //= -scalemxAl xcfunZr. + rewrite -repr_mxM // mulgV xcfunG // cfRegE eqxx mulrC big1 ?addr0 //. + move=> y /andP[Gy /negbTE neq_xy]; rewrite -scalemxAl xcfunZr -repr_mxM //. + by rewrite xcfunG ?groupM // cfRegE -eq_mulgV1 neq_xy mulr0. +rewrite cfReg_sum -xcfun_rE raddf_sum /= (bigD1 i) //= xcfunZl. +rewrite xcfun_mul_id ?envelop_mx_id ?xcfunG ?groupV ?big1 ?addr0 // => j ne_ji. +rewrite xcfunZl (xcfun_annihilate ne_ji) ?mulr0 //. +have /andP[_ /(submx_trans _)-> //] := Wedderburn_ideal (W i). +by rewrite mem_mulsmx // envelop_mx_id ?groupV. +Qed. + +End IrrClass. + +Arguments Scope cfReg [_ group_scope]. +Prenex Implicits cfIirr. +Implicit Arguments irr_inj [[gT] [G] x1 x2]. + +Section IsChar. + +Variable gT : finGroupType. + +Definition character {G : {set gT}} := + [qualify a phi : 'CF(G) | [forall i, coord (irr G) i phi \in Cnat]]. +Fact character_key G : pred_key (@character G). Proof. by []. Qed. +Canonical character_keyed G := KeyedQualifier (character_key G). + +Variable G : {group gT}. +Implicit Types (phi chi xi : 'CF(G)) (i : Iirr G). + +Lemma irr_char i : 'chi_i \is a character. +Proof. +by apply/forallP=> j; rewrite (tnth_nth 0) coord_free ?irr_free ?isNatC_nat. +Qed. + +Lemma cfun1_char : (1 : 'CF(G)) \is a character. +Proof. by rewrite -irr0 irr_char. Qed. + +Lemma cfun0_char : (0 : 'CF(G)) \is a character. +Proof. by apply/forallP=> i; rewrite linear0 rpred0. Qed. + +Fact add_char : addr_closed (@character G). +Proof. +split=> [|chi xi /forallP-Nchi /forallP-Nxi]; first exact: cfun0_char. +by apply/forallP=> i; rewrite linearD rpredD /=. +Qed. +Canonical character_addrPred := AddrPred add_char. + +Lemma char_sum_irrP {phi} : + reflect (exists n, phi = \sum_i (n i)%:R *: 'chi_i) (phi \is a character). +Proof. +apply: (iffP idP)=> [/forallP-Nphi | [n ->]]; last first. + by apply: rpred_sum => i _; rewrite scaler_nat rpredMn // irr_char. +do [have [a ->] := cfun_irr_sum phi] in Nphi *; exists (truncC \o a). +apply: eq_bigr => i _; congr (_ *: _); have:= eqP (Nphi i). +by rewrite eq_sum_nth_irr coord_sum_free ?irr_free. +Qed. + +Lemma char_sum_irr chi : + chi \is a character -> {r | chi = \sum_(i <- r) 'chi_i}. +Proof. +move=> Nchi; apply: sig_eqW; case/char_sum_irrP: Nchi => n {chi}->. +elim/big_rec: _ => [|i _ _ [r ->]]; first by exists nil; rewrite big_nil. +exists (ncons (n i) i r); rewrite scaler_nat. +by elim: {n}(n i) => [|n IHn]; rewrite ?add0r //= big_cons mulrS -addrA IHn. +Qed. + +Lemma Cnat_char1 chi : chi \is a character -> chi 1%g \in Cnat. +Proof. +case/char_sum_irr=> r ->{chi}. +by elim/big_rec: _ => [|i chi _ Nchi1]; rewrite cfunE ?rpredD // Cnat_irr1. +Qed. + +Lemma char1_ge0 chi : chi \is a character -> 0 <= chi 1%g. +Proof. by move/Cnat_char1/Cnat_ge0. Qed. + +Lemma char1_eq0 chi : chi \is a character -> (chi 1%g == 0) = (chi == 0). +Proof. +case/char_sum_irr=> r ->; apply/idP/idP=> [|/eqP->]; last by rewrite cfunE. +case: r => [|i r]; rewrite ?big_nil // sum_cfunE big_cons. +rewrite paddr_eq0 ?sumr_ge0 => // [||j _]; rewrite 1?ltrW ?irr1_gt0 //. +by rewrite (negbTE (irr1_neq0 i)). +Qed. + +Lemma char1_gt0 chi : chi \is a character -> (0 < chi 1%g) = (chi != 0). +Proof. by move=> Nchi; rewrite -char1_eq0 // Cnat_gt0 ?Cnat_char1. Qed. + +Lemma char_reprP phi : + reflect (exists rG : representation algCF G, phi = cfRepr rG) + (phi \is a character). +Proof. +apply: (iffP char_sum_irrP) => [[n ->] | [[n rG] ->]]; last first. + exists (fun i => standard_irr_coef rG (socle_of_Iirr i)). + by rewrite -cfRepr_standard (cfRepr_sim (mx_rsim_standard rG)). +exists (\big[dadd_grepr/grepr0]_i muln_grepr (Representation 'Chi_i) (n i)). +rewrite cfRepr_dsum; apply: eq_bigr => i _. +by rewrite cfRepr_muln irrRepr scaler_nat. +Qed. + +Local Notation reprG := (mx_representation algCF G). + +Lemma cfRepr_char n (rG : reprG n) : cfRepr rG \is a character. +Proof. by apply/char_reprP; exists (Representation rG). Qed. + +Lemma cfReg_char : cfReg G \is a character. +Proof. by rewrite -cfReprReg cfRepr_char. Qed. + +Lemma cfRepr_prod n1 n2 (rG1 : reprG n1) (rG2 : reprG n2) : + cfRepr rG1 * cfRepr rG2 = cfRepr (prod_repr rG1 rG2). +Proof. by apply/cfun_inP=> x Gx; rewrite !cfunE /= Gx mxtrace_prod. Qed. + +Lemma mul_char : mulr_closed (@character G). +Proof. +split=> [|_ _ /char_reprP[rG1 ->] /char_reprP[rG2 ->]]; first exact: cfun1_char. +apply/char_reprP; exists (Representation (prod_repr rG1 rG2)). +by rewrite cfRepr_prod. +Qed. +Canonical char_mulrPred := MulrPred mul_char. +Canonical char_semiringPred := SemiringPred mul_char. + +End IsChar. +Prenex Implicits character. +Implicit Arguments char_reprP [gT G phi]. + +Section AutChar. + +Variables (gT : finGroupType) (G : {group gT}). +Implicit Type u : {rmorphism algC -> algC}. + +Lemma cfRepr_map u n (rG : mx_representation algCF G n) : + cfRepr (map_repr u rG) = cfAut u (cfRepr rG). +Proof. by apply/cfun_inP=> x Gx; rewrite !cfunE Gx map_reprE trace_map_mx. Qed. + +Lemma cfAut_char u (chi : 'CF(G)) : + chi \is a character -> cfAut u chi \is a character. +Proof. +case/char_reprP=> rG ->; apply/char_reprP. +by exists (Representation (map_repr u rG)); rewrite cfRepr_map. +Qed. + +Lemma cfConjC_char (chi : 'CF(G)) : + chi \is a character -> chi^*%CF \is a character. +Proof. exact: cfAut_char. Qed. + +Lemma cfAut_char1 u (chi : 'CF(G)) : + chi \is a character -> cfAut u chi 1%g = chi 1%g. +Proof. by move/Cnat_char1=> Nchi1; rewrite cfunE aut_Cnat. Qed. + +Lemma cfAut_irr1 u i : (cfAut u 'chi[G]_i) 1%g = 'chi_i 1%g. +Proof. exact: cfAut_char1 (irr_char i). Qed. + +Lemma cfConjC_char1 (chi : 'CF(G)) : + chi \is a character -> chi^*%CF 1%g = chi 1%g. +Proof. exact: cfAut_char1. Qed. + +Lemma cfConjC_irr1 u i : ('chi[G]_i)^*%CF 1%g = 'chi_i 1%g. +Proof. exact: cfAut_irr1. Qed. + +End AutChar. + +Section Linear. + +Variables (gT : finGroupType) (G : {group gT}). + +Definition linear_char {B : {set gT}} := + [qualify a phi : 'CF(B) | (phi \is a character) && (phi 1%g == 1)]. + +Section OneChar. + +Variable xi : 'CF(G). +Hypothesis CFxi : xi \is a linear_char. + +Lemma lin_char1: xi 1%g = 1. +Proof. by case/andP: CFxi => _ /eqP. Qed. + +Lemma lin_charW : xi \is a character. +Proof. by case/andP: CFxi. Qed. + +Lemma cfun1_lin_char : (1 : 'CF(G)) \is a linear_char. +Proof. by rewrite qualifE cfun1_char /= cfun11. Qed. + +Lemma lin_charM : {in G &, {morph xi : x y / (x * y)%g >-> x * y}}. +Proof. +move=> x y Gx Gy; case/andP: CFxi => /char_reprP[[n rG] -> /=]. +rewrite cfRepr1 pnatr_eq1 => /eqP n1; rewrite {n}n1 in rG *. +rewrite !cfunE Gx Gy groupM //= !mulr1n repr_mxM //. +by rewrite [rG x]mx11_scalar [rG y]mx11_scalar -scalar_mxM !mxtrace_scalar. +Qed. + +Lemma lin_char_prod I r (P : pred I) (x : I -> gT) : + (forall i, P i -> x i \in G) -> + xi (\prod_(i <- r | P i) x i)%g = \prod_(i <- r | P i) xi (x i). +Proof. +move=> Gx; elim/(big_load (fun y => y \in G)): _. +elim/big_rec2: _ => [|i a y Pi [Gy <-]]; first by rewrite lin_char1. +by rewrite groupM ?lin_charM ?Gx. +Qed. + +Let xiMV x : x \in G -> xi x * xi (x^-1)%g = 1. +Proof. by move=> Gx; rewrite -lin_charM ?groupV // mulgV lin_char1. Qed. + +Lemma lin_char_neq0 x : x \in G -> xi x != 0. +Proof. +by move/xiMV/(congr1 (predC1 0)); rewrite /= oner_eq0 mulf_eq0 => /norP[]. +Qed. + +Lemma lin_charV x : x \in G -> xi x^-1%g = (xi x)^-1. +Proof. by move=> Gx; rewrite -[_^-1]mulr1 -(xiMV Gx) mulKf ?lin_char_neq0. Qed. + +Lemma lin_charX x n : x \in G -> xi (x ^+ n)%g = xi x ^+ n. +Proof. +move=> Gx; elim: n => [|n IHn]; first exact: lin_char1. +by rewrite expgS exprS lin_charM ?groupX ?IHn. +Qed. + +Lemma lin_char_unity_root x : x \in G -> xi x ^+ #[x] = 1. +Proof. by move=> Gx; rewrite -lin_charX // expg_order lin_char1. Qed. + +Lemma normC_lin_char x : x \in G -> `|xi x| = 1. +Proof. +move=> Gx; apply/eqP; rewrite -(@pexpr_eq1 _ _ #[x]) ?normr_ge0 //. +by rewrite -normrX // lin_char_unity_root ?normr1. +Qed. + +Lemma lin_charV_conj x : x \in G -> xi x^-1%g = (xi x)^*. +Proof. +move=> Gx; rewrite lin_charV // invC_norm mulrC normC_lin_char //. +by rewrite expr1n divr1. +Qed. + +Lemma lin_char_irr : xi \in irr G. +Proof. +case/andP: CFxi => /char_reprP[rG ->]; rewrite cfRepr1 pnatr_eq1 => /eqP n1. +by apply/irr_reprP; exists rG => //; exact/mx_abs_irrW/linear_mx_abs_irr. +Qed. + +Lemma mul_conjC_lin_char : xi * xi^*%CF = 1. +Proof. +apply/cfun_inP=> x Gx. +by rewrite !cfunE cfun1E Gx -normCK normC_lin_char ?expr1n. +Qed. + +Lemma lin_char_unitr : xi \in GRing.unit. +Proof. by apply/unitrPr; exists xi^*%CF; apply: mul_conjC_lin_char. Qed. + +Lemma invr_lin_char : xi^-1 = xi^*%CF. +Proof. by rewrite -[_^-1]mulr1 -mul_conjC_lin_char mulKr ?lin_char_unitr. Qed. + +Lemma cfAut_lin_char u : cfAut u xi \is a linear_char. +Proof. by rewrite qualifE cfunE lin_char1 rmorph1 cfAut_char ?lin_charW /=. Qed. + +Lemma cfConjC_lin_char : xi^*%CF \is a linear_char. +Proof. exact: cfAut_lin_char. Qed. + +Lemma fful_lin_char_inj : cfaithful xi -> {in G &, injective xi}. +Proof. +move=> fful_phi x y Gx Gy xi_xy; apply/eqP; rewrite eq_mulgV1 -in_set1. +rewrite (subsetP fful_phi) // inE groupM ?groupV //=; apply/forallP=> z. +have [Gz | G'z] := boolP (z \in G); last by rewrite !cfun0 ?groupMl ?groupV. +by rewrite -mulgA lin_charM ?xi_xy -?lin_charM ?groupM ?groupV // mulKVg. +Qed. + +End OneChar. + +Lemma card_Iirr_abelian : abelian G -> #|Iirr G| = #|G|. +Proof. by rewrite card_ord NirrE card_classes_abelian => /eqP. Qed. + +Lemma card_Iirr_cyclic : cyclic G -> #|Iirr G| = #|G|. +Proof. by move/cyclic_abelian/card_Iirr_abelian. Qed. + +Lemma char_abelianP : + reflect (forall i : Iirr G, 'chi_i \is a linear_char) (abelian G). +Proof. +apply: (iffP idP) => [cGG i | CF_G]. + rewrite qualifE irr_char /= irr1_degree. + by rewrite irr_degree_abelian //; last exact: groupC. +rewrite card_classes_abelian -NirrE -eqC_nat -irr_sum_square //. +rewrite -{1}[Nirr G]card_ord -sumr_const; apply/eqP/eq_bigr=> i _. +by rewrite lin_char1 ?expr1n ?CF_G. +Qed. + +Lemma irr_repr_lin_char (i : Iirr G) x : + x \in G -> 'chi_i \is a linear_char -> + irr_repr (socle_of_Iirr i) x = ('chi_i x)%:M. +Proof. +move=> Gx CFi; rewrite -irrRepr cfunE Gx. +move: (_ x); rewrite -[irr_degree _]natCK -irr1_degree lin_char1 //. +by rewrite (natCK 1) => A; rewrite trace_mx11 -mx11_scalar. +Qed. + +Fact linear_char_key B : pred_key (@linear_char B). Proof. by []. Qed. +Canonical linear_char_keted B := KeyedQualifier (linear_char_key B). +Fact linear_char_divr : divr_closed (@linear_char G). +Proof. +split=> [|chi xi Lchi Lxi]; first exact: cfun1_lin_char. +rewrite invr_lin_char // qualifE cfunE. +by rewrite rpredM ?lin_char1 ?mulr1 ?lin_charW //= cfConjC_lin_char. +Qed. +Canonical lin_char_mulrPred := MulrPred linear_char_divr. +Canonical lin_char_divrPred := DivrPred linear_char_divr. + +Lemma irr_cyclic_lin i : cyclic G -> 'chi[G]_i \is a linear_char. +Proof. by move/cyclic_abelian/char_abelianP. Qed. + +Lemma irr_prime_lin i : prime #|G| -> 'chi[G]_i \is a linear_char. +Proof. by move/prime_cyclic/irr_cyclic_lin. Qed. + +End Linear. + +Prenex Implicits linear_char. + +Section Restrict. + +Variable (gT : finGroupType) (G H : {group gT}). + +Lemma cfRepr_sub n (rG : mx_representation algCF G n) (sHG : H \subset G) : + cfRepr (subg_repr rG sHG) = 'Res[H] (cfRepr rG). +Proof. +by apply/cfun_inP => x Hx; rewrite cfResE // !cfunE Hx (subsetP sHG). +Qed. + +Lemma cfRes_char chi : chi \is a character -> 'Res[H, G] chi \is a character. +Proof. +have [sHG | not_sHG] := boolP (H \subset G). + by case/char_reprP=> rG ->; rewrite -(cfRepr_sub rG sHG) cfRepr_char. +by move/Cnat_char1=> Nchi1; rewrite cfResEout // rpredZ_Cnat ?rpred1. +Qed. + +Lemma cfRes_eq0 phi : phi \is a character -> ('Res[H, G] phi == 0) = (phi == 0). +Proof. by move=> Nchi; rewrite -!char1_eq0 ?cfRes_char // cfRes1. Qed. + +Lemma cfRes_lin_char chi : + chi \is a linear_char -> 'Res[H, G] chi \is a linear_char. +Proof. by case/andP=> Nchi; rewrite qualifE cfRes_char ?cfRes1. Qed. + +Lemma Res_irr_neq0 i : 'Res[H, G] 'chi_i != 0. +Proof. by rewrite cfRes_eq0 ?irr_neq0 ?irr_char. Qed. + +Lemma cfRes_lin_lin (chi : 'CF(G)) : + chi \is a character -> 'Res[H] chi \is a linear_char -> chi \is a linear_char. +Proof. by rewrite !qualifE cfRes1 => -> /andP[]. Qed. + +Lemma cfRes_irr_irr chi : + chi \is a character -> 'Res[H] chi \in irr H -> chi \in irr G. +Proof. +have [sHG /char_reprP[rG ->] | not_sHG Nchi] := boolP (H \subset G). + rewrite -(cfRepr_sub _ sHG) => /irr_reprP[rH irrH def_rH]; apply/irr_reprP. + suffices /subg_mx_irr: mx_irreducible (subg_repr rG sHG) by exists rG. + by apply: mx_rsim_irr irrH; exact/cfRepr_rsimP/eqP. +rewrite cfResEout // => /irrP[j Dchi_j]; apply/lin_char_irr/cfRes_lin_lin=> //. +suffices j0: j = 0 by rewrite cfResEout // Dchi_j j0 irr0 rpred1. +apply: contraNeq (irr1_neq0 j) => nz_j. +have:= xcfun_id j 0; rewrite -Dchi_j cfunE xcfunZl -irr0 xcfun_id eqxx => ->. +by rewrite (negPf nz_j). +Qed. + +Definition Res_Iirr (A B : {set gT}) i := cfIirr ('Res[B, A] 'chi_i). + +Lemma Res_Iirr0 : Res_Iirr H (0 : Iirr G) = 0. +Proof. by rewrite /Res_Iirr irr0 rmorph1 -irr0 irrK. Qed. + +Lemma lin_Res_IirrE i : 'chi[G]_i 1%g = 1 -> 'chi_(Res_Iirr H i) = 'Res 'chi_i. +Proof. +move=> chi1; rewrite cfIirrE ?lin_char_irr ?cfRes_lin_char //. +by rewrite qualifE irr_char /= chi1. +Qed. + +End Restrict. + +Arguments Scope Res_Iirr [_ group_scope group_scope ring_scope]. + +Section Morphim. + +Variables (aT rT : finGroupType) (G D : {group aT}) (f : {morphism D >-> rT}). +Implicit Type chi : 'CF(f @* G). + +Lemma cfRepr_morphim n (rfG : mx_representation algCF (f @* G) n) sGD : + cfRepr (morphim_repr rfG sGD) = cfMorph (cfRepr rfG). +Proof. +apply/cfun_inP=> x Gx; have Dx: x \in D := subsetP sGD x Gx. +by rewrite cfMorphE // !cfunE ?mem_morphim ?Gx. +Qed. + +Lemma cfMorph_char chi : chi \is a character -> cfMorph chi \is a character. +Proof. +have [sGD /char_reprP[rG ->] | outGD Nchi] := boolP (G \subset D); last first. + by rewrite cfMorphEout // rpredZ_Cnat ?rpred1 ?Cnat_char1. +apply/char_reprP; exists (Representation (morphim_repr rG sGD)). +by rewrite cfRepr_morphim. +Qed. + +Lemma cfMorph_lin_char chi : + chi \is a linear_char -> cfMorph chi \is a linear_char. +Proof. by case/andP=> Nchi; rewrite qualifE cfMorph_char ?cfMorph1. Qed. + +Lemma cfMorph_irr chi : + G \subset D -> chi \in irr (f @* G) -> cfMorph chi \in irr G. +Proof. +move=> sGD /irr_reprP[rG irrG ->]; apply/irr_reprP. +exists (Representation (morphim_repr rG sGD)); first exact/morphim_mx_irr. +apply/cfun_inP=> x Gx; rewrite !cfunElock /= sGD Gx. +by rewrite mem_morphim ?(subsetP sGD). +Qed. + +Definition morph_Iirr i := cfIirr (cfMorph 'chi[f @* G]_i). + +Lemma morph_Iirr0 : morph_Iirr 0 = 0. +Proof. by rewrite /morph_Iirr irr0 rmorph1 -irr0 irrK. Qed. + +Hypothesis sGD : G \subset D. + +Lemma morph_IirrE i : 'chi_(morph_Iirr i) = cfMorph 'chi_i. +Proof. by rewrite cfIirrE ?cfMorph_irr ?mem_irr. Qed. + +Lemma morph_Iirr_inj : injective morph_Iirr. +Proof. +by move=> i j eq_ij; apply/irr_inj/cfMorph_inj; rewrite // -!morph_IirrE eq_ij. +Qed. + +Lemma morph_Iirr_eq0 i : (morph_Iirr i == 0) = (i == 0). +Proof. by rewrite -!irr_eq1 morph_IirrE cfMorph_eq1. Qed. + +End Morphim. + +Section Isom. + +Variables (aT rT : finGroupType) (G : {group aT}) (f : {morphism G >-> rT}). +Variables (R : {group rT}) (isoGR : isom G R f). +Implicit Type chi : 'CF(G). + +Lemma cfIsom_char chi : chi \is a character -> cfIsom isoGR chi \is a character. +Proof. +by move=> Nchi; rewrite [cfIsom _]locked_withE cfMorph_char ?cfRes_char. +Qed. + +Lemma cfIsom_lin_char chi : + chi \is a linear_char -> cfIsom isoGR chi \is a linear_char. +Proof. by case/andP=> Nchi; rewrite qualifE cfIsom_char ?cfIsom1. Qed. + +Lemma cfIsom_irr chi : chi \in irr G -> cfIsom isoGR chi \in irr R. +Proof. +move=> irr_chi; rewrite [cfIsom _]locked_withE cfMorph_irr //. +by rewrite (isom_im (isom_sym isoGR)) cfRes_id. +Qed. + +Definition isom_Iirr i := cfIirr (cfIsom isoGR 'chi_i). + +Lemma isom_IirrE i : 'chi_(isom_Iirr i) = cfIsom isoGR 'chi_i. +Proof. by rewrite cfIirrE ?cfIsom_irr ?mem_irr. Qed. + +Lemma isom_Iirr_inj : injective isom_Iirr. +Proof. +by move=> i j eqij; apply/irr_inj/(cfIsom_inj isoGR); rewrite -!isom_IirrE eqij. +Qed. + +Lemma isom_Iirr_eq0 i : (isom_Iirr i == 0) = (i == 0). +Proof. by rewrite -!irr_eq1 isom_IirrE cfIsom_eq1. Qed. + +Lemma isom_Iirr0 : isom_Iirr 0 = 0. +Proof. by apply/eqP; rewrite isom_Iirr_eq0. Qed. + +End Isom. + +Implicit Arguments isom_Iirr_inj [aT rT G f R x1 x2]. + +Section IsomInv. + +Variables (aT rT : finGroupType) (G : {group aT}) (f : {morphism G >-> rT}). +Variables (R : {group rT}) (isoGR : isom G R f). + +Lemma isom_IirrK : cancel (isom_Iirr isoGR) (isom_Iirr (isom_sym isoGR)). +Proof. by move=> i; apply: irr_inj; rewrite !isom_IirrE cfIsomK. Qed. + +Lemma isom_IirrKV : cancel (isom_Iirr (isom_sym isoGR)) (isom_Iirr isoGR). +Proof. by move=> i; apply: irr_inj; rewrite !isom_IirrE cfIsomKV. Qed. + +End IsomInv. + +Section OrthogonalityRelations. + +Variables aT gT : finGroupType. + +(* This is Isaacs, Lemma (2.15) *) +Lemma repr_rsim_diag (G : {group gT}) f (rG : mx_representation algCF G f) x : + x \in G -> let chi := cfRepr rG in + exists e, + [/\ (*a*) exists2 B, B \in unitmx & rG x = invmx B *m diag_mx e *m B, + (*b*) (forall i, e 0 i ^+ #[x] = 1) /\ (forall i, `|e 0 i| = 1), + (*c*) chi x = \sum_i e 0 i /\ `|chi x| <= chi 1%g + & (*d*) chi x^-1%g = (chi x)^*]. +Proof. +move=> Gx; without loss cGG: G rG Gx / abelian G. + have sXG: <[x]> \subset G by rewrite cycle_subG. + move/(_ _ (subg_repr rG sXG) (cycle_id x) (cycle_abelian x)). + by rewrite /= !cfunE !groupV Gx (cycle_id x) !group1. +have [I U W simU W1 dxW]: mxsemisimple rG 1%:M. + rewrite -(reducible_Socle1 (DecSocleType rG) (mx_Maschke _ (algC'G G))). + exact: Socle_semisimple. +have linU i: \rank (U i) = 1%N. + by apply: mxsimple_abelian_linear cGG (simU i); exact: groupC. +have castI: f = #|I|. + by rewrite -(mxrank1 algCF f) -W1 (eqnP dxW) /= -sum1_card; exact/eq_bigr. +pose B := \matrix_j nz_row (U (enum_val (cast_ord castI j))). +have rowU i: (nz_row (U i) :=: U i)%MS. + apply/eqmxP; rewrite -(geq_leqif (mxrank_leqif_eq (nz_row_sub _))) linU. + by rewrite lt0n mxrank_eq0 (nz_row_mxsimple (simU i)). +have unitB: B \in unitmx. + rewrite -row_full_unit -sub1mx -W1; apply/sumsmx_subP=> i _. + pose j := cast_ord (esym castI) (enum_rank i). + by rewrite (submx_trans _ (row_sub j B)) // rowK cast_ordKV enum_rankK rowU. +pose e := \row_j row j (B *m rG x *m invmx B) 0 j. +have rGx: rG x = invmx B *m diag_mx e *m B. + rewrite -mulmxA; apply: canRL (mulKmx unitB) _. + apply/row_matrixP=> j; rewrite 2!row_mul; set u := row j B. + have /sub_rVP[a def_ux]: (u *m rG x <= u)%MS. + rewrite /u rowK rowU (eqmxMr _ (rowU _)). + exact: (mxmoduleP (mxsimple_module (simU _))). + rewrite def_ux [u]rowE scalemxAl; congr (_ *m _). + apply/rowP=> k; rewrite 5!mxE !row_mul def_ux [u]rowE scalemxAl mulmxK //. + by rewrite !mxE !eqxx !mulr_natr eq_sym. +have exp_e j: e 0 j ^+ #[x] = 1. + suffices: (diag_mx e j j) ^+ #[x] = (B *m rG (x ^+ #[x])%g *m invmx B) j j. + by rewrite expg_order repr_mx1 mulmx1 mulmxV // [e]lock !mxE eqxx. + elim: #[x] => [|n IHn]; first by rewrite repr_mx1 mulmx1 mulmxV // !mxE eqxx. + rewrite expgS repr_mxM ?groupX // {1}rGx -!mulmxA mulKVmx //. + by rewrite mul_diag_mx mulmxA [M in _ = M]mxE -IHn exprS {1}mxE eqxx. +have norm1_e j: `|e 0 j| = 1. + apply/eqP; rewrite -(@pexpr_eq1 _ _ #[x]) ?normr_ge0 //. + by rewrite -normrX exp_e normr1. +exists e; split=> //; first by exists B. + rewrite cfRepr1 !cfunE Gx rGx mxtrace_mulC mulKVmx // mxtrace_diag. + split=> //=; apply: (ler_trans (ler_norm_sum _ _ _)). + by rewrite (eq_bigr _ (in1W norm1_e)) sumr_const card_ord lerr. +rewrite !cfunE groupV !mulrb Gx rGx mxtrace_mulC mulKVmx //. +rewrite -trace_map_mx map_diag_mx; set d' := diag_mx _. +rewrite -[d'](mulKVmx unitB) mxtrace_mulC -[_ *m _](repr_mxK rG Gx) rGx. +rewrite -!mulmxA mulKVmx // (mulmxA d'). +suffices->: d' *m diag_mx e = 1%:M by rewrite mul1mx mulKmx. +rewrite mulmx_diag -diag_const_mx; congr diag_mx; apply/rowP=> j. +by rewrite [e]lock !mxE mulrC -normCK -lock norm1_e expr1n. +Qed. + +Variables (A : {group aT}) (G : {group gT}). + +(* This is Isaacs, Lemma (2.15) (d). *) +Lemma char_inv (chi : 'CF(G)) x : chi \is a character -> chi x^-1%g = (chi x)^*. +Proof. +case Gx: (x \in G); last by rewrite !cfun0 ?rmorph0 ?groupV ?Gx. +by case/char_reprP=> rG ->; have [e [_ _ _]] := repr_rsim_diag rG Gx. +Qed. + +Lemma irr_inv i x : 'chi[G]_i x^-1%g = ('chi_i x)^*. +Proof. exact/char_inv/irr_char. Qed. + +(* This is Isaacs, Theorem (2.13). *) +Theorem generalized_orthogonality_relation y (i j : Iirr G) : + #|G|%:R^-1 * (\sum_(x in G) 'chi_i (x * y)%g * 'chi_j x^-1%g) + = (i == j)%:R * ('chi_i y / 'chi_i 1%g). +Proof. +pose W := @socle_of_Iirr _ G; pose e k := Wedderburn_id (W k). +pose aG := regular_repr algCF G. +have [Gy | notGy] := boolP (y \in G); last first. + rewrite cfun0 // mul0r big1 ?mulr0 // => x Gx. + by rewrite cfun0 ?groupMl ?mul0r. +transitivity (('chi_i).[e j *m aG y]%CF / 'chi_j 1%g). + rewrite [e j]Wedderburn_id_expansion -scalemxAl xcfunZr -mulrA; congr (_ * _). + rewrite mulmx_suml raddf_sum big_distrl; apply: eq_bigr => x Gx /=. + rewrite -scalemxAl xcfunZr -repr_mxM // xcfunG ?groupM // mulrAC mulrC. + by congr (_ * _); rewrite mulrC mulKf ?irr1_neq0. +rewrite mulr_natl mulrb; have [<-{j} | neq_ij] := altP eqP. + by congr (_ / _); rewrite xcfun_mul_id ?envelop_mx_id ?xcfunG. +rewrite (xcfun_annihilate neq_ij) ?mul0r //. +case/andP: (Wedderburn_ideal (W j)) => _; apply: submx_trans. +by rewrite mem_mulsmx ?Wedderburn_id_mem ?envelop_mx_id. +Qed. + +(* This is Isaacs, Corollary (2.14). *) +Corollary first_orthogonality_relation (i j : Iirr G) : + #|G|%:R^-1 * (\sum_(x in G) 'chi_i x * 'chi_j x^-1%g) = (i == j)%:R. +Proof. +have:= generalized_orthogonality_relation 1 i j. +rewrite mulrA mulfK ?irr1_neq0 // => <-; congr (_ * _). +by apply: eq_bigr => x; rewrite mulg1. +Qed. + +(* The character table. *) + +Definition irr_class i := enum_val (cast_ord (NirrE G) i). +Definition class_Iirr xG := + cast_ord (esym (NirrE G)) (enum_rank_in (classes1 G) xG). + +Local Notation c := irr_class. +Local Notation g i := (repr (c i)). +Local Notation iC := class_Iirr. + +Definition character_table := \matrix_(i, j) 'chi[G]_i (g j). +Local Notation X := character_table. + +Lemma irr_classP i : c i \in classes G. +Proof. exact: enum_valP. Qed. + +Lemma repr_irr_classK i : g i ^: G = c i. +Proof. by case/repr_classesP: (irr_classP i). Qed. + +Lemma irr_classK : cancel c iC. +Proof. by move=> i; rewrite /iC enum_valK_in cast_ordK. Qed. + +Lemma class_IirrK : {in classes G, cancel iC c}. +Proof. by move=> xG GxG; rewrite /c cast_ordKV enum_rankK_in. Qed. + +Lemma reindex_irr_class R idx (op : @Monoid.com_law R idx) F : + \big[op/idx]_(xG in classes G) F xG = \big[op/idx]_i F (c i). +Proof. +rewrite (reindex c); first by apply: eq_bigl => i; exact: enum_valP. +by exists iC; [apply: in1W; exact: irr_classK | exact: class_IirrK]. +Qed. + +(* The explicit value of the inverse is needed for the proof of the second *) +(* orthogonality relation. *) +Let X' := \matrix_(i, j) (#|'C_G[g i]|%:R^-1 * ('chi[G]_j (g i))^*). +Let XX'_1: X *m X' = 1%:M. +Proof. +apply/matrixP=> i j; rewrite !mxE -first_orthogonality_relation mulr_sumr. +rewrite sum_by_classes => [|u v Gu Gv]; last by rewrite -conjVg !cfunJ. +rewrite reindex_irr_class /=; apply/esym/eq_bigr=> k _. +rewrite !mxE irr_inv // -/(g k) -divg_index -indexgI /=. +rewrite (char0_natf_div Cchar) ?dvdn_indexg // index_cent1 invfM invrK. +by rewrite repr_irr_classK mulrCA mulrA mulrCA. +Qed. + +Lemma character_table_unit : X \in unitmx. +Proof. by case/mulmx1_unit: XX'_1. Qed. +Let uX := character_table_unit. + +(* This is Isaacs, Theorem (2.18). *) +Theorem second_orthogonality_relation x y : + y \in G -> + \sum_i 'chi[G]_i x * ('chi_i y)^* = #|'C_G[x]|%:R *+ (x \in y ^: G). +Proof. +move=> Gy; pose i_x := iC (x ^: G); pose i_y := iC (y ^: G). +have [Gx | notGx] := boolP (x \in G); last first. + rewrite (contraNF (subsetP _ x) notGx) ?class_subG ?big1 // => i _. + by rewrite cfun0 ?mul0r. +transitivity ((#|'C_G[repr (y ^: G)]|%:R *: (X' *m X)) i_y i_x). + rewrite scalemxAl !mxE; apply: eq_bigr => k _; rewrite !mxE mulrC -!mulrA. + by rewrite !class_IirrK ?mem_classes // !cfun_repr mulVKf ?neq0CG. +rewrite mulmx1C // !mxE -!divg_index !(index_cent1, =^~ indexgI). +rewrite (class_transr (mem_repr y _)) ?class_refl // mulr_natr. +rewrite (can_in_eq class_IirrK) ?mem_classes //. +have [-> | not_yGx] := altP eqP; first by rewrite class_refl. +by rewrite [x \in _](contraNF _ not_yGx) // => /class_transr->. +Qed. + +Lemma eq_irr_mem_classP x y : + y \in G -> reflect (forall i, 'chi[G]_i x = 'chi_i y) (x \in y ^: G). +Proof. +move=> Gy; apply: (iffP idP) => [/imsetP[z Gz ->] i | xGy]; first exact: cfunJ. +have Gx: x \in G. + congr is_true: Gy; apply/eqP; rewrite -(can_eq oddb) -eqC_nat -!cfun1E. + by rewrite -irr0 xGy. +congr is_true: (class_refl G x); apply/eqP; rewrite -(can_eq oddb). +rewrite -(eqn_pmul2l (cardG_gt0 'C_G[x])) -eqC_nat !mulrnA; apply/eqP. +by rewrite -!second_orthogonality_relation //; apply/eq_bigr=> i _; rewrite xGy. +Qed. + +(* This is Isaacs, Theorem (6.32) (due to Brauer). *) +Lemma card_afix_irr_classes (ito : action A (Iirr G)) (cto : action A _) a : + a \in A -> [acts A, on classes G | cto] -> + (forall i x y, x \in G -> y \in cto (x ^: G) a -> + 'chi_i x = 'chi_(ito i a) y) -> + #|'Fix_ito[a]| = #|'Fix_(classes G | cto)[a]|. +Proof. +move=> Aa actsAG stabAchi; apply/eqP; rewrite -eqC_nat; apply/eqP. +have [[cP cK] iCK] := (irr_classP, irr_classK, class_IirrK). +pose icto b i := iC (cto (c i) b). +have Gca i: cto (c i) a \in classes G by rewrite (acts_act actsAG). +have inj_qa: injective (icto a). + by apply: can_inj (icto a^-1%g) _ => i; rewrite /icto iCK ?actKin ?cK. +pose Pa : 'M[algC]_(Nirr G) := perm_mx (actperm ito a). +pose qa := perm inj_qa; pose Qa : 'M[algC]_(Nirr G) := perm_mx qa^-1^-1%g. +transitivity (\tr Pa). + rewrite -sumr_const big_mkcond; apply: eq_bigr => i _. + by rewrite !mxE permE inE sub1set inE; case: ifP. +symmetry; transitivity (\tr Qa). + rewrite cardsE -sumr_const -big_filter_cond big_mkcond big_filter /=. + rewrite reindex_irr_class; apply: eq_bigr => i _; rewrite !mxE invgK permE. + by rewrite inE sub1set inE -(can_eq cK) iCK //; case: ifP. +rewrite -[Pa](mulmxK uX) -[Qa](mulKmx uX) mxtrace_mulC; congr (\tr(_ *m _)). +rewrite -row_permE -col_permE; apply/matrixP=> i j; rewrite !mxE. +rewrite -{2}[j](permKV qa); move: {j}(_ j) => j; rewrite !permE iCK //. +apply: stabAchi; first by case/repr_classesP: (cP j). +by rewrite repr_irr_classK (mem_repr_classes (Gca _)). +Qed. + +End OrthogonalityRelations. + +Arguments Scope character_table [_ group_scope]. + +Section InnerProduct. + +Variable (gT : finGroupType) (G : {group gT}). + +Lemma cfdot_irr i j : '['chi_i, 'chi_j]_G = (i == j)%:R. +Proof. +rewrite -first_orthogonality_relation; congr (_ * _). +by apply: eq_bigr => x Gx; rewrite irr_inv. +Qed. + +Lemma cfnorm_irr i : '['chi[G]_i] = 1. +Proof. by rewrite cfdot_irr eqxx. Qed. + +Lemma irr_orthonormal : orthonormal (irr G). +Proof. +apply/orthonormalP; split; first exact: free_uniq (irr_free G). +move=> _ _ /irrP[i ->] /irrP[j ->]. +by rewrite cfdot_irr (inj_eq (@irr_inj _ G)). +Qed. + +Lemma coord_cfdot phi i : coord (irr G) i phi = '[phi, 'chi_i]. +Proof. +rewrite {2}(coord_basis (irr_basis G) (memvf phi)). +rewrite cfdot_suml (bigD1 i) // cfdotZl /= -tnth_nth cfdot_irr eqxx mulr1. +rewrite big1 ?addr0 // => j neq_ji; rewrite cfdotZl /= -tnth_nth cfdot_irr. +by rewrite (negbTE neq_ji) mulr0. +Qed. + +Lemma cfun_sum_cfdot phi : phi = \sum_i '[phi, 'chi_i]_G *: 'chi_i. +Proof. +rewrite {1}(coord_basis (irr_basis G) (memvf phi)). +by apply: eq_bigr => i _; rewrite coord_cfdot -tnth_nth. +Qed. + +Lemma cfdot_sum_irr phi psi : + '[phi, psi]_G = \sum_i '[phi, 'chi_i] * '[psi, 'chi_i]^*. +Proof. +rewrite {1}[phi]cfun_sum_cfdot cfdot_suml; apply: eq_bigr => i _. +by rewrite cfdotZl -cfdotC. +Qed. + +Lemma Cnat_cfdot_char_irr i phi : + phi \is a character -> '[phi, 'chi_i]_G \in Cnat. +Proof. by move/forallP/(_ i); rewrite coord_cfdot. Qed. + +Lemma cfdot_char_r phi chi : + chi \is a character -> '[phi, chi]_G = \sum_i '[phi, 'chi_i] * '[chi, 'chi_i]. +Proof. +move=> Nchi; rewrite cfdot_sum_irr; apply: eq_bigr => i _; congr (_ * _). +by rewrite conj_Cnat ?Cnat_cfdot_char_irr. +Qed. + +Lemma Cnat_cfdot_char chi xi : + chi \is a character -> xi \is a character -> '[chi, xi]_G \in Cnat. +Proof. +move=> Nchi Nxi; rewrite cfdot_char_r ?rpred_sum // => i _. +by rewrite rpredM ?Cnat_cfdot_char_irr. +Qed. + +Lemma cfdotC_char chi xi : + chi \is a character-> xi \is a character -> '[chi, xi]_G = '[xi, chi]. +Proof. by move=> Nchi Nxi; rewrite cfdotC conj_Cnat ?Cnat_cfdot_char. Qed. + +Lemma irrEchar chi : (chi \in irr G) = (chi \is a character) && ('[chi] == 1). +Proof. +apply/irrP/andP=> [[i ->] | [Nchi]]; first by rewrite irr_char cfnorm_irr. +rewrite cfdot_sum_irr => /eqP/Cnat_sum_eq1[i _| i [_ ci1 cj0]]. + by rewrite rpredM // ?conj_Cnat ?Cnat_cfdot_char_irr. +exists i; rewrite [chi]cfun_sum_cfdot (bigD1 i) //=. +rewrite -(@normr_idP _ _ (@Cnat_ge0 _ (Cnat_cfdot_char_irr i Nchi))). +rewrite normC_def {}ci1 sqrtC1 scale1r big1 ?addr0 // => j neq_ji. +by rewrite (('[_] =P 0) _) ?scale0r // -normr_eq0 normC_def cj0 ?sqrtC0. +Qed. + +Lemma irrWchar chi : chi \in irr G -> chi \is a character. +Proof. by rewrite irrEchar => /andP[]. Qed. + +Lemma irrWnorm chi : chi \in irr G -> '[chi] = 1. +Proof. by rewrite irrEchar => /andP[_ /eqP]. Qed. + +Lemma mul_lin_irr xi chi : + xi \is a linear_char -> chi \in irr G -> xi * chi \in irr G. +Proof. +move=> Lxi; rewrite !irrEchar => /andP[Nphi /eqP <-]. +rewrite rpredM // ?lin_charW //=; apply/eqP; congr (_ * _). +apply: eq_bigr => x Gx; rewrite !cfunE rmorphM mulrACA -(lin_charV_conj Lxi) //. +by rewrite -lin_charM ?groupV // mulgV lin_char1 ?mul1r. +Qed. + +Lemma eq_scaled_irr a b i j : + (a *: 'chi[G]_i == b *: 'chi_j) = (a == b) && ((a == 0) || (i == j)). +Proof. +apply/eqP/andP=> [|[/eqP-> /pred2P[]-> //]]; last by rewrite !scale0r. +move/(congr1 (cfdotr 'chi__)) => /= eq_ai_bj. +move: {eq_ai_bj}(eq_ai_bj i) (esym (eq_ai_bj j)); rewrite !cfdotZl !cfdot_irr. +by rewrite !mulr_natr !mulrb !eqxx eq_sym orbC; case: ifP => _ -> //= ->. +Qed. + +Lemma eq_signed_irr (s t : bool) i j : + ((-1) ^+ s *: 'chi[G]_i == (-1) ^+ t *: 'chi_j) = (s == t) && (i == j). +Proof. by rewrite eq_scaled_irr signr_eq0 (inj_eq (@signr_inj _)). Qed. + +Lemma eq_scale_irr a (i j : Iirr G) : + (a *: 'chi_i == a *: 'chi_j) = (a == 0) || (i == j). +Proof. by rewrite eq_scaled_irr eqxx. Qed. + +Lemma eq_addZ_irr a b (i j r t : Iirr G) : + (a *: 'chi_i + b *: 'chi_j == a *: 'chi_r + b *: 'chi_t) + = [|| [&& (a == 0) || (i == r) & (b == 0) || (j == t)], + [&& i == t, j == r & a == b] | [&& i == j, r == t & a == - b]]. +Proof. +rewrite -!eq_scale_irr; apply/eqP/idP; last first. + case/orP; first by case/andP=> /eqP-> /eqP->. + case/orP=> /and3P[/eqP-> /eqP-> /eqP->]; first by rewrite addrC. + by rewrite !scaleNr !addNr. +have [-> /addrI/eqP-> // | /= ] := altP eqP. +rewrite eq_scale_irr => /norP[/negP nz_a /negPf neq_ir]. +move/(congr1 (cfdotr 'chi__))/esym/eqP => /= eq_cfdot. +move: {eq_cfdot}(eq_cfdot i) (eq_cfdot r); rewrite eq_sym !cfdotDl !cfdotZl. +rewrite !cfdot_irr !mulr_natr !mulrb !eqxx -!(eq_sym i) neq_ir !add0r. +have [<- _ | _] := i =P t; first by rewrite neq_ir addr0; case: ifP => // _ ->. +rewrite 2!fun_if if_arg addr0 addr_eq0; case: eqP => //= <- ->. +by rewrite neq_ir 2!fun_if if_arg eq_sym addr0; case: ifP. +Qed. + +Lemma eq_subZnat_irr (a b : nat) (i j r t : Iirr G) : + (a%:R *: 'chi_i - b%:R *: 'chi_j == a%:R *: 'chi_r - b%:R *: 'chi_t) + = [|| a == 0%N | i == r] && [|| b == 0%N | j == t] + || [&& i == j, r == t & a == b]. +Proof. +rewrite -!scaleNr eq_addZ_irr oppr_eq0 opprK -addr_eq0 -natrD eqr_nat. +by rewrite !pnatr_eq0 addn_eq0; case: a b => [|a] [|b]; rewrite ?andbF. +Qed. + +End InnerProduct. + +Section Sdprod. + +Variables (gT : finGroupType) (K H G : {group gT}). +Hypothesis defG : K ><| H = G. + +Lemma cfSdprod_char chi : + chi \is a character -> cfSdprod defG chi \is a character. +Proof. by move=> Nchi; rewrite unlock cfMorph_char ?cfIsom_char. Qed. + +Lemma cfSdprod_lin_char chi : + chi \is a linear_char -> cfSdprod defG chi \is a linear_char. +Proof. by move=> Nphi; rewrite unlock cfMorph_lin_char ?cfIsom_lin_char. Qed. + +Lemma cfSdprod_irr chi : chi \in irr H -> cfSdprod defG chi \in irr G. +Proof. +have [/andP[_ nKG] _ _ _ _] := sdprod_context defG. +by move=> Nphi; rewrite unlock cfMorph_irr ?cfIsom_irr. +Qed. + +Definition sdprod_Iirr j := cfIirr (cfSdprod defG 'chi_j). + +Lemma sdprod_IirrE j : 'chi_(sdprod_Iirr j) = cfSdprod defG 'chi_j. +Proof. by rewrite cfIirrE ?cfSdprod_irr ?mem_irr. Qed. + +Lemma sdprod_IirrK : cancel sdprod_Iirr (Res_Iirr H). +Proof. by move=> j; rewrite /Res_Iirr sdprod_IirrE cfSdprodK irrK. Qed. + +Lemma sdprod_Iirr_inj : injective sdprod_Iirr. +Proof. exact: can_inj sdprod_IirrK. Qed. + +Lemma sdprod_Iirr_eq0 i : (sdprod_Iirr i == 0) = (i == 0). +Proof. by rewrite -!irr_eq1 sdprod_IirrE cfSdprod_eq1. Qed. + +Lemma sdprod_Iirr0 : sdprod_Iirr 0 = 0. +Proof. by apply/eqP; rewrite sdprod_Iirr_eq0. Qed. + +Lemma Res_sdprod_irr phi : + K \subset cfker phi -> phi \in irr G -> 'Res phi \in irr H. +Proof. +move=> kerK /irrP[i Dphi]; rewrite irrEchar -(cfSdprod_iso defG). +by rewrite cfRes_sdprodK // Dphi cfnorm_irr cfRes_char ?irr_char /=. +Qed. + +Lemma sdprod_Res_IirrE i : + K \subset cfker 'chi[G]_i -> 'chi_(Res_Iirr H i) = 'Res 'chi_i. +Proof. by move=> kerK; rewrite cfIirrE ?Res_sdprod_irr ?mem_irr. Qed. + +Lemma sdprod_Res_IirrK i : + K \subset cfker 'chi_i -> sdprod_Iirr (Res_Iirr H i) = i. +Proof. +by move=> kerK; rewrite /sdprod_Iirr sdprod_Res_IirrE ?cfRes_sdprodK ?irrK. +Qed. + +End Sdprod. + +Implicit Arguments sdprod_Iirr_inj [gT K H G x1 x2]. + +Section DProd. + +Variables (gT : finGroupType) (G K H : {group gT}). +Hypothesis KxH : K \x H = G. + +Lemma cfDprodKl_abelian j : abelian H -> cancel ((cfDprod KxH)^~ 'chi_j) 'Res. +Proof. by move=> cHH; apply: cfDprodKl; apply/lin_char1/char_abelianP. Qed. + +Lemma cfDprodKr_abelian i : abelian K -> cancel (cfDprod KxH 'chi_i) 'Res. +Proof. by move=> cKK; apply: cfDprodKr; apply/lin_char1/char_abelianP. Qed. + +Lemma cfDprodl_char phi : + phi \is a character -> cfDprodl KxH phi \is a character. +Proof. exact: cfSdprod_char. Qed. + +Lemma cfDprodr_char psi : + psi \is a character -> cfDprodr KxH psi \is a character. +Proof. exact: cfSdprod_char. Qed. + +Lemma cfDprod_char phi psi : + phi \is a character -> psi \is a character -> + cfDprod KxH phi psi \is a character. +Proof. by move=> /cfDprodl_char Nphi /cfDprodr_char; apply: rpredM. Qed. + +Lemma cfDprod_eq1 phi psi : + phi \is a character -> psi \is a character -> + (cfDprod KxH phi psi == 1) = (phi == 1) && (psi == 1). +Proof. +move=> /Cnat_char1 Nphi /Cnat_char1 Npsi. +apply/eqP/andP=> [phi_psi_1 | [/eqP-> /eqP->]]; last by rewrite cfDprod_cfun1. +have /andP[/eqP phi1 /eqP psi1]: (phi 1%g == 1) && (psi 1%g == 1). + by rewrite -Cnat_mul_eq1 // -(cfDprod1 KxH) phi_psi_1 cfun11. +rewrite -[phi](cfDprodKl KxH psi1) -{2}[psi](cfDprodKr KxH phi1) phi_psi_1. +by rewrite !rmorph1. +Qed. + +Lemma cfDprodl_lin_char phi : + phi \is a linear_char -> cfDprodl KxH phi \is a linear_char. +Proof. exact: cfSdprod_lin_char. Qed. + +Lemma cfDprodr_lin_char psi : + psi \is a linear_char -> cfDprodr KxH psi \is a linear_char. +Proof. exact: cfSdprod_lin_char. Qed. + +Lemma cfDprod_lin_char phi psi : + phi \is a linear_char -> psi \is a linear_char -> + cfDprod KxH phi psi \is a linear_char. +Proof. by move=> /cfDprodl_lin_char Lphi /cfDprodr_lin_char; apply: rpredM. Qed. + +Lemma cfDprodl_irr chi : chi \in irr K -> cfDprodl KxH chi \in irr G. +Proof. exact: cfSdprod_irr. Qed. + +Lemma cfDprodr_irr chi : chi \in irr H -> cfDprodr KxH chi \in irr G. +Proof. exact: cfSdprod_irr. Qed. + +Definition dprodl_Iirr i := cfIirr (cfDprodl KxH 'chi_i). + +Lemma dprodl_IirrE i : 'chi_(dprodl_Iirr i) = cfDprodl KxH 'chi_i. +Proof. exact: sdprod_IirrE. Qed. +Lemma dprodl_IirrK : cancel dprodl_Iirr (Res_Iirr K). +Proof. exact: sdprod_IirrK. Qed. +Lemma dprodl_Iirr_eq0 i : (dprodl_Iirr i == 0) = (i == 0). +Proof. exact: sdprod_Iirr_eq0. Qed. +Lemma dprodl_Iirr0 : dprodl_Iirr 0 = 0. +Proof. exact: sdprod_Iirr0. Qed. + +Definition dprodr_Iirr j := cfIirr (cfDprodr KxH 'chi_j). + +Lemma dprodr_IirrE j : 'chi_(dprodr_Iirr j) = cfDprodr KxH 'chi_j. +Proof. exact: sdprod_IirrE. Qed. +Lemma dprodr_IirrK : cancel dprodr_Iirr (Res_Iirr H). +Proof. exact: sdprod_IirrK. Qed. +Lemma dprodr_Iirr_eq0 j : (dprodr_Iirr j == 0) = (j == 0). +Proof. exact: sdprod_Iirr_eq0. Qed. +Lemma dprodr_Iirr0 : dprodr_Iirr 0 = 0. +Proof. exact: sdprod_Iirr0. Qed. + +Lemma cfDprod_irr i j : cfDprod KxH 'chi_i 'chi_j \in irr G. +Proof. +rewrite irrEchar cfDprod_char ?irr_char //=. +by rewrite cfdot_dprod !cfdot_irr !eqxx mul1r. +Qed. + +Definition dprod_Iirr ij := cfIirr (cfDprod KxH 'chi_ij.1 'chi_ij.2). + +Lemma dprod_IirrE i j : 'chi_(dprod_Iirr (i, j)) = cfDprod KxH 'chi_i 'chi_j. +Proof. by rewrite cfIirrE ?cfDprod_irr. Qed. + +Lemma dprod_IirrEl i : 'chi_(dprod_Iirr (i, 0)) = cfDprodl KxH 'chi_i. +Proof. by rewrite dprod_IirrE /cfDprod irr0 rmorph1 mulr1. Qed. + +Lemma dprod_IirrEr j : 'chi_(dprod_Iirr (0, j)) = cfDprodr KxH 'chi_j. +Proof. by rewrite dprod_IirrE /cfDprod irr0 rmorph1 mul1r. Qed. + +Lemma dprod_Iirr_inj : injective dprod_Iirr. +Proof. +move=> [i1 j1] [i2 j2] /eqP; rewrite -[_ == _]oddb -(natCK (_ == _)). +rewrite -cfdot_irr !dprod_IirrE cfdot_dprod !cfdot_irr -natrM mulnb. +by rewrite natCK oddb -xpair_eqE => /eqP. +Qed. + +Lemma dprod_Iirr0 : dprod_Iirr (0, 0) = 0. +Proof. by apply/irr_inj; rewrite dprod_IirrE !irr0 cfDprod_cfun1. Qed. + +Lemma dprod_Iirr0l j : dprod_Iirr (0, j) = dprodr_Iirr j. +Proof. +by apply/irr_inj; rewrite dprod_IirrE irr0 dprodr_IirrE cfDprod_cfun1l. +Qed. + +Lemma dprod_Iirr0r i : dprod_Iirr (i, 0) = dprodl_Iirr i. +Proof. +by apply/irr_inj; rewrite dprod_IirrE irr0 dprodl_IirrE cfDprod_cfun1r. +Qed. + +Lemma dprod_Iirr_eq0 i j : (dprod_Iirr (i, j) == 0) = (i == 0) && (j == 0). +Proof. by rewrite -xpair_eqE -(inj_eq dprod_Iirr_inj) dprod_Iirr0. Qed. + +Lemma cfdot_dprod_irr i1 i2 j1 j2 : + '['chi_(dprod_Iirr (i1, j1)), 'chi_(dprod_Iirr (i2, j2))] + = ((i1 == i2) && (j1 == j2))%:R. +Proof. by rewrite cfdot_irr (inj_eq dprod_Iirr_inj). Qed. + +Lemma dprod_Iirr_onto k : k \in codom dprod_Iirr. +Proof. +set D := codom _; have Df: dprod_Iirr _ \in D := codom_f dprod_Iirr _. +have: 'chi_k 1%g ^+ 2 != 0 by rewrite mulf_neq0 ?irr1_neq0. +apply: contraR => notDk; move/eqP: (irr_sum_square G). +rewrite (bigID (mem D)) (reindex _ (bij_on_codom dprod_Iirr_inj (0, 0))) /=. +have ->: #|G|%:R = \sum_i \sum_j 'chi_(dprod_Iirr (i, j)) 1%g ^+ 2. + rewrite -(dprod_card KxH) natrM. + do 2![rewrite -irr_sum_square (mulr_suml, mulr_sumr); apply: eq_bigr => ? _]. + by rewrite dprod_IirrE -exprMn -{3}(mulg1 1%g) cfDprodE. +rewrite (eq_bigl _ _ Df) pair_bigA addrC -subr_eq0 addrK. +by move/eqP/psumr_eq0P=> -> //= i _; rewrite irr1_degree -natrX ler0n. +Qed. + +Definition inv_dprod_Iirr i := iinv (dprod_Iirr_onto i). + +Lemma dprod_IirrK : cancel dprod_Iirr inv_dprod_Iirr. +Proof. by move=> p; exact: (iinv_f dprod_Iirr_inj). Qed. + +Lemma inv_dprod_IirrK : cancel inv_dprod_Iirr dprod_Iirr. +Proof. by move=> i; exact: f_iinv. Qed. + +Lemma inv_dprod_Iirr0 : inv_dprod_Iirr 0 = (0, 0). +Proof. by apply/(canLR dprod_IirrK); rewrite dprod_Iirr0. Qed. + +End DProd. + +Implicit Arguments dprod_Iirr_inj [gT G K H x1 x2]. + +Lemma dprod_IirrC (gT : finGroupType) (G K H : {group gT}) + (KxH : K \x H = G) (HxK : H \x K = G) i j : + dprod_Iirr KxH (i, j) = dprod_Iirr HxK (j, i). +Proof. by apply: irr_inj; rewrite !dprod_IirrE; apply: cfDprodC. Qed. + +Section BigDprod. + +Variables (gT : finGroupType) (I : finType) (P : pred I). +Variables (A : I -> {group gT}) (G : {group gT}). +Hypothesis defG : \big[dprod/1%g]_(i | P i) A i = G. + +Let sAG i : P i -> A i \subset G. +Proof. by move=> Pi; rewrite -(bigdprodWY defG) (bigD1 i) ?joing_subl. Qed. + +Lemma cfBigdprodi_char i (phi : 'CF(A i)) : + phi \is a character -> cfBigdprodi defG phi \is a character. +Proof. by move=> Nphi; rewrite cfDprodl_char ?cfRes_char. Qed. + +Lemma cfBigdprod_char phi : + (forall i, P i -> phi i \is a character) -> + cfBigdprod defG phi \is a character. +Proof. +by move=> Nphi; apply: rpred_prod => i /Nphi; apply: cfBigdprodi_char. +Qed. + +Lemma cfBigdprodi_lin_char i (phi : 'CF(A i)) : + phi \is a linear_char -> cfBigdprodi defG phi \is a linear_char. +Proof. by move=> Lphi; rewrite cfDprodl_lin_char ?cfRes_lin_char. Qed. + +Lemma cfBigdprod_lin_char phi : + (forall i, P i -> phi i \is a linear_char) -> + cfBigdprod defG phi \is a linear_char. +Proof. +by move=> Lphi; apply/rpred_prod=> i /Lphi; apply: cfBigdprodi_lin_char. +Qed. + +Lemma cfBigdprodi_irr i chi : + P i -> chi \in irr (A i) -> cfBigdprodi defG chi \in irr G. +Proof. by move=> Pi Nchi; rewrite cfDprodl_irr // Pi cfRes_id. Qed. + +Lemma cfBigdprod_irr chi : + (forall i, P i -> chi i \in irr (A i)) -> cfBigdprod defG chi \in irr G. +Proof. +move=> Nchi; rewrite irrEchar cfBigdprod_char => [|i /Nchi/irrWchar] //=. +by rewrite cfdot_bigdprod big1 // => i /Nchi/irrWnorm. +Qed. + +Lemma cfBigdprod_eq1 phi : + (forall i, P i -> phi i \is a character) -> + (cfBigdprod defG phi == 1) = [forall (i | P i), phi i == 1]. +Proof. +move=> Nphi; set Phi := cfBigdprod defG phi. +apply/eqP/eqfun_inP=> [Phi1 i Pi | phi1]; last first. + by apply: big1 => i /phi1->; rewrite rmorph1. +have Phi1_1: Phi 1%g = 1 by rewrite Phi1 cfun1E group1. +have nz_Phi1: Phi 1%g != 0 by rewrite Phi1_1 oner_eq0. +have [_ <-] := cfBigdprodK nz_Phi1 Pi. +rewrite Phi1_1 divr1 -/Phi Phi1 rmorph1. +rewrite prod_cfunE // in Phi1_1; have := Cnat_prod_eq1 _ Phi1_1 Pi. +rewrite -(cfRes1 (A i)) cfBigdprodiK // => ->; first by rewrite scale1r. +by move=> {i Pi} j /Nphi Nphi_j; rewrite Cnat_char1 ?cfBigdprodi_char. +Qed. + +Lemma cfBigdprod_Res_lin chi : + chi \is a linear_char -> cfBigdprod defG (fun i => 'Res[A i] chi) = chi. +Proof. +move=> Lchi; apply/cfun_inP=> _ /(mem_bigdprod defG)[x [Ax -> _]]. +rewrite (lin_char_prod Lchi) ?cfBigdprodE // => [|i Pi]; last first. + by rewrite (subsetP (sAG Pi)) ?Ax. +by apply/eq_bigr=> i Pi; rewrite cfResE ?sAG ?Ax. +Qed. + +Lemma cfBigdprodKlin phi : + (forall i, P i -> phi i \is a linear_char) -> + forall i, P i -> 'Res (cfBigdprod defG phi) = phi i. +Proof. +move=> Lphi i Pi; have Lpsi := cfBigdprod_lin_char Lphi. +have [_ <-] := cfBigdprodK (lin_char_neq0 Lpsi (group1 G)) Pi. +by rewrite !lin_char1 ?Lphi // divr1 scale1r. +Qed. + +Lemma cfBigdprodKabelian Iphi (phi := fun i => 'chi_(Iphi i)) : + abelian G -> forall i, P i -> 'Res (cfBigdprod defG phi) = 'chi_(Iphi i). +Proof. +move=> /(abelianS _) cGG. +by apply: cfBigdprodKlin => i /sAG/cGG/char_abelianP->. +Qed. + +End BigDprod. + +Section Aut. + +Variables (gT : finGroupType) (G : {group gT}). +Implicit Type u : {rmorphism algC -> algC}. + +Lemma conjC_charAut u (chi : 'CF(G)) x : + chi \is a character -> (u (chi x))^* = u (chi x)^*. +Proof. +have [Gx | /cfun0->] := boolP (x \in G); last by rewrite !rmorph0. +case/char_reprP=> rG ->; have [e [_ [en1 _] [-> _] _]] := repr_rsim_diag rG Gx. +by rewrite !rmorph_sum; apply: eq_bigr => i _; exact: aut_unity_rootC (en1 i). +Qed. + +Lemma conjC_irrAut u i x : (u ('chi[G]_i x))^* = u ('chi_i x)^*. +Proof. exact: conjC_charAut (irr_char i). Qed. + +Lemma cfdot_aut_char u (phi chi : 'CF(G)) : + chi \is a character -> '[cfAut u phi, cfAut u chi] = u '[phi, chi]. +Proof. by move/conjC_charAut=> Nchi; apply: cfdot_cfAut => _ /mapP[x _ ->]. Qed. + +Lemma cfdot_aut_irr u phi i : + '[cfAut u phi, cfAut u 'chi[G]_i] = u '[phi, 'chi_i]. +Proof. exact: cfdot_aut_char (irr_char i). Qed. + +Lemma cfAut_irr u chi : chi \in irr G -> cfAut u chi \in irr G. +Proof. +case/irrP=> i ->; rewrite irrEchar cfAut_char ?irr_char //=. +by rewrite cfdot_aut_irr // cfdot_irr eqxx rmorph1. +Qed. + +Lemma cfConjC_irr i : (('chi_i)^*)%CF \in irr G. +Proof. by rewrite cfAut_irr ?mem_irr. Qed. + +Lemma irr_aut_closed u : cfAut_closed u (irr G). +Proof. exact: cfAut_irr. Qed. + +Definition aut_Iirr u i := cfIirr (cfAut u 'chi[G]_i). + +Lemma aut_IirrE u i : 'chi_(aut_Iirr u i) = cfAut u 'chi_i. +Proof. by rewrite cfIirrE ?cfAut_irr ?mem_irr. Qed. + +Definition conjC_Iirr := aut_Iirr conjC. + +Lemma conjC_IirrE i : 'chi[G]_(conjC_Iirr i) = ('chi_i)^*%CF. +Proof. exact: aut_IirrE. Qed. + +Lemma conjC_IirrK : involutive conjC_Iirr. +Proof. by move=> i; apply: irr_inj; rewrite !conjC_IirrE cfConjCK. Qed. + +Lemma aut_Iirr0 u : aut_Iirr u 0 = 0 :> Iirr G. +Proof. by apply/irr_inj; rewrite aut_IirrE irr0 cfAut_cfun1. Qed. + +Lemma conjC_Iirr0 : conjC_Iirr 0 = 0 :> Iirr G. +Proof. exact: aut_Iirr0. Qed. + +Lemma aut_Iirr_eq0 u i : (aut_Iirr u i == 0) = (i == 0). +Proof. by rewrite -!irr_eq1 aut_IirrE cfAut_eq1. Qed. + +Lemma conjC_Iirr_eq0 i : (conjC_Iirr i == 0 :> Iirr G) = (i == 0). +Proof. exact: aut_Iirr_eq0. Qed. + +Lemma aut_Iirr_inj u : injective (aut_Iirr u). +Proof. +by move=> i j eq_ij; apply/irr_inj/(cfAut_inj u); rewrite -!aut_IirrE eq_ij. +Qed. + +Lemma char_aut u (chi : 'CF(G)) : + (cfAut u chi \is a character) = (chi \is a character). +Proof. +apply/idP/idP=> [Nuchi|]; last exact: cfAut_char. +rewrite [chi]cfun_sum_cfdot rpred_sum // => i _. +rewrite rpredZ_Cnat ?irr_char // -(Cnat_aut u) -cfdot_aut_irr. +by rewrite -aut_IirrE Cnat_cfdot_char_irr. +Qed. + +Lemma irr_aut u chi : (cfAut u chi \in irr G) = (chi \in irr G). +Proof. +rewrite !irrEchar char_aut; apply/andb_id2l=> /cfdot_aut_char->. +by rewrite fmorph_eq1. +Qed. + +End Aut. + +Section IrrConstt. + +Variable (gT : finGroupType) (G H : {group gT}). + +Lemma char1_ge_norm (chi : 'CF(G)) x : + chi \is a character -> `|chi x| <= chi 1%g. +Proof. +case/char_reprP=> rG ->; case Gx: (x \in G); last first. + by rewrite cfunE cfRepr1 Gx normr0 ler0n. +by have [e [_ _ []]] := repr_rsim_diag rG Gx. +Qed. + +Lemma max_cfRepr_norm_scalar n (rG : mx_representation algCF G n) x : + x \in G -> `|cfRepr rG x| = cfRepr rG 1%g -> + exists2 c, `|c| = 1 & rG x = c%:M. +Proof. +move=> Gx; have [e [[B uB def_x] [_ e1] [-> _] _]] := repr_rsim_diag rG Gx. +rewrite cfRepr1 -[n in n%:R]card_ord -sumr_const -(eq_bigr _ (in1W e1)). +case/normC_sum_eq1=> [i _ | c /eqP norm_c_1 def_e]; first by rewrite e1. +have{def_e} def_e: e = const_mx c by apply/rowP=> i; rewrite mxE def_e ?andbT. +by exists c => //; rewrite def_x def_e diag_const_mx scalar_mxC mulmxKV. +Qed. + +Lemma max_cfRepr_mx1 n (rG : mx_representation algCF G n) x : + x \in G -> cfRepr rG x = cfRepr rG 1%g -> rG x = 1%:M. +Proof. +move=> Gx kerGx; have [|c _ def_x] := @max_cfRepr_norm_scalar n rG x Gx. + by rewrite kerGx cfRepr1 normr_nat. +move/eqP: kerGx; rewrite cfRepr1 cfunE Gx {rG}def_x mxtrace_scalar. +case: n => [_|n]; first by rewrite ![_%:M]flatmx0. +rewrite mulrb -subr_eq0 -mulrnBl -mulr_natl mulf_eq0 pnatr_eq0 /=. +by rewrite subr_eq0 => /eqP->. +Qed. + +Definition irr_constt (B : {set gT}) phi := [pred i | '[phi, 'chi_i]_B != 0]. + +Lemma irr_consttE i phi : (i \in irr_constt phi) = ('[phi, 'chi_i]_G != 0). +Proof. by []. Qed. + +Lemma constt_charP (i : Iirr G) chi : + chi \is a character -> + reflect (exists2 chi', chi' \is a character & chi = 'chi_i + chi') + (i \in irr_constt chi). +Proof. +move=> Nchi; apply: (iffP idP) => [i_in_chi| [chi' Nchi' ->]]; last first. + rewrite inE /= cfdotDl cfdot_irr eqxx -(eqP (Cnat_cfdot_char_irr i Nchi')). + by rewrite -natrD pnatr_eq0. +exists (chi - 'chi_i); last by rewrite addrC subrK. +apply/forallP=> j; rewrite coord_cfdot cfdotBl cfdot_irr. +have [<- | _] := eqP; last by rewrite subr0 Cnat_cfdot_char_irr. +have := i_in_chi; rewrite inE /= -(eqP (Cnat_cfdot_char_irr i Nchi)) pnatr_eq0. +by case: (truncC _) => // n _; rewrite mulrSr addrK ?isNatC_nat. +Qed. + +Lemma cfun_sum_constt (phi : 'CF(G)) : + phi = \sum_(i in irr_constt phi) '[phi, 'chi_i] *: 'chi_i. +Proof. +rewrite {1}[phi]cfun_sum_cfdot (bigID [pred i | '[phi, 'chi_i] == 0]) /=. +by rewrite big1 ?add0r // => i /eqP->; rewrite scale0r. +Qed. + +Lemma neq0_has_constt (phi : 'CF(G)) : + phi != 0 -> exists i, i \in irr_constt phi. +Proof. +move=> nz_phi; apply/existsP; apply: contra nz_phi => /pred0P phi0. +by rewrite [phi]cfun_sum_constt big_pred0. +Qed. + +Lemma constt_irr i : irr_constt 'chi[G]_i =i pred1 i. +Proof. +by move=> j; rewrite !inE cfdot_irr pnatr_eq0 (eq_sym j); case: (i == j). +Qed. + +Lemma char1_ge_constt (i : Iirr G) chi : + chi \is a character -> i \in irr_constt chi -> 'chi_i 1%g <= chi 1%g. +Proof. +move=> {chi} _ /constt_charP[// | chi Nchi ->]. +by rewrite cfunE addrC -subr_ge0 addrK char1_ge0. +Qed. + +Lemma constt_ortho_char (phi psi : 'CF(G)) i j : + phi \is a character -> psi \is a character -> + i \in irr_constt phi -> j \in irr_constt psi -> + '[phi, psi] = 0 -> '['chi_i, 'chi_j] = 0. +Proof. +move=> _ _ /constt_charP[//|phi1 Nphi1 ->] /constt_charP[//|psi1 Npsi1 ->]. +rewrite cfdot_irr; case: eqP => // -> /eqP/idPn[]. +rewrite cfdotDl !cfdotDr cfnorm_irr -addrA gtr_eqF ?ltr_paddr ?ltr01 //. +by rewrite Cnat_ge0 ?rpredD ?Cnat_cfdot_char ?irr_char. +Qed. + +End IrrConstt. + +Arguments Scope irr_constt [_ group_scope cfun_scope]. +Implicit Arguments aut_Iirr_inj [gT G x1 x2]. + +Section MoreConstt. + +Variables (gT : finGroupType) (G H : {group gT}). + +Lemma constt_Ind_Res i j : + i \in irr_constt ('Ind[G] 'chi_j) = (j \in irr_constt ('Res[H] 'chi_i)). +Proof. by rewrite !irr_consttE cfdotC conjC_eq0 -cfdot_Res_l. Qed. + +Lemma cfdot_Res_ge_constt i j psi : + psi \is a character -> j \in irr_constt psi -> + '['Res[H, G] 'chi_j, 'chi_i] <= '['Res[H] psi, 'chi_i]. +Proof. +move=> {psi} _ /constt_charP[// | psi Npsi ->]. +rewrite linearD cfdotDl addrC -subr_ge0 addrK Cnat_ge0 //=. +by rewrite Cnat_cfdot_char_irr // cfRes_char. +Qed. + +Lemma constt_Res_trans j psi : + psi \is a character -> j \in irr_constt psi -> + {subset irr_constt ('Res[H, G] 'chi_j) <= irr_constt ('Res[H] psi)}. +Proof. +move=> Npsi Cj i; apply: contraNneq; rewrite eqr_le => {1}<-. +rewrite cfdot_Res_ge_constt ?Cnat_ge0 ?Cnat_cfdot_char_irr //. +by rewrite cfRes_char ?irr_char. +Qed. + +End MoreConstt. + +Section Kernel. + +Variable (gT : finGroupType) (G : {group gT}). +Implicit Types (phi chi xi : 'CF(G)) (H : {group gT}). + +Lemma cfker_repr n (rG : mx_representation algCF G n) : + cfker (cfRepr rG) = rker rG. +Proof. +apply/esym/setP=> x; rewrite inE mul1mx /=. +case Gx: (x \in G); last by rewrite inE Gx. +apply/eqP/idP=> Kx; last by rewrite max_cfRepr_mx1 // cfker1. +rewrite inE Gx; apply/forallP=> y; rewrite !cfunE !mulrb groupMl //. +by case: ifP => // Gy; rewrite repr_mxM // Kx mul1mx. +Qed. + +Lemma cfkerEchar chi : + chi \is a character -> cfker chi = [set x in G | chi x == chi 1%g]. +Proof. +move=> Nchi; apply/setP=> x; apply/idP/setIdP=> [Kx | [Gx /eqP chi_x]]. + by rewrite (subsetP (cfker_sub chi)) // cfker1. +case/char_reprP: Nchi => rG -> in chi_x *; rewrite inE Gx; apply/forallP=> y. +rewrite !cfunE groupMl // !mulrb; case: ifP => // Gy. +by rewrite repr_mxM // max_cfRepr_mx1 ?mul1mx. +Qed. + +Lemma cfker_nzcharE chi : + chi \is a character -> chi != 0 -> cfker chi = [set x | chi x == chi 1%g]. +Proof. +move=> Nchi nzchi; apply/setP=> x; rewrite cfkerEchar // !inE andb_idl //. +by apply: contraLR => /cfun0-> //; rewrite eq_sym char1_eq0. +Qed. + +Lemma cfkerEirr i : cfker 'chi[G]_i = [set x | 'chi_i x == 'chi_i 1%g]. +Proof. by rewrite cfker_nzcharE ?irr_char ?irr_neq0. Qed. + +Lemma cfker_irr0 : cfker 'chi[G]_0 = G. +Proof. by rewrite irr0 cfker_cfun1. Qed. + +Lemma cfaithful_reg : cfaithful (cfReg G). +Proof. +apply/subsetP=> x; rewrite cfkerEchar ?cfReg_char // !inE !cfRegE eqxx. +by case/andP=> _; apply: contraLR => /negbTE->; rewrite eq_sym neq0CG. +Qed. + +Lemma cfkerE chi : + chi \is a character -> + cfker chi = G :&: \bigcap_(i in irr_constt chi) cfker 'chi_i. +Proof. +move=> Nchi; rewrite cfkerEchar //; apply/setP=> x; rewrite !inE. +apply: andb_id2l => Gx; rewrite {1 2}[chi]cfun_sum_constt !sum_cfunE. +apply/eqP/bigcapP=> [Kx i Ci | Kx]; last first. + by apply: eq_bigr => i /Kx Kx_i; rewrite !cfunE cfker1. +rewrite cfkerEirr inE /= -(inj_eq (mulfI Ci)). +have:= (normC_sum_upper _ Kx) i; rewrite !cfunE => -> // {i Ci} i _. +have chi_i_ge0: 0 <= '[chi, 'chi_i]. + by rewrite Cnat_ge0 ?Cnat_cfdot_char_irr. +by rewrite !cfunE normrM (normr_idP _) ?ler_wpmul2l ?char1_ge_norm ?irr_char. +Qed. + +Lemma TI_cfker_irr : \bigcap_i cfker 'chi[G]_i = [1]. +Proof. +apply/trivgP; apply: subset_trans cfaithful_reg; rewrite cfkerE ?cfReg_char //. +rewrite subsetI (bigcap_min 0) //=; last by rewrite cfker_irr0. +by apply/bigcapsP=> i _; rewrite bigcap_inf. +Qed. + +Lemma cfker_constt i chi : + chi \is a character -> i \in irr_constt chi -> + cfker chi \subset cfker 'chi[G]_i. +Proof. by move=> Nchi Ci; rewrite cfkerE ?subIset ?(bigcap_min i) ?orbT. Qed. + +Section KerLin. + +Variable xi : 'CF(G). +Hypothesis lin_xi : xi \is a linear_char. +Let Nxi: xi \is a character. Proof. by have [] := andP lin_xi. Qed. + +Lemma lin_char_der1 : G^`(1)%g \subset cfker xi. +Proof. +rewrite gen_subG /=; apply/subsetP=> _ /imset2P[x y Gx Gy ->]. +rewrite cfkerEchar // inE groupR //= !lin_charM ?lin_charV ?in_group //. +by rewrite mulrCA mulKf ?mulVf ?lin_char_neq0 // lin_char1. +Qed. + +Lemma cforder_lin_char : #[xi]%CF = exponent (G / cfker xi)%g. +Proof. +apply/eqP; rewrite eqn_dvd; apply/andP; split. + apply/dvdn_cforderP=> x Gx; rewrite -lin_charX // -cfQuoEker ?groupX //. + rewrite morphX ?(subsetP (cfker_norm xi)) //= expg_exponent ?mem_quotient //. + by rewrite cfQuo1 ?cfker_normal ?lin_char1. +have abGbar: abelian (G / cfker xi) := sub_der1_abelian lin_char_der1. +have [_ /morphimP[x Nx Gx ->] ->] := exponent_witness (abelian_nil abGbar). +rewrite order_dvdn -morphX //= coset_id cfkerEchar // !inE groupX //=. +by rewrite lin_charX ?lin_char1 // (dvdn_cforderP _ _ _). +Qed. + +Lemma cforder_lin_char_dvdG : #[xi]%CF %| #|G|. +Proof. +by rewrite cforder_lin_char (dvdn_trans (exponent_dvdn _)) ?dvdn_morphim. +Qed. + +Lemma cforder_lin_char_gt0 : (0 < #[xi]%CF)%N. +Proof. by rewrite cforder_lin_char exponent_gt0. Qed. + +End KerLin. + +End Kernel. + +Section Coset. + +Variable (gT : finGroupType). + +Implicit Types G H : {group gT}. + +Lemma cfQuo_char G H (chi : 'CF(G)) : + chi \is a character -> (chi / H)%CF \is a character. +Proof. +move=> Nchi; case KchiH: (H \subset cfker chi); last first. + suffices ->: (chi / H)%CF = (chi 1%g)%:A. + by rewrite rpredZ_Cnat ?Cnat_char1 ?rpred1. + by apply/cfunP=> x; rewrite cfunE cfun1E mulr_natr cfunElock KchiH. +have sHG := subset_trans KchiH (cfker_sub _). +pose N := 'N_G(H); pose phi := 'Res[N] chi. +have nsHN: H <| N by [rewrite normal_subnorm]; have [sHN nHN] := andP nsHN. +have{Nchi} Nphi: phi \is a character by apply: cfRes_char. +have KphiH: H \subset cfker phi. + apply/subsetP=> x Hx; have [Kx Nx] := (subsetP KchiH x Hx, subsetP sHN x Hx). + by rewrite cfkerEchar // inE Nx cfRes1 cfResE ?subsetIl //= cfker1. +pose psi := 'Res[(N / H)%g] (chi / H)%CF. +have ->: (chi / H)%CF = 'Res psi by rewrite /psi quotientInorm !cfRes_id. +have{KchiH} ->: psi = (phi / H)%CF. + apply/cfun_inP => _ /morphimP[x nHx Nx ->]; have [Gx _] := setIP Nx. + rewrite cfResE ?mem_quotient ?quotientS ?subsetIl // cfQuoEnorm //. + by rewrite cfQuoE ?cfResE ?subsetIl. +have [rG Dphi] := char_reprP Nphi; rewrite {phi Nphi}Dphi cfker_repr in KphiH *. +apply/cfRes_char/char_reprP; exists (Representation (quo_repr KphiH nHN)). +apply/cfun_inP=> _ /morphimP[x nHx Nx ->]; rewrite cfQuoE ?cfker_repr //=. +by rewrite !cfunE Nx quo_repr_coset ?mem_quotient. +Qed. + +Lemma cfQuo_lin_char G H (chi : 'CF(G)) : + chi \is a linear_char -> (chi / H)%CF \is a linear_char. +Proof. by case/andP=> Nchi; rewrite qualifE cfQuo_char ?cfQuo1. Qed. + +Lemma cfMod_char G H (chi : 'CF(G / H)) : + chi \is a character -> (chi %% H)%CF \is a character. +Proof. exact: cfMorph_char. Qed. + +Lemma cfMod_lin_char G H (chi : 'CF(G / H)) : + chi \is a linear_char -> (chi %% H)%CF \is a linear_char. +Proof. exact: cfMorph_lin_char. Qed. + +Lemma cfMod_irr G H chi : + H <| G -> chi \in irr (G / H) -> (chi %% H)%CF \in irr G. +Proof. by case/andP=> _; apply: cfMorph_irr. Qed. + +Definition mod_Iirr G H i := cfIirr ('chi[G / H]_i %% H)%CF. + +Lemma mod_Iirr0 G H : mod_Iirr (0 : Iirr (G / H)) = 0. +Proof. exact: morph_Iirr0. Qed. + +Lemma mod_IirrE G H i : H <| G -> 'chi_(mod_Iirr i) = ('chi[G / H]_i %% H)%CF. +Proof. by move=> nsHG; rewrite cfIirrE ?cfMod_irr ?mem_irr. Qed. + +Lemma mod_Iirr_eq0 G H i : + H <| G -> (mod_Iirr i == 0) = (i == 0 :> Iirr (G / H)). +Proof. by case/andP=> _ /morph_Iirr_eq0->. Qed. + +Lemma cfQuo_irr G H chi : + H <| G -> H \subset cfker chi -> chi \in irr G -> + (chi / H)%CF \in irr (G / H). +Proof. +move=> nsHG sHK /irr_reprP[rG irrG Dchi]; have [sHG nHG] := andP nsHG. +have sHKr: H \subset rker rG by rewrite -cfker_repr -Dchi. +apply/irr_reprP; exists (Representation (quo_repr sHKr nHG)). + exact/quo_mx_irr. +apply/cfun_inP=> _ /morphimP[x Nx Gx ->]. +by rewrite cfQuoE //= Dchi !cfunE Gx quo_repr_coset ?mem_quotient. +Qed. + +Definition quo_Iirr G H i := cfIirr ('chi[G]_i / H)%CF. + +Lemma quo_Iirr0 G H : quo_Iirr H (0 : Iirr G) = 0. +Proof. by rewrite /quo_Iirr irr0 cfQuo_cfun1 -irr0 irrK. Qed. + +Lemma quo_IirrE G H i : + H <| G -> H \subset cfker 'chi[G]_i -> 'chi_(quo_Iirr H i) = ('chi_i / H)%CF. +Proof. by move=> nsHG kerH; rewrite cfIirrE ?cfQuo_irr ?mem_irr. Qed. + +Lemma quo_Iirr_eq0 G H i : + H <| G -> H \subset cfker 'chi[G]_i -> (quo_Iirr H i == 0) = (i == 0). +Proof. by move=> nsHG kerH; rewrite -!irr_eq1 quo_IirrE ?cfQuo_eq1. Qed. + +Lemma mod_IirrK G H : H <| G -> cancel (@mod_Iirr G H) (@quo_Iirr G H). +Proof. +move=> nsHG i; apply: irr_inj. +by rewrite quo_IirrE ?mod_IirrE ?cfker_mod // cfModK. +Qed. + +Lemma quo_IirrK G H i : + H <| G -> H \subset cfker 'chi[G]_i -> mod_Iirr (quo_Iirr H i) = i. +Proof. +by move=> nsHG kerH; apply: irr_inj; rewrite mod_IirrE ?quo_IirrE ?cfQuoK. +Qed. + +Lemma quo_IirrKeq G H : + H <| G -> + forall i, (mod_Iirr (quo_Iirr H i) == i) = (H \subset cfker 'chi[G]_i). +Proof. +move=> nsHG i; apply/eqP/idP=> [<- | ]; last exact: quo_IirrK. +by rewrite mod_IirrE ?cfker_mod. +Qed. + +Lemma mod_Iirr_bij H G : + H <| G -> {on [pred i | H \subset cfker 'chi_i], bijective (@mod_Iirr G H)}. +Proof. +by exists (quo_Iirr H) => [i _ | i]; [exact: mod_IirrK | exact: quo_IirrK]. +Qed. + +Lemma sum_norm_irr_quo H G x : + x \in G -> H <| G -> + \sum_i `|'chi[G / H]_i (coset H x)| ^+ 2 + = \sum_(i | H \subset cfker 'chi_i) `|'chi[G]_i x| ^+ 2. +Proof. +move=> Gx nsHG; rewrite (reindex _ (mod_Iirr_bij nsHG)) /=. +by apply/esym/eq_big=> [i | i _]; rewrite mod_IirrE ?cfker_mod ?cfModE. +Qed. + +Lemma cap_cfker_normal G H : + H <| G -> \bigcap_(i | H \subset cfker 'chi[G]_i) (cfker 'chi_i) = H. +Proof. +move=> nsHG; have [sHG nHG] := andP nsHG; set lhs := \bigcap_(i | _) _. +have nHlhs: lhs \subset 'N(H) by rewrite (bigcap_min 0) ?cfker_irr0. +apply/esym/eqP; rewrite eqEsubset (introT bigcapsP) //= -quotient_sub1 //. +rewrite -(TI_cfker_irr (G / H)); apply/bigcapsP=> i _. +rewrite sub_quotient_pre // (bigcap_min (mod_Iirr i)) ?mod_IirrE ?cfker_mod //. +by rewrite cfker_morph ?subsetIr. +Qed. + +Lemma cfker_reg_quo G H : H <| G -> cfker (cfReg (G / H)%g %% H) = H. +Proof. +move=> nsHG; have [sHG nHG] := andP nsHG. +apply/setP=> x; rewrite cfkerEchar ?cfMod_char ?cfReg_char //. +rewrite -[in RHS in _ = RHS](setIidPr sHG) !inE; apply: andb_id2l => Gx. +rewrite !cfModE // !cfRegE // morph1 eqxx. +rewrite (sameP eqP (kerP _ (subsetP nHG x Gx))) ker_coset. +by rewrite -!mulrnA eqr_nat eqn_pmul2l ?cardG_gt0 // (can_eq oddb) eqb_id. +Qed. + +End Coset. + +Section Derive. + +Variable gT : finGroupType. +Implicit Types G H : {group gT}. + +Lemma lin_irr_der1 G i : + ('chi_i \is a linear_char) = (G^`(1)%g \subset cfker 'chi[G]_i). +Proof. +apply/idP/idP=> [|sG'K]; first by apply: lin_char_der1. +have nsG'G: G^`(1) <| G := der_normal 1 G. +rewrite qualifE irr_char -[i](quo_IirrK nsG'G) // mod_IirrE //=. +by rewrite cfModE // morph1 lin_char1 //; exact/char_abelianP/der_abelian. +Qed. + +Lemma subGcfker G i : (G \subset cfker 'chi[G]_i) = (i == 0). +Proof. +rewrite -irr_eq1; apply/idP/eqP=> [chiG1 | ->]; last by rewrite cfker_cfun1. +apply/cfun_inP=> x Gx; rewrite cfun1E Gx cfker1 ?(subsetP chiG1) ?lin_char1 //. +by rewrite lin_irr_der1 (subset_trans (der_sub 1 G)). +Qed. + +Lemma irr_prime_injP G i : + prime #|G| -> reflect {in G &, injective 'chi[G]_i} (i != 0). +Proof. +move=> pr_G; apply: (iffP idP) => [nz_i | inj_chi]. + apply: fful_lin_char_inj (irr_prime_lin i pr_G) _. + by rewrite cfaithfulE -(setIidPr (cfker_sub _)) prime_TIg // subGcfker. +have /trivgPn[x Gx ntx]: G :!=: 1%g by rewrite -cardG_gt1 prime_gt1. +apply: contraNneq ntx => i0; apply/eqP/inj_chi=> //. +by rewrite i0 irr0 !cfun1E Gx group1. +Qed. + +(* This is Isaacs (2.23)(a). *) +Lemma cap_cfker_lin_irr G : + \bigcap_(i | 'chi[G]_i \is a linear_char) (cfker 'chi_i) = G^`(1)%g. +Proof. +rewrite -(cap_cfker_normal (der_normal 1 G)). +by apply: eq_bigl => i; rewrite lin_irr_der1. +Qed. + +(* This is Isaacs (2.23)(b) *) +Lemma card_lin_irr G : + #|[pred i | 'chi[G]_i \is a linear_char]| = #|G : G^`(1)%g|. +Proof. +have nsG'G := der_normal 1 G; rewrite (eq_card (@lin_irr_der1 G)). +rewrite -(on_card_preimset (mod_Iirr_bij nsG'G)). +rewrite -card_quotient ?normal_norm //. +move: (der_abelian 0 G); rewrite card_classes_abelian; move/eqP<-. +rewrite -NirrE -[X in _ = X]card_ord. +by apply: eq_card => i; rewrite !inE mod_IirrE ?cfker_mod. +(* Alternative: use the equivalent result in modular representation theory +transitivity #|@socle_of_Iirr _ G @^-1: linear_irr _|; last first. + rewrite (on_card_preimset (socle_of_Iirr_bij _)). + by rewrite card_linear_irr ?algC'G; last exact: groupC. +by apply: eq_card => i; rewrite !inE /lin_char irr_char irr1_degree -eqC_nat. +*) +Qed. + +(* A non-trivial solvable group has a nonprincipal linear character. *) +Lemma solvable_has_lin_char G : + G :!=: 1%g -> solvable G -> + exists2 i, 'chi[G]_i \is a linear_char & 'chi_i != 1. +Proof. +move=> ntG solG. +suff /subsetPn[i]: ~~ ([pred i | 'chi[G]_i \is a linear_char] \subset pred1 0). + by rewrite !inE -(inj_eq irr_inj) irr0; exists i. +rewrite (contra (@subset_leq_card _ _ _)) // -ltnNge card1 card_lin_irr. +by rewrite indexg_gt1 proper_subn // (sol_der1_proper solG). +Qed. + +(* A combinatorial group isommorphic to the linear characters. *) +Lemma lin_char_group G : + {linG : finGroupType & {cF : linG -> 'CF(G) | + [/\ injective cF, #|linG| = #|G : G^`(1)|, + forall u, cF u \is a linear_char + & forall phi, phi \is a linear_char -> exists u, phi = cF u] + & [/\ cF 1%g = 1%R, + {morph cF : u v / (u * v)%g >-> (u * v)%R}, + forall k, {morph cF : u / (u^+ k)%g >-> u ^+ k}, + {morph cF: u / u^-1%g >-> u^-1%CF} + & {mono cF: u / #[u]%g >-> #[u]%CF} ]}}. +Proof. +pose linT := {i : Iirr G | 'chi_i \is a linear_char}. +pose cF (u : linT) := 'chi_(sval u). +have cFlin u: cF u \is a linear_char := svalP u. +have cFinj: injective cF := inj_comp irr_inj val_inj. +have inT xi : xi \is a linear_char -> {u | cF u = xi}. + move=> lin_xi; have /irrP/sig_eqW[i Dxi] := lin_char_irr lin_xi. + by apply: (exist _ (Sub i _)) => //; rewrite -Dxi. +have [one cFone] := inT 1 (rpred1 _). +pose inv u := sval (inT _ (rpredVr (cFlin u))). +pose mul u v := sval (inT _ (rpredM (cFlin u) (cFlin v))). +have cFmul u v: cF (mul u v) = cF u * cF v := svalP (inT _ _). +have cFinv u: cF (inv u) = (cF u)^-1 := svalP (inT _ _). +have mulA: associative mul by move=> u v w; apply: cFinj; rewrite !cFmul mulrA. +have mul1: left_id one mul by move=> u; apply: cFinj; rewrite cFmul cFone mul1r. +have mulV: left_inverse one inv mul. + by move=> u; apply: cFinj; rewrite cFmul cFinv cFone mulVr ?lin_char_unitr. +pose linGm := FinGroup.Mixin mulA mul1 mulV. +pose linG := @FinGroupType (BaseFinGroupType linT linGm) mulV. +have cFexp k: {morph cF : u / ((u : linG) ^+ k)%g >-> u ^+ k}. + by move=> u; elim: k => // k IHk; rewrite expgS exprS cFmul IHk. +do [exists linG, cF; split=> //] => [|xi /inT[u <-]|u]; first 2 [by exists u]. + have inj_cFI: injective (cfIirr \o cF). + apply: can_inj (insubd one) _ => u; apply: val_inj. + by rewrite insubdK /= ?irrK //; apply: cFlin. + rewrite -(card_image inj_cFI) -card_lin_irr. + apply/eq_card=> i; rewrite inE; apply/codomP/idP=> [[u ->] | /inT[u Du]]. + by rewrite /= irrK; apply: cFlin. + by exists u; apply: irr_inj; rewrite /= irrK. +apply/eqP; rewrite eqn_dvd; apply/andP; split. + by rewrite dvdn_cforder; rewrite -cFexp expg_order cFone. +by rewrite order_dvdn -(inj_eq cFinj) cFone cFexp exp_cforder. +Qed. + +Lemma cfExp_prime_transitive G (i j : Iirr G) : + prime #|G| -> i != 0 -> j != 0 -> + exists2 k, coprime k #['chi_i]%CF & 'chi_j = 'chi_i ^+ k. +Proof. +set p := #|G| => pr_p nz_i nz_j; have cycG := prime_cyclic pr_p. +have [L [h [injh oL Lh h_ontoL]] [h1 hM hX _ o_h]] := lin_char_group G. +rewrite (derG1P (cyclic_abelian cycG)) indexg1 -/p in oL. +have /fin_all_exists[h' h'K] := h_ontoL _ (irr_cyclic_lin _ cycG). +have o_h' k: k != 0 -> #[h' k] = p. + rewrite -cforder_irr_eq1 h'K -o_h => nt_h'k. + by apply/prime_nt_dvdP=> //; rewrite cforder_lin_char_dvdG. +have{oL} genL k: k != 0 -> generator [set: L] (h' k). + move=> /o_h' o_h'k; rewrite /generator eq_sym eqEcard subsetT /=. + by rewrite cardsT oL -o_h'k. +have [/(_ =P <[_]>)-> gen_j] := (genL i nz_i, genL j nz_j). +have /cycleP[k Dj] := cycle_generator gen_j. +by rewrite !h'K Dj o_h hX generator_coprime coprime_sym in gen_j *; exists k. +Qed. + +(* This is Isaacs (2.24). *) +Lemma card_subcent1_coset G H x : + x \in G -> H <| G -> (#|'C_(G / H)[coset H x]| <= #|'C_G[x]|)%N. +Proof. +move=> Gx nsHG; rewrite -leC_nat. +move: (second_orthogonality_relation x Gx); rewrite mulrb class_refl => <-. +have GHx: coset H x \in (G / H)%g by apply: mem_quotient. +move: (second_orthogonality_relation (coset H x) GHx). +rewrite mulrb class_refl => <-. +rewrite -2!(eq_bigr _ (fun _ _ => normCK _)) sum_norm_irr_quo // -subr_ge0. +rewrite (bigID (fun i => H \subset cfker 'chi[G]_i)) //= addrC addKr. +by apply: sumr_ge0 => i _; rewrite normCK mul_conjC_ge0. +Qed. + +End Derive. + +Implicit Arguments irr_prime_injP [gT G i]. + +(* Determinant characters and determinential order. *) +Section DetOrder. + +Variables (gT : finGroupType) (G : {group gT}). + +Section DetRepr. + +Variables (n : nat) (rG : mx_representation [fieldType of algC] G n). + +Definition det_repr_mx x : 'M_1 := (\det (rG x))%:M. + +Fact det_is_repr : mx_repr G det_repr_mx. +Proof. +split=> [|g h Gg Gh]; first by rewrite /det_repr_mx repr_mx1 det1. +by rewrite /det_repr_mx repr_mxM // det_mulmx !mulmxE scalar_mxM. +Qed. + +Canonical det_repr := MxRepresentation det_is_repr. +Definition detRepr := cfRepr det_repr. + +Lemma detRepr_lin_char : detRepr \is a linear_char. +Proof. +by rewrite qualifE cfRepr_char cfunE group1 repr_mx1 mxtrace1 mulr1n /=. +Qed. + +End DetRepr. + +Definition cfDet phi := \prod_i detRepr 'Chi_i ^+ truncC '[phi, 'chi[G]_i]. + +Lemma cfDet_lin_char phi : cfDet phi \is a linear_char. +Proof. by apply: rpred_prod => i _; apply: rpredX; apply: detRepr_lin_char. Qed. + +Lemma cfDetD : + {in character &, {morph cfDet : phi psi / phi + psi >-> phi * psi}}. +Proof. +move=> phi psi Nphi Npsi; rewrite /= -big_split; apply: eq_bigr => i _ /=. +by rewrite -exprD cfdotDl truncCD ?nnegrE ?Cnat_ge0 // Cnat_cfdot_char_irr. +Qed. + +Lemma cfDet0 : cfDet 0 = 1. +Proof. by rewrite /cfDet big1 // => i _; rewrite cfdot0l truncC0. Qed. + +Lemma cfDetMn k : + {in character, {morph cfDet : phi / phi *+ k >-> phi ^+ k}}. +Proof. +move=> phi Nphi; elim: k => [|k IHk]; rewrite ?cfDet0 // mulrS exprS -{}IHk. +by rewrite cfDetD ?rpredMn. +Qed. + +Lemma cfDetRepr n rG : cfDet (cfRepr rG) = @detRepr n rG. +Proof. +transitivity (\prod_W detRepr (socle_repr W) ^+ standard_irr_coef rG W). + rewrite (reindex _ (socle_of_Iirr_bij _)) /cfDet /=. + apply: eq_bigr => i _; congr (_ ^+ _). + rewrite (cfRepr_sim (mx_rsim_standard rG)) cfRepr_standard. + rewrite cfdot_suml (bigD1 i) ?big1 //= => [|j i'j]; last first. + by rewrite cfdotZl cfdot_irr (negPf i'j) mulr0. + by rewrite cfdotZl cfnorm_irr mulr1 addr0 natCK. +apply/cfun_inP=> x Gx; rewrite prod_cfunE //. +transitivity (detRepr (standard_grepr rG) x); last first. + rewrite !cfunE Gx !trace_mx11 !mxE eqxx !mulrb. + case: (standard_grepr rG) (mx_rsim_standard rG) => /= n1 rG1 [B Dn1]. + rewrite -{n1}Dn1 in rG1 B *; rewrite row_free_unit => uB rG_B. + by rewrite -[rG x](mulmxK uB) rG_B // !det_mulmx mulrC -!det_mulmx mulKmx. +rewrite /standard_grepr; elim/big_rec2: _ => [|W y _ _ ->]. + by rewrite cfunE trace_mx11 mxE Gx det1. +rewrite !cfunE Gx /= !{1}trace_mx11 !{1}mxE det_ublock; congr (_ * _). +rewrite exp_cfunE //; elim: (standard_irr_coef rG W) => /= [|k IHk]. + by rewrite /muln_grepr big_ord0 det1. +rewrite exprS /muln_grepr big_ord_recl det_ublock -IHk; congr (_ * _). +by rewrite cfunE trace_mx11 mxE Gx. +Qed. + +Lemma cfDet_id xi : xi \is a linear_char -> cfDet xi = xi. +Proof. +move=> lin_xi; have /irrP[i Dxi] := lin_char_irr lin_xi. +apply/cfun_inP=> x Gx; rewrite Dxi -irrRepr cfDetRepr !cfunE trace_mx11 mxE. +move: lin_xi (_ x) => /andP[_]; rewrite Dxi irr1_degree pnatr_eq1 => /eqP-> X. +by rewrite {1}[X]mx11_scalar det_scalar1 trace_mx11. +Qed. + +Definition cfDet_order phi := #[cfDet phi]%CF. + +Definition cfDet_order_lin xi : + xi \is a linear_char -> cfDet_order xi = #[xi]%CF. +Proof. by rewrite /cfDet_order => /cfDet_id->. Qed. + +Definition cfDet_order_dvdG phi : cfDet_order phi %| #|G|. +Proof. by rewrite cforder_lin_char_dvdG ?cfDet_lin_char. Qed. + +End DetOrder. + +Notation "''o' ( phi )" := (cfDet_order phi) + (at level 8, format "''o' ( phi )") : cfun_scope. + +Section CfDetOps. + +Implicit Types gT aT rT : finGroupType. + +Lemma cfDetRes gT (G H : {group gT}) phi : + phi \is a character -> cfDet ('Res[H, G] phi) = 'Res (cfDet phi). +Proof. +move=> Nphi; have [sGH | not_sHG] := boolP (H \subset G); last first. + have /CnatP[n Dphi1] := Cnat_char1 Nphi. + rewrite !cfResEout // Dphi1 lin_char1 ?cfDet_lin_char // scale1r. + by rewrite scaler_nat cfDetMn ?cfDet_id ?rpred1 // expr1n. +have [rG ->] := char_reprP Nphi; rewrite !(=^~ cfRepr_sub, cfDetRepr) //. +apply: cfRepr_sim; exists 1%:M; rewrite ?row_free_unit ?unitmx1 // => x Hx. +by rewrite mulmx1 mul1mx. +Qed. + +Lemma cfDetMorph aT rT (D G : {group aT}) (f : {morphism D >-> rT}) + (phi : 'CF(f @* G)) : + phi \is a character -> cfDet (cfMorph phi) = cfMorph (cfDet phi). +Proof. +move=> Nphi; have [sGD | not_sGD] := boolP (G \subset D); last first. + have /CnatP[n Dphi1] := Cnat_char1 Nphi. + rewrite !cfMorphEout // Dphi1 lin_char1 ?cfDet_lin_char // scale1r. + by rewrite scaler_nat cfDetMn ?cfDet_id ?rpred1 // expr1n. +have [rG ->] := char_reprP Nphi; rewrite !(=^~ cfRepr_morphim, cfDetRepr) //. +apply: cfRepr_sim; exists 1%:M; rewrite ?row_free_unit ?unitmx1 // => x Hx. +by rewrite mulmx1 mul1mx. +Qed. + +Lemma cfDetIsom aT rT (G : {group aT}) (R : {group rT}) + (f : {morphism G >-> rT}) (isoGR : isom G R f) phi : + cfDet (cfIsom isoGR phi) = cfIsom isoGR (cfDet phi). +Proof. +rewrite rmorph_prod /cfDet (reindex (isom_Iirr isoGR)); last first. + by exists (isom_Iirr (isom_sym isoGR)) => i; rewrite ?isom_IirrK ?isom_IirrKV. +apply: eq_bigr => i; rewrite -!cfDetRepr !irrRepr isom_IirrE rmorphX cfIsom_iso. +by rewrite /= ![in cfIsom _]unlock cfDetMorph ?cfRes_char ?cfDetRes ?irr_char. +Qed. + +Lemma cfDet_mul_lin gT (G : {group gT}) (lambda phi : 'CF(G)) : + lambda \is a linear_char -> phi \is a character -> + cfDet (lambda * phi) = lambda ^+ truncC (phi 1%g) * cfDet phi. +Proof. +case/andP=> /char_reprP[[n1 rG1] ->] /= n1_1 /char_reprP[[n2 rG2] ->] /=. +do [rewrite !cfRepr1 pnatr_eq1 natCK; move/eqP] in n1_1 *. +rewrite {n1}n1_1 in rG1 *; rewrite cfRepr_prod cfDetRepr. +apply/cfun_inP=> x Gx; rewrite !cfunE cfDetRepr cfunE Gx !mulrb !trace_mx11. +rewrite !mxE prod_repr_lin ?mulrb //=; case: _ / (esym _); rewrite detZ. +congr (_ * _); case: {rG2}n2 => [|n2]; first by rewrite cfun1E Gx. +by rewrite expS_cfunE //= cfunE Gx trace_mx11. +Qed. + +End CfDetOps. + +Definition cfcenter (gT : finGroupType) (G : {set gT}) (phi : 'CF(G)) := + if phi \is a character then [set g in G | `|phi g| == phi 1%g] else cfker phi. + +Notation "''Z' ( phi )" := (cfcenter phi) : cfun_scope. + +Section Center. + +Variable (gT : finGroupType) (G : {group gT}). +Implicit Types (phi chi : 'CF(G)) (H : {group gT}). + +(* This is Isaacs (2.27)(a). *) +Lemma cfcenter_repr n (rG : mx_representation algCF G n) : + 'Z(cfRepr rG)%CF = rcenter rG. +Proof. +rewrite /cfcenter /rcenter cfRepr_char /=. +apply/setP=> x; rewrite !inE; apply/andb_id2l=> Gx. +apply/eqP/is_scalar_mxP=> [|[c rG_c]]. + by case/max_cfRepr_norm_scalar=> // c; exists c. +rewrite -(sqrCK (char1_ge0 (cfRepr_char rG))) normC_def; congr (sqrtC _). +rewrite expr2 -{2}(mulgV x) -char_inv ?cfRepr_char ?cfunE ?groupM ?groupV //. +rewrite Gx group1 repr_mx1 repr_mxM ?repr_mxV ?groupV // !mulrb rG_c. +by rewrite invmx_scalar -scalar_mxM !mxtrace_scalar mulrnAr mulrnAl mulr_natl. +Qed. + +(* This is part of Isaacs (2.27)(b). *) +Fact cfcenter_group_set phi : group_set ('Z(phi))%CF. +Proof. +have [[rG ->] | /negbTE notNphi] := altP (@char_reprP _ G phi). + by rewrite cfcenter_repr groupP. +by rewrite /cfcenter notNphi groupP. +Qed. +Canonical cfcenter_group f := Group (cfcenter_group_set f). + +Lemma char_cfcenterE chi x : + chi \is a character -> x \in G -> + (x \in ('Z(chi))%CF) = (`|chi x| == chi 1%g). +Proof. by move=> Nchi Gx; rewrite /cfcenter Nchi inE Gx. Qed. + +Lemma irr_cfcenterE i x : + x \in G -> (x \in 'Z('chi[G]_i)%CF) = (`|'chi_i x| == 'chi_i 1%g). +Proof. by move/char_cfcenterE->; rewrite ?irr_char. Qed. + +(* This is also Isaacs (2.27)(b). *) +Lemma cfcenter_sub phi : ('Z(phi))%CF \subset G. +Proof. by rewrite /cfcenter /cfker !setIdE -fun_if subsetIl. Qed. + +Lemma cfker_center_normal phi : cfker phi <| 'Z(phi)%CF. +Proof. +apply: normalS (cfcenter_sub phi) (cfker_normal phi). +rewrite /= /cfcenter; case: ifP => // Hphi; rewrite cfkerEchar //. +apply/subsetP=> x; rewrite !inE => /andP[-> /eqP->] /=. +by rewrite ger0_norm ?char1_ge0. +Qed. + +Lemma cfcenter_normal phi : 'Z(phi)%CF <| G. +Proof. +have [[rG ->] | /negbTE notNphi] := altP (@char_reprP _ _ phi). + by rewrite cfcenter_repr rcenter_normal. +by rewrite /cfcenter notNphi cfker_normal. +Qed. + +(* This is Isaacs (2.27)(c). *) +Lemma cfcenter_Res chi : + exists2 chi1, chi1 \is a linear_char & 'Res['Z(chi)%CF] chi = chi 1%g *: chi1. +Proof. +have [[rG ->] | /negbTE notNphi] := altP (@char_reprP _ _ chi); last first. + exists 1; first exact: cfun1_lin_char. + rewrite /cfcenter notNphi; apply/cfun_inP=> x Kx. + by rewrite cfunE cfun1E Kx mulr1 cfResE ?cfker_sub // cfker1. +rewrite cfcenter_repr -(cfRepr_sub _ (normal_sub (rcenter_normal _))). +case: rG => [[|n] rG] /=; rewrite cfRepr1. + exists 1; first exact: cfun1_lin_char. + by apply/cfun_inP=> x Zx; rewrite scale0r !cfunE flatmx0 raddf0 Zx. +pose rZmx x := ((rG x 0 0)%:M : 'M_(1,1)). +have rZmxP: mx_repr [group of rcenter rG] rZmx. + split=> [|x y]; first by rewrite /rZmx repr_mx1 mxE eqxx. + move=> /setIdP[Gx /is_scalar_mxP[a rGx]] /setIdP[Gy /is_scalar_mxP[b rGy]]. + by rewrite /rZmx repr_mxM // rGx rGy -!scalar_mxM !mxE. +exists (cfRepr (MxRepresentation rZmxP)). + by rewrite qualifE cfRepr_char cfRepr1 eqxx. +apply/cfun_inP=> x Zx; rewrite !cfunE Zx /= /rZmx mulr_natl. +by case/setIdP: Zx => Gx /is_scalar_mxP[a ->]; rewrite mxE !mxtrace_scalar. +Qed. + +(* This is Isaacs (2.27)(d). *) +Lemma cfcenter_cyclic chi : cyclic ('Z(chi)%CF / cfker chi)%g. +Proof. +case Nchi: (chi \is a character); last first. + by rewrite /cfcenter Nchi trivg_quotient cyclic1. +have [-> | nz_chi] := eqVneq chi 0. + rewrite quotientS1 ?cyclic1 //= /cfcenter cfkerEchar ?cfun0_char //. + by apply/subsetP=> x /setIdP[Gx _]; rewrite inE Gx /= !cfunE. +have [xi Lxi def_chi] := cfcenter_Res chi. +set Z := ('Z(_))%CF in xi Lxi def_chi *. +have sZG: Z \subset G by exact: cfcenter_sub. +have ->: cfker chi = cfker xi. + rewrite -(setIidPr (normal_sub (cfker_center_normal _))) -/Z. + rewrite !cfkerEchar // ?lin_charW //= -/Z. + apply/setP=> x; rewrite !inE; apply: andb_id2l => Zx. + rewrite (subsetP sZG) //= -!(cfResE chi sZG) ?group1 // def_chi !cfunE. + by rewrite (inj_eq (mulfI _)) ?char1_eq0. +have: abelian (Z / cfker xi) by rewrite sub_der1_abelian ?lin_char_der1. +have [rG irrG ->] := irr_reprP _ (lin_char_irr Lxi); rewrite cfker_repr. +apply: mx_faithful_irr_abelian_cyclic (kquo_mx_faithful rG) _. +exact/quo_mx_irr. +Qed. + +(* This is Isaacs (2.27)(e). *) +Lemma cfcenter_subset_center chi : + ('Z(chi)%CF / cfker chi)%g \subset 'Z(G / cfker chi)%g. +Proof. +case Nchi: (chi \is a character); last first. + by rewrite /cfcenter Nchi trivg_quotient sub1G. +rewrite subsetI quotientS ?cfcenter_sub // quotient_cents2r //=. +case/char_reprP: Nchi => rG ->{chi}; rewrite cfker_repr cfcenter_repr gen_subG. +apply/subsetP=> _ /imset2P[x y /setIdP[Gx /is_scalar_mxP[c rGx]] Gy ->]. +rewrite inE groupR //= !repr_mxM ?groupM ?groupV // rGx -(scalar_mxC c) -rGx. +by rewrite !mulmxA !repr_mxKV. +Qed. + +(* This is Isaacs (2.27)(f). *) +Lemma cfcenter_eq_center (i : Iirr G) : + ('Z('chi_i)%CF / cfker 'chi_i)%g = 'Z(G / cfker 'chi_i)%g. +Proof. +apply/eqP; rewrite eqEsubset; rewrite cfcenter_subset_center ?irr_char //. +apply/subsetP=> _ /setIP[/morphimP[x /= _ Gx ->] cGx]; rewrite mem_quotient //=. +rewrite -irrRepr cfker_repr cfcenter_repr inE Gx in cGx *. +apply: mx_abs_irr_cent_scalar 'Chi_i _ _ _. + by apply: groupC; apply: socle_irr. +have nKG: G \subset 'N(rker 'Chi_i) by exact: rker_norm. +(* GG -- locking here is critical to prevent Coq kernel divergence. *) +apply/centgmxP=> y Gy; rewrite [eq]lock -2?(quo_repr_coset (subxx _) nKG) //. +move: (quo_repr _ _) => rG; rewrite -2?repr_mxM ?mem_quotient // -lock. +by rewrite (centP cGx) // mem_quotient. +Qed. + +(* This is Isaacs (2.28). *) +Lemma cap_cfcenter_irr : \bigcap_i 'Z('chi[G]_i)%CF = 'Z(G). +Proof. +apply/esym/eqP; rewrite eqEsubset (introT bigcapsP) /= => [|i _]; last first. + rewrite -(quotientSGK _ (normal_sub (cfker_center_normal _))). + by rewrite cfcenter_eq_center morphim_center. + by rewrite subIset // normal_norm // cfker_normal. +set Z := \bigcap_i _. +have sZG: Z \subset G by rewrite (bigcap_min 0) ?cfcenter_sub. +rewrite subsetI sZG (sameP commG1P trivgP) -(TI_cfker_irr G). +apply/bigcapsP=> i _; have nKiG := normal_norm (cfker_normal 'chi_i). +rewrite -quotient_cents2 ?(subset_trans sZG) //. +rewrite (subset_trans (quotientS _ (bigcap_inf i _))) //. +by rewrite cfcenter_eq_center subsetIr. +Qed. + +(* This is Isaacs (2.29). *) +Lemma cfnorm_Res_lerif H phi : + H \subset G -> + '['Res[H] phi] <= #|G : H|%:R * '[phi] ?= iff (phi \in 'CF(G, H)). +Proof. +move=> sHG; rewrite cfun_onE mulrCA natf_indexg // -mulrA mulKf ?neq0CG //. +rewrite (big_setID H) (setIidPr sHG) /= addrC. +rewrite (mono_lerif (ler_pmul2l _)) ?invr_gt0 ?gt0CG // -lerif_subLR -sumrB. +rewrite big1 => [|x Hx]; last by rewrite !cfResE ?subrr. +have ->: (support phi \subset H) = (G :\: H \subset [set x | phi x == 0]). + rewrite subDset setUC -subDset; apply: eq_subset => x. + by rewrite !inE (andb_idr (contraR _)) // => /cfun0->. +rewrite (sameP subsetP forall_inP); apply: lerif_0_sum => x _. +by rewrite !inE /] := cfcenter_Res 'chi_i. + have /irrP[j ->] := lin_char_irr Lxi; rewrite cfdotZl cfdotZr cfdot_irr eqxx. + by rewrite mulr1 irr1_degree conjC_nat. +by rewrite cfdot_irr eqxx mulr1. +Qed. + +(* This is Isaacs (2.31). *) +Lemma irr1_abelian_bound (i : Iirr G) : + abelian (G / 'Z('chi_i)%CF) -> ('chi_i 1%g) ^+ 2 = #|G : 'Z('chi_i)%CF|%:R. +Proof. +move=> AbGc; apply/eqP; rewrite irr1_bound cfun_onE; apply/subsetP=> x nz_chi_x. +have Gx: x \in G by apply: contraR nz_chi_x => /cfun0->. +have nKx := subsetP (normal_norm (cfker_normal 'chi_i)) _ Gx. +rewrite -(quotientGK (cfker_center_normal _)) inE nKx inE /=. +rewrite cfcenter_eq_center inE mem_quotient //=. +apply/centP=> _ /morphimP[y nKy Gy ->]; apply/commgP; rewrite -morphR //=. +set z := [~ x, y]; rewrite coset_id //. +have: z \in 'Z('chi_i)%CF. + apply: subsetP (mem_commg Gx Gy). + by rewrite der1_min // normal_norm ?cfcenter_normal. +rewrite -irrRepr cfker_repr cfcenter_repr !inE in nz_chi_x *. +case/andP=> Gz /is_scalar_mxP[c Chi_z]; rewrite Gz Chi_z mul1mx /=. +apply/eqP; congr _%:M; apply: (mulIf nz_chi_x); rewrite mul1r. +rewrite -{2}(cfunJ _ x Gy) conjg_mulR -/z !cfunE Gx groupM // !{1}mulrb. +by rewrite repr_mxM // Chi_z mul_mx_scalar mxtraceZ. +Qed. + +(* This is Isaacs (2.32)(a). *) +Lemma irr_faithful_center i : cfaithful 'chi[G]_i -> cyclic 'Z(G). +Proof. +rewrite (isog_cyclic (isog_center (quotient1_isog G))) /=. +by move/trivgP <-; rewrite -cfcenter_eq_center cfcenter_cyclic. +Qed. + +Lemma cfcenter_fful_irr i : cfaithful 'chi[G]_i -> 'Z('chi_i)%CF = 'Z(G). +Proof. +move/trivgP=> Ki1; have:= cfcenter_eq_center i; rewrite {}Ki1. +have inj1: 'injm (@coset gT 1%g) by rewrite ker_coset. +by rewrite -injm_center; first apply: injm_morphim_inj; rewrite ?norms1. +Qed. + +(* This is Isaacs (2.32)(b). *) +Lemma pgroup_cyclic_faithful (p : nat) : + p.-group G -> cyclic 'Z(G) -> exists i, cfaithful 'chi[G]_i. +Proof. +pose Z := 'Ohm_1('Z(G)) => pG cycZG; have nilG := pgroup_nil pG. +have [-> | ntG] := eqsVneq G [1]; first by exists 0; exact: cfker_sub. +have{pG} [[p_pr _ _] pZ] := (pgroup_pdiv pG ntG, pgroupS (center_sub G) pG). +have ntZ: 'Z(G) != [1] by rewrite center_nil_eq1. +have{pZ} oZ: #|Z| = p by exact: Ohm1_cyclic_pgroup_prime. +apply/existsP; apply: contraR ntZ; rewrite negb_exists => /forallP-not_ffulG. +rewrite -Ohm1_eq1 -subG1 /= -/Z -(TI_cfker_irr G); apply/bigcapsP=> i _. +rewrite prime_meetG ?oZ // setIC meet_Ohm1 // meet_center_nil ?cfker_normal //. +by rewrite -subG1 not_ffulG. +Qed. + +End Center. + +Section Induced. + +Variables (gT : finGroupType) (G H : {group gT}). +Implicit Types (phi : 'CF(G)) (chi : 'CF(H)). + +Lemma cfInd_char chi : chi \is a character -> 'Ind[G] chi \is a character. +Proof. +move=> Nchi; apply/forallP=> i; rewrite coord_cfdot -Frobenius_reciprocity //. +by rewrite Cnat_cfdot_char ?cfRes_char ?irr_char. +Qed. + +Lemma cfInd_eq0 chi : + H \subset G -> chi \is a character -> ('Ind[G] chi == 0) = (chi == 0). +Proof. +move=> sHG Nchi; rewrite -!(char1_eq0) ?cfInd_char // cfInd1 //. +by rewrite (mulrI_eq0 _ (mulfI _)) ?neq0CiG. +Qed. + +Lemma Ind_irr_neq0 i : H \subset G -> 'Ind[G, H] 'chi_i != 0. +Proof. by move/cfInd_eq0->; rewrite ?irr_neq0 ?irr_char. Qed. + +Definition Ind_Iirr (A B : {set gT}) i := cfIirr ('Ind[B, A] 'chi_i). + +Lemma constt_cfRes_irr i : {j | j \in irr_constt ('Res[H, G] 'chi_i)}. +Proof. apply/sigW/neq0_has_constt/Res_irr_neq0. Qed. + +Lemma constt_cfInd_irr i : + H \subset G -> {j | j \in irr_constt ('Ind[G, H] 'chi_i)}. +Proof. by move=> sHG; apply/sigW/neq0_has_constt/Ind_irr_neq0. Qed. + +Lemma cfker_Res phi : + H \subset G -> phi \is a character -> cfker ('Res[H] phi) = H :&: cfker phi. +Proof. +move=> sHG Nphi; apply/setP=> x; rewrite !cfkerEchar ?cfRes_char // !inE. +by apply/andb_id2l=> Hx; rewrite (subsetP sHG) ?cfResE. +Qed. + +(* This is Isaacs Lemma (5.11). *) +Lemma cfker_Ind chi : + H \subset G -> chi \is a character -> chi != 0 -> + cfker ('Ind[G, H] chi) = gcore (cfker chi) G. +Proof. +move=> sHG Nchi nzchi; rewrite !cfker_nzcharE ?cfInd_char ?cfInd_eq0 //. +apply/setP=> x; rewrite inE cfIndE // (can2_eq (mulVKf _) (mulKf _)) ?neq0CG //. +rewrite cfInd1 // mulrA -natrM Lagrange // mulr_natl -sumr_const. +apply/eqP/bigcapP=> [/normC_sum_upper ker_chiG_x y Gy | ker_chiG_x]. + by rewrite mem_conjg inE ker_chiG_x ?groupV // => z _; exact: char1_ge_norm. +by apply: eq_bigr => y /groupVr/ker_chiG_x; rewrite mem_conjgV inE => /eqP. +Qed. + +Lemma cfker_Ind_irr i : + H \subset G -> cfker ('Ind[G, H] 'chi_i) = gcore (cfker 'chi_i) G. +Proof. by move/cfker_Ind->; rewrite ?irr_neq0 ?irr_char. Qed. + +End Induced. + +Arguments Scope Ind_Iirr [_ group_scope group_scope ring_scope]. \ No newline at end of file diff --git a/mathcomp/character/classfun.v b/mathcomp/character/classfun.v new file mode 100644 index 0000000..16d044b --- /dev/null +++ b/mathcomp/character/classfun.v @@ -0,0 +1,2463 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg poly finset. +Require Import fingroup morphism perm automorphism quotient finalg action. +Require Import gproduct zmodp commutator cyclic center pgroup sylow. +Require Import matrix vector falgebra ssrnum algC algnum. + +(******************************************************************************) +(* This file contains the basic theory of class functions: *) +(* 'CF(G) == the type of class functions on G : {group gT}, i.e., *) +(* which map gT to the type algC of complex algebraics, *) +(* have support in G, and are constant on each conjugacy *) +(* class of G. 'CF(G) implements the algebraType interface *) +(* of finite-dimensional F-algebras. *) +(* The identity 1 : 'CF(G) is the indicator function of G, *) +(* and (later) the principal character. *) +(* --> The %CF scope (cfun_scope) is bound to the 'CF(_) types. *) +(* 'CF(G)%VS == the (total) vector space of 'CF(G). *) +(* 'CF(G, A) == the subspace of functions in 'CF(G) with support in A. *) +(* phi x == the image of x : gT under phi : 'CF(G). *) +(* #[phi]%CF == the multiplicative order of phi : 'CF(G). *) +(* cfker phi == the kernel of phi : 'CF(G); note that cfker phi <| G. *) +(* cfaithful phi <=> phi : 'CF(G) is faithful (has a trivial kernel). *) +(* '1_A == the indicator function of A as a function of 'CF(G). *) +(* (Provided A <| G; G is determined by the context.) *) +(* phi^*%CF == the function conjugate to phi : 'CF(G). *) +(* cfAut u phi == the function conjugate to phi by an algC-automorphism u *) +(* phi^u The notation "_ ^u" is only reserved; it is up to *) +(* clients to set Notation "phi ^u" := (cfAut u phi). *) +(* '[phi, psi] == the convolution of phi, psi : 'CF(G) over G, normalised *) +(* '[phi, psi]_G by #|G| so that '[1, 1]_G = 1 (G is usually inferred). *) +(* cfdotr psi phi == '[phi, psi] (self-expanding). *) +(* '[phi], '[phi]_G == the squared norm '[phi, phi] of phi : 'CF(G). *) +(* orthogonal R S <=> each phi in R : seq 'CF(G) is orthogonal to each psi in *) +(* S, i.e., '[phi, psi] = 0. As 'CF(G) coerces to seq, one *) +(* can write orthogonal phi S and orthogonal phi psi. *) +(* pairwise_orthogonal S <=> the class functions in S are pairwise orthogonal *) +(* AND non-zero. *) +(* orthonormal S <=> S is pairwise orthogonal and all class functions in S *) +(* have norm 1. *) +(* isometry tau <-> tau : 'CF(D) -> 'CF(R) is an isometry, mapping *) +(* '[_, _]_D to '[_, _]_R. *) +(* {in CD, isometry tau, to CR} <-> in the domain CD, tau is an isometry *) +(* whose range is contained in CR. *) +(* cfReal phi <=> phi is real, i.e., phi^* == phi. *) +(* cfAut_closed u S <-> S : seq 'CF(G) is closed under conjugation by u. *) +(* conjC_closed S <-> S : seq 'CF(G) is closed under complex conjugation. *) +(* conjC_subset S1 S2 <-> S1 : seq 'CF(G) represents a subset of S2 closed *) +(* under complex conjugation. *) +(* := [/\ uniq S1, {subset S1 <= S2} & conjC_closed S1]. *) +(* 'Res[H] phi == the restriction of phi : 'CF(G) to a function of 'CF(H) *) +(* 'Res[H, G] phi 'Res[H] phi x = phi x if x \in H (when H \subset G), *) +(* 'Res phi 'Res[H] phi x = 0 if x \notin H. The syntax variants *) +(* allow H and G to be inferred; the default is to specify *) +(* H explicitly, and infer G from the type of phi. *) +(* 'Ind[G] phi == the class function of 'CF(G) induced by phi : 'CF(H), *) +(* 'Ind[G, H] phi when H \subset G. As with 'Res phi, both G and H can *) +(* 'Ind phi be inferred, though usually G isn't. *) +(* cfMorph phi == the class function in 'CF(G) that maps x to phi (f x), *) +(* where phi : 'CF(f @* G), provided G \subset 'dom f. *) +(* cfIsom isoGR phi == the class function in 'CF(R) that maps f x to phi x, *) +(* given isoGR : isom G R f, f : {morphism G >-> rT} and *) +(* phi : 'CF(G). *) +(* (phi %% H)%CF == special case of cfMorph phi, when phi : 'CF(G / H). *) +(* (phi / H)%CF == the class function in 'CF(G / H) that coincides with *) +(* phi : 'CF(G) on cosets of H \subset cfker phi. *) +(* For a group G that is a semidirect product (defG : K ><| H = G), we have *) +(* cfSdprod KxH phi == for phi : 'CF(H), the class function of 'CF(G) that *) +(* maps k * h to psi h when k \in K and h \in H. *) +(* For a group G that is a direct product (with KxH : K \x H = G), we have *) +(* cfDprodl KxH phi == for phi : 'CF(K), the class function of 'CF(G) that *) +(* maps k * h to phi k when k \in K and h \in H. *) +(* cfDprodr KxH psi == for psi : 'CF(H), the class function of 'CF(G) that *) +(* maps k * h to psi h when k \in K and h \in H. *) +(* cfDprod KxH phi psi == for phi : 'CF(K), psi : 'CF(H), the class function *) +(* of 'CF(G) that maps k * h to phi k * psi h (this is *) +(* the product of the two functions above). *) +(* Finally, given defG : \big[dprod/1]_(i | P i) A i = G, with G and A i *) +(* groups and i ranges over a finType, we have *) +(* cfBigdprodi defG phi == for phi : 'CF(A i) s.t. P i, the class function *) +(* of 'CF(G) that maps x to phi x_i, where x_i is the *) +(* (A i)-component of x : G. *) +(* cfBigdprodi defG phi == for phi : forall i, 'CF(A i), the class function *) +(* of 'CF(G) that maps x to \prod_(i | P i) phi i x_i, *) +(* where x_i is the (A i)-component of x : G. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory Num.Theory. +Local Open Scope ring_scope. +Delimit Scope cfun_scope with CF. + +Reserved Notation "''CF' ( G , A )" (at level 8, format "''CF' ( G , A )"). +Reserved Notation "''CF' ( G )" (at level 8, format "''CF' ( G )"). +Reserved Notation "''1_' G" (at level 8, G at level 2, format "''1_' G"). +Reserved Notation "''Res[' H , G ]" (at level 8, only parsing). +Reserved Notation "''Res[' H ]" (at level 8, format "''Res[' H ]"). +Reserved Notation "''Res'" (at level 8, only parsing). +Reserved Notation "''Ind[' G , H ]" (at level 8, only parsing). +Reserved Notation "''Ind[' G ]" (at level 8, format "''Ind[' G ]"). +Reserved Notation "''Ind'" (at level 8, only parsing). +Reserved Notation "'[ phi , psi ]_ G" (at level 2, only parsing). +Reserved Notation "'[ phi , psi ]" + (at level 2, format "'[hv' ''[' phi , '/ ' psi ] ']'"). +Reserved Notation "'[ phi ]_ G" (at level 2, only parsing). +Reserved Notation "'[ phi ]" (at level 2, format "''[' phi ]"). +Reserved Notation "phi ^u" (at level 3, format "phi ^u"). + +Section AlgC. +(* Arithmetic properties of group orders in the characteristic 0 field algC. *) + +Variable (gT : finGroupType). +Implicit Types (G : {group gT}) (B : {set gT}). + +Lemma neq0CG G : (#|G|)%:R != 0 :> algC. Proof. exact: natrG_neq0. Qed. +Lemma neq0CiG G B : (#|G : B|)%:R != 0 :> algC. +Proof. exact: natr_indexg_neq0. Qed. +Lemma gt0CG G : 0 < #|G|%:R :> algC. Proof. exact: natrG_gt0. Qed. +Lemma gt0CiG G B : 0 < #|G : B|%:R :> algC. Proof. exact: natr_indexg_gt0. Qed. + +Lemma algC'G G : [char algC]^'.-group G. +Proof. by apply/pgroupP=> p _; rewrite inE /= char_num. Qed. + +End AlgC. + +Section Defs. + +Variable gT : finGroupType. + +Definition is_class_fun (B : {set gT}) (f : {ffun gT -> algC}) := + [forall x, forall y in B, f (x ^ y) == f x] && (support f \subset B). + +Lemma intro_class_fun (G : {group gT}) f : + {in G &, forall x y, f (x ^ y) = f x} -> + (forall x, x \notin G -> f x = 0) -> + is_class_fun G (finfun f). +Proof. +move=> fJ Gf; apply/andP; split; last first. + by apply/supportP=> x notAf; rewrite ffunE Gf. +apply/'forall_eqfun_inP=> x y Gy; rewrite !ffunE. +by have [/fJ-> // | notGx] := boolP (x \in G); rewrite !Gf ?groupJr. +Qed. + +Variable B : {set gT}. +Local Notation G := <>. + +Record classfun : predArgType := + Classfun {cfun_val; _ : is_class_fun G cfun_val}. +Implicit Types phi psi xi : classfun. +(* The default expansion lemma cfunE requires key = 0. *) +Fact classfun_key : unit. Proof. by []. Qed. +Definition Cfun := locked_with classfun_key (fun flag : nat => Classfun). + +Canonical cfun_subType := Eval hnf in [subType for cfun_val]. +Definition cfun_eqMixin := Eval hnf in [eqMixin of classfun by <:]. +Canonical cfun_eqType := Eval hnf in EqType classfun cfun_eqMixin. +Definition cfun_choiceMixin := Eval hnf in [choiceMixin of classfun by <:]. +Canonical cfun_choiceType := Eval hnf in ChoiceType classfun cfun_choiceMixin. + +Definition fun_of_cfun phi := cfun_val phi : gT -> algC. +Coercion fun_of_cfun : classfun >-> Funclass. + +Lemma cfunElock k f fP : @Cfun k (finfun f) fP =1 f. +Proof. by rewrite locked_withE; apply: ffunE. Qed. + +Lemma cfunE f fP : @Cfun 0 (finfun f) fP =1 f. +Proof. exact: cfunElock. Qed. + +Lemma cfunP phi psi : phi =1 psi <-> phi = psi. +Proof. by split=> [/ffunP/val_inj | ->]. Qed. + +Lemma cfun0gen phi x : x \notin G -> phi x = 0. +Proof. by case: phi => f fP; case: (andP fP) => _ /supportP; exact. Qed. + +Lemma cfun_in_genP phi psi : {in G, phi =1 psi} -> phi = psi. +Proof. +move=> eq_phi; apply/cfunP=> x. +by have [/eq_phi-> // | notAx] := boolP (x \in G); rewrite !cfun0gen. +Qed. + +Lemma cfunJgen phi x y : y \in G -> phi (x ^ y) = phi x. +Proof. +case: phi => f fP Gy; apply/eqP. +by case: (andP fP) => /'forall_forall_inP->. +Qed. + +Fact cfun_zero_subproof : is_class_fun G (0 : {ffun _}). +Proof. exact: intro_class_fun. Qed. +Definition cfun_zero := Cfun 0 cfun_zero_subproof. + +Fact cfun_comp_subproof f phi : + f 0 = 0 -> is_class_fun G [ffun x => f (phi x)]. +Proof. +by move=> f0; apply: intro_class_fun => [x y _ /cfunJgen | x /cfun0gen] ->. +Qed. +Definition cfun_comp f f0 phi := Cfun 0 (@cfun_comp_subproof f phi f0). +Definition cfun_opp := cfun_comp (oppr0 _). + +Fact cfun_add_subproof phi psi : is_class_fun G [ffun x => phi x + psi x]. +Proof. +apply: intro_class_fun => [x y Gx Gy | x notGx]; rewrite ?cfunJgen //. +by rewrite !cfun0gen ?add0r. +Qed. +Definition cfun_add phi psi := Cfun 0 (cfun_add_subproof phi psi). + +Fact cfun_indicator_subproof (A : {set gT}) : + is_class_fun G [ffun x => ((x \in G) && (x ^: G \subset A))%:R]. +Proof. +apply: intro_class_fun => [x y Gx Gy | x /negbTE/= -> //]. +by rewrite groupJr ?classGidl. +Qed. +Definition cfun_indicator A := Cfun 1 (cfun_indicator_subproof A). +Local Notation "''1_' A" := (cfun_indicator A) : ring_scope. + +Lemma cfun1Egen x : '1_G x = (x \in G)%:R. +Proof. by rewrite cfunElock andb_idr // => /class_subG->. Qed. + +Fact cfun_mul_subproof phi psi : is_class_fun G [ffun x => phi x * psi x]. +Proof. +apply: intro_class_fun => [x y Gx Gy | x notGx]; rewrite ?cfunJgen //. +by rewrite cfun0gen ?mul0r. +Qed. +Definition cfun_mul phi psi := Cfun 0 (cfun_mul_subproof phi psi). + +Definition cfun_unit := [pred phi : classfun | [forall x in G, phi x != 0]]. +Definition cfun_inv phi := + if phi \in cfun_unit then cfun_comp (invr0 _) phi else phi. + +Definition cfun_scale a := cfun_comp (mulr0 a). + +Fact cfun_addA : associative cfun_add. +Proof. by move=> phi psi xi; apply/cfunP=> x; rewrite !cfunE addrA. Qed. +Fact cfun_addC : commutative cfun_add. +Proof. by move=> phi psi; apply/cfunP=> x; rewrite !cfunE addrC. Qed. +Fact cfun_add0 : left_id cfun_zero cfun_add. +Proof. by move=> phi; apply/cfunP=> x; rewrite !cfunE add0r. Qed. +Fact cfun_addN : left_inverse cfun_zero cfun_opp cfun_add. +Proof. by move=> phi; apply/cfunP=> x; rewrite !cfunE addNr. Qed. + +Definition cfun_zmodMixin := ZmodMixin cfun_addA cfun_addC cfun_add0 cfun_addN. +Canonical cfun_zmodType := ZmodType classfun cfun_zmodMixin. + +Lemma muln_cfunE phi n x : (phi *+ n) x = phi x *+ n. +Proof. by elim: n => [|n IHn]; rewrite ?mulrS !cfunE ?IHn. Qed. + +Lemma sum_cfunE I r (P : pred I) (phi : I -> classfun) x : + (\sum_(i <- r | P i) phi i) x = \sum_(i <- r | P i) (phi i) x. +Proof. by elim/big_rec2: _ => [|i _ psi _ <-]; rewrite cfunE. Qed. + +Fact cfun_mulA : associative cfun_mul. +Proof. by move=> phi psi xi; apply/cfunP=> x; rewrite !cfunE mulrA. Qed. +Fact cfun_mulC : commutative cfun_mul. +Proof. by move=> phi psi; apply/cfunP=> x; rewrite !cfunE mulrC. Qed. +Fact cfun_mul1 : left_id '1_G cfun_mul. +Proof. +by move=> phi; apply: cfun_in_genP => x Gx; rewrite !cfunE cfun1Egen Gx mul1r. +Qed. +Fact cfun_mulD : left_distributive cfun_mul cfun_add. +Proof. by move=> phi psi xi; apply/cfunP=> x; rewrite !cfunE mulrDl. Qed. +Fact cfun_nz1 : '1_G != 0. +Proof. +by apply/eqP=> /cfunP/(_ 1%g)/eqP; rewrite cfun1Egen cfunE group1 oner_eq0. +Qed. + +Definition cfun_ringMixin := + ComRingMixin cfun_mulA cfun_mulC cfun_mul1 cfun_mulD cfun_nz1. +Canonical cfun_ringType := RingType classfun cfun_ringMixin. +Canonical cfun_comRingType := ComRingType classfun cfun_mulC. + +Lemma expS_cfunE phi n x : (phi ^+ n.+1) x = phi x ^+ n.+1. +Proof. by elim: n => //= n IHn; rewrite !cfunE IHn. Qed. + +Fact cfun_mulV : {in cfun_unit, left_inverse 1 cfun_inv *%R}. +Proof. +move=> phi Uphi; rewrite /cfun_inv Uphi; apply/cfun_in_genP=> x Gx. +by rewrite !cfunE cfun1Egen Gx mulVf ?(forall_inP Uphi). +Qed. +Fact cfun_unitP phi psi : psi * phi = 1 -> phi \in cfun_unit. +Proof. +move/cfunP=> phiK; apply/forall_inP=> x Gx; rewrite -unitfE; apply/unitrP. +by exists (psi x); have:= phiK x; rewrite !cfunE cfun1Egen Gx mulrC. +Qed. +Fact cfun_inv0id : {in [predC cfun_unit], cfun_inv =1 id}. +Proof. by rewrite /cfun_inv => phi /negbTE/= ->. Qed. + +Definition cfun_unitMixin := ComUnitRingMixin cfun_mulV cfun_unitP cfun_inv0id. +Canonical cfun_unitRingType := UnitRingType classfun cfun_unitMixin. +Canonical cfun_comUnitRingType := [comUnitRingType of classfun]. + +Fact cfun_scaleA a b phi : + cfun_scale a (cfun_scale b phi) = cfun_scale (a * b) phi. +Proof. by apply/cfunP=> x; rewrite !cfunE mulrA. Qed. +Fact cfun_scale1 : left_id 1 cfun_scale. +Proof. by move=> phi; apply/cfunP=> x; rewrite !cfunE mul1r. Qed. +Fact cfun_scaleDr : right_distributive cfun_scale +%R. +Proof. by move=> a phi psi; apply/cfunP=> x; rewrite !cfunE mulrDr. Qed. +Fact cfun_scaleDl phi : {morph cfun_scale^~ phi : a b / a + b}. +Proof. by move=> a b; apply/cfunP=> x; rewrite !cfunE mulrDl. Qed. + +Definition cfun_lmodMixin := + LmodMixin cfun_scaleA cfun_scale1 cfun_scaleDr cfun_scaleDl. +Canonical cfun_lmodType := LmodType algC classfun cfun_lmodMixin. + +Fact cfun_scaleAl a phi psi : a *: (phi * psi) = (a *: phi) * psi. +Proof. by apply/cfunP=> x; rewrite !cfunE mulrA. Qed. +Fact cfun_scaleAr a phi psi : a *: (phi * psi) = phi * (a *: psi). +Proof. by rewrite !(mulrC phi) cfun_scaleAl. Qed. + +Canonical cfun_lalgType := LalgType algC classfun cfun_scaleAl. +Canonical cfun_algType := AlgType algC classfun cfun_scaleAr. +Canonical cfun_unitAlgType := [unitAlgType algC of classfun]. + +Section Automorphism. + +Variable u : {rmorphism algC -> algC}. + +Definition cfAut := cfun_comp (rmorph0 u). + +Lemma cfAut_cfun1i A : cfAut '1_A = '1_A. +Proof. by apply/cfunP=> x; rewrite !cfunElock rmorph_nat. Qed. + +Lemma cfAutZ a phi : cfAut (a *: phi) = u a *: cfAut phi. +Proof. by apply/cfunP=> x; rewrite !cfunE rmorphM. Qed. + +Lemma cfAut_is_rmorphism : rmorphism cfAut. +Proof. +by do 2?split=> [phi psi|]; last exact: cfAut_cfun1i; + apply/cfunP=> x; rewrite !cfunE (rmorphB, rmorphM). +Qed. +Canonical cfAut_additive := Additive cfAut_is_rmorphism. +Canonical cfAut_rmorphism := RMorphism cfAut_is_rmorphism. + +Lemma cfAut_cfun1 : cfAut 1 = 1. Proof. exact: rmorph1. Qed. + +Lemma cfAut_scalable : scalable_for (u \; *:%R) cfAut. +Proof. by move=> a phi; apply/cfunP=> x; rewrite !cfunE rmorphM. Qed. +Canonical cfAut_linear := AddLinear cfAut_scalable. +Canonical cfAut_lrmorphism := [lrmorphism of cfAut]. + +Definition cfAut_closed (S : seq classfun) := + {in S, forall phi, cfAut phi \in S}. + +End Automorphism. + +Definition cfReal phi := cfAut conjC phi == phi. + +Definition cfConjC_subset (S1 S2 : seq classfun) := + [/\ uniq S1, {subset S1 <= S2} & cfAut_closed conjC S1]. + +Fact cfun_vect_iso : Vector.axiom #|classes G| classfun. +Proof. +exists (fun phi => \row_i phi (repr (enum_val i))) => [a phi psi|]. + by apply/rowP=> i; rewrite !(mxE, cfunE). +set n := #|_|; pose eK x : 'I_n := enum_rank_in (classes1 _) (x ^: G). +have rV2vP v : is_class_fun G [ffun x => v (eK x) *+ (x \in G)]. + apply: intro_class_fun => [x y Gx Gy | x /negbTE/=-> //]. + by rewrite groupJr // /eK classGidl. +exists (fun v : 'rV_n => Cfun 0 (rV2vP (v 0))) => [phi | v]. + apply/cfun_in_genP=> x Gx; rewrite cfunE Gx mxE enum_rankK_in ?mem_classes //. + by have [y Gy ->] := repr_class <> x; rewrite cfunJgen. +apply/rowP=> i; rewrite mxE cfunE; have /imsetP[x Gx def_i] := enum_valP i. +rewrite def_i; have [y Gy ->] := repr_class <> x. +by rewrite groupJ // /eK classGidl // -def_i enum_valK_in. +Qed. +Definition cfun_vectMixin := VectMixin cfun_vect_iso. +Canonical cfun_vectType := VectType algC classfun cfun_vectMixin. +Canonical cfun_FalgType := [FalgType algC of classfun]. + +Definition cfun_base A : #|classes B ::&: A|.-tuple classfun := + [tuple of [seq '1_xB | xB in classes B ::&: A]]. +Definition classfun_on A := <>%VS. + +Definition cfdot phi psi := #|B|%:R^-1 * \sum_(x in B) phi x * (psi x)^*. +Definition cfdotr_head k psi phi := let: tt := k in cfdot phi psi. +Definition cfnorm_head k phi := let: tt := k in cfdot phi phi. + +Coercion seq_of_cfun phi := [:: phi]. + +Definition cforder phi := \big[lcmn/1%N]_(x in <>) #[phi x]%C. + +End Defs. + +Bind Scope cfun_scope with classfun. + +Arguments Scope classfun [_ group_scope]. +Arguments Scope classfun_on [_ group_scope group_scope]. +Arguments Scope cfun_indicator [_ group_scope]. +Arguments Scope cfAut [_ group_scope _ cfun_scope]. +Arguments Scope cfReal [_ group_scope cfun_scope]. +Arguments Scope cfdot [_ group_scope cfun_scope cfun_scope]. +Arguments Scope cfdotr_head [_ group_scope _ cfun_scope cfun_scope]. +Arguments Scope cfdotr_head [_ group_scope _ cfun_scope]. + +Notation "''CF' ( G )" := (classfun G) : type_scope. +Notation "''CF' ( G )" := (@fullv _ (cfun_vectType G)) : vspace_scope. +Notation "''1_' A" := (cfun_indicator _ A) : ring_scope. +Notation "''CF' ( G , A )" := (classfun_on G A) : ring_scope. +Notation "1" := (@GRing.one (cfun_ringType _)) (only parsing) : cfun_scope. + +Notation "phi ^*" := (cfAut conjC phi) : cfun_scope. +Notation conjC_closed := (cfAut_closed conjC). +Prenex Implicits cfReal. +(* Workaround for overeager projection reduction. *) +Notation eqcfP := (@eqP (cfun_eqType _) _ _) (only parsing). + +Notation "#[ phi ]" := (cforder phi) : cfun_scope. +Notation "''[' u , v ]_ G":= (@cfdot _ G u v) (only parsing) : ring_scope. +Notation "''[' u , v ]" := (cfdot u v) : ring_scope. +Notation "''[' u ]_ G" := '[u, u]_G (only parsing) : ring_scope. +Notation "''[' u ]" := '[u, u] : ring_scope. +Notation cfdotr := (cfdotr_head tt). +Notation cfnorm := (cfnorm_head tt). + +Section Predicates. + +Variables (gT rT : finGroupType) (D : {set gT}) (R : {set rT}). +Implicit Types (phi psi : 'CF(D)) (S : seq 'CF(D)) (tau : 'CF(D) -> 'CF(R)). + +Definition cfker phi := [set x in D | [forall y, phi (x * y)%g == phi y]]. + +Definition cfaithful phi := cfker phi \subset [1]. + +Definition ortho_rec S1 S2 := + all [pred phi | all [pred psi | '[phi, psi] == 0] S2] S1. + +Fixpoint pair_ortho_rec S := + if S is psi :: S' then ortho_rec psi S' && pair_ortho_rec S' else true. + +(* We exclude 0 from pairwise orthogonal sets. *) +Definition pairwise_orthogonal S := (0 \notin S) && pair_ortho_rec S. + +Definition orthonormal S := all [pred psi | '[psi] == 1] S && pair_ortho_rec S. + +Definition isometry tau := forall phi psi, '[tau phi, tau psi] = '[phi, psi]. + +Definition isometry_from_to mCFD tau mCFR := + prop_in2 mCFD (inPhantom (isometry tau)) + /\ prop_in1 mCFD (inPhantom (forall phi, in_mem (tau phi) mCFR)). + +End Predicates. + +(* Outside section so the nosimpl does not get "cooked" out. *) +Definition orthogonal gT D S1 S2 := nosimpl (@ortho_rec gT D S1 S2). + +Arguments Scope cfker [_ group_scope cfun_scope]. +Arguments Scope cfaithful [_ group_scope cfun_scope]. +Arguments Scope orthogonal [_ group_scope cfun_scope cfun_scope]. +Arguments Scope pairwise_orthogonal [_ group_scope cfun_scope]. +Arguments Scope orthonormal [_ group_scope cfun_scope]. +Arguments Scope isometry [_ _ group_scope group_scope cfun_scope]. + +Notation "{ 'in' CFD , 'isometry' tau , 'to' CFR }" := + (isometry_from_to (mem CFD) tau (mem CFR)) + (at level 0, format "{ 'in' CFD , 'isometry' tau , 'to' CFR }") + : type_scope. + +Section ClassFun. + +Variables (gT : finGroupType) (G : {group gT}). +Implicit Types (A B : {set gT}) (H K : {group gT}) (phi psi xi : 'CF(G)). + +Local Notation "''1_' A" := (cfun_indicator G A). + +Lemma cfun0 phi x : x \notin G -> phi x = 0. +Proof. by rewrite -{1}(genGid G) => /(cfun0gen phi). Qed. + +Lemma support_cfun phi : support phi \subset G. +Proof. by apply/subsetP=> g; apply: contraR => /cfun0->. Qed. + +Lemma cfunJ phi x y : y \in G -> phi (x ^ y) = phi x. +Proof. by rewrite -{1}(genGid G) => /(cfunJgen phi)->. Qed. + +Lemma cfun_repr phi x : phi (repr (x ^: G)) = phi x. +Proof. by have [y Gy ->] := repr_class G x; exact: cfunJ. Qed. + +Lemma cfun_inP phi psi : {in G, phi =1 psi} -> phi = psi. +Proof. by rewrite -{1}genGid => /cfun_in_genP. Qed. + +Lemma cfuniE A x : A <| G -> '1_A x = (x \in A)%:R. +Proof. +case/andP=> sAG nAG; rewrite cfunElock genGid. +by rewrite class_sub_norm // andb_idl // => /(subsetP sAG). +Qed. + +Lemma support_cfuni A : A <| G -> support '1_A =i A. +Proof. by move=> nsAG x; rewrite !inE cfuniE // pnatr_eq0 -lt0n lt0b. Qed. + +Lemma eq_mul_cfuni A phi : A <| G -> {in A, phi * '1_A =1 phi}. +Proof. by move=> nsAG x Ax; rewrite cfunE cfuniE // Ax mulr1. Qed. + +Lemma eq_cfuni A : A <| G -> {in A, '1_A =1 (1 : 'CF(G))}. +Proof. by rewrite -['1_A]mul1r; exact: eq_mul_cfuni. Qed. + +Lemma cfuniG : '1_G = 1. +Proof. by rewrite -[G in '1_G]genGid. Qed. + +Lemma cfun1E g : (1 : 'CF(G)) g = (g \in G)%:R. +Proof. by rewrite -cfuniG cfuniE. Qed. + +Lemma cfun11 : (1 : 'CF(G)) 1%g = 1. +Proof. by rewrite cfun1E group1. Qed. + +Lemma prod_cfunE I r (P : pred I) (phi : I -> 'CF(G)) x : + x \in G -> (\prod_(i <- r | P i) phi i) x = \prod_(i <- r | P i) (phi i) x. +Proof. +by move=> Gx; elim/big_rec2: _ => [|i _ psi _ <-]; rewrite ?cfunE ?cfun1E ?Gx. +Qed. + +Lemma exp_cfunE phi n x : x \in G -> (phi ^+ n) x = phi x ^+ n. +Proof. by rewrite -[n]card_ord -!prodr_const; apply: prod_cfunE. Qed. + +Lemma mul_cfuni A B : '1_A * '1_B = '1_(A :&: B) :> 'CF(G). +Proof. +apply/cfunP=> g; rewrite !cfunElock -natrM mulnb subsetI. +by rewrite andbCA !andbA andbb. +Qed. + +Lemma cfun_classE x y : '1_(x ^: G) y = ((x \in G) && (y \in x ^: G))%:R. +Proof. +rewrite cfunElock genGid class_sub_norm ?class_norm //; congr (_ : bool)%:R. +by apply: andb_id2r => /imsetP[z Gz ->]; rewrite groupJr. +Qed. + +Lemma cfun_on_sum A : + 'CF(G, A) = (\sum_(xG in classes G | xG \subset A) <['1_xG]>)%VS. +Proof. +rewrite ['CF(G, A)]span_def big_map big_filter. +by apply: eq_bigl => xG; rewrite !inE. +Qed. + +Lemma cfun_onP A phi : + reflect (forall x, x \notin A -> phi x = 0) (phi \in 'CF(G, A)). +Proof. +apply: (iffP idP) => [/coord_span-> x notAx | Aphi]. + set b := cfun_base G A; rewrite sum_cfunE big1 // => i _; rewrite cfunE. + have /mapP[xG]: b`_i \in b by rewrite -tnth_nth mem_tnth. + rewrite mem_enum => /setIdP[/imsetP[y Gy ->] Ay] ->. + by rewrite cfun_classE Gy (contraNF (subsetP Ay x)) ?mulr0. +suffices <-: \sum_(xG in classes G) phi (repr xG) *: '1_xG = phi. + apply: memv_suml => _ /imsetP[x Gx ->]; rewrite rpredZeq cfun_repr. + have [s_xG_A | /subsetPn[_ /imsetP[y Gy ->]]] := boolP (x ^: G \subset A). + by rewrite cfun_on_sum [_ \in _](sumv_sup (x ^: G)) ?mem_classes ?orbT. + by move/Aphi; rewrite cfunJ // => ->; rewrite eqxx. +apply/cfun_inP=> x Gx; rewrite sum_cfunE (bigD1 (x ^: G)) ?mem_classes //=. +rewrite cfunE cfun_repr cfun_classE Gx class_refl mulr1. +rewrite big1 ?addr0 // => _ /andP[/imsetP[y Gy ->]]; apply: contraNeq. +rewrite cfunE cfun_repr cfun_classE Gy mulf_eq0 => /norP[_]. +by rewrite pnatr_eq0 -lt0n lt0b => /class_transr->. +Qed. +Implicit Arguments cfun_onP [A phi]. + +Lemma cfun_on0 A phi x : phi \in 'CF(G, A) -> x \notin A -> phi x = 0. +Proof. by move/cfun_onP; exact. Qed. + +Lemma sum_by_classes (R : ringType) (F : gT -> R) : + {in G &, forall g h, F (g ^ h) = F g} -> + \sum_(g in G) F g = \sum_(xG in classes G) #|xG|%:R * F (repr xG). +Proof. +move=> FJ; rewrite {1}(partition_big _ _ ((@mem_classes gT)^~ G)) /=. +apply: eq_bigr => _ /imsetP[x Gx ->]; have [y Gy ->] := repr_class G x. +rewrite mulr_natl -sumr_const FJ {y Gy}//; apply/esym/eq_big=> y /=. + apply/idP/andP=> [xGy | [Gy /eqP<-]]; last exact: class_refl. + by rewrite (class_transr xGy) (subsetP (class_subG Gx (subxx _))). +by case/imsetP=> z Gz ->; rewrite FJ. +Qed. + +Lemma cfun_base_free A : free (cfun_base G A). +Proof. +have b_i (i : 'I_#|classes G ::&: A|) : (cfun_base G A)`_i = '1_(enum_val i). + by rewrite /enum_val -!tnth_nth tnth_map. +apply/freeP => s S0 i; move/cfunP/(_ (repr (enum_val i))): S0. +rewrite sum_cfunE (bigD1 i) //= big1 ?addr0 => [|j]. + rewrite b_i !cfunE; have /setIdP[/imsetP[x Gx ->] _] := enum_valP i. + by rewrite cfun_repr cfun_classE Gx class_refl mulr1. +apply: contraNeq; rewrite b_i !cfunE mulf_eq0 => /norP[_]. +rewrite -(inj_eq enum_val_inj). +have /setIdP[/imsetP[x _ ->] _] := enum_valP i; rewrite cfun_repr. +have /setIdP[/imsetP[y Gy ->] _] := enum_valP j; rewrite cfun_classE Gy. +by rewrite pnatr_eq0 -lt0n lt0b => /class_transr->. +Qed. + +Lemma dim_cfun : \dim 'CF(G) = #|classes G|. +Proof. by rewrite dimvf /Vector.dim /= genGid. Qed. + +Lemma dim_cfun_on A : \dim 'CF(G, A) = #|classes G ::&: A|. +Proof. by rewrite (eqnP (cfun_base_free A)) size_tuple. Qed. + +Lemma dim_cfun_on_abelian A : abelian G -> A \subset G -> \dim 'CF(G, A) = #|A|. +Proof. +move/abelian_classP=> cGG sAG; rewrite -(card_imset _ set1_inj) dim_cfun_on. +apply/eq_card=> xG; rewrite !inE. +apply/andP/imsetP=> [[/imsetP[x Gx ->] Ax] | [x Ax ->]] {xG}. + by rewrite cGG ?sub1set // in Ax *; exists x. +by rewrite -{1}(cGG x) ?mem_classes ?(subsetP sAG) ?sub1set. +Qed. + +Lemma cfuni_on A : '1_A \in 'CF(G, A). +Proof. +apply/cfun_onP=> x notAx; rewrite cfunElock genGid. +by case: andP => // [[_ s_xG_A]]; rewrite (subsetP s_xG_A) ?class_refl in notAx. +Qed. + +Lemma mul_cfuni_on A phi : phi * '1_A \in 'CF(G, A). +Proof. +by apply/cfun_onP=> x /(cfun_onP (cfuni_on A)) Ax0; rewrite cfunE Ax0 mulr0. +Qed. + +Lemma cfun_onE phi A : (phi \in 'CF(G, A)) = (support phi \subset A). +Proof. exact: (sameP cfun_onP supportP). Qed. + +Lemma cfun_onT phi : phi \in 'CF(G, [set: gT]). +Proof. by rewrite cfun_onE. Qed. + +Lemma cfun_onD1 phi A : + (phi \in 'CF(G, A^#)) = (phi \in 'CF(G, A)) && (phi 1%g == 0). +Proof. +by rewrite !cfun_onE -!(eq_subset (in_set (support _))) subsetD1 !inE negbK. +Qed. + +Lemma cfun_onG phi : phi \in 'CF(G, G). +Proof. by rewrite cfun_onE support_cfun. Qed. + +Lemma cfunD1E phi : (phi \in 'CF(G, G^#)) = (phi 1%g == 0). +Proof. by rewrite cfun_onD1 cfun_onG. Qed. + +Lemma cfunGid : 'CF(G, G) = 'CF(G)%VS. +Proof. by apply/vspaceP=> phi; rewrite cfun_onG memvf. Qed. + +Lemma cfun_onS A B phi : B \subset A -> phi \in 'CF(G, B) -> phi \in 'CF(G, A). +Proof. by rewrite !cfun_onE => sBA /subset_trans->. Qed. + +Lemma cfun_complement A : + A <| G -> ('CF(G, A) + 'CF(G, G :\: A)%SET = 'CF(G))%VS. +Proof. +case/andP=> sAG nAG; rewrite -cfunGid [rhs in _ = rhs]cfun_on_sum. +rewrite (bigID (fun B => B \subset A)) /=. +congr (_ + _)%VS; rewrite cfun_on_sum; apply: eq_bigl => /= xG. + rewrite andbAC; apply/esym/andb_idr=> /andP[/imsetP[x Gx ->] _]. + by rewrite class_subG. +rewrite -andbA; apply: andb_id2l => /imsetP[x Gx ->]. +by rewrite !class_sub_norm ?normsD ?normG // inE andbC. +Qed. + +Lemma cfConjCE phi x : (phi^*)%CF x = (phi x)^*. +Proof. by rewrite cfunE. Qed. + +Lemma cfConjCK : involutive (fun phi => phi^*)%CF. +Proof. by move=> phi; apply/cfunP=> x; rewrite !cfunE conjCK. Qed. + +Lemma cfConjC_cfun1 : (1^*)%CF = 1 :> 'CF(G). +Proof. exact: rmorph1. Qed. + +(* Class function kernel and faithful class functions *) + +Fact cfker_is_group phi : group_set (cfker phi). +Proof. +apply/group_setP; split=> [|x y]; rewrite !inE ?group1. + by apply/forallP=> y; rewrite mul1g. +case/andP=> Gx /forallP-Kx /andP[Gy /forallP-Ky]; rewrite groupM //. +by apply/forallP=> z; rewrite -mulgA (eqP (Kx _)) Ky. +Qed. +Canonical cfker_group phi := Group (cfker_is_group phi). + +Lemma cfker_sub phi : cfker phi \subset G. +Proof. by rewrite /cfker setIdE subsetIl. Qed. + +Lemma cfker_norm phi : G \subset 'N(cfker phi). +Proof. +apply/subsetP=> z Gz; have phiJz := cfunJ phi _ (groupVr Gz). +rewrite inE; apply/subsetP=> _ /imsetP[x /setIdP[Gx /forallP-Kx] ->]. +rewrite inE groupJ //; apply/forallP=> y. +by rewrite -(phiJz y) -phiJz conjMg conjgK Kx. +Qed. + +Lemma cfker_normal phi : cfker phi <| G. +Proof. by rewrite /normal cfker_sub cfker_norm. Qed. + +Lemma cfkerMl phi x y : x \in cfker phi -> phi (x * y)%g = phi y. +Proof. by case/setIdP=> _ /eqfunP->. Qed. + +Lemma cfkerMr phi x y : x \in cfker phi -> phi (y * x)%g = phi y. +Proof. +by move=> Kx; rewrite conjgC cfkerMl ?cfunJ ?(subsetP (cfker_sub phi)). +Qed. + +Lemma cfker1 phi x : x \in cfker phi -> phi x = phi 1%g. +Proof. by move=> Kx; rewrite -[x]mulg1 cfkerMl. Qed. + +Lemma cfker_cfun0 : @cfker _ G 0 = G. +Proof. +apply/setP=> x; rewrite !inE andb_idr // => Gx; apply/forallP=> y. +by rewrite !cfunE. +Qed. + +Lemma cfker_add phi psi : cfker phi :&: cfker psi \subset cfker (phi + psi). +Proof. +apply/subsetP=> x /setIP[Kphi_x Kpsi_x]; have [Gx _] := setIdP Kphi_x. +by rewrite inE Gx; apply/forallP=> y; rewrite !cfunE !cfkerMl. +Qed. + +Lemma cfker_sum I r (P : pred I) (Phi : I -> 'CF(G)) : + G :&: \bigcap_(i <- r | P i) cfker (Phi i) + \subset cfker (\sum_(i <- r | P i) Phi i). +Proof. +elim/big_rec2: _ => [|i K psi Pi sK_psi]; first by rewrite setIT cfker_cfun0. +by rewrite setICA; apply: subset_trans (setIS _ sK_psi) (cfker_add _ _). +Qed. + +Lemma cfker_scale a phi : cfker phi \subset cfker (a *: phi). +Proof. +apply/subsetP=> x Kphi_x; have [Gx _] := setIdP Kphi_x. +by rewrite inE Gx; apply/forallP=> y; rewrite !cfunE cfkerMl. +Qed. + +Lemma cfker_scale_nz a phi : a != 0 -> cfker (a *: phi) = cfker phi. +Proof. +move=> nz_a; apply/eqP. +by rewrite eqEsubset -{2}(scalerK nz_a phi) !cfker_scale. +Qed. + +Lemma cfker_opp phi : cfker (- phi) = cfker phi. +Proof. by rewrite -scaleN1r cfker_scale_nz // oppr_eq0 oner_eq0. Qed. + +Lemma cfker_cfun1 : @cfker _ G 1 = G. +Proof. +apply/setP=> x; rewrite !inE andb_idr // => Gx; apply/forallP=> y. +by rewrite !cfun1E groupMl. +Qed. + +Lemma cfker_mul phi psi : cfker phi :&: cfker psi \subset cfker (phi * psi). +Proof. +apply/subsetP=> x /setIP[Kphi_x Kpsi_x]; have [Gx _] := setIdP Kphi_x. +by rewrite inE Gx; apply/forallP=> y; rewrite !cfunE !cfkerMl. +Qed. + +Lemma cfker_prod I r (P : pred I) (Phi : I -> 'CF(G)) : + G :&: \bigcap_(i <- r | P i) cfker (Phi i) + \subset cfker (\prod_(i <- r | P i) Phi i). +Proof. +elim/big_rec2: _ => [|i K psi Pi sK_psi]; first by rewrite setIT cfker_cfun1. +by rewrite setICA; apply: subset_trans (setIS _ sK_psi) (cfker_mul _ _). +Qed. + +Lemma cfaithfulE phi : cfaithful phi = (cfker phi \subset [1]). +Proof. by []. Qed. + +End ClassFun. + +Arguments Scope classfun_on [_ group_scope group_scope]. +Notation "''CF' ( G , A )" := (classfun_on G A) : ring_scope. + +Implicit Arguments cfun_onP [gT G A phi]. +Hint Resolve cfun_onT. + +Section DotProduct. + +Variable (gT : finGroupType) (G : {group gT}). +Implicit Types (M : {group gT}) (phi psi xi : 'CF(G)) (R S : seq 'CF(G)). + +Lemma cfdotE phi psi : + '[phi, psi] = #|G|%:R^-1 * \sum_(x in G) phi x * (psi x)^*. +Proof. by []. Qed. + +Lemma cfdotElr A B phi psi : + phi \in 'CF(G, A) -> psi \in 'CF(G, B) -> + '[phi, psi] = #|G|%:R^-1 * \sum_(x in A :&: B) phi x * (psi x)^*. +Proof. +move=> Aphi Bpsi; rewrite (big_setID G) cfdotE (big_setID (A :&: B)) setIC /=. +congr (_ * (_ + _)); rewrite !big1 // => x /setDP[_]. + by move/cfun0->; rewrite mul0r. +rewrite inE; case/nandP=> notABx; first by rewrite (cfun_on0 Aphi) ?mul0r. +by rewrite (cfun_on0 Bpsi) // rmorph0 mulr0. +Qed. + +Lemma cfdotEl A phi psi : + phi \in 'CF(G, A) -> + '[phi, psi] = #|G|%:R^-1 * \sum_(x in A) phi x * (psi x)^*. +Proof. by move=> Aphi; rewrite (cfdotElr Aphi (cfun_onT psi)) setIT. Qed. + +Lemma cfdotEr A phi psi : + psi \in 'CF(G, A) -> + '[phi, psi] = #|G|%:R^-1 * \sum_(x in A) phi x * (psi x)^*. +Proof. by move=> Apsi; rewrite (cfdotElr (cfun_onT phi) Apsi) setTI. Qed. + +Lemma cfdot_complement A phi psi : + phi \in 'CF(G, A) -> psi \in 'CF(G, G :\: A) -> '[phi, psi] = 0. +Proof. +move=> Aphi A'psi; rewrite (cfdotElr Aphi A'psi). +by rewrite setDE setICA setICr setI0 big_set0 mulr0. +Qed. + +Lemma cfnormE A phi : + phi \in 'CF(G, A) -> '[phi] = #|G|%:R^-1 * (\sum_(x in A) `|phi x| ^+ 2). +Proof. by move/cfdotEl->; rewrite (eq_bigr _ (fun _ _ => normCK _)). Qed. + +Lemma eq_cfdotl A phi1 phi2 psi : + psi \in 'CF(G, A) -> {in A, phi1 =1 phi2} -> '[phi1, psi] = '[phi2, psi]. +Proof. +move/cfdotEr=> eq_dot eq_phi; rewrite !eq_dot; congr (_ * _). +by apply: eq_bigr => x Ax; rewrite eq_phi. +Qed. + +Lemma cfdot_cfuni A B : + A <| G -> B <| G -> '['1_A, '1_B]_G = #|A :&: B|%:R / #|G|%:R. +Proof. +move=> nsAG nsBG; rewrite (cfdotElr (cfuni_on G A) (cfuni_on G B)) mulrC. +congr (_ / _); rewrite -sumr_const; apply: eq_bigr => x /setIP[Ax Bx]. +by rewrite !cfuniE // Ax Bx rmorph1 mulr1. +Qed. + +Lemma cfnorm1 : '[1]_G = 1. +Proof. by rewrite cfdot_cfuni ?genGid // setIid divff ?neq0CG. Qed. + +Lemma cfdotrE psi phi : cfdotr psi phi = '[phi, psi]. Proof. by []. Qed. + +Lemma cfdotr_is_linear xi : linear (cfdotr xi : 'CF(G) -> algC^o). +Proof. +move=> a phi psi; rewrite scalerAr -mulrDr; congr (_ * _). +rewrite linear_sum -big_split; apply: eq_bigr => x _ /=. +by rewrite !cfunE mulrDl -mulrA. +Qed. +Canonical cfdotr_additive xi := Additive (cfdotr_is_linear xi). +Canonical cfdotr_linear xi := Linear (cfdotr_is_linear xi). + +Lemma cfdot0l xi : '[0, xi] = 0. +Proof. by rewrite -cfdotrE linear0. Qed. +Lemma cfdotNl xi phi : '[- phi, xi] = - '[phi, xi]. +Proof. by rewrite -!cfdotrE linearN. Qed. +Lemma cfdotDl xi phi psi : '[phi + psi, xi] = '[phi, xi] + '[psi, xi]. +Proof. by rewrite -!cfdotrE linearD. Qed. +Lemma cfdotBl xi phi psi : '[phi - psi, xi] = '[phi, xi] - '[psi, xi]. +Proof. by rewrite -!cfdotrE linearB. Qed. +Lemma cfdotMnl xi phi n : '[phi *+ n, xi] = '[phi, xi] *+ n. +Proof. by rewrite -!cfdotrE linearMn. Qed. +Lemma cfdot_suml xi I r (P : pred I) (phi : I -> 'CF(G)) : + '[\sum_(i <- r | P i) phi i, xi] = \sum_(i <- r | P i) '[phi i, xi]. +Proof. by rewrite -!cfdotrE linear_sum. Qed. +Lemma cfdotZl xi a phi : '[a *: phi, xi] = a * '[phi, xi]. +Proof. by rewrite -!cfdotrE linearZ. Qed. + +Lemma cfdotC phi psi : '[phi, psi] = ('[psi, phi])^*. +Proof. +rewrite /cfdot rmorphM fmorphV rmorph_nat rmorph_sum; congr (_ * _). +by apply: eq_bigr=> x _; rewrite rmorphM conjCK mulrC. +Qed. + +Lemma eq_cfdotr A phi psi1 psi2 : + phi \in 'CF(G, A) -> {in A, psi1 =1 psi2} -> '[phi, psi1] = '[phi, psi2]. +Proof. by move=> Aphi /eq_cfdotl eq_dot; rewrite cfdotC eq_dot // -cfdotC. Qed. + +Lemma cfdotBr xi phi psi : '[xi, phi - psi] = '[xi, phi] - '[xi, psi]. +Proof. by rewrite !(cfdotC xi) -rmorphB cfdotBl. Qed. +Canonical cfun_dot_additive xi := Additive (cfdotBr xi). + +Lemma cfdot0r xi : '[xi, 0] = 0. Proof. exact: raddf0. Qed. +Lemma cfdotNr xi phi : '[xi, - phi] = - '[xi, phi]. +Proof. exact: raddfN. Qed. +Lemma cfdotDr xi phi psi : '[xi, phi + psi] = '[xi, phi] + '[xi, psi]. +Proof. exact: raddfD. Qed. +Lemma cfdotMnr xi phi n : '[xi, phi *+ n] = '[xi, phi] *+ n. +Proof. exact: raddfMn. Qed. +Lemma cfdot_sumr xi I r (P : pred I) (phi : I -> 'CF(G)) : + '[xi, \sum_(i <- r | P i) phi i] = \sum_(i <- r | P i) '[xi, phi i]. +Proof. exact: raddf_sum. Qed. +Lemma cfdotZr a xi phi : '[xi, a *: phi] = a^* * '[xi, phi]. +Proof. by rewrite !(cfdotC xi) cfdotZl rmorphM. Qed. + +Lemma cfdot_cfAut (u : {rmorphism algC -> algC}) phi psi : + {in image psi G, {morph u : x / x^*}} -> + '[cfAut u phi, cfAut u psi] = u '[phi, psi]. +Proof. +move=> uC; rewrite rmorphM fmorphV rmorph_nat rmorph_sum; congr (_ * _). +by apply: eq_bigr => x Gx; rewrite !cfunE rmorphM uC ?map_f ?mem_enum. +Qed. + +Lemma cfdot_conjC phi psi : '[phi^*, psi^*] = '[phi, psi]^*. +Proof. by rewrite cfdot_cfAut. Qed. + +Lemma cfdot_conjCl phi psi : '[phi^*, psi] = '[phi, psi^*]^*. +Proof. by rewrite -cfdot_conjC cfConjCK. Qed. + +Lemma cfdot_conjCr phi psi : '[phi, psi^*] = '[phi^*, psi]^*. +Proof. by rewrite -cfdot_conjC cfConjCK. Qed. + +Lemma cfnorm_ge0 phi : 0 <= '[phi]. +Proof. +by rewrite mulr_ge0 ?invr_ge0 ?ler0n ?sumr_ge0 // => x _; exact: mul_conjC_ge0. +Qed. + +Lemma cfnorm_eq0 phi : ('[phi] == 0) = (phi == 0). +Proof. +apply/idP/eqP=> [|->]; last by rewrite cfdot0r. +rewrite mulf_eq0 invr_eq0 (negbTE (neq0CG G)) /= => /eqP/psumr_eq0P phi0. +apply/cfun_inP=> x Gx; apply/eqP; rewrite cfunE -mul_conjC_eq0. +by rewrite phi0 // => y _; exact: mul_conjC_ge0. +Qed. + +Lemma cfnorm_gt0 phi : ('[phi] > 0) = (phi != 0). +Proof. by rewrite ltr_def cfnorm_ge0 cfnorm_eq0 andbT. Qed. + +Lemma sqrt_cfnorm_ge0 phi : 0 <= sqrtC '[phi]. +Proof. by rewrite sqrtC_ge0 cfnorm_ge0. Qed. + +Lemma sqrt_cfnorm_eq0 phi : (sqrtC '[phi] == 0) = (phi == 0). +Proof. by rewrite sqrtC_eq0 cfnorm_eq0. Qed. + +Lemma sqrt_cfnorm_gt0 phi : (sqrtC '[phi] > 0) = (phi != 0). +Proof. by rewrite sqrtC_gt0 cfnorm_gt0. Qed. + +Lemma cfnormZ a phi : '[a *: phi]= `|a| ^+ 2 * '[phi]_G. +Proof. by rewrite cfdotZl cfdotZr mulrA normCK. Qed. + +Lemma cfnormN phi : '[- phi] = '[phi]. +Proof. by rewrite cfdotNl raddfN opprK. Qed. + +Lemma cfnorm_sign n phi : '[(-1) ^+ n *: phi] = '[phi]. +Proof. by rewrite -signr_odd scaler_sign; case: (odd n); rewrite ?cfnormN. Qed. + +Lemma cfnormD phi psi : + let d := '[phi, psi] in '[phi + psi] = '[phi] + '[psi] + (d + d^*). +Proof. by rewrite /= addrAC -cfdotC cfdotDl !cfdotDr !addrA. Qed. + +Lemma cfnormB phi psi : + let d := '[phi, psi] in '[phi - psi] = '[phi] + '[psi] - (d + d^*). +Proof. by rewrite /= cfnormD cfnormN cfdotNr rmorphN -opprD. Qed. + +Lemma cfnormDd phi psi : '[phi, psi] = 0 -> '[phi + psi] = '[phi] + '[psi]. +Proof. by move=> ophipsi; rewrite cfnormD ophipsi rmorph0 !addr0. Qed. + +Lemma cfnormBd phi psi : '[phi, psi] = 0 -> '[phi - psi] = '[phi] + '[psi]. +Proof. +by move=> ophipsi; rewrite cfnormDd ?cfnormN // cfdotNr ophipsi oppr0. +Qed. + +Lemma cfnorm_conjC phi : '[phi^*] = '[phi]. +Proof. by rewrite cfdot_conjC geC0_conj // cfnorm_ge0. Qed. + +Lemma cfCauchySchwarz phi psi : + `|'[phi, psi]| ^+ 2 <= '[phi] * '[psi] ?= iff ~~ free (phi :: psi). +Proof. +rewrite free_cons span_seq1 seq1_free -negb_or negbK orbC. +have [-> | nz_psi] /= := altP (psi =P 0). + by apply/lerifP; rewrite !cfdot0r normCK mul0r mulr0. +without loss ophi: phi / '[phi, psi] = 0. + move=> IHo; pose a := '[phi, psi] / '[psi]; pose phi1 := phi - a *: psi. + have ophi: '[phi1, psi] = 0. + by rewrite cfdotBl cfdotZl divfK ?cfnorm_eq0 ?subrr. + rewrite (canRL (subrK _) (erefl phi1)) rpredDr ?rpredZ ?memv_line //. + rewrite cfdotDl ophi add0r cfdotZl normrM (ger0_norm (cfnorm_ge0 _)). + rewrite exprMn mulrA -cfnormZ cfnormDd; last by rewrite cfdotZr ophi mulr0. + by have:= IHo _ ophi; rewrite mulrDl -lerif_subLR subrr ophi normCK mul0r. +rewrite ophi normCK mul0r; split; first by rewrite mulr_ge0 ?cfnorm_ge0. +rewrite eq_sym mulf_eq0 orbC cfnorm_eq0 (negPf nz_psi) /=. +apply/idP/idP=> [|/vlineP[a {2}->]]; last by rewrite cfdotZr ophi mulr0. +by rewrite cfnorm_eq0 => /eqP->; apply: rpred0. +Qed. + +Lemma cfCauchySchwarz_sqrt phi psi : + `|'[phi, psi]| <= sqrtC '[phi] * sqrtC '[psi] ?= iff ~~ free (phi :: psi). +Proof. +rewrite -(sqrCK (normr_ge0 _)) -sqrtCM ?qualifE ?cfnorm_ge0 //. +rewrite (mono_in_lerif ler_sqrtC) 1?rpredM ?qualifE ?normr_ge0 ?cfnorm_ge0 //. +exact: cfCauchySchwarz. +Qed. + +Lemma cf_triangle_lerif phi psi : + sqrtC '[phi + psi] <= sqrtC '[phi] + sqrtC '[psi] + ?= iff ~~ free (phi :: psi) && (0 <= coord [tuple psi] 0 phi). +Proof. +rewrite -(mono_in_lerif ler_sqr) ?rpredD ?qualifE ?sqrtC_ge0 ?cfnorm_ge0 //. +rewrite andbC sqrrD !sqrtCK addrAC cfnormD (mono_lerif (ler_add2l _)). +rewrite -mulr_natr -[_ + _](divfK (negbT (eqC_nat 2 0))) -/('Re _). +rewrite (mono_lerif (ler_pmul2r _)) ?ltr0n //. +have:= lerif_trans (lerif_Re_Creal '[phi, psi]) (cfCauchySchwarz_sqrt phi psi). +congr (_ <= _ ?= iff _); apply: andb_id2r. +rewrite free_cons span_seq1 seq1_free -negb_or negbK orbC. +have [-> | nz_psi] := altP (psi =P 0); first by rewrite cfdot0r coord0. +case/vlineP=> [x ->]; rewrite cfdotZl linearZ pmulr_lge0 ?cfnorm_gt0 //=. +by rewrite (coord_free 0) ?seq1_free // eqxx mulr1. +Qed. + +Lemma orthogonal_cons phi R S : + orthogonal (phi :: R) S = orthogonal phi S && orthogonal R S. +Proof. by rewrite /orthogonal /= andbT. Qed. + +Lemma orthoP phi psi : reflect ('[phi, psi] = 0) (orthogonal phi psi). +Proof. by rewrite /orthogonal /= !andbT; exact: eqP. Qed. + +Lemma orthogonalP S R : + reflect {in S & R, forall phi psi, '[phi, psi] = 0} (orthogonal S R). +Proof. +apply: (iffP allP) => oSR phi => [psi /oSR/allP opS /opS/eqP // | /oSR opS]. +by apply/allP=> psi /= /opS->. +Qed. + +Lemma orthoPl phi S : + reflect {in S, forall psi, '[phi, psi] = 0} (orthogonal phi S). +Proof. +by rewrite [orthogonal _ S]andbT /=; apply: (iffP allP) => ophiS ? /ophiS/eqP. +Qed. +Implicit Arguments orthoPl [phi S]. + +Lemma orthogonal_sym : symmetric (@orthogonal _ G). +Proof. +apply: symmetric_from_pre => R S /orthogonalP oRS. +by apply/orthogonalP=> phi psi Rpsi Sphi; rewrite cfdotC oRS ?rmorph0. +Qed. + +Lemma orthoPr S psi : + reflect {in S, forall phi, '[phi, psi] = 0} (orthogonal S psi). +Proof. +rewrite orthogonal_sym. +by apply: (iffP orthoPl) => oSpsi phi Sphi; rewrite cfdotC oSpsi ?conjC0. +Qed. + +Lemma eq_orthogonal R1 R2 S1 S2 : + R1 =i R2 -> S1 =i S2 -> orthogonal R1 S1 = orthogonal R2 S2. +Proof. +move=> eqR eqS; rewrite [orthogonal _ _](eq_all_r eqR). +by apply: eq_all => psi /=; exact: eq_all_r. +Qed. + +Lemma orthogonal_catl R1 R2 S : + orthogonal (R1 ++ R2) S = orthogonal R1 S && orthogonal R2 S. +Proof. exact: all_cat. Qed. + +Lemma orthogonal_catr R S1 S2 : + orthogonal R (S1 ++ S2) = orthogonal R S1 && orthogonal R S2. +Proof. by rewrite !(orthogonal_sym R) orthogonal_catl. Qed. + +Lemma span_orthogonal S1 S2 phi1 phi2 : + orthogonal S1 S2 -> phi1 \in <>%VS -> phi2 \in <>%VS -> + '[phi1, phi2] = 0. +Proof. +move/orthogonalP=> oS12; do 2!move/(@coord_span _ _ _ (in_tuple _))->. +rewrite cfdot_suml big1 // => i _; rewrite cfdot_sumr big1 // => j _. +by rewrite cfdotZl cfdotZr oS12 ?mem_nth ?mulr0. +Qed. + +Lemma orthogonal_split S beta : + {X : 'CF(G) & X \in <>%VS & + {Y | [/\ beta = X + Y, '[X, Y] = 0 & orthogonal Y S]}}. +Proof. +suffices [X S_X [Y -> oYS]]: + {X : _ & X \in <>%VS & {Y | beta = X + Y & orthogonal Y S}}. +- exists X => //; exists Y. + by rewrite cfdotC (span_orthogonal oYS) ?memv_span1 ?conjC0. +elim: S beta => [|phi S IHS] beta. + by exists 0; last exists beta; rewrite ?mem0v ?add0r. +have [[U S_U [V -> oVS]] [X S_X [Y -> oYS]]] := (IHS phi, IHS beta). +pose Z := '[Y, V] / '[V] *: V; exists (X + Z). + rewrite /Z -{4}(addKr U V) scalerDr scalerN addrA addrC span_cons. + by rewrite memv_add ?memvB ?memvZ ?memv_line. +exists (Y - Z); first by rewrite addrCA !addrA addrK addrC. +apply/orthoPl=> psi; rewrite !inE => /predU1P[-> | Spsi]; last first. + by rewrite cfdotBl cfdotZl (orthoPl oVS _ Spsi) mulr0 subr0 (orthoPl oYS). +rewrite cfdotBl !cfdotDr (span_orthogonal oYS) // ?memv_span ?mem_head //. +rewrite !cfdotZl (span_orthogonal oVS _ S_U) ?mulr0 ?memv_span ?mem_head //. +have [-> | nzV] := eqVneq V 0; first by rewrite cfdot0r !mul0r subrr. +by rewrite divfK ?cfnorm_eq0 ?subrr. +Qed. + +Lemma map_orthogonal M (nu : 'CF(G) -> 'CF(M)) S R (A : pred 'CF(G)) : + {in A &, isometry nu} -> {subset S <= A} -> {subset R <= A} -> + orthogonal (map nu S) (map nu R) = orthogonal S R. +Proof. +move=> Inu sSA sRA; rewrite [orthogonal _ _]all_map. +apply: eq_in_all => phi Sphi; rewrite /= all_map. +by apply: eq_in_all => psi Rpsi; rewrite /= Inu ?(sSA phi) ?(sRA psi). +Qed. + +Lemma orthogonal_oppr S R : orthogonal S (map -%R R) = orthogonal S R. +Proof. +wlog suffices IH: S R / orthogonal S R -> orthogonal S (map -%R R). + apply/idP/idP=> /IH; rewrite ?mapK //; exact: opprK. +move/orthogonalP=> oSR; apply/orthogonalP=> xi1 _ Sxi1 /mapP[xi2 Rxi2 ->]. +by rewrite cfdotNr oSR ?oppr0. +Qed. + +Lemma orthogonal_oppl S R : orthogonal (map -%R S) R = orthogonal S R. +Proof. by rewrite -!(orthogonal_sym R) orthogonal_oppr. Qed. + +Lemma pairwise_orthogonalP S : + reflect (uniq (0 :: S) + /\ {in S &, forall phi psi, phi != psi -> '[phi, psi] = 0}) + (pairwise_orthogonal S). +Proof. +rewrite /pairwise_orthogonal /=; case notS0: (~~ _); last by right; case. +elim: S notS0 => [|phi S IH] /=; first by left. +rewrite inE eq_sym andbT => /norP[nz_phi /IH{IH}IH]. +have [opS | not_opS] := allP; last first. + right=> [[/andP[notSp _] opS]]; case: not_opS => psi Spsi /=. + by rewrite opS ?mem_head 1?mem_behead // (memPnC notSp). +rewrite (contra (opS _)) /= ?cfnorm_eq0 //. +apply: (iffP IH) => [] [uniqS oSS]; last first. + by split=> //; apply: sub_in2 oSS => psi Spsi; exact: mem_behead. +split=> // psi xi; rewrite !inE => /predU1P[-> // | Spsi]. + by case/predU1P=> [-> | /opS] /eqP. +case/predU1P=> [-> _ | Sxi /oSS-> //]. +by apply/eqP; rewrite cfdotC conjC_eq0 [_ == 0]opS. +Qed. + +Lemma pairwise_orthogonal_cat R S : + pairwise_orthogonal (R ++ S) = + [&& pairwise_orthogonal R, pairwise_orthogonal S & orthogonal R S]. +Proof. +rewrite /pairwise_orthogonal mem_cat negb_or -!andbA; do !bool_congr. +elim: R => [|phi R /= ->]; rewrite ?andbT // orthogonal_cons all_cat -!andbA /=. +by do !bool_congr. +Qed. + +Lemma eq_pairwise_orthogonal R S : + perm_eq R S -> pairwise_orthogonal R = pairwise_orthogonal S. +Proof. +apply: catCA_perm_subst R S => R S S'. +rewrite !pairwise_orthogonal_cat !orthogonal_catr (orthogonal_sym R S) -!andbA. +by do !bool_congr. +Qed. + +Lemma sub_pairwise_orthogonal S1 S2 : + {subset S1 <= S2} -> uniq S1 -> + pairwise_orthogonal S2 -> pairwise_orthogonal S1. +Proof. +move=> sS12 uniqS1 /pairwise_orthogonalP[/andP[notS2_0 _] oS2]. +apply/pairwise_orthogonalP; rewrite /= (contra (sS12 0)) //. +by split=> //; exact: sub_in2 oS2. +Qed. + +Lemma orthogonal_free S : pairwise_orthogonal S -> free S. +Proof. +case/pairwise_orthogonalP=> [/=/andP[notS0 uniqS] oSS]. +rewrite -(in_tupleE S); apply/freeP => a aS0 i. +have S_i: S`_i \in S by exact: mem_nth. +have /eqP: '[S`_i, 0]_G = 0 := cfdot0r _. +rewrite -{2}aS0 raddf_sum /= (bigD1 i) //= big1 => [|j neq_ji]; last 1 first. + by rewrite cfdotZr oSS ?mulr0 ?mem_nth // eq_sym nth_uniq. +rewrite addr0 cfdotZr mulf_eq0 conjC_eq0 cfnorm_eq0. +by case/pred2P=> // Si0; rewrite -Si0 S_i in notS0. +Qed. + +Lemma filter_pairwise_orthogonal S p : + pairwise_orthogonal S -> pairwise_orthogonal (filter p S). +Proof. +move=> orthoS; apply: sub_pairwise_orthogonal (orthoS). + exact: mem_subseq (filter_subseq p S). +exact/filter_uniq/free_uniq/orthogonal_free. +Qed. + +Lemma orthonormal_not0 S : orthonormal S -> 0 \notin S. +Proof. +by case/andP=> /allP S1 _; rewrite (contra (S1 _)) //= cfdot0r eq_sym oner_eq0. +Qed. + +Lemma orthonormalE S : + orthonormal S = all [pred phi | '[phi] == 1] S && pairwise_orthogonal S. +Proof. by rewrite -(andb_idl (@orthonormal_not0 S)) andbCA. Qed. + +Lemma orthonormal_orthogonal S : orthonormal S -> pairwise_orthogonal S. +Proof. by rewrite orthonormalE => /andP[_]. Qed. + +Lemma orthonormal_cat R S : + orthonormal (R ++ S) = [&& orthonormal R, orthonormal S & orthogonal R S]. +Proof. +rewrite !orthonormalE pairwise_orthogonal_cat all_cat -!andbA. +by do !bool_congr. +Qed. + +Lemma eq_orthonormal R S : perm_eq R S -> orthonormal R = orthonormal S. +Proof. +move=> eqRS; rewrite !orthonormalE (eq_all_r (perm_eq_mem eqRS)). +by rewrite (eq_pairwise_orthogonal eqRS). +Qed. + +Lemma orthonormal_free S : orthonormal S -> free S. +Proof. by move/orthonormal_orthogonal/orthogonal_free. Qed. + +Lemma orthonormalP S : + reflect (uniq S /\ {in S &, forall phi psi, '[phi, psi]_G = (phi == psi)%:R}) + (orthonormal S). +Proof. +rewrite orthonormalE; have [/= normS | not_normS] := allP; last first. + by right=> [[_ o1S]]; case: not_normS => phi Sphi; rewrite /= o1S ?eqxx. +apply: (iffP (pairwise_orthogonalP S)) => [] [uniqS oSS]. + split=> // [|phi psi]; first by case/andP: uniqS. + by have [-> _ /normS/eqP | /oSS] := altP eqP. +split=> // [|phi psi Sphi Spsi /negbTE]; last by rewrite oSS // => ->. +by rewrite /= (contra (normS _)) // cfdot0r eq_sym oner_eq0. +Qed. + +Lemma sub_orthonormal S1 S2 : + {subset S1 <= S2} -> uniq S1 -> orthonormal S2 -> orthonormal S1. +Proof. +move=> sS12 uniqS1 /orthonormalP[_ oS1]. +by apply/orthonormalP; split; last exact: sub_in2 sS12 _ _. +Qed. + +Lemma orthonormal2P phi psi : + reflect [/\ '[phi, psi] = 0, '[phi] = 1 & '[psi] = 1] + (orthonormal [:: phi; psi]). +Proof. +rewrite /orthonormal /= !andbT andbC. +by apply: (iffP and3P) => [] []; do 3!move/eqP->. +Qed. + +Lemma conjC_pair_orthogonal S chi : + conjC_closed S -> ~~ has cfReal S -> pairwise_orthogonal S -> chi \in S -> + pairwise_orthogonal (chi :: chi^*%CF). +Proof. +move=> ccS /hasPn nrS oSS Schi; apply: sub_pairwise_orthogonal oSS. + by apply/allP; rewrite /= Schi ccS. +by rewrite /= inE eq_sym nrS. +Qed. + +Lemma cfdot_real_conjC phi psi : cfReal phi -> '[phi, psi^*]_G = '[phi, psi]^*. +Proof. by rewrite -cfdot_conjC => /eqcfP->. Qed. + +(* Note: other isometry lemmas, and the dot product lemmas for orthogonal *) +(* and orthonormal sequences are in vcharacter, because we need the 'Z[S] *) +(* notation for the isometry domains. Alternatively, this could be moved to *) +(* cfun. *) + +End DotProduct. + +Implicit Arguments orthoP [gT G phi psi]. +Implicit Arguments orthoPl [gT G phi S]. +Implicit Arguments orthoPr [gT G S psi]. +Implicit Arguments orthogonalP [gT G R S]. +Implicit Arguments pairwise_orthogonalP [gT G S]. +Implicit Arguments orthonormalP [gT G S]. + +Section CfunOrder. + +Variables (gT : finGroupType) (G : {group gT}) (phi : 'CF(G)). + +Lemma dvdn_cforderP n : + reflect {in G, forall x, phi x ^+ n = 1} (#[phi]%CF %| n)%N. +Proof. +apply: (iffP (dvdn_biglcmP _ _ _)); rewrite genGid => phiG1 x Gx. + by apply/eqP; rewrite -dvdn_orderC phiG1. +by rewrite dvdn_orderC phiG1. +Qed. + +Lemma dvdn_cforder n : (#[phi]%CF %| n) = (phi ^+ n == 1). +Proof. +apply/dvdn_cforderP/eqP=> phi_n_1 => [|x Gx]. + by apply/cfun_inP=> x Gx; rewrite exp_cfunE // cfun1E Gx phi_n_1. +by rewrite -exp_cfunE // phi_n_1 // cfun1E Gx. +Qed. + +Lemma exp_cforder : phi ^+ #[phi]%CF = 1. +Proof. by apply/eqP; rewrite -dvdn_cforder. Qed. + +End CfunOrder. + +Implicit Arguments dvdn_cforderP [gT G phi n]. + +Section MorphOrder. + +Variables (aT rT : finGroupType) (G : {group aT}) (R : {group rT}). +Variable f : {rmorphism 'CF(G) -> 'CF(R)}. + +Lemma cforder_rmorph phi : #[f phi]%CF %| #[phi]%CF. +Proof. by rewrite dvdn_cforder -rmorphX exp_cforder rmorph1. Qed. + +Lemma cforder_inj_rmorph phi : injective f -> #[f phi]%CF = #[phi]%CF. +Proof. +move=> inj_f; apply/eqP; rewrite eqn_dvd cforder_rmorph dvdn_cforder /=. +by rewrite -(rmorph_eq1 _ inj_f) rmorphX exp_cforder. +Qed. + +End MorphOrder. + +Section BuildIsometries. + +Variable (gT : finGroupType) (L G : {group gT}). +Implicit Types (phi psi xi : 'CF(L)) (R S : seq 'CF(L)). +Implicit Types (U : pred 'CF(L)) (W : pred 'CF(G)). + +Lemma sub_iso_to U1 U2 W1 W2 tau : + {subset U2 <= U1} -> {subset W1 <= W2} -> + {in U1, isometry tau, to W1} -> {in U2, isometry tau, to W2}. +Proof. +by move=> sU sW [Itau Wtau]; split=> [|u /sU/Wtau/sW //]; exact: sub_in2 Itau. +Qed. + +Lemma isometry_of_cfnorm S tauS : + pairwise_orthogonal S -> pairwise_orthogonal tauS -> + map cfnorm tauS = map cfnorm S -> + {tau : {linear 'CF(L) -> 'CF(G)} | map tau S = tauS + & {in <>%VS &, isometry tau}}. +Proof. +move=> oS oT eq_nST; have freeS := orthogonal_free oS. +have eq_sz: size tauS = size S by have:= congr1 size eq_nST; rewrite !size_map. +have [tau /(_ freeS eq_sz) defT] := linear_of_free S tauS. +rewrite -[S]/(tval (in_tuple S)). +exists tau => // u v /coord_span-> /coord_span->; rewrite !raddf_sum /=. +apply: eq_bigr => i _ /=; rewrite linearZ !cfdotZr !cfdot_suml; congr (_ * _). +apply: eq_bigr => j _ /=; rewrite linearZ !cfdotZl; congr (_ * _). +rewrite -!((nth_map _ 0) tau) // defT; have [-> | neq_ji] := eqVneq j i. + by rewrite -!['[_]]((nth_map _ 0) cfnorm) ?eq_sz // eq_nST. +have{oS} [/=/andP[_ uS] oS] := pairwise_orthogonalP oS. +have{oT} [/=/andP[_ uT] oT] := pairwise_orthogonalP oT. +by rewrite oS ?oT ?mem_nth ? nth_uniq ?eq_sz. +Qed. + +Lemma isometry_raddf_inj U (tau : {additive 'CF(L) -> 'CF(G)}) : + {in U &, isometry tau} -> {in U &, forall u v, u - v \in U} -> + {in U &, injective tau}. +Proof. +move=> Itau linU phi psi Uphi Upsi /eqP; rewrite -subr_eq0 -raddfB. +by rewrite -cfnorm_eq0 Itau ?linU // cfnorm_eq0 subr_eq0 => /eqP. +Qed. + +Lemma opp_isometry : @isometry _ _ G G -%R. +Proof. by move=> x y; rewrite cfdotNl cfdotNr opprK. Qed. + +End BuildIsometries. + +Section Restrict. + +Variables (gT : finGroupType) (A B : {set gT}). +Local Notation H := <>. +Local Notation G := <>. + +Fact cfRes_subproof (phi : 'CF(B)) : + is_class_fun H [ffun x => phi (if H \subset G then x else 1%g) *+ (x \in H)]. +Proof. +apply: intro_class_fun => /= [x y Hx Hy | x /negbTE/=-> //]. +by rewrite Hx (groupJ Hx) //; case: subsetP => // sHG; rewrite cfunJgen ?sHG. +Qed. +Definition cfRes phi := Cfun 1 (cfRes_subproof phi). + +Lemma cfResE phi : A \subset B -> {in A, cfRes phi =1 phi}. +Proof. by move=> sAB x Ax; rewrite cfunElock mem_gen ?genS. Qed. + +Lemma cfRes1 phi : cfRes phi 1%g = phi 1%g. +Proof. by rewrite cfunElock if_same group1. Qed. + +Lemma cfRes_is_linear : linear cfRes. +Proof. +by move=> a phi psi; apply/cfunP=> x; rewrite !cfunElock mulrnAr mulrnDl. +Qed. +Canonical cfRes_additive := Additive cfRes_is_linear. +Canonical cfRes_linear := Linear cfRes_is_linear. + +Lemma cfRes_cfun1 : cfRes 1 = 1. +Proof. +apply: cfun_in_genP => x Hx; rewrite cfunElock Hx !cfun1Egen Hx. +by case: subsetP => [-> // | _]; rewrite group1. +Qed. + +Lemma cfRes_is_multiplicative : multiplicative cfRes. +Proof. +split=> [phi psi|]; [apply/cfunP=> x | exact: cfRes_cfun1]. +by rewrite !cfunElock mulrnAr mulrnAl -mulrnA mulnb andbb. +Qed. +Canonical cfRes_rmorphism := AddRMorphism cfRes_is_multiplicative. +Canonical cfRes_lrmorphism := [lrmorphism of cfRes]. + +End Restrict. + +Arguments Scope cfRes [_ group_scope group_scope cfun_scope]. +Notation "''Res[' H , G ]" := (@cfRes _ H G) (only parsing) : ring_scope. +Notation "''Res[' H ]" := 'Res[H, _] : ring_scope. +Notation "''Res'" := 'Res[_] (only parsing) : ring_scope. + +Section MoreRestrict. + +Variables (gT : finGroupType) (G H : {group gT}). +Implicit Types (A : {set gT}) (phi : 'CF(G)). + +Lemma cfResEout phi : ~~ (H \subset G) -> 'Res[H] phi = (phi 1%g)%:A. +Proof. +move/negPf=> not_sHG; apply/cfunP=> x. +by rewrite cfunE cfun1E mulr_natr cfunElock !genGid not_sHG. +Qed. + +Lemma cfResRes A phi : + A \subset H -> H \subset G -> 'Res[A] ('Res[H] phi) = 'Res[A] phi. +Proof. +move=> sAH sHG; apply/cfunP=> x; rewrite !cfunElock !genGid !gen_subG sAH sHG. +by rewrite (subset_trans sAH) // -mulrnA mulnb -in_setI (setIidPr _) ?gen_subG. +Qed. + +Lemma cfRes_id A psi : 'Res[A] psi = psi. +Proof. by apply/cfun_in_genP=> x Ax; rewrite cfunElock Ax subxx. Qed. + +Lemma sub_cfker_Res A phi : + A \subset H -> A \subset cfker phi -> A \subset cfker ('Res[H, G] phi). +Proof. +move=> sAH kerA; apply/subsetP=> x Ax; have Hx := subsetP sAH x Ax. +rewrite inE Hx; apply/forallP=> y; rewrite !cfunElock !genGid groupMl //. +by rewrite !(fun_if phi) cfkerMl // (subsetP kerA). +Qed. + +Lemma eq_cfker_Res phi : H \subset cfker phi -> cfker ('Res[H, G] phi) = H. +Proof. by move=> kH; apply/eqP; rewrite eqEsubset cfker_sub sub_cfker_Res. Qed. + +Lemma cfRes_sub_ker phi : H \subset cfker phi -> 'Res[H, G] phi = (phi 1%g)%:A. +Proof. +move=> kerHphi; have sHG := subset_trans kerHphi (cfker_sub phi). +apply/cfun_inP=> x Hx; have ker_x := subsetP kerHphi x Hx. +by rewrite cfResE // cfunE cfun1E Hx mulr1 cfker1. +Qed. + +Lemma cforder_Res phi : #['Res[H] phi]%CF %| #[phi]%CF. +Proof. exact: cforder_rmorph. Qed. + +End MoreRestrict. + +Section Morphim. + +Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}). + +Section Main. + +Variable G : {group aT}. +Implicit Type phi : 'CF(f @* G). + +Fact cfMorph_subproof phi : + is_class_fun <> + [ffun x => phi (if G \subset D then f x else 1%g) *+ (x \in G)]. +Proof. +rewrite genGid; apply: intro_class_fun => [x y Gx Gy | x /negPf-> //]. +rewrite Gx groupJ //; case subsetP => // sGD. +by rewrite morphJ ?cfunJ ?mem_morphim ?sGD. +Qed. +Definition cfMorph phi := Cfun 1 (cfMorph_subproof phi). + +Lemma cfMorphE phi x : G \subset D -> x \in G -> cfMorph phi x = phi (f x). +Proof. by rewrite cfunElock => -> ->. Qed. + +Lemma cfMorph1 phi : cfMorph phi 1%g = phi 1%g. +Proof. by rewrite cfunElock morph1 if_same group1. Qed. + +Lemma cfMorphEout phi : ~~ (G \subset D) -> cfMorph phi = (phi 1%g)%:A. +Proof. +move/negPf=> not_sGD; apply/cfunP=> x; rewrite cfunE cfun1E mulr_natr. +by rewrite cfunElock not_sGD. +Qed. + +Lemma cfMorph_cfun1 : cfMorph 1 = 1. +Proof. +apply/cfun_inP=> x Gx; rewrite cfunElock !cfun1E Gx. +by case: subsetP => [sGD | _]; rewrite ?group1 // mem_morphim ?sGD. +Qed. + +Fact cfMorph_is_linear : linear cfMorph. +Proof. +by move=> a phi psi; apply/cfunP=> x; rewrite !cfunElock mulrnAr -mulrnDl. +Qed. +Canonical cfMorph_additive := Additive cfMorph_is_linear. +Canonical cfMorph_linear := Linear cfMorph_is_linear. + +Fact cfMorph_is_multiplicative : multiplicative cfMorph. +Proof. +split=> [phi psi|]; [apply/cfunP=> x | exact: cfMorph_cfun1]. +by rewrite !cfunElock mulrnAr mulrnAl -mulrnA mulnb andbb. +Qed. +Canonical cfMorph_rmorphism := AddRMorphism cfMorph_is_multiplicative. +Canonical cfMorph_lrmorphism := [lrmorphism of cfMorph]. + +Hypothesis sGD : G \subset D. + +Lemma cfMorph_inj : injective cfMorph. +Proof. +move=> phi1 phi2 eq_phi; apply/cfun_inP=> _ /morphimP[x Dx Gx ->]. +by rewrite -!cfMorphE // eq_phi. +Qed. + +Lemma cfMorph_eq1 phi : (cfMorph phi == 1) = (phi == 1). +Proof. by apply: rmorph_eq1; apply: cfMorph_inj. Qed. + +Lemma cfker_morph phi : cfker (cfMorph phi) = G :&: f @*^-1 (cfker phi). +Proof. +apply/setP=> x; rewrite !inE; apply: andb_id2l => Gx. +have Dx := subsetP sGD x Gx; rewrite Dx mem_morphim //=. +apply/forallP/forallP=> Kx y. + have [{y} /morphimP[y Dy Gy ->] | fG'y] := boolP (y \in f @* G). + by rewrite -morphM // -!(cfMorphE phi) ?groupM. + by rewrite !cfun0 ?groupMl // mem_morphim. +have [Gy | G'y] := boolP (y \in G); last by rewrite !cfun0 ?groupMl. +by rewrite !cfMorphE ?groupM ?morphM // (subsetP sGD). +Qed. + +Lemma cfker_morph_im phi : f @* cfker (cfMorph phi) = cfker phi. +Proof. by rewrite cfker_morph // morphim_setIpre (setIidPr (cfker_sub _)). Qed. + +Lemma sub_cfker_morph phi (A : {set aT}) : + (A \subset cfker (cfMorph phi)) = (A \subset G) && (f @* A \subset cfker phi). +Proof. +rewrite cfker_morph // subsetI; apply: andb_id2l => sAG. +by rewrite sub_morphim_pre // (subset_trans sAG). +Qed. + +Lemma sub_morphim_cfker phi (A : {set aT}) : + A \subset G -> (f @* A \subset cfker phi) = (A \subset cfker (cfMorph phi)). +Proof. by move=> sAG; rewrite sub_cfker_morph ?sAG. Qed. + +Lemma cforder_morph phi : #[cfMorph phi]%CF = #[phi]%CF. +Proof. by apply: cforder_inj_rmorph; apply: cfMorph_inj. Qed. + +End Main. + +Lemma cfResMorph (G H : {group aT}) (phi : 'CF(f @* G)) : + H \subset G -> G \subset D -> 'Res (cfMorph phi) = cfMorph ('Res[f @* H] phi). +Proof. +move=> sHG sGD; have sHD := subset_trans sHG sGD. +apply/cfun_inP=> x Hx; have [Gx Dx] := (subsetP sHG x Hx, subsetP sHD x Hx). +by rewrite !(cfMorphE, cfResE) ?morphimS ?mem_morphim //. +Qed. + +End Morphim. + +Prenex Implicits cfMorph. + +Section Isomorphism. + +Variables (aT rT : finGroupType) (G : {group aT}) (f : {morphism G >-> rT}). +Variable R : {group rT}. + +Hypothesis isoGR : isom G R f. + +Let defR := isom_im isoGR. +Local Notation G1 := (isom_inv isoGR @* R). +Let defG : G1 = G := isom_im (isom_sym isoGR). + +Fact cfIsom_key : unit. Proof. by []. Qed. +Definition cfIsom := + locked_with cfIsom_key (cfMorph \o 'Res[G1] : 'CF(G) -> 'CF(R)). +Canonical cfIsom_unlockable := [unlockable of cfIsom]. + +Lemma cfIsomE phi x : x \in G -> cfIsom phi (f x) = phi x. +Proof. +move=> Gx; rewrite unlock cfMorphE //= /restrm ?defG ?cfRes_id ?invmE //. +by rewrite -defR mem_morphim. +Qed. + +Lemma cfIsom1 phi : cfIsom phi 1%g = phi 1%g. +Proof. by rewrite -(morph1 f) cfIsomE. Qed. + +Canonical cfIsom_additive := [additive of cfIsom]. +Canonical cfIsom_linear := [linear of cfIsom]. +Canonical cfIsom_rmorphism := [rmorphism of cfIsom]. +Canonical cfIsom_lrmorphism := [lrmorphism of cfIsom]. +Lemma cfIsom_cfun1 : cfIsom 1 = 1. Proof. exact: rmorph1. Qed. + +Lemma cfker_isom phi : cfker (cfIsom phi) = f @* cfker phi. +Proof. +rewrite unlock cfker_morph // defG cfRes_id morphpre_restrm morphpre_invm. +by rewrite -defR !morphimIim. +Qed. + +End Isomorphism. + +Prenex Implicits cfIsom. + +Section InvMorphism. + +Variables (aT rT : finGroupType) (G : {group aT}) (f : {morphism G >-> rT}). +Variable R : {group rT}. + +Hypothesis isoGR : isom G R f. + +Lemma cfIsomK : cancel (cfIsom isoGR) (cfIsom (isom_sym isoGR)). +Proof. +move=> phi; apply/cfun_inP=> x Gx; rewrite -{1}(invmE (isom_inj isoGR) Gx). +by rewrite !cfIsomE // -(isom_im isoGR) mem_morphim. +Qed. + +Lemma cfIsomKV : cancel (cfIsom (isom_sym isoGR)) (cfIsom isoGR). +Proof. +move=> phi; apply/cfun_inP=> y Ry; pose injGR := isom_inj isoGR. +rewrite -{1}[y](invmK injGR) ?(isom_im isoGR) //. +suffices /morphpreP[fGy Gf'y]: y \in invm injGR @*^-1 G by rewrite !cfIsomE. +by rewrite morphpre_invm (isom_im isoGR). +Qed. + +Lemma cfIsom_inj : injective (cfIsom isoGR). Proof. exact: can_inj cfIsomK. Qed. + +Lemma cfIsom_eq1 phi : (cfIsom isoGR phi == 1) = (phi == 1). +Proof. by apply: rmorph_eq1; apply: cfIsom_inj. Qed. + +Lemma cforder_isom phi : #[cfIsom isoGR phi]%CF = #[phi]%CF. +Proof. exact: cforder_inj_rmorph cfIsom_inj. Qed. + +End InvMorphism. + +Implicit Arguments cfIsom_inj [aT rT G R f x1 x2]. + +Section Coset. + +Variables (gT : finGroupType) (G : {group gT}) (B : {set gT}). +Implicit Type rT : finGroupType. +Local Notation H := <>%g. + +Definition cfMod : 'CF(G / B) -> 'CF(G) := cfMorph. + +Definition ffun_Quo (phi : 'CF(G)) := + [ffun Hx : coset_of B => + phi (if B \subset cfker phi then repr Hx else 1%g) *+ (Hx \in G / B)%g]. +Fact cfQuo_subproof phi : is_class_fun <> (ffun_Quo phi). +Proof. +rewrite genGid; apply: intro_class_fun => [|Hx /negPf-> //]. +move=> _ _ /morphimP[x Nx Gx ->] /morphimP[z Nz Gz ->]. +rewrite -morphJ ?mem_morphim ?val_coset_prim ?groupJ //= -gen_subG. +case: subsetP => // KphiH; do 2!case: repr_rcosetP => _ /KphiH/cfkerMl->. +by rewrite cfunJ. +Qed. +Definition cfQuo phi := Cfun 1 (cfQuo_subproof phi). + +Local Notation "phi / 'B'" := (cfQuo phi) (at level 40) : cfun_scope. +Local Notation "phi %% 'B'" := (cfMod phi) (at level 40) : cfun_scope. + +(* We specialize the cfMorph lemmas to cfMod by strengthening the domain *) +(* condition G \subset 'N(H) to H <| G; the cfMorph lemmas can be used if the *) +(* stronger results are needed. *) + +Lemma cfModE phi x : B <| G -> x \in G -> (phi %% B)%CF x = phi (coset B x). +Proof. by move/normal_norm=> nBG; exact: cfMorphE. Qed. + +Lemma cfMod1 phi : (phi %% B)%CF 1%g = phi 1%g. Proof. exact: cfMorph1. Qed. + +Canonical cfMod_additive := [additive of cfMod]. +Canonical cfMod_rmorphism := [rmorphism of cfMod]. +Canonical cfMod_linear := [linear of cfMod]. +Canonical cfMod_lrmorphism := [lrmorphism of cfMod]. + +Lemma cfMod_cfun1 : (1 %% B)%CF = 1. Proof. exact: rmorph1. Qed. + +Lemma cfker_mod phi : B <| G -> B \subset cfker (phi %% B). +Proof. +case/andP=> sBG nBG; rewrite cfker_morph // subsetI sBG. +apply: subset_trans _ (ker_sub_pre _ _); rewrite ker_coset_prim subsetI. +by rewrite (subset_trans sBG nBG) sub_gen. +Qed. + +(* Note that cfQuo is nondegenerate even when G does not normalize B. *) + +Lemma cfQuoEnorm (phi : 'CF(G)) x : + B \subset cfker phi -> x \in 'N_G(B) -> (phi / B)%CF (coset B x) = phi x. +Proof. +rewrite cfunElock -gen_subG => sHK /setIP[Gx nHx]; rewrite sHK /=. +rewrite mem_morphim // val_coset_prim //. +by case: repr_rcosetP => _ /(subsetP sHK)/cfkerMl->. +Qed. + +Lemma cfQuoE (phi : 'CF(G)) x : + B <| G -> B \subset cfker phi -> x \in G -> (phi / B)%CF (coset B x) = phi x. +Proof. by case/andP=> _ nBG sBK Gx; rewrite cfQuoEnorm // (setIidPl _). Qed. + +Lemma cfQuo1 (phi : 'CF(G)) : (phi / B)%CF 1%g = phi 1%g. +Proof. by rewrite cfunElock repr_coset1 group1 if_same. Qed. + +Lemma cfQuoEout (phi : 'CF(G)) : + ~~ (B \subset cfker phi) -> (phi / B)%CF = (phi 1%g)%:A. +Proof. +move/negPf=> not_kerB; apply/cfunP=> x; rewrite cfunE cfun1E mulr_natr. +by rewrite cfunElock not_kerB. +Qed. + +(* cfQuo is only linear on the class functions that have H in their kernel. *) + +Lemma cfQuo_cfun1 : (1 / B)%CF = 1. +Proof. +apply/cfun_inP=> Hx G_Hx; rewrite cfunElock !cfun1E G_Hx cfker_cfun1 -gen_subG. +have [x nHx Gx ->] := morphimP G_Hx. +case: subsetP=> [sHG | _]; last by rewrite group1. +by rewrite val_coset_prim //; case: repr_rcosetP => y /sHG/groupM->. +Qed. + +(* Cancellation properties *) + +Lemma cfModK : B <| G -> cancel cfMod cfQuo. +Proof. +move=> nsBG phi; apply/cfun_inP=> _ /morphimP[x Nx Gx ->] //. +by rewrite cfQuoE ?cfker_mod ?cfModE. +Qed. + +Lemma cfQuoK : + B <| G -> forall phi, B \subset cfker phi -> (phi / B %% B)%CF = phi. +Proof. +by move=> nsHG phi sHK; apply/cfun_inP=> x Gx; rewrite cfModE ?cfQuoE. +Qed. + +Lemma cfMod_eq1 psi : B <| G -> (psi %% B == 1)%CF = (psi == 1). +Proof. by move/cfModK/can_eq <-; rewrite rmorph1. Qed. + +Lemma cfQuo_eq1 phi : + B <| G -> B \subset cfker phi -> (phi / B == 1)%CF = (phi == 1). +Proof. by move=> nsBG kerH; rewrite -cfMod_eq1 // cfQuoK. Qed. + +End Coset. + +Arguments Scope cfQuo [_ Group_scope group_scope cfun_scope]. +Arguments Scope cfMod [_ Group_scope group_scope cfun_scope]. +Prenex Implicits cfMod. +Notation "phi / H" := (cfQuo H phi) : cfun_scope. +Notation "phi %% H" := (@cfMod _ _ H phi) : cfun_scope. + +Section MoreCoset. + +Variables (gT : finGroupType) (G : {group gT}). +Implicit Types (H K : {group gT}) (phi : 'CF(G)). + +Lemma cfResMod H K (psi : 'CF(G / K)) : + H \subset G -> K <| G -> ('Res (psi %% K) = 'Res[H / K] psi %% K)%CF. +Proof. by move=> sHG /andP[_]; apply: cfResMorph. Qed. + +Lemma quotient_cfker_mod (A : {set gT}) K (psi : 'CF(G / K)) : + K <| G -> (cfker (psi %% K) / K)%g = cfker psi. +Proof. by case/andP=> _ /cfker_morph_im <-. Qed. + +Lemma sub_cfker_mod (A : {set gT}) K (psi : 'CF(G / K)) : + K <| G -> A \subset 'N(K) -> + (A \subset cfker (psi %% K)) = (A / K \subset cfker psi)%g. +Proof. +by move=> nsKG nKA; rewrite -(quotientSGK nKA) ?quotient_cfker_mod ?cfker_mod. +Qed. + +Lemma cfker_quo H phi : + H <| G -> H \subset cfker (phi) -> cfker (phi / H) = (cfker phi / H)%g. +Proof. +move=> nsHG /cfQuoK {2}<- //; have [sHG nHG] := andP nsHG. +by rewrite cfker_morph 1?quotientGI // cosetpreK (setIidPr _) ?cfker_sub. +Qed. + +Lemma cfQuoEker phi x : + x \in G -> (phi / cfker phi)%CF (coset (cfker phi) x) = phi x. +Proof. by move/cfQuoE->; rewrite ?cfker_normal. Qed. + +Lemma cfaithful_quo phi : cfaithful (phi / cfker phi). +Proof. by rewrite cfaithfulE cfker_quo ?cfker_normal ?trivg_quotient. Qed. + +(* Note that there is no requirement that K be normal in H or G. *) +Lemma cfResQuo H K phi : + K \subset cfker phi -> K \subset H -> H \subset G -> + ('Res[H / K] (phi / K) = 'Res[H] phi / K)%CF. +Proof. +move=> kerK sKH sHG; apply/cfun_inP=> xb Hxb; rewrite cfResE ?quotientS //. +have{xb Hxb} [x nKx Hx ->] := morphimP Hxb. +by rewrite !cfQuoEnorm ?cfResE ?sub_cfker_Res // inE ?Hx ?(subsetP sHG). +Qed. + +Lemma cfQuoInorm K phi : + K \subset cfker phi -> (phi / K)%CF = 'Res ('Res['N_G(K)] phi / K)%CF. +Proof. +move=> kerK; rewrite -cfResQuo ?subsetIl ?quotientInorm ?cfRes_id //. +by rewrite subsetI normG (subset_trans kerK) ?cfker_sub. +Qed. + +Lemma cforder_mod H (psi : 'CF(G / H)) : H <| G -> #[psi %% H]%CF = #[psi]%CF. +Proof. by move/cfModK/can_inj/cforder_inj_rmorph->. Qed. + +Lemma cforder_quo H phi : + H <| G -> H \subset cfker phi -> #[phi / H]%CF = #[phi]%CF. +Proof. by move=> nsHG kerHphi; rewrite -cforder_mod ?cfQuoK. Qed. + +End MoreCoset. + +Section Product. + +Variable (gT : finGroupType) (G : {group gT}). + +Lemma cfunM_onI A B phi psi : + phi \in 'CF(G, A) -> psi \in 'CF(G, B) -> phi * psi \in 'CF(G, A :&: B). +Proof. +rewrite !cfun_onE => Aphi Bpsi; apply/subsetP=> x; rewrite !inE cfunE mulf_eq0. +by case/norP=> /(subsetP Aphi)-> /(subsetP Bpsi). +Qed. + +Lemma cfunM_on A phi psi : + phi \in 'CF(G, A) -> psi \in 'CF(G, A) -> phi * psi \in 'CF(G, A). +Proof. by move=> Aphi Bpsi; rewrite -[A]setIid cfunM_onI. Qed. + +End Product. + +Section SDproduct. + +Variables (gT : finGroupType) (G K H : {group gT}). +Hypothesis defG : K ><| H = G. + +Fact cfSdprodKey : unit. Proof. by []. Qed. + +Definition cfSdprod := + locked_with cfSdprodKey + (cfMorph \o cfIsom (tagged (sdprod_isom defG)) : 'CF(H) -> 'CF(G)). +Canonical cfSdprod_unlockable := [unlockable of cfSdprod]. + +Canonical cfSdprod_additive := [additive of cfSdprod]. +Canonical cfSdprod_linear := [linear of cfSdprod]. +Canonical cfSdprod_rmorphism := [rmorphism of cfSdprod]. +Canonical cfSdprod_lrmorphism := [lrmorphism of cfSdprod]. + +Lemma cfSdprod1 phi : cfSdprod phi 1%g = phi 1%g. +Proof. by rewrite unlock /= cfMorph1 cfIsom1. Qed. + +Let nsKG : K <| G. Proof. by have [] := sdprod_context defG. Qed. +Let sHG : H \subset G. Proof. by have [] := sdprod_context defG. Qed. +Let sKG : K \subset G. Proof. by have [] := andP nsKG. Qed. + +Lemma cfker_sdprod phi : K \subset cfker (cfSdprod phi). +Proof. by rewrite unlock_with cfker_mod. Qed. + +Lemma cfSdprodEr phi : {in H, cfSdprod phi =1 phi}. +Proof. by move=> y Hy; rewrite unlock cfModE ?cfIsomE ?(subsetP sHG). Qed. + +Lemma cfSdprodE phi : {in K & H, forall x y, cfSdprod phi (x * y)%g = phi y}. +Proof. +by move=> x y Kx Hy; rewrite /= cfkerMl ?(subsetP (cfker_sdprod _)) ?cfSdprodEr. +Qed. + +Lemma cfSdprodK : cancel cfSdprod 'Res[H]. +Proof. by move=> phi; apply/cfun_inP=> x Hx; rewrite cfResE ?cfSdprodEr. Qed. + +Lemma cfSdprod_inj : injective cfSdprod. Proof. exact: can_inj cfSdprodK. Qed. + +Lemma cfSdprod_eq1 phi : (cfSdprod phi == 1) = (phi == 1). +Proof. exact: rmorph_eq1 cfSdprod_inj. Qed. + +Lemma cfRes_sdprodK phi : K \subset cfker phi -> cfSdprod ('Res[H] phi) = phi. +Proof. +move=> kerK; apply/cfun_inP=> _ /(mem_sdprod defG)[x [y [Kx Hy -> _]]]. +by rewrite cfSdprodE // cfResE // cfkerMl ?(subsetP kerK). +Qed. + +Lemma sdprod_cfker phi : K ><| cfker phi = cfker (cfSdprod phi). +Proof. +have [skerH [_ _ nKH tiKH]] := (cfker_sub phi, sdprodP defG). +rewrite unlock cfker_morph ?normal_norm // cfker_isom restrmEsub //=. +rewrite -(sdprod_modl defG) ?sub_cosetpre //=; congr (_ ><| _). +by rewrite quotientK ?(subset_trans skerH) // -group_modr //= setIC tiKH mul1g. +Qed. + +Lemma cforder_sdprod phi : #[cfSdprod phi]%CF = #[phi]%CF. +Proof. by apply: cforder_inj_rmorph cfSdprod_inj. Qed. + +End SDproduct. + +Section DProduct. + +Variables (gT : finGroupType) (G K H : {group gT}). +Hypothesis KxH : K \x H = G. + +Lemma reindex_dprod R idx (op : Monoid.com_law idx) (F : gT -> R) : + \big[op/idx]_(g in G) F g = + \big[op/idx]_(k in K) \big[op/idx]_(h in H) F (k * h)%g. +Proof. +have /mulgmP/misomP[fM /isomP[injf im_f]] := KxH. +rewrite pair_big_dep -im_f morphimEdom big_imset; last exact/injmP. +by apply: eq_big => [][x y]; rewrite ?inE. +Qed. + +Definition cfDprodr := cfSdprod (dprodWsd KxH). +Definition cfDprodl := cfSdprod (dprodWsdC KxH). +Definition cfDprod phi psi := cfDprodl phi * cfDprodr psi. + +Canonical cfDprodl_additive := [additive of cfDprodl]. +Canonical cfDprodl_linear := [linear of cfDprodl]. +Canonical cfDprodl_rmorphism := [rmorphism of cfDprodl]. +Canonical cfDprodl_lrmorphism := [lrmorphism of cfDprodl]. +Canonical cfDprodr_additive := [additive of cfDprodr]. +Canonical cfDprodr_linear := [linear of cfDprodr]. +Canonical cfDprodr_rmorphism := [rmorphism of cfDprodr]. +Canonical cfDprodr_lrmorphism := [lrmorphism of cfDprodr]. + +Lemma cfDprodl1 phi : cfDprodl phi 1%g = phi 1%g. Proof. exact: cfSdprod1. Qed. +Lemma cfDprodr1 psi : cfDprodr psi 1%g = psi 1%g. Proof. exact: cfSdprod1. Qed. +Lemma cfDprod1 phi psi : cfDprod phi psi 1%g = phi 1%g * psi 1%g. +Proof. by rewrite cfunE /= !cfSdprod1. Qed. + +Lemma cfDprodl_eq1 phi : (cfDprodl phi == 1) = (phi == 1). +Proof. exact: cfSdprod_eq1. Qed. +Lemma cfDprodr_eq1 psi : (cfDprodr psi == 1) = (psi == 1). +Proof. exact: cfSdprod_eq1. Qed. + +Lemma cfDprod_cfun1r phi : cfDprod phi 1 = cfDprodl phi. +Proof. by rewrite /cfDprod rmorph1 mulr1. Qed. +Lemma cfDprod_cfun1l psi : cfDprod 1 psi = cfDprodr psi. +Proof. by rewrite /cfDprod rmorph1 mul1r. Qed. +Lemma cfDprod_cfun1 : cfDprod 1 1 = 1. +Proof. by rewrite cfDprod_cfun1l rmorph1. Qed. +Lemma cfDprod_split phi psi : cfDprod phi psi = cfDprod phi 1 * cfDprod 1 psi. +Proof. by rewrite cfDprod_cfun1l cfDprod_cfun1r. Qed. + +Let nsKG : K <| G. Proof. by have [] := dprod_normal2 KxH. Qed. +Let nsHG : H <| G. Proof. by have [] := dprod_normal2 KxH. Qed. +Let cKH : H \subset 'C(K). Proof. by have [] := dprodP KxH. Qed. +Let sKG := normal_sub nsKG. +Let sHG := normal_sub nsHG. + +Lemma cfDprodlK : cancel cfDprodl 'Res[K]. Proof. exact: cfSdprodK. Qed. +Lemma cfDprodrK : cancel cfDprodr 'Res[H]. Proof. exact: cfSdprodK. Qed. + +Lemma cfker_dprodl phi : cfker phi \x H = cfker (cfDprodl phi). +Proof. +by rewrite dprodC -sdprod_cfker dprodEsd // centsC (centsS (cfker_sub _)). +Qed. + +Lemma cfker_dprodr psi : K \x cfker psi = cfker (cfDprodr psi). +Proof. by rewrite -sdprod_cfker dprodEsd // (subset_trans (cfker_sub _)). Qed. + +Lemma cfDprodEl phi : {in K & H, forall k h, cfDprodl phi (k * h)%g = phi k}. +Proof. by move=> k h Kk Hh /=; rewrite -(centsP cKH) // cfSdprodE. Qed. + +Lemma cfDprodEr psi : {in K & H, forall k h, cfDprodr psi (k * h)%g = psi h}. +Proof. exact: cfSdprodE. Qed. + +Lemma cfDprodE phi psi : + {in K & H, forall h k, cfDprod phi psi (h * k)%g = phi h * psi k}. +Proof. by move=> k h Kk Hh /=; rewrite cfunE cfDprodEl ?cfDprodEr. Qed. + +Lemma cfDprod_Resl phi psi : 'Res[K] (cfDprod phi psi) = psi 1%g *: phi. +Proof. +by apply/cfun_inP=> x Kx; rewrite cfunE cfResE // -{1}[x]mulg1 mulrC cfDprodE. +Qed. + +Lemma cfDprod_Resr phi psi : 'Res[H] (cfDprod phi psi) = phi 1%g *: psi. +Proof. +by apply/cfun_inP=> y Hy; rewrite cfunE cfResE // -{1}[y]mul1g cfDprodE. +Qed. + +Lemma cfDprodKl (psi : 'CF(H)) : psi 1%g = 1 -> cancel (cfDprod^~ psi) 'Res. +Proof. by move=> psi1 phi; rewrite cfDprod_Resl psi1 scale1r. Qed. + +Lemma cfDprodKr (phi : 'CF(K)) : phi 1%g = 1 -> cancel (cfDprod phi) 'Res. +Proof. by move=> phi1 psi; rewrite cfDprod_Resr phi1 scale1r. Qed. + +(* Note that equality holds here iff either cfker phi = K and cfker psi = H, *) +(* or else phi != 0, psi != 0 and coprime #|K : cfker phi| #|H : cfker phi|. *) +Lemma cfker_dprod phi psi : + cfker phi <*> cfker psi \subset cfker (cfDprod phi psi). +Proof. +rewrite -genM_join gen_subG; apply/subsetP=> _ /mulsgP[x y kKx kHy ->] /=. +have [[Kx _] [Hy _]] := (setIdP kKx, setIdP kHy). +have Gxy: (x * y)%g \in G by rewrite -(dprodW KxH) mem_mulg. +rewrite inE Gxy; apply/forallP=> g. +have [Gg | G'g] := boolP (g \in G); last by rewrite !cfun0 1?groupMl. +have{g Gg} [k [h [Kk Hh -> _]]] := mem_dprod KxH Gg. +rewrite mulgA -(mulgA x) (centsP cKH y) // mulgA -mulgA !cfDprodE ?groupM //. +by rewrite !cfkerMl. +Qed. + +Lemma cfdot_dprod phi1 phi2 psi1 psi2 : + '[cfDprod phi1 psi1, cfDprod phi2 psi2] = '[phi1, phi2] * '[psi1, psi2]. +Proof. +rewrite !cfdotE mulrCA -mulrA mulrCA mulrA -invfM -natrM (dprod_card KxH). +congr (_ * _); rewrite big_distrl reindex_dprod /=; apply: eq_bigr => k Kk. +rewrite big_distrr; apply: eq_bigr => h Hh /=. +by rewrite mulrCA -mulrA -rmorphM mulrCA mulrA !cfDprodE. +Qed. + +Lemma cfDprodl_iso : isometry cfDprodl. +Proof. +by move=> phi1 phi2; rewrite -!cfDprod_cfun1r cfdot_dprod cfnorm1 mulr1. +Qed. + +Lemma cfDprodr_iso : isometry cfDprodr. +Proof. +by move=> psi1 psi2; rewrite -!cfDprod_cfun1l cfdot_dprod cfnorm1 mul1r. +Qed. + +Lemma cforder_dprodl phi : #[cfDprodl phi]%CF = #[phi]%CF. +Proof. exact: cforder_sdprod. Qed. + +Lemma cforder_dprodr psi : #[cfDprodr psi]%CF = #[psi]%CF. +Proof. exact: cforder_sdprod. Qed. + +End DProduct. + +Lemma cfDprodC (gT : finGroupType) (G K H : {group gT}) + (KxH : K \x H = G) (HxK : H \x K = G) chi psi : + cfDprod KxH chi psi = cfDprod HxK psi chi. +Proof. +rewrite /cfDprod mulrC. +by congr (_ * _); congr (cfSdprod _ _); apply: eq_irrelevance. +Qed. + +Section Bigdproduct. + +Variables (gT : finGroupType) (I : finType) (P : pred I). +Variables (A : I -> {group gT}) (G : {group gT}). +Hypothesis defG : \big[dprod/1%g]_(i | P i) A i = G. + +Let sAG i : P i -> A i \subset G. +Proof. by move=> Pi; rewrite -(bigdprodWY defG) (bigD1 i) ?joing_subl. Qed. + +Fact cfBigdprodi_subproof i : + gval (if P i then A i else 1%G) \x <<\bigcup_(j | P j && (j != i)) A j>> = G. +Proof. +have:= defG; rewrite fun_if big_mkcond (bigD1 i) // -big_mkcondl /= => defGi. +by have [[_ Gi' _ defGi']] := dprodP defGi; rewrite (bigdprodWY defGi') -defGi'. +Qed. +Definition cfBigdprodi i := cfDprodl (cfBigdprodi_subproof i) \o 'Res[_, A i]. + +Canonical cfBigdprodi_additive i := [additive of @cfBigdprodi i]. +Canonical cfBigdprodi_linear i := [linear of @cfBigdprodi i]. +Canonical cfBigdprodi_rmorphism i := [rmorphism of @cfBigdprodi i]. +Canonical cfBigdprodi_lrmorphism i := [lrmorphism of @cfBigdprodi i]. + +Lemma cfBigdprodi1 i (phi : 'CF(A i)) : cfBigdprodi phi 1%g = phi 1%g. +Proof. by rewrite cfDprodl1 cfRes1. Qed. + +Lemma cfBigdprodi_eq1 i (phi : 'CF(A i)) : + P i -> (cfBigdprodi phi == 1) = (phi == 1). +Proof. by move=> Pi; rewrite cfSdprod_eq1 Pi cfRes_id. Qed. + +Lemma cfBigdprodiK i : P i -> cancel (@cfBigdprodi i) 'Res[A i]. +Proof. +move=> Pi phi; have:= cfDprodlK (cfBigdprodi_subproof i) ('Res phi). +by rewrite -[cfDprodl _ _]/(cfBigdprodi phi) Pi cfRes_id. +Qed. + +Lemma cfBigdprodi_inj i : P i -> injective (@cfBigdprodi i). +Proof. by move/cfBigdprodiK; apply: can_inj. Qed. + +Lemma cfBigdprodEi i (phi : 'CF(A i)) x : + P i -> (forall j, P j -> x j \in A j) -> + cfBigdprodi phi (\prod_(j | P j) x j)%g = phi (x i). +Proof. +set r := enum P => Pi /forall_inP; have r_i: i \in r by rewrite mem_enum. +have:= bigdprodWcp defG; rewrite -big_andE -!(big_filter _ P) filter_index_enum. +rewrite -/r big_all => defGr /allP Ax. +rewrite (perm_bigcprod defGr Ax (perm_to_rem r_i)) big_cons cfDprodEl ?Pi //. +- by rewrite cfRes_id. +- by rewrite Ax. +rewrite big_seq group_prod // => j; rewrite mem_rem_uniq ?enum_uniq //. +case/andP=> i'j /= r_j; apply/mem_gen/bigcupP; exists j; last exact: Ax. +by rewrite -[P j](mem_enum P) r_j. +Qed. + +Lemma cfBigdprodi_iso i : P i -> isometry (@cfBigdprodi i). +Proof. by move=> Pi phi psi; rewrite cfDprodl_iso Pi !cfRes_id. Qed. + +Definition cfBigdprod (phi : forall i, 'CF(A i)) := + \prod_(i | P i) cfBigdprodi (phi i). + +Lemma cfBigdprodE phi x : + (forall i, P i -> x i \in A i) -> + cfBigdprod phi (\prod_(i | P i) x i)%g = \prod_(i | P i) phi i (x i). +Proof. +move=> Ax; rewrite prod_cfunE; last by rewrite -(bigdprodW defG) mem_prodg. +by apply: eq_bigr => i Pi; rewrite cfBigdprodEi. +Qed. + +Lemma cfBigdprod1 phi : cfBigdprod phi 1%g = \prod_(i | P i) phi i 1%g. +Proof. by rewrite prod_cfunE //; apply/eq_bigr=> i _; apply: cfBigdprodi1. Qed. + +Lemma cfBigdprodK phi (Phi := cfBigdprod phi) i (a := phi i 1%g / Phi 1%g) : + Phi 1%g != 0 -> P i -> a != 0 /\ a *: 'Res[A i] Phi = phi i. +Proof. +move=> nzPhi Pi; split. + rewrite mulf_neq0 ?invr_eq0 // (contraNneq _ nzPhi) // => phi_i0. + by rewrite cfBigdprod1 (bigD1 i) //= phi_i0 mul0r. +apply/cfun_inP=> x Aix; rewrite cfunE cfResE ?sAG // mulrAC. +have {1}->: x = (\prod_(j | P j) (if j == i then x else 1))%g. + rewrite -big_mkcondr (big_pred1 i) ?eqxx // => j /=. + by apply: andb_idl => /eqP->. +rewrite cfBigdprodE => [|j _]; last by case: eqP => // ->. +apply: canLR (mulfK nzPhi) _; rewrite cfBigdprod1 !(bigD1 i Pi) /= eqxx. +by rewrite mulrCA !mulrA; congr (_ * _); apply: eq_bigr => j /andP[_ /negPf->]. +Qed. + +Lemma cfdot_bigdprod phi psi : + '[cfBigdprod phi, cfBigdprod psi] = \prod_(i | P i) '[phi i, psi i]. +Proof. +apply: canLR (mulKf (neq0CG G)) _; rewrite -(bigdprod_card defG). +rewrite (big_morph _ (@natrM _) (erefl _)) -big_split /=. +rewrite (eq_bigr _ (fun i _ => mulVKf (neq0CG _) _)) (big_distr_big_dep 1%g) /=. +set F := pfamily _ _ _; pose h (f : {ffun I -> gT}) := (\prod_(i | P i) f i)%g. +pose is_hK x f := forall f1, (f1 \in F) && (h f1 == x) = (f == f1). +have /fin_all_exists[h1 Dh1] x: exists f, x \in G -> is_hK x f. + case Gx: (x \in G); last by exists [ffun _ => x]. + have [f [Af fK Uf]] := mem_bigdprod defG Gx. + exists [ffun i => if P i then f i else 1%g] => _ f1. + apply/andP/eqP=> [[/pfamilyP[Pf1 Af1] /eqP Dx] | <-]. + by apply/ffunP=> i; rewrite ffunE; case: ifPn => [/Uf-> | /(supportP Pf1)]. + split; last by rewrite fK; apply/eqP/eq_bigr=> i Pi; rewrite ffunE Pi. + by apply/familyP=> i; rewrite ffunE !unfold_in; case: ifP => //= /Af. +rewrite (reindex_onto h h1) /= => [|x /Dh1/(_ (h1 x))]; last first. + by rewrite eqxx => /andP[_ /eqP]. +apply/eq_big => [f | f /andP[/Dh1<- /andP[/pfamilyP[_ Af] _]]]; last first. + by rewrite !cfBigdprodE // rmorph_prod -big_split /=. +apply/idP/idP=> [/andP[/Dh1<-] | Ff]; first by rewrite eqxx andbT. +have /pfamilyP[_ Af] := Ff; suffices Ghf: h f \in G by rewrite -Dh1 ?Ghf ?Ff /=. +by apply/group_prod=> i Pi; rewrite (subsetP (sAG Pi)) ?Af. +Qed. + +End Bigdproduct. + +Section MorphIsometry. + +Variable gT : finGroupType. +Implicit Types (D G H K : {group gT}) (aT rT : finGroupType). + +Lemma cfMorph_iso aT rT (G D : {group aT}) (f : {morphism D >-> rT}) : + G \subset D -> isometry (cfMorph : 'CF(f @* G) -> 'CF(G)). +Proof. +move=> sGD phi psi; rewrite !cfdotE card_morphim (setIidPr sGD). +rewrite -(LagrangeI G ('ker f)) /= mulnC natrM invfM -mulrA. +congr (_ * _); apply: (canLR (mulKf (neq0CG _))). +rewrite mulr_sumr (partition_big_imset f) /= -morphimEsub //. +apply: eq_bigr => _ /morphimP[x Dx Gx ->]. +rewrite -(card_rcoset _ x) mulr_natl -sumr_const. +apply/eq_big => [y | y /andP[Gy /eqP <-]]; last by rewrite !cfMorphE. +rewrite mem_rcoset inE groupMr ?groupV // -mem_rcoset. +by apply: andb_id2l => /(subsetP sGD) Dy; exact: sameP eqP (rcoset_kerP f _ _). +Qed. + +Lemma cfIsom_iso rT G (R : {group rT}) (f : {morphism G >-> rT}) : + forall isoG : isom G R f, isometry (cfIsom isoG). +Proof. +move=> isoG phi psi; rewrite unlock cfMorph_iso //; set G1 := _ @* R. +by rewrite -(isom_im (isom_sym isoG)) -/G1 in phi psi *; rewrite !cfRes_id. +Qed. + +Lemma cfMod_iso H G : H <| G -> isometry (@cfMod _ G H). +Proof. by case/andP=> _; apply: cfMorph_iso. Qed. + +Lemma cfQuo_iso H G : + H <| G -> {in [pred phi | H \subset cfker phi] &, isometry (@cfQuo _ G H)}. +Proof. +by move=> nsHG phi psi sHkphi sHkpsi; rewrite -(cfMod_iso nsHG) !cfQuoK. +Qed. + +Lemma cfnorm_quo H G phi : + H <| G -> H \subset cfker phi -> '[phi / H] = '[phi]_G. +Proof. by move=> nsHG sHker; apply: cfQuo_iso. Qed. + +Lemma cfSdprod_iso K H G (defG : K ><| H = G) : isometry (cfSdprod defG). +Proof. +move=> phi psi; have [/andP[_ nKG] _ _ _ _] := sdprod_context defG. +by rewrite [cfSdprod _]locked_withE cfMorph_iso ?cfIsom_iso. +Qed. + +End MorphIsometry. + +Section Induced. + +Variable gT : finGroupType. + +Section Def. + +Variables B A : {set gT}. +Local Notation G := <>. +Local Notation H := <>. + +(* The defalut value for the ~~ (H \subset G) case matches the one for cfRes *) +(* so that Frobenius reciprocity holds even in this degenerate case. *) +Definition ffun_cfInd (phi : 'CF(A)) := + [ffun x => if H \subset G then #|A|%:R^-1 * (\sum_(y in G) phi (x ^ y)) + else #|G|%:R * '[phi, 1] *+ (x == 1%g)]. + +Fact cfInd_subproof phi : is_class_fun G (ffun_cfInd phi). +Proof. +apply: intro_class_fun => [x y Gx Gy | x H'x]; last first. + case: subsetP => [sHG | _]; last by rewrite (negPf (group1_contra H'x)). + rewrite big1 ?mulr0 // => y Gy; rewrite cfun0gen ?(contra _ H'x) //= => /sHG. + by rewrite memJ_norm ?(subsetP (normG _)). +rewrite conjg_eq1 (reindex_inj (mulgI y^-1)%g); congr (if _ then _ * _ else _). +by apply: eq_big => [z | z Gz]; rewrite ?groupMl ?groupV // -conjgM mulKVg. +Qed. +Definition cfInd phi := Cfun 1 (cfInd_subproof phi). + +Lemma cfInd_is_linear : linear cfInd. +Proof. +move=> c phi psi; apply/cfunP=> x; rewrite !cfunElock; case: ifP => _. + rewrite mulrCA -mulrDr [c * _]mulr_sumr -big_split /=. + by congr (_ * _); apply: eq_bigr => y _; rewrite !cfunE. +rewrite mulrnAr -mulrnDl !(mulrCA c) -!mulrDr [c * _]mulr_sumr -big_split /=. +by congr (_ * (_ * _) *+ _); apply: eq_bigr => y; rewrite !cfunE mulrA mulrDl. +Qed. +Canonical cfInd_additive := Additive cfInd_is_linear. +Canonical cfInd_linear := Linear cfInd_is_linear. + +End Def. + +Local Notation "''Ind[' B , A ]" := (@cfInd B A) : ring_scope. +Local Notation "''Ind[' B ]" := 'Ind[B, _] : ring_scope. + +Lemma cfIndE (G H : {group gT}) phi x : + H \subset G -> 'Ind[G, H] phi x = #|H|%:R^-1 * (\sum_(y in G) phi (x ^ y)). +Proof. by rewrite cfunElock !genGid => ->. Qed. + +Variables G K H : {group gT}. +Implicit Types (phi : 'CF(H)) (psi : 'CF(G)). + +Lemma cfIndEout phi : + ~~ (H \subset G) -> 'Ind[G] phi = (#|G|%:R * '[phi, 1]) *: '1_1%G. +Proof. +move/negPf=> not_sHG; apply/cfunP=> x; rewrite cfunE cfuniE ?normal1 // inE. +by rewrite mulr_natr cfunElock !genGid not_sHG. +Qed. + +Lemma cfIndEsdprod (phi : 'CF(K)) x : + K ><| H = G -> 'Ind[G] phi x = \sum_(w in H) phi (x ^ w)%g. +Proof. +move=> defG; have [/andP[sKG _] _ mulKH nKH _] := sdprod_context defG. +rewrite cfIndE //; apply: canLR (mulKf (neq0CG _)) _; rewrite -mulKH mulr_sumr. +rewrite (set_partition_big _ (rcosets_partition_mul H K)) ?big_imset /=. + apply: eq_bigr => y Hy; rewrite rcosetE norm_rlcoset ?(subsetP nKH) //. + rewrite -lcosetE mulr_natl big_imset /=; last exact: in2W (mulgI _). + by rewrite -sumr_const; apply: eq_bigr => z Kz; rewrite conjgM cfunJ. +have [{nKH}nKH /isomP[injf _]] := sdprod_isom defG. +apply: can_in_inj (fun Ky => invm injf (coset K (repr Ky))) _ => y Hy. +by rewrite rcosetE -val_coset ?(subsetP nKH) // coset_reprK invmE. +Qed. + +Lemma cfInd_on A phi : + H \subset G -> phi \in 'CF(H, A) -> 'Ind[G] phi \in 'CF(G, class_support A G). +Proof. +move=> sHG Af; apply/cfun_onP=> g AG'g; rewrite cfIndE ?big1 ?mulr0 // => h Gh. +apply: (cfun_on0 Af); apply: contra AG'g => Agh. +by rewrite -[g](conjgK h) memJ_class_support // groupV. +Qed. + +Lemma cfInd_id phi : 'Ind[H] phi = phi. +Proof. +apply/cfun_inP=> x Hx; rewrite cfIndE // (eq_bigr _ (cfunJ phi x)) sumr_const. +by rewrite -[phi x *+ _]mulr_natl mulKf ?neq0CG. +Qed. + +Lemma cfInd_normal phi : H <| G -> 'Ind[G] phi \in 'CF(G, H). +Proof. +case/andP=> sHG nHG; apply: (cfun_onS (class_support_sub_norm (subxx _) nHG)). +by rewrite cfInd_on ?cfun_onG. +Qed. + +Lemma cfInd1 phi : H \subset G -> 'Ind[G] phi 1%g = #|G : H|%:R * phi 1%g. +Proof. +move=> sHG; rewrite cfIndE // natf_indexg // -mulrA mulrCA; congr (_ * _). +by rewrite mulr_natl -sumr_const; apply: eq_bigr => x; rewrite conj1g. +Qed. + +Lemma cfInd_cfun1 : H <| G -> 'Ind[G, H] 1 = #|G : H|%:R *: '1_H. +Proof. +move=> nsHG; have [sHG nHG] := andP nsHG; rewrite natf_indexg // mulrC. +apply/cfunP=> x; rewrite cfIndE ?cfunE ?cfuniE // -mulrA; congr (_ * _). +rewrite mulr_natl -sumr_const; apply: eq_bigr => y Gy. +by rewrite cfun1E -{1}(normsP nHG y Gy) memJ_conjg. +Qed. + +Lemma cfnorm_Ind_cfun1 : H <| G -> '['Ind[G, H] 1] = #|G : H|%:R. +Proof. +move=> nsHG; rewrite cfInd_cfun1 // cfnormZ normr_nat cfdot_cfuni // setIid. +by rewrite expr2 {2}natf_indexg ?normal_sub // !mulrA divfK ?mulfK ?neq0CG. +Qed. + +Lemma cfIndInd phi : + K \subset G -> H \subset K -> 'Ind[G] ('Ind[K] phi) = 'Ind[G] phi. +Proof. +move=> sKG sHK; apply/cfun_inP=> x Gx; rewrite !cfIndE ?(subset_trans sHK) //. +apply: canLR (mulKf (neq0CG K)) _; rewrite mulr_sumr mulr_natl. +transitivity (\sum_(y in G) \sum_(z in K) #|H|%:R^-1 * phi ((x ^ y) ^ z)). + by apply: eq_bigr => y Gy; rewrite cfIndE // -mulr_sumr. +symmetry; rewrite exchange_big /= -sumr_const; apply: eq_bigr => z Kz. +rewrite (reindex_inj (mulIg z)). +by apply: eq_big => [y | y _]; rewrite ?conjgM // groupMr // (subsetP sKG). +Qed. + +(* This is Isaacs, Lemma (5.2). *) +Lemma Frobenius_reciprocity phi psi : '[phi, 'Res[H] psi] = '['Ind[G] phi, psi]. +Proof. +have [sHG | not_sHG] := boolP (H \subset G); last first. + rewrite cfResEout // cfIndEout // cfdotZr cfdotZl mulrAC; congr (_ * _). + rewrite (cfdotEl _ (cfuni_on _ _)) mulVKf ?neq0CG // big_set1. + by rewrite cfuniE ?normal1 ?set11 ?mul1r. +transitivity (#|H|%:R^-1 * \sum_(x in G) phi x * (psi x)^*). + rewrite (big_setID H) /= (setIidPr sHG) addrC big1 ?add0r; last first. + by move=> x /setDP[_ /cfun0->]; rewrite mul0r. + by congr (_ * _); apply: eq_bigr => x Hx; rewrite cfResE. +set h' := _^-1; apply: canRL (mulKf (neq0CG G)) _. +transitivity (h' * \sum_(y in G) \sum_(x in G) phi (x ^ y) * (psi (x ^ y))^*). + rewrite mulrCA mulr_natl -sumr_const; congr (_ * _); apply: eq_bigr => y Gy. + by rewrite (reindex_acts 'J _ Gy) ?astabsJ ?normG. +rewrite exchange_big mulr_sumr; apply: eq_bigr => x _; rewrite cfIndE //=. +by rewrite -mulrA mulr_suml; congr (_ * _); apply: eq_bigr => y /(cfunJ psi)->. +Qed. +Definition cfdot_Res_r := Frobenius_reciprocity. + +Lemma cfdot_Res_l psi phi : '['Res[H] psi, phi] = '[psi, 'Ind[G] phi]. +Proof. by rewrite cfdotC cfdot_Res_r -cfdotC. Qed. + +Lemma cfIndM phi psi: H \subset G -> + 'Ind[G] (phi * ('Res[H] psi)) = 'Ind[G] phi * psi. +Proof. +move=> HsG; apply/cfun_inP=> x Gx; rewrite !cfIndE // !cfunE !cfIndE // -mulrA. +congr (_ * _); rewrite mulr_suml; apply: eq_bigr=> i iG; rewrite !cfunE. +case:(boolP (x^i \in H))=> xJi; last by rewrite cfun0gen ?mul0r ?genGid. +by rewrite !cfResE //; congr (_*_); rewrite cfunJgen ?genGid. +Qed. + +End Induced. + +Arguments Scope cfInd [_ group_scope group_scope cfun_scope]. +Notation "''Ind[' G , H ]" := (@cfInd _ G H) (only parsing) : ring_scope. +Notation "''Ind[' G ]" := 'Ind[G, _] : ring_scope. +Notation "''Ind'" := 'Ind[_] (only parsing) : ring_scope. + +Section MorphInduced. + +Variables (aT rT : finGroupType) (D G H : {group aT}) (R S : {group rT}). + +Lemma cfIndMorph (f : {morphism D >-> rT}) (phi : 'CF(f @* H)) : + 'ker f \subset H -> H \subset G -> G \subset D -> + 'Ind[G] (cfMorph phi) = cfMorph ('Ind[f @* G] phi). +Proof. +move=> sKH sHG sGD; have [sHD inD] := (subset_trans sHG sGD, subsetP sGD). +apply/cfun_inP=> /= x Gx; have [Dx sKG] := (inD x Gx, subset_trans sKH sHG). +rewrite cfMorphE ?cfIndE ?morphimS // (partition_big_imset f) -morphimEsub //=. +rewrite card_morphim (setIidPr sHD) natf_indexg // invfM invrK -mulrA. +congr (_ * _); rewrite mulr_sumr; apply: eq_bigr => _ /morphimP[y Dy Gy ->]. +rewrite -(card_rcoset _ y) mulr_natl -sumr_const. +apply: eq_big => [z | z /andP[Gz /eqP <-]]. + have [Gz | G'z] := boolP (z \in G). + by rewrite (sameP eqP (rcoset_kerP _ _ _)) ?inD. + by case: rcosetP G'z => // [[t Kt ->]]; rewrite groupM // (subsetP sKG). +have [Dz Dxz] := (inD z Gz, inD (x ^ z) (groupJ Gx Gz)); rewrite -morphJ //. +have [Hxz | notHxz] := boolP (x ^ z \in H); first by rewrite cfMorphE. +by rewrite !cfun0 // -sub1set -morphim_set1 // morphimSGK ?sub1set. +Qed. + +Variables (g : {morphism G >-> rT}) (h : {morphism H >-> rT}). +Hypotheses (isoG : isom G R g) (isoH : isom H S h) (eq_hg : {in H, h =1 g}). +Hypothesis sHG : H \subset G. + +Lemma cfResIsom phi : 'Res[S] (cfIsom isoG phi) = cfIsom isoH ('Res[H] phi). +Proof. +have [[injg defR] [injh defS]] := (isomP isoG, isomP isoH). +rewrite !morphimEdom in defS defR; apply/cfun_inP=> s. +rewrite -{1}defS => /imsetP[x Hx ->] {s}; have Gx := subsetP sHG x Hx. +rewrite {1}eq_hg ?(cfResE, cfIsomE) // -defS -?eq_hg ?mem_imset // -defR. +by rewrite (eq_in_imset eq_hg) imsetS. +Qed. + +Lemma cfIndIsom phi : 'Ind[R] (cfIsom isoH phi) = cfIsom isoG ('Ind[G] phi). +Proof. +have [[injg defR] [_ defS]] := (isomP isoG, isomP isoH). +rewrite morphimEdom (eq_in_imset eq_hg) -morphimEsub // in defS. +apply/cfun_inP=> s; rewrite -{1}defR => /morphimP[x _ Gx ->]{s}. +rewrite cfIsomE ?cfIndE // -defR -{1}defS ?morphimS ?card_injm // morphimEdom. +congr (_ * _); rewrite big_imset //=; last exact/injmP. +apply: eq_bigr => y Gy; rewrite -morphJ //. +have [Hxy | H'xy] := boolP (x ^ y \in H); first by rewrite -eq_hg ?cfIsomE. +by rewrite !cfun0 -?defS // -sub1set -morphim_set1 ?injmSK ?sub1set // groupJ. +Qed. + +End MorphInduced. + +Section FieldAutomorphism. + +Variables (u : {rmorphism algC -> algC}) (gT rT : finGroupType). +Variables (G K H : {group gT}) (f : {morphism G >-> rT}) (R : {group rT}). +Implicit Types (phi : 'CF(G)) (S : seq 'CF(G)). +Local Notation "phi ^u" := (cfAut u phi) (at level 3, format "phi ^u"). + +Lemma cfAutZ_nat n phi : (n%:R *: phi)^u = n%:R *: phi^u. +Proof. exact: raddfZnat. Qed. + +Lemma cfAutZ_Cnat z phi : z \in Cnat -> (z *: phi)^u = z *: phi^u. +Proof. exact: raddfZ_Cnat. Qed. + +Lemma cfAutZ_Cint z phi : z \in Cint -> (z *: phi)^u = z *: phi^u. +Proof. exact: raddfZ_Cint. Qed. + +Lemma cfAut_inj : injective (@cfAut gT G u). +Proof. +move=> phi psi /cfunP eqfg; apply/cfunP=> x. +by have := eqfg x; rewrite !cfunE => /fmorph_inj. +Qed. + +Lemma cfAut_eq1 phi : (cfAut u phi == 1) = (phi == 1). +Proof. by rewrite rmorph_eq1 //; apply: cfAut_inj. Qed. + +Lemma support_cfAut phi : support phi^u =i support phi. +Proof. by move=> x; rewrite !inE cfunE fmorph_eq0. Qed. + +Lemma map_cfAut_free S : cfAut_closed u S -> free S -> free (map (cfAut u) S). +Proof. +set Su := map _ S => sSuS freeS; have uniqS := free_uniq freeS. +have uniqSu: uniq Su by rewrite (map_inj_uniq cfAut_inj). +have{sSuS} sSuS: {subset Su <= S} by move=> _ /mapP[phi Sphi ->]; apply: sSuS. +have [|eqSuS _] := leq_size_perm uniqSu sSuS; first by rewrite size_map. +by rewrite (perm_free (uniq_perm_eq uniqSu uniqS eqSuS)). +Qed. + +Lemma cfAut_on A phi : (phi^u \in 'CF(G, A)) = (phi \in 'CF(G, A)). +Proof. by rewrite !cfun_onE (eq_subset (support_cfAut phi)). Qed. + +Lemma cfker_aut phi : cfker phi^u = cfker phi. +Proof. +apply/setP=> x; rewrite !inE; apply: andb_id2l => Gx. +by apply/forallP/forallP=> Kx y; + have:= Kx y; rewrite !cfunE (inj_eq (fmorph_inj u)). +Qed. + +Lemma cfAut_cfuni A : ('1_A)^u = '1_A :> 'CF(G). +Proof. by apply/cfunP=> x; rewrite !cfunElock rmorph_nat. Qed. + +Lemma cforder_aut phi : #[phi^u]%CF = #[phi]%CF. +Proof. exact: cforder_inj_rmorph cfAut_inj. Qed. + +Lemma cfAutRes phi : ('Res[H] phi)^u = 'Res phi^u. +Proof. by apply/cfunP=> x; rewrite !cfunElock rmorphMn. Qed. + +Lemma cfAutMorph (psi : 'CF(f @* H)) : (cfMorph psi)^u = cfMorph psi^u. +Proof. by apply/cfun_inP=> x Hx; rewrite !cfunElock Hx. Qed. + +Lemma cfAutIsom (isoGR : isom G R f) phi : + (cfIsom isoGR phi)^u = cfIsom isoGR phi^u. +Proof. +apply/cfun_inP=> y; have [_ {1}<-] := isomP isoGR => /morphimP[x _ Gx ->{y}]. +by rewrite !(cfunE, cfIsomE). +Qed. + +Lemma cfAutQuo phi : (phi / H)^u = (phi^u / H)%CF. +Proof. by apply/cfunP=> Hx; rewrite !cfunElock cfker_aut rmorphMn. Qed. + +Lemma cfAutMod (psi : 'CF(G / H)) : (psi %% H)^u = (psi^u %% H)%CF. +Proof. by apply/cfunP=> x; rewrite !cfunElock rmorphMn. Qed. + +Lemma cfAutInd (psi : 'CF(H)) : ('Ind[G] psi)^u = 'Ind psi^u. +Proof. +have [sHG | not_sHG] := boolP (H \subset G). + apply/cfunP=> x; rewrite !(cfunE, cfIndE) // rmorphM fmorphV rmorph_nat. + by congr (_ * _); rewrite rmorph_sum; apply: eq_bigr => y; rewrite !cfunE. +rewrite !cfIndEout // linearZ /= cfAut_cfuni rmorphM rmorph_nat. +rewrite -cfdot_cfAut ?rmorph1 // => _ /imageP[x Hx ->]. +by rewrite cfun1E Hx !rmorph1. +Qed. + +Hypothesis KxH : K \x H = G. + +Lemma cfAutDprodl (phi : 'CF(K)) : (cfDprodl KxH phi)^u = cfDprodl KxH phi^u. +Proof. +apply/cfun_inP=> _ /(mem_dprod KxH)[x [y [Kx Hy -> _]]]. +by rewrite !(cfunE, cfDprodEl). +Qed. + +Lemma cfAutDprodr (psi : 'CF(H)) : (cfDprodr KxH psi)^u = cfDprodr KxH psi^u. +Proof. +apply/cfun_inP=> _ /(mem_dprod KxH)[x [y [Kx Hy -> _]]]. +by rewrite !(cfunE, cfDprodEr). +Qed. + +Lemma cfAutDprod (phi : 'CF(K)) (psi : 'CF(H)) : + (cfDprod KxH phi psi)^u = cfDprod KxH phi^u psi^u. +Proof. by rewrite rmorphM /= cfAutDprodl cfAutDprodr. Qed. + +End FieldAutomorphism. + +Implicit Arguments cfAut_inj [gT G x1 x2]. + +Definition conj_cfRes := cfAutRes conjC. +Definition cfker_conjC := cfker_aut conjC. +Definition conj_cfQuo := cfAutQuo conjC. +Definition conj_cfMod := cfAutMod conjC. +Definition conj_cfInd := cfAutInd conjC. +Definition cfconjC_eq1 := cfAut_eq1 conjC. + diff --git a/mathcomp/character/inertia.v b/mathcomp/character/inertia.v new file mode 100644 index 0000000..fc33e1a --- /dev/null +++ b/mathcomp/character/inertia.v @@ -0,0 +1,1607 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path choice div. +Require Import fintype tuple finfun bigop prime ssralg ssrnum finset fingroup. +Require Import morphism perm automorphism quotient action zmodp cyclic center. +Require Import gproduct commutator gseries nilpotent pgroup sylow maximal. +Require Import frobenius. +Require Import matrix mxalgebra mxrepresentation vector algC classfun character. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory Num.Theory. +Local Open Scope ring_scope. + +(******************************************************************************) +(* This file contains the definitions and properties of inertia groups: *) +(* (phi ^ y)%CF == the y-conjugate of phi : 'CF(G), i.e., the class *) +(* function mapping x ^ y to phi x provided y normalises G. *) +(* We take (phi ^ y)%CF = phi when y \notin 'N(G). *) +(* (phi ^: G)%CF == the sequence of all distinct conjugates of phi : 'CF(H) *) +(* by all y in G. *) +(* 'I[phi] == the inertia group of phi : CF(H), i.e., the set of y *) +(* such that (phi ^ y)%CF = phi AND H :^ y = y. *) +(* 'I_G[phi] == the inertia group of phi in G, i.e., G :&: 'I[phi]. *) +(* conjg_Iirr i y == the index j : Iirr G such that ('chi_i ^ y)%CF = 'chi_j. *) +(* cfclass_Iirr G i == the image of G under conjg_Iirr i, i.e., the set of j *) +(* such that 'chi_j \in ('chi_i ^: G)%CF. *) +(* mul_Iirr i j == the index k such that 'chi_j * 'chi_i = 'chi[G]_k, *) +(* or 0 if 'chi_j * 'chi_i is reducible. *) +(* mul_mod_Iirr i j := mul_Iirr i (mod_Iirr j), for j : Iirr (G / H). *) +(******************************************************************************) + +Reserved Notation "''I[' phi ]" + (at level 8, format "''I[' phi ]"). +Reserved Notation "''I_' G [ phi ]" + (at level 8, G at level 2, format "''I_' G [ phi ]"). + +Section ConjDef. + +Variables (gT : finGroupType) (B : {set gT}) (y : gT) (phi : 'CF(B)). +Local Notation G := <>. + +Fact cfConjg_subproof : + is_class_fun G [ffun x => phi (if y \in 'N(G) then x ^ y^-1 else x)]. +Proof. +apply: intro_class_fun => [x z _ Gz | x notGx]. + have [nGy | _] := ifP; last by rewrite cfunJgen. + by rewrite -conjgM conjgC conjgM cfunJgen // memJ_norm ?groupV. +by rewrite cfun0gen //; case: ifP => // nGy; rewrite memJ_norm ?groupV. +Qed. +Definition cfConjg := Cfun 1 cfConjg_subproof. + +End ConjDef. + +Prenex Implicits cfConjg. +Notation "f ^ y" := (cfConjg y f) : cfun_scope. + +Section Conj. + +Variables (gT : finGroupType) (G : {group gT}). +Implicit Type phi : 'CF(G). + +Lemma cfConjgE phi y x : y \in 'N(G) -> (phi ^ y)%CF x = phi (x ^ y^-1)%g. +Proof. by rewrite cfunElock genGid => ->. Qed. + +Lemma cfConjgEJ phi y x : y \in 'N(G) -> (phi ^ y)%CF (x ^ y) = phi x. +Proof. by move/cfConjgE->; rewrite conjgK. Qed. + +Lemma cfConjgEout phi y : y \notin 'N(G) -> (phi ^ y = phi)%CF. +Proof. +by move/negbTE=> notNy; apply/cfunP=> x; rewrite !cfunElock genGid notNy. +Qed. + +Lemma cfConjgEin phi y (nGy : y \in 'N(G)) : + (phi ^ y)%CF = cfIsom (norm_conj_isom nGy) phi. +Proof. +apply/cfun_inP=> x Gx. +by rewrite cfConjgE // -{2}[x](conjgKV y) cfIsomE ?memJ_norm ?groupV. +Qed. + +Lemma cfConjgMnorm phi : + {in 'N(G) &, forall y z, phi ^ (y * z) = (phi ^ y) ^ z}%CF. +Proof. +move=> y z nGy nGz. +by apply/cfunP=> x; rewrite !cfConjgE ?groupM // invMg conjgM. +Qed. + +Lemma cfConjg_id phi y : y \in G -> (phi ^ y)%CF = phi. +Proof. +move=> Gy; apply/cfunP=> x; have nGy := subsetP (normG G) y Gy. +by rewrite -(cfunJ _ _ Gy) cfConjgEJ. +Qed. + +(* Isaacs' 6.1.b *) +Lemma cfConjgM L phi : + G <| L -> {in L &, forall y z, phi ^ (y * z) = (phi ^ y) ^ z}%CF. +Proof. by case/andP=> _ /subsetP nGL; exact: sub_in2 (cfConjgMnorm phi). Qed. + +Lemma cfConjgJ1 phi : (phi ^ 1)%CF = phi. +Proof. by apply/cfunP=> x; rewrite cfConjgE ?group1 // invg1 conjg1. Qed. + +Lemma cfConjgK y : cancel (cfConjg y) (cfConjg y^-1 : 'CF(G) -> 'CF(G)). +Proof. +move=> phi; apply/cfunP=> x; rewrite !cfunElock groupV /=. +by case: ifP => -> //; rewrite conjgKV. +Qed. + +Lemma cfConjgKV y : cancel (cfConjg y^-1) (cfConjg y : 'CF(G) -> 'CF(G)). +Proof. by move=> phi /=; rewrite -{1}[y]invgK cfConjgK. Qed. + +Lemma cfConjg1 phi y : (phi ^ y)%CF 1%g = phi 1%g. +Proof. by rewrite cfunElock conj1g if_same. Qed. + +Fact cfConjg_is_linear y : linear (cfConjg y : 'CF(G) -> 'CF(G)). +Proof. by move=> a phi psi; apply/cfunP=> x; rewrite !cfunElock. Qed. +Canonical cfConjg_additive y := Additive (cfConjg_is_linear y). +Canonical cfConjg_linear y := AddLinear (cfConjg_is_linear y). + +Lemma cfConjg_cfuniJ A y : y \in 'N(G) -> ('1_A ^ y)%CF = '1_(A :^ y) :> 'CF(G). +Proof. +move=> nGy; apply/cfunP=> x; rewrite !cfunElock genGid nGy -sub_conjgV. +by rewrite -class_lcoset -class_rcoset norm_rlcoset ?memJ_norm ?groupV. +Qed. + +Lemma cfConjg_cfuni A y : y \in 'N(A) -> ('1_A ^ y)%CF = '1_A :> 'CF(G). +Proof. +by have [/cfConjg_cfuniJ-> /normP-> | /cfConjgEout] := boolP (y \in 'N(G)). +Qed. + +Lemma cfConjg_cfun1 y : (1 ^ y)%CF = 1 :> 'CF(G). +Proof. +by rewrite -cfuniG; have [/cfConjg_cfuni|/cfConjgEout] := boolP (y \in 'N(G)). +Qed. + +Fact cfConjg_is_multiplicative y : multiplicative (cfConjg y : _ -> 'CF(G)). +Proof. +split=> [phi psi|]; last exact: cfConjg_cfun1. +by apply/cfunP=> x; rewrite !cfunElock. +Qed. +Canonical cfConjg_rmorphism y := AddRMorphism (cfConjg_is_multiplicative y). +Canonical cfConjg_lrmorphism y := [lrmorphism of cfConjg y]. + +Lemma cfConjg_eq1 phi y : ((phi ^ y)%CF == 1) = (phi == 1). +Proof. by apply: rmorph_eq1; apply: can_inj (cfConjgK y). Qed. + +Lemma cfAutConjg phi u y : cfAut u (phi ^ y) = (cfAut u phi ^ y)%CF. +Proof. by apply/cfunP=> x; rewrite !cfunElock. Qed. + +Lemma conj_cfConjg phi y : (phi ^ y)^*%CF = (phi^* ^ y)%CF. +Proof. exact: cfAutConjg. Qed. + +Lemma cfker_conjg phi y : y \in 'N(G) -> cfker (phi ^ y) = cfker phi :^ y. +Proof. +move=> nGy; rewrite cfConjgEin // cfker_isom. +by rewrite morphim_conj (setIidPr (cfker_sub _)). +Qed. + +Lemma cfDetConjg phi y : cfDet (phi ^ y) = (cfDet phi ^ y)%CF. +Proof. +have [nGy | not_nGy] := boolP (y \in 'N(G)); last by rewrite !cfConjgEout. +by rewrite !cfConjgEin cfDetIsom. +Qed. + +End Conj. + +Section Inertia. + +Variable gT : finGroupType. + +Definition inertia (B : {set gT}) (phi : 'CF(B)) := + [set y in 'N(B) | (phi ^ y)%CF == phi]. + +Local Notation "''I[' phi ]" := (inertia phi) : group_scope. +Local Notation "''I_' G [ phi ]" := (G%g :&: 'I[phi]) : group_scope. + +Fact group_set_inertia (H : {group gT}) phi : group_set 'I[phi : 'CF(H)]. +Proof. +apply/group_setP; split; first by rewrite inE group1 /= cfConjgJ1. +move=> y z /setIdP[nHy /eqP n_phi_y] /setIdP[nHz n_phi_z]. +by rewrite inE groupM //= cfConjgMnorm ?n_phi_y. +Qed. +Canonical inertia_group H phi := Group (@group_set_inertia H phi). + +Local Notation "''I[' phi ]" := (inertia_group phi) : Group_scope. +Local Notation "''I_' G [ phi ]" := (G :&: 'I[phi])%G : Group_scope. + +Variables G H : {group gT}. +Implicit Type phi : 'CF(H). + +Lemma inertiaJ phi y : y \in 'I[phi] -> (phi ^ y)%CF = phi. +Proof. by case/setIdP=> _ /eqP->. Qed. + +Lemma inertia_valJ phi x y : y \in 'I[phi] -> phi (x ^ y)%g = phi x. +Proof. by case/setIdP=> nHy /eqP {1}<-; rewrite cfConjgEJ. Qed. + +(* To disambiguate basic inclucion lemma names we capitalize Inertia for *) +(* lemmas concerning the localized inertia group 'I_G[phi]. *) +Lemma Inertia_sub phi : 'I_G[phi] \subset G. +Proof. exact: subsetIl. Qed. + +Lemma norm_inertia phi : 'I[phi] \subset 'N(H). +Proof. by rewrite ['I[_]]setIdE subsetIl. Qed. + +Lemma sub_inertia phi : H \subset 'I[phi]. +Proof. +by apply/subsetP=> y Hy; rewrite inE cfConjg_id ?(subsetP (normG H)) /=. +Qed. + +Lemma normal_inertia phi : H <| 'I[phi]. +Proof. by rewrite /normal sub_inertia norm_inertia. Qed. + +Lemma sub_Inertia phi : H \subset G -> H \subset 'I_G[phi]. +Proof. by rewrite subsetI sub_inertia andbT. Qed. + +Lemma norm_Inertia phi : 'I_G[phi] \subset 'N(H). +Proof. by rewrite setIC subIset ?norm_inertia. Qed. + +Lemma normal_Inertia phi : H \subset G -> H <| 'I_G[phi]. +Proof. by rewrite /normal norm_Inertia andbT; apply: sub_Inertia. Qed. + +Lemma cfConjg_eqE phi : + H <| G -> + {in G &, forall y z, (phi ^ y == phi ^ z)%CF = (z \in 'I_G[phi] :* y)}. +Proof. +case/andP=> _ nHG y z Gy; rewrite -{1 2}[z](mulgKV y) groupMr // mem_rcoset. +move: {z}(z * _)%g => z Gz; rewrite 2!inE Gz cfConjgMnorm ?(subsetP nHG) //=. +by rewrite eq_sym (can_eq (cfConjgK y)). +Qed. + +Lemma cent_sub_inertia phi : 'C(H) \subset 'I[phi]. +Proof. +apply/subsetP=> y cHy; have nHy := subsetP (cent_sub H) y cHy. +rewrite inE nHy; apply/eqP/cfun_inP=> x Hx; rewrite cfConjgE //. +by rewrite /conjg invgK mulgA (centP cHy) ?mulgK. +Qed. + +Lemma cent_sub_Inertia phi : 'C_G(H) \subset 'I_G[phi]. +Proof. exact: setIS (cent_sub_inertia phi). Qed. + +Lemma center_sub_Inertia phi : H \subset G -> 'Z(G) \subset 'I_G[phi]. +Proof. +by move/centS=> sHG; rewrite setIS // (subset_trans sHG) // cent_sub_inertia. +Qed. + +Lemma conjg_inertia phi y : y \in 'N(H) -> 'I[phi] :^ y = 'I[phi ^ y]. +Proof. +move=> nHy; apply/setP=> z; rewrite !['I[_]]setIdE conjIg conjGid // !in_setI. +apply/andb_id2l=> nHz; rewrite mem_conjg !inE. +by rewrite !cfConjgMnorm ?in_group ?(can2_eq (cfConjgKV y) (cfConjgK y)) ?invgK. +Qed. + +Lemma inertia0 : 'I[0 : 'CF(H)] = 'N(H). +Proof. by apply/setP=> x; rewrite !inE linear0 eqxx andbT. Qed. + +Lemma inertia_add phi psi : 'I[phi] :&: 'I[psi] \subset 'I[phi + psi]. +Proof. +rewrite !['I[_]]setIdE -setIIr setIS //. +by apply/subsetP=> x; rewrite !inE linearD /= => /andP[/eqP-> /eqP->]. +Qed. + +Lemma inertia_sum I r (P : pred I) (Phi : I -> 'CF(H)) : + 'N(H) :&: \bigcap_(i <- r | P i) 'I[Phi i] + \subset 'I[\sum_(i <- r | P i) Phi i]. +Proof. +elim/big_rec2: _ => [|i K psi Pi sK_Ipsi]; first by rewrite setIT inertia0. +by rewrite setICA; apply: subset_trans (setIS _ sK_Ipsi) (inertia_add _ _). +Qed. + +Lemma inertia_scale a phi : 'I[phi] \subset 'I[a *: phi]. +Proof. +apply/subsetP=> x /setIdP[nHx /eqP Iphi_x]. +by rewrite inE nHx linearZ /= Iphi_x. +Qed. + +Lemma inertia_scale_nz a phi : a != 0 -> 'I[a *: phi] = 'I[phi]. +Proof. +move=> nz_a; apply/eqP. +by rewrite eqEsubset -{2}(scalerK nz_a phi) !inertia_scale. +Qed. + +Lemma inertia_opp phi : 'I[- phi] = 'I[phi]. +Proof. by rewrite -scaleN1r inertia_scale_nz // oppr_eq0 oner_eq0. Qed. + +Lemma inertia1 : 'I[1 : 'CF(H)] = 'N(H). +Proof. by apply/setP=> x; rewrite inE rmorph1 eqxx andbT. Qed. + +Lemma Inertia1 : H <| G -> 'I_G[1 : 'CF(H)] = G. +Proof. by rewrite inertia1 => /normal_norm/setIidPl. Qed. + +Lemma inertia_mul phi psi : 'I[phi] :&: 'I[psi] \subset 'I[phi * psi]. +Proof. +rewrite !['I[_]]setIdE -setIIr setIS //. +by apply/subsetP=> x; rewrite !inE rmorphM /= => /andP[/eqP-> /eqP->]. +Qed. + +Lemma inertia_prod I r (P : pred I) (Phi : I -> 'CF(H)) : + 'N(H) :&: \bigcap_(i <- r | P i) 'I[Phi i] + \subset 'I[\prod_(i <- r | P i) Phi i]. +Proof. +elim/big_rec2: _ => [|i K psi Pi sK_psi]; first by rewrite inertia1 setIT. +by rewrite setICA; apply: subset_trans (setIS _ sK_psi) (inertia_mul _ _). +Qed. + +Lemma inertia_injective (chi : 'CF(H)) : + {in H &, injective chi} -> 'I[chi] = 'C(H). +Proof. +move=> inj_chi; apply/eqP; rewrite eqEsubset cent_sub_inertia andbT. +apply/subsetP=> y Ichi_y; have /setIdP[nHy _] := Ichi_y. +apply/centP=> x Hx; apply/esym/commgP/conjg_fixP. +by apply/inj_chi; rewrite ?memJ_norm ?(inertia_valJ _ Ichi_y). +Qed. + +Lemma inertia_irr_prime p i : + #|H| = p -> prime p -> i != 0 -> 'I['chi[H]_i] = 'C(H). +Proof. by move=> <- pr_H /(irr_prime_injP pr_H); apply: inertia_injective. Qed. + +Lemma inertia_irr0 : 'I['chi[H]_0] = 'N(H). +Proof. by rewrite irr0 inertia1. Qed. + +(* Isaacs' 6.1.c *) +Lemma cfConjg_iso y : isometry (cfConjg y : 'CF(H) -> 'CF(H)). +Proof. +move=> phi psi; congr (_ * _). +have [nHy | not_nHy] := boolP (y \in 'N(H)); last by rewrite !cfConjgEout. +rewrite (reindex_astabs 'J y) ?astabsJ //=. +by apply: eq_bigr=> x _; rewrite !cfConjgEJ. +Qed. + +(* Isaacs' 6.1.d *) +Lemma cfdot_Res_conjg psi phi y : + y \in G -> '['Res[H, G] psi, phi ^ y] = '['Res[H] psi, phi]. +Proof. +move=> Gy; rewrite -(cfConjg_iso y _ phi); congr '[_, _]; apply/cfunP=> x. +rewrite !cfunElock !genGid; case nHy: (y \in 'N(H)) => //. +by rewrite !(fun_if psi) cfunJ ?memJ_norm ?groupV. +Qed. + +(* Isaac's 6.1.e *) +Lemma cfConjg_char (chi : 'CF(H)) y : + chi \is a character -> (chi ^ y)%CF \is a character. +Proof. +have [nHy Nchi | /cfConjgEout-> //] := boolP (y \in 'N(H)). +by rewrite cfConjgEin cfIsom_char. +Qed. + +Lemma cfConjg_lin_char (chi : 'CF(H)) y : + chi \is a linear_char -> (chi ^ y)%CF \is a linear_char. +Proof. by case/andP=> Nchi chi1; rewrite qualifE cfConjg1 cfConjg_char. Qed. + +Lemma cfConjg_irr y chi : chi \in irr H -> (chi ^ y)%CF \in irr H. +Proof. by rewrite !irrEchar cfConjg_iso => /andP[/cfConjg_char->]. Qed. + +Definition conjg_Iirr i y := cfIirr ('chi[H]_i ^ y)%CF. + +Lemma conjg_IirrE i y : 'chi_(conjg_Iirr i y) = ('chi_i ^ y)%CF. +Proof. by rewrite cfIirrE ?cfConjg_irr ?mem_irr. Qed. + +Lemma conjg_IirrK y : cancel (conjg_Iirr^~ y) (conjg_Iirr^~ y^-1%g). +Proof. by move=> i; apply/irr_inj; rewrite !conjg_IirrE cfConjgK. Qed. + +Lemma conjg_IirrKV y : cancel (conjg_Iirr^~ y^-1%g) (conjg_Iirr^~ y). +Proof. by rewrite -{2}[y]invgK; apply: conjg_IirrK. Qed. + +Lemma conjg_Iirr_inj y : injective (conjg_Iirr^~ y). +Proof. exact: can_inj (conjg_IirrK y). Qed. + +Lemma conjg_Iirr_eq0 i y : (conjg_Iirr i y == 0) = (i == 0). +Proof. by rewrite -!irr_eq1 conjg_IirrE cfConjg_eq1. Qed. + +Lemma conjg_Iirr0 x : conjg_Iirr 0 x = 0. +Proof. by apply/eqP; rewrite conjg_Iirr_eq0. Qed. + +Lemma cfdot_irr_conjg i y : + H <| G -> y \in G -> '['chi_i, 'chi_i ^ y]_H = (y \in 'I_G['chi_i])%:R. +Proof. +move=> nsHG Gy; rewrite -conjg_IirrE cfdot_irr -(inj_eq irr_inj) conjg_IirrE. +by rewrite -{1}['chi_i]cfConjgJ1 cfConjg_eqE ?mulg1. +Qed. + +Definition cfclass (A : {set gT}) (phi : 'CF(A)) (B : {set gT}) := + [seq (phi ^ repr Tx)%CF | Tx in rcosets 'I_B[phi] B]. + +Local Notation "phi ^: G" := (cfclass phi G) : cfun_scope. + +Lemma size_cfclass i : size ('chi[H]_i ^: G)%CF = #|G : 'I_G['chi_i]|. +Proof. by rewrite size_map -cardE. Qed. + +Lemma cfclassP (A : {group gT}) phi psi : + reflect (exists2 y, y \in A & psi = phi ^ y)%CF (psi \in phi ^: A)%CF. +Proof. +apply: (iffP imageP) => [[_ /rcosetsP[y Ay ->] ->] | [y Ay ->]]. + by case: repr_rcosetP => z /setIdP[Az _]; exists (z * y)%g; rewrite ?groupM. +without loss nHy: y Ay / y \in 'N(H). + have [nHy | /cfConjgEout->] := boolP (y \in 'N(H)); first exact. + by move/(_ 1%g); rewrite !group1 !cfConjgJ1; exact. +exists ('I_A[phi] :* y); first by rewrite -rcosetE mem_imset. +case: repr_rcosetP => z /setIP[_ /setIdP[nHz /eqP Tz]]. +by rewrite cfConjgMnorm ?Tz. +Qed. + +Lemma cfclassInorm phi : (phi ^: 'N_G(H) =i phi ^: G)%CF. +Proof. +move=> xi; apply/cfclassP/cfclassP=> [[x /setIP[Gx _] ->] | [x Gx ->]]. + by exists x. +have [Nx | /cfConjgEout-> //] := boolP (x \in 'N(H)). + by exists x; first exact/setIP. +by exists 1%g; rewrite ?group1 ?cfConjgJ1. +Qed. + +Lemma cfclass_refl phi : phi \in (phi ^: G)%CF. +Proof. by apply/cfclassP; exists 1%g => //; rewrite cfConjgJ1. Qed. + +Lemma cfclass_transl phi psi : + (psi \in phi ^: G)%CF -> (phi ^: G =i psi ^: G)%CF. +Proof. +rewrite -cfclassInorm; case/cfclassP=> x Gx -> xi; rewrite -!cfclassInorm. +have nHN: {subset 'N_G(H) <= 'N(H)} by apply/subsetP; exact: subsetIr. +apply/cfclassP/cfclassP=> [[y Gy ->] | [y Gy ->]]. + by exists (x^-1 * y)%g; rewrite -?cfConjgMnorm ?groupM ?groupV ?nHN // mulKVg. +by exists (x * y)%g; rewrite -?cfConjgMnorm ?groupM ?nHN. +Qed. + +Lemma cfclass_sym phi psi : (psi \in phi ^: G)%CF = (phi \in psi ^: G)%CF. +Proof. by apply/idP/idP=> /cfclass_transl <-; exact: cfclass_refl. Qed. + +Lemma cfclass_uniq phi : H <| G -> uniq (phi ^: G)%CF. +Proof. +move=> nsHG; rewrite map_inj_in_uniq ?enum_uniq // => Ty Tz; rewrite !mem_enum. +move=> {Ty}/rcosetsP[y Gy ->] {Tz}/rcosetsP[z Gz ->] /eqP. +case: repr_rcosetP => u Iphi_u; case: repr_rcosetP => v Iphi_v. +have [[Gu _] [Gv _]] := (setIdP Iphi_u, setIdP Iphi_v). +rewrite cfConjg_eqE ?groupM // => /rcoset_transl. +by rewrite !rcosetM (rcoset_id Iphi_v) (rcoset_id Iphi_u). +Qed. + +Lemma cfclass_invariant phi : G \subset 'I[phi] -> (phi ^: G)%CF = phi. +Proof. +move/setIidPl=> IGphi; rewrite /cfclass IGphi // rcosets_id. +by rewrite /(image _ _) enum_set1 /= repr_group cfConjgJ1. +Qed. + +Lemma cfclass1 : H <| G -> (1 ^: G)%CF = [:: 1 : 'CF(H)]. +Proof. by move/normal_norm=> nHG; rewrite cfclass_invariant ?inertia1. Qed. + +Definition cfclass_Iirr (A : {set gT}) i := conjg_Iirr i @: A. + +Lemma cfclass_IirrE i j : + (j \in cfclass_Iirr G i) = ('chi_j \in 'chi_i ^: G)%CF. +Proof. +apply/imsetP/cfclassP=> [[y Gy ->] | [y]]; exists y; rewrite ?conjg_IirrE //. +by apply: irr_inj; rewrite conjg_IirrE. +Qed. + +Lemma eq_cfclass_IirrE i j : + (cfclass_Iirr G j == cfclass_Iirr G i) = (j \in cfclass_Iirr G i). +Proof. +apply/eqP/idP=> [<- | iGj]; first by rewrite cfclass_IirrE cfclass_refl. +by apply/setP=> k; rewrite !cfclass_IirrE in iGj *; apply/esym/cfclass_transl. +Qed. + +Lemma im_cfclass_Iirr i : + H <| G -> perm_eq [seq 'chi_j | j in cfclass_Iirr G i] ('chi_i ^: G)%CF. +Proof. +move=> nsHG; have UchiG := cfclass_uniq 'chi_i nsHG. +apply: uniq_perm_eq; rewrite ?(map_inj_uniq irr_inj) ?enum_uniq // => phi. +apply/imageP/idP=> [[j iGj ->] | /cfclassP[y]]; first by rewrite -cfclass_IirrE. +by exists (conjg_Iirr i y); rewrite ?mem_imset ?conjg_IirrE. +Qed. + +Lemma card_cfclass_Iirr i : H <| G -> #|cfclass_Iirr G i| = #|G : 'I_G['chi_i]|. +Proof. +move=> nsHG; rewrite -size_cfclass -(perm_eq_size (im_cfclass_Iirr i nsHG)). +by rewrite size_map -cardE. +Qed. + +Lemma reindex_cfclass R idx (op : Monoid.com_law idx) (F : 'CF(H) -> R) i : + H <| G -> + \big[op/idx]_(chi <- ('chi_i ^: G)%CF) F chi + = \big[op/idx]_(j | 'chi_j \in ('chi_i ^: G)%CF) F 'chi_j. +Proof. +move/im_cfclass_Iirr/(eq_big_perm _) <-; rewrite big_map big_filter /=. +by apply: eq_bigl => j; rewrite cfclass_IirrE. +Qed. + +Lemma cfResInd j: + H <| G -> + 'Res[H] ('Ind[G] 'chi_j) = #|H|%:R^-1 *: (\sum_(y in G) 'chi_j ^ y)%CF. +Proof. +case/andP=> [sHG /subsetP nHG]. +rewrite (reindex_inj invg_inj); apply/cfun_inP=> x Hx. +rewrite cfResE // cfIndE // ?cfunE ?sum_cfunE; congr (_ * _). +by apply: eq_big => [y | y Gy]; rewrite ?cfConjgE ?groupV ?invgK ?nHG. +Qed. + +(* This is Isaacs, Theorem (6.2) *) +Lemma Clifford_Res_sum_cfclass i j : + H <| G -> j \in irr_constt ('Res[H, G] 'chi_i) -> + 'Res[H] 'chi_i = + '['Res[H] 'chi_i, 'chi_j] *: (\sum_(chi <- ('chi_j ^: G)%CF) chi). +Proof. +move=> nsHG chiHj; have [sHG /subsetP nHG] := andP nsHG. +rewrite reindex_cfclass //= big_mkcond. +rewrite {1}['Res _]cfun_sum_cfdot linear_sum /=; apply: eq_bigr => k _. +have [[y Gy ->] | ] := altP (cfclassP _ _ _); first by rewrite cfdot_Res_conjg. +apply: contraNeq; rewrite scaler0 scaler_eq0 orbC => /norP[_ chiHk]. +have{chiHk chiHj}: '['Res[H] ('Ind[G] 'chi_j), 'chi_k] != 0. + rewrite !inE !cfdot_Res_l in chiHj chiHk *. + apply: contraNneq chiHk; rewrite cfdot_sum_irr => /psumr_eq0P/(_ i isT)/eqP. + rewrite -cfdotC cfdotC mulf_eq0 conjC_eq0 (negbTE chiHj) /= => -> // i1. + by rewrite -cfdotC Cnat_ge0 // rpredM ?Cnat_cfdot_char ?cfInd_char ?irr_char. +rewrite cfResInd // cfdotZl mulf_eq0 cfdot_suml => /norP[_]. +apply: contraR => chiGk'j; rewrite big1 // => x Gx; apply: contraNeq chiGk'j. +rewrite -conjg_IirrE cfdot_irr pnatr_eq0; case: (_ =P k) => // <- _. +by rewrite conjg_IirrE; apply/cfclassP; exists x. +Qed. + +Lemma cfRes_Ind_invariant psi : + H <| G -> G \subset 'I[psi] -> 'Res ('Ind[G, H] psi) = #|G : H|%:R *: psi. +Proof. +case/andP=> sHG _ /subsetP IGpsi; apply/cfun_inP=> x Hx. +rewrite cfResE ?cfIndE ?natf_indexg // cfunE -mulrA mulrCA; congr (_ * _). +by rewrite mulr_natl -sumr_const; apply: eq_bigr => y /IGpsi/inertia_valJ->. +Qed. + +(* This is Isaacs, Corollary (6.7). *) +Corollary constt0_Res_cfker i : + H <| G -> 0 \in irr_constt ('Res[H] 'chi[G]_i) -> H \subset cfker 'chi[G]_i. +Proof. +move=> nsHG /(Clifford_Res_sum_cfclass nsHG); have [sHG nHG] := andP nsHG. +rewrite irr0 cfdot_Res_l cfclass1 // big_seq1 cfInd_cfun1 //. +rewrite cfdotZr conjC_nat => def_chiH. +apply/subsetP=> x Hx; rewrite cfkerEirr inE -!(cfResE _ sHG) //. +by rewrite def_chiH !cfunE cfun11 cfun1E Hx. +Qed. + +(* This is Isaacs, Lemma (6.8). *) +Lemma dvdn_constt_Res1_irr1 i j : + H <| G -> j \in irr_constt ('Res[H, G] 'chi_i) -> + exists n, 'chi_i 1%g = n%:R * 'chi_j 1%g. +Proof. +move=> nsHG chiHj; have [sHG nHG] := andP nsHG; rewrite -(cfResE _ sHG) //. +rewrite {1}(Clifford_Res_sum_cfclass nsHG chiHj) cfunE sum_cfunE. +have /CnatP[n ->]: '['Res[H] 'chi_i, 'chi_j] \in Cnat. + by rewrite Cnat_cfdot_char ?cfRes_char ?irr_char. +exists (n * size ('chi_j ^: G)%CF)%N; rewrite natrM -mulrA; congr (_ * _). +rewrite mulr_natl -[size _]card_ord big_tnth -sumr_const; apply: eq_bigr => k _. +by have /cfclassP[y Gy ->]:= mem_tnth k (in_tuple _); rewrite cfConjg1. +Qed. + +Lemma cfclass_Ind phi psi : + H <| G -> psi \in (phi ^: G)%CF -> 'Ind[G] phi = 'Ind[G] psi. +Proof. +move=> nsHG /cfclassP[y Gy ->]; have [sHG /subsetP nHG] := andP nsHG. +apply/cfun_inP=> x Hx; rewrite !cfIndE //; congr (_ * _). +rewrite (reindex_acts 'R _ (groupVr Gy)) ?astabsR //=. +by apply: eq_bigr => z Gz; rewrite conjgM cfConjgE ?nHG. +Qed. + +End Inertia. + +Arguments Scope inertia [_ group_scope cfun_scope]. +Arguments Scope cfclass [_ group_scope cfun_scope group_scope]. +Implicit Arguments conjg_Iirr_inj [gT H x1 x2]. + +Notation "''I[' phi ] " := (inertia phi) : group_scope. +Notation "''I[' phi ] " := (inertia_group phi) : Group_scope. +Notation "''I_' G [ phi ] " := (G%g :&: 'I[phi]) : group_scope. +Notation "''I_' G [ phi ] " := (G :&: 'I[phi])%G : Group_scope. +Notation "phi ^: G" := (cfclass phi G) : cfun_scope. + +Section ConjRestrict. + +Variables (gT : finGroupType) (G H K : {group gT}). + +Lemma cfConjgRes_norm phi y : + y \in 'N(K) -> y \in 'N(H) -> ('Res[K, H] phi ^ y)%CF = 'Res (phi ^ y)%CF. +Proof. +move=> nKy nHy; have [sKH | not_sKH] := boolP (K \subset H); last first. + by rewrite !cfResEout // linearZ rmorph1 cfConjg1. +by apply/cfun_inP=> x Kx; rewrite !(cfConjgE, cfResE) ?memJ_norm ?groupV. +Qed. + +Lemma cfConjgRes phi y : + H <| G -> K <| G -> y \in G -> ('Res[K, H] phi ^ y)%CF = 'Res (phi ^ y)%CF. +Proof. +move=> /andP[_ nHG] /andP[_ nKG] Gy. +by rewrite cfConjgRes_norm ?(subsetP nHG) ?(subsetP nKG). +Qed. + +Lemma sub_inertia_Res phi : + G \subset 'N(K) -> 'I_G[phi] \subset 'I_G['Res[K, H] phi]. +Proof. +move=> nKG; apply/subsetP=> y /setIP[Gy /setIdP[nHy /eqP Iphi_y]]. +by rewrite 2!inE Gy cfConjgRes_norm ?(subsetP nKG) ?Iphi_y /=. +Qed. + +Lemma cfConjgInd_norm phi y : + y \in 'N(K) -> y \in 'N(H) -> ('Ind[H, K] phi ^ y)%CF = 'Ind (phi ^ y)%CF. +Proof. +move=> nKy nHy; have [sKH | not_sKH] := boolP (K \subset H). + by rewrite !cfConjgEin (cfIndIsom (norm_conj_isom nHy)). +rewrite !cfIndEout // linearZ -(cfConjg_iso y) rmorph1 /=; congr (_ *: _). +by rewrite cfConjg_cfuni ?norm1 ?inE. +Qed. + +Lemma cfConjgInd phi y : + H <| G -> K <| G -> y \in G -> ('Ind[H, K] phi ^ y)%CF = 'Ind (phi ^ y)%CF. +Proof. +move=> /andP[_ nHG] /andP[_ nKG] Gy. +by rewrite cfConjgInd_norm ?(subsetP nHG) ?(subsetP nKG). +Qed. + +Lemma sub_inertia_Ind phi : + G \subset 'N(H) -> 'I_G[phi] \subset 'I_G['Ind[H, K] phi]. +Proof. +move=> nHG; apply/subsetP=> y /setIP[Gy /setIdP[nKy /eqP Iphi_y]]. +by rewrite 2!inE Gy cfConjgInd_norm ?(subsetP nHG) ?Iphi_y /=. +Qed. + +End ConjRestrict. + +Section MoreInertia. + +Variables (gT : finGroupType) (G H : {group gT}) (i : Iirr H). +Let T := 'I_G['chi_i]. + +Lemma inertia_id : 'I_T['chi_i] = T. Proof. by rewrite -setIA setIid. Qed. + +Lemma cfclass_inertia : ('chi[H]_i ^: T)%CF = [:: 'chi_i]. +Proof. +rewrite /cfclass inertia_id rcosets_id /(image _ _) enum_set1 /=. +by rewrite repr_group cfConjgJ1. +Qed. + +End MoreInertia. + +Section ConjMorph. + +Variables (aT rT : finGroupType) (D G H : {group aT}) (f : {morphism D >-> rT}). + +Lemma cfConjgMorph (phi : 'CF(f @* H)) y : + y \in D -> y \in 'N(H) -> (cfMorph phi ^ y)%CF = cfMorph (phi ^ f y). +Proof. +move=> Dy nHy; have [sHD | not_sHD] := boolP (H \subset D); last first. + by rewrite !cfMorphEout // linearZ rmorph1 cfConjg1. +apply/cfun_inP=> x Gx; rewrite !(cfConjgE, cfMorphE) ?memJ_norm ?groupV //. + by rewrite morphJ ?morphV ?groupV // (subsetP sHD). +by rewrite (subsetP (morphim_norm _ _)) ?mem_morphim. +Qed. + +Lemma inertia_morph_pre (phi : 'CF(f @* H)) : + H <| G -> G \subset D -> 'I_G[cfMorph phi] = G :&: f @*^-1 'I_(f @* G)[phi]. +Proof. +case/andP=> sHG nHG sGD; have sHD := subset_trans sHG sGD. +apply/setP=> y; rewrite !in_setI; apply: andb_id2l => Gy. +have [Dy nHy] := (subsetP sGD y Gy, subsetP nHG y Gy). +rewrite Dy inE nHy 4!inE mem_morphim // -morphimJ ?(normP nHy) // subxx /=. +rewrite cfConjgMorph //; apply/eqP/eqP=> [Iphi_y | -> //]. +by apply/cfun_inP=> _ /morphimP[x Dx Hx ->]; rewrite -!cfMorphE ?Iphi_y. +Qed. + +Lemma inertia_morph_im (phi : 'CF(f @* H)) : + H <| G -> G \subset D -> f @* 'I_G[cfMorph phi] = 'I_(f @* G)[phi]. +Proof. +move=> nsHG sGD; rewrite inertia_morph_pre // morphim_setIpre. +by rewrite (setIidPr _) ?Inertia_sub. +Qed. + +Variables (R S : {group rT}). +Variables (g : {morphism G >-> rT}) (h : {morphism H >-> rT}). +Hypotheses (isoG : isom G R g) (isoH : isom H S h). +Hypotheses (eq_hg : {in H, h =1 g}) (sHG : H \subset G). + +(* This does not depend on the (isoG : isom G R g) assumption. *) +Lemma cfConjgIsom phi y : + y \in G -> y \in 'N(H) -> (cfIsom isoH phi ^ g y)%CF = cfIsom isoH (phi ^ y). +Proof. +move=> Gy nHy; have [_ defS] := isomP isoH. +rewrite morphimEdom (eq_in_imset eq_hg) -morphimEsub // in defS. +apply/cfun_inP=> gx; rewrite -{1}defS => /morphimP[x Gx Hx ->] {gx}. +rewrite cfConjgE; last by rewrite -defS inE -morphimJ ?(normP nHy). +by rewrite -morphV -?morphJ -?eq_hg ?cfIsomE ?cfConjgE ?memJ_norm ?groupV. +Qed. + +Lemma inertia_isom phi : 'I_R[cfIsom isoH phi] = g @* 'I_G[phi]. +Proof. +have [[_ defS] [injg <-]] := (isomP isoH, isomP isoG). +rewrite morphimEdom (eq_in_imset eq_hg) -morphimEsub // in defS. +rewrite /inertia !setIdE morphimIdom setIA -{1}defS -injm_norm ?injmI //. +apply/setP=> gy; rewrite !inE; apply: andb_id2l => /morphimP[y Gy nHy ->] {gy}. +rewrite cfConjgIsom // -sub1set -morphim_set1 // injmSK ?sub1set //= inE. +apply/eqP/eqP=> [Iphi_y | -> //]. +by apply/cfun_inP=> x Hx; rewrite -!(cfIsomE isoH) ?Iphi_y. +Qed. + +End ConjMorph. + +Section ConjQuotient. + +Variables gT : finGroupType. +Implicit Types G H K : {group gT}. + +Lemma cfConjgMod_norm H K (phi : 'CF(H / K)) y : + y \in 'N(K) -> y \in 'N(H) -> ((phi %% K) ^ y)%CF = (phi ^ coset K y %% K)%CF. +Proof. exact: cfConjgMorph. Qed. + +Lemma cfConjgMod G H K (phi : 'CF(H / K)) y : + H <| G -> K <| G -> y \in G -> + ((phi %% K) ^ y)%CF = (phi ^ coset K y %% K)%CF. +Proof. +move=> /andP[_ nHG] /andP[_ nKG] Gy. +by rewrite cfConjgMod_norm ?(subsetP nHG) ?(subsetP nKG). +Qed. + +Lemma cfConjgQuo_norm H K (phi : 'CF(H)) y : + y \in 'N(K) -> y \in 'N(H) -> ((phi / K) ^ coset K y)%CF = (phi ^ y / K)%CF. +Proof. +move=> nKy nHy; have keryK: (K \subset cfker (phi ^ y)) = (K \subset cfker phi). + by rewrite cfker_conjg // -{1}(normP nKy) conjSg. +have [kerK | not_kerK] := boolP (K \subset cfker phi); last first. + by rewrite !cfQuoEout ?linearZ ?rmorph1 ?cfConjg1 ?keryK. +apply/cfun_inP=> _ /morphimP[x nKx Hx ->]. +have nHyb: coset K y \in 'N(H / K) by rewrite inE -morphimJ ?(normP nHy). +rewrite !(cfConjgE, cfQuoEnorm) ?keryK // ?in_setI ?Hx //. +rewrite -morphV -?morphJ ?groupV // cfQuoEnorm //. +by rewrite inE memJ_norm ?Hx ?groupJ ?groupV. +Qed. + +Lemma cfConjgQuo G H K (phi : 'CF(H)) y : + H <| G -> K <| G -> y \in G -> + ((phi / K) ^ coset K y)%CF = (phi ^ y / K)%CF. +Proof. +move=> /andP[_ nHG] /andP[_ nKG] Gy. +by rewrite cfConjgQuo_norm ?(subsetP nHG) ?(subsetP nKG). +Qed. + +Lemma inertia_mod_pre G H K (phi : 'CF(H / K)) : + H <| G -> K <| G -> 'I_G[phi %% K] = G :&: coset K @*^-1 'I_(G / K)[phi]. +Proof. by move=> nsHG /andP[_]; apply: inertia_morph_pre. Qed. + +Lemma inertia_mod_quo G H K (phi : 'CF(H / K)) : + H <| G -> K <| G -> ('I_G[phi %% K] / K)%g = 'I_(G / K)[phi]. +Proof. by move=> nsHG /andP[_]; apply: inertia_morph_im. Qed. + +Lemma inertia_quo G H K (phi : 'CF(H)) : + H <| G -> K <| G -> K \subset cfker phi -> + 'I_(G / K)[phi / K] = ('I_G[phi] / K)%g. +Proof. +move=> nsHG nsKG kerK; rewrite -inertia_mod_quo ?cfQuoK //. +by rewrite (normalS _ (normal_sub nsHG)) // (subset_trans _ (cfker_sub phi)). +Qed. + +End ConjQuotient. + +Section InertiaSdprod. + +Variables (gT : finGroupType) (K H G : {group gT}). + +Hypothesis defG : K ><| H = G. + +Lemma cfConjgSdprod phi y : + y \in 'N(K) -> y \in 'N(H) -> + (cfSdprod defG phi ^ y = cfSdprod defG (phi ^ y))%CF. +Proof. +move=> nKy nHy. +have nGy: y \in 'N(G) by rewrite -sub1set -(sdprodW defG) normsM ?sub1set. +rewrite -{2}[phi](cfSdprodK defG) cfConjgRes_norm // cfRes_sdprodK //. +by rewrite cfker_conjg // -{1}(normP nKy) conjSg cfker_sdprod. +Qed. + +Lemma inertia_sdprod (L : {group gT}) phi : + L \subset 'N(K) -> L \subset 'N(H) -> 'I_L[cfSdprod defG phi] = 'I_L[phi]. +Proof. +move=> nKL nHL; have nGL: L \subset 'N(G) by rewrite -(sdprodW defG) normsM. +apply/setP=> z; rewrite !in_setI ![z \in 'I[_]]inE; apply: andb_id2l => Lz. +rewrite cfConjgSdprod ?(subsetP nKL) ?(subsetP nHL) ?(subsetP nGL) //=. +by rewrite (can_eq (cfSdprodK defG)). +Qed. + +End InertiaSdprod. + +Section InertiaDprod. + +Variables (gT : finGroupType) (G K H : {group gT}). +Implicit Type L : {group gT}. +Hypothesis KxH : K \x H = G. + +Lemma cfConjgDprodl phi y : + y \in 'N(K) -> y \in 'N(H) -> + (cfDprodl KxH phi ^ y = cfDprodl KxH (phi ^ y))%CF. +Proof. by move=> nKy nHy; apply: cfConjgSdprod. Qed. + +Lemma cfConjgDprodr psi y : + y \in 'N(K) -> y \in 'N(H) -> + (cfDprodr KxH psi ^ y = cfDprodr KxH (psi ^ y))%CF. +Proof. by move=> nKy nHy; apply: cfConjgSdprod. Qed. + +Lemma cfConjgDprod phi psi y : + y \in 'N(K) -> y \in 'N(H) -> + (cfDprod KxH phi psi ^ y = cfDprod KxH (phi ^ y) (psi ^ y))%CF. +Proof. by move=> nKy nHy; rewrite rmorphM /= cfConjgDprodl ?cfConjgDprodr. Qed. + +Lemma inertia_dprodl L phi : + L \subset 'N(K) -> L \subset 'N(H) -> 'I_L[cfDprodl KxH phi] = 'I_L[phi]. +Proof. by move=> nKL nHL; apply: inertia_sdprod. Qed. + +Lemma inertia_dprodr L psi : + L \subset 'N(K) -> L \subset 'N(H) -> 'I_L[cfDprodr KxH psi] = 'I_L[psi]. +Proof. by move=> nKL nHL; apply: inertia_sdprod. Qed. + +Lemma inertia_dprod L (phi : 'CF(K)) (psi : 'CF(H)) : + L \subset 'N(K) -> L \subset 'N(H) -> phi 1%g != 0 -> psi 1%g != 0 -> + 'I_L[cfDprod KxH phi psi] = 'I_L[phi] :&: 'I_L[psi]. +Proof. +move=> nKL nHL nz_phi nz_psi; apply/eqP; rewrite eqEsubset subsetI. +rewrite -{1}(inertia_scale_nz psi nz_phi) -{1}(inertia_scale_nz phi nz_psi). +rewrite -(cfDprod_Resl KxH) -(cfDprod_Resr KxH) !sub_inertia_Res //=. +by rewrite -inertia_dprodl -?inertia_dprodr // -setIIr setIS ?inertia_mul. +Qed. + +Lemma inertia_dprod_irr L i j : + L \subset 'N(K) -> L \subset 'N(H) -> + 'I_L[cfDprod KxH 'chi_i 'chi_j] = 'I_L['chi_i] :&: 'I_L['chi_j]. +Proof. by move=> nKL nHL; rewrite inertia_dprod ?irr1_neq0. Qed. + +End InertiaDprod. + +Section InertiaBigdprod. + +Variables (gT : finGroupType) (I : finType) (P : pred I). +Variables (A : I -> {group gT}) (G : {group gT}). +Implicit Type L : {group gT}. +Hypothesis defG : \big[dprod/1%g]_(i | P i) A i = G. + +Section ConjBig. + +Variable y : gT. +Hypothesis nAy: forall i, P i -> y \in 'N(A i). + +Lemma cfConjgBigdprodi i (phi : 'CF(A i)) : + (cfBigdprodi defG phi ^ y = cfBigdprodi defG (phi ^ y))%CF. +Proof. +rewrite cfConjgDprodl; try by case: ifP => [/nAy// | _]; rewrite norm1 inE. + congr (cfDprodl _ _); case: ifP => [Pi | _]. + by rewrite cfConjgRes_norm ?nAy. + by apply/cfun_inP=> _ /set1P->; rewrite !(cfRes1, cfConjg1). +rewrite -sub1set norms_gen ?norms_bigcup // sub1set. +by apply/bigcapP=> j /andP[/nAy]. +Qed. + +Lemma cfConjgBigdprod phi : + (cfBigdprod defG phi ^ y = cfBigdprod defG (fun i => phi i ^ y))%CF. +Proof. +by rewrite rmorph_prod /=; apply: eq_bigr => i _; apply: cfConjgBigdprodi. +Qed. + +End ConjBig. + +Section InertiaBig. + +Variable L : {group gT}. +Hypothesis nAL : forall i, P i -> L \subset 'N(A i). + +Lemma inertia_bigdprodi i (phi : 'CF(A i)) : + P i -> 'I_L[cfBigdprodi defG phi] = 'I_L[phi]. +Proof. +move=> Pi; rewrite inertia_dprodl ?Pi ?cfRes_id ?nAL //. +by apply/norms_gen/norms_bigcup/bigcapsP=> j /andP[/nAL]. +Qed. + +Lemma inertia_bigdprod phi (Phi := cfBigdprod defG phi) : + Phi 1%g != 0 -> 'I_L[Phi] = L :&: \bigcap_(i | P i) 'I_L[phi i]. +Proof. +move=> nz_Phi; apply/eqP; rewrite eqEsubset; apply/andP; split. + rewrite subsetI Inertia_sub; apply/bigcapsP=> i Pi. + have [] := cfBigdprodK nz_Phi Pi; move: (_ / _) => a nz_a <-. + by rewrite inertia_scale_nz ?sub_inertia_Res //= ?nAL. +rewrite subsetI subsetIl; apply: subset_trans (inertia_prod _ _ _). +apply: setISS. + by rewrite -(bigdprodWY defG) norms_gen ?norms_bigcup //; apply/bigcapsP. +apply/bigcapsP=> i Pi; rewrite (bigcap_min i) //. +by rewrite -inertia_bigdprodi ?subsetIr. +Qed. + +Lemma inertia_bigdprod_irr Iphi (phi := fun i => 'chi_(Iphi i)) : + 'I_L[cfBigdprod defG phi] = L :&: \bigcap_(i | P i) 'I_L[phi i]. +Proof. +rewrite inertia_bigdprod // -[cfBigdprod _ _]cfIirrE ?irr1_neq0 //. +by apply: cfBigdprod_irr => i _; apply: mem_irr. +Qed. + +End InertiaBig. + +End InertiaBigdprod. + +Section ConsttInertiaBijection. + +Variables (gT : finGroupType) (H G : {group gT}) (t : Iirr H). +Hypothesis nsHG : H <| G. + +Local Notation theta := 'chi_t. +Local Notation T := 'I_G[theta]%G. +Local Notation "` 'T'" := 'I_(gval G)[theta] + (at level 0, format "` 'T'") : group_scope. + +Let calA := irr_constt ('Ind[T] theta). +Let calB := irr_constt ('Ind[G] theta). +Local Notation AtoB := (Ind_Iirr G). + +(* This is Isaacs, Theorem (6.11). *) +Theorem constt_Inertia_bijection : + [/\ (*a*) {in calA, forall s, 'Ind[G] 'chi_s \in irr G}, + (*b*) {in calA &, injective (Ind_Iirr G)}, + Ind_Iirr G @: calA =i calB, + (*c*) {in calA, forall s (psi := 'chi_s) (chi := 'Ind[G] psi), + [predI irr_constt ('Res chi) & calA] =i pred1 s} + & (*d*) {in calA, forall s (psi := 'chi_s) (chi := 'Ind[G] psi), + '['Res psi, theta] = '['Res chi, theta]}]. +Proof. +have [sHG sTG]: H \subset G /\ T \subset G by rewrite subsetIl normal_sub. +have nsHT : H <| T := normal_Inertia theta sHG; have sHT := normal_sub nsHT. +have AtoB_P s (psi := 'chi_s) (chi := 'Ind[G] psi): s \in calA -> + [/\ chi \in irr G, AtoB s \in calB & '['Res psi, theta] = '['Res chi, theta]]. +- rewrite !constt_Ind_Res => sHt; have [r sGr] := constt_cfInd_irr s sTG. + have rTs: s \in irr_constt ('Res[T] 'chi_r) by rewrite -constt_Ind_Res. + have NrT: 'Res[T] 'chi_r \is a character by rewrite cfRes_char ?irr_char. + have rHt: t \in irr_constt ('Res[H] 'chi_r). + by have:= constt_Res_trans NrT rTs sHt; rewrite cfResRes. + pose e := '['Res[H] 'chi_r, theta]; set f := '['Res[H] psi, theta]. + have DrH: 'Res[H] 'chi_r = e *: \sum_(xi <- (theta ^: G)%CF) xi. + exact: Clifford_Res_sum_cfclass. + have DpsiH: 'Res[H] psi = f *: theta. + rewrite (Clifford_Res_sum_cfclass nsHT sHt). + by rewrite cfclass_invariant ?subsetIr ?big_seq1. + have ub_chi_r: 'chi_r 1%g <= chi 1%g ?= iff ('chi_r == chi). + have Nchi: chi \is a character by rewrite cfInd_char ?irr_char. + have [chi1 Nchi1->] := constt_charP _ Nchi sGr. + rewrite addrC cfunE -lerif_subLR subrr eq_sym -subr_eq0 addrK. + by split; rewrite ?char1_ge0 // eq_sym char1_eq0. + have lb_chi_r: chi 1%g <= 'chi_r 1%g ?= iff (f == e). + rewrite cfInd1 // -(cfRes1 H) DpsiH -(cfRes1 H 'chi_r) DrH !cfunE sum_cfunE. + rewrite (eq_big_seq (fun _ => theta 1%g)) => [|i]; last first. + by case/cfclassP=> y _ ->; rewrite cfConjg1. + rewrite reindex_cfclass //= sumr_const -(eq_card (cfclass_IirrE _ _)). + rewrite mulr_natl mulrnAr card_cfclass_Iirr //. + rewrite (mono_lerif (ler_pmuln2r (indexg_gt0 G T))). + rewrite (mono_lerif (ler_pmul2r (irr1_gt0 t))); apply: lerif_eq. + by rewrite /e -(cfResRes _ sHT) ?cfdot_Res_ge_constt. + have [_ /esym] := lerif_trans ub_chi_r lb_chi_r; rewrite eqxx. + by case/andP=> /eqP Dchi /eqP->;rewrite cfIirrE -/chi -?Dchi ?mem_irr. +have part_c: {in calA, forall s (chi := 'Ind[G] 'chi_s), + [predI irr_constt ('Res[T] chi) & calA] =i pred1 s}. +- move=> s As chi s1; have [irr_chi _ /eqP Dchi_theta] := AtoB_P s As. + have chiTs: s \in irr_constt ('Res[T] chi). + by rewrite irr_consttE cfdot_Res_l irrWnorm ?oner_eq0. + apply/andP/eqP=> [[/= chiTs1 As1] | -> //]. + apply: contraTeq Dchi_theta => s's1; rewrite ltr_eqF // -/chi. + have [|phi Nphi DchiT] := constt_charP _ _ chiTs. + by rewrite cfRes_char ?cfInd_char ?irr_char. + have [|phi1 Nphi1 Dphi] := constt_charP s1 Nphi _. + rewrite irr_consttE -(canLR (addKr _) DchiT) addrC cfdotBl cfdot_irr. + by rewrite mulrb ifN_eqC ?subr0. + rewrite -(cfResRes chi sHT sTG) DchiT Dphi !rmorphD !cfdotDl /=. + rewrite -ltr_subl_addl subrr ltr_paddr ?ltr_def //; + rewrite Cnat_ge0 ?Cnat_cfdot_char ?cfRes_char ?irr_char //. + by rewrite andbT -irr_consttE -constt_Ind_Res. +do [split=> //; try by move=> s /AtoB_P[]] => [s1 s2 As1 As2 | r]. + have [[irr_s1G _ _] [irr_s2G _ _]] := (AtoB_P _ As1, AtoB_P _ As2). + move/(congr1 (tnth (irr G))); rewrite !cfIirrE // => eq_s12_G. + apply/eqP; rewrite -[_ == _]part_c // inE /= As1 -eq_s12_G. + by rewrite -As1 [_ && _]part_c // inE /=. +apply/imsetP/idP=> [[s /AtoB_P[_ BsG _] -> //] | Br]. +have /exists_inP[s rTs As]: [exists s in irr_constt ('Res 'chi_r), s \in calA]. + rewrite -negb_forall_in; apply: contra Br => /eqfun_inP => o_tT_rT. + rewrite -(cfIndInd _ sTG sHT) -cfdot_Res_r ['Res _]cfun_sum_constt. + by rewrite cfdot_sumr big1 // => i rTi; rewrite cfdotZr o_tT_rT ?mulr0. +exists s => //; have [/irrP[r1 DsG] _ _] := AtoB_P s As. +by apply/eqP; rewrite /AtoB -constt_Ind_Res DsG irrK constt_irr in rTs *. +Qed. + +End ConsttInertiaBijection. + +Section ExtendInvariantIrr. + +Variable gT : finGroupType. +Implicit Types G H K L M N : {group gT}. + +Section ConsttIndExtendible. + +Variables (G N : {group gT}) (t : Iirr N) (c : Iirr G). +Let theta := 'chi_t. +Let chi := 'chi_c. + +Definition mul_Iirr b := cfIirr ('chi_b * chi). +Definition mul_mod_Iirr (b : Iirr (G / N)) := mul_Iirr (mod_Iirr b). + +Hypotheses (nsNG : N <| G) (cNt : 'Res[N] chi = theta). +Let sNG : N \subset G. Proof. exact: normal_sub. Qed. +Let nNG : G \subset 'N(N). Proof. exact: normal_norm. Qed. + +Lemma extendible_irr_invariant : G \subset 'I[theta]. +Proof. +apply/subsetP=> y Gy; have nNy := subsetP nNG y Gy. +rewrite inE nNy; apply/eqP/cfun_inP=> x Nx; rewrite cfConjgE // -cNt. +by rewrite !cfResE ?memJ_norm ?cfunJ ?groupV. +Qed. +Let IGtheta := extendible_irr_invariant. + +(* This is Isaacs, Theorem (6.16) *) +Theorem constt_Ind_mul_ext f (phi := 'chi_f) (psi := phi * theta) : + G \subset 'I[phi] -> psi \in irr N -> + let calS := irr_constt ('Ind phi) in + [/\ {in calS, forall b, 'chi_b * chi \in irr G}, + {in calS &, injective mul_Iirr}, + irr_constt ('Ind psi) =i [seq mul_Iirr b | b in calS] + & 'Ind psi = \sum_(b in calS) '['Ind phi, 'chi_b] *: 'chi_(mul_Iirr b)]. +Proof. +move=> IGphi irr_psi calS. +have IGpsi: G \subset 'I[psi]. + by rewrite (subset_trans _ (inertia_mul _ _)) // subsetI IGphi. +pose e b := '['Ind[G] phi, 'chi_b]; pose d b g := '['chi_b * chi, 'chi_g * chi]. +have Ne b: e b \in Cnat by rewrite Cnat_cfdot_char ?cfInd_char ?irr_char. +have egt0 b: b \in calS -> e b > 0 by rewrite Cnat_gt0. +have DphiG: 'Ind phi = \sum_(b in calS) e b *: 'chi_b := cfun_sum_constt _. +have DpsiG: 'Ind psi = \sum_(b in calS) e b *: 'chi_b * chi. + by rewrite /psi -cNt cfIndM // DphiG mulr_suml. +pose d_delta := [forall b in calS, forall g in calS, d b g == (b == g)%:R]. +have charMchi b: 'chi_b * chi \is a character by rewrite rpredM ?irr_char. +have [_]: '['Ind[G] phi] <= '['Ind[G] psi] ?= iff d_delta. + pose sum_delta := \sum_(b in calS) e b * \sum_(g in calS) e g * (b == g)%:R. + pose sum_d := \sum_(b in calS) e b * \sum_(g in calS) e g * d b g. + have ->: '['Ind[G] phi] = sum_delta. + rewrite DphiG cfdot_suml; apply: eq_bigr => b _; rewrite cfdotZl cfdot_sumr. + by congr (_ * _); apply: eq_bigr => g; rewrite cfdotZr cfdot_irr conj_Cnat. + have ->: '['Ind[G] psi] = sum_d. + rewrite DpsiG cfdot_suml; apply: eq_bigr => b _. + rewrite -scalerAl cfdotZl cfdot_sumr; congr (_ * _). + by apply: eq_bigr => g _; rewrite -scalerAl cfdotZr conj_Cnat. + have eMmono := mono_lerif (ler_pmul2l (egt0 _ _)). + apply: lerif_sum => b /eMmono->; apply: lerif_sum => g /eMmono->. + split; last exact: eq_sym. + have /CnatP[n Dd]: d b g \in Cnat by rewrite Cnat_cfdot_char. + have [Db | _] := eqP; rewrite Dd leC_nat // -ltC_nat -Dd Db cfnorm_gt0. + by rewrite -char1_eq0 // cfunE mulf_neq0 ?irr1_neq0. +rewrite -!cfdot_Res_l ?cfRes_Ind_invariant // !cfdotZl cfnorm_irr irrWnorm //. +rewrite eqxx => /esym/forall_inP/(_ _ _)/eqfun_inP; rewrite /d /= => Dd. +have irrMchi: {in calS, forall b, 'chi_b * chi \in irr G}. + by move=> b Sb; rewrite /= irrEchar charMchi Dd ?eqxx. +have injMchi: {in calS &, injective mul_Iirr}. + move=> b g Sb Sg /(congr1 (fun s => '['chi_s, 'chi_(mul_Iirr g)]))/eqP. + by rewrite cfnorm_irr !cfIirrE ?irrMchi ?Dd // pnatr_eq1; case: (b =P g). +have{DpsiG} ->: 'Ind psi = \sum_(b in calS) e b *: 'chi_(mul_Iirr b). + by rewrite DpsiG; apply: eq_bigr => b Sb; rewrite -scalerAl cfIirrE ?irrMchi. +split=> // i; rewrite irr_consttE cfdot_suml; +apply/idP/idP=> [|/imageP[b Sb ->]]. + apply: contraR => N'i; rewrite big1 // => b Sb. + rewrite cfdotZl cfdot_irr mulrb ifN_eqC ?mulr0 //. + by apply: contraNneq N'i => ->; apply: image_f. +rewrite gtr_eqF // (bigD1 b) //= cfdotZl cfnorm_irr mulr1 ltr_paddr ?egt0 //. +apply: sumr_ge0 => g /andP[Sg _]; rewrite cfdotZl cfdot_irr. +by rewrite mulr_ge0 ?ler0n ?Cnat_ge0. +Qed. + +(* This is Isaacs, Corollary (6.17) (due to Gallagher). *) +Corollary constt_Ind_ext : + [/\ forall b : Iirr (G / N), 'chi_(mod_Iirr b) * chi \in irr G, + injective mul_mod_Iirr, + irr_constt ('Ind theta) =i codom mul_mod_Iirr + & 'Ind theta = \sum_b 'chi_b 1%g *: 'chi_(mul_mod_Iirr b)]. +Proof. +have IHchi0: G \subset 'I['chi[N]_0] by rewrite inertia_irr0. +have [] := constt_Ind_mul_ext IHchi0; rewrite irr0 ?mul1r ?mem_irr //. +set psiG := 'Ind 1 => irrMchi injMchi constt_theta {2}->. +have dot_psiG b: '[psiG, 'chi_(mod_Iirr b)] = 'chi[G / N]_b 1%g. + rewrite mod_IirrE // -cfdot_Res_r cfRes_sub_ker ?cfker_mod //. + by rewrite cfdotZr cfnorm1 mulr1 conj_Cnat ?cfMod1 ?Cnat_irr1. +have mem_psiG (b : Iirr (G / N)): mod_Iirr b \in irr_constt psiG. + by rewrite irr_consttE dot_psiG irr1_neq0. +have constt_psiG b: (b \in irr_constt psiG) = (N \subset cfker 'chi_b). + apply/idP/idP=> [psiGb | /quo_IirrK <- //]. + by rewrite constt0_Res_cfker // -constt_Ind_Res irr0. +split=> [b | b g /injMchi/(can_inj (mod_IirrK nsNG))-> // | b0 | ]. +- exact: irrMchi. +- rewrite constt_theta. + apply/imageP/imageP=> [][b psiGb ->]; last by exists (mod_Iirr b). + by exists (quo_Iirr N b) => //; rewrite /mul_mod_Iirr quo_IirrK -?constt_psiG. +rewrite (reindex_onto _ _ (in1W (mod_IirrK nsNG))) /=. +apply/esym/eq_big => b; first by rewrite constt_psiG quo_IirrKeq. +by rewrite -dot_psiG /mul_mod_Iirr => /eqP->. +Qed. + +End ConsttIndExtendible. + +(* This is Isaacs, Theorem (6.19). *) +Theorem invariant_chief_irr_cases G K L s (theta := 'chi[K]_s) : + chief_factor G L K -> abelian (K / L) -> G \subset 'I[theta] -> + let t := #|K : L| in + [\/ 'Res[L] theta \in irr L, + exists2 e, exists p, 'Res[L] theta = e%:R *: 'chi_p & (e ^ 2)%N = t + | exists2 p, injective p & 'Res[L] theta = \sum_(i < t) 'chi_(p i)]. +Proof. +case/andP=> /maxgroupP[/andP[ltLK nLG] maxL] nsKG abKbar IGtheta t. +have [sKG nKG] := andP nsKG; have sLG := subset_trans (proper_sub ltLK) sKG. +have nsLG: L <| G by apply/andP. +have nsLK := normalS (proper_sub ltLK) sKG nsLG; have [sLK nLK] := andP nsLK. +have [p0 sLp0] := constt_cfRes_irr L s; rewrite -/theta in sLp0. +pose phi := 'chi_p0; pose T := 'I_G[phi]. +have sTG: T \subset G := subsetIl G _. +have /eqP mulKT: (K * T)%g == G. + rewrite eqEcard mulG_subG sKG sTG -LagrangeMr -indexgI -(Lagrange sTG) /= -/T. + rewrite mulnC leq_mul // setIA (setIidPl sKG) -!size_cfclass // -/phi. + rewrite uniq_leq_size ?cfclass_uniq // => _ /cfclassP[x Gx ->]. + have: conjg_Iirr p0 x \in irr_constt ('Res theta). + have /inertiaJ <-: x \in 'I[theta] := subsetP IGtheta x Gx. + by rewrite -(cfConjgRes _ nsKG) // irr_consttE conjg_IirrE // cfConjg_iso. + apply: contraR; rewrite -conjg_IirrE // => not_sLp0x. + rewrite (Clifford_Res_sum_cfclass nsLK sLp0) cfdotZl cfdot_suml. + rewrite big1_seq ?mulr0 // => _ /cfclassP[y Ky ->]; rewrite -conjg_IirrE //. + rewrite cfdot_irr mulrb ifN_eq ?(contraNneq _ not_sLp0x) // => <-. + by rewrite conjg_IirrE //; apply/cfclassP; exists y. +have nsKT_G: K :&: T <| G. + rewrite /normal subIset ?sKG // -mulKT setIA (setIidPl sKG) mulG_subG. + rewrite normsIG // sub_der1_norm ?subsetIl //. + exact: subset_trans (der1_min nLK abKbar) (sub_Inertia _ sLK). +have [e DthL]: exists e, 'Res theta = e%:R *: \sum_(xi <- (phi ^: K)%CF) xi. + rewrite (Clifford_Res_sum_cfclass nsLK sLp0) -/phi; set e := '[_, _]. + by exists (truncC e); rewrite truncCK ?Cnat_cfdot_char ?cfRes_char ?irr_char. +have [defKT | ltKT_K] := eqVneq (K :&: T) K; last first. + have defKT: K :&: T = L. + apply: maxL; last by rewrite subsetI sLK sub_Inertia. + by rewrite normal_norm // properEneq ltKT_K subsetIl. + have t_cast: size (phi ^: K)%CF = t. + by rewrite size_cfclass //= -{2}(setIidPl sKG) -setIA defKT. + pose phiKt := Tuple (introT eqP t_cast); pose p i := cfIirr (tnth phiKt i). + have pK i: 'chi_(p i) = (phi ^: K)%CF`_i. + rewrite cfIirrE; first by rewrite (tnth_nth 0). + by have /cfclassP[y _ ->] := mem_tnth i phiKt; rewrite cfConjg_irr ?mem_irr. + constructor 3; exists p => [i j /(congr1 (tnth (irr L)))/eqP| ]. + by apply: contraTeq; rewrite !pK !nth_uniq ?t_cast ?cfclass_uniq. + have{DthL} DthL: 'Res theta = e%:R *: \sum_(i < t) (phi ^: K)%CF`_i. + by rewrite DthL (big_nth 0) big_mkord t_cast. + suffices /eqP e1: e == 1%N by rewrite DthL e1 scale1r; apply: eq_bigr. + have Dth1: theta 1%g = e%:R * t%:R * phi 1%g. + rewrite -[t]card_ord -mulrA -(cfRes1 L) DthL cfunE; congr (_ * _). + rewrite mulr_natl -sumr_const sum_cfunE -t_cast; apply: eq_bigr => i _. + by have /cfclassP[y _ ->] := mem_nth 0 (valP i); rewrite cfConjg1. + rewrite eqn_leq lt0n (contraNneq _ (irr1_neq0 s)); last first. + by rewrite Dth1 => ->; rewrite !mul0r. + rewrite -leC_nat -(ler_pmul2r (gt0CiG K L)) -/t -(ler_pmul2r (irr1_gt0 p0)). + rewrite mul1r -Dth1 -cfInd1 //. + by rewrite char1_ge_constt ?cfInd_char ?irr_char ?constt_Ind_Res. +have IKphi: 'I_K[phi] = K by rewrite -{1}(setIidPl sKG) -setIA. +have{DthL} DthL: 'Res[L] theta = e%:R *: phi. + by rewrite DthL -[rhs in (_ ^: rhs)%CF]IKphi cfclass_inertia big_seq1. +pose mmLth := @mul_mod_Iirr K L s. +have linKbar := char_abelianP _ abKbar. +have LmodL i: ('chi_i %% L)%CF \is a linear_char := cfMod_lin_char (linKbar i). +have mmLthE i: 'chi_(mmLth i) = ('chi_i %% L)%CF * theta. + by rewrite cfIirrE ?mod_IirrE // mul_lin_irr ?mem_irr. +have mmLthL i: 'Res[L] 'chi_(mmLth i) = 'Res[L] theta. + rewrite mmLthE rmorphM /= cfRes_sub_ker ?cfker_mod ?lin_char1 //. + by rewrite scale1r mul1r. +have [inj_Mphi | /injectivePn[i [j i'j eq_mm_ij]]] := boolP (injectiveb mmLth). + suffices /eqP e1: e == 1%N by constructor 1; rewrite DthL e1 scale1r mem_irr. + rewrite eqn_leq lt0n (contraNneq _ (irr1_neq0 s)); last first. + by rewrite -(cfRes1 L) DthL cfunE => ->; rewrite !mul0r. + rewrite -leq_sqr -leC_nat natrX -(ler_pmul2r (irr1_gt0 p0)) -mulrA mul1r. + have ->: e%:R * 'chi_p0 1%g = 'Res[L] theta 1%g by rewrite DthL cfunE. + rewrite cfRes1 -(ler_pmul2l (gt0CiG K L)) -cfInd1 // -/phi. + rewrite -card_quotient // -card_Iirr_abelian // mulr_natl. + rewrite ['Ind phi]cfun_sum_cfdot sum_cfunE (bigID (mem (codom mmLth))) /=. + rewrite ler_paddr ?sumr_ge0 // => [i _|]. + by rewrite char1_ge0 ?rpredZ_Cnat ?Cnat_cfdot_char ?cfInd_char ?irr_char. + rewrite -big_uniq //= big_map big_filter -sumr_const ler_sum // => i _. + rewrite cfunE -[in rhs in _ <= rhs](cfRes1 L) -cfdot_Res_r mmLthL cfRes1. + by rewrite DthL cfdotZr rmorph_nat cfnorm_irr mulr1. +constructor 2; exists e; first by exists p0. +pose mu := (('chi_i / 'chi_j)%R %% L)%CF; pose U := cfker mu. +have lin_mu: mu \is a linear_char by rewrite cfMod_lin_char ?rpred_div. +have Uj := lin_char_unitr (linKbar j). +have ltUK: U \proper K. + rewrite /proper cfker_sub /U; have /irrP[k Dmu] := lin_char_irr lin_mu. + rewrite Dmu subGcfker -irr_eq1 -Dmu cfMod_eq1 //. + by rewrite (can2_eq (divrK Uj) (mulrK Uj)) mul1r (inj_eq irr_inj). +suffices: theta \in 'CF(K, L). + rewrite -cfnorm_Res_lerif // DthL cfnormZ !cfnorm_irr !mulr1 normr_nat. + by rewrite -natrX eqC_nat => /eqP. +have <-: gcore U G = L. + apply: maxL; last by rewrite sub_gcore ?cfker_mod. + by rewrite gcore_norm (sub_proper_trans (gcore_sub _ _)). +apply/cfun_onP=> x; apply: contraNeq => nz_th_x. +apply/bigcapP=> y /(subsetP IGtheta)/setIdP[nKy /eqP th_y]. +apply: contraR nz_th_x; rewrite mem_conjg -{}th_y cfConjgE {nKy}//. +move: {x y}(x ^ _) => x U'x; have [Kx | /cfun0-> //] := boolP (x \in K). +have /eqP := congr1 (fun k => (('chi_j %% L)%CF^-1 * 'chi_k) x) eq_mm_ij. +rewrite -rmorphV // !mmLthE !mulrA -!rmorphM mulVr //= rmorph1 !cfunE. +rewrite (mulrC _^-1) -/mu -subr_eq0 -mulrBl cfun1E Kx mulf_eq0 => /orP[]//. +rewrite mulrb subr_eq0 -(lin_char1 lin_mu) [_ == _](contraNF _ U'x) //. +by rewrite /U cfkerEchar ?lin_charW // inE Kx. +Qed. + +(* This is Isaacs, Corollary (6.19). *) +Corollary cfRes_prime_irr_cases G N s p (chi := 'chi[G]_s) : + N <| G -> #|G : N| = p -> prime p -> + [\/ 'Res[N] chi \in irr N + | exists2 c, injective c & 'Res[N] chi = \sum_(i < p) 'chi_(c i)]. +Proof. +move=> /andP[sNG nNG] iGN pr_p. +have chiefGN: chief_factor G N G. + apply/andP; split=> //; apply/maxgroupP. + split=> [|M /andP[/andP[sMG ltMG] _] sNM]. + by rewrite /proper sNG -indexg_gt1 iGN prime_gt1. + apply/esym/eqP; rewrite eqEsubset sNM -indexg_eq1 /= eq_sym. + rewrite -(eqn_pmul2l (indexg_gt0 G M)) muln1 Lagrange_index // iGN. + by apply/eqP/prime_nt_dvdP; rewrite ?indexg_eq1 // -iGN indexgS. +have abGbar: abelian (G / N). + by rewrite cyclic_abelian ?prime_cyclic ?card_quotient ?iGN. +have IGchi: G \subset 'I[chi] by apply: sub_inertia. +have [] := invariant_chief_irr_cases chiefGN abGbar IGchi; first by left. + case=> e _ /(congr1 (fun m => odd (logn p m)))/eqP/idPn[]. + by rewrite lognX mul2n odd_double iGN logn_prime // eqxx. +by rewrite iGN; right. +Qed. + +(* This is Isaacs, Corollary (6.20). *) +Corollary prime_invariant_irr_extendible G N s p : + N <| G -> #|G : N| = p -> prime p -> G \subset 'I['chi_s] -> + {t | 'Res[N, G] 'chi_t = 'chi_s}. +Proof. +move=> nsNG iGN pr_p IGchi. +have [t sGt] := constt_cfInd_irr s (normal_sub nsNG); exists t. +have [e DtN]: exists e, 'Res 'chi_t = e%:R *: 'chi_s. + rewrite constt_Ind_Res in sGt. + rewrite (Clifford_Res_sum_cfclass nsNG sGt); set e := '[_, _]. + rewrite cfclass_invariant // big_seq1. + by exists (truncC e); rewrite truncCK ?Cnat_cfdot_char ?cfRes_char ?irr_char. +have [/irrWnorm/eqP | [c injc DtNc]] := cfRes_prime_irr_cases t nsNG iGN pr_p. + rewrite DtN cfnormZ cfnorm_irr normr_nat mulr1 -natrX pnatr_eq1. + by rewrite muln_eq1 andbb => /eqP->; rewrite scale1r. +have nz_e: e != 0%N. + have: 'Res[N] 'chi_t != 0 by rewrite cfRes_eq0 // ?irr_char ?irr_neq0. + by rewrite DtN; apply: contraNneq => ->; rewrite scale0r. +have [i s'ci]: exists i, c i != s. + pose i0 := Ordinal (prime_gt0 pr_p); pose i1 := Ordinal (prime_gt1 pr_p). + have [<- | ] := eqVneq (c i0) s; last by exists i0. + by exists i1; rewrite (inj_eq injc). +have /esym/eqP/idPn[] := congr1 (cfdotr 'chi_(c i)) DtNc; rewrite {1}DtN /=. +rewrite cfdot_suml cfdotZl cfdot_irr mulrb ifN_eqC // mulr0. +rewrite (bigD1 i) //= cfnorm_irr big1 ?addr0 ?oner_eq0 // => j i'j. +by rewrite cfdot_irr mulrb ifN_eq ?(inj_eq injc). +Qed. + +(* This is Isaacs, Lemma (6.24). *) +Lemma extend_to_cfdet G N s c0 u : + let theta := 'chi_s in let lambda := cfDet theta in let mu := 'chi_u in + N <| G -> coprime #|G : N| (truncC (theta 1%g)) -> + 'Res[N, G] 'chi_c0 = theta -> 'Res[N, G] mu = lambda -> + exists2 c, 'Res 'chi_c = theta /\ cfDet 'chi_c = mu + & forall c1, 'Res 'chi_c1 = theta -> cfDet 'chi_c1 = mu -> c1 = c. +Proof. +move=> theta lambda mu nsNG; set e := #|G : N|; set f := truncC _. +set eta := 'chi_c0 => co_e_f etaNth muNlam; have [sNG nNG] := andP nsNG. +have fE: f%:R = theta 1%g by rewrite truncCK ?Cnat_irr1. +pose nu := cfDet eta; have lin_nu: nu \is a linear_char := cfDet_lin_char _. +have nuNlam: 'Res nu = lambda by rewrite -cfDetRes ?irr_char ?etaNth. +have lin_lam: lambda \is a linear_char := cfDet_lin_char _. +have lin_mu: mu \is a linear_char. + by have:= lin_lam; rewrite -muNlam; apply: cfRes_lin_lin; apply: irr_char. +have [Unu Ulam] := (lin_char_unitr lin_nu, lin_char_unitr lin_lam). +pose alpha := mu / nu. +have alphaN_1: 'Res[N] alpha = 1 by rewrite rmorph_div //= muNlam nuNlam divrr. +have lin_alpha: alpha \is a linear_char by apply: rpred_div. +have alpha_e: alpha ^+ e = 1. + have kerNalpha: N \subset cfker alpha. + by rewrite -subsetIidl -cfker_Res ?lin_charW // alphaN_1 cfker_cfun1. + apply/eqP; rewrite -(cfQuoK nsNG kerNalpha) -rmorphX cfMod_eq1 //. + rewrite -dvdn_cforder /e -card_quotient //. + by rewrite cforder_lin_char_dvdG ?cfQuo_lin_char. +have det_alphaXeta b: cfDet (alpha ^+ b * eta) = alpha ^+ (b * f) * nu. + by rewrite cfDet_mul_lin ?rpredX ?irr_char // -exprM -(cfRes1 N) etaNth. +have [b bf_mod_e]: exists b, b * f = 1 %[mod e]. + rewrite -(chinese_modl co_e_f 1 0) /chinese !mul0n addn0 !mul1n mulnC. + by exists (egcdn f e).1. +have alpha_bf: alpha ^+ (b * f) = alpha. + by rewrite -(expr_mod _ alpha_e) bf_mod_e expr_mod. +have /irrP[c Dc]: alpha ^+ b * eta \in irr G. + by rewrite mul_lin_irr ?rpredX ?mem_irr. +have chiN: 'Res 'chi_c = theta. + by rewrite -Dc rmorphM rmorphX /= alphaN_1 expr1n mul1r. +have det_chi: cfDet 'chi_c = mu by rewrite -Dc det_alphaXeta alpha_bf divrK. +exists c => // c2 c2Nth det_c2_mu; apply: irr_inj. +have [irrMc _ imMc _] := constt_Ind_ext nsNG chiN. +have /codomP[s2 Dc2]: c2 \in codom (@mul_mod_Iirr G N c). + by rewrite -imMc constt_Ind_Res c2Nth constt_irr ?inE. +have{Dc2} Dc2: 'chi_c2 = ('chi_s2 %% N)%CF * 'chi_c. + by rewrite Dc2 cfIirrE // mod_IirrE. +have s2_lin: 'chi_s2 \is a linear_char. + rewrite qualifE irr_char; apply/eqP/(mulIf (irr1_neq0 c)). + rewrite mul1r -[in rhs in _ = rhs](cfRes1 N) chiN -c2Nth cfRes1. + by rewrite Dc2 cfunE cfMod1. +have s2Xf_1: 'chi_s2 ^+ f = 1. + apply/(can_inj (cfModK nsNG))/(mulIr (lin_char_unitr lin_mu))/esym. + rewrite rmorph1 rmorphX /= mul1r -{1}det_c2_mu Dc2 -det_chi. + by rewrite cfDet_mul_lin ?cfMod_lin_char ?irr_char // -(cfRes1 N) chiN. +suffices /eqP s2_1: 'chi_s2 == 1 by rewrite Dc2 s2_1 rmorph1 mul1r. +rewrite -['chi_s2]expr1 -dvdn_cforder -(eqnP co_e_f) dvdn_gcd. +by rewrite /e -card_quotient ?cforder_lin_char_dvdG //= dvdn_cforder s2Xf_1. +Qed. + +(* This is Isaacs, Theorem (6.25). *) +Theorem solvable_irr_extendible_from_det G N s (theta := 'chi[N]_s) : + N <| G -> solvable (G / N) -> + G \subset 'I[theta] -> coprime #|G : N| (truncC (theta 1%g)) -> + [exists c, 'Res 'chi[G]_c == theta] + = [exists u, 'Res 'chi[G]_u == cfDet theta]. +Proof. +set e := #|G : N|; set f := truncC _ => nsNG solG IGtheta co_e_f. +apply/exists_eqP/exists_eqP=> [[c cNth] | [u uNdth]]. + have /lin_char_irr/irrP[u Du] := cfDet_lin_char 'chi_c. + by exists u; rewrite -Du -cfDetRes ?irr_char ?cNth. +move: {2}e.+1 (ltnSn e) => m. +elim: m => // m IHm in G u e nsNG solG IGtheta co_e_f uNdth *. +rewrite ltnS => le_e; have [sNG nNG] := andP nsNG. +have [<- | ltNG] := eqsVneq N G; first by exists s; rewrite cfRes_id. +have [G0 maxG0 sNG0]: {G0 | maxnormal (gval G0) G G & N \subset G0}. + by apply: maxgroup_exists; rewrite properEneq ltNG sNG. +have [/andP[ltG0G nG0G] maxG0_P] := maxgroupP maxG0. +set mu := 'chi_u in uNdth; have lin_mu: mu \is a linear_char. + by rewrite qualifE irr_char -(cfRes1 N) uNdth /= lin_char1 ?cfDet_lin_char. +have sG0G := proper_sub ltG0G; have nsNG0 := normalS sNG0 sG0G nsNG. +have nsG0G: G0 <| G by apply/andP. +have /lin_char_irr/irrP[u0 Du0] := cfRes_lin_char G0 lin_mu. +have u0Ndth: 'Res 'chi_u0 = cfDet theta by rewrite -Du0 cfResRes. +have IG0theta: G0 \subset 'I[theta]. + by rewrite (subset_trans sG0G) // -IGtheta subsetIr. +have coG0f: coprime #|G0 : N| f by rewrite (coprime_dvdl _ co_e_f) ?indexSg. +have{m IHm le_e} [c0 c0Ns]: exists c0, 'Res 'chi[G0]_c0 = theta. + have solG0: solvable (G0 / N) := solvableS (quotientS N sG0G) solG. + apply: IHm nsNG0 solG0 IG0theta coG0f u0Ndth (leq_trans _ le_e). + by rewrite -(ltn_pmul2l (cardG_gt0 N)) !Lagrange ?proper_card. +have{c0 c0Ns} [c0 [c0Ns dc0_u0] Uc0] := extend_to_cfdet nsNG0 coG0f c0Ns u0Ndth. +have IGc0: G \subset 'I['chi_c0]. + apply/subsetP=> x Gx; rewrite inE (subsetP nG0G) //= -conjg_IirrE. + apply/eqP; congr 'chi__; apply: Uc0; rewrite conjg_IirrE. + by rewrite -(cfConjgRes _ nsG0G nsNG) // c0Ns inertiaJ ?(subsetP IGtheta). + by rewrite cfDetConjg dc0_u0 -Du0 (cfConjgRes _ _ nsG0G) // cfConjg_id. +have prG0G: prime #|G : G0|. + have [h injh im_h] := third_isom sNG0 nsNG nsG0G. + rewrite -card_quotient // -im_h // card_injm //. + rewrite simple_sol_prime 1?quotient_sol //. + by rewrite /simple -(injm_minnormal injh) // im_h // maxnormal_minnormal. +have [t tG0c0] := prime_invariant_irr_extendible nsG0G (erefl _) prG0G IGc0. +by exists t; rewrite /theta -c0Ns -tG0c0 cfResRes. +Qed. + +(* This is Isaacs, Theorem (6.26). *) +Theorem extend_linear_char_from_Sylow G N (lambda : 'CF(N)) : + N <| G -> lambda \is a linear_char -> G \subset 'I[lambda] -> + (forall p, p \in \pi('o(lambda)%CF) -> + exists2 Hp : {group gT}, + [/\ N \subset Hp, Hp \subset G & p.-Sylow(G / N) (Hp / N)%g] + & exists u, 'Res 'chi[Hp]_u = lambda) -> + exists u, 'Res[N, G] 'chi_u = lambda. +Proof. +set m := 'o(lambda)%CF => nsNG lam_lin IGlam p_ext_lam. +have [sNG nNG] := andP nsNG; have linN := @cfRes_lin_lin _ _ N. +wlog [p p_lam]: lambda @m lam_lin IGlam p_ext_lam / + exists p : nat, \pi(m) =i (p : nat_pred). +- move=> IHp; have [linG [cf [inj_cf _ lin_cf onto_cf]]] := lin_char_group N. + case=> cf1 cfM cfX _ cf_order; have [lam cf_lam] := onto_cf _ lam_lin. + pose mu p := cf lam.`_p; pose pi_m p := p \in \pi(m). + have Dm: m = #[lam] by rewrite /m cfDet_order_lin // cf_lam cf_order. + have Dlambda: lambda = \prod_(p < m.+1 | pi_m p) mu p. + rewrite -(big_morph cf cfM cf1) big_mkcond cf_lam /pi_m Dm; congr (cf _). + rewrite -{1}[lam]prod_constt big_mkord; apply: eq_bigr => p _. + by case: ifPn => // p'lam; apply/constt1P; rewrite /p_elt p'natEpi. + have lin_mu p: mu p \is a linear_char by rewrite /mu cfX -cf_lam rpredX. + suffices /fin_all_exists [u uNlam] (p : 'I_m.+1): + exists u, pi_m p -> 'Res[N, G] 'chi_u = mu p. + - pose nu := \prod_(p < m.+1 | pi_m p) 'chi_(u p). + have lin_nu: nu \is a linear_char. + by apply: rpred_prod => p m_p; rewrite linN ?irr_char ?uNlam. + have /irrP[u1 Dnu] := lin_char_irr lin_nu. + by exists u1; rewrite Dlambda -Dnu rmorph_prod; apply: eq_bigr. + have [m_p | _] := boolP (pi_m p); last by exists 0. + have o_mu: \pi('o(mu p)%CF) =i (p : nat_pred). + rewrite cfDet_order_lin // cf_order orderE /=. + have [|pr_p _ [k ->]] := pgroup_pdiv (p_elt_constt p lam). + by rewrite cycle_eq1 (sameP eqP constt1P) /p_elt p'natEpi // negbK -Dm. + by move=> q; rewrite pi_of_exp // pi_of_prime. + have IGmu: G \subset 'I[mu p]. + rewrite (subset_trans IGlam) // /mu cfX -cf_lam. + elim: (chinese _ _ _ _) => [|k IHk]; first by rewrite inertia1 norm_inertia. + by rewrite exprS (subset_trans _ (inertia_mul _ _)) // subsetIidl. + have [q||u] := IHp _ (lin_mu p) IGmu; [ | by exists p | by exists u]. + rewrite o_mu => /eqnP-> {q}. + have [Hp sylHp [u uNlam]] := p_ext_lam p m_p; exists Hp => //. + rewrite /mu cfX -cf_lam -uNlam -rmorphX /=; set nu := _ ^+ _. + have /lin_char_irr/irrP[v ->]: nu \is a linear_char; last by exists v. + by rewrite rpredX // linN ?irr_char ?uNlam. +have pi_m_p: p \in \pi(m) by rewrite p_lam !inE. +have [pr_p mgt0]: prime p /\ (m > 0)%N. + by have:= pi_m_p; rewrite mem_primes => /and3P[]. +have p_m: p.-nat m by rewrite -(eq_pnat _ p_lam) pnat_pi. +have{p_ext_lam} [H [sNH sHG sylHbar] [v vNlam]] := p_ext_lam p pi_m_p. +have co_p_GH: coprime p #|G : H|. + rewrite -(index_quotient_eq _ sHG nNG) ?subIset ?sNH ?orbT //. + by rewrite (pnat_coprime (pnat_id pr_p)) //; have [] := and3P sylHbar. +have lin_v: 'chi_v \is a linear_char by rewrite linN ?irr_char ?vNlam. +pose nuG := 'Ind[G] 'chi_v. +have [c vGc co_p_f]: exists2 c, c \in irr_constt nuG & ~~ (p %| 'chi_c 1%g)%C. + apply/exists_inP; rewrite -negb_forall_in. + apply: contraL co_p_GH => /forall_inP p_dv_v1. + rewrite prime_coprime // negbK -dvdC_nat -[rhs in (_ %| rhs)%C]mulr1. + rewrite -(lin_char1 lin_v) -cfInd1 // ['Ind _]cfun_sum_constt /=. + rewrite sum_cfunE rpred_sum // => i /p_dv_v1 p_dv_chi1i. + rewrite cfunE dvdC_mull // rpred_Cnat //. + by rewrite Cnat_cfdot_char ?cfInd_char ?irr_char. +pose f := truncC ('chi_c 1%g); pose b := (egcdn f m).1. +have fK: f%:R = 'chi_c 1%g by rewrite truncCK ?Cnat_irr1. +have fb_mod_m: f * b = 1 %[mod m]. + have co_m_f: coprime m f. + by rewrite (pnat_coprime p_m) ?p'natE // -dvdC_nat CdivE fK. + by rewrite -(chinese_modl co_m_f 1 0) /chinese !mul0n addn0 mul1n. +have /irrP[s Dlam] := lin_char_irr lam_lin. +have cHv: v \in irr_constt ('Res[H] 'chi_c) by rewrite -constt_Ind_Res. +have{cHv} cNs: s \in irr_constt ('Res[N] 'chi_c). + rewrite -(cfResRes _ sNH) ?(constt_Res_trans _ cHv) ?cfRes_char ?irr_char //. + by rewrite vNlam Dlam constt_irr !inE. +have DcN: 'Res[N] 'chi_c = lambda *+ f. + have:= Clifford_Res_sum_cfclass nsNG cNs. + rewrite cfclass_invariant -Dlam // big_seq1 Dlam => DcN. + have:= cfRes1 N 'chi_c; rewrite DcN cfunE -Dlam lin_char1 // mulr1 => ->. + by rewrite -scaler_nat fK. +have /lin_char_irr/irrP[d Dd]: cfDet 'chi_c ^+ b \is a linear_char. + by rewrite rpredX // cfDet_lin_char. +exists d; rewrite -{}Dd rmorphX /= -cfDetRes ?irr_char // DcN. +rewrite cfDetMn ?lin_charW // -exprM cfDet_id //. +rewrite -(expr_mod _ (exp_cforder _)) -cfDet_order_lin // -/m. +by rewrite fb_mod_m /m cfDet_order_lin // expr_mod ?exp_cforder. +Qed. + +(* This is Isaacs, Corollary (6.27). *) +Corollary extend_coprime_linear_char G N (lambda : 'CF(N)) : + N <| G -> lambda \is a linear_char -> G \subset 'I[lambda] -> + coprime #|G : N| 'o(lambda)%CF -> + exists u, [/\ 'Res 'chi[G]_u = lambda, 'o('chi_u)%CF = 'o(lambda)%CF + & forall v, + 'Res 'chi_v = lambda -> coprime #|G : N| 'o('chi_v)%CF -> + v = u]. +Proof. +set e := #|G : N| => nsNG lam_lin IGlam co_e_lam; have [sNG nNG] := andP nsNG. +have [p lam_p | v vNlam] := extend_linear_char_from_Sylow nsNG lam_lin IGlam. + exists N; last first. + by have /irrP[u ->] := lin_char_irr lam_lin; exists u; rewrite cfRes_id. + split=> //; rewrite trivg_quotient /pHall sub1G pgroup1 indexg1. + rewrite card_quotient //= -/e (pi'_p'nat _ lam_p) //. + rewrite -coprime_pi' ?indexg_gt0 1?coprime_sym //. + by have:= lam_p; rewrite mem_primes => /and3P[]. +set nu := 'chi_v in vNlam. +have lin_nu: nu \is a linear_char. + by rewrite (@cfRes_lin_lin _ _ N) ?vNlam ?irr_char. +have [b be_mod_lam]: exists b, b * e = 1 %[mod 'o(lambda)%CF]. + rewrite -(chinese_modr co_e_lam 0 1) /chinese !mul0n !mul1n mulnC. + by set b := _.1; exists b. +have /irrP[u Du]: nu ^+ (b * e) \in irr G by rewrite lin_char_irr ?rpredX. +exists u; set mu := 'chi_u in Du *. +have uNlam: 'Res mu = lambda. + rewrite cfDet_order_lin // in be_mod_lam. + rewrite -Du rmorphX /= vNlam -(expr_mod _ (exp_cforder _)) //. + by rewrite be_mod_lam expr_mod ?exp_cforder. +have lin_mu: mu \is a linear_char by rewrite -Du rpredX. +have o_mu: ('o(mu) = 'o(lambda))%CF. + have dv_o_lam_mu: 'o(lambda)%CF %| 'o(mu)%CF. + by rewrite !cfDet_order_lin // -uNlam cforder_Res. + have kerNnu_olam: N \subset cfker (nu ^+ 'o(lambda)%CF). + rewrite -subsetIidl -cfker_Res ?rpredX ?irr_char //. + by rewrite rmorphX /= vNlam cfDet_order_lin // exp_cforder cfker_cfun1. + apply/eqP; rewrite eqn_dvd dv_o_lam_mu andbT cfDet_order_lin //. + rewrite dvdn_cforder -Du exprAC -dvdn_cforder dvdn_mull //. + rewrite -(cfQuoK nsNG kerNnu_olam) cforder_mod // /e -card_quotient //. + by rewrite cforder_lin_char_dvdG ?cfQuo_lin_char ?rpredX. +split=> // t tNlam co_e_t. +have lin_t: 'chi_t \is a linear_char. + by rewrite (@cfRes_lin_lin _ _ N) ?tNlam ?irr_char. +have Ut := lin_char_unitr lin_t. +have kerN_mu_t: N \subset cfker (mu / 'chi_t)%R. + rewrite -subsetIidl -cfker_Res ?lin_charW ?rpred_div ?rmorph_div //. + by rewrite /= uNlam tNlam divrr ?lin_char_unitr ?cfker_cfun1. +have co_e_mu_t: coprime e #[(mu / 'chi_t)%R]%CF. + suffices dv_o_mu_t: #[(mu / 'chi_t)%R]%CF %| 'o(mu)%CF * 'o('chi_t)%CF. + by rewrite (coprime_dvdr dv_o_mu_t) // coprime_mulr o_mu co_e_lam. + rewrite !cfDet_order_lin //; apply/dvdn_cforderP=> x Gx. + rewrite invr_lin_char // !cfunE exprMn -rmorphX {2}mulnC. + by rewrite !(dvdn_cforderP _) ?conjC1 ?mulr1 // dvdn_mulr. +have /eqP mu_t_1: mu / 'chi_t == 1. + rewrite -(dvdn_cforder (_ / _)%R 1) -(eqnP co_e_mu_t) dvdn_gcd dvdnn andbT. + rewrite -(cfQuoK nsNG kerN_mu_t) cforder_mod // /e -card_quotient //. + by rewrite cforder_lin_char_dvdG ?cfQuo_lin_char ?rpred_div. +by apply: irr_inj; rewrite -['chi_t]mul1r -mu_t_1 divrK. +Qed. + +(* This is Isaacs, Corollary (6.28). *) +Corollary extend_solvable_coprime_irr G N t (theta := 'chi[N]_t) : + N <| G -> solvable (G / N) -> G \subset 'I[theta] -> + coprime #|G : N| ('o(theta)%CF * truncC (theta 1%g)) -> + exists c, [/\ 'Res 'chi[G]_c = theta, 'o('chi_c)%CF = 'o(theta)%CF + & forall d, + 'Res 'chi_d = theta -> coprime #|G : N| 'o('chi_d)%CF -> + d = c]. +Proof. +set e := #|G : N|; set f := truncC _ => nsNG solG IGtheta. +rewrite coprime_mulr => /andP[co_e_th co_e_f]. +have [sNG nNG] := andP nsNG; pose lambda := cfDet theta. +have lin_lam: lambda \is a linear_char := cfDet_lin_char theta. +have IGlam: G \subset 'I[lambda]. + apply/subsetP=> y /(subsetP IGtheta)/setIdP[nNy /eqP th_y]. + by rewrite inE nNy /= -cfDetConjg th_y. +have co_e_lam: coprime e 'o(lambda)%CF by rewrite cfDet_order_lin. +have [//|u [uNlam o_u Uu]] := extend_coprime_linear_char nsNG lin_lam IGlam. +have /exists_eqP[c cNth]: [exists c, 'Res 'chi[G]_c == theta]. + rewrite solvable_irr_extendible_from_det //. + by apply/exists_eqP; exists u. +have{c cNth} [c [cNth det_c] Uc] := extend_to_cfdet nsNG co_e_f cNth uNlam. +have lin_u: 'chi_u \is a linear_char by rewrite -det_c cfDet_lin_char. +exists c; split=> // [|c0 c0Nth co_e_c0]. + by rewrite !cfDet_order_lin // -det_c in o_u. +have lin_u0: cfDet 'chi_c0 \is a linear_char := cfDet_lin_char 'chi_c0. +have /irrP[u0 Du0] := lin_char_irr lin_u0. +have co_e_u0: coprime e 'o('chi_u0)%CF by rewrite -Du0 cfDet_order_lin. +have eq_u0u: u0 = u by apply: Uu; rewrite // -Du0 -cfDetRes ?irr_char ?c0Nth. +by apply: Uc; rewrite // Du0 eq_u0u. +Qed. + +End ExtendInvariantIrr. + +Section Frobenius. + +Variables (gT : finGroupType) (G K : {group gT}). + +(* Because he only defines Frobenius groups in chapter 7, Isaacs does not *) +(* state these theorems using the Frobenius property. *) +Hypothesis frobGK : [Frobenius G with kernel K]. + +(* This is Isaacs, Theorem 6.34(a1). *) +Theorem inertia_Frobenius_ker i : i != 0 -> 'I_G['chi[K]_i] = K. +Proof. +have [_ _ nsKG regK] := Frobenius_kerP frobGK; have [sKG nKG] := andP nsKG. +move=> nzi; apply/eqP; rewrite eqEsubset sub_Inertia // andbT. +apply/subsetP=> x /setIP[Gx /setIdP[nKx /eqP x_stab_i]]. +have actIirrK: is_action G (@conjg_Iirr _ K). + split=> [y j k eq_jk | j y z Gy Gz]. + by apply/irr_inj/(can_inj (cfConjgK y)); rewrite -!conjg_IirrE eq_jk. + by apply: irr_inj; rewrite !conjg_IirrE (cfConjgM _ nsKG). +pose ito := Action actIirrK; pose cto := ('Js \ (subsetT G))%act. +have acts_Js : [acts G, on classes K | 'Js]. + apply/subsetP=> y Gy; have nKy := subsetP nKG y Gy. + rewrite !inE; apply/subsetP=> _ /imsetP[z Gz ->]; rewrite !inE /=. + rewrite -class_rcoset norm_rlcoset // class_lcoset. + by apply: mem_imset; rewrite memJ_norm. +have acts_cto : [acts G, on classes K | cto] by rewrite astabs_ract subsetIidl. +pose m := #|'Fix_(classes K | cto)[x]|. +have def_m: #|'Fix_ito[x]| = m. + apply: card_afix_irr_classes => // j y _ Ky /imsetP[_ /imsetP[z Kz ->] ->]. + by rewrite conjg_IirrE cfConjgEJ // cfunJ. +have: (m != 1)%N. + rewrite -def_m (cardD1 (0 : Iirr K)) (cardD1 i) !(inE, sub1set) /=. + by rewrite conjg_Iirr0 nzi eqxx -(inj_eq irr_inj) conjg_IirrE x_stab_i eqxx. +apply: contraR => notKx; apply/cards1P; exists 1%g; apply/esym/eqP. +rewrite eqEsubset !(sub1set, inE) classes1 /= conjs1g eqxx /=. +apply/subsetP=> _ /setIP[/imsetP[y Ky ->] /afix1P /= cyKx]. +have /imsetP[z Kz def_yx]: y ^ x \in y ^: K. + by rewrite -cyKx; apply: mem_imset; exact: class_refl. +rewrite inE classG_eq1; apply: contraR notKx => nty. +rewrite -(groupMr x (groupVr Kz)). +apply: (subsetP (regK y _)); first exact/setD1P. +rewrite !inE groupMl // groupV (subsetP sKG) //=. +by rewrite conjg_set1 conjgM def_yx conjgK. +Qed. + +(* This is Isaacs, Theorem 6.34(a2) *) +Theorem irr_induced_Frobenius_ker i : i != 0 -> 'Ind[G, K] 'chi_i \in irr G. +Proof. +move/inertia_Frobenius_ker/group_inj=> defK. +have [_ _ nsKG _] := Frobenius_kerP frobGK. +have [] := constt_Inertia_bijection i nsKG; rewrite defK cfInd_id => -> //. +by rewrite constt_irr !inE. +Qed. + +(* This is Isaacs, Theorem 6.34(b) *) +Theorem Frobenius_Ind_irrP j : + reflect (exists2 i, i != 0 & 'chi_j = 'Ind[G, K] 'chi_i) + (~~ (K \subset cfker 'chi_j)). +Proof. +have [_ _ nsKG _] := Frobenius_kerP frobGK; have [sKG nKG] := andP nsKG. +apply: (iffP idP) => [not_chijK1 | [i nzi ->]]; last first. + by rewrite cfker_Ind_irr ?sub_gcore // subGcfker. +have /neq0_has_constt[i chijKi]: 'Res[K] 'chi_j != 0 by exact: Res_irr_neq0. +have nz_i: i != 0. + by apply: contraNneq not_chijK1 => i0; rewrite constt0_Res_cfker // -i0. +have /irrP[k def_chik] := irr_induced_Frobenius_ker nz_i. +have: '['chi_j, 'chi_k] != 0 by rewrite -def_chik -cfdot_Res_l. +by rewrite cfdot_irr pnatr_eq0; case: (j =P k) => // ->; exists i. +Qed. + +End Frobenius. diff --git a/mathcomp/character/integral_char.v b/mathcomp/character/integral_char.v new file mode 100644 index 0000000..d327ac3 --- /dev/null +++ b/mathcomp/character/integral_char.v @@ -0,0 +1,708 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg poly finset. +Require Import fingroup morphism perm automorphism quotient action finalg zmodp. +Require Import commutator cyclic center pgroup sylow gseries nilpotent abelian. +Require Import ssrnum ssrint polydiv rat matrix mxalgebra intdiv mxpoly. +Require Import vector falgebra fieldext separable galois algC cyclotomic algnum. +Require Import mxrepresentation classfun character. + +(******************************************************************************) +(* This file provides some standard results based on integrality properties *) +(* of characters, such as theorem asserting that the degree of an irreducible *) +(* character of G divides the order of G (Isaacs 3.11), or the famous p^a.q^b *) +(* solvability theorem of Burnside. *) +(* Defined here: *) +(* 'K_k == the kth class sum in gring F G, where k : 'I_#|classes G|, and *) +(* F is inferred from the context. *) +(* := gset_mx F G (enum_val k) (see mxrepresentation.v). *) +(* --> The 'K_k form a basis of 'Z(group_ring F G)%MS. *) +(* gring_classM_coef i j k == the coordinate of 'K_i *m 'K_j on 'K_k; this *) +(* is usually abbreviated as a i j k. *) +(* gring_classM_coef_set A B z == the set of all (x, y) in setX A B such *) +(* that x * y = z; if A and B are respectively the ith and jth *) +(* conjugacy class of G, and z is in the kth conjugacy class, then *) +(* gring_classM_coef i j k is exactly the cadinal of this set. *) +(* 'omega_i[A] == the mode of 'chi[G]_i on (A \in 'Z(group_ring algC G))%MS, *) +(* i.e., the z such that gring_op 'Chi_i A = z%:M. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory Num.Theory. +Local Open Scope ring_scope. + +Lemma group_num_field_exists (gT : finGroupType) (G : {group gT}) : + {Qn : splittingFieldType rat & galois 1 {:Qn} & + {QnC : {rmorphism Qn -> algC} + & forall nuQn : argumentType (mem ('Gal({:Qn}%VS / 1%VS))), + {nu : {rmorphism algC -> algC} | + {morph QnC: a / nuQn a >-> nu a}} + & {w : Qn & #|G|.-primitive_root w /\ <<1; w>>%VS = fullv + & forall (hT : finGroupType) (H : {group hT}) (phi : 'CF(H)), + phi \is a character -> + forall x, (#[x] %| #|G|)%N -> {a | QnC a = phi x}}}}. +Proof. +have [z prim_z] := C_prim_root_exists (cardG_gt0 G); set n := #|G| in prim_z *. +have [Qn [QnC [[|w []] // [Dz] genQn]]] := num_field_exists [:: z]. +have prim_w: n.-primitive_root w by rewrite -Dz fmorph_primitive_root in prim_z. +have Q_Xn1: ('X^n - 1 : {poly Qn}) \is a polyOver 1%AS. + by rewrite rpredB ?rpred1 ?rpredX //= polyOverX. +have splitXn1: splittingFieldFor 1 ('X^n - 1) {:Qn}. + pose r := codom (fun i : 'I_n => w ^+ i). + have Dr: 'X^n - 1 = \prod_(y <- r) ('X - y%:P). + by rewrite -(factor_Xn_sub_1 prim_w) big_mkord big_map enumT. + exists r; first by rewrite -Dr eqpxx. + apply/eqP; rewrite eqEsubv subvf -genQn adjoin_seqSr //; apply/allP=> /=. + by rewrite andbT -root_prod_XsubC -Dr; apply/unity_rootP/prim_expr_order. +have Qn_ax : SplittingField.axiom Qn by exists ('X^n - 1). +exists (SplittingFieldType _ _ Qn_ax). + apply/splitting_galoisField. + exists ('X^n - 1); split => //. + apply: separable_Xn_sub_1; rewrite -(fmorph_eq0 QnC) rmorph_nat. + by rewrite pnatr_eq0 -lt0n cardG_gt0. +exists QnC => [// nuQn|]. + by exact: (extend_algC_subfield_aut QnC [rmorphism of nuQn]). +rewrite span_seq1 in genQn. +exists w => // hT H phi Nphi x x_dv_n. +apply: sig_eqW; have [rH ->] := char_reprP Nphi. +have [Hx | /cfun0->] := boolP (x \in H); last by exists 0; rewrite rmorph0. +have [e [_ [enx1 _] [-> _] _]] := repr_rsim_diag rH Hx. +have /fin_all_exists[k Dk] i: exists k, e 0 i = z ^+ k. + have [|k ->] := (prim_rootP prim_z) (e 0 i); last by exists k. + by have /dvdnP[q ->] := x_dv_n; rewrite mulnC exprM enx1 expr1n. +exists (\sum_i w ^+ k i); rewrite rmorph_sum; apply/eq_bigr => i _. +by rewrite rmorphX Dz Dk. +Qed. + +Section GenericClassSums. + +(* This is Isaacs, Theorem (2.4), generalized to an arbitrary field, and with *) +(* the combinatorial definition of the coeficients exposed. *) +(* This part could move to mxrepresentation.*) + +Variable (gT : finGroupType) (G : {group gT}) (F : fieldType). + +Definition gring_classM_coef_set (Ki Kj : {set gT}) g := + [set xy in [predX Ki & Kj] | let: (x, y) := xy in x * y == g]%g. + +Definition gring_classM_coef (i j k : 'I_#|classes G|) := + #|gring_classM_coef_set (enum_val i) (enum_val j) (repr (enum_val k))|. + +Definition gring_class_sum (i : 'I_#|classes G|) := gset_mx F G (enum_val i). + +Local Notation "''K_' i" := (gring_class_sum i) + (at level 8, i at level 2, format "''K_' i") : ring_scope. +Local Notation a := gring_classM_coef. + +Lemma gring_class_sum_central i : ('K_i \in 'Z(group_ring F G))%MS. +Proof. by rewrite -classg_base_center (eq_row_sub i) // rowK. Qed. + +Lemma set_gring_classM_coef (i j k : 'I_#|classes G|) g : + g \in enum_val k -> + a i j k = #|gring_classM_coef_set (enum_val i) (enum_val j) g|. +Proof. +rewrite /a; have /repr_classesP[] := enum_valP k; move: (repr _) => g1 Gg1 ->. +have [/imsetP[zi Gzi ->] /imsetP[zj Gzj ->]] := (enum_valP i, enum_valP j). +move=> g1Gg; have Gg := subsetP (class_subG Gg1 (subxx _)) _ g1Gg. +set Aij := gring_classM_coef_set _ _. +without loss suffices IH: g g1 Gg Gg1 g1Gg / (#|Aij g1| <= #|Aij g|)%N. + by apply/eqP; rewrite eqn_leq !IH // class_sym. +have [w Gw Dg] := imsetP g1Gg; pose J2 (v : gT) xy := (xy.1 ^ v, xy.2 ^ v)%g. +have J2inj: injective (J2 w). + by apply: can_inj (J2 w^-1)%g _ => [[x y]]; rewrite /J2 /= !conjgK. +rewrite -(card_imset _ J2inj) subset_leq_card //; apply/subsetP. +move=> _ /imsetP[[x y] /setIdP[/andP[/= x1Gx y1Gy] Dxy1] ->]; rewrite !inE /=. +rewrite !(class_sym _ (_ ^ _)) !classGidl // class_sym x1Gx class_sym y1Gy. +by rewrite -conjMg (eqP Dxy1) /= -Dg. +Qed. + +Theorem gring_classM_expansion i j : 'K_i *m 'K_j = \sum_k (a i j k)%:R *: 'K_k. +Proof. +have [/imsetP[zi Gzi dKi] /imsetP[zj Gzj dKj]] := (enum_valP i, enum_valP j). +pose aG := regular_repr F G; have sKG := subsetP (class_subG _ (subxx G)). +transitivity (\sum_(x in zi ^: G) \sum_(y in zj ^: G) aG (x * y)%g). + rewrite mulmx_suml -/aG dKi; apply: eq_bigr => x /sKG Gx. + rewrite mulmx_sumr -/aG dKj; apply: eq_bigr => y /sKG Gy. + by rewrite repr_mxM ?Gx ?Gy. +pose h2 xy : gT := (xy.1 * xy.2)%g. +pose h1 xy := enum_rank_in (classes1 G) (h2 xy ^: G). +rewrite pair_big (partition_big h1 xpredT) //=; apply: eq_bigr => k _. +rewrite (partition_big h2 (mem (enum_val k))) /= => [|[x y]]; last first. + case/andP=> /andP[/= /sKG Gx /sKG Gy] /eqP <-. + by rewrite enum_rankK_in ?class_refl ?mem_classes ?groupM ?Gx ?Gy. +rewrite scaler_sumr; apply: eq_bigr => g Kk_g; rewrite scaler_nat. +rewrite (set_gring_classM_coef _ _ Kk_g) -sumr_const; apply: eq_big => [] [x y]. + rewrite !inE /= dKi dKj /h1 /h2 /=; apply: andb_id2r => /eqP ->. + have /imsetP[zk Gzk dKk] := enum_valP k; rewrite dKk in Kk_g. + by rewrite (class_transr Kk_g) -dKk enum_valK_in eqxx andbT. +by rewrite /h2 /= => /andP[_ /eqP->]. +Qed. + +Fact gring_irr_mode_key : unit. Proof. by []. Qed. +Definition gring_irr_mode_def (i : Iirr G) := ('chi_i 1%g)^-1 *: 'chi_i. +Definition gring_irr_mode := locked_with gring_irr_mode_key gring_irr_mode_def. +Canonical gring_irr_mode_unlockable := [unlockable fun gring_irr_mode]. + +End GenericClassSums. + +Arguments Scope gring_irr_mode [_ Group_scope ring_scope group_scope]. + +Notation "''K_' i" := (gring_class_sum _ i) + (at level 8, i at level 2, format "''K_' i") : ring_scope. + +Notation "''omega_' i [ A ]" := (xcfun (gring_irr_mode i) A) + (at level 8, i at level 2, format "''omega_' i [ A ]") : ring_scope. + +Section IntegralChar. + +Variables (gT : finGroupType) (G : {group gT}). + +(* This is Isaacs, Corollary (3.6). *) +Lemma Aint_char (chi : 'CF(G)) x : chi \is a character -> chi x \in Aint. +Proof. +have [Gx /char_reprP[rG ->] {chi} | /cfun0->//] := boolP (x \in G). +have [e [_ [unit_e _] [-> _] _]] := repr_rsim_diag rG Gx. +rewrite rpred_sum // => i _; apply: (@Aint_unity_root #[x]) => //. +exact/unity_rootP. +Qed. + +Lemma Aint_irr i x : 'chi[G]_i x \in Aint. +Proof. by apply: Aint_char; exact: irr_char. Qed. + +Local Notation R_G := (group_ring algCfield G). +Local Notation a := gring_classM_coef. + +(* This is Isaacs (2.25). *) +Lemma mx_irr_gring_op_center_scalar n (rG : mx_representation algCfield G n) A : + mx_irreducible rG -> (A \in 'Z(R_G))%MS -> is_scalar_mx (gring_op rG A). +Proof. +move/groupC=> irrG /center_mxP[R_A cGA]. +apply: mx_abs_irr_cent_scalar irrG _ _; apply/centgmxP => x Gx. +by rewrite -(gring_opG rG Gx) -!gring_opM ?cGA // envelop_mx_id. +Qed. + +Section GringIrrMode. + +Variable i : Iirr G. + +Let n := irr_degree (socle_of_Iirr i). +Let mxZn_inj: injective (@scalar_mx algCfield n). +Proof. by rewrite -[n]prednK ?irr_degree_gt0 //; apply: fmorph_inj. Qed. + +Lemma cfRepr_gring_center n1 (rG : mx_representation algCfield G n1) A : + cfRepr rG = 'chi_i -> (A \in 'Z(R_G))%MS -> gring_op rG A = 'omega_i[A]%:M. +Proof. +move=> def_rG Z_A; rewrite unlock xcfunZl -{2}def_rG xcfun_repr. +have irr_rG: mx_irreducible rG. + have sim_rG: mx_rsim 'Chi_i rG by apply: cfRepr_inj; rewrite irrRepr. + exact: mx_rsim_irr sim_rG (socle_irr _). +have /is_scalar_mxP[e ->] := mx_irr_gring_op_center_scalar irr_rG Z_A. +congr _%:M; apply: (canRL (mulKf (irr1_neq0 i))). +by rewrite mulrC -def_rG cfunE repr_mx1 group1 -mxtraceZ scalemx1. +Qed. + +Lemma irr_gring_center A : + (A \in 'Z(R_G))%MS -> gring_op 'Chi_i A = 'omega_i[A]%:M. +Proof. exact: cfRepr_gring_center (irrRepr i). Qed. + +Lemma gring_irr_modeM A B : + (A \in 'Z(R_G))%MS -> (B \in 'Z(R_G))%MS -> + 'omega_i[A *m B] = 'omega_i[A] * 'omega_i[B]. +Proof. +move=> Z_A Z_B; have [[R_A cRA] [R_B cRB]] := (center_mxP Z_A, center_mxP Z_B). +apply: mxZn_inj; rewrite scalar_mxM -!irr_gring_center ?gring_opM //. +apply/center_mxP; split=> [|C R_C]; first exact: envelop_mxM. +by rewrite mulmxA cRA // -!mulmxA cRB. +Qed. + +Lemma gring_mode_class_sum_eq (k : 'I_#|classes G|) g : + g \in enum_val k -> 'omega_i['K_k] = #|g ^: G|%:R * 'chi_i g / 'chi_i 1%g. +Proof. +have /imsetP[x Gx DxG] := enum_valP k; rewrite DxG => /imsetP[u Gu ->{g}]. +rewrite unlock classGidl ?cfunJ {u Gu}// mulrC mulr_natl. +rewrite xcfunZl raddf_sum DxG -sumr_const /=; congr (_ * _). +by apply: eq_bigr => _ /imsetP[u Gu ->]; rewrite xcfunG ?groupJ ?cfunJ. +Qed. + +(* This is Isaacs, Theorem (3.7). *) +Lemma Aint_gring_mode_class_sum k : 'omega_i['K_k] \in Aint. +Proof. +move: k; pose X := [tuple 'omega_i['K_k] | k < #|classes G| ]. +have memX k: 'omega_i['K_k] \in X by apply: map_f; exact: mem_enum. +have S_P := Cint_spanP X; set S := Cint_span X in S_P. +have S_X: {subset X <= S} by exact: mem_Cint_span. +have S_1: 1 \in S. + apply: S_X; apply/codomP; exists (enum_rank_in (classes1 G) 1%g). + rewrite (@gring_mode_class_sum_eq _ 1%g) ?enum_rankK_in ?classes1 //. + by rewrite mulfK ?irr1_neq0 // class1G cards1. +suffices Smul: mulr_closed S. + by move=> k; apply: fin_Csubring_Aint S_P _ _; rewrite ?S_X. +split=> // _ _ /S_P[x ->] /S_P[y ->]. +rewrite mulr_sumr rpred_sum // => j _. +rewrite mulrzAr mulr_suml rpredMz ?rpred_sum // => k _. +rewrite mulrzAl rpredMz {x y}// !nth_mktuple. +rewrite -gring_irr_modeM ?gring_class_sum_central //. +rewrite gring_classM_expansion raddf_sum rpred_sum // => jk _. +by rewrite scaler_nat raddfMn rpredMn ?S_X ?memX. +Qed. + +(* A more usable reformulation that does not involve the class sums. *) +Corollary Aint_class_div_irr1 x : + x \in G -> #|x ^: G|%:R * 'chi_i x / 'chi_i 1%g \in Aint. +Proof. +move=> Gx; have clGxG := mem_classes Gx; pose k := enum_rank_in clGxG (x ^: G). +have k_x: x \in enum_val k by rewrite enum_rankK_in // class_refl. +by rewrite -(gring_mode_class_sum_eq k_x) Aint_gring_mode_class_sum. +Qed. + +(* This is Isaacs, Theorem (3.8). *) +Theorem coprime_degree_support_cfcenter g : + coprime (truncC ('chi_i 1%g)) #|g ^: G| -> g \notin ('Z('chi_i))%CF -> + 'chi_i g = 0. +Proof. +set m := truncC _ => co_m_gG notZg. +have [Gg | /cfun0-> //] := boolP (g \in G). +have Dm: 'chi_i 1%g = m%:R by rewrite truncCK ?Cnat_irr1. +have m_gt0: (0 < m)%N by rewrite -ltC_nat -Dm irr1_gt0. +have nz_m: m%:R != 0 :> algC by rewrite pnatr_eq0 -lt0n. +pose alpha := 'chi_i g / m%:R. +have a_lt1: `|alpha| < 1. + rewrite normrM normfV normr_nat -{2}(divff nz_m). + rewrite ltr_def (can_eq (mulfVK nz_m)) eq_sym -{1}Dm -irr_cfcenterE // notZg. + by rewrite ler_pmul2r ?invr_gt0 ?ltr0n // -Dm char1_ge_norm ?irr_char. +have Za: alpha \in Aint. + have [u _ /dvdnP[v eq_uv]] := Bezoutl #|g ^: G| m_gt0. + suffices ->: alpha = v%:R * 'chi_i g - u%:R * (alpha * #|g ^: G|%:R). + rewrite rpredB // rpredM ?rpred_nat ?Aint_irr //. + by rewrite mulrC mulrA -Dm Aint_class_div_irr1. + rewrite -mulrCA -[v%:R](mulfK nz_m) -!natrM -eq_uv (eqnP co_m_gG). + by rewrite mulrAC -mulrA -/alpha mulr_natl mulr_natr mulrS addrK. +have [Qn galQn [QnC gQnC [_ _ Qn_g]]] := group_num_field_exists <[g]>. +have{Qn_g} [a Da]: exists a, QnC a = alpha. + rewrite /alpha; have [a <-] := Qn_g _ G _ (irr_char i) g (dvdnn _). + by exists (a / m%:R); rewrite fmorph_div rmorph_nat. +have Za_nu nu: sval (gQnC nu) alpha \in Aint by rewrite Aint_aut. +have norm_a_nu nu: `|sval (gQnC nu) alpha| <= 1. + move: {nu}(sval _) => nu; rewrite fmorph_div rmorph_nat normrM normfV. + rewrite normr_nat -Dm -(ler_pmul2r (irr1_gt0 (aut_Iirr nu i))) mul1r. + congr (_ <= _): (char1_ge_norm g (irr_char (aut_Iirr nu i))). + by rewrite !aut_IirrE !cfunE Dm rmorph_nat divfK. +pose beta := QnC (galNorm 1 {:Qn} a). +have Dbeta: beta = \prod_(nu in 'Gal({:Qn} / 1)) sval (gQnC nu) alpha. + rewrite /beta rmorph_prod. apply: eq_bigr => nu _. + by case: (gQnC nu) => f /= ->; rewrite Da. +have Zbeta: beta \in Cint. + apply: Cint_rat_Aint; last by rewrite Dbeta rpred_prod. + rewrite /beta; have /vlineP[/= c ->] := mem_galNorm galQn (memvf a). + by rewrite alg_num_field fmorph_rat rpred_rat. +have [|nz_a] := boolP (alpha == 0). + by rewrite (can2_eq (divfK _) (mulfK _)) // mul0r => /eqP. +have: beta != 0 by rewrite Dbeta; apply/prodf_neq0 => nu _; rewrite fmorph_eq0. +move/(norm_Cint_ge1 Zbeta); rewrite ltr_geF //; apply: ler_lt_trans a_lt1. +rewrite -[`|alpha|]mulr1 Dbeta (bigD1 1%g) ?group1 //= -Da. +case: (gQnC _) => /= _ <-; rewrite gal_id normrM. +rewrite -subr_ge0 -mulrBr mulr_ge0 ?normr_ge0 // Da subr_ge0. +elim/big_rec: _ => [|nu c _]; first by rewrite normr1 lerr. +apply: ler_trans; rewrite -subr_ge0 -{1}[`|c|]mul1r normrM -mulrBl. +by rewrite mulr_ge0 ?normr_ge0 // subr_ge0 norm_a_nu. +Qed. + +End GringIrrMode. + +(* This is Isaacs, Theorem (3.9). *) +Theorem primes_class_simple_gt1 C : + simple G -> ~~ abelian G -> C \in (classes G)^# -> (size (primes #|C|) > 1)%N. +Proof. +move=> simpleG not_cGG /setD1P[ntC /imsetP[g Gg defC]]. +have{ntC} nt_g: g != 1%g by rewrite defC classG_eq1 in ntC. +rewrite ltnNge {C}defC; set m := #|_|; apply/negP=> p_natC. +have{p_natC} [p p_pr [a Dm]]: {p : nat & prime p & {a | m = p ^ a}%N}. + have /prod_prime_decomp->: (0 < m)%N by rewrite /m -index_cent1. + rewrite prime_decompE; case Dpr: (primes _) p_natC => [|p []] // _. + by exists 2 => //; rewrite big_nil; exists 0%N. + rewrite big_seq1; exists p; last by exists (logn p m). + by have:= mem_primes p m; rewrite Dpr mem_head => /esym/and3P[]. +have{simpleG} [ntG minG] := simpleP _ simpleG. +pose p_dv1 i := (p %| 'chi[G]_i 1%g)%C. +have p_dvd_supp_g i: ~~ p_dv1 i && (i != 0) -> 'chi_i g = 0. + rewrite /p_dv1 irr1_degree dvdC_nat -prime_coprime // => /andP[co_p_i1 nz_i]. + have fful_i: cfker 'chi_i = [1]. + have /minG[//|/eqP] := cfker_normal 'chi_i. + by rewrite eqEsubset subGcfker (negPf nz_i) andbF. + have trivZ: 'Z(G) = [1] by have /minG[|/center_idP/idPn] := center_normal G. + have trivZi: ('Z('chi_i))%CF = [1]. + apply/trivgP; rewrite -quotient_sub1 ?norms1 //= -fful_i cfcenter_eq_center. + rewrite fful_i subG1 -(isog_eq1 (isog_center (quotient1_isog G))) /=. + by rewrite trivZ. + rewrite coprime_degree_support_cfcenter ?trivZi ?inE //. + by rewrite -/m Dm irr1_degree natCK coprime_sym coprime_expl. +pose alpha := \sum_(i | p_dv1 i && (i != 0)) 'chi_i 1%g / p%:R * 'chi_i g. +have nz_p: p%:R != 0 :> algC by rewrite pnatr_eq0 -lt0n prime_gt0. +have Dalpha: alpha = - 1 / p%:R. + apply/(canRL (mulfK nz_p))/eqP; rewrite -addr_eq0 addrC; apply/eqP/esym. + transitivity (cfReg G g); first by rewrite cfRegE (negPf nt_g). + rewrite cfReg_sum sum_cfunE (bigD1 0) //= irr0 !cfunE cfun11 cfun1E Gg. + rewrite mulr1; congr (1 + _); rewrite (bigID p_dv1) /= addrC big_andbC. + rewrite big1 => [|i /p_dvd_supp_g chig0]; last by rewrite cfunE chig0 mulr0. + rewrite add0r big_andbC mulr_suml; apply: eq_bigr => i _. + by rewrite mulrAC divfK // cfunE. +suffices: (p %| 1)%C by rewrite (dvdC_nat p 1) dvdn1 -(subnKC (prime_gt1 p_pr)). +rewrite unfold_in (negPf nz_p). +rewrite Cint_rat_Aint ?rpred_div ?rpred1 ?rpred_nat //. +rewrite -rpredN // -mulNr -Dalpha rpred_sum // => i /andP[/dvdCP[c Zc ->] _]. +by rewrite mulfK // rpredM ?Aint_irr ?Aint_Cint. +Qed. + +End IntegralChar. + +Section MoreIntegralChar. + +Implicit Type gT : finGroupType. + +(* This is Burnside's famous p^a.q^b theorem (Isaacs, Theorem (3.10)). *) +Theorem Burnside_p_a_q_b gT (G : {group gT}) : + (size (primes #|G|) <= 2)%N -> solvable G. +Proof. +move: {2}_.+1 (ltnSn #|G|) => n; elim: n => // n IHn in gT G *. +rewrite ltnS => leGn piGle2; have [simpleG | ] := boolP (simple G); last first. + rewrite negb_forall_in => /exists_inP[N sNG]; rewrite eq_sym. + have [-> | ] := altP (N =P G). + rewrite groupP /= genGid normG andbT eqb_id negbK => /eqP->. + exact: solvable1. + rewrite [N == G]eqEproper sNG eqbF_neg !negbK => ltNG /and3P[grN]. + case/isgroupP: grN => {N}N -> in sNG ltNG *; rewrite /= genGid => ntN nNG. + have nsNG: N <| G by exact/andP. + have dv_le_pi m: (m %| #|G| -> size (primes m) <= 2)%N. + move=> m_dv_G; apply: leq_trans piGle2. + by rewrite uniq_leq_size ?primes_uniq //; apply: pi_of_dvd. + rewrite (series_sol nsNG) !IHn ?dv_le_pi ?cardSg ?dvdn_quotient //. + by apply: leq_trans leGn; apply: ltn_quotient. + by apply: leq_trans leGn; apply: proper_card. +have [->|[p p_pr p_dv_G]] := trivgVpdiv G; first exact: solvable1. +have piGp: p \in \pi(G) by rewrite mem_primes p_pr cardG_gt0. +have [P sylP] := Sylow_exists p G; have [sPG pP p'GP] := and3P sylP. +have ntP: P :!=: 1%g by rewrite -rank_gt0 (rank_Sylow sylP) p_rank_gt0. +have /trivgPn[g /setIP[Pg cPg] nt_g]: 'Z(P) != 1%g. + by rewrite center_nil_eq1 // (pgroup_nil pP). +apply: abelian_sol; have: (size (primes #|g ^: G|) <= 1)%N. + rewrite -ltnS -[_.+1]/(size (p :: _)) (leq_trans _ piGle2) //. + rewrite -index_cent1 uniq_leq_size // => [/= | q]. + rewrite primes_uniq -p'natEpi ?(pnat_dvd _ p'GP) ?indexgS //. + by rewrite subsetI sPG sub_cent1. + by rewrite inE => /predU1P[-> // |]; apply: pi_of_dvd; rewrite ?dvdn_indexg. +rewrite leqNgt; apply: contraR => /primes_class_simple_gt1-> //. +by rewrite !inE classG_eq1 nt_g mem_classes // (subsetP sPG). +Qed. + +(* This is Isaacs, Theorem (3.11). *) +Theorem dvd_irr1_cardG gT (G : {group gT}) i : ('chi[G]_i 1%g %| #|G|)%C. +Proof. +rewrite unfold_in -if_neg irr1_neq0 Cint_rat_Aint //=. + by rewrite rpred_div ?rpred_nat // rpred_Cnat ?Cnat_irr1. +rewrite -[n in n / _]/(_ *+ true) -(eqxx i) -mulr_natr. +rewrite -first_orthogonality_relation mulVKf ?neq0CG //. +rewrite sum_by_classes => [|x y Gx Gy]; rewrite -?conjVg ?cfunJ //. +rewrite mulr_suml rpred_sum // => K /repr_classesP[Gx {1}->]. +by rewrite !mulrA mulrAC rpredM ?Aint_irr ?Aint_class_div_irr1. +Qed. + +(* This is Isaacs, Theorem (3.12). *) +Theorem dvd_irr1_index_center gT (G : {group gT}) i : + ('chi[G]_i 1%g %| #|G : 'Z('chi_i)%CF|)%C. +Proof. +without loss fful: gT G i / cfaithful 'chi_i. + rewrite -{2}[i](quo_IirrK _ (subxx _)) ?mod_IirrE ?cfModE ?cfker_normal //. + rewrite morph1; set i1 := quo_Iirr _ i => /(_ _ _ i1) IH. + have fful_i1: cfaithful 'chi_i1. + by rewrite quo_IirrE ?cfker_normal ?cfaithful_quo. + have:= IH fful_i1; rewrite cfcenter_fful_irr // -cfcenter_eq_center. + rewrite index_quotient_eq ?cfcenter_sub ?cfker_norm //. + by rewrite setIC subIset // normal_sub ?cfker_center_normal. +have [lambda lin_lambda Dlambda] := cfcenter_Res 'chi_i. +have DchiZ: {in G & 'Z(G), forall x y, 'chi_i (x * y)%g = 'chi_i x * lambda y}. + rewrite -(cfcenter_fful_irr fful) => x y Gx Zy. + apply: (mulfI (irr1_neq0 i)); rewrite mulrCA. + transitivity ('chi_i x * ('chi_i 1%g *: lambda) y); last by rewrite !cfunE. + rewrite -Dlambda cfResE ?cfcenter_sub //. + rewrite -irrRepr cfcenter_repr !cfunE in Zy *. + case/setIdP: Zy => Gy /is_scalar_mxP[e De]. + rewrite repr_mx1 group1 (groupM Gx Gy) (repr_mxM _ Gx Gy) Gx Gy De. + by rewrite mul_mx_scalar mxtraceZ mulrCA mulrA mulrC -mxtraceZ scalemx1. +have inj_lambda: {in 'Z(G) &, injective lambda}. + rewrite -(cfcenter_fful_irr fful) => x y Zx Zy eq_xy. + apply/eqP; rewrite eq_mulVg1 -in_set1 (subsetP fful) // cfkerEirr inE. + apply/eqP; transitivity ('Res['Z('chi_i)%CF] 'chi_i (x^-1 * y)%g). + by rewrite cfResE ?cfcenter_sub // groupM ?groupV. + rewrite Dlambda !cfunE lin_charM ?groupV // -eq_xy -lin_charM ?groupV //. + by rewrite mulrC mulVg lin_char1 ?mul1r. +rewrite unfold_in -if_neg irr1_neq0 Cint_rat_Aint //. + by rewrite rpred_div ?rpred_nat // rpred_Cnat ?Cnat_irr1. +rewrite (cfcenter_fful_irr fful) nCdivE natf_indexg ?center_sub //=. +have ->: #|G|%:R = \sum_(x in G) 'chi_i x * 'chi_i (x^-1)%g. + rewrite -[_%:R]mulr1; apply: canLR (mulVKf (neq0CG G)) _. + by rewrite first_orthogonality_relation eqxx. +rewrite (big_setID [set x | 'chi_i x == 0]) /= -setIdE. +rewrite big1 ?add0r => [| x /setIdP[_ /eqP->]]; last by rewrite mul0r. +pose h x := (x ^: G * 'Z(G))%g; rewrite (partition_big_imset h). +rewrite !mulr_suml rpred_sum //= => _ /imsetP[x /setDP[Gx nz_chi_x] ->]. +have: #|x ^: G|%:R * ('chi_i x * 'chi_i x^-1%g) / 'chi_i 1%g \in Aint. + by rewrite !mulrA mulrAC rpredM ?Aint_irr ?Aint_class_div_irr1. +congr 2 (_ * _ \in Aint); apply: canRL (mulfK (neq0CG _)) _. +rewrite inE in nz_chi_x. +transitivity ('chi_i x * 'chi_i (x^-1)%g *+ #|h x|); last first. + rewrite -sumr_const. + apply: eq_big => [y | _ /mulsgP[_ z /imsetP[u Gu ->] Zz] ->]. + rewrite !inE -andbA; apply/idP/and3P=> [|[_ _ /eqP <-]]; last first. + by rewrite -{1}[y]mulg1 mem_mulg ?class_refl. + case/mulsgP=> _ z /imsetP[u Gu ->] Zz ->; have /centerP[Gz cGz] := Zz. + rewrite groupM 1?DchiZ ?groupJ ?cfunJ //; split=> //. + by rewrite mulf_neq0 // lin_char_neq0 /= ?cfcenter_fful_irr. + rewrite -[z](mulKg u) -cGz // -conjMg /h classGidl {u Gu}//. + apply/eqP/setP=> w; apply/mulsgP/mulsgP=> [][_ z1 /imsetP[v Gv ->] Zz1 ->]. + exists (x ^ v)%g (z * z1)%g; rewrite ?mem_imset ?groupM //. + by rewrite conjMg -mulgA /(z ^ v)%g cGz // mulKg. + exists ((x * z) ^ v)%g (z^-1 * z1)%g; rewrite ?mem_imset ?groupM ?groupV //. + by rewrite conjMg -mulgA /(z ^ v)%g cGz // mulKg mulKVg. + rewrite !irr_inv DchiZ ?groupJ ?cfunJ // rmorphM mulrACA -!normCK -exprMn. + by rewrite (normC_lin_char lin_lambda) ?mulr1 //= cfcenter_fful_irr. +rewrite mulrAC -natrM mulr_natl; congr (_ *+ _). +symmetry; rewrite /h /mulg /= /set_mulg [in _ @2: (_, _)]unlock cardsE. +rewrite -cardX card_in_image // => [] [y1 z1] [y2 z2] /=. +move=> /andP[/=/imsetP[u1 Gu1 ->] Zz1] /andP[/=/imsetP[u2 Gu2 ->] Zz2] {y1 y2}. +move=> eq12; have /eqP := congr1 'chi_i eq12. +rewrite !(cfunJ, DchiZ) ?groupJ // (can_eq (mulKf nz_chi_x)). +rewrite (inj_in_eq inj_lambda) // => /eqP eq_z12; rewrite eq_z12 in eq12 *. +by rewrite (mulIg _ _ _ eq12). +Qed. + +(* This is Isaacs, Problem (3.7). *) +Lemma gring_classM_coef_sum_eq gT (G : {group gT}) j1 j2 k g1 g2 g : + let a := @gring_classM_coef gT G j1 j2 in let a_k := a k in + g1 \in enum_val j1 -> g2 \in enum_val j2 -> g \in enum_val k -> + let sum12g := \sum_i 'chi[G]_i g1 * 'chi_i g2 * ('chi_i g)^* / 'chi_i 1%g in + a_k%:R = (#|enum_val j1| * #|enum_val j2|)%:R / #|G|%:R * sum12g. +Proof. +move=> a /= Kg1 Kg2 Kg; rewrite mulrAC; apply: canRL (mulfK (neq0CG G)) _. +transitivity (\sum_j (#|G| * a j)%:R *+ (j == k) : algC). + by rewrite (bigD1 k) //= eqxx -natrM mulnC big1 ?addr0 // => j /negPf->. +have defK (j : 'I_#|classes G|) x: x \in enum_val j -> enum_val j = x ^: G. + by have /imsetP[y Gy ->] := enum_valP j => /class_transr. +have Gg: g \in G. + by case/imsetP: (enum_valP k) Kg => x Gx -> /imsetP[y Gy ->]; apply: groupJ. +transitivity (\sum_j \sum_i 'omega_i['K_j] * 'chi_i 1%g * ('chi_i g)^* *+ a j). + apply: eq_bigr => j _; have /imsetP[z Gz Dj] := enum_valP j. + have Kz: z \in enum_val j by rewrite Dj class_refl. + rewrite -(Lagrange (subsetIl G 'C[z])) index_cent1 -mulnA natrM -mulrnAl. + have ->: (j == k) = (z \in enum_val k). + by rewrite -(inj_eq enum_val_inj); apply/eqP/idP=> [<-|/defK->]. + rewrite (defK _ g) // -second_orthogonality_relation // mulr_suml. + apply: eq_bigr=> i _; rewrite natrM mulrA mulr_natr mulrC mulrA. + by rewrite (gring_mode_class_sum_eq i Kz) divfK ?irr1_neq0. +rewrite exchange_big /= mulr_sumr; apply: eq_bigr => i _. +transitivity ('omega_i['K_j1 *m 'K_j2] * 'chi_i 1%g * ('chi_i g)^*). + rewrite gring_classM_expansion -/a raddf_sum !mulr_suml /=. + by apply: eq_bigr => j _; rewrite xcfunZr -!mulrA mulr_natl. +rewrite !mulrA 2![_ / _]mulrAC (defK _ _ Kg1) (defK _ _ Kg2); congr (_ * _). +rewrite gring_irr_modeM ?gring_class_sum_central // mulnC natrM. +rewrite (gring_mode_class_sum_eq i Kg2) !mulrA divfK ?irr1_neq0 //. +by congr (_ * _); rewrite [_ * _]mulrC (gring_mode_class_sum_eq i Kg1) !mulrA. +Qed. + +(* This is Isaacs, Problem (2.16). *) +Lemma index_support_dvd_degree gT (G H : {group gT}) chi : + H \subset G -> chi \is a character -> chi \in 'CF(G, H) -> + (H :==: 1%g) || abelian G -> + (#|G : H| %| chi 1%g)%C. +Proof. +move=> sHG Nchi Hchi ZHG. +suffices: (#|G : H| %| 'Res[H] chi 1%g)%C by rewrite cfResE ?group1. +rewrite ['Res _]cfun_sum_cfdot sum_cfunE rpred_sum // => i _. +rewrite cfunE dvdC_mulr ?Cint_Cnat ?Cnat_irr1 //. +have [j ->]: exists j, 'chi_i = 'Res 'chi[G]_j. + case/predU1P: ZHG => [-> | cGG] in i *. + suffices ->: i = 0 by exists 0; rewrite !irr0 cfRes_cfun1 ?sub1G. + apply/val_inj; case: i => [[|i] //=]; rewrite ltnNge NirrE. + by rewrite (@leq_trans 1) // leqNgt classes_gt1 eqxx. + have linG := char_abelianP G cGG; have linG1 j := eqP (proj2 (andP (linG j))). + have /fin_all_exists[rH DrH] j: exists k, 'Res[H, G] 'chi_j = 'chi_k. + apply/irrP/lin_char_irr/andP. + by rewrite cfRes_char ?irr_char // cfRes1 ?linG1. + suffices{i} all_rH: codom rH =i Iirr H. + by exists (iinv (all_rH i)); rewrite DrH f_iinv. + apply/subset_cardP; last exact/subsetP; apply/esym/eqP. + rewrite card_Iirr_abelian ?(abelianS sHG) //. + rewrite -(eqn_pmul2r (indexg_gt0 G H)) Lagrange //; apply/eqP. + rewrite -sum_nat_const -card_Iirr_abelian // -sum1_card. + rewrite (partition_big rH (mem (codom rH))) /=; last exact: image_f. + have nsHG: H <| G by rewrite -sub_abelian_normal. + apply: eq_bigr => _ /codomP[i ->]; rewrite -card_quotient ?normal_norm //. + rewrite -card_Iirr_abelian ?quotient_abelian //. + have Mlin j1 j2: exists k, 'chi_j1 * 'chi_j2 = 'chi[G]_k. + exact/irrP/lin_char_irr/rpredM. + have /fin_all_exists[rQ DrQ] (j : Iirr (G / H)) := Mlin i (mod_Iirr j). + have mulJi: ('chi[G]_i)^*%CF * 'chi_i = 1. + apply/cfun_inP=> x Gx; rewrite !cfunE -lin_charV_conj ?linG // cfun1E Gx. + by rewrite lin_charV ?mulVf ?lin_char_neq0 ?linG. + have inj_rQ: injective rQ. + move=> j1 j2 /(congr1 (fun k => (('chi_i)^*%CF * 'chi_k) / H)%CF). + by rewrite -!DrQ !mulrA mulJi !mul1r !mod_IirrE ?cfModK // => /irr_inj. + rewrite -(card_imset _ inj_rQ) -sum1_card; apply: eq_bigl => j. + rewrite -(inj_eq irr_inj) -!DrH; apply/eqP/imsetP=> [eq_ij | [k _ ->]]. + have [k Dk] := Mlin (conjC_Iirr i) j; exists (quo_Iirr H k) => //. + apply/irr_inj; rewrite -DrQ quo_IirrK //. + by rewrite -Dk conjC_IirrE mulrCA mulrA mulJi mul1r. + apply/subsetP=> x Hx; have Gx := subsetP sHG x Hx. + rewrite cfkerEirr inE linG1 -Dk conjC_IirrE; apply/eqP. + transitivity ((1 : 'CF(G)) x); last by rewrite cfun1E Gx. + by rewrite -mulJi !cfunE -!(cfResE _ sHG Hx) eq_ij. + rewrite -DrQ; apply/cfun_inP=> x Hx; rewrite !cfResE // cfunE mulrC. + by rewrite cfker1 ?linG1 ?mul1r ?(subsetP _ x Hx) // mod_IirrE ?cfker_mod. +have: (#|G : H| %| #|G : H|%:R * '[chi, 'chi_j])%C. + by rewrite dvdC_mulr ?Cint_Cnat ?Cnat_cfdot_char_irr. +congr (_ %| _)%C; rewrite (cfdotEl _ Hchi) -(Lagrange sHG) mulnC natrM. +rewrite invfM -mulrA mulVKf ?neq0CiG //; congr (_ * _). +by apply: eq_bigr => x Hx; rewrite !cfResE. +Qed. + +(* This is Isaacs, Theorem (3.13). *) +Theorem faithful_degree_p_part gT (p : nat) (G P : {group gT}) i : + cfaithful 'chi[G]_i -> p.-nat (truncC ('chi_i 1%g)) -> + p.-Sylow(G) P -> abelian P -> + 'chi_i 1%g = (#|G : 'Z(G)|`_p)%:R. +Proof. +have [p_pr | pr'p] := boolP (prime p); last first. + have p'n n: (n > 0)%N -> p^'.-nat n. + by move/p'natEpi->; rewrite mem_primes (negPf pr'p). + rewrite irr1_degree natCK => _ /pnat_1-> => [_ _|]. + by rewrite part_p'nat ?p'n. + by rewrite p'n ?irr_degree_gt0. +move=> fful_i /p_natP[a Dchi1] sylP cPP. +have Dchi1C: 'chi_i 1%g = (p ^ a)%:R by rewrite -Dchi1 irr1_degree natCK. +have pa_dv_ZiG: (p ^ a %| #|G : 'Z(G)|)%N. + rewrite -dvdC_nat -[pa in (pa %| _)%C]Dchi1C -(cfcenter_fful_irr fful_i). + exact: dvd_irr1_index_center. +have [sPG pP p'PiG] := and3P sylP. +have ZchiP: 'Res[P] 'chi_i \in 'CF(P, P :&: 'Z(G)). + apply/cfun_onP=> x; rewrite inE; have [Px | /cfun0->//] := boolP (x \in P). + rewrite /= -(cfcenter_fful_irr fful_i) cfResE //. + apply: coprime_degree_support_cfcenter. + rewrite Dchi1 coprime_expl // prime_coprime // -p'natE //. + apply: pnat_dvd p'PiG; rewrite -index_cent1 indexgS // subsetI sPG. + by rewrite sub_cent1 (subsetP cPP). +have /andP[_ nZG] := center_normal G; have nZP := subset_trans sPG nZG. +apply/eqP; rewrite Dchi1C eqr_nat eqn_dvd -{1}(pfactorK a p_pr) -p_part. +rewrite partn_dvd //= -dvdC_nat -[pa in (_ %| pa)%C]Dchi1C -card_quotient //=. +rewrite -(card_Hall (quotient_pHall nZP sylP)) card_quotient // -indexgI. +rewrite -(cfResE _ sPG) // index_support_dvd_degree ?subsetIl ?cPP ?orbT //. +by rewrite cfRes_char ?irr_char. +Qed. + +(* This is Isaacs, Lemma (3.14). *) +(* Note that the assumption that G be cyclic is unnecessary, as S will be *) +(* empty if this is not the case. *) +Lemma sum_norm2_char_generators gT (G : {group gT}) (chi : 'CF(G)) : + let S := [pred s | generator G s] in + chi \is a character -> {in S, forall s, chi s != 0} -> + \sum_(s in S) `|chi s| ^+ 2 >= #|S|%:R. +Proof. +move=> S Nchi nz_chi_S; pose n := #|G|. +have [g Sg | S_0] := pickP (generator G); last first. + by rewrite eq_card0 // big_pred0 ?lerr. +have defG: <[g]> = G by apply/esym/eqP. +have [cycG Gg]: cyclic G /\ g \in G by rewrite -defG cycle_cyclic cycle_id. +pose I := {k : 'I_n | coprime n k}; pose ItoS (k : I) := (g ^+ sval k)%g. +have imItoS: codom ItoS =i S. + move=> s; rewrite inE /= /ItoS /I /n /S -defG -orderE. + apply/codomP/idP=> [[[i cogi] ->] | Ss]; first by rewrite generator_coprime. + have [m ltmg Ds] := cyclePmin (cycle_generator Ss). + by rewrite Ds generator_coprime in Ss; apply: ex_intro (Sub (Sub m _) _) _. +have /injectiveP injItoS: injective ItoS. + move=> k1 k2 /eqP; apply: contraTeq. + by rewrite eq_expg_mod_order orderE defG -/n !modn_small. +have [Qn galQn [QnC gQnC [eps [pr_eps defQn] QnG]]] := group_num_field_exists G. +have{QnG} QnGg := QnG _ G _ _ g (order_dvdG Gg). +pose calG := 'Gal({:Qn} / 1). +have /fin_all_exists2[ItoQ inItoQ defItoQ] (k : I): + exists2 nu, nu \in calG & nu eps = eps ^+ val k. +- case: k => [[m _] /=]; rewrite coprime_sym => /Qn_aut_exists[nuC DnuC]. + have [nuQ DnuQ] := restrict_aut_to_normal_num_field QnC nuC. + have hom_nu: kHom 1 {:Qn} (linfun nuQ). + rewrite k1HomE; apply/ahom_inP. + by split=> [u v | ]; rewrite !lfunE ?rmorphM ?rmorph1. + have [|nu cGnu Dnu] := kHom_to_gal _ (normalFieldf 1) hom_nu. + by rewrite !subvf. + exists nu => //; apply: (fmorph_inj QnC). + rewrite -Dnu ?memvf // lfunE DnuQ rmorphX DnuC //. + by rewrite prim_expr_order // fmorph_primitive_root. +have{defQn} imItoQ: calG = ItoQ @: {:I}. + apply/setP=> nu; apply/idP/imsetP=> [cGnu | [k _ ->] //]. + have pr_nu_e: n.-primitive_root (nu eps) by rewrite fmorph_primitive_root. + have [i Dnue] := prim_rootP pr_eps (prim_expr_order pr_nu_e). + rewrite Dnue prim_root_exp_coprime // coprime_sym in pr_nu_e. + apply: ex_intro2 (Sub i _) _ _ => //; apply/eqP. + rewrite /calG /= -defQn in ItoQ inItoQ defItoQ nu cGnu Dnue *. + by rewrite gal_adjoin_eq // defItoQ -Dnue. +have injItoQ: {in {:I} &, injective ItoQ}. + move=> k1 k2 _ _ /(congr1 (fun nu : gal_of _ => nu eps))/eqP. + by apply: contraTeq; rewrite !defItoQ (eq_prim_root_expr pr_eps) !modn_small. +pose pi1 := \prod_(s in S) chi s; pose pi2 := \prod_(s in S) `|chi s| ^+ 2. +have Qpi1: pi1 \in Crat. + have [a Da] := QnGg _ Nchi; suffices ->: pi1 = QnC (galNorm 1 {:Qn} a). + have /vlineP[q ->] := mem_galNorm galQn (memvf a). + by rewrite rmorphZ_num rmorph1 mulr1 Crat_rat. + rewrite /galNorm rmorph_prod -/calG imItoQ big_imset //=. + rewrite /pi1 -(eq_bigl _ _ imItoS) -big_uniq // big_map big_filter /=. + apply: eq_bigr => k _; have [nuC DnuC] := gQnC (ItoQ k); rewrite DnuC Da. + have [r ->] := char_sum_irr Nchi; rewrite !sum_cfunE rmorph_sum. + apply: eq_bigr => i _; have /QnGg[b Db] := irr_char i. + have Lchi_i: 'chi_i \is a linear_char by rewrite irr_cyclic_lin. + have /(prim_rootP pr_eps)[m Dem]: b ^+ n = 1. + apply/eqP; rewrite -(fmorph_eq1 QnC) rmorphX Db -lin_charX //. + by rewrite -expg_mod_order orderE defG modnn lin_char1. + rewrite -Db -DnuC Dem rmorphX /= defItoQ exprAC -{m}Dem rmorphX {b}Db. + by rewrite lin_charX. +clear I ItoS imItoS injItoS ItoQ inItoQ defItoQ imItoQ injItoQ. +clear Qn galQn QnC gQnC eps pr_eps QnGg calG. +have{Qpi1} Zpi1: pi1 \in Cint. + by rewrite Cint_rat_Aint // rpred_prod // => s _; apply: Aint_char. +have{pi1 Zpi1} pi2_ge1: 1 <= pi2. + have ->: pi2 = `|pi1| ^+ 2. + by rewrite (big_morph Num.norm (@normrM _) (@normr1 _)) -prodrXl. + by rewrite Cint_normK // sqr_Cint_ge1 //; exact/prodf_neq0. +have Sgt0: (#|S| > 0)%N by rewrite (cardD1 g) [g \in S]Sg. +rewrite -mulr_natr -ler_pdivl_mulr ?ltr0n //. +have n2chi_ge0 s: s \in S -> 0 <= `|chi s| ^+ 2 by rewrite exprn_ge0 ?normr_ge0. +rewrite -(expr_ge1 Sgt0); last by rewrite divr_ge0 ?ler0n ?sumr_ge0. +by rewrite (ler_trans pi2_ge1) // lerif_AGM. +Qed. + +(* This is Burnside's vanishing theorem (Isaacs, Theorem (3.15)). *) +Theorem nonlinear_irr_vanish gT (G : {group gT}) i : + 'chi[G]_i 1%g > 1 -> exists2 x, x \in G & 'chi_i x = 0. +Proof. +move=> chi1gt1; apply/exists_eq_inP; apply: contraFT (ltr_geF chi1gt1). +rewrite negb_exists_in => /forall_inP nz_chi. +rewrite -(norm_Cnat (Cnat_irr1 i)) -(@expr_le1 _ 2) ?normr_ge0 //. +rewrite -(ler_add2r (#|G|%:R * '['chi_i])) {1}cfnorm_irr mulr1. +rewrite (cfnormE (cfun_onG _)) mulVKf ?neq0CG // (big_setD1 1%g) //=. +rewrite addrCA ler_add2l (cardsD1 1%g) group1 mulrS ler_add2l. +rewrite -sumr_const !(partition_big_imset (fun s => <[s]>)) /=. +apply: ler_sum => _ /imsetP[g /setD1P[ntg Gg] ->]. +have sgG: <[g]> \subset G by rewrite cycle_subG. +pose S := [pred s | generator <[g]> s]; pose chi := 'Res[<[g]>] 'chi_i. +have defS: [pred s in G^# | <[s]> == <[g]>] =i S. + move=> s; rewrite inE /= eq_sym andb_idl // !inE -cycle_eq1 -cycle_subG. + by move/eqP <-; rewrite cycle_eq1 ntg. +have resS: {in S, 'chi_i =1 chi}. + by move=> s /cycle_generator=> g_s; rewrite cfResE ?cycle_subG. +rewrite !(eq_bigl _ _ defS) sumr_const. +rewrite (eq_bigr (fun s => `|chi s| ^+ 2)) => [|s /resS-> //]. +apply: sum_norm2_char_generators => [|s Ss]. + by rewrite cfRes_char ?irr_char. +by rewrite -resS // nz_chi ?(subsetP sgG) ?cycle_generator. +Qed. + +End MoreIntegralChar. \ No newline at end of file diff --git a/mathcomp/character/mxabelem.v b/mathcomp/character/mxabelem.v new file mode 100644 index 0000000..188000d --- /dev/null +++ b/mathcomp/character/mxabelem.v @@ -0,0 +1,1057 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg poly finset. +Require Import fingroup morphism perm automorphism quotient gproduct action. +Require Import finalg zmodp commutator cyclic center pgroup gseries nilpotent. +Require Import sylow maximal abelian matrix mxalgebra mxrepresentation. + +(******************************************************************************) +(* This file completes the theory developed in mxrepresentation.v with the *) +(* construction and properties of linear representations over finite fields, *) +(* and in particular the correspondance between internal action on a (normal) *) +(* elementary abelian p-subgroup and a linear representation on an Fp-module. *) +(* We provide the following next constructions for a finite field F: *) +(* 'Zm%act == the action of {unit F} on 'M[F]_(m, n). *) +(* rowg A == the additive group of 'rV[F]_n spanned by the row space *) +(* of the matrix A. *) +(* rowg_mx L == the partial inverse to rowg; for any 'Zm-stable group L *) +(* of 'rV[F]_n we have rowg (rowg_mx L) = L. *) +(* GLrepr F n == the natural, faithful representation of 'GL_n[F]. *) +(* reprGLm rG == the morphism G >-> 'GL_n[F] equivalent to the *) +(* representation r of G (with rG : mx_repr r G). *) +(* ('MR rG)%act == the action of G on 'rV[F]_n equivalent to the *) +(* representation r of G (with rG : mx_repr r G). *) +(* The second set of constructions defines the interpretation of a normal *) +(* non-trivial elementary abelian p-subgroup as an 'F_p module. We assume *) +(* abelE : p.-abelem E and ntE : E != 1, throughout, as these are needed to *) +(* build the isomorphism between E and a nontrivial 'rV['F_p]_n. *) +(* 'rV(E) == the type of row vectors of the 'F_p module equivalent *) +(* to E when E is a non-trivial p.-abelem group. *) +(* 'M(E) == the type of matrices corresponding to E. *) +(* 'dim E == the width of vectors/matrices in 'rV(E) / 'M(E). *) +(* abelem_rV abelE ntE == the one-to-one injection of E onto 'rV(E). *) +(* rVabelem abelE ntE == the one-to-one projection of 'rV(E) onto E. *) +(* abelem_repr abelE ntE nEG == the representation of G on 'rV(E) that is *) +(* equivalent to conjugation by G in E; here abelE, ntE are *) +(* as above, and G \subset 'N(E). *) +(* This file end with basic results on p-modular representations of p-groups, *) +(* and theorems giving the structure of the representation of extraspecial *) +(* groups; these results use somewhat more advanced group theory than the *) +(* rest of mxrepresentation, in particular, results of sylow.v and maximal.v. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory FinRing.Theory. +Local Open Scope ring_scope. + +(* Special results for representations on a finite field. In this case, the *) +(* representation is equivalent to a morphism into the general linear group *) +(* 'GL_n[F]. It is furthermore equivalent to a group action on the finite *) +(* additive group of the corresponding row space 'rV_n. In addition, row *) +(* spaces of matrices in 'M[F]_n correspond to subgroups of that vector group *) +(* (this is only surjective when F is a prime field 'F_p), with moduleules *) +(* corresponding to subgroups stabilized by the external action. *) + +Section FinRingRepr. + +Variable (R : finComUnitRingType) (gT : finGroupType). +Variables (G : {group gT}) (n : nat) (rG : mx_representation R G n). + +Definition mx_repr_act (u : 'rV_n) x := u *m rG (val (subg G x)). + +Lemma mx_repr_actE u x : x \in G -> mx_repr_act u x = u *m rG x. +Proof. by move=> Gx; rewrite /mx_repr_act /= subgK. Qed. + +Fact mx_repr_is_action : is_action G mx_repr_act. +Proof. +split=> [x | u x y Gx Gy]; first exact: can_inj (repr_mxK _ (subgP _)). +by rewrite !mx_repr_actE ?groupM // -mulmxA repr_mxM. +Qed. +Canonical Structure mx_repr_action := Action mx_repr_is_action. + +Fact mx_repr_is_groupAction : is_groupAction [set: 'rV[R]_n] mx_repr_action. +Proof. +move=> x Gx /=; rewrite !inE. +apply/andP; split; first by apply/subsetP=> u; rewrite !inE. +by apply/morphicP=> /= u v _ _; rewrite !actpermE /= /mx_repr_act mulmxDl. +Qed. +Canonical Structure mx_repr_groupAction := GroupAction mx_repr_is_groupAction. + +End FinRingRepr. + +Notation "''MR' rG" := (mx_repr_action rG) + (at level 10, rG at level 8) : action_scope. +Notation "''MR' rG" := (mx_repr_groupAction rG) : groupAction_scope. + +Section FinFieldRepr. + +Variable F : finFieldType. + +(* The external group action (by scaling) of the multiplicative unit group *) +(* of the finite field, and the correspondence between additive subgroups *) +(* of row vectors that are stable by this action, and the matrix row spaces. *) +Section ScaleAction. + +Variables m n : nat. + +Definition scale_act (A : 'M[F]_(m, n)) (a : {unit F}) := val a *: A. +Lemma scale_actE A a : scale_act A a = val a *: A. Proof. by []. Qed. +Fact scale_is_action : is_action setT scale_act. +Proof. +apply: is_total_action=> [A | A a b]; rewrite /scale_act ?scale1r //. +by rewrite ?scalerA mulrC. +Qed. +Canonical scale_action := Action scale_is_action. +Fact scale_is_groupAction : is_groupAction setT scale_action. +Proof. +move=> a _ /=; rewrite inE; apply/andP. +split; first by apply/subsetP=> A; rewrite !inE. +by apply/morphicP=> u A _ _ /=; rewrite !actpermE /= /scale_act scalerDr. +Qed. +Canonical scale_groupAction := GroupAction scale_is_groupAction. + +Lemma astab1_scale_act A : A != 0 -> 'C[A | scale_action] = 1%g. +Proof. +rewrite -mxrank_eq0=> nzA; apply/trivgP/subsetP=> a; apply: contraLR. +rewrite !inE -val_eqE -subr_eq0 sub1set !inE => nz_a1. +by rewrite -subr_eq0 -scaleN1r -scalerDl -mxrank_eq0 eqmx_scale. +Qed. + +End ScaleAction. + +Local Notation "'Zm" := (scale_action _ _) (at level 8) : action_scope. + +Section RowGroup. + +Variable n : nat. +Local Notation rVn := 'rV[F]_n. + +Definition rowg m (A : 'M[F]_(m, n)) : {set rVn} := [set u | u <= A]%MS. + +Lemma mem_rowg m A v : (v \in @rowg m A) = (v <= A)%MS. +Proof. by rewrite inE. Qed. + +Fact rowg_group_set m A : group_set (@rowg m A). +Proof. +by apply/group_setP; split=> [|u v]; rewrite !inE ?sub0mx //; exact: addmx_sub. +Qed. +Canonical rowg_group m A := Group (@rowg_group_set m A). + +Lemma rowg_stable m (A : 'M_(m, n)) : [acts setT, on rowg A | 'Zm]. +Proof. by apply/actsP=> a _ v; rewrite !inE eqmx_scale // -unitfE (valP a). Qed. + +Lemma rowgS m1 m2 (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (rowg A \subset rowg B) = (A <= B)%MS. +Proof. +apply/subsetP/idP=> sAB => [| u]. + by apply/row_subP=> i; have:= sAB (row i A); rewrite !inE row_sub => ->. +by rewrite !inE => suA; exact: submx_trans sAB. +Qed. + +Lemma eq_rowg m1 m2 (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + (A :=: B)%MS -> rowg A = rowg B. +Proof. by move=> eqAB; apply/eqP; rewrite eqEsubset !rowgS !eqAB andbb. Qed. + +Lemma rowg0 m : rowg (0 : 'M_(m, n)) = 1%g. +Proof. by apply/trivgP/subsetP=> v; rewrite !inE eqmx0 submx0. Qed. + +Lemma rowg1 : rowg 1%:M = setT. +Proof. by apply/setP=> x; rewrite !inE submx1. Qed. + +Lemma trivg_rowg m (A : 'M_(m, n)) : (rowg A == 1%g) = (A == 0). +Proof. by rewrite -submx0 -rowgS rowg0 (sameP trivgP eqP). Qed. + +Definition rowg_mx (L : {set rVn}) := <<\matrix_(i < #|L|) enum_val i>>%MS. + +Lemma rowgK m (A : 'M_(m, n)) : (rowg_mx (rowg A) :=: A)%MS. +Proof. +apply/eqmxP; rewrite !genmxE; apply/andP; split. + by apply/row_subP=> i; rewrite rowK; have:= enum_valP i; rewrite /= inE. +apply/row_subP=> i; set v := row i A. +have Av: v \in rowg A by rewrite inE row_sub. +by rewrite (eq_row_sub (enum_rank_in Av v)) // rowK enum_rankK_in. +Qed. + +Lemma rowg_mxS (L M : {set 'rV[F]_n}) : + L \subset M -> (rowg_mx L <= rowg_mx M)%MS. +Proof. +move/subsetP=> sLM; rewrite !genmxE; apply/row_subP=> i. +rewrite rowK; move: (enum_val i) (sLM _ (enum_valP i)) => v Mv. +by rewrite (eq_row_sub (enum_rank_in Mv v)) // rowK enum_rankK_in. +Qed. + +Lemma sub_rowg_mx (L : {set rVn}) : L \subset rowg (rowg_mx L). +Proof. +apply/subsetP=> v Lv; rewrite inE genmxE. +by rewrite (eq_row_sub (enum_rank_in Lv v)) // rowK enum_rankK_in. +Qed. + +Lemma stable_rowg_mxK (L : {group rVn}) : + [acts setT, on L | 'Zm] -> rowg (rowg_mx L) = L. +Proof. +move=> linL; apply/eqP; rewrite eqEsubset sub_rowg_mx andbT. +apply/subsetP=> v; rewrite inE genmxE => /submxP[u ->{v}]. +rewrite mulmx_sum_row group_prod // => i _. +rewrite rowK; move: (enum_val i) (enum_valP i) => v Lv. +case: (eqVneq (u 0 i) 0) => [->|]; first by rewrite scale0r group1. +by rewrite -unitfE => aP; rewrite ((actsP linL) (FinRing.Unit _ aP)) ?inE. +Qed. + +Lemma rowg_mx1 : rowg_mx 1%g = 0. +Proof. by apply/eqP; rewrite -submx0 -(rowg0 0) rowgK sub0mx. Qed. + +Lemma rowg_mx_eq0 (L : {group rVn}) : (rowg_mx L == 0) = (L :==: 1%g). +Proof. +rewrite -trivg_rowg; apply/idP/idP=> [|/eqP->]; last by rewrite rowg_mx1 rowg0. +by rewrite !(sameP eqP trivgP); apply: subset_trans; exact: sub_rowg_mx. +Qed. + +Lemma rowgI m1 m2 (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + rowg (A :&: B)%MS = rowg A :&: rowg B. +Proof. by apply/setP=> u; rewrite !inE sub_capmx. Qed. + +Lemma card_rowg m (A : 'M_(m, n)) : #|rowg A| = (#|F| ^ \rank A)%N. +Proof. +rewrite -[\rank A]mul1n -card_matrix. +have injA: injective (mulmxr (row_base A)). + have /row_freeP[A' A'K] := row_base_free A. + by move=> ?; apply: can_inj (mulmxr A') _ => u; rewrite /= -mulmxA A'K mulmx1. +rewrite -(card_image (injA _)); apply: eq_card => v. +by rewrite inE -(eq_row_base A) (sameP submxP codomP). +Qed. + +Lemma rowgD m1 m2 (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + rowg (A + B)%MS = (rowg A * rowg B)%g. +Proof. +apply/eqP; rewrite eq_sym eqEcard mulG_subG /= !rowgS. +rewrite addsmxSl addsmxSr -(@leq_pmul2r #|rowg A :&: rowg B|) ?cardG_gt0 //=. +by rewrite -mul_cardG -rowgI !card_rowg -!expnD mxrank_sum_cap. +Qed. + +Lemma cprod_rowg m1 m2 (A : 'M_(m1, n)) (B : 'M_(m2, n)) : + rowg A \* rowg B = rowg (A + B)%MS. +Proof. by rewrite rowgD cprodE // (sub_abelian_cent2 (zmod_abelian setT)). Qed. + +Lemma dprod_rowg m1 m2 (A : 'M[F]_(m1, n)) (B : 'M[F]_(m2, n)) : + mxdirect (A + B) -> rowg A \x rowg B = rowg (A + B)%MS. +Proof. +rewrite (sameP mxdirect_addsP eqP) -trivg_rowg rowgI => /eqP tiAB. +by rewrite -cprod_rowg dprodEcp. +Qed. + +Lemma bigcprod_rowg m I r (P : pred I) (A : I -> 'M[F]_n) (B : 'M[F]_(m, n)) : + (\sum_(i <- r | P i) A i :=: B)%MS -> + \big[cprod/1%g]_(i <- r | P i) rowg (A i) = rowg B. +Proof. +by move/eq_rowg <-; apply/esym/big_morph=> [? ?|]; rewrite (rowg0, cprod_rowg). +Qed. + +Lemma bigdprod_rowg m (I : finType) (P : pred I) A (B : 'M[F]_(m, n)) : + let S := (\sum_(i | P i) A i)%MS in (S :=: B)%MS -> mxdirect S -> + \big[dprod/1%g]_(i | P i) rowg (A i) = rowg B. +Proof. +move=> S defS; rewrite mxdirectE defS /= => /eqP rankB. +apply: bigcprod_card_dprod (bigcprod_rowg defS) (eq_leq _). +by rewrite card_rowg rankB expn_sum; apply: eq_bigr => i _; rewrite card_rowg. +Qed. + +End RowGroup. + +Variables (gT : finGroupType) (G : {group gT}) (n' : nat). +Local Notation n := n'.+1. +Variable (rG : mx_representation F G n). + +Fact GL_mx_repr : mx_repr 'GL_n[F] GLval. Proof. by []. Qed. +Canonical GLrepr := MxRepresentation GL_mx_repr. + +Lemma GLmx_faithful : mx_faithful GLrepr. +Proof. by apply/subsetP=> A; rewrite !inE mul1mx. Qed. + +Definition reprGLm x : {'GL_n[F]} := insubd (1%g : {'GL_n[F]}) (rG x). + +Lemma val_reprGLm x : x \in G -> val (reprGLm x) = rG x. +Proof. by move=> Gx; rewrite val_insubd (repr_mx_unitr rG). Qed. + +Lemma comp_reprGLm : {in G, GLval \o reprGLm =1 rG}. +Proof. exact: val_reprGLm. Qed. + +Lemma reprGLmM : {in G &, {morph reprGLm : x y / x * y}}%g. +Proof. +by move=> x y Gx Gy; apply: val_inj; rewrite /= !val_reprGLm ?groupM ?repr_mxM. +Qed. +Canonical reprGL_morphism := Morphism reprGLmM. + +Lemma ker_reprGLm : 'ker reprGLm = rker rG. +Proof. +apply/setP=> x; rewrite !inE mul1mx; apply: andb_id2l => Gx. +by rewrite -val_eqE val_reprGLm. +Qed. + +Lemma astab_rowg_repr m (A : 'M_(m, n)) : 'C(rowg A | 'MR rG) = rstab rG A. +Proof. +apply/setP=> x; rewrite !inE /=; apply: andb_id2l => Gx. +apply/subsetP/eqP=> cAx => [|u]; last first. + by rewrite !inE mx_repr_actE // => /submxP[u' ->]; rewrite -mulmxA cAx. +apply/row_matrixP=> i; apply/eqP; move/implyP: (cAx (row i A)). +by rewrite !inE row_sub mx_repr_actE //= row_mul. +Qed. + +Lemma astabs_rowg_repr m (A : 'M_(m, n)) : 'N(rowg A | 'MR rG) = rstabs rG A. +Proof. +apply/setP=> x; rewrite !inE /=; apply: andb_id2l => Gx. +apply/subsetP/idP=> nAx => [|u]; last first. + rewrite !inE mx_repr_actE // => Au; exact: (submx_trans (submxMr _ Au)). +apply/row_subP=> i; move/implyP: (nAx (row i A)). +by rewrite !inE row_sub mx_repr_actE //= row_mul. +Qed. + +Lemma acts_rowg (A : 'M_n) : [acts G, on rowg A | 'MR rG] = mxmodule rG A. +Proof. by rewrite astabs_rowg_repr. Qed. + +Lemma astab_setT_repr : 'C(setT | 'MR rG) = rker rG. +Proof. by rewrite -rowg1 astab_rowg_repr. Qed. + +Lemma mx_repr_action_faithful : + [faithful G, on setT | 'MR rG] = mx_faithful rG. +Proof. +by rewrite /faithful astab_setT_repr (setIidPr _) // [rker _]setIdE subsetIl. +Qed. + +Lemma afix_repr (H : {set gT}) : + H \subset G -> 'Fix_('MR rG)(H) = rowg (rfix_mx rG H). +Proof. +move/subsetP=> sHG; apply/setP=> /= u; rewrite !inE. +apply/subsetP/rfix_mxP=> cHu x Hx; have:= cHu x Hx; + by rewrite !inE /= => /eqP; rewrite mx_repr_actE ?sHG. +Qed. + +Lemma gacent_repr (H : {set gT}) : + H \subset G -> 'C_(| 'MR rG)(H) = rowg (rfix_mx rG H). +Proof. by move=> sHG; rewrite gacentE // setTI afix_repr. Qed. + +End FinFieldRepr. + +Arguments Scope rowg_mx [_ _ group_scope]. +Notation "''Zm'" := (scale_action _ _ _) (at level 8) : action_scope. +Notation "''Zm'" := (scale_groupAction _ _ _) : groupAction_scope. + +Section MatrixGroups. + +Implicit Types m n p q : nat. + +Lemma exponent_mx_group m n q : + m > 0 -> n > 0 -> q > 1 -> exponent [set: 'M['Z_q]_(m, n)] = q. +Proof. +move=> m_gt0 n_gt0 q_gt1; apply/eqP; rewrite eqn_dvd; apply/andP; split. + apply/exponentP=> x _; apply/matrixP=> i j; rewrite mulmxnE !mxE. + by rewrite -mulr_natr -Zp_nat_mod // modnn mulr0. +pose cmx1 := const_mx 1%R : 'M['Z_q]_(m, n). +apply: dvdn_trans (dvdn_exponent (in_setT cmx1)). +have/matrixP/(_ (Ordinal m_gt0))/(_ (Ordinal n_gt0))/eqP := expg_order cmx1. +by rewrite mulmxnE !mxE -order_dvdn order_Zp1 Zp_cast. +Qed. + +Lemma rank_mx_group m n q : 'r([set: 'M['Z_q]_(m, n)]) = (m * n)%N. +Proof. +wlog q_gt1: q / q > 1 by case: q => [|[|q -> //]] /(_ 2)->. +set G := setT; have cGG: abelian G := zmod_abelian _. +have [mn0 | ] := posnP (m * n). + by rewrite [G](card1_trivg _) ?rank1 // cardsT card_matrix mn0. +rewrite muln_gt0 => /andP[m_gt0 n_gt0]. +have expG: exponent G = q := exponent_mx_group m_gt0 n_gt0 q_gt1. +apply/eqP; rewrite eqn_leq andbC -(leq_exp2l _ _ q_gt1) -{2}expG. +have ->: (q ^ (m * n))%N = #|G| by rewrite cardsT card_matrix card_ord Zp_cast. +rewrite max_card_abelian //= -grank_abelian //= -/G. +pose B : {set 'M['Z_q]_(m, n)} := [set delta_mx ij.1 ij.2 | ij : 'I_m * 'I_n]. +suffices ->: G = <>. + have ->: (m * n)%N = #|{: 'I_m * 'I_n}| by rewrite card_prod !card_ord. + exact: leq_trans (grank_min _) (leq_imset_card _ _). +apply/setP=> v; rewrite inE (matrix_sum_delta v). +rewrite group_prod // => i _; rewrite group_prod // => j _. +rewrite -[v i j]natr_Zp scaler_nat groupX // mem_gen //. +by apply/imsetP; exists (i, j). +Qed. + +Lemma mx_group_homocyclic m n q : homocyclic [set: 'M['Z_q]_(m, n)]. +Proof. +wlog q_gt1: q / q > 1 by case: q => [|[|q -> //]] /(_ 2)->. +set G := setT; have cGG: abelian G := zmod_abelian _. +rewrite -max_card_abelian //= rank_mx_group cardsT card_matrix card_ord -/G. +rewrite {1}Zp_cast //; have [-> // | ] := posnP (m * n). +by rewrite muln_gt0 => /andP[m_gt0 n_gt0]; rewrite exponent_mx_group. +Qed. + +Lemma abelian_type_mx_group m n q : + q > 1 -> abelian_type [set: 'M['Z_q]_(m, n)] = nseq (m * n) q. +Proof. +rewrite (abelian_type_homocyclic (mx_group_homocyclic m n q)) rank_mx_group. +have [-> // | ] := posnP (m * n); rewrite muln_gt0 => /andP[m_gt0 n_gt0] q_gt1. +by rewrite exponent_mx_group. +Qed. + +End MatrixGroups. + +Delimit Scope abelem_scope with Mg. +Open Scope abelem_scope. + +Definition abelem_dim' (gT : finGroupType) (E : {set gT}) := + (logn (pdiv #|E|) #|E|).-1. +Arguments Scope abelem_dim' [_ group_scope]. +Notation "''dim' E" := (abelem_dim' E).+1 + (at level 10, E at level 8, format "''dim' E") : abelem_scope. + +Notation "''rV' ( E )" := 'rV_('dim E) + (at level 8, format "''rV' ( E )") : abelem_scope. +Notation "''M' ( E )" := 'M_('dim E) + (at level 8, format "''M' ( E )") : abelem_scope. +Notation "''rV[' F ] ( E )" := 'rV[F]_('dim E) + (at level 8, only parsing) : abelem_scope. +Notation "''M[' F ] ( E )" := 'M[F]_('dim E) + (at level 8, only parsing) : abelem_scope. + +Section AbelemRepr. + +Section FpMatrix. + +Variables p m n : nat. +Local Notation Mmn := 'M['F_p]_(m, n). + +Lemma mx_Fp_abelem : prime p -> p.-abelem [set: Mmn]. +Proof. +move=> p_pr; apply/abelemP=> //; rewrite zmod_abelian. +split=> //= v _; rewrite zmodXgE -scaler_nat. +by case/andP: (char_Fp p_pr) => _ /eqP->; rewrite scale0r. +Qed. + +Lemma mx_Fp_stable (L : {group Mmn}) : [acts setT, on L | 'Zm]. +Proof. +apply/subsetP=> a _; rewrite !inE; apply/subsetP=> A L_A. +by rewrite inE /= /scale_act -[val _]natr_Zp scaler_nat groupX. +Qed. + +End FpMatrix. + +Section FpRow. + +Variables p n : nat. +Local Notation rVn := 'rV['F_p]_n. + +Lemma rowg_mxK (L : {group rVn}) : rowg (rowg_mx L) = L. +Proof. by apply: stable_rowg_mxK; exact: mx_Fp_stable. Qed. + +Lemma rowg_mxSK (L : {set rVn}) (M : {group rVn}) : + (rowg_mx L <= rowg_mx M)%MS = (L \subset M). +Proof. +apply/idP/idP; last exact: rowg_mxS. +by rewrite -rowgS rowg_mxK; apply: subset_trans; exact: sub_rowg_mx. +Qed. + +Lemma mxrank_rowg (L : {group rVn}) : + prime p -> \rank (rowg_mx L) = logn p #|L|. +Proof. +by move=> p_pr; rewrite -{2}(rowg_mxK L) card_rowg card_Fp ?pfactorK. +Qed. + +End FpRow. + +Variables (p : nat) (gT : finGroupType) (E : {group gT}). +Hypotheses (abelE : p.-abelem E) (ntE : E :!=: 1%g). + +Let pE : p.-group E := abelem_pgroup abelE. +Let p_pr : prime p. Proof. by have [] := pgroup_pdiv pE ntE. Qed. + +Local Notation n' := (abelem_dim' (gval E)). +Local Notation n := n'.+1. +Local Notation rVn := 'rV['F_p](gval E). + +Lemma dim_abelemE : n = logn p #|E|. +Proof. +rewrite /n'; have [_ _ [k ->]] := pgroup_pdiv pE ntE. +by rewrite /pdiv primes_exp ?primes_prime // pfactorK. +Qed. + +Lemma card_abelem_rV : #|rVn| = #|E|. +Proof. +by rewrite dim_abelemE card_matrix mul1n card_Fp // -p_part part_pnat_id. +Qed. + +Lemma isog_abelem_rV : E \isog [set: rVn]. +Proof. +by rewrite (isog_abelem_card _ abelE) cardsT card_abelem_rV mx_Fp_abelem /=. +Qed. + +Local Notation ab_rV_P := (existsP isog_abelem_rV). +Definition abelem_rV : gT -> rVn := xchoose ab_rV_P. + +Local Notation ErV := abelem_rV. + +Lemma abelem_rV_M : {in E &, {morph ErV : x y / (x * y)%g >-> x + y}}. +Proof. by case/misomP: (xchooseP ab_rV_P) => fM _; move/morphicP: fM. Qed. + +Canonical abelem_rV_morphism := Morphism abelem_rV_M. + +Lemma abelem_rV_isom : isom E setT ErV. +Proof. by case/misomP: (xchooseP ab_rV_P). Qed. + +Lemma abelem_rV_injm : 'injm ErV. Proof. by case/isomP: abelem_rV_isom. Qed. + +Lemma abelem_rV_inj : {in E &, injective ErV}. +Proof. by apply/injmP; exact: abelem_rV_injm. Qed. + +Lemma im_abelem_rV : ErV @* E = setT. Proof. by case/isomP: abelem_rV_isom. Qed. + +Lemma mem_im_abelem_rV u : u \in ErV @* E. +Proof. by rewrite im_abelem_rV inE. Qed. + +Lemma sub_im_abelem_rV mA : subset mA (mem (ErV @* E)). +Proof. by rewrite unlock; apply/pred0P=> v /=; rewrite mem_im_abelem_rV. Qed. +Hint Resolve mem_im_abelem_rV sub_im_abelem_rV. + +Lemma abelem_rV_1 : ErV 1 = 0%R. Proof. by rewrite morph1. Qed. + +Lemma abelem_rV_X x i : x \in E -> ErV (x ^+ i) = i%:R *: ErV x. +Proof. by move=> Ex; rewrite morphX // scaler_nat. Qed. + +Lemma abelem_rV_V x : x \in E -> ErV x^-1 = - ErV x. +Proof. by move=> Ex; rewrite morphV. Qed. + +Definition rVabelem : rVn -> gT := invm abelem_rV_injm. +Canonical rVabelem_morphism := [morphism of rVabelem]. +Local Notation rV_E := rVabelem. + +Lemma rVabelem0 : rV_E 0 = 1%g. Proof. exact: morph1. Qed. + +Lemma rVabelemD : {morph rV_E : u v / u + v >-> (u * v)%g}. +Proof. by move=> u v /=; rewrite -morphM. Qed. + +Lemma rVabelemN : {morph rV_E: u / - u >-> (u^-1)%g}. +Proof. by move=> u /=; rewrite -morphV. Qed. + +Lemma rVabelemZ (m : 'F_p) : {morph rV_E : u / m *: u >-> (u ^+ m)%g}. +Proof. by move=> u; rewrite /= -morphX -?[(u ^+ m)%g]scaler_nat ?natr_Zp. Qed. + +Lemma abelem_rV_K : {in E, cancel ErV rV_E}. Proof. exact: invmE. Qed. + +Lemma rVabelemK : cancel rV_E ErV. Proof. by move=> u; rewrite invmK. Qed. + +Lemma rVabelem_inj : injective rV_E. Proof. exact: can_inj rVabelemK. Qed. + +Lemma rVabelem_injm : 'injm rV_E. Proof. exact: injm_invm abelem_rV_injm. Qed. + +Lemma im_rVabelem : rV_E @* setT = E. +Proof. by rewrite -im_abelem_rV im_invm. Qed. + +Lemma mem_rVabelem u : rV_E u \in E. +Proof. by rewrite -im_rVabelem mem_morphim. Qed. + +Lemma sub_rVabelem L : rV_E @* L \subset E. +Proof. by rewrite -[_ @* L]morphimIim im_invm subsetIl. Qed. +Hint Resolve mem_rVabelem sub_rVabelem. + +Lemma card_rVabelem L : #|rV_E @* L| = #|L|. +Proof. by rewrite card_injm ?rVabelem_injm. Qed. + +Lemma abelem_rV_mK (H : {set gT}) : H \subset E -> rV_E @* (ErV @* H) = H. +Proof. exact: morphim_invm abelem_rV_injm H. Qed. + +Lemma rVabelem_mK L : ErV @* (rV_E @* L) = L. +Proof. by rewrite morphim_invmE morphpreK. Qed. + +Lemma rVabelem_minj : injective (morphim (MorPhantom rV_E)). +Proof. exact: can_inj rVabelem_mK. Qed. + +Lemma rVabelemS L M : (rV_E @* L \subset rV_E @* M) = (L \subset M). +Proof. by rewrite injmSK ?rVabelem_injm. Qed. + +Lemma abelem_rV_S (H K : {set gT}) : + H \subset E -> (ErV @* H \subset ErV @* K) = (H \subset K). +Proof. by move=> sHE; rewrite injmSK ?abelem_rV_injm. Qed. + +Lemma sub_rVabelem_im L (H : {set gT}) : + (rV_E @* L \subset H) = (L \subset ErV @* H). +Proof. by rewrite sub_morphim_pre ?morphpre_invm. Qed. + +Lemma sub_abelem_rV_im (H : {set gT}) (L : {set 'rV['F_p]_n}) : + H \subset E -> (ErV @* H \subset L) = (H \subset rV_E @* L). +Proof. by move=> sHE; rewrite sub_morphim_pre ?morphim_invmE. Qed. + +Section OneGroup. + +Variable G : {group gT}. +Definition abelem_mx_fun (g : subg_of G) v := ErV ((rV_E v) ^ val g). +Definition abelem_mx of G \subset 'N(E) := + fun x => lin1_mx (abelem_mx_fun (subg G x)). + +Hypothesis nEG : G \subset 'N(E). +Local Notation r := (abelem_mx nEG). + +Fact abelem_mx_linear_proof g : linear (abelem_mx_fun g). +Proof. +rewrite /abelem_mx_fun; case: g => x /= /(subsetP nEG) Nx /= m u v. +rewrite rVabelemD rVabelemZ conjMg conjXg. +by rewrite abelem_rV_M ?abelem_rV_X ?groupX ?memJ_norm // natr_Zp. +Qed. +Canonical abelem_mx_linear g := Linear (abelem_mx_linear_proof g). + +Let rVabelemJmx v x : x \in G -> rV_E (v *m r x) = (rV_E v) ^ x. +Proof. +move=> Gx; rewrite /= mul_rV_lin1 /= /abelem_mx_fun subgK //. +by rewrite abelem_rV_K // memJ_norm // (subsetP nEG). +Qed. + +Fact abelem_mx_repr : mx_repr G r. +Proof. +split=> [|x y Gx Gy]; apply/row_matrixP=> i; apply: rVabelem_inj. + by rewrite rowE -row1 rVabelemJmx // conjg1. +by rewrite !rowE mulmxA !rVabelemJmx ?groupM // conjgM. +Qed. +Canonical abelem_repr := MxRepresentation abelem_mx_repr. +Let rG := abelem_repr. + +Lemma rVabelemJ v x : x \in G -> rV_E (v *m rG x) = (rV_E v) ^ x. +Proof. exact: rVabelemJmx. Qed. + +Lemma abelem_rV_J : {in E & G, forall x y, ErV (x ^ y) = ErV x *m rG y}. +Proof. +by move=> x y Ex Gy; rewrite -{1}(abelem_rV_K Ex) -rVabelemJ ?rVabelemK. +Qed. + +Lemma abelem_rowgJ m (A : 'M_(m, n)) x : + x \in G -> rV_E @* rowg (A *m rG x) = (rV_E @* rowg A) :^ x. +Proof. +move=> Gx; apply: (canRL (conjsgKV _)); apply/setP=> y. +rewrite mem_conjgV !morphim_invmE !inE memJ_norm ?(subsetP nEG) //=. +apply: andb_id2l => Ey; rewrite abelem_rV_J //. +by rewrite submxMfree // row_free_unit (repr_mx_unit rG). +Qed. + +Lemma rV_abelem_sJ (L : {group gT}) x : + x \in G -> L \subset E -> ErV @* (L :^ x) = rowg (rowg_mx (ErV @* L) *m rG x). +Proof. +move=> Gx sLE; apply: rVabelem_minj; rewrite abelem_rowgJ //. +by rewrite rowg_mxK !morphim_invm // -(normsP nEG x Gx) conjSg. +Qed. + +Lemma rstab_abelem m (A : 'M_(m, n)) : rstab rG A = 'C_G(rV_E @* rowg A). +Proof. +apply/setP=> x; rewrite !inE /=; apply: andb_id2l => Gx. +apply/eqP/centP=> cAx => [_ /morphimP[u _ Au ->]|]. + move: Au; rewrite inE => /submxP[u' ->] {u}. + by apply/esym/commgP/conjg_fixP; rewrite -rVabelemJ -?mulmxA ?cAx. +apply/row_matrixP=> i; apply: rVabelem_inj. +by rewrite row_mul rVabelemJ // /conjg -cAx ?mulKg ?mem_morphim // inE row_sub. +Qed. + +Lemma rstabs_abelem m (A : 'M_(m, n)) : rstabs rG A = 'N_G(rV_E @* rowg A). +Proof. +apply/setP=> x; rewrite !inE /=; apply: andb_id2l => Gx. +by rewrite -rowgS -rVabelemS abelem_rowgJ. +Qed. + +Lemma rstabs_abelemG (L : {group gT}) : + L \subset E -> rstabs rG (rowg_mx (ErV @* L)) = 'N_G(L). +Proof. by move=> sLE; rewrite rstabs_abelem rowg_mxK morphim_invm. Qed. + +Lemma mxmodule_abelem m (U : 'M['F_p]_(m, n)) : + mxmodule rG U = (G \subset 'N(rV_E @* rowg U)). +Proof. by rewrite -subsetIidl -rstabs_abelem. Qed. + +Lemma mxmodule_abelemG (L : {group gT}) : + L \subset E -> mxmodule rG (rowg_mx (ErV @* L)) = (G \subset 'N(L)). +Proof. by move=> sLE; rewrite -subsetIidl -rstabs_abelemG. Qed. + +Lemma mxsimple_abelemP (U : 'M['F_p]_n) : + reflect (mxsimple rG U) (minnormal (rV_E @* rowg U) G). +Proof. +apply: (iffP mingroupP) => [[/andP[ntU modU] minU] | [modU ntU minU]]. + split=> [||V modV sVU ntV]; first by rewrite mxmodule_abelem. + by apply: contraNneq ntU => ->; rewrite /= rowg0 morphim1. + rewrite -rowgS -rVabelemS [_ @* rowg V]minU //. + rewrite -subG1 sub_rVabelem_im morphim1 subG1 trivg_rowg ntV /=. + by rewrite -mxmodule_abelem. + by rewrite rVabelemS rowgS. +split=> [|D /andP[ntD nDG sDU]]. + rewrite -subG1 sub_rVabelem_im morphim1 subG1 trivg_rowg ntU /=. + by rewrite -mxmodule_abelem. +apply/eqP; rewrite eqEsubset sDU sub_rVabelem_im /= -rowg_mxSK rowgK. +have sDE: D \subset E := subset_trans sDU (sub_rVabelem _). +rewrite minU ?mxmodule_abelemG //. + by rewrite -rowgS rowg_mxK sub_abelem_rV_im. +by rewrite rowg_mx_eq0 (morphim_injm_eq1 abelem_rV_injm). +Qed. + +Lemma mxsimple_abelemGP (L : {group gT}) : + L \subset E -> reflect (mxsimple rG (rowg_mx (ErV @* L))) (minnormal L G). +Proof. +move/abelem_rV_mK=> {2}<-; rewrite -{2}[_ @* L]rowg_mxK. +exact: mxsimple_abelemP. +Qed. + +Lemma abelem_mx_irrP : reflect (mx_irreducible rG) (minnormal E G). +Proof. +by rewrite -[E in minnormal E G]im_rVabelem -rowg1; exact: mxsimple_abelemP. +Qed. + +Lemma rfix_abelem (H : {set gT}) : + H \subset G -> (rfix_mx rG H :=: rowg_mx (ErV @* 'C_E(H)%g))%MS. +Proof. +move/subsetP=> sHG; apply/eqmxP/andP; split. + rewrite -rowgS rowg_mxK -sub_rVabelem_im // subsetI sub_rVabelem /=. + apply/centsP=> y /morphimP[v _]; rewrite inE => cGv ->{y} x Gx. + by apply/commgP/conjg_fixP; rewrite /= -rVabelemJ ?sHG ?(rfix_mxP H _). +rewrite genmxE; apply/rfix_mxP=> x Hx; apply/row_matrixP=> i. +rewrite row_mul rowK; case/morphimP: (enum_valP i) => z Ez /setIP[_ cHz] ->. +by rewrite -abelem_rV_J ?sHG // conjgE (centP cHz) ?mulKg. +Qed. + +Lemma rker_abelem : rker rG = 'C_G(E). +Proof. by rewrite /rker rstab_abelem rowg1 im_rVabelem. Qed. + +Lemma abelem_mx_faithful : 'C_G(E) = 1%g -> mx_faithful rG. +Proof. by rewrite /mx_faithful rker_abelem => ->. Qed. + +End OneGroup. + +Section SubGroup. + +Variables G H : {group gT}. +Hypotheses (nEG : G \subset 'N(E)) (sHG : H \subset G). +Let nEH := subset_trans sHG nEG. +Local Notation rG := (abelem_repr nEG). +Local Notation rHG := (subg_repr rG sHG). +Local Notation rH := (abelem_repr nEH). + +Lemma eq_abelem_subg_repr : {in H, rHG =1 rH}. +Proof. +move=> x Hx; apply/row_matrixP=> i; rewrite !rowE !mul_rV_lin1 /=. +by rewrite /abelem_mx_fun !subgK ?(subsetP sHG). +Qed. + +Lemma rsim_abelem_subg : mx_rsim rHG rH. +Proof. +exists 1%:M => // [|x Hx]; first by rewrite row_free_unit unitmx1. +by rewrite mul1mx mulmx1 eq_abelem_subg_repr. +Qed. + +Lemma mxmodule_abelem_subg m (U : 'M_(m, n)) : mxmodule rHG U = mxmodule rH U. +Proof. +apply: eq_subset_r => x; rewrite !inE; apply: andb_id2l => Hx. +by rewrite eq_abelem_subg_repr. +Qed. + +Lemma mxsimple_abelem_subg U : mxsimple rHG U <-> mxsimple rH U. +Proof. +have eq_modH := mxmodule_abelem_subg; rewrite /mxsimple eq_modH. +by split=> [] [-> -> minU]; split=> // V; have:= minU V; rewrite eq_modH. +Qed. + +End SubGroup. + +End AbelemRepr. + +Section ModularRepresentation. + +Variables (F : fieldType) (p : nat) (gT : finGroupType). +Hypothesis charFp : p \in [char F]. +Implicit Types G H : {group gT}. + +(* This is Gorenstein, Lemma 2.6.3. *) +Lemma rfix_pgroup_char G H n (rG : mx_representation F G n) : + n > 0 -> p.-group H -> H \subset G -> rfix_mx rG H != 0. +Proof. +move=> n_gt0 pH sHG; rewrite -(rfix_subg rG sHG). +move: {2}_.+1 (ltnSn (n + #|H|)) {rG G sHG}(subg_repr _ _) => m. +elim: m gT H pH => // m IHm gT' G pG in n n_gt0 *; rewrite ltnS => le_nG_m rG. +apply/eqP=> Gregular; have irrG: mx_irreducible rG. + apply/mx_irrP; split=> // U modU; rewrite -mxrank_eq0 -lt0n => Unz. + rewrite /row_full eqn_leq rank_leq_col leqNgt; apply/negP=> ltUn. + have: rfix_mx (submod_repr modU) G != 0. + by apply: IHm => //; apply: leq_trans le_nG_m; rewrite ltn_add2r. + by rewrite -mxrank_eq0 (rfix_submod modU) // Gregular capmx0 linear0 mxrank0. +have{m le_nG_m IHm} faithfulG: mx_faithful rG. + apply/trivgP/eqP/idPn; set C := _ rG => ntC. + suffices: rfix_mx (kquo_repr rG) (G / _)%g != 0. + by rewrite -mxrank_eq0 rfix_quo // Gregular mxrank0. + apply: (IHm _ _ (morphim_pgroup _ _)) => //. + by apply: leq_trans le_nG_m; rewrite ltn_add2l ltn_quotient // rstab_sub. +have{Gregular} ntG: G :!=: 1%g. + apply: contraL n_gt0; move/eqP=> G1; rewrite -leqNgt -(mxrank1 F n). + rewrite -(mxrank0 F n n) -Gregular mxrankS //; apply/rfix_mxP=> x. + by rewrite {1}G1 mul1mx => /set1P->; rewrite repr_mx1. +have p_pr: prime p by case/andP: charFp. +have{ntG pG} [z]: {z | z \in 'Z(G) & #[z] = p}; last case/setIP=> Gz cGz ozp. + apply: Cauchy => //; apply: contraR ntG; rewrite -p'natE // => p'Z. + have pZ: p.-group 'Z(G) by rewrite (pgroupS (center_sub G)). + by rewrite (trivg_center_pgroup pG (card1_trivg (pnat_1 pZ p'Z))). +have{cGz} cGz1: centgmx rG (rG z - 1%:M). + apply/centgmxP=> x Gx; rewrite mulmxBl mulmxBr mulmx1 mul1mx. + by rewrite -!repr_mxM // (centP cGz). +have{irrG faithfulG cGz1} Urz1: rG z - 1%:M \in unitmx. + apply: (mx_Schur irrG) cGz1 _; rewrite subr_eq0. + move/implyP: (subsetP faithfulG z). + by rewrite !inE Gz mul1mx -order_eq1 ozp -implybNN neq_ltn orbC prime_gt1. +do [case: n n_gt0 => // n' _; set n := n'.+1] in rG Urz1 *. +have charMp: p \in [char 'M[F]_n]. + exact: (rmorph_char (scalar_mx_rmorphism _ _)). +have{Urz1}: Frobenius_aut charMp (rG z - 1) \in GRing.unit by rewrite unitrX. +rewrite (Frobenius_autB_comm _ (commr1 _)) Frobenius_aut1. +by rewrite -[_ (rG z)](repr_mxX rG) // -ozp expg_order repr_mx1 subrr unitr0. +Qed. + +Variables (G : {group gT}) (n : nat) (rG : mx_representation F G n). + +Lemma pcore_sub_rstab_mxsimple M : mxsimple rG M -> 'O_p(G) \subset rstab rG M. +Proof. +case=> modM nzM simM; have sGpG := pcore_sub p G. +rewrite rfix_mx_rstabC //; set U := rfix_mx _ _. +have:= simM (M :&: U)%MS; rewrite sub_capmx submx_refl. +apply; rewrite ?capmxSl //. + by rewrite capmx_module // normal_rfix_mx_module ?pcore_normal. +rewrite -(in_submodK (capmxSl _ _)) val_submod_eq0 -submx0. +rewrite -(rfix_submod modM) // submx0 rfix_pgroup_char ?pcore_pgroup //. +by rewrite lt0n mxrank_eq0. +Qed. + +Lemma pcore_sub_rker_mx_irr : mx_irreducible rG -> 'O_p(G) \subset rker rG. +Proof. exact: pcore_sub_rstab_mxsimple. Qed. + +(* This is Gorenstein, Lemma 3.1.3. *) +Lemma pcore_faithful_mx_irr : + mx_irreducible rG -> mx_faithful rG -> 'O_p(G) = 1%g. +Proof. +move=> irrG ffulG; apply/trivgP; apply: subset_trans ffulG. +exact: pcore_sub_rstab_mxsimple. +Qed. + +End ModularRepresentation. + +Section Extraspecial. + +Variables (F : fieldType) (gT : finGroupType) (S : {group gT}) (p n : nat). +Hypotheses (pS : p.-group S) (esS : extraspecial S). +Hypothesis oSpn : #|S| = (p ^ n.*2.+1)%N. +Hypotheses (splitF : group_splitting_field F S) (F'S : [char F]^'.-group S). + +Let p_pr := extraspecial_prime pS esS. +Let p_gt0 := prime_gt0 p_pr. +Let p_gt1 := prime_gt1 p_pr. +Let oZp := card_center_extraspecial pS esS. + +Let modIp' (i : 'I_p.-1) : (i.+1 %% p = i.+1)%N. +Proof. by case: i => i; rewrite /= -ltnS prednK //; exact: modn_small. Qed. + +(* This is Aschbacher (34.9), parts (1)-(4). *) +Theorem extraspecial_repr_structure (sS : irrType F S) : + [/\ #|linear_irr sS| = (p ^ n.*2)%N, + exists iphi : 'I_p.-1 -> sS, let phi i := irr_repr (iphi i) in + [/\ injective iphi, + codom iphi =i ~: linear_irr sS, + forall i, mx_faithful (phi i), + forall z, z \in 'Z(S)^# -> + exists2 w, primitive_root_of_unity p w + & forall i, phi i z = (w ^+ i.+1)%:M + & forall i, irr_degree (iphi i) = (p ^ n)%N] + & #|sS| = (p ^ n.*2 + p.-1)%N]. +Proof. +have [[defPhiS defS'] prZ] := esS; set linS := linear_irr sS. +have nb_lin: #|linS| = (p ^ n.*2)%N. + rewrite card_linear_irr // -divgS ?der_sub //=. + by rewrite oSpn defS' oZp expnS mulKn. +have nb_irr: #|sS| = (p ^ n.*2 + p.-1)%N. + pose Zcl := classes S ::&: 'Z(S). + have cardZcl: #|Zcl| = p. + transitivity #|[set [set z] | z in 'Z(S)]|; last first. + by rewrite card_imset //; exact: set1_inj. + apply: eq_card => zS; apply/setIdP/imsetP=> [[] | [z]]. + case/imsetP=> z Sz ->{zS} szSZ. + have Zz: z \in 'Z(S) by rewrite (subsetP szSZ) ?class_refl. + exists z => //; rewrite inE Sz in Zz. + apply/eqP; rewrite eq_sym eqEcard sub1set class_refl cards1. + by rewrite -index_cent1 (setIidPl _) ?indexgg // sub_cent1. + case/setIP=> Sz cSz ->{zS}; rewrite sub1set inE Sz; split=> //. + apply/imsetP; exists z; rewrite //. + apply/eqP; rewrite eqEcard sub1set class_refl cards1. + by rewrite -index_cent1 (setIidPl _) ?indexgg // sub_cent1. + move/eqP: (class_formula S); rewrite (bigID (mem Zcl)) /=. + rewrite (eq_bigr (fun _ => 1%N)) => [|zS]; last first. + case/andP=> _ /setIdP[/imsetP[z Sz ->{zS}] /subsetIP[_ cSzS]]. + rewrite (setIidPl _) ?indexgg // sub_cent1 (subsetP cSzS) //. + exact: mem_repr (class_refl S z). + rewrite sum1dep_card setIdE (setIidPr _) 1?cardsE ?cardZcl; last first. + by apply/subsetP=> zS; rewrite 2!inE => /andP[]. + have pn_gt0: p ^ n.*2 > 0 by rewrite expn_gt0 p_gt0. + rewrite card_irr // oSpn expnS -(prednK pn_gt0) mulnS eqn_add2l. + rewrite (eq_bigr (fun _ => p)) => [|xS]; last first. + case/andP=> SxS; rewrite inE SxS; case/imsetP: SxS => x Sx ->{xS} notZxS. + have [y Sy ->] := repr_class S x; apply: p_maximal_index => //. + apply: cent1_extraspecial_maximal => //; first exact: groupJ. + apply: contra notZxS => Zxy; rewrite -{1}(lcoset_id Sy) class_lcoset. + rewrite ((_ ^: _ =P [set x ^ y])%g _) ?sub1set // eq_sym eqEcard. + rewrite sub1set class_refl cards1 -index_cent1 (setIidPl _) ?indexgg //. + by rewrite sub_cent1; apply: subsetP Zxy; exact: subsetIr. + rewrite sum_nat_dep_const mulnC eqn_pmul2l //; move/eqP <-. + rewrite addSnnS prednK // -cardZcl -[card _](cardsID Zcl) /= addnC. + by congr (_ + _)%N; apply: eq_card => t; rewrite !inE andbC // andbAC andbb. +have fful_nlin i: i \in ~: linS -> mx_faithful (irr_repr i). + rewrite !inE => nlin_phi. + apply/trivgP; apply: (TI_center_nil (pgroup_nil pS) (rker_normal _)). + rewrite setIC; apply: (prime_TIg prZ); rewrite /= -defS' der1_sub_rker //. + exact: socle_irr. +have [i0 nlin_i0]: exists i0, i0 \in ~: linS. + by apply/card_gt0P; rewrite cardsCs setCK nb_irr nb_lin addKn -subn1 subn_gt0. +have [z defZ]: exists z, 'Z(S) = <[z]> by apply/cyclicP; rewrite prime_cyclic. +have Zz: z \in 'Z(S) by [rewrite defZ cycle_id]; have [Sz cSz] := setIP Zz. +have ozp: #[z] = p by rewrite -oZp defZ. +have ntz: z != 1%g by rewrite -order_gt1 ozp. +pose phi := irr_repr i0; have irr_phi: mx_irreducible phi := socle_irr i0. +pose w := irr_mode i0 z. +have phi_z: phi z = w%:M by rewrite /phi irr_center_scalar. +have phi_ze e: phi (z ^+ e)%g = (w ^+ e)%:M. + by rewrite /phi irr_center_scalar ?groupX ?irr_modeX. +have wp1: w ^+ p = 1 by rewrite -irr_modeX // -ozp expg_order irr_mode1. +have injw: {in 'Z(S) &, injective (irr_mode i0)}. + move=> x y Zx Zy /= eq_xy; have [[Sx _] [Sy _]] := (setIP Zx, setIP Zy). + apply: mx_faithful_inj (fful_nlin _ nlin_i0) _ _ Sx Sy _. + by rewrite !{1}irr_center_scalar ?eq_xy; first by split. +have prim_w e: 0 < e < p -> p.-primitive_root (w ^+ e). + case/andP=> e_gt0 lt_e_p; apply/andP; split=> //. + apply/eqfunP=> -[d ltdp] /=; rewrite unity_rootE -exprM. + rewrite -(irr_mode1 i0) -irr_modeX // (inj_in_eq injw) ?groupX ?group1 //. + rewrite -order_dvdn ozp Euclid_dvdM // gtnNdvd //=. + move: ltdp; rewrite leq_eqVlt. + by case: eqP => [-> _ | _ ltd1p]; rewrite (dvdnn, gtnNdvd). +have /cyclicP[a defAutZ]: cyclic (Aut 'Z(S)) by rewrite Aut_prime_cyclic ?ozp. +have phi_unitP (i : 'I_p.-1): (i.+1%:R : 'Z_#[z]) \in GRing.unit. + by rewrite unitZpE ?order_gt1 // ozp prime_coprime // -lt0n !modIp'. +pose ephi i := invm (injm_Zpm a) (Zp_unitm (FinRing.Unit _ (phi_unitP i))). +pose j : 'Z_#[z] := val (invm (injm_Zp_unitm z) a). +have co_j_p: coprime j p. + rewrite coprime_sym /j; case: (invm _ a) => /=. + by rewrite ozp /GRing.unit /= Zp_cast. +have [alpha Aut_alpha alphaZ] := center_aut_extraspecial pS esS co_j_p. +have alpha_i_z i: ((alpha ^+ ephi i) z = z ^+ i.+1)%g. + transitivity ((a ^+ ephi i) z)%g. + elim: (ephi i : nat) => // e IHe; rewrite !expgS !permM alphaZ //. + have Aut_a: a \in Aut 'Z(S) by rewrite defAutZ cycle_id. + rewrite -{2}[a](invmK (injm_Zp_unitm z)); last by rewrite im_Zp_unitm -defZ. + rewrite /= autE ?cycle_id // -/j /= /cyclem. + rewrite -(autmE (groupX _ Aut_a)) -(autmE (groupX _ Aut_alpha)). + by rewrite !morphX //= !autmE IHe. + rewrite [(a ^+ _)%g](invmK (injm_Zpm a)) /=; last first. + by rewrite im_Zpm -defAutZ defZ Aut_aut. + by rewrite autE ?cycle_id //= val_Zp_nat ozp ?modIp'. +have rphiP i: S :==: autm (groupX (ephi i) Aut_alpha) @* S by rewrite im_autm. +pose rphi i := morphim_repr (eqg_repr phi (rphiP i)) (subxx S). +have rphi_irr i: mx_irreducible (rphi i). + by apply/morphim_mx_irr; exact/eqg_mx_irr. +have rphi_fful i: mx_faithful (rphi i). + rewrite /mx_faithful rker_morphim rker_eqg. + by rewrite (trivgP (fful_nlin _ nlin_i0)) morphpreIdom; exact: injm_autm. +have rphi_z i: rphi i z = (w ^+ i.+1)%:M. + by rewrite /rphi [phi]lock /= /morphim_mx autmE alpha_i_z -lock phi_ze. +pose iphi i := irr_comp sS (rphi i); pose phi_ i := irr_repr (iphi i). +have{phi_ze} phi_ze i e: phi_ i (z ^+ e)%g = (w ^+ (e * i.+1)%N)%:M. + rewrite /phi_ !{1}irr_center_scalar ?groupX ?irr_modeX //. + suffices ->: irr_mode (iphi i) z = w ^+ i.+1 by rewrite mulnC exprM. + have:= mx_rsim_sym (rsim_irr_comp sS F'S (rphi_irr i)). + case/mx_rsim_def=> B [B' _ homB]; rewrite /irr_mode homB // rphi_z. + rewrite -{1}scalemx1 -scalemxAr -scalemxAl -{1}(repr_mx1 (rphi i)). + by rewrite -homB // repr_mx1 scalemx1 mxE. +have inj_iphi: injective iphi. + move=> i1 i2 eqi12; apply/eqP. + move/eqP: (congr1 (fun i => irr_mode i (z ^+ 1)) eqi12). + rewrite /irr_mode !{1}[irr_repr _ _]phi_ze !{1}mxE !mul1n. + by rewrite (eq_prim_root_expr (prim_w 1%N p_gt1)) !modIp'. +have deg_phi i: irr_degree (iphi i) = irr_degree i0. + by case: (rsim_irr_comp sS F'S (rphi_irr i)). +have im_iphi: codom iphi =i ~: linS. + apply/subset_cardP; last apply/subsetP=> _ /codomP[i ->]. + by rewrite card_image // card_ord cardsCs setCK nb_irr nb_lin addKn. + by rewrite !inE /= (deg_phi i) in nlin_i0 *. +split=> //; exists iphi; rewrite -/phi_. +split=> // [i | ze | i]. +- have sim_i := rsim_irr_comp sS F'S (rphi_irr i). + by rewrite -(mx_rsim_faithful sim_i) rphi_fful. +- rewrite {1}defZ 2!inE andbC; case/andP. + case/cyclePmin=> e; rewrite ozp => lt_e_p ->{ze}. + case: (posnP e) => [-> | e_gt0 _]; first by rewrite eqxx. + exists (w ^+ e) => [|i]; first by rewrite prim_w ?e_gt0. + by rewrite phi_ze exprM. +rewrite deg_phi {i}; set d := irr_degree i0. +apply/eqP; move/eqP: (sum_irr_degree sS F'S splitF). +rewrite (bigID (mem linS)) /= -/irr_degree. +rewrite (eq_bigr (fun _ => 1%N)) => [|i]; last by rewrite !inE; move/eqP->. +rewrite sum1_card nb_lin. +rewrite (eq_bigl (mem (codom iphi))) // => [|i]; last first. + by rewrite -in_setC -im_iphi. +rewrite (eq_bigr (fun _ => d ^ 2))%N => [|_ /codomP[i ->]]; last first. + by rewrite deg_phi. +rewrite sum_nat_const card_image // card_ord oSpn (expnS p) -{3}[p]prednK //. +rewrite mulSn eqn_add2l eqn_pmul2l; last by rewrite -ltnS prednK. +by rewrite -muln2 expnM eqn_sqr. +Qed. + +(* This is the corolloray of the above that is actually used in the proof of *) +(* B & G, Theorem 2.5. It encapsulates the dependency on a socle of the *) +(* regular representation. *) + +Variables (m : nat) (rS : mx_representation F S m) (U : 'M[F]_m). +Hypotheses (simU : mxsimple rS U) (ffulU : rstab rS U == 1%g). +Let sZS := center_sub S. +Let rZ := subg_repr rS sZS. + +Lemma faithful_repr_extraspecial : + \rank U = (p ^ n)%N /\ + (forall V, mxsimple rS V -> mx_iso rZ U V -> mx_iso rS U V). +Proof. +suffices IH V: mxsimple rS V -> mx_iso rZ U V -> + [&& \rank U == (p ^ n)%N & mxsimple_iso rS U V]. +- split=> [|/= V simV isoUV]. + by case/andP: (IH U simU (mx_iso_refl _ _)) => /eqP. + by case/andP: (IH V simV isoUV) => _ /(mxsimple_isoP simU). +move=> simV isoUV; wlog sS: / irrType F S by exact: socle_exists. +have [[_ defS'] prZ] := esS. +have{prZ} ntZ: 'Z(S) :!=: 1%g by case: eqP prZ => // ->; rewrite cards1. +have [_ [iphi]] := extraspecial_repr_structure sS. +set phi := fun i => _ => [] [inj_phi im_phi _ phiZ dim_phi] _. +have [modU nzU _]:= simU; pose rU := submod_repr modU. +have nlinU: \rank U != 1%N. + apply/eqP=> /(rker_linear rU); apply/negP; rewrite /rker rstab_submod. + by rewrite (eqmx_rstab _ (val_submod1 _)) (eqP ffulU) defS' subG1. +have irrU: mx_irreducible rU by exact/submod_mx_irr. +have rsimU := rsim_irr_comp sS F'S irrU. +set iU := irr_comp sS rU in rsimU; have [_ degU _ _]:= rsimU. +have phiUP: iU \in codom iphi by rewrite im_phi !inE -degU. +rewrite degU -(f_iinv phiUP) dim_phi eqxx /=; apply/(mxsimple_isoP simU). +have [modV _ _]:= simV; pose rV := submod_repr modV. +have irrV: mx_irreducible rV by exact/submod_mx_irr. +have rsimV := rsim_irr_comp sS F'S irrV. +set iV := irr_comp sS rV in rsimV; have [_ degV _ _]:= rsimV. +have phiVP: iV \in codom iphi by rewrite im_phi !inE -degV -(mxrank_iso isoUV). +pose jU := iinv phiUP; pose jV := iinv phiVP. +have [z Zz ntz]:= trivgPn _ ntZ. +have [|w prim_w phi_z] := phiZ z; first by rewrite 2!inE ntz. +suffices eqjUV: jU == jV. + apply/(mx_rsim_iso modU modV); apply: mx_rsim_trans rsimU _. + by rewrite -(f_iinv phiUP) -/jU (eqP eqjUV) f_iinv; exact: mx_rsim_sym. +have rsimUV: mx_rsim (subg_repr (phi jU) sZS) (subg_repr (phi jV) sZS). + have [bU _ bUfree bUhom] := mx_rsim_sym rsimU. + have [bV _ bVfree bVhom] := rsimV. + have modUZ := mxmodule_subg sZS modU; have modVZ := mxmodule_subg sZS modV. + case/(mx_rsim_iso modUZ modVZ): isoUV => [bZ degZ bZfree bZhom]. + rewrite /phi !f_iinv; exists (bU *m bZ *m bV)=> [||x Zx]. + - by rewrite -degU degZ degV. + - by rewrite /row_free !mxrankMfree. + have Sx := subsetP sZS x Zx. + by rewrite 2!mulmxA bUhom // -(mulmxA _ _ bZ) bZhom // -4!mulmxA bVhom. +have{rsimUV} [B [B' _ homB]] := mx_rsim_def rsimUV. +have:= eqxx (irr_mode (iphi jU) z); rewrite /irr_mode; set i0 := Ordinal _. +rewrite {2}[_ z]homB // ![_ z]phi_z mxE mulr1n -scalemx1 -scalemxAr -scalemxAl. +rewrite -(repr_mx1 (subg_repr (phi jV) sZS)) -{B B'}homB // repr_mx1 scalemx1. +by rewrite mxE (eq_prim_root_expr prim_w) !modIp'. +Qed. + +End Extraspecial. diff --git a/mathcomp/character/mxrepresentation.v b/mathcomp/character/mxrepresentation.v new file mode 100644 index 0000000..e8bbed3 --- /dev/null +++ b/mathcomp/character/mxrepresentation.v @@ -0,0 +1,5853 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg poly polydiv finset. +Require Import fingroup morphism perm automorphism quotient finalg action zmodp. +Require Import commutator cyclic center pgroup matrix mxalgebra mxpoly. + +(******************************************************************************) +(* This file provides linkage between classic Group Theory and commutative *) +(* algebra -- representation theory. Since general abstract linear algebra is *) +(* still being sorted out, we develop the required theory here on the *) +(* assumption that all vector spaces are matrix spaces, indeed that most are *) +(* row matrix spaces; our representation theory is specialized to the latter *) +(* case. We provide many definitions and results of representation theory: *) +(* enveloping algebras, reducible, irreducible and absolutely irreducible *) +(* representations, representation centralisers, submodules and kernels, *) +(* simple and semisimple modules, the Schur lemmas, Maschke's theorem, *) +(* components, socles, homomorphisms and isomorphisms, the Jacobson density *) +(* theorem, similar representations, the Jordan-Holder theorem, Clifford's *) +(* theorem and Wedderburn components, regular representations and the *) +(* Wedderburn structure theorem for semisimple group rings, and the *) +(* construction of a splitting field of an irreducible representation, and of *) +(* reduced, tensored, and factored representations. *) +(* mx_representation F G n == the Structure type for representations of G *) +(* with n x n matrices with coefficients in F. Note that *) +(* rG : mx_representation F G n coerces to a function from *) +(* the element type of G to 'M_n, and conversely all such *) +(* functions have a Canonical mx_representation. *) +(* mx_repr G r <-> r : gT -> 'M_n defines a (matrix) group representation *) +(* on G : {set gT} (Prop predicate). *) +(* enveloping_algebra_mx rG == a #|G| x (n ^ 2) matrix whose rows are the *) +(* mxvec encodings of the image of G under rG, and whose *) +(* row space therefore encodes the enveloping algebra of *) +(* the representation of G. *) +(* rker rG == the kernel of the representation of r on G, i.e., the *) +(* subgroup of elements of G mapped to the identity by rG. *) +(* mx_faithful rG == the representation rG of G is faithful (its kernel is *) +(* trivial). *) +(* rfix_mx rG H == an n x n matrix whose row space is the set of vectors *) +(* fixed (centralised) by the representation of H by rG. *) +(* rcent rG A == the subgroup of G whose representation via rG commutes *) +(* with the square matrix A. *) +(* rcenter rG == the subgroup of G whose representation via rG consists of *) +(* scalar matrices. *) +(* mxcentg rG f <=> f commutes with every matrix in the representation of G *) +(* (i.e., f is a total rG-homomorphism). *) +(* rstab rG U == the subgroup of G whose representation via r fixes all *) +(* vectors in U, pointwise. *) +(* rstabs rG U == the subgroup of G whose representation via r fixes the row *) +(* space of U globally. *) +(* mxmodule rG U <=> the row-space of the matrix U is a module (globally *) +(* invariant) under the representation rG of G. *) +(* max_submod rG U V <-> U < V is not a proper is a proper subset of any *) +(* proper rG-submodule of V (if both U and V are modules, *) +(* then U is a maximal proper submodule of V). *) +(* mx_subseries rG Us <=> Us : seq 'M_n is a list of rG-modules *) +(* mx_composition_series rG Us <-> Us is an increasing composition series *) +(* for an rG-module (namely, last 0 Us). *) +(* mxsimple rG M <-> M is a simple rG-module (i.e., minimal and nontrivial) *) +(* This is a Prop predicate on square matrices. *) +(* mxnonsimple rG U <-> U is constructively not a submodule, that is, U *) +(* contains a proper nontrivial submodule. *) +(* mxnonsimple_sat rG U == U is not a simple as an rG-module. *) +(* This is a bool predicate, which requires a decField *) +(* structure on the scalar field. *) +(* mxsemisimple rG W <-> W is constructively a direct sum of simple modules. *) +(* mxsplits rG V U <-> V splits over U in rG, i.e., U has an rG-invariant *) +(* complement in V. *) +(* mx_completely_reducible rG V <-> V splits over all its submodules; note *) +(* that this is only classically equivalent to stating that *) +(* V is semisimple. *) +(* mx_irreducible rG <-> the representation rG is irreducible, i.e., the full *) +(* module 1%:M of rG is simple. *) +(* mx_absolutely_irreducible rG == the representation rG of G is absolutely *) +(* irreducible: its enveloping algebra is the full matrix *) +(* ring. This is only classically equivalent to the more *) +(* standard ``rG does not reduce in any field extension''. *) +(* group_splitting_field F G <-> F is a splitting field for the group G: *) +(* every irreducible representation of G is absolutely *) +(* irreducible. Any field can be embedded classically into a *) +(* splitting field. *) +(* group_closure_field F gT <-> F is a splitting field for every group *) +(* G : {group gT}, and indeed for any section of such a *) +(* group. This is a convenient constructive substitute for *) +(* algebraic closures, that can be constructed classically. *) +(* dom_hom_mx rG f == a square matrix encoding the set of vectors for which *) +(* multiplication by the n x n matrix f commutes with the *) +(* representation of G, i.e., the largest domain on which *) +(* f is an rG homomorphism. *) +(* mx_iso rG U V <-> U and V are (constructively) rG-isomorphic; this is *) +(* a Prop predicate. *) +(* mx_simple_iso rG U V == U and V are rG-isomorphic if one of them is *) +(* simple; this is a bool predicate. *) +(* cyclic_mx rG u == the cyclic rG-module generated by the row vector u *) +(* annihilator_mx rG u == the annihilator of the row vector u in the *) +(* enveloping algebra the representation rG. *) +(* row_hom_mx rG u == the image of u by the set of all rG-homomorphisms on *) +(* its cyclic module, or, equivalently, the null-space of the *) +(* annihilator of u. *) +(* component_mx rG M == when M is a simple rG-module, the component of M in *) +(* the representation rG, i.e. the module generated by all *) +(* the (simple) modules rG-isomorphic to M. *) +(* socleType rG == a Structure that represents the type of all components *) +(* of rG (more precisely, it coerces to such a type via *) +(* socle_sort). For sG : socleType, values of type sG (to be *) +(* exact, socle_sort sG) coerce to square matrices. For any *) +(* representation rG we can construct sG : socleType rG *) +(* classically; the socleType structure encapsulates this *) +(* use of classical logic. *) +(* DecSocleType rG == a socleType rG structure, for a representation over a *) +(* decidable field type. *) +(* socle_base W == for W : (sG : socleType), a simple module whose *) +(* component is W; socle_simple W and socle_module W are *) +(* proofs that socle_base W is a simple module. *) +(* socle_mult W == the multiplicity of socle_base W in W : sG. *) +(* := \rank W %/ \rank (socle_base W) *) +(* Socle sG == the Socle of rG, given sG : socleType rG, i.e., the *) +(* (direct) sum of all the components of rG. *) +(* mx_rsim rG rG' <-> rG and rG' are similar representations of the same *) +(* group G. Note that rG and rG' must then have equal, but *) +(* not necessarily convertible, degree. *) +(* submod_repr modU == a representation of G on 'rV_(\rank U) equivalent to *) +(* the restriction of rG to U (here modU : mxmodule rG U). *) +(* socle_repr W := submod_repr (socle_module W) *) +(* val/in_submod rG U == the projections resp. from/onto 'rV_(\rank U), *) +(* that correspond to submod_repr r G U (these work both on *) +(* vectors and row spaces). *) +(* factmod_repr modV == a representation of G on 'rV_(\rank (cokermx V)) that *) +(* is equivalent to the factor module 'rV_n / V induced by V *) +(* and rG (here modV : mxmodule rG V). *) +(* val/in_factmod rG U == the projections for factmod_repr r G U. *) +(* section_repr modU modV == the restriction to in_factmod V U of the factor *) +(* representation factmod_repr modV (for modU : mxmodule rG U *) +(* and modV : mxmodule rG V); section_repr modU modV is *) +(* irreducible iff max_submod rG U V. *) +(* subseries_repr modUs i == the representation for the section module *) +(* in_factmod (0 :: Us)`_i Us`_i, where *) +(* modUs : mx_subseries rG Us. *) +(* series_repr compUs i == the representation for the section module *) +(* in_factmod (0 :: Us)`_i Us`_i, where *) +(* compUs : mx_composition_series rG Us. The Jordan-Holder *) +(* theorem asserts the uniqueness of the set of such *) +(* representations, up to similarity and permutation. *) +(* regular_repr F G == the regular F-representation of the group G. *) +(* group_ring F G == a #|G| x #|G|^2 matrix that encodes the free group *) +(* ring of G -- that is, the enveloping algebra of the *) +(* regular F-representation of G. *) +(* gring_index x == the index corresponding to x \in G in the matrix *) +(* encoding of regular_repr and group_ring. *) +(* gring_row A == the row vector corresponding to A \in group_ring F G in *) +(* the regular FG-module. *) +(* gring_proj x A == the 1 x 1 matrix holding the coefficient of x \in G in *) +(* (A \in group_ring F G)%MS. *) +(* gring_mx rG u == the image of a row vector u of the regular FG-module, *) +(* in the enveloping algebra of another representation rG. *) +(* gring_op rG A == the image of a matrix of the free group ring of G, *) +(* in the enveloping algebra of rG. *) +(* gset_mx F G C == the group sum of C in the free group ring of G -- the *) +(* sum of the images of all the x \in C in group_ring F G. *) +(* classg_base F G == a #|classes G| x #|G|^2 matrix whose rows encode the *) +(* group sums of the conjugacy classes of G -- this is a *) +(* basis of 'Z(group_ring F G)%MS. *) +(* irrType F G == a type indexing irreducible representations of G over a *) +(* field F, provided its characteristic does not divide the *) +(* order of G; it also indexes Wedderburn subrings. *) +(* := socleType (regular_repr F G) *) +(* irr_repr i == the irreducible representation corresponding to the *) +(* index i : irrType sG *) +(* := socle_repr i as i coerces to a component matrix. *) +(* 'n_i, irr_degree i == the degree of irr_repr i; the notation is only *) +(* active after Open Scope group_ring_scope. *) +(* linear_irr sG == the set of sG-indices of linear irreducible *) +(* representations of G. *) +(* irr_comp sG rG == the sG-index of the unique irreducible representation *) +(* similar to rG, at least when rG is irreducible and the *) +(* characteristic is coprime. *) +(* irr_mode i z == the unique eigenvalue of irr_repr i z, at least when *) +(* irr_repr i z is scalar (e.g., when z \in 'Z(G)). *) +(* [1 sG]%irr == the index of the principal representation of G, in *) +(* sG : irrType F G. The i argument ot irr_repr, irr_degree *) +(* and irr_mode is in the %irr scope. This notation may be *) +(* replaced locally by an interpretation of 1%irr as [1 sG] *) +(* for some specific irrType sG. *) +(* 'R_i, Wedderburn_subring i == the subring (indeed, the component) of the *) +(* free group ring of G corresponding to the component i : sG *) +(* of the regular FG-module, where sG : irrType F g. In *) +(* coprime characteristic the Wedderburn structure theorem *) +(* asserts that the free group ring is the direct sum of *) +(* these subrings; as with 'n_i above, the notation is only *) +(* active in group_ring_scope. *) +(* 'e_i, Wedderburn_id i == the projection of the identity matrix 1%:M on the *) +(* Wedderburn subring of i : sG (with sG a socleType). In *) +(* coprime characteristic this is the identity element of *) +(* the subring, and the basis of its center if the field F is *) +(* a splitting field. As 'R_i, 'e_i is in group_ring_scope. *) +(* subg_repr rG sHG == the restriction to H of the representation rG of G; *) +(* here sHG : H \subset G. *) +(* eqg_repr rG eqHG == the representation rG of G viewed a a representation *) +(* of H; here eqHG : G == H. *) +(* morphpre_repr f rG == the representation of f @*^-1 G obtained by *) +(* composing the group morphism f with rG. *) +(* morphim_repr rGf sGD == the representation of G induced by a *) +(* representation rGf of f @* G; here sGD : G \subset D where *) +(* D is the domain of the group morphism f. *) +(* rconj_repr rG uB == the conjugate representation x |-> B * rG x * B^-1; *) +(* here uB : B \in unitmx. *) +(* quo_repr sHK nHG == the representation of G / H induced by rG, given *) +(* sHK : H \subset rker rG, and nHG : G \subset 'N(H). *) +(* kquo_repr rG == the representation induced on G / rker rG by rG. *) +(* map_repr f rG == the representation f \o rG, whose module is the tensor *) +(* product of the module of rG with the extension field into *) +(* which f : {rmorphism F -> Fstar} embeds F. *) +(* 'Cl%act == the transitive action of G on the Wedderburn components of *) +(* H, with nsGH : H <| G, given by Clifford's theorem. More *) +(* precisely this is a total action of G on socle_sort sH, *) +(* where sH : socleType (subg_repr rG (normal_sub sGH)). *) +(* More involved constructions are encapsulated in two Coq submodules: *) +(* MatrixGenField == a module that encapsulates the lengthy details of the *) +(* construction of appropriate extension fields. We assume we *) +(* have an irreducible representation r of a group G, and a *) +(* non-scalar matrix A that centralises an r(G), as this data *) +(* is readily extracted from the Jacobson density theorem. It *) +(* then follows from Schur's lemma that the ring generated by *) +(* A is a field on which the extension of the representation *) +(* r of G is reducible. Note that this is equivalent to the *) +(* more traditional quotient of the polynomial ring by an *) +(* irreducible polynomial (the minimal polynomial of A), but *) +(* much better suited to our needs. *) +(* Here are the main definitions of MatrixGenField; they all have three *) +(* proofs as arguments: rG : mx_repr r G, irrG : mx_irreducible rG, and *) +(* cGA : mxcentg rG A, which ensure the validity of the construction and *) +(* allow us to define Canonical instances (the ~~ is_scalar_mx A assumption *) +(* is only needed to prove reducibility). *) +(* + gen_of irrG cGA == the carrier type of the field generated by A. It is *) +(* at least equipped with a fieldType structure; we also *) +(* propagate any decFieldType/finFieldType structures on the *) +(* original field. *) +(* + gen irrG cGA == the morphism injecting into gen_of rG irrG cGA. *) +(* + groot irrG cGA == the root of mxminpoly A in the gen_of field. *) +(* + gen_repr irrG cGA == an alternative to the field extension *) +(* representation, which consists in reconsidering the *) +(* original module as a module over the new gen_of field, *) +(* thereby DIVIDING the original dimension n by the degree of *) +(* the minimal polynomial of A. This can be simpler than the *) +(* extension method, and is actually required by the proof *) +(* that odd groups are p-stable (B & G 6.1-2, and Appendix A) *) +(* but is only applicable if G is the LARGEST group *) +(* represented by rG (e.g., NOT for B & G 2.6). *) +(* + val_gen/in_gen rG irrG cGA : the bijections from/to the module *) +(* corresponding to gen_repr. *) +(* + rowval_gen rG irrG cGA : the projection of row spaces in the module *) +(* corresponding to gen_repr to row spaces in 'rV_n. *) +(* We build on the MatrixFormula toolkit to define decision procedures for *) +(* the reducibility property: *) +(* + mxmodule_form rG U == a formula asserting that the interpretation of U *) +(* is a module of the representation rG of G via r. *) +(* + mxnonsimple_form rG U == a formula asserting that the interpretation *) +(* of U contains a proper nontrivial rG-module. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory. +Local Open Scope ring_scope. + +Reserved Notation "''n_' i" (at level 8, i at level 2, format "''n_' i"). +Reserved Notation "''R_' i" (at level 8, i at level 2, format "''R_' i"). +Reserved Notation "''e_' i" (at level 8, i at level 2, format "''e_' i"). + +Delimit Scope irrType_scope with irr. + +Section RingRepr. + +Variable R : comUnitRingType. + +Section OneRepresentation. + +Variable gT : finGroupType. + +Definition mx_repr (G : {set gT}) n (r : gT -> 'M[R]_n) := + r 1%g = 1%:M /\ {in G &, {morph r : x y / (x * y)%g >-> x *m y}}. + +Structure mx_representation G n := + MxRepresentation { repr_mx :> gT -> 'M_n; _ : mx_repr G repr_mx }. + +Variables (G : {group gT}) (n : nat) (rG : mx_representation G n). +Arguments Scope rG [group_scope]. + +Lemma repr_mx1 : rG 1 = 1%:M. +Proof. by case: rG => r []. Qed. + +Lemma repr_mxM : {in G &, {morph rG : x y / (x * y)%g >-> x *m y}}. +Proof. by case: rG => r []. Qed. + +Lemma repr_mxK m x : + x \in G -> cancel ((@mulmx _ m n n)^~ (rG x)) (mulmx^~ (rG x^-1)). +Proof. +by move=> Gx U; rewrite -mulmxA -repr_mxM ?groupV // mulgV repr_mx1 mulmx1. +Qed. + +Lemma repr_mxKV m x : + x \in G -> cancel ((@mulmx _ m n n)^~ (rG x^-1)) (mulmx^~ (rG x)). +Proof. by rewrite -groupV -{3}[x]invgK; exact: repr_mxK. Qed. + +Lemma repr_mx_unit x : x \in G -> rG x \in unitmx. +Proof. by move=> Gx; case/mulmx1_unit: (repr_mxKV Gx 1%:M). Qed. + +Lemma repr_mxV : {in G, {morph rG : x / x^-1%g >-> invmx x}}. +Proof. +by move=> x Gx /=; rewrite -[rG x^-1](mulKmx (repr_mx_unit Gx)) mulmxA repr_mxK. +Qed. + +(* This is only used in the group ring construction below, as we only have *) +(* developped the theory of matrix subalgebras for F-algebras. *) +Definition enveloping_algebra_mx := \matrix_(i < #|G|) mxvec (rG (enum_val i)). + +Section Stabiliser. + +Variables (m : nat) (U : 'M[R]_(m, n)). + +Definition rstab := [set x in G | U *m rG x == U]. + +Lemma rstab_sub : rstab \subset G. +Proof. by apply/subsetP=> x; case/setIdP. Qed. + +Lemma rstab_group_set : group_set rstab. +Proof. +apply/group_setP; rewrite inE group1 repr_mx1 mulmx1; split=> //= x y. +case/setIdP=> Gx cUx; case/setIdP=> Gy cUy; rewrite inE repr_mxM ?groupM //. +by rewrite mulmxA (eqP cUx). +Qed. +Canonical rstab_group := Group rstab_group_set. + +End Stabiliser. + +(* Centralizer subgroup and central homomorphisms. *) +Section CentHom. + +Variable f : 'M[R]_n. + +Definition rcent := [set x in G | f *m rG x == rG x *m f]. + +Lemma rcent_sub : rcent \subset G. +Proof. by apply/subsetP=> x; case/setIdP. Qed. + +Lemma rcent_group_set : group_set rcent. +Proof. +apply/group_setP; rewrite inE group1 repr_mx1 mulmx1 mul1mx; split=> //= x y. +case/setIdP=> Gx; move/eqP=> cfx; case/setIdP=> Gy; move/eqP=> cfy. +by rewrite inE repr_mxM ?groupM //= -mulmxA -cfy !mulmxA cfx. +Qed. +Canonical rcent_group := Group rcent_group_set. + +Definition centgmx := G \subset rcent. + +Lemma centgmxP : reflect (forall x, x \in G -> f *m rG x = rG x *m f) centgmx. +Proof. +apply: (iffP subsetP) => cGf x Gx; + by have:= cGf x Gx; rewrite !inE Gx /=; move/eqP. +Qed. + +End CentHom. + +(* Representation kernel, and faithful representations. *) + +Definition rker := rstab 1%:M. +Canonical rker_group := Eval hnf in [group of rker]. + +Lemma rkerP x : reflect (x \in G /\ rG x = 1%:M) (x \in rker). +Proof. by apply: (iffP setIdP) => [] [->]; move/eqP; rewrite mul1mx. Qed. + +Lemma rker_norm : G \subset 'N(rker). +Proof. +apply/subsetP=> x Gx; rewrite inE sub_conjg; apply/subsetP=> y. +case/rkerP=> Gy ry1; rewrite mem_conjgV !inE groupJ //=. +by rewrite !repr_mxM ?groupM ?groupV // ry1 !mulmxA mulmx1 repr_mxKV. +Qed. + +Lemma rker_normal : rker <| G. +Proof. by rewrite /normal rstab_sub rker_norm. Qed. + +Definition mx_faithful := rker \subset [1]. + +Lemma mx_faithful_inj : mx_faithful -> {in G &, injective rG}. +Proof. +move=> ffulG x y Gx Gy eq_rGxy; apply/eqP; rewrite eq_mulgV1 -in_set1. +rewrite (subsetP ffulG) // inE groupM ?repr_mxM ?groupV //= eq_rGxy. +by rewrite mulmxA repr_mxK. +Qed. + +Lemma rker_linear : n = 1%N -> G^`(1)%g \subset rker. +Proof. +move=> n1; rewrite gen_subG; apply/subsetP=> xy; case/imset2P=> x y Gx Gy ->. +rewrite !inE groupR //= /commg mulgA -invMg repr_mxM ?groupV ?groupM //. +rewrite mulmxA (can2_eq (repr_mxK _) (repr_mxKV _)) ?groupM //. +rewrite !repr_mxV ?repr_mxM ?groupM //; move: (rG x) (rG y). +by rewrite n1 => rx ry; rewrite (mx11_scalar rx) scalar_mxC. +Qed. + +(* Representation center. *) + +Definition rcenter := [set g in G | is_scalar_mx (rG g)]. + +Fact rcenter_group_set : group_set rcenter. +Proof. +apply/group_setP; split=> [|x y]. + by rewrite inE group1 repr_mx1 scalar_mx_is_scalar. +move=> /setIdP[Gx /is_scalar_mxP[a defx]] /setIdP[Gy /is_scalar_mxP[b defy]]. +by rewrite !inE groupM ?repr_mxM // defx defy -scalar_mxM ?scalar_mx_is_scalar. +Qed. +Canonical rcenter_group := Group rcenter_group_set. + +Lemma rcenter_normal : rcenter <| G. +Proof. +rewrite /normal /rcenter {1}setIdE subsetIl; apply/subsetP=> x Gx; rewrite inE. +apply/subsetP=> _ /imsetP[y /setIdP[Gy /is_scalar_mxP[c rGy]] ->]. +rewrite inE !repr_mxM ?groupM ?groupV //= mulmxA rGy scalar_mxC repr_mxKV //. +exact: scalar_mx_is_scalar. +Qed. + +End OneRepresentation. + +Implicit Arguments rkerP [gT G n rG x]. + +Section Proper. + +Variables (gT : finGroupType) (G : {group gT}) (n' : nat). +Local Notation n := n'.+1. +Variable rG : mx_representation G n. + +Lemma repr_mxMr : {in G &, {morph rG : x y / (x * y)%g >-> x * y}}. +Proof. exact: repr_mxM. Qed. + +Lemma repr_mxVr : {in G, {morph rG : x / (x^-1)%g >-> x^-1}}. +Proof. exact: repr_mxV. + Qed. + +Lemma repr_mx_unitr x : x \in G -> rG x \is a GRing.unit. +Proof. exact: repr_mx_unit. Qed. + +Lemma repr_mxX m : {in G, {morph rG : x / (x ^+ m)%g >-> x ^+ m}}. +Proof. +elim: m => [|m IHm] x Gx; rewrite /= ?repr_mx1 // expgS exprS -IHm //. +by rewrite repr_mxM ?groupX. +Qed. + +End Proper. + +Section ChangeGroup. + +Variables (gT : finGroupType) (G H : {group gT}) (n : nat). +Variables (rG : mx_representation G n). + +Section SubGroup. + +Hypothesis sHG : H \subset G. + +Lemma subg_mx_repr : mx_repr H rG. +Proof. +by split=> [|x y Hx Hy]; rewrite (repr_mx1, repr_mxM) ?(subsetP sHG). +Qed. +Definition subg_repr := MxRepresentation subg_mx_repr. +Local Notation rH := subg_repr. + +Lemma rcent_subg U : rcent rH U = H :&: rcent rG U. +Proof. by apply/setP=> x; rewrite !inE andbA -in_setI (setIidPl sHG). Qed. + +Section Stabiliser. + +Variables (m : nat) (U : 'M[R]_(m, n)). + +Lemma rstab_subg : rstab rH U = H :&: rstab rG U. +Proof. by apply/setP=> x; rewrite !inE andbA -in_setI (setIidPl sHG). Qed. + +End Stabiliser. + +Lemma rker_subg : rker rH = H :&: rker rG. Proof. exact: rstab_subg. Qed. + +Lemma subg_mx_faithful : mx_faithful rG -> mx_faithful rH. +Proof. by apply: subset_trans; rewrite rker_subg subsetIr. Qed. + +End SubGroup. + +Section SameGroup. + +Hypothesis eqGH : G :==: H. + +Lemma eqg_repr_proof : H \subset G. Proof. by rewrite (eqP eqGH). Qed. + +Definition eqg_repr := subg_repr eqg_repr_proof. +Local Notation rH := eqg_repr. + +Lemma rcent_eqg U : rcent rH U = rcent rG U. +Proof. by rewrite rcent_subg -(eqP eqGH) (setIidPr _) ?rcent_sub. Qed. + +Section Stabiliser. + +Variables (m : nat) (U : 'M[R]_(m, n)). + +Lemma rstab_eqg : rstab rH U = rstab rG U. +Proof. by rewrite rstab_subg -(eqP eqGH) (setIidPr _) ?rstab_sub. Qed. + +End Stabiliser. + +Lemma rker_eqg : rker rH = rker rG. Proof. exact: rstab_eqg. Qed. + +Lemma eqg_mx_faithful : mx_faithful rH = mx_faithful rG. +Proof. by rewrite /mx_faithful rker_eqg. Qed. + +End SameGroup. + +End ChangeGroup. + +Section Morphpre. + +Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}). +Variables (G : {group rT}) (n : nat) (rG : mx_representation G n). + +Lemma morphpre_mx_repr : mx_repr (f @*^-1 G) (rG \o f). +Proof. +split=> [|x y]; first by rewrite /= morph1 repr_mx1. +case/morphpreP=> Dx Gfx; case/morphpreP=> Dy Gfy. +by rewrite /= morphM ?repr_mxM. +Qed. +Canonical morphpre_repr := MxRepresentation morphpre_mx_repr. +Local Notation rGf := morphpre_repr. + +Section Stabiliser. + +Variables (m : nat) (U : 'M[R]_(m, n)). + +Lemma rstab_morphpre : rstab rGf U = f @*^-1 (rstab rG U). +Proof. by apply/setP=> x; rewrite !inE andbA. Qed. + +End Stabiliser. + +Lemma rker_morphpre : rker rGf = f @*^-1 (rker rG). +Proof. exact: rstab_morphpre. Qed. + +End Morphpre. + +Section Morphim. + +Variables (aT rT : finGroupType) (G D : {group aT}) (f : {morphism D >-> rT}). +Variables (n : nat) (rGf : mx_representation (f @* G) n). + +Definition morphim_mx of G \subset D := fun x => rGf (f x). + +Hypothesis sGD : G \subset D. + +Lemma morphim_mxE x : morphim_mx sGD x = rGf (f x). Proof. by []. Qed. + +Let sG_f'fG : G \subset f @*^-1 (f @* G). +Proof. by rewrite -sub_morphim_pre. Qed. + +Lemma morphim_mx_repr : mx_repr G (morphim_mx sGD). +Proof. exact: subg_mx_repr (morphpre_repr f rGf) sG_f'fG. Qed. +Canonical morphim_repr := MxRepresentation morphim_mx_repr. +Local Notation rG := morphim_repr. + +Section Stabiliser. +Variables (m : nat) (U : 'M[R]_(m, n)). + +Lemma rstab_morphim : rstab rG U = G :&: f @*^-1 rstab rGf U. +Proof. by rewrite -rstab_morphpre -(rstab_subg _ sG_f'fG). Qed. + +End Stabiliser. + +Lemma rker_morphim : rker rG = G :&: f @*^-1 (rker rGf). +Proof. exact: rstab_morphim. Qed. + +End Morphim. + +Section Conjugate. + +Variables (gT : finGroupType) (G : {group gT}) (n : nat). +Variables (rG : mx_representation G n) (B : 'M[R]_n). + +Definition rconj_mx of B \in unitmx := fun x => B *m rG x *m invmx B. + +Hypothesis uB : B \in unitmx. + +Lemma rconj_mx_repr : mx_repr G (rconj_mx uB). +Proof. +split=> [|x y Gx Gy]; rewrite /rconj_mx ?repr_mx1 ?mulmx1 ?mulmxV ?repr_mxM //. +by rewrite !mulmxA mulmxKV. +Qed. +Canonical rconj_repr := MxRepresentation rconj_mx_repr. +Local Notation rGB := rconj_repr. + +Lemma rconj_mxE x : rGB x = B *m rG x *m invmx B. +Proof. by []. Qed. + +Lemma rconj_mxJ m (W : 'M_(m, n)) x : W *m rGB x *m B = W *m B *m rG x. +Proof. by rewrite !mulmxA mulmxKV. Qed. + +Lemma rcent_conj A : rcent rGB A = rcent rG (invmx B *m A *m B). +Proof. +apply/setP=> x; rewrite !inE /= rconj_mxE !mulmxA. +rewrite (can2_eq (mulmxKV uB) (mulmxK uB)) -!mulmxA. +by rewrite -(can2_eq (mulKVmx uB) (mulKmx uB)). +Qed. + +Lemma rstab_conj m (U : 'M_(m, n)) : rstab rGB U = rstab rG (U *m B). +Proof. +apply/setP=> x; rewrite !inE /= rconj_mxE !mulmxA. +by rewrite (can2_eq (mulmxKV uB) (mulmxK uB)). +Qed. + +Lemma rker_conj : rker rGB = rker rG. +Proof. +apply/setP=> x; rewrite !inE /= mulmxA (can2_eq (mulmxKV uB) (mulmxK uB)). +by rewrite mul1mx -scalar_mxC (inj_eq (can_inj (mulKmx uB))) mul1mx. +Qed. + +Lemma conj_mx_faithful : mx_faithful rGB = mx_faithful rG. +Proof. by rewrite /mx_faithful rker_conj. Qed. + +End Conjugate. + +Section Quotient. + +Variables (gT : finGroupType) (G : {group gT}) (n : nat). +Variable rG : mx_representation G n. + +Definition quo_mx (H : {set gT}) of H \subset rker rG & G \subset 'N(H) := + fun Hx : coset_of H => rG (repr Hx). + +Section SubQuotient. + +Variable H : {group gT}. +Hypotheses (krH : H \subset rker rG) (nHG : G \subset 'N(H)). +Let nHGs := subsetP nHG. + +Lemma quo_mx_coset x : x \in G -> quo_mx krH nHG (coset H x) = rG x. +Proof. +move=> Gx; rewrite /quo_mx val_coset ?nHGs //; case: repr_rcosetP => z Hz. +by case/rkerP: (subsetP krH z Hz) => Gz rz1; rewrite repr_mxM // rz1 mul1mx. +Qed. + +Lemma quo_mx_repr : mx_repr (G / H)%g (quo_mx krH nHG). +Proof. +split=> [|Hx Hy]; first by rewrite /quo_mx repr_coset1 repr_mx1. +case/morphimP=> x Nx Gx ->{Hx}; case/morphimP=> y Ny Gy ->{Hy}. +by rewrite -morphM // !quo_mx_coset ?groupM ?repr_mxM. +Qed. +Canonical quo_repr := MxRepresentation quo_mx_repr. +Local Notation rGH := quo_repr. + +Lemma quo_repr_coset x : x \in G -> rGH (coset H x) = rG x. +Proof. exact: quo_mx_coset. Qed. + +Lemma rcent_quo A : rcent rGH A = (rcent rG A / H)%g. +Proof. +apply/setP=> Hx; rewrite !inE. +apply/andP/idP=> [[]|]; case/morphimP=> x Nx Gx ->{Hx}. + by rewrite quo_repr_coset // => cAx; rewrite mem_morphim // inE Gx. +by case/setIdP: Gx => Gx cAx; rewrite quo_repr_coset ?mem_morphim. +Qed. + +Lemma rstab_quo m (U : 'M_(m, n)) : rstab rGH U = (rstab rG U / H)%g. +Proof. +apply/setP=> Hx; rewrite !inE. +apply/andP/idP=> [[]|]; case/morphimP=> x Nx Gx ->{Hx}. + by rewrite quo_repr_coset // => nUx; rewrite mem_morphim // inE Gx. +by case/setIdP: Gx => Gx nUx; rewrite quo_repr_coset ?mem_morphim. +Qed. + +Lemma rker_quo : rker rGH = (rker rG / H)%g. +Proof. exact: rstab_quo. Qed. + +End SubQuotient. + +Definition kquo_mx := quo_mx (subxx (rker rG)) (rker_norm rG). +Lemma kquo_mxE : kquo_mx = quo_mx (subxx (rker rG)) (rker_norm rG). +Proof. by []. Qed. + +Canonical kquo_repr := @MxRepresentation _ _ _ kquo_mx (quo_mx_repr _ _). + +Lemma kquo_repr_coset x : + x \in G -> kquo_repr (coset (rker rG) x) = rG x. +Proof. exact: quo_repr_coset. Qed. + +Lemma kquo_mx_faithful : mx_faithful kquo_repr. +Proof. by rewrite /mx_faithful rker_quo trivg_quotient. Qed. + +End Quotient. + +Section Regular. + +Variables (gT : finGroupType) (G : {group gT}). +Local Notation nG := #|pred_of_set (gval G)|. + +Definition gring_index (x : gT) := enum_rank_in (group1 G) x. + +Lemma gring_valK : cancel enum_val gring_index. +Proof. exact: enum_valK_in. Qed. + +Lemma gring_indexK : {in G, cancel gring_index enum_val}. +Proof. exact: enum_rankK_in. Qed. + +Definition regular_mx x : 'M[R]_nG := + \matrix_i delta_mx 0 (gring_index (enum_val i * x)). + +Lemma regular_mx_repr : mx_repr G regular_mx. +Proof. +split=> [|x y Gx Gy]; apply/row_matrixP=> i; rewrite !rowK. + by rewrite mulg1 row1 gring_valK. +by rewrite row_mul rowK -rowE rowK mulgA gring_indexK // groupM ?enum_valP. +Qed. +Canonical regular_repr := MxRepresentation regular_mx_repr. +Local Notation aG := regular_repr. + +Definition group_ring := enveloping_algebra_mx aG. +Local Notation R_G := group_ring. + +Definition gring_row : 'M[R]_nG -> 'rV_nG := row (gring_index 1). +Canonical gring_row_linear := [linear of gring_row]. + +Lemma gring_row_mul A B : gring_row (A *m B) = gring_row A *m B. +Proof. exact: row_mul. Qed. + +Definition gring_proj x := row (gring_index x) \o trmx \o gring_row. +Canonical gring_proj_linear x := [linear of gring_proj x]. + +Lemma gring_projE : {in G &, forall x y, gring_proj x (aG y) = (x == y)%:R}. +Proof. +move=> x y Gx Gy; rewrite /gring_proj /= /gring_row rowK gring_indexK //=. +rewrite mul1g trmx_delta rowE mul_delta_mx_cond [delta_mx 0 0]mx11_scalar !mxE. +by rewrite /= -(inj_eq (can_inj gring_valK)) !gring_indexK. +Qed. + +Lemma regular_mx_faithful : mx_faithful aG. +Proof. +apply/subsetP=> x /setIdP[Gx]. +rewrite mul1mx inE => /eqP/(congr1 (gring_proj 1%g)). +rewrite -(repr_mx1 aG) !gring_projE ?group1 // eqxx eq_sym. +by case: (x == _) => // /eqP; rewrite eq_sym oner_eq0. +Qed. + +Section GringMx. + +Variables (n : nat) (rG : mx_representation G n). + +Definition gring_mx := vec_mx \o mulmxr (enveloping_algebra_mx rG). +Canonical gring_mx_linear := [linear of gring_mx]. + +Lemma gring_mxJ a x : + x \in G -> gring_mx (a *m aG x) = gring_mx a *m rG x. +Proof. +move=> Gx; rewrite /gring_mx /= ![a *m _]mulmx_sum_row. +rewrite !(mulmx_suml, linear_sum); apply: eq_bigr => i _. +rewrite linearZ -!scalemxAl linearZ /=; congr (_ *: _) => {a}. +rewrite !rowK /= !mxvecK -rowE rowK mxvecK. +by rewrite gring_indexK ?groupM ?repr_mxM ?enum_valP. +Qed. + +End GringMx. + +Lemma gring_mxK : cancel (gring_mx aG) gring_row. +Proof. +move=> a; rewrite /gring_mx /= mulmx_sum_row !linear_sum. +rewrite {2}[a]row_sum_delta; apply: eq_bigr => i _. +rewrite !linearZ /= /gring_row !(rowK, mxvecK). +by rewrite gring_indexK // mul1g gring_valK. +Qed. + +Section GringOp. + +Variables (n : nat) (rG : mx_representation G n). + +Definition gring_op := gring_mx rG \o gring_row. +Canonical gring_op_linear := [linear of gring_op]. + +Lemma gring_opE a : gring_op a = gring_mx rG (gring_row a). +Proof. by []. Qed. + +Lemma gring_opG x : x \in G -> gring_op (aG x) = rG x. +Proof. +move=> Gx; rewrite gring_opE /gring_row rowK gring_indexK // mul1g. +by rewrite /gring_mx /= -rowE rowK mxvecK gring_indexK. +Qed. + +Lemma gring_op1 : gring_op 1%:M = 1%:M. +Proof. by rewrite -(repr_mx1 aG) gring_opG ?repr_mx1. Qed. + +Lemma gring_opJ A b : + gring_op (A *m gring_mx aG b) = gring_op A *m gring_mx rG b. +Proof. +rewrite /gring_mx /= ![b *m _]mulmx_sum_row !linear_sum. +apply: eq_bigr => i _; rewrite !linearZ /= !rowK !mxvecK. +by rewrite gring_opE gring_row_mul gring_mxJ ?enum_valP. +Qed. + +Lemma gring_op_mx b : gring_op (gring_mx aG b) = gring_mx rG b. +Proof. by rewrite -[_ b]mul1mx gring_opJ gring_op1 mul1mx. Qed. + +Lemma gring_mxA a b : + gring_mx rG (a *m gring_mx aG b) = gring_mx rG a *m gring_mx rG b. +Proof. +by rewrite -(gring_op_mx a) -gring_opJ gring_opE gring_row_mul gring_mxK. +Qed. + +End GringOp. + +End Regular. + +End RingRepr. + +Arguments Scope mx_representation [_ _ group_scope nat_scope]. +Arguments Scope mx_repr [_ _ group_scope nat_scope _]. +Arguments Scope group_ring [_ _ group_scope]. +Arguments Scope regular_repr [_ _ group_scope]. + +Implicit Arguments centgmxP [R gT G n rG f]. +Implicit Arguments rkerP [R gT G n rG x]. +Prenex Implicits gring_mxK. + +Section ChangeOfRing. + +Variables (aR rR : comUnitRingType) (f : {rmorphism aR -> rR}). +Local Notation "A ^f" := (map_mx (GRing.RMorphism.apply f) A) : ring_scope. +Variables (gT : finGroupType) (G : {group gT}). + +Lemma map_regular_mx x : (regular_mx aR G x)^f = regular_mx rR G x. +Proof. by apply/matrixP=> i j; rewrite !mxE rmorph_nat. Qed. + +Lemma map_gring_row (A : 'M_#|G|) : (gring_row A)^f = gring_row A^f. +Proof. by rewrite map_row. Qed. + +Lemma map_gring_proj x (A : 'M_#|G|) : (gring_proj x A)^f = gring_proj x A^f. +Proof. by rewrite map_row -map_trmx map_gring_row. Qed. + +Section OneRepresentation. + +Variables (n : nat) (rG : mx_representation aR G n). + +Definition map_repr_mx (f0 : aR -> rR) rG0 (g : gT) : 'M_n := map_mx f0 (rG0 g). + +Lemma map_mx_repr : mx_repr G (map_repr_mx f rG). +Proof. +split=> [|x y Gx Gy]; first by rewrite /map_repr_mx repr_mx1 map_mx1. +by rewrite -map_mxM -repr_mxM. +Qed. +Canonical map_repr := MxRepresentation map_mx_repr. +Local Notation rGf := map_repr. + +Lemma map_reprE x : rGf x = (rG x)^f. Proof. by []. Qed. + +Lemma map_reprJ m (A : 'M_(m, n)) x : (A *m rG x)^f = A^f *m rGf x. +Proof. exact: map_mxM. Qed. + +Lemma map_enveloping_algebra_mx : + (enveloping_algebra_mx rG)^f = enveloping_algebra_mx rGf. +Proof. by apply/row_matrixP=> i; rewrite -map_row !rowK map_mxvec. Qed. + +Lemma map_gring_mx a : (gring_mx rG a)^f = gring_mx rGf a^f. +Proof. by rewrite map_vec_mx map_mxM map_enveloping_algebra_mx. Qed. + +Lemma map_gring_op A : (gring_op rG A)^f = gring_op rGf A^f. +Proof. by rewrite map_gring_mx map_gring_row. Qed. + +End OneRepresentation. + +Lemma map_regular_repr : map_repr (regular_repr aR G) =1 regular_repr rR G. +Proof. exact: map_regular_mx. Qed. + +Lemma map_group_ring : (group_ring aR G)^f = group_ring rR G. +Proof. +rewrite map_enveloping_algebra_mx; apply/row_matrixP=> i. +by rewrite !rowK map_regular_repr. +Qed. + +(* Stabilisers, etc, are only mapped properly for fields. *) + +End ChangeOfRing. + +Section FieldRepr. + +Variable F : fieldType. + +Section OneRepresentation. + +Variable gT : finGroupType. + +Variables (G : {group gT}) (n : nat) (rG : mx_representation F G n). +Arguments Scope rG [group_scope]. + +Local Notation E_G := (enveloping_algebra_mx rG). + +Lemma repr_mx_free x : x \in G -> row_free (rG x). +Proof. by move=> Gx; rewrite row_free_unit repr_mx_unit. Qed. + +Section Stabilisers. + +Variables (m : nat) (U : 'M[F]_(m, n)). + +Definition rstabs := [set x in G | U *m rG x <= U]%MS. + +Lemma rstabs_sub : rstabs \subset G. +Proof. by apply/subsetP=> x /setIdP[]. Qed. + +Lemma rstabs_group_set : group_set rstabs. +Proof. +apply/group_setP; rewrite inE group1 repr_mx1 mulmx1. +split=> //= x y /setIdP[Gx nUx] /setIdP[Gy]; rewrite inE repr_mxM ?groupM //. +by apply: submx_trans; rewrite mulmxA submxMr. +Qed. +Canonical rstabs_group := Group rstabs_group_set. + +Lemma rstab_act x m1 (W : 'M_(m1, n)) : + x \in rstab rG U -> (W <= U)%MS -> W *m rG x = W. +Proof. by case/setIdP=> _ /eqP cUx /submxP[w ->]; rewrite -mulmxA cUx. Qed. + +Lemma rstabs_act x m1 (W : 'M_(m1, n)) : + x \in rstabs -> (W <= U)%MS -> (W *m rG x <= U)%MS. +Proof. +by case/setIdP=> [_ nUx] sWU; apply: submx_trans nUx; exact: submxMr. +Qed. + +Definition mxmodule := G \subset rstabs. + +Lemma mxmoduleP : reflect {in G, forall x, U *m rG x <= U}%MS mxmodule. +Proof. +by apply: (iffP subsetP) => modU x Gx; have:= modU x Gx; rewrite !inE ?Gx. +Qed. + +End Stabilisers. +Implicit Arguments mxmoduleP [m U]. + +Lemma rstabS m1 m2 (U : 'M_(m1, n)) (V : 'M_(m2, n)) : + (U <= V)%MS -> rstab rG V \subset rstab rG U. +Proof. +case/submxP=> u ->; apply/subsetP=> x. +by rewrite !inE => /andP[-> /= /eqP cVx]; rewrite -mulmxA cVx. +Qed. + +Lemma eqmx_rstab m1 m2 (U : 'M_(m1, n)) (V : 'M_(m2, n)) : + (U :=: V)%MS -> rstab rG U = rstab rG V. +Proof. by move=> eqUV; apply/eqP; rewrite eqEsubset !rstabS ?eqUV. Qed. + +Lemma eqmx_rstabs m1 m2 (U : 'M_(m1, n)) (V : 'M_(m2, n)) : + (U :=: V)%MS -> rstabs U = rstabs V. +Proof. by move=> eqUV; apply/setP=> x; rewrite !inE eqUV (eqmxMr _ eqUV). Qed. + +Lemma eqmx_module m1 m2 (U : 'M_(m1, n)) (V : 'M_(m2, n)) : + (U :=: V)%MS -> mxmodule U = mxmodule V. +Proof. by move=> eqUV; rewrite /mxmodule (eqmx_rstabs eqUV). Qed. + +Lemma mxmodule0 m : mxmodule (0 : 'M_(m, n)). +Proof. by apply/mxmoduleP=> x _; rewrite mul0mx. Qed. + +Lemma mxmodule1 : mxmodule 1%:M. +Proof. by apply/mxmoduleP=> x _; rewrite submx1. Qed. + +Lemma mxmodule_trans m1 m2 (U : 'M_(m1, n)) (W : 'M_(m2, n)) x : + mxmodule U -> x \in G -> (W <= U -> W *m rG x <= U)%MS. +Proof. +by move=> modU Gx sWU; apply: submx_trans (mxmoduleP modU x Gx); exact: submxMr. +Qed. + +Lemma mxmodule_eigenvector m (U : 'M_(m, n)) : + mxmodule U -> \rank U = 1%N -> + {u : 'rV_n & {a | (U :=: u)%MS & {in G, forall x, u *m rG x = a x *: u}}}. +Proof. +move=> modU linU; set u := nz_row U; exists u. +have defU: (U :=: u)%MS. + apply/eqmxP; rewrite andbC -(geq_leqif (mxrank_leqif_eq _)) ?nz_row_sub //. + by rewrite linU lt0n mxrank_eq0 nz_row_eq0 -mxrank_eq0 linU. +pose a x := (u *m rG x *m pinvmx u) 0 0; exists a => // x Gx. +by rewrite -mul_scalar_mx -mx11_scalar mulmxKpV // -defU mxmodule_trans ?defU. +Qed. + +Lemma addsmx_module m1 m2 U V : + @mxmodule m1 U -> @mxmodule m2 V -> mxmodule (U + V)%MS. +Proof. +move=> modU modV; apply/mxmoduleP=> x Gx. +by rewrite addsmxMr addsmxS ?(mxmoduleP _ x Gx). +Qed. + +Lemma sumsmx_module I r (P : pred I) U : + (forall i, P i -> mxmodule (U i)) -> mxmodule (\sum_(i <- r | P i) U i)%MS. +Proof. +by move=> modU; elim/big_ind: _; [exact: mxmodule0 | exact: addsmx_module | ]. +Qed. + +Lemma capmx_module m1 m2 U V : + @mxmodule m1 U -> @mxmodule m2 V -> mxmodule (U :&: V)%MS. +Proof. +move=> modU modV; apply/mxmoduleP=> x Gx. +by rewrite sub_capmx !mxmodule_trans ?capmxSl ?capmxSr. +Qed. + +Lemma bigcapmx_module I r (P : pred I) U : + (forall i, P i -> mxmodule (U i)) -> mxmodule (\bigcap_(i <- r | P i) U i)%MS. +Proof. +by move=> modU; elim/big_ind: _; [exact: mxmodule1 | exact: capmx_module | ]. +Qed. + +(* Sub- and factor representations induced by a (sub)module. *) +Section Submodule. + +Variable U : 'M[F]_n. + +Definition val_submod m : 'M_(m, \rank U) -> 'M_(m, n) := mulmxr (row_base U). +Definition in_submod m : 'M_(m, n) -> 'M_(m, \rank U) := + mulmxr (invmx (row_ebase U) *m pid_mx (\rank U)). +Canonical val_submod_linear m := [linear of @val_submod m]. +Canonical in_submod_linear m := [linear of @in_submod m]. + +Lemma val_submodE m W : @val_submod m W = W *m val_submod 1%:M. +Proof. by rewrite mulmxA mulmx1. Qed. + +Lemma in_submodE m W : @in_submod m W = W *m in_submod 1%:M. +Proof. by rewrite mulmxA mulmx1. Qed. + +Lemma val_submod1 : (val_submod 1%:M :=: U)%MS. +Proof. by rewrite /val_submod /= mul1mx; exact: eq_row_base. Qed. + +Lemma val_submodP m W : (@val_submod m W <= U)%MS. +Proof. by rewrite mulmx_sub ?eq_row_base. Qed. + +Lemma val_submodK m : cancel (@val_submod m) (@in_submod m). +Proof. +move=> W; rewrite /in_submod /= -!mulmxA mulKVmx ?row_ebase_unit //. +by rewrite pid_mx_id ?rank_leq_row // pid_mx_1 mulmx1. +Qed. + +Lemma val_submod_inj m : injective (@val_submod m). +Proof. exact: can_inj (@val_submodK m). Qed. + +Lemma val_submodS m1 m2 (V : 'M_(m1, \rank U)) (W : 'M_(m2, \rank U)) : + (val_submod V <= val_submod W)%MS = (V <= W)%MS. +Proof. +apply/idP/idP=> sVW; last exact: submxMr. +by rewrite -[V]val_submodK -[W]val_submodK submxMr. +Qed. + +Lemma in_submodK m W : (W <= U)%MS -> val_submod (@in_submod m W) = W. +Proof. +case/submxP=> w ->; rewrite /val_submod /= -!mulmxA. +congr (_ *m _); rewrite -{1}[U]mulmx_ebase !mulmxA mulmxK ?row_ebase_unit //. +by rewrite -2!(mulmxA (col_ebase U)) !pid_mx_id ?rank_leq_row // mulmx_ebase. +Qed. + +Lemma val_submod_eq0 m W : (@val_submod m W == 0) = (W == 0). +Proof. by rewrite -!submx0 -val_submodS linear0 !(submx0, eqmx0). Qed. + +Lemma in_submod_eq0 m W : (@in_submod m W == 0) = (W <= U^C)%MS. +Proof. +apply/eqP/submxP=> [W_U0 | [w ->{W}]]. + exists (W *m invmx (row_ebase U)). + rewrite mulmxA mulmxBr mulmx1 -(pid_mx_id _ _ _ (leqnn _)). + rewrite mulmxA -(mulmxA W) [W *m (_ *m _)]W_U0 mul0mx subr0. + by rewrite mulmxKV ?row_ebase_unit. +rewrite /in_submod /= -!mulmxA mulKVmx ?row_ebase_unit //. +by rewrite mul_copid_mx_pid ?rank_leq_row ?mulmx0. +Qed. + +Lemma mxrank_in_submod m (W : 'M_(m, n)) : + (W <= U)%MS -> \rank (in_submod W) = \rank W. +Proof. +by move=> sWU; apply/eqP; rewrite eqn_leq -{3}(in_submodK sWU) !mxrankM_maxl. +Qed. + +Definition val_factmod m : _ -> 'M_(m, n) := + mulmxr (row_base (cokermx U) *m row_ebase U). +Definition in_factmod m : 'M_(m, n) -> _ := mulmxr (col_base (cokermx U)). +Canonical val_factmod_linear m := [linear of @val_factmod m]. +Canonical in_factmod_linear m := [linear of @in_factmod m]. + +Lemma val_factmodE m W : @val_factmod m W = W *m val_factmod 1%:M. +Proof. by rewrite mulmxA mulmx1. Qed. + +Lemma in_factmodE m W : @in_factmod m W = W *m in_factmod 1%:M. +Proof. by rewrite mulmxA mulmx1. Qed. + +Lemma val_factmodP m W : (@val_factmod m W <= U^C)%MS. +Proof. +by rewrite mulmx_sub {m W}// (eqmxMr _ (eq_row_base _)) -mulmxA submxMl. +Qed. + +Lemma val_factmodK m : cancel (@val_factmod m) (@in_factmod m). +Proof. +move=> W /=; rewrite /in_factmod /=; set Uc := cokermx U. +apply: (row_free_inj (row_base_free Uc)); rewrite -mulmxA mulmx_base. +rewrite /val_factmod /= 2!mulmxA -/Uc mulmxK ?row_ebase_unit //. +have /submxP[u ->]: (row_base Uc <= Uc)%MS by rewrite eq_row_base. +by rewrite -!mulmxA copid_mx_id ?rank_leq_row. +Qed. + +Lemma val_factmod_inj m : injective (@val_factmod m). +Proof. exact: can_inj (@val_factmodK m). Qed. + +Lemma val_factmodS m1 m2 (V : 'M_(m1, _)) (W : 'M_(m2, _)) : + (val_factmod V <= val_factmod W)%MS = (V <= W)%MS. +Proof. +apply/idP/idP=> sVW; last exact: submxMr. +by rewrite -[V]val_factmodK -[W]val_factmodK submxMr. +Qed. + +Lemma val_factmod_eq0 m W : (@val_factmod m W == 0) = (W == 0). +Proof. by rewrite -!submx0 -val_factmodS linear0 !(submx0, eqmx0). Qed. + +Lemma in_factmod_eq0 m (W : 'M_(m, n)) : (in_factmod W == 0) = (W <= U)%MS. +Proof. +rewrite submxE -!mxrank_eq0 -{2}[_ U]mulmx_base mulmxA. +by rewrite (mxrankMfree _ (row_base_free _)). +Qed. + +Lemma in_factmodK m (W : 'M_(m, n)) : + (W <= U^C)%MS -> val_factmod (in_factmod W) = W. +Proof. +case/submxP=> w ->{W}; rewrite /val_factmod /= -2!mulmxA. +congr (_ *m _); rewrite (mulmxA (col_base _)) mulmx_base -2!mulmxA. +by rewrite mulKVmx ?row_ebase_unit // mulmxA copid_mx_id ?rank_leq_row. +Qed. + +Lemma in_factmod_addsK m (W : 'M_(m, n)) : + (in_factmod (U + W)%MS :=: in_factmod W)%MS. +Proof. +apply: eqmx_trans (addsmxMr _ _ _) _. +by rewrite ((_ *m _ =P 0) _) ?in_factmod_eq0 //; exact: adds0mx. +Qed. + +Lemma add_sub_fact_mod m (W : 'M_(m, n)) : + val_submod (in_submod W) + val_factmod (in_factmod W) = W. +Proof. +rewrite /val_submod /val_factmod /= -!mulmxA -mulmxDr. +rewrite addrC (mulmxA (pid_mx _)) pid_mx_id // (mulmxA (col_ebase _)). +rewrite (mulmxA _ _ (row_ebase _)) mulmx_ebase. +rewrite (mulmxA (pid_mx _)) pid_mx_id // mulmxA -mulmxDl -mulmxDr. +by rewrite subrK mulmx1 mulmxA mulmxKV ?row_ebase_unit. +Qed. + +Lemma proj_factmodS m (W : 'M_(m, n)) : + (val_factmod (in_factmod W) <= U + W)%MS. +Proof. +by rewrite -{2}[W]add_sub_fact_mod addsmx_addKl ?val_submodP ?addsmxSr. +Qed. + +Lemma in_factmodsK m (W : 'M_(m, n)) : + (U <= W)%MS -> (U + val_factmod (in_factmod W) :=: W)%MS. +Proof. +move/addsmx_idPr; apply: eqmx_trans (eqmx_sym _). +by rewrite -{1}[W]add_sub_fact_mod; apply: addsmx_addKl; exact: val_submodP. +Qed. + +Lemma mxrank_in_factmod m (W : 'M_(m, n)) : + (\rank (in_factmod W) + \rank U)%N = \rank (U + W). +Proof. +rewrite -in_factmod_addsK in_factmodE; set fU := in_factmod 1%:M. +suffices <-: ((U + W) :&: kermx fU :=: U)%MS by rewrite mxrank_mul_ker. +apply: eqmx_trans (capmx_idPr (addsmxSl U W)). +apply: cap_eqmx => //; apply/eqmxP/rV_eqP => u. +by rewrite (sameP sub_kermxP eqP) -in_factmodE in_factmod_eq0. +Qed. + +Definition submod_mx of mxmodule U := + fun x => in_submod (val_submod 1%:M *m rG x). + +Definition factmod_mx of mxmodule U := + fun x => in_factmod (val_factmod 1%:M *m rG x). + +Hypothesis Umod : mxmodule U. + +Lemma in_submodJ m (W : 'M_(m, n)) x : + (W <= U)%MS -> in_submod (W *m rG x) = in_submod W *m submod_mx Umod x. +Proof. +move=> sWU; rewrite mulmxA; congr (in_submod _). +by rewrite mulmxA -val_submodE in_submodK. +Qed. + +Lemma val_submodJ m (W : 'M_(m, \rank U)) x : + x \in G -> val_submod (W *m submod_mx Umod x) = val_submod W *m rG x. +Proof. +move=> Gx; rewrite 2!(mulmxA W) -val_submodE in_submodK //. +by rewrite mxmodule_trans ?val_submodP. +Qed. + +Lemma submod_mx_repr : mx_repr G (submod_mx Umod). +Proof. +rewrite /submod_mx; split=> [|x y Gx Gy /=]. + by rewrite repr_mx1 mulmx1 val_submodK. +rewrite -in_submodJ; first by rewrite repr_mxM ?mulmxA. +by rewrite mxmodule_trans ?val_submodP. +Qed. + +Canonical submod_repr := MxRepresentation submod_mx_repr. + +Lemma in_factmodJ m (W : 'M_(m, n)) x : + x \in G -> in_factmod (W *m rG x) = in_factmod W *m factmod_mx Umod x. +Proof. +move=> Gx; rewrite -{1}[W]add_sub_fact_mod mulmxDl linearD /=. +apply: (canLR (subrK _)); apply: etrans (_ : 0 = _). + apply/eqP; rewrite in_factmod_eq0 (submx_trans _ (mxmoduleP Umod x Gx)) //. + by rewrite submxMr ?val_submodP. +by rewrite /in_factmod /val_factmod /= !mulmxA mulmx1 ?subrr. +Qed. + +Lemma val_factmodJ m (W : 'M_(m, \rank (cokermx U))) x : + x \in G -> + val_factmod (W *m factmod_mx Umod x) = + val_factmod (in_factmod (val_factmod W *m rG x)). +Proof. by move=> Gx; rewrite -{1}[W]val_factmodK -in_factmodJ. Qed. + +Lemma factmod_mx_repr : mx_repr G (factmod_mx Umod). +Proof. +split=> [|x y Gx Gy /=]. + by rewrite /factmod_mx repr_mx1 mulmx1 val_factmodK. +by rewrite -in_factmodJ // -mulmxA -repr_mxM. +Qed. +Canonical factmod_repr := MxRepresentation factmod_mx_repr. + +(* For character theory. *) +Lemma mxtrace_sub_fact_mod x : + \tr (submod_repr x) + \tr (factmod_repr x) = \tr (rG x). +Proof. +rewrite -[submod_repr x]mulmxA mxtrace_mulC -val_submodE addrC. +rewrite -[factmod_repr x]mulmxA mxtrace_mulC -val_factmodE addrC. +by rewrite -mxtraceD add_sub_fact_mod. +Qed. + +End Submodule. + +(* Properties of enveloping algebra as a subspace of 'rV_(n ^ 2). *) + +Lemma envelop_mx_id x : x \in G -> (rG x \in E_G)%MS. +Proof. +by move=> Gx; rewrite (eq_row_sub (enum_rank_in Gx x)) // rowK enum_rankK_in. +Qed. + +Lemma envelop_mx1 : (1%:M \in E_G)%MS. +Proof. by rewrite -(repr_mx1 rG) envelop_mx_id. Qed. + +Lemma envelop_mxP A : + reflect (exists a, A = \sum_(x in G) a x *: rG x) (A \in E_G)%MS. +Proof. +have G_1 := group1 G; have bijG := enum_val_bij_in G_1. +set h := enum_val in bijG; have Gh: h _ \in G by exact: enum_valP. +apply: (iffP submxP) => [[u defA] | [a ->]]. + exists (fun x => u 0 (enum_rank_in G_1 x)); apply: (can_inj mxvecK). + rewrite defA mulmx_sum_row linear_sum (reindex h) //=. + by apply: eq_big => [i | i _]; rewrite ?Gh // rowK linearZ enum_valK_in. +exists (\row_i a (h i)); rewrite mulmx_sum_row linear_sum (reindex h) //=. +by apply: eq_big => [i | i _]; rewrite ?Gh // mxE rowK linearZ. +Qed. + +Lemma envelop_mxM A B : (A \in E_G -> B \in E_G -> A *m B \in E_G)%MS. +Proof. +case/envelop_mxP=> a ->{A}; case/envelop_mxP=> b ->{B}. +rewrite mulmx_suml !linear_sum summx_sub //= => x Gx. +rewrite !linear_sum summx_sub //= => y Gy. +rewrite -scalemxAl !(linearZ, scalemx_sub) //= -repr_mxM //. +by rewrite envelop_mx_id ?groupM. +Qed. + +Lemma mxmodule_envelop m1 m2 (U : 'M_(m1, n)) (W : 'M_(m2, n)) A : + (mxmodule U -> mxvec A <= E_G -> W <= U -> W *m A <= U)%MS. +Proof. +move=> modU /envelop_mxP[a ->] sWU; rewrite linear_sum summx_sub // => x Gx. +by rewrite linearZ scalemx_sub ?mxmodule_trans. +Qed. + +(* Module homomorphisms; any square matrix f defines a module homomorphism *) +(* over some domain, namely, dom_hom_mx f. *) + +Definition dom_hom_mx f : 'M_n := + kermx (lin1_mx (mxvec \o mulmx (cent_mx_fun E_G f) \o lin_mul_row)). + +Lemma hom_mxP m f (W : 'M_(m, n)) : + reflect (forall x, x \in G -> W *m rG x *m f = W *m f *m rG x) + (W <= dom_hom_mx f)%MS. +Proof. +apply: (iffP row_subP) => [cGf x Gx | cGf i]. + apply/row_matrixP=> i; apply/eqP; rewrite -subr_eq0 -!mulmxA -!linearB /=. + have:= sub_kermxP (cGf i); rewrite mul_rV_lin1 /=. + move/(canRL mxvecK)/row_matrixP/(_ (enum_rank_in Gx x))/eqP; rewrite !linear0. + by rewrite !row_mul rowK mul_vec_lin /= mul_vec_lin_row enum_rankK_in. +apply/sub_kermxP; rewrite mul_rV_lin1 /=; apply: (canLR vec_mxK). +apply/row_matrixP=> j; rewrite !row_mul rowK mul_vec_lin /= mul_vec_lin_row. +by rewrite -!row_mul mulmxBr !mulmxA cGf ?enum_valP // subrr !linear0. +Qed. +Implicit Arguments hom_mxP [m f W]. + +Lemma hom_envelop_mxC m f (W : 'M_(m, n)) A : + (W <= dom_hom_mx f -> A \in E_G -> W *m A *m f = W *m f *m A)%MS. +Proof. +move/hom_mxP=> cWfG /envelop_mxP[a ->]; rewrite !linear_sum mulmx_suml. +by apply: eq_bigr => x Gx; rewrite !linearZ -scalemxAl /= cWfG. +Qed. + +Lemma dom_hom_invmx f : + f \in unitmx -> (dom_hom_mx (invmx f) :=: dom_hom_mx f *m f)%MS. +Proof. +move=> injf; set U := dom_hom_mx _; apply/eqmxP. +rewrite -{1}[U](mulmxKV injf) submxMr; apply/hom_mxP=> x Gx. + by rewrite -[_ *m rG x](hom_mxP _) ?mulmxK. +by rewrite -[_ *m rG x](hom_mxP _) ?mulmxKV. +Qed. + +Lemma dom_hom_mx_module f : mxmodule (dom_hom_mx f). +Proof. +apply/mxmoduleP=> x Gx; apply/hom_mxP=> y Gy. +rewrite -[_ *m rG y]mulmxA -repr_mxM // 2?(hom_mxP _) ?groupM //. +by rewrite repr_mxM ?mulmxA. +Qed. + +Lemma hom_mxmodule m (U : 'M_(m, n)) f : + (U <= dom_hom_mx f)%MS -> mxmodule U -> mxmodule (U *m f). +Proof. +move/hom_mxP=> cGfU modU; apply/mxmoduleP=> x Gx. +by rewrite -cGfU // submxMr // (mxmoduleP modU). +Qed. + +Lemma kermx_hom_module m (U : 'M_(m, n)) f : + (U <= dom_hom_mx f)%MS -> mxmodule U -> mxmodule (U :&: kermx f)%MS. +Proof. +move=> homUf modU; apply/mxmoduleP=> x Gx. +rewrite sub_capmx mxmodule_trans ?capmxSl //=. +apply/sub_kermxP; rewrite (hom_mxP _) ?(submx_trans (capmxSl _ _)) //. +by rewrite (sub_kermxP (capmxSr _ _)) mul0mx. +Qed. + +Lemma scalar_mx_hom a m (U : 'M_(m, n)) : (U <= dom_hom_mx a%:M)%MS. +Proof. by apply/hom_mxP=> x Gx; rewrite -!mulmxA scalar_mxC. Qed. + +Lemma proj_mx_hom (U V : 'M_n) : + (U :&: V = 0)%MS -> mxmodule U -> mxmodule V -> + (U + V <= dom_hom_mx (proj_mx U V))%MS. +Proof. +move=> dxUV modU modV; apply/hom_mxP=> x Gx. +rewrite -{1}(add_proj_mx dxUV (submx_refl _)) !mulmxDl addrC. +rewrite {1}[_ *m _]proj_mx_0 ?add0r //; last first. + by rewrite mxmodule_trans ?proj_mx_sub. +by rewrite [_ *m _](proj_mx_id dxUV) // mxmodule_trans ?proj_mx_sub. +Qed. + +(* The subspace fixed by a subgroup H of G; it is a module if H <| G. *) +(* The definition below is extensionally equivalent to the straightforward *) +(* \bigcap_(x in H) kermx (rG x - 1%:M) *) +(* but it avoids the dependency on the choice function; this allows it to *) +(* commute with ring morphisms. *) + +Definition rfix_mx (H : {set gT}) := + let commrH := \matrix_(i < #|H|) mxvec (rG (enum_val i) - 1%:M) in + kermx (lin1_mx (mxvec \o mulmx commrH \o lin_mul_row)). + +Lemma rfix_mxP m (W : 'M_(m, n)) (H : {set gT}) : + reflect (forall x, x \in H -> W *m rG x = W) (W <= rfix_mx H)%MS. +Proof. +rewrite /rfix_mx; set C := \matrix_i _. +apply: (iffP row_subP) => [cHW x Hx | cHW j]. + apply/row_matrixP=> j; apply/eqP; rewrite -subr_eq0 row_mul. + move/sub_kermxP: {cHW}(cHW j); rewrite mul_rV_lin1 /=; move/(canRL mxvecK). + move/row_matrixP/(_ (enum_rank_in Hx x)); rewrite row_mul rowK !linear0. + by rewrite enum_rankK_in // mul_vec_lin_row mulmxBr mulmx1 => ->. +apply/sub_kermxP; rewrite mul_rV_lin1 /=; apply: (canLR vec_mxK). +apply/row_matrixP=> i; rewrite row_mul rowK mul_vec_lin_row -row_mul. +by rewrite mulmxBr mulmx1 cHW ?enum_valP // subrr !linear0. +Qed. +Implicit Arguments rfix_mxP [m W]. + +Lemma rfix_mx_id (H : {set gT}) x : x \in H -> rfix_mx H *m rG x = rfix_mx H. +Proof. exact/rfix_mxP. Qed. + +Lemma rfix_mxS (H K : {set gT}) : H \subset K -> (rfix_mx K <= rfix_mx H)%MS. +Proof. +by move=> sHK; apply/rfix_mxP=> x Hx; exact: rfix_mxP (subsetP sHK x Hx). +Qed. + +Lemma rfix_mx_conjsg (H : {set gT}) x : + x \in G -> H \subset G -> (rfix_mx (H :^ x) :=: rfix_mx H *m rG x)%MS. +Proof. +move=> Gx sHG; pose rf y := rfix_mx (H :^ y). +suffices{x Gx} IH: {in G &, forall y z, rf y *m rG z <= rf (y * z)%g}%MS. + apply/eqmxP; rewrite -/(rf x) -[H]conjsg1 -/(rf 1%g). + rewrite -{4}[x] mul1g -{1}[rf x](repr_mxKV rG Gx) -{1}(mulgV x). + by rewrite submxMr IH ?groupV. +move=> x y Gx Gy; apply/rfix_mxP=> zxy; rewrite actM => /imsetP[zx Hzx ->]. +have Gzx: zx \in G by apply: subsetP Hzx; rewrite conj_subG. +rewrite -mulmxA -repr_mxM ?groupM ?groupV // -conjgC repr_mxM // mulmxA. +by rewrite rfix_mx_id. +Qed. + +Lemma norm_sub_rstabs_rfix_mx (H : {set gT}) : + H \subset G -> 'N_G(H) \subset rstabs (rfix_mx H). +Proof. +move=> sHG; apply/subsetP=> x /setIP[Gx nHx]; rewrite inE Gx. +apply/rfix_mxP=> y Hy; have Gy := subsetP sHG y Hy. +have Hyx: (y ^ x^-1)%g \in H by rewrite memJ_norm ?groupV. +rewrite -mulmxA -repr_mxM // conjgCV repr_mxM ?(subsetP sHG _ Hyx) // mulmxA. +by rewrite (rfix_mx_id Hyx). +Qed. + +Lemma normal_rfix_mx_module H : H <| G -> mxmodule (rfix_mx H). +Proof. +case/andP=> sHG nHG. +by rewrite /mxmodule -{1}(setIidPl nHG) norm_sub_rstabs_rfix_mx. +Qed. + +Lemma rfix_mx_module : mxmodule (rfix_mx G). +Proof. exact: normal_rfix_mx_module. Qed. + +Lemma rfix_mx_rstabC (H : {set gT}) m (U : 'M[F]_(m, n)) : + H \subset G -> (H \subset rstab rG U) = (U <= rfix_mx H)%MS. +Proof. +move=> sHG; apply/subsetP/rfix_mxP=> cHU x Hx. + by rewrite (rstab_act (cHU x Hx)). +by rewrite !inE (subsetP sHG) //= cHU. +Qed. + +(* The cyclic module generated by a single vector. *) +Definition cyclic_mx u := <>%MS. + +Lemma cyclic_mxP u v : + reflect (exists2 A, A \in E_G & v = u *m A)%MS (v <= cyclic_mx u)%MS. +Proof. +rewrite genmxE; apply: (iffP submxP) => [[a] | [A /submxP[a defA]]] -> {v}. + exists (vec_mx (a *m E_G)); last by rewrite mulmxA mul_rV_lin1. + by rewrite vec_mxK submxMl. +by exists a; rewrite mulmxA mul_rV_lin1 /= -defA mxvecK. +Qed. +Implicit Arguments cyclic_mxP [u v]. + +Lemma cyclic_mx_id u : (u <= cyclic_mx u)%MS. +Proof. by apply/cyclic_mxP; exists 1%:M; rewrite ?mulmx1 ?envelop_mx1. Qed. + +Lemma cyclic_mx_eq0 u : (cyclic_mx u == 0) = (u == 0). +Proof. +rewrite -!submx0; apply/idP/idP. + by apply: submx_trans; exact: cyclic_mx_id. +move/submx0null->; rewrite genmxE; apply/row_subP=> i. +by rewrite row_mul mul_rV_lin1 /= mul0mx ?sub0mx. +Qed. + +Lemma cyclic_mx_module u : mxmodule (cyclic_mx u). +Proof. +apply/mxmoduleP=> x Gx; apply/row_subP=> i; rewrite row_mul. +have [A E_A ->{i}] := @cyclic_mxP u _ (row_sub i _); rewrite -mulmxA. +by apply/cyclic_mxP; exists (A *m rG x); rewrite ?envelop_mxM ?envelop_mx_id. +Qed. + +Lemma cyclic_mx_sub m u (W : 'M_(m, n)) : + mxmodule W -> (u <= W)%MS -> (cyclic_mx u <= W)%MS. +Proof. +move=> modU Wu; rewrite genmxE; apply/row_subP=> i. +by rewrite row_mul mul_rV_lin1 /= mxmodule_envelop // vec_mxK row_sub. +Qed. + +Lemma hom_cyclic_mx u f : + (u <= dom_hom_mx f)%MS -> (cyclic_mx u *m f :=: cyclic_mx (u *m f))%MS. +Proof. +move=> domf_u; apply/eqmxP; rewrite !(eqmxMr _ (genmxE _)). +apply/genmxP; rewrite genmx_id; congr <<_>>%MS; apply/row_matrixP=> i. +by rewrite !row_mul !mul_rV_lin1 /= hom_envelop_mxC // vec_mxK row_sub. +Qed. + +(* The annihilator of a single vector. *) + +Definition annihilator_mx u := (E_G :&: kermx (lin_mul_row u))%MS. + +Lemma annihilator_mxP u A : + reflect (A \in E_G /\ u *m A = 0)%MS (A \in annihilator_mx u)%MS. +Proof. +rewrite sub_capmx; apply: (iffP andP) => [[-> /sub_kermxP]|[-> uA0]]. + by rewrite mul_rV_lin1 /= mxvecK. +by split=> //; apply/sub_kermxP; rewrite mul_rV_lin1 /= mxvecK. +Qed. + +(* The subspace of homomorphic images of a row vector. *) + +Definition row_hom_mx u := + (\bigcap_j kermx (vec_mx (row j (annihilator_mx u))))%MS. + +Lemma row_hom_mxP u v : + reflect (exists2 f, u <= dom_hom_mx f & u *m f = v)%MS (v <= row_hom_mx u)%MS. +Proof. +apply: (iffP sub_bigcapmxP) => [iso_uv | [f hom_uf <-] i _]. + have{iso_uv} uv0 A: (A \in E_G)%MS /\ u *m A = 0 -> v *m A = 0. + move/annihilator_mxP=> /submxP[a defA]. + rewrite -[A]mxvecK {A}defA [a *m _]mulmx_sum_row !linear_sum big1 // => i _. + by rewrite !linearZ /= (sub_kermxP _) ?scaler0 ?iso_uv. + pose U := E_G *m lin_mul_row u; pose V := E_G *m lin_mul_row v. + pose f := pinvmx U *m V. + have hom_uv_f x: x \in G -> u *m rG x *m f = v *m rG x. + move=> Gx; apply/eqP; rewrite 2!mulmxA mul_rV_lin1 -subr_eq0 -mulmxBr. + rewrite uv0 // 2!linearB /= vec_mxK; split. + by rewrite addmx_sub ?submxMl // eqmx_opp envelop_mx_id. + have Uux: (u *m rG x <= U)%MS. + by rewrite -(genmxE U) mxmodule_trans ?cyclic_mx_id ?cyclic_mx_module. + by rewrite -{2}(mulmxKpV Uux) [_ *m U]mulmxA mul_rV_lin1 subrr. + have def_uf: u *m f = v. + by rewrite -[u]mulmx1 -[v]mulmx1 -(repr_mx1 rG) hom_uv_f. + by exists f => //; apply/hom_mxP=> x Gx; rewrite def_uf hom_uv_f. +apply/sub_kermxP; set A := vec_mx _. +have: (A \in annihilator_mx u)%MS by rewrite vec_mxK row_sub. +by case/annihilator_mxP => E_A uA0; rewrite -hom_envelop_mxC // uA0 mul0mx. +Qed. + +(* Sub-, isomorphic, simple, semisimple and completely reducible modules. *) +(* All these predicates are intuitionistic (since, e.g., testing simplicity *) +(* requires a splitting algorithm fo r the mas field). They are all *) +(* specialized to square matrices, to avoid spurrious height parameters. *) + +(* Module isomorphism is an intentional property in general, but it can be *) +(* decided when one of the two modules is known to be simple. *) + +CoInductive mx_iso (U V : 'M_n) : Prop := + MxIso f of f \in unitmx & (U <= dom_hom_mx f)%MS & (U *m f :=: V)%MS. + +Lemma eqmx_iso U V : (U :=: V)%MS -> mx_iso U V. +Proof. +by move=> eqUV; exists 1%:M; rewrite ?unitmx1 ?scalar_mx_hom ?mulmx1. +Qed. + +Lemma mx_iso_refl U : mx_iso U U. +Proof. exact: eqmx_iso. Qed. + +Lemma mx_iso_sym U V : mx_iso U V -> mx_iso V U. +Proof. +case=> f injf homUf defV; exists (invmx f); first by rewrite unitmx_inv. + by rewrite dom_hom_invmx // -defV submxMr. +by rewrite -[U](mulmxK injf); exact: eqmxMr (eqmx_sym _). +Qed. + +Lemma mx_iso_trans U V W : mx_iso U V -> mx_iso V W -> mx_iso U W. +Proof. +case=> f injf homUf defV [g injg homVg defW]. +exists (f *m g); first by rewrite unitmx_mul injf. + by apply/hom_mxP=> x Gx; rewrite !mulmxA 2?(hom_mxP _) ?defV. +by rewrite mulmxA; exact: eqmx_trans (eqmxMr g defV) defW. +Qed. + +Lemma mxrank_iso U V : mx_iso U V -> \rank U = \rank V. +Proof. by case=> f injf _ <-; rewrite mxrankMfree ?row_free_unit. Qed. + +Lemma mx_iso_module U V : mx_iso U V -> mxmodule U -> mxmodule V. +Proof. +by case=> f _ homUf defV; rewrite -(eqmx_module defV); exact: hom_mxmodule. +Qed. + +(* Simple modules (we reserve the term "irreducible" for representations). *) + +Definition mxsimple (V : 'M_n) := + [/\ mxmodule V, V != 0 & + forall U : 'M_n, mxmodule U -> (U <= V)%MS -> U != 0 -> (V <= U)%MS]. + +Definition mxnonsimple (U : 'M_n) := + exists V : 'M_n, [&& mxmodule V, (V <= U)%MS, V != 0 & \rank V < \rank U]. + +Lemma mxsimpleP U : + [/\ mxmodule U, U != 0 & ~ mxnonsimple U] <-> mxsimple U. +Proof. +do [split => [] [modU nzU simU]; split] => // [V modV sVU nzV | [V]]. + apply/idPn; rewrite -(ltn_leqif (mxrank_leqif_sup sVU)) => ltVU. + by case: simU; exists V; exact/and4P. +by case/and4P=> modV sVU nzV; apply/negP; rewrite -leqNgt mxrankS ?simU. +Qed. + +Lemma mxsimple_module U : mxsimple U -> mxmodule U. +Proof. by case. Qed. + +Lemma mxsimple_exists m (U : 'M_(m, n)) : + mxmodule U -> U != 0 -> classically (exists2 V, mxsimple V & V <= U)%MS. +Proof. +move=> modU nzU [] // simU; move: {2}_.+1 (ltnSn (\rank U)) => r leUr. +elim: r => // r IHr in m U leUr modU nzU simU. +have genU := genmxE U; apply simU; exists <>%MS; last by rewrite genU. +apply/mxsimpleP; split; rewrite ?(eqmx_eq0 genU) ?(eqmx_module genU) //. +case=> V; rewrite !genU=> /and4P[modV sVU nzV ltVU]; case: notF. +apply: IHr nzV _ => // [|[W simW sWV]]; first exact: leq_trans ltVU _. +by apply: simU; exists W => //; exact: submx_trans sWV sVU. +Qed. + +Lemma mx_iso_simple U V : mx_iso U V -> mxsimple U -> mxsimple V. +Proof. +move=> isoUV [modU nzU simU]; have [f injf homUf defV] := isoUV. +split=> [||W modW sWV nzW]; first by rewrite (mx_iso_module isoUV). + by rewrite -(eqmx_eq0 defV) -(mul0mx n f) (can_eq (mulmxK injf)). +rewrite -defV -[W](mulmxKV injf) submxMr //; set W' := W *m _. +have sW'U: (W' <= U)%MS by rewrite -[U](mulmxK injf) submxMr ?defV. +rewrite (simU W') //; last by rewrite -(can_eq (mulmxK injf)) mul0mx mulmxKV. +rewrite hom_mxmodule ?dom_hom_invmx // -[W](mulmxKV injf) submxMr //. +exact: submx_trans sW'U homUf. +Qed. + +Lemma mxsimple_cyclic u U : + mxsimple U -> u != 0 -> (u <= U)%MS -> (U :=: cyclic_mx u)%MS. +Proof. +case=> [modU _ simU] nz_u Uu; apply/eqmxP; set uG := cyclic_mx u. +have s_uG_U: (uG <= U)%MS by rewrite cyclic_mx_sub. +by rewrite simU ?cyclic_mx_eq0 ?submx_refl // cyclic_mx_module. +Qed. + +(* The surjective part of Schur's lemma. *) +Lemma mx_Schur_onto m (U : 'M_(m, n)) V f : + mxmodule U -> mxsimple V -> (U <= dom_hom_mx f)%MS -> + (U *m f <= V)%MS -> U *m f != 0 -> (U *m f :=: V)%MS. +Proof. +move=> modU [modV _ simV] homUf sUfV nzUf. +apply/eqmxP; rewrite sUfV -(genmxE (U *m f)). +rewrite simV ?(eqmx_eq0 (genmxE _)) ?genmxE //. +by rewrite (eqmx_module (genmxE _)) hom_mxmodule. +Qed. + +(* The injective part of Schur's lemma. *) +Lemma mx_Schur_inj U f : + mxsimple U -> (U <= dom_hom_mx f)%MS -> U *m f != 0 -> (U :&: kermx f)%MS = 0. +Proof. +case=> [modU _ simU] homUf nzUf; apply/eqP; apply: contraR nzUf => nz_ker. +rewrite (sameP eqP sub_kermxP) (sameP capmx_idPl eqmxP) simU ?capmxSl //. +exact: kermx_hom_module. +Qed. + +(* The injectve part of Schur's lemma, stated as isomorphism with the image. *) +Lemma mx_Schur_inj_iso U f : + mxsimple U -> (U <= dom_hom_mx f)%MS -> U *m f != 0 -> mx_iso U (U *m f). +Proof. +move=> simU homUf nzUf; have [modU _ _] := simU. +have eqUfU: \rank (U *m f) = \rank U by apply/mxrank_injP; rewrite mx_Schur_inj. +have{eqUfU} [g invg defUf] := complete_unitmx eqUfU. +suffices homUg: (U <= dom_hom_mx g)%MS by exists g; rewrite ?defUf. +apply/hom_mxP=> x Gx; have [ux defUx] := submxP (mxmoduleP modU x Gx). +by rewrite -defUf -(hom_mxP homUf) // defUx -!(mulmxA ux) defUf. +Qed. + +(* The isomorphism part of Schur's lemma. *) +Lemma mx_Schur_iso U V f : + mxsimple U -> mxsimple V -> (U <= dom_hom_mx f)%MS -> + (U *m f <= V)%MS -> U *m f != 0 -> mx_iso U V. +Proof. +move=> simU simV homUf sUfV nzUf; have [modU _ _] := simU. +have [g invg homUg defUg] := mx_Schur_inj_iso simU homUf nzUf. +exists g => //; apply: mx_Schur_onto; rewrite ?defUg //. +by rewrite -!submx0 defUg in nzUf *. +Qed. + +(* A boolean test for module isomorphism that is only valid for simple *) +(* modules; this is the only case that matters in practice. *) + +Lemma nz_row_mxsimple U : mxsimple U -> nz_row U != 0. +Proof. by case=> _ nzU _; rewrite nz_row_eq0. Qed. + +Definition mxsimple_iso (U V : 'M_n) := + [&& mxmodule V, (V :&: row_hom_mx (nz_row U))%MS != 0 & \rank V <= \rank U]. + +Lemma mxsimple_isoP U V : + mxsimple U -> reflect (mx_iso U V) (mxsimple_iso U V). +Proof. +move=> simU; pose u := nz_row U. +have [Uu nz_u]: (u <= U)%MS /\ u != 0 by rewrite nz_row_sub nz_row_mxsimple. +apply: (iffP and3P) => [[modV] | isoUV]; last first. + split; last by rewrite (mxrank_iso isoUV). + by case: (mx_iso_simple isoUV simU). + have [f injf homUf defV] := isoUV; apply/rowV0Pn; exists (u *m f). + rewrite sub_capmx -defV submxMr //. + by apply/row_hom_mxP; exists f; first exact: (submx_trans Uu). + by rewrite -(mul0mx _ f) (can_eq (mulmxK injf)) nz_u. +case/rowV0Pn=> v; rewrite sub_capmx => /andP[Vv]. +case/row_hom_mxP => f homMf def_v nz_v eqrUV. +pose uG := cyclic_mx u; pose vG := cyclic_mx v. +have def_vG: (uG *m f :=: vG)%MS by rewrite /vG -def_v; exact: hom_cyclic_mx. +have defU: (U :=: uG)%MS by exact: mxsimple_cyclic. +have mod_uG: mxmodule uG by rewrite cyclic_mx_module. +have homUf: (U <= dom_hom_mx f)%MS. + by rewrite defU cyclic_mx_sub ?dom_hom_mx_module. +have isoUf: mx_iso U (U *m f). + apply: mx_Schur_inj_iso => //; apply: contra nz_v; rewrite -!submx0. + by rewrite (eqmxMr f defU) def_vG; exact: submx_trans (cyclic_mx_id v). +apply: mx_iso_trans (isoUf) (eqmx_iso _); apply/eqmxP. +have sUfV: (U *m f <= V)%MS by rewrite (eqmxMr f defU) def_vG cyclic_mx_sub. +by rewrite -mxrank_leqif_eq ?eqn_leq 1?mxrankS // -(mxrank_iso isoUf). +Qed. + +Lemma mxsimple_iso_simple U V : + mxsimple_iso U V -> mxsimple U -> mxsimple V. +Proof. +by move=> isoUV simU; apply: mx_iso_simple (simU); exact/mxsimple_isoP. +Qed. + +(* For us, "semisimple" means "sum of simple modules"; this is classically, *) +(* but not intuitionistically, equivalent to the "completely reducible" *) +(* alternate characterization. *) + +Implicit Type I : finType. + +CoInductive mxsemisimple (V : 'M_n) := + MxSemisimple I U (W := (\sum_(i : I) U i)%MS) of + forall i, mxsimple (U i) & (W :=: V)%MS & mxdirect W. + +(* This is a slight generalization of Aschbacher 12.5 for finite sets. *) +Lemma sum_mxsimple_direct_compl m I W (U : 'M_(m, n)) : + let V := (\sum_(i : I) W i)%MS in + (forall i : I, mxsimple (W i)) -> mxmodule U -> (U <= V)%MS -> + {J : {set I} | let S := U + \sum_(i in J) W i in S :=: V /\ mxdirect S}%MS. +Proof. +move=> V simW modU sUV; pose V_ (J : {set I}) := (\sum_(i in J) W i)%MS. +pose dxU (J : {set I}) := mxdirect (U + V_ J). +have [J maxJ]: {J | maxset dxU J}; last case/maxsetP: maxJ => dxUVJ maxJ. + apply: ex_maxset; exists set0. + by rewrite /dxU mxdirectE /V_ /= !big_set0 addn0 addsmx0 /=. +have modWJ: mxmodule (V_ J) by apply: sumsmx_module => i _; case: (simW i). +exists J; split=> //; apply/eqmxP; rewrite addsmx_sub sUV; apply/andP; split. + by apply/sumsmx_subP=> i Ji; rewrite (sumsmx_sup i). +rewrite -/(V_ J); apply/sumsmx_subP=> i _. +case Ji: (i \in J). + by apply: submx_trans (addsmxSr _ _); exact: (sumsmx_sup i). +have [modWi nzWi simWi] := simW i. +rewrite (sameP capmx_idPl eqmxP) simWi ?capmxSl ?capmx_module ?addsmx_module //. +apply: contraFT (Ji); rewrite negbK => dxWiUVJ. +rewrite -(maxJ (i |: J)) ?setU11 ?subsetUr // /dxU. +rewrite mxdirectE /= !big_setU1 ?Ji //=. +rewrite addnCA addsmxA (addsmxC U) -addsmxA -mxdirectE /=. +by rewrite mxdirect_addsE /= mxdirect_trivial -/(dxU _) dxUVJ. +Qed. + +Lemma sum_mxsimple_direct_sub I W (V : 'M_n) : + (forall i : I, mxsimple (W i)) -> (\sum_i W i :=: V)%MS -> + {J : {set I} | let S := \sum_(i in J) W i in S :=: V /\ mxdirect S}%MS. +Proof. +move=> simW defV. +have [|J [defS dxS]] := sum_mxsimple_direct_compl simW (mxmodule0 n). + exact: sub0mx. +exists J; split; last by rewrite mxdirectE /= adds0mx mxrank0 in dxS. +by apply: eqmx_trans defV; rewrite adds0mx_id in defS. +Qed. + +Lemma mxsemisimple0 : mxsemisimple 0. +Proof. +exists [finType of 'I_0] (fun _ => 0); [by case | by rewrite big_ord0 | ]. +by rewrite mxdirectE /= !big_ord0 mxrank0. +Qed. + +Lemma intro_mxsemisimple (I : Type) r (P : pred I) W V : + (\sum_(i <- r | P i) W i :=: V)%MS -> + (forall i, P i -> W i != 0 -> mxsimple (W i)) -> + mxsemisimple V. +Proof. +move=> defV simW; pose W_0 := [pred i | W i == 0]. +have [-> | nzV] := eqVneq V 0; first exact: mxsemisimple0. +case def_r: r => [| i0 r'] => [|{r' def_r}]. + by rewrite -mxrank_eq0 -defV def_r big_nil mxrank0 in nzV. +move: defV; rewrite (bigID W_0) /= addsmxC -big_filter !(big_nth i0) !big_mkord. +rewrite addsmxC big1 ?adds0mx_id => [|i /andP[_ /eqP] //]. +set tI := 'I_(_); set r_ := nth _ _ => defV. +have{simW} simWr (i : tI) : mxsimple (W (r_ i)). + case: i => m /=; set Pr := fun i => _ => lt_m_r /=. + suffices: (Pr (r_ m)) by case/andP; exact: simW. + apply: all_nthP m lt_m_r; apply/all_filterP. + by rewrite -filter_predI; apply: eq_filter => i; rewrite /= andbb. +have [J []] := sum_mxsimple_direct_sub simWr defV. +case: (set_0Vmem J) => [-> V0 | [j0 Jj0]]. + by rewrite -mxrank_eq0 -V0 big_set0 mxrank0 in nzV. +pose K := {j | j \in J}; pose k0 : K := Sub j0 Jj0. +have bij_KJ: {on J, bijective (sval : K -> _)}. + by exists (insubd k0) => [k _ | j Jj]; rewrite ?valKd ?insubdK. +have J_K (k : K) : sval k \in J by exact: valP k. +rewrite mxdirectE /= !(reindex _ bij_KJ) !(eq_bigl _ _ J_K) -mxdirectE /= -/tI. +exact: MxSemisimple. +Qed. + +Lemma mxsimple_semisimple U : mxsimple U -> mxsemisimple U. +Proof. +move=> simU; apply: (intro_mxsemisimple (_ : \sum_(i < 1) U :=: U))%MS => //. +by rewrite big_ord1. +Qed. + +Lemma addsmx_semisimple U V : + mxsemisimple U -> mxsemisimple V -> mxsemisimple (U + V)%MS. +Proof. +case=> [I W /= simW defU _] [J T /= simT defV _]. +have defUV: (\sum_ij sum_rect (fun _ => 'M_n) W T ij :=: U + V)%MS. + by rewrite big_sumType /=; exact: adds_eqmx. +by apply: intro_mxsemisimple defUV _; case=> /=. +Qed. + +Lemma sumsmx_semisimple (I : finType) (P : pred I) V : + (forall i, P i -> mxsemisimple (V i)) -> mxsemisimple (\sum_(i | P i) V i)%MS. +Proof. +move=> ssimV; elim/big_ind: _ => //; first exact: mxsemisimple0. +exact: addsmx_semisimple. +Qed. + +Lemma eqmx_semisimple U V : (U :=: V)%MS -> mxsemisimple U -> mxsemisimple V. +Proof. +by move=> eqUV [I W S simW defU dxS]; exists I W => //; exact: eqmx_trans eqUV. +Qed. + +Lemma hom_mxsemisimple (V f : 'M_n) : + mxsemisimple V -> (V <= dom_hom_mx f)%MS -> mxsemisimple (V *m f). +Proof. +case=> I W /= simW defV _; rewrite -defV => /sumsmx_subP homWf. +have{defV} defVf: (\sum_i W i *m f :=: V *m f)%MS. + by apply: eqmx_trans (eqmx_sym _) (eqmxMr f defV); exact: sumsmxMr. +apply: (intro_mxsemisimple defVf) => i _ nzWf. +by apply: mx_iso_simple (simW i); apply: mx_Schur_inj_iso; rewrite ?homWf. +Qed. + +Lemma mxsemisimple_module U : mxsemisimple U -> mxmodule U. +Proof. +case=> I W /= simW defU _. +by rewrite -(eqmx_module defU) sumsmx_module // => i _; case: (simW i). +Qed. + +(* Completely reducible modules, and Maeschke's Theorem. *) + +CoInductive mxsplits (V U : 'M_n) := + MxSplits (W : 'M_n) of mxmodule W & (U + W :=: V)%MS & mxdirect (U + W). + +Definition mx_completely_reducible V := + forall U, mxmodule U -> (U <= V)%MS -> mxsplits V U. + +Lemma mx_reducibleS U V : + mxmodule U -> (U <= V)%MS -> + mx_completely_reducible V -> mx_completely_reducible U. +Proof. +move=> modU sUV redV U1 modU1 sU1U. +have [W modW defV dxU1W] := redV U1 modU1 (submx_trans sU1U sUV). +exists (W :&: U)%MS; first exact: capmx_module. + by apply/eqmxP; rewrite !matrix_modl // capmxSr sub_capmx defV sUV /=. +by apply/mxdirect_addsP; rewrite capmxA (mxdirect_addsP dxU1W) cap0mx. +Qed. + +Lemma mx_Maschke : [char F]^'.-group G -> mx_completely_reducible 1%:M. +Proof. +rewrite /pgroup charf'_nat; set nG := _%:R => nzG U => /mxmoduleP Umod _. +pose phi := nG^-1 *: (\sum_(x in G) rG x^-1 *m pinvmx U *m U *m rG x). +have phiG x: x \in G -> phi *m rG x = rG x *m phi. + move=> Gx; rewrite -scalemxAl -scalemxAr; congr (_ *: _). + rewrite {2}(reindex_acts 'R _ Gx) ?astabsR //= mulmx_suml mulmx_sumr. + apply: eq_bigr => y Gy; rewrite !mulmxA -repr_mxM ?groupV ?groupM //. + by rewrite invMg mulKVg repr_mxM ?mulmxA. +have Uphi: U *m phi = U. + rewrite -scalemxAr mulmx_sumr (eq_bigr (fun _ => U)) => [|x Gx]. + by rewrite sumr_const -scaler_nat !scalerA mulVf ?scale1r. + by rewrite 3!mulmxA mulmxKpV ?repr_mxKV ?Umod ?groupV. +have tiUker: (U :&: kermx phi = 0)%MS. + apply/eqP/rowV0P=> v; rewrite sub_capmx => /andP[/submxP[u ->] /sub_kermxP]. + by rewrite -mulmxA Uphi. +exists (kermx phi); last exact/mxdirect_addsP. + apply/mxmoduleP=> x Gx; apply/sub_kermxP. + by rewrite -mulmxA -phiG // mulmxA mulmx_ker mul0mx. +apply/eqmxP; rewrite submx1 sub1mx. +rewrite /row_full mxrank_disjoint_sum //= mxrank_ker. +suffices ->: (U :=: phi)%MS by rewrite subnKC ?rank_leq_row. +apply/eqmxP; rewrite -{1}Uphi submxMl scalemx_sub //. +by rewrite summx_sub // => x Gx; rewrite -mulmxA mulmx_sub ?Umod. +Qed. + +Lemma mxsemisimple_reducible V : mxsemisimple V -> mx_completely_reducible V. +Proof. +case=> [I W /= simW defV _] U modU sUV; rewrite -defV in sUV. +have [J [defV' dxV]] := sum_mxsimple_direct_compl simW modU sUV. +exists (\sum_(i in J) W i)%MS. +- by apply: sumsmx_module => i _; case: (simW i). +- exact: eqmx_trans defV' defV. +by rewrite mxdirect_addsE (sameP eqP mxdirect_addsP) /= in dxV; case/and3P: dxV. +Qed. + +Lemma mx_reducible_semisimple V : + mxmodule V -> mx_completely_reducible V -> classically (mxsemisimple V). +Proof. +move=> modV redV [] // nssimV; move: {-1}_.+1 (ltnSn (\rank V)) => r leVr. +elim: r => // r IHr in V leVr modV redV nssimV. +have [V0 | nzV] := eqVneq V 0. + by rewrite nssimV ?V0 //; exact: mxsemisimple0. +apply (mxsimple_exists modV nzV) => [[U simU sUV]]; have [modU nzU _] := simU. +have [W modW defUW dxUW] := redV U modU sUV. +have sWV: (W <= V)%MS by rewrite -defUW addsmxSr. +apply: IHr (mx_reducibleS modW sWV redV) _ => // [|ssimW]. + rewrite ltnS -defUW (mxdirectP dxUW) /= in leVr; apply: leq_trans leVr. + by rewrite -add1n leq_add2r lt0n mxrank_eq0. +apply: nssimV (eqmx_semisimple defUW (addsmx_semisimple _ ssimW)). +exact: mxsimple_semisimple. +Qed. + +Lemma mxsemisimpleS U V : + mxmodule U -> (U <= V)%MS -> mxsemisimple V -> mxsemisimple U. +Proof. +move=> modU sUV ssimV. +have [W modW defUW dxUW]:= mxsemisimple_reducible ssimV modU sUV. +move/mxdirect_addsP: dxUW => dxUW. +have defU : (V *m proj_mx U W :=: U)%MS. + by apply/eqmxP; rewrite proj_mx_sub -{1}[U](proj_mx_id dxUW) ?submxMr. +apply: eqmx_semisimple defU _; apply: hom_mxsemisimple ssimV _. +by rewrite -defUW proj_mx_hom. +Qed. + +Lemma hom_mxsemisimple_iso I P U W f : + let V := (\sum_(i : I | P i) W i)%MS in + mxsimple U -> (forall i, P i -> W i != 0 -> mxsimple (W i)) -> + (V <= dom_hom_mx f)%MS -> (U <= V *m f)%MS -> + {i | P i & mx_iso (W i) U}. +Proof. +move=> V simU simW homVf sUVf; have [modU nzU _] := simU. +have ssimVf: mxsemisimple (V *m f). + exact: hom_mxsemisimple (intro_mxsemisimple (eqmx_refl V) simW) homVf. +have [U' modU' defVf] := mxsemisimple_reducible ssimVf modU sUVf. +move/mxdirect_addsP=> dxUU'; pose p := f *m proj_mx U U'. +case: (pickP (fun i => P i && (W i *m p != 0))) => [i /andP[Pi nzWip] | no_i]. + have sWiV: (W i <= V)%MS by rewrite (sumsmx_sup i). + have sWipU: (W i *m p <= U)%MS by rewrite mulmxA proj_mx_sub. + exists i => //; apply: (mx_Schur_iso (simW i Pi _) simU _ sWipU nzWip). + by apply: contraNneq nzWip => ->; rewrite mul0mx. + apply: (submx_trans sWiV); apply/hom_mxP=> x Gx. + by rewrite mulmxA [_ *m p]mulmxA 2?(hom_mxP _) -?defVf ?proj_mx_hom. +case/negP: nzU; rewrite -submx0 -[U](proj_mx_id dxUU') //. +rewrite (submx_trans (submxMr _ sUVf)) // -mulmxA -/p sumsmxMr. +by apply/sumsmx_subP=> i Pi; move/negbT: (no_i i); rewrite Pi negbK submx0. +Qed. + +(* The component associated to a given irreducible module. *) + +Section Components. + +Fact component_mx_key : unit. Proof. by []. Qed. +Definition component_mx_expr (U : 'M[F]_n) := + (\sum_i cyclic_mx (row i (row_hom_mx (nz_row U))))%MS. +Definition component_mx := locked_with component_mx_key component_mx_expr. +Canonical component_mx_unfoldable := [unlockable fun component_mx]. + +Variable U : 'M[F]_n. +Hypothesis simU : mxsimple U. + +Let u := nz_row U. +Let iso_u := row_hom_mx u. +Let nz_u : u != 0 := nz_row_mxsimple simU. +Let Uu : (u <= U)%MS := nz_row_sub U. +Let defU : (U :=: cyclic_mx u)%MS := mxsimple_cyclic simU nz_u Uu. +Local Notation compU := (component_mx U). + +Lemma component_mx_module : mxmodule compU. +Proof. +by rewrite unlock sumsmx_module // => i; rewrite cyclic_mx_module. +Qed. + +Lemma genmx_component : <>%MS = compU. +Proof. +by rewrite [in compU]unlock genmx_sums; apply: eq_bigr => i; rewrite genmx_id. +Qed. + +Lemma component_mx_def : {I : finType & {W : I -> 'M_n | + forall i, mx_iso U (W i) & compU = \sum_i W i}}%MS. +Proof. +pose r i := row i iso_u; pose r_nz i := r i != 0; pose I := {i | r_nz i}. +exists [finType of I]; exists (fun i => cyclic_mx (r (sval i))) => [i|]. + apply/mxsimple_isoP=> //; apply/and3P. + split; first by rewrite cyclic_mx_module. + apply/rowV0Pn; exists (r (sval i)); last exact: (svalP i). + by rewrite sub_capmx cyclic_mx_id row_sub. + have [f hom_u_f <-] := @row_hom_mxP u (r (sval i)) (row_sub _ _). + by rewrite defU -hom_cyclic_mx ?mxrankM_maxl. +rewrite -(eq_bigr _ (fun _ _ => genmx_id _)) -genmx_sums -genmx_component. +rewrite [in compU]unlock; apply/genmxP/andP; split; last first. + by apply/sumsmx_subP => i _; rewrite (sumsmx_sup (sval i)). +apply/sumsmx_subP => i _. +case i0: (r_nz i); first by rewrite (sumsmx_sup (Sub i i0)). +by move/negbFE: i0; rewrite -cyclic_mx_eq0 => /eqP->; exact: sub0mx. +Qed. + +Lemma component_mx_semisimple : mxsemisimple compU. +Proof. +have [I [W isoUW ->]] := component_mx_def. +apply: intro_mxsemisimple (eqmx_refl _) _ => i _ _. +exact: mx_iso_simple (isoUW i) simU. +Qed. + +Lemma mx_iso_component V : mx_iso U V -> (V <= compU)%MS. +Proof. +move=> isoUV; have [f injf homUf defV] := isoUV. +have simV := mx_iso_simple isoUV simU. +have hom_u_f := submx_trans Uu homUf. +have ->: (V :=: cyclic_mx (u *m f))%MS. + apply: eqmx_trans (hom_cyclic_mx hom_u_f). + exact: eqmx_trans (eqmx_sym defV) (eqmxMr _ defU). +have iso_uf: (u *m f <= iso_u)%MS by apply/row_hom_mxP; exists f. +rewrite genmxE; apply/row_subP=> j; rewrite row_mul mul_rV_lin1 /=. +set a := vec_mx _; apply: submx_trans (submxMr _ iso_uf) _. +apply/row_subP=> i; rewrite row_mul [in compU]unlock (sumsmx_sup i) //. +by apply/cyclic_mxP; exists a; rewrite // vec_mxK row_sub. +Qed. + +Lemma component_mx_id : (U <= compU)%MS. +Proof. exact: mx_iso_component (mx_iso_refl U). Qed. + +Lemma hom_component_mx_iso f V : + mxsimple V -> (compU <= dom_hom_mx f)%MS -> (V <= compU *m f)%MS -> + mx_iso U V. +Proof. +have [I [W isoUW ->]] := component_mx_def => simV homWf sVWf. +have [i _ _|i _ ] := hom_mxsemisimple_iso simV _ homWf sVWf. + exact: mx_iso_simple (simU). +exact: mx_iso_trans. +Qed. + +Lemma component_mx_iso V : mxsimple V -> (V <= compU)%MS -> mx_iso U V. +Proof. +move=> simV; rewrite -[compU]mulmx1. +exact: hom_component_mx_iso (scalar_mx_hom _ _). +Qed. + +Lemma hom_component_mx f : + (compU <= dom_hom_mx f)%MS -> (compU *m f <= compU)%MS. +Proof. +move=> hom_f. +have [I W /= simW defW _] := hom_mxsemisimple component_mx_semisimple hom_f. +rewrite -defW; apply/sumsmx_subP=> i _; apply: mx_iso_component. +by apply: hom_component_mx_iso hom_f _ => //; rewrite -defW (sumsmx_sup i). +Qed. + +End Components. + +Lemma component_mx_isoP U V : + mxsimple U -> mxsimple V -> + reflect (mx_iso U V) (component_mx U == component_mx V). +Proof. +move=> simU simV; apply: (iffP eqP) => isoUV. + by apply: component_mx_iso; rewrite ?isoUV ?component_mx_id. +rewrite -(genmx_component U) -(genmx_component V); apply/genmxP. +wlog suffices: U V simU simV isoUV / (component_mx U <= component_mx V)%MS. + by move=> IH; rewrite !IH //; exact: mx_iso_sym. +have [I [W isoWU ->]] := component_mx_def simU. +apply/sumsmx_subP => i _; apply: mx_iso_component => //. +exact: mx_iso_trans (mx_iso_sym isoUV) (isoWU i). +Qed. + +Lemma component_mx_disjoint U V : + mxsimple U -> mxsimple V -> component_mx U != component_mx V -> + (component_mx U :&: component_mx V = 0)%MS. +Proof. +move=> simU simV neUV; apply: contraNeq neUV => ntUV. +apply: (mxsimple_exists _ ntUV) => [|[W simW]]. + by rewrite capmx_module ?component_mx_module. +rewrite sub_capmx => /andP[sWU sWV]; apply/component_mx_isoP=> //. +by apply: mx_iso_trans (_ : mx_iso U W) (mx_iso_sym _); exact: component_mx_iso. +Qed. + +Section Socle. + +Record socleType := EnumSocle { + socle_base_enum : seq 'M[F]_n; + _ : forall M, M \in socle_base_enum -> mxsimple M; + _ : forall M, mxsimple M -> has (mxsimple_iso M) socle_base_enum +}. + +Lemma socle_exists : classically socleType. +Proof. +pose V : 'M[F]_n := 0; have: mxsemisimple V by exact: mxsemisimple0. +have: n - \rank V < n.+1 by rewrite mxrank0 subn0. +elim: _.+1 V => // n' IHn' V; rewrite ltnS => le_nV_n' ssimV. +case=> // maxV; apply: (maxV); have [I /= U simU defV _] := ssimV. +exists (codom U) => [M | M simM]; first by case/mapP=> i _ ->. +suffices sMV: (M <= V)%MS. + rewrite -defV -(mulmx1 (\sum_i _)%MS) in sMV. + have [//| i _] := hom_mxsemisimple_iso simM _ (scalar_mx_hom _ _) sMV. + move/mx_iso_sym=> isoM; apply/hasP. + exists (U i); [exact: codom_f | exact/mxsimple_isoP]. +have ssimMV := addsmx_semisimple (mxsimple_semisimple simM) ssimV. +apply: contraLR isT => nsMV; apply: IHn' ssimMV _ maxV. +apply: leq_trans le_nV_n'; rewrite ltn_sub2l //. + rewrite ltn_neqAle rank_leq_row andbT -[_ == _]sub1mx. + apply: contra nsMV; apply: submx_trans; exact: submx1. +rewrite (ltn_leqif (mxrank_leqif_sup _)) ?addsmxSr //. +by rewrite addsmx_sub submx_refl andbT. +Qed. + +Section SocleDef. + +Variable sG0 : socleType. + +Definition socle_enum := map component_mx (socle_base_enum sG0). + +Lemma component_socle M : mxsimple M -> component_mx M \in socle_enum. +Proof. +rewrite /socle_enum; case: sG0 => e0 /= sim_e mem_e simM. +have /hasP[M' e0M' isoMM'] := mem_e M simM; apply/mapP; exists M' => //. +by apply/eqP/component_mx_isoP; [|exact: sim_e | exact/mxsimple_isoP]. +Qed. + +Inductive socle_sort : predArgType := PackSocle W of W \in socle_enum. + +Local Notation sG := socle_sort. +Local Notation e0 := (socle_base_enum sG0). + +Definition socle_base W := let: PackSocle W _ := W in e0`_(index W socle_enum). + +Coercion socle_val W : 'M[F]_n := component_mx (socle_base W). + +Definition socle_mult (W : sG) := (\rank W %/ \rank (socle_base W))%N. + +Lemma socle_simple W : mxsimple (socle_base W). +Proof. +case: W => M /=; rewrite /= /socle_enum /=; case: sG0 => e sim_e _ /= e_M. +by apply: sim_e; rewrite mem_nth // -(size_map component_mx) index_mem. +Qed. + +Definition socle_module (W : sG) := mxsimple_module (socle_simple W). + +Definition socle_repr W := submod_repr (socle_module W). + +Lemma nz_socle (W : sG) : W != 0 :> 'M_n. +Proof. +have simW := socle_simple W; have [_ nzW _] := simW; apply: contra nzW. +by rewrite -!submx0; exact: submx_trans (component_mx_id simW). +Qed. + +Lemma socle_mem (W : sG) : (W : 'M_n) \in socle_enum. +Proof. exact: component_socle (socle_simple _). Qed. + +Lemma PackSocleK W e0W : @PackSocle W e0W = W :> 'M_n. +Proof. +rewrite /socle_val /= in e0W *; rewrite -(nth_map _ 0) ?nth_index //. +by rewrite -(size_map component_mx) index_mem. +Qed. + +Canonical socle_subType := SubType _ _ _ socle_sort_rect PackSocleK. +Definition socle_eqMixin := Eval hnf in [eqMixin of sG by <:]. +Canonical socle_eqType := Eval hnf in EqType sG socle_eqMixin. +Definition socle_choiceMixin := Eval hnf in [choiceMixin of sG by <:]. +Canonical socle_choiceType := ChoiceType sG socle_choiceMixin. + +Lemma socleP (W W' : sG) : reflect (W = W') (W == W')%MS. +Proof. by rewrite (sameP genmxP eqP) !{1}genmx_component; exact: (W =P _). Qed. + +Fact socle_finType_subproof : + cancel (fun W => SeqSub (socle_mem W)) (fun s => PackSocle (valP s)). +Proof. by move=> W /=; apply: val_inj; rewrite /= PackSocleK. Qed. + +Definition socle_countMixin := CanCountMixin socle_finType_subproof. +Canonical socle_countType := CountType sG socle_countMixin. +Canonical socle_subCountType := [subCountType of sG]. +Definition socle_finMixin := CanFinMixin socle_finType_subproof. +Canonical socle_finType := FinType sG socle_finMixin. +Canonical socle_subFinType := [subFinType of sG]. + +End SocleDef. + +Coercion socle_sort : socleType >-> predArgType. + +Variable sG : socleType. + +Section SubSocle. + +Variable P : pred sG. +Notation S := (\sum_(W : sG | P W) socle_val W)%MS. + +Lemma subSocle_module : mxmodule S. +Proof. by rewrite sumsmx_module // => W _; exact: component_mx_module. Qed. + +Lemma subSocle_semisimple : mxsemisimple S. +Proof. +apply: sumsmx_semisimple => W _; apply: component_mx_semisimple. +exact: socle_simple. +Qed. +Local Notation ssimS := subSocle_semisimple. + +Lemma subSocle_iso M : + mxsimple M -> (M <= S)%MS -> {W : sG | P W & mx_iso (socle_base W) M}. +Proof. +move=> simM sMS; have [modM nzM _] := simM. +have [V /= modV defMV] := mxsemisimple_reducible ssimS modM sMS. +move/mxdirect_addsP=> dxMV; pose p := proj_mx M V; pose Sp (W : sG) := W *m p. +case: (pickP [pred i | P i & Sp i != 0]) => [/= W | Sp0]; last first. + case/negP: nzM; rewrite -submx0 -[M](proj_mx_id dxMV) //. + rewrite (submx_trans (submxMr _ sMS)) // sumsmxMr big1 // => W P_W. + by apply/eqP; move/negbT: (Sp0 W); rewrite /= P_W negbK. +rewrite {}/Sp /= => /andP[P_W nzSp]; exists W => //. +have homWp: (W <= dom_hom_mx p)%MS. + apply: submx_trans (proj_mx_hom dxMV modM modV). + by rewrite defMV (sumsmx_sup W). +have simWP := socle_simple W; apply: hom_component_mx_iso (homWp) _ => //. +by rewrite (mx_Schur_onto _ simM) ?proj_mx_sub ?component_mx_module. +Qed. + +Lemma capmx_subSocle m (M : 'M_(m, n)) : + mxmodule M -> (M :&: S :=: \sum_(W : sG | P W) (M :&: W))%MS. +Proof. +move=> modM; apply/eqmxP/andP; split; last first. + by apply/sumsmx_subP=> W P_W; rewrite capmxS // (sumsmx_sup W). +have modMS: mxmodule (M :&: S)%MS by rewrite capmx_module ?subSocle_module. +have [J /= U simU defMS _] := mxsemisimpleS modMS (capmxSr M S) ssimS. +rewrite -defMS; apply/sumsmx_subP=> j _. +have [sUjV sUjS]: (U j <= M /\ U j <= S)%MS. + by apply/andP; rewrite -sub_capmx -defMS (sumsmx_sup j). +have [W P_W isoWU] := subSocle_iso (simU j) sUjS. +rewrite (sumsmx_sup W) // sub_capmx sUjV mx_iso_component //. +exact: socle_simple. +Qed. + +End SubSocle. + +Lemma subSocle_direct P : mxdirect (\sum_(W : sG | P W) W). +Proof. +apply/mxdirect_sumsP=> W _; apply/eqP. +rewrite -submx0 capmx_subSocle ?component_mx_module //. +apply/sumsmx_subP=> W' /andP[_ neWW']. +by rewrite capmxC component_mx_disjoint //; exact: socle_simple. +Qed. + +Definition Socle := (\sum_(W : sG) W)%MS. + +Lemma simple_Socle M : mxsimple M -> (M <= Socle)%MS. +Proof. +move=> simM; have socM := component_socle sG simM. +by rewrite (sumsmx_sup (PackSocle socM)) // PackSocleK component_mx_id. +Qed. + +Lemma semisimple_Socle U : mxsemisimple U -> (U <= Socle)%MS. +Proof. +by case=> I M /= simM <- _; apply/sumsmx_subP=> i _; exact: simple_Socle. +Qed. + +Lemma reducible_Socle U : + mxmodule U -> mx_completely_reducible U -> (U <= Socle)%MS. +Proof. +move=> modU redU; apply: (mx_reducible_semisimple modU redU). +exact: semisimple_Socle. +Qed. + +Lemma genmx_Socle : <>%MS = Socle. +Proof. by rewrite genmx_sums; apply: eq_bigr => W; rewrite genmx_component. Qed. + +Lemma reducible_Socle1 : mx_completely_reducible 1%:M -> Socle = 1%:M. +Proof. +move=> redG; rewrite -genmx1 -genmx_Socle; apply/genmxP. +by rewrite submx1 reducible_Socle ?mxmodule1. +Qed. + +Lemma Socle_module : mxmodule Socle. Proof. exact: subSocle_module. Qed. + +Lemma Socle_semisimple : mxsemisimple Socle. +Proof. exact: subSocle_semisimple. Qed. + +Lemma Socle_direct : mxdirect Socle. Proof. exact: subSocle_direct. Qed. + +Lemma Socle_iso M : mxsimple M -> {W : sG | mx_iso (socle_base W) M}. +Proof. +by move=> simM; case/subSocle_iso: (simple_Socle simM) => // W _; exists W. +Qed. + +End Socle. + +(* Centralizer subgroup and central homomorphisms. *) +Section CentHom. + +Variable f : 'M[F]_n. + +Lemma row_full_dom_hom : row_full (dom_hom_mx f) = centgmx rG f. +Proof. +by rewrite -sub1mx; apply/hom_mxP/centgmxP=> cfG x /cfG; rewrite !mul1mx. +Qed. + +Lemma memmx_cent_envelop : (f \in 'C(E_G))%MS = centgmx rG f. +Proof. +apply/cent_rowP/centgmxP=> [cfG x Gx | cfG i]. + by have:= cfG (enum_rank_in Gx x); rewrite rowK mxvecK enum_rankK_in. +by rewrite rowK mxvecK /= cfG ?enum_valP. +Qed. + +Lemma kermx_centg_module : centgmx rG f -> mxmodule (kermx f). +Proof. +move/centgmxP=> cGf; apply/mxmoduleP=> x Gx; apply/sub_kermxP. +by rewrite -mulmxA -cGf // mulmxA mulmx_ker mul0mx. +Qed. + +Lemma centgmx_hom m (U : 'M_(m, n)) : centgmx rG f -> (U <= dom_hom_mx f)%MS. +Proof. by rewrite -row_full_dom_hom -sub1mx; exact: submx_trans (submx1 _). Qed. + +End CentHom. + +(* (Globally) irreducible, and absolutely irreducible representations. Note *) +(* that unlike "reducible", "absolutely irreducible" can easily be decided. *) + +Definition mx_irreducible := mxsimple 1%:M. + +Lemma mx_irrP : + mx_irreducible <-> n > 0 /\ (forall U, @mxmodule n U -> U != 0 -> row_full U). +Proof. +rewrite /mx_irreducible /mxsimple mxmodule1 -mxrank_eq0 mxrank1 -lt0n. +do [split=> [[_ -> irrG] | [-> irrG]]; split=> // U] => [modU | modU _] nzU. + by rewrite -sub1mx (irrG U) ?submx1. +by rewrite sub1mx irrG. +Qed. + +(* Schur's lemma for endomorphisms. *) +Lemma mx_Schur : + mx_irreducible -> forall f, centgmx rG f -> f != 0 -> f \in unitmx. +Proof. +move/mx_Schur_onto=> irrG f. +rewrite -row_full_dom_hom -!row_full_unit -!sub1mx => cGf nz. +by rewrite -[f]mul1mx irrG ?submx1 ?mxmodule1 ?mul1mx. +Qed. + +Definition mx_absolutely_irreducible := (n > 0) && row_full E_G. + +Lemma mx_abs_irrP : + reflect (n > 0 /\ exists a_, forall A, A = \sum_(x in G) a_ x A *: rG x) + mx_absolutely_irreducible. +Proof. +have G_1 := group1 G; have bijG := enum_val_bij_in G_1. +set h := enum_val in bijG; have Gh : h _ \in G by exact: enum_valP. +rewrite /mx_absolutely_irreducible; case: (n > 0); last by right; case. +apply: (iffP row_fullP) => [[E' E'G] | [_ [a_ a_G]]]. + split=> //; exists (fun x B => (mxvec B *m E') 0 (enum_rank_in G_1 x)) => B. + apply: (can_inj mxvecK); rewrite -{1}[mxvec B]mulmx1 -{}E'G mulmxA. + move: {B E'}(_ *m E') => u; apply/rowP=> j. + rewrite linear_sum (reindex h) //= mxE summxE. + by apply: eq_big => [k| k _]; rewrite ?Gh // enum_valK_in mxE linearZ !mxE. +exists (\matrix_(j, i) a_ (h i) (vec_mx (row j 1%:M))). +apply/row_matrixP=> i; rewrite -[row i 1%:M]vec_mxK {}[vec_mx _]a_G. +apply/rowP=> j; rewrite linear_sum (reindex h) //= 2!mxE summxE. +by apply: eq_big => [k| k _]; [rewrite Gh | rewrite linearZ !mxE]. +Qed. + +Lemma mx_abs_irr_cent_scalar : + mx_absolutely_irreducible -> forall A, centgmx rG A -> is_scalar_mx A. +Proof. +case/mx_abs_irrP=> n_gt0 [a_ a_G] A /centgmxP cGA. +have{cGA a_G} cMA B: A *m B = B *m A. + rewrite {}[B]a_G mulmx_suml mulmx_sumr. + by apply: eq_bigr => x Gx; rewrite -scalemxAl -scalemxAr cGA. +pose i0 := Ordinal n_gt0; apply/is_scalar_mxP; exists (A i0 i0). +apply/matrixP=> i j; move/matrixP/(_ i0 j): (esym (cMA (delta_mx i0 i))). +rewrite -[A *m _]trmxK trmx_mul trmx_delta -!(@mul_delta_mx _ n 1 n 0) -!mulmxA. +by rewrite -!rowE !mxE !big_ord1 !mxE !eqxx !mulr_natl /= andbT eq_sym. +Qed. + +Lemma mx_abs_irrW : mx_absolutely_irreducible -> mx_irreducible. +Proof. +case/mx_abs_irrP=> n_gt0 [a_ a_G]; apply/mx_irrP; split=> // U Umod. +case/rowV0Pn=> u Uu; rewrite -mxrank_eq0 -lt0n row_leq_rank -sub1mx. +case/submxP: Uu => v ->{u} /row_freeP[u' vK]; apply/row_subP=> i. +rewrite rowE scalar_mxC -{}vK -2![_ *m _]mulmxA; move: {u' i}(u' *m _) => A. +rewrite mulmx_sub {v}// [A]a_G linear_sum summx_sub //= => x Gx. +by rewrite linearZ /= scalemx_sub // (mxmoduleP Umod). +Qed. + +Lemma linear_mx_abs_irr : n = 1%N -> mx_absolutely_irreducible. +Proof. +move=> n1; rewrite /mx_absolutely_irreducible /row_full eqn_leq rank_leq_col. +rewrite {1 2 3}n1 /= lt0n mxrank_eq0; apply: contraTneq envelop_mx1 => ->. +by rewrite eqmx0 submx0 mxvec_eq0 -mxrank_eq0 mxrank1 n1. +Qed. + +Lemma abelian_abs_irr : abelian G -> mx_absolutely_irreducible = (n == 1%N). +Proof. +move=> cGG; apply/idP/eqP=> [absG|]; last exact: linear_mx_abs_irr. +have [n_gt0 _] := andP absG. +pose M := <>%MS. +have rM: \rank M = 1%N by rewrite genmxE mxrank_delta. +suffices defM: (M == 1%:M)%MS by rewrite (eqmxP defM) mxrank1 in rM. +case: (mx_abs_irrW absG) => _ _ ->; rewrite ?submx1 -?mxrank_eq0 ?rM //. +apply/mxmoduleP=> x Gx; suffices: is_scalar_mx (rG x). + by case/is_scalar_mxP=> a ->; rewrite mul_mx_scalar scalemx_sub. +apply: (mx_abs_irr_cent_scalar absG). +by apply/centgmxP=> y Gy; rewrite -!repr_mxM // (centsP cGG). +Qed. + +End OneRepresentation. + +Implicit Arguments mxmoduleP [gT G n rG m U]. +Implicit Arguments envelop_mxP [gT G n rG A]. +Implicit Arguments hom_mxP [gT G n rG m f W]. +Implicit Arguments rfix_mxP [gT G n rG m W]. +Implicit Arguments cyclic_mxP [gT G n rG u v]. +Implicit Arguments annihilator_mxP [gT G n rG u A]. +Implicit Arguments row_hom_mxP [gT G n rG u v]. +Implicit Arguments mxsimple_isoP [gT G n rG U V]. +Implicit Arguments socleP [gT G n rG sG0 W W']. +Implicit Arguments mx_abs_irrP [gT G n rG]. + +Implicit Arguments val_submod_inj [n U m]. +Implicit Arguments val_factmod_inj [n U m]. + +Prenex Implicits val_submod_inj val_factmod_inj. + +Section Proper. + +Variables (gT : finGroupType) (G : {group gT}) (n' : nat). +Local Notation n := n'.+1. +Variable rG : mx_representation F G n. + +Lemma envelop_mx_ring : mxring (enveloping_algebra_mx rG). +Proof. +apply/andP; split; first by apply/mulsmx_subP; exact: envelop_mxM. +apply/mxring_idP; exists 1%:M; split=> *; rewrite ?mulmx1 ?mul1mx //. + by rewrite -mxrank_eq0 mxrank1. +exact: envelop_mx1. +Qed. + +End Proper. + +Section JacobsonDensity. + +Variables (gT : finGroupType) (G : {group gT}) (n : nat). +Variable rG : mx_representation F G n. +Hypothesis irrG : mx_irreducible rG. + +Local Notation E_G := (enveloping_algebra_mx rG). +Local Notation Hom_G := 'C(E_G)%MS. + +Lemma mx_Jacobson_density : ('C(Hom_G) <= E_G)%MS. +Proof. +apply/row_subP=> iB; rewrite -[row iB _]vec_mxK; move defB: (vec_mx _) => B. +have{defB} cBcE: (B \in 'C(Hom_G))%MS by rewrite -defB vec_mxK row_sub. +have rGnP: mx_repr G (fun x => lin_mx (mulmxr (rG x)) : 'A_n). + split=> [|x y Gx Gy]; apply/row_matrixP=> i. + by rewrite !rowE mul_rV_lin repr_mx1 /= !mulmx1 vec_mxK. + by rewrite !rowE mulmxA !mul_rV_lin repr_mxM //= mxvecK mulmxA. +move def_rGn: (MxRepresentation rGnP) => rGn. +pose E_Gn := enveloping_algebra_mx rGn. +pose e1 : 'rV[F]_(n ^ 2) := mxvec 1%:M; pose U := cyclic_mx rGn e1. +have U_e1: (e1 <= U)%MS by rewrite cyclic_mx_id. +have modU: mxmodule rGn U by rewrite cyclic_mx_module. +pose Bn : 'M_(n ^ 2) := lin_mx (mulmxr B). +suffices U_e1Bn: (e1 *m Bn <= U)%MS. + rewrite mul_vec_lin /= mul1mx in U_e1Bn; apply: submx_trans U_e1Bn _. + rewrite genmxE; apply/row_subP=> i; rewrite row_mul rowK mul_vec_lin_row. + by rewrite -def_rGn mul_vec_lin /= mul1mx (eq_row_sub i) ?rowK. +have{cBcE} cBncEn A: centgmx rGn A -> A *m Bn = Bn *m A. + rewrite -def_rGn => cAG; apply/row_matrixP; case/mxvec_indexP=> j k /=. + rewrite !rowE !mulmxA -mxvec_delta -(mul_delta_mx (0 : 'I_1)). + rewrite mul_rV_lin mul_vec_lin /= -mulmxA; apply: (canLR vec_mxK). + apply/row_matrixP=> i; set dj0 := delta_mx j 0. + pose Aij := row i \o vec_mx \o mulmxr A \o mxvec \o mulmx dj0. + have defAij := mul_rV_lin1 [linear of Aij]; rewrite /= {2}/Aij /= in defAij. + rewrite -defAij row_mul -defAij -!mulmxA (cent_mxP cBcE) {k}//. + rewrite memmx_cent_envelop; apply/centgmxP=> x Gx; apply/row_matrixP=> k. + rewrite !row_mul !rowE !{}defAij /= -row_mul mulmxA mul_delta_mx. + congr (row i _); rewrite -(mul_vec_lin (mulmxr_linear _ _)) -mulmxA. + by rewrite -(centgmxP cAG) // mulmxA mx_rV_lin. +suffices redGn: mx_completely_reducible rGn 1%:M. + have [V modV defUV] := redGn _ modU (submx1 _); move/mxdirect_addsP=> dxUV. + rewrite -(proj_mx_id dxUV U_e1) -mulmxA {}cBncEn 1?mulmxA ?proj_mx_sub //. + by rewrite -row_full_dom_hom -sub1mx -defUV proj_mx_hom. +pose W i : 'M[F]_(n ^ 2) := <>%MS. +have defW: (\sum_i W i :=: 1%:M)%MS. + apply/eqmxP; rewrite submx1; apply/row_subP; case/mxvec_indexP=> i j. + rewrite row1 -mxvec_delta (sumsmx_sup i) // genmxE; apply/submxP. + by exists (delta_mx 0 j); rewrite mul_rV_lin1 /= mul_delta_mx. +apply: mxsemisimple_reducible; apply: (intro_mxsemisimple defW) => i _ nzWi. +split=> // [|Vi modVi sViWi nzVi]. + apply/mxmoduleP=> x Gx; rewrite genmxE (eqmxMr _ (genmxE _)) -def_rGn. + apply/row_subP=> j; rewrite rowE mulmxA !mul_rV_lin1 /= mxvecK -mulmxA. + by apply/submxP; move: (_ *m rG x) => v; exists v; rewrite mul_rV_lin1. +do [rewrite !genmxE; set f := lin1_mx _] in sViWi *. +have f_free: row_free f. + apply/row_freeP; exists (lin1_mx (row i \o vec_mx)); apply/row_matrixP=> j. + by rewrite row1 rowE mulmxA !mul_rV_lin1 /= mxvecK rowE !mul_delta_mx. +pose V := <>%MS; have Vidf := mulmxKpV sViWi. +suffices: (1%:M <= V)%MS by rewrite genmxE -(submxMfree _ _ f_free) mul1mx Vidf. +case: irrG => _ _ ->; rewrite ?submx1 //; last first. + by rewrite -mxrank_eq0 genmxE -(mxrankMfree _ f_free) Vidf mxrank_eq0. +apply/mxmoduleP=> x Gx; rewrite genmxE (eqmxMr _ (genmxE _)). +rewrite -(submxMfree _ _ f_free) Vidf. +apply: submx_trans (mxmoduleP modVi x Gx); rewrite -{2}Vidf. +apply/row_subP=> j; apply: (eq_row_sub j); rewrite row_mul -def_rGn. +by rewrite !(row_mul _ _ f) !mul_rV_lin1 /= mxvecK !row_mul !mulmxA. +Qed. + +Lemma cent_mx_scalar_abs_irr : \rank Hom_G <= 1 -> mx_absolutely_irreducible rG. +Proof. +rewrite leqNgt => /(has_non_scalar_mxP (scalar_mx_cent _ _)) scal_cE. +apply/andP; split; first by case/mx_irrP: irrG. +rewrite -sub1mx; apply: submx_trans mx_Jacobson_density. +apply/memmx_subP=> B _; apply/cent_mxP=> A cGA. +case scalA: (is_scalar_mx A); last by case: scal_cE; exists A; rewrite ?scalA. +by case/is_scalar_mxP: scalA => a ->; rewrite scalar_mxC. +Qed. + +End JacobsonDensity. + +Section ChangeGroup. + +Variables (gT : finGroupType) (G H : {group gT}) (n : nat). +Variables (rG : mx_representation F G n). + +Section SubGroup. + +Hypothesis sHG : H \subset G. + +Local Notation rH := (subg_repr rG sHG). + +Lemma rfix_subg : rfix_mx rH = rfix_mx rG. Proof. by []. Qed. + +Section Stabilisers. + +Variables (m : nat) (U : 'M[F]_(m, n)). + +Lemma rstabs_subg : rstabs rH U = H :&: rstabs rG U. +Proof. by apply/setP=> x; rewrite !inE andbA -in_setI (setIidPl sHG). Qed. + +Lemma mxmodule_subg : mxmodule rG U -> mxmodule rH U. +Proof. by rewrite /mxmodule rstabs_subg subsetI subxx; exact: subset_trans. Qed. + +End Stabilisers. + +Lemma mxsimple_subg M : mxmodule rG M -> mxsimple rH M -> mxsimple rG M. +Proof. +by move=> modM [_ nzM minM]; split=> // U /mxmodule_subg; exact: minM. +Qed. + +Lemma subg_mx_irr : mx_irreducible rH -> mx_irreducible rG. +Proof. by apply: mxsimple_subg; exact: mxmodule1. Qed. + +Lemma subg_mx_abs_irr : + mx_absolutely_irreducible rH -> mx_absolutely_irreducible rG. +Proof. +rewrite /mx_absolutely_irreducible -!sub1mx => /andP[-> /submx_trans-> //]. +apply/row_subP=> i; rewrite rowK /= envelop_mx_id //. +by rewrite (subsetP sHG) ?enum_valP. +Qed. + +End SubGroup. + +Section SameGroup. + +Hypothesis eqGH : G :==: H. + +Local Notation rH := (eqg_repr rG eqGH). + +Lemma rfix_eqg : rfix_mx rH = rfix_mx rG. Proof. by []. Qed. + +Section Stabilisers. + +Variables (m : nat) (U : 'M[F]_(m, n)). + +Lemma rstabs_eqg : rstabs rH U = rstabs rG U. +Proof. by rewrite rstabs_subg -(eqP eqGH) (setIidPr _) ?rstabs_sub. Qed. + +Lemma mxmodule_eqg : mxmodule rH U = mxmodule rG U. +Proof. by rewrite /mxmodule rstabs_eqg -(eqP eqGH). Qed. + +End Stabilisers. + +Lemma mxsimple_eqg M : mxsimple rH M <-> mxsimple rG M. +Proof. +rewrite /mxsimple mxmodule_eqg. +split=> [] [-> -> minM]; split=> // U modU; + by apply: minM; rewrite mxmodule_eqg in modU *. +Qed. + +Lemma eqg_mx_irr : mx_irreducible rH <-> mx_irreducible rG. +Proof. exact: mxsimple_eqg. Qed. + +Lemma eqg_mx_abs_irr : + mx_absolutely_irreducible rH = mx_absolutely_irreducible rG. +Proof. +by congr (_ && (_ == _)); rewrite /enveloping_algebra_mx /= -(eqP eqGH). +Qed. + +End SameGroup. + +End ChangeGroup. + +Section Morphpre. + +Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}). +Variables (G : {group rT}) (n : nat) (rG : mx_representation F G n). + +Local Notation rGf := (morphpre_repr f rG). + +Section Stabilisers. +Variables (m : nat) (U : 'M[F]_(m, n)). + +Lemma rstabs_morphpre : rstabs rGf U = f @*^-1 (rstabs rG U). +Proof. by apply/setP=> x; rewrite !inE andbA. Qed. + +Lemma mxmodule_morphpre : G \subset f @* D -> mxmodule rGf U = mxmodule rG U. +Proof. by move=> sGf; rewrite /mxmodule rstabs_morphpre morphpreSK. Qed. + +End Stabilisers. + +Lemma rfix_morphpre (H : {set aT}) : + H \subset D -> (rfix_mx rGf H :=: rfix_mx rG (f @* H))%MS. +Proof. +move=> sHD; apply/eqmxP/andP; split. + by apply/rfix_mxP=> _ /morphimP[x _ Hx ->]; rewrite rfix_mx_id. +by apply/rfix_mxP=> x Hx; rewrite rfix_mx_id ?mem_morphim ?(subsetP sHD). +Qed. + +Lemma morphpre_mx_irr : + G \subset f @* D -> (mx_irreducible rGf <-> mx_irreducible rG). +Proof. +move/mxmodule_morphpre=> modG; split=> /mx_irrP[n_gt0 irrG]; + by apply/mx_irrP; split=> // U modU; apply: irrG; rewrite modG in modU *. +Qed. + +Lemma morphpre_mx_abs_irr : + G \subset f @* D -> + mx_absolutely_irreducible rGf = mx_absolutely_irreducible rG. +Proof. +move=> sGfD; congr (_ && (_ == _)); apply/eqP; rewrite mxrank_leqif_sup //. + apply/row_subP=> i; rewrite rowK. + case/morphimP: (subsetP sGfD _ (enum_valP i)) => x Dx _ def_i. + by rewrite def_i (envelop_mx_id rGf) // !inE Dx -def_i enum_valP. +apply/row_subP=> i; rewrite rowK (envelop_mx_id rG) //. +by case/morphpreP: (enum_valP i). +Qed. + +End Morphpre. + +Section Morphim. + +Variables (aT rT : finGroupType) (G D : {group aT}) (f : {morphism D >-> rT}). +Variables (n : nat) (rGf : mx_representation F (f @* G) n). + +Hypothesis sGD : G \subset D. + +Let sG_f'fG : G \subset f @*^-1 (f @* G). +Proof. by rewrite -sub_morphim_pre. Qed. + +Local Notation rG := (morphim_repr rGf sGD). + +Section Stabilisers. +Variables (m : nat) (U : 'M[F]_(m, n)). + +Lemma rstabs_morphim : rstabs rG U = G :&: f @*^-1 rstabs rGf U. +Proof. by rewrite -rstabs_morphpre -(rstabs_subg _ sG_f'fG). Qed. + +Lemma mxmodule_morphim : mxmodule rG U = mxmodule rGf U. +Proof. by rewrite /mxmodule rstabs_morphim subsetI subxx -sub_morphim_pre. Qed. + +End Stabilisers. + +Lemma rfix_morphim (H : {set aT}) : + H \subset D -> (rfix_mx rG H :=: rfix_mx rGf (f @* H))%MS. +Proof. exact: rfix_morphpre. Qed. + +Lemma mxsimple_morphim M : mxsimple rG M <-> mxsimple rGf M. +Proof. +rewrite /mxsimple mxmodule_morphim. +split=> [] [-> -> minM]; split=> // U modU; + by apply: minM; rewrite mxmodule_morphim in modU *. +Qed. + +Lemma morphim_mx_irr : (mx_irreducible rG <-> mx_irreducible rGf). +Proof. exact: mxsimple_morphim. Qed. + +Lemma morphim_mx_abs_irr : + mx_absolutely_irreducible rG = mx_absolutely_irreducible rGf. +Proof. +have fG_onto: f @* G \subset restrm sGD f @* G. + by rewrite morphim_restrm setIid. +rewrite -(morphpre_mx_abs_irr _ fG_onto); congr (_ && (_ == _)). +by rewrite /enveloping_algebra_mx /= morphpre_restrm (setIidPl _). +Qed. + +End Morphim. + +Section Submodule. + +Variables (gT : finGroupType) (G : {group gT}) (n : nat). +Variables (rG : mx_representation F G n) (U : 'M[F]_n) (Umod : mxmodule rG U). +Local Notation rU := (submod_repr Umod). +Local Notation rU' := (factmod_repr Umod). + +Lemma rfix_submod (H : {set gT}) : + H \subset G -> (rfix_mx rU H :=: in_submod U (U :&: rfix_mx rG H))%MS. +Proof. +move=> sHG; apply/eqmxP/andP; split; last first. + apply/rfix_mxP=> x Hx; rewrite -in_submodJ ?capmxSl //. + by rewrite (rfix_mxP H _) ?capmxSr. +rewrite -val_submodS in_submodK ?capmxSl // sub_capmx val_submodP //=. +apply/rfix_mxP=> x Hx. +by rewrite -(val_submodJ Umod) ?(subsetP sHG) ?rfix_mx_id. +Qed. + +Lemma rfix_factmod (H : {set gT}) : + H \subset G -> (in_factmod U (rfix_mx rG H) <= rfix_mx rU' H)%MS. +Proof. +move=> sHG; apply/rfix_mxP=> x Hx. +by rewrite -(in_factmodJ Umod) ?(subsetP sHG) ?rfix_mx_id. +Qed. + +Lemma rstab_submod m (W : 'M_(m, \rank U)) : + rstab rU W = rstab rG (val_submod W). +Proof. +apply/setP=> x; rewrite !inE; apply: andb_id2l => Gx. +by rewrite -(inj_eq val_submod_inj) val_submodJ. +Qed. + +Lemma rstabs_submod m (W : 'M_(m, \rank U)) : + rstabs rU W = rstabs rG (val_submod W). +Proof. +apply/setP=> x; rewrite !inE; apply: andb_id2l => Gx. +by rewrite -val_submodS val_submodJ. +Qed. + +Lemma val_submod_module m (W : 'M_(m, \rank U)) : + mxmodule rG (val_submod W) = mxmodule rU W. +Proof. by rewrite /mxmodule rstabs_submod. Qed. + +Lemma in_submod_module m (V : 'M_(m, n)) : + (V <= U)%MS -> mxmodule rU (in_submod U V) = mxmodule rG V. +Proof. by move=> sVU; rewrite -val_submod_module in_submodK. Qed. + +Lemma rstab_factmod m (W : 'M_(m, n)) : + rstab rG W \subset rstab rU' (in_factmod U W). +Proof. +by apply/subsetP=> x /setIdP[Gx /eqP cUW]; rewrite inE Gx -in_factmodJ //= cUW. +Qed. + +Lemma rstabs_factmod m (W : 'M_(m, \rank (cokermx U))) : + rstabs rU' W = rstabs rG (U + val_factmod W)%MS. +Proof. +apply/setP=> x; rewrite !inE; apply: andb_id2l => Gx. +rewrite addsmxMr addsmx_sub (submx_trans (mxmoduleP Umod x Gx)) ?addsmxSl //. +rewrite -val_factmodS val_factmodJ //= val_factmodS; apply/idP/idP=> nWx. + rewrite (submx_trans (addsmxSr U _)) // -(in_factmodsK (addsmxSl U _)) //. + by rewrite addsmxS // val_factmodS in_factmod_addsK. +rewrite in_factmodE (submx_trans (submxMr _ nWx)) // -in_factmodE. +by rewrite in_factmod_addsK val_factmodK. +Qed. + +Lemma val_factmod_module m (W : 'M_(m, \rank (cokermx U))) : + mxmodule rG (U + val_factmod W)%MS = mxmodule rU' W. +Proof. by rewrite /mxmodule rstabs_factmod. Qed. + +Lemma in_factmod_module m (V : 'M_(m, n)) : + mxmodule rU' (in_factmod U V) = mxmodule rG (U + V)%MS. +Proof. +rewrite -(eqmx_module _ (in_factmodsK (addsmxSl U V))). +by rewrite val_factmod_module (eqmx_module _ (in_factmod_addsK _ _)). +Qed. + +Lemma rker_submod : rker rU = rstab rG U. +Proof. by rewrite /rker rstab_submod; exact: eqmx_rstab (val_submod1 U). Qed. + +Lemma rstab_norm : G \subset 'N(rstab rG U). +Proof. by rewrite -rker_submod rker_norm. Qed. + +Lemma rstab_normal : rstab rG U <| G. +Proof. by rewrite -rker_submod rker_normal. Qed. + +Lemma submod_mx_faithful : mx_faithful rU -> mx_faithful rG. +Proof. by apply: subset_trans; rewrite rker_submod rstabS ?submx1. Qed. + +Lemma rker_factmod : rker rG \subset rker rU'. +Proof. +apply/subsetP=> x /rkerP[Gx cVx]. +by rewrite inE Gx /= /factmod_mx cVx mul1mx mulmx1 val_factmodK. +Qed. + +Lemma factmod_mx_faithful : mx_faithful rU' -> mx_faithful rG. +Proof. exact: subset_trans rker_factmod. Qed. + +Lemma submod_mx_irr : mx_irreducible rU <-> mxsimple rG U. +Proof. +split=> [] [_ nzU simU]. + rewrite -mxrank_eq0 mxrank1 mxrank_eq0 in nzU; split=> // V modV sVU nzV. + rewrite -(in_submodK sVU) -val_submod1 val_submodS. + rewrite -(genmxE (in_submod U V)) simU ?genmxE ?submx1 //=. + by rewrite (eqmx_module _ (genmxE _)) in_submod_module. + rewrite -submx0 genmxE -val_submodS in_submodK //. + by rewrite linear0 eqmx0 submx0. +apply/mx_irrP; rewrite lt0n mxrank_eq0; split=> // V modV. +rewrite -(inj_eq val_submod_inj) linear0 -(eqmx_eq0 (genmxE _)) => nzV. +rewrite -sub1mx -val_submodS val_submod1 -(genmxE (val_submod V)). +rewrite simU ?genmxE ?val_submodP //=. +by rewrite (eqmx_module _ (genmxE _)) val_submod_module. +Qed. + +End Submodule. + +Section Conjugate. + +Variables (gT : finGroupType) (G : {group gT}) (n : nat). +Variables (rG : mx_representation F G n) (B : 'M[F]_n). + +Hypothesis uB : B \in unitmx. + +Local Notation rGB := (rconj_repr rG uB). + +Lemma rfix_conj (H : {set gT}) : + (rfix_mx rGB H :=: B *m rfix_mx rG H *m invmx B)%MS. +Proof. +apply/eqmxP/andP; split. + rewrite -mulmxA (eqmxMfull (_ *m _)) ?row_full_unit //. + rewrite -[rfix_mx rGB H](mulmxK uB) submxMr //; apply/rfix_mxP=> x Hx. + apply: (canRL (mulmxKV uB)); rewrite -(rconj_mxJ _ uB) mulmxK //. + by rewrite rfix_mx_id. +apply/rfix_mxP=> x Gx; rewrite -3!mulmxA; congr (_ *m _). +by rewrite !mulmxA mulmxKV // rfix_mx_id. +Qed. + +Lemma rstabs_conj m (U : 'M_(m, n)) : rstabs rGB U = rstabs rG (U *m B). +Proof. +apply/setP=> x; rewrite !inE rconj_mxE !mulmxA. +by rewrite -{2}[U](mulmxK uB) submxMfree // row_free_unit unitmx_inv. +Qed. + +Lemma mxmodule_conj m (U : 'M_(m, n)) : mxmodule rGB U = mxmodule rG (U *m B). +Proof. by rewrite /mxmodule rstabs_conj. Qed. + +Lemma conj_mx_irr : mx_irreducible rGB <-> mx_irreducible rG. +Proof. +have Bfree: row_free B by rewrite row_free_unit. +split => /mx_irrP[n_gt0 irrG]; apply/mx_irrP; split=> // U. + rewrite -[U](mulmxKV uB) -mxmodule_conj -mxrank_eq0 /row_full mxrankMfree //. + by rewrite mxrank_eq0; exact: irrG. +rewrite -mxrank_eq0 /row_full -(mxrankMfree _ Bfree) mxmodule_conj mxrank_eq0. +exact: irrG. +Qed. + +End Conjugate. + +Section Quotient. + +Variables (gT : finGroupType) (G : {group gT}) (n : nat). +Variables (rG : mx_representation F G n) (H : {group gT}). +Hypotheses (krH : H \subset rker rG) (nHG : G \subset 'N(H)). +Let nHGs := subsetP nHG. + +Local Notation rGH := (quo_repr krH nHG). + +Local Notation E_ r := (enveloping_algebra_mx r). +Lemma quo_mx_quotient : (E_ rGH :=: E_ rG)%MS. +Proof. +apply/eqmxP/andP; split; apply/row_subP=> i. + rewrite rowK; case/morphimP: (enum_valP i) => x _ Gx ->{i}. + rewrite quo_repr_coset // (eq_row_sub (enum_rank_in Gx x)) // rowK. + by rewrite enum_rankK_in. +rewrite rowK -(quo_mx_coset krH nHG) ?enum_valP //; set Hx := coset H _. +have GHx: Hx \in (G / H)%g by rewrite mem_quotient ?enum_valP. +by rewrite (eq_row_sub (enum_rank_in GHx Hx)) // rowK enum_rankK_in. +Qed. + +Lemma rfix_quo (K : {group gT}) : + K \subset G -> (rfix_mx rGH (K / H)%g :=: rfix_mx rG K)%MS. +Proof. +move=> sKG; apply/eqmxP/andP; (split; apply/rfix_mxP) => [x Kx | Hx]. + have Gx := subsetP sKG x Kx; rewrite -(quo_mx_coset krH nHG) // rfix_mx_id //. + by rewrite mem_morphim ?(subsetP nHG). +case/morphimP=> x _ Kx ->; have Gx := subsetP sKG x Kx. +by rewrite quo_repr_coset ?rfix_mx_id. +Qed. + +Lemma rstabs_quo m (U : 'M_(m, n)) : rstabs rGH U = (rstabs rG U / H)%g. +Proof. +apply/setP=> Hx; rewrite !inE; apply/andP/idP=> [[]|] /morphimP[x Nx Gx ->{Hx}]. + by rewrite quo_repr_coset // => nUx; rewrite mem_morphim // inE Gx. +by case/setIdP: Gx => Gx nUx; rewrite quo_repr_coset ?mem_morphim. +Qed. + +Lemma mxmodule_quo m (U : 'M_(m, n)) : mxmodule rGH U = mxmodule rG U. +Proof. +rewrite /mxmodule rstabs_quo quotientSGK // ?(subset_trans krH) //. +apply/subsetP=> x; rewrite !inE mul1mx => /andP[-> /eqP->]. +by rewrite /= mulmx1. +Qed. + +Lemma quo_mx_irr : mx_irreducible rGH <-> mx_irreducible rG. +Proof. +split; case/mx_irrP=> n_gt0 irrG; apply/mx_irrP; split=> // U modU; + by apply: irrG; rewrite mxmodule_quo in modU *. +Qed. + +End Quotient. + +Section SplittingField. + +Implicit Type gT : finGroupType. + +Definition group_splitting_field gT (G : {group gT}) := + forall n (rG : mx_representation F G n), + mx_irreducible rG -> mx_absolutely_irreducible rG. + +Definition group_closure_field gT := + forall G : {group gT}, group_splitting_field G. + +Lemma quotient_splitting_field gT (G : {group gT}) (H : {set gT}) : + G \subset 'N(H) -> group_splitting_field G -> group_splitting_field (G / H). +Proof. +move=> nHG splitG n rGH irrGH. +by rewrite -(morphim_mx_abs_irr _ nHG) splitG //; exact/morphim_mx_irr. +Qed. + +Lemma coset_splitting_field gT (H : {set gT}) : + group_closure_field gT -> group_closure_field (coset_groupType H). +Proof. +move=> split_gT Gbar; have ->: Gbar = (coset H @*^-1 Gbar / H)%G. + by apply: val_inj; rewrite /= /quotient morphpreK ?sub_im_coset. +by apply: quotient_splitting_field; [exact: subsetIl | exact: split_gT]. +Qed. + +End SplittingField. + +Section Abelian. + +Variables (gT : finGroupType) (G : {group gT}). + +Lemma mx_faithful_irr_center_cyclic n (rG : mx_representation F G n) : + mx_faithful rG -> mx_irreducible rG -> cyclic 'Z(G). +Proof. +case: n rG => [|n] rG injG irrG; first by case/mx_irrP: irrG. +move/trivgP: injG => KrG1; pose rZ := subg_repr rG (center_sub _). +apply: (div_ring_mul_group_cyclic (repr_mx1 rZ)) (repr_mxM rZ) _ _; last first. + exact: center_abelian. +move=> x; rewrite -[[set _]]KrG1 !inE mul1mx -subr_eq0 andbC; set U := _ - _. +do 2![case/andP]=> Gx cGx; rewrite Gx /=; apply: (mx_Schur irrG). +apply/centgmxP=> y Gy; rewrite mulmxBl mulmxBr mulmx1 mul1mx. +by rewrite -!repr_mxM // (centP cGx). +Qed. + +Lemma mx_faithful_irr_abelian_cyclic n (rG : mx_representation F G n) : + mx_faithful rG -> mx_irreducible rG -> abelian G -> cyclic G. +Proof. +move=> injG irrG cGG; rewrite -(setIidPl cGG). +exact: mx_faithful_irr_center_cyclic injG irrG. +Qed. + +Hypothesis splitG : group_splitting_field G. + +Lemma mx_irr_abelian_linear n (rG : mx_representation F G n) : + mx_irreducible rG -> abelian G -> n = 1%N. +Proof. +by move=> irrG cGG; apply/eqP; rewrite -(abelian_abs_irr rG) ?splitG. +Qed. + +Lemma mxsimple_abelian_linear n (rG : mx_representation F G n) M : + abelian G -> mxsimple rG M -> \rank M = 1%N. +Proof. +move=> cGG simM; have [modM _ _] := simM. +by move/(submod_mx_irr modM)/mx_irr_abelian_linear: simM => ->. +Qed. + +Lemma linear_mxsimple n (rG : mx_representation F G n) (M : 'M_n) : + mxmodule rG M -> \rank M = 1%N -> mxsimple rG M. +Proof. +move=> modM rM1; apply/(submod_mx_irr modM). +by apply: mx_abs_irrW; rewrite linear_mx_abs_irr. +Qed. + +End Abelian. + +Section AbelianQuotient. + +Variables (gT : finGroupType) (G : {group gT}). +Variables (n : nat) (rG : mx_representation F G n). + +Lemma center_kquo_cyclic : mx_irreducible rG -> cyclic 'Z(G / rker rG)%g. +Proof. +move=> irrG; apply: mx_faithful_irr_center_cyclic (kquo_mx_faithful rG) _. +exact/quo_mx_irr. +Qed. + +Lemma der1_sub_rker : + group_splitting_field G -> mx_irreducible rG -> + (G^`(1) \subset rker rG)%g = (n == 1)%N. +Proof. +move=> splitG irrG; apply/idP/idP; last by move/eqP; exact: rker_linear. +move/sub_der1_abelian; move/(abelian_abs_irr (kquo_repr rG))=> <-. +by apply: (quotient_splitting_field (rker_norm _) splitG); exact/quo_mx_irr. +Qed. + +End AbelianQuotient. + +Section Similarity. + +Variables (gT : finGroupType) (G : {group gT}). +Local Notation reprG := (mx_representation F G). + +CoInductive mx_rsim n1 (rG1 : reprG n1) n2 (rG2 : reprG n2) : Prop := + MxReprSim B of n1 = n2 & row_free B + & forall x, x \in G -> rG1 x *m B = B *m rG2 x. + +Lemma mxrank_rsim n1 n2 (rG1 : reprG n1) (rG2 : reprG n2) : + mx_rsim rG1 rG2 -> n1 = n2. +Proof. by case. Qed. + +Lemma mx_rsim_refl n (rG : reprG n) : mx_rsim rG rG. +Proof. +exists 1%:M => // [|x _]; first by rewrite row_free_unit unitmx1. +by rewrite mulmx1 mul1mx. +Qed. + +Lemma mx_rsim_sym n1 n2 (rG1 : reprG n1) (rG2 : reprG n2) : + mx_rsim rG1 rG2 -> mx_rsim rG2 rG1. +Proof. +case=> B def_n1; rewrite def_n1 in rG1 B *. +rewrite row_free_unit => injB homB; exists (invmx B) => // [|x Gx]. + by rewrite row_free_unit unitmx_inv. +by apply: canRL (mulKmx injB) _; rewrite mulmxA -homB ?mulmxK. +Qed. + +Lemma mx_rsim_trans n1 n2 n3 + (rG1 : reprG n1) (rG2 : reprG n2) (rG3 : reprG n3) : + mx_rsim rG1 rG2 -> mx_rsim rG2 rG3 -> mx_rsim rG1 rG3. +Proof. +case=> [B1 defn1 freeB1 homB1] [B2 defn2 freeB2 homB2]. +exists (B1 *m B2); rewrite /row_free ?mxrankMfree 1?defn1 // => x Gx. +by rewrite mulmxA homB1 // -!mulmxA homB2. +Qed. + +Lemma mx_rsim_def n1 n2 (rG1 : reprG n1) (rG2 : reprG n2) : + mx_rsim rG1 rG2 -> + exists B, exists2 B', B' *m B = 1%:M & + forall x, x \in G -> rG1 x = B *m rG2 x *m B'. +Proof. +case=> B def_n1; rewrite def_n1 in rG1 B *; rewrite row_free_unit => injB homB. +by exists B, (invmx B) => [|x Gx]; rewrite ?mulVmx // -homB // mulmxK. +Qed. + +Lemma mx_rsim_iso n (rG : reprG n) (U V : 'M_n) + (modU : mxmodule rG U) (modV : mxmodule rG V) : + mx_rsim (submod_repr modU) (submod_repr modV) <-> mx_iso rG U V. +Proof. +split=> [[B eqrUV injB homB] | [f injf homf defV]]. + have: \rank (U *m val_submod (in_submod U 1%:M *m B)) = \rank U. + do 2!rewrite mulmxA mxrankMfree ?row_base_free //. + by rewrite -(eqmxMr _ (val_submod1 U)) -in_submodE val_submodK mxrank1. + case/complete_unitmx => f injf defUf; exists f => //. + apply/hom_mxP=> x Gx; rewrite -defUf -2!mulmxA -(val_submodJ modV) //. + rewrite -(mulmxA _ B) -homB // val_submodE 3!(mulmxA U) (mulmxA _ _ B). + rewrite -in_submodE -in_submodJ //. + have [u ->] := submxP (mxmoduleP modU x Gx). + by rewrite in_submodE -mulmxA -defUf !mulmxA mulmx1. + apply/eqmxP; rewrite -mxrank_leqif_eq. + by rewrite mxrankMfree ?eqrUV ?row_free_unit. + by rewrite -defUf mulmxA val_submodP. +have eqrUV: \rank U = \rank V by rewrite -defV mxrankMfree ?row_free_unit. +exists (in_submod V (val_submod 1%:M *m f)) => // [|x Gx]. + rewrite /row_free {6}eqrUV -[_ == _]sub1mx -val_submodS. + rewrite in_submodK; last by rewrite -defV submxMr ?val_submodP. + by rewrite val_submod1 -defV submxMr ?val_submod1. +rewrite -in_submodJ; last by rewrite -defV submxMr ?val_submodP. +rewrite -(hom_mxP (submx_trans (val_submodP _) homf)) //. +by rewrite -(val_submodJ modU) // mul1mx 2!(mulmxA ((submod_repr _) x)) -val_submodE. +Qed. + +Lemma mx_rsim_irr n1 n2 (rG1 : reprG n1) (rG2 : reprG n2) : + mx_rsim rG1 rG2 -> mx_irreducible rG1 -> mx_irreducible rG2. +Proof. +case/mx_rsim_sym=> f def_n2; rewrite {n2}def_n2 in f rG2 * => injf homf. +case/mx_irrP=> n1_gt0 minG; apply/mx_irrP; split=> // U modU nzU. +rewrite /row_full -(mxrankMfree _ injf) -genmxE. +apply: minG; last by rewrite -mxrank_eq0 genmxE mxrankMfree // mxrank_eq0. +rewrite (eqmx_module _ (genmxE _)); apply/mxmoduleP=> x Gx. +by rewrite -mulmxA -homf // mulmxA submxMr // (mxmoduleP modU). +Qed. + +Lemma mx_rsim_abs_irr n1 n2 (rG1 : reprG n1) (rG2 : reprG n2) : + mx_rsim rG1 rG2 -> + mx_absolutely_irreducible rG1 = mx_absolutely_irreducible rG2. +Proof. +case=> f def_n2; rewrite -{n2}def_n2 in f rG2 *. +rewrite row_free_unit => injf homf; congr (_ && (_ == _)). +pose Eg (g : 'M[F]_n1) := lin_mx (mulmxr (invmx g) \o mulmx g). +have free_Ef: row_free (Eg f). + apply/row_freeP; exists (Eg (invmx f)); apply/row_matrixP=> i. + rewrite rowE row1 mulmxA mul_rV_lin mx_rV_lin /=. + by rewrite invmxK !{1}mulmxA mulmxKV // -mulmxA mulKmx // vec_mxK. +symmetry; rewrite -(mxrankMfree _ free_Ef); congr (\rank _). +apply/row_matrixP=> i; rewrite row_mul !rowK mul_vec_lin /=. +by rewrite -homf ?enum_valP // mulmxK. +Qed. + +Lemma rker_mx_rsim n1 n2 (rG1 : reprG n1) (rG2 : reprG n2) : + mx_rsim rG1 rG2 -> rker rG1 = rker rG2. +Proof. +case=> f def_n2; rewrite -{n2}def_n2 in f rG2 *. +rewrite row_free_unit => injf homf. +apply/setP=> x; rewrite !inE !mul1mx; apply: andb_id2l => Gx. +by rewrite -(can_eq (mulmxK injf)) homf // -scalar_mxC (can_eq (mulKmx injf)). +Qed. + +Lemma mx_rsim_faithful n1 n2 (rG1 : reprG n1) (rG2 : reprG n2) : + mx_rsim rG1 rG2 -> mx_faithful rG1 = mx_faithful rG2. +Proof. by move=> simG12; rewrite /mx_faithful (rker_mx_rsim simG12). Qed. + +Lemma mx_rsim_factmod n (rG : reprG n) U V + (modU : mxmodule rG U) (modV : mxmodule rG V) : + (U + V :=: 1%:M)%MS -> mxdirect (U + V) -> + mx_rsim (factmod_repr modV) (submod_repr modU). +Proof. +move=> addUV dxUV. +have eqUV: \rank U = \rank (cokermx V). + by rewrite mxrank_coker -{3}(mxrank1 F n) -addUV (mxdirectP dxUV) addnK. +have{dxUV} dxUV: (U :&: V = 0)%MS by exact/mxdirect_addsP. +exists (in_submod U (val_factmod 1%:M *m proj_mx U V)) => // [|x Gx]. + rewrite /row_free -{6}eqUV -[_ == _]sub1mx -val_submodS val_submod1. + rewrite in_submodK ?proj_mx_sub // -{1}[U](proj_mx_id dxUV) //. + rewrite -{1}(add_sub_fact_mod V U) mulmxDl proj_mx_0 ?val_submodP // add0r. + by rewrite submxMr // val_factmodS submx1. +rewrite -in_submodJ ?proj_mx_sub // -(hom_mxP _) //; last first. + by apply: submx_trans (submx1 _) _; rewrite -addUV proj_mx_hom. +rewrite mulmxA; congr (_ *m _); rewrite mulmxA -val_factmodE; apply/eqP. +rewrite eq_sym -subr_eq0 -mulmxBl proj_mx_0 //. +by rewrite -[_ *m rG x](add_sub_fact_mod V) addrK val_submodP. +Qed. + +Lemma mxtrace_rsim n1 n2 (rG1 : reprG n1) (rG2 : reprG n2) : + mx_rsim rG1 rG2 -> {in G, forall x, \tr (rG1 x) = \tr (rG2 x)}. +Proof. +case/mx_rsim_def=> B [B' B'B def_rG1] x Gx. +by rewrite def_rG1 // mxtrace_mulC mulmxA B'B mul1mx. +Qed. + +Lemma mx_rsim_scalar n1 n2 (rG1 : reprG n1) (rG2 : reprG n2) x c : + x \in G -> mx_rsim rG1 rG2 -> rG1 x = c%:M -> rG2 x = c%:M. +Proof. +move=> Gx /mx_rsim_sym[B _ Bfree rG2_B] rG1x. +by apply: (row_free_inj Bfree); rewrite rG2_B // rG1x scalar_mxC. +Qed. + +End Similarity. + +Section Socle. + +Variables (gT : finGroupType) (G : {group gT}). +Variables (n : nat) (rG : mx_representation F G n) (sG : socleType rG). + +Lemma socle_irr (W : sG) : mx_irreducible (socle_repr W). +Proof. by apply/submod_mx_irr; exact: socle_simple. Qed. + +Lemma socle_rsimP (W1 W2 : sG) : + reflect (mx_rsim (socle_repr W1) (socle_repr W2)) (W1 == W2). +Proof. +have [simW1 simW2] := (socle_simple W1, socle_simple W2). +by apply: (iffP (component_mx_isoP simW1 simW2)); move/mx_rsim_iso; exact. +Qed. + +Local Notation mG U := (mxmodule rG U). +Local Notation sr modV := (submod_repr modV). + +Lemma mx_rsim_in_submod U V (modU : mG U) (modV : mG V) : + let U' := <>%MS in + (U <= V)%MS -> + exists modU' : mxmodule (sr modV) U', mx_rsim (sr modU) (sr modU'). +Proof. +move=> U' sUV; have modU': mxmodule (sr modV) U'. + by rewrite (eqmx_module _ (genmxE _)) in_submod_module. +have rankU': \rank U = \rank U' by rewrite genmxE mxrank_in_submod. +pose v1 := val_submod 1%:M; pose U1 := v1 _ U. +have sU1V: (U1 <= V)%MS by rewrite val_submod1. +have sU1U': (in_submod V U1 <= U')%MS by rewrite genmxE submxMr ?val_submod1. +exists modU', (in_submod U' (in_submod V U1)) => // [|x Gx]. + apply/row_freeP; exists (v1 _ _ *m v1 _ _ *m in_submod U 1%:M). + by rewrite 2!mulmxA -in_submodE -!val_submodE !in_submodK ?val_submodK. +rewrite -!in_submodJ // -(val_submodJ modU) // mul1mx. +by rewrite 2!{1}in_submodE mulmxA (mulmxA _ U1) -val_submodE -!in_submodE. +Qed. + +Lemma rsim_submod1 U (modU : mG U) : (U :=: 1%:M)%MS -> mx_rsim (sr modU) rG. +Proof. +move=> U1; exists (val_submod 1%:M) => [||x Gx]; first by rewrite U1 mxrank1. + by rewrite /row_free val_submod1. +by rewrite -(val_submodJ modU) // mul1mx -val_submodE. +Qed. + +Lemma mxtrace_submod1 U (modU : mG U) : + (U :=: 1%:M)%MS -> {in G, forall x, \tr (sr modU x) = \tr (rG x)}. +Proof. by move=> defU; exact: mxtrace_rsim (rsim_submod1 modU defU). Qed. + +Lemma mxtrace_dadd_mod U V W (modU : mG U) (modV : mG V) (modW : mG W) : + (U + V :=: W)%MS -> mxdirect (U + V) -> + {in G, forall x, \tr (sr modU x) + \tr (sr modV x) = \tr (sr modW x)}. +Proof. +move=> defW dxW x Gx; have [sUW sVW]: (U <= W)%MS /\ (V <= W)%MS. + by apply/andP; rewrite -addsmx_sub defW. +pose U' := <>%MS; pose V' := <>%MS. +have addUV': (U' + V' :=: 1%:M)%MS. + apply/eqmxP; rewrite submx1 /= (adds_eqmx (genmxE _) (genmxE _)). + by rewrite -addsmxMr -val_submodS val_submod1 in_submodK ?defW. +have dxUV': mxdirect (U' + V'). + apply/eqnP; rewrite /= addUV' mxrank1 !genmxE !mxrank_in_submod //. + by rewrite -(mxdirectP dxW) /= defW. +have [modU' simU] := mx_rsim_in_submod modU modW sUW. +have [modV' simV] := mx_rsim_in_submod modV modW sVW. +rewrite (mxtrace_rsim simU) // (mxtrace_rsim simV) //. +rewrite -(mxtrace_sub_fact_mod modV') addrC; congr (_ + _). +by rewrite (mxtrace_rsim (mx_rsim_factmod modU' modV' addUV' dxUV')). +Qed. + +Lemma mxtrace_dsum_mod (I : finType) (P : pred I) U W + (modU : forall i, mG (U i)) (modW : mG W) : + let S := (\sum_(i | P i) U i)%MS in (S :=: W)%MS -> mxdirect S -> + {in G, forall x, \sum_(i | P i) \tr (sr (modU i) x) = \tr (sr modW x)}. +Proof. +move=> /= sumS dxS x Gx. +elim: {P}_.+1 {-2}P (ltnSn #|P|) => // m IHm P lePm in W modW sumS dxS *. +have [j /= Pj | P0] := pickP P; last first. + case: sumS (_ x); rewrite !big_pred0 // mxrank0 => <- _ rWx. + by rewrite [rWx]flatmx0 linear0. +rewrite ltnS (cardD1x Pj) in lePm. +rewrite mxdirectE /= !(bigD1 j Pj) -mxdirectE mxdirect_addsE /= in dxS sumS *. +have [_ dxW' dxW] := and3P dxS; rewrite (sameP eqP mxdirect_addsP) in dxW. +rewrite (IHm _ _ _ (sumsmx_module _ (fun i _ => modU i)) (eqmx_refl _)) //. +exact: mxtrace_dadd_mod. +Qed. + +Lemma mxtrace_component U (simU : mxsimple rG U) : + let V := component_mx rG U in + let modV := component_mx_module rG U in let modU := mxsimple_module simU in + {in G, forall x, \tr (sr modV x) = \tr (sr modU x) *+ (\rank V %/ \rank U)}. +Proof. +move=> V modV modU x Gx. +have [I W S simW defV dxV] := component_mx_semisimple simU. +rewrite -(mxtrace_dsum_mod (fun i => mxsimple_module (simW i)) modV defV) //. +have rankU_gt0: \rank U > 0 by rewrite lt0n mxrank_eq0; case simU. +have isoW i: mx_iso rG U (W i). + by apply: component_mx_iso; rewrite ?simU // -defV (sumsmx_sup i). +have ->: (\rank V %/ \rank U)%N = #|I|. + symmetry; rewrite -(mulnK #|I| rankU_gt0); congr (_ %/ _)%N. + rewrite -defV (mxdirectP dxV) /= -sum_nat_const. + by apply: eq_bigr => i _; exact: mxrank_iso. +rewrite -sumr_const; apply: eq_bigr => i _; symmetry. +by apply: mxtrace_rsim Gx; apply/mx_rsim_iso; exact: isoW. +Qed. + +Lemma mxtrace_Socle : let modS := Socle_module sG in + {in G, forall x, + \tr (sr modS x) = \sum_(W : sG) \tr (socle_repr W x) *+ socle_mult W}. +Proof. +move=> /= x Gx /=; pose modW (W : sG) := component_mx_module rG (socle_base W). +rewrite -(mxtrace_dsum_mod modW _ (eqmx_refl _) (Socle_direct sG)) //. +by apply: eq_bigr => W _; rewrite (mxtrace_component (socle_simple W)). +Qed. + +End Socle. + +Section Clifford. + +Variables (gT : finGroupType) (G H : {group gT}). +Hypothesis nsHG : H <| G. +Variables (n : nat) (rG : mx_representation F G n). +Let sHG := normal_sub nsHG. +Let nHG := normal_norm nsHG. +Let rH := subg_repr rG sHG. + +Lemma Clifford_simple M x : mxsimple rH M -> x \in G -> mxsimple rH (M *m rG x). +Proof. +have modmG m U y: y \in G -> (mxmodule rH) m U -> mxmodule rH (U *m rG y). + move=> Gy modU; apply/mxmoduleP=> h Hh; have Gh := subsetP sHG h Hh. + rewrite -mulmxA -repr_mxM // conjgCV repr_mxM ?groupJ ?groupV // mulmxA. + by rewrite submxMr ?(mxmoduleP modU) // -mem_conjg (normsP nHG). +have nzmG m y (U : 'M_(m, n)): y \in G -> (U *m rG y == 0) = (U == 0). + by move=> Gy; rewrite -{1}(mul0mx m (rG y)) (can_eq (repr_mxK rG Gy)). +case=> [modM nzM simM] Gx; have Gx' := groupVr Gx. +split=> [||U modU sUMx nzU]; rewrite ?modmG ?nzmG //. +rewrite -(repr_mxKV rG Gx U) submxMr //. +by rewrite (simM (U *m _)) ?modmG ?nzmG // -(repr_mxK rG Gx M) submxMr. +Qed. + +Lemma Clifford_hom x m (U : 'M_(m, n)) : + x \in 'C_G(H) -> (U <= dom_hom_mx rH (rG x))%MS. +Proof. +case/setIP=> Gx cHx; apply/rV_subP=> v _{U}. +apply/hom_mxP=> h Hh; have Gh := subsetP sHG h Hh. +by rewrite -!mulmxA /= -!repr_mxM // (centP cHx). +Qed. + +Lemma Clifford_iso x U : x \in 'C_G(H) -> mx_iso rH U (U *m rG x). +Proof. +move=> cHx; have [Gx _] := setIP cHx. +by exists (rG x); rewrite ?repr_mx_unit ?Clifford_hom. +Qed. + +Lemma Clifford_iso2 x U V : + mx_iso rH U V -> x \in G -> mx_iso rH (U *m rG x) (V *m rG x). +Proof. +case=> [f injf homUf defV] Gx; have Gx' := groupVr Gx. +pose fx := rG (x^-1)%g *m f *m rG x; exists fx; last 1 first. +- by rewrite !mulmxA repr_mxK //; exact: eqmxMr. +- by rewrite !unitmx_mul andbC !repr_mx_unit. +apply/hom_mxP=> h Hh; have Gh := subsetP sHG h Hh. +rewrite -(mulmxA U) -repr_mxM // conjgCV repr_mxM ?groupJ // !mulmxA. +rewrite !repr_mxK // (hom_mxP homUf) -?mem_conjg ?(normsP nHG) //=. +by rewrite !repr_mxM ?invgK ?groupM // !mulmxA repr_mxKV. +Qed. + +Lemma Clifford_componentJ M x : + mxsimple rH M -> x \in G -> + (component_mx rH (M *m rG x) :=: component_mx rH M *m rG x)%MS. +Proof. +set simH := mxsimple rH; set cH := component_mx rH. +have actG: {in G, forall y M, simH M -> cH M *m rG y <= cH (M *m rG y)}%MS. + move=> {M} y Gy /= M simM; have [I [U isoU def_cHM]] := component_mx_def simM. + rewrite /cH def_cHM sumsmxMr; apply/sumsmx_subP=> i _. + by apply: mx_iso_component; [exact: Clifford_simple | exact: Clifford_iso2]. +move=> simM Gx; apply/eqmxP; rewrite actG // -/cH. +rewrite -{1}[cH _](repr_mxKV rG Gx) submxMr // -{2}[M](repr_mxK rG Gx). +by rewrite actG ?groupV //; exact: Clifford_simple. +Qed. + +Hypothesis irrG : mx_irreducible rG. + +Lemma Clifford_basis M : mxsimple rH M -> + {X : {set gT} | X \subset G & + let S := \sum_(x in X) M *m rG x in S :=: 1%:M /\ mxdirect S}%MS. +Proof. +move=> simM. have simMG (g : [subg G]) : mxsimple rH (M *m rG (val g)). + by case: g => x Gx; exact: Clifford_simple. +have [|XG [defX1 dxX1]] := sum_mxsimple_direct_sub simMG (_ : _ :=: 1%:M)%MS. + apply/eqmxP; case irrG => _ _ ->; rewrite ?submx1 //; last first. + rewrite -submx0; apply/sumsmx_subP; move/(_ 1%g (erefl _)); apply: negP. + by rewrite submx0 repr_mx1 mulmx1; case simM. + apply/mxmoduleP=> x Gx; rewrite sumsmxMr; apply/sumsmx_subP=> [[y Gy]] /= _. + by rewrite (sumsmx_sup (subg G (y * x))) // subgK ?groupM // -mulmxA repr_mxM. +exists (val @: XG); first by apply/subsetP=> ?; case/imsetP=> [[x Gx]] _ ->. +have bij_val: {on val @: XG, bijective (@sgval _ G)}. + exists (subg G) => [g _ | x]; first exact: sgvalK. + by case/imsetP=> [[x' Gx]] _ ->; rewrite subgK. +have defXG g: (val g \in val @: XG) = (g \in XG). + by apply/imsetP/idP=> [[h XGh] | XGg]; [move/val_inj-> | exists g]. +by rewrite /= mxdirectE /= !(reindex _ bij_val) !(eq_bigl _ _ defXG). +Qed. + +Variable sH : socleType rH. + +Definition Clifford_act (W : sH) x := + let Gx := subgP (subg G x) in + PackSocle (component_socle sH (Clifford_simple (socle_simple W) Gx)). + +Let valWact W x : (Clifford_act W x :=: W *m rG (sgval (subg G x)))%MS. +Proof. +rewrite PackSocleK; apply: Clifford_componentJ (subgP _). +exact: socle_simple. +Qed. + +Fact Clifford_is_action : is_action G Clifford_act. +Proof. +split=> [x W W' eqWW' | W x y Gx Gy]. + pose Gx := subgP (subg G x); apply/socleP; apply/eqmxP. + rewrite -(repr_mxK rG Gx W) -(repr_mxK rG Gx W'); apply: eqmxMr. + apply: eqmx_trans (eqmx_sym _) (valWact _ _); rewrite -eqWW'; exact: valWact. +apply/socleP; rewrite !{1}valWact 2!{1}(eqmxMr _ (valWact _ _)). +by rewrite !subgK ?groupM ?repr_mxM ?mulmxA ?andbb. +Qed. + +Definition Clifford_action := Action Clifford_is_action. + +Local Notation "'Cl" := Clifford_action (at level 8) : action_scope. + +Lemma val_Clifford_act W x : x \in G -> ('Cl%act W x :=: W *m rG x)%MS. +Proof. by move=> Gx; apply: eqmx_trans (valWact _ _) _; rewrite subgK. Qed. + +Lemma Clifford_atrans : [transitive G, on [set: sH] | 'Cl]. +Proof. +have [_ nz1 _] := irrG. +apply: mxsimple_exists (mxmodule1 rH) nz1 _ _ => [[M simM _]]. +pose W1 := PackSocle (component_socle sH simM). +have [X sXG [def1 _]] := Clifford_basis simM; move/subsetP: sXG => sXG. +apply/imsetP; exists W1; first by rewrite inE. +symmetry; apply/setP=> W; rewrite inE; have simW := socle_simple W. +have:= submx1 (socle_base W); rewrite -def1 -[(\sum_(x in X) _)%MS]mulmx1. +case/(hom_mxsemisimple_iso simW) => [x Xx _ | | x Xx isoMxW]. +- by apply: Clifford_simple; rewrite ?sXG. +- exact: scalar_mx_hom. +have Gx := sXG x Xx; apply/imsetP; exists x => //; apply/socleP/eqmxP/eqmx_sym. +apply: eqmx_trans (val_Clifford_act _ Gx) _; rewrite PackSocleK. +apply: eqmx_trans (eqmx_sym (Clifford_componentJ simM Gx)) _. +apply/eqmxP; rewrite (sameP genmxP eqP) !{1}genmx_component. +by apply/component_mx_isoP=> //; exact: Clifford_simple. +Qed. + +Lemma Clifford_Socle1 : Socle sH = 1%:M. +Proof. +case/imsetP: Clifford_atrans => W _ _; have simW := socle_simple W. +have [X sXG [def1 _]] := Clifford_basis simW. +rewrite reducible_Socle1 //; apply: mxsemisimple_reducible. +apply: intro_mxsemisimple def1 _ => x /(subsetP sXG) Gx _. +exact: Clifford_simple. +Qed. + +Lemma Clifford_rank_components (W : sH) : (#|sH| * \rank W)%N = n. +Proof. +rewrite -{9}(mxrank1 F n) -Clifford_Socle1. +rewrite (mxdirectP (Socle_direct sH)) /= -sum_nat_const. +apply: eq_bigr => W1 _; have [W0 _ W0G] := imsetP Clifford_atrans. +have{W0G} W0G W': W' \in orbit 'Cl G W0 by rewrite -W0G inE. +have [/orbitP[x Gx <-] /orbitP[y Gy <-]] := (W0G W, W0G W1). +by rewrite !{1}val_Clifford_act // !mxrankMfree // !repr_mx_free. +Qed. + +Theorem Clifford_component_basis M : mxsimple rH M -> + {t : nat & {x_ : sH -> 'I_t -> gT | + forall W, let sW := (\sum_j M *m rG (x_ W j))%MS in + [/\ forall j, x_ W j \in G, (sW :=: W)%MS & mxdirect sW]}}. +Proof. +move=> simM; pose t := (n %/ #|sH| %/ \rank M)%N; exists t. +have [X /subsetP sXG [defX1 dxX1]] := Clifford_basis simM. +pose sMv (W : sH) x := (M *m rG x <= W)%MS; pose Xv := [pred x in X | sMv _ x]. +have sXvG W: {subset Xv W <= G} by move=> x /andP[/sXG]. +have defW W: (\sum_(x in Xv W) M *m rG x :=: W)%MS. + apply/eqmxP; rewrite -(geq_leqif (mxrank_leqif_eq _)); last first. + by apply/sumsmx_subP=> x /andP[]. + rewrite -(leq_add2r (\sum_(W' | W' != W) \rank W')) -((bigD1 W) predT) //=. + rewrite -(mxdirectP (Socle_direct sH)) /= -/(Socle _) Clifford_Socle1 -defX1. + apply: leq_trans (mxrankS _) (mxrank_sum_leqif _).1 => /=. + rewrite (bigID (sMv W))%MS addsmxS //=. + apply/sumsmx_subP=> x /andP[Xx notW_Mx]; have Gx := sXG x Xx. + have simMx := Clifford_simple simM Gx. + pose Wx := PackSocle (component_socle sH simMx). + have sMxWx: (M *m rG x <= Wx)%MS by rewrite PackSocleK component_mx_id. + by rewrite (sumsmx_sup Wx) //; apply: contra notW_Mx => /eqP <-. +have dxXv W: mxdirect (\sum_(x in Xv W) M *m rG x). + move: dxX1; rewrite !mxdirectE /= !(bigID (sMv W) (mem X)) /=. + by rewrite -mxdirectE mxdirect_addsE /= => /andP[]. +have def_t W: #|Xv W| = t. + rewrite /t -{1}(Clifford_rank_components W) mulKn 1?(cardD1 W) //. + rewrite -defW (mxdirectP (dxXv W)) /= (eq_bigr (fun _ => \rank M)) => [|x]. + rewrite sum_nat_const mulnK //; last by rewrite lt0n mxrank_eq0; case simM. + by move/sXvG=> Gx; rewrite mxrankMfree // row_free_unit repr_mx_unit. +exists (fun W i => enum_val (cast_ord (esym (def_t W)) i)) => W. +case: {def_t}t / (def_t W) => sW. +case: (pickP (Xv W)) => [x0 XvWx0 | XvW0]; last first. + by case/negP: (nz_socle W); rewrite -submx0 -defW big_pred0. +have{x0 XvWx0} reXv := reindex _ (enum_val_bij_in XvWx0). +have def_sW: (sW :=: W)%MS. + apply: eqmx_trans (defW W); apply/eqmxP; apply/genmxP; congr <<_>>%MS. + rewrite reXv /=; apply: eq_big => [j | j _]; first by have:= enum_valP j. + by rewrite cast_ord_id. +split=> // [j|]; first by rewrite (sXvG W) ?enum_valP. +apply/mxdirectP; rewrite def_sW -(defW W) /= (mxdirectP (dxXv W)) /= reXv /=. +by apply: eq_big => [j | j _]; [move: (enum_valP j) | rewrite cast_ord_id]. +Qed. + +Lemma Clifford_astab : H <*> 'C_G(H) \subset 'C([set: sH] | 'Cl). +Proof. +rewrite join_subG !subsetI sHG subsetIl /=; apply/andP; split. + apply/subsetP=> h Hh; have Gh := subsetP sHG h Hh; rewrite inE. + apply/subsetP=> W _; have simW := socle_simple W; have [modW _ _] := simW. + have simWh: mxsimple rH (socle_base W *m rG h) by exact: Clifford_simple. + rewrite inE -val_eqE /= PackSocleK eq_sym. + apply/component_mx_isoP; rewrite ?subgK //; apply: component_mx_iso => //. + by apply: submx_trans (component_mx_id simW); move/mxmoduleP: modW => ->. +apply/subsetP=> z cHz; have [Gz _] := setIP cHz; rewrite inE. +apply/subsetP=> W _; have simW := socle_simple W; have [modW _ _] := simW. +have simWz: mxsimple rH (socle_base W *m rG z) by exact: Clifford_simple. +rewrite inE -val_eqE /= PackSocleK eq_sym. +by apply/component_mx_isoP; rewrite ?subgK //; exact: Clifford_iso. +Qed. + +Lemma Clifford_astab1 (W : sH) : 'C[W | 'Cl] = rstabs rG W. +Proof. +apply/setP=> x; rewrite !inE; apply: andb_id2l => Gx. +rewrite sub1set inE (sameP eqP socleP) !val_Clifford_act //. +rewrite andb_idr // => sWxW; rewrite -mxrank_leqif_sup //. +by rewrite mxrankMfree ?repr_mx_free. +Qed. + +Lemma Clifford_rstabs_simple (W : sH) : + mxsimple (subg_repr rG (rstabs_sub rG W)) W. +Proof. +split => [||U modU sUW nzU]; last 2 [exact: nz_socle]. + by rewrite /mxmodule rstabs_subg setIid. +have modUH: mxmodule rH U. + apply/mxmoduleP=> h Hh; rewrite (mxmoduleP modU) //. + rewrite /= -Clifford_astab1 !(inE, sub1set) (subsetP sHG) //. + rewrite (astab_act (subsetP Clifford_astab h _)) ?inE //=. + by rewrite mem_gen // inE Hh. +apply: (mxsimple_exists modUH nzU) => [[M simM sMU]]. +have [t [x_ /(_ W)[Gx_ defW _]]] := Clifford_component_basis simM. +rewrite -defW; apply/sumsmx_subP=> j _; set x := x_ W j. +have{Gx_} Gx: x \in G by rewrite Gx_. +apply: submx_trans (submxMr _ sMU) _; apply: (mxmoduleP modU). +rewrite inE -val_Clifford_act Gx //; set Wx := 'Cl%act W x. +have [-> //= | neWxW] := eqVneq Wx W. +case: (simM) => _ /negP[]; rewrite -submx0. +rewrite (canF_eq (actKin 'Cl Gx)) in neWxW. +rewrite -(component_mx_disjoint _ _ neWxW); try exact: socle_simple. +rewrite sub_capmx {1}(submx_trans sMU sUW) val_Clifford_act ?groupV //. +by rewrite -(eqmxMr _ defW) sumsmxMr (sumsmx_sup j) ?repr_mxK. +Qed. + +End Clifford. + +Section JordanHolder. + +Variables (gT : finGroupType) (G : {group gT}). +Variables (n : nat) (rG : mx_representation F G n). +Local Notation modG := ((mxmodule rG) n). + +Lemma section_module (U V : 'M_n) (modU : modG U) (modV : modG V) : + mxmodule (factmod_repr modU) <>%MS. +Proof. +by rewrite (eqmx_module _ (genmxE _)) in_factmod_module addsmx_module. +Qed. + +Definition section_repr U V (modU : modG U) (modV : modG V) := + submod_repr (section_module modU modV). + +Lemma mx_factmod_sub U modU : + mx_rsim (@section_repr U _ modU (mxmodule1 rG)) (factmod_repr modU). +Proof. +exists (val_submod 1%:M) => [||x Gx]. +- apply: (@addIn (\rank U)); rewrite genmxE mxrank_in_factmod mxrank_coker. + by rewrite (addsmx_idPr (submx1 U)) mxrank1 subnK ?rank_leq_row. +- by rewrite /row_free val_submod1. +by rewrite -[_ x]mul1mx -val_submodE val_submodJ. +Qed. + +Definition max_submod (U V : 'M_n) := + (U < V)%MS /\ (forall W, ~ [/\ modG W, U < W & W < V])%MS. + +Lemma max_submodP U V (modU : modG U) (modV : modG V) : + (U <= V)%MS -> (max_submod U V <-> mx_irreducible (section_repr modU modV)). +Proof. +move=> sUV; split=> [[ltUV maxU] | ]. + apply/mx_irrP; split=> [|WU modWU nzWU]. + by rewrite genmxE lt0n mxrank_eq0 in_factmod_eq0; case/andP: ltUV. + rewrite -sub1mx -val_submodS val_submod1 genmxE. + pose W := (U + val_factmod (val_submod WU))%MS. + suffices sVW: (V <= W)%MS. + rewrite {2}in_factmodE (submx_trans (submxMr _ sVW)) //. + rewrite addsmxMr -!in_factmodE val_factmodK. + by rewrite ((in_factmod U U =P 0) _) ?adds0mx ?in_factmod_eq0. + move/and3P: {maxU}(maxU W); apply: contraR; rewrite /ltmx addsmxSl => -> /=. + move: modWU; rewrite /mxmodule rstabs_submod rstabs_factmod => -> /=. + rewrite addsmx_sub submx_refl -in_factmod_eq0 val_factmodK. + move: nzWU; rewrite -[_ == 0](inj_eq val_submod_inj) linear0 => ->. + rewrite -(in_factmodsK sUV) addsmxS // val_factmodS. + by rewrite -(genmxE (in_factmod U V)) val_submodP. +case/mx_irrP; rewrite lt0n {1}genmxE mxrank_eq0 in_factmod_eq0 => ltUV maxV. +split=> // [|W [modW /andP[sUW ltUW] /andP[sWV /negP[]]]]; first exact/andP. +rewrite -(in_factmodsK sUV) -(in_factmodsK sUW) addsmxS // val_factmodS. +rewrite -genmxE -val_submod1; set VU := <<_>>%MS. +have sW_VU: (in_factmod U W <= VU)%MS. + by rewrite genmxE -val_factmodS !submxMr. +rewrite -(in_submodK sW_VU) val_submodS -(genmxE (in_submod _ _)). +rewrite sub1mx maxV //. + rewrite (eqmx_module _ (genmxE _)) in_submod_module ?genmxE ?submxMr //. + by rewrite in_factmod_module addsmx_module. +rewrite -submx0 [(_ <= 0)%MS]genmxE -val_submodS linear0 in_submodK //. +by rewrite eqmx0 submx0 in_factmod_eq0. +Qed. + +Lemma max_submod_eqmx U1 U2 V1 V2 : + (U1 :=: U2)%MS -> (V1 :=: V2)%MS -> max_submod U1 V1 -> max_submod U2 V2. +Proof. +move=> eqU12 eqV12 [ltUV1 maxU1]. +by split=> [|W]; rewrite -(lt_eqmx eqU12) -(lt_eqmx eqV12). +Qed. + +Definition mx_subseries := all modG. + +Definition mx_composition_series V := + mx_subseries V /\ (forall i, i < size V -> max_submod (0 :: V)`_i V`_i). +Local Notation mx_series := mx_composition_series. + +Fact mx_subseries_module V i : mx_subseries V -> mxmodule rG V`_i. +Proof. +move=> modV; have [|leVi] := ltnP i (size V); first exact: all_nthP. +by rewrite nth_default ?mxmodule0. +Qed. + +Fact mx_subseries_module' V i : mx_subseries V -> mxmodule rG (0 :: V)`_i. +Proof. by move=> modV; rewrite mx_subseries_module //= mxmodule0. Qed. + +Definition subseries_repr V i (modV : all modG V) := + section_repr (mx_subseries_module' i modV) (mx_subseries_module i modV). + +Definition series_repr V i (compV : mx_composition_series V) := + subseries_repr i (proj1 compV). + +Lemma mx_series_lt V : mx_composition_series V -> path ltmx 0 V. +Proof. by case=> _ compV; apply/(pathP 0)=> i /compV[]. Qed. + +Lemma max_size_mx_series (V : seq 'M[F]_n) : + path ltmx 0 V -> size V <= \rank (last 0 V). +Proof. +rewrite -[size V]addn0 -(mxrank0 F n n); elim: V 0 => //= V1 V IHV V0. +rewrite ltmxErank -andbA => /and3P[_ ltV01 ltV]. +by apply: leq_trans (IHV _ ltV); rewrite addSnnS leq_add2l. +Qed. + +Lemma mx_series_repr_irr V i (compV : mx_composition_series V) : + i < size V -> mx_irreducible (series_repr i compV). +Proof. +case: compV => modV compV /compV maxVi; apply/max_submodP => //. +by apply: ltmxW; case: maxVi. +Qed. + +Lemma mx_series_rcons U V : + mx_series (rcons U V) <-> [/\ mx_series U, modG V & max_submod (last 0 U) V]. +Proof. +rewrite /mx_series /mx_subseries all_rcons size_rcons -rcons_cons. +split=> [ [/andP[modU modV] maxU] | [[modU maxU] modV maxV]]. + split=> //; last first. + by have:= maxU _ (leqnn _); rewrite !nth_rcons leqnn ltnn eqxx -last_nth. + by split=> // i ltiU; have:= maxU i (ltnW ltiU); rewrite !nth_rcons leqW ltiU. +rewrite modV; split=> // i; rewrite !nth_rcons ltnS leq_eqVlt. +case: eqP => [-> _ | /= _ ltiU]; first by rewrite ltnn ?eqxx -last_nth. +by rewrite ltiU; exact: maxU. +Qed. + +Theorem mx_Schreier U : + mx_subseries U -> path ltmx 0 U -> + classically (exists V, [/\ mx_series V, last 0 V :=: 1%:M & subseq U V])%MS. +Proof. +move: U => U0; set U := {1 2}U0; have: subseq U0 U := subseq_refl U. +pose n' := n.+1; have: n < size U + n' by rewrite leq_addl. +elim: n' U => [|n' IH_U] U ltUn' sU0U modU incU [] // noV. + rewrite addn0 ltnNge in ltUn'; case/negP: ltUn'. + by rewrite (leq_trans (max_size_mx_series incU)) ?rank_leq_row. +apply: (noV); exists U; split => //; first split=> // i lt_iU; last first. + apply/eqmxP; apply: contraT => neU1. + apply: {IH_U}(IH_U (rcons U 1%:M)) noV. + - by rewrite size_rcons addSnnS. + - by rewrite (subseq_trans sU0U) ?subseq_rcons. + - by rewrite /mx_subseries all_rcons mxmodule1. + by rewrite rcons_path ltmxEneq neU1 submx1 !andbT. +set U'i := _`_i; set Ui := _`_i; have defU := cat_take_drop i U. +have defU'i: U'i = last 0 (take i U). + rewrite (last_nth 0) /U'i -{1}defU -cat_cons nth_cat /=. + by rewrite size_take lt_iU leqnn. +move: incU; rewrite -defU cat_path (drop_nth 0) //= -/Ui -defU'i. +set U' := take i U; set U'' := drop _ U; case/and3P=> incU' ltUi incU''. +split=> // W [modW ltUW ltWV]; case: notF. +apply: {IH_U}(IH_U (U' ++ W :: Ui :: U'')) noV; last 2 first. +- by rewrite /mx_subseries -drop_nth // all_cat /= modW -all_cat defU. +- by rewrite cat_path /= -defU'i; exact/and4P. +- by rewrite -drop_nth // size_cat /= addnS -size_cat defU addSnnS. +by rewrite (subseq_trans sU0U) // -defU cat_subseq // -drop_nth ?subseq_cons. +Qed. + +Lemma mx_second_rsim U V (modU : modG U) (modV : modG V) : + let modI := capmx_module modU modV in let modA := addsmx_module modU modV in + mx_rsim (section_repr modI modU) (section_repr modV modA). +Proof. +move=> modI modA; set nI := {1}(\rank _). +have sIU := capmxSl U V; have sVA := addsmxSr U V. +pose valI := val_factmod (val_submod (1%:M : 'M_nI)). +have UvalI: (valI <= U)%MS. + rewrite -(addsmx_idPr sIU) (submx_trans _ (proj_factmodS _ _)) //. + by rewrite submxMr // val_submod1 genmxE. +exists (valI *m in_factmod _ 1%:M *m in_submod _ 1%:M) => [||x Gx]. +- apply: (@addIn (\rank (U :&: V) + \rank V)%N); rewrite genmxE addnA addnCA. + rewrite /nI genmxE !{1}mxrank_in_factmod 2?(addsmx_idPr _) //. + by rewrite -mxrank_sum_cap addnC. +- rewrite -kermx_eq0; apply/rowV0P=> u; rewrite (sameP sub_kermxP eqP). + rewrite mulmxA -in_submodE mulmxA -in_factmodE -(inj_eq val_submod_inj). + rewrite linear0 in_submodK ?in_factmod_eq0 => [Vvu|]; last first. + by rewrite genmxE addsmxC in_factmod_addsK submxMr // mulmx_sub. + apply: val_submod_inj; apply/eqP; rewrite linear0 -[val_submod u]val_factmodK. + rewrite val_submodE val_factmodE -mulmxA -val_factmodE -/valI. + by rewrite in_factmod_eq0 sub_capmx mulmx_sub. +symmetry; rewrite -{1}in_submodE -{1}in_submodJ; last first. + by rewrite genmxE addsmxC in_factmod_addsK -in_factmodE submxMr. +rewrite -{1}in_factmodE -{1}in_factmodJ // mulmxA in_submodE; congr (_ *m _). +apply/eqP; rewrite mulmxA -in_factmodE -subr_eq0 -linearB in_factmod_eq0. +apply: submx_trans (capmxSr U V); rewrite -in_factmod_eq0 linearB /=. +rewrite subr_eq0 {1}(in_factmodJ modI) // val_factmodK eq_sym. +rewrite /valI val_factmodE mulmxA -val_factmodE val_factmodK. +by rewrite -[submod_mx _ _]mul1mx -val_submodE val_submodJ. +Qed. + +Lemma section_eqmx_add U1 U2 V1 V2 modU1 modU2 modV1 modV2 : + (U1 :=: U2)%MS -> (U1 + V1 :=: U2 + V2)%MS -> + mx_rsim (@section_repr U1 V1 modU1 modV1) (@section_repr U2 V2 modU2 modV2). +Proof. +move=> eqU12 eqV12; set n1 := {1}(\rank _). +pose v1 := val_factmod (val_submod (1%:M : 'M_n1)). +have sv12: (v1 <= U2 + V2)%MS. + rewrite -eqV12 (submx_trans _ (proj_factmodS _ _)) //. + by rewrite submxMr // val_submod1 genmxE. +exists (v1 *m in_factmod _ 1%:M *m in_submod _ 1%:M) => [||x Gx]. +- apply: (@addIn (\rank U1)); rewrite {2}eqU12 /n1 !{1}genmxE. + by rewrite !{1}mxrank_in_factmod eqV12. +- rewrite -kermx_eq0; apply/rowV0P=> u; rewrite (sameP sub_kermxP eqP) mulmxA. + rewrite -in_submodE mulmxA -in_factmodE -(inj_eq val_submod_inj) linear0. + rewrite in_submodK ?in_factmod_eq0 -?eqU12 => [U1uv1|]; last first. + by rewrite genmxE -(in_factmod_addsK U2 V2) submxMr // mulmx_sub. + apply: val_submod_inj; apply/eqP; rewrite linear0 -[val_submod _]val_factmodK. + by rewrite in_factmod_eq0 val_factmodE val_submodE -mulmxA -val_factmodE. +symmetry; rewrite -{1}in_submodE -{1}in_factmodE -{1}in_submodJ; last first. + by rewrite genmxE -(in_factmod_addsK U2 V2) submxMr. +rewrite -{1}in_factmodJ // mulmxA in_submodE; congr (_ *m _); apply/eqP. +rewrite mulmxA -in_factmodE -subr_eq0 -linearB in_factmod_eq0 -eqU12. +rewrite -in_factmod_eq0 linearB /= subr_eq0 {1}(in_factmodJ modU1) //. +rewrite val_factmodK /v1 val_factmodE eq_sym mulmxA -val_factmodE val_factmodK. +by rewrite -[_ *m _]mul1mx mulmxA -val_submodE val_submodJ. +Qed. + +Lemma section_eqmx U1 U2 V1 V2 modU1 modU2 modV1 modV2 + (eqU : (U1 :=: U2)%MS) (eqV : (V1 :=: V2)%MS) : + mx_rsim (@section_repr U1 V1 modU1 modV1) (@section_repr U2 V2 modU2 modV2). +Proof. by apply: section_eqmx_add => //; exact: adds_eqmx. Qed. + +Lemma mx_butterfly U V W modU modV modW : + ~~ (U == V)%MS -> max_submod U W -> max_submod V W -> + let modUV := capmx_module modU modV in + max_submod (U :&: V)%MS U + /\ mx_rsim (@section_repr V W modV modW) (@section_repr _ U modUV modU). +Proof. +move=> neUV maxU maxV modUV; have{neUV maxU} defW: (U + V :=: W)%MS. + wlog{neUV modUV} ltUV: U V modU modV maxU maxV / ~~ (V <= U)%MS. + by case/nandP: neUV => ?; first rewrite addsmxC; exact. + apply/eqmxP/idPn=> neUVW; case: maxU => ltUW; case/(_ (U + V)%MS). + rewrite addsmx_module // ltmxE ltmxEneq neUVW addsmxSl !addsmx_sub. + by have [ltVW _] := maxV; rewrite submx_refl andbT ltUV !ltmxW. +have sUV_U := capmxSl U V; have sVW: (V <= W)%MS by rewrite -defW addsmxSr. +set goal := mx_rsim _ _; suffices{maxV} simUV: goal. + split=> //; apply/(max_submodP modUV modU sUV_U). + by apply: mx_rsim_irr simUV _; exact/max_submodP. +apply: {goal}mx_rsim_sym. +by apply: mx_rsim_trans (mx_second_rsim modU modV) _; exact: section_eqmx. +Qed. + +Lemma mx_JordanHolder_exists U V : + mx_composition_series U -> modG V -> max_submod V (last 0 U) -> + {W : seq 'M_n | mx_composition_series W & last 0 W = V}. +Proof. +elim/last_ind: U V => [|U Um IHU] V compU modV; first by case; rewrite ltmx0. +rewrite last_rcons => maxV; case/mx_series_rcons: compU => compU modUm maxUm. +case eqUV: (last 0 U == V)%MS. + case/lastP: U eqUV compU {maxUm IHU} => [|U' Um']. + by rewrite andbC; move/eqmx0P->; exists [::]. + rewrite last_rcons; move/eqmxP=> eqU'V; case/mx_series_rcons=> compU _ maxUm'. + exists (rcons U' V); last by rewrite last_rcons. + apply/mx_series_rcons; split => //; exact: max_submod_eqmx maxUm'. +set Um' := last 0 U in maxUm eqUV; have [modU _] := compU. +have modUm': modG Um' by rewrite /Um' (last_nth 0) mx_subseries_module'. +have [|||W compW lastW] := IHU (V :&: Um')%MS; rewrite ?capmx_module //. + by case: (mx_butterfly modUm' modV modUm); rewrite ?eqUV // {1}capmxC. +exists (rcons W V); last by rewrite last_rcons. +apply/mx_series_rcons; split; rewrite // lastW. +by case: (mx_butterfly modV modUm' modUm); rewrite // andbC eqUV. +Qed. + +Let rsim_rcons U V compU compUV i : i < size U -> + mx_rsim (@series_repr U i compU) (@series_repr (rcons U V) i compUV). +Proof. +by move=> ltiU; apply: section_eqmx; rewrite -?rcons_cons nth_rcons ?leqW ?ltiU. +Qed. + +Let last_mod U (compU : mx_series U) : modG (last 0 U). +Proof. +by case: compU => modU _; rewrite (last_nth 0) (mx_subseries_module' _ modU). +Qed. + +Let rsim_last U V modUm modV compUV : + mx_rsim (@section_repr (last 0 U) V modUm modV) + (@series_repr (rcons U V) (size U) compUV). +Proof. +apply: section_eqmx; last by rewrite nth_rcons ltnn eqxx. +by rewrite -rcons_cons nth_rcons leqnn -last_nth. +Qed. +Local Notation rsimT := mx_rsim_trans. +Local Notation rsimC := mx_rsim_sym. + +Lemma mx_JordanHolder U V compU compV : + let m := size U in (last 0 U :=: last 0 V)%MS -> + m = size V /\ (exists p : 'S_m, forall i : 'I_m, + mx_rsim (@series_repr U i compU) (@series_repr V (p i) compV)). +Proof. +elim: {U}(size U) {-2}U V (eqxx (size U)) compU compV => /= [|r IHr] U V. + move/nilP->; case/lastP: V => [|V Vm] /= ? compVm; rewrite ?last_rcons => Vm0. + by split=> //; exists 1%g; case. + by case/mx_series_rcons: (compVm) => _ _ []; rewrite -(lt_eqmx Vm0) ltmx0. +case/lastP: U => // [U Um]; rewrite size_rcons eqSS => szUr compUm. +case/mx_series_rcons: (compUm); set Um' := last 0 U => compU modUm maxUm. +case/lastP: V => [|V Vm] compVm; rewrite ?last_rcons ?size_rcons /= => eqUVm. + by case/mx_series_rcons: (compUm) => _ _ []; rewrite (lt_eqmx eqUVm) ltmx0. +case/mx_series_rcons: (compVm); set Vm' := last 0 V => compV modVm maxVm. +have [modUm' modVm']: modG Um' * modG Vm' := (last_mod compU, last_mod compV). +pose i_m := @ord_max (size U). +have [eqUVm' | neqUVm'] := altP (@eqmxP _ _ _ _ Um' Vm'). + have [szV [p sim_p]] := IHr U V szUr compU compV eqUVm'. + split; first by rewrite szV. + exists (lift_perm i_m i_m p) => i; case: (unliftP i_m i) => [j|] ->{i}. + apply: rsimT (rsimC _) (rsimT (sim_p j) _). + by rewrite lift_max; exact: rsim_rcons. + by rewrite lift_perm_lift lift_max; apply: rsim_rcons; rewrite -szV. + have simUVm := section_eqmx modUm' modVm' modUm modVm eqUVm' eqUVm. + apply: rsimT (rsimC _) (rsimT simUVm _); first exact: rsim_last. + by rewrite lift_perm_id /= szV; exact: rsim_last. +have maxVUm: max_submod Vm' Um by exact: max_submod_eqmx (eqmx_sym _) maxVm. +have:= mx_butterfly modUm' modVm' modUm neqUVm' maxUm maxVUm. +move: (capmx_module _ _); set Wm := (Um' :&: Vm')%MS => modWm [maxWUm simWVm]. +have:= mx_butterfly modVm' modUm' modUm _ maxVUm maxUm. +move: (capmx_module _ _); rewrite andbC capmxC -/Wm => modWmV [// | maxWVm]. +rewrite {modWmV}(bool_irrelevance modWmV modWm) => simWUm. +have [W compW lastW] := mx_JordanHolder_exists compU modWm maxWUm. +have compWU: mx_series (rcons W Um') by apply/mx_series_rcons; rewrite lastW. +have compWV: mx_series (rcons W Vm') by apply/mx_series_rcons; rewrite lastW. +have [|szW [pU pUW]] := IHr U _ szUr compU compWU; first by rewrite last_rcons. +rewrite size_rcons in szW; have ltWU: size W < size U by rewrite -szW. +have{IHr} := IHr _ V _ compWV compV; rewrite last_rcons size_rcons -szW. +case=> {r szUr}// szV [pV pWV]; split; first by rewrite szV. +pose j_m := Ordinal ltWU; pose i_m' := lift i_m j_m. +exists (lift_perm i_m i_m pU * tperm i_m i_m' * lift_perm i_m i_m pV)%g => i. +rewrite !permM; case: (unliftP i_m i) => [j {simWUm}|] ->{i}; last first. + rewrite lift_perm_id tpermL lift_perm_lift lift_max {simWVm}. + apply: rsimT (rsimT (pWV j_m) _); last by apply: rsim_rcons; rewrite -szV. + apply: rsimT (rsimC _) {simWUm}(rsimT simWUm _); first exact: rsim_last. + by rewrite -lastW in modWm *; exact: rsim_last. +apply: rsimT (rsimC _) {pUW}(rsimT (pUW j) _). + by rewrite lift_max; exact: rsim_rcons. +rewrite lift_perm_lift; case: (unliftP j_m (pU j)) => [k|] ->{j pU}. + rewrite tpermD ?(inj_eq (@lift_inj _ _)) ?neq_lift //. + rewrite lift_perm_lift !lift_max; set j := lift j_m k. + have ltjW: j < size W by have:= ltn_ord k; rewrite -(lift_max k) /= {1 3}szW. + apply: rsimT (rsimT (pWV j) _); last by apply: rsim_rcons; rewrite -szV. + by apply: rsimT (rsimC _) (rsim_rcons compW _ _); first exact: rsim_rcons. +apply: rsimT {simWVm}(rsimC (rsimT simWVm _)) _. + by rewrite -lastW in modWm *; exact: rsim_last. +rewrite tpermR lift_perm_id /= szV. +by apply: rsimT (rsim_last modVm' modVm _); exact: section_eqmx. +Qed. + +Lemma mx_JordanHolder_max U (m := size U) V compU modV : + (last 0 U :=: 1%:M)%MS -> mx_irreducible (@factmod_repr _ G n rG V modV) -> + exists i : 'I_m, mx_rsim (factmod_repr modV) (@series_repr U i compU). +Proof. +rewrite {}/m; set Um := last 0 U => Um1 irrV. +have modUm: modG Um := last_mod compU; have simV := rsimC (mx_factmod_sub modV). +have maxV: max_submod V Um. + move/max_submodP: (mx_rsim_irr simV irrV) => /(_ (submx1 _)). + by apply: max_submod_eqmx; last exact: eqmx_sym. +have [W compW lastW] := mx_JordanHolder_exists compU modV maxV. +have compWU: mx_series (rcons W Um) by apply/mx_series_rcons; rewrite lastW. +have:= mx_JordanHolder compU compWU; rewrite last_rcons size_rcons. +case=> // szW [p pUW]; have ltWU: size W < size U by rewrite szW. +pose i := Ordinal ltWU; exists ((p^-1)%g i). +apply: rsimT simV (rsimT _ (rsimC (pUW _))); rewrite permKV. +apply: rsimT (rsimC _) (rsim_last (last_mod compW) modUm _). +by apply: section_eqmx; rewrite ?lastW. +Qed. + +End JordanHolder. + +Bind Scope irrType_scope with socle_sort. + +Section Regular. + +Variables (gT : finGroupType) (G : {group gT}). +Local Notation nG := #|pred_of_set (gval G)|. + +Local Notation rF := (GRing.Field.comUnitRingType F) (only parsing). +Local Notation aG := (regular_repr rF G). +Local Notation R_G := (group_ring rF G). + +Lemma gring_free : row_free R_G. +Proof. +apply/row_freeP; exists (lin1_mx (row (gring_index G 1) \o vec_mx)). +apply/row_matrixP=> i; rewrite row_mul rowK mul_rV_lin1 /= mxvecK rowK row1. +by rewrite gring_indexK // mul1g gring_valK. +Qed. + +Lemma gring_op_id A : (A \in R_G)%MS -> gring_op aG A = A. +Proof. +case/envelop_mxP=> a ->{A}; rewrite linear_sum. +by apply: eq_bigr => x Gx; rewrite linearZ /= gring_opG. +Qed. + +Lemma gring_rowK A : (A \in R_G)%MS -> gring_mx aG (gring_row A) = A. +Proof. exact: gring_op_id. Qed. + +Lemma mem_gring_mx m a (M : 'M_(m, nG)) : + (gring_mx aG a \in M *m R_G)%MS = (a <= M)%MS. +Proof. by rewrite vec_mxK submxMfree ?gring_free. Qed. + +Lemma mem_sub_gring m A (M : 'M_(m, nG)) : + (A \in M *m R_G)%MS = (A \in R_G)%MS && (gring_row A <= M)%MS. +Proof. +rewrite -(andb_idl (memmx_subP (submxMl _ _) A)); apply: andb_id2l => R_A. +by rewrite -mem_gring_mx gring_rowK. +Qed. + +Section GringMx. + +Variables (n : nat) (rG : mx_representation F G n). + +Lemma gring_mxP a : (gring_mx rG a \in enveloping_algebra_mx rG)%MS. +Proof. by rewrite vec_mxK submxMl. Qed. + +Lemma gring_opM A B : + (B \in R_G)%MS -> gring_op rG (A *m B) = gring_op rG A *m gring_op rG B. +Proof. by move=> R_B; rewrite -gring_opJ gring_rowK. Qed. + +Hypothesis irrG : mx_irreducible rG. + +Lemma rsim_regular_factmod : + {U : 'M_nG & {modU : mxmodule aG U & mx_rsim rG (factmod_repr modU)}}. +Proof. +pose v : 'rV[F]_n := nz_row 1%:M. +pose fU := lin1_mx (mulmx v \o gring_mx rG); pose U := kermx fU. +have modU: mxmodule aG U. + apply/mxmoduleP => x Gx; apply/sub_kermxP/row_matrixP=> i. + rewrite 2!row_mul row0; move: (row i U) (sub_kermxP (row_sub i U)) => u. + by rewrite !mul_rV_lin1 /= gring_mxJ // mulmxA => ->; rewrite mul0mx. +have def_n: \rank (cokermx U) = n. + apply/eqP; rewrite mxrank_coker mxrank_ker subKn ?rank_leq_row // -genmxE. + rewrite -[_ == _]sub1mx; have [_ _ ->] := irrG; rewrite ?submx1 //. + rewrite (eqmx_module _ (genmxE _)); apply/mxmoduleP=> x Gx. + apply/row_subP=> i; apply: eq_row_sub (gring_index G (enum_val i * x)) _. + rewrite !rowE mulmxA !mul_rV_lin1 /= -mulmxA -gring_mxJ //. + by rewrite -rowE rowK. + rewrite (eqmx_eq0 (genmxE _)); apply/rowV0Pn. + exists v; last exact: (nz_row_mxsimple irrG). + apply/submxP; exists (gring_row (aG 1%g)); rewrite mul_rV_lin1 /=. + by rewrite -gring_opE gring_opG // repr_mx1 mulmx1. +exists U; exists modU; apply: mx_rsim_sym. +exists (val_factmod 1%:M *m fU) => // [|x Gx]. + rewrite /row_free eqn_leq rank_leq_row /= -subn_eq0 -mxrank_ker mxrank_eq0. + apply/rowV0P=> u /sub_kermxP; rewrite mulmxA => /sub_kermxP. + by rewrite -/U -in_factmod_eq0 mulmxA mulmx1 val_factmodK => /eqP. +rewrite mulmxA -val_factmodE (canRL (addKr _) (add_sub_fact_mod U _)). +rewrite mulmxDl mulNmx (sub_kermxP (val_submodP _)) oppr0 add0r. +apply/row_matrixP=> i; move: (val_factmod _) => zz. +by rewrite !row_mul !mul_rV_lin1 /= gring_mxJ // mulmxA. +Qed. + +Lemma rsim_regular_series U (compU : mx_composition_series aG U) : + (last 0 U :=: 1%:M)%MS -> + exists i : 'I_(size U), mx_rsim rG (series_repr i compU). +Proof. +move=> lastU; have [V [modV simGV]] := rsim_regular_factmod. +have irrV := mx_rsim_irr simGV irrG. +have [i simVU] := mx_JordanHolder_max compU lastU irrV. +exists i; exact: mx_rsim_trans simGV simVU. +Qed. + +Hypothesis F'G : [char F]^'.-group G. + +Lemma rsim_regular_submod : + {U : 'M_nG & {modU : mxmodule aG U & mx_rsim rG (submod_repr modU)}}. +Proof. +have [V [modV eqG'V]] := rsim_regular_factmod. +have [U modU defVU dxVU] := mx_Maschke F'G modV (submx1 V). +exists U; exists modU; apply: mx_rsim_trans eqG'V _. +by apply: mx_rsim_factmod; rewrite ?mxdirectE /= addsmxC // addnC. +Qed. + +End GringMx. + +Definition gset_mx (A : {set gT}) := \sum_(x in A) aG x. + +Local Notation tG := #|pred_of_set (classes (gval G))|. + +Definition classg_base := \matrix_(k < tG) mxvec (gset_mx (enum_val k)). + +Let groupCl : {in G, forall x, {subset x ^: G <= G}}. +Proof. by move=> x Gx; apply: subsetP; exact: class_subG. Qed. + +Lemma classg_base_free : row_free classg_base. +Proof. +rewrite -kermx_eq0; apply/rowV0P=> v /sub_kermxP; rewrite mulmx_sum_row => v0. +apply/rowP=> k; rewrite mxE. +have [x Gx def_k] := imsetP (enum_valP k). +transitivity (@gring_proj F _ G x (vec_mx 0) 0 0); last first. + by rewrite !linear0 !mxE. +rewrite -{}v0 !linear_sum (bigD1 k) //= !linearZ /= rowK mxvecK def_k. +rewrite linear_sum (bigD1 x) ?class_refl //= gring_projE // eqxx. +rewrite !big1 ?addr0 ?mxE ?mulr1 // => [k' | y /andP[xGy ne_yx]]; first 1 last. + by rewrite gring_projE ?(groupCl Gx xGy) // eq_sym (negPf ne_yx). +rewrite rowK !linearZ /= mxvecK -(inj_eq enum_val_inj) def_k eq_sym. +have [z Gz ->] := imsetP (enum_valP k'). +move/eqP=> not_Gxz; rewrite linear_sum big1 ?scaler0 //= => y zGy. +rewrite gring_projE ?(groupCl Gz zGy) //. +by case: eqP zGy => // <- /class_transr. +Qed. + +Lemma classg_base_center : (classg_base :=: 'Z(R_G))%MS. +Proof. +apply/eqmxP/andP; split. + apply/row_subP=> k; rewrite rowK /gset_mx sub_capmx {1}linear_sum. + have [x Gx ->{k}] := imsetP (enum_valP k); have sxGG := groupCl Gx. + rewrite summx_sub => [|y xGy]; last by rewrite envelop_mx_id ?sxGG. + rewrite memmx_cent_envelop; apply/centgmxP=> y Gy. + rewrite {2}(reindex_acts 'J _ Gy) ?astabsJ ?class_norm //=. + rewrite mulmx_suml mulmx_sumr; apply: eq_bigr => z; move/sxGG=> Gz. + by rewrite -!repr_mxM ?groupJ -?conjgC. +apply/memmx_subP=> A; rewrite sub_capmx memmx_cent_envelop. +case/andP=> /envelop_mxP[a ->{A}] cGa. +rewrite (partition_big_imset (class^~ G)) -/(classes G) /=. +rewrite linear_sum summx_sub //= => xG GxG; have [x Gx def_xG] := imsetP GxG. +apply: submx_trans (scalemx_sub (a x) (submx_refl _)). +rewrite (eq_row_sub (enum_rank_in GxG xG)) // linearZ /= rowK enum_rankK_in //. +rewrite !linear_sum {xG GxG}def_xG; apply: eq_big => [y | xy] /=. + apply/idP/andP=> [| [_ xGy]]; last by rewrite -(eqP xGy) class_refl. + by case/imsetP=> z Gz ->; rewrite groupJ // classGidl. +case/imsetP=> y Gy ->{xy}; rewrite linearZ; congr (_ *: _). +move/(canRL (repr_mxK aG Gy)): (centgmxP cGa y Gy); have Gy' := groupVr Gy. +move/(congr1 (gring_proj x)); rewrite -mulmxA mulmx_suml !linear_sum. +rewrite (bigD1 x Gx) big1 => [|z /andP[Gz]]; rewrite !linearZ /=; last first. + by rewrite eq_sym gring_projE // => /negPf->; rewrite scaler0. +rewrite gring_projE // eqxx scalemx1 (bigD1 (x ^ y)%g) ?groupJ //=. +rewrite big1 => [|z /andP[Gz]]; rewrite -scalemxAl !linearZ /=. + rewrite !addr0 -!repr_mxM ?groupM // mulgA mulKVg mulgK => /rowP/(_ 0). + by rewrite gring_projE // eqxx scalemx1 !mxE. +rewrite eq_sym -(can_eq (conjgKV y)) conjgK conjgE invgK. +by rewrite -!repr_mxM ?gring_projE ?groupM // => /negPf->; rewrite scaler0. +Qed. + +Lemma regular_module_ideal m (M : 'M_(m, nG)) : + mxmodule aG M = right_mx_ideal R_G (M *m R_G). +Proof. +apply/idP/idP=> modM. + apply/mulsmx_subP=> A B; rewrite !mem_sub_gring => /andP[R_A M_A] R_B. + by rewrite envelop_mxM // gring_row_mul (mxmodule_envelop modM). +apply/mxmoduleP=> x Gx; apply/row_subP=> i; rewrite row_mul -mem_gring_mx. +rewrite gring_mxJ // (mulsmx_subP modM) ?envelop_mx_id //. +by rewrite mem_gring_mx row_sub. +Qed. + +Definition irrType := socleType aG. +Identity Coercion type_of_irrType : irrType >-> socleType. + +Variable sG : irrType. + +Definition irr_degree (i : sG) := \rank (socle_base i). +Local Notation "'n_ i" := (irr_degree i) : group_ring_scope. +Local Open Scope group_ring_scope. + +Lemma irr_degreeE i : 'n_i = \rank (socle_base i). Proof. by []. Qed. +Lemma irr_degree_gt0 i : 'n_i > 0. +Proof. by rewrite lt0n mxrank_eq0; case: (socle_simple i). Qed. + +Definition irr_repr i : mx_representation F G 'n_i := socle_repr i. +Lemma irr_reprE i x : irr_repr i x = submod_mx (socle_module i) x. +Proof. by []. Qed. + +Lemma rfix_regular : (rfix_mx aG G :=: gring_row (gset_mx G))%MS. +Proof. +apply/eqmxP/andP; split; last first. + apply/rfix_mxP => x Gx; rewrite -gring_row_mul; congr gring_row. + rewrite {2}/gset_mx (reindex_astabs 'R x) ?astabsR //= mulmx_suml. + by apply: eq_bigr => y Gy; rewrite repr_mxM. +apply/rV_subP=> v /rfix_mxP cGv. +have /envelop_mxP[a def_v]: (gring_mx aG v \in R_G)%MS. + by rewrite vec_mxK submxMl. +suffices ->: v = a 1%g *: gring_row (gset_mx G) by rewrite scalemx_sub. +rewrite -linearZ scaler_sumr -[v]gring_mxK def_v; congr (gring_row _). +apply: eq_bigr => x Gx; congr (_ *: _). +move/rowP/(_ 0): (congr1 (gring_proj x \o gring_mx aG) (cGv x Gx)). +rewrite /= gring_mxJ // def_v mulmx_suml !linear_sum (bigD1 1%g) //=. +rewrite repr_mx1 -scalemxAl mul1mx linearZ /= gring_projE // eqxx scalemx1. +rewrite big1 ?addr0 ?mxE /= => [ | y /andP[Gy nt_y]]; last first. + rewrite -scalemxAl linearZ -repr_mxM //= gring_projE ?groupM //. + by rewrite eq_sym eq_mulgV1 mulgK (negPf nt_y) scaler0. +rewrite (bigD1 x) //= linearZ /= gring_projE // eqxx scalemx1. +rewrite big1 ?addr0 ?mxE // => y /andP[Gy ne_yx]. +by rewrite linearZ /= gring_projE // eq_sym (negPf ne_yx) scaler0. +Qed. + +Lemma principal_comp_subproof : mxsimple aG (rfix_mx aG G). +Proof. +apply: linear_mxsimple; first exact: rfix_mx_module. +apply/eqP; rewrite rfix_regular eqn_leq rank_leq_row lt0n mxrank_eq0. +apply/eqP => /(congr1 (gring_proj 1 \o gring_mx aG)); apply/eqP. +rewrite /= -[gring_mx _ _]/(gring_op _ _) !linear0 !linear_sum (bigD1 1%g) //=. +rewrite gring_opG ?gring_projE // eqxx big1 ?addr0 ?oner_eq0 // => x. +by case/andP=> Gx nt_x; rewrite gring_opG // gring_projE // eq_sym (negPf nt_x). +Qed. + +Fact principal_comp_key : unit. Proof. by []. Qed. +Definition principal_comp_def := + PackSocle (component_socle sG principal_comp_subproof). +Definition principal_comp := locked_with principal_comp_key principal_comp_def. +Local Notation "1" := principal_comp : irrType_scope. + +Lemma irr1_rfix : (1%irr :=: rfix_mx aG G)%MS. +Proof. +rewrite [1%irr]unlock PackSocleK; apply/eqmxP. +rewrite (component_mx_id principal_comp_subproof) andbT. +have [I [W isoW ->]] := component_mx_def principal_comp_subproof. +apply/sumsmx_subP=> i _; have [f _ hom_f <-]:= isoW i. +by apply/rfix_mxP=> x Gx; rewrite -(hom_mxP hom_f) // (rfix_mxP G _). +Qed. + +Lemma rank_irr1 : \rank 1%irr = 1%N. +Proof. +apply/eqP; rewrite eqn_leq lt0n mxrank_eq0 nz_socle andbT. +by rewrite irr1_rfix rfix_regular rank_leq_row. +Qed. + +Lemma degree_irr1 : 'n_1 = 1%N. +Proof. +apply/eqP; rewrite eqn_leq irr_degree_gt0 -rank_irr1. +by rewrite mxrankS ?component_mx_id //; exact: socle_simple. +Qed. + +Definition Wedderburn_subring (i : sG) := <>%MS. + +Local Notation "''R_' i" := (Wedderburn_subring i) : group_ring_scope. + +Let sums_R : (\sum_i 'R_i :=: Socle sG *m R_G)%MS. +Proof. +apply/eqmxP; set R_S := (_ <= _)%MS. +have sRS: R_S by apply/sumsmx_subP=> i; rewrite genmxE submxMr ?(sumsmx_sup i). +rewrite sRS -(mulmxKpV sRS) mulmxA submxMr //; apply/sumsmx_subP=> i _. +rewrite -(submxMfree _ _ gring_free) -(mulmxA _ _ R_G) mulmxKpV //. +by rewrite (sumsmx_sup i) ?genmxE. +Qed. + +Lemma Wedderburn_ideal i : mx_ideal R_G 'R_i. +Proof. +apply/andP; split; last first. + rewrite /right_mx_ideal genmxE (muls_eqmx (genmxE _) (eqmx_refl _)). + by rewrite -[(_ <= _)%MS]regular_module_ideal component_mx_module. +apply/mulsmx_subP=> A B R_A; rewrite !genmxE !mem_sub_gring => /andP[R_B SiB]. +rewrite envelop_mxM {R_A}// gring_row_mul -{R_B}(gring_rowK R_B). +pose f := mulmx (gring_row A) \o gring_mx aG. +rewrite -[_ *m _](mul_rV_lin1 [linear of f]). +suffices: (i *m lin1_mx f <= i)%MS by apply: submx_trans; rewrite submxMr. +apply: hom_component_mx; first exact: socle_simple. +apply/rV_subP=> v _; apply/hom_mxP=> x Gx. +by rewrite !mul_rV_lin1 /f /= gring_mxJ ?mulmxA. +Qed. + +Lemma Wedderburn_direct : mxdirect (\sum_i 'R_i)%MS. +Proof. +apply/mxdirectP; rewrite /= sums_R mxrankMfree ?gring_free //. +rewrite (mxdirectP (Socle_direct sG)); apply: eq_bigr=> i _ /=. +by rewrite genmxE mxrankMfree ?gring_free. +Qed. + +Lemma Wedderburn_disjoint i j : i != j -> ('R_i :&: 'R_j)%MS = 0. +Proof. +move=> ne_ij; apply/eqP; rewrite -submx0 capmxC. +by rewrite -(mxdirect_sumsP Wedderburn_direct j) // capmxS // (sumsmx_sup i). +Qed. + +Lemma Wedderburn_annihilate i j : i != j -> ('R_i * 'R_j)%MS = 0. +Proof. +move=> ne_ij; apply/eqP; rewrite -submx0 -(Wedderburn_disjoint ne_ij). +rewrite sub_capmx; apply/andP; split. + case/andP: (Wedderburn_ideal i) => _; apply: submx_trans. + by rewrite mulsmxS // genmxE submxMl. +case/andP: (Wedderburn_ideal j) => idlRj _; apply: submx_trans idlRj. +by rewrite mulsmxS // genmxE submxMl. +Qed. + +Lemma Wedderburn_mulmx0 i j A B : + i != j -> (A \in 'R_i)%MS -> (B \in 'R_j)%MS -> A *m B = 0. +Proof. +move=> ne_ij RiA RjB; apply: memmx0. +by rewrite -(Wedderburn_annihilate ne_ij) mem_mulsmx. +Qed. + +Hypothesis F'G : [char F]^'.-group G. + +Lemma irr_mx_sum : (\sum_(i : sG) i = 1%:M)%MS. +Proof. by apply: reducible_Socle1; exact: mx_Maschke. Qed. + +Lemma Wedderburn_sum : (\sum_i 'R_i :=: R_G)%MS. +Proof. by apply: eqmx_trans sums_R _; rewrite /Socle irr_mx_sum mul1mx. Qed. + +Definition Wedderburn_id i := + vec_mx (mxvec 1%:M *m proj_mx 'R_i (\sum_(j | j != i) 'R_j)%MS). + +Local Notation "''e_' i" := (Wedderburn_id i) : group_ring_scope. + +Lemma Wedderburn_sum_id : \sum_i 'e_i = 1%:M. +Proof. +rewrite -linear_sum; apply: canLR mxvecK _. +have: (1%:M \in R_G)%MS := envelop_mx1 aG. +rewrite -Wedderburn_sum; case/(sub_dsumsmx Wedderburn_direct) => e Re -> _. +apply: eq_bigr => i _; have dxR := mxdirect_sumsP Wedderburn_direct i (erefl _). +rewrite (bigD1 i) // mulmxDl proj_mx_id ?Re // proj_mx_0 ?addr0 //=. +by rewrite summx_sub // => j ne_ji; rewrite (sumsmx_sup j) ?Re. +Qed. + +Lemma Wedderburn_id_mem i : ('e_i \in 'R_i)%MS. +Proof. by rewrite vec_mxK proj_mx_sub. Qed. + +Lemma Wedderburn_is_id i : mxring_id 'R_i 'e_i. +Proof. +have ideRi A: (A \in 'R_i)%MS -> 'e_i *m A = A. + move=> RiA; rewrite -{2}[A]mul1mx -Wedderburn_sum_id mulmx_suml. + rewrite (bigD1 i) //= big1 ?addr0 // => j ne_ji. + by rewrite (Wedderburn_mulmx0 ne_ji) ?Wedderburn_id_mem. + split=> // [||A RiA]; first 2 [exact: Wedderburn_id_mem]. + apply: contraNneq (nz_socle i) => e0. + apply/rowV0P=> v; rewrite -mem_gring_mx -(genmxE (i *m _)) => /ideRi. + by rewrite e0 mul0mx => /(canLR gring_mxK); rewrite linear0. +rewrite -{2}[A]mulmx1 -Wedderburn_sum_id mulmx_sumr (bigD1 i) //=. +rewrite big1 ?addr0 // => j; rewrite eq_sym => ne_ij. +by rewrite (Wedderburn_mulmx0 ne_ij) ?Wedderburn_id_mem. +Qed. + +Lemma Wedderburn_closed i : ('R_i * 'R_i = 'R_i)%MS. +Proof. +rewrite -{3}['R_i]genmx_id -/'R_i -genmx_muls; apply/genmxP. +have [idlRi idrRi] := andP (Wedderburn_ideal i). +apply/andP; split. + by apply: submx_trans idrRi; rewrite mulsmxS // genmxE submxMl. +have [_ Ri_e ideRi _] := Wedderburn_is_id i. +by apply/memmx_subP=> A RiA; rewrite -[A]ideRi ?mem_mulsmx. +Qed. + +Lemma Wedderburn_is_ring i : mxring 'R_i. +Proof. +rewrite /mxring /left_mx_ideal Wedderburn_closed submx_refl. +by apply/mxring_idP; exists 'e_i; exact: Wedderburn_is_id. +Qed. + +Lemma Wedderburn_min_ideal m i (E : 'A_(m, nG)) : + E != 0 -> (E <= 'R_i)%MS -> mx_ideal R_G E -> (E :=: 'R_i)%MS. +Proof. +move=> nzE sE_Ri /andP[idlE idrE]; apply/eqmxP; rewrite sE_Ri. +pose M := E *m pinvmx R_G; have defE: E = M *m R_G. + by rewrite mulmxKpV // (submx_trans sE_Ri) // genmxE submxMl. +have modM: mxmodule aG M by rewrite regular_module_ideal -defE. +have simSi := socle_simple i; set Si := socle_base i in simSi. +have [I [W isoW defW]]:= component_mx_def simSi. +rewrite /'R_i /socle_val /= defW genmxE defE submxMr //. +apply/sumsmx_subP=> j _. +have simW := mx_iso_simple (isoW j) simSi; have [modW _ minW] := simW. +have [{minW}dxWE | nzWE] := eqVneq (W j :&: M)%MS 0; last first. + by rewrite (sameP capmx_idPl eqmxP) minW ?capmxSl ?capmx_module. +have [_ Rei ideRi _] := Wedderburn_is_id i. +have:= nzE; rewrite -submx0 => /memmx_subP[A E_A]. +rewrite -(ideRi _ (memmx_subP sE_Ri _ E_A)). +have:= E_A; rewrite defE mem_sub_gring => /andP[R_A M_A]. +have:= Rei; rewrite genmxE mem_sub_gring => /andP[Re]. +rewrite -{2}(gring_rowK Re) /socle_val defW => /sub_sumsmxP[e ->]. +rewrite !(linear_sum, mulmx_suml) summx_sub //= => k _. +rewrite -(gring_rowK R_A) -gring_mxA -mulmxA gring_rowK //. +rewrite ((W k *m _ =P 0) _) ?linear0 ?sub0mx //. +have [f _ homWf defWk] := mx_iso_trans (mx_iso_sym (isoW j)) (isoW k). +rewrite -submx0 -{k defWk}(eqmxMr _ defWk) -(hom_envelop_mxC homWf) //. +rewrite -(mul0mx _ f) submxMr {f homWf}// -dxWE sub_capmx. +rewrite (mxmodule_envelop modW) //=; apply/row_subP=> k. +rewrite row_mul -mem_gring_mx -(gring_rowK R_A) gring_mxA gring_rowK //. +by rewrite -defE (memmx_subP idlE) // mem_mulsmx ?gring_mxP. +Qed. + +Section IrrComponent. + +(* The component of the socle of the regular module that is associated to an *) +(* irreducible representation. *) + +Variables (n : nat) (rG : mx_representation F G n). +Local Notation E_G := (enveloping_algebra_mx rG). + +Let not_rsim_op0 (iG j : sG) A : + mx_rsim rG (socle_repr iG) -> iG != j -> (A \in 'R_j)%MS -> + gring_op rG A = 0. +Proof. +case/mx_rsim_def=> f [f' _ hom_f] ne_iG_j RjA. +transitivity (f *m in_submod _ (val_submod 1%:M *m A) *m f'). + have{RjA}: (A \in R_G)%MS by rewrite -Wedderburn_sum (sumsmx_sup j). + case/envelop_mxP=> a ->{A}; rewrite !(linear_sum, mulmx_suml). + by apply: eq_bigr => x Gx; rewrite !linearZ /= -scalemxAl -hom_f ?gring_opG. +rewrite (_ : _ *m A = 0) ?(linear0, mul0mx) //. +apply/row_matrixP=> i; rewrite row_mul row0 -[row _ _]gring_mxK -gring_row_mul. +rewrite (Wedderburn_mulmx0 ne_iG_j) ?linear0 // genmxE mem_gring_mx. +by rewrite (row_subP _) // val_submod1 component_mx_id //; exact: socle_simple. +Qed. + +Definition irr_comp := odflt 1%irr [pick i | gring_op rG 'e_i != 0]. +Local Notation iG := irr_comp. + +Hypothesis irrG : mx_irreducible rG. + +Lemma rsim_irr_comp : mx_rsim rG (irr_repr iG). +Proof. +have [M [modM rsimM]] := rsim_regular_submod irrG F'G. +have simM: mxsimple aG M. + case/mx_irrP: irrG => n_gt0 minG. + have [f def_n injf homf] := mx_rsim_sym rsimM. + apply/(submod_mx_irr modM)/mx_irrP. + split=> [|U modU nzU]; first by rewrite def_n. + rewrite /row_full -(mxrankMfree _ injf) -genmxE {4}def_n. + apply: minG; last by rewrite -mxrank_eq0 genmxE mxrankMfree // mxrank_eq0. + rewrite (eqmx_module _ (genmxE _)); apply/mxmoduleP=> x Gx. + by rewrite -mulmxA -homf // mulmxA submxMr // (mxmoduleP modU). +pose i := PackSocle (component_socle sG simM). +have{modM rsimM} rsimM: mx_rsim rG (socle_repr i). + apply: mx_rsim_trans rsimM (mx_rsim_sym _); apply/mx_rsim_iso. + apply: (component_mx_iso (socle_simple _)) => //. + by rewrite [component_mx _ _]PackSocleK component_mx_id. +have [<- // | ne_i_iG] := eqVneq i iG. +suffices {i M simM ne_i_iG rsimM}: gring_op rG 'e_iG != 0. + by rewrite (not_rsim_op0 rsimM ne_i_iG) ?Wedderburn_id_mem ?eqxx. +rewrite /iG; case: pickP => //= G0. +suffices: rG 1%g == 0. + by case/idPn; rewrite -mxrank_eq0 repr_mx1 mxrank1 -lt0n; case/mx_irrP: irrG. +rewrite -gring_opG // repr_mx1 -Wedderburn_sum_id linear_sum big1 // => j _. +by move/eqP: (G0 j). +Qed. + +Lemma irr_comp'_op0 j A : j != iG -> (A \in 'R_j)%MS -> gring_op rG A = 0. +Proof. by rewrite eq_sym; exact: not_rsim_op0 rsim_irr_comp. Qed. + +Lemma irr_comp_envelop : ('R_iG *m lin_mx (gring_op rG) :=: E_G)%MS. +Proof. +apply/eqmxP/andP; split; apply/row_subP=> i. + by rewrite row_mul mul_rV_lin gring_mxP. +rewrite rowK /= -gring_opG ?enum_valP // -mul_vec_lin -gring_opG ?enum_valP //. +rewrite vec_mxK /= -mulmxA mulmx_sub {i}//= -(eqmxMr _ Wedderburn_sum). +rewrite (bigD1 iG) //= addsmxMr addsmxC [_ *m _](sub_kermxP _) ?adds0mx //=. +apply/sumsmx_subP => j ne_j_iG; apply/memmx_subP=> A RjA; apply/sub_kermxP. +by rewrite mul_vec_lin /= (irr_comp'_op0 ne_j_iG RjA) linear0. +Qed. + +Lemma ker_irr_comp_op : ('R_iG :&: kermx (lin_mx (gring_op rG)))%MS = 0. +Proof. +apply/eqP; rewrite -submx0; apply/memmx_subP=> A. +rewrite sub_capmx /= submx0 mxvec_eq0 => /andP[R_A]. +rewrite (sameP sub_kermxP eqP) mul_vec_lin mxvec_eq0 /= => opA0. +have [_ Re ideR _] := Wedderburn_is_id iG; rewrite -[A]ideR {ideR}//. +move: Re; rewrite genmxE mem_sub_gring /socle_val => /andP[Re]. +rewrite -{2}(gring_rowK Re) -submx0. +pose simMi := socle_simple iG; have [J [M isoM ->]] := component_mx_def simMi. +case/sub_sumsmxP=> e ->; rewrite linear_sum mulmx_suml summx_sub // => j _. +rewrite -(in_submodK (submxMl _ (M j))); move: (in_submod _ _) => v. +have modMj: mxmodule aG (M j) by apply: mx_iso_module (isoM j) _; case: simMi. +have rsimMj: mx_rsim rG (submod_repr modMj). + by apply: mx_rsim_trans rsim_irr_comp _; exact/mx_rsim_iso. +have [f [f' _ hom_f]] := mx_rsim_def (mx_rsim_sym rsimMj); rewrite submx0. +have <-: (gring_mx aG (val_submod (v *m (f *m gring_op rG A *m f')))) = 0. + by rewrite (eqP opA0) !(mul0mx, linear0). +have: (A \in R_G)%MS by rewrite -Wedderburn_sum (sumsmx_sup iG). +case/envelop_mxP=> a ->; rewrite !(linear_sum, mulmx_suml) /=; apply/eqP. +apply: eq_bigr=> x Gx; rewrite !linearZ -scalemxAl !linearZ /=. +by rewrite gring_opG // -hom_f // val_submodJ // gring_mxJ. +Qed. + +Lemma regular_op_inj : + {in [pred A | (A \in 'R_iG)%MS] &, injective (gring_op rG)}. +Proof. +move=> A B RnA RnB /= eqAB; apply/eqP; rewrite -subr_eq0 -mxvec_eq0 -submx0. +rewrite -ker_irr_comp_op sub_capmx (sameP sub_kermxP eqP) mul_vec_lin. +by rewrite 2!linearB /= eqAB subrr linear0 addmx_sub ?eqmx_opp /=. +Qed. + +Lemma rank_irr_comp : \rank 'R_iG = \rank E_G. +Proof. +symmetry; rewrite -{1}irr_comp_envelop; apply/mxrank_injP. +by rewrite ker_irr_comp_op. +Qed. + +End IrrComponent. + +Lemma irr_comp_rsim n1 n2 rG1 rG2 : + @mx_rsim _ G n1 rG1 n2 rG2 -> irr_comp rG1 = irr_comp rG2. +Proof. +case=> f eq_n12; rewrite -eq_n12 in rG2 f * => inj_f hom_f. +congr (odflt _ _); apply: eq_pick => i; rewrite -!mxrank_eq0. +rewrite -(mxrankMfree _ inj_f); symmetry; rewrite -(eqmxMfull _ inj_f). +have /envelop_mxP[e ->{i}]: ('e_i \in R_G)%MS. + by rewrite -Wedderburn_sum (sumsmx_sup i) ?Wedderburn_id_mem. +congr (\rank _ != _); rewrite !(mulmx_suml, linear_sum); apply: eq_bigr => x Gx. +by rewrite !linearZ -scalemxAl /= !gring_opG ?hom_f. +Qed. + +Lemma irr_reprK i : irr_comp (irr_repr i) = i. +Proof. +apply/eqP; apply/component_mx_isoP; try exact: socle_simple. +by move/mx_rsim_iso: (rsim_irr_comp (socle_irr i)); exact: mx_iso_sym. +Qed. + +Lemma irr_repr'_op0 i j A : + j != i -> (A \in 'R_j)%MS -> gring_op (irr_repr i) A = 0. +Proof. +by move=> neq_ij /irr_comp'_op0-> //; [exact: socle_irr | rewrite irr_reprK]. +Qed. + +Lemma op_Wedderburn_id i : gring_op (irr_repr i) 'e_i = 1%:M. +Proof. +rewrite -(gring_op1 (irr_repr i)) -Wedderburn_sum_id. +rewrite linear_sum (bigD1 i) //= addrC big1 ?add0r // => j neq_ji. +exact: irr_repr'_op0 (Wedderburn_id_mem j). +Qed. + +Lemma irr_comp_id (M : 'M_nG) (modM : mxmodule aG M) (iM : sG) : + mxsimple aG M -> (M <= iM)%MS -> irr_comp (submod_repr modM) = iM. +Proof. +move=> simM sMiM; rewrite -[iM]irr_reprK. +apply/esym/irr_comp_rsim/mx_rsim_iso/component_mx_iso => //. +exact: socle_simple. +Qed. + +Lemma irr1_repr x : x \in G -> irr_repr 1 x = 1%:M. +Proof. +move=> Gx; suffices: x \in rker (irr_repr 1) by case/rkerP. +apply: subsetP x Gx; rewrite rker_submod rfix_mx_rstabC // -irr1_rfix. +by apply: component_mx_id; exact: socle_simple. +Qed. + +Hypothesis splitG : group_splitting_field G. + +Lemma rank_Wedderburn_subring i : \rank 'R_i = ('n_i ^ 2)%N. +Proof. +apply/eqP; rewrite -{1}[i]irr_reprK; have irrSi := socle_irr i. +by case/andP: (splitG irrSi) => _; rewrite rank_irr_comp. +Qed. + +Lemma sum_irr_degree : (\sum_i 'n_i ^ 2 = nG)%N. +Proof. +apply: etrans (eqnP gring_free). +rewrite -Wedderburn_sum (mxdirectP Wedderburn_direct) /=. +by apply: eq_bigr => i _; rewrite rank_Wedderburn_subring. +Qed. + +Lemma irr_mx_mult i : socle_mult i = 'n_i. +Proof. +rewrite /socle_mult -(mxrankMfree _ gring_free) -genmxE. +by rewrite rank_Wedderburn_subring mulKn ?irr_degree_gt0. +Qed. + +Lemma mxtrace_regular : + {in G, forall x, \tr (aG x) = \sum_i \tr (socle_repr i x) *+ 'n_i}. +Proof. +move=> x Gx; have soc1: (Socle sG :=: 1%:M)%MS by rewrite -irr_mx_sum. +rewrite -(mxtrace_submod1 (Socle_module sG) soc1) // mxtrace_Socle //. +by apply: eq_bigr => i _; rewrite irr_mx_mult. +Qed. + +Definition linear_irr := [set i | 'n_i == 1%N]. + +Lemma irr_degree_abelian : abelian G -> forall i, 'n_i = 1%N. +Proof. by move=> cGG i; exact: mxsimple_abelian_linear (socle_simple i). Qed. + +Lemma linear_irr_comp i : 'n_i = 1%N -> (i :=: socle_base i)%MS. +Proof. +move=> ni1; apply/eqmxP; rewrite andbC -mxrank_leqif_eq -/'n_i. + by rewrite -(mxrankMfree _ gring_free) -genmxE rank_Wedderburn_subring ni1. +exact: component_mx_id (socle_simple i). +Qed. + +Lemma Wedderburn_subring_center i : ('Z('R_i) :=: mxvec 'e_i)%MS. +Proof. +have [nz_e Re ideR idRe] := Wedderburn_is_id i. +have Ze: (mxvec 'e_i <= 'Z('R_i))%MS. + rewrite sub_capmx [(_ <= _)%MS]Re. + by apply/cent_mxP=> A R_A; rewrite ideR // idRe. +pose irrG := socle_irr i; set rG := socle_repr i in irrG. +pose E_G := enveloping_algebra_mx rG; have absG := splitG irrG. +apply/eqmxP; rewrite andbC -(geq_leqif (mxrank_leqif_eq Ze)). +have ->: \rank (mxvec 'e_i) = (0 + 1)%N. + by apply/eqP; rewrite eqn_leq rank_leq_row lt0n mxrank_eq0 mxvec_eq0. +rewrite -(mxrank_mul_ker _ (lin_mx (gring_op rG))) addnC leq_add //. + rewrite leqn0 mxrank_eq0 -submx0 -(ker_irr_comp_op irrG) capmxS //. + by rewrite irr_reprK capmxSl. +apply: leq_trans (mxrankS _) (rank_leq_row (mxvec 1%:M)). +apply/memmx_subP=> Ar; case/submxP=> a ->{Ar}. +rewrite mulmxA mul_rV_lin /=; set A := vec_mx _. +rewrite memmx1 (mx_abs_irr_cent_scalar absG) // -memmx_cent_envelop. +apply/cent_mxP=> Br; rewrite -(irr_comp_envelop irrG) irr_reprK. +case/submxP=> b /(canRL mxvecK) ->{Br}; rewrite mulmxA mx_rV_lin /=. +set B := vec_mx _; have RiB: (B \in 'R_i)%MS by rewrite vec_mxK submxMl. +have sRiR: ('R_i <= R_G)%MS by rewrite -Wedderburn_sum (sumsmx_sup i). +have: (A \in 'Z('R_i))%MS by rewrite vec_mxK submxMl. +rewrite sub_capmx => /andP[RiA /cent_mxP cRiA]. +by rewrite -!gring_opM ?(memmx_subP sRiR) 1?cRiA. +Qed. + +Lemma Wedderburn_center : + ('Z(R_G) :=: \matrix_(i < #|sG|) mxvec 'e_(enum_val i))%MS. +Proof. +have:= mxdirect_sums_center Wedderburn_sum Wedderburn_direct Wedderburn_ideal. +move/eqmx_trans; apply; apply/eqmxP/andP; split. + apply/sumsmx_subP=> i _; rewrite Wedderburn_subring_center. + by apply: (eq_row_sub (enum_rank i)); rewrite rowK enum_rankK. +apply/row_subP=> i; rewrite rowK -Wedderburn_subring_center. +by rewrite (sumsmx_sup (enum_val i)). +Qed. + +Lemma card_irr : #|sG| = tG. +Proof. +rewrite -(eqnP classg_base_free) classg_base_center. +have:= mxdirect_sums_center Wedderburn_sum Wedderburn_direct Wedderburn_ideal. +move->; rewrite (mxdirectP _) /=; last first. + apply/mxdirect_sumsP=> i _; apply/eqP; rewrite -submx0. + rewrite -{2}(mxdirect_sumsP Wedderburn_direct i) // capmxS ?capmxSl //=. + by apply/sumsmx_subP=> j neji; rewrite (sumsmx_sup j) ?capmxSl. +rewrite -sum1_card; apply: eq_bigr => i _; apply/eqP. +rewrite Wedderburn_subring_center eqn_leq rank_leq_row lt0n mxrank_eq0. +by rewrite andbT mxvec_eq0; case: (Wedderburn_is_id i). +Qed. + +Section CenterMode. + +Variable i : sG. + +Let i0 := Ordinal (irr_degree_gt0 i). + +Definition irr_mode x := irr_repr i x i0 i0. + +Lemma irr_mode1 : irr_mode 1 = 1. +Proof. by rewrite /irr_mode repr_mx1 mxE eqxx. Qed. + +Lemma irr_center_scalar : {in 'Z(G), forall x, irr_repr i x = (irr_mode x)%:M}. +Proof. +rewrite /irr_mode => x /setIP[Gx cGx]. +suffices [a ->]: exists a, irr_repr i x = a%:M by rewrite mxE eqxx. +apply/is_scalar_mxP; apply: (mx_abs_irr_cent_scalar (splitG (socle_irr i))). +by apply/centgmxP=> y Gy; rewrite -!{1}repr_mxM 1?(centP cGx). +Qed. + +Lemma irr_modeM : {in 'Z(G) &, {morph irr_mode : x y / (x * y)%g >-> x * y}}. +Proof. +move=> x y Zx Zy; rewrite {1}/irr_mode repr_mxM ?(subsetP (center_sub G)) //. +by rewrite !irr_center_scalar // -scalar_mxM mxE eqxx. +Qed. + +Lemma irr_modeX n : {in 'Z(G), {morph irr_mode : x / (x ^+ n)%g >-> x ^+ n}}. +Proof. +elim: n => [|n IHn] x Zx; first exact: irr_mode1. +by rewrite expgS irr_modeM ?groupX // exprS IHn. +Qed. + +Lemma irr_mode_unit : {in 'Z(G), forall x, irr_mode x \is a GRing.unit}. +Proof. +move=> x Zx /=; have:= unitr1 F. +by rewrite -irr_mode1 -(mulVg x) irr_modeM ?groupV // unitrM; case/andP=> _. +Qed. + +Lemma irr_mode_neq0 : {in 'Z(G), forall x, irr_mode x != 0}. +Proof. by move=> x /irr_mode_unit; rewrite unitfE. Qed. + +Lemma irr_modeV : {in 'Z(G), {morph irr_mode : x / (x^-1)%g >-> x^-1}}. +Proof. +move=> x Zx /=; rewrite -[_^-1]mul1r; apply: canRL (mulrK (irr_mode_unit Zx)) _. +by rewrite -irr_modeM ?groupV // mulVg irr_mode1. +Qed. + +End CenterMode. + +Lemma irr1_mode x : x \in G -> irr_mode 1 x = 1. +Proof. by move=> Gx; rewrite /irr_mode irr1_repr ?mxE. Qed. + +End Regular. + +Local Notation "[ 1 sG ]" := (principal_comp sG) : irrType_scope. + +Section LinearIrr. + +Variables (gT : finGroupType) (G : {group gT}). + +Lemma card_linear_irr (sG : irrType G) : + [char F]^'.-group G -> group_splitting_field G -> + #|linear_irr sG| = #|G : G^`(1)|%g. +Proof. +move=> F'G splitG; apply/eqP. +wlog sGq: / irrType (G / G^`(1))%G by exact: socle_exists. +have [_ nG'G] := andP (der_normal 1 G); apply/eqP; rewrite -card_quotient //. +have cGqGq: abelian (G / G^`(1))%g by exact: sub_der1_abelian. +have F'Gq: [char F]^'.-group (G / G^`(1))%g by exact: morphim_pgroup. +have splitGq: group_splitting_field (G / G^`(1))%G. + exact: quotient_splitting_field. +rewrite -(sum_irr_degree sGq) // -sum1_card. +pose rG (j : sGq) := morphim_repr (socle_repr j) nG'G. +have irrG j: mx_irreducible (rG j) by apply/morphim_mx_irr; exact: socle_irr. +rewrite (reindex (fun j => irr_comp sG (rG j))) /=. + apply: eq_big => [j | j _]; last by rewrite irr_degree_abelian. + have [_ lin_j _ _] := rsim_irr_comp sG F'G (irrG j). + by rewrite inE -lin_j -irr_degreeE irr_degree_abelian. +pose sGlin := {i | i \in linear_irr sG}. +have sG'k (i : sGlin) : G^`(1)%g \subset rker (irr_repr (val i)). + by case: i => i /=; rewrite !inE => lin; rewrite rker_linear //=; exact/eqP. +pose h' u := irr_comp sGq (quo_repr (sG'k u) nG'G). +have irrGq u: mx_irreducible (quo_repr (sG'k u) nG'G). + by apply/quo_mx_irr; exact: socle_irr. +exists (fun i => oapp h' [1 sGq]%irr (insub i)) => [j | i] lin_i. + rewrite (insubT (mem _) lin_i) /=; apply/esym/eqP/socle_rsimP. + apply: mx_rsim_trans (rsim_irr_comp sGq F'Gq (irrGq _)). + have [g lin_g inj_g hom_g] := rsim_irr_comp sG F'G (irrG j). + exists g => [||G'x]; last 1 [case/morphimP=> x _ Gx ->] || by []. + by rewrite quo_repr_coset ?hom_g. +rewrite (insubT (mem _) lin_i) /=; apply/esym/eqP/socle_rsimP. +set u := exist _ _ _; apply: mx_rsim_trans (rsim_irr_comp sG F'G (irrG _)). +have [g lin_g inj_g hom_g] := rsim_irr_comp sGq F'Gq (irrGq u). +exists g => [||x Gx]; last 1 [have:= hom_g (coset _ x)] || by []. +by rewrite quo_repr_coset; first by apply; rewrite mem_quotient. +Qed. + +Lemma primitive_root_splitting_abelian (z : F) : + #|G|.-primitive_root z -> abelian G -> group_splitting_field G. +Proof. +move=> ozG cGG [|n] rG irrG; first by case/mx_irrP: irrG. +case: (pickP [pred x in G | ~~ is_scalar_mx (rG x)]) => [x | scalG]. + case/andP=> Gx nscal_rGx; have: horner_mx (rG x) ('X^#|G| - 1) == 0. + rewrite rmorphB rmorphX /= horner_mx_C horner_mx_X. + rewrite -repr_mxX ?inE // ((_ ^+ _ =P 1)%g _) ?repr_mx1 ?subrr //. + by rewrite -order_dvdn order_dvdG. + case/idPn; rewrite -mxrank_eq0 -(factor_Xn_sub_1 ozG). + elim: #|G| => [|i IHi]; first by rewrite big_nil horner_mx_C mxrank1. + rewrite big_nat_recr //= rmorphM mxrankMfree {IHi}//. + rewrite row_free_unit rmorphB /= horner_mx_X horner_mx_C. + rewrite (mx_Schur irrG) ?subr_eq0 //; last first. + by apply: contraNneq nscal_rGx => ->; exact: scalar_mx_is_scalar. + rewrite -memmx_cent_envelop linearB. + rewrite addmx_sub ?eqmx_opp ?scalar_mx_cent //= memmx_cent_envelop. + by apply/centgmxP=> j Zh_j; rewrite -!repr_mxM // (centsP cGG). +pose M := <>%MS. +have linM: \rank M = 1%N by rewrite genmxE mxrank_delta. +have modM: mxmodule rG M. + apply/mxmoduleP=> x Gx; move/idPn: (scalG x); rewrite /= Gx negbK. + by case/is_scalar_mxP=> ? ->; rewrite scalar_mxC submxMl. +apply: linear_mx_abs_irr; apply/eqP; rewrite eq_sym -linM. +by case/mx_irrP: irrG => _; apply; rewrite // -mxrank_eq0 linM. +Qed. + +Lemma cycle_repr_structure x (sG : irrType G) : + G :=: <[x]> -> [char F]^'.-group G -> group_splitting_field G -> + exists2 w : F, #|G|.-primitive_root w & + exists iphi : 'I_#|G| -> sG, + [/\ bijective iphi, + #|sG| = #|G|, + forall i, irr_mode (iphi i) x = w ^+ i + & forall i, irr_repr (iphi i) x = (w ^+ i)%:M]. +Proof. +move=> defG; rewrite {defG}(group_inj defG) -/#[x] in sG * => F'X splitF. +have Xx := cycle_id x; have cXX := cycle_abelian x. +have card_sG: #|sG| = #[x]. + by rewrite card_irr //; apply/eqP; rewrite -card_classes_abelian. +have linX := irr_degree_abelian splitF cXX (_ : sG). +pose r (W : sG) := irr_mode W x. +have scalX W: irr_repr W x = (r W)%:M. + by apply: irr_center_scalar; rewrite ?(center_idP _). +have inj_r: injective r. + move=> V W eqVW; rewrite -(irr_reprK F'X V) -(irr_reprK F'X W). + move: (irr_repr V) (irr_repr W) (scalX V) (scalX W). + rewrite !linX {}eqVW => rV rW <- rWx; apply: irr_comp_rsim => //. + exists 1%:M; rewrite ?row_free_unit ?unitmx1 // => xk; case/cycleP=> k ->{xk}. + by rewrite mulmx1 mul1mx !repr_mxX // rWx. +have rx1 W: r W ^+ #[x] = 1. + by rewrite -irr_modeX ?(center_idP _) // expg_order irr_mode1. +have /hasP[w _ prim_w]: has #[x].-primitive_root (map r (enum sG)). + rewrite has_prim_root 1?map_inj_uniq ?enum_uniq //; first 1 last. + by rewrite size_map -cardE card_sG. + by apply/allP=> _ /mapP[W _ ->]; rewrite unity_rootE rx1. +have iphi'P := prim_rootP prim_w (rx1 _); pose iphi' := sval (iphi'P _). +have def_r W: r W = w ^+ iphi' W by exact: svalP (iphi'P W). +have inj_iphi': injective iphi'. + by move=> i j eq_ij; apply: inj_r; rewrite !def_r eq_ij. +have iphiP: codom iphi' =i 'I_#[x]. + by apply/subset_cardP; rewrite ?subset_predT // card_ord card_image. +pose iphi i := iinv (iphiP i); exists w => //; exists iphi. +have iphiK: cancel iphi iphi' by move=> i; exact: f_iinv. +have r_iphi i: r (iphi i) = w ^+ i by rewrite def_r iphiK. +split=> // [|i]; last by rewrite scalX r_iphi. +by exists iphi' => // W; rewrite /iphi iinv_f. +Qed. + +Lemma splitting_cyclic_primitive_root : + cyclic G -> [char F]^'.-group G -> group_splitting_field G -> + classically {z : F | #|G|.-primitive_root z}. +Proof. +case/cyclicP=> x defG F'G splitF; case=> // IH. +wlog sG: / irrType G by exact: socle_exists. +have [w prim_w _] := cycle_repr_structure sG defG F'G splitF. +by apply: IH; exists w. +Qed. + +End LinearIrr. + +End FieldRepr. + +Arguments Scope rfix_mx [_ _ group_scope nat_scope _ group_scope]. +Arguments Scope gset_mx [_ _ group_scope group_scope]. +Arguments Scope classg_base [_ _ group_scope group_scope]. +Arguments Scope irrType [_ _ group_scope group_scope]. + +Implicit Arguments mxmoduleP [F gT G n rG m U]. +Implicit Arguments envelop_mxP [F gT G n rG A]. +Implicit Arguments hom_mxP [F gT G n rG m f W]. +Implicit Arguments mx_Maschke [F gT G n U]. +Implicit Arguments rfix_mxP [F gT G n rG m W]. +Implicit Arguments cyclic_mxP [F gT G n rG u v]. +Implicit Arguments annihilator_mxP [F gT G n rG u A]. +Implicit Arguments row_hom_mxP [F gT G n rG u v]. +Implicit Arguments mxsimple_isoP [F gT G n rG U V]. +Implicit Arguments socle_exists [F gT G n]. +Implicit Arguments socleP [F gT G n rG sG0 W W']. +Implicit Arguments mx_abs_irrP [F gT G n rG]. +Implicit Arguments socle_rsimP [F gT G n rG sG W1 W2]. + +Implicit Arguments val_submod_inj [F n U m]. +Implicit Arguments val_factmod_inj [F n U m]. +Prenex Implicits val_submod_inj val_factmod_inj. + +Notation "'Cl" := (Clifford_action _) : action_scope. + +Bind Scope irrType_scope with socle_sort. +Notation "[ 1 sG ]" := (principal_comp sG) : irrType_scope. +Arguments Scope irr_degree [_ _ Group_scope _ irrType_scope]. +Arguments Scope irr_repr [_ _ Group_scope _ irrType_scope group_scope]. +Arguments Scope irr_mode [_ _ Group_scope _ irrType_scope group_scope]. +Notation "''n_' i" := (irr_degree i) : group_ring_scope. +Notation "''R_' i" := (Wedderburn_subring i) : group_ring_scope. +Notation "''e_' i" := (Wedderburn_id i) : group_ring_scope. + +Section DecideRed. + +Import MatrixFormula. +Local Notation term := GRing.term. +Local Notation True := GRing.True. +Local Notation And := GRing.And (only parsing). +Local Notation morphAnd f := ((big_morph f) true andb). +Local Notation eval := GRing.eval. +Local Notation holds := GRing.holds. +Local Notation qf_form := GRing.qf_form. +Local Notation qf_eval := GRing.qf_eval. + +Section Definitions. + +Variables (F : fieldType) (gT : finGroupType) (G : {group gT}) (n : nat). +Variable rG : mx_representation F G n. + +Definition mxmodule_form (U : 'M[term F]_n) := + \big[And/True]_(x in G) submx_form (mulmx_term U (mx_term (rG x))) U. + +Lemma mxmodule_form_qf U : qf_form (mxmodule_form U). +Proof. +by rewrite (morphAnd (@qf_form _)) ?big1 //= => x _; rewrite submx_form_qf. +Qed. + +Lemma eval_mxmodule U e : + qf_eval e (mxmodule_form U) = mxmodule rG (eval_mx e U). +Proof. +rewrite (morphAnd (qf_eval e)) //= big_andE /=. +apply/forallP/mxmoduleP=> Umod x; move/implyP: (Umod x); + by rewrite eval_submx eval_mulmx eval_mx_term. +Qed. + +Definition mxnonsimple_form (U : 'M[term F]_n) := + let V := vec_mx (row_var F (n * n) 0) in + let nzV := (~ mxrank_form 0 V)%T in + let properVU := (submx_form V U /\ ~ submx_form U V)%T in + (Exists_row_form (n * n) 0 (mxmodule_form V /\ nzV /\ properVU))%T. + +End Definitions. + +Variables (F : decFieldType) (gT : finGroupType) (G : {group gT}) (n : nat). +Variable rG : mx_representation F G n. + +Definition mxnonsimple_sat U := + GRing.sat (@row_env _ (n * n) [::]) (mxnonsimple_form rG (mx_term U)). + +Lemma mxnonsimpleP U : + U != 0 -> reflect (mxnonsimple rG U) (mxnonsimple_sat U). +Proof. +rewrite /mxnonsimple_sat {1}/mxnonsimple_form; set Vt := vec_mx _ => /= nzU. +pose nsim V := [&& mxmodule rG V, (V <= U)%MS, V != 0 & \rank V < \rank U]. +set nsimUt := (_ /\ _)%T; have: qf_form nsimUt. + by rewrite /= mxmodule_form_qf !mxrank_form_qf !submx_form_qf. +move/GRing.qf_evalP; set qev := @GRing.qf_eval _ => qevP. +have qev_nsim u: qev (row_env [:: u]) nsimUt = nsim n (vec_mx u). + rewrite /nsim -mxrank_eq0 /qev /= eval_mxmodule eval_mxrank. + rewrite !eval_submx eval_mx_term eval_vec_mx eval_row_var /=. + do 2!bool_congr; apply: andb_id2l => sUV. + by rewrite ltn_neqAle andbC !mxrank_leqif_sup. +have n2gt0: n ^ 2 > 0. + by move: nzU; rewrite muln_gt0 -mxrank_eq0; case: posnP (U) => // ->. +apply: (iffP satP) => [|[V nsimV]]. + by case/Exists_rowP=> // v; move/qevP; rewrite qev_nsim; exists (vec_mx v). +apply/Exists_rowP=> //; exists (mxvec V); apply/qevP. +by rewrite qev_nsim mxvecK. +Qed. + +Lemma dec_mxsimple_exists (U : 'M_n) : + mxmodule rG U -> U != 0 -> {V | mxsimple rG V & V <= U}%MS. +Proof. +elim: {U}_.+1 {-2}U (ltnSn (\rank U)) => // m IHm U leUm modU nzU. +have [nsimU | simU] := mxnonsimpleP nzU; last first. + by exists U; first exact/mxsimpleP. +move: (xchooseP nsimU); move: (xchoose _) => W /and4P[modW sWU nzW ltWU]. +case: (IHm W) => // [|V simV sVW]; first exact: leq_trans ltWU _. +by exists V; last exact: submx_trans sVW sWU. +Qed. + +Lemma dec_mx_reducible_semisimple U : + mxmodule rG U -> mx_completely_reducible rG U -> mxsemisimple rG U. +Proof. +elim: {U}_.+1 {-2}U (ltnSn (\rank U)) => // m IHm U leUm modU redU. +have [U0 | nzU] := eqVneq U 0. + have{U0} U0: (\sum_(i < 0) 0 :=: U)%MS by rewrite big_ord0 U0. + by apply: (intro_mxsemisimple U0); case. +have [V simV sVU] := dec_mxsimple_exists modU nzU; have [modV nzV _] := simV. +have [W modW defVW dxVW] := redU V modV sVU. +have [||I W_ /= simW defW _] := IHm W _ modW. +- rewrite ltnS in leUm; apply: leq_trans leUm. + by rewrite -defVW (mxdirectP dxVW) /= -add1n leq_add2r lt0n mxrank_eq0. +- by apply: mx_reducibleS redU; rewrite // -defVW addsmxSr. +suffices defU: (\sum_i oapp W_ V i :=: U)%MS. + by apply: (intro_mxsemisimple defU) => [] [|i] //=. +apply: eqmx_trans defVW; rewrite (bigD1 None) //=; apply/eqmxP. +have [i0 _ | I0] := pickP I. + by rewrite (reindex some) ?addsmxS ?defW //; exists (odflt i0) => //; case. +rewrite big_pred0 //; last by case => // /I0. +by rewrite !addsmxS ?sub0mx // -defW big_pred0. +Qed. + +Lemma DecSocleType : socleType rG. +Proof. +have [n0 | n_gt0] := posnP n. + by exists [::] => // M [_]; rewrite -mxrank_eq0 -leqn0 -n0 rank_leq_row. +have n2_gt0: n ^ 2 > 0 by rewrite muln_gt0 n_gt0. +pose span Ms := (\sum_(M <- Ms) component_mx rG M)%MS. +have: {in [::], forall M, mxsimple rG M} by []. +elim: _.+1 {-2}nil (ltnSn (n - \rank (span nil))) => // m IHm Ms Ms_ge_n simMs. +rewrite ltnS in Ms_ge_n; pose V := span Ms; pose Vt := mx_term V. +pose Ut i := vec_mx (row_var F (n * n) i); pose Zt := mx_term (0 : 'M[F]_n). +pose exU i f := Exists_row_form (n * n) i (~ submx_form (Ut i) Zt /\ f (Ut i)). +pose meetUVf U := exU 1%N (fun W => submx_form W Vt /\ submx_form W U)%T. +pose mx_sat := GRing.sat (@row_env F (n * n) [::]). +have ev_sub0 := GRing.qf_evalP _ (submx_form_qf _ Zt). +have ev_mod := GRing.qf_evalP _ (mxmodule_form_qf rG _). +pose ev := (eval_mxmodule, eval_submx, eval_vec_mx, eval_row_var, eval_mx_term). +case haveU: (mx_sat (exU 0%N (fun U => mxmodule_form rG U /\ ~ meetUVf _ U)%T)). + have [U modU]: {U : 'M_n | mxmodule rG U & (U != 0) && ((U :&: V)%MS == 0)}. + apply: sig2W; case/Exists_rowP: (satP haveU) => //= u [nzU [modU tiUV]]. + exists (vec_mx u); first by move/ev_mod: modU; rewrite !ev. + set W := (_ :&: V)%MS; move/ev_sub0: nzU; rewrite !ev -!submx0 => -> /=. + apply/idPn=> nzW; case: tiUV; apply/Exists_rowP=> //; exists (mxvec W). + apply/GRing.qf_evalP; rewrite /= ?submx_form_qf // !ev mxvecK nzW /=. + by rewrite andbC -sub_capmx. + case/andP=> nzU tiUV; have [M simM sMU] := dec_mxsimple_exists modU nzU. + apply: (IHm (M :: Ms)) => [|M']; last first. + by case/predU1P=> [-> //|]; exact: simMs. + have [_ nzM _] := simM. + suffices ltVMV: \rank V < \rank (span (M :: Ms)). + rewrite (leq_trans _ Ms_ge_n) // ltn_sub2l ?(leq_trans ltVMV) //. + exact: rank_leq_row. + rewrite /span big_cons (ltn_leqif (mxrank_leqif_sup (addsmxSr _ _))). + apply: contra nzM; rewrite addsmx_sub -submx0 -(eqP tiUV) sub_capmx sMU. + by case/andP=> sMV _; rewrite (submx_trans _ sMV) ?component_mx_id. +exists Ms => // M simM; have [modM nzM minM] := simM. +have sMV: (M <= V)%MS. + apply: contraFT haveU => not_sMV; apply/satP/Exists_rowP=> //. + exists (mxvec M); split; first by apply/ev_sub0; rewrite !ev mxvecK submx0. + split; first by apply/ev_mod; rewrite !ev mxvecK. + apply/Exists_rowP=> // [[w]]. + apply/GRing.qf_evalP; rewrite /= ?submx_form_qf // !ev /= mxvecK submx0. + rewrite -nz_row_eq0 -(cyclic_mx_eq0 rG); set W := cyclic_mx _ _. + apply: contra not_sMV => /and3P[nzW Vw Mw]. + have{Vw Mw} [sWV sWM]: (W <= V /\ W <= M)%MS. + rewrite !cyclic_mx_sub ?(submx_trans (nz_row_sub _)) //. + by rewrite sumsmx_module // => M' _; exact: component_mx_module. + by rewrite (submx_trans _ sWV) // minM ?cyclic_mx_module. +wlog sG: / socleType rG by exact: socle_exists. +have sVS: (V <= \sum_(W : sG | has (fun Mi => Mi <= W) Ms) W)%MS. + rewrite [V](big_nth 0) big_mkord; apply/sumsmx_subP=> i _. + set Mi := Ms`_i; have MsMi: Mi \in Ms by exact: mem_nth. + have simMi := simMs _ MsMi; have S_Mi := component_socle sG simMi. + rewrite (sumsmx_sup (PackSocle S_Mi)) ?PackSocleK //. + by apply/hasP; exists Mi; rewrite ?component_mx_id. +have [W MsW isoWM] := subSocle_iso simM (submx_trans sMV sVS). +have [Mi MsMi sMiW] := hasP MsW; apply/hasP; exists Mi => //. +have [simMi simW] := (simMs _ MsMi, socle_simple W); apply/mxsimple_isoP=> //. +exact: mx_iso_trans (mx_iso_sym isoWM) (component_mx_iso simW simMi sMiW). +Qed. + +End DecideRed. + +(* Change of representation field (by tensoring) *) +Section ChangeOfField. + +Variables (aF rF : fieldType) (f : {rmorphism aF -> rF}). +Local Notation "A ^f" := (map_mx (GRing.RMorphism.apply f) A) : ring_scope. +Variables (gT : finGroupType) (G : {group gT}). + +Section OneRepresentation. + +Variables (n : nat) (rG : mx_representation aF G n). +Local Notation rGf := (map_repr f rG). + +Lemma map_rfix_mx H : (rfix_mx rG H)^f = rfix_mx rGf H. +Proof. +rewrite map_kermx //; congr (kermx _); apply: map_lin1_mx => //= v. +rewrite map_mxvec map_mxM; congr (mxvec (_ *m _)); last first. + by apply: map_lin1_mx => //= u; rewrite map_mxM map_vec_mx. +apply/row_matrixP=> i. +by rewrite -map_row !rowK map_mxvec map_mx_sub map_mx1. +Qed. + +Lemma rcent_map A : rcent rGf A^f = rcent rG A. +Proof. +by apply/setP=> x; rewrite !inE -!map_mxM inj_eq //; exact: map_mx_inj. +Qed. + +Lemma rstab_map m (U : 'M_(m, n)) : rstab rGf U^f = rstab rG U. +Proof. +by apply/setP=> x; rewrite !inE -!map_mxM inj_eq //; exact: map_mx_inj. +Qed. + +Lemma rstabs_map m (U : 'M_(m, n)) : rstabs rGf U^f = rstabs rG U. +Proof. by apply/setP=> x; rewrite !inE -!map_mxM ?map_submx. Qed. + +Lemma centgmx_map A : centgmx rGf A^f = centgmx rG A. +Proof. by rewrite /centgmx rcent_map. Qed. + +Lemma mxmodule_map m (U : 'M_(m, n)) : mxmodule rGf U^f = mxmodule rG U. +Proof. by rewrite /mxmodule rstabs_map. Qed. + +Lemma mxsimple_map (U : 'M_n) : mxsimple rGf U^f -> mxsimple rG U. +Proof. +case; rewrite map_mx_eq0 // mxmodule_map // => modU nzU minU. +split=> // V modV sVU nzV; rewrite -(map_submx f). +by rewrite (minU V^f) //= ?mxmodule_map ?map_mx_eq0 // map_submx. +Qed. + +Lemma mx_irr_map : mx_irreducible rGf -> mx_irreducible rG. +Proof. by move=> irrGf; apply: mxsimple_map; rewrite map_mx1. Qed. + +Lemma rker_map : rker rGf = rker rG. +Proof. by rewrite /rker -rstab_map map_mx1. Qed. + +Lemma map_mx_faithful : mx_faithful rGf = mx_faithful rG. +Proof. by rewrite /mx_faithful rker_map. Qed. + +Lemma map_mx_abs_irr : + mx_absolutely_irreducible rGf = mx_absolutely_irreducible rG. +Proof. +by rewrite /mx_absolutely_irreducible -map_enveloping_algebra_mx row_full_map. +Qed. + +End OneRepresentation. + +Lemma mx_rsim_map n1 n2 rG1 rG2 : + @mx_rsim _ _ G n1 rG1 n2 rG2 -> mx_rsim (map_repr f rG1) (map_repr f rG2). +Proof. +case=> g eqn12 inj_g hom_g. +by exists g^f => // [|x Gx]; rewrite ?row_free_map // -!map_mxM ?hom_g. +Qed. + +Lemma map_section_repr n (rG : mx_representation aF G n) rGf U V + (modU : mxmodule rG U) (modV : mxmodule rG V) + (modUf : mxmodule rGf U^f) (modVf : mxmodule rGf V^f) : + map_repr f rG =1 rGf -> + mx_rsim (map_repr f (section_repr modU modV)) (section_repr modUf modVf). +Proof. +move=> def_rGf; set VU := <<_>>%MS. +pose valUV := val_factmod (val_submod (1%:M : 'M[aF]_(\rank VU))). +have sUV_Uf: (valUV^f <= U^f + V^f)%MS. + rewrite -map_addsmx map_submx; apply: submx_trans (proj_factmodS _ _). + by rewrite val_factmodS val_submod1 genmxE. +exists (in_submod _ (in_factmod U^f valUV^f)) => [||x Gx]. +- rewrite !genmxE -(mxrank_map f) map_mxM map_col_base. + by case: (\rank (cokermx U)) / (mxrank_map _ _); rewrite map_cokermx. +- rewrite -kermx_eq0 -submx0; apply/rV_subP=> u. + rewrite (sameP sub_kermxP eqP) submx0 -val_submod_eq0. + rewrite val_submodE -mulmxA -val_submodE in_submodK; last first. + by rewrite genmxE -(in_factmod_addsK _ V^f) submxMr. + rewrite in_factmodE mulmxA -in_factmodE in_factmod_eq0. + move/(submxMr (in_factmod U 1%:M *m in_submod VU 1%:M)^f). + rewrite -mulmxA -!map_mxM //; do 2!rewrite mulmxA -in_factmodE -in_submodE. + rewrite val_factmodK val_submodK map_mx1 mulmx1. + have ->: in_factmod U U = 0 by apply/eqP; rewrite in_factmod_eq0. + by rewrite linear0 map_mx0 eqmx0 submx0. +rewrite {1}in_submodE mulmxA -in_submodE -in_submodJ; last first. + by rewrite genmxE -(in_factmod_addsK _ V^f) submxMr. +congr (in_submod _ _); rewrite -in_factmodJ // in_factmodE mulmxA -in_factmodE. +apply/eqP; rewrite -subr_eq0 -def_rGf -!map_mxM -linearB in_factmod_eq0. +rewrite -map_mx_sub map_submx -in_factmod_eq0 linearB. +rewrite /= (in_factmodJ modU) // val_factmodK. +rewrite [valUV]val_factmodE mulmxA -val_factmodE val_factmodK. +rewrite -val_submodE in_submodK ?subrr //. +by rewrite mxmodule_trans ?section_module // val_submod1. +Qed. + +Lemma map_regular_subseries U i (modU : mx_subseries (regular_repr aF G) U) + (modUf : mx_subseries (regular_repr rF G) [seq M^f | M <- U]) : + mx_rsim (map_repr f (subseries_repr i modU)) (subseries_repr i modUf). +Proof. +set mf := map _ in modUf *; rewrite /subseries_repr. +do 2!move: (mx_subseries_module' _ _) (mx_subseries_module _ _). +have mf_i V: nth 0^f (mf V) i = (V`_i)^f. + case: (ltnP i (size V)) => [ltiV | leVi]; first exact: nth_map. + by rewrite !nth_default ?size_map. +rewrite -(map_mx0 f) mf_i (mf_i (0 :: U)) => modUi'f modUif modUi' modUi. +by apply: map_section_repr; exact: map_regular_repr. +Qed. + +Lemma extend_group_splitting_field : + group_splitting_field aF G -> group_splitting_field rF G. +Proof. +move=> splitG n rG irrG. +have modU0: all ((mxmodule (regular_repr aF G)) #|G|) [::] by []. +apply: (mx_Schreier modU0 _) => // [[U [compU lastU _]]]; have [modU _]:= compU. +pose Uf := map ((map_mx f) _ _) U. +have{lastU} lastUf: (last 0 Uf :=: 1%:M)%MS. + by rewrite -(map_mx0 f) -(map_mx1 f) last_map; exact/map_eqmx. +have modUf: mx_subseries (regular_repr rF G) Uf. + rewrite /mx_subseries all_map; apply: etrans modU; apply: eq_all => Ui /=. + rewrite -mxmodule_map; apply: eq_subset_r => x. + by rewrite !inE map_regular_repr. +have absUf i: i < size U -> mx_absolutely_irreducible (subseries_repr i modUf). + move=> lt_i_U; rewrite -(mx_rsim_abs_irr (map_regular_subseries i modU _)). + rewrite map_mx_abs_irr; apply: splitG. + by apply: mx_rsim_irr (mx_series_repr_irr compU lt_i_U); exact: section_eqmx. +have compUf: mx_composition_series (regular_repr rF G) Uf. + split=> // i; rewrite size_map => ltiU. + move/max_submodP: (mx_abs_irrW (absUf i ltiU)); apply. + rewrite -{2}(map_mx0 f) -map_cons !(nth_map 0) ?leqW //. + by rewrite map_submx // ltmxW // (pathP _ (mx_series_lt compU)). +have [[i ltiU] simUi] := rsim_regular_series irrG compUf lastUf. +have{simUi} simUi: mx_rsim rG (subseries_repr i modUf). + by apply: mx_rsim_trans simUi _; exact: section_eqmx. +by rewrite (mx_rsim_abs_irr simUi) absUf; rewrite size_map in ltiU. +Qed. + +End ChangeOfField. + +(* Construction of a splitting field FA of an irreducible representation, for *) +(* a matrix A in the centraliser of the representation. FA is the row-vector *) +(* space of the matrix algebra generated by A with basis 1, A, ..., A ^+ d.-1 *) +(* or, equivalently, the polynomials in {poly F} taken mod the (irreducible) *) +(* minimal polynomial pA of A (of degree d). *) +(* The details of the construction of FA are encapsulated in a submodule. *) +Module Import MatrixGenField. + +Section GenField. + +Variables (F : fieldType) (gT : finGroupType) (G : {group gT}) (n' : nat). +Local Notation n := n'.+1. +Variables (rG : mx_representation F G n) (A : 'M[F]_n). + +Local Notation d := (degree_mxminpoly A). +Local Notation Ad := (powers_mx A d). +Local Notation pA := (mxminpoly A). +Let d_gt0 := mxminpoly_nonconstant A. +Local Notation irr := mx_irreducible. + +Record gen_of (irrG : irr rG) (cGA : centgmx rG A) := Gen {rVval : 'rV[F]_d}. +Prenex Implicits rVval. + +Hypotheses (irrG : irr rG) (cGA : centgmx rG A). + +Notation FA := (gen_of irrG cGA). +Let inFA := Gen irrG cGA. + +Canonical gen_subType := Eval hnf in [newType for @rVval irrG cGA]. +Definition gen_eqMixin := Eval hnf in [eqMixin of FA by <:]. +Canonical gen_eqType := Eval hnf in EqType FA gen_eqMixin. +Definition gen_choiceMixin := [choiceMixin of FA by <:]. +Canonical gen_choiceType := Eval hnf in ChoiceType FA gen_choiceMixin. + +Definition gen0 := inFA 0. +Definition genN (x : FA) := inFA (- val x). +Definition genD (x y : FA) := inFA (val x + val y). + +Lemma gen_addA : associative genD. +Proof. by move=> x y z; apply: val_inj; rewrite /= addrA. Qed. + +Lemma gen_addC : commutative genD. +Proof. by move=> x y; apply: val_inj; rewrite /= addrC. Qed. + +Lemma gen_add0r : left_id gen0 genD. +Proof. by move=> x; apply: val_inj; rewrite /= add0r. Qed. + +Lemma gen_addNr : left_inverse gen0 genN genD. +Proof. by move=> x; apply: val_inj; rewrite /= addNr. Qed. + +Definition gen_zmodMixin := ZmodMixin gen_addA gen_addC gen_add0r gen_addNr. +Canonical gen_zmodType := Eval hnf in ZmodType FA gen_zmodMixin. + +Definition pval (x : FA) := rVpoly (val x). + +Definition mxval (x : FA) := horner_mx A (pval x). + +Definition gen (x : F) := inFA (poly_rV x%:P). + +Lemma genK x : mxval (gen x) = x%:M. +Proof. +by rewrite /mxval [pval _]poly_rV_K ?horner_mx_C // size_polyC; case: (x != 0). +Qed. + +Lemma mxval_inj : injective mxval. +Proof. exact: inj_comp (@horner_rVpoly_inj _ _ A) val_inj. Qed. + +Lemma mxval0 : mxval 0 = 0. +Proof. by rewrite /mxval [pval _]raddf0 rmorph0. Qed. + +Lemma mxvalN : {morph mxval : x / - x}. +Proof. by move=> x; rewrite /mxval [pval _]raddfN rmorphN. Qed. + +Lemma mxvalD : {morph mxval : x y / x + y}. +Proof. by move=> x y; rewrite /mxval [pval _]raddfD rmorphD. Qed. + +Definition mxval_sum := big_morph mxval mxvalD mxval0. + +Definition gen1 := inFA (poly_rV 1). +Definition genM x y := inFA (poly_rV (pval x * pval y %% pA)). +Definition genV x := inFA (poly_rV (mx_inv_horner A (mxval x)^-1)). + +Lemma mxval_gen1 : mxval gen1 = 1%:M. +Proof. by rewrite /mxval [pval _]poly_rV_K ?size_poly1 // horner_mx_C. Qed. + +Lemma mxval_genM : {morph mxval : x y / genM x y >-> x *m y}. +Proof. +move=> x y; rewrite /mxval [pval _]poly_rV_K ?size_mod_mxminpoly //. +by rewrite -horner_mxK mx_inv_hornerK ?horner_mx_mem // rmorphM. +Qed. + +Lemma mxval_genV : {morph mxval : x / genV x >-> invmx x}. +Proof. +move=> x; rewrite /mxval [pval _]poly_rV_K ?size_poly ?mx_inv_hornerK //. +pose m B : 'M[F]_(n * n) := lin_mx (mulmxr B); set B := mxval x. +case uB: (B \is a GRing.unit); last by rewrite invr_out ?uB ?horner_mx_mem. +have defAd: Ad = Ad *m m B *m m B^-1. + apply/row_matrixP=> i. + by rewrite !row_mul mul_rV_lin /= mx_rV_lin /= mulmxK ?vec_mxK. +rewrite -[B^-1]mul1mx -(mul_vec_lin (mulmxr_linear _ _)) defAd submxMr //. +rewrite -mxval_gen1 (submx_trans (horner_mx_mem _ _)) // {1}defAd. +rewrite -(geq_leqif (mxrank_leqif_sup _)) ?mxrankM_maxl // -{}defAd. +apply/row_subP=> i; rewrite row_mul rowK mul_vec_lin /= -{2}[A]horner_mx_X. +by rewrite -rmorphX mulmxE -rmorphM horner_mx_mem. +Qed. + +Lemma gen_mulA : associative genM. +Proof. by move=> x y z; apply: mxval_inj; rewrite !mxval_genM mulmxA. Qed. + +Lemma gen_mulC : commutative genM. +Proof. by move=> x y; rewrite /genM mulrC. Qed. + +Lemma gen_mul1r : left_id gen1 genM. +Proof. by move=> x; apply: mxval_inj; rewrite mxval_genM mxval_gen1 mul1mx. Qed. + +Lemma gen_mulDr : left_distributive genM +%R. +Proof. +by move=> x y z; apply: mxval_inj; rewrite !(mxvalD, mxval_genM) mulmxDl. +Qed. + +Lemma gen_ntriv : gen1 != 0. +Proof. by rewrite -(inj_eq mxval_inj) mxval_gen1 mxval0 oner_eq0. Qed. + +Definition gen_ringMixin := + ComRingMixin gen_mulA gen_mulC gen_mul1r gen_mulDr gen_ntriv. +Canonical gen_ringType := Eval hnf in RingType FA gen_ringMixin. +Canonical gen_comRingType := Eval hnf in ComRingType FA gen_mulC. + +Lemma mxval1 : mxval 1 = 1%:M. Proof. exact: mxval_gen1. Qed. + +Lemma mxvalM : {morph mxval : x y / x * y >-> x *m y}. +Proof. exact: mxval_genM. Qed. + +Lemma mxval_sub : additive mxval. +Proof. by move=> x y; rewrite mxvalD mxvalN. Qed. +Canonical mxval_additive := Additive mxval_sub. + +Lemma mxval_is_multiplicative : multiplicative mxval. +Proof. by split; [exact: mxvalM | exact: mxval1]. Qed. +Canonical mxval_rmorphism := AddRMorphism mxval_is_multiplicative. + +Lemma mxval_centg x : centgmx rG (mxval x). +Proof. +rewrite [mxval _]horner_rVpoly -memmx_cent_envelop vec_mxK {x}mulmx_sub //. +apply/row_subP=> k; rewrite rowK memmx_cent_envelop; apply/centgmxP => g Gg /=. +by rewrite !mulmxE commrX // /GRing.comm -mulmxE (centgmxP cGA). +Qed. + +Lemma gen_mulVr : GRing.Field.axiom genV. +Proof. +move=> x; rewrite -(inj_eq mxval_inj) mxval0. +move/(mx_Schur irrG (mxval_centg x)) => u_x. +by apply: mxval_inj; rewrite mxvalM mxval_genV mxval1 mulVmx. +Qed. + +Lemma gen_invr0 : genV 0 = 0. +Proof. by apply: mxval_inj; rewrite mxval_genV !mxval0 -{2}invr0. Qed. + +Definition gen_unitRingMixin := FieldUnitMixin gen_mulVr gen_invr0. +Canonical gen_unitRingType := Eval hnf in UnitRingType FA gen_unitRingMixin. +Canonical gen_comUnitRingType := Eval hnf in [comUnitRingType of FA]. +Definition gen_fieldMixin := + @FieldMixin _ _ _ _ : GRing.Field.mixin_of gen_unitRingType. +Definition gen_idomainMixin := FieldIdomainMixin gen_fieldMixin. +Canonical gen_idomainType := Eval hnf in IdomainType FA gen_idomainMixin. +Canonical gen_fieldType := Eval hnf in FieldType FA gen_fieldMixin. + +Lemma mxvalV : {morph mxval : x / x^-1 >-> invmx x}. +Proof. exact: mxval_genV. Qed. + +Lemma gen_is_rmorphism : rmorphism gen. +Proof. +split=> [x y|]; first by apply: mxval_inj; rewrite genK !rmorphB /= !genK. +by split=> // x y; apply: mxval_inj; rewrite genK !rmorphM /= !genK. +Qed. +Canonical gen_additive := Additive gen_is_rmorphism. +Canonical gen_rmorphism := RMorphism gen_is_rmorphism. + +(* The generated field contains a root of the minimal polynomial (in some *) +(* cases we want to use the construction solely for that purpose). *) + +Definition groot := inFA (poly_rV ('X %% pA)). + +Lemma mxval_groot : mxval groot = A. +Proof. +rewrite /mxval [pval _]poly_rV_K ?size_mod_mxminpoly // -horner_mxK. +by rewrite mx_inv_hornerK ?horner_mx_mem // horner_mx_X. +Qed. + +Lemma mxval_grootX k : mxval (groot ^+ k) = A ^+ k. +Proof. by rewrite rmorphX /= mxval_groot. Qed. + +Lemma map_mxminpoly_groot : (map_poly gen pA).[groot] = 0. +Proof. (* The [_ groot] prevents divergence of simpl. *) +apply: mxval_inj; rewrite -horner_map [_ groot]/= mxval_groot mxval0. +rewrite -(mx_root_minpoly A); congr ((_ : {poly _}).[A]). +by apply/polyP=> i; rewrite 3!coef_map; exact: genK. +Qed. + +(* Plugging the extension morphism gen into the ext_repr construction *) +(* yields a (reducible) tensored representation. *) + +Lemma non_linear_gen_reducible : + d > 1 -> mxnonsimple (map_repr gen_rmorphism rG) 1%:M. +Proof. +rewrite ltnNge mxminpoly_linear_is_scalar => Anscal. +pose Af := map_mx gen A; exists (kermx (Af - groot%:M)). +rewrite submx1 kermx_centg_module /=; last first. + apply/centgmxP=> z Gz; rewrite mulmxBl mulmxBr scalar_mxC. + by rewrite -!map_mxM 1?(centgmxP cGA). +rewrite andbC mxrank_ker -subn_gt0 mxrank1 subKn ?rank_leq_row // lt0n. +rewrite mxrank_eq0 subr_eq0; case: eqP => [defAf | _]. + rewrite -(map_mx_is_scalar gen_rmorphism) -/Af in Anscal. + by case/is_scalar_mxP: Anscal; exists groot. +rewrite -mxrank_eq0 mxrank_ker subn_eq0 row_leq_rank. +apply/row_freeP=> [[XA' XAK]]. +have pAf0: (mxminpoly Af).[groot] == 0. + by rewrite mxminpoly_map ?map_mxminpoly_groot. +have{pAf0} [q def_pAf]:= factor_theorem _ _ pAf0. +have q_nz: q != 0. + case: eqP (congr1 (fun p : {poly _} => size p) def_pAf) => // ->. + by rewrite size_mxminpoly mul0r size_poly0. +have qAf0: horner_mx Af q = 0. + rewrite -[_ q]mulr1 -[1]XAK mulrA -{2}(horner_mx_X Af) -(horner_mx_C Af). + by rewrite -rmorphB -rmorphM -def_pAf /= mx_root_minpoly mul0r. +have{qAf0} := dvdp_leq q_nz (mxminpoly_min qAf0); rewrite def_pAf. +by rewrite size_Mmonic ?monicXsubC // polyseqXsubC addn2 ltnn. +Qed. + +(* An alternative to the above, used in the proof of the p-stability of *) +(* groups of odd order, is to reconsider the original vector space as a *) +(* vector space of dimension n / e over FA. This is applicable only if G is *) +(* the largest group represented on the original vector space (i.e., if we *) +(* are not studying a representation of G induced by one of a larger group, *) +(* as in B & G Theorem 2.6 for instance). We can't fully exploit one of the *) +(* benefits of this approach -- that the type domain for the vector space can *) +(* remain unchanged -- because we're restricting ourselves to row matrices; *) +(* we have to use explicit bijections to convert between the two views. *) + +Definition subbase m (B : 'rV_m) : 'M_(m * d, n) := + \matrix_ik mxvec (\matrix_(i, k) (row (B 0 i) (A ^+ k))) 0 ik. + +Lemma gen_dim_ex_proof : exists m, [exists B : 'rV_m, row_free (subbase B)]. +Proof. by exists 0%N; apply/existsP; exists 0. Qed. + +Lemma gen_dim_ub_proof m : + [exists B : 'rV_m, row_free (subbase B)] -> (m <= n)%N. +Proof. +case/existsP=> B /eqnP def_md. +by rewrite (leq_trans _ (rank_leq_col (subbase B))) // def_md leq_pmulr. +Qed. + +Definition gen_dim := ex_maxn gen_dim_ex_proof gen_dim_ub_proof. +Notation m := gen_dim. + +Definition gen_base : 'rV_m := odflt 0 [pick B | row_free (subbase B)]. +Definition base := subbase gen_base. + +Lemma base_free : row_free base. +Proof. +rewrite /base /gen_base /m; case: pickP => //; case: ex_maxnP => m_max. +by case/existsP=> B Bfree _ no_free; rewrite no_free in Bfree. +Qed. + +Lemma base_full : row_full base. +Proof. +rewrite /row_full (eqnP base_free) /m; case: ex_maxnP => m. +case/existsP=> /= B /eqnP Bfree m_max; rewrite -Bfree eqn_leq rank_leq_col. +rewrite -{1}(mxrank1 F n) mxrankS //; apply/row_subP=> j; set u := row _ _. +move/implyP: {m_max}(m_max m.+1); rewrite ltnn implybF. +apply: contraR => nBj; apply/existsP. +exists (row_mx (const_mx j : 'M_1) B); rewrite -row_leq_rank. +pose Bj := Ad *m lin1_mx (mulmx u \o vec_mx). +have rBj: \rank Bj = d. + apply/eqP; rewrite eqn_leq rank_leq_row -subn_eq0 -mxrank_ker mxrank_eq0 /=. + apply/rowV0P=> v /sub_kermxP; rewrite mulmxA mul_rV_lin1 /=. + rewrite -horner_rVpoly; pose x := inFA v; rewrite -/(mxval x). + have [[] // | nzx /(congr1 (mulmx^~ (mxval x^-1)))] := eqVneq x 0. + rewrite mul0mx /= -mulmxA -mxvalM divff // mxval1 mulmx1. + by move/rowP/(_ j)/eqP; rewrite !mxE !eqxx oner_eq0. +rewrite {1}mulSn -Bfree -{1}rBj {rBj} -mxrank_disjoint_sum. + rewrite mxrankS // addsmx_sub -[m.+1]/(1 + m)%N; apply/andP; split. + apply/row_subP=> k; rewrite row_mul mul_rV_lin1 /=. + apply: eq_row_sub (mxvec_index (lshift _ 0) k) _. + by rewrite !rowK mxvecK mxvecE mxE row_mxEl mxE -row_mul mul1mx. + apply/row_subP; case/mxvec_indexP=> i k. + apply: eq_row_sub (mxvec_index (rshift 1 i) k) _. + by rewrite !rowK !mxvecE 2!mxE row_mxEr. +apply/eqP/rowV0P=> v; rewrite sub_capmx => /andP[/submxP[w]]. +set x := inFA w; rewrite {Bj}mulmxA mul_rV_lin1 /= -horner_rVpoly -/(mxval x). +have [-> | nzx ->] := eqVneq x 0; first by rewrite mxval0 mulmx0. +move/(submxMr (mxval x^-1)); rewrite -mulmxA -mxvalM divff {nzx}//. +rewrite mxval1 mulmx1 => Bx'j; rewrite (submx_trans Bx'j) in nBj => {Bx'j} //. +apply/row_subP; case/mxvec_indexP=> i k. +rewrite row_mul rowK mxvecE mxE rowE -mulmxA. +have ->: A ^+ k *m mxval x^-1 = mxval (groot ^+ k / x). + by rewrite mxvalM rmorphX /= mxval_groot. +rewrite [mxval _]horner_rVpoly; move: {k u x}(val _) => u. +rewrite (mulmx_sum_row u) !linear_sum summx_sub //= => k _. +rewrite !linearZ scalemx_sub //= rowK mxvecK -rowE. +by apply: eq_row_sub (mxvec_index i k) _; rewrite rowK mxvecE mxE. +Qed. + +Lemma gen_dim_factor : (m * d)%N = n. +Proof. by rewrite -(eqnP base_free) (eqnP base_full). Qed. + +Lemma gen_dim_gt0 : m > 0. +Proof. by case: posnP gen_dim_factor => // ->. Qed. + +Section Bijection. + +Variable m1 : nat. + +Definition in_gen (W : 'M[F]_(m1, n)) : 'M[FA]_(m1, m) := + \matrix_(i, j) inFA (row j (vec_mx (row i W *m pinvmx base))). + +Definition val_gen (W : 'M[FA]_(m1, m)) : 'M[F]_(m1, n) := + \matrix_i (mxvec (\matrix_j val (W i j)) *m base). + +Lemma in_genK : cancel in_gen val_gen. +Proof. +move=> W; apply/row_matrixP=> i; rewrite rowK; set w := row i W. +have b_w: (w <= base)%MS by rewrite submx_full ?base_full. +rewrite -{b_w}(mulmxKpV b_w); congr (_ *m _). +by apply/rowP; case/mxvec_indexP=> j k; rewrite mxvecE !mxE. +Qed. + +Lemma val_genK : cancel val_gen in_gen. +Proof. +move=> W; apply/matrixP=> i j; apply: val_inj; rewrite mxE /= rowK. +case/row_freeP: base_free => B' BB'; rewrite -[_ *m _]mulmx1 -BB' mulmxA. +by rewrite mulmxKpV ?submxMl // -mulmxA BB' mulmx1 mxvecK rowK. +Qed. + +Lemma in_gen0 : in_gen 0 = 0. +Proof. by apply/matrixP=> i j; rewrite !mxE !(mul0mx, linear0). Qed. + +Lemma val_gen0 : val_gen 0 = 0. +Proof. by apply: (canLR in_genK); rewrite in_gen0. Qed. + +Lemma in_genN : {morph in_gen : W / - W}. +Proof. +move=> W; apply/matrixP=> i j; apply: val_inj. +by rewrite !mxE !(mulNmx, linearN). +Qed. + +Lemma val_genN : {morph val_gen : W / - W}. +Proof. by move=> W; apply: (canLR in_genK); rewrite in_genN val_genK. Qed. + +Lemma in_genD : {morph in_gen : U V / U + V}. +Proof. +move=> U V; apply/matrixP=> i j; apply: val_inj. +by rewrite !mxE !(mulmxDl, linearD). +Qed. + +Lemma val_genD : {morph val_gen : U V / U + V}. +Proof. by move=> U V; apply: (canLR in_genK); rewrite in_genD !val_genK. Qed. + +Definition in_gen_sum := big_morph in_gen in_genD in_gen0. +Definition val_gen_sum := big_morph val_gen val_genD val_gen0. + +Lemma in_genZ a : {morph in_gen : W / a *: W >-> gen a *: W}. +Proof. +move=> W; apply/matrixP=> i j; apply: mxval_inj. +rewrite !mxE mxvalM genK ![mxval _]horner_rVpoly /=. +by rewrite mul_scalar_mx !(I, scalemxAl, linearZ). +Qed. + +End Bijection. + +Prenex Implicits val_genK in_genK. + +Lemma val_gen_rV (w : 'rV_m) : + val_gen w = mxvec (\matrix_j val (w 0 j)) *m base. +Proof. by apply/rowP=> j; rewrite mxE. Qed. + +Section Bijection2. + +Variable m1 : nat. + +Lemma val_gen_row W (i : 'I_m1) : val_gen (row i W) = row i (val_gen W). +Proof. +rewrite val_gen_rV rowK; congr (mxvec _ *m _). +by apply/matrixP=> j k; rewrite !mxE. +Qed. + +Lemma in_gen_row W (i : 'I_m1) : in_gen (row i W) = row i (in_gen W). +Proof. by apply: (canLR val_genK); rewrite val_gen_row in_genK. Qed. + +Lemma row_gen_sum_mxval W (i : 'I_m1) : + row i (val_gen W) = \sum_j row (gen_base 0 j) (mxval (W i j)). +Proof. +rewrite -val_gen_row [row i W]row_sum_delta val_gen_sum. +apply: eq_bigr => /= j _; rewrite mxE; move: {W i}(W i j) => x. +have ->: x = \sum_k gen (val x 0 k) * inFA (delta_mx 0 k). + case: x => u; apply: mxval_inj; rewrite {1}[u]row_sum_delta. + rewrite mxval_sum [mxval _]horner_rVpoly mulmx_suml linear_sum /=. + apply: eq_bigr => k _; rewrite mxvalM genK [mxval _]horner_rVpoly /=. + by rewrite mul_scalar_mx -scalemxAl linearZ. +rewrite scaler_suml val_gen_sum mxval_sum linear_sum; apply: eq_bigr => k _. +rewrite mxvalM genK mul_scalar_mx linearZ [mxval _]horner_rVpoly /=. +rewrite -scalerA; apply: (canLR in_genK); rewrite in_genZ; congr (_ *: _). +apply: (canRL val_genK); transitivity (row (mxvec_index j k) base); last first. + by rewrite -rowE rowK mxvecE mxE rowK mxvecK. +rewrite rowE -mxvec_delta -[val_gen _](row_id 0) rowK /=; congr (mxvec _ *m _). +apply/row_matrixP=> j'; rewrite rowK !mxE mulr_natr rowE mul_delta_mx_cond. +by rewrite !mulrb (fun_if rVval). +Qed. + +Lemma val_genZ x : {morph @val_gen m1 : W / x *: W >-> W *m mxval x}. +Proof. +move=> W; apply/row_matrixP=> i; rewrite row_mul !row_gen_sum_mxval. +by rewrite mulmx_suml; apply: eq_bigr => j _; rewrite mxE mulrC mxvalM row_mul. +Qed. + +End Bijection2. + +Lemma submx_in_gen m1 m2 (U : 'M_(m1, n)) (V : 'M_(m2, n)) : + (U <= V -> in_gen U <= in_gen V)%MS. +Proof. +move=> sUV; apply/row_subP=> i; rewrite -in_gen_row. +case/submxP: (row_subP sUV i) => u ->{i}. +rewrite mulmx_sum_row in_gen_sum summx_sub // => j _. +by rewrite in_genZ in_gen_row scalemx_sub ?row_sub. +Qed. + +Lemma submx_in_gen_eq m1 m2 (U : 'M_(m1, n)) (V : 'M_(m2, n)) : + (V *m A <= V -> (in_gen U <= in_gen V) = (U <= V))%MS. +Proof. +move=> sVA_V; apply/idP/idP=> siUV; last exact: submx_in_gen. +apply/row_subP=> i; rewrite -[row i U]in_genK in_gen_row. +case/submxP: (row_subP siUV i) => u ->{i U siUV}. +rewrite mulmx_sum_row val_gen_sum summx_sub // => j _. +rewrite val_genZ val_gen_row in_genK rowE -mulmxA mulmx_sub //. +rewrite [mxval _]horner_poly mulmx_sumr summx_sub // => [[k _]] _ /=. +rewrite mulmxA mul_mx_scalar -scalemxAl scalemx_sub {u j}//. +elim: k => [|k IHk]; first by rewrite mulmx1. +by rewrite exprSr mulmxA (submx_trans (submxMr A IHk)). +Qed. + +Definition gen_mx g := \matrix_i in_gen (row (gen_base 0 i) (rG g)). + +Let val_genJmx m : + {in G, forall g, {morph @val_gen m : W / W *m gen_mx g >-> W *m rG g}}. +Proof. +move=> g Gg /= W; apply/row_matrixP=> i; rewrite -val_gen_row !row_mul. +rewrite mulmx_sum_row val_gen_sum row_gen_sum_mxval mulmx_suml. +apply: eq_bigr => /= j _; rewrite val_genZ rowK in_genK mxE -!row_mul. +by rewrite (centgmxP (mxval_centg _)). +Qed. + +Lemma gen_mx_repr : mx_repr G gen_mx. +Proof. +split=> [|g h Gg Gh]; apply: (can_inj val_genK). + by rewrite -[gen_mx 1]mul1mx val_genJmx // repr_mx1 mulmx1. +rewrite {1}[val_gen]lock -[gen_mx g]mul1mx !val_genJmx // -mulmxA -repr_mxM //. +by rewrite -val_genJmx ?groupM ?mul1mx -?lock. +Qed. +Canonical gen_repr := MxRepresentation gen_mx_repr. +Local Notation rGA := gen_repr. + +Lemma val_genJ m : + {in G, forall g, {morph @val_gen m : W / W *m rGA g >-> W *m rG g}}. +Proof. exact: val_genJmx. Qed. + +Lemma in_genJ m : + {in G, forall g, {morph @in_gen m : v / v *m rG g >-> v *m rGA g}}. +Proof. +by move=> g Gg /= v; apply: (canLR val_genK); rewrite val_genJ ?in_genK. +Qed. + +Lemma rfix_gen (H : {set gT}) : + H \subset G -> (rfix_mx rGA H :=: in_gen (rfix_mx rG H))%MS. +Proof. +move/subsetP=> sHG; apply/eqmxP/andP; split; last first. + by apply/rfix_mxP=> g Hg; rewrite -in_genJ ?sHG ?rfix_mx_id. +rewrite -[rfix_mx rGA H]val_genK; apply: submx_in_gen. +by apply/rfix_mxP=> g Hg; rewrite -val_genJ ?rfix_mx_id ?sHG. +Qed. + +Definition rowval_gen m1 U := + <<\matrix_ik + mxvec (\matrix_(i < m1, k < d) (row i (val_gen U) *m A ^+ k)) 0 ik>>%MS. + +Lemma submx_rowval_gen m1 m2 (U : 'M_(m1, n)) (V : 'M_(m2, m)) : + (U <= rowval_gen V)%MS = (in_gen U <= V)%MS. +Proof. +rewrite genmxE; apply/idP/idP=> sUV. + apply: submx_trans (submx_in_gen sUV) _. + apply/row_subP; case/mxvec_indexP=> i k; rewrite -in_gen_row rowK mxvecE mxE. + rewrite -mxval_grootX -val_gen_row -val_genZ val_genK scalemx_sub //. + exact: row_sub. +rewrite -[U]in_genK; case/submxP: sUV => u ->{U}. +apply/row_subP=> i0; rewrite -val_gen_row row_mul; move: {i0 u}(row _ u) => u. +rewrite mulmx_sum_row val_gen_sum summx_sub // => i _. +rewrite val_genZ [mxval _]horner_rVpoly [_ *m Ad]mulmx_sum_row. +rewrite !linear_sum summx_sub // => k _. +rewrite !linearZ scalemx_sub {u}//= rowK mxvecK val_gen_row. +by apply: (eq_row_sub (mxvec_index i k)); rewrite rowK mxvecE mxE. +Qed. + +Lemma rowval_genK m1 (U : 'M_(m1, m)) : (in_gen (rowval_gen U) :=: U)%MS. +Proof. +apply/eqmxP; rewrite -submx_rowval_gen submx_refl /=. +by rewrite -{1}[U]val_genK submx_in_gen // submx_rowval_gen val_genK. +Qed. + +Lemma rowval_gen_stable m1 (U : 'M_(m1, m)) : + (rowval_gen U *m A <= rowval_gen U)%MS. +Proof. +rewrite -[A]mxval_groot -{1}[_ U]in_genK -val_genZ. +by rewrite submx_rowval_gen val_genK scalemx_sub // rowval_genK. +Qed. + +Lemma rstab_in_gen m1 (U : 'M_(m1, n)) : rstab rGA (in_gen U) = rstab rG U. +Proof. +apply/setP=> x; rewrite !inE; case Gx: (x \in G) => //=. +by rewrite -in_genJ // (inj_eq (can_inj in_genK)). +Qed. + +Lemma rstabs_in_gen m1 (U : 'M_(m1, n)) : + rstabs rG U \subset rstabs rGA (in_gen U). +Proof. +apply/subsetP=> x; rewrite !inE => /andP[Gx nUx]. +by rewrite -in_genJ Gx // submx_in_gen. +Qed. + +Lemma rstabs_rowval_gen m1 (U : 'M_(m1, m)) : + rstabs rG (rowval_gen U) = rstabs rGA U. +Proof. +apply/setP=> x; rewrite !inE; case Gx: (x \in G) => //=. +by rewrite submx_rowval_gen in_genJ // (eqmxMr _ (rowval_genK U)). +Qed. + +Lemma mxmodule_rowval_gen m1 (U : 'M_(m1, m)) : + mxmodule rG (rowval_gen U) = mxmodule rGA U. +Proof. by rewrite /mxmodule rstabs_rowval_gen. Qed. + +Lemma gen_mx_irr : mx_irreducible rGA. +Proof. +apply/mx_irrP; split=> [|U Umod nzU]; first exact: gen_dim_gt0. +rewrite -sub1mx -rowval_genK -submx_rowval_gen submx_full //. +case/mx_irrP: irrG => _; apply; first by rewrite mxmodule_rowval_gen. +rewrite -(inj_eq (can_inj in_genK)) in_gen0. +by rewrite -mxrank_eq0 rowval_genK mxrank_eq0. +Qed. + +Lemma rker_gen : rker rGA = rker rG. +Proof. +apply/setP=> g; rewrite !inE !mul1mx; case Gg: (g \in G) => //=. +apply/eqP/eqP=> g1; apply/row_matrixP=> i. + by apply: (can_inj in_genK); rewrite rowE in_genJ //= g1 mulmx1 row1. +by apply: (can_inj val_genK); rewrite rowE val_genJ //= g1 mulmx1 row1. +Qed. + +Lemma gen_mx_faithful : mx_faithful rGA = mx_faithful rG. +Proof. by rewrite /mx_faithful rker_gen. Qed. + +End GenField. + +Section DecideGenField. + +Import MatrixFormula. + +Variable F : decFieldType. + +Local Notation False := GRing.False. +Local Notation True := GRing.True. +Local Notation Bool b := (GRing.Bool b%bool). +Local Notation term := (GRing.term F). +Local Notation form := (GRing.formula F). + +Local Notation morphAnd f := ((big_morph f) true andb). + +Variables (gT : finGroupType) (G : {group gT}) (n' : nat). +Local Notation n := n'.+1. +Variables (rG : mx_representation F G n) (A : 'M[F]_n). +Hypotheses (irrG : mx_irreducible rG) (cGA : centgmx rG A). +Local Notation FA := (gen_of irrG cGA). +Local Notation inFA := (Gen irrG cGA). + +Local Notation d := (degree_mxminpoly A). +Let d_gt0 : d > 0 := mxminpoly_nonconstant A. +Local Notation Ad := (powers_mx A d). + +Let mxT (u : 'rV_d) := vec_mx (mulmx_term u (mx_term Ad)). + +Let eval_mxT e u : eval_mx e (mxT u) = mxval (inFA (eval_mx e u)). +Proof. +by rewrite eval_vec_mx eval_mulmx eval_mx_term [mxval _]horner_rVpoly. +Qed. + +Let Ad'T := mx_term (pinvmx Ad). +Let mulT (u v : 'rV_d) := mulmx_term (mxvec (mulmx_term (mxT u) (mxT v))) Ad'T. + +Lemma eval_mulT e u v : + eval_mx e (mulT u v) = val (inFA (eval_mx e u) * inFA (eval_mx e v)). +Proof. +rewrite !(eval_mulmx, eval_mxvec) !eval_mxT eval_mx_term. +by apply: (can_inj (@rVpolyK _ _)); rewrite -mxvalM [rVpoly _]horner_rVpolyK. +Qed. + +Fixpoint gen_term t := match t with +| 'X_k => row_var _ d k +| x%:T => mx_term (val (x : FA)) +| n1%:R => mx_term (val (n1%:R : FA))%R +| t1 + t2 => \row_i (gen_term t1 0%R i + gen_term t2 0%R i) +| - t1 => \row_i (- gen_term t1 0%R i) +| t1 *+ n1 => mulmx_term (mx_term n1%:R%:M)%R (gen_term t1) +| t1 * t2 => mulT (gen_term t1) (gen_term t2) +| t1^-1 => gen_term t1 +| t1 ^+ n1 => iter n1 (mulT (gen_term t1)) (mx_term (val (1%R : FA))) +end%T. + +Definition gen_env (e : seq FA) := row_env (map val e). + +Lemma nth_map_rVval (e : seq FA) j : (map val e)`_j = val e`_j. +Proof. +case: (ltnP j (size e)) => [| leej]; first exact: (nth_map 0 0). +by rewrite !nth_default ?size_map. +Qed. + +Lemma set_nth_map_rVval (e : seq FA) j v : + set_nth 0 (map val e) j v = map val (set_nth 0 e j (inFA v)). +Proof. +apply: (@eq_from_nth _ 0) => [|k _]; first by rewrite !(size_set_nth, size_map). +by rewrite !(nth_map_rVval, nth_set_nth) /= nth_map_rVval [rVval _]fun_if. +Qed. + +Lemma eval_gen_term e t : + GRing.rterm t -> eval_mx (gen_env e) (gen_term t) = val (GRing.eval e t). +Proof. +elim: t => //=. +- by move=> k _; apply/rowP=> i; rewrite !mxE /= nth_row_env nth_map_rVval. +- by move=> x _; rewrite eval_mx_term. +- by move=> x _; rewrite eval_mx_term. +- move=> t1 IH1 t2 IH2 /andP[rt1 rt2]; rewrite -{}IH1 // -{}IH2 //. + by apply/rowP=> k; rewrite !mxE. +- by move=> t1 IH1 rt1; rewrite -{}IH1 //; apply/rowP=> k; rewrite !mxE. +- move=> t1 IH1 n1 rt1; rewrite eval_mulmx eval_mx_term mul_scalar_mx. + by rewrite scaler_nat {}IH1 //; elim: n1 => //= n1 IHn1; rewrite !mulrS IHn1. +- by move=> t1 IH1 t2 IH2 /andP[rt1 rt2]; rewrite eval_mulT IH1 ?IH2. +move=> t1 IH1 n1 /IH1 {IH1}IH1. +elim: n1 => [|n1 IHn1] /=; first by rewrite eval_mx_term. +by rewrite eval_mulT exprS IH1 IHn1. +Qed. + +(* WARNING: Coq will core dump if the Notation Bool is used in the match *) +(* pattern here. *) +Fixpoint gen_form f := match f with +| GRing.Bool b => Bool b +| t1 == t2 => mxrank_form 0 (gen_term (t1 - t2)) +| GRing.Unit t1 => mxrank_form 1 (gen_term t1) +| f1 /\ f2 => gen_form f1 /\ gen_form f2 +| f1 \/ f2 => gen_form f1 \/ gen_form f2 +| f1 ==> f2 => gen_form f1 ==> gen_form f2 +| ~ f1 => ~ gen_form f1 +| ('exists 'X_k, f1) => Exists_row_form d k (gen_form f1) +| ('forall 'X_k, f1) => ~ Exists_row_form d k (~ (gen_form f1)) +end%T. + +Lemma sat_gen_form e f : GRing.rformula f -> + reflect (GRing.holds e f) (GRing.sat (gen_env e) (gen_form f)). +Proof. +have ExP := Exists_rowP; have set_val := set_nth_map_rVval. +elim: f e => //. +- by move=> b e _; exact: (iffP satP). +- rewrite /gen_form => t1 t2 e rt_t; set t := (_ - _)%T. + have:= GRing.qf_evalP (gen_env e) (mxrank_form_qf 0 (gen_term t)). + rewrite eval_mxrank mxrank_eq0 eval_gen_term // => tP. + by rewrite (sameP satP tP) /= subr_eq0 val_eqE; exact: eqP. +- move=> f1 IH1 f2 IH2 s /= /andP[/(IH1 s)f1P /(IH2 s)f2P]. + by apply: (iffP satP) => [[/satP/f1P ? /satP/f2P] | [/f1P/satP ? /f2P/satP]]. +- move=> f1 IH1 f2 IH2 s /= /andP[/(IH1 s)f1P /(IH2 s)f2P]. + by apply: (iffP satP) => /= [] []; + try move/satP; do [move/f1P | move/f2P]; try move/satP; auto. +- move=> f1 IH1 f2 IH2 s /= /andP[/(IH1 s)f1P /(IH2 s)f2P]. + by apply: (iffP satP) => /= implP; + try move/satP; move/f1P; try move/satP; move/implP; + try move/satP; move/f2P; try move/satP. +- move=> f1 IH1 s /= /(IH1 s) f1P. + by apply: (iffP satP) => /= notP; try move/satP; move/f1P; try move/satP. +- move=> k f1 IHf1 s /IHf1 f1P; apply: (iffP satP) => /= [|[[v f1v]]]. + by case/ExP=> // x /satP; rewrite set_val => /f1P; exists (inFA x). + by apply/ExP=> //; exists v; rewrite set_val; apply/satP/f1P. +move=> i f1 IHf1 s /IHf1 f1P; apply: (iffP satP) => /= allf1 => [[v]|]. + apply/f1P; case: satP => // notf1x; case: allf1; apply/ExP=> //. + by exists v; rewrite set_val. +by case/ExP=> //= v []; apply/satP; rewrite set_val; apply/f1P. +Qed. + +Definition gen_sat e f := GRing.sat (gen_env e) (gen_form (GRing.to_rform f)). + +Lemma gen_satP : GRing.DecidableField.axiom gen_sat. +Proof. +move=> e f; have [tor rto] := GRing.to_rformP e f. +exact: (iffP (sat_gen_form e (GRing.to_rform_rformula f))). +Qed. + +Definition gen_decFieldMixin := DecFieldMixin gen_satP. + +Canonical gen_decFieldType := Eval hnf in DecFieldType FA gen_decFieldMixin. + +End DecideGenField. + +Section FiniteGenField. + +Variables (F : finFieldType) (gT : finGroupType) (G : {group gT}) (n' : nat). +Local Notation n := n'.+1. +Variables (rG : mx_representation F G n) (A : 'M[F]_n). +Hypotheses (irrG : mx_irreducible rG) (cGA : centgmx rG A). +Notation FA := (gen_of irrG cGA). + +(* This should be [countMixin of FA by <:]*) +Definition gen_countMixin := (sub_countMixin (gen_subType irrG cGA)). +Canonical gen_countType := Eval hnf in CountType FA gen_countMixin. +Canonical gen_subCountType := Eval hnf in [subCountType of FA]. +Definition gen_finMixin := [finMixin of FA by <:]. +Canonical gen_finType := Eval hnf in FinType FA gen_finMixin. +Canonical gen_subFinType := Eval hnf in [subFinType of FA]. +Canonical gen_finZmodType := Eval hnf in [finZmodType of FA]. +Canonical gen_baseFinGroupType := Eval hnf in [baseFinGroupType of FA for +%R]. +Canonical gen_finGroupType := Eval hnf in [finGroupType of FA for +%R]. +Canonical gen_finRingType := Eval hnf in [finRingType of FA]. +Canonical gen_finComRingType := Eval hnf in [finComRingType of FA]. +Canonical gen_finUnitRingType := Eval hnf in [finUnitRingType of FA]. +Canonical gen_finComUnitRingType := Eval hnf in [finComUnitRingType of FA]. +Canonical gen_finIdomainType := Eval hnf in [finIdomainType of FA]. +Canonical gen_finFieldType := Eval hnf in [finFieldType of FA]. + +Lemma card_gen : #|{:FA}| = (#|F| ^ degree_mxminpoly A)%N. +Proof. by rewrite card_sub card_matrix mul1n. Qed. + +End FiniteGenField. + +End MatrixGenField. + +Canonical gen_subType. +Canonical gen_eqType. +Canonical gen_choiceType. +Canonical gen_countType. +Canonical gen_subCountType. +Canonical gen_finType. +Canonical gen_subFinType. +Canonical gen_zmodType. +Canonical gen_finZmodType. +Canonical gen_baseFinGroupType. +Canonical gen_finGroupType. +Canonical gen_ringType. +Canonical gen_finRingType. +Canonical gen_comRingType. +Canonical gen_finComRingType. +Canonical gen_unitRingType. +Canonical gen_finUnitRingType. +Canonical gen_comUnitRingType. +Canonical gen_finComUnitRingType. +Canonical gen_idomainType. +Canonical gen_finIdomainType. +Canonical gen_fieldType. +Canonical gen_finFieldType. +Canonical gen_decFieldType. + +(* Classical splitting and closure field constructions provide convenient *) +(* packaging for the pointwise construction. *) +Section BuildSplittingField. + +Implicit Type gT : finGroupType. +Implicit Type F : fieldType. + +Lemma group_splitting_field_exists gT (G : {group gT}) F : + classically {Fs : fieldType & {rmorphism F -> Fs} + & group_splitting_field Fs G}. +Proof. +move: F => F0 [] // nosplit; pose nG := #|G|; pose aG F := regular_repr F G. +pose m := nG.+1; pose F := F0; pose U : seq 'M[F]_nG := [::]. +suffices: size U + m <= nG by rewrite ltnn. +have: mx_subseries (aG F) U /\ path ltmx 0 U by []. +pose f : {rmorphism F0 -> F} := [rmorphism of idfun]. +elim: m F U f => [|m IHm] F U f [modU ltU]. + by rewrite addn0 (leq_trans (max_size_mx_series ltU)) ?rank_leq_row. +rewrite addnS ltnNge -implybF; apply/implyP=> le_nG_Um; apply nosplit. +exists F => //; case=> [|n] rG irrG; first by case/mx_irrP: irrG. +apply/idPn=> nabsG; pose cG := ('C(enveloping_algebra_mx rG))%MS. +have{nabsG} [A]: exists2 A, (A \in cG)%MS & ~~ is_scalar_mx A. + apply/has_non_scalar_mxP; rewrite ?scalar_mx_cent // ltnNge. + by apply: contra nabsG; exact: cent_mx_scalar_abs_irr. +rewrite {cG}memmx_cent_envelop -mxminpoly_linear_is_scalar -ltnNge => cGA. +move/(non_linear_gen_reducible irrG cGA). +set F' := gen_fieldType _ _; set rG' := @map_repr _ F' _ _ _ _ rG. +move: F' (gen_rmorphism _ _ : {rmorphism F -> F'}) => F' f' in rG' * => irrG'. +pose U' := [seq map_mx f' Ui | Ui <- U]. +have modU': mx_subseries (aG F') U'. + apply: etrans modU; rewrite /mx_subseries all_map; apply: eq_all => Ui. + rewrite -(mxmodule_map f'); apply: eq_subset_r => x. + by rewrite !inE map_regular_repr. +case: notF; apply: (mx_Schreier modU ltU) => [[V [compV lastV sUV]]]. +have{lastV} [] := rsim_regular_series irrG compV lastV. +have{sUV} defV: V = U. + apply/eqP; rewrite eq_sym -(geq_leqif (size_subseq_leqif sUV)). + rewrite -(leq_add2r m); apply: leq_trans le_nG_Um. + by apply: IHm f _; rewrite (mx_series_lt compV); case: compV. +rewrite {V}defV in compV * => i rsimVi. +apply: (mx_Schreier modU') => [|[V' [compV' _ sUV']]]. + rewrite {modU' compV modU i le_nG_Um rsimVi}/U' -(map_mx0 f'). + by apply: etrans ltU; elim: U 0 => //= Ui U IHU Ui'; rewrite IHU map_ltmx. +have{sUV'} defV': V' = U'; last rewrite {V'}defV' in compV'. + apply/eqP; rewrite eq_sym -(geq_leqif (size_subseq_leqif sUV')) size_map. + rewrite -(leq_add2r m); apply: leq_trans le_nG_Um. + apply: IHm [rmorphism of f' \o f] _. + by rewrite (mx_series_lt compV'); case: compV'. +suffices{irrG'}: mx_irreducible rG' by case/mxsimpleP=> _ _ []. +have ltiU': i < size U' by rewrite size_map. +apply: mx_rsim_irr (mx_rsim_sym _ ) (mx_series_repr_irr compV' ltiU'). +apply: mx_rsim_trans (mx_rsim_map f' rsimVi) _; exact: map_regular_subseries. +Qed. + +Lemma group_closure_field_exists gT F : + classically {Fs : fieldType & {rmorphism F -> Fs} + & group_closure_field Fs gT}. +Proof. +set n := #|{group gT}|. +suffices: classically {Fs : fieldType & {rmorphism F -> Fs} + & forall G : {group gT}, enum_rank G < n -> group_splitting_field Fs G}. +- apply: classic_bind => [[Fs f splitFs]] _ -> //. + by exists Fs => // G; exact: splitFs. +elim: (n) => [|i IHi]; first by move=> _ -> //; exists F => //; exists id. +apply: classic_bind IHi => [[F' f splitF']]. +have [le_n_i _ -> // | lt_i_n] := leqP n i. + by exists F' => // G _; apply: splitF'; exact: leq_trans le_n_i. +have:= @group_splitting_field_exists _ (enum_val (Ordinal lt_i_n)) F'. +apply: classic_bind => [[Fs f' splitFs]] _ -> //. +exists Fs => [|G]; first exact: [rmorphism of (f' \o f)]. +rewrite ltnS leq_eqVlt -{1}[i]/(val (Ordinal lt_i_n)) val_eqE. +case/predU1P=> [defG | ltGi]; first by rewrite -[G]enum_rankK defG. +by apply: (extend_group_splitting_field f'); exact: splitF'. +Qed. + +Lemma group_closure_closed_field (F : closedFieldType) gT : + group_closure_field F gT. +Proof. +move=> G [|n] rG irrG; first by case/mx_irrP: irrG. +apply: cent_mx_scalar_abs_irr => //; rewrite leqNgt. +apply/(has_non_scalar_mxP (scalar_mx_cent _ _)) => [[A cGA nscalA]]. +have [a]: exists a, eigenvalue A a. + pose P := mxminpoly A; pose d := degree_mxminpoly A. + have Pd1: P`_d = 1. + by rewrite -(eqP (mxminpoly_monic A)) /lead_coef size_mxminpoly. + have d_gt0: d > 0 := mxminpoly_nonconstant A. + have [a def_ad] := solve_monicpoly (nth 0 (- P)) d_gt0. + exists a; rewrite eigenvalue_root_min -/P /root -oppr_eq0 -hornerN. + rewrite horner_coef size_opp size_mxminpoly -/d big_ord_recr -def_ad. + by rewrite coefN Pd1 mulN1r /= subrr. +case/negP; rewrite kermx_eq0 row_free_unit (mx_Schur irrG) ?subr_eq0 //. + by rewrite -memmx_cent_envelop -raddfN linearD addmx_sub ?scalar_mx_cent. +by apply: contraNneq nscalA => ->; exact: scalar_mx_is_scalar. +Qed. + +End BuildSplittingField. diff --git a/mathcomp/character/vcharacter.v b/mathcomp/character/vcharacter.v new file mode 100644 index 0000000..3ef364d --- /dev/null +++ b/mathcomp/character/vcharacter.v @@ -0,0 +1,987 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg poly finset. +Require Import fingroup morphism perm automorphism quotient finalg action. +Require Import gproduct zmodp commutator cyclic center pgroup sylow frobenius. +Require Import vector ssrnum ssrint intdiv algC algnum. +Require Import classfun character integral_char. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory Num.Theory. +Local Open Scope ring_scope. + +(******************************************************************************) +(* This file provides basic notions of virtual character theory: *) +(* 'Z[S, A] == collective predicate for the phi that are Z-linear *) +(* combinations of elements of S : seq 'CF(G) and have *) +(* support in A : {set gT}. *) +(* 'Z[S] == collective predicate for the Z-linear combinations of *) +(* elements of S. *) +(* 'Z[irr G] == the collective predicate for virtual characters. *) +(* dirr G == the collective predicate for normal virtual characters, *) +(* i.e., virtual characters of norm 1: *) +(* mu \in dirr G <=> m \in 'Z[irr G] and '[mu] = 1 *) +(* <=> mu or - mu \in irr G. *) +(* --> othonormal subsets of 'Z[irr G] are contained in dirr G. *) +(* dIirr G == an index type for normal virtual characters. *) +(* dchi i == the normal virtual character of index i. *) +(* of_irr i == the (unique) irreducible constituent of dchi i: *) +(* dchi i = 'chi_(of_irr i) or - 'chi_(of_irr i). *) +(* ndirr i == the index of - dchi i. *) +(* dirr1 G == the normal virtual character index of 1 : 'CF(G), the *) +(* principal character. *) +(* dirr_dIirr j f == the index i (or dirr1 G if it does not exist) such that *) +(* dchi i = f j. *) +(* dirr_constt phi == the normal virtual character constituents of phi: *) +(* i \in dirr_constt phi <=> [dchi i, phi] > 0. *) +(* to_dirr phi i == the normal virtual character constituent of phi with an *) +(* irreducible constituent i, when i \in irr_constt phi. *) +(******************************************************************************) + +Section Basics. + +Variables (gT : finGroupType) (B : {set gT}) (S : seq 'CF(B)) (A : {set gT}). + +Definition Zchar : pred_class := + [pred phi in 'CF(B, A) | dec_Cint_span (in_tuple S) phi]. +Fact Zchar_key : pred_key Zchar. Proof. by []. Qed. +Canonical Zchar_keyed := KeyedPred Zchar_key. + +Lemma cfun0_zchar : 0 \in Zchar. +Proof. +rewrite inE mem0v; apply/sumboolP; exists 0. +by rewrite big1 // => i _; rewrite ffunE. +Qed. + +Fact Zchar_zmod : zmod_closed Zchar. +Proof. +split; first exact: cfun0_zchar. +move=> phi xi /andP[Aphi /sumboolP[a Da]] /andP[Axi /sumboolP[b Db]]. +rewrite inE rpredB // Da Db -sumrB; apply/sumboolP; exists (a - b). +by apply: eq_bigr => i _; rewrite -mulrzBr !ffunE. +Qed. +Canonical Zchar_opprPred := OpprPred Zchar_zmod. +Canonical Zchar_addrPred := AddrPred Zchar_zmod. +Canonical Zchar_zmodPred := ZmodPred Zchar_zmod. + +Lemma scale_zchar a phi : a \in Cint -> phi \in Zchar -> a *: phi \in Zchar. +Proof. by case/CintP=> m -> Zphi; rewrite scaler_int rpredMz. Qed. + +End Basics. + +Notation "''Z[' S , A ]" := (Zchar S A) + (at level 8, format "''Z[' S , A ]") : group_scope. +Notation "''Z[' S ]" := 'Z[S, setT] + (at level 8, format "''Z[' S ]") : group_scope. + +Section Zchar. + +Variables (gT : finGroupType) (G : {group gT}). +Implicit Types (A B : {set gT}) (S : seq 'CF(G)). + +Lemma zchar_split S A phi : + phi \in 'Z[S, A] = (phi \in 'Z[S]) && (phi \in 'CF(G, A)). +Proof. by rewrite !inE cfun_onT andbC. Qed. + +Lemma zcharD1E phi S : (phi \in 'Z[S, G^#]) = (phi \in 'Z[S]) && (phi 1%g == 0). +Proof. by rewrite zchar_split cfunD1E. Qed. + +Lemma zcharD1 phi S A : + (phi \in 'Z[S, A^#]) = (phi \in 'Z[S, A]) && (phi 1%g == 0). +Proof. by rewrite zchar_split cfun_onD1 andbA -zchar_split. Qed. + +Lemma zcharW S A : {subset 'Z[S, A] <= 'Z[S]}. +Proof. by move=> phi; rewrite zchar_split => /andP[]. Qed. + +Lemma zchar_on S A : {subset 'Z[S, A] <= 'CF(G, A)}. +Proof. by move=> phi /andP[]. Qed. + +Lemma zchar_onS A B S : A \subset B -> {subset 'Z[S, A] <= 'Z[S, B]}. +Proof. +move=> sAB phi; rewrite zchar_split (zchar_split _ B) => /andP[->]. +exact: cfun_onS. +Qed. + +Lemma zchar_onG S : 'Z[S, G] =i 'Z[S]. +Proof. by move=> phi; rewrite zchar_split cfun_onG andbT. Qed. + +Lemma irr_vchar_on A : {subset 'Z[irr G, A] <= 'CF(G, A)}. +Proof. exact: zchar_on. Qed. + +Lemma support_zchar S A phi : phi \in 'Z[S, A] -> support phi \subset A. +Proof. by move/zchar_on; rewrite cfun_onE. Qed. + +Lemma mem_zchar_on S A phi : + phi \in 'CF(G, A) -> phi \in S -> phi \in 'Z[S, A]. +Proof. +move=> Aphi /(@tnthP _ _ (in_tuple S))[i Dphi]; rewrite inE /= {}Aphi {phi}Dphi. +apply/sumboolP; exists [ffun j => (j == i)%:Z]. +rewrite (bigD1 i) //= ffunE eqxx (tnth_nth 0) big1 ?addr0 // => j i'j. +by rewrite ffunE (negPf i'j). +Qed. + +(* A special lemma is needed because trivial fails to use the cfun_onT Hint. *) +Lemma mem_zchar S phi : phi \in S -> phi \in 'Z[S]. +Proof. by move=> Sphi; rewrite mem_zchar_on ?cfun_onT. Qed. + +Lemma zchar_nth_expansion S A phi : + phi \in 'Z[S, A] -> + {z | forall i, z i \in Cint & phi = \sum_(i < size S) z i *: S`_i}. +Proof. +case/andP=> _ /sumboolP/sig_eqW[/= z ->]. +exists (intr \o z) => [i|]; first exact: Cint_int. +by apply: eq_bigr => i _; rewrite scaler_int. +Qed. + +Lemma zchar_tuple_expansion n (S : n.-tuple 'CF(G)) A phi : + phi \in 'Z[S, A] -> + {z | forall i, z i \in Cint & phi = \sum_(i < n) z i *: S`_i}. +Proof. by move/zchar_nth_expansion; rewrite size_tuple. Qed. + +(* A pure seq version with the extra hypothesis of S's unicity. *) +Lemma zchar_expansion S A phi : uniq S -> + phi \in 'Z[S, A] -> + {z | forall xi, z xi \in Cint & phi = \sum_(xi <- S) z xi *: xi}. +Proof. +move=> Suniq /zchar_nth_expansion[z Zz ->] /=. +pose zS xi := oapp z 0 (insub (index xi S)). +exists zS => [xi | ]; rewrite {}/zS; first by case: (insub _). +rewrite (big_nth 0) big_mkord; apply: eq_bigr => i _; congr (_ *: _). +by rewrite index_uniq // valK. +Qed. + +Lemma zchar_span S A : {subset 'Z[S, A] <= <>%VS}. +Proof. +move=> _ /zchar_nth_expansion[z Zz ->] /=. +by apply: rpred_sum => i _; rewrite rpredZ // memv_span ?mem_nth. +Qed. + +Lemma zchar_trans S1 S2 A B : + {subset S1 <= 'Z[S2, B]} -> {subset 'Z[S1, A] <= 'Z[S2, A]}. +Proof. +move=> sS12 phi; rewrite !(zchar_split _ A) andbC => /andP[->]; rewrite andbT. +case/zchar_nth_expansion=> z Zz ->; apply: rpred_sum => i _. +by rewrite scale_zchar // (@zcharW _ B) ?sS12 ?mem_nth. +Qed. + +Lemma zchar_trans_on S1 S2 A : + {subset S1 <= 'Z[S2, A]} -> {subset 'Z[S1] <= 'Z[S2, A]}. +Proof. +move=> sS12 _ /zchar_nth_expansion[z Zz ->]; apply: rpred_sum => i _. +by rewrite scale_zchar // sS12 ?mem_nth. +Qed. + +Lemma zchar_sub_irr S A : + {subset S <= 'Z[irr G]} -> {subset 'Z[S, A] <= 'Z[irr G, A]}. +Proof. exact: zchar_trans. Qed. + +Lemma zchar_subset S1 S2 A : + {subset S1 <= S2} -> {subset 'Z[S1, A] <= 'Z[S2, A]}. +Proof. +move=> sS12; apply: zchar_trans setT _ => // f /sS12 S2f. +by rewrite mem_zchar. +Qed. + +Lemma zchar_subseq S1 S2 A : + subseq S1 S2 -> {subset 'Z[S1, A] <= 'Z[S2, A]}. +Proof. move=> sS12; exact: zchar_subset (mem_subseq sS12). Qed. + +Lemma zchar_filter S A (p : pred 'CF(G)) : + {subset 'Z[filter p S, A] <= 'Z[S, A]}. +Proof. by apply: zchar_subset=> f; rewrite mem_filter => /andP[]. Qed. + +End Zchar. + +Section VChar. + +Variables (gT : finGroupType) (G : {group gT}). +Implicit Types (A B : {set gT}) (phi chi : 'CF(G)) (S : seq 'CF(G)). + +Lemma char_vchar chi : chi \is a character -> chi \in 'Z[irr G]. +Proof. +case/char_sum_irr=> r ->; apply: rpred_sum => i _. +by rewrite mem_zchar ?mem_tnth. +Qed. + +Lemma irr_vchar i : 'chi[G]_i \in 'Z[irr G]. +Proof. exact/char_vchar/irr_char. Qed. + +Lemma cfun1_vchar : 1 \in 'Z[irr G]. Proof. by rewrite -irr0 irr_vchar. Qed. + +Lemma vcharP phi : + reflect (exists2 chi1, chi1 \is a character + & exists2 chi2, chi2 \is a character & phi = chi1 - chi2) + (phi \in 'Z[irr G]). +Proof. +apply: (iffP idP) => [| [a Na [b Nb ->]]]; last by rewrite rpredB ?char_vchar. +case/zchar_tuple_expansion=> z Zz ->; rewrite (bigID (fun i => 0 <= z i)) /=. +set chi1 := \sum_(i | _) _; set nchi2 := \sum_(i | _) _. +exists chi1; last exists (- nchi2); last by rewrite opprK. + apply: rpred_sum => i zi_ge0; rewrite -tnth_nth rpredZ_Cnat ?irr_char //. + by rewrite CnatEint Zz. +rewrite -sumrN rpred_sum // => i zi_lt0; rewrite -scaleNr -tnth_nth. +rewrite rpredZ_Cnat ?irr_char // CnatEint rpredN Zz oppr_ge0 ltrW //. +by rewrite real_ltrNge ?Creal_Cint. +Qed. + +Lemma Aint_vchar phi x : phi \in 'Z[irr G] -> phi x \in Aint. +Proof. +case/vcharP=> [chi1 Nchi1 [chi2 Nchi2 ->]]. +by rewrite !cfunE rpredB ?Aint_char. +Qed. + +Lemma Cint_vchar1 phi : phi \in 'Z[irr G] -> phi 1%g \in Cint. +Proof. +case/vcharP=> phi1 Nphi1 [phi2 Nphi2 ->]. +by rewrite !cfunE rpredB // rpred_Cnat ?Cnat_char1. +Qed. + +Lemma Cint_cfdot_vchar_irr i phi : phi \in 'Z[irr G] -> '[phi, 'chi_i] \in Cint. +Proof. +case/vcharP=> chi1 Nchi1 [chi2 Nchi2 ->]. +by rewrite cfdotBl rpredB // rpred_Cnat ?Cnat_cfdot_char_irr. +Qed. + +Lemma cfdot_vchar_r phi psi : + psi \in 'Z[irr G] -> '[phi, psi] = \sum_i '[phi, 'chi_i] * '[psi, 'chi_i]. +Proof. +move=> Zpsi; rewrite cfdot_sum_irr; apply: eq_bigr => i _; congr (_ * _). +by rewrite aut_Cint ?Cint_cfdot_vchar_irr. +Qed. + +Lemma Cint_cfdot_vchar : {in 'Z[irr G] &, forall phi psi, '[phi, psi] \in Cint}. +Proof. +move=> phi psi Zphi Zpsi; rewrite /= cfdot_vchar_r // rpred_sum // => k _. +by rewrite rpredM ?Cint_cfdot_vchar_irr. +Qed. + +Lemma Cnat_cfnorm_vchar : {in 'Z[irr G], forall phi, '[phi] \in Cnat}. +Proof. +by move=> phi Zphi; rewrite /= CnatEint cfnorm_ge0 Cint_cfdot_vchar. +Qed. + +Fact vchar_mulr_closed : mulr_closed 'Z[irr G]. +Proof. +split; first exact: cfun1_vchar. +move=> _ _ /vcharP[xi1 Nxi1 [xi2 Nxi2 ->]] /vcharP[xi3 Nxi3 [xi4 Nxi4 ->]]. +by rewrite mulrBl !mulrBr !(rpredB, rpredD) // char_vchar ?rpredM. +Qed. +Canonical vchar_mulrPred := MulrPred vchar_mulr_closed. +Canonical vchar_smulrPred := SmulrPred vchar_mulr_closed. +Canonical vchar_semiringPred := SemiringPred vchar_mulr_closed. +Canonical vchar_subringPred := SubringPred vchar_mulr_closed. + +Lemma mul_vchar A : + {in 'Z[irr G, A] &, forall phi psi, phi * psi \in 'Z[irr G, A]}. +Proof. +move=> phi psi; rewrite zchar_split => /andP[Zphi Aphi] /zcharW Zpsi. +rewrite zchar_split rpredM //; apply/cfun_onP=> x A'x. +by rewrite cfunE (cfun_onP Aphi) ?mul0r. +Qed. + +Section CfdotPairwiseOrthogonal. + +Variables (M : {group gT}) (S : seq 'CF(G)) (nu : 'CF(G) -> 'CF(M)). +Hypotheses (Inu : {in 'Z[S] &, isometry nu}) (oSS : pairwise_orthogonal S). + +Let freeS := orthogonal_free oSS. +Let uniqS : uniq S := free_uniq freeS. +Let Z_S : {subset S <= 'Z[S]}. Proof. by move=> phi; exact: mem_zchar. Qed. +Let notS0 : 0 \notin S. Proof. by case/andP: oSS. Qed. +Let dotSS := proj2 (pairwise_orthogonalP oSS). + +Lemma map_pairwise_orthogonal : pairwise_orthogonal (map nu S). +Proof. +have inj_nu: {in S &, injective nu}. + move=> phi psi Sphi Spsi /= eq_nu; apply: contraNeq (memPn notS0 _ Sphi). + by rewrite -cfnorm_eq0 -Inu ?Z_S // {2}eq_nu Inu ?Z_S // => /dotSS->. +have notSnu0: 0 \notin map nu S. + apply: contra notS0 => /mapP[phi Sphi /esym/eqP]. + by rewrite -cfnorm_eq0 Inu ?Z_S // cfnorm_eq0 => /eqP <-. +apply/pairwise_orthogonalP; split; first by rewrite /= notSnu0 map_inj_in_uniq. +move=>_ _ /mapP[phi Sphi ->] /mapP[psi Spsi ->]. +by rewrite (inj_in_eq inj_nu) // Inu ?Z_S //; exact: dotSS. +Qed. + +Lemma cfproj_sum_orthogonal P z phi : + phi \in S -> + '[\sum_(xi <- S | P xi) z xi *: nu xi, nu phi] + = if P phi then z phi * '[phi] else 0. +Proof. +move=> Sphi; have defS := perm_to_rem Sphi. +rewrite cfdot_suml (eq_big_perm _ defS) big_cons /= cfdotZl Inu ?Z_S //. +rewrite big1_seq ?addr0 // => xi; rewrite mem_rem_uniq ?inE //. +by case/and3P=> _ neq_xi Sxi; rewrite cfdotZl Inu ?Z_S // dotSS ?mulr0. +Qed. + +Lemma cfdot_sum_orthogonal z1 z2 : + '[\sum_(xi <- S) z1 xi *: nu xi, \sum_(xi <- S) z2 xi *: nu xi] + = \sum_(xi <- S) z1 xi * (z2 xi)^* * '[xi]. +Proof. +rewrite cfdot_sumr; apply: eq_big_seq => phi Sphi. +by rewrite cfdotZr cfproj_sum_orthogonal // mulrCA mulrA. +Qed. + +Lemma cfnorm_sum_orthogonal z : + '[\sum_(xi <- S) z xi *: nu xi] = \sum_(xi <- S) `|z xi| ^+ 2 * '[xi]. +Proof. +by rewrite cfdot_sum_orthogonal; apply: eq_bigr => xi _; rewrite normCK. +Qed. + +Lemma cfnorm_orthogonal : '[\sum_(xi <- S) nu xi] = \sum_(xi <- S) '[xi]. +Proof. +rewrite -(eq_bigr _ (fun _ _ => scale1r _)) cfnorm_sum_orthogonal. +by apply: eq_bigr => xi; rewrite normCK conjC1 !mul1r. +Qed. + +End CfdotPairwiseOrthogonal. + +Lemma orthogonal_span S phi : + pairwise_orthogonal S -> phi \in <>%VS -> + {z | z = fun xi => '[phi, xi] / '[xi] & phi = \sum_(xi <- S) z xi *: xi}. +Proof. +move=> oSS /free_span[|c -> _]; first exact: orthogonal_free. +set z := fun _ => _ : algC; exists z => //; apply: eq_big_seq => u Su. +rewrite /z cfproj_sum_orthogonal // mulfK // cfnorm_eq0. +by rewrite (memPn _ u Su); case/andP: oSS. +Qed. + +Section CfDotOrthonormal. + +Variables (M : {group gT}) (S : seq 'CF(G)) (nu : 'CF(G) -> 'CF(M)). +Hypotheses (Inu : {in 'Z[S] &, isometry nu}) (onS : orthonormal S). +Let oSS := orthonormal_orthogonal onS. +Let freeS := orthogonal_free oSS. +Let nS1 : {in S, forall phi, '[phi] = 1}. +Proof. by move=> phi Sphi; case/orthonormalP: onS => _ -> //; rewrite eqxx. Qed. + +Lemma map_orthonormal : orthonormal (map nu S). +Proof. +rewrite !orthonormalE map_pairwise_orthogonal // andbT. +by apply/allP=> _ /mapP[xi Sxi ->]; rewrite /= Inu ?nS1 // mem_zchar. +Qed. + +Lemma cfproj_sum_orthonormal z phi : + phi \in S -> '[\sum_(xi <- S) z xi *: nu xi, nu phi] = z phi. +Proof. by move=> Sphi; rewrite cfproj_sum_orthogonal // nS1 // mulr1. Qed. + +Lemma cfdot_sum_orthonormal z1 z2 : + '[\sum_(xi <- S) z1 xi *: xi, \sum_(xi <- S) z2 xi *: xi] + = \sum_(xi <- S) z1 xi * (z2 xi)^*. +Proof. +rewrite cfdot_sum_orthogonal //; apply: eq_big_seq => phi /nS1->. +by rewrite mulr1. +Qed. + +Lemma cfnorm_sum_orthonormal z : + '[\sum_(xi <- S) z xi *: nu xi] = \sum_(xi <- S) `|z xi| ^+ 2. +Proof. +rewrite cfnorm_sum_orthogonal //. +by apply: eq_big_seq => xi /nS1->; rewrite mulr1. +Qed. + +Lemma cfnorm_map_orthonormal : '[\sum_(xi <- S) nu xi] = (size S)%:R. +Proof. +by rewrite cfnorm_orthogonal // (eq_big_seq _ nS1) big_tnth sumr_const card_ord. +Qed. + +Lemma orthonormal_span phi : + phi \in <>%VS -> + {z | z = fun xi => '[phi, xi] & phi = \sum_(xi <- S) z xi *: xi}. +Proof. +case/orthogonal_span=> // _ -> {2}->; set z := fun _ => _ : algC. +by exists z => //; apply: eq_big_seq => xi /nS1->; rewrite divr1. +Qed. + +End CfDotOrthonormal. + +Lemma cfnorm_orthonormal S : + orthonormal S -> '[\sum_(xi <- S) xi] = (size S)%:R. +Proof. exact: cfnorm_map_orthonormal. Qed. + +Lemma zchar_orthonormalP S : + {subset S <= 'Z[irr G]} -> + reflect (exists I : {set Iirr G}, exists b : Iirr G -> bool, + perm_eq S [seq (-1) ^+ b i *: 'chi_i | i in I]) + (orthonormal S). +Proof. +move=> vcS; apply: (equivP orthonormalP). +split=> [[uniqS oSS] | [I [b defS]]]; last first. + split=> [|xi1 xi2]; rewrite ?(perm_eq_mem defS). + rewrite (perm_eq_uniq defS) map_inj_uniq ?enum_uniq // => i j /eqP. + by rewrite eq_signed_irr => /andP[_ /eqP]. + case/mapP=> [i _ ->] /mapP[j _ ->]; rewrite eq_signed_irr. + rewrite cfdotZl cfdotZr rmorph_sign mulrA cfdot_irr -signr_addb mulr_natr. + by rewrite mulrb andbC; case: eqP => //= ->; rewrite addbb eqxx. +pose I := [set i | ('chi_i \in S) || (- 'chi_i \in S)]. +pose b i := - 'chi_i \in S; exists I, b. +apply: uniq_perm_eq => // [|xi]. + rewrite map_inj_uniq ?enum_uniq // => i j /eqP. + by rewrite eq_signed_irr => /andP[_ /eqP]. +apply/idP/mapP=> [Sxi | [i Ii ->{xi}]]; last first. + move: Ii; rewrite mem_enum inE orbC -/(b i). + by case b_i: (b i); rewrite (scale1r, scaleN1r). +have: '[xi] = 1 by rewrite oSS ?eqxx. +have vc_xi := vcS _ Sxi; rewrite cfdot_sum_irr. +case/Cnat_sum_eq1 => [i _ | i [_ /eqP norm_xi_i xi_i'_0]]. + by rewrite -normCK rpredX // Cnat_norm_Cint ?Cint_cfdot_vchar_irr. +suffices def_xi: xi = (-1) ^+ b i *: 'chi_i. + exists i; rewrite // mem_enum inE -/(b i) orbC. + by case: (b i) def_xi Sxi => // ->; rewrite scale1r. +move: Sxi; rewrite [xi]cfun_sum_cfdot (bigD1 i) //. +rewrite big1 //= ?addr0 => [|j ne_ji]; last first. + apply/eqP; rewrite scaler_eq0 -normr_eq0 -[_ == 0](expf_eq0 _ 2) normCK. + by rewrite xi_i'_0 ?eqxx. +have:= norm_xi_i; rewrite (aut_Cint _ (Cint_cfdot_vchar_irr _ _)) //. +rewrite -subr_eq0 subr_sqr_1 mulf_eq0 subr_eq0 addr_eq0 /b scaler_sign. +case/pred2P=> ->; last by rewrite scaleN1r => ->. +rewrite scale1r => Sxi; case: ifP => // SNxi. +have:= oSS _ _ Sxi SNxi; rewrite cfdotNr cfdot_irr eqxx; case: eqP => // _. +by move/eqP; rewrite oppr_eq0 oner_eq0. +Qed. + +Lemma vchar_norm1P phi : + phi \in 'Z[irr G] -> '[phi] = 1 -> + exists b : bool, exists i : Iirr G, phi = (-1) ^+ b *: 'chi_i. +Proof. +move=> Zphi phiN1. +have: orthonormal phi by rewrite /orthonormal/= phiN1 eqxx. +case/zchar_orthonormalP=> [xi /predU1P[->|] // | I [b def_phi]]. +have: phi \in (phi : seq _) := mem_head _ _. +by rewrite (perm_eq_mem def_phi) => /mapP[i _ ->]; exists (b i), i. +Qed. + +Lemma zchar_small_norm phi n : + phi \in 'Z[irr G] -> '[phi] = n%:R -> (n < 4)%N -> + {S : n.-tuple 'CF(G) | + [/\ orthonormal S, {subset S <= 'Z[irr G]} & phi = \sum_(xi <- S) xi]}. +Proof. +move=> Zphi def_n lt_n_4. +pose S := [seq '[phi, 'chi_i] *: 'chi_i | i in irr_constt phi]. +have def_phi: phi = \sum_(xi <- S) xi. + rewrite big_map /= big_filter big_mkcond {1}[phi]cfun_sum_cfdot. + by apply: eq_bigr => i _; rewrite if_neg; case: eqP => // ->; rewrite scale0r. +have orthS: orthonormal S. + apply/orthonormalP; split=> [|_ _ /mapP[i phi_i ->] /mapP[j _ ->]]. + rewrite map_inj_in_uniq ?enum_uniq // => i j; rewrite mem_enum => phi_i _. + by move/eqP; rewrite eq_scaled_irr (negbTE phi_i) => /andP[_ /= /eqP]. + rewrite eq_scaled_irr cfdotZl cfdotZr cfdot_irr mulrA mulr_natr mulrb. + rewrite mem_enum in phi_i; rewrite (negbTE phi_i) andbC; case: eqP => // <-. + have /CnatP[m def_m] := Cnat_norm_Cint (Cint_cfdot_vchar_irr i Zphi). + apply/eqP; rewrite eqxx /= -normCK def_m -natrX eqr_nat eqn_leq lt0n. + rewrite expn_eq0 andbT -eqC_nat -def_m normr_eq0 [~~ _]phi_i andbT. + rewrite (leq_exp2r _ 1) // -ltnS -(@ltn_exp2r _ _ 2) //. + apply: leq_ltn_trans lt_n_4; rewrite -leC_nat -def_n natrX. + rewrite cfdot_sum_irr (bigD1 i) //= -normCK def_m addrC -subr_ge0 addrK. + by rewrite sumr_ge0 // => ? _; exact: mul_conjC_ge0. +have <-: size S = n. + by apply/eqP; rewrite -eqC_nat -def_n def_phi cfnorm_orthonormal. +exists (in_tuple S); split=> // _ /mapP[i _ ->]. +by rewrite scale_zchar ?irr_vchar // Cint_cfdot_vchar_irr. +Qed. + +Lemma vchar_norm2 phi : + phi \in 'Z[irr G, G^#] -> '[phi] = 2%:R -> + exists i, exists2 j, j != i & phi = 'chi_i - 'chi_j. +Proof. +rewrite zchar_split cfunD1E => /andP[Zphi phi1_0]. +case/zchar_small_norm => // [[[|chi [|xi [|?]]] //= S2]]. +case=> /andP[/and3P[Nchi Nxi _] /= ochi] /allP/and3P[Zchi Zxi _]. +rewrite big_cons big_seq1 => def_phi. +have [b [i def_chi]] := vchar_norm1P Zchi (eqP Nchi). +have [c [j def_xi]] := vchar_norm1P Zxi (eqP Nxi). +have neq_ji: j != i. + apply: contraTneq ochi; rewrite !andbT def_chi def_xi => ->. + rewrite cfdotZl cfdotZr rmorph_sign cfnorm_irr mulr1 -signr_addb. + by rewrite signr_eq0. +have neq_bc: b != c. + apply: contraTneq phi1_0; rewrite def_phi def_chi def_xi => ->. + rewrite -scalerDr !cfunE mulf_eq0 signr_eq0 eqr_le ltr_geF //. + by rewrite ltr_paddl ?ltrW ?irr1_gt0. +rewrite {}def_phi {}def_chi {}def_xi !scaler_sign. +case: b c neq_bc => [|] [|] // _; last by exists i, j. +by exists j, i; rewrite 1?eq_sym // addrC. +Qed. + +End VChar. + +Section Isometries. + +Variables (gT : finGroupType) (L G : {group gT}) (S : seq 'CF(L)). +Implicit Type nu : {additive 'CF(L) -> 'CF(G)}. + +Lemma Zisometry_of_cfnorm (tauS : seq 'CF(G)) : + pairwise_orthogonal S -> pairwise_orthogonal tauS -> + map cfnorm tauS = map cfnorm S -> {subset tauS <= 'Z[irr G]} -> + {tau : {linear 'CF(L) -> 'CF(G)} | map tau S = tauS + & {in 'Z[S], isometry tau, to 'Z[irr G]}}. +Proof. +move=> oSS oTT /isometry_of_cfnorm[||tau defT Itau] // Z_T; exists tau => //. +split=> [|_ /zchar_nth_expansion[u Zu ->]]. + by apply: sub_in2 Itau; apply: zchar_span. +rewrite big_seq linear_sum rpred_sum // => xi Sxi. +by rewrite linearZ scale_zchar ?Z_T // -defT map_f ?mem_nth. +Qed. + +Lemma Zisometry_of_iso f : + pairwise_orthogonal S -> {in S, isometry f, to 'Z[irr G]} -> + {tau : {linear 'CF(L) -> 'CF(G)} | {in S, tau =1 f} + & {in 'Z[S], isometry tau, to 'Z[irr G]}}. +Proof. +move=> oS [If Zf]; have [/=/andP[S'0 uS] oSS] := pairwise_orthogonalP oS. +have injf: {in S &, injective f}. + move=> xi1 xi2 Sxi1 Sxi2 /=/(congr1 (cfdot (f xi1)))/eqP; rewrite !If //. + by apply: contraTeq => /oSS-> //; rewrite cfnorm_eq0 (memPn S'0). +have{injf} oSf: pairwise_orthogonal (map f S). + apply/pairwise_orthogonalP; split=> /=. + rewrite map_inj_in_uniq // uS (contra _ S'0) // => /mapP[chi Schi /eqP]. + by rewrite eq_sym -cfnorm_eq0 If // cfnorm_eq0 => /eqP <-. + move=> _ _ /mapP[xi1 Xxi1 ->] /mapP[xi2 Xxi2 ->]. + by rewrite If ?(inj_in_eq injf) // => /oSS->. +have{If} nSf: map cfnorm (map f S) = map cfnorm S. + by rewrite -map_comp; apply/eq_in_map=> xi Sxi; rewrite /= If. +have{Zf} ZSf: {subset map f S <= 'Z[irr G]} by move=> _ /mapP[xi /Zf Zfxi ->]. +by have [tau /eq_in_map] := Zisometry_of_cfnorm oS oSf nSf ZSf; exists tau. +Qed. + +Lemma Zisometry_inj A nu : + {in 'Z[S, A] &, isometry nu} -> {in 'Z[S, A] &, injective nu}. +Proof. by move/isometry_raddf_inj; apply; apply: rpredB. Qed. + +Lemma isometry_in_zchar nu : {in S &, isometry nu} -> {in 'Z[S] &, isometry nu}. +Proof. +move=> Inu _ _ /zchar_nth_expansion[u Zu ->] /zchar_nth_expansion[v Zv ->]. +rewrite !raddf_sum; apply: eq_bigr => j _ /=. +rewrite !cfdot_suml; apply: eq_bigr => i _. +by rewrite !raddfZ_Cint //= !cfdotZl !cfdotZr Inu ?mem_nth. +Qed. + +End Isometries. + +Section AutVchar. + +Variables (u : {rmorphism algC -> algC}) (gT : finGroupType) (G : {group gT}). +Local Notation "alpha ^u" := (cfAut u alpha). +Implicit Type (S : seq 'CF(G)) (phi chi : 'CF(G)). + +Lemma cfAut_zchar S A psi : + cfAut_closed u S -> psi \in 'Z[S, A] -> psi^u \in 'Z[S, A]. +Proof. +rewrite zchar_split => SuS /andP[/zchar_nth_expansion[z Zz Dpsi] Apsi]. +rewrite zchar_split cfAut_on {}Apsi {psi}Dpsi rmorph_sum rpred_sum //= => i _. +by rewrite cfAutZ_Cint // scale_zchar // mem_zchar ?SuS ?mem_nth. +Qed. + +Lemma cfAut_vchar A psi : psi \in 'Z[irr G, A] -> psi^u \in 'Z[irr G, A]. +Proof. by apply: cfAut_zchar; exact: irr_aut_closed. Qed. + +Lemma sub_aut_zchar S A psi : + {subset S <= 'Z[irr G]} -> psi \in 'Z[S, A] -> psi^u \in 'Z[S, A] -> + psi - psi^u \in 'Z[S, A^#]. +Proof. +move=> Z_S Spsi Spsi_u; rewrite zcharD1 !cfunE subr_eq0 rpredB //=. +by rewrite aut_Cint // Cint_vchar1 // (zchar_trans Z_S) ?(zcharW Spsi). +Qed. + +Lemma conjC_vcharAut chi x : chi \in 'Z[irr G] -> (u (chi x))^* = u (chi x)^*. +Proof. +case/vcharP=> chi1 Nchi1 [chi2 Nchi2 ->]. +by rewrite !cfunE !rmorphB !conjC_charAut. +Qed. + +Lemma cfdot_aut_vchar phi chi : + chi \in 'Z[irr G] -> '[phi^u , chi^u] = u '[phi, chi]. +Proof. +case/vcharP=> chi1 Nchi1 [chi2 Nchi2 ->]. +by rewrite !raddfB /= !cfdot_aut_char. +Qed. + +Lemma vchar_aut A chi : (chi^u \in 'Z[irr G, A]) = (chi \in 'Z[irr G, A]). +Proof. +rewrite !(zchar_split _ A) cfAut_on; congr (_ && _). +apply/idP/idP=> [Zuchi|]; last exact: cfAut_vchar. +rewrite [chi]cfun_sum_cfdot rpred_sum // => i _. +rewrite scale_zchar ?irr_vchar //. +by rewrite -(Cint_aut u) -cfdot_aut_irr -aut_IirrE Cint_cfdot_vchar_irr. +Qed. + +End AutVchar. + +Definition cfConjC_vchar := cfAut_vchar conjC. + +Section MoreVchar. + +Variables (gT : finGroupType) (G H : {group gT}). + +Lemma cfRes_vchar phi : phi \in 'Z[irr G] -> 'Res[H] phi \in 'Z[irr H]. +Proof. +case/vcharP=> xi1 Nx1 [xi2 Nxi2 ->]. +by rewrite raddfB rpredB ?char_vchar ?cfRes_char. +Qed. + +Lemma cfRes_vchar_on A phi : + H \subset G -> phi \in 'Z[irr G, A] -> 'Res[H] phi \in 'Z[irr H, A]. +Proof. +rewrite zchar_split => sHG /andP[Zphi Aphi]; rewrite zchar_split cfRes_vchar //. +apply/cfun_onP=> x /(cfun_onP Aphi); rewrite !cfunElock !genGid sHG => ->. +exact: mul0rn. +Qed. + +Lemma cfInd_vchar phi : phi \in 'Z[irr H] -> 'Ind[G] phi \in 'Z[irr G]. +Proof. +move=> /vcharP[xi1 Nx1 [xi2 Nxi2 ->]]. +by rewrite raddfB rpredB ?char_vchar ?cfInd_char. +Qed. + +Lemma sub_conjC_vchar A phi : + phi \in 'Z[irr G, A] -> phi - (phi^*)%CF \in 'Z[irr G, A^#]. +Proof. +move=> Zphi; rewrite sub_aut_zchar ?cfAut_zchar // => _ /irrP[i ->]. + exact: irr_vchar. +exact: cfConjC_irr. +Qed. + +Lemma Frobenius_kernel_exists : + [Frobenius G with complement H] -> {K : {group gT} | [Frobenius G = K ><| H]}. +Proof. +move=> frobG; have [_ ntiHG] := andP frobG. +have [[_ sHG regGH][_ tiHG /eqP defNH]] := (normedTI_memJ_P ntiHG, and3P ntiHG). +suffices /sigW[K defG]: exists K, gval K ><| H == G by exists K; apply/andP. +pose K1 := G :\: cover (H^# :^: G). +have oK1: #|K1| = #|G : H|. + rewrite cardsD (setIidPr _); last first. + rewrite cover_imset; apply/bigcupsP=> x Gx. + by rewrite sub_conjg conjGid ?groupV // (subset_trans (subsetDl _ _)). + rewrite (cover_partition (partition_normedTI ntiHG)) -(Lagrange sHG). + by rewrite (card_support_normedTI ntiHG) (cardsD1 1%g) group1 mulSn addnK. +suffices extG i: {j | {in H, 'chi[G]_j =1 'chi[H]_i} & K1 \subset cfker 'chi_j}. + pose K := [group of \bigcap_i cfker 'chi_(s2val (extG i))]. + have nKH: H \subset 'N(K). + by apply/norms_bigcap/bigcapsP=> i _; apply: subset_trans (cfker_norm _). + have tiKH: K :&: H = 1%g. + apply/trivgP; rewrite -(TI_cfker_irr H) /= setIC; apply/bigcapsP=> i _. + apply/subsetP=> x /setIP[Hx /bigcapP/(_ i isT)/=]; rewrite !cfkerEirr !inE. + by case: (extG i) => /= j def_j _; rewrite !def_j. + exists K; rewrite sdprodE // eqEcard TI_cardMg // mul_subG //=; last first. + by rewrite (bigcap_min (0 : Iirr H)) ?cfker_sub. + rewrite -(Lagrange sHG) mulnC leq_pmul2r // -oK1 subset_leq_card //. + by apply/bigcapsP=> i _; case: (extG i). +case i0: (i == 0). + exists 0 => [x Hx|]; last by rewrite irr0 cfker_cfun1 subsetDl. + by rewrite (eqP i0) !irr0 !cfun1E // (subsetP sHG) ?Hx. +have ochi1: '['chi_i, 1] = 0 by rewrite -irr0 cfdot_irr i0. +pose a := 'chi_i 1%g; have Za: a \in Cint by rewrite CintE Cnat_irr1. +pose theta := 'chi_i - a%:A; pose phi := 'Ind[G] theta + a%:A. +have /cfun_onP theta0: theta \in 'CF(H, H^#). + by rewrite cfunD1E !cfunE cfun11 mulr1 subrr. +have RItheta: 'Res ('Ind[G] theta) = theta. + apply/cfun_inP=> x Hx; rewrite cfResE ?cfIndE // (big_setID H) /= addrC. + apply: canLR (mulKf (neq0CG H)) _; rewrite (setIidPr sHG) mulr_natl. + rewrite big1 ?add0r => [|y /setDP[/regGH tiHy H'y]]; last first. + have [-> | ntx] := eqVneq x 1%g; first by rewrite conj1g theta0 ?inE ?eqxx. + by rewrite theta0 ?tiHy // !inE ntx. + by rewrite -sumr_const; apply: eq_bigr => y Hy; rewrite cfunJ. +have ophi1: '[phi, 1] = 0. + rewrite cfdotDl -cfdot_Res_r cfRes_cfun1 // cfdotBl !cfdotZl !cfnorm1. + by rewrite ochi1 add0r addNr. +have{ochi1} n1phi: '[phi] = 1. + have: '[phi - a%:A] = '[theta] by rewrite addrK -cfdot_Res_l RItheta. + rewrite !cfnormBd ?cfnormZ ?cfdotZr ?ophi1 ?ochi1 ?mulr0 //. + by rewrite !cfnorm1 cfnorm_irr => /addIr. +have Zphi: phi \in 'Z[irr G]. + by rewrite rpredD ?cfInd_vchar ?rpredB ?irr_vchar // scale_zchar ?rpred1. +have def_phi: {in H, phi =1 'chi_i}. + move=> x Hx /=; rewrite !cfunE -[_ x](cfResE _ sHG) ?RItheta //. + by rewrite !cfunE !cfun1E ?(subsetP sHG) ?Hx ?subrK. +have [j def_chi_j]: {j | 'chi_j = phi}. + apply/sig_eqW; have [[] [j]] := vchar_norm1P Zphi n1phi; last first. + by rewrite scale1r; exists j. + move/cfunP/(_ 1%g)/eqP; rewrite scaleN1r def_phi // cfunE -addr_eq0 eqr_le. + by rewrite ltr_geF // ltr_paddl ?ltrW ?irr1_gt0. +exists j; rewrite ?cfkerEirr def_chi_j //; apply/subsetP => x /setDP[Gx notHx]. +rewrite inE cfunE def_phi // cfunE -/a cfun1E // Gx mulr1 cfIndE //. +rewrite big1 ?mulr0 ?add0r // => y Gy; apply/theta0/(contra _ notHx) => Hxy. +by rewrite -(conjgK y x) cover_imset -class_supportEr mem_imset2 ?groupV. +Qed. + +End MoreVchar. + +Definition dirr (gT : finGroupType) (B : {set gT}) : pred_class := + [pred f : 'CF(B) | (f \in irr B) || (- f \in irr B)]. +Implicit Arguments dirr [[gT]]. + +Section Norm1vchar. + +Variables (gT : finGroupType) (G : {group gT}). + +Fact dirr_key : pred_key (dirr G). Proof. by []. Qed. +Canonical dirr_keyed := KeyedPred dirr_key. + +Fact dirr_oppr_closed : oppr_closed (dirr G). +Proof. by move=> xi; rewrite !inE opprK orbC. Qed. +Canonical dirr_opprPred := OpprPred dirr_oppr_closed. + +Lemma dirr_opp v : (- v \in dirr G) = (v \in dirr G). Proof. exact: rpredN. Qed. +Lemma dirr_sign n v : ((-1)^+ n *: v \in dirr G) = (v \in dirr G). +Proof. exact: rpredZsign. Qed. + +Lemma irr_dirr i : 'chi_i \in dirr G. +Proof. by rewrite !inE mem_irr. Qed. + +Lemma dirrP f : + reflect (exists b : bool, exists i, f = (-1) ^+ b *: 'chi_i) (f \in dirr G). +Proof. +apply: (iffP idP) => [| [b [i ->]]]; last by rewrite dirr_sign irr_dirr. +case/orP=> /irrP[i Hf]; first by exists false, i; rewrite scale1r. +by exists true, i; rewrite scaleN1r -Hf opprK. +Qed. + +(* This should perhaps be the definition of dirr. *) +Lemma dirrE phi : phi \in dirr G = (phi \in 'Z[irr G]) && ('[phi] == 1). +Proof. +apply/dirrP/andP=> [[b [i ->]] | [Zphi /eqP/vchar_norm1P]]; last exact. +by rewrite rpredZsign irr_vchar cfnorm_sign cfnorm_irr. +Qed. + +Lemma cfdot_dirr f g : f \in dirr G -> g \in dirr G -> + '[f, g] = (if f == - g then -1 else (f == g)%:R). +Proof. +case/dirrP=> [b1 [i1 ->]] /dirrP[b2 [i2 ->]]. +rewrite cfdotZl cfdotZr rmorph_sign mulrA -signr_addb cfdot_irr. +rewrite -scaleNr -signrN !eq_scaled_irr signr_eq0 !(inj_eq (@signr_inj _)) /=. +by rewrite -!negb_add addbN mulr_sign -mulNrn mulrb; case: ifP. +Qed. + +Lemma dirr_norm1 phi : phi \in 'Z[irr G] -> '[phi] = 1 -> phi \in dirr G. +Proof. by rewrite dirrE => -> -> /=. Qed. + +Lemma dirr_aut u phi : (cfAut u phi \in dirr G) = (phi \in dirr G). +Proof. +rewrite !dirrE vchar_aut; apply: andb_id2l => /cfdot_aut_vchar->. +exact: fmorph_eq1. +Qed. + +Definition dIirr (B : {set gT}) := (bool * (Iirr B))%type. + +Definition dirr1 (B : {set gT}) : dIirr B := (false, 0). + +Definition ndirr (B : {set gT}) (i : dIirr B) : dIirr B := + (~~ i.1, i.2). + +Lemma ndirr_diff (i : dIirr G) : ndirr i != i. +Proof. by case: i => [] [|] i. Qed. + +Lemma ndirrK : involutive (@ndirr G). +Proof. by move=> [b i]; rewrite /ndirr /= negbK. Qed. + +Lemma ndirr_inj : injective (@ndirr G). +Proof. exact: (inv_inj ndirrK). Qed. + +Definition dchi (B : {set gT}) (i : dIirr B) : 'CF(B) := + (-1)^+ i.1 *: 'chi_i.2. + +Lemma dchi1 : dchi (dirr1 G) = 1. +Proof. by rewrite /dchi scale1r irr0. Qed. + +Lemma dirr_dchi i : dchi i \in dirr G. +Proof. by apply/dirrP; exists i.1; exists i.2. Qed. + +Lemma dIrrP (phi : 'CF(G)) : + reflect (exists i , phi = dchi i) (phi \in dirr G). +Proof. +by apply: (iffP idP)=> [/dirrP [b [i ->]]| [i ->]]; + [exists (b, i) | exact: dirr_dchi]. +Qed. + +Lemma dchi_ndirrE (i : dIirr G) : dchi (ndirr i) = - dchi i. +Proof. by case: i => [b i]; rewrite /ndirr /dchi signrN scaleNr. Qed. + +Lemma cfdot_dchi (i j : dIirr G) : + '[dchi i, dchi j] = (i == j)%:R - (i == ndirr j)%:R. +Proof. +case: i => bi i; case: j => bj j; rewrite cfdot_dirr ?dirr_dchi // !xpair_eqE. +rewrite -dchi_ndirrE !eq_scaled_irr signr_eq0 !(inj_eq (@signr_inj _)) /=. +by rewrite -!negb_add addbN negbK; case: andP => [[->]|]; rewrite ?subr0 ?add0r. +Qed. + +Lemma dchi_vchar i : dchi i \in 'Z[irr G]. +Proof. by case: i => b i; rewrite rpredZsign irr_vchar. Qed. + +Lemma cfnorm_dchi (i : dIirr G) : '[dchi i] = 1. +Proof. by case: i => b i; rewrite cfnorm_sign cfnorm_irr. Qed. + +Lemma dirr_inj : injective (@dchi G). +Proof. +case=> b1 i1 [b2 i2] /eqP; rewrite eq_scaled_irr (inj_eq (@signr_inj _)) /=. +by rewrite signr_eq0 -xpair_eqE => /eqP. +Qed. + +Definition dirr_dIirr (B : {set gT}) J (f : J -> 'CF(B)) j : dIirr B := + odflt (dirr1 B) [pick i | dchi i == f j]. + +Lemma dirr_dIirrPE J (f : J -> 'CF(G)) (P : pred J) : + (forall j, P j -> f j \in dirr G) -> + forall j, P j -> dchi (dirr_dIirr f j) = f j. +Proof. +rewrite /dirr_dIirr => dirrGf j Pj; case: pickP => [i /eqP //|]. +by have /dIrrP[i-> /(_ i)/eqP] := dirrGf j Pj. +Qed. + +Lemma dirr_dIirrE J (f : J -> 'CF(G)) : + (forall j, f j \in dirr G) -> forall j, dchi (dirr_dIirr f j) = f j. +Proof. by move=> dirrGf j; exact: (@dirr_dIirrPE _ _ xpredT). Qed. + +Definition dirr_constt (B : {set gT}) (phi: 'CF(B)) : {set (dIirr B)} := + [set i | 0 < '[phi, dchi i]]. + +Lemma dirr_consttE (phi : 'CF(G)) (i : dIirr G) : + (i \in dirr_constt phi) = (0 < '[phi, dchi i]). +Proof. by rewrite inE. Qed. + +Lemma Cnat_dirr (phi : 'CF(G)) i : + phi \in 'Z[irr G] -> i \in dirr_constt phi -> '[phi, dchi i] \in Cnat. +Proof. +move=> PiZ; rewrite CnatEint dirr_consttE andbC => /ltrW -> /=. +by case: i => b i; rewrite cfdotZr rmorph_sign rpredMsign Cint_cfdot_vchar_irr. +Qed. + +Lemma dirr_constt_oppr (i : dIirr G) (phi : 'CF(G)) : + (i \in dirr_constt (-phi)) = (ndirr i \in dirr_constt phi). +Proof. by rewrite !dirr_consttE dchi_ndirrE cfdotNl cfdotNr. Qed. + +Lemma dirr_constt_oppI (phi: 'CF(G)) : + dirr_constt phi :&: dirr_constt (-phi) = set0. +Proof. +apply/setP=> i; rewrite inE !dirr_consttE cfdotNl inE. +apply/idP=> /andP [L1 L2]; have := ltr_paddl (ltrW L1) L2. +by rewrite subrr ltr_def eqxx. +Qed. + +Lemma dirr_constt_oppl (phi: 'CF(G)) i : + i \in dirr_constt phi -> (ndirr i) \notin dirr_constt phi. +Proof. +rewrite !dirr_consttE dchi_ndirrE cfdotNr oppr_gt0. +by move/ltrW=> /ler_gtF ->. +Qed. + +Definition to_dirr (B : {set gT}) (phi : 'CF(B)) (i : Iirr B) : dIirr B := + ('[phi, 'chi_i] < 0, i). + +Definition of_irr (B : {set gT}) (i : dIirr B) : Iirr B := i.2. + +Lemma irr_constt_to_dirr (phi: 'CF(G)) i : phi \in 'Z[irr G] -> + (i \in irr_constt phi) = (to_dirr phi i \in dirr_constt phi). +Proof. +move=> Zphi; rewrite irr_consttE dirr_consttE cfdotZr rmorph_sign /=. +by rewrite -real_normrEsign ?normr_gt0 ?Creal_Cint // Cint_cfdot_vchar_irr. +Qed. + +Lemma to_dirrK (phi: 'CF(G)) : cancel (to_dirr phi) (@of_irr G). +Proof. by []. Qed. + +Lemma of_irrK (phi: 'CF(G)) : + {in dirr_constt phi, cancel (@of_irr G) (to_dirr phi)}. +Proof. +case=> b i; rewrite dirr_consttE cfdotZr rmorph_sign /= /to_dirr mulr_sign. +by rewrite fun_if oppr_gt0; case: b => [|/ltrW/ler_gtF] ->. +Qed. + +Lemma cfdot_todirrE (phi: 'CF(G)) i (phi_i := dchi (to_dirr phi i)) : + '[phi, phi_i] *: phi_i = '[phi, 'chi_i] *: 'chi_i. +Proof. by rewrite cfdotZr rmorph_sign mulrC -scalerA signrZK. Qed. + +Lemma cfun_sum_dconstt (phi : 'CF(G)) : + phi \in 'Z[irr G] -> + phi = \sum_(i in dirr_constt phi) '[phi, dchi i] *: dchi i. +Proof. +(* GG -- rewrite pattern fails in trunk + move=> PiZ; rewrite [X in X = _]cfun_sum_constt. *) +move=> PiZ; rewrite {1}[phi]cfun_sum_constt. +rewrite (reindex (to_dirr phi))=> [/= |]; last first. + by exists (@of_irr _)=> //; exact: of_irrK . +by apply: eq_big=> i; rewrite ?irr_constt_to_dirr // cfdot_todirrE. +Qed. + +Lemma cnorm_dconstt (phi : 'CF(G)) : + phi \in 'Z[irr G] -> + '[phi] = \sum_(i in dirr_constt phi) '[phi, dchi i] ^+ 2. +Proof. +move=> PiZ; rewrite {1 2}(cfun_sum_dconstt PiZ). +rewrite cfdot_suml; apply: eq_bigr=> i IiD. +rewrite cfdot_sumr (bigD1 i) //= big1 ?addr0 => [|j /andP [JiD IdJ]]. + rewrite cfdotZr cfdotZl cfdot_dchi eqxx eq_sym (negPf (ndirr_diff i)). + by rewrite subr0 mulr1 aut_Cnat ?Cnat_dirr. +rewrite cfdotZr cfdotZl cfdot_dchi eq_sym (negPf IdJ) -natrB ?mulr0 //. +by rewrite (negPf (contraNneq _ (dirr_constt_oppl JiD))) => // <-. +Qed. + +Lemma dirr_small_norm (phi : 'CF(G)) n : + phi \in 'Z[irr G] -> '[phi] = n%:R -> (n < 4)%N -> + [/\ #|dirr_constt phi| = n, dirr_constt phi :&: dirr_constt (- phi) = set0 & + phi = \sum_(i in dirr_constt phi) dchi i]. +Proof. +move=> PiZ Pln; rewrite ltnNge -leC_nat => Nl4. +suffices Fd i: i \in dirr_constt phi -> '[phi, dchi i] = 1. + split; last 2 [by apply/setP=> u; rewrite !inE cfdotNl oppr_gt0 ltr_asym]. + apply/eqP; rewrite -eqC_nat -sumr_const -Pln (cnorm_dconstt PiZ). + by apply/eqP/eq_bigr=> i Hi; rewrite Fd // expr1n. + rewrite {1}[phi]cfun_sum_dconstt //. + by apply: eq_bigr => i /Fd->; rewrite scale1r. +move=> IiD; apply: contraNeq Nl4 => phi_i_neq1. +rewrite -Pln cnorm_dconstt // (bigD1 i) ?ler_paddr ?sumr_ge0 //=. + by move=> j /andP[JiD _]; rewrite exprn_ge0 ?Cnat_ge0 ?Cnat_dirr. +have /CnatP[m Dm] := Cnat_dirr PiZ IiD; rewrite Dm -natrX ler_nat (leq_sqr 2). +by rewrite ltn_neqAle eq_sym -eqC_nat -ltC_nat -Dm phi_i_neq1 -dirr_consttE. +Qed. + +Lemma cfdot_sum_dchi (phi1 phi2 : 'CF(G)) : + '[\sum_(i in dirr_constt phi1) dchi i, + \sum_(i in dirr_constt phi2) dchi i] = + #|dirr_constt phi1 :&: dirr_constt phi2|%:R - + #|dirr_constt phi1 :&: dirr_constt (- phi2)|%:R. +Proof. +rewrite addrC (big_setID (dirr_constt (- phi2))) /= cfdotDl; congr (_ + _). + rewrite cfdot_suml -sumr_const -sumrN; apply: eq_bigr => i /setIP[p1i p2i]. + rewrite cfdot_sumr (bigD1 (ndirr i)) -?dirr_constt_oppr //= dchi_ndirrE. + rewrite cfdotNr cfnorm_dchi big1 ?addr0 // => j /andP[p2j i'j]. + rewrite cfdot_dchi -(inv_eq ndirrK) [in rhs in - rhs]eq_sym (negPf i'j) subr0. + rewrite (negPf (contraTneq _ p2i)) // => ->. + by rewrite dirr_constt_oppr dirr_constt_oppl. +rewrite cfdot_sumr (big_setID (dirr_constt phi1)) setIC /= addrC. +rewrite big1 ?add0r => [|j /setDP[p2j p1'j]]; last first. + rewrite cfdot_suml big1 // => i /setDP[p1i p2'i]. + rewrite cfdot_dchi (negPf (contraTneq _ p1i)) => [|-> //]. + rewrite (negPf (contraNneq _ p2'i)) ?subrr // => ->. + by rewrite dirr_constt_oppr ndirrK. +rewrite -sumr_const; apply: eq_bigr => i /setIP[p1i p2i]; rewrite cfdot_suml. +rewrite (bigD1 i) /=; last by rewrite inE dirr_constt_oppr dirr_constt_oppl. +rewrite cfnorm_dchi big1 ?addr0 // => j /andP[/setDP[p1j _] i'j]. +rewrite cfdot_dchi (negPf i'j) (negPf (contraTneq _ p1j)) ?subrr // => ->. +exact: dirr_constt_oppl. +Qed. + +Lemma cfdot_dirr_eq1 : + {in dirr G &, forall phi psi, ('[phi, psi] == 1) = (phi == psi)}. +Proof. +move=> _ _ /dirrP[b1 [i1 ->]] /dirrP[b2 [i2 ->]]. +rewrite eq_signed_irr cfdotZl cfdotZr rmorph_sign cfdot_irr mulrA -signr_addb. +rewrite pmulrn -rmorphMsign (eqr_int _ _ 1) -negb_add. +by case: (b1 (+) b2) (i1 == i2) => [] []. +Qed. + +Lemma cfdot_add_dirr_eq1 : + {in dirr G & &, forall phi1 phi2 psi, + '[phi1 + phi2, psi] = 1 -> psi = phi1 \/ psi = phi2}. +Proof. +move=> _ _ _ /dirrP[b1 [i1 ->]] /dirrP[b2 [i2 ->]] /dirrP[c [j ->]] /eqP. +rewrite cfdotDl !cfdotZl !cfdotZr !rmorph_sign !cfdot_irr !mulrA -!signr_addb. +rewrite 2!{1}signrE !mulrBl !mul1r -!natrM addrCA -subr_eq0 -!addrA. +rewrite -!opprD addrA subr_eq0 -mulrSr -!natrD eqr_nat => eq_phi_psi. +apply/pred2P; rewrite /= !eq_signed_irr -!negb_add !(eq_sym j) !(addbC c). +by case: (i1 == j) eq_phi_psi; case: (i2 == j); do 2!case: (_ (+) c). +Qed. + +End Norm1vchar. diff --git a/mathcomp/discrete/all.v b/mathcomp/discrete/all.v new file mode 100644 index 0000000..d100add --- /dev/null +++ b/mathcomp/discrete/all.v @@ -0,0 +1,12 @@ +Require Export bigop. +Require Export binomial. +Require Export choice. +Require Export div. +Require Export finfun. +Require Export fingraph. +Require Export finset. +Require Export fintype. +Require Export generic_quotient. +Require Export path. +Require Export prime. +Require Export tuple. diff --git a/mathcomp/discrete/bigop.v b/mathcomp/discrete/bigop.v new file mode 100644 index 0000000..88bf4d2 --- /dev/null +++ b/mathcomp/discrete/bigop.v @@ -0,0 +1,1770 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div fintype. +Require Import tuple finfun. + +(******************************************************************************) +(* This file provides a generic definition for iterating an operator over a *) +(* set of indices (reducebig); this big operator is parametrized by the *) +(* return type (R), the type of indices (I), the operator (op), the default *) +(* value on empty lists (idx), the range of indices (r), the filter applied *) +(* on this range (P) and the expression we are iterating (F). The definition *) +(* is not to be used directly, but via the wide range of notations provided *) +(* and which allows a natural use of big operators. *) +(* The lemmas can be classified according to the operator being iterated: *) +(* 1. results independent of the operator: extensionality with respect to *) +(* the range of indices, to the filtering predicate or to the expression *) +(* being iterated; reindexing, widening or narrowing of the range of *) +(* indices; we provide lemmas for the special cases where indices are *) +(* natural numbers or bounded natural numbers ("ordinals"). We supply *) +(* several "functional" induction principles that can be used with the *) +(* ssreflect 1.3 "elim" tactic to do induction over the index range for *) +(* up to 3 bigops simultaneously. *) +(* 2. results depending on the properties of the operator: *) +(* We distinguish: monoid laws (op is associative, idx is an identity *) +(* element), abelian monoid laws (op is also commutative), and laws with *) +(* a distributive operation (semi-rings). Examples of such results are *) +(* splitting, permuting, and exchanging bigops. *) +(* A special section is dedicated to big operators on natural numbers. *) +(******************************************************************************) +(* Notations: *) +(* The general form for iterated operators is *) +(* _ *) +(* - is one of \big[op/idx], \sum, \prod, or \max (see below). *) +(* - can be any expression. *) +(* - binds an index variable in ; is one of *) +(* (i <- s) i ranges over the sequence s *) +(* (m <= i < n) i ranges over the nat interval m, m.+1, ..., n.-1 *) +(* (i < n) i ranges over the (finite) type 'I_n (i.e., ordinal n) *) +(* (i : T) i ranges over the finite type T *) +(* i or (i) i ranges over its (inferred) finite type *) +(* (i in A) i ranges over the elements that satisfy the collective *) +(* predicate A (the domain of A must be a finite type) *) +(* (i <- s | ) limits the range to the i for which *) +(* holds. can be any expression that coerces to *) +(* bool, and may mention the bound index i. All six kinds of *) +(* ranges above can have a part. *) +(* - One can use the "\big[op/idx]" notations for any operator. *) +(* - BIG_F and BIG_P are pattern abbreviations for the and *) +(* part of a \big ... expression; for (i in A) and (i in A | C) *) +(* ranges the term matched by BIG_P will include the i \in A condition. *) +(* - The (locked) head constant of a \big notation is bigop. *) +(* - The "\sum", "\prod" and "\max" notations in the %N scope are used for *) +(* natural numbers with addition, multiplication and maximum (and their *) +(* corresponding neutral elements), respectively. *) +(* - The "\sum" and "\prod" reserved notations are overloaded in ssralg in *) +(* the %R scope, in mxalgebra, vector & falgebra in the %MS and %VS scopes; *) +(* "\prod" is also overloaded in fingroup, the %g and %G scopes. *) +(* - We reserve "\bigcup" and "\bigcap" notations for iterated union and *) +(* intersection (of sets, groups, vector spaces, etc). *) +(******************************************************************************) +(* Tips for using lemmas in this file: *) +(* to apply a lemma for a specific operator: if no special property is *) +(* required for the operator, simply apply the lemma; if the lemma needs *) +(* certain properties for the operator, make sure the appropriate Canonical *) +(* instances are declared. *) +(******************************************************************************) +(* Interfaces for operator properties are packaged in the Monoid submodule: *) +(* Monoid.law idx == interface (keyed on the operator) for associative *) +(* operators with identity element idx. *) +(* Monoid.com_law idx == extension (telescope) of Monoid.law for operators *) +(* that are also commutative. *) +(* Monoid.mul_law abz == interface for operators with absorbing (zero) *) +(* element abz. *) +(* Monoid.add_law idx mop == extension of Monoid.com_law for operators over *) +(* which operation mop distributes (mop will often also *) +(* have a Monoid.mul_law idx structure). *) +(* [law of op], [com_law of op], [mul_law of op], [add_law mop of op] == *) +(* syntax for cloning Monoid structures. *) +(* Monoid.Theory == submodule containing basic generic algebra lemmas *) +(* for operators satisfying the Monoid interfaces. *) +(* Monoid.simpm == generic monoid simplification rewrite multirule. *) +(* Monoid structures are predeclared for many basic operators: (_ && _)%B, *) +(* (_ || _)%B, (_ (+) _)%B (exclusive or) , (_ + _)%N, (_ * _)%N, maxn, *) +(* gcdn, lcmn and (_ ++ _)%SEQ (list concatenation). *) +(******************************************************************************) +(* Additional documentation for this file: *) +(* Y. Bertot, G. Gonthier, S. Ould Biha and I. Pasca. *) +(* Canonical Big Operators. In TPHOLs 2008, LNCS vol. 5170, Springer. *) +(* Article available at: *) +(* http://hal.inria.fr/docs/00/33/11/93/PDF/main.pdf *) +(******************************************************************************) +(* Examples of use in: poly.v, matrix.v *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Reserved Notation "\big [ op / idx ]_ i F" + (at level 36, F at level 36, op, idx at level 10, i at level 0, + right associativity, + format "'[' \big [ op / idx ]_ i '/ ' F ']'"). +Reserved Notation "\big [ op / idx ]_ ( i <- r | P ) F" + (at level 36, F at level 36, op, idx at level 10, i, r at level 50, + format "'[' \big [ op / idx ]_ ( i <- r | P ) '/ ' F ']'"). +Reserved Notation "\big [ op / idx ]_ ( i <- r ) F" + (at level 36, F at level 36, op, idx at level 10, i, r at level 50, + format "'[' \big [ op / idx ]_ ( i <- r ) '/ ' F ']'"). +Reserved Notation "\big [ op / idx ]_ ( m <= i < n | P ) F" + (at level 36, F at level 36, op, idx at level 10, m, i, n at level 50, + format "'[' \big [ op / idx ]_ ( m <= i < n | P ) F ']'"). +Reserved Notation "\big [ op / idx ]_ ( m <= i < n ) F" + (at level 36, F at level 36, op, idx at level 10, i, m, n at level 50, + format "'[' \big [ op / idx ]_ ( m <= i < n ) '/ ' F ']'"). +Reserved Notation "\big [ op / idx ]_ ( i | P ) F" + (at level 36, F at level 36, op, idx at level 10, i at level 50, + format "'[' \big [ op / idx ]_ ( i | P ) '/ ' F ']'"). +Reserved Notation "\big [ op / idx ]_ ( i : t | P ) F" + (at level 36, F at level 36, op, idx at level 10, i at level 50, + format "'[' \big [ op / idx ]_ ( i : t | P ) '/ ' F ']'"). +Reserved Notation "\big [ op / idx ]_ ( i : t ) F" + (at level 36, F at level 36, op, idx at level 10, i at level 50, + format "'[' \big [ op / idx ]_ ( i : t ) '/ ' F ']'"). +Reserved Notation "\big [ op / idx ]_ ( i < n | P ) F" + (at level 36, F at level 36, op, idx at level 10, i, n at level 50, + format "'[' \big [ op / idx ]_ ( i < n | P ) '/ ' F ']'"). +Reserved Notation "\big [ op / idx ]_ ( i < n ) F" + (at level 36, F at level 36, op, idx at level 10, i, n at level 50, + format "'[' \big [ op / idx ]_ ( i < n ) F ']'"). +Reserved Notation "\big [ op / idx ]_ ( i 'in' A | P ) F" + (at level 36, F at level 36, op, idx at level 10, i, A at level 50, + format "'[' \big [ op / idx ]_ ( i 'in' A | P ) '/ ' F ']'"). +Reserved Notation "\big [ op / idx ]_ ( i 'in' A ) F" + (at level 36, F at level 36, op, idx at level 10, i, A at level 50, + format "'[' \big [ op / idx ]_ ( i 'in' A ) '/ ' F ']'"). + +Reserved Notation "\sum_ i F" + (at level 41, F at level 41, i at level 0, + right associativity, + format "'[' \sum_ i '/ ' F ']'"). +Reserved Notation "\sum_ ( i <- r | P ) F" + (at level 41, F at level 41, i, r at level 50, + format "'[' \sum_ ( i <- r | P ) '/ ' F ']'"). +Reserved Notation "\sum_ ( i <- r ) F" + (at level 41, F at level 41, i, r at level 50, + format "'[' \sum_ ( i <- r ) '/ ' F ']'"). +Reserved Notation "\sum_ ( m <= i < n | P ) F" + (at level 41, F at level 41, i, m, n at level 50, + format "'[' \sum_ ( m <= i < n | P ) '/ ' F ']'"). +Reserved Notation "\sum_ ( m <= i < n ) F" + (at level 41, F at level 41, i, m, n at level 50, + format "'[' \sum_ ( m <= i < n ) '/ ' F ']'"). +Reserved Notation "\sum_ ( i | P ) F" + (at level 41, F at level 41, i at level 50, + format "'[' \sum_ ( i | P ) '/ ' F ']'"). +Reserved Notation "\sum_ ( i : t | P ) F" + (at level 41, F at level 41, i at level 50, + only parsing). +Reserved Notation "\sum_ ( i : t ) F" + (at level 41, F at level 41, i at level 50, + only parsing). +Reserved Notation "\sum_ ( i < n | P ) F" + (at level 41, F at level 41, i, n at level 50, + format "'[' \sum_ ( i < n | P ) '/ ' F ']'"). +Reserved Notation "\sum_ ( i < n ) F" + (at level 41, F at level 41, i, n at level 50, + format "'[' \sum_ ( i < n ) '/ ' F ']'"). +Reserved Notation "\sum_ ( i 'in' A | P ) F" + (at level 41, F at level 41, i, A at level 50, + format "'[' \sum_ ( i 'in' A | P ) '/ ' F ']'"). +Reserved Notation "\sum_ ( i 'in' A ) F" + (at level 41, F at level 41, i, A at level 50, + format "'[' \sum_ ( i 'in' A ) '/ ' F ']'"). + +Reserved Notation "\max_ i F" + (at level 41, F at level 41, i at level 0, + format "'[' \max_ i '/ ' F ']'"). +Reserved Notation "\max_ ( i <- r | P ) F" + (at level 41, F at level 41, i, r at level 50, + format "'[' \max_ ( i <- r | P ) '/ ' F ']'"). +Reserved Notation "\max_ ( i <- r ) F" + (at level 41, F at level 41, i, r at level 50, + format "'[' \max_ ( i <- r ) '/ ' F ']'"). +Reserved Notation "\max_ ( m <= i < n | P ) F" + (at level 41, F at level 41, i, m, n at level 50, + format "'[' \max_ ( m <= i < n | P ) '/ ' F ']'"). +Reserved Notation "\max_ ( m <= i < n ) F" + (at level 41, F at level 41, i, m, n at level 50, + format "'[' \max_ ( m <= i < n ) '/ ' F ']'"). +Reserved Notation "\max_ ( i | P ) F" + (at level 41, F at level 41, i at level 50, + format "'[' \max_ ( i | P ) '/ ' F ']'"). +Reserved Notation "\max_ ( i : t | P ) F" + (at level 41, F at level 41, i at level 50, + only parsing). +Reserved Notation "\max_ ( i : t ) F" + (at level 41, F at level 41, i at level 50, + only parsing). +Reserved Notation "\max_ ( i < n | P ) F" + (at level 41, F at level 41, i, n at level 50, + format "'[' \max_ ( i < n | P ) '/ ' F ']'"). +Reserved Notation "\max_ ( i < n ) F" + (at level 41, F at level 41, i, n at level 50, + format "'[' \max_ ( i < n ) F ']'"). +Reserved Notation "\max_ ( i 'in' A | P ) F" + (at level 41, F at level 41, i, A at level 50, + format "'[' \max_ ( i 'in' A | P ) '/ ' F ']'"). +Reserved Notation "\max_ ( i 'in' A ) F" + (at level 41, F at level 41, i, A at level 50, + format "'[' \max_ ( i 'in' A ) '/ ' F ']'"). + +Reserved Notation "\prod_ i F" + (at level 36, F at level 36, i at level 0, + format "'[' \prod_ i '/ ' F ']'"). +Reserved Notation "\prod_ ( i <- r | P ) F" + (at level 36, F at level 36, i, r at level 50, + format "'[' \prod_ ( i <- r | P ) '/ ' F ']'"). +Reserved Notation "\prod_ ( i <- r ) F" + (at level 36, F at level 36, i, r at level 50, + format "'[' \prod_ ( i <- r ) '/ ' F ']'"). +Reserved Notation "\prod_ ( m <= i < n | P ) F" + (at level 36, F at level 36, i, m, n at level 50, + format "'[' \prod_ ( m <= i < n | P ) '/ ' F ']'"). +Reserved Notation "\prod_ ( m <= i < n ) F" + (at level 36, F at level 36, i, m, n at level 50, + format "'[' \prod_ ( m <= i < n ) '/ ' F ']'"). +Reserved Notation "\prod_ ( i | P ) F" + (at level 36, F at level 36, i at level 50, + format "'[' \prod_ ( i | P ) '/ ' F ']'"). +Reserved Notation "\prod_ ( i : t | P ) F" + (at level 36, F at level 36, i at level 50, + only parsing). +Reserved Notation "\prod_ ( i : t ) F" + (at level 36, F at level 36, i at level 50, + only parsing). +Reserved Notation "\prod_ ( i < n | P ) F" + (at level 36, F at level 36, i, n at level 50, + format "'[' \prod_ ( i < n | P ) '/ ' F ']'"). +Reserved Notation "\prod_ ( i < n ) F" + (at level 36, F at level 36, i, n at level 50, + format "'[' \prod_ ( i < n ) '/ ' F ']'"). +Reserved Notation "\prod_ ( i 'in' A | P ) F" + (at level 36, F at level 36, i, A at level 50, + format "'[' \prod_ ( i 'in' A | P ) F ']'"). +Reserved Notation "\prod_ ( i 'in' A ) F" + (at level 36, F at level 36, i, A at level 50, + format "'[' \prod_ ( i 'in' A ) '/ ' F ']'"). + +Reserved Notation "\bigcup_ i F" + (at level 41, F at level 41, i at level 0, + format "'[' \bigcup_ i '/ ' F ']'"). +Reserved Notation "\bigcup_ ( i <- r | P ) F" + (at level 41, F at level 41, i, r at level 50, + format "'[' \bigcup_ ( i <- r | P ) '/ ' F ']'"). +Reserved Notation "\bigcup_ ( i <- r ) F" + (at level 41, F at level 41, i, r at level 50, + format "'[' \bigcup_ ( i <- r ) '/ ' F ']'"). +Reserved Notation "\bigcup_ ( m <= i < n | P ) F" + (at level 41, F at level 41, m, i, n at level 50, + format "'[' \bigcup_ ( m <= i < n | P ) '/ ' F ']'"). +Reserved Notation "\bigcup_ ( m <= i < n ) F" + (at level 41, F at level 41, i, m, n at level 50, + format "'[' \bigcup_ ( m <= i < n ) '/ ' F ']'"). +Reserved Notation "\bigcup_ ( i | P ) F" + (at level 41, F at level 41, i at level 50, + format "'[' \bigcup_ ( i | P ) '/ ' F ']'"). +Reserved Notation "\bigcup_ ( i : t | P ) F" + (at level 41, F at level 41, i at level 50, + format "'[' \bigcup_ ( i : t | P ) '/ ' F ']'"). +Reserved Notation "\bigcup_ ( i : t ) F" + (at level 41, F at level 41, i at level 50, + format "'[' \bigcup_ ( i : t ) '/ ' F ']'"). +Reserved Notation "\bigcup_ ( i < n | P ) F" + (at level 41, F at level 41, i, n at level 50, + format "'[' \bigcup_ ( i < n | P ) '/ ' F ']'"). +Reserved Notation "\bigcup_ ( i < n ) F" + (at level 41, F at level 41, i, n at level 50, + format "'[' \bigcup_ ( i < n ) '/ ' F ']'"). +Reserved Notation "\bigcup_ ( i 'in' A | P ) F" + (at level 41, F at level 41, i, A at level 50, + format "'[' \bigcup_ ( i 'in' A | P ) '/ ' F ']'"). +Reserved Notation "\bigcup_ ( i 'in' A ) F" + (at level 41, F at level 41, i, A at level 50, + format "'[' \bigcup_ ( i 'in' A ) '/ ' F ']'"). + +Reserved Notation "\bigcap_ i F" + (at level 41, F at level 41, i at level 0, + format "'[' \bigcap_ i '/ ' F ']'"). +Reserved Notation "\bigcap_ ( i <- r | P ) F" + (at level 41, F at level 41, i, r at level 50, + format "'[' \bigcap_ ( i <- r | P ) F ']'"). +Reserved Notation "\bigcap_ ( i <- r ) F" + (at level 41, F at level 41, i, r at level 50, + format "'[' \bigcap_ ( i <- r ) '/ ' F ']'"). +Reserved Notation "\bigcap_ ( m <= i < n | P ) F" + (at level 41, F at level 41, m, i, n at level 50, + format "'[' \bigcap_ ( m <= i < n | P ) '/ ' F ']'"). +Reserved Notation "\bigcap_ ( m <= i < n ) F" + (at level 41, F at level 41, i, m, n at level 50, + format "'[' \bigcap_ ( m <= i < n ) '/ ' F ']'"). +Reserved Notation "\bigcap_ ( i | P ) F" + (at level 41, F at level 41, i at level 50, + format "'[' \bigcap_ ( i | P ) '/ ' F ']'"). +Reserved Notation "\bigcap_ ( i : t | P ) F" + (at level 41, F at level 41, i at level 50, + format "'[' \bigcap_ ( i : t | P ) '/ ' F ']'"). +Reserved Notation "\bigcap_ ( i : t ) F" + (at level 41, F at level 41, i at level 50, + format "'[' \bigcap_ ( i : t ) '/ ' F ']'"). +Reserved Notation "\bigcap_ ( i < n | P ) F" + (at level 41, F at level 41, i, n at level 50, + format "'[' \bigcap_ ( i < n | P ) '/ ' F ']'"). +Reserved Notation "\bigcap_ ( i < n ) F" + (at level 41, F at level 41, i, n at level 50, + format "'[' \bigcap_ ( i < n ) '/ ' F ']'"). +Reserved Notation "\bigcap_ ( i 'in' A | P ) F" + (at level 41, F at level 41, i, A at level 50, + format "'[' \bigcap_ ( i 'in' A | P ) '/ ' F ']'"). +Reserved Notation "\bigcap_ ( i 'in' A ) F" + (at level 41, F at level 41, i, A at level 50, + format "'[' \bigcap_ ( i 'in' A ) '/ ' F ']'"). + +Module Monoid. + +Section Definitions. +Variables (T : Type) (idm : T). + +Structure law := Law { + operator : T -> T -> T; + _ : associative operator; + _ : left_id idm operator; + _ : right_id idm operator +}. +Local Coercion operator : law >-> Funclass. + +Structure com_law := ComLaw { + com_operator : law; + _ : commutative com_operator +}. +Local Coercion com_operator : com_law >-> law. + +Structure mul_law := MulLaw { + mul_operator : T -> T -> T; + _ : left_zero idm mul_operator; + _ : right_zero idm mul_operator +}. +Local Coercion mul_operator : mul_law >-> Funclass. + +Structure add_law (mul : T -> T -> T) := AddLaw { + add_operator : com_law; + _ : left_distributive mul add_operator; + _ : right_distributive mul add_operator +}. +Local Coercion add_operator : add_law >-> com_law. + +Let op_id (op1 op2 : T -> T -> T) := phant_id op1 op2. + +Definition clone_law op := + fun (opL : law) & op_id opL op => + fun opmA op1m opm1 (opL' := @Law op opmA op1m opm1) + & phant_id opL' opL => opL'. + +Definition clone_com_law op := + fun (opL : law) (opC : com_law) & op_id opL op & op_id opC op => + fun opmC (opC' := @ComLaw opL opmC) & phant_id opC' opC => opC'. + +Definition clone_mul_law op := + fun (opM : mul_law) & op_id opM op => + fun op0m opm0 (opM' := @MulLaw op op0m opm0) & phant_id opM' opM => opM'. + +Definition clone_add_law mop aop := + fun (opC : com_law) (opA : add_law mop) & op_id opC aop & op_id opA aop => + fun mopDm mopmD (opA' := @AddLaw mop opC mopDm mopmD) + & phant_id opA' opA => opA'. + +End Definitions. + +Module Import Exports. +Coercion operator : law >-> Funclass. +Coercion com_operator : com_law >-> law. +Coercion mul_operator : mul_law >-> Funclass. +Coercion add_operator : add_law >-> com_law. +Notation "[ 'law' 'of' f ]" := (@clone_law _ _ f _ id _ _ _ id) + (at level 0, format"[ 'law' 'of' f ]") : form_scope. +Notation "[ 'com_law' 'of' f ]" := (@clone_com_law _ _ f _ _ id id _ id) + (at level 0, format "[ 'com_law' 'of' f ]") : form_scope. +Notation "[ 'mul_law' 'of' f ]" := (@clone_mul_law _ _ f _ id _ _ id) + (at level 0, format"[ 'mul_law' 'of' f ]") : form_scope. +Notation "[ 'add_law' m 'of' a ]" := (@clone_add_law _ _ m a _ _ id id _ _ id) + (at level 0, format "[ 'add_law' m 'of' a ]") : form_scope. +End Exports. + +Section CommutativeAxioms. + +Variable (T : Type) (zero one : T) (mul add : T -> T -> T) (inv : T -> T). +Hypothesis mulC : commutative mul. + +Lemma mulC_id : left_id one mul -> right_id one mul. +Proof. by move=> mul1x x; rewrite mulC. Qed. + +Lemma mulC_zero : left_zero zero mul -> right_zero zero mul. +Proof. by move=> mul0x x; rewrite mulC. Qed. + +Lemma mulC_dist : left_distributive mul add -> right_distributive mul add. +Proof. by move=> mul_addl x y z; rewrite !(mulC x). Qed. + +End CommutativeAxioms. + +Module Theory. + +Section Theory. +Variables (T : Type) (idm : T). + +Section Plain. +Variable mul : law idm. +Lemma mul1m : left_id idm mul. Proof. by case mul. Qed. +Lemma mulm1 : right_id idm mul. Proof. by case mul. Qed. +Lemma mulmA : associative mul. Proof. by case mul. Qed. +Lemma iteropE n x : iterop n mul x idm = iter n (mul x) idm. +Proof. by case: n => // n; rewrite iterSr mulm1 iteropS. Qed. +End Plain. + +Section Commutative. +Variable mul : com_law idm. +Lemma mulmC : commutative mul. Proof. by case mul. Qed. +Lemma mulmCA : left_commutative mul. +Proof. by move=> x y z; rewrite !mulmA (mulmC x). Qed. +Lemma mulmAC : right_commutative mul. +Proof. by move=> x y z; rewrite -!mulmA (mulmC y). Qed. +Lemma mulmACA : interchange mul mul. +Proof. by move=> x y z t; rewrite -!mulmA (mulmCA y). Qed. +End Commutative. + +Section Mul. +Variable mul : mul_law idm. +Lemma mul0m : left_zero idm mul. Proof. by case mul. Qed. +Lemma mulm0 : right_zero idm mul. Proof. by case mul. Qed. +End Mul. + +Section Add. +Variables (mul : T -> T -> T) (add : add_law idm mul). +Lemma addmA : associative add. Proof. exact: mulmA. Qed. +Lemma addmC : commutative add. Proof. exact: mulmC. Qed. +Lemma addmCA : left_commutative add. Proof. exact: mulmCA. Qed. +Lemma addmAC : right_commutative add. Proof. exact: mulmAC. Qed. +Lemma add0m : left_id idm add. Proof. exact: mul1m. Qed. +Lemma addm0 : right_id idm add. Proof. exact: mulm1. Qed. +Lemma mulm_addl : left_distributive mul add. Proof. by case add. Qed. +Lemma mulm_addr : right_distributive mul add. Proof. by case add. Qed. +End Add. + +Definition simpm := (mulm1, mulm0, mul1m, mul0m, mulmA). + +End Theory. + +End Theory. +Include Theory. + +End Monoid. +Export Monoid.Exports. + +Section PervasiveMonoids. + +Import Monoid. + +Canonical andb_monoid := Law andbA andTb andbT. +Canonical andb_comoid := ComLaw andbC. + +Canonical andb_muloid := MulLaw andFb andbF. +Canonical orb_monoid := Law orbA orFb orbF. +Canonical orb_comoid := ComLaw orbC. +Canonical orb_muloid := MulLaw orTb orbT. +Canonical addb_monoid := Law addbA addFb addbF. +Canonical addb_comoid := ComLaw addbC. +Canonical orb_addoid := AddLaw andb_orl andb_orr. +Canonical andb_addoid := AddLaw orb_andl orb_andr. +Canonical addb_addoid := AddLaw andb_addl andb_addr. + +Canonical addn_monoid := Law addnA add0n addn0. +Canonical addn_comoid := ComLaw addnC. +Canonical muln_monoid := Law mulnA mul1n muln1. +Canonical muln_comoid := ComLaw mulnC. +Canonical muln_muloid := MulLaw mul0n muln0. +Canonical addn_addoid := AddLaw mulnDl mulnDr. + +Canonical maxn_monoid := Law maxnA max0n maxn0. +Canonical maxn_comoid := ComLaw maxnC. +Canonical maxn_addoid := AddLaw maxn_mull maxn_mulr. + +Canonical gcdn_monoid := Law gcdnA gcd0n gcdn0. +Canonical gcdn_comoid := ComLaw gcdnC. +Canonical gcdnDoid := AddLaw muln_gcdl muln_gcdr. + +Canonical lcmn_monoid := Law lcmnA lcm1n lcmn1. +Canonical lcmn_comoid := ComLaw lcmnC. +Canonical lcmn_addoid := AddLaw muln_lcml muln_lcmr. + +Canonical cat_monoid T := Law (@catA T) (@cat0s T) (@cats0 T). + +End PervasiveMonoids. + +(* Unit test for the [...law of ...] Notations +Definition myp := addn. Definition mym := muln. +Canonical myp_mon := [law of myp]. +Canonical myp_cmon := [com_law of myp]. +Canonical mym_mul := [mul_law of mym]. +Canonical myp_add := [add_law _ of myp]. +Print myp_add. +Print Canonical Projections. +*) + +Delimit Scope big_scope with BIG. +Open Scope big_scope. + +(* The bigbody wrapper is a workaround for a quirk of the Coq pretty-printer, *) +(* which would fail to redisplay the \big notation when the or *) +(* do not depend on the bound index. The BigBody constructor *) +(* packages both in in a term in which i occurs; it also depends on the *) +(* iterated , as this can give more information on the expected type of *) +(* the , thus allowing for the insertion of coercions. *) +CoInductive bigbody R I := BigBody of I & (R -> R -> R) & bool & R. + +Definition applybig {R I} (body : bigbody R I) x := + let: BigBody _ op b v := body in if b then op v x else x. + +Definition reducebig R I idx r (body : I -> bigbody R I) := + foldr (applybig \o body) idx r. + +Module Type BigOpSig. +Parameter bigop : forall R I, R -> seq I -> (I -> bigbody R I) -> R. +Axiom bigopE : bigop = reducebig. +End BigOpSig. + +Module BigOp : BigOpSig. +Definition bigop := reducebig. +Lemma bigopE : bigop = reducebig. Proof. by []. Qed. +End BigOp. + +Notation bigop := BigOp.bigop (only parsing). +Canonical bigop_unlock := Unlockable BigOp.bigopE. + +Definition index_iota m n := iota m (n - m). + +Definition index_enum (T : finType) := Finite.enum T. + +Lemma mem_index_iota m n i : i \in index_iota m n = (m <= i < n). +Proof. +rewrite mem_iota; case le_m_i: (m <= i) => //=. +by rewrite -leq_subLR subSn // -subn_gt0 -subnDA subnKC // subn_gt0. +Qed. + +Lemma mem_index_enum T i : i \in index_enum T. +Proof. by rewrite -[index_enum T]enumT mem_enum. Qed. +Hint Resolve mem_index_enum. + +Lemma filter_index_enum T P : filter P (index_enum T) = enum P. +Proof. by []. Qed. + +Notation "\big [ op / idx ]_ ( i <- r | P ) F" := + (bigop idx r (fun i => BigBody i op P%B F)) : big_scope. +Notation "\big [ op / idx ]_ ( i <- r ) F" := + (bigop idx r (fun i => BigBody i op true F)) : big_scope. +Notation "\big [ op / idx ]_ ( m <= i < n | P ) F" := + (bigop idx (index_iota m n) (fun i : nat => BigBody i op P%B F)) + : big_scope. +Notation "\big [ op / idx ]_ ( m <= i < n ) F" := + (bigop idx (index_iota m n) (fun i : nat => BigBody i op true F)) + : big_scope. +Notation "\big [ op / idx ]_ ( i | P ) F" := + (bigop idx (index_enum _) (fun i => BigBody i op P%B F)) : big_scope. +Notation "\big [ op / idx ]_ i F" := + (bigop idx (index_enum _) (fun i => BigBody i op true F)) : big_scope. +Notation "\big [ op / idx ]_ ( i : t | P ) F" := + (bigop idx (index_enum _) (fun i : t => BigBody i op P%B F)) + (only parsing) : big_scope. +Notation "\big [ op / idx ]_ ( i : t ) F" := + (bigop idx (index_enum _) (fun i : t => BigBody i op true F)) + (only parsing) : big_scope. +Notation "\big [ op / idx ]_ ( i < n | P ) F" := + (\big[op/idx]_(i : ordinal n | P%B) F) : big_scope. +Notation "\big [ op / idx ]_ ( i < n ) F" := + (\big[op/idx]_(i : ordinal n) F) : big_scope. +Notation "\big [ op / idx ]_ ( i 'in' A | P ) F" := + (\big[op/idx]_(i | (i \in A) && P) F) : big_scope. +Notation "\big [ op / idx ]_ ( i 'in' A ) F" := + (\big[op/idx]_(i | i \in A) F) : big_scope. + +Notation BIG_F := (F in \big[_/_]_(i <- _ | _) F i)%pattern. +Notation BIG_P := (P in \big[_/_]_(i <- _ | P i) _)%pattern. + +Local Notation "+%N" := addn (at level 0, only parsing). +Notation "\sum_ ( i <- r | P ) F" := + (\big[+%N/0%N]_(i <- r | P%B) F%N) : nat_scope. +Notation "\sum_ ( i <- r ) F" := + (\big[+%N/0%N]_(i <- r) F%N) : nat_scope. +Notation "\sum_ ( m <= i < n | P ) F" := + (\big[+%N/0%N]_(m <= i < n | P%B) F%N) : nat_scope. +Notation "\sum_ ( m <= i < n ) F" := + (\big[+%N/0%N]_(m <= i < n) F%N) : nat_scope. +Notation "\sum_ ( i | P ) F" := + (\big[+%N/0%N]_(i | P%B) F%N) : nat_scope. +Notation "\sum_ i F" := + (\big[+%N/0%N]_i F%N) : nat_scope. +Notation "\sum_ ( i : t | P ) F" := + (\big[+%N/0%N]_(i : t | P%B) F%N) (only parsing) : nat_scope. +Notation "\sum_ ( i : t ) F" := + (\big[+%N/0%N]_(i : t) F%N) (only parsing) : nat_scope. +Notation "\sum_ ( i < n | P ) F" := + (\big[+%N/0%N]_(i < n | P%B) F%N) : nat_scope. +Notation "\sum_ ( i < n ) F" := + (\big[+%N/0%N]_(i < n) F%N) : nat_scope. +Notation "\sum_ ( i 'in' A | P ) F" := + (\big[+%N/0%N]_(i in A | P%B) F%N) : nat_scope. +Notation "\sum_ ( i 'in' A ) F" := + (\big[+%N/0%N]_(i in A) F%N) : nat_scope. + +Local Notation "*%N" := muln (at level 0, only parsing). +Notation "\prod_ ( i <- r | P ) F" := + (\big[*%N/1%N]_(i <- r | P%B) F%N) : nat_scope. +Notation "\prod_ ( i <- r ) F" := + (\big[*%N/1%N]_(i <- r) F%N) : nat_scope. +Notation "\prod_ ( m <= i < n | P ) F" := + (\big[*%N/1%N]_(m <= i < n | P%B) F%N) : nat_scope. +Notation "\prod_ ( m <= i < n ) F" := + (\big[*%N/1%N]_(m <= i < n) F%N) : nat_scope. +Notation "\prod_ ( i | P ) F" := + (\big[*%N/1%N]_(i | P%B) F%N) : nat_scope. +Notation "\prod_ i F" := + (\big[*%N/1%N]_i F%N) : nat_scope. +Notation "\prod_ ( i : t | P ) F" := + (\big[*%N/1%N]_(i : t | P%B) F%N) (only parsing) : nat_scope. +Notation "\prod_ ( i : t ) F" := + (\big[*%N/1%N]_(i : t) F%N) (only parsing) : nat_scope. +Notation "\prod_ ( i < n | P ) F" := + (\big[*%N/1%N]_(i < n | P%B) F%N) : nat_scope. +Notation "\prod_ ( i < n ) F" := + (\big[*%N/1%N]_(i < n) F%N) : nat_scope. +Notation "\prod_ ( i 'in' A | P ) F" := + (\big[*%N/1%N]_(i in A | P%B) F%N) : nat_scope. +Notation "\prod_ ( i 'in' A ) F" := + (\big[*%N/1%N]_(i in A) F%N) : nat_scope. + +Notation "\max_ ( i <- r | P ) F" := + (\big[maxn/0%N]_(i <- r | P%B) F%N) : nat_scope. +Notation "\max_ ( i <- r ) F" := + (\big[maxn/0%N]_(i <- r) F%N) : nat_scope. +Notation "\max_ ( i | P ) F" := + (\big[maxn/0%N]_(i | P%B) F%N) : nat_scope. +Notation "\max_ i F" := + (\big[maxn/0%N]_i F%N) : nat_scope. +Notation "\max_ ( i : I | P ) F" := + (\big[maxn/0%N]_(i : I | P%B) F%N) (only parsing) : nat_scope. +Notation "\max_ ( i : I ) F" := + (\big[maxn/0%N]_(i : I) F%N) (only parsing) : nat_scope. +Notation "\max_ ( m <= i < n | P ) F" := + (\big[maxn/0%N]_(m <= i < n | P%B) F%N) : nat_scope. +Notation "\max_ ( m <= i < n ) F" := + (\big[maxn/0%N]_(m <= i < n) F%N) : nat_scope. +Notation "\max_ ( i < n | P ) F" := + (\big[maxn/0%N]_(i < n | P%B) F%N) : nat_scope. +Notation "\max_ ( i < n ) F" := + (\big[maxn/0%N]_(i < n) F%N) : nat_scope. +Notation "\max_ ( i 'in' A | P ) F" := + (\big[maxn/0%N]_(i in A | P%B) F%N) : nat_scope. +Notation "\max_ ( i 'in' A ) F" := + (\big[maxn/0%N]_(i in A) F%N) : nat_scope. + +(* Induction loading *) +Lemma big_load R (K K' : R -> Type) idx op I r (P : pred I) F : + K (\big[op/idx]_(i <- r | P i) F i) * K' (\big[op/idx]_(i <- r | P i) F i) + -> K' (\big[op/idx]_(i <- r | P i) F i). +Proof. by case. Qed. + +Implicit Arguments big_load [R K' I]. + +Section Elim3. + +Variables (R1 R2 R3 : Type) (K : R1 -> R2 -> R3 -> Type). +Variables (id1 : R1) (op1 : R1 -> R1 -> R1). +Variables (id2 : R2) (op2 : R2 -> R2 -> R2). +Variables (id3 : R3) (op3 : R3 -> R3 -> R3). + +Hypothesis Kid : K id1 id2 id3. + +Lemma big_rec3 I r (P : pred I) F1 F2 F3 + (K_F : forall i y1 y2 y3, P i -> K y1 y2 y3 -> + K (op1 (F1 i) y1) (op2 (F2 i) y2) (op3 (F3 i) y3)) : + K (\big[op1/id1]_(i <- r | P i) F1 i) + (\big[op2/id2]_(i <- r | P i) F2 i) + (\big[op3/id3]_(i <- r | P i) F3 i). +Proof. by rewrite unlock; elim: r => //= i r; case: ifP => //; exact: K_F. Qed. + +Hypothesis Kop : forall x1 x2 x3 y1 y2 y3, + K x1 x2 x3 -> K y1 y2 y3-> K (op1 x1 y1) (op2 x2 y2) (op3 x3 y3). +Lemma big_ind3 I r (P : pred I) F1 F2 F3 + (K_F : forall i, P i -> K (F1 i) (F2 i) (F3 i)) : + K (\big[op1/id1]_(i <- r | P i) F1 i) + (\big[op2/id2]_(i <- r | P i) F2 i) + (\big[op3/id3]_(i <- r | P i) F3 i). +Proof. by apply: big_rec3 => i x1 x2 x3 /K_F; exact: Kop. Qed. + +End Elim3. + +Implicit Arguments big_rec3 [R1 R2 R3 id1 op1 id2 op2 id3 op3 I r P F1 F2 F3]. +Implicit Arguments big_ind3 [R1 R2 R3 id1 op1 id2 op2 id3 op3 I r P F1 F2 F3]. + +Section Elim2. + +Variables (R1 R2 : Type) (K : R1 -> R2 -> Type) (f : R2 -> R1). +Variables (id1 : R1) (op1 : R1 -> R1 -> R1). +Variables (id2 : R2) (op2 : R2 -> R2 -> R2). + +Hypothesis Kid : K id1 id2. + +Lemma big_rec2 I r (P : pred I) F1 F2 + (K_F : forall i y1 y2, P i -> K y1 y2 -> + K (op1 (F1 i) y1) (op2 (F2 i) y2)) : + K (\big[op1/id1]_(i <- r | P i) F1 i) (\big[op2/id2]_(i <- r | P i) F2 i). +Proof. by rewrite unlock; elim: r => //= i r; case: ifP => //; exact: K_F. Qed. + +Hypothesis Kop : forall x1 x2 y1 y2, + K x1 x2 -> K y1 y2 -> K (op1 x1 y1) (op2 x2 y2). +Lemma big_ind2 I r (P : pred I) F1 F2 (K_F : forall i, P i -> K (F1 i) (F2 i)) : + K (\big[op1/id1]_(i <- r | P i) F1 i) (\big[op2/id2]_(i <- r | P i) F2 i). +Proof. by apply: big_rec2 => i x1 x2 /K_F; exact: Kop. Qed. + +Hypotheses (f_op : {morph f : x y / op2 x y >-> op1 x y}) (f_id : f id2 = id1). +Lemma big_morph I r (P : pred I) F : + f (\big[op2/id2]_(i <- r | P i) F i) = \big[op1/id1]_(i <- r | P i) f (F i). +Proof. by rewrite unlock; elim: r => //= i r <-; rewrite -f_op -fun_if. Qed. + +End Elim2. + +Implicit Arguments big_rec2 [R1 R2 id1 op1 id2 op2 I r P F1 F2]. +Implicit Arguments big_ind2 [R1 R2 id1 op1 id2 op2 I r P F1 F2]. +Implicit Arguments big_morph [R1 R2 id1 op1 id2 op2 I]. + +Section Elim1. + +Variables (R : Type) (K : R -> Type) (f : R -> R). +Variables (idx : R) (op op' : R -> R -> R). + +Hypothesis Kid : K idx. + +Lemma big_rec I r (P : pred I) F + (Kop : forall i x, P i -> K x -> K (op (F i) x)) : + K (\big[op/idx]_(i <- r | P i) F i). +Proof. by rewrite unlock; elim: r => //= i r; case: ifP => //; exact: Kop. Qed. + +Hypothesis Kop : forall x y, K x -> K y -> K (op x y). +Lemma big_ind I r (P : pred I) F (K_F : forall i, P i -> K (F i)) : + K (\big[op/idx]_(i <- r | P i) F i). +Proof. by apply: big_rec => // i x /K_F /Kop; exact. Qed. + +Hypothesis Kop' : forall x y, K x -> K y -> op x y = op' x y. +Lemma eq_big_op I r (P : pred I) F (K_F : forall i, P i -> K (F i)) : + \big[op/idx]_(i <- r | P i) F i = \big[op'/idx]_(i <- r | P i) F i. +Proof. +by elim/(big_load K): _; elim/big_rec2: _ => // i _ y Pi [Ky <-]; auto. +Qed. + +Hypotheses (fM : {morph f : x y / op x y}) (f_id : f idx = idx). +Lemma big_endo I r (P : pred I) F : + f (\big[op/idx]_(i <- r | P i) F i) = \big[op/idx]_(i <- r | P i) f (F i). +Proof. exact: big_morph. Qed. + +End Elim1. + +Implicit Arguments big_rec [R idx op I r P F]. +Implicit Arguments big_ind [R idx op I r P F]. +Implicit Arguments eq_big_op [R idx op I]. +Implicit Arguments big_endo [R idx op I]. + +Section Extensionality. + +Variables (R : Type) (idx : R) (op : R -> R -> R). + +Section SeqExtension. + +Variable I : Type. + +Lemma big_filter r (P : pred I) F : + \big[op/idx]_(i <- filter P r) F i = \big[op/idx]_(i <- r | P i) F i. +Proof. by rewrite unlock; elim: r => //= i r <-; case (P i). Qed. + +Lemma big_filter_cond r (P1 P2 : pred I) F : + \big[op/idx]_(i <- filter P1 r | P2 i) F i + = \big[op/idx]_(i <- r | P1 i && P2 i) F i. +Proof. +rewrite -big_filter -(big_filter r); congr bigop. +rewrite -filter_predI; apply: eq_filter => i; exact: andbC. +Qed. + +Lemma eq_bigl r (P1 P2 : pred I) F : + P1 =1 P2 -> + \big[op/idx]_(i <- r | P1 i) F i = \big[op/idx]_(i <- r | P2 i) F i. +Proof. by move=> eqP12; rewrite -!(big_filter r) (eq_filter eqP12). Qed. + +(* A lemma to permute aggregate conditions. *) +Lemma big_andbC r (P Q : pred I) F : + \big[op/idx]_(i <- r | P i && Q i) F i + = \big[op/idx]_(i <- r | Q i && P i) F i. +Proof. by apply: eq_bigl => i; exact: andbC. Qed. + +Lemma eq_bigr r (P : pred I) F1 F2 : (forall i, P i -> F1 i = F2 i) -> + \big[op/idx]_(i <- r | P i) F1 i = \big[op/idx]_(i <- r | P i) F2 i. +Proof. by move=> eqF12; elim/big_rec2: _ => // i x _ /eqF12-> ->. Qed. + +Lemma eq_big r (P1 P2 : pred I) F1 F2 : + P1 =1 P2 -> (forall i, P1 i -> F1 i = F2 i) -> + \big[op/idx]_(i <- r | P1 i) F1 i = \big[op/idx]_(i <- r | P2 i) F2 i. +Proof. by move/eq_bigl <-; move/eq_bigr->. Qed. + +Lemma congr_big r1 r2 (P1 P2 : pred I) F1 F2 : + r1 = r2 -> P1 =1 P2 -> (forall i, P1 i -> F1 i = F2 i) -> + \big[op/idx]_(i <- r1 | P1 i) F1 i = \big[op/idx]_(i <- r2 | P2 i) F2 i. +Proof. by move=> <-{r2}; exact: eq_big. Qed. + +Lemma big_nil (P : pred I) F : \big[op/idx]_(i <- [::] | P i) F i = idx. +Proof. by rewrite unlock. Qed. + +Lemma big_cons i r (P : pred I) F : + let x := \big[op/idx]_(j <- r | P j) F j in + \big[op/idx]_(j <- i :: r | P j) F j = if P i then op (F i) x else x. +Proof. by rewrite unlock. Qed. + +Lemma big_map J (h : J -> I) r (P : pred I) F : + \big[op/idx]_(i <- map h r | P i) F i + = \big[op/idx]_(j <- r | P (h j)) F (h j). +Proof. by rewrite unlock; elim: r => //= j r ->. Qed. + +Lemma big_nth x0 r (P : pred I) F : + \big[op/idx]_(i <- r | P i) F i + = \big[op/idx]_(0 <= i < size r | P (nth x0 r i)) (F (nth x0 r i)). +Proof. by rewrite -{1}(mkseq_nth x0 r) big_map /index_iota subn0. Qed. + +Lemma big_hasC r (P : pred I) F : + ~~ has P r -> \big[op/idx]_(i <- r | P i) F i = idx. +Proof. +by rewrite -big_filter has_count -size_filter -eqn0Ngt unlock => /nilP->. +Qed. + +Lemma big_pred0_eq (r : seq I) F : \big[op/idx]_(i <- r | false) F i = idx. +Proof. by rewrite big_hasC // has_pred0. Qed. + +Lemma big_pred0 r (P : pred I) F : + P =1 xpred0 -> \big[op/idx]_(i <- r | P i) F i = idx. +Proof. by move/eq_bigl->; exact: big_pred0_eq. Qed. + +Lemma big_cat_nested r1 r2 (P : pred I) F : + let x := \big[op/idx]_(i <- r2 | P i) F i in + \big[op/idx]_(i <- r1 ++ r2 | P i) F i = \big[op/x]_(i <- r1 | P i) F i. +Proof. by rewrite unlock /reducebig foldr_cat. Qed. + +Lemma big_catl r1 r2 (P : pred I) F : + ~~ has P r2 -> + \big[op/idx]_(i <- r1 ++ r2 | P i) F i = \big[op/idx]_(i <- r1 | P i) F i. +Proof. by rewrite big_cat_nested => /big_hasC->. Qed. + +Lemma big_catr r1 r2 (P : pred I) F : + ~~ has P r1 -> + \big[op/idx]_(i <- r1 ++ r2 | P i) F i = \big[op/idx]_(i <- r2 | P i) F i. +Proof. +rewrite -big_filter -(big_filter r2) filter_cat. +by rewrite has_count -size_filter; case: filter. +Qed. + +Lemma big_const_seq r (P : pred I) x : + \big[op/idx]_(i <- r | P i) x = iter (count P r) (op x) idx. +Proof. by rewrite unlock; elim: r => //= i r ->; case: (P i). Qed. + +End SeqExtension. + +(* The following lemmas can be used to localise extensionality to a specific *) +(* index sequence. This is done by ssreflect rewriting, before applying *) +(* congruence or induction lemmas. *) +Lemma big_seq_cond (I : eqType) r (P : pred I) F : + \big[op/idx]_(i <- r | P i) F i + = \big[op/idx]_(i <- r | (i \in r) && P i) F i. +Proof. +by rewrite -!(big_filter r); congr bigop; apply: eq_in_filter => i ->. +Qed. + +Lemma big_seq (I : eqType) (r : seq I) F : + \big[op/idx]_(i <- r) F i = \big[op/idx]_(i <- r | i \in r) F i. +Proof. by rewrite big_seq_cond big_andbC. Qed. + +Lemma eq_big_seq (I : eqType) (r : seq I) F1 F2 : + {in r, F1 =1 F2} -> \big[op/idx]_(i <- r) F1 i = \big[op/idx]_(i <- r) F2 i. +Proof. by move=> eqF; rewrite !big_seq (eq_bigr _ eqF). Qed. + +(* Similar lemmas for exposing integer indexing in the predicate. *) +Lemma big_nat_cond m n (P : pred nat) F : + \big[op/idx]_(m <= i < n | P i) F i + = \big[op/idx]_(m <= i < n | (m <= i < n) && P i) F i. +Proof. +by rewrite big_seq_cond; apply: eq_bigl => i; rewrite mem_index_iota. +Qed. + +Lemma big_nat m n F : + \big[op/idx]_(m <= i < n) F i = \big[op/idx]_(m <= i < n | m <= i < n) F i. +Proof. by rewrite big_nat_cond big_andbC. Qed. + +Lemma congr_big_nat m1 n1 m2 n2 P1 P2 F1 F2 : + m1 = m2 -> n1 = n2 -> + (forall i, m1 <= i < n2 -> P1 i = P2 i) -> + (forall i, P1 i && (m1 <= i < n2) -> F1 i = F2 i) -> + \big[op/idx]_(m1 <= i < n1 | P1 i) F1 i + = \big[op/idx]_(m2 <= i < n2 | P2 i) F2 i. +Proof. +move=> <- <- eqP12 eqF12; rewrite big_seq_cond (big_seq_cond _ P2). +apply: eq_big => i; rewrite ?inE /= !mem_index_iota. + by apply: andb_id2l; exact: eqP12. +by rewrite andbC; exact: eqF12. +Qed. + +Lemma eq_big_nat m n F1 F2 : + (forall i, m <= i < n -> F1 i = F2 i) -> + \big[op/idx]_(m <= i < n) F1 i = \big[op/idx]_(m <= i < n) F2 i. +Proof. by move=> eqF; apply: congr_big_nat. Qed. + +Lemma big_geq m n (P : pred nat) F : + m >= n -> \big[op/idx]_(m <= i < n | P i) F i = idx. +Proof. by move=> ge_m_n; rewrite /index_iota (eqnP ge_m_n) big_nil. Qed. + +Lemma big_ltn_cond m n (P : pred nat) F : + m < n -> let x := \big[op/idx]_(m.+1 <= i < n | P i) F i in + \big[op/idx]_(m <= i < n | P i) F i = if P m then op (F m) x else x. +Proof. +by case: n => [//|n] le_m_n; rewrite /index_iota subSn // big_cons. +Qed. + +Lemma big_ltn m n F : + m < n -> + \big[op/idx]_(m <= i < n) F i = op (F m) (\big[op/idx]_(m.+1 <= i < n) F i). +Proof. move=> lt_mn; exact: big_ltn_cond. Qed. + +Lemma big_addn m n a (P : pred nat) F : + \big[op/idx]_(m + a <= i < n | P i) F i = + \big[op/idx]_(m <= i < n - a | P (i + a)) F (i + a). +Proof. +rewrite /index_iota -subnDA addnC iota_addl big_map. +by apply: eq_big => ? *; rewrite addnC. +Qed. + +Lemma big_add1 m n (P : pred nat) F : + \big[op/idx]_(m.+1 <= i < n | P i) F i = + \big[op/idx]_(m <= i < n.-1 | P (i.+1)) F (i.+1). +Proof. +by rewrite -addn1 big_addn subn1; apply: eq_big => ? *; rewrite addn1. +Qed. + +Lemma big_nat_recl n m F : m <= n -> + \big[op/idx]_(m <= i < n.+1) F i = + op (F m) (\big[op/idx]_(m <= i < n) F i.+1). +Proof. by move=> lemn; rewrite big_ltn // big_add1. Qed. + +Lemma big_mkord n (P : pred nat) F : + \big[op/idx]_(0 <= i < n | P i) F i = \big[op/idx]_(i < n | P i) F i. +Proof. +rewrite /index_iota subn0 -(big_map (@nat_of_ord n)). +by congr bigop; rewrite /index_enum unlock val_ord_enum. +Qed. + +Lemma big_nat_widen m n1 n2 (P : pred nat) F : + n1 <= n2 -> + \big[op/idx]_(m <= i < n1 | P i) F i + = \big[op/idx]_(m <= i < n2 | P i && (i < n1)) F i. +Proof. +move=> len12; symmetry; rewrite -big_filter filter_predI big_filter. +have [ltn_trans eq_by_mem] := (ltn_trans, eq_sorted_irr ltn_trans ltnn). +congr bigop; apply: eq_by_mem; rewrite ?sorted_filter ?iota_ltn_sorted // => i. +rewrite mem_filter !mem_index_iota andbCA andbA andb_idr => // /andP[_]. +by move/leq_trans->. +Qed. + +Lemma big_ord_widen_cond n1 n2 (P : pred nat) (F : nat -> R) : + n1 <= n2 -> + \big[op/idx]_(i < n1 | P i) F i + = \big[op/idx]_(i < n2 | P i && (i < n1)) F i. +Proof. by move/big_nat_widen=> len12; rewrite -big_mkord len12 big_mkord. Qed. + +Lemma big_ord_widen n1 n2 (F : nat -> R) : + n1 <= n2 -> + \big[op/idx]_(i < n1) F i = \big[op/idx]_(i < n2 | i < n1) F i. +Proof. by move=> le_n12; exact: (big_ord_widen_cond (predT)). Qed. + +Lemma big_ord_widen_leq n1 n2 (P : pred 'I_(n1.+1)) F : + n1 < n2 -> + \big[op/idx]_(i < n1.+1 | P i) F i + = \big[op/idx]_(i < n2 | P (inord i) && (i <= n1)) F (inord i). +Proof. +move=> len12; pose g G i := G (inord i : 'I_(n1.+1)). +rewrite -(big_ord_widen_cond (g _ P) (g _ F) len12) {}/g. +by apply: eq_big => i *; rewrite inord_val. +Qed. + +Lemma big_ord0 P F : \big[op/idx]_(i < 0 | P i) F i = idx. +Proof. by rewrite big_pred0 => [|[]]. Qed. + +Lemma big_tnth I r (P : pred I) F : + let r_ := tnth (in_tuple r) in + \big[op/idx]_(i <- r | P i) F i + = \big[op/idx]_(i < size r | P (r_ i)) (F (r_ i)). +Proof. +case: r => /= [|x0 r]; first by rewrite big_nil big_ord0. +by rewrite (big_nth x0) big_mkord; apply: eq_big => i; rewrite (tnth_nth x0). +Qed. + +Lemma big_index_uniq (I : eqType) (r : seq I) (E : 'I_(size r) -> R) : + uniq r -> + \big[op/idx]_i E i = \big[op/idx]_(x <- r) oapp E idx (insub (index x r)). +Proof. +move=> Ur; apply/esym; rewrite big_tnth; apply: eq_bigr => i _. +by rewrite index_uniq // valK. +Qed. + +Lemma big_tuple I n (t : n.-tuple I) (P : pred I) F : + \big[op/idx]_(i <- t | P i) F i + = \big[op/idx]_(i < n | P (tnth t i)) F (tnth t i). +Proof. by rewrite big_tnth tvalK; case: _ / (esym _). Qed. + +Lemma big_ord_narrow_cond n1 n2 (P : pred 'I_n2) F (le_n12 : n1 <= n2) : + let w := widen_ord le_n12 in + \big[op/idx]_(i < n2 | P i && (i < n1)) F i + = \big[op/idx]_(i < n1 | P (w i)) F (w i). +Proof. +case: n1 => [|n1] /= in le_n12 *. + by rewrite big_ord0 big_pred0 // => i; rewrite andbF. +rewrite (big_ord_widen_leq _ _ le_n12); apply: eq_big => i. + by apply: andb_id2r => le_i_n1; congr P; apply: val_inj; rewrite /= inordK. +by case/andP=> _ le_i_n1; congr F; apply: val_inj; rewrite /= inordK. +Qed. + +Lemma big_ord_narrow_cond_leq n1 n2 (P : pred _) F (le_n12 : n1 <= n2) : + let w := @widen_ord n1.+1 n2.+1 le_n12 in + \big[op/idx]_(i < n2.+1 | P i && (i <= n1)) F i + = \big[op/idx]_(i < n1.+1 | P (w i)) F (w i). +Proof. exact: (@big_ord_narrow_cond n1.+1 n2.+1). Qed. + +Lemma big_ord_narrow n1 n2 F (le_n12 : n1 <= n2) : + let w := widen_ord le_n12 in + \big[op/idx]_(i < n2 | i < n1) F i = \big[op/idx]_(i < n1) F (w i). +Proof. exact: (big_ord_narrow_cond (predT)). Qed. + +Lemma big_ord_narrow_leq n1 n2 F (le_n12 : n1 <= n2) : + let w := @widen_ord n1.+1 n2.+1 le_n12 in + \big[op/idx]_(i < n2.+1 | i <= n1) F i = \big[op/idx]_(i < n1.+1) F (w i). +Proof. exact: (big_ord_narrow_cond_leq (predT)). Qed. + +Lemma big_ord_recl n F : + \big[op/idx]_(i < n.+1) F i = + op (F ord0) (\big[op/idx]_(i < n) F (@lift n.+1 ord0 i)). +Proof. +pose G i := F (inord i); have eqFG i: F i = G i by rewrite /G inord_val. +rewrite (eq_bigr _ (fun i _ => eqFG i)) -(big_mkord _ (fun _ => _) G) eqFG. +rewrite big_ltn // big_add1 /= big_mkord; congr op. +by apply: eq_bigr => i _; rewrite eqFG. +Qed. + +Lemma big_const (I : finType) (A : pred I) x : + \big[op/idx]_(i in A) x = iter #|A| (op x) idx. +Proof. by rewrite big_const_seq -size_filter cardE. Qed. + +Lemma big_const_nat m n x : + \big[op/idx]_(m <= i < n) x = iter (n - m) (op x) idx. +Proof. by rewrite big_const_seq count_predT size_iota. Qed. + +Lemma big_const_ord n x : + \big[op/idx]_(i < n) x = iter n (op x) idx. +Proof. by rewrite big_const card_ord. Qed. + +Lemma big_nseq_cond I n a (P : pred I) F : + \big[op/idx]_(i <- nseq n a | P i) F i = if P a then iter n (op (F a)) idx else idx. +Proof. by rewrite unlock; elim: n => /= [|n ->]; case: (P a). Qed. + +Lemma big_nseq I n a (F : I -> R): + \big[op/idx]_(i <- nseq n a) F i = iter n (op (F a)) idx. +Proof. exact: big_nseq_cond. Qed. + +End Extensionality. + +Section MonoidProperties. + +Import Monoid.Theory. + +Variable R : Type. + +Variable idx : R. +Notation Local "1" := idx. + +Section Plain. + +Variable op : Monoid.law 1. + +Notation Local "*%M" := op (at level 0). +Notation Local "x * y" := (op x y). + +Lemma eq_big_idx_seq idx' I r (P : pred I) F : + right_id idx' *%M -> has P r -> + \big[*%M/idx']_(i <- r | P i) F i =\big[*%M/1]_(i <- r | P i) F i. +Proof. +move=> op_idx'; rewrite -!(big_filter _ _ r) has_count -size_filter. +case/lastP: (filter P r) => {r}// r i _. +by rewrite -cats1 !(big_cat_nested, big_cons, big_nil) op_idx' mulm1. +Qed. + +Lemma eq_big_idx idx' (I : finType) i0 (P : pred I) F : + P i0 -> right_id idx' *%M -> + \big[*%M/idx']_(i | P i) F i =\big[*%M/1]_(i | P i) F i. +Proof. +by move=> Pi0 op_idx'; apply: eq_big_idx_seq => //; apply/hasP; exists i0. +Qed. + +Lemma big1_eq I r (P : pred I) : \big[*%M/1]_(i <- r | P i) 1 = 1. +Proof. +by rewrite big_const_seq; elim: (count _ _) => //= n ->; exact: mul1m. +Qed. + +Lemma big1 I r (P : pred I) F : + (forall i, P i -> F i = 1) -> \big[*%M/1]_(i <- r | P i) F i = 1. +Proof. by move/(eq_bigr _)->; exact: big1_eq. Qed. + +Lemma big1_seq (I : eqType) r (P : pred I) F : + (forall i, P i && (i \in r) -> F i = 1) -> + \big[*%M/1]_(i <- r | P i) F i = 1. +Proof. by move=> eqF1; rewrite big_seq_cond big_andbC big1. Qed. + +Lemma big_seq1 I (i : I) F : \big[*%M/1]_(j <- [:: i]) F j = F i. +Proof. by rewrite unlock /= mulm1. Qed. + +Lemma big_mkcond I r (P : pred I) F : + \big[*%M/1]_(i <- r | P i) F i = + \big[*%M/1]_(i <- r) (if P i then F i else 1). +Proof. by rewrite unlock; elim: r => //= i r ->; case P; rewrite ?mul1m. Qed. + +Lemma big_mkcondr I r (P Q : pred I) F : + \big[*%M/1]_(i <- r | P i && Q i) F i = + \big[*%M/1]_(i <- r | P i) (if Q i then F i else 1). +Proof. by rewrite -big_filter_cond big_mkcond big_filter. Qed. + +Lemma big_mkcondl I r (P Q : pred I) F : + \big[*%M/1]_(i <- r | P i && Q i) F i = + \big[*%M/1]_(i <- r | Q i) (if P i then F i else 1). +Proof. by rewrite big_andbC big_mkcondr. Qed. + +Lemma big_cat I r1 r2 (P : pred I) F : + \big[*%M/1]_(i <- r1 ++ r2 | P i) F i = + \big[*%M/1]_(i <- r1 | P i) F i * \big[*%M/1]_(i <- r2 | P i) F i. +Proof. +rewrite !(big_mkcond _ P) unlock. +by elim: r1 => /= [|i r1 ->]; rewrite (mul1m, mulmA). +Qed. + +Lemma big_pred1_eq (I : finType) (i : I) F : + \big[*%M/1]_(j | j == i) F j = F i. +Proof. by rewrite -big_filter filter_index_enum enum1 big_seq1. Qed. + +Lemma big_pred1 (I : finType) i (P : pred I) F : + P =1 pred1 i -> \big[*%M/1]_(j | P j) F j = F i. +Proof. by move/(eq_bigl _ _)->; exact: big_pred1_eq. Qed. + +Lemma big_cat_nat n m p (P : pred nat) F : m <= n -> n <= p -> + \big[*%M/1]_(m <= i < p | P i) F i = + (\big[*%M/1]_(m <= i < n | P i) F i) * (\big[*%M/1]_(n <= i < p | P i) F i). +Proof. +move=> le_mn le_np; rewrite -big_cat -{2}(subnKC le_mn) -iota_add subnDA. +by rewrite subnKC // leq_sub. +Qed. + +Lemma big_nat1 n F : \big[*%M/1]_(n <= i < n.+1) F i = F n. +Proof. by rewrite big_ltn // big_geq // mulm1. Qed. + +Lemma big_nat_recr n m F : m <= n -> + \big[*%M/1]_(m <= i < n.+1) F i = (\big[*%M/1]_(m <= i < n) F i) * F n. +Proof. by move=> lemn; rewrite (@big_cat_nat n) ?leqnSn // big_nat1. Qed. + +Lemma big_ord_recr n F : + \big[*%M/1]_(i < n.+1) F i = + (\big[*%M/1]_(i < n) F (widen_ord (leqnSn n) i)) * F ord_max. +Proof. +transitivity (\big[*%M/1]_(0 <= i < n.+1) F (inord i)). + by rewrite big_mkord; apply: eq_bigr=> i _; rewrite inord_val. +rewrite big_nat_recr // big_mkord; congr (_ * F _); last first. + by apply: val_inj; rewrite /= inordK. +by apply: eq_bigr => [] i _; congr F; apply: ord_inj; rewrite inordK //= leqW. +Qed. + +Lemma big_sumType (I1 I2 : finType) (P : pred (I1 + I2)) F : + \big[*%M/1]_(i | P i) F i = + (\big[*%M/1]_(i | P (inl _ i)) F (inl _ i)) + * (\big[*%M/1]_(i | P (inr _ i)) F (inr _ i)). +Proof. +by rewrite /index_enum {1}[@Finite.enum]unlock /= big_cat !big_map. +Qed. + +Lemma big_split_ord m n (P : pred 'I_(m + n)) F : + \big[*%M/1]_(i | P i) F i = + (\big[*%M/1]_(i | P (lshift n i)) F (lshift n i)) + * (\big[*%M/1]_(i | P (rshift m i)) F (rshift m i)). +Proof. +rewrite -(big_map _ _ (lshift n) _ P F) -(big_map _ _ (@rshift m _) _ P F). +rewrite -big_cat; congr bigop; apply: (inj_map val_inj). +rewrite /index_enum -!enumT val_enum_ord map_cat -map_comp val_enum_ord. +rewrite -map_comp (map_comp (addn m)) val_enum_ord. +by rewrite -iota_addl addn0 iota_add. +Qed. + +Lemma big_flatten I rr (P : pred I) F : + \big[*%M/1]_(i <- flatten rr | P i) F i + = \big[*%M/1]_(r <- rr) \big[*%M/1]_(i <- r | P i) F i. +Proof. +by elim: rr => [|r rr IHrr]; rewrite ?big_nil //= big_cat big_cons -IHrr. +Qed. + +End Plain. + +Section Abelian. + +Variable op : Monoid.com_law 1. + +Notation Local "'*%M'" := op (at level 0). +Notation Local "x * y" := (op x y). + +Lemma eq_big_perm (I : eqType) r1 r2 (P : pred I) F : + perm_eq r1 r2 -> + \big[*%M/1]_(i <- r1 | P i) F i = \big[*%M/1]_(i <- r2 | P i) F i. +Proof. +move/perm_eqP; rewrite !(big_mkcond _ _ P). +elim: r1 r2 => [|i r1 IHr1] r2 eq_r12. + by case: r2 eq_r12 => // i r2; move/(_ (pred1 i)); rewrite /= eqxx. +have r2i: i \in r2 by rewrite -has_pred1 has_count -eq_r12 /= eqxx. +case/splitPr: r2 / r2i => [r3 r4] in eq_r12 *; rewrite big_cat /= !big_cons. +rewrite mulmCA; congr (_ * _); rewrite -big_cat; apply: IHr1 => a. +move/(_ a): eq_r12; rewrite !count_cat /= addnCA; exact: addnI. +Qed. + +Lemma big_uniq (I : finType) (r : seq I) F : + uniq r -> \big[*%M/1]_(i <- r) F i = \big[*%M/1]_(i in r) F i. +Proof. +move=> uniq_r; rewrite -(big_filter _ _ _ (mem r)); apply: eq_big_perm. +by rewrite filter_index_enum uniq_perm_eq ?enum_uniq // => i; rewrite mem_enum. +Qed. + +Lemma big_rem (I : eqType) r x (P : pred I) F : + x \in r -> + \big[*%M/1]_(y <- r | P y) F y + = (if P x then F x else 1) * \big[*%M/1]_(y <- rem x r | P y) F y. +Proof. +by move/perm_to_rem/(eq_big_perm _)->; rewrite !(big_mkcond _ _ P) big_cons. +Qed. + +Lemma big_undup (I : eqType) (r : seq I) (P : pred I) F : + idempotent *%M -> + \big[*%M/1]_(i <- undup r | P i) F i = \big[*%M/1]_(i <- r | P i) F i. +Proof. +move=> idM; rewrite -!(big_filter _ _ _ P) filter_undup. +elim: {P r}(filter P r) => //= i r IHr. +case: ifP => [r_i | _]; rewrite !big_cons {}IHr //. +by rewrite (big_rem _ _ r_i) mulmA idM. +Qed. + +Lemma eq_big_idem (I : eqType) (r1 r2 : seq I) (P : pred I) F : + idempotent *%M -> r1 =i r2 -> + \big[*%M/1]_(i <- r1 | P i) F i = \big[*%M/1]_(i <- r2 | P i) F i. +Proof. +move=> idM eq_r; rewrite -big_undup // -(big_undup r2) //; apply/eq_big_perm. +by rewrite uniq_perm_eq ?undup_uniq // => i; rewrite !mem_undup eq_r. +Qed. + +Lemma big_undup_iterop_count (I : eqType) (r : seq I) (P : pred I) F : + \big[*%M/1]_(i <- undup r | P i) iterop (count_mem i r) *%M (F i) 1 + = \big[*%M/1]_(i <- r | P i) F i. +Proof. +rewrite -[RHS](eq_big_perm _ F (perm_undup_count _)) big_flatten big_map. +by rewrite big_mkcond; apply: eq_bigr => i _; rewrite big_nseq_cond iteropE. +Qed. + +Lemma big_split I r (P : pred I) F1 F2 : + \big[*%M/1]_(i <- r | P i) (F1 i * F2 i) = + \big[*%M/1]_(i <- r | P i) F1 i * \big[*%M/1]_(i <- r | P i) F2 i. +Proof. +by elim/big_rec3: _ => [|i x y _ _ ->]; rewrite ?mulm1 // mulmCA -!mulmA mulmCA. +Qed. + +Lemma bigID I r (a P : pred I) F : + \big[*%M/1]_(i <- r | P i) F i = + \big[*%M/1]_(i <- r | P i && a i) F i * + \big[*%M/1]_(i <- r | P i && ~~ a i) F i. +Proof. +rewrite !(big_mkcond _ _ _ F) -big_split. +by apply: eq_bigr => i; case: (a i); rewrite !simpm. +Qed. +Implicit Arguments bigID [I r]. + +Lemma bigU (I : finType) (A B : pred I) F : + [disjoint A & B] -> + \big[*%M/1]_(i in [predU A & B]) F i = + (\big[*%M/1]_(i in A) F i) * (\big[*%M/1]_(i in B) F i). +Proof. +move=> dAB; rewrite (bigID (mem A)). +congr (_ * _); apply: eq_bigl => i; first by rewrite orbK. +by have:= pred0P dAB i; rewrite andbC /= !inE; case: (i \in A). +Qed. + +Lemma bigD1 (I : finType) j (P : pred I) F : + P j -> \big[*%M/1]_(i | P i) F i + = F j * \big[*%M/1]_(i | P i && (i != j)) F i. +Proof. +move=> Pj; rewrite (bigID (pred1 j)); congr (_ * _). +by apply: big_pred1 => i; rewrite /= andbC; case: eqP => // ->. +Qed. +Implicit Arguments bigD1 [I P F]. + +Lemma bigD1_seq (I : eqType) (r : seq I) j F : + j \in r -> uniq r -> + \big[*%M/1]_(i <- r) F i = F j * \big[*%M/1]_(i <- r | i != j) F i. +Proof. by move=> /big_rem-> /rem_filter->; rewrite big_filter. Qed. + +Lemma cardD1x (I : finType) (A : pred I) j : + A j -> #|SimplPred A| = 1 + #|[pred i | A i & i != j]|. +Proof. +move=> Aj; rewrite (cardD1 j) [j \in A]Aj; congr (_ + _). +by apply: eq_card => i; rewrite inE /= andbC. +Qed. +Implicit Arguments cardD1x [I A]. + +Lemma partition_big (I J : finType) (P : pred I) p (Q : pred J) F : + (forall i, P i -> Q (p i)) -> + \big[*%M/1]_(i | P i) F i = + \big[*%M/1]_(j | Q j) \big[*%M/1]_(i | P i && (p i == j)) F i. +Proof. +move=> Qp; transitivity (\big[*%M/1]_(i | P i && Q (p i)) F i). + by apply: eq_bigl => i; case Pi: (P i); rewrite // Qp. +elim: {Q Qp}_.+1 {-2}Q (ltnSn #|Q|) => // n IHn Q. +case: (pickP Q) => [j Qj | Q0 _]; last first. + by rewrite !big_pred0 // => i; rewrite Q0 andbF. +rewrite ltnS (cardD1x j Qj) (bigD1 j) //; move/IHn=> {n IHn} <-. +rewrite (bigID (fun i => p i == j)); congr (_ * _); apply: eq_bigl => i. + by case: eqP => [-> | _]; rewrite !(Qj, simpm). +by rewrite andbA. +Qed. + +Implicit Arguments partition_big [I J P F]. + +Lemma reindex_onto (I J : finType) (h : J -> I) h' (P : pred I) F : + (forall i, P i -> h (h' i) = i) -> + \big[*%M/1]_(i | P i) F i = + \big[*%M/1]_(j | P (h j) && (h' (h j) == j)) F (h j). +Proof. +move=> h'K; elim: {P}_.+1 {-3}P h'K (ltnSn #|P|) => //= n IHn P h'K. +case: (pickP P) => [i Pi | P0 _]; last first. + by rewrite !big_pred0 // => j; rewrite P0. +rewrite ltnS (cardD1x i Pi); move/IHn {n IHn} => IH. +rewrite (bigD1 i Pi) (bigD1 (h' i)) h'K ?Pi ?eq_refl //=; congr (_ * _). +rewrite {}IH => [|j]; [apply: eq_bigl => j | by case/andP; auto]. +rewrite andbC -andbA (andbCA (P _)); case: eqP => //= hK; congr (_ && ~~ _). +by apply/eqP/eqP=> [<-|->] //; rewrite h'K. +Qed. +Implicit Arguments reindex_onto [I J P F]. + +Lemma reindex (I J : finType) (h : J -> I) (P : pred I) F : + {on [pred i | P i], bijective h} -> + \big[*%M/1]_(i | P i) F i = \big[*%M/1]_(j | P (h j)) F (h j). +Proof. +case=> h' hK h'K; rewrite (reindex_onto h h' h'K). +by apply: eq_bigl => j; rewrite !inE; case Pi: (P _); rewrite //= hK ?eqxx. +Qed. +Implicit Arguments reindex [I J P F]. + +Lemma reindex_inj (I : finType) (h : I -> I) (P : pred I) F : + injective h -> \big[*%M/1]_(i | P i) F i = \big[*%M/1]_(j | P (h j)) F (h j). +Proof. move=> injh; exact: reindex (onW_bij _ (injF_bij injh)). Qed. +Implicit Arguments reindex_inj [I h P F]. + +Lemma big_nat_rev m n P F : + \big[*%M/1]_(m <= i < n | P i) F i + = \big[*%M/1]_(m <= i < n | P (m + n - i.+1)) F (m + n - i.+1). +Proof. +case: (ltnP m n) => ltmn; last by rewrite !big_geq. +rewrite -{3 4}(subnK (ltnW ltmn)) addnA. +do 2!rewrite (big_addn _ _ 0) big_mkord; rewrite (reindex_inj rev_ord_inj) /=. +by apply: eq_big => [i | i _]; rewrite /= -addSn subnDr addnC addnBA. +Qed. + +Lemma pair_big_dep (I J : finType) (P : pred I) (Q : I -> pred J) F : + \big[*%M/1]_(i | P i) \big[*%M/1]_(j | Q i j) F i j = + \big[*%M/1]_(p | P p.1 && Q p.1 p.2) F p.1 p.2. +Proof. +rewrite (partition_big (fun p => p.1) P) => [|j]; last by case/andP. +apply: eq_bigr => i /= Pi; rewrite (reindex_onto (pair i) (fun p => p.2)). + by apply: eq_bigl => j; rewrite !eqxx [P i]Pi !andbT. +by case=> i' j /=; case/andP=> _ /=; move/eqP->. +Qed. + +Lemma pair_big (I J : finType) (P : pred I) (Q : pred J) F : + \big[*%M/1]_(i | P i) \big[*%M/1]_(j | Q j) F i j = + \big[*%M/1]_(p | P p.1 && Q p.2) F p.1 p.2. +Proof. exact: pair_big_dep. Qed. + +Lemma pair_bigA (I J : finType) (F : I -> J -> R) : + \big[*%M/1]_i \big[*%M/1]_j F i j = \big[*%M/1]_p F p.1 p.2. +Proof. exact: pair_big_dep. Qed. + +Lemma exchange_big_dep I J rI rJ (P : pred I) (Q : I -> pred J) + (xQ : pred J) F : + (forall i j, P i -> Q i j -> xQ j) -> + \big[*%M/1]_(i <- rI | P i) \big[*%M/1]_(j <- rJ | Q i j) F i j = + \big[*%M/1]_(j <- rJ | xQ j) \big[*%M/1]_(i <- rI | P i && Q i j) F i j. +Proof. +move=> PQxQ; pose p u := (u.2, u.1). +rewrite (eq_bigr _ _ _ (fun _ _ => big_tnth _ _ rI _ _)) (big_tnth _ _ rJ). +rewrite (eq_bigr _ _ _ (fun _ _ => (big_tnth _ _ rJ _ _))) big_tnth. +rewrite !pair_big_dep (reindex_onto (p _ _) (p _ _)) => [|[]] //=. +apply: eq_big => [] [j i] //=; symmetry; rewrite eqxx andbT andb_idl //. +by case/andP; exact: PQxQ. +Qed. +Implicit Arguments exchange_big_dep [I J rI rJ P Q F]. + +Lemma exchange_big I J rI rJ (P : pred I) (Q : pred J) F : + \big[*%M/1]_(i <- rI | P i) \big[*%M/1]_(j <- rJ | Q j) F i j = + \big[*%M/1]_(j <- rJ | Q j) \big[*%M/1]_(i <- rI | P i) F i j. +Proof. +rewrite (exchange_big_dep Q) //; apply: eq_bigr => i /= Qi. +by apply: eq_bigl => j; rewrite Qi andbT. +Qed. + +Lemma exchange_big_dep_nat m1 n1 m2 n2 (P : pred nat) (Q : rel nat) + (xQ : pred nat) F : + (forall i j, m1 <= i < n1 -> m2 <= j < n2 -> P i -> Q i j -> xQ j) -> + \big[*%M/1]_(m1 <= i < n1 | P i) \big[*%M/1]_(m2 <= j < n2 | Q i j) F i j = + \big[*%M/1]_(m2 <= j < n2 | xQ j) + \big[*%M/1]_(m1 <= i < n1 | P i && Q i j) F i j. +Proof. +move=> PQxQ; rewrite (eq_bigr _ _ _ (fun _ _ => big_seq_cond _ _ _ _ _)). +rewrite big_seq_cond /= (exchange_big_dep xQ) => [|i j]; last first. + by rewrite !mem_index_iota => /andP[mn_i Pi] /andP[mn_j /PQxQ->]. +rewrite 2!(big_seq_cond _ _ _ xQ); apply: eq_bigr => j /andP[-> _] /=. +by rewrite [rhs in _ = rhs]big_seq_cond; apply: eq_bigl => i; rewrite -andbA. +Qed. +Implicit Arguments exchange_big_dep_nat [m1 n1 m2 n2 P Q F]. + +Lemma exchange_big_nat m1 n1 m2 n2 (P Q : pred nat) F : + \big[*%M/1]_(m1 <= i < n1 | P i) \big[*%M/1]_(m2 <= j < n2 | Q j) F i j = + \big[*%M/1]_(m2 <= j < n2 | Q j) \big[*%M/1]_(m1 <= i < n1 | P i) F i j. +Proof. +rewrite (exchange_big_dep_nat Q) //. +by apply: eq_bigr => i /= Qi; apply: eq_bigl => j; rewrite Qi andbT. +Qed. + +End Abelian. + +End MonoidProperties. + +Implicit Arguments big_filter [R op idx I]. +Implicit Arguments big_filter_cond [R op idx I]. +Implicit Arguments congr_big [R op idx I r1 P1 F1]. +Implicit Arguments eq_big [R op idx I r P1 F1]. +Implicit Arguments eq_bigl [R op idx I r P1]. +Implicit Arguments eq_bigr [R op idx I r P F1]. +Implicit Arguments eq_big_idx [R op idx idx' I P F]. +Implicit Arguments big_seq_cond [R op idx I r]. +Implicit Arguments eq_big_seq [R op idx I r F1]. +Implicit Arguments congr_big_nat [R op idx m1 n1 P1 F1]. +Implicit Arguments big_map [R op idx I J r]. +Implicit Arguments big_nth [R op idx I r]. +Implicit Arguments big_catl [R op idx I r1 r2 P F]. +Implicit Arguments big_catr [R op idx I r1 r2 P F]. +Implicit Arguments big_geq [R op idx m n P F]. +Implicit Arguments big_ltn_cond [R op idx m n P F]. +Implicit Arguments big_ltn [R op idx m n F]. +Implicit Arguments big_addn [R op idx]. +Implicit Arguments big_mkord [R op idx n]. +Implicit Arguments big_nat_widen [R op idx] . +Implicit Arguments big_ord_widen_cond [R op idx n1]. +Implicit Arguments big_ord_widen [R op idx n1]. +Implicit Arguments big_ord_widen_leq [R op idx n1]. +Implicit Arguments big_ord_narrow_cond [R op idx n1 n2 P F]. +Implicit Arguments big_ord_narrow_cond_leq [R op idx n1 n2 P F]. +Implicit Arguments big_ord_narrow [R op idx n1 n2 F]. +Implicit Arguments big_ord_narrow_leq [R op idx n1 n2 F]. +Implicit Arguments big_mkcond [R op idx I r]. +Implicit Arguments big1_eq [R op idx I]. +Implicit Arguments big1_seq [R op idx I]. +Implicit Arguments big1 [R op idx I]. +Implicit Arguments big_pred1 [R op idx I P F]. +Implicit Arguments eq_big_perm [R op idx I r1 P F]. +Implicit Arguments big_uniq [R op idx I F]. +Implicit Arguments big_rem [R op idx I r P F]. +Implicit Arguments bigID [R op idx I r]. +Implicit Arguments bigU [R op idx I]. +Implicit Arguments bigD1 [R op idx I P F]. +Implicit Arguments bigD1_seq [R op idx I r F]. +Implicit Arguments partition_big [R op idx I J P F]. +Implicit Arguments reindex_onto [R op idx I J P F]. +Implicit Arguments reindex [R op idx I J P F]. +Implicit Arguments reindex_inj [R op idx I h P F]. +Implicit Arguments pair_big_dep [R op idx I J]. +Implicit Arguments pair_big [R op idx I J]. +Implicit Arguments exchange_big_dep [R op idx I J rI rJ P Q F]. +Implicit Arguments exchange_big_dep_nat [R op idx m1 n1 m2 n2 P Q F]. +Implicit Arguments big_ord_recl [R op idx]. +Implicit Arguments big_ord_recr [R op idx]. +Implicit Arguments big_nat_recl [R op idx]. +Implicit Arguments big_nat_recr [R op idx]. + +Section Distributivity. + +Import Monoid.Theory. + +Variable R : Type. +Variables zero one : R. +Notation Local "0" := zero. +Notation Local "1" := one. +Variable times : Monoid.mul_law 0. +Notation Local "*%M" := times (at level 0). +Notation Local "x * y" := (times x y). +Variable plus : Monoid.add_law 0 *%M. +Notation Local "+%M" := plus (at level 0). +Notation Local "x + y" := (plus x y). + +Lemma big_distrl I r a (P : pred I) F : + \big[+%M/0]_(i <- r | P i) F i * a = \big[+%M/0]_(i <- r | P i) (F i * a). +Proof. by rewrite (big_endo ( *%M^~ a)) ?mul0m // => x y; exact: mulm_addl. Qed. + +Lemma big_distrr I r a (P : pred I) F : + a * \big[+%M/0]_(i <- r | P i) F i = \big[+%M/0]_(i <- r | P i) (a * F i). +Proof. by rewrite big_endo ?mulm0 // => x y; exact: mulm_addr. Qed. + +Lemma big_distrlr I J rI rJ (pI : pred I) (pJ : pred J) F G : + (\big[+%M/0]_(i <- rI | pI i) F i) * (\big[+%M/0]_(j <- rJ | pJ j) G j) + = \big[+%M/0]_(i <- rI | pI i) \big[+%M/0]_(j <- rJ | pJ j) (F i * G j). +Proof. by rewrite big_distrl; apply: eq_bigr => i _; rewrite big_distrr. Qed. + +Lemma big_distr_big_dep (I J : finType) j0 (P : pred I) (Q : I -> pred J) F : + \big[*%M/1]_(i | P i) \big[+%M/0]_(j | Q i j) F i j = + \big[+%M/0]_(f in pfamily j0 P Q) \big[*%M/1]_(i | P i) F i (f i). +Proof. +pose fIJ := {ffun I -> J}; pose Pf := pfamily j0 (_ : seq I) Q. +rewrite -big_filter filter_index_enum; set r := enum P; symmetry. +transitivity (\big[+%M/0]_(f in Pf r) \big[*%M/1]_(i <- r) F i (f i)). + apply: eq_big => f; last by rewrite -big_filter filter_index_enum. + by apply: eq_forallb => i; rewrite /= mem_enum. +have: uniq r by exact: enum_uniq. +elim: {P}r => /= [_ | i r IHr]. + rewrite (big_pred1 [ffun => j0]) ?big_nil //= => f. + apply/familyP/eqP=> /= [Df |->{f} i]; last by rewrite ffunE !inE. + by apply/ffunP=> i; rewrite ffunE; exact/eqP/Df. +case/andP=> /negbTE nri; rewrite big_cons big_distrl => {IHr}/IHr <-. +rewrite (partition_big (fun f : fIJ => f i) (Q i)) => [|f]; last first. + by move/familyP/(_ i); rewrite /= inE /= eqxx. +pose seti j (f : fIJ) := [ffun k => if k == i then j else f k]. +apply: eq_bigr => j Qij. +rewrite (reindex_onto (seti j) (seti j0)) => [|f /andP[_ /eqP fi]]; last first. + by apply/ffunP=> k; rewrite !ffunE; case: eqP => // ->. +rewrite big_distrr; apply: eq_big => [f | f eq_f]; last first. + rewrite big_cons ffunE eqxx !big_seq; congr (_ * _). + by apply: eq_bigr => k; rewrite ffunE; case: eqP nri => // -> ->. +rewrite !ffunE !eqxx andbT; apply/andP/familyP=> /= [[Pjf fij0] k | Pff]. + have:= familyP Pjf k; rewrite /= ffunE inE; case: eqP => // -> _. + by rewrite nri -(eqP fij0) !ffunE !inE !eqxx. +split; [apply/familyP | apply/eqP/ffunP] => k; have:= Pff k; rewrite !ffunE. + by rewrite inE; case: eqP => // ->. +by case: eqP => // ->; rewrite nri /= => /eqP. +Qed. + +Lemma big_distr_big (I J : finType) j0 (P : pred I) (Q : pred J) F : + \big[*%M/1]_(i | P i) \big[+%M/0]_(j | Q j) F i j = + \big[+%M/0]_(f in pffun_on j0 P Q) \big[*%M/1]_(i | P i) F i (f i). +Proof. +rewrite (big_distr_big_dep j0); apply: eq_bigl => f. +by apply/familyP/familyP=> Pf i; case: ifP (Pf i). +Qed. + +Lemma bigA_distr_big_dep (I J : finType) (Q : I -> pred J) F : + \big[*%M/1]_i \big[+%M/0]_(j | Q i j) F i j + = \big[+%M/0]_(f in family Q) \big[*%M/1]_i F i (f i). +Proof. +case: (pickP J) => [j0 _ | J0]; first exact: (big_distr_big_dep j0). +rewrite {1 4}/index_enum -enumT; case: (enum I) (mem_enum I) => [I0 | i r _]. + have f0: I -> J by move=> i; have:= I0 i. + rewrite (big_pred1 (finfun f0)) ?big_nil // => g. + by apply/familyP/eqP=> _; first apply/ffunP; move=> i; have:= I0 i. +have Q0 i': Q i' =1 pred0 by move=> j; have:= J0 j. +rewrite big_cons /= big_pred0 // mul0m big_pred0 // => f. +by apply/familyP=> /(_ i); rewrite [_ \in _]Q0. +Qed. + +Lemma bigA_distr_big (I J : finType) (Q : pred J) (F : I -> J -> R) : + \big[*%M/1]_i \big[+%M/0]_(j | Q j) F i j + = \big[+%M/0]_(f in ffun_on Q) \big[*%M/1]_i F i (f i). +Proof. exact: bigA_distr_big_dep. Qed. + +Lemma bigA_distr_bigA (I J : finType) F : + \big[*%M/1]_(i : I) \big[+%M/0]_(j : J) F i j + = \big[+%M/0]_(f : {ffun I -> J}) \big[*%M/1]_i F i (f i). +Proof. by rewrite bigA_distr_big; apply: eq_bigl => ?; exact/familyP. Qed. + +End Distributivity. + +Implicit Arguments big_distrl [R zero times plus I r]. +Implicit Arguments big_distrr [R zero times plus I r]. +Implicit Arguments big_distr_big_dep [R zero one times plus I J]. +Implicit Arguments big_distr_big [R zero one times plus I J]. +Implicit Arguments bigA_distr_big_dep [R zero one times plus I J]. +Implicit Arguments bigA_distr_big [R zero one times plus I J]. +Implicit Arguments bigA_distr_bigA [R zero one times plus I J]. + +Section BigBool. + +Section Seq. + +Variables (I : Type) (r : seq I) (P B : pred I). + +Lemma big_has : \big[orb/false]_(i <- r) B i = has B r. +Proof. by rewrite unlock. Qed. + +Lemma big_all : \big[andb/true]_(i <- r) B i = all B r. +Proof. by rewrite unlock. Qed. + +Lemma big_has_cond : \big[orb/false]_(i <- r | P i) B i = has (predI P B) r. +Proof. by rewrite big_mkcond unlock. Qed. + +Lemma big_all_cond : + \big[andb/true]_(i <- r | P i) B i = all [pred i | P i ==> B i] r. +Proof. by rewrite big_mkcond unlock. Qed. + +End Seq. + +Section FinType. + +Variables (I : finType) (P B : pred I). + +Lemma big_orE : \big[orb/false]_(i | P i) B i = [exists (i | P i), B i]. +Proof. by rewrite big_has_cond; apply/hasP/existsP=> [] [i]; exists i. Qed. + +Lemma big_andE : \big[andb/true]_(i | P i) B i = [forall (i | P i), B i]. +Proof. +rewrite big_all_cond; apply/allP/forallP=> /= allB i; rewrite allB //. +exact: mem_index_enum. +Qed. + +End FinType. + +End BigBool. + +Section NatConst. + +Variables (I : finType) (A : pred I). + +Lemma sum_nat_const n : \sum_(i in A) n = #|A| * n. +Proof. by rewrite big_const iter_addn_0 mulnC. Qed. + +Lemma sum1_card : \sum_(i in A) 1 = #|A|. +Proof. by rewrite sum_nat_const muln1. Qed. + +Lemma sum1_count J (r : seq J) (a : pred J) : \sum_(j <- r | a j) 1 = count a r. +Proof. by rewrite big_const_seq iter_addn_0 mul1n. Qed. + +Lemma sum1_size J (r : seq J) : \sum_(j <- r) 1 = size r. +Proof. by rewrite sum1_count count_predT. Qed. + +Lemma prod_nat_const n : \prod_(i in A) n = n ^ #|A|. +Proof. by rewrite big_const -Monoid.iteropE. Qed. + +Lemma sum_nat_const_nat n1 n2 n : \sum_(n1 <= i < n2) n = (n2 - n1) * n. +Proof. by rewrite big_const_nat; elim: (_ - _) => //= ? ->. Qed. + +Lemma prod_nat_const_nat n1 n2 n : \prod_(n1 <= i < n2) n = n ^ (n2 - n1). +Proof. by rewrite big_const_nat -Monoid.iteropE. Qed. + +End NatConst. + +Lemma leqif_sum (I : finType) (P C : pred I) (E1 E2 : I -> nat) : + (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. +by elim/big_rec3: _ => // i Ci m1 m2 /leE12; exact: leqif_add. +Qed. + +Lemma leq_sum I r (P : pred I) (E1 E2 : I -> nat) : + (forall i, P i -> E1 i <= E2 i) -> + \sum_(i <- r | P i) E1 i <= \sum_(i <- r | P i) E2 i. +Proof. by move=> leE12; elim/big_ind2: _ => // m1 m2 n1 n2; exact: leq_add. Qed. + +Lemma sum_nat_eq0 (I : finType) (P : pred I) (E : I -> nat) : + (\sum_(i | P i) E i == 0)%N = [forall (i | P i), E i == 0%N]. +Proof. by rewrite eq_sym -(@leqif_sum I P _ (fun _ => 0%N) E) ?big1_eq. Qed. + +Lemma prodn_cond_gt0 I r (P : pred I) F : + (forall i, P i -> 0 < F i) -> 0 < \prod_(i <- r | P i) F i. +Proof. by move=> Fpos; elim/big_ind: _ => // n1 n2; rewrite muln_gt0 => ->. Qed. + +Lemma prodn_gt0 I r (P : pred I) F : + (forall i, 0 < F i) -> 0 < \prod_(i <- r | P i) F i. +Proof. move=> Fpos; exact: prodn_cond_gt0. Qed. + +Lemma leq_bigmax_cond (I : finType) (P : pred I) F i0 : + P i0 -> F i0 <= \max_(i | P i) F i. +Proof. by move=> Pi0; rewrite (bigD1 i0) ?leq_maxl. Qed. +Implicit Arguments leq_bigmax_cond [I P F]. + +Lemma leq_bigmax (I : finType) F (i0 : I) : F i0 <= \max_i F i. +Proof. exact: leq_bigmax_cond. Qed. +Implicit Arguments leq_bigmax [I F]. + +Lemma bigmax_leqP (I : finType) (P : pred I) m F : + reflect (forall i, P i -> F i <= m) (\max_(i | P i) F i <= m). +Proof. +apply: (iffP idP) => leFm => [i Pi|]. + by apply: leq_trans leFm; exact: leq_bigmax_cond. +by elim/big_ind: _ => // m1 m2; rewrite geq_max => ->. +Qed. + +Lemma bigmax_sup (I : finType) i0 (P : pred I) m F : + P i0 -> m <= F i0 -> m <= \max_(i | P i) F i. +Proof. by move=> Pi0 le_m_Fi0; exact: leq_trans (leq_bigmax_cond i0 Pi0). Qed. +Implicit Arguments bigmax_sup [I P m F]. + +Lemma bigmax_eq_arg (I : finType) i0 (P : pred I) F : + P i0 -> \max_(i | P i) F i = F [arg max_(i > i0 | P i) F i]. +Proof. +move=> Pi0; case: arg_maxP => //= i Pi maxFi. +by apply/eqP; rewrite eqn_leq leq_bigmax_cond // andbT; exact/bigmax_leqP. +Qed. +Implicit Arguments bigmax_eq_arg [I P F]. + +Lemma eq_bigmax_cond (I : finType) (A : pred I) F : + #|A| > 0 -> {i0 | i0 \in A & \max_(i in A) F i = F i0}. +Proof. +case: (pickP A) => [i0 Ai0 _ | ]; last by move/eq_card0->. +by exists [arg max_(i > i0 in A) F i]; [case: arg_maxP | exact: bigmax_eq_arg]. +Qed. + +Lemma eq_bigmax (I : finType) F : #|I| > 0 -> {i0 : I | \max_i F i = F i0}. +Proof. by case/(eq_bigmax_cond F) => x _ ->; exists x. Qed. + +Lemma expn_sum m I r (P : pred I) F : + (m ^ (\sum_(i <- r | P i) F i) = \prod_(i <- r | P i) m ^ F i)%N. +Proof. exact: (big_morph _ (expnD m)). Qed. + +Lemma dvdn_biglcmP (I : finType) (P : pred I) F m : + reflect (forall i, P i -> F i %| m) (\big[lcmn/1%N]_(i | P i) F i %| m). +Proof. +apply: (iffP idP) => [dvFm i Pi | dvFm]. + by rewrite (bigD1 i) // dvdn_lcm in dvFm; case/andP: dvFm. +by elim/big_ind: _ => // p q p_m; rewrite dvdn_lcm p_m. +Qed. + +Lemma biglcmn_sup (I : finType) i0 (P : pred I) F m : + P i0 -> m %| F i0 -> m %| \big[lcmn/1%N]_(i | P i) F i. +Proof. +by move=> Pi0 m_Fi0; rewrite (dvdn_trans m_Fi0) // (bigD1 i0) ?dvdn_lcml. +Qed. +Implicit Arguments biglcmn_sup [I P F m]. + +Lemma dvdn_biggcdP (I : finType) (P : pred I) F m : + reflect (forall i, P i -> m %| F i) (m %| \big[gcdn/0]_(i | P i) F i). +Proof. +apply: (iffP idP) => [dvmF i Pi | dvmF]. + by rewrite (bigD1 i) // dvdn_gcd in dvmF; case/andP: dvmF. +by elim/big_ind: _ => // p q m_p; rewrite dvdn_gcd m_p. +Qed. + +Lemma biggcdn_inf (I : finType) i0 (P : pred I) F m : + P i0 -> F i0 %| m -> \big[gcdn/0]_(i | P i) F i %| m. +Proof. by move=> Pi0; apply: dvdn_trans; rewrite (bigD1 i0) ?dvdn_gcdl. Qed. +Implicit Arguments biggcdn_inf [I P F m]. + +Unset Implicit Arguments. diff --git a/mathcomp/discrete/binomial.v b/mathcomp/discrete/binomial.v new file mode 100644 index 0000000..756a8f9 --- /dev/null +++ b/mathcomp/discrete/binomial.v @@ -0,0 +1,524 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path div. +Require Import fintype tuple finfun bigop prime finset. + +(******************************************************************************) +(* This files contains the definition of: *) +(* n ^_ m == the falling (or lower) factorial of n with m terms, i.e., *) +(* the product n * (n - 1) * ... * (n - m + 1) *) +(* Note that n ^_ m = 0 if m > n. *) +(* 'C(n, m) == the binomial coeficient n choose m *) +(* := n ^_ m %/ fact m *) +(* *) +(* In additions to the properties of these functions, triangular_sum, Wilson *) +(* and Pascal are examples of how to manipulate expressions with bigops. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +(** More properties of the factorial **) + +Lemma fact_smonotone m n : 0 < m -> m < n -> m`! < n`!. +Proof. +case: m => // m _; elim: n m => // n IHn [|m] lt_m_n. + by rewrite -[_.+1]muln1 leq_mul ?fact_gt0. +by rewrite ltn_mul ?IHn. +Qed. + +Lemma fact_prod n : n`! = \prod_(1 <= i < n.+1) i. +Proof. +elim: n => [|n IHn] //; first by rewrite big_nil. +by apply sym_equal; rewrite factS IHn // !big_add1 big_nat_recr //= mulnC. +Qed. + +Lemma logn_fact p n : prime p -> logn p n`! = \sum_(1 <= k < n.+1) n %/ p ^ k. +Proof. +move=> p_prime; transitivity (\sum_(1 <= i < n.+1) logn p i). + rewrite big_add1; elim: n => /= [|n IHn]; first by rewrite logn1 big_geq. + by rewrite big_nat_recr // -IHn /= factS mulnC lognM ?fact_gt0. +transitivity (\sum_(1 <= i < n.+1) \sum_(1 <= k < n.+1) (p ^ k %| i)). + apply: eq_big_nat => i /andP[i_gt0 le_i_n]; rewrite logn_count_dvd //. + rewrite -!big_mkcond (big_nat_widen _ _ n.+1) 1?ltnW //; apply: eq_bigl => k. + by apply: andb_idr => /dvdn_leq/(leq_trans (ltn_expl _ (prime_gt1 _)))->. +by rewrite exchange_big_nat; apply: eq_bigr => i _; rewrite divn_count_dvd. +Qed. + +Theorem Wilson p : p > 1 -> prime p = (p %| ((p.-1)`!).+1). +Proof. +have dFact n: 0 < n -> (n.-1)`! = \prod_(0 <= i < n | i != 0) i. + move=> n_gt0; rewrite -big_filter fact_prod; symmetry; apply: congr_big => //. + rewrite /index_iota subn1 -[n]prednK //=; apply/all_filterP. + by rewrite all_predC has_pred1 mem_iota. +move=> lt1p; have p_gt0 := ltnW lt1p. +apply/idP/idP=> [pr_p | dv_pF]; last first. + apply/primeP; split=> // d dv_dp; have: d <= p by exact: dvdn_leq. + rewrite orbC leq_eqVlt => /orP[-> // | ltdp]. + have:= dvdn_trans dv_dp dv_pF; rewrite dFact // big_mkord. + rewrite (bigD1 (Ordinal ltdp)) /=; last by rewrite -lt0n (dvdn_gt0 p_gt0). + by rewrite orbC -addn1 dvdn_addr ?dvdn_mulr // dvdn1 => ->. +pose Fp1 := Ordinal lt1p; pose Fp0 := Ordinal p_gt0. +have ltp1p: p.-1 < p by [rewrite prednK]; pose Fpn1 := Ordinal ltp1p. +case eqF1n1: (Fp1 == Fpn1); first by rewrite -{1}[p]prednK -1?((1 =P p.-1) _). +have toFpP m: m %% p < p by rewrite ltn_mod. +pose toFp := Ordinal (toFpP _); pose mFp (i j : 'I_p) := toFp (i * j). +have Fp_mod (i : 'I_p) : i %% p = i by exact: modn_small. +have mFpA: associative mFp. + by move=> i j k; apply: val_inj; rewrite /= modnMml modnMmr mulnA. +have mFpC: commutative mFp by move=> i j; apply: val_inj; rewrite /= mulnC. +have mFp1: left_id Fp1 mFp by move=> i; apply: val_inj; rewrite /= mul1n. +have mFp1r: right_id Fp1 mFp by move=> i; apply: val_inj; rewrite /= muln1. +pose mFpLaw := Monoid.Law mFpA mFp1 mFp1r. +pose mFpM := Monoid.operator (@Monoid.ComLaw _ _ mFpLaw mFpC). +pose vFp (i : 'I_p) := toFp (egcdn i p).1. +have vFpV i: i != Fp0 -> mFp (vFp i) i = Fp1. + rewrite -val_eqE /= -lt0n => i_gt0; apply: val_inj => /=. + rewrite modnMml; case: egcdnP => //= _ km -> _; rewrite {km}modnMDl. + suffices: coprime i p by move/eqnP->; rewrite modn_small. + rewrite coprime_sym prime_coprime //; apply/negP=> /(dvdn_leq i_gt0). + by rewrite leqNgt ltn_ord. +have vFp0 i: i != Fp0 -> vFp i != Fp0. + move/vFpV=> inv_i; apply/eqP=> vFp0. + by have:= congr1 val inv_i; rewrite vFp0 /= mod0n. +have vFpK: {in predC1 Fp0, involutive vFp}. + move=> i n0i; rewrite /= -[vFp _]mFp1r -(vFpV _ n0i) mFpA. + by rewrite vFpV (vFp0, mFp1). +have le_pmFp (i : 'I_p) m: i <= p + m. + by apply: leq_trans (ltnW _) (leq_addr _ _). +have eqFp (i j : 'I_p): (i == j) = (p %| p + i - j). + by rewrite -eqn_mod_dvd ?(modnDl, Fp_mod). +have vFpId i: (vFp i == i :> nat) = xpred2 Fp1 Fpn1 i. + symmetry; have [->{i} | /eqP ni0] := i =P Fp0. + by rewrite /= -!val_eqE /= -{2}[p]prednK //= modn_small //= -(subnKC lt1p). + rewrite 2!eqFp -Euclid_dvdM //= -[_ - p.-1]subSS prednK //. + have lt0i: 0 < i by rewrite lt0n. + rewrite -addnS addKn -addnBA // mulnDl -{2}(addn1 i) -subn_sqr. + rewrite addnBA ?leq_sqr // mulnS -addnA -mulnn -mulnDl. + rewrite -(subnK (le_pmFp (vFp i) i)) mulnDl addnCA. + rewrite -[1 ^ 2]/(Fp1 : nat) -addnBA // dvdn_addl. + by rewrite Euclid_dvdM // -eqFp eq_sym orbC /dvdn Fp_mod eqn0Ngt lt0i. + by rewrite -eqn_mod_dvd // Fp_mod modnDl -(vFpV _ ni0) eqxx. +suffices [mod_fact]: toFp (p.-1)`! = Fpn1. + by rewrite /dvdn -addn1 -modnDml mod_fact addn1 prednK // modnn. +rewrite dFact //; rewrite ((big_morph toFp) Fp1 mFpM) //; first last. +- by apply: val_inj; rewrite /= modn_small. +- by move=> i j; apply: val_inj; rewrite /= modnMm. +rewrite big_mkord (eq_bigr id) => [|i _]; last by apply: val_inj => /=. +pose ltv i := vFp i < i; rewrite (bigID ltv) -/mFpM [mFpM _ _]mFpC. +rewrite (bigD1 Fp1) -/mFpM; last by rewrite [ltv _]ltn_neqAle vFpId. +rewrite [mFpM _ _]mFp1 (bigD1 Fpn1) -?mFpA -/mFpM; last first. + rewrite -lt0n -ltnS prednK // lt1p. + by rewrite [ltv _]ltn_neqAle vFpId eqxx orbT eq_sym eqF1n1. +rewrite (reindex_onto vFp vFp) -/mFpM => [|i]; last by do 3!case/andP; auto. +rewrite (eq_bigl (xpredD1 ltv Fp0)) => [|i]; last first. + rewrite andbC -!andbA -2!negb_or -vFpId orbC -leq_eqVlt. + rewrite andbA -ltnNge; symmetry; case: (altP eqP) => [->|ni0]. + by case: eqP => // E; rewrite ?E !andbF. + by rewrite vFpK //eqxx vFp0. +rewrite -{2}[mFp]/mFpM -[mFpM _ _]big_split -/mFpM. +by rewrite big1 ?mFp1r //= => i /andP[]; auto. +Qed. + +(** The falling factorial *) + +Fixpoint ffact_rec n m := if m is m'.+1 then n * ffact_rec n.-1 m' else 1. + +Definition falling_factorial := nosimpl ffact_rec. + +Notation "n ^_ m" := (falling_factorial n m) + (at level 30, right associativity) : nat_scope. + +Lemma ffactE : falling_factorial = ffact_rec. Proof. by []. Qed. + +Lemma ffactn0 n : n ^_ 0 = 1. Proof. by []. Qed. + +Lemma ffact0n m : 0 ^_ m = (m == 0). Proof. by case: m. Qed. + +Lemma ffactnS n m : n ^_ m.+1 = n * n.-1 ^_ m. Proof. by []. Qed. + +Lemma ffactSS n m : n.+1 ^_ m.+1 = n.+1 * n ^_ m. Proof. by []. Qed. + +Lemma ffactn1 n : n ^_ 1 = n. Proof. exact: muln1. Qed. + +Lemma ffactnSr n m : n ^_ m.+1 = n ^_ m * (n - m). +Proof. +elim: n m => [|n IHn] [|m] //=; first by rewrite ffactn1 mul1n. +by rewrite !ffactSS IHn mulnA. +Qed. + +Lemma ffact_gt0 n m : (0 < n ^_ m) = (m <= n). +Proof. by elim: n m => [|n IHn] [|m] //=; rewrite ffactSS muln_gt0 IHn. Qed. + +Lemma ffact_small n m : n < m -> n ^_ m = 0. +Proof. by rewrite ltnNge -ffact_gt0; case: posnP. Qed. + +Lemma ffactnn n : n ^_ n = n`!. +Proof. by elim: n => [|n IHn] //; rewrite ffactnS IHn. Qed. + +Lemma ffact_fact n m : m <= n -> n ^_ m * (n - m)`! = n`!. +Proof. +by elim: n m => [|n IHn] [|m] //= le_m_n; rewrite ?mul1n // -mulnA IHn. +Qed. + +Lemma ffact_factd n m : m <= n -> n ^_ m = n`! %/ (n - m)`!. +Proof. by move/ffact_fact <-; rewrite mulnK ?fact_gt0. Qed. + +(** Binomial coefficients *) + +Fixpoint binomial_rec n m := + match n, m with + | n'.+1, m'.+1 => binomial_rec n' m + binomial_rec n' m' + | _, 0 => 1 + | 0, _.+1 => 0 + end. + +Definition binomial := nosimpl binomial_rec. + +Notation "''C' ( n , m )" := (binomial n m) + (at level 8, format "''C' ( n , m )") : nat_scope. + +Lemma binE : binomial = binomial_rec. Proof. by []. Qed. + +Lemma bin0 n : 'C(n, 0) = 1. Proof. by case: n. Qed. + +Lemma bin0n m : 'C(0, m) = (m == 0). Proof. by case: m. Qed. + +Lemma binS n m : 'C(n.+1, m.+1) = 'C(n, m.+1) + 'C(n, m). Proof. by []. Qed. + +Lemma bin1 n : 'C(n, 1) = n. +Proof. by elim: n => //= n IHn; rewrite binS bin0 IHn addn1. Qed. + +Lemma bin_gt0 m n : (0 < 'C(m, n)) = (n <= m). +Proof. +elim: m n => [|m IHm] [|n] //. +by rewrite binS addn_gt0 !IHm orbC ltn_neqAle andKb. +Qed. + +Lemma leq_bin2l m1 m2 n : m1 <= m2 -> 'C(m1, n) <= 'C(m2, n). +Proof. +elim: m1 m2 n => [m2 | m1 IHm [|m2] //] [|n] le_m12; rewrite ?bin0 //. +by rewrite !binS leq_add // IHm. +Qed. + +Lemma bin_small n m : n < m -> 'C(n, m) = 0. +Proof. by rewrite ltnNge -bin_gt0; case: posnP. Qed. + +Lemma binn n : 'C(n, n) = 1. +Proof. by elim: n => [|n IHn] //; rewrite binS bin_small. Qed. + +Lemma mul_Sm_binm m n : m.+1 * 'C(m, n) = n.+1 * 'C(m.+1, n.+1). +Proof. +elim: m n => [|m IHm] [|n] //; first by rewrite bin0 bin1 muln1 mul1n. +by rewrite mulSn {2}binS mulnDr addnCA !IHm -mulnDr. +Qed. + +Lemma bin_fact m n : n <= m -> 'C(m, n) * (n`! * (m - n)`!) = m`!. +Proof. +move/subnKC; move: (m - n) => m0 <-{m}. +elim: n => [|n IHn]; first by rewrite bin0 !mul1n. +by rewrite -mulnA mulnCA mulnA -mul_Sm_binm -mulnA IHn. +Qed. + +(* In fact the only exception is n = 0 and m = 1 *) +Lemma bin_factd n m : 0 < n -> 'C(n, m) = n`! %/ (m`! * (n - m)`!). +Proof. +move=> n_gt0; have [/bin_fact <-|lt_n_m] := leqP m n. + by rewrite mulnK // muln_gt0 !fact_gt0. +by rewrite bin_small // divnMA !divn_small ?fact_gt0 // fact_smonotone. +Qed. + +Lemma bin_ffact n m : 'C(n, m) * m`! = n ^_ m. +Proof. +apply/eqP; have [lt_n_m | le_m_n] := ltnP n m. + by rewrite bin_small ?ffact_small. +by rewrite -(eqn_pmul2r (fact_gt0 (n - m))) ffact_fact // -mulnA bin_fact. +Qed. + +Lemma bin_ffactd n m : 'C(n, m) = n ^_ m %/ m`!. +Proof. by rewrite -bin_ffact mulnK ?fact_gt0. Qed. + +Lemma bin_sub n m : m <= n -> 'C(n, n - m) = 'C(n, m). +Proof. +move=> le_m_n; apply/eqP; move/eqP: (bin_fact (leq_subr m n)). +by rewrite subKn // -(bin_fact le_m_n) !mulnA mulnAC !eqn_pmul2r // fact_gt0. +Qed. + +Lemma binSn n : 'C(n.+1, n) = n.+1. +Proof. by rewrite -bin_sub ?leqnSn // subSnn bin1. Qed. + +Lemma bin2 n : 'C(n, 2) = (n * n.-1)./2. +Proof. +by case: n => //= n; rewrite -{3}[n]bin1 mul_Sm_binm mul2n half_double. +Qed. + +Lemma bin2odd n : odd n -> 'C(n, 2) = n * n.-1./2. +Proof. by case: n => // n oddn; rewrite bin2 -!divn2 muln_divA ?dvdn2. Qed. + +Lemma prime_dvd_bin k p : prime p -> 0 < k < p -> p %| 'C(p, k). +Proof. +move=> p_pr /andP[k_gt0 lt_k_p]; have def_p := ltn_predK lt_k_p. +have: p %| p * 'C(p.-1, k.-1) by rewrite dvdn_mulr. +by rewrite -def_p mul_Sm_binm def_p prednK // Euclid_dvdM // gtnNdvd. +Qed. + +Lemma triangular_sum n : \sum_(0 <= i < n) i = 'C(n, 2). +Proof. +elim: n => [|n IHn]; first by rewrite big_geq. +by rewrite big_nat_recr // IHn binS bin1. +Qed. + +Lemma textbook_triangular_sum n : \sum_(0 <= i < n) i = 'C(n, 2). +Proof. +rewrite bin2; apply: canRL half_double _. +rewrite -addnn {1}big_nat_rev -big_split big_mkord /= ?add0n. +rewrite (eq_bigr (fun _ => n.-1)); first by rewrite sum_nat_const card_ord. +by case: n => [|n] [i le_i_n] //=; rewrite subSS subnK. +Qed. + +Theorem Pascal a b n : + (a + b) ^ n = \sum_(i < n.+1) 'C(n, i) * (a ^ (n - i) * b ^ i). +Proof. +elim: n => [|n IHn]; rewrite big_ord_recl muln1 ?big_ord0 //. +rewrite expnS {}IHn /= mulnDl !big_distrr /= big_ord_recl muln1 subn0. +rewrite !big_ord_recr /= !binn !subnn bin0 !subn0 !mul1n -!expnS -addnA. +congr (_ + _); rewrite addnA -big_split /=; congr (_ + _). +apply: eq_bigr => i _; rewrite mulnCA (mulnA a) -expnS subnSK //=. +by rewrite (mulnC b) -2!mulnA -expnSr -mulnDl. +Qed. +Definition expnDn := Pascal. + +Lemma Vandermonde k l i : + \sum_(j < i.+1) 'C(k, j) * 'C(l, i - j) = 'C(k + l , i). +Proof. +pose f k i := \sum_(j < i.+1) 'C(k, j) * 'C(l, i - j). +suffices{k i} fxx k i: f k.+1 i.+1 = f k i.+1 + f k i. + elim: k i => [i | k IHk [|i]]; last by rewrite -/(f _ _) fxx /f !IHk -binS. + by rewrite big_ord_recl big1_eq addn0 mul1n subn0. + by rewrite big_ord_recl big_ord0 addn0 !bin0 muln1. +rewrite {}/f big_ord_recl (big_ord_recl (i.+1)) !bin0 !mul1n. +rewrite -addnA -big_split /=; congr (_ + _). +by apply: eq_bigr => j _ ; rewrite -mulnDl. +Qed. + +Lemma subn_exp m n k : + m ^ k - n ^ k = (m - n) * (\sum_(i < k) m ^ (k.-1 -i) * n ^ i). +Proof. +case: k => [|k]; first by rewrite big_ord0. +rewrite mulnBl !big_distrr big_ord_recl big_ord_recr /= subn0 muln1. +rewrite subnn mul1n -!expnS subnDA; congr (_ - _); apply: canRL (addnK _) _. +congr (_ + _); apply: eq_bigr => i _. +by rewrite (mulnCA n) -expnS mulnA -expnS subnSK /=. +Qed. + +Lemma predn_exp m k : (m ^ k).-1 = m.-1 * (\sum_(i < k) m ^ i). +Proof. +rewrite -!subn1 -{1}(exp1n k) subn_exp; congr (_ * _). +symmetry; rewrite (reindex_inj rev_ord_inj); apply: eq_bigr => i _ /=. +by rewrite -subn1 -subnDA exp1n muln1. +Qed. + +Lemma dvdn_pred_predX n e : (n.-1 %| (n ^ e).-1)%N. +Proof. by rewrite predn_exp dvdn_mulr. Qed. + +Lemma modn_summ I r (P : pred I) F d : + \sum_(i <- r | P i) F i %% d = \sum_(i <- r | P i) F i %[mod d]. +Proof. +by apply/eqP; elim/big_rec2: _ => // i m n _; rewrite modnDml eqn_modDl. +Qed. + +(* Combinatorial characterizations. *) + +Section Combinations. + +Implicit Types T D : finType. + +Lemma card_uniq_tuples T n (A : pred T) : + #|[set t : n.-tuple T | all A t & uniq t]| = #|A| ^_ n. +Proof. +elim: n A => [|n IHn] A. + by rewrite (@eq_card1 _ [tuple]) // => t; rewrite [t]tuple0 inE. +rewrite -sum1dep_card (partition_big (@thead _ _) A) /= => [|t]; last first. + by case/tupleP: t => x t; do 2!case/andP. +transitivity (#|A| * #|A|.-1 ^_ n)%N; last by case: #|A|. +rewrite -sum_nat_const; apply: eq_bigr => x Ax. +rewrite (cardD1 x) [x \in A]Ax /= -(IHn [predD1 A & x]) -sum1dep_card. +rewrite (reindex (fun t : n.-tuple T => [tuple of x :: t])) /=; last first. + pose ttail (t : n.+1.-tuple T) := [tuple of behead t]. + exists ttail => [t _ | t /andP[_ /eqP <-]]; first exact: val_inj. + by rewrite -tuple_eta. +apply: eq_bigl=> t; rewrite Ax theadE eqxx andbT /= andbA; congr (_ && _). +by rewrite all_predI all_predC has_pred1 andbC. +Qed. + +Lemma card_inj_ffuns_on D T (R : pred T) : + #|[set f : {ffun D -> T} in ffun_on R | injectiveb f]| = #|R| ^_ #|D|. +Proof. +rewrite -card_uniq_tuples. +have bijFF: {on (_ : pred _), bijective (@Finfun D T)}. + by exists val => // x _; exact: val_inj. +rewrite -(on_card_preimset (bijFF _)); apply: eq_card => t. +rewrite !inE -(codom_ffun (Finfun t)); congr (_ && _); apply: negb_inj. +by rewrite -has_predC has_map enumT has_filter -size_eq0 -cardE. +Qed. + +Lemma card_inj_ffuns D T : + #|[set f : {ffun D -> T} | injectiveb f]| = #|T| ^_ #|D|. +Proof. +rewrite -card_inj_ffuns_on; apply: eq_card => f. +by rewrite 2!inE; case: ffun_onP => // []. +Qed. + +Lemma card_draws T k : #|[set A : {set T} | #|A| == k]| = 'C(#|T|, k). +Proof. +have [ltTk | lekT] := ltnP #|T| k. + rewrite bin_small // eq_card0 // => A. + by rewrite inE eqn_leq andbC leqNgt (leq_ltn_trans (max_card _)). +apply/eqP; rewrite -(eqn_pmul2r (fact_gt0 k)) bin_ffact // eq_sym. +rewrite -sum_nat_dep_const -{1 3}(card_ord k) -card_inj_ffuns -sum1dep_card. +pose imIk (f : {ffun 'I_k -> T}) := f @: 'I_k. +rewrite (partition_big imIk (fun A => #|A| == k)) /= => [|f]; last first. + by move/injectiveP=> inj_f; rewrite card_imset ?card_ord. +apply/eqP; apply: eq_bigr => A /eqP cardAk. +have [f0 inj_f0 im_f0]: exists2 f, injective f & f @: 'I_k = A. + rewrite -cardAk; exists enum_val; first exact: enum_val_inj. + apply/setP=> a; apply/imsetP/idP=> [[i _ ->] | Aa]; first exact: enum_valP. + by exists (enum_rank_in Aa a); rewrite ?enum_rankK_in. +rewrite (reindex (fun p : {ffun _} => [ffun i => f0 (p i)])) /=; last first. + pose ff0' f i := odflt i [pick j | f i == f0 j]. + exists (fun f => [ffun i => ff0' f i]) => [p _ | f]. + apply/ffunP=> i; rewrite ffunE /ff0'; case: pickP => [j | /(_ (p i))]. + by rewrite ffunE (inj_eq inj_f0) => /eqP. + by rewrite ffunE eqxx. + rewrite -im_f0 => /andP[/injectiveP injf /eqP im_f]. + apply/ffunP=> i; rewrite !ffunE /ff0'; case: pickP => [y /eqP //|]. + have /imsetP[j _ eq_f0j_fi]: f i \in f0 @: 'I_k by rewrite -im_f mem_imset. + by move/(_ j)=> /eqP[]. +rewrite -ffactnn -card_inj_ffuns -sum1dep_card; apply: eq_bigl => p. +apply/andP/injectiveP=> [[/injectiveP inj_f0p _] i j eq_pij | inj_p]. + by apply: inj_f0p; rewrite !ffunE eq_pij. +set f := finfun _. +have injf: injective f by move=> i j; rewrite !ffunE => /inj_f0; exact: inj_p. +split; first exact/injectiveP. +rewrite eqEcard card_imset // cardAk card_ord leqnn andbT -im_f0. +by apply/subsetP=> x /imsetP[i _ ->]; rewrite ffunE mem_imset. +Qed. + +Lemma card_ltn_sorted_tuples m n : + #|[set t : m.-tuple 'I_n | sorted ltn (map val t)]| = 'C(n, m). +Proof. +have [-> | n_gt0] := posnP n; last pose i0 := Ordinal n_gt0. + case: m => [|m]; last by apply: eq_card0; case/tupleP=> [[]]. + by apply: (@eq_card1 _ [tuple]) => t; rewrite [t]tuple0 inE. +rewrite -{12}[n]card_ord -card_draws. +pose f_t (t : m.-tuple 'I_n) := [set i in t]. +pose f_A (A : {set 'I_n}) := [tuple of mkseq (nth i0 (enum A)) m]. +have val_fA (A : {set 'I_n}) : #|A| = m -> val (f_A A) = enum A. + by move=> Am; rewrite -[enum _](mkseq_nth i0) -cardE Am. +have inc_A (A : {set 'I_n}) : sorted ltn (map val (enum A)). + rewrite -[enum _](eq_filter (mem_enum _)). + rewrite -(eq_filter (mem_map val_inj _)) -filter_map. + by rewrite (sorted_filter ltn_trans) // unlock val_ord_enum iota_ltn_sorted. +rewrite -!sum1dep_card (reindex_onto f_t f_A) /= => [|A]; last first. + by move/eqP=> cardAm; apply/setP=> x; rewrite inE -(mem_enum (mem A)) -val_fA. +apply: eq_bigl => t; apply/idP/idP=> [inc_t|]; last first. + by case/andP; move/eqP=> t_m; move/eqP=> <-; rewrite val_fA. +have ft_m: #|f_t t| = m. + rewrite cardsE (card_uniqP _) ?size_tuple // -(map_inj_uniq val_inj). + exact: (sorted_uniq ltn_trans ltnn). +rewrite ft_m eqxx -val_eqE val_fA // -(inj_eq (inj_map val_inj)) /=. +apply/eqP; apply: (eq_sorted_irr ltn_trans ltnn) => // y. +by apply/mapP/mapP=> [] [x t_x ->]; exists x; rewrite // mem_enum inE in t_x *. +Qed. + +Lemma card_sorted_tuples m n : + #|[set t : m.-tuple 'I_n.+1 | sorted leq (map val t)]| = 'C(m + n, m). +Proof. +set In1 := 'I_n.+1; pose x0 : In1 := ord0. +have add_mnP (i : 'I_m) (x : In1) : i + x < m + n. + by rewrite -ltnS -addSn -!addnS leq_add. +pose add_mn t i := Ordinal (add_mnP i (tnth t i)). +pose add_mn_nat (t : m.-tuple In1) i := i + nth x0 t i. +have add_mnC t: val \o add_mn t =1 add_mn_nat t \o val. + by move=> i; rewrite /= (tnth_nth x0). +pose f_add t := [tuple of map (add_mn t) (ord_tuple m)]. +rewrite -card_ltn_sorted_tuples -!sum1dep_card (reindex f_add) /=. + apply: eq_bigl => t; rewrite -map_comp (eq_map (add_mnC t)) map_comp. + rewrite enumT unlock val_ord_enum -{1}(drop0 t). + have [m0 | m_gt0] := posnP m. + by rewrite {2}m0 /= drop_oversize // size_tuple m0. + have def_m := subnK m_gt0; rewrite -{2}def_m addn1 /= {1}/add_mn_nat. + move: 0 (m - 1) def_m => i k; rewrite -{1}(size_tuple t) => def_m. + rewrite (drop_nth x0) /=; last by rewrite -def_m leq_addl. + elim: k i (nth x0 t i) def_m => [|k IHk] i x /=. + by rewrite add0n => ->; rewrite drop_size. + rewrite addSnnS => def_m; rewrite -addSn leq_add2l -IHk //. + by rewrite (drop_nth x0) // -def_m leq_addl. +pose sub_mn (t : m.-tuple 'I_(m + n)) i : In1 := inord (tnth t i - i). +exists (fun t => [tuple of map (sub_mn t) (ord_tuple m)]) => [t _ | t]. + apply: eq_from_tnth => i; apply: val_inj. + by rewrite /sub_mn !(tnth_ord_tuple, tnth_map) addKn inord_val. +rewrite inE /= => inc_t; apply: eq_from_tnth => i; apply: val_inj. +rewrite tnth_map tnth_ord_tuple /= tnth_map tnth_ord_tuple. +suffices [le_i_ti le_ti_ni]: i <= tnth t i /\ tnth t i <= i + n. + by rewrite /sub_mn inordK ?subnKC // ltnS leq_subLR. +pose y0 := tnth t i; rewrite (tnth_nth y0) -(nth_map _ (val i)) ?size_tuple //. +case def_e: (map _ _) => [|x e] /=; first by rewrite nth_nil ?leq_addr. +rewrite def_e in inc_t; split. + case: {-2}i; rewrite /= -{1}(size_tuple t) -(size_map val) def_e. + elim=> //= j IHj lt_j_t; apply: leq_trans (pathP (val i) inc_t _ lt_j_t). + by rewrite ltnS IHj 1?ltnW. +move: (_ - _) (subnK (valP i)) => k /=. +elim: k {-2}(val i) => /= [|k IHk] j def_m; rewrite -ltnS -addSn. + by rewrite [j.+1]def_m -def_e (nth_map y0) ?ltn_ord // size_tuple -def_m. +rewrite (leq_trans _ (IHk _ _)) -1?addSnnS //; apply: (pathP _ inc_t). +rewrite -ltnS (leq_trans (leq_addl k _)) // -addSnnS def_m. +by rewrite -(size_tuple t) -(size_map val) def_e. +Qed. + +Lemma card_partial_ord_partitions m n : + #|[set t : m.-tuple 'I_n.+1 | \sum_(i <- t) i <= n]| = 'C(m + n, m). +Proof. +symmetry; set In1 := 'I_n.+1; pose x0 : In1 := ord0. +pose add_mn (i j : In1) : In1 := inord (i + j). +pose f_add (t : m.-tuple In1) := [tuple of scanl add_mn x0 t]. +rewrite -card_sorted_tuples -!sum1dep_card (reindex f_add) /=. + apply: eq_bigl => t; rewrite -[\sum_(i <- t) i]add0n. + transitivity (path leq x0 (map val (f_add t))) => /=; first by case: map. + rewrite -{1 2}[0]/(val x0); elim: {t}(val t) (x0) => /= [|x t IHt] s. + by rewrite big_nil addn0 -ltnS ltn_ord. + rewrite big_cons addnA IHt /= val_insubd ltnS. + have [_ | ltn_n_sx] := leqP (s + x) n; first by rewrite leq_addr. + rewrite -(leq_add2r x) leqNgt (leq_trans (valP x)) //=. + by rewrite leqNgt (leq_trans ltn_n_sx) ?leq_addr. +pose sub_mn (i j : In1) := Ordinal (leq_ltn_trans (leq_subr i j) (valP j)). +exists (fun t : m.-tuple In1 => [tuple of pairmap sub_mn x0 t]) => /= t inc_t. + apply: val_inj => /=; have{inc_t}: path leq x0 (map val (f_add t)). + by move: inc_t; rewrite inE /=; case: map. + rewrite [map _ _]/=; elim: {t}(val t) (x0) => //= x t IHt s. + case/andP=> le_s_sx /IHt->; congr (_ :: _); apply: val_inj => /=. + move: le_s_sx; rewrite val_insubd. + case le_sx_n: (_ < n.+1); first by rewrite addKn. + by case: (val s) le_sx_n; rewrite ?ltn_ord. +apply: val_inj => /=; have{inc_t}: path leq x0 (map val t). + by move: inc_t; rewrite inE /=; case: map. +elim: {t}(val t) (x0) => //= x t IHt s /andP[le_s_sx inc_t]. +suffices ->: add_mn s (sub_mn s x) = x by rewrite IHt. +by apply: val_inj; rewrite /add_mn /= subnKC ?inord_val. +Qed. + +Lemma card_ord_partitions m n : + #|[set t : m.+1.-tuple 'I_n.+1 | \sum_(i <- t) i == n]| = 'C(m + n, m). +Proof. +symmetry; set In1 := 'I_n.+1; pose x0 : In1 := ord0. +pose f_add (t : m.-tuple In1) := [tuple of sub_ord (\sum_(x <- t) x) :: t]. +rewrite -card_partial_ord_partitions -!sum1dep_card (reindex f_add) /=. + by apply: eq_bigl => t; rewrite big_cons /= addnC (sameP maxn_idPr eqP) maxnE. +exists (fun t : m.+1.-tuple In1 => [tuple of behead t]) => [t _|]. + exact: val_inj. +case/tupleP=> x t; rewrite inE /= big_cons => /eqP def_n. +by apply: val_inj; congr (_ :: _); apply: val_inj; rewrite /= -{1}def_n addnK. +Qed. + +End Combinations. + diff --git a/mathcomp/discrete/choice.v b/mathcomp/discrete/choice.v new file mode 100644 index 0000000..96b549c --- /dev/null +++ b/mathcomp/discrete/choice.v @@ -0,0 +1,681 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq. + +(******************************************************************************) +(* This file contains the definitions of: *) +(* choiceType == interface for types with a choice operator *) +(* countType == interface for countable types *) +(* subCountType == interface for types that are both subType and countType. *) +(* xchoose exP == a standard x such that P x, given exP : exists x : T, P x *) +(* when T is a choiceType. The choice depends only on the *) +(* extent of P (in particular, it is independent of exP). *) +(* choose P x0 == if P x0, a standard x such that P x. *) +(* pickle x == a nat encoding the value x : T, where T is a countType. *) +(* unpickle n == a partial inverse to pickle: unpickle (pickle x) = Some x *) +(* pickle_inv n == a sharp partial inverse to pickle pickle_inv n = Some x *) +(* if and only if pickle x = n. *) +(* [choiceType of T for cT] == clone for T of the choiceType cT. *) +(* [choiceType of T] == clone for T of the choiceType inferred for T. *) +(* [countType of T for cT] == clone for T of the countType cT. *) +(* [count Type of T] == clone for T of the countType inferred for T. *) +(* [choiceMixin of T by <:] == Choice mixin for T when T has a subType p *) +(* structure with p : pred cT and cT has a Choice *) +(* structure; the corresponding structure is Canonical.*) +(* [countMixin of T by <:] == Count mixin for a subType T of a countType. *) +(* PcanChoiceMixin fK == Choice mixin for T, given f : T -> cT where cT has *) +(* a Choice structure, a left inverse partial function *) +(* g and fK : pcancel f g. *) +(* CanChoiceMixin fK == Choice mixin for T, given f : T -> cT, g and *) +(* fK : cancel f g. *) +(* PcanCountMixin fK == Count mixin for T, given f : T -> cT where cT has *) +(* a Countable structure, a left inverse partial *) +(* function g and fK : pcancel f g. *) +(* CanCountMixin fK == Count mixin for T, given f : T -> cT, g and *) +(* fK : cancel f g. *) +(* GenTree.tree T == generic n-ary tree type with nat-labeled nodes and *) +(* T-labeled nodes. It is equipped with canonical *) +(* eqType, choiceType, and countType instances, and so *) +(* can be used to similarly equip simple datatypes *) +(* by using the mixins above. *) +(* In addition to the lemmas relevant to these definitions, this file also *) +(* contains definitions of a Canonical choiceType and countType instances for *) +(* all basic datatypes (e.g., nat, bool, subTypes, pairs, sums, etc.). *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +(* Technical definitions about coding and decoding of nat sequances, which *) +(* are used below to define various Canonical instances of the choice and *) +(* countable interfaces. *) + +Module CodeSeq. + +(* Goedel-style one-to-one encoding of seq nat into nat. *) +(* The code for [:: n1; ...; nk] has binary representation *) +(* 1 0 ... 0 1 ... 1 0 ... 0 1 0 ... 0 *) +(* <-----> <-----> <-----> *) +(* nk 0s n2 0s n1 0s *) + +Definition code := foldr (fun n m => 2 ^ n * m.*2.+1) 0. + +Fixpoint decode_rec (v q r : nat) {struct q} := + match q, r with + | 0, _ => [:: v] + | q'.+1, 0 => v :: [rec 0, q', q'] + | q'.+1, 1 => [rec v.+1, q', q'] + | q'.+1, r'.+2 => [rec v, q', r'] + end where "[ 'rec' v , q , r ]" := (decode_rec v q r). + +Definition decode n := if n is 0 then [::] else [rec 0, n.-1, n.-1]. + +Lemma decodeK : cancel decode code. +Proof. +have m2s: forall n, n.*2 - n = n by move=> n; rewrite -addnn addnK. +case=> //= n; rewrite -[n.+1]mul1n -(expn0 2) -{3}[n]m2s. +elim: n {2 4}n {1 3}0 => [|q IHq] [|[|r]] v //=; rewrite {}IHq ?mul1n ?m2s //. +by rewrite expnSr -mulnA mul2n. +Qed. + +Lemma codeK : cancel code decode. +Proof. +elim=> //= v s IHs; rewrite -[_ * _]prednK ?muln_gt0 ?expn_gt0 //=. +rewrite -{3}[v]addn0; elim: v {1 4}0 => [|v IHv {IHs}] q. + rewrite mul1n /= -{1}addnn -{4}IHs; move: (_ s) {IHs} => n. + by elim: {1 3}n => //=; case: n. +rewrite expnS -mulnA mul2n -{1}addnn -[_ * _]prednK ?muln_gt0 ?expn_gt0 //. +by rewrite doubleS addSn /= addSnnS; elim: {-2}_.-1 => //=. +Qed. + +Lemma ltn_code s : all (fun j => j < code s) s. +Proof. +elim: s => //= i s IHs; rewrite -[_.+1]muln1 leq_mul 1?ltn_expl //=. +apply: sub_all IHs => j /leqW lejs; rewrite -[j.+1]mul1n leq_mul ?expn_gt0 //. +by rewrite ltnS -[j]mul1n -mul2n leq_mul. +Qed. + +Lemma gtn_decode n : all (ltn^~ n) (decode n). +Proof. by rewrite -{1}[n]decodeK ltn_code. Qed. + +End CodeSeq. + +Section OtherEncodings. +(* Miscellaneous encodings: option T -c-> seq T, T1 * T2 -c-> {i : T1 & T2} *) +(* T1 + T2 -c-> option T1 * option T2, unit -c-> bool; bool -c-> nat is *) +(* already covered in ssrnat by the nat_of_bool coercion, the odd predicate, *) +(* and their "cancellation" lemma oddb. We use these encodings to propagate *) +(* canonical structures through these type constructors so that ultimately *) +(* all Choice and Countable instanced derive from nat and the seq and sigT *) +(* constructors. *) + +Variables T T1 T2 : Type. + +Definition seq_of_opt := @oapp T _ (nseq 1) [::]. +Lemma seq_of_optK : cancel seq_of_opt ohead. Proof. by case. Qed. + +Definition tag_of_pair (p : T1 * T2) := @Tagged T1 p.1 (fun _ => T2) p.2. +Definition pair_of_tag (u : {i : T1 & T2}) := (tag u, tagged u). +Lemma tag_of_pairK : cancel tag_of_pair pair_of_tag. Proof. by case. Qed. +Lemma pair_of_tagK : cancel pair_of_tag tag_of_pair. Proof. by case. Qed. + +Definition opair_of_sum (s : T1 + T2) := + match s with inl x => (Some x, None) | inr y => (None, Some y) end. +Definition sum_of_opair p := + oapp (some \o @inr T1 T2) (omap (@inl _ T2) p.1) p.2. +Lemma opair_of_sumK : pcancel opair_of_sum sum_of_opair. Proof. by case. Qed. + +Lemma bool_of_unitK : cancel (fun _ => true) (fun _ => tt). +Proof. by case. Qed. + +End OtherEncodings. + +(* Generic variable-arity tree type, providing an encoding target for *) +(* miscellaneous user datatypes. The GenTree.tree type can be combined with *) +(* a sigT type to model multi-sorted concrete datatypes. *) +Module GenTree. + +Section Def. + +Variable T : Type. + +Unset Elimination Schemes. +Inductive tree := Leaf of T | Node of nat & seq tree. + +Definition tree_rect K IH_leaf IH_node := + fix loop t : K t := match t with + | Leaf x => IH_leaf x + | Node n f0 => + let fix iter_pair f : foldr (fun t => prod (K t)) unit f := + if f is t :: f' then (loop t, iter_pair f') else tt in + IH_node n f0 (iter_pair f0) + end. +Definition tree_rec (K : tree -> Set) := @tree_rect K. +Definition tree_ind K IH_leaf IH_node := + fix loop t : K t : Prop := match t with + | Leaf x => IH_leaf x + | Node n f0 => + let fix iter_conj f : foldr (fun t => and (K t)) True f := + if f is t :: f' then conj (loop t) (iter_conj f') else Logic.I + in IH_node n f0 (iter_conj f0) + end. + +Fixpoint encode t : seq (nat + T) := + match t with + | Leaf x => [:: inr _ x] + | Node n f => inl _ n.+1 :: rcons (flatten (map encode f)) (inl _ 0) + end. + +Definition decode_step c fs := + match c with + | inr x => (Leaf x :: fs.1, fs.2) + | inl 0 => ([::], fs.1 :: fs.2) + | inl n.+1 => (Node n fs.1 :: head [::] fs.2, behead fs.2) + end. + +Definition decode c := ohead (foldr decode_step ([::], [::]) c).1. + +Lemma codeK : pcancel encode decode. +Proof. +move=> t; rewrite /decode; set fs := (_, _). +suffices ->: foldr decode_step fs (encode t) = (t :: fs.1, fs.2) by []. +elim: t => //= n f IHt in (fs) *; elim: f IHt => //= t f IHf []. +by rewrite rcons_cat foldr_cat => -> /= /IHf[-> -> ->]. +Qed. + +End Def. + +End GenTree. +Implicit Arguments GenTree.codeK []. + +Definition tree_eqMixin (T : eqType) := PcanEqMixin (GenTree.codeK T). +Canonical tree_eqType (T : eqType) := EqType (GenTree.tree T) (tree_eqMixin T). + +(* Structures for Types with a choice function, and for Types with countably *) +(* many elements. The two concepts are closely linked: we indeed make *) +(* Countable a subclass of Choice, as countable choice is valid in CiC. This *) +(* apparent redundancy is needed to ensure the consistency of the Canonical *) +(* inference, as the canonical Choice for a given type may differ from the *) +(* countable choice for its canonical Countable structure, e.g., for options. *) +(* The Choice interface exposes two choice functions; for T : choiceType *) +(* and P : pred T, we provide: *) +(* xchoose : (exists x, P x) -> T *) +(* choose : pred T -> T -> T *) +(* While P (xchoose exP) will always hold, P (choose P x0) will be true if *) +(* and only if P x0 holds. Both xchoose and choose are extensional in P and *) +(* do not depend on the witness exP or x0 (provided P x0 holds). Note that *) +(* xchoose is slightly more powerful, but less convenient to use. *) +(* However, neither choose nor xchoose are composable: it would not be *) +(* be possible to extend the Choice structure to arbitrary pairs using only *) +(* these functions, for instance. Internally, the interfaces provides a *) +(* subtly stronger operation, Choice.InternalTheory.find, which performs a *) +(* limited search using an integer parameter only rather than a full value as *) +(* [x]choose does. This is not a restriction in the constructive setting *) +(* (where all types are concrete and hence countable). In the case of *) +(* axiomatizations, like for the Coq reals library, postulating a suitable *) +(* axiom of choice suppresses the need for guidance. Nevertheless this *) +(* operation is just what is needed to make the Choice interface compose. *) +(* The Countable interface provides three functions; for T : countType we *) +(* geth pickle : T -> nat, and unpickle, pickle_inv : nat -> option T. *) +(* The functions provide an effective embedding of T in nat: unpickle is a *) +(* left inverse to pickle, which satisfies pcancel pickle unpickle, i.e., *) +(* unpickle \o pickle =1 some; pickle_inv is a more precise inverse for which *) +(* we also have ocancel pickle_inv pickle. Both unpickle and pickle need to *) +(* partial functions, to allow for possibly empty types such as {x | P x}. *) +(* The names of these functions underline the correspondence with the *) +(* notion of "Serializable" types in programming languages. *) +(* Finally, we need to provide a join class to let type inference unify *) +(* subType and countType class constraints, e.g., for a countable subType of *) +(* an uncountable choiceType (the issue does not arise earlier with eqType or *) +(* choiceType because in practice the base type of an Equality/Choice subType *) +(* is always an Equality/Choice Type). *) + +Module Choice. + +Section ClassDef. + +Record mixin_of T := Mixin { + find : pred T -> nat -> option T; + _ : forall P n x, find P n = Some x -> P x; + _ : forall P : pred T, (exists x, P x) -> exists n, find P n; + _ : forall P Q : pred T, P =1 Q -> find P =1 find Q +}. + +Record class_of T := Class {base : Equality.class_of T; mixin : mixin_of T}. +Local Coercion base : class_of >-> Equality.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. +Definition clone c of phant_id class c := @Pack T c T. +Let xT := let: Pack T _ _ := cT in T. +Notation xclass := (class : class_of xT). + +Definition pack m := + fun b bT & phant_id (Equality.class bT) b => Pack (@Class T b m) T. + +(* Inheritance *) +Definition eqType := @Equality.Pack cT xclass xT. + +End ClassDef. + +Module Import Exports. +Coercion base : class_of >-> Equality.class_of. +Coercion sort : type >-> Sortclass. +Coercion eqType : type >-> Equality.type. +Canonical eqType. +Notation choiceType := type. +Notation choiceMixin := mixin_of. +Notation ChoiceType T m := (@pack T m _ _ id). +Notation "[ 'choiceType' 'of' T 'for' cT ]" := (@clone T cT _ idfun) + (at level 0, format "[ 'choiceType' 'of' T 'for' cT ]") : form_scope. +Notation "[ 'choiceType' 'of' T ]" := (@clone T _ _ id) + (at level 0, format "[ 'choiceType' 'of' T ]") : form_scope. + +End Exports. + +Module InternalTheory. +Section InternalTheory. +(* Inner choice function. *) +Definition find T := find (mixin (class T)). + +Variable T : choiceType. +Implicit Types P Q : pred T. + +Lemma correct P n x : find P n = Some x -> P x. +Proof. by case: T => _ [_ []] //= in P n x *. Qed. + +Lemma complete P : (exists x, P x) -> (exists n, find P n). +Proof. by case: T => _ [_ []] //= in P *. Qed. + +Lemma extensional P Q : P =1 Q -> find P =1 find Q. +Proof. by case: T => _ [_ []] //= in P Q *. Qed. + +Fact xchoose_subproof P exP : {x | find P (ex_minn (@complete P exP)) = Some x}. +Proof. +by case: (ex_minnP (complete exP)) => n; case: (find P n) => // x; exists x. +Qed. + +End InternalTheory. +End InternalTheory. + +End Choice. +Export Choice.Exports. + +Section ChoiceTheory. + +Implicit Type T : choiceType. +Import Choice.InternalTheory CodeSeq. +Local Notation dc := decode. + +Section OneType. + +Variable T : choiceType. +Implicit Types P Q : pred T. + +Definition xchoose P exP := sval (@xchoose_subproof T P exP). + +Lemma xchooseP P exP : P (@xchoose P exP). +Proof. by rewrite /xchoose; case: (xchoose_subproof exP) => x /= /correct. Qed. + +Lemma eq_xchoose P Q exP exQ : P =1 Q -> @xchoose P exP = @xchoose Q exQ. +Proof. +rewrite /xchoose => eqPQ. +case: (xchoose_subproof exP) => x; case: (xchoose_subproof exQ) => y /=. +case: ex_minnP => n; case: ex_minnP => m. +rewrite -(extensional eqPQ) {1}(extensional eqPQ). +move=> Qm minPm Pn minQn; suffices /eqP->: m == n by move=> -> []. +by rewrite eqn_leq minQn ?minPm. +Qed. + +Lemma sigW P : (exists x, P x) -> {x | P x}. +Proof. by move=> exP; exists (xchoose exP); exact: xchooseP. Qed. + +Lemma sig2W P Q : (exists2 x, P x & Q x) -> {x | P x & Q x}. +Proof. +move=> exPQ; have [|x /andP[]] := @sigW (predI P Q); last by exists x. +by have [x Px Qx] := exPQ; exists x; exact/andP. +Qed. + +Lemma sig_eqW (vT : eqType) (lhs rhs : T -> vT) : + (exists x, lhs x = rhs x) -> {x | lhs x = rhs x}. +Proof. +move=> exP; suffices [x /eqP Ex]: {x | lhs x == rhs x} by exists x. +by apply: sigW; have [x /eqP Ex] := exP; exists x. +Qed. + +Lemma sig2_eqW (vT : eqType) (P : pred T) (lhs rhs : T -> vT) : + (exists2 x, P x & lhs x = rhs x) -> {x | P x & lhs x = rhs x}. +Proof. +move=> exP; suffices [x Px /eqP Ex]: {x | P x & lhs x == rhs x} by exists x. +by apply: sig2W; have [x Px /eqP Ex] := exP; exists x. +Qed. + +Definition choose P x0 := + if insub x0 : {? x | P x} is Some (exist x Px) then + xchoose (ex_intro [eta P] x Px) + else x0. + +Lemma chooseP P x0 : P x0 -> P (choose P x0). +Proof. by move=> Px0; rewrite /choose insubT xchooseP. Qed. + +Lemma choose_id P x0 y0 : P x0 -> P y0 -> choose P x0 = choose P y0. +Proof. by move=> Px0 Py0; rewrite /choose !insubT /=; exact: eq_xchoose. Qed. + +Lemma eq_choose P Q : P =1 Q -> choose P =1 choose Q. +Proof. +rewrite /choose => eqPQ x0. +do [case: insubP; rewrite eqPQ] => [[x Px] Qx0 _| ?]; last by rewrite insubN. +by rewrite insubT; exact: eq_xchoose. +Qed. + +Section CanChoice. + +Variables (sT : Type) (f : sT -> T). + +Lemma PcanChoiceMixin f' : pcancel f f' -> choiceMixin sT. +Proof. +move=> fK; pose liftP sP := [pred x | oapp sP false (f' x)]. +pose sf sP := [fun n => obind f' (find (liftP sP) n)]. +exists sf => [sP n x | sP [y sPy] | sP sQ eqPQ n] /=. +- by case Df: (find _ n) => //= [?] Dx; have:= correct Df; rewrite /= Dx. +- have [|n Pn] := @complete T (liftP sP); first by exists (f y); rewrite /= fK. + exists n; case Df: (find _ n) Pn => //= [x] _. + by have:= correct Df => /=; case: (f' x). +by congr (obind _ _); apply: extensional => x /=; case: (f' x) => /=. +Qed. + +Definition CanChoiceMixin f' (fK : cancel f f') := + PcanChoiceMixin (can_pcan fK). + +End CanChoice. + +Section SubChoice. + +Variables (P : pred T) (sT : subType P). + +Definition sub_choiceMixin := PcanChoiceMixin (@valK T P sT). +Definition sub_choiceClass := @Choice.Class sT (sub_eqMixin sT) sub_choiceMixin. +Canonical sub_choiceType := Choice.Pack sub_choiceClass sT. + +End SubChoice. + +Fact seq_choiceMixin : choiceMixin (seq T). +Proof. +pose r f := [fun xs => fun x : T => f (x :: xs) : option (seq T)]. +pose fix f sP ns xs {struct ns} := + if ns is n :: ns1 then let fr := r (f sP ns1) xs in obind fr (find fr n) + else if sP xs then Some xs else None. +exists (fun sP nn => f sP (dc nn) nil) => [sP n ys | sP [ys] | sP sQ eqPQ n]. +- elim: {n}(dc n) nil => [|n ns IHs] xs /=; first by case: ifP => // sPxs [<-]. + by case: (find _ n) => //= [x]; apply: IHs. +- rewrite -(cats0 ys); elim/last_ind: ys nil => [|ys y IHs] xs /=. + by move=> sPxs; exists 0; rewrite /= sPxs. + rewrite cat_rcons => /IHs[n1 sPn1] {IHs}. + have /complete[n]: exists z, f sP (dc n1) (z :: xs) by exists y. + case Df: (find _ n)=> // [x] _; exists (code (n :: dc n1)). + by rewrite codeK /= Df /= (correct Df). +elim: {n}(dc n) nil => [|n ns IHs] xs /=; first by rewrite eqPQ. +rewrite (@extensional _ _ (r (f sQ ns) xs)) => [|x]; last by rewrite IHs. +by case: find => /=. +Qed. +Canonical seq_choiceType := Eval hnf in ChoiceType (seq T) seq_choiceMixin. + +End OneType. + +Section TagChoice. + +Variables (I : choiceType) (T_ : I -> choiceType). + +Fact tagged_choiceMixin : choiceMixin {i : I & T_ i}. +Proof. +pose mkT i (x : T_ i) := Tagged T_ x. +pose ft tP n i := omap (mkT i) (find (tP \o mkT i) n). +pose fi tP ni nt := obind (ft tP nt) (find (ft tP nt) ni). +pose f tP n := if dc n is [:: ni; nt] then fi tP ni nt else None. +exists f => [tP n u | tP [[i x] tPxi] | sP sQ eqPQ n]. +- rewrite /f /fi; case: (dc n) => [|ni [|nt []]] //=. + case: (find _ _) => //= [i]; rewrite /ft. + by case Df: (find _ _) => //= [x] [<-]; have:= correct Df. +- have /complete[nt tPnt]: exists y, (tP \o mkT i) y by exists x. + have{tPnt}: exists j, ft tP nt j by exists i; rewrite /ft; case: find tPnt. + case/complete=> ni tPn; exists (code [:: ni; nt]); rewrite /f codeK /fi. + by case Df: find tPn => //= [j] _; have:= correct Df. +rewrite /f /fi; case: (dc n) => [|ni [|nt []]] //=. +rewrite (@extensional _ _ (ft sQ nt)) => [|i]. + by case: find => //= i; congr (omap _ _); apply: extensional => x /=. +by congr (omap _ _); apply: extensional => x /=. +Qed. +Canonical tagged_choiceType := + Eval hnf in ChoiceType {i : I & T_ i} tagged_choiceMixin. + +End TagChoice. + +Fact nat_choiceMixin : choiceMixin nat. +Proof. +pose f := [fun (P : pred nat) n => if P n then Some n else None]. +exists f => [P n m | P [n Pn] | P Q eqPQ n] /=; last by rewrite eqPQ. + by case: ifP => // Pn [<-]. +by exists n; rewrite Pn. +Qed. +Canonical nat_choiceType := Eval hnf in ChoiceType nat nat_choiceMixin. + +Definition bool_choiceMixin := CanChoiceMixin oddb. +Canonical bool_choiceType := Eval hnf in ChoiceType bool bool_choiceMixin. +Canonical bitseq_choiceType := Eval hnf in [choiceType of bitseq]. + +Definition unit_choiceMixin := CanChoiceMixin bool_of_unitK. +Canonical unit_choiceType := Eval hnf in ChoiceType unit unit_choiceMixin. + +Definition option_choiceMixin T := CanChoiceMixin (@seq_of_optK T). +Canonical option_choiceType T := + Eval hnf in ChoiceType (option T) (option_choiceMixin T). + +Definition sig_choiceMixin T (P : pred T) : choiceMixin {x | P x} := + sub_choiceMixin _. +Canonical sig_choiceType T (P : pred T) := + Eval hnf in ChoiceType {x | P x} (sig_choiceMixin P). + +Definition prod_choiceMixin T1 T2 := CanChoiceMixin (@tag_of_pairK T1 T2). +Canonical prod_choiceType T1 T2 := + Eval hnf in ChoiceType (T1 * T2) (prod_choiceMixin T1 T2). + +Definition sum_choiceMixin T1 T2 := PcanChoiceMixin (@opair_of_sumK T1 T2). +Canonical sum_choiceType T1 T2 := + Eval hnf in ChoiceType (T1 + T2) (sum_choiceMixin T1 T2). + +Definition tree_choiceMixin T := PcanChoiceMixin (GenTree.codeK T). +Canonical tree_choiceType T := ChoiceType (GenTree.tree T) (tree_choiceMixin T). + +End ChoiceTheory. + +Prenex Implicits xchoose choose. +Notation "[ 'choiceMixin' 'of' T 'by' <: ]" := + (sub_choiceMixin _ : choiceMixin T) + (at level 0, format "[ 'choiceMixin' 'of' T 'by' <: ]") : form_scope. + +Module Countable. + +Record mixin_of (T : Type) : Type := Mixin { + pickle : T -> nat; + unpickle : nat -> option T; + pickleK : pcancel pickle unpickle +}. + +Definition EqMixin T m := PcanEqMixin (@pickleK T m). +Definition ChoiceMixin T m := PcanChoiceMixin (@pickleK T m). + +Section ClassDef. + +Record class_of T := Class { base : Choice.class_of T; mixin : mixin_of T }. +Local Coercion base : class_of >-> Choice.class_of. + +Structure type : Type := Pack {sort : Type; _ : 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. +Definition clone c of phant_id class c := @Pack T c T. +Let xT := let: Pack T _ _ := cT in T. +Notation xclass := (class : class_of xT). + +Definition pack m := + fun bT b & phant_id (Choice.class bT) b => Pack (@Class T b m) T. + +Definition eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> Choice.class_of. +Coercion mixin : class_of >-> mixin_of. +Coercion sort : type >-> Sortclass. +Coercion eqType : type >-> Equality.type. +Canonical eqType. +Coercion choiceType : type >-> Choice.type. +Canonical choiceType. +Notation countType := type. +Notation CountType T m := (@pack T m _ _ id). +Notation CountMixin := Mixin. +Notation CountChoiceMixin := ChoiceMixin. +Notation "[ 'countType' 'of' T 'for' cT ]" := (@clone T cT _ idfun) + (at level 0, format "[ 'countType' 'of' T 'for' cT ]") : form_scope. +Notation "[ 'countType' 'of' T ]" := (@clone T _ _ id) + (at level 0, format "[ 'countType' 'of' T ]") : form_scope. + +End Exports. + +End Countable. +Export Countable.Exports. + +Definition unpickle T := Countable.unpickle (Countable.class T). +Definition pickle T := Countable.pickle (Countable.class T). +Implicit Arguments unpickle [T]. +Prenex Implicits pickle unpickle. + +Section CountableTheory. + +Variable T : countType. + +Lemma pickleK : @pcancel nat T pickle unpickle. +Proof. exact: Countable.pickleK. Qed. + +Definition pickle_inv n := + obind (fun x : T => if pickle x == n then Some x else None) (unpickle n). + +Lemma pickle_invK : ocancel pickle_inv pickle. +Proof. +by rewrite /pickle_inv => n; case def_x: (unpickle n) => //= [x]; case: eqP. +Qed. + +Lemma pickleK_inv : pcancel pickle pickle_inv. +Proof. by rewrite /pickle_inv => x; rewrite pickleK /= eqxx. Qed. + +Lemma pcan_pickleK sT f f' : + @pcancel T sT f f' -> pcancel (pickle \o f) (pcomp f' unpickle). +Proof. by move=> fK x; rewrite /pcomp pickleK /= fK. Qed. + +Definition PcanCountMixin sT f f' (fK : pcancel f f') := + @CountMixin sT _ _ (pcan_pickleK fK). + +Definition CanCountMixin sT f f' (fK : cancel f f') := + @PcanCountMixin sT _ _ (can_pcan fK). + +Definition sub_countMixin P sT := PcanCountMixin (@valK T P sT). + +Definition pickle_seq s := CodeSeq.code (map (@pickle T) s). +Definition unpickle_seq n := Some (pmap (@unpickle T) (CodeSeq.decode n)). +Lemma pickle_seqK : pcancel pickle_seq unpickle_seq. +Proof. by move=> s; rewrite /unpickle_seq CodeSeq.codeK (map_pK pickleK). Qed. + +Definition seq_countMixin := CountMixin pickle_seqK. +Canonical seq_countType := Eval hnf in CountType (seq T) seq_countMixin. + +End CountableTheory. + +Notation "[ 'countMixin' 'of' T 'by' <: ]" := + (sub_countMixin _ : Countable.mixin_of T) + (at level 0, format "[ 'countMixin' 'of' T 'by' <: ]") : form_scope. + +Section SubCountType. + +Variables (T : choiceType) (P : pred T). +Import Countable. + +Structure subCountType : Type := + SubCountType {subCount_sort :> subType P; _ : mixin_of subCount_sort}. + +Coercion sub_countType (sT : subCountType) := + Eval hnf in pack (let: SubCountType _ m := sT return mixin_of sT in m) id. +Canonical sub_countType. + +Definition pack_subCountType U := + fun sT cT & sub_sort sT * sort cT -> U * U => + fun b m & phant_id (Class b m) (class cT) => @SubCountType sT m. + +End SubCountType. + +(* This assumes that T has both countType and subType structures. *) +Notation "[ 'subCountType' 'of' T ]" := + (@pack_subCountType _ _ T _ _ id _ _ id) + (at level 0, format "[ 'subCountType' 'of' T ]") : form_scope. + +Section TagCountType. + +Variables (I : countType) (T_ : I -> countType). + +Definition pickle_tagged (u : {i : I & T_ i}) := + CodeSeq.code [:: pickle (tag u); pickle (tagged u)]. +Definition unpickle_tagged s := + if CodeSeq.decode s is [:: ni; nx] then + obind (fun i => omap (@Tagged I i T_) (unpickle nx)) (unpickle ni) + else None. +Lemma pickle_taggedK : pcancel pickle_tagged unpickle_tagged. +Proof. +by case=> i x; rewrite /unpickle_tagged CodeSeq.codeK /= pickleK /= pickleK. +Qed. + +Definition tag_countMixin := CountMixin pickle_taggedK. +Canonical tag_countType := Eval hnf in CountType {i : I & T_ i} tag_countMixin. + +End TagCountType. + +(* The remaining Canonicals for standard datatypes. *) +Section CountableDataTypes. + +Implicit Type T : countType. + +Lemma nat_pickleK : pcancel id (@Some nat). Proof. by []. Qed. +Definition nat_countMixin := CountMixin nat_pickleK. +Canonical nat_countType := Eval hnf in CountType nat nat_countMixin. + +Definition bool_countMixin := CanCountMixin oddb. +Canonical bool_countType := Eval hnf in CountType bool bool_countMixin. +Canonical bitseq_countType := Eval hnf in [countType of bitseq]. + +Definition unit_countMixin := CanCountMixin bool_of_unitK. +Canonical unit_countType := Eval hnf in CountType unit unit_countMixin. + +Definition option_countMixin T := CanCountMixin (@seq_of_optK T). +Canonical option_countType T := + Eval hnf in CountType (option T) (option_countMixin T). + +Definition sig_countMixin T (P : pred T) := [countMixin of {x | P x} by <:]. +Canonical sig_countType T (P : pred T) := + Eval hnf in CountType {x | P x} (sig_countMixin P). +Canonical sig_subCountType T (P : pred T) := + Eval hnf in [subCountType of {x | P x}]. + +Definition prod_countMixin T1 T2 := CanCountMixin (@tag_of_pairK T1 T2). +Canonical prod_countType T1 T2 := + Eval hnf in CountType (T1 * T2) (prod_countMixin T1 T2). + +Definition sum_countMixin T1 T2 := PcanCountMixin (@opair_of_sumK T1 T2). +Canonical sum_countType T1 T2 := + Eval hnf in CountType (T1 + T2) (sum_countMixin T1 T2). + +Definition tree_countMixin T := PcanCountMixin (GenTree.codeK T). +Canonical tree_countType T := CountType (GenTree.tree T) (tree_countMixin T). + +End CountableDataTypes. diff --git a/mathcomp/discrete/div.v b/mathcomp/discrete/div.v new file mode 100644 index 0000000..d06a8e3 --- /dev/null +++ b/mathcomp/discrete/div.v @@ -0,0 +1,946 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq. + +(******************************************************************************) +(* This file deals with divisibility for natural numbers. *) +(* It contains the definitions of: *) +(* edivn m d == the pair composed of the quotient and remainder *) +(* of the Euclidean division of m by d. *) +(* m %/ d == quotient of m by d. *) +(* m %% d == remainder of m by d. *) +(* m = n %[mod d] <-> m equals n modulo d. *) +(* m == n %[mod d] <=> m equals n modulo d (boolean version). *) +(* m <> n %[mod d] <-> m differs from n modulo d. *) +(* m != n %[mod d] <=> m differs from n modulo d (boolean version). *) +(* d %| m <=> d divides m. *) +(* gcdn m n == the GCD of m and n. *) +(* egcdn m n == the extended GCD of m and n. *) +(* lcmn m n == the LCM of m and n. *) +(* coprime m n <=> m and n are coprime (:= gcdn m n == 1). *) +(* chinese m n r s == witness of the chinese remainder theorem. *) +(* We adjoin an m to operator suffixes to indicate a nested %% (modn), as in *) +(* modnDml : m %% d + n = m + n %[mod d]. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +(** Euclidean division *) + +Definition edivn_rec d := + fix loop m q := if m - d is m'.+1 then loop m' q.+1 else (q, m). + +Definition edivn m d := if d > 0 then edivn_rec d.-1 m 0 else (0, m). + +CoInductive edivn_spec m d : nat * nat -> Type := + EdivnSpec q r of m = q * d + r & (d > 0) ==> (r < d) : edivn_spec m d (q, r). + +Lemma edivnP m d : edivn_spec m d (edivn m d). +Proof. +rewrite -{1}[m]/(0 * d + m) /edivn; case: d => //= d. +elim: m {-2}m 0 (leqnn m) => [|n IHn] [|m] q //= le_mn. +have le_m'n: m - d <= n by rewrite (leq_trans (leq_subr d m)). +rewrite subn_if_gt; case: ltnP => [// | le_dm]. +by rewrite -{1}(subnKC le_dm) -addSn addnA -mulSnr; exact: IHn. +Qed. + +Lemma edivn_eq d q r : r < d -> edivn (q * d + r) d = (q, r). +Proof. +move=> lt_rd; have d_gt0: 0 < d by exact: leq_trans lt_rd. +case: edivnP lt_rd => q' r'; rewrite d_gt0 /=. +wlog: q q' r r' / q <= q' by case/orP: (leq_total q q'); last symmetry; eauto. +rewrite leq_eqVlt; case/predU1P => [-> /addnI-> |] //=. +rewrite -(leq_pmul2r d_gt0) => /leq_add lt_qr eq_qr _ /lt_qr {lt_qr}. +by rewrite addnS ltnNge mulSn -addnA eq_qr addnCA addnA leq_addr. +Qed. + +Definition divn m d := (edivn m d).1. + +Notation "m %/ d" := (divn m d) : nat_scope. + +(* We redefine modn so that it is structurally decreasing. *) + +Definition modn_rec d := fix loop m := if m - d is m'.+1 then loop m' else m. + +Definition modn m d := if d > 0 then modn_rec d.-1 m else m. + +Notation "m %% d" := (modn m d) : nat_scope. +Notation "m = n %[mod d ]" := (m %% d = n %% d) : nat_scope. +Notation "m == n %[mod d ]" := (m %% d == n %% d) : nat_scope. +Notation "m <> n %[mod d ]" := (m %% d <> n %% d) : nat_scope. +Notation "m != n %[mod d ]" := (m %% d != n %% d) : nat_scope. + +Lemma modn_def m d : m %% d = (edivn m d).2. +Proof. +case: d => //= d; rewrite /modn /edivn /=. +elim: m {-2}m 0 (leqnn m) => [|n IHn] [|m] q //=. +rewrite ltnS !subn_if_gt; case: (d <= m) => // le_mn. +by apply: IHn; apply: leq_trans le_mn; exact: leq_subr. +Qed. + +Lemma edivn_def m d : edivn m d = (m %/ d, m %% d). +Proof. by rewrite /divn modn_def; case: (edivn m d). Qed. + +Lemma divn_eq m d : m = m %/ d * d + m %% d. +Proof. by rewrite /divn modn_def; case: edivnP. Qed. + +Lemma div0n d : 0 %/ d = 0. Proof. by case: d. Qed. +Lemma divn0 m : m %/ 0 = 0. Proof. by []. Qed. +Lemma mod0n d : 0 %% d = 0. Proof. by case: d. Qed. +Lemma modn0 m : m %% 0 = m. Proof. by []. Qed. + +Lemma divn_small m d : m < d -> m %/ d = 0. +Proof. by move=> lt_md; rewrite /divn (edivn_eq 0). Qed. + +Lemma divnMDl q m d : 0 < d -> (q * d + m) %/ d = q + m %/ d. +Proof. +move=> d_gt0; rewrite {1}(divn_eq m d) addnA -mulnDl. +by rewrite /divn edivn_eq // modn_def; case: edivnP; rewrite d_gt0. +Qed. + +Lemma mulnK m d : 0 < d -> m * d %/ d = m. +Proof. by move=> d_gt0; rewrite -[m * d]addn0 divnMDl // div0n addn0. Qed. + +Lemma mulKn m d : 0 < d -> d * m %/ d = m. +Proof. by move=> d_gt0; rewrite mulnC mulnK. Qed. + +Lemma expnB p m n : p > 0 -> m >= n -> p ^ (m - n) = p ^ m %/ p ^ n. +Proof. +by move=> p_gt0 /subnK{2}<-; rewrite expnD mulnK // expn_gt0 p_gt0. +Qed. + +Lemma modn1 m : m %% 1 = 0. +Proof. by rewrite modn_def; case: edivnP => ? []. Qed. + +Lemma divn1 m : m %/ 1 = m. +Proof. by rewrite {2}(@divn_eq m 1) // modn1 addn0 muln1. Qed. + +Lemma divnn d : d %/ d = (0 < d). +Proof. by case: d => // d; rewrite -{1}[d.+1]muln1 mulKn. Qed. + +Lemma divnMl p m d : p > 0 -> p * m %/ (p * d) = m %/ d. +Proof. +move=> p_gt0; case: (posnP d) => [-> | d_gt0]; first by rewrite muln0. +rewrite {2}/divn; case: edivnP; rewrite d_gt0 /= => q r ->{m} lt_rd. +rewrite mulnDr mulnCA divnMDl; last by rewrite muln_gt0 p_gt0. +by rewrite addnC divn_small // ltn_pmul2l. +Qed. +Implicit Arguments divnMl [p m d]. + +Lemma divnMr p m d : p > 0 -> m * p %/ (d * p) = m %/ d. +Proof. by move=> p_gt0; rewrite -!(mulnC p) divnMl. Qed. +Implicit Arguments divnMr [p m d]. + +Lemma ltn_mod m d : (m %% d < d) = (0 < d). +Proof. by case: d => // d; rewrite modn_def; case: edivnP. Qed. + +Lemma ltn_pmod m d : 0 < d -> m %% d < d. +Proof. by rewrite ltn_mod. Qed. + +Lemma leq_trunc_div m d : m %/ d * d <= m. +Proof. by rewrite {2}(divn_eq m d) leq_addr. Qed. + +Lemma leq_mod m d : m %% d <= m. +Proof. by rewrite {2}(divn_eq m d) leq_addl. Qed. + +Lemma leq_div m d : m %/ d <= m. +Proof. +by case: d => // d; apply: leq_trans (leq_pmulr _ _) (leq_trunc_div _ _). +Qed. + +Lemma ltn_ceil m d : 0 < d -> m < (m %/ d).+1 * d. +Proof. +by move=> d_gt0; rewrite {1}(divn_eq m d) -addnS mulSnr leq_add2l ltn_mod. +Qed. + +Lemma ltn_divLR m n d : d > 0 -> (m %/ d < n) = (m < n * d). +Proof. +move=> d_gt0; apply/idP/idP. + by rewrite -(leq_pmul2r d_gt0); apply: leq_trans (ltn_ceil _ _). +rewrite !ltnNge -(@leq_pmul2r d n) //; apply: contra => le_nd_floor. +exact: leq_trans le_nd_floor (leq_trunc_div _ _). +Qed. + +Lemma leq_divRL m n d : d > 0 -> (m <= n %/ d) = (m * d <= n). +Proof. by move=> d_gt0; rewrite leqNgt ltn_divLR // -leqNgt. Qed. + +Lemma ltn_Pdiv m d : 1 < d -> 0 < m -> m %/ d < m. +Proof. by move=> d_gt1 m_gt0; rewrite ltn_divLR ?ltn_Pmulr // ltnW. Qed. + +Lemma divn_gt0 d m : 0 < d -> (0 < m %/ d) = (d <= m). +Proof. by move=> d_gt0; rewrite leq_divRL ?mul1n. Qed. + +Lemma leq_div2r d m n : m <= n -> m %/ d <= n %/ d. +Proof. +have [-> //| d_gt0 le_mn] := posnP d. +by rewrite leq_divRL // (leq_trans _ le_mn) -?leq_divRL. +Qed. + +Lemma leq_div2l m d e : 0 < d -> d <= e -> m %/ e <= m %/ d. +Proof. +move/leq_divRL=> -> le_de. +by apply: leq_trans (leq_trunc_div m e); apply: leq_mul. +Qed. + +Lemma leq_divDl p m n : (m + n) %/ p <= m %/ p + n %/ p + 1. +Proof. +have [-> //| p_gt0] := posnP p; rewrite -ltnS -addnS ltn_divLR // ltnW //. +rewrite {1}(divn_eq n p) {1}(divn_eq m p) addnACA !mulnDl -3!addnS leq_add2l. +by rewrite mul2n -addnn -addSn leq_add // ltn_mod. +Qed. + +Lemma geq_divBl k m p : k %/ p - m %/ p <= (k - m) %/ p + 1. +Proof. +rewrite leq_subLR addnA; apply: leq_trans (leq_divDl _ _ _). +by rewrite -maxnE leq_div2r ?leq_maxr. +Qed. + +Lemma divnMA m n p : m %/ (n * p) = m %/ n %/ p. +Proof. +case: n p => [|n] [|p]; rewrite ?muln0 ?div0n //. +rewrite {2}(divn_eq m (n.+1 * p.+1)) mulnA mulnAC !divnMDl //. +by rewrite [_ %/ p.+1]divn_small ?addn0 // ltn_divLR // mulnC ltn_mod. +Qed. + +Lemma divnAC m n p : m %/ n %/ p = m %/ p %/ n. +Proof. by rewrite -!divnMA mulnC. Qed. + +Lemma modn_small m d : m < d -> m %% d = m. +Proof. by move=> lt_md; rewrite {2}(divn_eq m d) divn_small. Qed. + +Lemma modn_mod m d : m %% d = m %[mod d]. +Proof. by case: d => // d; apply: modn_small; rewrite ltn_mod. Qed. + +Lemma modnMDl p m d : p * d + m = m %[mod d]. +Proof. +case: (posnP d) => [-> | d_gt0]; first by rewrite muln0. +by rewrite {1}(divn_eq m d) addnA -mulnDl modn_def edivn_eq // ltn_mod. +Qed. + +Lemma muln_modr {p m d} : 0 < p -> p * (m %% d) = (p * m) %% (p * d). +Proof. +move=> p_gt0; apply: (@addnI (p * (m %/ d * d))). +by rewrite -mulnDr -divn_eq mulnCA -(divnMl p_gt0) -divn_eq. +Qed. + +Lemma muln_modl {p m d} : 0 < p -> (m %% d) * p = (m * p) %% (d * p). +Proof. by rewrite -!(mulnC p); apply: muln_modr. Qed. + +Lemma modnDl m d : d + m = m %[mod d]. +Proof. by rewrite -{1}[d]mul1n modnMDl. Qed. + +Lemma modnDr m d : m + d = m %[mod d]. +Proof. by rewrite addnC modnDl. Qed. + +Lemma modnn d : d %% d = 0. +Proof. by rewrite -{1}[d]addn0 modnDl mod0n. Qed. + +Lemma modnMl p d : p * d %% d = 0. +Proof. by rewrite -[p * d]addn0 modnMDl mod0n. Qed. + +Lemma modnMr p d : d * p %% d = 0. +Proof. by rewrite mulnC modnMl. Qed. + +Lemma modnDml m n d : m %% d + n = m + n %[mod d]. +Proof. by rewrite {2}(divn_eq m d) -addnA modnMDl. Qed. + +Lemma modnDmr m n d : m + n %% d = m + n %[mod d]. +Proof. by rewrite !(addnC m) modnDml. Qed. + +Lemma modnDm m n d : m %% d + n %% d = m + n %[mod d]. +Proof. by rewrite modnDml modnDmr. Qed. + +Lemma eqn_modDl p m n d : (p + m == p + n %[mod d]) = (m == n %[mod d]). +Proof. +case: d => [|d]; first by rewrite !modn0 eqn_add2l. +apply/eqP/eqP=> eq_mn; last by rewrite -modnDmr eq_mn modnDmr. +rewrite -(modnMDl p m) -(modnMDl p n) !mulnSr -!addnA. +by rewrite -modnDmr eq_mn modnDmr. +Qed. + +Lemma eqn_modDr p m n d : (m + p == n + p %[mod d]) = (m == n %[mod d]). +Proof. by rewrite -!(addnC p) eqn_modDl. Qed. + +Lemma modnMml m n d : m %% d * n = m * n %[mod d]. +Proof. by rewrite {2}(divn_eq m d) mulnDl mulnAC modnMDl. Qed. + +Lemma modnMmr m n d : m * (n %% d) = m * n %[mod d]. +Proof. by rewrite !(mulnC m) modnMml. Qed. + +Lemma modnMm m n d : m %% d * (n %% d) = m * n %[mod d]. +Proof. by rewrite modnMml modnMmr. Qed. + +Lemma modn2 m : m %% 2 = odd m. +Proof. by elim: m => //= m IHm; rewrite -addn1 -modnDml IHm; case odd. Qed. + +Lemma divn2 m : m %/ 2 = m./2. +Proof. by rewrite {2}(divn_eq m 2) modn2 muln2 addnC half_bit_double. Qed. + +Lemma odd_mod m d : odd d = false -> odd (m %% d) = odd m. +Proof. +by move=> d_even; rewrite {2}(divn_eq m d) odd_add odd_mul d_even andbF. +Qed. + +Lemma modnXm m n a : (a %% n) ^ m = a ^ m %[mod n]. +Proof. +by elim: m => // m IHm; rewrite !expnS -modnMmr IHm modnMml modnMmr. +Qed. + +(** Divisibility **) + +Definition dvdn d m := m %% d == 0. + +Notation "m %| d" := (dvdn m d) : nat_scope. + +Lemma dvdnP d m : reflect (exists k, m = k * d) (d %| m). +Proof. +apply: (iffP eqP) => [md0 | [k ->]]; last by rewrite modnMl. +by exists (m %/ d); rewrite {1}(divn_eq m d) md0 addn0. +Qed. +Implicit Arguments dvdnP [d m]. +Prenex Implicits dvdnP. + +Lemma dvdn0 d : d %| 0. +Proof. by case: d. Qed. + +Lemma dvd0n n : (0 %| n) = (n == 0). +Proof. by case: n. Qed. + +Lemma dvdn1 d : (d %| 1) = (d == 1). +Proof. by case: d => [|[|d]] //; rewrite /dvdn modn_small. Qed. + +Lemma dvd1n m : 1 %| m. +Proof. by rewrite /dvdn modn1. Qed. + +Lemma dvdn_gt0 d m : m > 0 -> d %| m -> d > 0. +Proof. by case: d => // /prednK <-. Qed. + +Lemma dvdnn m : m %| m. +Proof. by rewrite /dvdn modnn. Qed. + +Lemma dvdn_mull d m n : d %| n -> d %| m * n. +Proof. by case/dvdnP=> n' ->; rewrite /dvdn mulnA modnMl. Qed. + +Lemma dvdn_mulr d m n : d %| m -> d %| m * n. +Proof. by move=> d_m; rewrite mulnC dvdn_mull. Qed. +Hint Resolve dvdn0 dvd1n dvdnn dvdn_mull dvdn_mulr. + +Lemma dvdn_mul d1 d2 m1 m2 : d1 %| m1 -> d2 %| m2 -> d1 * d2 %| m1 * m2. +Proof. +by move=> /dvdnP[q1 ->] /dvdnP[q2 ->]; rewrite mulnCA -mulnA 2?dvdn_mull. +Qed. + +Lemma dvdn_trans n d m : d %| n -> n %| m -> d %| m. +Proof. by move=> d_dv_n /dvdnP[n1 ->]; exact: dvdn_mull. Qed. + +Lemma dvdn_eq d m : (d %| m) = (m %/ d * d == m). +Proof. +apply/eqP/eqP=> [modm0 | <-]; last exact: modnMl. +by rewrite {2}(divn_eq m d) modm0 addn0. +Qed. + +Lemma dvdn2 n : (2 %| n) = ~~ odd n. +Proof. by rewrite /dvdn modn2; case (odd n). Qed. + +Lemma dvdn_odd m n : m %| n -> odd n -> odd m. +Proof. +by move=> m_dv_n; apply: contraTT; rewrite -!dvdn2 => /dvdn_trans->. +Qed. + +Lemma divnK d m : d %| m -> m %/ d * d = m. +Proof. by rewrite dvdn_eq; move/eqP. Qed. + +Lemma leq_divLR d m n : d %| m -> (m %/ d <= n) = (m <= n * d). +Proof. by case: d m => [|d] [|m] ///divnK=> {2}<-; rewrite leq_pmul2r. Qed. + +Lemma ltn_divRL d m n : d %| m -> (n < m %/ d) = (n * d < m). +Proof. by move=> dv_d_m; rewrite !ltnNge leq_divLR. Qed. + +Lemma eqn_div d m n : d > 0 -> d %| m -> (n == m %/ d) = (n * d == m). +Proof. by move=> d_gt0 dv_d_m; rewrite -(eqn_pmul2r d_gt0) divnK. Qed. + +Lemma eqn_mul d m n : d > 0 -> d %| m -> (m == n * d) = (m %/ d == n). +Proof. by move=> d_gt0 dv_d_m; rewrite eq_sym -eqn_div // eq_sym. Qed. + +Lemma divn_mulAC d m n : d %| m -> m %/ d * n = m * n %/ d. +Proof. +case: d m => [[] //| d m] dv_d_m; apply/eqP. +by rewrite eqn_div ?dvdn_mulr // mulnAC divnK. +Qed. + +Lemma muln_divA d m n : d %| n -> m * (n %/ d) = m * n %/ d. +Proof. by move=> dv_d_m; rewrite !(mulnC m) divn_mulAC. Qed. + +Lemma muln_divCA d m n : d %| m -> d %| n -> m * (n %/ d) = n * (m %/ d). +Proof. by move=> dv_d_m dv_d_n; rewrite mulnC divn_mulAC ?muln_divA. Qed. + +Lemma divnA m n p : p %| n -> m %/ (n %/ p) = m * p %/ n. +Proof. by case: p => [|p] dv_n; rewrite -{2}(divnK dv_n) // divnMr. Qed. + +Lemma modn_dvdm m n d : d %| m -> n %% m = n %[mod d]. +Proof. +by case/dvdnP=> q def_m; rewrite {2}(divn_eq n m) {3}def_m mulnA modnMDl. +Qed. + +Lemma dvdn_leq d m : 0 < m -> d %| m -> d <= m. +Proof. by move=> m_gt0 /dvdnP[[|k] Dm]; rewrite Dm // leq_addr in m_gt0 *. Qed. + +Lemma gtnNdvd n d : 0 < n -> n < d -> (d %| n) = false. +Proof. by move=> n_gt0 lt_nd; rewrite /dvdn eqn0Ngt modn_small ?n_gt0. Qed. + +Lemma eqn_dvd m n : (m == n) = (m %| n) && (n %| m). +Proof. +case: m n => [|m] [|n] //; apply/idP/andP; first by move/eqP->; auto. +rewrite eqn_leq => [[Hmn Hnm]]; apply/andP; have:= dvdn_leq; auto. +Qed. + +Lemma dvdn_pmul2l p d m : 0 < p -> (p * d %| p * m) = (d %| m). +Proof. by case: p => // p _; rewrite /dvdn -muln_modr // muln_eq0. Qed. +Implicit Arguments dvdn_pmul2l [p m d]. + +Lemma dvdn_pmul2r p d m : 0 < p -> (d * p %| m * p) = (d %| m). +Proof. by move=> p_gt0; rewrite -!(mulnC p) dvdn_pmul2l. Qed. +Implicit Arguments dvdn_pmul2r [p m d]. + +Lemma dvdn_divLR p d m : 0 < p -> p %| d -> (d %/ p %| m) = (d %| m * p). +Proof. by move=> /(@dvdn_pmul2r p _ m) <- /divnK->. Qed. + +Lemma dvdn_divRL p d m : p %| m -> (d %| m %/ p) = (d * p %| m). +Proof. +have [-> | /(@dvdn_pmul2r p d) <- /divnK-> //] := posnP p. +by rewrite divn0 muln0 dvdn0. +Qed. + +Lemma dvdn_div d m : d %| m -> m %/ d %| m. +Proof. by move/divnK=> {2}<-; apply: dvdn_mulr. Qed. + +Lemma dvdn_exp2l p m n : m <= n -> p ^ m %| p ^ n. +Proof. by move/subnK <-; rewrite expnD dvdn_mull. Qed. + +Lemma dvdn_Pexp2l p m n : p > 1 -> (p ^ m %| p ^ n) = (m <= n). +Proof. +move=> p_gt1; case: leqP => [|gt_n_m]; first exact: dvdn_exp2l. +by rewrite gtnNdvd ?ltn_exp2l ?expn_gt0 // ltnW. +Qed. + +Lemma dvdn_exp2r m n k : m %| n -> m ^ k %| n ^ k. +Proof. by case/dvdnP=> q ->; rewrite expnMn dvdn_mull. Qed. + +Lemma dvdn_addr m d n : d %| m -> (d %| m + n) = (d %| n). +Proof. by case/dvdnP=> q ->; rewrite /dvdn modnMDl. Qed. + +Lemma dvdn_addl n d m : d %| n -> (d %| m + n) = (d %| m). +Proof. by rewrite addnC; exact: dvdn_addr. Qed. + +Lemma dvdn_add d m n : d %| m -> d %| n -> d %| m + n. +Proof. by move/dvdn_addr->. Qed. + +Lemma dvdn_add_eq d m n : d %| m + n -> (d %| m) = (d %| n). +Proof. by move=> dv_d_mn; apply/idP/idP => [/dvdn_addr | /dvdn_addl] <-. Qed. + +Lemma dvdn_subr d m n : n <= m -> d %| m -> (d %| m - n) = (d %| n). +Proof. by move=> le_n_m dv_d_m; apply: dvdn_add_eq; rewrite subnK. Qed. + +Lemma dvdn_subl d m n : n <= m -> d %| n -> (d %| m - n) = (d %| m). +Proof. by move=> le_n_m dv_d_m; rewrite -(dvdn_addl _ dv_d_m) subnK. Qed. + +Lemma dvdn_sub d m n : d %| m -> d %| n -> d %| m - n. +Proof. +by case: (leqP n m) => [le_nm /dvdn_subr <- // | /ltnW/eqnP ->]; rewrite dvdn0. +Qed. + +Lemma dvdn_exp k d m : 0 < k -> d %| m -> d %| (m ^ k). +Proof. by case: k => // k _ d_dv_m; rewrite expnS dvdn_mulr. Qed. + +Hint Resolve dvdn_add dvdn_sub dvdn_exp. + +Lemma eqn_mod_dvd d m n : n <= m -> (m == n %[mod d]) = (d %| m - n). +Proof. +by move=> le_mn; rewrite -{1}[n]add0n -{1}(subnK le_mn) eqn_modDr mod0n. +Qed. + +Lemma divnDl m n d : d %| m -> (m + n) %/ d = m %/ d + n %/ d. +Proof. by case: d => // d /divnK{1}<-; rewrite divnMDl. Qed. + +Lemma divnDr m n d : d %| n -> (m + n) %/ d = m %/ d + n %/ d. +Proof. by move=> dv_n; rewrite addnC divnDl // addnC. Qed. + +(***********************************************************************) +(* A function that computes the gcd of 2 numbers *) +(***********************************************************************) + +Fixpoint gcdn_rec m n := + let n' := n %% m in if n' is 0 then m else + if m - n'.-1 is m'.+1 then gcdn_rec (m' %% n') n' else n'. + +Definition gcdn := nosimpl gcdn_rec. + +Lemma gcdnE m n : gcdn m n = if m == 0 then n else gcdn (n %% m) m. +Proof. +rewrite /gcdn; elim: m {-2}m (leqnn m) n => [|s IHs] [|m] le_ms [|n] //=. +case def_n': (_ %% _) => // [n']. +have{def_n'} lt_n'm: n' < m by rewrite -def_n' -ltnS ltn_pmod. +rewrite {}IHs ?(leq_trans lt_n'm) // subn_if_gt ltnW //=; congr gcdn_rec. +by rewrite -{2}(subnK (ltnW lt_n'm)) -addnS modnDr. +Qed. + +Lemma gcdnn : idempotent gcdn. +Proof. by case=> // n; rewrite gcdnE modnn. Qed. + +Lemma gcdnC : commutative gcdn. +Proof. +move=> m n; wlog lt_nm: m n / n < m. + by case: (ltngtP n m) => [||-> //]; last symmetry; auto. +by rewrite gcdnE -{1}(ltn_predK lt_nm) modn_small. +Qed. + +Lemma gcd0n : left_id 0 gcdn. Proof. by case. Qed. +Lemma gcdn0 : right_id 0 gcdn. Proof. by case. Qed. + +Lemma gcd1n : left_zero 1 gcdn. +Proof. by move=> n; rewrite gcdnE modn1. Qed. + +Lemma gcdn1 : right_zero 1 gcdn. +Proof. by move=> n; rewrite gcdnC gcd1n. Qed. + +Lemma dvdn_gcdr m n : gcdn m n %| n. +Proof. +elim: m {-2}m (leqnn m) n => [|s IHs] [|m] le_ms [|n] //. +rewrite gcdnE; case def_n': (_ %% _) => [|n']; first by rewrite /dvdn def_n'. +have lt_n's: n' < s by rewrite -ltnS (leq_trans _ le_ms) // -def_n' ltn_pmod. +rewrite /= (divn_eq n.+1 m.+1) def_n' dvdn_addr ?dvdn_mull //; last exact: IHs. +by rewrite gcdnE /= IHs // (leq_trans _ lt_n's) // ltnW // ltn_pmod. +Qed. + +Lemma dvdn_gcdl m n : gcdn m n %| m. +Proof. by rewrite gcdnC dvdn_gcdr. Qed. + +Lemma gcdn_gt0 m n : (0 < gcdn m n) = (0 < m) || (0 < n). +Proof. +by case: m n => [|m] [|n] //; apply: (@dvdn_gt0 _ m.+1) => //; exact: dvdn_gcdl. +Qed. + +Lemma gcdnMDl k m n : gcdn m (k * m + n) = gcdn m n. +Proof. by rewrite !(gcdnE m) modnMDl mulnC; case: m. Qed. + +Lemma gcdnDl m n : gcdn m (m + n) = gcdn m n. +Proof. by rewrite -{2}(mul1n m) gcdnMDl. Qed. + +Lemma gcdnDr m n : gcdn m (n + m) = gcdn m n. +Proof. by rewrite addnC gcdnDl. Qed. + +Lemma gcdnMl n m : gcdn n (m * n) = n. +Proof. by case: n => [|n]; rewrite gcdnE modnMl gcd0n. Qed. + +Lemma gcdnMr n m : gcdn n (n * m) = n. +Proof. by rewrite mulnC gcdnMl. Qed. + +Lemma gcdn_idPl {m n} : reflect (gcdn m n = m) (m %| n). +Proof. +by apply: (iffP idP) => [/dvdnP[q ->] | <-]; rewrite (gcdnMl, dvdn_gcdr). +Qed. + +Lemma gcdn_idPr {m n} : reflect (gcdn m n = n) (n %| m). +Proof. by rewrite gcdnC; apply: gcdn_idPl. Qed. + +Lemma expn_min e m n : e ^ minn m n = gcdn (e ^ m) (e ^ n). +Proof. +rewrite /minn; case: leqP; [rewrite gcdnC | move/ltnW]; + by move/(dvdn_exp2l e)/gcdn_idPl. +Qed. + +Lemma gcdn_modr m n : gcdn m (n %% m) = gcdn m n. +Proof. by rewrite {2}(divn_eq n m) gcdnMDl. Qed. + +Lemma gcdn_modl m n : gcdn (m %% n) n = gcdn m n. +Proof. by rewrite !(gcdnC _ n) gcdn_modr. Qed. + +(* Extended gcd, which computes Bezout coefficients. *) + +Fixpoint Bezout_rec km kn qs := + if qs is q :: qs' then Bezout_rec kn (NatTrec.add_mul q kn km) qs' + else (km, kn). + +Fixpoint egcdn_rec m n s qs := + if s is s'.+1 then + let: (q, r) := edivn m n in + if r > 0 then egcdn_rec n r s' (q :: qs) else + if odd (size qs) then qs else q.-1 :: qs + else [::0]. + +Definition egcdn m n := Bezout_rec 0 1 (egcdn_rec m n n [::]). + +CoInductive egcdn_spec m n : nat * nat -> Type := + EgcdnSpec km kn of km * m = kn * n + gcdn m n & kn * gcdn m n < m : + egcdn_spec m n (km, kn). + +Lemma egcd0n n : egcdn 0 n = (1, 0). +Proof. by case: n. Qed. + +Lemma egcdnP m n : m > 0 -> egcdn_spec m n (egcdn m n). +Proof. +rewrite /egcdn; have: (n, m) = Bezout_rec n m [::] by []. +case: (posnP n) => [-> /=|]; first by split; rewrite // mul1n gcdn0. +move: {2 6}n {4 6}n {1 4}m [::] (ltnSn n) => s n0 m0. +elim: s n m => [[]//|s IHs] n m qs /= le_ns n_gt0 def_mn0 m_gt0. +case: edivnP => q r def_m; rewrite n_gt0 /= => lt_rn. +case: posnP => [r0 {s le_ns IHs lt_rn}|r_gt0]; last first. + by apply: IHs => //=; [rewrite (leq_trans lt_rn) | rewrite natTrecE -def_m]. +rewrite {r}r0 addn0 in def_m; set b := odd _; pose d := gcdn m n. +pose km := ~~ b : nat; pose kn := if b then 1 else q.-1. +rewrite (_ : Bezout_rec _ _ _ = Bezout_rec km kn qs); last first. + by rewrite /kn /km; case: (b) => //=; rewrite natTrecE addn0 muln1. +have def_d: d = n by rewrite /d def_m gcdnC gcdnE modnMl gcd0n -[n]prednK. +have: km * m + 2 * b * d = kn * n + d. + rewrite {}/kn {}/km def_m def_d -mulSnr; case: b; rewrite //= addn0 mul1n. + by rewrite prednK //; apply: dvdn_gt0 m_gt0 _; rewrite def_m dvdn_mulr. +have{def_m}: kn * d <= m. + have q_gt0 : 0 < q by rewrite def_m muln_gt0 n_gt0 ?andbT in m_gt0. + by rewrite /kn; case b; rewrite def_d def_m leq_pmul2r // leq_pred. +have{def_d}: km * d <= n by rewrite -[n]mul1n def_d leq_pmul2r // leq_b1. +move: km {q}kn m_gt0 n_gt0 def_mn0; rewrite {}/d {}/b. +elim: qs m n => [|q qs IHq] n r kn kr n_gt0 r_gt0 /=. + case=> -> -> {m0 n0}; rewrite !addn0 => le_kn_r _ def_d; split=> //. + have d_gt0: 0 < gcdn n r by rewrite gcdn_gt0 n_gt0. + have: 0 < kn * n by rewrite def_d addn_gt0 d_gt0 orbT. + rewrite muln_gt0 n_gt0 andbT; move/ltn_pmul2l <-. + by rewrite def_d -addn1 leq_add // mulnCA leq_mul2l le_kn_r orbT. +rewrite !natTrecE; set m:= _ + r; set km := _ * _ + kn; pose d := gcdn m n. +have ->: gcdn n r = d by rewrite [d]gcdnC gcdnMDl. +have m_gt0: 0 < m by rewrite addn_gt0 r_gt0 orbT. +have d_gt0: 0 < d by rewrite gcdn_gt0 m_gt0. +move/IHq=> {IHq} IHq le_kn_r le_kr_n def_d; apply: IHq => //; rewrite -/d. + by rewrite mulnDl leq_add // -mulnA leq_mul2l le_kr_n orbT. +apply: (@addIn d); rewrite -!addnA addnn addnCA mulnDr -addnA addnCA. +rewrite /km mulnDl mulnCA mulnA -addnA; congr (_ + _). +by rewrite -def_d addnC -addnA -mulnDl -mulnDr addn_negb -mul2n. +Qed. + +Lemma Bezoutl m n : m > 0 -> {a | a < m & m %| gcdn m n + a * n}. +Proof. +move=> m_gt0; case: (egcdnP n m_gt0) => km kn def_d lt_kn_m. +exists kn; last by rewrite addnC -def_d dvdn_mull. +apply: leq_ltn_trans lt_kn_m. +by rewrite -{1}[kn]muln1 leq_mul2l gcdn_gt0 m_gt0 orbT. +Qed. + +Lemma Bezoutr m n : n > 0 -> {a | a < n & n %| gcdn m n + a * m}. +Proof. by rewrite gcdnC; exact: Bezoutl. Qed. + +(* Back to the gcd. *) + +Lemma dvdn_gcd p m n : p %| gcdn m n = (p %| m) && (p %| n). +Proof. +apply/idP/andP=> [dv_pmn | [dv_pm dv_pn]]. + by rewrite !(dvdn_trans dv_pmn) ?dvdn_gcdl ?dvdn_gcdr. +case (posnP n) => [->|n_gt0]; first by rewrite gcdn0. +case: (Bezoutr m n_gt0) => // km _ /(dvdn_trans dv_pn). +by rewrite dvdn_addl // dvdn_mull. +Qed. + +Lemma gcdnAC : right_commutative gcdn. +Proof. +suffices dvd m n p: gcdn (gcdn m n) p %| gcdn (gcdn m p) n. + by move=> m n p; apply/eqP; rewrite eqn_dvd !dvd. +rewrite !dvdn_gcd dvdn_gcdr. +by rewrite !(dvdn_trans (dvdn_gcdl _ p)) ?dvdn_gcdl ?dvdn_gcdr. +Qed. + +Lemma gcdnA : associative gcdn. +Proof. by move=> m n p; rewrite !(gcdnC m) gcdnAC. Qed. + +Lemma gcdnCA : left_commutative gcdn. +Proof. by move=> m n p; rewrite !gcdnA (gcdnC m). Qed. + +Lemma gcdnACA : interchange gcdn gcdn. +Proof. by move=> m n p q; rewrite -!gcdnA (gcdnCA n). Qed. + +Lemma muln_gcdr : right_distributive muln gcdn. +Proof. +move=> p m n; case: (posnP p) => [-> //| p_gt0]. +elim: {m}m.+1 {-2}m n (ltnSn m) => // s IHs m n; rewrite ltnS => le_ms. +rewrite gcdnE [rhs in _ = rhs]gcdnE muln_eq0 (gtn_eqF p_gt0) -muln_modr //=. +by case: posnP => // m_gt0; apply: IHs; apply: leq_trans le_ms; apply: ltn_pmod. +Qed. + +Lemma muln_gcdl : left_distributive muln gcdn. +Proof. by move=> m n p; rewrite -!(mulnC p) muln_gcdr. Qed. + +Lemma gcdn_def d m n : + d %| m -> d %| n -> (forall d', d' %| m -> d' %| n -> d' %| d) -> + gcdn m n = d. +Proof. +move=> dv_dm dv_dn gdv_d; apply/eqP. +by rewrite eqn_dvd dvdn_gcd dv_dm dv_dn gdv_d ?dvdn_gcdl ?dvdn_gcdr. +Qed. + +Lemma muln_divCA_gcd n m : n * (m %/ gcdn n m) = m * (n %/ gcdn n m). +Proof. by rewrite muln_divCA ?dvdn_gcdl ?dvdn_gcdr. Qed. + +(* We derive the lcm directly. *) + +Definition lcmn m n := m * n %/ gcdn m n. + +Lemma lcmnC : commutative lcmn. +Proof. by move=> m n; rewrite /lcmn mulnC gcdnC. Qed. + +Lemma lcm0n : left_zero 0 lcmn. Proof. by move=> n; exact: div0n. Qed. +Lemma lcmn0 : right_zero 0 lcmn. Proof. by move=> n; rewrite lcmnC lcm0n. Qed. + +Lemma lcm1n : left_id 1 lcmn. +Proof. by move=> n; rewrite /lcmn gcd1n mul1n divn1. Qed. + +Lemma lcmn1 : right_id 1 lcmn. +Proof. by move=> n; rewrite lcmnC lcm1n. Qed. + +Lemma muln_lcm_gcd m n : lcmn m n * gcdn m n = m * n. +Proof. by apply/eqP; rewrite divnK ?dvdn_mull ?dvdn_gcdr. Qed. + +Lemma lcmn_gt0 m n : (0 < lcmn m n) = (0 < m) && (0 < n). +Proof. by rewrite -muln_gt0 ltn_divRL ?dvdn_mull ?dvdn_gcdr. Qed. + +Lemma muln_lcmr : right_distributive muln lcmn. +Proof. +case=> // m n p; rewrite /lcmn -muln_gcdr -!mulnA divnMl // mulnCA. +by rewrite muln_divA ?dvdn_mull ?dvdn_gcdr. +Qed. + +Lemma muln_lcml : left_distributive muln lcmn. +Proof. by move=> m n p; rewrite -!(mulnC p) muln_lcmr. Qed. + +Lemma lcmnA : associative lcmn. +Proof. +move=> m n p; rewrite {1 3}/lcmn mulnC !divn_mulAC ?dvdn_mull ?dvdn_gcdr //. +rewrite -!divnMA ?dvdn_mulr ?dvdn_gcdl // mulnC mulnA !muln_gcdr. +by rewrite ![_ * lcmn _ _]mulnC !muln_lcm_gcd !muln_gcdl -!(mulnC m) gcdnA. +Qed. + +Lemma lcmnCA : left_commutative lcmn. +Proof. by move=> m n p; rewrite !lcmnA (lcmnC m). Qed. + +Lemma lcmnAC : right_commutative lcmn. +Proof. by move=> m n p; rewrite -!lcmnA (lcmnC n). Qed. + +Lemma lcmnACA : interchange lcmn lcmn. +Proof. by move=> m n p q; rewrite -!lcmnA (lcmnCA n). Qed. + +Lemma dvdn_lcml d1 d2 : d1 %| lcmn d1 d2. +Proof. by rewrite /lcmn -muln_divA ?dvdn_gcdr ?dvdn_mulr. Qed. + +Lemma dvdn_lcmr d1 d2 : d2 %| lcmn d1 d2. +Proof. by rewrite lcmnC dvdn_lcml. Qed. + +Lemma dvdn_lcm d1 d2 m : lcmn d1 d2 %| m = (d1 %| m) && (d2 %| m). +Proof. +case: d1 d2 => [|d1] [|d2]; try by case: m => [|m]; rewrite ?lcmn0 ?andbF. +rewrite -(@dvdn_pmul2r (gcdn d1.+1 d2.+1)) ?gcdn_gt0 // muln_lcm_gcd. +by rewrite muln_gcdr dvdn_gcd {1}mulnC andbC !dvdn_pmul2r. +Qed. + +Lemma lcmnMl m n : lcmn m (m * n) = m * n. +Proof. by case: m => // m; rewrite /lcmn gcdnMr mulKn. Qed. + +Lemma lcmnMr m n : lcmn n (m * n) = m * n. +Proof. by rewrite mulnC lcmnMl. Qed. + +Lemma lcmn_idPr {m n} : reflect (lcmn m n = n) (m %| n). +Proof. +by apply: (iffP idP) => [/dvdnP[q ->] | <-]; rewrite (lcmnMr, dvdn_lcml). +Qed. + +Lemma lcmn_idPl {m n} : reflect (lcmn m n = m) (n %| m). +Proof. by rewrite lcmnC; apply: lcmn_idPr. Qed. + +Lemma expn_max e m n : e ^ maxn m n = lcmn (e ^ m) (e ^ n). +Proof. +rewrite /maxn; case: leqP; [rewrite lcmnC | move/ltnW]; + by move/(dvdn_exp2l e)/lcmn_idPr. +Qed. + +(* Coprime factors *) + +Definition coprime m n := gcdn m n == 1. + +Lemma coprime1n n : coprime 1 n. +Proof. by rewrite /coprime gcd1n. Qed. + +Lemma coprimen1 n : coprime n 1. +Proof. by rewrite /coprime gcdn1. Qed. + +Lemma coprime_sym m n : coprime m n = coprime n m. +Proof. by rewrite /coprime gcdnC. Qed. + +Lemma coprime_modl m n : coprime (m %% n) n = coprime m n. +Proof. by rewrite /coprime gcdn_modl. Qed. + +Lemma coprime_modr m n : coprime m (n %% m) = coprime m n. +Proof. by rewrite /coprime gcdn_modr. Qed. + +Lemma coprime2n n : coprime 2 n = odd n. +Proof. by rewrite -coprime_modr modn2; case: (odd n). Qed. + +Lemma coprimen2 n : coprime n 2 = odd n. +Proof. by rewrite coprime_sym coprime2n. Qed. + +Lemma coprimeSn n : coprime n.+1 n. +Proof. by rewrite -coprime_modl (modnDr 1) coprime_modl coprime1n. Qed. + +Lemma coprimenS n : coprime n n.+1. +Proof. by rewrite coprime_sym coprimeSn. Qed. + +Lemma coprimePn n : n > 0 -> coprime n.-1 n. +Proof. by case: n => // n _; rewrite coprimenS. Qed. + +Lemma coprimenP n : n > 0 -> coprime n n.-1. +Proof. by case: n => // n _; rewrite coprimeSn. Qed. + +Lemma coprimeP n m : + n > 0 -> reflect (exists u, u.1 * n - u.2 * m = 1) (coprime n m). +Proof. +move=> n_gt0; apply: (iffP eqP) => [<-| [[kn km] /= kn_km_1]]. + by have [kn km kg _] := egcdnP m n_gt0; exists (kn, km); rewrite kg addKn. +apply gcdn_def; rewrite ?dvd1n // => d dv_d_n dv_d_m. +by rewrite -kn_km_1 dvdn_subr ?dvdn_mull // ltnW // -subn_gt0 kn_km_1. +Qed. + +Lemma modn_coprime k n : 0 < k -> (exists u, (k * u) %% n = 1) -> coprime k n. +Proof. +move=> k_gt0 [u Hu]; apply/coprimeP=> //. +by exists (u, k * u %/ n); rewrite /= mulnC {1}(divn_eq (k * u) n) addKn. +Qed. + +Lemma Gauss_dvd m n p : coprime m n -> (m * n %| p) = (m %| p) && (n %| p). +Proof. by move=> co_mn; rewrite -muln_lcm_gcd (eqnP co_mn) muln1 dvdn_lcm. Qed. + +Lemma Gauss_dvdr m n p : coprime m n -> (m %| n * p) = (m %| p). +Proof. +case: n => [|n] co_mn; first by case: m co_mn => [|[]] // _; rewrite !dvd1n. +by symmetry; rewrite mulnC -(@dvdn_pmul2r n.+1) ?Gauss_dvd // andbC dvdn_mull. +Qed. + +Lemma Gauss_dvdl m n p : coprime m p -> (m %| n * p) = (m %| n). +Proof. by rewrite mulnC; apply: Gauss_dvdr. Qed. + +Lemma dvdn_double_leq m n : m %| n -> odd m -> ~~ odd n -> 0 < n -> m.*2 <= n. +Proof. +move=> m_dv_n odd_m even_n n_gt0. +by rewrite -muln2 dvdn_leq // Gauss_dvd ?coprimen2 ?m_dv_n ?dvdn2. +Qed. + +Lemma dvdn_double_ltn m n : m %| n.-1 -> odd m -> odd n -> 1 < n -> m.*2 < n. +Proof. by case: n => //; apply: dvdn_double_leq. Qed. + +Lemma Gauss_gcdr p m n : coprime p m -> gcdn p (m * n) = gcdn p n. +Proof. +move=> co_pm; apply/eqP; rewrite eqn_dvd !dvdn_gcd !dvdn_gcdl /=. +rewrite andbC dvdn_mull ?dvdn_gcdr //= -(@Gauss_dvdr _ m) ?dvdn_gcdr //. +by rewrite /coprime gcdnAC (eqnP co_pm) gcd1n. +Qed. + +Lemma Gauss_gcdl p m n : coprime p n -> gcdn p (m * n) = gcdn p m. +Proof. by move=> co_pn; rewrite mulnC Gauss_gcdr. Qed. + +Lemma coprime_mulr p m n : coprime p (m * n) = coprime p m && coprime p n. +Proof. +case co_pm: (coprime p m) => /=; first by rewrite /coprime Gauss_gcdr. +apply/eqP=> co_p_mn; case/eqnP: co_pm; apply gcdn_def => // d dv_dp dv_dm. +by rewrite -co_p_mn dvdn_gcd dv_dp dvdn_mulr. +Qed. + +Lemma coprime_mull p m n : coprime (m * n) p = coprime m p && coprime n p. +Proof. by rewrite -!(coprime_sym p) coprime_mulr. Qed. + +Lemma coprime_pexpl k m n : 0 < k -> coprime (m ^ k) n = coprime m n. +Proof. +case: k => // k _; elim: k => [|k IHk]; first by rewrite expn1. +by rewrite expnS coprime_mull -IHk; case coprime. +Qed. + +Lemma coprime_pexpr k m n : 0 < k -> coprime m (n ^ k) = coprime m n. +Proof. by move=> k_gt0; rewrite !(coprime_sym m) coprime_pexpl. Qed. + +Lemma coprime_expl k m n : coprime m n -> coprime (m ^ k) n. +Proof. by case: k => [|k] co_pm; rewrite ?coprime1n // coprime_pexpl. Qed. + +Lemma coprime_expr k m n : coprime m n -> coprime m (n ^ k). +Proof. by rewrite !(coprime_sym m); exact: coprime_expl. Qed. + +Lemma coprime_dvdl m n p : m %| n -> coprime n p -> coprime m p. +Proof. by case/dvdnP=> d ->; rewrite coprime_mull => /andP[]. Qed. + +Lemma coprime_dvdr m n p : m %| n -> coprime p n -> coprime p m. +Proof. by rewrite !(coprime_sym p); exact: coprime_dvdl. Qed. + +Lemma coprime_egcdn n m : n > 0 -> coprime (egcdn n m).1 (egcdn n m).2. +Proof. +move=> n_gt0; case: (egcdnP m n_gt0) => kn km /= /eqP. +have [/dvdnP[u defn] /dvdnP[v defm]] := (dvdn_gcdl n m, dvdn_gcdr n m). +rewrite -[gcdn n m]mul1n {1}defm {1}defn !mulnA -mulnDl addnC. +rewrite eqn_pmul2r ?gcdn_gt0 ?n_gt0 //; case: kn => // kn /eqP def_knu _. +by apply/coprimeP=> //; exists (u, v); rewrite mulnC def_knu mulnC addnK. +Qed. + +Lemma dvdn_pexp2r m n k : k > 0 -> (m ^ k %| n ^ k) = (m %| n). +Proof. +move=> k_gt0; apply/idP/idP=> [dv_mn_k|]; last exact: dvdn_exp2r. +case: (posnP n) => [-> | n_gt0]; first by rewrite dvdn0. +have [n' def_n] := dvdnP (dvdn_gcdr m n); set d := gcdn m n in def_n. +have [m' def_m] := dvdnP (dvdn_gcdl m n); rewrite -/d in def_m. +have d_gt0: d > 0 by rewrite gcdn_gt0 n_gt0 orbT. +rewrite def_m def_n !expnMn dvdn_pmul2r ?expn_gt0 ?d_gt0 // in dv_mn_k. +have: coprime (m' ^ k) (n' ^ k). + rewrite coprime_pexpl // coprime_pexpr // /coprime -(eqn_pmul2r d_gt0) mul1n. + by rewrite muln_gcdl -def_m -def_n. +rewrite /coprime -gcdn_modr (eqnP dv_mn_k) gcdn0 -(exp1n k). +by rewrite (inj_eq (expIn k_gt0)) def_m; move/eqP->; rewrite mul1n dvdn_gcdr. +Qed. + +Section Chinese. + +(***********************************************************************) +(* The chinese remainder theorem *) +(***********************************************************************) + +Variables m1 m2 : nat. +Hypothesis co_m12 : coprime m1 m2. + +Lemma chinese_remainder x y : + (x == y %[mod m1 * m2]) = (x == y %[mod m1]) && (x == y %[mod m2]). +Proof. +wlog le_yx : x y / y <= x; last by rewrite !eqn_mod_dvd // Gauss_dvd. +by case/orP: (leq_total y x); last rewrite !(eq_sym (x %% _)); auto. +Qed. + +(***********************************************************************) +(* A function that solves the chinese remainder problem *) +(***********************************************************************) + +Definition chinese r1 r2 := + r1 * m2 * (egcdn m2 m1).1 + r2 * m1 * (egcdn m1 m2).1. + +Lemma chinese_modl r1 r2 : chinese r1 r2 = r1 %[mod m1]. +Proof. +rewrite /chinese; case: (posnP m2) co_m12 => [-> /eqnP | m2_gt0 _]. + by rewrite gcdn0 => ->; rewrite !modn1. +case: egcdnP => // k2 k1 def_m1 _. +rewrite mulnAC -mulnA def_m1 gcdnC (eqnP co_m12) mulnDr mulnA muln1. +by rewrite addnAC (mulnAC _ m1) -mulnDl modnMDl. +Qed. + +Lemma chinese_modr r1 r2 : chinese r1 r2 = r2 %[mod m2]. +Proof. +rewrite /chinese; case: (posnP m1) co_m12 => [-> /eqnP | m1_gt0 _]. + by rewrite gcd0n => ->; rewrite !modn1. +case: (egcdnP m2) => // k1 k2 def_m2 _. +rewrite addnC mulnAC -mulnA def_m2 (eqnP co_m12) mulnDr mulnA muln1. +by rewrite addnAC (mulnAC _ m2) -mulnDl modnMDl. +Qed. + +Lemma chinese_mod x : x = chinese (x %% m1) (x %% m2) %[mod m1 * m2]. +Proof. +apply/eqP; rewrite chinese_remainder //. +by rewrite chinese_modl chinese_modr !modn_mod !eqxx. +Qed. + +End Chinese. diff --git a/mathcomp/discrete/finfun.v b/mathcomp/discrete/finfun.v new file mode 100644 index 0000000..f880260 --- /dev/null +++ b/mathcomp/discrete/finfun.v @@ -0,0 +1,302 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype tuple. + +(******************************************************************************) +(* This file implements a type for functions with a finite domain: *) +(* {ffun aT -> rT} where aT should have a finType structure. *) +(* Any eqType, choiceType, countType and finType structures on rT extend to *) +(* {ffun aT -> rT} as Leibnitz equality and extensional equalities coincide. *) +(* (T ^ n)%type is notation for {ffun 'I_n -> T}, which is isomorphic *) +(* ot n.-tuple T. *) +(* For f : {ffun aT -> rT}, we define *) +(* f x == the image of x under f (f coerces to a CiC function) *) +(* fgraph f == the graph of f, i.e., the #|aT|.-tuple rT of the *) +(* values of f over enum aT. *) +(* finfun lam == the f such that f =1 lam; this is the RECOMMENDED *) +(* interface to build an element of {ffun aT -> rT}. *) +(* [ffun x => expr] == finfun (fun x => expr) *) +(* [ffun => expr] == finfun (fun _ => expr) *) +(* f \in ffun_on R == the range of f is a subset of R *) +(* f \in family F == f belongs to the family F (f x \in F x for all x) *) +(* y.-support f == the y-support of f, i.e., [pred x | f x != y]. *) +(* Thus, y.-support f \subset D means f has y-support D. *) +(* We will put Notation support := 0.-support in ssralg. *) +(* f \in pffun_on y D R == f is a y-partial function from D to R: *) +(* f has y-support D and f x \in R for all x \in D. *) +(* f \in pfamily y D F == f belongs to the y-partial family from D to F: *) +(* f has y-support D and f x \in F x for all x \in D. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section Def. + +Variables (aT : finType) (rT : Type). + +Inductive finfun_type : predArgType := Finfun of #|aT|.-tuple rT. + +Definition finfun_of of phant (aT -> rT) := finfun_type. + +Identity Coercion type_of_finfun : finfun_of >-> finfun_type. + +Definition fgraph f := let: Finfun t := f in t. + +Canonical finfun_subType := Eval hnf in [newType for fgraph]. + +End Def. + +Notation "{ 'ffun' fT }" := (finfun_of (Phant fT)) + (at level 0, format "{ 'ffun' '[hv' fT ']' }") : type_scope. +Definition finexp_domFinType n := ordinal_finType n. +Notation "T ^ n" := (@finfun_of (finexp_domFinType n) T (Phant _)) : type_scope. + +Notation Local fun_of_fin_def := + (fun aT rT f x => tnth (@fgraph aT rT f) (enum_rank x)). + +Notation Local finfun_def := (fun aT rT f => @Finfun aT rT (codom_tuple f)). + +Module Type FunFinfunSig. +Parameter fun_of_fin : forall aT rT, finfun_type aT rT -> aT -> rT. +Parameter finfun : forall (aT : finType) rT, (aT -> rT) -> {ffun aT -> rT}. +Axiom fun_of_finE : fun_of_fin = fun_of_fin_def. +Axiom finfunE : finfun = finfun_def. +End FunFinfunSig. + +Module FunFinfun : FunFinfunSig. +Definition fun_of_fin := fun_of_fin_def. +Definition finfun := finfun_def. +Lemma fun_of_finE : fun_of_fin = fun_of_fin_def. Proof. by []. Qed. +Lemma finfunE : finfun = finfun_def. Proof. by []. Qed. +End FunFinfun. + +Notation fun_of_fin := FunFinfun.fun_of_fin. +Notation finfun := FunFinfun.finfun. +Coercion fun_of_fin : finfun_type >-> Funclass. +Canonical fun_of_fin_unlock := Unlockable FunFinfun.fun_of_finE. +Canonical finfun_unlock := Unlockable FunFinfun.finfunE. + +Notation "[ 'ffun' x : aT => F ]" := (finfun (fun x : aT => F)) + (at level 0, x ident, only parsing) : fun_scope. + +Notation "[ 'ffun' : aT => F ]" := (finfun (fun _ : aT => F)) + (at level 0, only parsing) : fun_scope. + +Notation "[ 'ffun' x => F ]" := [ffun x : _ => F] + (at level 0, x ident, format "[ 'ffun' x => F ]") : fun_scope. + +Notation "[ 'ffun' => F ]" := [ffun : _ => F] + (at level 0, format "[ 'ffun' => F ]") : fun_scope. + +(* Helper for defining notation for function families. *) +Definition fmem aT rT (pT : predType rT) (f : aT -> pT) := [fun x => mem (f x)]. + +(* Lemmas on the correspondance between finfun_type and CiC functions. *) +Section PlainTheory. + +Variables (aT : finType) (rT : Type). +Notation fT := {ffun aT -> rT}. +Implicit Types (f : fT) (R : pred rT). + +Canonical finfun_of_subType := Eval hnf in [subType of fT]. + +Lemma tnth_fgraph f i : tnth (fgraph f) i = f (enum_val i). +Proof. by rewrite [@fun_of_fin]unlock enum_valK. Qed. + +Lemma ffunE (g : aT -> rT) : finfun g =1 g. +Proof. +move=> x; rewrite [@finfun]unlock unlock tnth_map. +by rewrite -[tnth _ _]enum_val_nth enum_rankK. +Qed. + +Lemma fgraph_codom f : fgraph f = codom_tuple f. +Proof. +apply: eq_from_tnth => i; rewrite [@fun_of_fin]unlock tnth_map. +by congr tnth; rewrite -[tnth _ _]enum_val_nth enum_valK. +Qed. + +Lemma codom_ffun f : codom f = val f. +Proof. by rewrite /= fgraph_codom. Qed. + +Lemma ffunP f1 f2 : f1 =1 f2 <-> f1 = f2. +Proof. +split=> [eq_f12 | -> //]; do 2!apply: val_inj => /=. +by rewrite !fgraph_codom /= (eq_codom eq_f12). +Qed. + +Lemma ffunK : cancel (@fun_of_fin aT rT) (@finfun aT rT). +Proof. by move=> f; apply/ffunP/ffunE. Qed. + +Definition family_mem mF := [pred f : fT | [forall x, in_mem (f x) (mF x)]]. + +Lemma familyP (pT : predType rT) (F : aT -> pT) f : + reflect (forall x, f x \in F x) (f \in family_mem (fmem F)). +Proof. exact: forallP. Qed. + +Definition ffun_on_mem mR := family_mem (fun _ => mR). + +Lemma ffun_onP R f : reflect (forall x, f x \in R) (f \in ffun_on_mem (mem R)). +Proof. exact: forallP. Qed. + +End PlainTheory. + +Notation family F := (family_mem (fun_of_simpl (fmem F))). +Notation ffun_on R := (ffun_on_mem _ (mem R)). + +Implicit Arguments familyP [aT rT pT F f]. +Implicit Arguments ffun_onP [aT rT R f]. + +(*****************************************************************************) + +Lemma nth_fgraph_ord T n (x0 : T) (i : 'I_n) f : nth x0 (fgraph f) i = f i. +Proof. +by rewrite -{2}(enum_rankK i) -tnth_fgraph (tnth_nth x0) enum_rank_ord. +Qed. + +Section Support. + +Variables (aT : Type) (rT : eqType). + +Definition support_for y (f : aT -> rT) := [pred x | f x != y]. + +Lemma supportE x y f : (x \in support_for y f) = (f x != y). Proof. by []. Qed. + +End Support. + +Notation "y .-support" := (support_for y) + (at level 2, format "y .-support") : fun_scope. + +Section EqTheory. + +Variables (aT : finType) (rT : eqType). +Notation fT := {ffun aT -> rT}. +Implicit Types (y : rT) (D : pred aT) (R : pred rT) (f : fT). + +Lemma supportP y D g : + reflect (forall x, x \notin D -> g x = y) (y.-support g \subset D). +Proof. +by apply: (iffP subsetP) => Dg x; [apply: contraNeq | apply: contraR] => /Dg->. +Qed. + +Definition finfun_eqMixin := + Eval hnf in [eqMixin of finfun_type aT rT by <:]. +Canonical finfun_eqType := Eval hnf in EqType _ finfun_eqMixin. +Canonical finfun_of_eqType := Eval hnf in [eqType of fT]. + +Definition pfamily_mem y mD (mF : aT -> mem_pred rT) := + family (fun i : aT => if in_mem i mD then pred_of_simpl (mF i) else pred1 y). + +Lemma pfamilyP (pT : predType rT) y D (F : aT -> pT) f : + reflect (y.-support f \subset D /\ {in D, forall x, f x \in F x}) + (f \in pfamily_mem y (mem D) (fmem F)). +Proof. +apply: (iffP familyP) => [/= f_pfam | [/supportP f_supp f_fam] x]. + split=> [|x Ax]; last by have:= f_pfam x; rewrite Ax. + by apply/subsetP=> x; case: ifP (f_pfam x) => //= _ fx0 /negP[]. +by case: ifPn => Ax /=; rewrite inE /= (f_fam, f_supp). +Qed. + +Definition pffun_on_mem y mD mR := pfamily_mem y mD (fun _ => mR). + +Lemma pffun_onP y D R f : + reflect (y.-support f \subset D /\ {subset image f D <= R}) + (f \in pffun_on_mem y (mem D) (mem R)). +Proof. +apply: (iffP (pfamilyP y D (fun _ => R) f)) => [] [-> f_fam]; split=> //. + by move=> _ /imageP[x Ax ->]; exact: f_fam. +by move=> x Ax; apply: f_fam; apply/imageP; exists x. +Qed. + +End EqTheory. +Canonical exp_eqType (T : eqType) n := [eqType of T ^ n]. + +Implicit Arguments supportP [aT rT y D g]. +Notation pfamily y D F := (pfamily_mem y (mem D) (fun_of_simpl (fmem F))). +Notation pffun_on y D R := (pffun_on_mem y (mem D) (mem R)). + +Definition finfun_choiceMixin aT (rT : choiceType) := + [choiceMixin of finfun_type aT rT by <:]. +Canonical finfun_choiceType aT rT := + Eval hnf in ChoiceType _ (finfun_choiceMixin aT rT). +Canonical finfun_of_choiceType (aT : finType) (rT : choiceType) := + Eval hnf in [choiceType of {ffun aT -> rT}]. +Canonical exp_choiceType (T : choiceType) n := [choiceType of T ^ n]. + +Definition finfun_countMixin aT (rT : countType) := + [countMixin of finfun_type aT rT by <:]. +Canonical finfun_countType aT (rT : countType) := + Eval hnf in CountType _ (finfun_countMixin aT rT). +Canonical finfun_of_countType (aT : finType) (rT : countType) := + Eval hnf in [countType of {ffun aT -> rT}]. +Canonical finfun_subCountType aT (rT : countType) := + Eval hnf in [subCountType of finfun_type aT rT]. +Canonical finfun_of_subCountType (aT : finType) (rT : countType) := + Eval hnf in [subCountType of {ffun aT -> rT}]. + +(*****************************************************************************) + +Section FinTheory. + +Variables aT rT : finType. +Notation fT := {ffun aT -> rT}. +Notation ffT := (finfun_type aT rT). +Implicit Types (D : pred aT) (R : pred rT) (F : aT -> pred rT). + +Definition finfun_finMixin := [finMixin of ffT by <:]. +Canonical finfun_finType := Eval hnf in FinType ffT finfun_finMixin. +Canonical finfun_subFinType := Eval hnf in [subFinType of ffT]. +Canonical finfun_of_finType := Eval hnf in [finType of fT for finfun_finType]. +Canonical finfun_of_subFinType := Eval hnf in [subFinType of fT]. + +Lemma card_pfamily y0 D F : + #|pfamily y0 D F| = foldr muln 1 [seq #|F x| | x in D]. +Proof. +rewrite /image_mem; transitivity #|pfamily y0 (enum D) F|. + by apply/eq_card=> f; apply/eq_forallb=> x /=; rewrite mem_enum. +elim: {D}(enum D) (enum_uniq D) => /= [_|x0 s IHs /andP[s'x0 /IHs<-{IHs}]]. + apply: eq_card1 [ffun=> y0] _ _ => f. + apply/familyP/eqP=> [y0_f|-> x]; last by rewrite ffunE inE. + by apply/ffunP=> x; rewrite ffunE (eqP (y0_f x)). +pose g (xf : rT * fT) := finfun [eta xf.2 with x0 |-> xf.1]. +have gK: cancel (fun f : fT => (f x0, g (y0, f))) g. + by move=> f; apply/ffunP=> x; do !rewrite ffunE /=; case: eqP => // ->. +rewrite -cardX -(card_image (can_inj gK)); apply: eq_card => [] [y f] /=. +apply/imageP/andP=> [[f0 /familyP/=Ff0] [{f}-> ->]| [Fy /familyP/=Ff]]. + split; first by have:= Ff0 x0; rewrite /= mem_head. + apply/familyP=> x; have:= Ff0 x; rewrite ffunE inE /=. + by case: eqP => //= -> _; rewrite ifN ?inE. +exists (g (y, f)). + by apply/familyP=> x; have:= Ff x; rewrite ffunE /= inE; case: eqP => // ->. +congr (_, _); last apply/ffunP=> x; do !rewrite ffunE /= ?eqxx //. +by case: eqP => // ->{x}; apply/eqP; have:= Ff x0; rewrite ifN. +Qed. + +Lemma card_family F : #|family F| = foldr muln 1 [seq #|F x| | x : aT]. +Proof. +have [y0 _ | rT0] := pickP rT; first exact: (card_pfamily y0 aT). +rewrite /image_mem; case DaT: (enum aT) => [{rT0}|x0 e] /=; last first. + by rewrite !eq_card0 // => [f | y]; [have:= rT0 (f x0) | have:= rT0 y]. +have{DaT} no_aT P (x : aT) : P by have:= mem_enum aT x; rewrite DaT. +apply: eq_card1 [ffun x => no_aT rT x] _ _ => f. +by apply/familyP/eqP=> _; [apply/ffunP | ] => x; apply: no_aT. +Qed. + +Lemma card_pffun_on y0 D R : #|pffun_on y0 D R| = #|R| ^ #|D|. +Proof. +rewrite (cardE D) card_pfamily /image_mem. +by elim: (enum D) => //= _ e ->; rewrite expnS. +Qed. + +Lemma card_ffun_on R : #|ffun_on R| = #|R| ^ #|aT|. +Proof. +rewrite card_family /image_mem cardT. +by elim: (enum aT) => //= _ e ->; rewrite expnS. +Qed. + +Lemma card_ffun : #|fT| = #|rT| ^ #|aT|. +Proof. by rewrite -card_ffun_on; apply/esym/eq_card=> f; apply/forallP. Qed. + +End FinTheory. +Canonical exp_finType (T : finType) n := [finType of T ^ n]. + diff --git a/mathcomp/discrete/fingraph.v b/mathcomp/discrete/fingraph.v new file mode 100644 index 0000000..403d1ca --- /dev/null +++ b/mathcomp/discrete/fingraph.v @@ -0,0 +1,721 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +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. + diff --git a/mathcomp/discrete/finset.v b/mathcomp/discrete/finset.v new file mode 100644 index 0000000..54dacc0 --- /dev/null +++ b/mathcomp/discrete/finset.v @@ -0,0 +1,2214 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat div seq choice fintype. +Require Import finfun bigop. + +(******************************************************************************) +(* This file defines a type for sets over a finite Type, similar to the type *) +(* of functions over a finite Type defined in finfun.v (indeed, based in it): *) +(* {set T} where T must have a finType structure *) +(* We equip {set T} itself with a finType structure, hence Leibnitz and *) +(* extensional equalities coincide on {set T}, and we can form {set {set T}} *) +(* If A, B : {set T} and P : {set {set T}}, we define: *) +(* x \in A == x belongs to A (i.e., {set T} implements predType, *) +(* by coercion to pred_sort). *) +(* mem A == the predicate corresponding to A. *) +(* finset p == the set corresponding to a predicate p. *) +(* [set x | P] == the set containing the x such that P is true (x may *) +(* appear in P). *) +(* [set x | P & Q] := [set x | P && Q]. *) +(* [set x in A] == the set containing the x in a collective predicate A. *) +(* [set x in A | P] == the set containing the x in A such that P is true. *) +(* [set x in A | P & Q] := [set x in A | P && Q]. *) +(* All these have typed variants [set x : T | P], [set x : T in A], etc. *) +(* set0 == the empty set. *) +(* [set: T] or setT == the full set (the A containing all x : T). *) +(* A :|: B == the union of A and B. *) +(* x |: A == A with the element x added (:= [set x] :| A). *) +(* A :&: B == the intersection of A and B. *) +(* ~: A == the complement of A. *) +(* A :\: B == the difference A minus B. *) +(* A :\ x == A with the element x removed (:= A :\: [set x]). *) +(* \bigcup_ A == the union of all A, for i in (i is bound in *) +(* A, see bigop.v). *) +(* \bigcap_ A == the intersection of all A, for i in . *) +(* cover P == the union of the set of sets P. *) +(* trivIset P <=> the elements of P are pairwise disjoint. *) +(* partition P A <=> P is a partition of A. *) +(* pblock P x == a block of P containing x, or else set0. *) +(* equivalence_partition R D == the partition induced on D by the relation R *) +(* (provided R is an equivalence relation in D). *) +(* preim_partition f D == the partition induced on D by the equivalence *) +(* [rel x y | f x == f y]. *) +(* is_transversal X P D <=> X is a transversal of the partition P of D. *) +(* transversal P D == a transversal of P, provided P is a partition of D. *) +(* transversal_repr x0 X B == a representative of B \in P selected by the *) +(* tranversal X of P, or else x0. *) +(* powerset A == the set of all subset of the set A. *) +(* P ::&: A == those sets in P that are subsets of the set A. *) +(* f @^-1: A == the preimage of the collective predicate A under f. *) +(* f @: A == the image set of the collective predicate A by f. *) +(* f @2:(A, B) == the image set of A x B by the binary function f. *) +(* [set E | x in A] == the set of all the values of the expression E, for x *) +(* drawn from the collective predicate A. *) +(* [set E | x in A & P] == the set of values of E for x drawn from A, such *) +(* that P is true. *) +(* [set E | x in A, y in B] == the set of values of E for x drawn from A and *) +(* and y drawn from B; B may depend on x. *) +(* [set E | x <- A, y <- B & P] == the set of values of E for x drawn from A *) +(* y drawn from B, such that P is trye. *) +(* [set E | x : T] == the set of all values of E, with x in type T. *) +(* [set E | x : T & P] == the set of values of E for x : T s.t. P is true. *) +(* [set E | x : T, y : U in B], [set E | x : T, y : U in B & P], *) +(* [set E | x : T in A, y : U], [set E | x : T in A, y : U & P], *) +(* [set E | x : T, y : U], [set E | x : T, y : U & P] *) +(* == type-ranging versions of the binary comprehensions. *) +(* [set E | x : T in A], [set E | x in A, y], [set E | x, y & P], etc. *) +(* == typed and untyped variants of the comprehensions above. *) +(* The types may be required as type inference processes E *) +(* before considering A or B. Note that type casts in the *) +(* binary comprehension must either be both present or absent *) +(* and that there are no untyped variants for single-type *) +(* comprehension as Coq parsing confuses [x | P] and [E | x]. *) +(* minset p A == A is a minimal set satisfying p. *) +(* maxset p A == A is a maximal set satisfying p. *) +(* We also provide notations A :=: B, A :<>: B, A :==: B, A :!=: B, A :=P: B *) +(* that specialize A = B, A <> B, A == B, etc., to {set _}. This is useful *) +(* for subtypes of {set T}, such as {group T}, that coerce to {set T}. *) +(* We give many lemmas on these operations, on card, and on set inclusion. *) +(* In addition to the standard suffixes described in ssrbool.v, we associate *) +(* the following suffixes to set operations: *) +(* 0 -- the empty set, as in in_set0 : (x \in set0) = false. *) +(* T -- the full set, as in in_setT : x \in [set: T]. *) +(* 1 -- a singleton set, as in in_set1 : (x \in [set a]) = (x == a). *) +(* 2 -- an unordered pair, as in *) +(* in_set2 : (x \in [set a; b]) = (x == a) || (x == b). *) +(* C -- complement, as in setCK : ~: ~: A = A. *) +(* I -- intersection, as in setIid : A :&: A = A. *) +(* U -- union, as in setUid : A :|: A = A. *) +(* D -- difference, as in setDv : A :\: A = set0. *) +(* S -- a subset argument, as in *) +(* setIS: B \subset C -> A :&: B \subset A :&: C *) +(* These suffixes are sometimes preceded with an `s' to distinguish them from *) +(* their basic ssrbool interpretation, e.g., *) +(* card1 : #|pred1 x| = 1 and cards1 : #|[set x]| = 1 *) +(* We also use a trailling `r' to distinguish a right-hand complement from *) +(* commutativity, e.g., *) +(* setIC : A :&: B = B :&: A and setICr : A :&: ~: A = set0. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. +Section SetType. + +Variable T : finType. + +Inductive set_type : predArgType := FinSet of {ffun pred T}. +Definition finfun_of_set A := let: FinSet f := A in f. +Definition set_of of phant T := set_type. +Identity Coercion type_of_set_of : set_of >-> set_type. + +Canonical set_subType := Eval hnf in [newType for finfun_of_set]. +Definition set_eqMixin := Eval hnf in [eqMixin of set_type by <:]. +Canonical set_eqType := Eval hnf in EqType set_type set_eqMixin. +Definition set_choiceMixin := [choiceMixin of set_type by <:]. +Canonical set_choiceType := Eval hnf in ChoiceType set_type set_choiceMixin. +Definition set_countMixin := [countMixin of set_type by <:]. +Canonical set_countType := Eval hnf in CountType set_type set_countMixin. +Canonical set_subCountType := Eval hnf in [subCountType of set_type]. +Definition set_finMixin := [finMixin of set_type by <:]. +Canonical set_finType := Eval hnf in FinType set_type set_finMixin. +Canonical set_subFinType := Eval hnf in [subFinType of set_type]. + +End SetType. + +Delimit Scope set_scope with SET. +Bind Scope set_scope with set_type. +Bind Scope set_scope with set_of. +Open Scope set_scope. +Arguments Scope finfun_of_set [_ set_scope]. + +Notation "{ 'set' T }" := (set_of (Phant T)) + (at level 0, format "{ 'set' T }") : type_scope. + +(* We later define several subtypes that coerce to set; for these it is *) +(* preferable to state equalities at the {set _} level, even when comparing *) +(* subtype values, because the primitive "injection" tactic tends to diverge *) +(* on complex types (e.g., quotient groups). We provide some parse-only *) +(* notation to make this technicality less obstrusive. *) +Notation "A :=: B" := (A = B :> {set _}) + (at level 70, no associativity, only parsing) : set_scope. +Notation "A :<>: B" := (A <> B :> {set _}) + (at level 70, no associativity, only parsing) : set_scope. +Notation "A :==: B" := (A == B :> {set _}) + (at level 70, no associativity, only parsing) : set_scope. +Notation "A :!=: B" := (A != B :> {set _}) + (at level 70, no associativity, only parsing) : set_scope. +Notation "A :=P: B" := (A =P B :> {set _}) + (at level 70, no associativity, only parsing) : set_scope. + +Notation Local finset_def := (fun T P => @FinSet T (finfun P)). + +Notation Local pred_of_set_def := (fun T (A : set_type T) => val A : _ -> _). + +Module Type SetDefSig. +Parameter finset : forall T : finType, pred T -> {set T}. +Parameter pred_of_set : forall T, set_type T -> fin_pred_sort (predPredType T). +(* The weird type of pred_of_set is imposed by the syntactic restrictions on *) +(* coercion declarations; it is unfortunately not possible to use a functor *) +(* to retype the declaration, because this triggers an ugly bug in the Coq *) +(* coercion chaining code. *) +Axiom finsetE : finset = finset_def. +Axiom pred_of_setE : pred_of_set = pred_of_set_def. +End SetDefSig. + +Module SetDef : SetDefSig. +Definition finset := finset_def. +Definition pred_of_set := pred_of_set_def. +Lemma finsetE : finset = finset_def. Proof. by []. Qed. +Lemma pred_of_setE : pred_of_set = pred_of_set_def. Proof. by []. Qed. +End SetDef. + +Notation finset := SetDef.finset. +Notation pred_of_set := SetDef.pred_of_set. +Canonical finset_unlock := Unlockable SetDef.finsetE. +Canonical pred_of_set_unlock := Unlockable SetDef.pred_of_setE. + +Notation "[ 'set' x : T | P ]" := (finset (fun x : T => P%B)) + (at level 0, x at level 99, only parsing) : set_scope. +Notation "[ 'set' x | P ]" := [set x : _ | P] + (at level 0, x, P at level 99, format "[ 'set' x | P ]") : set_scope. +Notation "[ 'set' x 'in' A ]" := [set x | x \in A] + (at level 0, x at level 99, format "[ 'set' x 'in' A ]") : set_scope. +Notation "[ 'set' x : T 'in' A ]" := [set x : T | x \in A] + (at level 0, x at level 99, only parsing) : set_scope. +Notation "[ 'set' x : T | P & Q ]" := [set x : T | P && Q] + (at level 0, x at level 99, only parsing) : set_scope. +Notation "[ 'set' x | P & Q ]" := [set x | P && Q ] + (at level 0, x, P at level 99, format "[ 'set' x | P & Q ]") : set_scope. +Notation "[ 'set' x : T 'in' A | P ]" := [set x : T | x \in A & P] + (at level 0, x at level 99, only parsing) : set_scope. +Notation "[ 'set' x 'in' A | P ]" := [set x | x \in A & P] + (at level 0, x at level 99, format "[ 'set' x 'in' A | P ]") : set_scope. +Notation "[ 'set' x 'in' A | P & Q ]" := [set x in A | P && Q] + (at level 0, x at level 99, + format "[ 'set' x 'in' A | P & Q ]") : set_scope. +Notation "[ 'set' x : T 'in' A | P & Q ]" := [set x : T in A | P && Q] + (at level 0, x at level 99, only parsing) : set_scope. + +(* This lets us use set and subtypes of set, like group or coset_of, both as *) +(* collective predicates and as arguments of the \pi(_) notation. *) +Coercion pred_of_set: set_type >-> fin_pred_sort. + +(* Declare pred_of_set as a canonical instance of topred, but use the *) +(* coercion to resolve mem A to @mem (predPredType T) (pred_of_set A). *) +Canonical set_predType T := + Eval hnf in @mkPredType _ (unkeyed (set_type T)) (@pred_of_set T). + +Section BasicSetTheory. + +Variable T : finType. +Implicit Types (x : T) (A B : {set T}) (pA : pred T). + +Canonical set_of_subType := Eval hnf in [subType of {set T}]. +Canonical set_of_eqType := Eval hnf in [eqType of {set T}]. +Canonical set_of_choiceType := Eval hnf in [choiceType of {set T}]. +Canonical set_of_countType := Eval hnf in [countType of {set T}]. +Canonical set_of_subCountType := Eval hnf in [subCountType of {set T}]. +Canonical set_of_finType := Eval hnf in [finType of {set T}]. +Canonical set_of_subFinType := Eval hnf in [subFinType of {set T}]. + +Lemma in_set pA x : x \in finset pA = pA x. +Proof. by rewrite [@finset]unlock unlock [x \in _]ffunE. Qed. + +Lemma setP A B : A =i B <-> A = B. +Proof. +by split=> [eqAB|-> //]; apply/val_inj/ffunP=> x; have:= eqAB x; rewrite unlock. +Qed. + +Definition set0 := [set x : T | false]. +Definition setTfor (phT : phant T) := [set x : T | true]. + +Lemma in_setT x : x \in setTfor (Phant T). +Proof. by rewrite in_set. Qed. + +Lemma eqsVneq A B : {A = B} + {A != B}. +Proof. exact: eqVneq. Qed. + +End BasicSetTheory. + +Definition inE := (in_set, inE). + +Implicit Arguments set0 [T]. +Prenex Implicits set0. +Hint Resolve in_setT. + +Notation "[ 'set' : T ]" := (setTfor (Phant T)) + (at level 0, format "[ 'set' : T ]") : set_scope. + +Notation setT := [set: _] (only parsing). + +Section setOpsDefs. + +Variable T : finType. +Implicit Types (a x : T) (A B D : {set T}) (P : {set {set T}}). + +Definition set1 a := [set x | x == a]. +Definition setU A B := [set x | (x \in A) || (x \in B)]. +Definition setI A B := [set x in A | x \in B]. +Definition setC A := [set x | x \notin A]. +Definition setD A B := [set x | x \notin B & x \in A]. +Definition ssetI P D := [set A in P | A \subset D]. +Definition powerset D := [set A : {set T} | A \subset D]. + +End setOpsDefs. + +Notation "[ 'set' a ]" := (set1 a) + (at level 0, a at level 99, format "[ 'set' a ]") : set_scope. +Notation "[ 'set' a : T ]" := [set (a : T)] + (at level 0, a at level 99, format "[ 'set' a : T ]") : set_scope. +Notation "A :|: B" := (setU A B) : set_scope. +Notation "a |: A" := ([set a] :|: A) : set_scope. +(* This is left-associative due to historical limitations of the .. Notation. *) +Notation "[ 'set' a1 ; a2 ; .. ; an ]" := (setU .. (a1 |: [set a2]) .. [set an]) + (at level 0, a1 at level 99, + format "[ 'set' a1 ; a2 ; .. ; an ]") : set_scope. +Notation "A :&: B" := (setI A B) : set_scope. +Notation "~: A" := (setC A) (at level 35, right associativity) : set_scope. +Notation "[ 'set' ~ a ]" := (~: [set a]) + (at level 0, format "[ 'set' ~ a ]") : set_scope. +Notation "A :\: B" := (setD A B) : set_scope. +Notation "A :\ a" := (A :\: [set a]) : set_scope. +Notation "P ::&: D" := (ssetI P D) (at level 48) : set_scope. + +Section setOps. + +Variable T : finType. +Implicit Types (a x : T) (A B C D : {set T}) (pA pB pC : pred T). + +Lemma eqEsubset A B : (A == B) = (A \subset B) && (B \subset A). +Proof. by apply/eqP/subset_eqP=> /setP. Qed. + +Lemma subEproper A B : A \subset B = (A == B) || (A \proper B). +Proof. by rewrite eqEsubset -andb_orr orbN andbT. Qed. + +Lemma eqVproper A B : A \subset B -> A = B \/ A \proper B. +Proof. by rewrite subEproper => /predU1P. Qed. + +Lemma properEneq A B : A \proper B = (A != B) && (A \subset B). +Proof. by rewrite andbC eqEsubset negb_and andb_orr andbN. Qed. + +Lemma proper_neq A B : A \proper B -> A != B. +Proof. by rewrite properEneq; case/andP. Qed. + +Lemma eqEproper A B : (A == B) = (A \subset B) && ~~ (A \proper B). +Proof. by rewrite negb_and negbK andb_orr andbN eqEsubset. Qed. + +Lemma eqEcard A B : (A == B) = (A \subset B) && (#|B| <= #|A|). +Proof. +rewrite eqEsubset; apply: andb_id2l => sAB. +by rewrite (geq_leqif (subset_leqif_card sAB)). +Qed. + +Lemma properEcard A B : (A \proper B) = (A \subset B) && (#|A| < #|B|). +Proof. by rewrite properEneq ltnNge andbC eqEcard; case: (A \subset B). Qed. + +Lemma subset_leqif_cards A B : A \subset B -> (#|A| <= #|B| ?= iff (A == B)). +Proof. by move=> sAB; rewrite eqEsubset sAB; exact: subset_leqif_card. Qed. + +Lemma in_set0 x : x \in set0 = false. +Proof. by rewrite inE. Qed. + +Lemma sub0set A : set0 \subset A. +Proof. by apply/subsetP=> x; rewrite inE. Qed. + +Lemma subset0 A : (A \subset set0) = (A == set0). +Proof. by rewrite eqEsubset sub0set andbT. Qed. + +Lemma proper0 A : (set0 \proper A) = (A != set0). +Proof. by rewrite properE sub0set subset0. Qed. + +Lemma subset_neq0 A B : A \subset B -> A != set0 -> B != set0. +Proof. by rewrite -!proper0 => sAB /proper_sub_trans->. Qed. + +Lemma set_0Vmem A : (A = set0) + {x : T | x \in A}. +Proof. +case: (pickP (mem A)) => [x Ax | A0]; [by right; exists x | left]. +apply/setP=> x; rewrite inE; exact: A0. +Qed. + +Lemma enum_set0 : enum set0 = [::] :> seq T. +Proof. by rewrite (eq_enum (in_set _)) enum0. Qed. + +Lemma subsetT A : A \subset setT. +Proof. by apply/subsetP=> x; rewrite inE. Qed. + +Lemma subsetT_hint mA : subset mA (mem [set: T]). +Proof. by rewrite unlock; apply/pred0P=> x; rewrite !inE. Qed. +Hint Resolve subsetT_hint. + +Lemma subTset A : (setT \subset A) = (A == setT). +Proof. by rewrite eqEsubset subsetT. Qed. + +Lemma properT A : (A \proper setT) = (A != setT). +Proof. by rewrite properEneq subsetT andbT. Qed. + +Lemma set1P x a : reflect (x = a) (x \in [set a]). +Proof. by rewrite inE; exact: eqP. Qed. + +Lemma enum_setT : enum [set: T] = Finite.enum T. +Proof. by rewrite (eq_enum (in_set _)) enumT. Qed. + +Lemma in_set1 x a : (x \in [set a]) = (x == a). +Proof. exact: in_set. Qed. + +Lemma set11 x : x \in [set x]. +Proof. by rewrite inE. Qed. + +Lemma set1_inj : injective (@set1 T). +Proof. by move=> a b eqsab; apply/set1P; rewrite -eqsab set11. Qed. + +Lemma enum_set1 a : enum [set a] = [:: a]. +Proof. by rewrite (eq_enum (in_set _)) enum1. Qed. + +Lemma setU1P x a B : reflect (x = a \/ x \in B) (x \in a |: B). +Proof. by rewrite !inE; exact: predU1P. Qed. + +Lemma in_setU1 x a B : (x \in a |: B) = (x == a) || (x \in B). +Proof. by rewrite !inE. Qed. + +Lemma set_cons a s : [set x in a :: s] = a |: [set x in s]. +Proof. by apply/setP=> x; rewrite !inE. Qed. + +Lemma setU11 x B : x \in x |: B. +Proof. by rewrite !inE eqxx. Qed. + +Lemma setU1r x a B : x \in B -> x \in a |: B. +Proof. by move=> Bx; rewrite !inE predU1r. Qed. + +(* We need separate lemmas for the explicit enumerations since they *) +(* associate on the left. *) +Lemma set1Ul x A b : x \in A -> x \in A :|: [set b]. +Proof. by move=> Ax; rewrite !inE Ax. Qed. + +Lemma set1Ur A b : b \in A :|: [set b]. +Proof. by rewrite !inE eqxx orbT. Qed. + +Lemma in_setC1 x a : (x \in [set~ a]) = (x != a). +Proof. by rewrite !inE. Qed. + +Lemma setC11 x : (x \in [set~ x]) = false. +Proof. by rewrite !inE eqxx. Qed. + +Lemma setD1P x A b : reflect (x != b /\ x \in A) (x \in A :\ b). +Proof. rewrite !inE; exact: andP. Qed. + +Lemma in_setD1 x A b : (x \in A :\ b) = (x != b) && (x \in A) . +Proof. by rewrite !inE. Qed. + +Lemma setD11 b A : (b \in A :\ b) = false. +Proof. by rewrite !inE eqxx. Qed. + +Lemma setD1K a A : a \in A -> a |: (A :\ a) = A. +Proof. by move=> Aa; apply/setP=> x; rewrite !inE; case: eqP => // ->. Qed. + +Lemma setU1K a B : a \notin B -> (a |: B) :\ a = B. +Proof. +by move/negPf=> nBa; apply/setP=> x; rewrite !inE; case: eqP => // ->. +Qed. + +Lemma set2P x a b : reflect (x = a \/ x = b) (x \in [set a; b]). +Proof. rewrite !inE; exact: pred2P. Qed. + +Lemma in_set2 x a b : (x \in [set a; b]) = (x == a) || (x == b). +Proof. by rewrite !inE. Qed. + +Lemma set21 a b : a \in [set a; b]. +Proof. by rewrite !inE eqxx. Qed. + +Lemma set22 a b : b \in [set a; b]. +Proof. by rewrite !inE eqxx orbT. Qed. + +Lemma setUP x A B : reflect (x \in A \/ x \in B) (x \in A :|: B). +Proof. by rewrite !inE; exact: orP. Qed. + +Lemma in_setU x A B : (x \in A :|: B) = (x \in A) || (x \in B). +Proof. exact: in_set. Qed. + +Lemma setUC A B : A :|: B = B :|: A. +Proof. by apply/setP => x; rewrite !inE orbC. Qed. + +Lemma setUS A B C : A \subset B -> C :|: A \subset C :|: B. +Proof. +move=> sAB; apply/subsetP=> x; rewrite !inE. +by case: (x \in C) => //; exact: (subsetP sAB). +Qed. + +Lemma setSU A B C : A \subset B -> A :|: C \subset B :|: C. +Proof. by move=> sAB; rewrite -!(setUC C) setUS. Qed. + +Lemma setUSS A B C D : A \subset C -> B \subset D -> A :|: B \subset C :|: D. +Proof. by move=> /(setSU B) /subset_trans sAC /(setUS C)/sAC. Qed. + +Lemma set0U A : set0 :|: A = A. +Proof. by apply/setP => x; rewrite !inE orFb. Qed. + +Lemma setU0 A : A :|: set0 = A. +Proof. by rewrite setUC set0U. Qed. + +Lemma setUA A B C : A :|: (B :|: C) = A :|: B :|: C. +Proof. by apply/setP => x; rewrite !inE orbA. Qed. + +Lemma setUCA A B C : A :|: (B :|: C) = B :|: (A :|: C). +Proof. by rewrite !setUA (setUC B). Qed. + +Lemma setUAC A B C : A :|: B :|: C = A :|: C :|: B. +Proof. by rewrite -!setUA (setUC B). Qed. + +Lemma setUACA A B C D : (A :|: B) :|: (C :|: D) = (A :|: C) :|: (B :|: D). +Proof. by rewrite -!setUA (setUCA B). Qed. + +Lemma setTU A : setT :|: A = setT. +Proof. by apply/setP => x; rewrite !inE orTb. Qed. + +Lemma setUT A : A :|: setT = setT. +Proof. by rewrite setUC setTU. Qed. + +Lemma setUid A : A :|: A = A. +Proof. by apply/setP=> x; rewrite inE orbb. Qed. + +Lemma setUUl A B C : A :|: B :|: C = (A :|: C) :|: (B :|: C). +Proof. by rewrite setUA !(setUAC _ C) -(setUA _ C) setUid. Qed. + +Lemma setUUr A B C : A :|: (B :|: C) = (A :|: B) :|: (A :|: C). +Proof. by rewrite !(setUC A) setUUl. Qed. + +(* intersection *) + +(* setIdP is a generalisation of setIP that applies to comprehensions. *) +Lemma setIdP x pA pB : reflect (pA x /\ pB x) (x \in [set y | pA y & pB y]). +Proof. by rewrite !inE; exact: andP. Qed. + +Lemma setId2P x pA pB pC : + reflect [/\ pA x, pB x & pC x] (x \in [set y | pA y & pB y && pC y]). +Proof. by rewrite !inE; exact: and3P. Qed. + +Lemma setIdE A pB : [set x in A | pB x] = A :&: [set x | pB x]. +Proof. by apply/setP=> x; rewrite !inE. Qed. + +Lemma setIP x A B : reflect (x \in A /\ x \in B) (x \in A :&: B). +Proof. exact: (iffP (@setIdP _ _ _)). Qed. + +Lemma in_setI x A B : (x \in A :&: B) = (x \in A) && (x \in B). +Proof. exact: in_set. Qed. + +Lemma setIC A B : A :&: B = B :&: A. +Proof. by apply/setP => x; rewrite !inE andbC. Qed. + +Lemma setIS A B C : A \subset B -> C :&: A \subset C :&: B. +Proof. +move=> sAB; apply/subsetP=> x; rewrite !inE. +by case: (x \in C) => //; exact: (subsetP sAB). +Qed. + +Lemma setSI A B C : A \subset B -> A :&: C \subset B :&: C. +Proof. by move=> sAB; rewrite -!(setIC C) setIS. Qed. + +Lemma setISS A B C D : A \subset C -> B \subset D -> A :&: B \subset C :&: D. +Proof. by move=> /(setSI B) /subset_trans sAC /(setIS C) /sAC. Qed. + +Lemma setTI A : setT :&: A = A. +Proof. by apply/setP => x; rewrite !inE andTb. Qed. + +Lemma setIT A : A :&: setT = A. +Proof. by rewrite setIC setTI. Qed. + +Lemma set0I A : set0 :&: A = set0. +Proof. by apply/setP => x; rewrite !inE andFb. Qed. + +Lemma setI0 A : A :&: set0 = set0. + +Proof. by rewrite setIC set0I. Qed. + +Lemma setIA A B C : A :&: (B :&: C) = A :&: B :&: C. +Proof. by apply/setP=> x; rewrite !inE andbA. Qed. + +Lemma setICA A B C : A :&: (B :&: C) = B :&: (A :&: C). +Proof. by rewrite !setIA (setIC A). Qed. + +Lemma setIAC A B C : A :&: B :&: C = A :&: C :&: B. +Proof. by rewrite -!setIA (setIC B). Qed. + +Lemma setIACA A B C D : (A :&: B) :&: (C :&: D) = (A :&: C) :&: (B :&: D). +Proof. by rewrite -!setIA (setICA B). Qed. + +Lemma setIid A : A :&: A = A. +Proof. by apply/setP=> x; rewrite inE andbb. Qed. + +Lemma setIIl A B C : A :&: B :&: C = (A :&: C) :&: (B :&: C). +Proof. by rewrite setIA !(setIAC _ C) -(setIA _ C) setIid. Qed. + +Lemma setIIr A B C : A :&: (B :&: C) = (A :&: B) :&: (A :&: C). +Proof. by rewrite !(setIC A) setIIl. Qed. + +(* distribute /cancel *) + +Lemma setIUr A B C : A :&: (B :|: C) = (A :&: B) :|: (A :&: C). +Proof. by apply/setP=> x; rewrite !inE andb_orr. Qed. + +Lemma setIUl A B C : (A :|: B) :&: C = (A :&: C) :|: (B :&: C). +Proof. by apply/setP=> x; rewrite !inE andb_orl. Qed. + +Lemma setUIr A B C : A :|: (B :&: C) = (A :|: B) :&: (A :|: C). +Proof. by apply/setP=> x; rewrite !inE orb_andr. Qed. + +Lemma setUIl A B C : (A :&: B) :|: C = (A :|: C) :&: (B :|: C). +Proof. by apply/setP=> x; rewrite !inE orb_andl. Qed. + +Lemma setUK A B : (A :|: B) :&: A = A. +Proof. by apply/setP=> x; rewrite !inE orbK. Qed. + +Lemma setKU A B : A :&: (B :|: A) = A. +Proof. by apply/setP=> x; rewrite !inE orKb. Qed. + +Lemma setIK A B : (A :&: B) :|: A = A. +Proof. by apply/setP=> x; rewrite !inE andbK. Qed. + +Lemma setKI A B : A :|: (B :&: A) = A. +Proof. by apply/setP=> x; rewrite !inE andKb. Qed. + +(* complement *) + +Lemma setCP x A : reflect (~ x \in A) (x \in ~: A). +Proof. by rewrite !inE; exact: negP. Qed. + +Lemma in_setC x A : (x \in ~: A) = (x \notin A). +Proof. exact: in_set. Qed. + +Lemma setCK : involutive (@setC T). +Proof. by move=> A; apply/setP=> x; rewrite !inE negbK. Qed. + +Lemma setC_inj : injective (@setC T). +Proof. exact: can_inj setCK. Qed. + +Lemma subsets_disjoint A B : (A \subset B) = [disjoint A & ~: B]. +Proof. by rewrite subset_disjoint; apply: eq_disjoint_r => x; rewrite !inE. Qed. + +Lemma disjoints_subset A B : [disjoint A & B] = (A \subset ~: B). +Proof. by rewrite subsets_disjoint setCK. Qed. + +Lemma powersetCE A B : (A \in powerset (~: B)) = [disjoint A & B]. +Proof. by rewrite inE disjoints_subset. Qed. + +Lemma setCS A B : (~: A \subset ~: B) = (B \subset A). +Proof. by rewrite !subsets_disjoint setCK disjoint_sym. Qed. + +Lemma setCU A B : ~: (A :|: B) = ~: A :&: ~: B. +Proof. by apply/setP=> x; rewrite !inE negb_or. Qed. + +Lemma setCI A B : ~: (A :&: B) = ~: A :|: ~: B. +Proof. by apply/setP=> x; rewrite !inE negb_and. Qed. + +Lemma setUCr A : A :|: ~: A = setT. +Proof. by apply/setP=> x; rewrite !inE orbN. Qed. + +Lemma setICr A : A :&: ~: A = set0. +Proof. by apply/setP=> x; rewrite !inE andbN. Qed. + +Lemma setC0 : ~: set0 = [set: T]. +Proof. by apply/setP=> x; rewrite !inE. Qed. + +Lemma setCT : ~: [set: T] = set0. +Proof. by rewrite -setC0 setCK. Qed. + +(* difference *) + +Lemma setDP A B x : reflect (x \in A /\ x \notin B) (x \in A :\: B). +Proof. by rewrite inE andbC; exact: andP. Qed. + +Lemma in_setD A B x : (x \in A :\: B) = (x \notin B) && (x \in A). +Proof. exact: in_set. Qed. + +Lemma setDE A B : A :\: B = A :&: ~: B. +Proof. by apply/setP => x; rewrite !inE andbC. Qed. + +Lemma setSD A B C : A \subset B -> A :\: C \subset B :\: C. +Proof. by rewrite !setDE; exact: setSI. Qed. + +Lemma setDS A B C : A \subset B -> C :\: B \subset C :\: A. +Proof. by rewrite !setDE -setCS; exact: setIS. Qed. + +Lemma setDSS A B C D : A \subset C -> D \subset B -> A :\: B \subset C :\: D. +Proof. by move=> /(setSD B) /subset_trans sAC /(setDS C) /sAC. Qed. + +Lemma setD0 A : A :\: set0 = A. +Proof. by apply/setP=> x; rewrite !inE. Qed. + +Lemma set0D A : set0 :\: A = set0. +Proof. by apply/setP=> x; rewrite !inE andbF. Qed. + +Lemma setDT A : A :\: setT = set0. +Proof. by apply/setP=> x; rewrite !inE. Qed. + +Lemma setTD A : setT :\: A = ~: A. +Proof. by apply/setP=> x; rewrite !inE andbT. Qed. + +Lemma setDv A : A :\: A = set0. +Proof. by apply/setP=> x; rewrite !inE andNb. Qed. + +Lemma setCD A B : ~: (A :\: B) = ~: A :|: B. +Proof. by rewrite !setDE setCI setCK. Qed. + +Lemma setID A B : A :&: B :|: A :\: B = A. +Proof. by rewrite setDE -setIUr setUCr setIT. Qed. + +Lemma setDUl A B C : (A :|: B) :\: C = (A :\: C) :|: (B :\: C). +Proof. by rewrite !setDE setIUl. Qed. + +Lemma setDUr A B C : A :\: (B :|: C) = (A :\: B) :&: (A :\: C). +Proof. by rewrite !setDE setCU setIIr. Qed. + +Lemma setDIl A B C : (A :&: B) :\: C = (A :\: C) :&: (B :\: C). +Proof. by rewrite !setDE setIIl. Qed. + +Lemma setIDA A B C : A :&: (B :\: C) = (A :&: B) :\: C. +Proof. by rewrite !setDE setIA. Qed. + +Lemma setIDAC A B C : (A :\: B) :&: C = (A :&: C) :\: B. +Proof. by rewrite !setDE setIAC. Qed. + +Lemma setDIr A B C : A :\: (B :&: C) = (A :\: B) :|: (A :\: C). +Proof. by rewrite !setDE setCI setIUr. Qed. + +Lemma setDDl A B C : (A :\: B) :\: C = A :\: (B :|: C). +Proof. by rewrite !setDE setCU setIA. Qed. + +Lemma setDDr A B C : A :\: (B :\: C) = (A :\: B) :|: (A :&: C). +Proof. by rewrite !setDE setCI setIUr setCK. Qed. + +(* powerset *) + +Lemma powersetE A B : (A \in powerset B) = (A \subset B). +Proof. by rewrite inE. Qed. + +Lemma powersetS A B : (powerset A \subset powerset B) = (A \subset B). +Proof. +apply/subsetP/idP=> [sAB | sAB C]; last by rewrite !inE => /subset_trans ->. +by rewrite -powersetE sAB // inE. +Qed. + +Lemma powerset0 : powerset set0 = [set set0] :> {set {set T}}. +Proof. by apply/setP=> A; rewrite !inE subset0. Qed. + +Lemma powersetT : powerset [set: T] = [set: {set T}]. +Proof. by apply/setP=> A; rewrite !inE subsetT. Qed. + +Lemma setI_powerset P A : P :&: powerset A = P ::&: A. +Proof. by apply/setP=> B; rewrite !inE. Qed. + +(* cardinal lemmas for sets *) + +Lemma cardsE pA : #|[set x in pA]| = #|pA|. +Proof. by apply: eq_card; exact: in_set. Qed. + +Lemma sum1dep_card pA : \sum_(x | pA x) 1 = #|[set x | pA x]|. +Proof. by rewrite sum1_card cardsE. Qed. + +Lemma sum_nat_dep_const pA n : \sum_(x | pA x) n = #|[set x | pA x]| * n. +Proof. by rewrite sum_nat_const cardsE. Qed. + +Lemma cards0 : #|@set0 T| = 0. +Proof. by rewrite cardsE card0. Qed. + +Lemma cards_eq0 A : (#|A| == 0) = (A == set0). +Proof. by rewrite (eq_sym A) eqEcard sub0set cards0 leqn0. Qed. + +Lemma set0Pn A : reflect (exists x, x \in A) (A != set0). +Proof. by rewrite -cards_eq0; exact: existsP. Qed. + +Lemma card_gt0 A : (0 < #|A|) = (A != set0). +Proof. by rewrite lt0n cards_eq0. Qed. + +Lemma cards0_eq A : #|A| = 0 -> A = set0. +Proof. by move=> A_0; apply/setP=> x; rewrite inE (card0_eq A_0). Qed. + +Lemma cards1 x : #|[set x]| = 1. +Proof. by rewrite cardsE card1. Qed. + +Lemma cardsUI A B : #|A :|: B| + #|A :&: B| = #|A| + #|B|. +Proof. by rewrite !cardsE cardUI. Qed. + +Lemma cardsU A B : #|A :|: B| = (#|A| + #|B| - #|A :&: B|)%N. +Proof. by rewrite -cardsUI addnK. Qed. + +Lemma cardsI A B : #|A :&: B| = (#|A| + #|B| - #|A :|: B|)%N. +Proof. by rewrite -cardsUI addKn. Qed. + +Lemma cardsT : #|[set: T]| = #|T|. +Proof. by rewrite cardsE. Qed. + +Lemma cardsID B A : #|A :&: B| + #|A :\: B| = #|A|. +Proof. by rewrite !cardsE cardID. Qed. + +Lemma cardsD A B : #|A :\: B| = (#|A| - #|A :&: B|)%N. +Proof. by rewrite -(cardsID B A) addKn. Qed. + +Lemma cardsC A : #|A| + #|~: A| = #|T|. +Proof. by rewrite cardsE cardC. Qed. + +Lemma cardsCs A : #|A| = #|T| - #|~: A|. +Proof. by rewrite -(cardsC A) addnK. Qed. + +Lemma cardsU1 a A : #|a |: A| = (a \notin A) + #|A|. +Proof. by rewrite -cardU1; apply: eq_card=> x; rewrite !inE. Qed. + +Lemma cards2 a b : #|[set a; b]| = (a != b).+1. +Proof. by rewrite -card2; apply: eq_card=> x; rewrite !inE. Qed. + +Lemma cardsC1 a : #|[set~ a]| = #|T|.-1. +Proof. by rewrite -(cardC1 a); apply: eq_card=> x; rewrite !inE. Qed. + +Lemma cardsD1 a A : #|A| = (a \in A) + #|A :\ a|. +Proof. +by rewrite (cardD1 a); congr (_ + _); apply: eq_card => x; rewrite !inE. +Qed. + +(* other inclusions *) + +Lemma subsetIl A B : A :&: B \subset A. +Proof. by apply/subsetP=> x; rewrite inE; case/andP. Qed. + +Lemma subsetIr A B : A :&: B \subset B. +Proof. by apply/subsetP=> x; rewrite inE; case/andP. Qed. + +Lemma subsetUl A B : A \subset A :|: B. +Proof. by apply/subsetP=> x; rewrite inE => ->. Qed. + +Lemma subsetUr A B : B \subset A :|: B. +Proof. by apply/subsetP=> x; rewrite inE orbC => ->. Qed. + +Lemma subsetU1 x A : A \subset x |: A. +Proof. exact: subsetUr. Qed. + +Lemma subsetDl A B : A :\: B \subset A. +Proof. by rewrite setDE subsetIl. Qed. + +Lemma subD1set A x : A :\ x \subset A. +Proof. by rewrite subsetDl. Qed. + +Lemma subsetDr A B : A :\: B \subset ~: B. +Proof. by rewrite setDE subsetIr. Qed. + +Lemma sub1set A x : ([set x] \subset A) = (x \in A). +Proof. by rewrite -subset_pred1; apply: eq_subset=> y; rewrite !inE. Qed. + +Lemma cards1P A : reflect (exists x, A = [set x]) (#|A| == 1). +Proof. +apply: (iffP idP) => [|[x ->]]; last by rewrite cards1. +rewrite eq_sym eqn_leq card_gt0 => /andP[/set0Pn[x Ax] leA1]. +by exists x; apply/eqP; rewrite eq_sym eqEcard sub1set Ax cards1 leA1. +Qed. + +Lemma subset1 A x : (A \subset [set x]) = (A == [set x]) || (A == set0). +Proof. +rewrite eqEcard cards1 -cards_eq0 orbC andbC. +by case: posnP => // A0; rewrite (cards0_eq A0) sub0set. +Qed. + +Lemma powerset1 x : powerset [set x] = [set set0; [set x]]. +Proof. by apply/setP=> A; rewrite !inE subset1 orbC. Qed. + +Lemma setIidPl A B : reflect (A :&: B = A) (A \subset B). +Proof. +apply: (iffP subsetP) => [sAB | <- x /setIP[] //]. +by apply/setP=> x; rewrite inE; apply: andb_idr; exact: sAB. +Qed. +Implicit Arguments setIidPl [A B]. + +Lemma setIidPr A B : reflect (A :&: B = B) (B \subset A). +Proof. rewrite setIC; exact: setIidPl. Qed. + +Lemma cardsDS A B : B \subset A -> #|A :\: B| = (#|A| - #|B|)%N. +Proof. by rewrite cardsD => /setIidPr->. Qed. + +Lemma setUidPl A B : reflect (A :|: B = A) (B \subset A). +Proof. +by rewrite -setCS (sameP setIidPl eqP) -setCU (inj_eq setC_inj); exact: eqP. +Qed. + +Lemma setUidPr A B : reflect (A :|: B = B) (A \subset B). +Proof. rewrite setUC; exact: setUidPl. Qed. + +Lemma setDidPl A B : reflect (A :\: B = A) [disjoint A & B]. +Proof. rewrite setDE disjoints_subset; exact: setIidPl. Qed. + +Lemma subIset A B C : (B \subset A) || (C \subset A) -> (B :&: C \subset A). +Proof. by case/orP; apply: subset_trans; rewrite (subsetIl, subsetIr). Qed. + +Lemma subsetI A B C : (A \subset B :&: C) = (A \subset B) && (A \subset C). +Proof. +rewrite !(sameP setIidPl eqP) setIA; have [-> //| ] := altP (A :&: B =P A). +by apply: contraNF => /eqP <-; rewrite -setIA -setIIl setIAC. +Qed. + +Lemma subsetIP A B C : reflect (A \subset B /\ A \subset C) (A \subset B :&: C). +Proof. by rewrite subsetI; exact: andP. Qed. + +Lemma subsetIidl A B : (A \subset A :&: B) = (A \subset B). +Proof. by rewrite subsetI subxx. Qed. + +Lemma subsetIidr A B : (B \subset A :&: B) = (B \subset A). +Proof. by rewrite setIC subsetIidl. Qed. + +Lemma powersetI A B : powerset (A :&: B) = powerset A :&: powerset B. +Proof. by apply/setP=> C; rewrite !inE subsetI. Qed. + +Lemma subUset A B C : (B :|: C \subset A) = (B \subset A) && (C \subset A). +Proof. by rewrite -setCS setCU subsetI !setCS. Qed. + +Lemma subsetU A B C : (A \subset B) || (A \subset C) -> A \subset B :|: C. +Proof. by rewrite -!(setCS _ A) setCU; exact: subIset. Qed. + +Lemma subUsetP A B C : reflect (A \subset C /\ B \subset C) (A :|: B \subset C). +Proof. by rewrite subUset; exact: andP. Qed. + +Lemma subsetC A B : (A \subset ~: B) = (B \subset ~: A). +Proof. by rewrite -setCS setCK. Qed. + +Lemma subCset A B : (~: A \subset B) = (~: B \subset A). +Proof. by rewrite -setCS setCK. Qed. + +Lemma subsetD A B C : (A \subset B :\: C) = (A \subset B) && [disjoint A & C]. +Proof. by rewrite setDE subsetI -disjoints_subset. Qed. + +Lemma subDset A B C : (A :\: B \subset C) = (A \subset B :|: C). +Proof. +apply/subsetP/subsetP=> sABC x; rewrite !inE. + by case Bx: (x \in B) => // Ax; rewrite sABC ?inE ?Bx. +by case Bx: (x \in B) => //; move/sABC; rewrite inE Bx. +Qed. + +Lemma subsetDP A B C : + reflect (A \subset B /\ [disjoint A & C]) (A \subset B :\: C). +Proof. by rewrite subsetD; exact: andP. Qed. + +Lemma setU_eq0 A B : (A :|: B == set0) = (A == set0) && (B == set0). +Proof. by rewrite -!subset0 subUset. Qed. + +Lemma setD_eq0 A B : (A :\: B == set0) = (A \subset B). +Proof. by rewrite -subset0 subDset setU0. Qed. + +Lemma setI_eq0 A B : (A :&: B == set0) = [disjoint A & B]. +Proof. by rewrite disjoints_subset -setD_eq0 setDE setCK. Qed. + +Lemma disjoint_setI0 A B : [disjoint A & B] -> A :&: B = set0. +Proof. by rewrite -setI_eq0; move/eqP. Qed. + +Lemma subsetD1 A B x : (A \subset B :\ x) = (A \subset B) && (x \notin A). +Proof. by rewrite setDE subsetI subsetC sub1set inE. Qed. + +Lemma subsetD1P A B x : reflect (A \subset B /\ x \notin A) (A \subset B :\ x). +Proof. by rewrite subsetD1; exact: andP. Qed. + +Lemma properD1 A x : x \in A -> A :\ x \proper A. +Proof. +move=> Ax; rewrite properE subsetDl; apply/subsetPn; exists x=> //. +by rewrite in_setD1 Ax eqxx. +Qed. + +Lemma properIr A B : ~~ (B \subset A) -> A :&: B \proper B. +Proof. by move=> nsAB; rewrite properE subsetIr subsetI negb_and nsAB. Qed. + +Lemma properIl A B : ~~ (A \subset B) -> A :&: B \proper A. +Proof. by move=> nsBA; rewrite properE subsetIl subsetI negb_and nsBA orbT. Qed. + +Lemma properUr A B : ~~ (A \subset B) -> B \proper A :|: B. +Proof. by rewrite properE subsetUr subUset subxx /= andbT. Qed. + +Lemma properUl A B : ~~ (B \subset A) -> A \proper A :|: B. +Proof. by move=> not_sBA; rewrite setUC properUr. Qed. + +Lemma proper1set A x : ([set x] \proper A) -> (x \in A). +Proof. by move/proper_sub; rewrite sub1set. Qed. + +Lemma properIset A B C : (B \proper A) || (C \proper A) -> (B :&: C \proper A). +Proof. by case/orP; apply: sub_proper_trans; rewrite (subsetIl, subsetIr). Qed. + +Lemma properI A B C : (A \proper B :&: C) -> (A \proper B) && (A \proper C). +Proof. +move=> pAI; apply/andP. +by split; apply: (proper_sub_trans pAI); rewrite (subsetIl, subsetIr). +Qed. + +Lemma properU A B C : (B :|: C \proper A) -> (B \proper A) && (C \proper A). +Proof. +move=> pUA; apply/andP. +by split; apply: sub_proper_trans pUA; rewrite (subsetUr, subsetUl). +Qed. + +Lemma properD A B C : (A \proper B :\: C) -> (A \proper B) && [disjoint A & C]. +Proof. by rewrite setDE disjoints_subset => /properI/andP[-> /proper_sub]. Qed. + +End setOps. + +Implicit Arguments set1P [T x a]. +Implicit Arguments set1_inj [T]. +Implicit Arguments set2P [T x a b]. +Implicit Arguments setIdP [T x pA pB]. +Implicit Arguments setIP [T x A B]. +Implicit Arguments setU1P [T x a B]. +Implicit Arguments setD1P [T x A b]. +Implicit Arguments setUP [T x A B]. +Implicit Arguments setDP [T x A B]. +Implicit Arguments cards1P [T A]. +Implicit Arguments setCP [T x A]. +Implicit Arguments setIidPl [T A B]. +Implicit Arguments setIidPr [T A B]. +Implicit Arguments setUidPl [T A B]. +Implicit Arguments setUidPr [T A B]. +Implicit Arguments setDidPl [T A B]. +Implicit Arguments subsetIP [T A B C]. +Implicit Arguments subUsetP [T A B C]. +Implicit Arguments subsetDP [T A B C]. +Implicit Arguments subsetD1P [T A B x]. +Prenex Implicits set1 set1_inj. +Prenex Implicits set1P set2P setU1P setD1P setIdP setIP setUP setDP. +Prenex Implicits cards1P setCP setIidPl setIidPr setUidPl setUidPr setDidPl. +Hint Resolve subsetT_hint. + +Section setOpsAlgebra. + +Import Monoid. + +Variable T : finType. + +Canonical setI_monoid := Law (@setIA T) (@setTI T) (@setIT T). + +Canonical setI_comoid := ComLaw (@setIC T). +Canonical setI_muloid := MulLaw (@set0I T) (@setI0 T). + +Canonical setU_monoid := Law (@setUA T) (@set0U T) (@setU0 T). +Canonical setU_comoid := ComLaw (@setUC T). +Canonical setU_muloid := MulLaw (@setTU T) (@setUT T). + +Canonical setI_addoid := AddLaw (@setUIl T) (@setUIr T). +Canonical setU_addoid := AddLaw (@setIUl T) (@setIUr T). + +End setOpsAlgebra. + +Section CartesianProd. + +Variables fT1 fT2 : finType. +Variables (A1 : {set fT1}) (A2 : {set fT2}). + +Definition setX := [set u | u.1 \in A1 & u.2 \in A2]. + +Lemma in_setX x1 x2 : ((x1, x2) \in setX) = (x1 \in A1) && (x2 \in A2). +Proof. by rewrite inE. Qed. + +Lemma setXP x1 x2 : reflect (x1 \in A1 /\ x2 \in A2) ((x1, x2) \in setX). +Proof. by rewrite inE; exact: andP. Qed. + +Lemma cardsX : #|setX| = #|A1| * #|A2|. +Proof. by rewrite cardsE cardX. Qed. + +End CartesianProd. + +Implicit Arguments setXP [x1 x2 fT1 fT2 A1 A2]. +Prenex Implicits setXP. + +Notation Local imset_def := + (fun (aT rT : finType) f mD => [set y in @image_mem aT rT f mD]). +Notation Local imset2_def := + (fun (aT1 aT2 rT : finType) f (D1 : mem_pred aT1) (D2 : _ -> mem_pred aT2) => + [set y in @image_mem _ rT (prod_curry f) + (mem [pred u | D1 u.1 & D2 u.1 u.2])]). + +Module Type ImsetSig. +Parameter imset : forall aT rT : finType, + (aT -> rT) -> mem_pred aT -> {set rT}. +Parameter imset2 : forall aT1 aT2 rT : finType, + (aT1 -> aT2 -> rT) -> mem_pred aT1 -> (aT1 -> mem_pred aT2) -> {set rT}. +Axiom imsetE : imset = imset_def. +Axiom imset2E : imset2 = imset2_def. +End ImsetSig. + +Module Imset : ImsetSig. +Definition imset := imset_def. +Definition imset2 := imset2_def. +Lemma imsetE : imset = imset_def. Proof. by []. Qed. +Lemma imset2E : imset2 = imset2_def. Proof. by []. Qed. +End Imset. + +Notation imset := Imset.imset. +Notation imset2 := Imset.imset2. +Canonical imset_unlock := Unlockable Imset.imsetE. +Canonical imset2_unlock := Unlockable Imset.imset2E. +Definition preimset (aT : finType) rT f (R : mem_pred rT) := + [set x : aT | in_mem (f x) R]. + +Notation "f @^-1: A" := (preimset f (mem A)) (at level 24) : set_scope. +Notation "f @: A" := (imset f (mem A)) (at level 24) : set_scope. +Notation "f @2: ( A , B )" := (imset2 f (mem A) (fun _ => mem B)) + (at level 24, format "f @2: ( A , B )") : set_scope. + +(* Comprehensions *) +Notation "[ 'set' E | x 'in' A ]" := ((fun x => E) @: A) + (at level 0, E, x at level 99, + format "[ '[hv' 'set' E '/ ' | x 'in' A ] ']'") : set_scope. +Notation "[ 'set' E | x 'in' A & P ]" := [set E | x in [set x in A | P]] + (at level 0, E, x at level 99, + format "[ '[hv' 'set' E '/ ' | x 'in' A '/ ' & P ] ']'") : set_scope. +Notation "[ 'set' E | x 'in' A , y 'in' B ]" := + (imset2 (fun x y => E) (mem A) (fun x => (mem B))) + (at level 0, E, x, y at level 99, format + "[ '[hv' 'set' E '/ ' | x 'in' A , '/ ' y 'in' B ] ']'" + ) : set_scope. +Notation "[ 'set' E | x 'in' A , y 'in' B & P ]" := + [set E | x in A, y in [set y in B | P]] + (at level 0, E, x, y at level 99, format + "[ '[hv' 'set' E '/ ' | x 'in' A , '/ ' y 'in' B '/ ' & P ] ']'" + ) : set_scope. + +(* Typed variants. *) +Notation "[ 'set' E | x : T 'in' A ]" := ((fun x : T => E) @: A) + (at level 0, E, x at level 99, only parsing) : set_scope. +Notation "[ 'set' E | x : T 'in' A & P ]" := + [set E | x : T in [set x : T in A | P]] + (at level 0, E, x at level 99, only parsing) : set_scope. +Notation "[ 'set' E | x : T 'in' A , y : U 'in' B ]" := + (imset2 (fun (x : T) (y : U) => E) (mem A) (fun (x : T) => (mem B))) + (at level 0, E, x, y at level 99, only parsing) : set_scope. +Notation "[ 'set' E | x : T 'in' A , y : U 'in' B & P ]" := + [set E | x : T in A, y : U in [set y : U in B | P]] + (at level 0, E, x, y at level 99, only parsing) : set_scope. + +(* Comprehensions over a type. *) +Local Notation predOfType T := (sort_of_simpl_pred (@pred_of_argType T)). +Notation "[ 'set' E | x : T ]" := [set E | x : T in predOfType T] + (at level 0, E, x at level 99, + format "[ '[hv' 'set' E '/ ' | x : T ] ']'") : set_scope. +Notation "[ 'set' E | x : T & P ]" := [set E | x : T in [set x : T | P]] + (at level 0, E, x at level 99, + format "[ '[hv' 'set' E '/ ' | x : T '/ ' & P ] ']'") : set_scope. +Notation "[ 'set' E | x : T , y : U 'in' B ]" := + [set E | x : T in predOfType T, y : U in B] + (at level 0, E, x, y at level 99, format + "[ '[hv' 'set' E '/ ' | x : T , '/ ' y : U 'in' B ] ']'") + : set_scope. +Notation "[ 'set' E | x : T , y : U 'in' B & P ]" := + [set E | x : T, y : U in [set y in B | P]] + (at level 0, E, x, y at level 99, format + "[ '[hv ' 'set' E '/' | x : T , '/ ' y : U 'in' B '/' & P ] ']'" + ) : set_scope. +Notation "[ 'set' E | x : T 'in' A , y : U ]" := + [set E | x : T in A, y : U in predOfType U] + (at level 0, E, x, y at level 99, format + "[ '[hv' 'set' E '/ ' | x : T 'in' A , '/ ' y : U ] ']'") + : set_scope. +Notation "[ 'set' E | x : T 'in' A , y : U & P ]" := + [set E | x : T in A, y : U in [set y in P]] + (at level 0, E, x, y at level 99, format + "[ '[hv' 'set' E '/ ' | x : T 'in' A , '/ ' y : U & P ] ']'") + : set_scope. +Notation "[ 'set' E | x : T , y : U ]" := + [set E | x : T, y : U in predOfType U] + (at level 0, E, x, y at level 99, format + "[ '[hv' 'set' E '/ ' | x : T , '/ ' y : U ] ']'") + : set_scope. +Notation "[ 'set' E | x : T , y : U & P ]" := + [set E | x : T, y : U in [set y in P]] + (at level 0, E, x, y at level 99, format + "[ '[hv' 'set' E '/ ' | x : T , '/ ' y : U & P ] ']'") + : set_scope. + +(* Untyped variants. *) +Notation "[ 'set' E | x , y 'in' B ]" := [set E | x : _, y : _ in B] + (at level 0, E, x, y at level 99, only parsing) : set_scope. +Notation "[ 'set' E | x , y 'in' B & P ]" := [set E | x : _, y : _ in B & P] + (at level 0, E, x, y at level 99, only parsing) : set_scope. +Notation "[ 'set' E | x 'in' A , y ]" := [set E | x : _ in A, y : _] + (at level 0, E, x, y at level 99, only parsing) : set_scope. +Notation "[ 'set' E | x 'in' A , y & P ]" := [set E | x : _ in A, y : _ & P] + (at level 0, E, x, y at level 99, only parsing) : set_scope. +Notation "[ 'set' E | x , y ]" := [set E | x : _, y : _] + (at level 0, E, x, y at level 99, only parsing) : set_scope. +Notation "[ 'set' E | x , y & P ]" := [set E | x : _, y : _ & P ] + (at level 0, E, x, y at level 99, only parsing) : set_scope. + +(* Print-only variants to work around the Coq pretty-printer K-term kink. *) +Notation "[ 'se' 't' E | x 'in' A , y 'in' B ]" := + (imset2 (fun x y => E) (mem A) (fun _ => mem B)) + (at level 0, E, x, y at level 99, format + "[ '[hv' 'se' 't' E '/ ' | x 'in' A , '/ ' y 'in' B ] ']'") + : set_scope. +Notation "[ 'se' 't' E | x 'in' A , y 'in' B & P ]" := + [se t E | x in A, y in [set y in B | P]] + (at level 0, E, x, y at level 99, format + "[ '[hv ' 'se' 't' E '/' | x 'in' A , '/ ' y 'in' B '/' & P ] ']'" + ) : set_scope. +Notation "[ 'se' 't' E | x : T , y : U 'in' B ]" := + (imset2 (fun x (y : U) => E) (mem (predOfType T)) (fun _ => mem B)) + (at level 0, E, x, y at level 99, format + "[ '[hv ' 'se' 't' E '/' | x : T , '/ ' y : U 'in' B ] ']'") + : set_scope. +Notation "[ 'se' 't' E | x : T , y : U 'in' B & P ]" := + [se t E | x : T, y : U in [set y in B | P]] + (at level 0, E, x, y at level 99, format +"[ '[hv ' 'se' 't' E '/' | x : T , '/ ' y : U 'in' B '/' & P ] ']'" + ) : set_scope. +Notation "[ 'se' 't' E | x : T 'in' A , y : U ]" := + (imset2 (fun x y => E) (mem A) (fun _ : T => mem (predOfType U))) + (at level 0, E, x, y at level 99, format + "[ '[hv' 'se' 't' E '/ ' | x : T 'in' A , '/ ' y : U ] ']'") + : set_scope. +Notation "[ 'se' 't' E | x : T 'in' A , y : U & P ]" := + (imset2 (fun x (y : U) => E) (mem A) (fun _ : T => mem [set y \in P])) + (at level 0, E, x, y at level 99, format +"[ '[hv ' 'se' 't' E '/' | x : T 'in' A , '/ ' y : U '/' & P ] ']'" + ) : set_scope. +Notation "[ 'se' 't' E | x : T , y : U ]" := + [se t E | x : T, y : U in predOfType U] + (at level 0, E, x, y at level 99, format + "[ '[hv' 'se' 't' E '/ ' | x : T , '/ ' y : U ] ']'") + : set_scope. +Notation "[ 'se' 't' E | x : T , y : U & P ]" := + [se t E | x : T, y : U in [set y in P]] + (at level 0, E, x, y at level 99, format + "[ '[hv' 'se' 't' E '/' | x : T , '/ ' y : U '/' & P ] ']'") + : set_scope. + +Section FunImage. + +Variables aT aT2 : finType. + +Section ImsetTheory. + +Variable rT : finType. + +Section ImsetProp. + +Variables (f : aT -> rT) (f2 : aT -> aT2 -> rT). + +Lemma imsetP D y : reflect (exists2 x, in_mem x D & y = f x) (y \in imset f D). +Proof. rewrite [@imset]unlock inE; exact: imageP. Qed. + +CoInductive imset2_spec D1 D2 y : Prop := + Imset2spec x1 x2 of in_mem x1 D1 & in_mem x2 (D2 x1) & y = f2 x1 x2. + +Lemma imset2P D1 D2 y : reflect (imset2_spec D1 D2 y) (y \in imset2 f2 D1 D2). +Proof. +rewrite [@imset2]unlock inE. +apply: (iffP imageP) => [[[x1 x2] Dx12] | [x1 x2 Dx1 Dx2]] -> {y}. + by case/andP: Dx12; exists x1 x2. +by exists (x1, x2); rewrite //= !inE Dx1. +Qed. + +Lemma mem_imset (D : pred aT) x : x \in D -> f x \in f @: D. +Proof. by move=> Dx; apply/imsetP; exists x. Qed. + +Lemma imset0 : f @: set0 = set0. +Proof. by apply/setP => y; rewrite inE; apply/imsetP=> [[x]]; rewrite inE. Qed. + +Lemma imset_eq0 (A : {set aT}) : (f @: A == set0) = (A == set0). +Proof. +have [-> | [x Ax]] := set_0Vmem A; first by rewrite imset0 !eqxx. +by rewrite -!cards_eq0 (cardsD1 x) Ax (cardsD1 (f x)) mem_imset. +Qed. + +Lemma imset_set1 x : f @: [set x] = [set f x]. +Proof. +apply/setP => y. +by apply/imsetP/set1P=> [[x' /set1P-> //]| ->]; exists x; rewrite ?set11. +Qed. + +Lemma mem_imset2 (D : pred aT) (D2 : aT -> pred aT2) x x2 : + x \in D -> x2 \in D2 x -> + f2 x x2 \in imset2 f2 (mem D) (fun x1 => mem (D2 x1)). +Proof. by move=> Dx Dx2; apply/imset2P; exists x x2. Qed. + +Lemma sub_imset_pre (A : pred aT) (B : pred rT) : + (f @: A \subset B) = (A \subset f @^-1: B). +Proof. +apply/subsetP/subsetP=> [sfAB x Ax | sAf'B fx]. + by rewrite inE sfAB ?mem_imset. +by case/imsetP=> x Ax ->; move/sAf'B: Ax; rewrite inE. +Qed. + +Lemma preimsetS (A B : pred rT) : + A \subset B -> (f @^-1: A) \subset (f @^-1: B). +Proof. move=> sAB; apply/subsetP=> y; rewrite !inE; exact: (subsetP sAB). Qed. + +Lemma preimset0 : f @^-1: set0 = set0. +Proof. by apply/setP=> x; rewrite !inE. Qed. + +Lemma preimsetT : f @^-1: setT = setT. +Proof. by apply/setP=> x; rewrite !inE. Qed. + +Lemma preimsetI (A B : {set rT}) : + f @^-1: (A :&: B) = (f @^-1: A) :&: (f @^-1: B). +Proof. by apply/setP=> y; rewrite !inE. Qed. + +Lemma preimsetU (A B : {set rT}) : + f @^-1: (A :|: B) = (f @^-1: A) :|: (f @^-1: B). +Proof. by apply/setP=> y; rewrite !inE. Qed. + +Lemma preimsetD (A B : {set rT}) : + f @^-1: (A :\: B) = (f @^-1: A) :\: (f @^-1: B). +Proof. by apply/setP=> y; rewrite !inE. Qed. + +Lemma preimsetC (A : {set rT}) : f @^-1: (~: A) = ~: f @^-1: A. +Proof. by apply/setP=> y; rewrite !inE. Qed. + +Lemma imsetS (A B : pred aT) : A \subset B -> f @: A \subset f @: B. +Proof. +move=> sAB; apply/subsetP=> _ /imsetP[x Ax ->]. +by apply/imsetP; exists x; rewrite ?(subsetP sAB). +Qed. + +Lemma imset_proper (A B : {set aT}) : + {in B &, injective f} -> A \proper B -> f @: A \proper f @: B. +Proof. +move=> injf /properP[sAB [x Bx nAx]]; rewrite properE imsetS //=. +apply: contra nAx => sfBA. +have: f x \in f @: A by rewrite (subsetP sfBA) ?mem_imset. +by case/imsetP=> y Ay /injf-> //; exact: subsetP sAB y Ay. +Qed. + +Lemma preimset_proper (A B : {set rT}) : + B \subset codom f -> A \proper B -> (f @^-1: A) \proper (f @^-1: B). +Proof. +move=> sBc /properP[sAB [u Bu nAu]]; rewrite properE preimsetS //=. +by apply/subsetPn; exists (iinv (subsetP sBc _ Bu)); rewrite inE /= f_iinv. +Qed. + +Lemma imsetU (A B : {set aT}) : f @: (A :|: B) = (f @: A) :|: (f @: B). +Proof. +apply/eqP; rewrite eqEsubset subUset. +rewrite 2?imsetS (andbT, subsetUl, subsetUr) // andbT. +apply/subsetP=> _ /imsetP[x ABx ->]; apply/setUP. +by case/setUP: ABx => [Ax | Bx]; [left | right]; apply/imsetP; exists x. +Qed. + +Lemma imsetU1 a (A : {set aT}) : f @: (a |: A) = f a |: (f @: A). +Proof. by rewrite imsetU imset_set1. Qed. + +Lemma imsetI (A B : {set aT}) : + {in A & B, injective f} -> f @: (A :&: B) = f @: A :&: f @: B. +Proof. +move=> injf; apply/eqP; rewrite eqEsubset subsetI. +rewrite 2?imsetS (andTb, subsetIl, subsetIr) //=. +apply/subsetP=> _ /setIP[/imsetP[x Ax ->] /imsetP[z Bz /injf eqxz]]. +by rewrite mem_imset // inE Ax eqxz. +Qed. + +Lemma imset2Sl (A B : pred aT) (C : pred aT2) : + A \subset B -> f2 @2: (A, C) \subset f2 @2: (B, C). +Proof. +move=> sAB; apply/subsetP=> _ /imset2P[x y Ax Cy ->]. +by apply/imset2P; exists x y; rewrite ?(subsetP sAB). +Qed. + +Lemma imset2Sr (A B : pred aT2) (C : pred aT) : + A \subset B -> f2 @2: (C, A) \subset f2 @2: (C, B). +Proof. +move=> sAB; apply/subsetP=> _ /imset2P[x y Ax Cy ->]. +by apply/imset2P; exists x y; rewrite ?(subsetP sAB). +Qed. + +Lemma imset2S (A B : pred aT) (A2 B2 : pred aT2) : + A \subset B -> A2 \subset B2 -> f2 @2: (A, A2) \subset f2 @2: (B, B2). +Proof. by move=> /(imset2Sl B2) sBA /(imset2Sr A)/subset_trans->. Qed. + +End ImsetProp. + +Implicit Types (f g : aT -> rT) (D : {set aT}) (R : pred rT). + +Lemma eq_preimset f g R : f =1 g -> f @^-1: R = g @^-1: R. +Proof. by move=> eqfg; apply/setP => y; rewrite !inE eqfg. Qed. + +Lemma eq_imset f g D : f =1 g -> f @: D = g @: D. +Proof. +move=> eqfg; apply/setP=> y. +by apply/imsetP/imsetP=> [] [x Dx ->]; exists x; rewrite ?eqfg. +Qed. + +Lemma eq_in_imset f g D : {in D, f =1 g} -> f @: D = g @: D. +Proof. +move=> eqfg; apply/setP => y. +by apply/imsetP/imsetP=> [] [x Dx ->]; exists x; rewrite ?eqfg. +Qed. + +Lemma eq_in_imset2 (f g : aT -> aT2 -> rT) (D : pred aT) (D2 : pred aT2) : + {in D & D2, f =2 g} -> f @2: (D, D2) = g @2: (D, D2). +Proof. +move=> eqfg; apply/setP => y. +by apply/imset2P/imset2P=> [] [x x2 Dx Dx2 ->]; exists x x2; rewrite ?eqfg. +Qed. + +End ImsetTheory. + +Lemma imset2_pair (A : {set aT}) (B : {set aT2}) : + [set (x, y) | x in A, y in B] = setX A B. +Proof. +apply/setP=> [[x y]]; rewrite !inE /=. +by apply/imset2P/andP=> [[_ _ _ _ [-> ->]//]| []]; exists x y. +Qed. + +Lemma setXS (A1 B1 : {set aT}) (A2 B2 : {set aT2}) : + A1 \subset B1 -> A2 \subset B2 -> setX A1 A2 \subset setX B1 B2. +Proof. by move=> sAB1 sAB2; rewrite -!imset2_pair imset2S. Qed. + +End FunImage. + +Implicit Arguments imsetP [aT rT f D y]. +Implicit Arguments imset2P [aT aT2 rT f2 D1 D2 y]. +Prenex Implicits imsetP imset2P. + +Section BigOps. + +Variables (R : Type) (idx : R). +Variables (op : Monoid.law idx) (aop : Monoid.com_law idx). +Variables I J : finType. +Implicit Type A B : {set I}. +Implicit Type h : I -> J. +Implicit Type P : pred I. +Implicit Type F : I -> R. + +Lemma big_set0 F : \big[op/idx]_(i in set0) F i = idx. +Proof. by apply: big_pred0 => i; rewrite inE. Qed. + +Lemma big_set1 a F : \big[op/idx]_(i in [set a]) F i = F a. +Proof. by apply: big_pred1 => i; rewrite !inE. Qed. + +Lemma big_setIDdep A B P F : + \big[aop/idx]_(i in A | P i) F i = + aop (\big[aop/idx]_(i in A :&: B | P i) F i) + (\big[aop/idx]_(i in A :\: B | P i) F i). +Proof. +rewrite (bigID (mem B)) setDE. +by congr (aop _ _); apply: eq_bigl => i; rewrite !inE andbAC. +Qed. + +Lemma big_setID A B F : + \big[aop/idx]_(i in A) F i = + aop (\big[aop/idx]_(i in A :&: B) F i) + (\big[aop/idx]_(i in A :\: B) F i). +Proof. +rewrite (bigID (mem B)) !(eq_bigl _ _ (in_set _)) //=. +by congr (aop _); apply: eq_bigl => i; rewrite andbC. +Qed. + +Lemma big_setD1 a A F : a \in A -> + \big[aop/idx]_(i in A) F i = aop (F a) (\big[aop/idx]_(i in A :\ a) F i). +Proof. +move=> Aa; rewrite (bigD1 a Aa); congr (aop _). +by apply: eq_bigl => x; rewrite !inE andbC. +Qed. + +Lemma big_setU1 a A F : a \notin A -> + \big[aop/idx]_(i in a |: A) F i = aop (F a) (\big[aop/idx]_(i in A) F i). +Proof. by move=> notAa; rewrite (@big_setD1 a) ?setU11 //= setU1K. Qed. + +Lemma big_imset h (A : pred I) G : + {in A &, injective h} -> + \big[aop/idx]_(j in h @: A) G j = \big[aop/idx]_(i in A) G (h i). +Proof. +move=> injh; pose hA := mem (image h A). +have [x0 Ax0 | A0] := pickP A; last first. + by rewrite !big_pred0 // => x; apply/imsetP=> [[i]]; rewrite unfold_in A0. +rewrite (eq_bigl hA) => [|j]; last by exact/imsetP/imageP. +pose h' j := if insub j : {? j | hA j} is Some u then iinv (svalP u) else x0. +rewrite (reindex_onto h h') => [|j hAj]; rewrite {}/h'; last first. + by rewrite (insubT hA hAj) f_iinv. +apply: eq_bigl => i; case: insubP => [u -> /= def_u | nhAhi]. + set i' := iinv _; have Ai' : i' \in A := mem_iinv (svalP u). + by apply/eqP/idP=> [<- // | Ai]; apply: injh; rewrite ?f_iinv. +symmetry; rewrite (negbTE nhAhi); apply/idP=> Ai. +by case/imageP: nhAhi; exists i. +Qed. + +Lemma partition_big_imset h (A : pred I) F : + \big[aop/idx]_(i in A) F i = + \big[aop/idx]_(j in h @: A) \big[aop/idx]_(i in A | h i == j) F i. +Proof. by apply: partition_big => i Ai; apply/imsetP; exists i. Qed. + +End BigOps. + +Implicit Arguments big_setID [R idx aop I A]. +Implicit Arguments big_setD1 [R idx aop I A F]. +Implicit Arguments big_setU1 [R idx aop I A F]. +Implicit Arguments big_imset [R idx aop h I J A]. +Implicit Arguments partition_big_imset [R idx aop I J]. + +Section Fun2Set1. + +Variables aT1 aT2 rT : finType. +Variables (f : aT1 -> aT2 -> rT). + +Lemma imset2_set1l x1 (D2 : pred aT2) : f @2: ([set x1], D2) = f x1 @: D2. +Proof. +apply/setP=> y; apply/imset2P/imsetP=> [[x x2 /set1P->]| [x2 Dx2 ->]]. + by exists x2. +by exists x1 x2; rewrite ?set11. +Qed. + +Lemma imset2_set1r x2 (D1 : pred aT1) : f @2: (D1, [set x2]) = f^~ x2 @: D1. +Proof. +apply/setP=> y; apply/imset2P/imsetP=> [[x1 x Dx1 /set1P->]| [x1 Dx1 ->]]. + by exists x1. +by exists x1 x2; rewrite ?set11. +Qed. + +End Fun2Set1. + +Section CardFunImage. + +Variables aT aT2 rT : finType. +Variables (f : aT -> rT) (g : rT -> aT) (f2 : aT -> aT2 -> rT). +Variables (D : pred aT) (D2 : pred aT). + +Lemma imset_card : #|f @: D| = #|image f D|. +Proof. by rewrite [@imset]unlock cardsE. Qed. + +Lemma leq_imset_card : #|f @: D| <= #|D|. +Proof. by rewrite imset_card leq_image_card. Qed. + +Lemma card_in_imset : {in D &, injective f} -> #|f @: D| = #|D|. +Proof. by move=> injf; rewrite imset_card card_in_image. Qed. + +Lemma card_imset : injective f -> #|f @: D| = #|D|. +Proof. by move=> injf; rewrite imset_card card_image. Qed. + +Lemma imset_injP : reflect {in D &, injective f} (#|f @: D| == #|D|). +Proof. by rewrite [@imset]unlock cardsE; exact: image_injP. Qed. + +Lemma can2_in_imset_pre : + {in D, cancel f g} -> {on D, cancel g & f} -> f @: D = g @^-1: D. +Proof. +move=> fK gK; apply/setP=> y; rewrite inE. +by apply/imsetP/idP=> [[x Ax ->] | Agy]; last exists (g y); rewrite ?(fK, gK). +Qed. + +Lemma can2_imset_pre : cancel f g -> cancel g f -> f @: D = g @^-1: D. +Proof. by move=> fK gK; apply: can2_in_imset_pre; exact: in1W. Qed. + +End CardFunImage. + +Implicit Arguments imset_injP [aT rT f D]. + +Lemma on_card_preimset (aT rT : finType) (f : aT -> rT) (R : pred rT) : + {on R, bijective f} -> #|f @^-1: R| = #|R|. +Proof. +case=> g fK gK; rewrite -(can2_in_imset_pre gK) // card_in_imset //. +exact: can_in_inj gK. +Qed. + +Lemma can_imset_pre (T : finType) f g (A : {set T}) : + cancel f g -> f @: A = g @^-1: A :> {set T}. +Proof. +move=> fK; apply: can2_imset_pre => // x. +suffices fx: x \in codom f by rewrite -(f_iinv fx) fK. +move: x; apply/(subset_cardP (card_codom (can_inj fK))); exact/subsetP. +Qed. + +Lemma imset_id (T : finType) (A : {set T}) : [set x | x in A] = A. +Proof. by apply/setP=> x; rewrite (@can_imset_pre _ _ id) ?inE. Qed. + +Lemma card_preimset (T : finType) (f : T -> T) (A : {set T}) : + injective f -> #|f @^-1: A| = #|A|. +Proof. +move=> injf; apply: on_card_preimset; apply: onW_bij. +have ontof: _ \in codom f by exact/(subset_cardP (card_codom injf))/subsetP. +by exists (fun x => iinv (ontof x)) => x; rewrite (f_iinv, iinv_f). +Qed. + +Lemma card_powerset (T : finType) (A : {set T}) : #|powerset A| = 2 ^ #|A|. +Proof. +rewrite -card_bool -(card_pffun_on false) -(card_imset _ val_inj). +apply: eq_card => f; pose sf := false.-support f; pose D := finset sf. +have sDA: (D \subset A) = (sf \subset A) by apply: eq_subset; exact: in_set. +have eq_sf x : sf x = f x by rewrite /= negb_eqb addbF. +have valD: val D = f by rewrite /D unlock; apply/ffunP=> x; rewrite ffunE eq_sf. +apply/imsetP/pffun_onP=> [[B] | [sBA _]]; last by exists D; rewrite // inE ?sDA. +by rewrite inE -sDA -valD => sBA /val_inj->. +Qed. + +Section FunImageComp. + +Variables T T' U : finType. + +Lemma imset_comp (f : T' -> U) (g : T -> T') (H : pred T) : + (f \o g) @: H = f @: (g @: H). +Proof. +apply/setP/subset_eqP/andP. +split; apply/subsetP=> _ /imsetP[x0 Hx0 ->]; apply/imsetP. + by exists (g x0); first apply: mem_imset. +by move/imsetP: Hx0 => [x1 Hx1 ->]; exists x1. +Qed. + +End FunImageComp. + +Notation "\bigcup_ ( i <- r | P ) F" := + (\big[@setU _/set0]_(i <- r | P) F%SET) : set_scope. +Notation "\bigcup_ ( i <- r ) F" := + (\big[@setU _/set0]_(i <- r) F%SET) : set_scope. +Notation "\bigcup_ ( m <= i < n | P ) F" := + (\big[@setU _/set0]_(m <= i < n | P%B) F%SET) : set_scope. +Notation "\bigcup_ ( m <= i < n ) F" := + (\big[@setU _/set0]_(m <= i < n) F%SET) : set_scope. +Notation "\bigcup_ ( i | P ) F" := + (\big[@setU _/set0]_(i | P%B) F%SET) : set_scope. +Notation "\bigcup_ i F" := + (\big[@setU _/set0]_i F%SET) : set_scope. +Notation "\bigcup_ ( i : t | P ) F" := + (\big[@setU _/set0]_(i : t | P%B) F%SET) (only parsing): set_scope. +Notation "\bigcup_ ( i : t ) F" := + (\big[@setU _/set0]_(i : t) F%SET) (only parsing) : set_scope. +Notation "\bigcup_ ( i < n | P ) F" := + (\big[@setU _/set0]_(i < n | P%B) F%SET) : set_scope. +Notation "\bigcup_ ( i < n ) F" := + (\big[@setU _/set0]_ (i < n) F%SET) : set_scope. +Notation "\bigcup_ ( i 'in' A | P ) F" := + (\big[@setU _/set0]_(i in A | P%B) F%SET) : set_scope. +Notation "\bigcup_ ( i 'in' A ) F" := + (\big[@setU _/set0]_(i in A) F%SET) : set_scope. + +Notation "\bigcap_ ( i <- r | P ) F" := + (\big[@setI _/setT]_(i <- r | P%B) F%SET) : set_scope. +Notation "\bigcap_ ( i <- r ) F" := + (\big[@setI _/setT]_(i <- r) F%SET) : set_scope. +Notation "\bigcap_ ( m <= i < n | P ) F" := + (\big[@setI _/setT]_(m <= i < n | P%B) F%SET) : set_scope. +Notation "\bigcap_ ( m <= i < n ) F" := + (\big[@setI _/setT]_(m <= i < n) F%SET) : set_scope. +Notation "\bigcap_ ( i | P ) F" := + (\big[@setI _/setT]_(i | P%B) F%SET) : set_scope. +Notation "\bigcap_ i F" := + (\big[@setI _/setT]_i F%SET) : set_scope. +Notation "\bigcap_ ( i : t | P ) F" := + (\big[@setI _/setT]_(i : t | P%B) F%SET) (only parsing): set_scope. +Notation "\bigcap_ ( i : t ) F" := + (\big[@setI _/setT]_(i : t) F%SET) (only parsing) : set_scope. +Notation "\bigcap_ ( i < n | P ) F" := + (\big[@setI _/setT]_(i < n | P%B) F%SET) : set_scope. +Notation "\bigcap_ ( i < n ) F" := + (\big[@setI _/setT]_(i < n) F%SET) : set_scope. +Notation "\bigcap_ ( i 'in' A | P ) F" := + (\big[@setI _/setT]_(i in A | P%B) F%SET) : set_scope. +Notation "\bigcap_ ( i 'in' A ) F" := + (\big[@setI _/setT]_(i in A) F%SET) : set_scope. + +Section BigSetOps. + +Variables T I : finType. +Implicit Types (U : pred T) (P : pred I) (A B : {set I}) (F : I -> {set T}). + +(* It is very hard to use this lemma, because the unification fails to *) +(* defer the F j pattern (even though it's a Miller pattern!). *) +Lemma bigcup_sup j P F : P j -> F j \subset \bigcup_(i | P i) F i. +Proof. by move=> Pj; rewrite (bigD1 j) //= subsetUl. Qed. + +Lemma bigcup_max j U P F : + P j -> U \subset F j -> U \subset \bigcup_(i | P i) F i. +Proof. by move=> Pj sUF; exact: subset_trans (bigcup_sup _ Pj). Qed. + +Lemma bigcupP x P F : + reflect (exists2 i, P i & x \in F i) (x \in \bigcup_(i | P i) F i). +Proof. +apply: (iffP idP) => [|[i Pi]]; last first. + apply: subsetP x; exact: bigcup_sup. +by elim/big_rec: _ => [|i _ Pi _ /setUP[|//]]; [rewrite inE | exists i]. +Qed. + +Lemma bigcupsP U P F : + reflect (forall i, P i -> F i \subset U) (\bigcup_(i | P i) F i \subset U). +Proof. +apply: (iffP idP) => [sFU i Pi| sFU]. + by apply: subset_trans sFU; exact: bigcup_sup. +by apply/subsetP=> x /bigcupP[i Pi]; exact: (subsetP (sFU i Pi)). +Qed. + +Lemma bigcup_disjoint U P F : + (forall i, P i -> [disjoint U & F i]) -> [disjoint U & \bigcup_(i | P i) F i]. +Proof. +move=> dUF; rewrite disjoint_sym disjoint_subset. +by apply/bigcupsP=> i /dUF; rewrite disjoint_sym disjoint_subset. +Qed. + +Lemma bigcup_setU A B F : + \bigcup_(i in A :|: B) F i = + (\bigcup_(i in A) F i) :|: (\bigcup_ (i in B) F i). +Proof. +apply/setP=> x; apply/bigcupP/setUP=> [[i] | ]. + by case/setUP; [left | right]; apply/bigcupP; exists i. +by case=> /bigcupP[i Pi]; exists i; rewrite // inE Pi ?orbT. +Qed. + +Lemma bigcup_seq r F : \bigcup_(i <- r) F i = \bigcup_(i in r) F i. +Proof. +elim: r => [|i r IHr]; first by rewrite big_nil big_pred0. +rewrite big_cons {}IHr; case r_i: (i \in r). + rewrite (setUidPr _) ?bigcup_sup //. + by apply: eq_bigl => j; rewrite !inE; case: eqP => // ->. +rewrite (bigD1 i (mem_head i r)) /=; congr (_ :|: _). +by apply: eq_bigl => j /=; rewrite andbC; case: eqP => // ->. +Qed. + +(* Unlike its setU counterpart, this lemma is useable. *) +Lemma bigcap_inf j P F : P j -> \bigcap_(i | P i) F i \subset F j. +Proof. by move=> Pj; rewrite (bigD1 j) //= subsetIl. Qed. + +Lemma bigcap_min j U P F : + P j -> F j \subset U -> \bigcap_(i | P i) F i \subset U. +Proof. by move=> Pj; exact: subset_trans (bigcap_inf _ Pj). Qed. + +Lemma bigcapsP U P F : + reflect (forall i, P i -> U \subset F i) (U \subset \bigcap_(i | P i) F i). +Proof. +apply: (iffP idP) => [sUF i Pi | sUF]. + apply: subset_trans sUF _; exact: bigcap_inf. +elim/big_rec: _ => [|i V Pi sUV]; apply/subsetP=> x Ux; rewrite inE //. +by rewrite !(subsetP _ x Ux) ?sUF. +Qed. + +Lemma bigcapP x P F : + reflect (forall i, P i -> x \in F i) (x \in \bigcap_(i | P i) F i). +Proof. +rewrite -sub1set. +by apply: (iffP (bigcapsP _ _ _)) => Fx i /Fx; rewrite sub1set. +Qed. + +Lemma setC_bigcup J r (P : pred J) (F : J -> {set T}) : + ~: (\bigcup_(j <- r | P j) F j) = \bigcap_(j <- r | P j) ~: F j. +Proof. by apply: big_morph => [A B|]; rewrite ?setC0 ?setCU. Qed. + +Lemma setC_bigcap J r (P : pred J) (F : J -> {set T}) : + ~: (\bigcap_(j <- r | P j) F j) = \bigcup_(j <- r | P j) ~: F j. +Proof. by apply: big_morph => [A B|]; rewrite ?setCT ?setCI. Qed. + +Lemma bigcap_setU A B F : + (\bigcap_(i in A :|: B) F i) = + (\bigcap_(i in A) F i) :&: (\bigcap_(i in B) F i). +Proof. by apply: setC_inj; rewrite setCI !setC_bigcap bigcup_setU. Qed. + +Lemma bigcap_seq r F : \bigcap_(i <- r) F i = \bigcap_(i in r) F i. +Proof. by apply: setC_inj; rewrite !setC_bigcap bigcup_seq. Qed. + +End BigSetOps. + +Implicit Arguments bigcup_sup [T I P F]. +Implicit Arguments bigcup_max [T I U P F]. +Implicit Arguments bigcupP [T I x P F]. +Implicit Arguments bigcupsP [T I U P F]. +Implicit Arguments bigcap_inf [T I P F]. +Implicit Arguments bigcap_min [T I U P F]. +Implicit Arguments bigcapP [T I x P F]. +Implicit Arguments bigcapsP [T I U P F]. +Prenex Implicits bigcupP bigcupsP bigcapP bigcapsP. + +Section ImsetCurry. + +Variables (aT1 aT2 rT : finType) (f : aT1 -> aT2 -> rT). + +Section Curry. + +Variables (A1 : {set aT1}) (A2 : {set aT2}). +Variables (D1 : pred aT1) (D2 : pred aT2). + +Lemma curry_imset2X : f @2: (A1, A2) = prod_curry f @: (setX A1 A2). +Proof. +rewrite [@imset]unlock unlock; apply/setP=> x; rewrite !in_set; congr (x \in _). +by apply: eq_image => u //=; rewrite !inE. +Qed. + +Lemma curry_imset2l : f @2: (D1, D2) = \bigcup_(x1 in D1) f x1 @: D2. +Proof. +apply/setP=> y; apply/imset2P/bigcupP => [[x1 x2 Dx1 Dx2 ->{y}] | [x1 Dx1]]. + by exists x1; rewrite // mem_imset. +by case/imsetP=> x2 Dx2 ->{y}; exists x1 x2. +Qed. + +Lemma curry_imset2r : f @2: (D1, D2) = \bigcup_(x2 in D2) f^~ x2 @: D1. +Proof. +apply/setP=> y; apply/imset2P/bigcupP => [[x1 x2 Dx1 Dx2 ->{y}] | [x2 Dx2]]. + by exists x2; rewrite // (mem_imset (f^~ x2)). +by case/imsetP=> x1 Dx1 ->{y}; exists x1 x2. +Qed. + +End Curry. + +Lemma imset2Ul (A B : {set aT1}) (C : {set aT2}) : + f @2: (A :|: B, C) = f @2: (A, C) :|: f @2: (B, C). +Proof. by rewrite !curry_imset2l bigcup_setU. Qed. + +Lemma imset2Ur (A : {set aT1}) (B C : {set aT2}) : + f @2: (A, B :|: C) = f @2: (A, B) :|: f @2: (A, C). +Proof. by rewrite !curry_imset2r bigcup_setU. Qed. + +End ImsetCurry. + +Section Partitions. + +Variables T I : finType. +Implicit Types (x y z : T) (A B D X : {set T}) (P Q : {set {set T}}). +Implicit Types (J : pred I) (F : I -> {set T}). + +Definition cover P := \bigcup_(B in P) B. +Definition pblock P x := odflt set0 (pick [pred B in P | x \in B]). +Definition trivIset P := \sum_(B in P) #|B| == #|cover P|. +Definition partition P D := [&& cover P == D, trivIset P & set0 \notin P]. + +Definition is_transversal X P D := + [&& partition P D, X \subset D & [forall B in P, #|X :&: B| == 1]]. +Definition transversal P D := [set odflt x [pick y in pblock P x] | x in D]. +Definition transversal_repr x0 X B := odflt x0 [pick x in X :&: B]. + +Lemma leq_card_setU A B : #|A :|: B| <= #|A| + #|B| ?= iff [disjoint A & B]. +Proof. +rewrite -(addn0 #|_|) -setI_eq0 -cards_eq0 -cardsUI eq_sym. +by rewrite (mono_leqif (leq_add2l _)). +Qed. + +Lemma leq_card_cover P : #|cover P| <= \sum_(A in P) #|A| ?= iff trivIset P. +Proof. +split; last exact: eq_sym. +rewrite /cover; elim/big_rec2: _ => [|A n U _ leUn]; first by rewrite cards0. +by rewrite (leq_trans (leq_card_setU A U).1) ?leq_add2l. +Qed. + +Lemma trivIsetP P : + reflect {in P &, forall A B, A != B -> [disjoint A & B]} (trivIset P). +Proof. +have->: P = [set x in enum (mem P)] by apply/setP=> x; rewrite inE mem_enum. +elim: {P}(enum _) (enum_uniq (mem P)) => [_ | A e IHe] /=. + by rewrite /trivIset /cover !big_set0 cards0; left=> A; rewrite inE. +case/andP; rewrite set_cons -(in_set (fun B => B \in e)) => PA {IHe}/IHe. +move: {e}[set x in e] PA => P PA IHP. +rewrite /trivIset /cover !big_setU1 //= eq_sym. +have:= leq_card_cover P; rewrite -(mono_leqif (leq_add2l #|A|)). +move/(leqif_trans (leq_card_setU _ _))->; rewrite disjoints_subset setC_bigcup. +case: bigcapsP => [disjA | meetA]; last first. + right=> [tI]; case: meetA => B PB; rewrite -disjoints_subset. + by rewrite tI ?setU11 ?setU1r //; apply: contraNneq PA => ->. +apply: (iffP IHP) => [] tI B C PB PC; last by apply: tI; exact: setU1r. +by case/setU1P: PC PB => [->|PC] /setU1P[->|PB]; try by [exact: tI | case/eqP]; + first rewrite disjoint_sym; rewrite disjoints_subset disjA. +Qed. + +Lemma trivIsetS P Q : P \subset Q -> trivIset Q -> trivIset P. +Proof. by move/subsetP/sub_in2=> sPQ /trivIsetP/sPQ/trivIsetP. Qed. + +Lemma trivIsetI P D : trivIset P -> trivIset (P ::&: D). +Proof. by apply: trivIsetS; rewrite -setI_powerset subsetIl. Qed. + +Lemma cover_setI P D : cover (P ::&: D) \subset cover P :&: D. +Proof. +by apply/bigcupsP=> A /setIdP[PA sAD]; rewrite subsetI sAD andbT (bigcup_max A). +Qed. + +Lemma mem_pblock P x : (x \in pblock P x) = (x \in cover P). +Proof. +rewrite /pblock; apply/esym/bigcupP. +case: pickP => /= [A /andP[PA Ax]| noA]; first by rewrite Ax; exists A. +by rewrite inE => [[A PA Ax]]; case/andP: (noA A). +Qed. + +Lemma pblock_mem P x : x \in cover P -> pblock P x \in P. +Proof. +by rewrite -mem_pblock /pblock; case: pickP => [A /andP[]| _] //=; rewrite inE. +Qed. + +Lemma def_pblock P B x : trivIset P -> B \in P -> x \in B -> pblock P x = B. +Proof. +move/trivIsetP=> tiP PB Bx; have Px: x \in cover P by apply/bigcupP; exists B. +apply: (contraNeq (tiP _ _ _ PB)); first by rewrite pblock_mem. +by apply/pred0Pn; exists x; rewrite /= mem_pblock Px. +Qed. + +Lemma same_pblock P x y : + trivIset P -> x \in pblock P y -> pblock P x = pblock P y. +Proof. +rewrite {1 3}/pblock => tI; case: pickP => [A|]; last by rewrite inE. +by case/andP=> PA _{y} /= Ax; exact: def_pblock. +Qed. + +Lemma eq_pblock P x y : + trivIset P -> x \in cover P -> + (pblock P x == pblock P y) = (y \in pblock P x). +Proof. +move=> tiP Px; apply/eqP/idP=> [eq_xy | /same_pblock-> //]. +move: Px; rewrite -mem_pblock eq_xy /pblock. +by case: pickP => [B /andP[] // | _]; rewrite inE. +Qed. + +Lemma trivIsetU1 A P : + {in P, forall B, [disjoint A & B]} -> trivIset P -> set0 \notin P -> + trivIset (A |: P) /\ A \notin P. +Proof. +move=> tiAP tiP notPset0; split; last first. + apply: contra notPset0 => P_A. + by have:= tiAP A P_A; rewrite -setI_eq0 setIid => /eqP <-. +apply/trivIsetP=> B1 B2 /setU1P[->|PB1] /setU1P[->|PB2]; + by [exact: (trivIsetP _ tiP) | rewrite ?eqxx // ?(tiAP, disjoint_sym)]. +Qed. + +Lemma cover_imset J F : cover (F @: J) = \bigcup_(i in J) F i. +Proof. +apply/setP=> x. +apply/bigcupP/bigcupP=> [[_ /imsetP[i Ji ->]] | [i]]; first by exists i. +by exists (F i); first exact: mem_imset. +Qed. + +Lemma trivIimset J F (P := F @: J) : + {in J &, forall i j, j != i -> [disjoint F i & F j]} -> set0 \notin P -> + trivIset P /\ {in J &, injective F}. +Proof. +move=> tiF notPset0; split=> [|i j Ji Jj /= eqFij]. + apply/trivIsetP=> _ _ /imsetP[i Ji ->] /imsetP[j Jj ->] neqFij. + by rewrite tiF // (contraNneq _ neqFij) // => ->. +apply: contraNeq notPset0 => neq_ij; apply/imsetP; exists i => //; apply/eqP. +by rewrite eq_sym -[F i]setIid setI_eq0 {1}eqFij tiF. +Qed. + +Lemma cover_partition P D : partition P D -> cover P = D. +Proof. by case/and3P=> /eqP. Qed. + +Lemma card_partition P D : partition P D -> #|D| = \sum_(A in P) #|A|. +Proof. by case/and3P=> /eqP <- /eqnP. Qed. + +Lemma card_uniform_partition n P D : + {in P, forall A, #|A| = n} -> partition P D -> #|D| = #|P| * n. +Proof. +by move=> uniP /card_partition->; rewrite -sum_nat_const; exact: eq_bigr. +Qed. + +Section BigOps. + +Variables (R : Type) (idx : R) (op : Monoid.com_law idx). +Let rhs_cond P K E := \big[op/idx]_(A in P) \big[op/idx]_(x in A | K x) E x. +Let rhs P E := \big[op/idx]_(A in P) \big[op/idx]_(x in A) E x. + +Lemma big_trivIset_cond P (K : pred T) (E : T -> R) : + trivIset P -> \big[op/idx]_(x in cover P | K x) E x = rhs_cond P K E. +Proof. +move=> tiP; rewrite (partition_big (pblock P) (mem P)) -/op => /= [|x]. + apply: eq_bigr => A PA; apply: eq_bigl => x; rewrite andbAC; congr (_ && _). + rewrite -mem_pblock; apply/andP/idP=> [[Px /eqP <- //] | Ax]. + by rewrite (def_pblock tiP PA Ax). +by case/andP=> Px _; exact: pblock_mem. +Qed. + +Lemma big_trivIset P (E : T -> R) : + trivIset P -> \big[op/idx]_(x in cover P) E x = rhs P E. +Proof. +have biginT := eq_bigl _ _ (fun _ => andbT _) => tiP. +by rewrite -biginT big_trivIset_cond //; apply: eq_bigr => A _; exact: biginT. +Qed. + +Lemma set_partition_big_cond P D (K : pred T) (E : T -> R) : + partition P D -> \big[op/idx]_(x in D | K x) E x = rhs_cond P K E. +Proof. by case/and3P=> /eqP <- tI_P _; exact: big_trivIset_cond. Qed. + +Lemma set_partition_big P D (E : T -> R) : + partition P D -> \big[op/idx]_(x in D) E x = rhs P E. +Proof. by case/and3P=> /eqP <- tI_P _; exact: big_trivIset. Qed. + +Lemma partition_disjoint_bigcup (F : I -> {set T}) E : + (forall i j, i != j -> [disjoint F i & F j]) -> + \big[op/idx]_(x in \bigcup_i F i) E x = + \big[op/idx]_i \big[op/idx]_(x in F i) E x. +Proof. +move=> disjF; pose P := [set F i | i in I & F i != set0]. +have trivP: trivIset P. + apply/trivIsetP=> _ _ /imsetP[i _ ->] /imsetP[j _ ->] neqFij. + by apply: disjF; apply: contraNneq neqFij => ->. +have ->: \bigcup_i F i = cover P. + apply/esym; rewrite cover_imset big_mkcond; apply: eq_bigr => i _. + by rewrite inE; case: eqP. +rewrite big_trivIset // /rhs big_imset => [|i j _ /setIdP[_ notFj0] eqFij]. + rewrite big_mkcond; apply: eq_bigr => i _; rewrite inE. + by case: eqP => //= ->; rewrite big_set0. +by apply: contraNeq (disjF _ _) _; rewrite -setI_eq0 eqFij setIid. +Qed. + +End BigOps. + +Section Equivalence. + +Variables (R : rel T) (D : {set T}). + +Let Px x := [set y in D | R x y]. +Definition equivalence_partition := [set Px x | x in D]. +Local Notation P := equivalence_partition. +Hypothesis eqiR : {in D & &, equivalence_rel R}. + +Let Pxx x : x \in D -> x \in Px x. +Proof. by move=> Dx; rewrite !inE Dx (eqiR Dx Dx). Qed. +Let PPx x : x \in D -> Px x \in P := fun Dx => mem_imset _ Dx. + +Lemma equivalence_partitionP : partition P D. +Proof. +have defD: cover P == D. + rewrite eqEsubset; apply/andP; split. + by apply/bigcupsP=> _ /imsetP[x Dx ->]; rewrite /Px setIdE subsetIl. + by apply/subsetP=> x Dx; apply/bigcupP; exists (Px x); rewrite (Pxx, PPx). +have tiP: trivIset P. + apply/trivIsetP=> _ _ /imsetP[x Dx ->] /imsetP[y Dy ->]; apply: contraR. + case/pred0Pn=> z /andP[]; rewrite !inE => /andP[Dz Rxz] /andP[_ Ryz]. + apply/eqP/setP=> t; rewrite !inE; apply: andb_id2l => Dt. + by rewrite (eqiR Dx Dz Dt) // (eqiR Dy Dz Dt). +rewrite /partition tiP defD /=. +by apply/imsetP=> [[x /Pxx Px_x Px0]]; rewrite -Px0 inE in Px_x. +Qed. + +Lemma pblock_equivalence_partition : + {in D &, forall x y, (y \in pblock P x) = R x y}. +Proof. +have [_ tiP _] := and3P equivalence_partitionP. +by move=> x y Dx Dy; rewrite /= (def_pblock tiP (PPx Dx) (Pxx Dx)) inE Dy. +Qed. + +End Equivalence. + +Lemma pblock_equivalence P D : + partition P D -> {in D & &, equivalence_rel (fun x y => y \in pblock P x)}. +Proof. +case/and3P=> /eqP <- tiP _ x y z Px Py Pz. +by rewrite mem_pblock; split=> // /same_pblock->. +Qed. + +Lemma equivalence_partition_pblock P D : + partition P D -> equivalence_partition (fun x y => y \in pblock P x) D = P. +Proof. +case/and3P=> /eqP <-{D} tiP notP0; apply/setP=> B /=; set D := cover P. +have defP x: x \in D -> [set y in D | y \in pblock P x] = pblock P x. + by move=> Dx; apply/setIidPr; rewrite (bigcup_max (pblock P x)) ?pblock_mem. +apply/imsetP/idP=> [[x Px ->{B}] | PB]; first by rewrite defP ?pblock_mem. +have /set0Pn[x Bx]: B != set0 := memPn notP0 B PB. +have Px: x \in cover P by apply/bigcupP; exists B. +by exists x; rewrite // defP // (def_pblock tiP PB Bx). +Qed. + +Section Preim. + +Variables (rT : eqType) (f : T -> rT). + +Definition preim_partition := equivalence_partition (fun x y => f x == f y). + +Lemma preim_partitionP D : partition (preim_partition D) D. +Proof. by apply/equivalence_partitionP; split=> // /eqP->. Qed. + +End Preim. + +Lemma preim_partition_pblock P D : + partition P D -> preim_partition (pblock P) D = P. +Proof. +move=> partP; have [/eqP defD tiP _] := and3P partP. +rewrite -{2}(equivalence_partition_pblock partP); apply: eq_in_imset => x Dx. +by apply/setP=> y; rewrite !inE eq_pblock ?defD. +Qed. + +Lemma transversalP P D : partition P D -> is_transversal (transversal P D) P D. +Proof. +case/and3P=> /eqP <- tiP notP0; apply/and3P; split; first exact/and3P. + apply/subsetP=> _ /imsetP[x Px ->]; case: pickP => //= y Pxy. + by apply/bigcupP; exists (pblock P x); rewrite ?pblock_mem //. +apply/forall_inP=> B PB; have /set0Pn[x Bx]: B != set0 := memPn notP0 B PB. +apply/cards1P; exists (odflt x [pick y in pblock P x]); apply/esym/eqP. +rewrite eqEsubset sub1set inE -andbA; apply/andP; split. + by apply/mem_imset/bigcupP; exists B. +rewrite (def_pblock tiP PB Bx); case def_y: _ / pickP => [y By | /(_ x)/idP//]. +rewrite By /=; apply/subsetP=> _ /setIP[/imsetP[z Pz ->]]. +case: {1}_ / pickP => [t zPt Bt | /(_ z)/idP[]]; last by rewrite mem_pblock. +by rewrite -(same_pblock tiP zPt) (def_pblock tiP PB Bt) def_y set11. +Qed. + +Section Transversals. + +Variables (X : {set T}) (P : {set {set T}}) (D : {set T}). +Hypothesis trPX : is_transversal X P D. + +Lemma transversal_sub : X \subset D. Proof. by case/and3P: trPX. Qed. + +Let tiP : trivIset P. Proof. by case/andP: trPX => /and3P[]. Qed. + +Let sXP : {subset X <= cover P}. +Proof. by case/and3P: trPX => /andP[/eqP-> _] /subsetP. Qed. + +Let trX : {in P, forall B, #|X :&: B| == 1}. +Proof. by case/and3P: trPX => _ _ /forall_inP. Qed. + +Lemma setI_transversal_pblock x0 B : + B \in P -> X :&: B = [set transversal_repr x0 X B]. +Proof. +by case/trX/cards1P=> x defXB; rewrite /transversal_repr defXB /pick enum_set1. +Qed. + +Lemma repr_mem_pblock x0 B : B \in P -> transversal_repr x0 X B \in B. +Proof. by move=> PB; rewrite -sub1set -setI_transversal_pblock ?subsetIr. Qed. + +Lemma repr_mem_transversal x0 B : B \in P -> transversal_repr x0 X B \in X. +Proof. by move=> PB; rewrite -sub1set -setI_transversal_pblock ?subsetIl. Qed. + +Lemma transversal_reprK x0 : {in P, cancel (transversal_repr x0 X) (pblock P)}. +Proof. by move=> B PB; rewrite /= (def_pblock tiP PB) ?repr_mem_pblock. Qed. + +Lemma pblockK x0 : {in X, cancel (pblock P) (transversal_repr x0 X)}. +Proof. +move=> x Xx; have /bigcupP[B PB Bx] := sXP Xx; rewrite (def_pblock tiP PB Bx). +by apply/esym/set1P; rewrite -setI_transversal_pblock // inE Xx. +Qed. + +Lemma pblock_inj : {in X &, injective (pblock P)}. +Proof. by move=> x0; exact: (can_in_inj (pblockK x0)). Qed. + +Lemma pblock_transversal : pblock P @: X = P. +Proof. +apply/setP=> B; apply/imsetP/idP=> [[x Xx ->] | PB]. + by rewrite pblock_mem ?sXP. +have /cards1P[x0 _] := trX PB; set x := transversal_repr x0 X B. +by exists x; rewrite ?transversal_reprK ?repr_mem_transversal. +Qed. + +Lemma card_transversal : #|X| = #|P|. +Proof. rewrite -pblock_transversal card_in_imset //; exact: pblock_inj. Qed. + +Lemma im_transversal_repr x0 : transversal_repr x0 X @: P = X. +Proof. +rewrite -{2}[X]imset_id -pblock_transversal -imset_comp. +by apply: eq_in_imset; exact: pblockK. +Qed. + +End Transversals. + +End Partitions. + +Implicit Arguments trivIsetP [T P]. +Implicit Arguments big_trivIset_cond [T R idx op K E]. +Implicit Arguments set_partition_big_cond [T R idx op D K E]. +Implicit Arguments big_trivIset [T R idx op E]. +Implicit Arguments set_partition_big [T R idx op D E]. + +Prenex Implicits cover trivIset partition pblock trivIsetP. + +Lemma partition_partition (T : finType) (D : {set T}) P Q : + partition P D -> partition Q P -> + partition (cover @: Q) D /\ {in Q &, injective cover}. +Proof. +move=> /and3P[/eqP defG tiP notP0] /and3P[/eqP defP tiQ notQ0]. +have sQP E: E \in Q -> {subset E <= P}. + by move=> Q_E; apply/subsetP; rewrite -defP (bigcup_max E). +rewrite /partition cover_imset -(big_trivIset _ tiQ) defP -defG eqxx /= andbC. +have{notQ0} notQ0: set0 \notin cover @: Q. + apply: contra notP0 => /imsetP[E Q_E E0]. + have /set0Pn[/= A E_A] := memPn notQ0 E Q_E. + congr (_ \in P): (sQP E Q_E A E_A). + by apply/eqP; rewrite -subset0 E0 (bigcup_max A). +rewrite notQ0; apply: trivIimset => // E F Q_E Q_F. +apply: contraR => /pred0Pn[x /andP[/bigcupP[A E_A Ax] /bigcupP[B F_B Bx]]]. +rewrite -(def_pblock tiQ Q_E E_A) -(def_pblock tiP _ Ax) ?(sQP E) //. +by rewrite -(def_pblock tiQ Q_F F_B) -(def_pblock tiP _ Bx) ?(sQP F). +Qed. + +(**********************************************************************) +(* *) +(* Maximum and minimun (sub)set with respect to a given pred *) +(* *) +(**********************************************************************) + +Section MaxSetMinSet. + +Variable T : finType. +Notation sT := {set T}. +Implicit Types A B C : sT. +Implicit Type P : pred sT. + +Definition minset P A := [forall (B : sT | B \subset A), (B == A) == P B]. + +Lemma minset_eq P1 P2 A : P1 =1 P2 -> minset P1 A = minset P2 A. +Proof. by move=> eP12; apply: eq_forallb => B; rewrite eP12. Qed. + +Lemma minsetP P A : + reflect ((P A) /\ (forall B, P B -> B \subset A -> B = A)) (minset P A). +Proof. +apply: (iffP forallP) => [minA | [PA minA] B]. + split; first by have:= minA A; rewrite subxx eqxx /= => /eqP. + by move=> B PB sBA; have:= minA B; rewrite PB sBA /= eqb_id => /eqP. +by apply/implyP=> sBA; apply/eqP; apply/eqP/idP=> [-> // | /minA]; exact. +Qed. +Implicit Arguments minsetP [P A]. + +Lemma minsetp P A : minset P A -> P A. +Proof. by case/minsetP. Qed. + +Lemma minsetinf P A B : minset P A -> P B -> B \subset A -> B = A. +Proof. by case/minsetP=> _; exact. Qed. + +Lemma ex_minset P : (exists A, P A) -> {A | minset P A}. +Proof. +move=> exP; pose pS n := [pred B | P B & #|B| == n]. +pose p n := ~~ pred0b (pS n); have{exP}: exists n, p n. + by case: exP => A PA; exists #|A|; apply/existsP; exists A; rewrite /= PA /=. +case/ex_minnP=> n /pred0P; case: (pickP (pS n)) => // A /andP[PA] /eqP <-{n} _. +move=> minA; exists A => //; apply/minsetP; split=> // B PB sBA; apply/eqP. +by rewrite eqEcard sBA minA //; apply/pred0Pn; exists B; rewrite /= PB /=. +Qed. + +Lemma minset_exists P C : P C -> {A | minset P A & A \subset C}. +Proof. +move=> PC; have{PC}: exists A, P A && (A \subset C) by exists C; rewrite PC /=. +case/ex_minset=> A /minsetP[/andP[PA sAC] minA]; exists A => //; apply/minsetP. +by split=> // B PB sBA; rewrite (minA B) // PB (subset_trans sBA). +Qed. + +(* The 'locked_with' allows Coq to find the value of P by unification. *) +Fact maxset_key : unit. Proof. by []. Qed. +Definition maxset P A := + minset (fun B => locked_with maxset_key P (~: B)) (~: A). + +Lemma maxset_eq P1 P2 A : P1 =1 P2 -> maxset P1 A = maxset P2 A. +Proof. by move=> eP12; apply: minset_eq => x /=; rewrite !unlock_with eP12. Qed. + +Lemma maxminset P A : maxset P A = minset [pred B | P (~: B)] (~: A). +Proof. by rewrite /maxset unlock. Qed. + +Lemma minmaxset P A : minset P A = maxset [pred B | P (~: B)] (~: A). +Proof. +by rewrite /maxset unlock setCK; apply: minset_eq => B /=; rewrite setCK. +Qed. + +Lemma maxsetP P A : + reflect ((P A) /\ (forall B, P B -> A \subset B -> B = A)) (maxset P A). +Proof. +apply: (iffP minsetP); rewrite ?setCK unlock_with => [] [PA minA]. + by split=> // B PB sAB; rewrite -[B]setCK [~: B]minA (setCK, setCS). +by split=> // B PB' sBA'; rewrite -(minA _ PB') -1?setCS setCK. +Qed. + +Lemma maxsetp P A : maxset P A -> P A. +Proof. by case/maxsetP. Qed. + +Lemma maxsetsup P A B : maxset P A -> P B -> A \subset B -> B = A. +Proof. by case/maxsetP=> _; exact. Qed. + +Lemma ex_maxset P : (exists A, P A) -> {A | maxset P A}. +Proof. +move=> exP; have{exP}: exists A, P (~: A). + by case: exP => A PA; exists (~: A); rewrite setCK. +by case/ex_minset=> A minA; exists (~: A); rewrite /maxset unlock setCK. +Qed. + +Lemma maxset_exists P C : P C -> {A : sT | maxset P A & C \subset A}. +Proof. +move=> PC; pose P' B := P (~: B); have: P' (~: C) by rewrite /P' setCK. +case/minset_exists=> B; rewrite -[B]setCK setCS. +by exists (~: B); rewrite // /maxset unlock. +Qed. + +End MaxSetMinSet. + +Implicit Arguments minsetP [T P A]. +Implicit Arguments maxsetP [T P A]. +Prenex Implicits minset maxset minsetP maxsetP. + diff --git a/mathcomp/discrete/fintype.v b/mathcomp/discrete/fintype.v new file mode 100644 index 0000000..63d5e84 --- /dev/null +++ b/mathcomp/discrete/fintype.v @@ -0,0 +1,2037 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice. + +(******************************************************************************) +(* The Finite interface describes Types with finitely many elements, *) +(* supplying a duplicate-free sequence of all the elements. It is a subclass *) +(* of Countable and thus of Choice and Equality. As with Countable, the *) +(* interface explicitly includes these somewhat redundant superclasses to *) +(* ensure that Canonical instance inference remains consistent. Finiteness *) +(* could be stated more simply by bounding the range of the pickle function *) +(* supplied by the Countable interface, but this would yield a useless *) +(* computational interpretation due to the wasteful Peano integer encodings. *) +(* Because the Countable interface is closely tied to the Finite interface *) +(* and is not much used on its own, the Countable mixin is included inside *) +(* the Finite mixin; this makes it much easier to derive Finite variants of *) +(* interfaces, in this file for subFinType, and in the finalg library. *) +(* We define the following interfaces and structures: *) +(* finType == the packed class type of the Finite interface. *) +(* FinType m == the packed class for the Finite mixin m. *) +(* Finite.axiom e == every x : T occurs exactly once in e : seq T. *) +(* FinMixin ax_e == the Finite mixin for T, encapsulating *) +(* ax_e : Finite.axiom e for some e : seq T. *) +(* UniqFinMixin uniq_e total_e == an alternative mixin constructor that uses *) +(* uniq_e : uniq e and total_e : e =i xpredT. *) +(* PcanFinMixin fK == the Finite mixin for T, given f : T -> fT and g with fT *) +(* a finType and fK : pcancel f g. *) +(* CanFinMixin fK == the Finite mixin for T, given f : T -> fT and g with fT *) +(* a finType and fK : cancel f g. *) +(* subFinType == the join interface type for subType and finType. *) +(* [finType of T for fT] == clone for T of the finType fT. *) +(* [finType of T] == clone for T of the finType inferred for T. *) +(* [subFinType of T] == a subFinType structure for T, when T already has both *) +(* finType and subType structures. *) +(* [finMixin of T by <:] == a finType structure for T, when T has a subType *) +(* structure over an existing finType. *) +(* We define or propagate the finType structure appropriately for all basic *) +(* basic types : unit, bool, option, prod, sum, sig and sigT. We also define *) +(* a generic type constructor for finite subtypes based on an explicit *) +(* enumeration: *) +(* seq_sub s == the subType of all x \in s, where s : seq T and T has *) +(* a choiceType structure; the seq_sub s type has a *) +(* canonical finType structure. *) +(* Bounded integers are supported by the following type and operations: *) +(* 'I_n, ordinal n == the finite subType of integers i < n, whose *) +(* enumeration is {0, ..., n.-1}. 'I_n coerces to nat, *) +(* so all the integer arithmetic functions can be used *) +(* with 'I_n. *) +(* Ordinal lt_i_n == the element of 'I_n with (nat) value i, given *) +(* lt_i_n : i < n. *) +(* nat_of_ord i == the nat value of i : 'I_n (this function is a *) +(* coercion so it is not usually displayed). *) +(* ord_enum n == the explicit increasing sequence of the i : 'I_n. *) +(* cast_ord eq_n_m i == the element j : 'I_m with the same value as i : 'I_n *) +(* given eq_n_m : n = m (indeed, i : nat and j : nat *) +(* are convertible). *) +(* widen_ord le_n_m i == a j : 'I_m with the same value as i : 'I_n, given *) +(* le_n_m : n <= m. *) +(* rev_ord i == the complement to n.-1 of i : 'I_n, such that *) +(* i + rev_ord i = n.-1. *) +(* inord k == the i : 'I_n.+1 with value k (n is inferred from the *) +(* context). *) +(* sub_ord k == the i : 'I_n.+1 with value n - k (n is inferred from *) +(* the context). *) +(* ord0 == the i : 'I_n.+1 with value 0 (n is inferred from the *) +(* context). *) +(* ord_max == the i : 'I_n.+1 with value n (n is inferred from the *) +(* context). *) +(* bump h k == k.+1 if k >= h, else k (this is a nat function). *) +(* unbump h k == k.-1 if k > h, else k (this is a nat function). *) +(* lift i j == the j' : 'I_n with value bump i j, where i : 'I_n *) +(* and j : 'I_n.-1. *) +(* unlift i j == None if i = j, else Some j', where j' : 'I_n.-1 has *) +(* value unbump i j, given i, j : 'I_n. *) +(* lshift n j == the i : 'I_(m + n) with value j : 'I_m. *) +(* rshift m k == the i : 'I_(m + n) with value m + k, k : 'I_n. *) +(* unsplit u == either lshift n j or rshift m k, depending on *) +(* whether if u : 'I_m + 'I_n is inl j or inr k. *) +(* split i == the u : 'I_m + 'I_n such that i = unsplit u; the *) +(* type 'I_(m + n) of i determines the split. *) +(* Finally, every type T with a finType structure supports the following *) +(* operations: *) +(* enum A == a duplicate-free list of all the x \in A, where A is a *) +(* collective predicate over T. *) +(* #|A| == the cardinal of A, i.e., the number of x \in A. *) +(* enum_val i == the i'th item of enum A, where i : 'I_(#|A|). *) +(* enum_rank x == the i : 'I_(#|T|) such that enum_val i = x. *) +(* enum_rank_in Ax0 x == some i : 'I_(#|A|) such that enum_val i = x if *) +(* x \in A, given Ax0 : x0 \in A. *) +(* A \subset B == all x \in A satisfy x \in B. *) +(* A \proper B == all x \in A satisfy x \in B but not the converse. *) +(* [disjoint A & B] == no x \in A satisfies x \in B. *) +(* image f A == the sequence of f x for all x : T such that x \in A *) +(* (where a is an applicative predicate), of length #|P|. *) +(* The codomain of F can be any type, but image f A can *) +(* only be used as a collective predicate is it is an *) +(* eqType. *) +(* codom f == a sequence spanning the codomain of f (:= image f T). *) +(* [seq F | x : T in A] := image (fun x : T => F) A. *) +(* [seq F | x : T] := [seq F | x <- {: T}]. *) +(* [seq F | x in A], [seq F | x] == variants without casts. *) +(* iinv im_y == some x such that P x holds and f x = y, given *) +(* im_y : y \in image f P. *) +(* invF inj_f y == the x such that f x = y, for inj_j : injective f with *) +(* f : T -> T. *) +(* dinjectiveb A f == the restriction of f : T -> R to A is injective *) +(* (this is a bolean predicate, R must be an eqType). *) +(* injectiveb f == f : T -> R is injective (boolean predicate). *) +(* pred0b A == no x : T satisfies x \in A. *) +(* [forall x, P] == P (in which x can appear) is true for all values of x; *) +(* x must range over a finType. *) +(* [exists x, P] == P is true for some value of x. *) +(* [forall (x | C), P] := [forall x, C ==> P]. *) +(* [forall x in A, P] := [forall (x | x \in A), P]. *) +(* [exists (x | C), P] := [exists x, C && P]. *) +(* [exists x in A, P] := [exists (x | x \in A), P]. *) +(* and typed variants [forall x : T, P], [forall (x : T | C), P], *) +(* [exists x : T, P], [exists x : T in A, P], etc. *) +(* -> The outer brackets can be omitted when nesting finitary quantifiers, *) +(* e.g., [forall i in I, forall j in J, exists a, f i j == a]. *) +(* 'forall_pP == view for [forall x, p _], for pP : reflect .. (p _). *) +(* 'exists_pP == view for [exists x, p _], for pP : reflect .. (p _). *) +(* [pick x | P] == Some x, for an x such that P holds, or None if there *) +(* is no such x. *) +(* [pick x : T] == Some x with x : T, provided T is nonempty, else None. *) +(* [pick x in A] == Some x, with x \in A, or None if A is empty. *) +(* [pick x in A | P] == Some x, with x \in A s.t. P holds, else None. *) +(* [pick x | P & Q] := [pick x | P & Q]. *) +(* [pick x in A | P & Q] := [pick x | P & Q]. *) +(* and (un)typed variants [pick x : T | P], [pick x : T in A], [pick x], etc. *) +(* [arg min_(i < i0 | P) M] == a value of i : T minimizing M : nat, subject *) +(* to the condition P (i may appear in P and M), and *) +(* provided P holds for i0. *) +(* [arg max_(i > i0 | P) M] == a value of i maximizing M subject to P and *) +(* provided P holds for i0. *) +(* [arg min_(i < i0 in A) M] == an i \in A minimizing M if i0 \in A. *) +(* [arg max_(i > i0 in A) M] == an i \in A maximizing M if i0 \in A. *) +(* [arg min_(i < i0) M] == an i : T minimizing M, given i0 : T. *) +(* [arg max_(i > i0) M] == an i : T maximizing M, given i0 : T. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Module Finite. + +Section RawMixin. + +Variable T : eqType. + +Definition axiom e := forall x : T, count_mem x e = 1. + +Lemma uniq_enumP e : uniq e -> e =i T -> axiom e. +Proof. by move=> Ue sT x; rewrite count_uniq_mem ?sT. Qed. + +Record mixin_of := Mixin { + mixin_base : Countable.mixin_of T; + mixin_enum : seq T; + _ : axiom mixin_enum +}. + +End RawMixin. + +Section Mixins. + +Variable T : countType. + +Definition EnumMixin := + let: Countable.Pack _ (Countable.Class _ m) _ as cT := T + return forall e : seq cT, axiom e -> mixin_of cT in + @Mixin (EqType _ _) m. + +Definition UniqMixin e Ue eT := @EnumMixin e (uniq_enumP Ue eT). + +Variable n : nat. + +Definition count_enum := pmap (@pickle_inv T) (iota 0 n). + +Hypothesis ubT : forall x : T, pickle x < n. + +Lemma count_enumP : axiom count_enum. +Proof. +apply: uniq_enumP (pmap_uniq (@pickle_invK T) (iota_uniq _ _)) _ => x. +by rewrite mem_pmap -pickleK_inv map_f // mem_iota ubT. +Qed. + +Definition CountMixin := EnumMixin count_enumP. + +End Mixins. + +Section ClassDef. + +Record class_of T := Class { + base : Choice.class_of T; + mixin : mixin_of (Equality.Pack base T) +}. +Definition base2 T c := Countable.Class (@base T c) (mixin_base (mixin c)). +Local Coercion base : class_of >-> Choice.class_of. + +Structure type : 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. +Definition clone c of phant_id class c := @Pack T c T. +Let xT := let: Pack T _ _ := cT in T. +Notation xclass := (class : class_of xT). + +Definition pack b0 (m0 : mixin_of (EqType T b0)) := + fun bT b & phant_id (Choice.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 countType := @Countable.Pack cT (base2 xclass) xT. + +End ClassDef. + +Module Import Exports. +Coercion mixin_base : mixin_of >-> Countable.mixin_of. +Coercion base : class_of >-> Choice.class_of. +Coercion mixin : class_of >-> mixin_of. +Coercion base2 : class_of >-> Countable.class_of. +Coercion sort : type >-> Sortclass. +Coercion eqType : type >-> Equality.type. +Canonical eqType. +Coercion choiceType : type >-> Choice.type. +Canonical choiceType. +Coercion countType : type >-> Countable.type. +Canonical countType. +Notation finType := type. +Notation FinType T m := (@pack T _ m _ _ id _ id). +Notation FinMixin := EnumMixin. +Notation UniqFinMixin := UniqMixin. +Notation "[ 'finType' 'of' T 'for' cT ]" := (@clone T cT _ idfun) + (at level 0, format "[ 'finType' 'of' T 'for' cT ]") : form_scope. +Notation "[ 'finType' 'of' T ]" := (@clone T _ _ id) + (at level 0, format "[ 'finType' 'of' T ]") : form_scope. +End Exports. + +Module Type EnumSig. +Parameter enum : forall cT : type, seq cT. +Axiom enumDef : enum = fun cT => mixin_enum (class cT). +End EnumSig. + +Module EnumDef : EnumSig. +Definition enum cT := mixin_enum (class cT). +Definition enumDef := erefl enum. +End EnumDef. + +Notation enum := EnumDef.enum. + +End Finite. +Export Finite.Exports. + +Canonical finEnum_unlock := Unlockable Finite.EnumDef.enumDef. + +(* Workaround for the silly syntactic uniformity restriction on coercions; *) +(* this avoids a cross-dependency between finset.v and prime.v for the *) +(* definition of the \pi(A) notation. *) +Definition fin_pred_sort (T : finType) (pT : predType T) := pred_sort pT. +Identity Coercion pred_sort_of_fin : fin_pred_sort >-> pred_sort. + +Definition enum_mem T (mA : mem_pred _) := filter mA (Finite.enum T). +Notation enum A := (enum_mem (mem A)). +Definition pick (T : finType) (P : pred T) := ohead (enum P). + +Notation "[ 'pick' x | P ]" := (pick (fun x => P%B)) + (at level 0, x ident, format "[ 'pick' x | P ]") : form_scope. +Notation "[ 'pick' x : T | P ]" := (pick (fun x : T => P%B)) + (at level 0, x ident, only parsing) : form_scope. +Definition pick_true T (x : T) := true. +Notation "[ 'pick' x : T ]" := [pick x : T | pick_true x] + (at level 0, x ident, only parsing). +Notation "[ 'pick' x ]" := [pick x : _] + (at level 0, x ident, only parsing) : form_scope. +Notation "[ 'pic' 'k' x : T ]" := [pick x : T | pick_true _] + (at level 0, x ident, format "[ 'pic' 'k' x : T ]") : form_scope. +Notation "[ 'pick' x | P & Q ]" := [pick x | P && Q ] + (at level 0, x ident, + format "[ '[hv ' 'pick' x | P '/ ' & Q ] ']'") : form_scope. +Notation "[ 'pick' x : T | P & Q ]" := [pick x : T | P && Q ] + (at level 0, x ident, only parsing) : form_scope. +Notation "[ 'pick' x 'in' A ]" := [pick x | x \in A] + (at level 0, x ident, format "[ 'pick' x 'in' A ]") : form_scope. +Notation "[ 'pick' x : T 'in' A ]" := [pick x : T | x \in A] + (at level 0, x ident, only parsing) : form_scope. +Notation "[ 'pick' x 'in' A | P ]" := [pick x | x \in A & P ] + (at level 0, x ident, + format "[ '[hv ' 'pick' x 'in' A '/ ' | P ] ']'") : form_scope. +Notation "[ 'pick' x : T 'in' A | P ]" := [pick x : T | x \in A & P ] + (at level 0, x ident, only parsing) : form_scope. +Notation "[ 'pick' x 'in' A | P & Q ]" := [pick x in A | P && Q] + (at level 0, x ident, format + "[ '[hv ' 'pick' x 'in' A '/ ' | P '/ ' & Q ] ']'") : form_scope. +Notation "[ 'pick' x : T 'in' A | P & Q ]" := [pick x : T in A | P && Q] + (at level 0, x ident, only parsing) : form_scope. + +(* We lock the definitions of card and subset to mitigate divergence of the *) +(* Coq term comparison algorithm. *) + +Local Notation card_type := (forall T : finType, mem_pred T -> nat). +Local Notation card_def := (fun T mA => size (enum_mem mA)). +Module Type CardDefSig. +Parameter card : card_type. Axiom cardEdef : card = card_def. +End CardDefSig. +Module CardDef : CardDefSig. +Definition card : card_type := card_def. Definition cardEdef := erefl card. +End CardDef. +(* Should be Include, but for a silly restriction: can't Include at toplevel! *) +Export CardDef. + +Canonical card_unlock := Unlockable cardEdef. +(* A is at level 99 to allow the notation #|G : H| in groups. *) +Notation "#| A |" := (card (mem A)) + (at level 0, A at level 99, format "#| A |") : nat_scope. + +Definition pred0b (T : finType) (P : pred T) := #|P| == 0. +Prenex Implicits pred0b. + +Module FiniteQuant. + +CoInductive quantified := Quantified of bool. + +Delimit Scope fin_quant_scope with Q. (* Bogus, only used to declare scope. *) +Bind Scope fin_quant_scope with quantified. + +Notation "F ^*" := (Quantified F) (at level 2). +Notation "F ^~" := (~~ F) (at level 2). + +Section Definitions. + +Variable T : finType. +Implicit Types (B : quantified) (x y : T). + +Definition quant0b Bp := pred0b [pred x : T | let: F^* := Bp x x in F]. +(* The first redundant argument protects the notation from Coq's K-term *) +(* display kludge; the second protects it from simpl and /=. *) +Definition ex B x y := B. +(* Binding the predicate value rather than projecting it prevents spurious *) +(* unfolding of the boolean connectives by unification. *) +Definition all B x y := let: F^* := B in F^~^*. +Definition all_in C B x y := let: F^* := B in (C ==> F)^~^*. +Definition ex_in C B x y := let: F^* := B in (C && F)^*. + +End Definitions. + +Notation "[ x | B ]" := (quant0b (fun x => B x)) (at level 0, x ident). +Notation "[ x : T | B ]" := (quant0b (fun x : T => B x)) (at level 0, x ident). + +Module Exports. + +Notation ", F" := F^* (at level 200, format ", '/ ' F") : fin_quant_scope. + +Notation "[ 'forall' x B ]" := [x | all B] + (at level 0, x at level 99, B at level 200, + format "[ '[hv' 'forall' x B ] ']'") : bool_scope. + +Notation "[ 'forall' x : T B ]" := [x : T | all B] + (at level 0, x at level 99, B at level 200, only parsing) : bool_scope. +Notation "[ 'forall' ( x | C ) B ]" := [x | all_in C B] + (at level 0, x at level 99, B at level 200, + format "[ '[hv' '[' 'forall' ( x '/ ' | C ) ']' B ] ']'") : bool_scope. +Notation "[ 'forall' ( x : T | C ) B ]" := [x : T | all_in C B] + (at level 0, x at level 99, B at level 200, only parsing) : bool_scope. +Notation "[ 'forall' x 'in' A B ]" := [x | all_in (x \in A) B] + (at level 0, x at level 99, B at level 200, + format "[ '[hv' '[' 'forall' x '/ ' 'in' A ']' B ] ']'") : bool_scope. +Notation "[ 'forall' x : T 'in' A B ]" := [x : T | all_in (x \in A) B] + (at level 0, x at level 99, B at level 200, only parsing) : bool_scope. +Notation ", 'forall' x B" := [x | all B]^* + (at level 200, x at level 99, B at level 200, + format ", '/ ' 'forall' x B") : fin_quant_scope. +Notation ", 'forall' x : T B" := [x : T | all B]^* + (at level 200, x at level 99, B at level 200, only parsing) : fin_quant_scope. +Notation ", 'forall' ( x | C ) B" := [x | all_in C B]^* + (at level 200, x at level 99, B at level 200, + format ", '/ ' '[' 'forall' ( x '/ ' | C ) ']' B") : fin_quant_scope. +Notation ", 'forall' ( x : T | C ) B" := [x : T | all_in C B]^* + (at level 200, x at level 99, B at level 200, only parsing) : fin_quant_scope. +Notation ", 'forall' x 'in' A B" := [x | all_in (x \in A) B]^* + (at level 200, x at level 99, B at level 200, + format ", '/ ' '[' 'forall' x '/ ' 'in' A ']' B") : bool_scope. +Notation ", 'forall' x : T 'in' A B" := [x : T | all_in (x \in A) B]^* + (at level 200, x at level 99, B at level 200, only parsing) : bool_scope. + +Notation "[ 'exists' x B ]" := [x | ex B]^~ + (at level 0, x at level 99, B at level 200, + format "[ '[hv' 'exists' x B ] ']'") : bool_scope. +Notation "[ 'exists' x : T B ]" := [x : T | ex B]^~ + (at level 0, x at level 99, B at level 200, only parsing) : bool_scope. +Notation "[ 'exists' ( x | C ) B ]" := [x | ex_in C B]^~ + (at level 0, x at level 99, B at level 200, + format "[ '[hv' '[' 'exists' ( x '/ ' | C ) ']' B ] ']'") : bool_scope. +Notation "[ 'exists' ( x : T | C ) B ]" := [x : T | ex_in C B]^~ + (at level 0, x at level 99, B at level 200, only parsing) : bool_scope. +Notation "[ 'exists' x 'in' A B ]" := [x | ex_in (x \in A) B]^~ + (at level 0, x at level 99, B at level 200, + format "[ '[hv' '[' 'exists' x '/ ' 'in' A ']' B ] ']'") : bool_scope. +Notation "[ 'exists' x : T 'in' A B ]" := [x : T | ex_in (x \in A) B]^~ + (at level 0, x at level 99, B at level 200, only parsing) : bool_scope. +Notation ", 'exists' x B" := [x | ex B]^~^* + (at level 200, x at level 99, B at level 200, + format ", '/ ' 'exists' x B") : fin_quant_scope. +Notation ", 'exists' x : T B" := [x : T | ex B]^~^* + (at level 200, x at level 99, B at level 200, only parsing) : fin_quant_scope. +Notation ", 'exists' ( x | C ) B" := [x | ex_in C B]^~^* + (at level 200, x at level 99, B at level 200, + format ", '/ ' '[' 'exists' ( x '/ ' | C ) ']' B") : fin_quant_scope. +Notation ", 'exists' ( x : T | C ) B" := [x : T | ex_in C B]^~^* + (at level 200, x at level 99, B at level 200, only parsing) : fin_quant_scope. +Notation ", 'exists' x 'in' A B" := [x | ex_in (x \in A) B]^~^* + (at level 200, x at level 99, B at level 200, + format ", '/ ' '[' 'exists' x '/ ' 'in' A ']' B") : bool_scope. +Notation ", 'exists' x : T 'in' A B" := [x : T | ex_in (x \in A) B]^~^* + (at level 200, x at level 99, B at level 200, only parsing) : bool_scope. + +End Exports. + +End FiniteQuant. +Export FiniteQuant.Exports. + +Definition disjoint T (A B : mem_pred _) := @pred0b T (predI A B). +Notation "[ 'disjoint' A & B ]" := (disjoint (mem A) (mem B)) + (at level 0, + format "'[hv' [ 'disjoint' '/ ' A '/' & B ] ']'") : bool_scope. + +Notation Local subset_type := (forall (T : finType) (A B : mem_pred T), bool). +Notation Local subset_def := (fun T A B => pred0b (predD A B)). +Module Type SubsetDefSig. +Parameter subset : subset_type. Axiom subsetEdef : subset = subset_def. +End SubsetDefSig. +Module Export SubsetDef : SubsetDefSig. +Definition subset : subset_type := subset_def. +Definition subsetEdef := erefl subset. +End SubsetDef. +Canonical subset_unlock := Unlockable subsetEdef. +Notation "A \subset B" := (subset (mem A) (mem B)) + (at level 70, no associativity) : bool_scope. + +Definition proper T A B := @subset T A B && ~~ subset B A. +Notation "A \proper B" := (proper (mem A) (mem B)) + (at level 70, no associativity) : bool_scope. + +(* image, xinv, inv, and ordinal operations will be defined later. *) + +Section OpsTheory. + +Variable T : finType. + +Implicit Types A B C P Q : pred T. +Implicit Types x y : T. +Implicit Type s : seq T. + +Lemma enumP : Finite.axiom (Finite.enum T). +Proof. by rewrite unlock; case T => ? [? []]. Qed. + +Section EnumPick. + +Variable P : pred T. + +Lemma enumT : enum T = Finite.enum T. +Proof. exact: filter_predT. Qed. + +Lemma mem_enum A : enum A =i A. +Proof. by move=> x; rewrite mem_filter andbC -has_pred1 has_count enumP. Qed. + +Lemma enum_uniq : uniq (enum P). +Proof. +by apply/filter_uniq/count_mem_uniq => x; rewrite enumP -enumT mem_enum. +Qed. + +Lemma enum0 : enum pred0 = Nil T. Proof. exact: filter_pred0. Qed. + +Lemma enum1 x : enum (pred1 x) = [:: x]. +Proof. +rewrite [enum _](all_pred1P x _ _); first by rewrite size_filter enumP. +by apply/allP=> y; rewrite mem_enum. +Qed. + +CoInductive pick_spec : option T -> Type := + | Pick x of P x : pick_spec (Some x) + | Nopick of P =1 xpred0 : pick_spec None. + +Lemma pickP : pick_spec (pick P). +Proof. +rewrite /pick; case: (enum _) (mem_enum P) => [|x s] Pxs /=. + by right; exact: fsym. +by left; rewrite -[P _]Pxs mem_head. +Qed. + +End EnumPick. + +Lemma eq_enum P Q : P =i Q -> enum P = enum Q. +Proof. move=> eqPQ; exact: eq_filter. Qed. + +Lemma eq_pick P Q : P =1 Q -> pick P = pick Q. +Proof. by move=> eqPQ; rewrite /pick (eq_enum eqPQ). Qed. + +Lemma cardE A : #|A| = size (enum A). +Proof. by rewrite unlock. Qed. + +Lemma eq_card A B : A =i B -> #|A| = #|B|. +Proof. by move=>eqAB; rewrite !cardE (eq_enum eqAB). Qed. + +Lemma eq_card_trans A B n : #|A| = n -> B =i A -> #|B| = n. +Proof. move <-; exact: eq_card. Qed. + +Lemma card0 : #|@pred0 T| = 0. Proof. by rewrite cardE enum0. Qed. + +Lemma cardT : #|T| = size (enum T). Proof. by rewrite cardE. Qed. + +Lemma card1 x : #|pred1 x| = 1. +Proof. by rewrite cardE enum1. Qed. + +Lemma eq_card0 A : A =i pred0 -> #|A| = 0. +Proof. exact: eq_card_trans card0. Qed. + +Lemma eq_cardT A : A =i predT -> #|A| = size (enum T). +Proof. exact: eq_card_trans cardT. Qed. + +Lemma eq_card1 x A : A =i pred1 x -> #|A| = 1. +Proof. exact: eq_card_trans (card1 x). Qed. + +Lemma cardUI A B : #|[predU A & B]| + #|[predI A & B]| = #|A| + #|B|. +Proof. by rewrite !cardE !size_filter count_predUI. Qed. + +Lemma cardID B A : #|[predI A & B]| + #|[predD A & B]| = #|A|. +Proof. +rewrite -cardUI addnC [#|predI _ _|]eq_card0 => [|x] /=. + by apply: eq_card => x; rewrite !inE andbC -andb_orl orbN. +by rewrite !inE -!andbA andbC andbA andbN. +Qed. + +Lemma cardC A : #|A| + #|[predC A]| = #|T|. +Proof. by rewrite !cardE !size_filter count_predC. Qed. + +Lemma cardU1 x A : #|[predU1 x & A]| = (x \notin A) + #|A|. +Proof. +case Ax: (x \in A). + by apply: eq_card => y; rewrite inE /=; case: eqP => // ->. +rewrite /= -(card1 x) -cardUI addnC. +rewrite [#|predI _ _|]eq_card0 => [|y /=]; first exact: eq_card. +by rewrite !inE; case: eqP => // ->. +Qed. + +Lemma card2 x y : #|pred2 x y| = (x != y).+1. +Proof. by rewrite cardU1 card1 addn1. Qed. + +Lemma cardC1 x : #|predC1 x| = #|T|.-1. +Proof. by rewrite -(cardC (pred1 x)) card1. Qed. + +Lemma cardD1 x A : #|A| = (x \in A) + #|[predD1 A & x]|. +Proof. +case Ax: (x \in A); last first. + by apply: eq_card => y; rewrite !inE /=; case: eqP => // ->. +rewrite /= -(card1 x) -cardUI addnC /=. +rewrite [#|predI _ _|]eq_card0 => [|y]; last by rewrite !inE; case: eqP. +by apply: eq_card => y; rewrite !inE; case: eqP => // ->. +Qed. + +Lemma max_card A : #|A| <= #|T|. +Proof. by rewrite -(cardC A) leq_addr. Qed. + +Lemma card_size s : #|s| <= size s. +Proof. +elim: s => [|x s IHs] /=; first by rewrite card0. +rewrite cardU1 /=; case: (~~ _) => //; exact: leqW. +Qed. + +Lemma card_uniqP s : reflect (#|s| = size s) (uniq s). +Proof. +elim: s => [|x s IHs]; first by left; exact card0. +rewrite cardU1 /= /addn; case: {+}(x \in s) => /=. + by right=> card_Ssz; have:= card_size s; rewrite card_Ssz ltnn. +by apply: (iffP IHs) => [<-| [<-]]. +Qed. + +Lemma card0_eq A : #|A| = 0 -> A =i pred0. +Proof. by move=> A0 x; apply/idP => Ax; rewrite (cardD1 x) Ax in A0. Qed. + +Lemma pred0P P : reflect (P =1 pred0) (pred0b P). +Proof. apply: (iffP eqP); [exact: card0_eq | exact: eq_card0]. Qed. + +Lemma pred0Pn P : reflect (exists x, P x) (~~ pred0b P). +Proof. +case: (pickP P) => [x Px | P0]. + by rewrite (introN (pred0P P)) => [|P0]; [left; exists x | rewrite P0 in Px]. +by rewrite -lt0n eq_card0 //; right=> [[x]]; rewrite P0. +Qed. + +Lemma card_gt0P A : reflect (exists i, i \in A) (#|A| > 0). +Proof. rewrite lt0n; exact: pred0Pn. Qed. + +Lemma subsetE A B : (A \subset B) = pred0b [predD A & B]. +Proof. by rewrite unlock. Qed. + +Lemma subsetP A B : reflect {subset A <= B} (A \subset B). +Proof. +rewrite unlock; apply: (iffP (pred0P _)) => [AB0 x | sAB x /=]. + by apply/implyP; apply/idPn; rewrite negb_imply andbC [_ && _]AB0. +by rewrite andbC -negb_imply; apply/negbF/implyP; exact: sAB. +Qed. + +Lemma subsetPn A B : + reflect (exists2 x, x \in A & x \notin B) (~~ (A \subset B)). +Proof. +rewrite unlock; apply: (iffP (pred0Pn _)) => [[x] | [x Ax nBx]]. + by case/andP; exists x. +by exists x; rewrite /= nBx. +Qed. + +Lemma subset_leq_card A B : A \subset B -> #|A| <= #|B|. +Proof. +move=> sAB. +rewrite -(cardID A B) [#|predI _ _|](@eq_card _ A) ?leq_addr //= => x. +rewrite !inE andbC; case Ax: (x \in A) => //; exact: subsetP Ax. +Qed. + +Lemma subxx_hint (mA : mem_pred T) : subset mA mA. +Proof. +by case: mA => A; have:= introT (subsetP A A); rewrite !unlock => ->. +Qed. +Hint Resolve subxx_hint. + +(* The parametrization by predType makes it easier to apply subxx. *) +Lemma subxx (pT : predType T) (pA : pT) : pA \subset pA. +Proof. by []. Qed. + +Lemma eq_subset A1 A2 : A1 =i A2 -> subset (mem A1) =1 subset (mem A2). +Proof. +move=> eqA12 [B]; rewrite !unlock; congr (_ == 0). +by apply: eq_card => x; rewrite inE /= eqA12. +Qed. + +Lemma eq_subset_r B1 B2 : B1 =i B2 -> + (@subset T)^~ (mem B1) =1 (@subset T)^~ (mem B2). +Proof. +move=> eqB12 [A]; rewrite !unlock; congr (_ == 0). +by apply: eq_card => x; rewrite !inE /= eqB12. +Qed. + +Lemma eq_subxx A B : A =i B -> A \subset B. +Proof. by move/eq_subset->. Qed. + +Lemma subset_predT A : A \subset T. +Proof. by apply/subsetP. Qed. + +Lemma predT_subset A : T \subset A -> forall x, x \in A. +Proof. move/subsetP=> allA x; exact: allA. Qed. + +Lemma subset_pred1 A x : (pred1 x \subset A) = (x \in A). +Proof. by apply/subsetP/idP=> [-> // | Ax y /eqP-> //]; exact: eqxx. Qed. + +Lemma subset_eqP A B : reflect (A =i B) ((A \subset B) && (B \subset A)). +Proof. +apply: (iffP andP) => [[sAB sBA] x| eqAB]; last by rewrite !eq_subxx. +by apply/idP/idP; apply: subsetP. +Qed. + +Lemma subset_cardP A B : #|A| = #|B| -> reflect (A =i B) (A \subset B). +Proof. +move=> eqcAB; case: (subsetP A B) (subset_eqP A B) => //= sAB. +case: (subsetP B A) => [//|[]] x Bx; apply/idPn => Ax. +case/idP: (ltnn #|A|); rewrite {2}eqcAB (cardD1 x B) Bx /=. +apply: subset_leq_card; apply/subsetP=> y Ay; rewrite inE /= andbC. +by rewrite sAB //; apply/eqP => eqyx; rewrite -eqyx Ay in Ax. +Qed. + +Lemma subset_leqif_card A B : A \subset B -> #|A| <= #|B| ?= iff (B \subset A). +Proof. +move=> sAB; split; [exact: subset_leq_card | apply/eqP/idP]. + by move/subset_cardP=> sABP; rewrite (eq_subset_r (sABP sAB)). +by move=> sBA; apply: eq_card; apply/subset_eqP; rewrite sAB. +Qed. + +Lemma subset_trans A B C : A \subset B -> B \subset C -> A \subset C. +Proof. +by move/subsetP=> sAB /subsetP=> sBC; apply/subsetP=> x /sAB; exact: sBC. +Qed. + +Lemma subset_all s A : (s \subset A) = all (mem A) s. +Proof. by exact (sameP (subsetP _ _) allP). Qed. + +Lemma properE A B : A \proper B = (A \subset B) && ~~(B \subset A). +Proof. by []. Qed. + +Lemma properP A B : + reflect (A \subset B /\ (exists2 x, x \in B & x \notin A)) (A \proper B). +Proof. +by rewrite properE; apply: (iffP andP) => [] [-> /subsetPn]. +Qed. + +Lemma proper_sub A B : A \proper B -> A \subset B. +Proof. by case/andP. Qed. + +Lemma proper_subn A B : A \proper B -> ~~ (B \subset A). +Proof. by case/andP. Qed. + +Lemma proper_trans A B C : A \proper B -> B \proper C -> A \proper C. +Proof. +case/properP=> sAB [x Bx nAx] /properP[sBC [y Cy nBy]]. +rewrite properE (subset_trans sAB) //=; apply/subsetPn; exists y => //. +by apply: contra nBy; exact: subsetP. +Qed. + +Lemma proper_sub_trans A B C : A \proper B -> B \subset C -> A \proper C. +Proof. +case/properP=> sAB [x Bx nAx] sBC; rewrite properE (subset_trans sAB) //. +by apply/subsetPn; exists x; rewrite ?(subsetP _ _ sBC). +Qed. + +Lemma sub_proper_trans A B C : A \subset B -> B \proper C -> A \proper C. +Proof. +move=> sAB /properP[sBC [x Cx nBx]]; rewrite properE (subset_trans sAB) //. +by apply/subsetPn; exists x => //; apply: contra nBx; exact: subsetP. +Qed. + +Lemma proper_card A B : A \proper B -> #|A| < #|B|. +Proof. +by case/andP=> sAB nsBA; rewrite ltn_neqAle !(subset_leqif_card sAB) andbT. +Qed. + +Lemma proper_irrefl A : ~~ (A \proper A). +Proof. by rewrite properE subxx. Qed. + +Lemma properxx A : (A \proper A) = false. +Proof. by rewrite properE subxx. Qed. + +Lemma eq_proper A B : A =i B -> proper (mem A) =1 proper (mem B). +Proof. +move=> eAB [C]; congr (_ && _); first exact: (eq_subset eAB). +by rewrite (eq_subset_r eAB). +Qed. + +Lemma eq_proper_r A B : A =i B -> + (@proper T)^~ (mem A) =1 (@proper T)^~ (mem B). +Proof. +move=> eAB [C]; congr (_ && _); first exact: (eq_subset_r eAB). +by rewrite (eq_subset eAB). +Qed. + +Lemma disjoint_sym A B : [disjoint A & B] = [disjoint B & A]. +Proof. by congr (_ == 0); apply: eq_card => x; exact: andbC. Qed. + +Lemma eq_disjoint A1 A2 : A1 =i A2 -> disjoint (mem A1) =1 disjoint (mem A2). +Proof. +by move=> eqA12 [B]; congr (_ == 0); apply: eq_card => x; rewrite !inE eqA12. +Qed. + +Lemma eq_disjoint_r B1 B2 : B1 =i B2 -> + (@disjoint T)^~ (mem B1) =1 (@disjoint T)^~ (mem B2). +Proof. +by move=> eqB12 [A]; congr (_ == 0); apply: eq_card => x; rewrite !inE eqB12. +Qed. + +Lemma subset_disjoint A B : (A \subset B) = [disjoint A & [predC B]]. +Proof. by rewrite disjoint_sym unlock. Qed. + +Lemma disjoint_subset A B : [disjoint A & B] = (A \subset [predC B]). +Proof. +by rewrite subset_disjoint; apply: eq_disjoint_r => x; rewrite !inE /= negbK. +Qed. + +Lemma disjoint_trans A B C : + A \subset B -> [disjoint B & C] -> [disjoint A & C]. +Proof. by rewrite 2!disjoint_subset; exact: subset_trans. Qed. + +Lemma disjoint0 A : [disjoint pred0 & A]. +Proof. exact/pred0P. Qed. + +Lemma eq_disjoint0 A B : A =i pred0 -> [disjoint A & B]. +Proof. by move/eq_disjoint->; exact: disjoint0. Qed. + +Lemma disjoint1 x A : [disjoint pred1 x & A] = (x \notin A). +Proof. +apply/negbRL/(sameP (pred0Pn _)). +apply: introP => [Ax | notAx [_ /andP[/eqP->]]]; last exact: negP. +by exists x; rewrite !inE eqxx. +Qed. + +Lemma eq_disjoint1 x A B : + A =i pred1 x -> [disjoint A & B] = (x \notin B). +Proof. by move/eq_disjoint->; exact: disjoint1. Qed. + +Lemma disjointU A B C : + [disjoint predU A B & C] = [disjoint A & C] && [disjoint B & C]. +Proof. +case: [disjoint A & C] / (pred0P (xpredI A C)) => [A0 | nA0] /=. + by congr (_ == 0); apply: eq_card => x; rewrite [x \in _]andb_orl A0. +apply/pred0P=> nABC; case: nA0 => x; apply/idPn=> /=; move/(_ x): nABC. +by rewrite [_ x]andb_orl; case/norP. +Qed. + +Lemma disjointU1 x A B : + [disjoint predU1 x A & B] = (x \notin B) && [disjoint A & B]. +Proof. by rewrite disjointU disjoint1. Qed. + +Lemma disjoint_cons x s B : + [disjoint x :: s & B] = (x \notin B) && [disjoint s & B]. +Proof. exact: disjointU1. Qed. + +Lemma disjoint_has s A : [disjoint s & A] = ~~ has (mem A) s. +Proof. +rewrite -(@eq_has _ (mem (enum A))) => [|x]; last exact: mem_enum. +rewrite has_sym has_filter -filter_predI -has_filter has_count -eqn0Ngt. +by rewrite -size_filter /disjoint /pred0b unlock. +Qed. + +Lemma disjoint_cat s1 s2 A : + [disjoint s1 ++ s2 & A] = [disjoint s1 & A] && [disjoint s2 & A]. +Proof. by rewrite !disjoint_has has_cat negb_or. Qed. + +End OpsTheory. + +Hint Resolve subxx_hint. + +Implicit Arguments pred0P [T P]. +Implicit Arguments pred0Pn [T P]. +Implicit Arguments subsetP [T A B]. +Implicit Arguments subsetPn [T A B]. +Implicit Arguments subset_eqP [T A B]. +Implicit Arguments card_uniqP [T s]. +Implicit Arguments properP [T A B]. +Prenex Implicits pred0P pred0Pn subsetP subsetPn subset_eqP card_uniqP. + +(**********************************************************************) +(* *) +(* Boolean quantifiers for finType *) +(* *) +(**********************************************************************) + +Section QuantifierCombinators. + +Variables (T : finType) (P : pred T) (PP : T -> Prop). +Hypothesis viewP : forall x, reflect (PP x) (P x). + +Lemma existsPP : reflect (exists x, PP x) [exists x, P x]. +Proof. by apply: (iffP pred0Pn) => -[x /viewP]; exists x. Qed. + +Lemma forallPP : reflect (forall x, PP x) [forall x, P x]. +Proof. by apply: (iffP pred0P) => /= allP x; have /viewP//=-> := allP x. Qed. + +End QuantifierCombinators. + +Notation "'exists_ view" := (existsPP (fun _ => view)) + (at level 4, right associativity, format "''exists_' view"). +Notation "'forall_ view" := (forallPP (fun _ => view)) + (at level 4, right associativity, format "''forall_' view"). + +Section Quantifiers. + +Variables (T : finType) (rT : T -> eqType). +Implicit Type (D P : pred T) (f : forall x, rT x). + +Lemma forallP P : reflect (forall x, P x) [forall x, P x]. +Proof. exact: 'forall_idP. Qed. + +Lemma eqfunP f1 f2 : reflect (forall x, f1 x = f2 x) [forall x, f1 x == f2 x]. +Proof. exact: 'forall_eqP. Qed. + +Lemma forall_inP D P : reflect (forall x, D x -> P x) [forall (x | D x), P x]. +Proof. exact: 'forall_implyP. Qed. + +Lemma eqfun_inP D f1 f2 : + reflect {in D, forall x, f1 x = f2 x} [forall (x | x \in D), f1 x == f2 x]. +Proof. by apply: (iffP 'forall_implyP) => eq_f12 x Dx; apply/eqP/eq_f12. Qed. + +Lemma existsP P : reflect (exists x, P x) [exists x, P x]. +Proof. exact: 'exists_idP. Qed. + +Lemma exists_eqP f1 f2 : + reflect (exists x, f1 x = f2 x) [exists x, f1 x == f2 x]. +Proof. exact: 'exists_eqP. Qed. + +Lemma exists_inP D P : reflect (exists2 x, D x & P x) [exists (x | D x), P x]. +Proof. by apply: (iffP 'exists_andP) => [[x []] | [x]]; exists x. Qed. + +Lemma exists_eq_inP D f1 f2 : + reflect (exists2 x, D x & f1 x = f2 x) [exists (x | D x), f1 x == f2 x]. +Proof. by apply: (iffP (exists_inP _ _)) => [] [x Dx /eqP]; exists x. Qed. + +Lemma eq_existsb P1 P2 : P1 =1 P2 -> [exists x, P1 x] = [exists x, P2 x]. +Proof. by move=> eqP12; congr (_ != 0); apply: eq_card. Qed. + +Lemma eq_existsb_in D P1 P2 : + (forall x, D x -> P1 x = P2 x) -> + [exists (x | D x), P1 x] = [exists (x | D x), P2 x]. +Proof. by move=> eqP12; apply: eq_existsb => x; apply: andb_id2l => /eqP12. Qed. + +Lemma eq_forallb P1 P2 : P1 =1 P2 -> [forall x, P1 x] = [forall x, P2 x]. +Proof. by move=> eqP12; apply/negb_inj/eq_existsb=> /= x; rewrite eqP12. Qed. + +Lemma eq_forallb_in D P1 P2 : + (forall x, D x -> P1 x = P2 x) -> + [forall (x | D x), P1 x] = [forall (x | D x), P2 x]. +Proof. +by move=> eqP12; apply: eq_forallb => i; case Di: (D i); rewrite // eqP12. +Qed. + +Lemma negb_forall P : ~~ [forall x, P x] = [exists x, ~~ P x]. +Proof. by []. Qed. + +Lemma negb_forall_in D P : + ~~ [forall (x | D x), P x] = [exists (x | D x), ~~ P x]. +Proof. by apply: eq_existsb => x; rewrite negb_imply. Qed. + +Lemma negb_exists P : ~~ [exists x, P x] = [forall x, ~~ P x]. +Proof. by apply/negbLR/esym/eq_existsb=> x; apply: negbK. Qed. + +Lemma negb_exists_in D P : + ~~ [exists (x | D x), P x] = [forall (x | D x), ~~ P x]. +Proof. by rewrite negb_exists; apply/eq_forallb => x; rewrite [~~ _]fun_if. Qed. + +End Quantifiers. + +Implicit Arguments forallP [T P]. +Implicit Arguments eqfunP [T rT f1 f2]. +Implicit Arguments forall_inP [T D P]. +Implicit Arguments eqfun_inP [T rT D f1 f2]. +Implicit Arguments existsP [T P]. +Implicit Arguments exists_eqP [T rT f1 f2]. +Implicit Arguments exists_inP [T D P]. +Implicit Arguments exists_eq_inP [T rT D f1 f2]. + +Section Extrema. + +Variables (I : finType) (i0 : I) (P : pred I) (F : I -> nat). + +Let arg_pred ord := [pred i | P i & [forall (j | P j), ord (F i) (F j)]]. + +Definition arg_min := odflt i0 (pick (arg_pred leq)). + +Definition arg_max := odflt i0 (pick (arg_pred geq)). + +CoInductive extremum_spec (ord : rel nat) : I -> Type := + ExtremumSpec i of P i & (forall j, P j -> ord (F i) (F j)) + : extremum_spec ord i. + +Hypothesis Pi0 : P i0. + +Let FP n := [exists (i | P i), F i == n]. +Let FP_F i : P i -> FP (F i). +Proof. by move=> Pi; apply/existsP; exists i; rewrite Pi /=. Qed. +Let exFP : exists n, FP n. Proof. by exists (F i0); exact: FP_F. Qed. + +Lemma arg_minP : extremum_spec leq arg_min. +Proof. +rewrite /arg_min; case: pickP => [i /andP[Pi /forallP/= min_i] | no_i]. + by split=> // j; apply/implyP. +case/ex_minnP: exFP => n ex_i min_i; case/pred0P: ex_i => i /=. +apply: contraFF (no_i i) => /andP[Pi /eqP def_n]; rewrite /= Pi. +by apply/forall_inP=> j Pj; rewrite def_n min_i ?FP_F. +Qed. + +Lemma arg_maxP : extremum_spec geq arg_max. +Proof. +rewrite /arg_max; case: pickP => [i /andP[Pi /forall_inP/= max_i] | no_i]. + by split=> // j; apply/implyP. +have (n): FP n -> n <= foldr maxn 0 (map F (enum P)). + case/existsP=> i; rewrite -[P i]mem_enum andbC /= => /andP[/eqP <-]. + elim: (enum P) => //= j e IHe; rewrite leq_max orbC !inE. + by case/predU1P=> [-> | /IHe-> //]; rewrite leqnn orbT. +case/ex_maxnP=> // n ex_i max_i; case/pred0P: ex_i => i /=. +apply: contraFF (no_i i) => /andP[Pi def_n]; rewrite /= Pi. +by apply/forall_inP=> j Pj; rewrite (eqP def_n) max_i ?FP_F. +Qed. + +End Extrema. + +Notation "[ 'arg' 'min_' ( i < i0 | P ) F ]" := + (arg_min i0 (fun i => P%B) (fun i => F)) + (at level 0, i, i0 at level 10, + format "[ 'arg' 'min_' ( i < i0 | P ) F ]") : form_scope. + +Notation "[ 'arg' 'min_' ( i < i0 'in' A ) F ]" := + [arg min_(i < i0 | i \in A) F] + (at level 0, i, i0 at level 10, + format "[ 'arg' 'min_' ( i < i0 'in' A ) F ]") : form_scope. + +Notation "[ 'arg' 'min_' ( i < i0 ) F ]" := [arg min_(i < i0 | true) F] + (at level 0, i, i0 at level 10, + format "[ 'arg' 'min_' ( i < i0 ) F ]") : form_scope. + +Notation "[ 'arg' 'max_' ( i > i0 | P ) F ]" := + (arg_max i0 (fun i => P%B) (fun i => F)) + (at level 0, i, i0 at level 10, + format "[ 'arg' 'max_' ( i > i0 | P ) F ]") : form_scope. + +Notation "[ 'arg' 'max_' ( i > i0 'in' A ) F ]" := + [arg max_(i > i0 | i \in A) F] + (at level 0, i, i0 at level 10, + format "[ 'arg' 'max_' ( i > i0 'in' A ) F ]") : form_scope. + +Notation "[ 'arg' 'max_' ( i > i0 ) F ]" := [arg max_(i > i0 | true) F] + (at level 0, i, i0 at level 10, + format "[ 'arg' 'max_' ( i > i0 ) F ]") : form_scope. + +(**********************************************************************) +(* *) +(* Boolean injectivity test for functions with a finType domain *) +(* *) +(**********************************************************************) + +Section Injectiveb. + +Variables (aT : finType) (rT : eqType) (f : aT -> rT). +Implicit Type D : pred aT. + +Definition dinjectiveb D := uniq (map f (enum D)). + +Definition injectiveb := dinjectiveb aT. + +Lemma dinjectivePn D : + reflect (exists2 x, x \in D & exists2 y, y \in [predD1 D & x] & f x = f y) + (~~ dinjectiveb D). +Proof. +apply: (iffP idP) => [injf | [x Dx [y Dxy eqfxy]]]; last first. + move: Dx; rewrite -(mem_enum D) => /rot_to[i E defE]. + rewrite /dinjectiveb -(rot_uniq i) -map_rot defE /=; apply/nandP; left. + rewrite inE /= -(mem_enum D) -(mem_rot i) defE inE in Dxy. + rewrite andb_orr andbC andbN in Dxy. + by rewrite eqfxy map_f //; case/andP: Dxy. +pose p := [pred x in D | [exists (y | y \in [predD1 D & x]), f x == f y]]. +case: (pickP p) => [x /= /andP[Dx /exists_inP[y Dxy /eqP eqfxy]] | no_p]. + by exists x; last exists y. +rewrite /dinjectiveb map_inj_in_uniq ?enum_uniq // in injf => x y Dx Dy eqfxy. +apply: contraNeq (negbT (no_p x)) => ne_xy /=; rewrite -mem_enum Dx. +by apply/existsP; exists y; rewrite /= !inE eq_sym ne_xy -mem_enum Dy eqfxy /=. +Qed. + +Lemma dinjectiveP D : reflect {in D &, injective f} (dinjectiveb D). +Proof. +rewrite -[dinjectiveb D]negbK. +case: dinjectivePn=> [noinjf | injf]; constructor. + case: noinjf => x Dx [y /andP[neqxy /= Dy] eqfxy] injf. + by case/eqP: neqxy; exact: injf. +move=> x y Dx Dy /= eqfxy; apply/eqP; apply/idPn=> nxy; case: injf. +by exists x => //; exists y => //=; rewrite inE /= eq_sym nxy. +Qed. + +Lemma injectivePn : + reflect (exists x, exists2 y, x != y & f x = f y) (~~ injectiveb). +Proof. +apply: (iffP (dinjectivePn _)) => [[x _ [y nxy eqfxy]] | [x [y nxy eqfxy]]]; + by exists x => //; exists y => //; rewrite inE /= andbT eq_sym in nxy *. +Qed. + +Lemma injectiveP : reflect (injective f) injectiveb. +Proof. apply: (iffP (dinjectiveP _)) => injf x y => [|_ _]; exact: injf. Qed. + +End Injectiveb. + +Definition image_mem T T' f mA : seq T' := map f (@enum_mem T mA). +Notation image f A := (image_mem f (mem A)). +Notation "[ 'seq' F | x 'in' A ]" := (image (fun x => F) A) + (at level 0, F at level 99, x ident, + format "'[hv' [ 'seq' F '/ ' | x 'in' A ] ']'") : seq_scope. +Notation "[ 'seq' F | x : T 'in' A ]" := (image (fun x : T => F) A) + (at level 0, F at level 99, x ident, only parsing) : seq_scope. +Notation "[ 'seq' F | x : T ]" := + [seq F | x : T in sort_of_simpl_pred (@pred_of_argType T)] + (at level 0, F at level 99, x ident, + format "'[hv' [ 'seq' F '/ ' | x : T ] ']'") : seq_scope. +Notation "[ 'seq' F , x ]" := [seq F | x : _ ] + (at level 0, F at level 99, x ident, only parsing) : seq_scope. + +Definition codom T T' f := @image_mem T T' f (mem T). + +Section Image. + +Variable T : finType. +Implicit Type A : pred T. + +Section SizeImage. + +Variables (T' : Type) (f : T -> T'). + +Lemma size_image A : size (image f A) = #|A|. +Proof. by rewrite size_map -cardE. Qed. + +Lemma size_codom : size (codom f) = #|T|. +Proof. exact: size_image. Qed. + +Lemma codomE : codom f = map f (enum T). +Proof. by []. Qed. + +End SizeImage. + +Variables (T' : eqType) (f : T -> T'). + +Lemma imageP A y : reflect (exists2 x, x \in A & y = f x) (y \in image f A). +Proof. +by apply: (iffP mapP) => [] [x Ax y_fx]; exists x; rewrite // mem_enum in Ax *. +Qed. + +Lemma codomP y : reflect (exists x, y = f x) (y \in codom f). +Proof. by apply: (iffP (imageP _ y)) => [][x]; exists x. Qed. + +Remark iinv_proof A y : y \in image f A -> {x | x \in A & f x = y}. +Proof. +move=> fy; pose b x := A x && (f x == y). +case: (pickP b) => [x /andP[Ax /eqP] | nfy]; first by exists x. +by case/negP: fy => /imageP[x Ax fx_y]; case/andP: (nfy x); rewrite fx_y. +Qed. + +Definition iinv A y fAy := s2val (@iinv_proof A y fAy). + +Lemma f_iinv A y fAy : f (@iinv A y fAy) = y. +Proof. exact: s2valP' (iinv_proof fAy). Qed. + +Lemma mem_iinv A y fAy : @iinv A y fAy \in A. +Proof. exact: s2valP (iinv_proof fAy). Qed. + +Lemma in_iinv_f A : {in A &, injective f} -> + forall x fAfx, x \in A -> @iinv A (f x) fAfx = x. +Proof. +move=> injf x fAfx Ax; apply: injf => //; [exact: mem_iinv | exact: f_iinv]. +Qed. + +Lemma preim_iinv A B y fAy : preim f B (@iinv A y fAy) = B y. +Proof. by rewrite /= f_iinv. Qed. + +Lemma image_f A x : x \in A -> f x \in image f A. +Proof. by move=> Ax; apply/imageP; exists x. Qed. + +Lemma codom_f x : f x \in codom f. +Proof. by exact: image_f. Qed. + +Lemma image_codom A : {subset image f A <= codom f}. +Proof. by move=> _ /imageP[x _ ->]; exact: codom_f. Qed. + +Lemma image_pred0 : image f pred0 =i pred0. +Proof. by move=> x; rewrite /image_mem /= enum0. Qed. + +Section Injective. + +Hypothesis injf : injective f. + +Lemma mem_image A x : (f x \in image f A) = (x \in A). +Proof. by rewrite mem_map ?mem_enum. Qed. + +Lemma pre_image A : [preim f of image f A] =i A. +Proof. by move=> x; rewrite inE /= mem_image. Qed. + +Lemma image_iinv A y (fTy : y \in codom f) : + (y \in image f A) = (iinv fTy \in A). +Proof. by rewrite -mem_image ?f_iinv. Qed. + +Lemma iinv_f x fTfx : @iinv T (f x) fTfx = x. +Proof. by apply: in_iinv_f; first exact: in2W. Qed. + +Lemma image_pre (B : pred T') : image f [preim f of B] =i [predI B & codom f]. +Proof. by move=> y; rewrite /image_mem -filter_map /= mem_filter -enumT. Qed. + +Lemma bij_on_codom (x0 : T) : {on [pred y in codom f], bijective f}. +Proof. +pose g y := iinv (valP (insigd (codom_f x0) y)). +by exists g => [x fAfx | y fAy]; first apply: injf; rewrite f_iinv insubdK. +Qed. + +Lemma bij_on_image A (x0 : T) : {on [pred y in image f A], bijective f}. +Proof. exact: subon_bij (@image_codom A) (bij_on_codom x0). Qed. + +End Injective. + +Fixpoint preim_seq s := + if s is y :: s' then + (if pick (preim f (pred1 y)) is Some x then cons x else id) (preim_seq s') + else [::]. + +Lemma map_preim (s : seq T') : {subset s <= codom f} -> map f (preim_seq s) = s. +Proof. +elim: s => //= y s IHs; case: pickP => [x /eqP fx_y | nfTy] fTs. + by rewrite /= fx_y IHs // => z s_z; apply: fTs; exact: predU1r. +by case/imageP: (fTs y (mem_head y s)) => x _ fx_y; case/eqP: (nfTy x). +Qed. + +End Image. + +Prenex Implicits codom iinv. +Implicit Arguments imageP [T T' f A y]. +Implicit Arguments codomP [T T' f y]. + +Lemma flatten_imageP (aT : finType) (rT : eqType) A (P : pred aT) (y : rT) : + reflect (exists2 x, x \in P & y \in A x) (y \in flatten [seq A x | x in P]). +Proof. +by apply: (iffP flatten_mapP) => [][x Px]; exists x; rewrite ?mem_enum in Px *. +Qed. +Implicit Arguments flatten_imageP [aT rT A P y]. + +Section CardFunImage. + +Variables (T T' : finType) (f : T -> T'). +Implicit Type A : pred T. + +Lemma leq_image_card A : #|image f A| <= #|A|. +Proof. by rewrite (cardE A) -(size_map f) card_size. Qed. + +Lemma card_in_image A : {in A &, injective f} -> #|image f A| = #|A|. +Proof. +move=> injf; rewrite (cardE A) -(size_map f); apply/card_uniqP. +rewrite map_inj_in_uniq ?enum_uniq // => x y; rewrite !mem_enum; exact: injf. +Qed. + +Lemma image_injP A : reflect {in A &, injective f} (#|image f A| == #|A|). +Proof. +apply: (iffP eqP) => [eqfA |]; last exact: card_in_image. +by apply/dinjectiveP; apply/card_uniqP; rewrite size_map -cardE. +Qed. + +Hypothesis injf : injective f. + +Lemma card_image A : #|image f A| = #|A|. +Proof. apply: card_in_image; exact: in2W. Qed. + +Lemma card_codom : #|codom f| = #|T|. +Proof. exact: card_image. Qed. + +Lemma card_preim (B : pred T') : #|[preim f of B]| = #|[predI codom f & B]|. +Proof. +rewrite -card_image /=; apply: eq_card => y. +by rewrite [y \in _]image_pre !inE andbC. +Qed. + +Hypothesis card_range : #|T| = #|T'|. + +Lemma inj_card_onto y : y \in codom f. +Proof. by move: y; apply/subset_cardP; rewrite ?card_codom ?subset_predT. Qed. + +Lemma inj_card_bij : bijective f. +Proof. +by exists (fun y => iinv (inj_card_onto y)) => y; rewrite ?iinv_f ?f_iinv. +Qed. + +End CardFunImage. + +Implicit Arguments image_injP [T T' f A]. + +Section FinCancel. + +Variables (T : finType) (f g : T -> T). + +Section Inv. + +Hypothesis injf : injective f. + +Lemma injF_onto y : y \in codom f. Proof. exact: inj_card_onto. Qed. +Definition invF y := iinv (injF_onto y). +Lemma invF_f : cancel f invF. Proof. by move=> x; exact: iinv_f. Qed. +Lemma f_invF : cancel invF f. Proof. by move=> y; exact: f_iinv. Qed. +Lemma injF_bij : bijective f. Proof. exact: inj_card_bij. Qed. + +End Inv. + +Hypothesis fK : cancel f g. + +Lemma canF_sym : cancel g f. +Proof. exact/(bij_can_sym (injF_bij (can_inj fK))). Qed. + +Lemma canF_LR x y : x = g y -> f x = y. +Proof. exact: canLR canF_sym. Qed. + +Lemma canF_RL x y : g x = y -> x = f y. +Proof. exact: canRL canF_sym. Qed. + +Lemma canF_eq x y : (f x == y) = (x == g y). +Proof. exact: (can2_eq fK canF_sym). Qed. + +Lemma canF_invF : g =1 invF (can_inj fK). +Proof. by move=> y; apply: (canLR fK); rewrite f_invF. Qed. + +End FinCancel. + +Section EqImage. + +Variables (T : finType) (T' : Type). + +Lemma eq_image (A B : pred T) (f g : T -> T') : + A =i B -> f =1 g -> image f A = image g B. +Proof. +by move=> eqAB eqfg; rewrite /image_mem (eq_enum eqAB) (eq_map eqfg). +Qed. + +Lemma eq_codom (f g : T -> T') : f =1 g -> codom f = codom g. +Proof. exact: eq_image. Qed. + +Lemma eq_invF f g injf injg : f =1 g -> @invF T f injf =1 @invF T g injg. +Proof. +by move=> eq_fg x; apply: (canLR (invF_f injf)); rewrite eq_fg f_invF. +Qed. + +End EqImage. + +(* Standard finTypes *) + +Section SeqFinType. + +Variables (T : eqType) (s : seq T). + +Record seq_sub : Type := SeqSub {ssval : T; ssvalP : in_mem ssval (@mem T _ s)}. + +Canonical seq_sub_subType := Eval hnf in [subType for ssval]. +Definition seq_sub_eqMixin := Eval hnf in [eqMixin of seq_sub by <:]. +Canonical seq_sub_eqType := Eval hnf in EqType seq_sub seq_sub_eqMixin. + +Definition seq_sub_enum : seq seq_sub := undup (pmap insub s). + +Lemma mem_seq_sub_enum x : x \in seq_sub_enum. +Proof. by rewrite mem_undup mem_pmap -valK map_f ?ssvalP. Qed. + +Lemma val_seq_sub_enum : uniq s -> map val seq_sub_enum = s. +Proof. +move=> Us; rewrite /seq_sub_enum undup_id ?pmap_sub_uniq //. +rewrite (pmap_filter (@insubK _ _ _)); apply/all_filterP. +by apply/allP => x; rewrite isSome_insub. +Qed. + +Definition seq_sub_pickle x := index x seq_sub_enum. +Definition seq_sub_unpickle n := nth None (map some seq_sub_enum) n. +Lemma seq_sub_pickleK : pcancel seq_sub_pickle seq_sub_unpickle. +Proof. +rewrite /seq_sub_unpickle => x. +by rewrite (nth_map x) ?nth_index ?index_mem ?mem_seq_sub_enum. +Qed. + +Definition seq_sub_choiceMixin := PcanChoiceMixin seq_sub_pickleK. +Canonical seq_sub_choiceType := + Eval hnf in ChoiceType seq_sub seq_sub_choiceMixin. + +Definition seq_sub_countMixin := CountMixin seq_sub_pickleK. +Canonical seq_sub_countType := Eval hnf in CountType seq_sub seq_sub_countMixin. + +Definition seq_sub_finMixin := + Eval hnf in UniqFinMixin (undup_uniq _) mem_seq_sub_enum. +Canonical seq_sub_finType := Eval hnf in FinType seq_sub seq_sub_finMixin. + +Lemma card_seq_sub : uniq s -> #|{:seq_sub}| = size s. +Proof. +by move=> Us; rewrite cardE enumT -(size_map val) unlock val_seq_sub_enum. +Qed. + +End SeqFinType. + +Canonical seq_sub_subCountType (T : choiceType) (s : seq T) := Eval hnf in [subCountType of (seq_sub s)]. + +Lemma unit_enumP : Finite.axiom [::tt]. Proof. by case. Qed. +Definition unit_finMixin := Eval hnf in FinMixin unit_enumP. +Canonical unit_finType := Eval hnf in FinType unit unit_finMixin. +Lemma card_unit : #|{: unit}| = 1. Proof. by rewrite cardT enumT unlock. Qed. + +Lemma bool_enumP : Finite.axiom [:: true; false]. Proof. by case. Qed. +Definition bool_finMixin := Eval hnf in FinMixin bool_enumP. +Canonical bool_finType := Eval hnf in FinType bool bool_finMixin. +Lemma card_bool : #|{: bool}| = 2. Proof. by rewrite cardT enumT unlock. Qed. + +Local Notation enumF T := (Finite.enum T). + +Section OptionFinType. + +Variable T : finType. + +Definition option_enum := None :: map some (enumF T). + +Lemma option_enumP : Finite.axiom option_enum. +Proof. by case=> [x|]; rewrite /= count_map (count_pred0, enumP). Qed. + +Definition option_finMixin := Eval hnf in FinMixin option_enumP. +Canonical option_finType := Eval hnf in FinType (option T) option_finMixin. + +Lemma card_option : #|{: option T}| = #|T|.+1. +Proof. by rewrite !cardT !enumT {1}unlock /= !size_map. Qed. + +End OptionFinType. + +Section TransferFinType. + +Variables (eT : countType) (fT : finType) (f : eT -> fT). + +Lemma pcan_enumP g : pcancel f g -> Finite.axiom (undup (pmap g (enumF fT))). +Proof. +move=> fK x; rewrite count_uniq_mem ?undup_uniq // mem_undup. +by rewrite mem_pmap -fK map_f // -enumT mem_enum. +Qed. + +Definition PcanFinMixin g fK := FinMixin (@pcan_enumP g fK). + +Definition CanFinMixin g (fK : cancel f g) := PcanFinMixin (can_pcan fK). + +End TransferFinType. + +Section SubFinType. + +Variables (T : choiceType) (P : pred T). +Import Finite. + +Structure subFinType := SubFinType { + subFin_sort :> subType P; + _ : mixin_of (sub_eqType subFin_sort) +}. + +Definition pack_subFinType U := + fun cT b m & phant_id (class cT) (@Class U b m) => + fun sT m' & phant_id m' m => @SubFinType sT m'. + +Implicit Type sT : subFinType. + +Definition subFin_mixin sT := + let: SubFinType _ m := sT return mixin_of (sub_eqType sT) in m. + +Coercion subFinType_subCountType sT := @SubCountType _ _ sT (subFin_mixin sT). +Canonical subFinType_subCountType. + +Coercion subFinType_finType sT := + Pack (@Class sT (sub_choiceClass sT) (subFin_mixin sT)) sT. +Canonical subFinType_finType. + +Lemma codom_val sT x : (x \in codom (val : sT -> T)) = P x. +Proof. +by apply/codomP/idP=> [[u ->]|Px]; last exists (Sub x Px); rewrite ?valP ?SubK. +Qed. + +End SubFinType. + +(* This assumes that T has both finType and subCountType structures. *) +Notation "[ 'subFinType' 'of' T ]" := (@pack_subFinType _ _ T _ _ _ id _ _ id) + (at level 0, format "[ 'subFinType' 'of' T ]") : form_scope. + +Canonical seq_sub_subFinType (T : choiceType) s := + Eval hnf in [subFinType of @seq_sub T s]. + +Section FinTypeForSub. + +Variables (T : finType) (P : pred T) (sT : subCountType P). + +Definition sub_enum : seq sT := pmap insub (enumF T). + +Lemma mem_sub_enum u : u \in sub_enum. +Proof. by rewrite mem_pmap_sub -enumT mem_enum. Qed. + +Lemma sub_enum_uniq : uniq sub_enum. +Proof. by rewrite pmap_sub_uniq // -enumT enum_uniq. Qed. + +Lemma val_sub_enum : map val sub_enum = enum P. +Proof. +rewrite pmap_filter; last exact: insubK. +by apply: eq_filter => x; exact: isSome_insub. +Qed. + +(* We can't declare a canonical structure here because we've already *) +(* stated that subType_sort and FinType.sort unify via to the *) +(* subType_finType structure. *) + +Definition SubFinMixin := UniqFinMixin sub_enum_uniq mem_sub_enum. +Definition SubFinMixin_for (eT : eqType) of phant eT := + eq_rect _ Finite.mixin_of SubFinMixin eT. + +Variable sfT : subFinType P. + +Lemma card_sub : #|sfT| = #|[pred x | P x]|. +Proof. by rewrite -(eq_card (codom_val sfT)) (card_image val_inj). Qed. + +Lemma eq_card_sub (A : pred sfT) : A =i predT -> #|A| = #|[pred x | P x]|. +Proof. exact: eq_card_trans card_sub. Qed. + +End FinTypeForSub. + +(* This assumes that T has a subCountType structure over a type that *) +(* has a finType structure. *) +Notation "[ 'finMixin' 'of' T 'by' <: ]" := + (SubFinMixin_for (Phant T) (erefl _)) + (at level 0, format "[ 'finMixin' 'of' T 'by' <: ]") : form_scope. + +(* Regression for the subFinType stack +Record myb : Type := MyB {myv : bool; _ : ~~ myv}. +Canonical myb_sub := Eval hnf in [subType for myv]. +Definition myb_eqm := Eval hnf in [eqMixin of myb by <:]. +Canonical myb_eq := Eval hnf in EqType myb myb_eqm. +Definition myb_chm := [choiceMixin of myb by <:]. +Canonical myb_ch := Eval hnf in ChoiceType myb myb_chm. +Definition myb_cntm := [countMixin of myb by <:]. +Canonical myb_cnt := Eval hnf in CountType myb myb_cntm. +Canonical myb_scnt := Eval hnf in [subCountType of myb]. +Definition myb_finm := [finMixin of myb by <:]. +Canonical myb_fin := Eval hnf in FinType myb myb_finm. +Canonical myb_sfin := Eval hnf in [subFinType of myb]. +Print Canonical Projections. +Print myb_finm. +Print myb_cntm. +*) + +Section CardSig. + +Variables (T : finType) (P : pred T). + +Definition sig_finMixin := [finMixin of {x | P x} by <:]. +Canonical sig_finType := Eval hnf in FinType {x | P x} sig_finMixin. +Canonical sig_subFinType := Eval hnf in [subFinType of {x | P x}]. + +Lemma card_sig : #|{: {x | P x}}| = #|[pred x | P x]|. +Proof. exact: card_sub. Qed. + +End CardSig. + +(**********************************************************************) +(* *) +(* Ordinal finType : {0, ... , n-1} *) +(* *) +(**********************************************************************) + +Section OrdinalSub. + +Variable n : nat. + +Inductive ordinal : predArgType := Ordinal m of m < n. + +Coercion nat_of_ord i := let: Ordinal m _ := i in m. + +Canonical ordinal_subType := [subType for nat_of_ord]. +Definition ordinal_eqMixin := Eval hnf in [eqMixin of ordinal by <:]. +Canonical ordinal_eqType := Eval hnf in EqType ordinal ordinal_eqMixin. +Definition ordinal_choiceMixin := [choiceMixin of ordinal by <:]. +Canonical ordinal_choiceType := + Eval hnf in ChoiceType ordinal ordinal_choiceMixin. +Definition ordinal_countMixin := [countMixin of ordinal by <:]. +Canonical ordinal_countType := Eval hnf in CountType ordinal ordinal_countMixin. +Canonical ordinal_subCountType := [subCountType of ordinal]. + +Lemma ltn_ord (i : ordinal) : i < n. Proof. exact: valP i. Qed. + +Lemma ord_inj : injective nat_of_ord. Proof. exact: val_inj. Qed. + +Definition ord_enum : seq ordinal := pmap insub (iota 0 n). + +Lemma val_ord_enum : map val ord_enum = iota 0 n. +Proof. +rewrite pmap_filter; last exact: insubK. +by apply/all_filterP; apply/allP=> i; rewrite mem_iota isSome_insub. +Qed. + +Lemma ord_enum_uniq : uniq ord_enum. +Proof. by rewrite pmap_sub_uniq ?iota_uniq. Qed. + +Lemma mem_ord_enum i : i \in ord_enum. +Proof. by rewrite -(mem_map ord_inj) val_ord_enum mem_iota ltn_ord. Qed. + +Definition ordinal_finMixin := + Eval hnf in UniqFinMixin ord_enum_uniq mem_ord_enum. +Canonical ordinal_finType := Eval hnf in FinType ordinal ordinal_finMixin. +Canonical ordinal_subFinType := Eval hnf in [subFinType of ordinal]. + +End OrdinalSub. + +Notation "''I_' n" := (ordinal n) + (at level 8, n at level 2, format "''I_' n"). + +Hint Resolve ltn_ord. + +Section OrdinalEnum. + +Variable n : nat. + +Lemma val_enum_ord : map val (enum 'I_n) = iota 0 n. +Proof. by rewrite enumT unlock val_ord_enum. Qed. + +Lemma size_enum_ord : size (enum 'I_n) = n. +Proof. by rewrite -(size_map val) val_enum_ord size_iota. Qed. + +Lemma card_ord : #|'I_n| = n. +Proof. by rewrite cardE size_enum_ord. Qed. + +Lemma nth_enum_ord i0 m : m < n -> nth i0 (enum 'I_n) m = m :> nat. +Proof. +by move=> ?; rewrite -(nth_map _ 0) (size_enum_ord, val_enum_ord) // nth_iota. +Qed. + +Lemma nth_ord_enum (i0 i : 'I_n) : nth i0 (enum 'I_n) i = i. +Proof. apply: val_inj; exact: nth_enum_ord. Qed. + +Lemma index_enum_ord (i : 'I_n) : index i (enum 'I_n) = i. +Proof. +by rewrite -{1}(nth_ord_enum i i) index_uniq ?(enum_uniq, size_enum_ord). +Qed. + +End OrdinalEnum. + +Lemma widen_ord_proof n m (i : 'I_n) : n <= m -> i < m. +Proof. exact: leq_trans. Qed. +Definition widen_ord n m le_n_m i := Ordinal (@widen_ord_proof n m i le_n_m). + +Lemma cast_ord_proof n m (i : 'I_n) : n = m -> i < m. +Proof. by move <-. Qed. +Definition cast_ord n m eq_n_m i := Ordinal (@cast_ord_proof n m i eq_n_m). + +Lemma cast_ord_id n eq_n i : cast_ord eq_n i = i :> 'I_n. +Proof. exact: val_inj. Qed. + +Lemma cast_ord_comp n1 n2 n3 eq_n2 eq_n3 i : + @cast_ord n2 n3 eq_n3 (@cast_ord n1 n2 eq_n2 i) = + cast_ord (etrans eq_n2 eq_n3) i. +Proof. exact: val_inj. Qed. + +Lemma cast_ordK n1 n2 eq_n : + cancel (@cast_ord n1 n2 eq_n) (cast_ord (esym eq_n)). +Proof. by move=> i; exact: val_inj. Qed. + +Lemma cast_ordKV n1 n2 eq_n : + cancel (cast_ord (esym eq_n)) (@cast_ord n1 n2 eq_n). +Proof. by move=> i; exact: val_inj. Qed. + +Lemma cast_ord_inj n1 n2 eq_n : injective (@cast_ord n1 n2 eq_n). +Proof. exact: can_inj (cast_ordK eq_n). Qed. + +Lemma rev_ord_proof n (i : 'I_n) : n - i.+1 < n. +Proof. by case: n i => [|n] [i lt_i_n] //; rewrite ltnS subSS leq_subr. Qed. +Definition rev_ord n i := Ordinal (@rev_ord_proof n i). + +Lemma rev_ordK n : involutive (@rev_ord n). +Proof. +by case: n => [|n] [i lti] //; apply: val_inj; rewrite /= !subSS subKn. +Qed. + +Lemma rev_ord_inj {n} : injective (@rev_ord n). +Proof. exact: inv_inj (@rev_ordK n). Qed. + +(* bijection between any finType T and the Ordinal finType of its cardinal *) +Section EnumRank. + +Variable T : finType. +Implicit Type A : pred T. + +Lemma enum_rank_subproof x0 A : x0 \in A -> 0 < #|A|. +Proof. by move=> Ax0; rewrite (cardD1 x0) Ax0. Qed. + +Definition enum_rank_in x0 A (Ax0 : x0 \in A) x := + insubd (Ordinal (@enum_rank_subproof x0 [eta A] Ax0)) (index x (enum A)). + +Definition enum_rank x := @enum_rank_in x T (erefl true) x. + +Lemma enum_default A : 'I_(#|A|) -> T. +Proof. by rewrite cardE; case: (enum A) => [|//] []. Qed. + +Definition enum_val A i := nth (@enum_default [eta A] i) (enum A) i. +Prenex Implicits enum_val. + +Lemma enum_valP A i : @enum_val A i \in A. +Proof. by rewrite -mem_enum mem_nth -?cardE. Qed. + +Lemma enum_val_nth A x i : @enum_val A i = nth x (enum A) i. +Proof. by apply: set_nth_default; rewrite cardE in i *; apply: ltn_ord. Qed. + +Lemma nth_image T' y0 (f : T -> T') A (i : 'I_#|A|) : + nth y0 (image f A) i = f (enum_val i). +Proof. by rewrite -(nth_map _ y0) // -cardE. Qed. + +Lemma nth_codom T' y0 (f : T -> T') (i : 'I_#|T|) : + nth y0 (codom f) i = f (enum_val i). +Proof. exact: nth_image. Qed. + +Lemma nth_enum_rank_in x00 x0 A Ax0 : + {in A, cancel (@enum_rank_in x0 A Ax0) (nth x00 (enum A))}. +Proof. +move=> x Ax; rewrite /= insubdK ?nth_index ?mem_enum //. +by rewrite cardE [_ \in _]index_mem mem_enum. +Qed. + +Lemma nth_enum_rank x0 : cancel enum_rank (nth x0 (enum T)). +Proof. by move=> x; apply: nth_enum_rank_in. Qed. + +Lemma enum_rankK_in x0 A Ax0 : + {in A, cancel (@enum_rank_in x0 A Ax0) enum_val}. +Proof. by move=> x; apply: nth_enum_rank_in. Qed. + +Lemma enum_rankK : cancel enum_rank enum_val. +Proof. by move=> x; apply: enum_rankK_in. Qed. + +Lemma enum_valK_in x0 A Ax0 : cancel enum_val (@enum_rank_in x0 A Ax0). +Proof. +move=> x; apply: ord_inj; rewrite insubdK; last first. + by rewrite cardE [_ \in _]index_mem mem_nth // -cardE. +by rewrite index_uniq ?enum_uniq // -cardE. +Qed. + +Lemma enum_valK : cancel enum_val enum_rank. +Proof. by move=> x; apply: enum_valK_in. Qed. + +Lemma enum_rank_inj : injective enum_rank. +Proof. exact: can_inj enum_rankK. Qed. + +Lemma enum_val_inj A : injective (@enum_val A). +Proof. by move=> i; apply: can_inj (enum_valK_in (enum_valP i)) (i). Qed. + +Lemma enum_val_bij_in x0 A : x0 \in A -> {on A, bijective (@enum_val A)}. +Proof. +move=> Ax0; exists (enum_rank_in Ax0) => [i _|]; last exact: enum_rankK_in. +exact: enum_valK_in. +Qed. + +Lemma enum_rank_bij : bijective enum_rank. +Proof. by move: enum_rankK enum_valK; exists (@enum_val T). Qed. + +Lemma enum_val_bij : bijective (@enum_val T). +Proof. by move: enum_rankK enum_valK; exists enum_rank. Qed. + +(* Due to the limitations of the Coq unification patterns, P can only be *) +(* inferred from the premise of this lemma, not its conclusion. As a result *) +(* this lemma will only be usable in forward chaining style. *) +Lemma fin_all_exists U (P : forall x : T, U x -> Prop) : + (forall x, exists u, P x u) -> (exists u, forall x, P x (u x)). +Proof. +move=> ex_u; pose Q m x := enum_rank x < m -> {ux | P x ux}. +suffices: forall m, m <= #|T| -> exists w : forall x, Q m x, True. + case/(_ #|T|)=> // w _; pose u x := sval (w x (ltn_ord _)). + by exists u => x; rewrite {}/u; case: (w x _). +elim=> [|m IHm] ltmX; first by have w x: Q 0 x by []; exists w. +have{IHm} [w _] := IHm (ltnW ltmX); pose i := Ordinal ltmX. +have [u Pu] := ex_u (enum_val i); suffices w' x: Q m.+1 x by exists w'. +rewrite /Q ltnS leq_eqVlt (val_eqE _ i); case: eqP => [def_i _ | _ /w //]. +by rewrite -def_i enum_rankK in u Pu; exists u. +Qed. + +Lemma fin_all_exists2 U (P Q : forall x : T, U x -> Prop) : + (forall x, exists2 u, P x u & Q x u) -> + (exists2 u, forall x, P x (u x) & forall x, Q x (u x)). +Proof. +move=> ex_u; have (x): exists u, P x u /\ Q x u by have [u] := ex_u x; exists u. +by case/fin_all_exists=> u /all_and2[]; exists u. +Qed. + +End EnumRank. + +Implicit Arguments enum_val_inj [[T] [A] x1 x2]. +Implicit Arguments enum_rank_inj [[T] x1 x2]. +Prenex Implicits enum_val enum_rank. + +Lemma enum_rank_ord n i : enum_rank i = cast_ord (esym (card_ord n)) i. +Proof. +by apply: val_inj; rewrite insubdK ?index_enum_ord // card_ord [_ \in _]ltn_ord. +Qed. + +Lemma enum_val_ord n i : enum_val i = cast_ord (card_ord n) i. +Proof. +by apply: canLR (@enum_rankK _) _; apply: val_inj; rewrite enum_rank_ord. +Qed. + +(* The integer bump / unbump operations. *) + +Definition bump h i := (h <= i) + i. +Definition unbump h i := i - (h < i). + +Lemma bumpK h : cancel (bump h) (unbump h). +Proof. +rewrite /bump /unbump => i. +have [le_hi | lt_ih] := leqP h i; first by rewrite ltnS le_hi subn1. +by rewrite ltnNge ltnW ?subn0. +Qed. + +Lemma neq_bump h i : h != bump h i. +Proof. +rewrite /bump eqn_leq; have [le_hi | lt_ih] := leqP h i. + by rewrite ltnNge le_hi andbF. +by rewrite leqNgt lt_ih. +Qed. + +Lemma unbumpKcond h i : bump h (unbump h i) = (i == h) + i. +Proof. +rewrite /bump /unbump leqNgt -subSKn. +case: (ltngtP i h) => /= [-> | ltih | ->] //; last by rewrite ltnn. +by rewrite subn1 /= leqNgt !(ltn_predK ltih, ltih, add1n). +Qed. + +Lemma unbumpK h : {in predC1 h, cancel (unbump h) (bump h)}. +Proof. by move=> i; move/negbTE=> neq_h_i; rewrite unbumpKcond neq_h_i. Qed. + +Lemma bump_addl h i k : bump (k + h) (k + i) = k + bump h i. +Proof. by rewrite /bump leq_add2l addnCA. Qed. + +Lemma bumpS h i : bump h.+1 i.+1 = (bump h i).+1. +Proof. exact: addnS. Qed. + +Lemma unbump_addl h i k : unbump (k + h) (k + i) = k + unbump h i. +Proof. +apply: (can_inj (bumpK (k + h))). +by rewrite bump_addl !unbumpKcond eqn_add2l addnCA. +Qed. + +Lemma unbumpS h i : unbump h.+1 i.+1 = (unbump h i).+1. +Proof. exact: unbump_addl 1. Qed. + +Lemma leq_bump h i j : (i <= bump h j) = (unbump h i <= j). +Proof. +rewrite /bump leq_subLR. +case: (leqP i h) (leqP h j) => [le_i_h | lt_h_i] [le_h_j | lt_j_h] //. + by rewrite leqW (leq_trans le_i_h). +by rewrite !(leqNgt i) ltnW (leq_trans _ lt_h_i). +Qed. + +Lemma leq_bump2 h i j : (bump h i <= bump h j) = (i <= j). +Proof. by rewrite leq_bump bumpK. Qed. + +Lemma bumpC h1 h2 i : + bump h1 (bump h2 i) = bump (bump h1 h2) (bump (unbump h2 h1) i). +Proof. +rewrite {1 5}/bump -leq_bump addnCA; congr (_ + (_ + _)). +rewrite 2!leq_bump /unbump /bump; case: (leqP h1 h2) => [le_h12 | lt_h21]. + by rewrite subn0 ltnS le_h12 subn1. +by rewrite subn1 (ltn_predK lt_h21) (leqNgt h1) lt_h21 subn0. +Qed. + +(* The lift operations on ordinals; to avoid a messy dependent type, *) +(* unlift is a partial operation (returns an option). *) + +Lemma lift_subproof n h (i : 'I_n.-1) : bump h i < n. +Proof. by case: n i => [[]|n] //= i; rewrite -addnS (leq_add (leq_b1 _)). Qed. + +Definition lift n (h : 'I_n) (i : 'I_n.-1) := Ordinal (lift_subproof h i). + +Lemma unlift_subproof n (h : 'I_n) (u : {j | j != h}) : unbump h (val u) < n.-1. +Proof. +case: n h u => [|n h] [] //= j ne_jh. +rewrite -(leq_bump2 h.+1) bumpS unbumpK // /bump. +case: (ltngtP n h) => [|_|eq_nh]; rewrite ?(leqNgt _ h) ?ltn_ord //. +by rewrite ltn_neqAle [j <= _](valP j) {2}eq_nh andbT. +Qed. + +Definition unlift n (h i : 'I_n) := + omap (fun u : {j | j != h} => Ordinal (unlift_subproof u)) (insub i). + +CoInductive unlift_spec n h i : option 'I_n.-1 -> Type := + | UnliftSome j of i = lift h j : unlift_spec h i (Some j) + | UnliftNone of i = h : unlift_spec h i None. + +Lemma unliftP n (h i : 'I_n) : unlift_spec h i (unlift h i). +Proof. +rewrite /unlift; case: insubP => [u nhi | ] def_i /=; constructor. + by apply: val_inj; rewrite /= def_i unbumpK. +by rewrite negbK in def_i; exact/eqP. +Qed. + +Lemma neq_lift n (h : 'I_n) i : h != lift h i. +Proof. exact: neq_bump. Qed. + +Lemma unlift_none n (h : 'I_n) : unlift h h = None. +Proof. by case: unliftP => // j Dh; case/eqP: (neq_lift h j). Qed. + +Lemma unlift_some n (h i : 'I_n) : + h != i -> {j | i = lift h j & unlift h i = Some j}. +Proof. +rewrite eq_sym => /eqP neq_ih. +by case Dui: (unlift h i) / (unliftP h i) => [j Dh|//]; exists j. +Qed. + +Lemma lift_inj n (h : 'I_n) : injective (lift h). +Proof. +move=> i1 i2; move/eqP; rewrite [_ == _](can_eq (@bumpK _)) => eq_i12. +exact/eqP. +Qed. + +Lemma liftK n (h : 'I_n) : pcancel (lift h) (unlift h). +Proof. +by move=> i; case: (unlift_some (neq_lift h i)) => j; move/lift_inj->. +Qed. + +(* Shifting and splitting indices, for cutting and pasting arrays *) + +Lemma lshift_subproof m n (i : 'I_m) : i < m + n. +Proof. by apply: leq_trans (valP i) _; exact: leq_addr. Qed. + +Lemma rshift_subproof m n (i : 'I_n) : m + i < m + n. +Proof. by rewrite ltn_add2l. Qed. + +Definition lshift m n (i : 'I_m) := Ordinal (lshift_subproof n i). +Definition rshift m n (i : 'I_n) := Ordinal (rshift_subproof m i). + +Lemma split_subproof m n (i : 'I_(m + n)) : i >= m -> i - m < n. +Proof. by move/subSn <-; rewrite leq_subLR. Qed. + +Definition split m n (i : 'I_(m + n)) : 'I_m + 'I_n := + match ltnP (i) m with + | LtnNotGeq lt_i_m => inl _ (Ordinal lt_i_m) + | GeqNotLtn ge_i_m => inr _ (Ordinal (split_subproof ge_i_m)) + end. + +CoInductive split_spec m n (i : 'I_(m + n)) : 'I_m + 'I_n -> bool -> Type := + | SplitLo (j : 'I_m) of i = j :> nat : split_spec i (inl _ j) true + | SplitHi (k : 'I_n) of i = m + k :> nat : split_spec i (inr _ k) false. + +Lemma splitP m n (i : 'I_(m + n)) : split_spec i (split i) (i < m). +Proof. +rewrite /split {-3}/leq. +by case: (@ltnP i m) => cmp_i_m //=; constructor; rewrite ?subnKC. +Qed. + +Definition unsplit m n (jk : 'I_m + 'I_n) := + match jk with inl j => lshift n j | inr k => rshift m k end. + +Lemma ltn_unsplit m n (jk : 'I_m + 'I_n) : (unsplit jk < m) = jk. +Proof. by case: jk => [j|k]; rewrite /= ?ltn_ord // ltnNge leq_addr. Qed. + +Lemma splitK m n : cancel (@split m n) (@unsplit m n). +Proof. by move=> i; apply: val_inj; case: splitP. Qed. + +Lemma unsplitK m n : cancel (@unsplit m n) (@split m n). +Proof. +move=> jk; have:= ltn_unsplit jk. +by do [case: splitP; case: jk => //= i j] => [|/addnI] => /ord_inj->. +Qed. + +Section OrdinalPos. + +Variable n' : nat. +Local Notation n := n'.+1. + +Definition ord0 := Ordinal (ltn0Sn n'). +Definition ord_max := Ordinal (ltnSn n'). + +Lemma leq_ord (i : 'I_n) : i <= n'. Proof. exact: valP i. Qed. + +Lemma sub_ord_proof m : n' - m < n. +Proof. by rewrite ltnS leq_subr. Qed. +Definition sub_ord m := Ordinal (sub_ord_proof m). + +Lemma sub_ordK (i : 'I_n) : n' - (n' - i) = i. +Proof. by rewrite subKn ?leq_ord. Qed. + +Definition inord m : 'I_n := insubd ord0 m. + +Lemma inordK m : m < n -> inord m = m :> nat. +Proof. by move=> lt_m; rewrite val_insubd lt_m. Qed. + +Lemma inord_val (i : 'I_n) : inord i = i. +Proof. by rewrite /inord /insubd valK. Qed. + +Lemma enum_ordS : enum 'I_n = ord0 :: map (lift ord0) (enum 'I_n'). +Proof. +apply: (inj_map val_inj); rewrite val_enum_ord /= -map_comp. +by rewrite (map_comp (addn 1)) val_enum_ord -iota_addl. +Qed. + +Lemma lift_max (i : 'I_n') : lift ord_max i = i :> nat. +Proof. by rewrite /= /bump leqNgt ltn_ord. Qed. + +Lemma lift0 (i : 'I_n') : lift ord0 i = i.+1 :> nat. Proof. by []. Qed. + +End OrdinalPos. + +Implicit Arguments ord0 [[n']]. +Implicit Arguments ord_max [[n']]. +Implicit Arguments inord [[n']]. +Implicit Arguments sub_ord [[n']]. + +(* Product of two fintypes which is a fintype *) +Section ProdFinType. + +Variable T1 T2 : finType. + +Definition prod_enum := [seq (x1, x2) | x1 <- enum T1, x2 <- enum T2]. + +Lemma predX_prod_enum (A1 : pred T1) (A2 : pred T2) : + count [predX A1 & A2] prod_enum = #|A1| * #|A2|. +Proof. +rewrite !cardE !size_filter -!enumT /prod_enum. +elim: (enum T1) => //= x1 s1 IHs; rewrite count_cat {}IHs count_map /preim /=. +by case: (x1 \in A1); rewrite ?count_pred0. +Qed. + +Lemma prod_enumP : Finite.axiom prod_enum. +Proof. +by case=> x1 x2; rewrite (predX_prod_enum (pred1 x1) (pred1 x2)) !card1. +Qed. + +Definition prod_finMixin := Eval hnf in FinMixin prod_enumP. +Canonical prod_finType := Eval hnf in FinType (T1 * T2) prod_finMixin. + +Lemma cardX (A1 : pred T1) (A2 : pred T2) : #|[predX A1 & A2]| = #|A1| * #|A2|. +Proof. by rewrite -predX_prod_enum unlock size_filter unlock. Qed. + +Lemma card_prod : #|{: T1 * T2}| = #|T1| * #|T2|. +Proof. by rewrite -cardX; apply: eq_card; case. Qed. + +Lemma eq_card_prod (A : pred (T1 * T2)) : A =i predT -> #|A| = #|T1| * #|T2|. +Proof. exact: eq_card_trans card_prod. Qed. + +End ProdFinType. + +Section TagFinType. + +Variables (I : finType) (T_ : I -> finType). + +Definition tag_enum := + flatten [seq [seq Tagged T_ x | x <- enumF (T_ i)] | i <- enumF I]. + +Lemma tag_enumP : Finite.axiom tag_enum. +Proof. +case=> i x; rewrite -(enumP i) /tag_enum -enumT. +elim: (enum I) => //= j e IHe. +rewrite count_cat count_map {}IHe; congr (_ + _). +rewrite -size_filter -cardE /=; case: eqP => [-> | ne_j_i]. + by apply: (@eq_card1 _ x) => y; rewrite -topredE /= tagged_asE ?eqxx. +by apply: eq_card0 => y. +Qed. + +Definition tag_finMixin := Eval hnf in FinMixin tag_enumP. +Canonical tag_finType := Eval hnf in FinType {i : I & T_ i} tag_finMixin. + +Lemma card_tagged : + #|{: {i : I & T_ i}}| = sumn (map (fun i => #|T_ i|) (enum I)). +Proof. +rewrite cardE !enumT {1}unlock size_flatten /shape -map_comp. +by congr (sumn _); apply: eq_map => i; rewrite /= size_map -enumT -cardE. +Qed. + +End TagFinType. + +Section SumFinType. + +Variables T1 T2 : finType. + +Definition sum_enum := + [seq inl _ x | x <- enumF T1] ++ [seq inr _ y | y <- enumF T2]. + +Lemma sum_enum_uniq : uniq sum_enum. +Proof. +rewrite cat_uniq -!enumT !(enum_uniq, map_inj_uniq); try by move=> ? ? []. +by rewrite andbT; apply/hasP=> [[_ /mapP[x _ ->] /mapP[]]]. +Qed. + +Lemma mem_sum_enum u : u \in sum_enum. +Proof. by case: u => x; rewrite mem_cat -!enumT map_f ?mem_enum ?orbT. Qed. + +Definition sum_finMixin := Eval hnf in UniqFinMixin sum_enum_uniq mem_sum_enum. +Canonical sum_finType := Eval hnf in FinType (T1 + T2) sum_finMixin. + +Lemma card_sum : #|{: T1 + T2}| = #|T1| + #|T2|. +Proof. by rewrite !cardT !enumT {1}unlock size_cat !size_map. Qed. + + +End SumFinType. diff --git a/mathcomp/discrete/generic_quotient.v b/mathcomp/discrete/generic_quotient.v new file mode 100644 index 0000000..1d9bd56 --- /dev/null +++ b/mathcomp/discrete/generic_quotient.v @@ -0,0 +1,727 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +(* -*- coding : utf-8 -*- *) + +Require Import ssreflect ssrfun ssrbool eqtype ssrnat choice seq fintype. + +(*****************************************************************************) +(* Provided a base type T, this files defines an interface for quotients Q *) +(* of the type T with explicit functions for canonical surjection (\pi *) +(* : T -> Q) and for choosing a representative (repr : Q -> T). It then *) +(* provide a helper to quotient T by a decidable equivalence relation (e *) +(* : rel T) if T is a choiceType (or encodable as a choiceType modulo e). *) +(* *) +(* See "Pragamatic Quotient Types in Coq", proceedings of ITP2013, *) +(* by Cyril Cohen. *) +(* *) +(* *** Generic Quotienting *** *) +(* QuotClass (reprK : cancel repr pi) == builds the quotient which *) +(* canonical surjection function is pi and which *) +(* representative selection function is repr. *) +(* QuotType Q class == packs the quotClass class to build a quotType *) +(* You may declare such elements as Canonical *) +(* \pi_Q x == the class in Q of the element x of T *) +(* \pi x == the class of x where Q is inferred from the context *) +(* repr c == canonical representative in T of the class c *) +(* [quotType of Q] == clone of the canonical quotType structure of Q on T *) +(* x = y %[mod Q] := \pi_Q x = \pi_Q y *) +(* <-> x and y are equal modulo Q *) +(* x <> y %[mod Q] := \pi_Q x <> \pi_Q y *) +(* x == y %[mod Q] := \pi_Q x == \pi_Q y *) +(* x != y %[mod Q] := \pi_Q x != \pi_Q y *) +(* *) +(* The quotient_scope is delimited by %qT *) +(* The most useful lemmas are piE and reprK *) +(* *) +(* *** Morphisms *** *) +(* One may declare existing functions and predicates as liftings of some *) +(* morphisms for a quotient. *) +(* PiMorph1 pi_f == where pi_f : {morph \pi : x / f x >-> fq x} *) +(* declares fq : Q -> Q as the lifting of f : T -> T *) +(* PiMorph2 pi_g == idem with pi_g : {morph \pi : x y / g x y >-> gq x y} *) +(* PiMono1 pi_p == idem with pi_p : {mono \pi : x / p x >-> pq x} *) +(* PiMono2 pi_r == idem with pi_r : {morph \pi : x y / r x y >-> rq x y} *) +(* PiMorph11 pi_f == idem with pi_f : {morph \pi : x / f x >-> fq x} *) +(* where fq : Q -> Q' and f : T -> T'. *) +(* PiMorph eq == Most general declaration of compatibility, *) +(* /!\ use with caution /!\ *) +(* One can use the following helpers to build the liftings which may or *) +(* may not satisfy the above properties (but if they do not, it is *) +(* probably not a good idea to define them): *) +(* lift_op1 Q f := lifts f : T -> T *) +(* lift_op2 Q g := lifts g : T -> T -> T *) +(* lift_fun1 Q p := lifts p : T -> R *) +(* lift_fun2 Q r := lifts r : T -> T -> R *) +(* lift_op11 Q Q' f := lifts f : T -> T' *) +(* There is also the special case of constants and embedding functions *) +(* that one may define and declare as compatible with Q using: *) +(* lift_cst Q x := lifts x : T to Q *) +(* PiConst c := declare the result c of the previous construction as *) +(* compatible with Q *) +(* lift_embed Q e := lifts e : R -> T to R -> Q *) +(* PiEmbed f := declare the result f of the previous construction as *) +(* compatible with Q *) +(* *) +(* *** Quotients that have an eqType structure *** *) +(* Having a canonical (eqQuotType e) structure enables piE to replace terms *) +(* of the form (x == y) by terms of the form (e x' y') if x and y are *) +(* canonical surjections of some x' and y'. *) +(* EqQuotType e Q m == builds an (eqQuotType e) structure on Q from the *) +(* morphism property m *) +(* where m : {mono \pi : x y / e x y >-> x == y} *) +(* [eqQuotType of Q] == clones the canonical eqQuotType structure of Q *) +(* *) +(* *** Equivalence and quotient by an equivalence *** *) +(* EquivRel r er es et == builds an equiv_rel structure based on the *) +(* reflexivity, symmetry and transitivity property *) +(* of a boolean relation. *) +(* {eq_quot e} == builds the quotType of T by equiv *) +(* where e : rel T is an equiv_rel *) +(* and T is a choiceType or a (choiceTypeMod e) *) +(* it is canonically an eqType, a choiceType, *) +(* a quotType and an eqQuotType. *) +(* x = y %[mod_eq e] := x = y %[mod {eq_quot e}] *) +(* <-> x and y are equal modulo e *) +(* ... *) +(*****************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Reserved Notation "\pi_ Q" (at level 0, format "\pi_ Q"). +Reserved Notation "\pi" (at level 0, format "\pi"). +Reserved Notation "{pi_ Q a }" + (at level 0, Q at next level, format "{pi_ Q a }"). +Reserved Notation "{pi a }" (at level 0, format "{pi a }"). +Reserved Notation "x == y %[mod_eq e ]" (at level 70, y at next level, + no associativity, format "'[hv ' x '/' == y '/' %[mod_eq e ] ']'"). +Reserved Notation "x = y %[mod_eq e ]" (at level 70, y at next level, + no associativity, format "'[hv ' x '/' = y '/' %[mod_eq e ] ']'"). +Reserved Notation "x != y %[mod_eq e ]" (at level 70, y at next level, + no associativity, format "'[hv ' x '/' != y '/' %[mod_eq e ] ']'"). +Reserved Notation "x <> y %[mod_eq e ]" (at level 70, y at next level, + no associativity, format "'[hv ' x '/' <> y '/' %[mod_eq e ] ']'"). +Reserved Notation "{eq_quot e }" (at level 0, e at level 0, + format "{eq_quot e }", only parsing). + +Delimit Scope quotient_scope with qT. +Local Open Scope quotient_scope. + +(*****************************************) +(* Definition of the quotient interface. *) +(*****************************************) + +Section QuotientDef. + +Variable T : Type. + +Record quot_mixin_of qT := QuotClass { + quot_repr : qT -> T; + quot_pi : T -> qT; + _ : cancel quot_repr quot_pi +}. + +Notation quot_class_of := quot_mixin_of. + +Record quotType := QuotTypePack { + quot_sort :> Type; + quot_class : quot_class_of quot_sort; + _ : Type +}. + +Definition QuotType_pack qT m := @QuotTypePack qT m qT. + +Variable qT : quotType. +Definition pi_phant of phant qT := quot_pi (quot_class qT). +Local Notation "\pi" := (pi_phant (Phant qT)). +Definition repr_of := quot_repr (quot_class qT). + +Lemma repr_ofK : cancel repr_of \pi. +Proof. by rewrite /pi_phant /repr_of /=; case:qT=> [? []]. Qed. + +Definition QuotType_clone (Q : Type) qT cT + of phant_id (quot_class qT) cT := @QuotTypePack Q cT Q. + +End QuotientDef. + +(****************************) +(* Protecting some symbols. *) +(****************************) + +Module Type PiSig. +Parameter f : forall (T : Type) (qT : quotType T), phant qT -> T -> qT. +Axiom E : f = pi_phant. +End PiSig. + +Module Pi : PiSig. +Definition f := pi_phant. +Definition E := erefl f. +End Pi. + +Module MPi : PiSig. +Definition f := pi_phant. +Definition E := erefl f. +End MPi. + +Module Type ReprSig. +Parameter f : forall (T : Type) (qT : quotType T), qT -> T. +Axiom E : f = repr_of. +End ReprSig. + +Module Repr : ReprSig. +Definition f := repr_of. +Definition E := erefl f. +End Repr. + +(*******************) +(* Fancy Notations *) +(*******************) + +Notation repr := Repr.f. +Notation "\pi_ Q" := (@Pi.f _ _ (Phant Q)) : quotient_scope. +Notation "\pi" := (@Pi.f _ _ (Phant _)) (only parsing) : quotient_scope. +Notation "x == y %[mod Q ]" := (\pi_Q x == \pi_Q y) : quotient_scope. +Notation "x = y %[mod Q ]" := (\pi_Q x = \pi_Q y) : quotient_scope. +Notation "x != y %[mod Q ]" := (\pi_Q x != \pi_Q y) : quotient_scope. +Notation "x <> y %[mod Q ]" := (\pi_Q x <> \pi_Q y) : quotient_scope. + +Local Notation "\mpi" := (@MPi.f _ _ (Phant _)). +Canonical mpi_unlock := Unlockable MPi.E. +Canonical pi_unlock := Unlockable Pi.E. +Canonical repr_unlock := Unlockable Repr.E. + +Notation quot_class_of := quot_mixin_of. +Notation QuotType Q m := (@QuotType_pack _ Q m). +Notation "[ 'quotType' 'of' Q ]" := (@QuotType_clone _ Q _ _ id) + (at level 0, format "[ 'quotType' 'of' Q ]") : form_scope. + +Implicit Arguments repr [T qT]. +Prenex Implicits repr. + +(************************) +(* Exporting the theory *) +(************************) + +Section QuotTypeTheory. + +Variable T : Type. +Variable qT : quotType T. + +Lemma reprK : cancel repr \pi_qT. +Proof. by move=> x; rewrite !unlock repr_ofK. Qed. + +CoInductive pi_spec (x : T) : T -> Type := + PiSpec y of x = y %[mod qT] : pi_spec x y. + +Lemma piP (x : T) : pi_spec x (repr (\pi_qT x)). +Proof. by constructor; rewrite reprK. Qed. + +Lemma mpiE : \mpi =1 \pi_qT. +Proof. by move=> x; rewrite !unlock. Qed. + +Lemma quotW P : (forall y : T, P (\pi_qT y)) -> forall x : qT, P x. +Proof. by move=> Py x; rewrite -[x]reprK; apply: Py. Qed. + +Lemma quotP P : (forall y : T, repr (\pi_qT y) = y -> P (\pi_qT y)) + -> forall x : qT, P x. +Proof. by move=> Py x; rewrite -[x]reprK; apply: Py; rewrite reprK. Qed. + +End QuotTypeTheory. + +(*******************) +(* About morphisms *) +(*******************) + +(* This was pi_morph T (x : T) := PiMorph { pi_op : T; _ : x = pi_op }. *) +Structure equal_to T (x : T) := EqualTo { + equal_val : T; + _ : x = equal_val +}. +Lemma equal_toE (T : Type) (x : T) (m : equal_to x) : equal_val m = x. +Proof. by case: m. Qed. + +Notation piE := (@equal_toE _ _). + +Canonical equal_to_pi T (qT : quotType T) (x : T) := + @EqualTo _ (\pi_qT x) (\pi x) (erefl _). + +Implicit Arguments EqualTo [T x equal_val]. +Prenex Implicits EqualTo. + +Section Morphism. + +Variables T U : Type. +Variable (qT : quotType T). +Variable (qU : quotType U). + +Variable (f : T -> T) (g : T -> T -> T) (p : T -> U) (r : T -> T -> U). +Variable (fq : qT -> qT) (gq : qT -> qT -> qT) (pq : qT -> U) (rq : qT -> qT -> U). +Variable (h : T -> U) (hq : qT -> qU). +Hypothesis pi_f : {morph \pi : x / f x >-> fq x}. +Hypothesis pi_g : {morph \pi : x y / g x y >-> gq x y}. +Hypothesis pi_p : {mono \pi : x / p x >-> pq x}. +Hypothesis pi_r : {mono \pi : x y / r x y >-> rq x y}. +Hypothesis pi_h : forall (x : T), \pi_qU (h x) = hq (\pi_qT x). +Variables (a b : T) (x : equal_to (\pi_qT a)) (y : equal_to (\pi_qT b)). + +(* Internal Lemmmas : do not use directly *) +Lemma pi_morph1 : \pi (f a) = fq (equal_val x). Proof. by rewrite !piE. Qed. +Lemma pi_morph2 : \pi (g a b) = gq (equal_val x) (equal_val y). Proof. by rewrite !piE. Qed. +Lemma pi_mono1 : p a = pq (equal_val x). Proof. by rewrite !piE. Qed. +Lemma pi_mono2 : r a b = rq (equal_val x) (equal_val y). Proof. by rewrite !piE. Qed. +Lemma pi_morph11 : \pi (h a) = hq (equal_val x). Proof. by rewrite !piE. Qed. + +End Morphism. + +Implicit Arguments pi_morph1 [T qT f fq]. +Implicit Arguments pi_morph2 [T qT g gq]. +Implicit Arguments pi_mono1 [T U qT p pq]. +Implicit Arguments pi_mono2 [T U qT r rq]. +Implicit Arguments pi_morph11 [T U qT qU h hq]. +Prenex Implicits pi_morph1 pi_morph2 pi_mono1 pi_mono2 pi_morph11. + +Notation "{pi_ Q a }" := (equal_to (\pi_Q a)) : quotient_scope. +Notation "{pi a }" := (equal_to (\pi a)) : quotient_scope. + +(* Declaration of morphisms *) +Notation PiMorph pi_x := (EqualTo pi_x). +Notation PiMorph1 pi_f := + (fun a (x : {pi a}) => EqualTo (pi_morph1 pi_f a x)). +Notation PiMorph2 pi_g := + (fun a b (x : {pi a}) (y : {pi b}) => EqualTo (pi_morph2 pi_g a b x y)). +Notation PiMono1 pi_p := + (fun a (x : {pi a}) => EqualTo (pi_mono1 pi_p a x)). +Notation PiMono2 pi_r := + (fun a b (x : {pi a}) (y : {pi b}) => EqualTo (pi_mono2 pi_r a b x y)). +Notation PiMorph11 pi_f := + (fun a (x : {pi a}) => EqualTo (pi_morph11 pi_f a x)). + +(* lifiting helpers *) +Notation lift_op1 Q f := (locked (fun x : Q => \pi_Q (f (repr x)) : Q)). +Notation lift_op2 Q g := + (locked (fun x y : Q => \pi_Q (g (repr x) (repr y)) : Q)). +Notation lift_fun1 Q f := (locked (fun x : Q => f (repr x))). +Notation lift_fun2 Q g := (locked (fun x y : Q => g (repr x) (repr y))). +Notation lift_op11 Q Q' f := (locked (fun x : Q => \pi_Q' (f (repr x)) : Q')). + +(* constant declaration *) +Notation lift_cst Q x := (locked (\pi_Q x : Q)). +Notation PiConst a := (@EqualTo _ _ a (lock _)). + +(* embedding declaration, please don't redefine \pi *) +Notation lift_embed qT e := (locked (fun x => \pi_qT (e x) : qT)). + +Lemma eq_lock T T' e : e =1 (@locked (T -> T') (fun x : T => e x)). +Proof. by rewrite -lock. Qed. +Prenex Implicits eq_lock. + +Notation PiEmbed e := + (fun x => @EqualTo _ _ (e x) (eq_lock (fun _ => \pi _) _)). + +(********************) +(* About eqQuotType *) +(********************) + +Section EqQuotTypeStructure. + +Variable T : Type. +Variable eq_quot_op : rel T. + +Definition eq_quot_mixin_of (Q : Type) (qc : quot_class_of T Q) + (ec : Equality.class_of Q) := + {mono \pi_(QuotTypePack qc Q) : x y / + eq_quot_op x y >-> @eq_op (Equality.Pack ec Q) x y}. + +Record eq_quot_class_of (Q : Type) : Type := EqQuotClass { + eq_quot_quot_class :> quot_class_of T Q; + eq_quot_eq_mixin :> Equality.class_of Q; + pi_eq_quot_mixin :> eq_quot_mixin_of eq_quot_quot_class eq_quot_eq_mixin +}. + +Record eqQuotType : Type := EqQuotTypePack { + eq_quot_sort :> Type; + _ : eq_quot_class_of eq_quot_sort; + _ : Type +}. + +Implicit Type eqT : eqQuotType. + +Definition eq_quot_class eqT : eq_quot_class_of eqT := + let: EqQuotTypePack _ cT _ as qT' := eqT return eq_quot_class_of qT' in cT. + +Canonical eqQuotType_eqType eqT := EqType eqT (eq_quot_class eqT). +Canonical eqQuotType_quotType eqT := QuotType eqT (eq_quot_class eqT). + +Coercion eqQuotType_eqType : eqQuotType >-> eqType. +Coercion eqQuotType_quotType : eqQuotType >-> quotType. + +Definition EqQuotType_pack Q := + fun (qT : quotType T) (eT : eqType) qc ec + of phant_id (quot_class qT) qc & phant_id (Equality.class eT) ec => + fun m => EqQuotTypePack (@EqQuotClass Q qc ec m) Q. + +Definition EqQuotType_clone (Q : Type) eqT cT + of phant_id (eq_quot_class eqT) cT := @EqQuotTypePack Q cT Q. + +Lemma pi_eq_quot eqT : {mono \pi_eqT : x y / eq_quot_op x y >-> x == y}. +Proof. by case: eqT => [] ? []. Qed. + +Canonical pi_eq_quot_mono eqT := PiMono2 (pi_eq_quot eqT). + +End EqQuotTypeStructure. + +Notation EqQuotType e Q m := (@EqQuotType_pack _ e Q _ _ _ _ id id m). +Notation "[ 'eqQuotType' e 'of' Q ]" := (@EqQuotType_clone _ e Q _ _ id) + (at level 0, format "[ 'eqQuotType' e 'of' Q ]") : form_scope. + +(**************************************************************************) +(* Even if a quotType is a natural subType, we do not make this subType *) +(* canonical, to allow the user to define the subtyping he wants. However *) +(* one can: *) +(* - get the eqMixin and the choiceMixin by subtyping *) +(* - get the subType structure and maybe declare it Canonical. *) +(**************************************************************************) + +Module QuotSubType. +Section SubTypeMixin. + +Variable T : eqType. +Variable qT : quotType T. + +Definition Sub x (px : repr (\pi_qT x) == x) := \pi_qT x. + +Lemma qreprK x Px : repr (@Sub x Px) = x. +Proof. by rewrite /Sub (eqP Px). Qed. + +Lemma sortPx (x : qT) : repr (\pi_qT (repr x)) == repr x. +Proof. by rewrite !reprK eqxx. Qed. + +Lemma sort_Sub (x : qT) : x = Sub (sortPx x). +Proof. by rewrite /Sub reprK. Qed. + +Lemma reprP K (PK : forall x Px, K (@Sub x Px)) u : K u. +Proof. by rewrite (sort_Sub u); apply: PK. Qed. + +Canonical subType := SubType _ _ _ reprP qreprK. +Definition eqMixin := Eval hnf in [eqMixin of qT by <:]. + +Canonical eqType := EqType qT eqMixin. + +End SubTypeMixin. + +Definition choiceMixin (T : choiceType) (qT : quotType T) := + Eval hnf in [choiceMixin of qT by <:]. +Canonical choiceType (T : choiceType) (qT : quotType T) := + ChoiceType qT (@choiceMixin T qT). + +Definition countMixin (T : countType) (qT : quotType T) := + Eval hnf in [countMixin of qT by <:]. +Canonical countType (T : countType) (qT : quotType T) := + CountType qT (@countMixin T qT). + +Section finType. +Variables (T : finType) (qT : quotType T). +Canonical subCountType := [subCountType of qT]. +Definition finMixin := Eval hnf in [finMixin of qT by <:]. +End finType. + +End QuotSubType. + +Notation "[ 'subType' Q 'of' T 'by' %/ ]" := +(@SubType T _ Q _ _ (@QuotSubType.reprP _ _) (@QuotSubType.qreprK _ _)) +(at level 0, format "[ 'subType' Q 'of' T 'by' %/ ]") : form_scope. + +Notation "[ 'eqMixin' 'of' Q 'by' <:%/ ]" := + (@QuotSubType.eqMixin _ _: Equality.class_of Q) + (at level 0, format "[ 'eqMixin' 'of' Q 'by' <:%/ ]") : form_scope. + +Notation "[ 'choiceMixin' 'of' Q 'by' <:%/ ]" := + (@QuotSubType.choiceMixin _ _: Choice.mixin_of Q) + (at level 0, format "[ 'choiceMixin' 'of' Q 'by' <:%/ ]") : form_scope. + +Notation "[ 'countMixin' 'of' Q 'by' <:%/ ]" := + (@QuotSubType.countMixin _ _: Countable.mixin_of Q) + (at level 0, format "[ 'countMixin' 'of' Q 'by' <:%/ ]") : form_scope. + +Notation "[ 'finMixin' 'of' Q 'by' <:%/ ]" := + (@QuotSubType.finMixin _ _: Finite.mixin_of Q) + (at level 0, format "[ 'finMixin' 'of' Q 'by' <:%/ ]") : form_scope. + +(****************************************************) +(* Definition of a (decidable) equivalence relation *) +(****************************************************) + +Section EquivRel. + +Variable T : Type. + +Lemma left_trans (e : rel T) : + symmetric e -> transitive e -> left_transitive e. +Proof. by move=> s t ? * ?; apply/idP/idP; apply: t; rewrite // s. Qed. + +Lemma right_trans (e : rel T) : + symmetric e -> transitive e -> right_transitive e. +Proof. by move=> s t ? * x; rewrite ![e x _]s; apply: left_trans. Qed. + +CoInductive equiv_class_of (equiv : rel T) := + EquivClass of reflexive equiv & symmetric equiv & transitive equiv. + +Record equiv_rel := EquivRelPack { + equiv :> rel T; + _ : equiv_class_of equiv +}. + +Variable e : equiv_rel. + +Definition equiv_class := + let: EquivRelPack _ ce as e' := e return equiv_class_of e' in ce. + +Definition equiv_pack (r : rel T) ce of phant_id ce equiv_class := + @EquivRelPack r ce. + +Lemma equiv_refl x : e x x. Proof. by case: e => [] ? []. Qed. +Lemma equiv_sym : symmetric e. Proof. by case: e => [] ? []. Qed. +Lemma equiv_trans : transitive e. Proof. by case: e => [] ? []. Qed. + +Lemma eq_op_trans (T' : eqType) : transitive (@eq_op T'). +Proof. by move=> x y z; move/eqP->; move/eqP->. Qed. + +Lemma equiv_ltrans: left_transitive e. +Proof. by apply: left_trans; [apply: equiv_sym|apply: equiv_trans]. Qed. + +Lemma equiv_rtrans: right_transitive e. +Proof. by apply: right_trans; [apply: equiv_sym|apply: equiv_trans]. Qed. + +End EquivRel. + +Hint Resolve equiv_refl. + +Notation EquivRel r er es et := (@EquivRelPack _ r (EquivClass er es et)). +Notation "[ 'equiv_rel' 'of' e ]" := (@equiv_pack _ _ e _ id) + (at level 0, format "[ 'equiv_rel' 'of' e ]") : form_scope. + +(**************************************************) +(* Encoding to another type modulo an equivalence *) +(**************************************************) + +Section EncodingModuloRel. + +Variables (D E : Type) (ED : E -> D) (DE : D -> E) (e : rel D). + +CoInductive encModRel_class_of (r : rel D) := + EncModRelClassPack of (forall x, r x x -> r (ED (DE x)) x) & (r =2 e). + +Record encModRel := EncModRelPack { + enc_mod_rel :> rel D; + _ : encModRel_class_of enc_mod_rel +}. + +Variable r : encModRel. + +Definition encModRelClass := + let: EncModRelPack _ c as r' := r return encModRel_class_of r' in c. + +Definition encModRelP (x : D) : r x x -> r (ED (DE x)) x. +Proof. by case: r => [] ? [] /= he _ /he. Qed. + +Definition encModRelE : r =2 e. Proof. by case: r => [] ? []. Qed. + +Definition encoded_equiv : rel E := [rel x y | r (ED x) (ED y)]. + +End EncodingModuloRel. + +Notation EncModRelClass m := + (EncModRelClassPack (fun x _ => m x) (fun _ _ => erefl _)). +Notation EncModRel r m := (@EncModRelPack _ _ _ _ _ r (EncModRelClass m)). + +Section EncodingModuloEquiv. + +Variables (D E : Type) (ED : E -> D) (DE : D -> E) (e : equiv_rel D). +Variable (r : encModRel ED DE e). + +Lemma enc_mod_rel_is_equiv : equiv_class_of (enc_mod_rel r). +Proof. +split => [x|x y|y x z]; rewrite !encModRelE //; first by rewrite equiv_sym. +by move=> exy /(equiv_trans exy). +Qed. + +Definition enc_mod_rel_equiv_rel := EquivRelPack enc_mod_rel_is_equiv. + +Definition encModEquivP (x : D) : r (ED (DE x)) x. +Proof. by rewrite encModRelP ?encModRelE. Qed. + +Local Notation e' := (encoded_equiv r). + +Lemma encoded_equivE : e' =2 [rel x y | e (ED x) (ED y)]. +Proof. by move=> x y; rewrite /encoded_equiv /= encModRelE. Qed. +Local Notation e'E := encoded_equivE. + +Lemma encoded_equiv_is_equiv : equiv_class_of e'. +Proof. +split => [x|x y|y x z]; rewrite !e'E //=; first by rewrite equiv_sym. +by move=> exy /(equiv_trans exy). +Qed. + +Canonical encoded_equiv_equiv_rel := EquivRelPack encoded_equiv_is_equiv. + +Lemma encoded_equivP x : e' (DE (ED x)) x. +Proof. by rewrite /encoded_equiv /= encModEquivP. Qed. + +End EncodingModuloEquiv. + +(**************************************) +(* Quotient by a equivalence relation *) +(**************************************) + +Module EquivQuot. +Section EquivQuot. + +Variables (D : Type) (C : choiceType) (CD : C -> D) (DC : D -> C). +Variables (eD : equiv_rel D) (encD : encModRel CD DC eD). +Notation eC := (encoded_equiv encD). + +Definition canon x := choose (eC x) (x). + +Record equivQuotient := EquivQuotient { + erepr : C; + _ : (frel canon) erepr erepr +}. + +Definition type_of of (phantom (rel _) encD) := equivQuotient. + +Lemma canon_id : forall x, (invariant canon canon) x. +Proof. +move=> x /=; rewrite /canon (@eq_choose _ _ (eC x)). + by rewrite (@choose_id _ (eC x) _ x) ?chooseP ?equiv_refl. +by move=> y; apply: equiv_ltrans; rewrite equiv_sym /= chooseP. +Qed. + +Definition pi := locked (fun x => EquivQuotient (canon_id x)). + +Lemma ereprK : cancel erepr pi. +Proof. +unlock pi; case=> x hx; move/eqP:(hx)=> hx'. +exact: (@val_inj _ _ [subType for erepr]). +Qed. + +Local Notation encDE := (encModRelE encD). +Local Notation encDP := (encModEquivP encD). +Canonical encD_equiv_rel := EquivRelPack (enc_mod_rel_is_equiv encD). + +Lemma pi_CD (x y : C) : reflect (pi x = pi y) (eC x y). +Proof. +apply: (iffP idP) => hxy. + apply: (can_inj ereprK); unlock pi canon => /=. + rewrite -(@eq_choose _ (eC x) (eC y)); last first. + by move=> z; rewrite /eC /=; apply: equiv_ltrans. + by apply: choose_id; rewrite ?equiv_refl //. +rewrite (equiv_trans (chooseP (equiv_refl _ _))) //=. +move: hxy => /(f_equal erepr) /=; unlock pi canon => /= ->. +by rewrite equiv_sym /= chooseP. +Qed. + +Lemma pi_DC (x y : D) : + reflect (pi (DC x) = pi (DC y)) (eD x y). +Proof. +apply: (iffP idP)=> hxy. + apply/pi_CD; rewrite /eC /=. + by rewrite (equiv_ltrans (encDP _)) (equiv_rtrans (encDP _)) /= encDE. +rewrite -encDE -(equiv_ltrans (encDP _)) -(equiv_rtrans (encDP _)) /=. +exact/pi_CD. +Qed. + +Lemma equivQTP : cancel (CD \o erepr) (pi \o DC). +Proof. +by move=> x; rewrite /= (pi_CD _ (erepr x) _) ?ereprK /eC /= ?encDP. +Qed. + +Local Notation qT := (type_of (Phantom (rel D) encD)). +Definition quotClass := QuotClass equivQTP. +Canonical quotType := QuotType qT quotClass. + +Lemma eqmodP x y : reflect (x = y %[mod qT]) (eD x y). +Proof. by apply: (iffP (pi_DC _ _)); rewrite !unlock. Qed. + +Fact eqMixin : Equality.mixin_of qT. Proof. exact: CanEqMixin ereprK. Qed. +Canonical eqType := EqType qT eqMixin. +Definition choiceMixin := CanChoiceMixin ereprK. +Canonical choiceType := ChoiceType qT choiceMixin. + +Lemma eqmodE x y : x == y %[mod qT] = eD x y. +Proof. exact: sameP eqP (@eqmodP _ _). Qed. + +Canonical eqQuotType := EqQuotType eD qT eqmodE. + +End EquivQuot. +End EquivQuot. + +Canonical EquivQuot.quotType. +Canonical EquivQuot.eqType. +Canonical EquivQuot.choiceType. +Canonical EquivQuot.eqQuotType. + +Notation "{eq_quot e }" := +(@EquivQuot.type_of _ _ _ _ _ _ (Phantom (rel _) e)) : quotient_scope. +Notation "x == y %[mod_eq r ]" := (x == y %[mod {eq_quot r}]) : quotient_scope. +Notation "x = y %[mod_eq r ]" := (x = y %[mod {eq_quot r}]) : quotient_scope. +Notation "x != y %[mod_eq r ]" := (x != y %[mod {eq_quot r}]) : quotient_scope. +Notation "x <> y %[mod_eq r ]" := (x <> y %[mod {eq_quot r}]) : quotient_scope. + +(***********************************************************) +(* If the type is directly a choiceType, no need to encode *) +(***********************************************************) + +Section DefaultEncodingModuloRel. + +Variables (D : choiceType) (r : rel D). + +Definition defaultEncModRelClass := + @EncModRelClassPack D D id id r r (fun _ rxx => rxx) (fun _ _ => erefl _). + +Canonical defaultEncModRel := EncModRelPack defaultEncModRelClass. + +End DefaultEncodingModuloRel. + +(***************************************************) +(* Recovering a potential countable type structure *) +(***************************************************) + +Section CountEncodingModuloRel. + +Variables (D : Type) (C : countType) (CD : C -> D) (DC : D -> C). +Variables (eD : equiv_rel D) (encD : encModRel CD DC eD). +Notation eC := (encoded_equiv encD). + +Fact eq_quot_countMixin : Countable.mixin_of {eq_quot encD}. +Proof. exact: CanCountMixin (@EquivQuot.ereprK _ _ _ _ _ _). Qed. +Canonical eq_quot_countType := CountType {eq_quot encD} eq_quot_countMixin. + +End CountEncodingModuloRel. + +Section EquivQuotTheory. + +Variables (T : choiceType) (e : equiv_rel T) (Q : eqQuotType e). + +Lemma eqmodE x y : x == y %[mod_eq e] = e x y. +Proof. by rewrite pi_eq_quot. Qed. + +Lemma eqmodP x y : reflect (x = y %[mod_eq e]) (e x y). +Proof. by rewrite -eqmodE; apply/eqP. Qed. + +End EquivQuotTheory. + +Prenex Implicits eqmodE eqmodP. + +Section EqQuotTheory. + +Variables (T : Type) (e : rel T) (Q : eqQuotType e). + +Lemma eqquotE x y : x == y %[mod Q] = e x y. +Proof. by rewrite pi_eq_quot. Qed. + +Lemma eqquotP x y : reflect (x = y %[mod Q]) (e x y). +Proof. by rewrite -eqquotE; apply/eqP. Qed. + +End EqQuotTheory. + +Prenex Implicits eqquotE eqquotP. diff --git a/mathcomp/discrete/path.v b/mathcomp/discrete/path.v new file mode 100644 index 0000000..804e673 --- /dev/null +++ b/mathcomp/discrete/path.v @@ -0,0 +1,890 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq. + +(******************************************************************************) +(* The basic theory of paths over an eqType; this file is essentially a *) +(* complement to seq.v. Paths are non-empty sequences that obey a progression *) +(* relation. They are passed around in three parts: the head and tail of the *) +(* sequence, and a proof of (boolean) predicate asserting the progression. *) +(* This "exploded" view is rarely embarrassing, as the first two parameters *) +(* are usually inferred from the type of the third; on the contrary, it saves *) +(* the hassle of constantly constructing and destructing a dependent record. *) +(* We define similarly cycles, for which we allow the empty sequence, *) +(* which represents a non-rooted empty cycle; by contrast, the "empty" path *) +(* from a point x is the one-item sequence containing only x. *) +(* We allow duplicates; uniqueness, if desired (as is the case for several *) +(* geometric constructions), must be asserted separately. We do provide *) +(* shorthand, but only for cycles, because the equational properties of *) +(* "path" and "uniq" are unfortunately incompatible (esp. wrt "cat"). *) +(* We define notations for the common cases of function paths, where the *) +(* progress relation is actually a function. In detail: *) +(* path e x p == x :: p is an e-path [:: x_0; x_1; ... ; x_n], i.e., we *) +(* e x_i x_{i+1} for all i < n. The path x :: p starts at x *) +(* and ends at last x p. *) +(* fpath f x p == x :: p is an f-path, where f is a function, i.e., p is of *) +(* the form [:: f x; f (f x); ...]. This is just a notation *) +(* for path (frel f) x p. *) +(* sorted e s == s is an e-sorted sequence: either s = [::], or s = x :: p *) +(* is an e-path (this is oten used with e = leq or ltn). *) +(* cycle e c == c is an e-cycle: either c = [::], or c = x :: p with *) +(* x :: (rcons p x) an e-path. *) +(* fcycle f c == c is an f-cycle, for a function f. *) +(* traject f x n == the f-path of size n starting at x *) +(* := [:: x; f x; ...; iter n.-1 f x] *) +(* looping f x n == the f-paths of size greater than n starting at x loop *) +(* back, or, equivalently, traject f x n contains all *) +(* iterates of f at x. *) +(* merge e s1 s2 == the e-sorted merge of sequences s1 and s2: this is always *) +(* a permutation of s1 ++ s2, and is e-sorted when s1 and s2 *) +(* are and e is total. *) +(* sort e s == a permutation of the sequence s, that is e-sorted when e *) +(* is total (computed by a merge sort with the merge function *) +(* above). *) +(* mem2 s x y == x, then y occur in the sequence (path) s; this is *) +(* non-strict: mem2 s x x = (x \in s). *) +(* next c x == the successor of the first occurrence of x in the sequence *) +(* c (viewed as a cycle), or x if x \notin c. *) +(* prev c x == the predecessor of the first occurrence of x in the *) +(* sequence c (viewed as a cycle), or x if x \notin c. *) +(* arc c x y == the sub-arc of the sequece c (viewed as a cycle) starting *) +(* at the first occurrence of x in c, and ending just before *) +(* the next ocurrence of y (in cycle order); arc c x y *) +(* returns an unspecified sub-arc of c if x and y do not both *) +(* occur in c. *) +(* ucycle e c <-> ucycleb e c (ucycle e c is a Coercion target of type Prop) *) +(* ufcycle f c <-> c is a simple f-cycle, for a function f. *) +(* shorten x p == the tail a duplicate-free subpath of x :: p with the same *) +(* endpoints (x and last x p), obtained by removing all loops *) +(* from x :: p. *) +(* rel_base e e' h b <-> the function h is a functor from relation e to *) +(* relation e', EXCEPT at points whose image under h satisfy *) +(* the "base" predicate b: *) +(* e' (h x) (h y) = e x y UNLESS b (h x) holds *) +(* This is the statement of the side condition of the path *) +(* functorial mapping lemma map_path. *) +(* fun_base f f' h b <-> the function h is a functor from function f to f', *) +(* except at the preimage of predicate b under h. *) +(* We also provide three segmenting dependently-typed lemmas (splitP, splitPl *) +(* and splitPr) whose elimination split a path x0 :: p at an internal point x *) +(* as follows: *) +(* - splitP applies when x \in p; it replaces p with (rcons p1 x ++ p2), so *) +(* that x appears explicitly at the end of the left part. The elimination *) +(* of splitP will also simultaneously replace take (index x p) with p1 and *) +(* drop (index x p).+1 p with p2. *) +(* - splitPl applies when x \in x0 :: p; it replaces p with p1 ++ p2 and *) +(* simulaneously generates an equation x = last x0 p. *) +(* - splitPr applies when x \in p; it replaces p with (p1 ++ x :: p2), so x *) +(* appears explicitly at the start of the right part. *) +(* The parts p1 and p2 are computed using index/take/drop in all cases, but *) +(* only splitP attemps to subsitute the explicit values. The substitution of *) +(* p can be deferred using the dependent equation generation feature of *) +(* ssreflect, e.g.: case/splitPr def_p: {1}p / x_in_p => [p1 p2] generates *) +(* the equation p = p1 ++ p2 instead of performing the substitution outright. *) +(* Similarly, eliminating the loop removal lemma shortenP simultaneously *) +(* replaces shorten e x p with a fresh constant p', and last x p with *) +(* last x p'. *) +(* Note that although all "path" functions actually operate on the *) +(* underlying sequence, we provide a series of lemmas that define their *) +(* interaction with thepath and cycle predicates, e.g., the cat_path equation *) +(* can be used to split the path predicate after splitting the underlying *) +(* sequence. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section Paths. + +Variables (n0 : nat) (T : Type). + +Section Path. + +Variables (x0_cycle : T) (e : rel T). + +Fixpoint path x (p : seq T) := + if p is y :: p' then e x y && path y p' else true. + +Lemma cat_path x p1 p2 : path x (p1 ++ p2) = path x p1 && path (last x p1) p2. +Proof. by elim: p1 x => [|y p1 Hrec] x //=; rewrite Hrec -!andbA. Qed. + +Lemma rcons_path x p y : path x (rcons p y) = path x p && e (last x p) y. +Proof. by rewrite -cats1 cat_path /= andbT. Qed. + +Lemma pathP x p x0 : + reflect (forall i, i < size p -> e (nth x0 (x :: p) i) (nth x0 p i)) + (path x p). +Proof. +elim: p x => [|y p IHp] x /=; first by left. +apply: (iffP andP) => [[e_xy /IHp e_p [] //] | e_p]. +by split; [exact: (e_p 0) | apply/(IHp y) => i; exact: e_p i.+1]. +Qed. + +Definition cycle p := if p is x :: p' then path x (rcons p' x) else true. + +Lemma cycle_path p : cycle p = path (last x0_cycle p) p. +Proof. by case: p => //= x p; rewrite rcons_path andbC. Qed. + +Lemma rot_cycle p : cycle (rot n0 p) = cycle p. +Proof. +case: n0 p => [|n] [|y0 p] //=; first by rewrite /rot /= cats0. +rewrite /rot /= -{3}(cat_take_drop n p) -cats1 -catA cat_path. +case: (drop n p) => [|z0 q]; rewrite /= -cats1 !cat_path /= !andbT andbC //. +by rewrite last_cat; repeat bool_congr. +Qed. + +Lemma rotr_cycle p : cycle (rotr n0 p) = cycle p. +Proof. by rewrite -rot_cycle rotrK. Qed. + +End Path. + +Lemma eq_path e e' : e =2 e' -> path e =2 path e'. +Proof. by move=> ee' x p; elim: p x => //= y p IHp x; rewrite ee' IHp. Qed. + +Lemma eq_cycle e e' : e =2 e' -> cycle e =1 cycle e'. +Proof. by move=> ee' [|x p] //=; exact: eq_path. Qed. + +Lemma sub_path e e' : subrel e e' -> forall x p, path e x p -> path e' x p. +Proof. by move=> ee' x p; elim: p x => //= y p IHp x /andP[/ee'-> /IHp]. Qed. + +Lemma rev_path e x p : + path e (last x p) (rev (belast x p)) = path (fun z => e^~ z) x p. +Proof. +elim: p x => //= y p IHp x; rewrite rev_cons rcons_path -{}IHp andbC. +by rewrite -(last_cons x) -rev_rcons -lastI rev_cons last_rcons. +Qed. + +End Paths. + +Implicit Arguments pathP [T e x p]. +Prenex Implicits pathP. + +Section EqPath. + +Variables (n0 : nat) (T : eqType) (x0_cycle : T) (e : rel T). +Implicit Type p : seq T. + +CoInductive split x : seq T -> seq T -> seq T -> Type := + Split p1 p2 : split x (rcons p1 x ++ p2) p1 p2. + +Lemma splitP p x (i := index x p) : + x \in p -> split x p (take i p) (drop i.+1 p). +Proof. +move=> p_x; have lt_ip: i < size p by rewrite index_mem. +by rewrite -{1}(cat_take_drop i p) (drop_nth x lt_ip) -cat_rcons nth_index. +Qed. + +CoInductive splitl x1 x : seq T -> Type := + Splitl p1 p2 of last x1 p1 = x : splitl x1 x (p1 ++ p2). + +Lemma splitPl x1 p x : x \in x1 :: p -> splitl x1 x p. +Proof. +rewrite inE; case: eqP => [->| _ /splitP[]]; first by rewrite -(cat0s p). +by split; exact: last_rcons. +Qed. + +CoInductive splitr x : seq T -> Type := + Splitr p1 p2 : splitr x (p1 ++ x :: p2). + +Lemma splitPr p x : x \in p -> splitr x p. +Proof. by case/splitP=> p1 p2; rewrite cat_rcons. Qed. + +Fixpoint next_at x y0 y p := + match p with + | [::] => if x == y then y0 else x + | y' :: p' => if x == y then y' else next_at x y0 y' p' + end. + +Definition next p x := if p is y :: p' then next_at x y y p' else x. + +Fixpoint prev_at x y0 y p := + match p with + | [::] => if x == y0 then y else x + | y' :: p' => if x == y' then y else prev_at x y0 y' p' + end. + +Definition prev p x := if p is y :: p' then prev_at x y y p' else x. + +Lemma next_nth p x : + next p x = if x \in p then + if p is y :: p' then nth y p' (index x p) else x + else x. +Proof. +case: p => //= y0 p. +elim: p {2 3 5}y0 => [|y' p IHp] y /=; rewrite (eq_sym y) inE; + by case: ifP => // _; exact: IHp. +Qed. + +Lemma prev_nth p x : + prev p x = if x \in p then + if p is y :: p' then nth y p (index x p') else x + else x. +Proof. +case: p => //= y0 p; rewrite inE orbC. +elim: p {2 5}y0 => [|y' p IHp] y; rewrite /= ?inE // (eq_sym y'). +by case: ifP => // _; exact: IHp. +Qed. + +Lemma mem_next p x : (next p x \in p) = (x \in p). +Proof. +rewrite next_nth; case p_x: (x \in p) => //. +case: p (index x p) p_x => [|y0 p'] //= i _; rewrite inE. +have [lt_ip | ge_ip] := ltnP i (size p'); first by rewrite orbC mem_nth. +by rewrite nth_default ?eqxx. +Qed. + +Lemma mem_prev p x : (prev p x \in p) = (x \in p). +Proof. +rewrite prev_nth; case p_x: (x \in p) => //; case: p => [|y0 p] // in p_x *. +by apply mem_nth; rewrite /= ltnS index_size. +Qed. + +(* ucycleb is the boolean predicate, but ucycle is defined as a Prop *) +(* so that it can be used as a coercion target. *) +Definition ucycleb p := cycle e p && uniq p. +Definition ucycle p : Prop := cycle e p && uniq p. + +(* Projections, used for creating local lemmas. *) +Lemma ucycle_cycle p : ucycle p -> cycle e p. +Proof. by case/andP. Qed. + +Lemma ucycle_uniq p : ucycle p -> uniq p. +Proof. by case/andP. Qed. + +Lemma next_cycle p x : cycle e p -> x \in p -> e x (next p x). +Proof. +case: p => //= y0 p; elim: p {1 3 5}y0 => [|z p IHp] y /=; rewrite inE. + by rewrite andbT; case: (x =P y) => // ->. +by case/andP=> eyz /IHp; case: (x =P y) => // ->. +Qed. + +Lemma prev_cycle p x : cycle e p -> x \in p -> e (prev p x) x. +Proof. +case: p => //= y0 p; rewrite inE orbC. +elim: p {1 5}y0 => [|z p IHp] y /=; rewrite ?inE. + by rewrite andbT; case: (x =P y0) => // ->. +by case/andP=> eyz /IHp; case: (x =P z) => // ->. +Qed. + +Lemma rot_ucycle p : ucycle (rot n0 p) = ucycle p. +Proof. by rewrite /ucycle rot_uniq rot_cycle. Qed. + +Lemma rotr_ucycle p : ucycle (rotr n0 p) = ucycle p. +Proof. by rewrite /ucycle rotr_uniq rotr_cycle. Qed. + +(* The "appears no later" partial preorder defined by a path. *) + +Definition mem2 p x y := y \in drop (index x p) p. + +Lemma mem2l p x y : mem2 p x y -> x \in p. +Proof. +by rewrite /mem2 -!index_mem size_drop ltn_subRL; apply/leq_ltn_trans/leq_addr. +Qed. + +Lemma mem2lf {p x y} : x \notin p -> mem2 p x y = false. +Proof. exact/contraNF/mem2l. Qed. + +Lemma mem2r p x y : mem2 p x y -> y \in p. +Proof. +by rewrite -[in y \in p](cat_take_drop (index x p) p) mem_cat orbC /mem2 => ->. +Qed. + +Lemma mem2rf {p x y} : y \notin p -> mem2 p x y = false. +Proof. exact/contraNF/mem2r. Qed. + +Lemma mem2_cat p1 p2 x y : + mem2 (p1 ++ p2) x y = mem2 p1 x y || mem2 p2 x y || (x \in p1) && (y \in p2). +Proof. +rewrite [LHS]/mem2 index_cat fun_if if_arg !drop_cat addKn. +case: ifPn => [p1x | /mem2lf->]; last by rewrite ltnNge leq_addr orbF. +by rewrite index_mem p1x mem_cat -orbA (orb_idl (@mem2r _ _ _)). +Qed. + +Lemma mem2_splice p1 p3 x y p2 : + mem2 (p1 ++ p3) x y -> mem2 (p1 ++ p2 ++ p3) x y. +Proof. +by rewrite !mem2_cat mem_cat andb_orr orbC => /or3P[]->; rewrite ?orbT. +Qed. + +Lemma mem2_splice1 p1 p3 x y z : + mem2 (p1 ++ p3) x y -> mem2 (p1 ++ z :: p3) x y. +Proof. exact: mem2_splice [::z]. Qed. + +Lemma mem2_cons x p y z : + mem2 (x :: p) y z = (if x == y then z \in x :: p else mem2 p y z). +Proof. by rewrite [LHS]/mem2 /=; case: ifP. Qed. + +Lemma mem2_seq1 x y z : mem2 [:: x] y z = (y == x) && (z == x). +Proof. by rewrite mem2_cons eq_sym inE. Qed. + +Lemma mem2_last y0 p x : mem2 p x (last y0 p) = (x \in p). +Proof. +apply/idP/idP; first exact: mem2l; rewrite -index_mem /mem2 => p_x. +by rewrite -nth_last -(subnKC p_x) -nth_drop mem_nth // size_drop subnSK. +Qed. + +Lemma mem2l_cat {p1 p2 x} : x \notin p1 -> mem2 (p1 ++ p2) x =1 mem2 p2 x. +Proof. by move=> p1'x y; rewrite mem2_cat (negPf p1'x) mem2lf ?orbF. Qed. + +Lemma mem2r_cat {p1 p2 x y} : y \notin p2 -> mem2 (p1 ++ p2) x y = mem2 p1 x y. +Proof. +by move=> p2'y; rewrite mem2_cat (negPf p2'y) -orbA orbC andbF mem2rf. +Qed. + +Lemma mem2lr_splice {p1 p2 p3 x y} : + x \notin p2 -> y \notin p2 -> mem2 (p1 ++ p2 ++ p3) x y = mem2 (p1 ++ p3) x y. +Proof. +move=> p2'x p2'y; rewrite catA !mem2_cat !mem_cat. +by rewrite (negPf p2'x) (negPf p2'y) (mem2lf p2'x) andbF !orbF. +Qed. + +CoInductive split2r x y : seq T -> Type := + Split2r p1 p2 of y \in x :: p2 : split2r x y (p1 ++ x :: p2). + +Lemma splitP2r p x y : mem2 p x y -> split2r x y p. +Proof. +move=> pxy; have px := mem2l pxy. +have:= pxy; rewrite /mem2 (drop_nth x) ?index_mem ?nth_index //. +by case/splitP: px => p1 p2; rewrite cat_rcons. +Qed. + +Fixpoint shorten x p := + if p is y :: p' then + if x \in p then shorten x p' else y :: shorten y p' + else [::]. + +CoInductive shorten_spec x p : T -> seq T -> Type := + ShortenSpec p' of path e x p' & uniq (x :: p') & subpred (mem p') (mem p) : + shorten_spec x p (last x p') p'. + +Lemma shortenP x p : path e x p -> shorten_spec x p (last x p) (shorten x p). +Proof. +move=> e_p; have: x \in x :: p by exact: mem_head. +elim: p x {1 3 5}x e_p => [|y2 p IHp] x y1. + by rewrite mem_seq1 => _ /eqP->. +rewrite inE orbC /= => /andP[ey12 /IHp {IHp}IHp]. +case: ifPn => [y2p_x _ | not_y2p_x /eqP def_x]. + have [p' e_p' Up' p'p] := IHp _ y2p_x. + by split=> // y /p'p; exact: predU1r. +have [p' e_p' Up' p'p] := IHp y2 (mem_head y2 p). +have{p'p} p'p z: z \in y2 :: p' -> z \in y2 :: p. + by rewrite !inE; case: (z == y2) => // /p'p. +rewrite -(last_cons y1) def_x; split=> //=; first by rewrite ey12. +by rewrite (contra (p'p y1)) -?def_x. +Qed. + +End EqPath. + + +(* Ordered paths and sorting. *) + +Section SortSeq. + +Variable T : eqType. +Variable leT : rel T. + +Definition sorted s := if s is x :: s' then path leT x s' else true. + +Lemma path_sorted x s : path leT x s -> sorted s. +Proof. by case: s => //= y s /andP[]. Qed. + +Lemma path_min_sorted x s : + {in s, forall y, leT x y} -> path leT x s = sorted s. +Proof. by case: s => //= y s -> //; exact: mem_head. Qed. + +Section Transitive. + +Hypothesis leT_tr : transitive leT. + +Lemma subseq_order_path x s1 s2 : + subseq s1 s2 -> path leT x s2 -> path leT x s1. +Proof. +elim: s2 x s1 => [|y s2 IHs] x [|z s1] //= {IHs}/(IHs y). +case: eqP => [-> | _] IHs /andP[] => [-> // | leTxy /IHs /=]. +by case/andP=> /(leT_tr leTxy)->. +Qed. + +Lemma order_path_min x s : path leT x s -> all (leT x) s. +Proof. +move/subseq_order_path=> le_x_s; apply/allP=> y. +by rewrite -sub1seq => /le_x_s/andP[]. +Qed. + +Lemma subseq_sorted s1 s2 : subseq s1 s2 -> sorted s2 -> sorted s1. +Proof. +case: s1 s2 => [|x1 s1] [|x2 s2] //= sub_s12 /(subseq_order_path sub_s12). +by case: eqP => [-> | _ /andP[]]. +Qed. + +Lemma sorted_filter a s : sorted s -> sorted (filter a s). +Proof. exact: subseq_sorted (filter_subseq a s). Qed. + +Lemma sorted_uniq : irreflexive leT -> forall s, sorted s -> uniq s. +Proof. +move=> leT_irr; elim=> //= x s IHs s_ord. +rewrite (IHs (path_sorted s_ord)) andbT; apply/negP=> s_x. +by case/allPn: (order_path_min s_ord); exists x; rewrite // leT_irr. +Qed. + +Lemma eq_sorted : antisymmetric leT -> + forall s1 s2, sorted s1 -> sorted s2 -> perm_eq s1 s2 -> s1 = s2. +Proof. +move=> leT_asym; elim=> [|x1 s1 IHs1] s2 //= ord_s1 ord_s2 eq_s12. + by case: {+}s2 (perm_eq_size eq_s12). +have s2_x1: x1 \in s2 by rewrite -(perm_eq_mem eq_s12) mem_head. +case: s2 s2_x1 eq_s12 ord_s2 => //= x2 s2; rewrite in_cons. +case: eqP => [<- _| ne_x12 /= s2_x1] eq_s12 ord_s2. + by rewrite {IHs1}(IHs1 s2) ?(@path_sorted x1) // -(perm_cons x1). +case: (ne_x12); apply: leT_asym; rewrite (allP (order_path_min ord_s2)) //. +have: x2 \in x1 :: s1 by rewrite (perm_eq_mem eq_s12) mem_head. +case/predU1P=> [eq_x12 | s1_x2]; first by case ne_x12. +by rewrite (allP (order_path_min ord_s1)). +Qed. + +Lemma eq_sorted_irr : irreflexive leT -> + forall s1 s2, sorted s1 -> sorted s2 -> s1 =i s2 -> s1 = s2. +Proof. +move=> leT_irr s1 s2 s1_sort s2_sort eq_s12. +have: antisymmetric leT. + by move=> m n /andP[? ltnm]; case/idP: (leT_irr m); exact: leT_tr ltnm. +by move/eq_sorted; apply=> //; apply: uniq_perm_eq => //; exact: sorted_uniq. +Qed. + +End Transitive. + +Hypothesis leT_total : total leT. + +Fixpoint merge s1 := + if s1 is x1 :: s1' then + let fix merge_s1 s2 := + if s2 is x2 :: s2' then + if leT x2 x1 then x2 :: merge_s1 s2' else x1 :: merge s1' s2 + else s1 in + merge_s1 + else id. + +Lemma merge_path x s1 s2 : + path leT x s1 -> path leT x s2 -> path leT x (merge s1 s2). +Proof. +elim: s1 s2 x => //= x1 s1 IHs1. +elim=> //= x2 s2 IHs2 x /andP[le_x_x1 ord_s1] /andP[le_x_x2 ord_s2]. +case: ifP => le_x21 /=; first by rewrite le_x_x2 {}IHs2 // le_x21. +by rewrite le_x_x1 IHs1 //=; have:= leT_total x2 x1; rewrite le_x21 /= => ->. +Qed. + +Lemma merge_sorted s1 s2 : sorted s1 -> sorted s2 -> sorted (merge s1 s2). +Proof. +case: s1 s2 => [|x1 s1] [|x2 s2] //= ord_s1 ord_s2. +case: ifP => le_x21 /=. + by apply: (@merge_path x2 (x1 :: s1)) => //=; rewrite le_x21. +by apply: merge_path => //=; have:= leT_total x2 x1; rewrite le_x21 /= => ->. +Qed. + +Lemma perm_merge s1 s2 : perm_eql (merge s1 s2) (s1 ++ s2). +Proof. +apply/perm_eqlP; rewrite perm_eq_sym; elim: s1 s2 => //= x1 s1 IHs1. +elim=> [|x2 s2 IHs2]; rewrite /= ?cats0 //. +case: ifP => _ /=; last by rewrite perm_cons. +by rewrite (perm_catCA (_ :: _) [::x2]) perm_cons. +Qed. + +Lemma mem_merge s1 s2 : merge s1 s2 =i s1 ++ s2. +Proof. by apply: perm_eq_mem; rewrite perm_merge. Qed. + +Lemma size_merge s1 s2 : size (merge s1 s2) = size (s1 ++ s2). +Proof. by apply: perm_eq_size; rewrite perm_merge. Qed. + +Lemma merge_uniq s1 s2 : uniq (merge s1 s2) = uniq (s1 ++ s2). +Proof. by apply: perm_eq_uniq; rewrite perm_merge. Qed. + +Fixpoint merge_sort_push s1 ss := + match ss with + | [::] :: ss' | [::] as ss' => s1 :: ss' + | s2 :: ss' => [::] :: merge_sort_push (merge s1 s2) ss' + end. + +Fixpoint merge_sort_pop s1 ss := + if ss is s2 :: ss' then merge_sort_pop (merge s1 s2) ss' else s1. + +Fixpoint merge_sort_rec ss s := + if s is [:: x1, x2 & s'] then + let s1 := if leT x1 x2 then [:: x1; x2] else [:: x2; x1] in + merge_sort_rec (merge_sort_push s1 ss) s' + else merge_sort_pop s ss. + +Definition sort := merge_sort_rec [::]. + +Lemma sort_sorted s : sorted (sort s). +Proof. +rewrite /sort; have allss: all sorted [::] by []. +elim: {s}_.+1 {-2}s [::] allss (ltnSn (size s)) => // n IHn s ss allss. +have: sorted s -> sorted (merge_sort_pop s ss). + elim: ss allss s => //= s2 ss IHss /andP[ord_s2 ord_ss] s ord_s. + exact: IHss ord_ss _ (merge_sorted ord_s ord_s2). +case: s => [|x1 [|x2 s _]]; try by auto. +move/ltnW/IHn; apply=> {n IHn s}; set s1 := if _ then _ else _. +have: sorted s1 by exact: (@merge_sorted [::x2] [::x1]). +elim: ss {x1 x2}s1 allss => /= [|s2 ss IHss] s1; first by rewrite andbT. +case/andP=> ord_s2 ord_ss ord_s1. +by case: {1}s2=> /= [|_ _]; [rewrite ord_s1 | exact: IHss (merge_sorted _ _)]. +Qed. + +Lemma perm_sort s : perm_eql (sort s) s. +Proof. +rewrite /sort; apply/perm_eqlP; pose catss := foldr (@cat T) [::]. +rewrite perm_eq_sym -{1}[s]/(catss [::] ++ s). +elim: {s}_.+1 {-2}s [::] (ltnSn (size s)) => // n IHn s ss. +have: perm_eq (catss ss ++ s) (merge_sort_pop s ss). + elim: ss s => //= s2 ss IHss s1; rewrite -{IHss}(perm_eqrP (IHss _)). + by rewrite perm_catC catA perm_catC perm_cat2l -perm_merge. +case: s => // x1 [//|x2 s _]; move/ltnW; move/IHn=> {n IHn}IHs. +rewrite -{IHs}(perm_eqrP (IHs _)) ifE; set s1 := if_expr _ _ _. +rewrite (catA _ [::_;_] s) {s}perm_cat2r. +apply: (@perm_eq_trans _ (catss ss ++ s1)). + by rewrite perm_cat2l /s1 -ifE; case: ifP; rewrite // (perm_catC [::_]). +elim: ss {x1 x2}s1 => /= [|s2 ss IHss] s1; first by rewrite cats0. +rewrite perm_catC; case def_s2: {2}s2=> /= [|y s2']; first by rewrite def_s2. +by rewrite catA -{IHss}(perm_eqrP (IHss _)) perm_catC perm_cat2l -perm_merge. +Qed. + +Lemma mem_sort s : sort s =i s. +Proof. by apply: perm_eq_mem; rewrite perm_sort. Qed. + +Lemma size_sort s : size (sort s) = size s. +Proof. by apply: perm_eq_size; rewrite perm_sort. Qed. + +Lemma sort_uniq s : uniq (sort s) = uniq s. +Proof. by apply: perm_eq_uniq; rewrite perm_sort. Qed. + +Lemma perm_sortP : transitive leT -> antisymmetric leT -> + forall s1 s2, reflect (sort s1 = sort s2) (perm_eq s1 s2). +Proof. +move=> leT_tr leT_asym s1 s2. +apply: (iffP idP) => eq12; last by rewrite -perm_sort eq12 perm_sort. +apply: eq_sorted; rewrite ?sort_sorted //. +by rewrite perm_sort (perm_eqlP eq12) -perm_sort. +Qed. + +End SortSeq. + +Lemma rev_sorted (T : eqType) (leT : rel T) s : + sorted leT (rev s) = sorted (fun y x => leT x y) s. +Proof. by case: s => //= x p; rewrite -rev_path lastI rev_rcons. Qed. + +Lemma ltn_sorted_uniq_leq s : sorted ltn s = uniq s && sorted leq s. +Proof. +case: s => //= n s; elim: s n => //= m s IHs n. +rewrite inE ltn_neqAle negb_or IHs -!andbA. +case sn: (n \in s); last do !bool_congr. +rewrite andbF; apply/and5P=> [[ne_nm lenm _ _ le_ms]]; case/negP: ne_nm. +rewrite eqn_leq lenm; exact: (allP (order_path_min leq_trans le_ms)). +Qed. + +Lemma iota_sorted i n : sorted leq (iota i n). +Proof. by elim: n i => // [[|n] //= IHn] i; rewrite IHn leqW. Qed. + +Lemma iota_ltn_sorted i n : sorted ltn (iota i n). +Proof. by rewrite ltn_sorted_uniq_leq iota_sorted iota_uniq. Qed. + +(* Function trajectories. *) + +Notation fpath f := (path (coerced_frel f)). +Notation fcycle f := (cycle (coerced_frel f)). +Notation ufcycle f := (ucycle (coerced_frel f)). + +Prenex Implicits path next prev cycle ucycle mem2. + +Section Trajectory. + +Variables (T : Type) (f : T -> T). + +Fixpoint traject x n := if n is n'.+1 then x :: traject (f x) n' else [::]. + +Lemma trajectS x n : traject x n.+1 = x :: traject (f x) n. +Proof. by []. Qed. + +Lemma trajectSr x n : traject x n.+1 = rcons (traject x n) (iter n f x). +Proof. by elim: n x => //= n IHn x; rewrite IHn -iterSr. Qed. + +Lemma last_traject x n : last x (traject (f x) n) = iter n f x. +Proof. by case: n => // n; rewrite iterSr trajectSr last_rcons. Qed. + +Lemma traject_iteri x n : + traject x n = iteri n (fun i => rcons^~ (iter i f x)) [::]. +Proof. by elim: n => //= n <-; rewrite -trajectSr. Qed. + +Lemma size_traject x n : size (traject x n) = n. +Proof. by elim: n x => //= n IHn x //=; rewrite IHn. Qed. + +Lemma nth_traject i n : i < n -> forall x, nth x (traject x n) i = iter i f x. +Proof. +elim: n => // n IHn; rewrite ltnS leq_eqVlt => le_i_n x. +rewrite trajectSr nth_rcons size_traject. +case: ltngtP le_i_n => [? _||->] //; exact: IHn. +Qed. + +End Trajectory. + +Section EqTrajectory. + +Variables (T : eqType) (f : T -> T). + +Lemma eq_fpath f' : f =1 f' -> fpath f =2 fpath f'. +Proof. by move/eq_frel/eq_path. Qed. + +Lemma eq_fcycle f' : f =1 f' -> fcycle f =1 fcycle f'. +Proof. by move/eq_frel/eq_cycle. Qed. + +Lemma fpathP x p : reflect (exists n, p = traject f (f x) n) (fpath f x p). +Proof. +elim: p x => [|y p IHp] x; first by left; exists 0. +rewrite /= andbC; case: IHp => [fn_p | not_fn_p]; last first. + by right=> [] [[//|n]] [<- fn_p]; case: not_fn_p; exists n. +apply: (iffP eqP) => [-> | [[] // _ []//]]. +by have [n ->] := fn_p; exists n.+1. +Qed. + +Lemma fpath_traject x n : fpath f x (traject f (f x) n). +Proof. by apply/(fpathP x); exists n. Qed. + +Definition looping x n := iter n f x \in traject f x n. + +Lemma loopingP x n : + reflect (forall m, iter m f x \in traject f x n) (looping x n). +Proof. +apply: (iffP idP) => loop_n; last exact: loop_n. +case: n => // n in loop_n *; elim=> [|m /= IHm]; first exact: mem_head. +move: (fpath_traject x n) loop_n; rewrite /looping !iterS -last_traject /=. +move: (iter m f x) IHm => y /splitPl[p1 p2 def_y]. +rewrite cat_path last_cat def_y; case: p2 => // z p2 /and3P[_ /eqP-> _] _. +by rewrite inE mem_cat mem_head !orbT. +Qed. + +Lemma trajectP x n y : + reflect (exists2 i, i < n & y = iter i f x) (y \in traject f x n). +Proof. +elim: n x => [|n IHn] x /=; first by right; case. +rewrite inE; have [-> | /= neq_xy] := eqP; first by left; exists 0. +apply: {IHn}(iffP (IHn _)) => [[i] | [[|i]]] // lt_i_n ->. + by exists i.+1; rewrite ?iterSr. +by exists i; rewrite ?iterSr. +Qed. + +Lemma looping_uniq x n : uniq (traject f x n.+1) = ~~ looping x n. +Proof. +rewrite /looping; elim: n x => [|n IHn] x //. +rewrite {-3}[n.+1]lock /= -lock {}IHn -iterSr -negb_or inE; congr (~~ _). +apply: orb_id2r => /trajectP no_loop. +apply/idP/eqP => [/trajectP[m le_m_n def_x] | {1}<-]; last first. + by rewrite iterSr -last_traject mem_last. +have loop_m: looping x m.+1 by rewrite /looping iterSr -def_x mem_head. +have/trajectP[[|i] // le_i_m def_fn1x] := loopingP _ _ loop_m n.+1. +by case: no_loop; exists i; rewrite -?iterSr // -ltnS (leq_trans le_i_m). +Qed. + +End EqTrajectory. + +Implicit Arguments fpathP [T f x p]. +Implicit Arguments loopingP [T f x n]. +Implicit Arguments trajectP [T f x n y]. +Prenex Implicits traject fpathP loopingP trajectP. + +Section UniqCycle. + +Variables (n0 : nat) (T : eqType) (e : rel T) (p : seq T). + +Hypothesis Up : uniq p. + +Lemma prev_next : cancel (next p) (prev p). +Proof. +move=> x; rewrite prev_nth mem_next next_nth; case p_x: (x \in p) => //. +case def_p: p Up p_x => // [y q]; rewrite -{-1}def_p => /= /andP[not_qy Uq] p_x. +rewrite -{2}(nth_index y p_x); congr (nth y _ _); set i := index x p. +have: ~~ (size q < i) by rewrite -index_mem -/i def_p leqNgt in p_x. +case: ltngtP => // [lt_i_q | ->] _; first by rewrite index_uniq. +by apply/eqP; rewrite nth_default // eqn_leq index_size leqNgt index_mem. +Qed. + +Lemma next_prev : cancel (prev p) (next p). +Proof. +move=> x; rewrite next_nth mem_prev prev_nth; case p_x: (x \in p) => //. +case def_p: p p_x => // [y q]; rewrite -def_p => p_x. +rewrite index_uniq //; last by rewrite def_p ltnS index_size. +case q_x: (x \in q); first exact: nth_index. +rewrite nth_default; last by rewrite leqNgt index_mem q_x. +by apply/eqP; rewrite def_p inE q_x orbF eq_sym in p_x. +Qed. + +Lemma cycle_next : fcycle (next p) p. +Proof. +case def_p: {-2}p Up => [|x q] Uq //. +apply/(pathP x)=> i; rewrite size_rcons => le_i_q. +rewrite -cats1 -cat_cons nth_cat le_i_q /= next_nth {}def_p mem_nth //. +rewrite index_uniq // nth_cat /= ltn_neqAle andbC -ltnS le_i_q. +by case: (i =P _) => //= ->; rewrite subnn nth_default. +Qed. + +Lemma cycle_prev : cycle (fun x y => x == prev p y) p. +Proof. +apply: etrans cycle_next; symmetry; case def_p: p => [|x q] //. +apply: eq_path; rewrite -def_p; exact (can2_eq prev_next next_prev). +Qed. + +Lemma cycle_from_next : (forall x, x \in p -> e x (next p x)) -> cycle e p. +Proof. +case: p (next p) cycle_next => //= [x q] n; rewrite -(belast_rcons x q x). +move: {q}(rcons q x) => q n_q; move/allP. +by elim: q x n_q => //= _ q IHq x /andP[/eqP <- n_q] /andP[-> /IHq->]. +Qed. + +Lemma cycle_from_prev : (forall x, x \in p -> e (prev p x) x) -> cycle e p. +Proof. +move=> e_p; apply: cycle_from_next => x p_x. +by rewrite -{1}[x]prev_next e_p ?mem_next. +Qed. + +Lemma next_rot : next (rot n0 p) =1 next p. +Proof. +move=> x; have n_p := cycle_next; rewrite -(rot_cycle n0) in n_p. +case p_x: (x \in p); last by rewrite !next_nth mem_rot p_x. +by rewrite (eqP (next_cycle n_p _)) ?mem_rot. +Qed. + +Lemma prev_rot : prev (rot n0 p) =1 prev p. +Proof. +move=> x; have p_p := cycle_prev; rewrite -(rot_cycle n0) in p_p. +case p_x: (x \in p); last by rewrite !prev_nth mem_rot p_x. +by rewrite (eqP (prev_cycle p_p _)) ?mem_rot. +Qed. + +End UniqCycle. + +Section UniqRotrCycle. + +Variables (n0 : nat) (T : eqType) (p : seq T). + +Hypothesis Up : uniq p. + +Lemma next_rotr : next (rotr n0 p) =1 next p. Proof. exact: next_rot. Qed. + +Lemma prev_rotr : prev (rotr n0 p) =1 prev p. Proof. exact: prev_rot. Qed. + +End UniqRotrCycle. + +Section UniqCycleRev. + +Variable T : eqType. +Implicit Type p : seq T. + +Lemma prev_rev p : uniq p -> prev (rev p) =1 next p. +Proof. +move=> Up x; case p_x: (x \in p); last first. + by rewrite next_nth prev_nth mem_rev p_x. +case/rot_to: p_x (Up) => [i q def_p] Urp; rewrite -rev_uniq in Urp. +rewrite -(prev_rotr i Urp); do 2 rewrite -(prev_rotr 1) ?rotr_uniq //. +rewrite -rev_rot -(next_rot i Up) {i p Up Urp}def_p. +by case: q => // y q; rewrite !rev_cons !(=^~ rcons_cons, rotr1_rcons) /= eqxx. +Qed. + +Lemma next_rev p : uniq p -> next (rev p) =1 prev p. +Proof. by move=> Up x; rewrite -{2}[p]revK prev_rev // rev_uniq. Qed. + +End UniqCycleRev. + +Section MapPath. + +Variables (T T' : Type) (h : T' -> T) (e : rel T) (e' : rel T'). + +Definition rel_base (b : pred T) := + forall x' y', ~~ b (h x') -> e (h x') (h y') = e' x' y'. + +Lemma map_path b x' p' (Bb : rel_base b) : + ~~ has (preim h b) (belast x' p') -> + path e (h x') (map h p') = path e' x' p'. +Proof. by elim: p' x' => [|y' p' IHp'] x' //= /norP[/Bb-> /IHp'->]. Qed. + +End MapPath. + +Section MapEqPath. + +Variables (T T' : eqType) (h : T' -> T) (e : rel T) (e' : rel T'). + +Hypothesis Ih : injective h. + +Lemma mem2_map x' y' p' : mem2 (map h p') (h x') (h y') = mem2 p' x' y'. +Proof. by rewrite {1}/mem2 (index_map Ih) -map_drop mem_map. Qed. + +Lemma next_map p : uniq p -> forall x, next (map h p) (h x) = h (next p x). +Proof. +move=> Up x; case p_x: (x \in p); last by rewrite !next_nth (mem_map Ih) p_x. +case/rot_to: p_x => i p' def_p. +rewrite -(next_rot i Up); rewrite -(map_inj_uniq Ih) in Up. +rewrite -(next_rot i Up) -map_rot {i p Up}def_p /=. +by case: p' => [|y p''] //=; rewrite !eqxx. +Qed. + +Lemma prev_map p : uniq p -> forall x, prev (map h p) (h x) = h (prev p x). +Proof. +move=> Up x; rewrite -{1}[x](next_prev Up) -(next_map Up). +by rewrite prev_next ?map_inj_uniq. +Qed. + +End MapEqPath. + +Definition fun_base (T T' : eqType) (h : T' -> T) f f' := + rel_base h (frel f) (frel f'). + +Section CycleArc. + +Variable T : eqType. +Implicit Type p : seq T. + +Definition arc p x y := let px := rot (index x p) p in take (index y px) px. + +Lemma arc_rot i p : uniq p -> {in p, arc (rot i p) =2 arc p}. +Proof. +move=> Up x p_x y; congr (fun q => take (index y q) q); move: Up p_x {y}. +rewrite -{1 2 5 6}(cat_take_drop i p) /rot cat_uniq => /and3P[_ Up12 _]. +rewrite !drop_cat !take_cat !index_cat mem_cat orbC. +case p2x: (x \in drop i p) => /= => [_ | p1x]. + rewrite index_mem p2x [x \in _](negbTE (hasPn Up12 _ p2x)) /= addKn. + by rewrite ltnNge leq_addr catA. +by rewrite p1x index_mem p1x addKn ltnNge leq_addr /= catA. +Qed. + +Lemma left_arc x y p1 p2 (p := x :: p1 ++ y :: p2) : + uniq p -> arc p x y = x :: p1. +Proof. +rewrite /arc /p [index x _]/= eqxx rot0 -cat_cons cat_uniq index_cat. +move: (x :: p1) => xp1 /and3P[_ /norP[/= /negbTE-> _] _]. +by rewrite eqxx addn0 take_size_cat. +Qed. + +Lemma right_arc x y p1 p2 (p := x :: p1 ++ y :: p2) : + uniq p -> arc p y x = y :: p2. +Proof. +rewrite -[p]cat_cons -rot_size_cat rot_uniq => Up. +by rewrite arc_rot ?left_arc ?mem_head. +Qed. + +CoInductive rot_to_arc_spec p x y := + RotToArcSpec i p1 p2 of x :: p1 = arc p x y + & y :: p2 = arc p y x + & rot i p = x :: p1 ++ y :: p2 : + rot_to_arc_spec p x y. + +Lemma rot_to_arc p x y : + uniq p -> x \in p -> y \in p -> x != y -> rot_to_arc_spec p x y. +Proof. +move=> Up p_x p_y ne_xy; case: (rot_to p_x) (p_y) (Up) => [i q def_p] q_y. +rewrite -(mem_rot i) def_p inE eq_sym (negbTE ne_xy) in q_y. +rewrite -(rot_uniq i) def_p. +case/splitPr: q / q_y def_p => q1 q2 def_p Uq12; exists i q1 q2 => //. + by rewrite -(arc_rot i Up p_x) def_p left_arc. +by rewrite -(arc_rot i Up p_y) def_p right_arc. +Qed. + +End CycleArc. + +Prenex Implicits arc. + diff --git a/mathcomp/discrete/prime.v b/mathcomp/discrete/prime.v new file mode 100644 index 0000000..fa39012 --- /dev/null +++ b/mathcomp/discrete/prime.v @@ -0,0 +1,1404 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path fintype. +Require Import div bigop. + +(******************************************************************************) +(* This file contains the definitions of: *) +(* prime p <=> p is a prime. *) +(* primes m == the sorted list of prime divisors of m > 1, else [::]. *) +(* pfactor == the type of prime factors, syntax (p ^ e)%pfactor. *) +(* prime_decomp m == the list of prime factors of m > 1, sorted by primes. *) +(* logn p m == the e such that (p ^ e) \in prime_decomp n, else 0. *) +(* trunc_log p m == the largest e such that p ^ e <= m, or 0 if p or m is 0. *) +(* pdiv n == the smallest prime divisor of n > 1, else 1. *) +(* max_pdiv n == the largest prime divisor of n > 1, else 1. *) +(* divisors m == the sorted list of divisors of m > 0, else [::]. *) +(* totient n == the Euler totient (#|{i < n | i and n coprime}|). *) +(* nat_pred == the type of explicit collective nat predicates. *) +(* := simpl_pred nat. *) +(* -> We allow the coercion nat >-> nat_pred, interpreting p as pred1 p. *) +(* -> We define a predType for nat_pred, enabling the notation p \in pi. *) +(* -> We don't have nat_pred >-> pred, which would imply nat >-> Funclass. *) +(* pi^' == the complement of pi : nat_pred, i.e., the nat_pred such *) +(* that (p \in pi^') = (p \notin pi). *) +(* \pi(n) == the set of prime divisors of n, i.e., the nat_pred such *) +(* that (p \in \pi(n)) = (p \in primes n). *) +(* \pi(A) == the set of primes of #|A|, with A a collective predicate *) +(* over a finite Type. *) +(* -> The notation \pi(A) is implemented with a collapsible Coercion, so *) +(* the type of A must coerce to finpred_class (e.g., by coercing to *) +(* {set T}), not merely implement the predType interface (as seq T *) +(* does). *) +(* -> The expression #|A| will only appear in \pi(A) after simplification *) +(* collapses the coercion stack, so it is advisable to do so early on. *) +(* pi.-nat n <=> n > 0 and all prime divisors of n are in pi. *) +(* n`_pi == the pi-part of n -- the largest pi.-nat divisor of n. *) +(* := \prod_(0 <= p < n.+1 | p \in pi) p ^ logn p n. *) +(* -> The nat >-> nat_pred coercion lets us write p.-nat n and n`_p. *) +(* In addition to the lemmas relevant to these definitions, this file also *) +(* contains the dvdn_sum lemma, so that bigop.v doesn't depend on div.v. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +(* The complexity of any arithmetic operation with the Peano representation *) +(* is pretty dreadful, so using algorithms for "harder" problems such as *) +(* factoring, that are geared for efficient artihmetic leads to dismal *) +(* performance -- it takes a significant time, for instance, to compute the *) +(* divisors of just a two-digit number. On the other hand, for Peano *) +(* integers, prime factoring (and testing) is linear-time with a small *) +(* constant factor -- indeed, the same as converting in and out of a binary *) +(* representation. This is implemented by the code below, which is then *) +(* used to give the "standard" definitions of prime, primes, and divisors, *) +(* which can then be used casually in proofs with moderately-sized numeric *) +(* values (indeed, the code here performs well for up to 6-digit numbers). *) + +(* We start with faster mod-2 functions. *) + +Fixpoint edivn2 q r := if r is r'.+2 then edivn2 q.+1 r' else (q, r). + +Lemma edivn2P n : edivn_spec n 2 (edivn2 0 n). +Proof. +rewrite -[n]odd_double_half addnC -{1}[n./2]addn0 -{1}mul2n mulnC. +elim: n./2 {1 4}0 => [|r IHr] q; first by case (odd n) => /=. +rewrite addSnnS; exact: IHr. +Qed. + +Fixpoint elogn2 e q r {struct q} := + match q, r with + | 0, _ | _, 0 => (e, q) + | q'.+1, 1 => elogn2 e.+1 q' q' + | q'.+1, r'.+2 => elogn2 e q' r' + end. + +CoInductive elogn2_spec n : nat * nat -> Type := + Elogn2Spec e m of n = 2 ^ e * m.*2.+1 : elogn2_spec n (e, m). + +Lemma elogn2P n : elogn2_spec n.+1 (elogn2 0 n n). +Proof. +rewrite -{1}[n.+1]mul1n -[1]/(2 ^ 0) -{1}(addKn n n) addnn. +elim: n {1 4 6}n {2 3}0 (leqnn n) => [|q IHq] [|[|r]] e //=; last first. + by move/ltnW; exact: IHq. +clear 1; rewrite subn1 -[_.-1.+1]doubleS -mul2n mulnA -expnSr. +rewrite -{1}(addKn q q) addnn; exact: IHq. +Qed. + +Definition ifnz T n (x y : T) := if n is 0 then y else x. + +CoInductive ifnz_spec T n (x y : T) : T -> Type := + | IfnzPos of n > 0 : ifnz_spec n x y x + | IfnzZero of n = 0 : ifnz_spec n x y y. + +Lemma ifnzP T n (x y : T) : ifnz_spec n x y (ifnz n x y). +Proof. by case: n => [|n]; [right | left]. Qed. + +(* For pretty-printing. *) +Definition NumFactor (f : nat * nat) := ([Num of f.1], f.2). + +Definition pfactor p e := p ^ e. + +Definition cons_pfactor (p e : nat) pd := ifnz e ((p, e) :: pd) pd. + +Notation Local "p ^? e :: pd" := (cons_pfactor p e pd) + (at level 30, e at level 30, pd at level 60) : nat_scope. + +Section prime_decomp. + +Import NatTrec. + +Fixpoint prime_decomp_rec m k a b c e := + let p := k.*2.+1 in + if a is a'.+1 then + if b - (ifnz e 1 k - c) is b'.+1 then + [rec m, k, a', b', ifnz c c.-1 (ifnz e p.-2 1), e] else + if (b == 0) && (c == 0) then + let b' := k + a' in [rec b'.*2.+3, k, a', b', k.-1, e.+1] else + let bc' := ifnz e (ifnz b (k, 0) (edivn2 0 c)) (b, c) in + p ^? e :: ifnz a' [rec m, k.+1, a'.-1, bc'.1 + a', bc'.2, 0] [:: (m, 1)] + else if (b == 0) && (c == 0) then [:: (p, e.+2)] else p ^? e :: [:: (m, 1)] +where "[ 'rec' m , k , a , b , c , e ]" := (prime_decomp_rec m k a b c e). + +Definition prime_decomp n := + let: (e2, m2) := elogn2 0 n.-1 n.-1 in + if m2 < 2 then 2 ^? e2 :: 3 ^? m2 :: [::] else + let: (a, bc) := edivn m2.-2 3 in + let: (b, c) := edivn (2 - bc) 2 in + 2 ^? e2 :: [rec m2.*2.+1, 1, a, b, c, 0]. + +(* The list of divisors and the Euler function are computed directly from *) +(* the decomposition, using a merge_sort variant sort the divisor list. *) + +Definition add_divisors f divs := + let: (p, e) := f in + let add1 divs' := merge leq (map (NatTrec.mul p) divs') divs in + iter e add1 divs. + +Definition add_totient_factor f m := let: (p, e) := f in p.-1 * p ^ e.-1 * m. + +End prime_decomp. + +Definition primes n := unzip1 (prime_decomp n). + +Definition prime p := if prime_decomp p is [:: (_ , 1)] then true else false. + +Definition nat_pred := simpl_pred nat. + +Definition pi_unwrapped_arg := nat. +Definition pi_wrapped_arg := wrapped nat. +Coercion unwrap_pi_arg (wa : pi_wrapped_arg) : pi_unwrapped_arg := unwrap wa. +Coercion pi_arg_of_nat (n : nat) := Wrap n : pi_wrapped_arg. +Coercion pi_arg_of_fin_pred T pT (A : @fin_pred_sort T pT) : pi_wrapped_arg := + Wrap #|A|. + +Definition pi_of (n : pi_unwrapped_arg) : nat_pred := [pred p in primes n]. + +Notation "\pi ( n )" := (pi_of n) + (at level 2, format "\pi ( n )") : nat_scope. +Notation "\p 'i' ( A )" := \pi(#|A|) + (at level 2, format "\p 'i' ( A )") : nat_scope. + +Definition pdiv n := head 1 (primes n). + +Definition max_pdiv n := last 1 (primes n). + +Definition divisors n := foldr add_divisors [:: 1] (prime_decomp n). + +Definition totient n := foldr add_totient_factor (n > 0) (prime_decomp n). + +(* Correctness of the decomposition algorithm. *) + +Lemma prime_decomp_correct : + let pd_val pd := \prod_(f <- pd) pfactor f.1 f.2 in + let lb_dvd q m := ~~ has [pred d | d %| m] (index_iota 2 q) in + let pf_ok f := lb_dvd f.1 f.1 && (0 < f.2) in + let pd_ord q pd := path ltn q (unzip1 pd) in + let pd_ok q n pd := [/\ n = pd_val pd, all pf_ok pd & pd_ord q pd] in + forall n, n > 0 -> pd_ok 1 n (prime_decomp n). +Proof. +rewrite unlock => pd_val lb_dvd pf_ok pd_ord pd_ok. +have leq_pd_ok m p q pd: q <= p -> pd_ok p m pd -> pd_ok q m pd. + rewrite /pd_ok /pd_ord; case: pd => [|[r _] pd] //= leqp [<- ->]. + by case/andP=> /(leq_trans _)->. +have apd_ok m e q p pd: lb_dvd p p || (e == 0) -> q < p -> + pd_ok p m pd -> pd_ok q (p ^ e * m) (p ^? e :: pd). +- case: e => [|e]; rewrite orbC /= => pr_p ltqp. + rewrite mul1n; apply: leq_pd_ok; exact: ltnW. + by rewrite /pd_ok /pd_ord /pf_ok /= pr_p ltqp => [[<- -> ->]]. +case=> // n _; rewrite /prime_decomp. +case: elogn2P => e2 m2 -> {n}; case: m2 => [|[|abc]]; try exact: apd_ok. +rewrite [_.-2]/= !ltnS ltn0 natTrecE; case: edivnP => a bc ->{abc}. +case: edivnP => b c def_bc /= ltc2 ltbc3; apply: (apd_ok) => //. +move def_m: _.*2.+1 => m; set k := {2}1; rewrite -[2]/k.*2; set e := 0. +pose p := k.*2.+1; rewrite -{1}[m]mul1n -[1]/(p ^ e)%N. +have{def_m bc def_bc ltc2 ltbc3}: + let kb := (ifnz e k 1).*2 in + [&& k > 0, p < m, lb_dvd p m, c < kb & lb_dvd p p || (e == 0)] + /\ m + (b * kb + c).*2 = p ^ 2 + (a * p).*2. +- rewrite -{-2}def_m; split=> //=; last first. + by rewrite -def_bc addSn -doubleD 2!addSn -addnA subnKC // addnC. + rewrite ltc2 /lb_dvd /index_iota /= dvdn2 -def_m. + by rewrite [_.+2]lock /= odd_double. +move: {2}a.+1 (ltnSn a) => n; clearbody k e. +elim: n => // n IHn in a k p m b c e *; rewrite ltnS => le_a_n []. +set kb := _.*2; set d := _ + c => /and5P[lt0k ltpm leppm ltc pr_p def_m]. +have def_k1: k.-1.+1 = k := ltn_predK lt0k. +have def_kb1: kb.-1.+1 = kb by rewrite /kb -def_k1; case e. +have eq_bc_0: (b == 0) && (c == 0) = (d == 0). + by rewrite addn_eq0 muln_eq0 orbC -def_kb1. +have lt1p: 1 < p by rewrite ltnS double_gt0. +have co_p_2: coprime p 2 by rewrite /coprime gcdnC gcdnE modn2 /= odd_double. +have if_d0: d = 0 -> [/\ m = (p + a.*2) * p, lb_dvd p p & lb_dvd p (p + a.*2)]. + move=> d0; have{d0 def_m} def_m: m = (p + a.*2) * p. + by rewrite d0 addn0 -mulnn -!mul2n mulnA -mulnDl in def_m *. + split=> //; apply/hasPn=> r /(hasPn leppm); apply: contra => /= dv_r. + by rewrite def_m dvdn_mull. + by rewrite def_m dvdn_mulr. +case def_a: a => [|a'] /= in le_a_n *; rewrite !natTrecE -/p {}eq_bc_0. + case: d if_d0 def_m => [[//| def_m {pr_p}pr_p pr_m'] _ | d _ def_m] /=. + rewrite def_m def_a addn0 mulnA -2!expnSr. + by split; rewrite /pd_ord /pf_ok /= ?muln1 ?pr_p ?leqnn. + apply: apd_ok; rewrite // /pd_ok /= /pfactor expn1 muln1 /pd_ord /= ltpm. + rewrite /pf_ok !andbT /=; split=> //; apply: contra leppm. + case/hasP=> r /=; rewrite mem_index_iota => /andP[lt1r ltrm] dvrm; apply/hasP. + have [ltrp | lepr] := ltnP r p. + by exists r; rewrite // mem_index_iota lt1r. + case/dvdnP: dvrm => q def_q; exists q; last by rewrite def_q /= dvdn_mulr. + rewrite mem_index_iota -(ltn_pmul2r (ltnW lt1r)) -def_q mul1n ltrm. + move: def_m; rewrite def_a addn0 -(@ltn_pmul2r p) // mulnn => <-. + apply: (@leq_ltn_trans m); first by rewrite def_q leq_mul. + by rewrite -addn1 leq_add2l. +have def_k2: k.*2 = ifnz e 1 k * kb. + by rewrite /kb; case: (e) => [|e']; rewrite (mul1n, muln2). +case def_b': (b - _) => [|b']; last first. + have ->: ifnz e k.*2.-1 1 = kb.-1 by rewrite /kb; case e. + apply: IHn => {n le_a_n}//; rewrite -/p -/kb; split=> //. + rewrite lt0k ltpm leppm pr_p andbT /=. + by case: ifnzP; [move/ltn_predK->; exact: ltnW | rewrite def_kb1]. + apply: (@addIn p.*2). + rewrite -2!addnA -!doubleD -addnA -mulSnr -def_a -def_m /d. + have ->: b * kb = b' * kb + (k.*2 - c * kb + kb). + rewrite addnCA addnC -mulSnr -def_b' def_k2 -mulnBl -mulnDl subnK //. + by rewrite ltnW // -subn_gt0 def_b'. + rewrite -addnA; congr (_ + (_ + _).*2). + case: (c) ltc; first by rewrite -addSnnS def_kb1 subn0 addn0 addnC. + rewrite /kb; case e => [[] // _ | e' c' _] /=; last first. + by rewrite subnDA subnn addnC addSnnS. + by rewrite mul1n -doubleB -doubleD subn1 !addn1 def_k1. +have ltdp: d < p. + move/eqP: def_b'; rewrite subn_eq0 -(@leq_pmul2r kb); last first. + by rewrite -def_kb1. + rewrite mulnBl -def_k2 ltnS -(leq_add2r c); move/leq_trans; apply. + have{ltc} ltc: c < k.*2. + by apply: (leq_trans ltc); rewrite leq_double /kb; case e. + rewrite -{2}(subnK (ltnW ltc)) leq_add2r leq_sub2l //. + by rewrite -def_kb1 mulnS leq_addr. +case def_d: d if_d0 => [|d'] => [[//|{def_m ltdp pr_p} def_m pr_p pr_m'] | _]. + rewrite eqxx -doubleS -addnS -def_a doubleD -addSn -/p def_m. + rewrite mulnCA mulnC -expnSr. + apply: IHn => {n le_a_n}//; rewrite -/p -/kb; split. + rewrite lt0k -addn1 leq_add2l {1}def_a pr_m' pr_p /= def_k1 -addnn. + by rewrite leq_addr. + rewrite -addnA -doubleD addnCA def_a addSnnS def_k1 -(addnC k) -mulnSr. + rewrite -[_.*2.+1]/p mulnDl doubleD addnA -mul2n mulnA mul2n -mulSn. + by rewrite -/p mulnn. +have next_pm: lb_dvd p.+2 m. + rewrite /lb_dvd /index_iota 2!subSS subn0 -(subnK lt1p) iota_add. + rewrite has_cat; apply/norP; split=> //=; rewrite orbF subnKC // orbC. + apply/norP; split; apply/dvdnP=> [[q def_q]]. + case/hasP: leppm; exists 2; first by rewrite /p -(subnKC lt0k). + by rewrite /= def_q dvdn_mull // dvdn2 /= odd_double. + move/(congr1 (dvdn p)): def_m; rewrite -mulnn -!mul2n mulnA -mulnDl. + rewrite dvdn_mull // dvdn_addr; last by rewrite def_q dvdn_mull. + case/dvdnP=> r; rewrite mul2n => def_r; move: ltdp (congr1 odd def_r). + rewrite odd_double -ltn_double {1}def_r -mul2n ltn_pmul2r //. + by case: r def_r => [|[|[]]] //; rewrite def_d // mul1n /= odd_double. +apply: apd_ok => //; case: a' def_a le_a_n => [|a'] def_a => [_ | lta] /=. + rewrite /pd_ok /= /pfactor expn1 muln1 /pd_ord /= ltpm /pf_ok !andbT /=. + split=> //; apply: contra next_pm. + case/hasP=> q; rewrite mem_index_iota => /andP[lt1q ltqm] dvqm; apply/hasP. + have [ltqp | lepq] := ltnP q p.+2. + by exists q; rewrite // mem_index_iota lt1q. + case/dvdnP: dvqm => r def_r; exists r; last by rewrite def_r /= dvdn_mulr. + rewrite mem_index_iota -(ltn_pmul2r (ltnW lt1q)) -def_r mul1n ltqm /=. + rewrite -(@ltn_pmul2l p.+2) //; apply: (@leq_ltn_trans m). + by rewrite def_r mulnC leq_mul. + rewrite -addn2 mulnn sqrnD mul2n muln2 -addnn addnCA -addnA addnCA addnA. + by rewrite def_a mul1n in def_m; rewrite -def_m addnS -addnA ltnS leq_addr. +set bc := ifnz _ _ _; apply: leq_pd_ok (leqnSn _) _. +rewrite -doubleS -{1}[m]mul1n -[1]/(k.+1.*2.+1 ^ 0)%N. +apply: IHn; first exact: ltnW. +rewrite doubleS -/p [ifnz 0 _ _]/=; do 2?split => //. + rewrite orbT next_pm /= -(leq_add2r d.*2) def_m 2!addSnnS -doubleS leq_add. + - move: ltc; rewrite /kb {}/bc andbT; case e => //= e' _; case: ifnzP => //. + by case: edivn2P. + - by rewrite -{1}[p]muln1 -mulnn ltn_pmul2l. + by rewrite leq_double def_a mulSn (leq_trans ltdp) ?leq_addr. +rewrite mulnDl !muln2 -addnA addnCA doubleD addnCA. +rewrite (_ : _ + bc.2 = d); last first. + rewrite /d {}/bc /kb -muln2. + case: (e) (b) def_b' => //= _ []; first by case: edivn2P. + by case c; do 2?case; rewrite // mul1n /= muln2. +rewrite def_m 3!doubleS addnC -(addn2 p) sqrnD mul2n muln2 -3!addnA. +congr (_ + _); rewrite 4!addnS -!doubleD; congr _.*2.+2.+2. +by rewrite def_a -add2n mulnDl -addnA -muln2 -mulnDr mul2n. +Qed. + +Lemma primePn n : + reflect (n < 2 \/ exists2 d, 1 < d < n & d %| n) (~~ prime n). +Proof. +rewrite /prime; case: n => [|[|p2]]; try by do 2!left. +case: (@prime_decomp_correct p2.+2) => //; rewrite unlock. +case: prime_decomp => [|[q [|[|e]]] pd] //=; last first; last by rewrite andbF. + rewrite {1}/pfactor 2!expnS -!mulnA /=. + case: (_ ^ _ * _) => [|u -> _ /andP[lt1q _]]; first by rewrite !muln0. + left; right; exists q; last by rewrite dvdn_mulr. + have lt0q := ltnW lt1q; rewrite lt1q -{1}[q]muln1 ltn_pmul2l //. + by rewrite -[2]muln1 leq_mul. +rewrite {1}/pfactor expn1; case: pd => [|[r e] pd] /=; last first. + case: e => [|e] /=; first by rewrite !andbF. + rewrite {1}/pfactor expnS -mulnA. + case: (_ ^ _ * _) => [|u -> _ /and3P[lt1q ltqr _]]; first by rewrite !muln0. + left; right; exists q; last by rewrite dvdn_mulr. + by rewrite lt1q -{1}[q]mul1n ltn_mul // -[q.+1]muln1 leq_mul. +rewrite muln1 !andbT => def_q pr_q lt1q; right=> [[]] // [d]. +by rewrite def_q -mem_index_iota => in_d_2q dv_d_q; case/hasP: pr_q; exists d. +Qed. + +Lemma primeP p : + reflect (p > 1 /\ forall d, d %| p -> xpred2 1 p d) (prime p). +Proof. +rewrite -[prime p]negbK; have [npr_p | pr_p] := primePn p. + right=> [[lt1p pr_p]]; case: npr_p => [|[d n1pd]]. + by rewrite ltnNge lt1p. + by move/pr_p=> /orP[] /eqP def_d; rewrite def_d ltnn ?andbF in n1pd. +have [lep1 | lt1p] := leqP; first by case: pr_p; left. +left; split=> // d dv_d_p; apply/norP=> [[nd1 ndp]]; case: pr_p; right. +exists d; rewrite // andbC 2!ltn_neqAle ndp eq_sym nd1. +by have lt0p := ltnW lt1p; rewrite dvdn_leq // (dvdn_gt0 lt0p). +Qed. + +Lemma prime_nt_dvdP d p : prime p -> d != 1 -> reflect (d = p) (d %| p). +Proof. +case/primeP=> _ min_p d_neq1; apply: (iffP idP) => [/min_p|-> //]. +by rewrite (negPf d_neq1) /= => /eqP. +Qed. + +Implicit Arguments primeP [p]. +Implicit Arguments primePn [n]. +Prenex Implicits primePn primeP. + +Lemma prime_gt1 p : prime p -> 1 < p. +Proof. by case/primeP. Qed. + +Lemma prime_gt0 p : prime p -> 0 < p. +Proof. by move/prime_gt1; exact: ltnW. Qed. + +Hint Resolve prime_gt1 prime_gt0. + +Lemma prod_prime_decomp n : + n > 0 -> n = \prod_(f <- prime_decomp n) f.1 ^ f.2. +Proof. by case/prime_decomp_correct. Qed. + +Lemma even_prime p : prime p -> p = 2 \/ odd p. +Proof. +move=> pr_p; case odd_p: (odd p); [by right | left]. +have: 2 %| p by rewrite dvdn2 odd_p. +by case/primeP: pr_p => _ dv_p /dv_p/(2 =P p). +Qed. + +Lemma prime_oddPn p : prime p -> reflect (p = 2) (~~ odd p). +Proof. +by move=> p_pr; apply: (iffP idP) => [|-> //]; case/even_prime: p_pr => ->. +Qed. + +Lemma odd_prime_gt2 p : odd p -> prime p -> p > 2. +Proof. by move=> odd_p /prime_gt1; apply: odd_gt2. Qed. + +Lemma mem_prime_decomp n p e : + (p, e) \in prime_decomp n -> [/\ prime p, e > 0 & p ^ e %| n]. +Proof. +case: (posnP n) => [-> //| /prime_decomp_correct[def_n mem_pd ord_pd pd_pe]]. +have /andP[pr_p ->] := allP mem_pd _ pd_pe; split=> //; last first. + case/splitPr: pd_pe def_n => pd1 pd2 ->. + by rewrite big_cat big_cons /= mulnCA dvdn_mulr. +have lt1p: 1 < p. + apply: (allP (order_path_min ltn_trans ord_pd)). + by apply/mapP; exists (p, e). +apply/primeP; split=> // d dv_d_p; apply/norP=> [[nd1 ndp]]. +case/hasP: pr_p; exists d => //. +rewrite mem_index_iota andbC 2!ltn_neqAle ndp eq_sym nd1. +by have lt0p := ltnW lt1p; rewrite dvdn_leq // (dvdn_gt0 lt0p). +Qed. + +Lemma prime_coprime p m : prime p -> coprime p m = ~~ (p %| m). +Proof. +case/primeP=> p_gt1 p_pr; apply/eqP/negP=> [d1 | ndv_pm]. + case/dvdnP=> k def_m; rewrite -(addn0 m) def_m gcdnMDl gcdn0 in d1. + by rewrite d1 in p_gt1. +by apply: gcdn_def => // d /p_pr /orP[] /eqP->. +Qed. + +Lemma dvdn_prime2 p q : prime p -> prime q -> (p %| q) = (p == q). +Proof. +move=> pr_p pr_q; apply: negb_inj. +by rewrite eqn_dvd negb_and -!prime_coprime // coprime_sym orbb. +Qed. + +Lemma Euclid_dvdM m n p : prime p -> (p %| m * n) = (p %| m) || (p %| n). +Proof. +move=> pr_p; case dv_pm: (p %| m); first exact: dvdn_mulr. +by rewrite Gauss_dvdr // prime_coprime // dv_pm. +Qed. + +Lemma Euclid_dvd1 p : prime p -> (p %| 1) = false. +Proof. by rewrite dvdn1; case: eqP => // ->. Qed. + +Lemma Euclid_dvdX m n p : prime p -> (p %| m ^ n) = (p %| m) && (n > 0). +Proof. +case: n => [|n] pr_p; first by rewrite andbF Euclid_dvd1. +by apply: (inv_inj negbK); rewrite !andbT -!prime_coprime // coprime_pexpr. +Qed. + +Lemma mem_primes p n : (p \in primes n) = [&& prime p, n > 0 & p %| n]. +Proof. +rewrite andbCA; case: posnP => [-> // | /= n_gt0]. +apply/mapP/andP=> [[[q e]]|[pr_p]] /=. + case/mem_prime_decomp=> pr_q e_gt0; case/dvdnP=> u -> -> {p}. + by rewrite -(prednK e_gt0) expnS mulnCA dvdn_mulr. +rewrite {1}(prod_prime_decomp n_gt0) big_seq. +apply big_ind => [| u v IHu IHv | [q e] /= mem_qe dv_p_qe]. +- by rewrite Euclid_dvd1. +- by rewrite Euclid_dvdM // => /orP[]. +exists (q, e) => //=; case/mem_prime_decomp: mem_qe => pr_q _ _. +by rewrite Euclid_dvdX // dvdn_prime2 // in dv_p_qe; case: eqP dv_p_qe. +Qed. + +Lemma sorted_primes n : sorted ltn (primes n). +Proof. +by case: (posnP n) => [-> // | /prime_decomp_correct[_ _]]; exact: path_sorted. +Qed. + +Lemma eq_primes m n : (primes m =i primes n) <-> (primes m = primes n). +Proof. +split=> [eqpr| -> //]. +by apply: (eq_sorted_irr ltn_trans ltnn); rewrite ?sorted_primes. +Qed. + +Lemma primes_uniq n : uniq (primes n). +Proof. exact: (sorted_uniq ltn_trans ltnn (sorted_primes n)). Qed. + +(* The smallest prime divisor *) + +Lemma pi_pdiv n : (pdiv n \in \pi(n)) = (n > 1). +Proof. +case: n => [|[|n]] //; rewrite /pdiv !inE /primes. +have:= prod_prime_decomp (ltn0Sn n.+1); rewrite unlock. +by case: prime_decomp => //= pf pd _; rewrite mem_head. +Qed. + +Lemma pdiv_prime n : 1 < n -> prime (pdiv n). +Proof. by rewrite -pi_pdiv mem_primes; case/and3P. Qed. + +Lemma pdiv_dvd n : pdiv n %| n. +Proof. +by case: n (pi_pdiv n) => [|[|n]] //; rewrite mem_primes=> /and3P[]. +Qed. + +Lemma pi_max_pdiv n : (max_pdiv n \in \pi(n)) = (n > 1). +Proof. +rewrite !inE -pi_pdiv /max_pdiv /pdiv !inE. +by case: (primes n) => //= p ps; rewrite mem_head mem_last. +Qed. + +Lemma max_pdiv_prime n : n > 1 -> prime (max_pdiv n). +Proof. by rewrite -pi_max_pdiv mem_primes => /andP[]. Qed. + +Lemma max_pdiv_dvd n : max_pdiv n %| n. +Proof. +by case: n (pi_max_pdiv n) => [|[|n]] //; rewrite mem_primes => /andP[]. +Qed. + +Lemma pdiv_leq n : 0 < n -> pdiv n <= n. +Proof. by move=> n_gt0; rewrite dvdn_leq // pdiv_dvd. Qed. + +Lemma max_pdiv_leq n : 0 < n -> max_pdiv n <= n. +Proof. by move=> n_gt0; rewrite dvdn_leq // max_pdiv_dvd. Qed. + +Lemma pdiv_gt0 n : 0 < pdiv n. +Proof. by case: n => [|[|n]] //; rewrite prime_gt0 ?pdiv_prime. Qed. + +Lemma max_pdiv_gt0 n : 0 < max_pdiv n. +Proof. by case: n => [|[|n]] //; rewrite prime_gt0 ?max_pdiv_prime. Qed. +Hint Resolve pdiv_gt0 max_pdiv_gt0. + +Lemma pdiv_min_dvd m d : 1 < d -> d %| m -> pdiv m <= d. +Proof. +move=> lt1d dv_d_m; case: (posnP m) => [->|mpos]; first exact: ltnW. +rewrite /pdiv; apply: leq_trans (pdiv_leq (ltnW lt1d)). +have: pdiv d \in primes m. + by rewrite mem_primes mpos pdiv_prime // (dvdn_trans (pdiv_dvd d)). +case: (primes m) (sorted_primes m) => //= p pm ord_pm. +rewrite inE => /predU1P[-> //|]. +move/(allP (order_path_min ltn_trans ord_pm)); exact: ltnW. +Qed. + +Lemma max_pdiv_max n p : p \in \pi(n) -> p <= max_pdiv n. +Proof. +rewrite /max_pdiv !inE => n_p. +case/splitPr: n_p (sorted_primes n) => p1 p2; rewrite last_cat -cat_rcons /=. +rewrite headI /= cat_path -(last_cons 0) -headI last_rcons; case/andP=> _. +move/(order_path_min ltn_trans); case/lastP: p2 => //= p2 q. +by rewrite all_rcons last_rcons ltn_neqAle -andbA => /and3P[]. +Qed. + +Lemma ltn_pdiv2_prime n : 0 < n -> n < pdiv n ^ 2 -> prime n. +Proof. +case def_n: n => [|[|n']] // _; rewrite -def_n => lt_n_p2. +suffices ->: n = pdiv n by rewrite pdiv_prime ?def_n. +apply/eqP; rewrite eqn_leq leqNgt andbC pdiv_leq; last by rewrite def_n. +move: lt_n_p2; rewrite ltnNge; apply: contra => lt_pm_m. +case/dvdnP: (pdiv_dvd n) => q def_q. +rewrite {2}def_q -mulnn leq_pmul2r // pdiv_min_dvd //. + by rewrite -[pdiv n]mul1n {2}def_q ltn_pmul2r in lt_pm_m. +by rewrite def_q dvdn_mulr. +Qed. + +Lemma primePns n : + reflect (n < 2 \/ exists p, [/\ prime p, p ^ 2 <= n & p %| n]) (~~ prime n). +Proof. +apply: (iffP idP) => [npr_p|]; last first. + case=> [|[p [pr_p le_p2_n dv_p_n]]]; first by case: n => [|[]]. + apply/negP=> pr_n; move: dv_p_n le_p2_n; rewrite dvdn_prime2 //; move/eqP->. + by rewrite leqNgt -{1}[n]muln1 -mulnn ltn_pmul2l ?prime_gt1 ?prime_gt0. +case: leqP => [lt1p|]; [right | by left]. +exists (pdiv n); rewrite pdiv_dvd pdiv_prime //; split=> //. +by case: leqP npr_p => //; move/ltn_pdiv2_prime->; auto. +Qed. + +Implicit Arguments primePns [n]. +Prenex Implicits primePns. + +Lemma pdivP n : n > 1 -> {p | prime p & p %| n}. +Proof. by move=> lt1n; exists (pdiv n); rewrite ?pdiv_dvd ?pdiv_prime. Qed. + +Lemma primes_mul m n p : m > 0 -> n > 0 -> + (p \in primes (m * n)) = (p \in primes m) || (p \in primes n). +Proof. +move=> m_gt0 n_gt0; rewrite !mem_primes muln_gt0 m_gt0 n_gt0. +by case pr_p: (prime p); rewrite // Euclid_dvdM. +Qed. + +Lemma primes_exp m n : n > 0 -> primes (m ^ n) = primes m. +Proof. +case: n => // n _; rewrite expnS; case: (posnP m) => [-> //| m_gt0]. +apply/eq_primes => /= p; elim: n => [|n IHn]; first by rewrite muln1. +by rewrite primes_mul ?(expn_gt0, expnS, IHn, orbb, m_gt0). +Qed. + +Lemma primes_prime p : prime p -> primes p = [::p]. +Proof. +move=> pr_p; apply: (eq_sorted_irr ltn_trans ltnn) => // [|q]. + exact: sorted_primes. +rewrite mem_seq1 mem_primes prime_gt0 //=. +by apply/andP/idP=> [[pr_q q_p] | /eqP-> //]; rewrite -dvdn_prime2. +Qed. + +Lemma coprime_has_primes m n : m > 0 -> n > 0 -> + coprime m n = ~~ has (mem (primes m)) (primes n). +Proof. +move=> m_gt0 n_gt0; apply/eqnP/hasPn=> [mn1 p | no_p_mn]. + rewrite /= !mem_primes m_gt0 n_gt0 /= => /andP[pr_p p_n]. + have:= prime_gt1 pr_p; rewrite pr_p ltnNge -mn1 /=; apply: contra => p_m. + by rewrite dvdn_leq ?gcdn_gt0 ?m_gt0 // dvdn_gcd ?p_m. +case: (ltngtP (gcdn m n) 1) => //; first by rewrite ltnNge gcdn_gt0 ?m_gt0. +move/pdiv_prime; set p := pdiv _ => pr_p. +move/implyP: (no_p_mn p); rewrite /= !mem_primes m_gt0 n_gt0 pr_p /=. +by rewrite !(dvdn_trans (pdiv_dvd _)) // (dvdn_gcdl, dvdn_gcdr). +Qed. + +Lemma pdiv_id p : prime p -> pdiv p = p. +Proof. by move=> p_pr; rewrite /pdiv primes_prime. Qed. + +Lemma pdiv_pfactor p k : prime p -> pdiv (p ^ k.+1) = p. +Proof. by move=> p_pr; rewrite /pdiv primes_exp ?primes_prime. Qed. + +(* Primes are unbounded. *) + +Lemma dvdn_fact m n : 0 < m <= n -> m %| n`!. +Proof. +case: m => //= m; elim: n => //= n IHn; rewrite ltnS leq_eqVlt. +by case/predU1P=> [-> | /IHn]; [apply: dvdn_mulr | apply: dvdn_mull]. +Qed. + +Lemma prime_above m : {p | m < p & prime p}. +Proof. +have /pdivP[p pr_p p_dv_m1]: 1 < m`! + 1 by rewrite addn1 ltnS fact_gt0. +exists p => //; rewrite ltnNge; apply: contraL p_dv_m1 => p_le_m. +by rewrite dvdn_addr ?dvdn_fact ?prime_gt0 // gtnNdvd ?prime_gt1. +Qed. + +(* "prime" logarithms and p-parts. *) + +Fixpoint logn_rec d m r := + match r, edivn m d with + | r'.+1, (_.+1 as m', 0) => (logn_rec d m' r').+1 + | _, _ => 0 + end. + +Definition logn p m := if prime p then logn_rec p m m else 0. + +Lemma lognE p m : + logn p m = if [&& prime p, 0 < m & p %| m] then (logn p (m %/ p)).+1 else 0. +Proof. +rewrite /logn /dvdn; case p_pr: (prime p) => //. +rewrite /divn modn_def; case def_m: {2 3}m => [|m'] //=. +case: edivnP def_m => [[|q] [|r] -> _] // def_m; congr _.+1; rewrite [_.1]/=. +have{m def_m}: q < m'. + by rewrite -ltnS -def_m addn0 mulnC -{1}[q.+1]mul1n ltn_pmul2r // prime_gt1. +elim: {m' q}_.+1 {-2}m' q.+1 (ltnSn m') (ltn0Sn q) => // s IHs. +case=> [[]|r] //= m; rewrite ltnS => lt_rs m_gt0 le_mr. +rewrite -{3}[m]prednK //=; case: edivnP => [[|q] [|_] def_q _] //. +have{def_q} lt_qm': q < m.-1. + by rewrite -[q.+1]muln1 -ltnS prednK // def_q addn0 ltn_pmul2l // prime_gt1. +have{le_mr} le_m'r: m.-1 <= r by rewrite -ltnS prednK. +by rewrite (IHs r) ?(IHs m.-1) // ?(leq_trans lt_qm', leq_trans _ lt_rs). +Qed. + +Lemma logn_gt0 p n : (0 < logn p n) = (p \in primes n). +Proof. by rewrite lognE -mem_primes; case: {+}(p \in _). Qed. + +Lemma ltn_log0 p n : n < p -> logn p n = 0. +Proof. by case: n => [|n] ltnp; rewrite lognE ?andbF // gtnNdvd ?andbF. Qed. + +Lemma logn0 p : logn p 0 = 0. +Proof. by rewrite /logn if_same. Qed. + +Lemma logn1 p : logn p 1 = 0. +Proof. by rewrite lognE dvdn1 /= andbC; case: eqP => // ->. Qed. + +Lemma pfactor_gt0 p n : 0 < p ^ logn p n. +Proof. by rewrite expn_gt0 lognE; case: (posnP p) => // ->. Qed. +Hint Resolve pfactor_gt0. + +Lemma pfactor_dvdn p n m : prime p -> m > 0 -> (p ^ n %| m) = (n <= logn p m). +Proof. +move=> p_pr; elim: n m => [|n IHn] m m_gt0; first exact: dvd1n. +rewrite lognE p_pr m_gt0 /=; case dv_pm: (p %| m); last first. + apply/dvdnP=> [] [/= q def_m]. + by rewrite def_m expnS mulnCA dvdn_mulr in dv_pm. +case/dvdnP: dv_pm m_gt0 => q ->{m}; rewrite muln_gt0 => /andP[p_gt0 q_gt0]. +by rewrite expnSr dvdn_pmul2r // mulnK // IHn. +Qed. + +Lemma pfactor_dvdnn p n : p ^ logn p n %| n. +Proof. +case: n => // n; case pr_p: (prime p); first by rewrite pfactor_dvdn. +by rewrite lognE pr_p dvd1n. +Qed. + +Lemma logn_prime p q : prime q -> logn p q = (p == q). +Proof. +move=> pr_q; have q_gt0 := prime_gt0 pr_q; rewrite lognE q_gt0 /=. +case pr_p: (prime p); last by case: eqP pr_p pr_q => // -> ->. +by rewrite dvdn_prime2 //; case: eqP => // ->; rewrite divnn q_gt0 logn1. +Qed. + +Lemma pfactor_coprime p n : + prime p -> n > 0 -> {m | coprime p m & n = m * p ^ logn p n}. +Proof. +move=> p_pr n_gt0; set k := logn p n. +have dv_pk_n: p ^ k %| n by rewrite pfactor_dvdn. +exists (n %/ p ^ k); last by rewrite divnK. +rewrite prime_coprime // -(@dvdn_pmul2r (p ^ k)) ?expn_gt0 ?prime_gt0 //. +by rewrite -expnS divnK // pfactor_dvdn // ltnn. +Qed. + +Lemma pfactorK p n : prime p -> logn p (p ^ n) = n. +Proof. +move=> p_pr; have pn_gt0: p ^ n > 0 by rewrite expn_gt0 prime_gt0. +apply/eqP; rewrite eqn_leq -pfactor_dvdn // dvdnn andbT. +by rewrite -(leq_exp2l _ _ (prime_gt1 p_pr)) dvdn_leq // pfactor_dvdn. +Qed. + +Lemma pfactorKpdiv p n : prime p -> logn (pdiv (p ^ n)) (p ^ n) = n. +Proof. by case: n => // n p_pr; rewrite pdiv_pfactor ?pfactorK. Qed. + +Lemma dvdn_leq_log p m n : 0 < n -> m %| n -> logn p m <= logn p n. +Proof. +move=> n_gt0 dv_m_n; have m_gt0 := dvdn_gt0 n_gt0 dv_m_n. +case p_pr: (prime p); last by do 2!rewrite lognE p_pr /=. +by rewrite -pfactor_dvdn //; apply: dvdn_trans dv_m_n; rewrite pfactor_dvdn. +Qed. + +Lemma ltn_logl p n : 0 < n -> logn p n < n. +Proof. +move=> n_gt0; have [p_gt1 | p_le1] := boolP (1 < p). + by rewrite (leq_trans (ltn_expl _ p_gt1)) // dvdn_leq ?pfactor_dvdnn. +by rewrite lognE (contraNF (@prime_gt1 _)). +Qed. + +Lemma logn_Gauss p m n : coprime p m -> logn p (m * n) = logn p n. +Proof. +move=> co_pm; case p_pr: (prime p); last by rewrite /logn p_pr. +have [-> | n_gt0] := posnP n; first by rewrite muln0. +have [m0 | m_gt0] := posnP m; first by rewrite m0 prime_coprime ?dvdn0 in co_pm. +have mn_gt0: m * n > 0 by rewrite muln_gt0 m_gt0. +apply/eqP; rewrite eqn_leq andbC dvdn_leq_log ?dvdn_mull //. +set k := logn p _; have: p ^ k %| m * n by rewrite pfactor_dvdn. +by rewrite Gauss_dvdr ?coprime_expl // -pfactor_dvdn. +Qed. + +Lemma lognM p m n : 0 < m -> 0 < n -> logn p (m * n) = logn p m + logn p n. +Proof. +case p_pr: (prime p); last by rewrite /logn p_pr. +have xlp := pfactor_coprime p_pr. +case/xlp=> m' co_m' def_m /xlp[n' co_n' def_n] {xlp}. +by rewrite {1}def_m {1}def_n mulnCA -mulnA -expnD !logn_Gauss // pfactorK. +Qed. + +Lemma lognX p m n : logn p (m ^ n) = n * logn p m. +Proof. +case p_pr: (prime p); last by rewrite /logn p_pr muln0. +elim: n => [|n IHn]; first by rewrite logn1. +have [->|m_gt0] := posnP m; first by rewrite exp0n // lognE andbF muln0. +by rewrite expnS lognM ?IHn // expn_gt0 m_gt0. +Qed. + +Lemma logn_div p m n : m %| n -> logn p (n %/ m) = logn p n - logn p m. +Proof. +rewrite dvdn_eq => /eqP def_n. +case: (posnP n) => [-> |]; first by rewrite div0n logn0. +by rewrite -{1 3}def_n muln_gt0 => /andP[q_gt0 m_gt0]; rewrite lognM ?addnK. +Qed. + +Lemma dvdn_pfactor p d n : prime p -> + reflect (exists2 m, m <= n & d = p ^ m) (d %| p ^ n). +Proof. +move=> p_pr; have pn_gt0: p ^ n > 0 by rewrite expn_gt0 prime_gt0. +apply: (iffP idP) => [dv_d_pn|[m le_m_n ->]]; last first. + by rewrite -(subnK le_m_n) expnD dvdn_mull. +exists (logn p d); first by rewrite -(pfactorK n p_pr) dvdn_leq_log. +have d_gt0: d > 0 by exact: dvdn_gt0 dv_d_pn. +case: (pfactor_coprime p_pr d_gt0) => q co_p_q def_d. +rewrite {1}def_d ((q =P 1) _) ?mul1n // -dvdn1. +suff: q %| p ^ n * 1 by rewrite Gauss_dvdr // coprime_sym coprime_expl. +by rewrite muln1 (dvdn_trans _ dv_d_pn) // def_d dvdn_mulr. +Qed. + +Lemma prime_decompE n : prime_decomp n = [seq (p, logn p n) | p <- primes n]. +Proof. +case: n => // n; pose f0 := (0, 0); rewrite -map_comp. +apply: (@eq_from_nth _ f0) => [|i lt_i_n]; first by rewrite size_map. +rewrite (nth_map f0) //; case def_f: (nth _ _ i) => [p e] /=. +congr (_, _); rewrite [n.+1]prod_prime_decomp //. +have: (p, e) \in prime_decomp n.+1 by rewrite -def_f mem_nth. +case/mem_prime_decomp=> pr_p _ _. +rewrite (big_nth f0) big_mkord (bigD1 (Ordinal lt_i_n)) //=. +rewrite def_f mulnC logn_Gauss ?pfactorK //. +apply big_ind => [|m1 m2 com1 com2| [j ltj] /=]; first exact: coprimen1. + by rewrite coprime_mulr com1. +rewrite -val_eqE /= => nji; case def_j: (nth _ _ j) => [q e1] /=. +have: (q, e1) \in prime_decomp n.+1 by rewrite -def_j mem_nth. +case/mem_prime_decomp=> pr_q e1_gt0 _; rewrite coprime_pexpr //. +rewrite prime_coprime // dvdn_prime2 //; apply: contra nji => eq_pq. +rewrite -(nth_uniq 0 _ _ (primes_uniq n.+1)) ?size_map //=. +by rewrite !(nth_map f0) // def_f def_j /= eq_sym. +Qed. + +(* Some combinatorial formulae. *) + +Lemma divn_count_dvd d n : n %/ d = \sum_(1 <= i < n.+1) (d %| i). +Proof. +have [-> | d_gt0] := posnP d; first by rewrite big_add1 divn0 big1. +apply: (@addnI (d %| 0)); rewrite -(@big_ltn _ 0 _ 0 _ (dvdn d)) // big_mkord. +rewrite (partition_big (fun i : 'I_n.+1 => inord (i %/ d)) 'I_(n %/ d).+1) //=. +rewrite dvdn0 add1n -{1}[_.+1]card_ord -sum1_card; apply: eq_bigr => [[q ?] _]. +rewrite (bigD1 (inord (q * d))) /eq_op /= !inordK ?ltnS -?leq_divRL ?mulnK //. +rewrite dvdn_mull ?big1 // => [[i /= ?] /andP[/eqP <- /negPf]]. +by rewrite eq_sym dvdn_eq inordK ?ltnS ?leq_div2r // => ->. +Qed. + +Lemma logn_count_dvd p n : prime p -> logn p n = \sum_(1 <= k < n) (p ^ k %| n). +Proof. +rewrite big_add1 => p_prime; case: n => [|n]; first by rewrite logn0 big_geq. +rewrite big_mkord -big_mkcond (eq_bigl _ _ (fun _ => pfactor_dvdn _ _ _)) //=. +by rewrite big_ord_narrow ?sum1_card ?card_ord // -ltnS ltn_logl. +Qed. + +(* Truncated real log. *) + +Definition trunc_log p n := + let fix loop n k := + if k is k'.+1 then if p <= n then (loop (n %/ p) k').+1 else 0 else 0 + in loop n n. + +Lemma trunc_log_bounds p n : + 1 < p -> 0 < n -> let k := trunc_log p n in p ^ k <= n < p ^ k.+1. +Proof. +rewrite {+}/trunc_log => p_gt1; have p_gt0 := ltnW p_gt1. +elim: n {-2 5}n (leqnn n) => [|m IHm] [|n] //=; rewrite ltnS => le_n_m _. +have [le_p_n | // ] := leqP p _; rewrite 2!expnSr -leq_divRL -?ltn_divLR //. +by apply: IHm; rewrite ?divn_gt0 // -ltnS (leq_trans (ltn_Pdiv _ _)). +Qed. + +Lemma trunc_log_ltn p n : 1 < p -> n < p ^ (trunc_log p n).+1. +Proof. +have [-> | n_gt0] := posnP n; first by move=> /ltnW; rewrite expn_gt0. +by case/trunc_log_bounds/(_ n_gt0)/andP. +Qed. + +Lemma trunc_logP p n : 1 < p -> 0 < n -> p ^ trunc_log p n <= n. +Proof. by move=> p_gt1 /(trunc_log_bounds p_gt1)/andP[]. Qed. + +Lemma trunc_log_max p k j : 1 < p -> p ^ j <= k -> j <= trunc_log p k. +Proof. +move=> p_gt1 le_pj_k; rewrite -ltnS -(@ltn_exp2l p) //. +exact: leq_ltn_trans (trunc_log_ltn _ _). +Qed. + +(* pi- parts *) + +(* Testing for membership in set of prime factors. *) + +Canonical nat_pred_pred := Eval hnf in [predType of nat_pred]. + +Coercion nat_pred_of_nat (p : nat) : nat_pred := pred1 p. + +Section NatPreds. + +Variables (n : nat) (pi : nat_pred). + +Definition negn : nat_pred := [predC pi]. + +Definition pnat : pred nat := fun m => (m > 0) && all (mem pi) (primes m). + +Definition partn := \prod_(0 <= p < n.+1 | p \in pi) p ^ logn p n. + +End NatPreds. + +Notation "pi ^'" := (negn pi) (at level 2, format "pi ^'") : nat_scope. + +Notation "pi .-nat" := (pnat pi) (at level 2, format "pi .-nat") : nat_scope. + +Notation "n `_ pi" := (partn n pi) : nat_scope. + +Section PnatTheory. + +Implicit Types (n p : nat) (pi rho : nat_pred). + +Lemma negnK pi : pi^'^' =i pi. +Proof. move=> p; exact: negbK. Qed. + +Lemma eq_negn pi1 pi2 : pi1 =i pi2 -> pi1^' =i pi2^'. +Proof. by move=> eq_pi n; rewrite 3!inE /= eq_pi. Qed. + +Lemma eq_piP m n : \pi(m) =i \pi(n) <-> \pi(m) = \pi(n). +Proof. +rewrite /pi_of; have eqs := eq_sorted_irr ltn_trans ltnn. +by split=> [|-> //]; move/(eqs _ _ (sorted_primes m) (sorted_primes n)) ->. +Qed. + +Lemma part_gt0 pi n : 0 < n`_pi. +Proof. exact: prodn_gt0. Qed. +Hint Resolve part_gt0. + +Lemma sub_in_partn pi1 pi2 n : + {in \pi(n), {subset pi1 <= pi2}} -> n`_pi1 %| n`_pi2. +Proof. +move=> pi12; rewrite ![n`__]big_mkcond /=. +apply (big_ind2 (fun m1 m2 => m1 %| m2)) => // [*|p _]; first exact: dvdn_mul. +rewrite lognE -mem_primes; case: ifP => pi1p; last exact: dvd1n. +by case: ifP => pr_p; [rewrite pi12 | rewrite if_same]. +Qed. + +Lemma eq_in_partn pi1 pi2 n : {in \pi(n), pi1 =i pi2} -> n`_pi1 = n`_pi2. +Proof. +by move=> pi12; apply/eqP; rewrite eqn_dvd ?sub_in_partn // => p /pi12->. +Qed. + +Lemma eq_partn pi1 pi2 n : pi1 =i pi2 -> n`_pi1 = n`_pi2. +Proof. by move=> pi12; apply: eq_in_partn => p _. Qed. + +Lemma partnNK pi n : n`_pi^'^' = n`_pi. +Proof. by apply: eq_partn; exact: negnK. Qed. + +Lemma widen_partn m pi n : + n <= m -> n`_pi = \prod_(0 <= p < m.+1 | p \in pi) p ^ logn p n. +Proof. +move=> le_n_m; rewrite big_mkcond /=. +rewrite [n`_pi](big_nat_widen _ _ m.+1) // big_mkcond /=. +apply: eq_bigr => p _; rewrite ltnS lognE. +by case: and3P => [[_ n_gt0 p_dv_n]|]; rewrite ?if_same // andbC dvdn_leq. +Qed. + +Lemma partn0 pi : 0`_pi = 1. +Proof. by apply: big1_seq => [] [|n]; rewrite andbC. Qed. + +Lemma partn1 pi : 1`_pi = 1. +Proof. by apply: big1_seq => [] [|[|n]]; rewrite andbC. Qed. + +Lemma partnM pi m n : m > 0 -> n > 0 -> (m * n)`_pi = m`_pi * n`_pi. +Proof. +have le_pmul m' n': m' > 0 -> n' <= m' * n' by move/prednK <-; exact: leq_addr. +move=> mpos npos; rewrite !(@widen_partn (n * m)) 3?(le_pmul, mulnC) //. +rewrite !big_mkord -big_split; apply: eq_bigr => p _ /=. +by rewrite lognM // expnD. +Qed. + +Lemma partnX pi m n : (m ^ n)`_pi = m`_pi ^ n. +Proof. +elim: n => [|n IHn]; first exact: partn1. +rewrite expnS; case: (posnP m) => [->|m_gt0]; first by rewrite partn0 exp1n. +by rewrite expnS partnM ?IHn // expn_gt0 m_gt0. +Qed. + +Lemma partn_dvd pi m n : n > 0 -> m %| n -> m`_pi %| n`_pi. +Proof. +move=> n_gt0 dvmn; case/dvdnP: dvmn n_gt0 => q ->{n}. +by rewrite muln_gt0 => /andP[q_gt0 m_gt0]; rewrite partnM ?dvdn_mull. +Qed. + +Lemma p_part p n : n`_p = p ^ logn p n. +Proof. +case (posnP (logn p n)) => [log0 |]. + by rewrite log0 [n`_p]big1_seq // => q; case/andP; move/eqnP->; rewrite log0. +rewrite logn_gt0 mem_primes; case/and3P=> _ n_gt0 dv_p_n. +have le_p_n: p < n.+1 by rewrite ltnS dvdn_leq. +by rewrite [n`_p]big_mkord (big_pred1 (Ordinal le_p_n)). +Qed. + +Lemma p_part_eq1 p n : (n`_p == 1) = (p \notin \pi(n)). +Proof. +rewrite mem_primes p_part lognE; case: and3P => // [[p_pr _ _]]. +by rewrite -dvdn1 pfactor_dvdn // logn1. +Qed. + +Lemma p_part_gt1 p n : (n`_p > 1) = (p \in \pi(n)). +Proof. by rewrite ltn_neqAle part_gt0 andbT eq_sym p_part_eq1 negbK. Qed. + +Lemma primes_part pi n : primes n`_pi = filter (mem pi) (primes n). +Proof. +have ltnT := ltn_trans. +case: (posnP n) => [-> | n_gt0]; first by rewrite partn0. +apply: (eq_sorted_irr ltnT ltnn); rewrite ?(sorted_primes, sorted_filter) //. +move=> p; rewrite mem_filter /= !mem_primes n_gt0 part_gt0 /=. +apply/andP/and3P=> [[p_pr] | [pi_p p_pr dv_p_n]]. + rewrite /partn; apply big_ind => [|n1 n2 IHn1 IHn2|q pi_q]. + - by rewrite dvdn1; case: eqP p_pr => // ->. + - by rewrite Euclid_dvdM //; case/orP. + rewrite -{1}(expn1 p) pfactor_dvdn // lognX muln_gt0. + rewrite logn_gt0 mem_primes n_gt0 - andbA /=; case/and3P=> pr_q dv_q_n. + by rewrite logn_prime //; case: eqP => // ->. +have le_p_n: p < n.+1 by rewrite ltnS dvdn_leq. +rewrite [n`_pi]big_mkord (bigD1 (Ordinal le_p_n)) //= dvdn_mulr //. +by rewrite lognE p_pr n_gt0 dv_p_n expnS dvdn_mulr. +Qed. + +Lemma filter_pi_of n m : n < m -> filter \pi(n) (index_iota 0 m) = primes n. +Proof. +move=> lt_n_m; have ltnT := ltn_trans; apply: (eq_sorted_irr ltnT ltnn). +- by rewrite sorted_filter // iota_ltn_sorted. +- exact: sorted_primes. +move=> p; rewrite mem_filter mem_index_iota /= mem_primes; case: and3P => //. +case=> _ n_gt0 dv_p_n; apply: leq_ltn_trans lt_n_m; exact: dvdn_leq. +Qed. + +Lemma partn_pi n : n > 0 -> n`_\pi(n) = n. +Proof. +move=> n_gt0; rewrite {3}(prod_prime_decomp n_gt0) prime_decompE big_map. +by rewrite -[n`__]big_filter filter_pi_of. +Qed. + +Lemma partnT n : n > 0 -> n`_predT = n. +Proof. +move=> n_gt0; rewrite -{2}(partn_pi n_gt0) {2}/partn big_mkcond /=. +by apply: eq_bigr => p _; rewrite -logn_gt0; case: (logn p _). +Qed. + +Lemma partnC pi n : n > 0 -> n`_pi * n`_pi^' = n. +Proof. +move=> n_gt0; rewrite -{3}(partnT n_gt0) /partn. +do 2!rewrite mulnC big_mkcond /=; rewrite -big_split; apply: eq_bigr => p _ /=. +by rewrite mulnC inE /=; case: (p \in pi); rewrite /= (muln1, mul1n). +Qed. + +Lemma dvdn_part pi n : n`_pi %| n. +Proof. by case: n => // n; rewrite -{2}[n.+1](@partnC pi) // dvdn_mulr. Qed. + +Lemma logn_part p m : logn p m`_p = logn p m. +Proof. +case p_pr: (prime p); first by rewrite p_part pfactorK. +by rewrite lognE (lognE p m) p_pr. +Qed. + +Lemma partn_lcm pi m n : m > 0 -> n > 0 -> (lcmn m n)`_pi = lcmn m`_pi n`_pi. +Proof. +move=> m_gt0 n_gt0; have p_gt0: lcmn m n > 0 by rewrite lcmn_gt0 m_gt0. +apply/eqP; rewrite eqn_dvd dvdn_lcm !partn_dvd ?dvdn_lcml ?dvdn_lcmr //. +rewrite -(dvdn_pmul2r (part_gt0 pi^' (lcmn m n))) partnC // dvdn_lcm !andbT. +rewrite -{1}(partnC pi m_gt0) andbC -{1}(partnC pi n_gt0). +by rewrite !dvdn_mul ?partn_dvd ?dvdn_lcml ?dvdn_lcmr. +Qed. + +Lemma partn_gcd pi m n : m > 0 -> n > 0 -> (gcdn m n)`_pi = gcdn m`_pi n`_pi. +Proof. +move=> m_gt0 n_gt0; have p_gt0: gcdn m n > 0 by rewrite gcdn_gt0 m_gt0. +apply/eqP; rewrite eqn_dvd dvdn_gcd !partn_dvd ?dvdn_gcdl ?dvdn_gcdr //=. +rewrite -(dvdn_pmul2r (part_gt0 pi^' (gcdn m n))) partnC // dvdn_gcd. +rewrite -{3}(partnC pi m_gt0) andbC -{3}(partnC pi n_gt0). +by rewrite !dvdn_mul ?partn_dvd ?dvdn_gcdl ?dvdn_gcdr. +Qed. + +Lemma partn_biglcm (I : finType) (P : pred I) F pi : + (forall i, P i -> F i > 0) -> + (\big[lcmn/1%N]_(i | P i) F i)`_pi = \big[lcmn/1%N]_(i | P i) (F i)`_pi. +Proof. +move=> F_gt0; set m := \big[lcmn/1%N]_(i | P i) F i. +have m_gt0: 0 < m by elim/big_ind: m => // p q p_gt0; rewrite lcmn_gt0 p_gt0. +apply/eqP; rewrite eqn_dvd andbC; apply/andP; split. + by apply/dvdn_biglcmP=> i Pi; rewrite partn_dvd // (@biglcmn_sup _ i). +rewrite -(dvdn_pmul2r (part_gt0 pi^' m)) partnC //. +apply/dvdn_biglcmP=> i Pi; rewrite -(partnC pi (F_gt0 i Pi)) dvdn_mul //. + by rewrite (@biglcmn_sup _ i). +by rewrite partn_dvd // (@biglcmn_sup _ i). +Qed. + +Lemma partn_biggcd (I : finType) (P : pred I) F pi : + #|SimplPred P| > 0 -> (forall i, P i -> F i > 0) -> + (\big[gcdn/0]_(i | P i) F i)`_pi = \big[gcdn/0]_(i | P i) (F i)`_pi. +Proof. +move=> ntP F_gt0; set d := \big[gcdn/0]_(i | P i) F i. +have d_gt0: 0 < d. + case/card_gt0P: ntP => i /= Pi; have:= F_gt0 i Pi. + rewrite !lt0n -!dvd0n; apply: contra => dv0d. + by rewrite (dvdn_trans dv0d) // (@biggcdn_inf _ i). +apply/eqP; rewrite eqn_dvd; apply/andP; split. + by apply/dvdn_biggcdP=> i Pi; rewrite partn_dvd ?F_gt0 // (@biggcdn_inf _ i). +rewrite -(dvdn_pmul2r (part_gt0 pi^' d)) partnC //. +apply/dvdn_biggcdP=> i Pi; rewrite -(partnC pi (F_gt0 i Pi)) dvdn_mul //. + by rewrite (@biggcdn_inf _ i). +by rewrite partn_dvd ?F_gt0 // (@biggcdn_inf _ i). +Qed. + +Lemma sub_in_pnat pi rho n : + {in \pi(n), {subset pi <= rho}} -> pi.-nat n -> rho.-nat n. +Proof. +rewrite /pnat => subpi /andP[-> pi_n]. +apply/allP=> p pr_p; apply: subpi => //; exact: (allP pi_n). +Qed. + +Lemma eq_in_pnat pi rho n : {in \pi(n), pi =i rho} -> pi.-nat n = rho.-nat n. +Proof. by move=> eqpi; apply/idP/idP; apply: sub_in_pnat => p /eqpi->. Qed. + +Lemma eq_pnat pi rho n : pi =i rho -> pi.-nat n = rho.-nat n. +Proof. by move=> eqpi; apply: eq_in_pnat => p _. Qed. + +Lemma pnatNK pi n : pi^'^'.-nat n = pi.-nat n. +Proof. exact: eq_pnat (negnK pi). Qed. + +Lemma pnatI pi rho n : [predI pi & rho].-nat n = pi.-nat n && rho.-nat n. +Proof. by rewrite /pnat andbCA all_predI !andbA andbb. Qed. + +Lemma pnat_mul pi m n : pi.-nat (m * n) = pi.-nat m && pi.-nat n. +Proof. +rewrite /pnat muln_gt0 andbCA -andbA andbCA. +case: posnP => // n_gt0; case: posnP => //= m_gt0. +apply/allP/andP=> [pi_mn | [pi_m pi_n] p]. + by split; apply/allP=> p m_p; apply: pi_mn; rewrite primes_mul // m_p ?orbT. +rewrite primes_mul // => /orP[]; [exact: (allP pi_m) | exact: (allP pi_n)]. +Qed. + +Lemma pnat_exp pi m n : pi.-nat (m ^ n) = pi.-nat m || (n == 0). +Proof. by case: n => [|n]; rewrite orbC // /pnat expn_gt0 orbC primes_exp. Qed. + +Lemma part_pnat pi n : pi.-nat n`_pi. +Proof. +rewrite /pnat primes_part part_gt0. +by apply/allP=> p; rewrite mem_filter => /andP[]. +Qed. + +Lemma pnatE pi p : prime p -> pi.-nat p = (p \in pi). +Proof. by move=> pr_p; rewrite /pnat prime_gt0 ?primes_prime //= andbT. Qed. + +Lemma pnat_id p : prime p -> p.-nat p. +Proof. by move=> pr_p; rewrite pnatE ?inE /=. Qed. + +Lemma coprime_pi' m n : m > 0 -> n > 0 -> coprime m n = \pi(m)^'.-nat n. +Proof. +by move=> m_gt0 n_gt0; rewrite /pnat n_gt0 all_predC coprime_has_primes. +Qed. + +Lemma pnat_pi n : n > 0 -> \pi(n).-nat n. +Proof. rewrite /pnat => ->; exact/allP. Qed. + +Lemma pi_of_dvd m n : m %| n -> n > 0 -> {subset \pi(m) <= \pi(n)}. +Proof. +move=> m_dv_n n_gt0 p; rewrite !mem_primes n_gt0 => /and3P[-> _ p_dv_m]. +exact: dvdn_trans p_dv_m m_dv_n. +Qed. + +Lemma pi_ofM m n : m > 0 -> n > 0 -> \pi(m * n) =i [predU \pi(m) & \pi(n)]. +Proof. move=> m_gt0 n_gt0 p; exact: primes_mul. Qed. + +Lemma pi_of_part pi n : n > 0 -> \pi(n`_pi) =i [predI \pi(n) & pi]. +Proof. by move=> n_gt0 p; rewrite /pi_of primes_part mem_filter andbC. Qed. + +Lemma pi_of_exp p n : n > 0 -> \pi(p ^ n) = \pi(p). +Proof. by move=> n_gt0; rewrite /pi_of primes_exp. Qed. + +Lemma pi_of_prime p : prime p -> \pi(p) =i (p : nat_pred). +Proof. by move=> pr_p q; rewrite /pi_of primes_prime // mem_seq1. Qed. + +Lemma p'natEpi p n : n > 0 -> p^'.-nat n = (p \notin \pi(n)). +Proof. by case: n => // n _; rewrite /pnat all_predC has_pred1. Qed. + +Lemma p'natE p n : prime p -> p^'.-nat n = ~~ (p %| n). +Proof. +case: n => [|n] p_pr; first by case: p p_pr. +by rewrite p'natEpi // mem_primes p_pr. +Qed. + +Lemma pnatPpi pi n p : pi.-nat n -> p \in \pi(n) -> p \in pi. +Proof. by case/andP=> _ /allP; exact. Qed. + +Lemma pnat_dvd m n pi : m %| n -> pi.-nat n -> pi.-nat m. +Proof. by case/dvdnP=> q ->; rewrite pnat_mul; case/andP. Qed. + +Lemma pnat_div m n pi : m %| n -> pi.-nat n -> pi.-nat (n %/ m). +Proof. +case/dvdnP=> q ->; rewrite pnat_mul andbC => /andP[]. +by case: m => // m _; rewrite mulnK. +Qed. + +Lemma pnat_coprime pi m n : pi.-nat m -> pi^'.-nat n -> coprime m n. +Proof. +case/andP=> m_gt0 pi_m /andP[n_gt0 pi'_n]. +rewrite coprime_has_primes //; apply/hasPn=> p /(allP pi'_n). +apply: contra; exact: allP. +Qed. + +Lemma p'nat_coprime pi m n : pi^'.-nat m -> pi.-nat n -> coprime m n. +Proof. by move=> pi'm pi_n; rewrite (pnat_coprime pi'm) ?pnatNK. Qed. + +Lemma sub_pnat_coprime pi rho m n : + {subset rho <= pi^'} -> pi.-nat m -> rho.-nat n -> coprime m n. +Proof. +by move=> pi'rho pi_m; move/(sub_in_pnat (in1W pi'rho)); exact: pnat_coprime. +Qed. + +Lemma coprime_partC pi m n : coprime m`_pi n`_pi^'. +Proof. by apply: (@pnat_coprime pi); exact: part_pnat. Qed. + +Lemma pnat_1 pi n : pi.-nat n -> pi^'.-nat n -> n = 1. +Proof. +by move=> pi_n pi'_n; rewrite -(eqnP (pnat_coprime pi_n pi'_n)) gcdnn. +Qed. + +Lemma part_pnat_id pi n : pi.-nat n -> n`_pi = n. +Proof. +case/andP=> n_gt0 pi_n. +rewrite -{2}(partnT n_gt0) /partn big_mkcond; apply: eq_bigr=> p _. +case: (posnP (logn p n)) => [-> |]; first by rewrite if_same. +by rewrite logn_gt0 => /(allP pi_n)/= ->. +Qed. + +Lemma part_p'nat pi n : pi^'.-nat n -> n`_pi = 1. +Proof. +case/andP=> n_gt0 pi'_n; apply: big1_seq => p /andP[pi_p _]. +case: (posnP (logn p n)) => [-> //|]. +by rewrite logn_gt0; move/(allP pi'_n); case/negP. +Qed. + +Lemma partn_eq1 pi n : n > 0 -> (n`_pi == 1) = pi^'.-nat n. +Proof. +move=> n_gt0; apply/eqP/idP=> [pi_n_1|]; last exact: part_p'nat. +by rewrite -(partnC pi n_gt0) pi_n_1 mul1n part_pnat. +Qed. + +Lemma pnatP pi n : + n > 0 -> reflect (forall p, prime p -> p %| n -> p \in pi) (pi.-nat n). +Proof. +move=> n_gt0; rewrite /pnat n_gt0. +apply: (iffP allP) => /= pi_n p => [pr_p p_n|]. + by rewrite pi_n // mem_primes pr_p n_gt0. +by rewrite mem_primes n_gt0 /=; case/andP; move: p. +Qed. + +Lemma pi_pnat pi p n : p.-nat n -> p \in pi -> pi.-nat n. +Proof. +move=> p_n pi_p; have [n_gt0 _] := andP p_n. +by apply/pnatP=> // q q_pr /(pnatP _ n_gt0 p_n _ q_pr)/eqnP->. +Qed. + +Lemma p_natP p n : p.-nat n -> {k | n = p ^ k}. +Proof. by move=> p_n; exists (logn p n); rewrite -p_part part_pnat_id. Qed. + +Lemma pi'_p'nat pi p n : pi^'.-nat n -> p \in pi -> p^'.-nat n. +Proof. +move=> pi'n pi_p; apply: sub_in_pnat pi'n => q _. +by apply: contraNneq => ->. +Qed. + +Lemma pi_p'nat p pi n : pi.-nat n -> p \in pi^' -> p^'.-nat n. +Proof. by move=> pi_n; apply: pi'_p'nat; rewrite pnatNK. Qed. + +Lemma partn_part pi rho n : {subset pi <= rho} -> n`_rho`_pi = n`_pi. +Proof. +move=> pi_sub_rho; have [->|n_gt0] := posnP n; first by rewrite !partn0 partn1. +rewrite -{2}(partnC rho n_gt0) partnM //. +suffices: pi^'.-nat n`_rho^' by move/part_p'nat->; rewrite muln1. +apply: sub_in_pnat (part_pnat _ _) => q _; apply: contra; exact: pi_sub_rho. +Qed. + +Lemma partnI pi rho n : n`_[predI pi & rho] = n`_pi`_rho. +Proof. +rewrite -(@partnC [predI pi & rho] _`_rho) //. +symmetry; rewrite 2?partn_part; try by move=> p /andP []. +rewrite mulnC part_p'nat ?mul1n // pnatNK pnatI part_pnat andbT. +exact: pnat_dvd (dvdn_part _ _) (part_pnat _ _). +Qed. + +Lemma odd_2'nat n : odd n = 2^'.-nat n. +Proof. by case: n => // n; rewrite p'natE // dvdn2 negbK. Qed. + +End PnatTheory. +Hint Resolve part_gt0. + +(************************************) +(* Properties of the divisors list. *) +(************************************) + +Lemma divisors_correct n : n > 0 -> + [/\ uniq (divisors n), sorted leq (divisors n) + & forall d, (d \in divisors n) = (d %| n)]. +Proof. +move/prod_prime_decomp=> def_n; rewrite {4}def_n {def_n}. +have: all prime (primes n) by apply/allP=> p; rewrite mem_primes; case/andP. +have:= primes_uniq n; rewrite /primes /divisors; move/prime_decomp: n. +elim=> [|[p e] pd] /=; first by split=> // d; rewrite big_nil dvdn1 mem_seq1. +rewrite big_cons /=; move: (foldr _ _ pd) => divs. +move=> IHpd /andP[npd_p Upd] /andP[pr_p pr_pd]. +have lt0p: 0 < p by exact: prime_gt0. +have {IHpd Upd}[Udivs Odivs mem_divs] := IHpd Upd pr_pd. +have ndivs_p m: p * m \notin divs. + suffices: p \notin divs; rewrite !mem_divs. + by apply: contra => /dvdnP[n ->]; rewrite mulnCA dvdn_mulr. + have ndv_p_1: ~~(p %| 1) by rewrite dvdn1 neq_ltn orbC prime_gt1. + rewrite big_seq; elim/big_ind: _ => [//|u v npu npv|[q f] /= pd_qf]. + by rewrite Euclid_dvdM //; apply/norP. + elim: (f) => // f'; rewrite expnS Euclid_dvdM // orbC negb_or => -> {f'}/=. + have pd_q: q \in unzip1 pd by apply/mapP; exists (q, f). + by apply: contra npd_p; rewrite dvdn_prime2 // ?(allP pr_pd) // => /eqP->. +elim: e => [|e] /=; first by split=> // d; rewrite mul1n. +have Tmulp_inj: injective (NatTrec.mul p). + by move=> u v /eqP; rewrite !natTrecE eqn_pmul2l // => /eqP. +move: (iter e _ _) => divs' [Udivs' Odivs' mem_divs']; split=> [||d]. +- rewrite merge_uniq cat_uniq map_inj_uniq // Udivs Udivs' andbT /=. + apply/hasP=> [[d dv_d /mapP[d' _ def_d]]]. + by case/idPn: dv_d; rewrite def_d natTrecE. +- rewrite (merge_sorted leq_total) //; case: (divs') Odivs' => //= d ds. + rewrite (@map_path _ _ _ _ leq xpred0) ?has_pred0 // => u v _. + by rewrite !natTrecE leq_pmul2l. +rewrite mem_merge mem_cat; case dv_d_p: (p %| d). + case/dvdnP: dv_d_p => d' ->{d}; rewrite mulnC (negbTE (ndivs_p d')) orbF. + rewrite expnS -mulnA dvdn_pmul2l // -mem_divs'. + by rewrite -(mem_map Tmulp_inj divs') natTrecE. +case pdiv_d: (_ \in _). + by case/mapP: pdiv_d dv_d_p => d' _ ->; rewrite natTrecE dvdn_mulr. +rewrite mem_divs Gauss_dvdr // coprime_sym. +by rewrite coprime_expl ?prime_coprime ?dv_d_p. +Qed. + +Lemma sorted_divisors n : sorted leq (divisors n). +Proof. by case: (posnP n) => [-> | /divisors_correct[]]. Qed. + +Lemma divisors_uniq n : uniq (divisors n). +Proof. by case: (posnP n) => [-> | /divisors_correct[]]. Qed. + +Lemma sorted_divisors_ltn n : sorted ltn (divisors n). +Proof. by rewrite ltn_sorted_uniq_leq divisors_uniq sorted_divisors. Qed. + +Lemma dvdn_divisors d m : 0 < m -> (d %| m) = (d \in divisors m). +Proof. by case/divisors_correct. Qed. + +Lemma divisor1 n : 1 \in divisors n. +Proof. by case: n => // n; rewrite -dvdn_divisors // dvd1n. Qed. + +Lemma divisors_id n : 0 < n -> n \in divisors n. +Proof. by move/dvdn_divisors <-. Qed. + +(* Big sum / product lemmas*) + +Lemma dvdn_sum d I r (K : pred I) F : + (forall i, K i -> d %| F i) -> d %| \sum_(i <- r | K i) F i. +Proof. move=> dF; elim/big_ind: _ => //; exact: dvdn_add. Qed. + +Lemma dvdn_partP n m : 0 < n -> + reflect (forall p, p \in \pi(n) -> n`_p %| m) (n %| m). +Proof. +move=> n_gt0; apply: (iffP idP) => n_dvd_m => [p _|]. + apply: dvdn_trans n_dvd_m; exact: dvdn_part. +have [-> // | m_gt0] := posnP m. +rewrite -(partnT n_gt0) -(partnT m_gt0). +rewrite !(@widen_partn (m + n)) ?leq_addl ?leq_addr // /in_mem /=. +elim/big_ind2: _ => // [* | q _]; first exact: dvdn_mul. +have [-> // | ] := posnP (logn q n); rewrite logn_gt0 => q_n. +have pr_q: prime q by move: q_n; rewrite mem_primes; case/andP. +by have:= n_dvd_m q q_n; rewrite p_part !pfactor_dvdn // pfactorK. +Qed. + +Lemma modn_partP n a b : 0 < n -> + reflect (forall p : nat, p \in \pi(n) -> a = b %[mod n`_p]) (a == b %[mod n]). +Proof. +move=> n_gt0; wlog le_b_a: a b / b <= a. + move=> IH; case: (leqP b a) => [|/ltnW] /IH {IH}// IH. + by rewrite eq_sym; apply: (iffP IH) => eqab p; move/eqab. +rewrite eqn_mod_dvd //; apply: (iffP (dvdn_partP _ n_gt0)) => eqab p /eqab; + by rewrite -eqn_mod_dvd // => /eqP. +Qed. + +(* The Euler totient function *) + +Lemma totientE n : + n > 0 -> totient n = \prod_(p <- primes n) (p.-1 * p ^ (logn p n).-1). +Proof. +move=> n_gt0; rewrite /totient n_gt0 prime_decompE unlock. +by elim: (primes n) => //= [p pr ->]; rewrite !natTrecE. +Qed. + +Lemma totient_gt0 n : (0 < totient n) = (0 < n). +Proof. +case: n => // n; rewrite totientE // big_seq_cond prodn_cond_gt0 // => p. +by rewrite mem_primes muln_gt0 expn_gt0; case: p => [|[|]]. +Qed. + +Lemma totient_pfactor p e : + prime p -> e > 0 -> totient (p ^ e) = p.-1 * p ^ e.-1. +Proof. +move=> p_pr e_gt0; rewrite totientE ?expn_gt0 ?prime_gt0 //. +by rewrite primes_exp // primes_prime // unlock /= muln1 pfactorK. +Qed. + +Lemma totient_coprime m n : + coprime m n -> totient (m * n) = totient m * totient n. +Proof. +move=> co_mn; have [-> //| m_gt0] := posnP m. +have [->|n_gt0] := posnP n; first by rewrite !muln0. +rewrite !totientE ?muln_gt0 ?m_gt0 //. +have /(eq_big_perm _)->: perm_eq (primes (m * n)) (primes m ++ primes n). + apply: uniq_perm_eq => [||p]; first exact: primes_uniq. + by rewrite cat_uniq !primes_uniq -coprime_has_primes // co_mn. + by rewrite mem_cat primes_mul. +rewrite big_cat /= !big_seq. +congr (_ * _); apply: eq_bigr => p; rewrite mem_primes => /and3P[_ _ dvp]. + rewrite (mulnC m) logn_Gauss //; move: co_mn. + by rewrite -(divnK dvp) coprime_mull => /andP[]. +rewrite logn_Gauss //; move: co_mn. +by rewrite coprime_sym -(divnK dvp) coprime_mull => /andP[]. +Qed. + +Lemma totient_count_coprime n : totient n = \sum_(0 <= d < n) coprime n d. +Proof. +elim: {n}_.+1 {-2}n (ltnSn n) => // m IHm n; rewrite ltnS => le_n_m. +case: (leqP n 1) => [|lt1n]; first by rewrite unlock; case: (n) => [|[]]. +pose p := pdiv n; have p_pr: prime p by exact: pdiv_prime. +have p1 := prime_gt1 p_pr; have p0 := ltnW p1. +pose np := n`_p; pose np' := n`_p^'. +have co_npp': coprime np np' by rewrite coprime_partC. +have [n0 np0 np'0]: [/\ n > 0, np > 0 & np' > 0] by rewrite ltnW ?part_gt0. +have def_n: n = np * np' by rewrite partnC. +have lnp0: 0 < logn p n by rewrite lognE p_pr n0 pdiv_dvd. +pose in_mod k (k0 : k > 0) d := Ordinal (ltn_pmod d k0). +rewrite {1}def_n totient_coprime // {IHm}(IHm np') ?big_mkord; last first. + apply: leq_trans le_n_m; rewrite def_n ltn_Pmull //. + by rewrite /np p_part -(expn0 p) ltn_exp2l. +have ->: totient np = #|[pred d : 'I_np | coprime np d]|. + rewrite {1}[np]p_part totient_pfactor //=; set q := p ^ _. + apply: (@addnI (1 * q)); rewrite -mulnDl [1 + _]prednK // mul1n. + have def_np: np = p * q by rewrite -expnS prednK // -p_part. + pose mulp := [fun d : 'I_q => in_mod _ np0 (p * d)]. + rewrite -def_np -{1}[np]card_ord -(cardC (mem (codom mulp))). + rewrite card_in_image => [|[d1 ltd1] [d2 ltd2] /= _ _ []]; last first. + move/eqP; rewrite def_np -!muln_modr ?modn_small //. + by rewrite eqn_pmul2l // => eq_op12; exact/eqP. + rewrite card_ord; congr (q + _); apply: eq_card => d /=. + rewrite !inE [np in coprime np _]p_part coprime_pexpl ?prime_coprime //. + congr (~~ _); apply/codomP/idP=> [[d' -> /=] | /dvdnP[r def_d]]. + by rewrite def_np -muln_modr // dvdn_mulr. + do [rewrite mulnC; case: d => d ltd /=] in def_d *. + have ltr: r < q by rewrite -(ltn_pmul2l p0) -def_np -def_d. + by exists (Ordinal ltr); apply: val_inj; rewrite /= -def_d modn_small. +pose h (d : 'I_n) := (in_mod _ np0 d, in_mod _ np'0 d). +pose h' (d : 'I_np * 'I_np') := in_mod _ n0 (chinese np np' d.1 d.2). +rewrite -!big_mkcond -sum_nat_const pair_big (reindex_onto h h') => [|[d d'] _]. + apply: eq_bigl => [[d ltd] /=]; rewrite !inE /= -val_eqE /= andbC. + rewrite !coprime_modr def_n -chinese_mod // -coprime_mull -def_n. + by rewrite modn_small ?eqxx. +apply/eqP; rewrite /eq_op /= /eq_op /= !modn_dvdm ?dvdn_part //. +by rewrite chinese_modl // chinese_modr // !modn_small ?eqxx ?ltn_ord. +Qed. + + + diff --git a/mathcomp/discrete/tuple.v b/mathcomp/discrete/tuple.v new file mode 100644 index 0000000..ba64bd0 --- /dev/null +++ b/mathcomp/discrete/tuple.v @@ -0,0 +1,412 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +(******************************************************************************) +(* Tuples, i.e., sequences with a fixed (known) length. We define: *) +(* n.-tuple T == the type of n-tuples of elements of type T. *) +(* [tuple of s] == the tuple whose underlying sequence (value) is s. *) +(* The size of s must be known: specifically, Coq must *) +(* be able to infer a Canonical tuple projecting on s. *) +(* in_tuple s == the (size s)-tuple with value s. *) +(* [tuple] == the empty tuple, and *) +(* [tuple x1; ..; xn] == the explicit n.-tuple . *) +(* [tuple E | i < n] == the n.-tuple with general term E (i : 'I_n is bound *) +(* in E). *) +(* tcast Emn t == the m-tuple t cast as an n-tuple using Emn : m = n. *) +(* As n.-tuple T coerces to seq t, all seq operations (size, nth, ...) can be *) +(* applied to t : n.-tuple T; we provide a few specialized instances when *) +(* avoids the need for a default value. *) +(* tsize t == the size of t (the n in n.-tuple T) *) +(* tnth t i == the i'th component of t, where i : 'I_n. *) +(* [tnth t i] == the i'th component of t, where i : nat and i < n *) +(* is convertible to true. *) +(* thead t == the first element of t, when n is m.+1 for some m. *) +(* Most seq constructors (cons, behead, cat, rcons, belast, take, drop, rot, *) +(* map, ...) can be used to build tuples via the [tuple of s] construct. *) +(* Tuples are actually a subType of seq, and inherit all combinatorial *) +(* structures, including the finType structure. *) +(* Some useful lemmas and definitions: *) +(* tuple0 : [tuple] is the only 0.-tuple *) +(* tupleP : elimination view for n.+1.-tuple *) +(* ord_tuple n : the n.-tuple of all i : 'I_n *) +(******************************************************************************) + +Section Def. + +Variables (n : nat) (T : Type). + +Structure tuple_of : Type := Tuple {tval :> seq T; _ : size tval == n}. + +Canonical tuple_subType := Eval hnf in [subType for tval]. + +Implicit Type t : tuple_of. + +Definition tsize of tuple_of := n. + +Lemma size_tuple t : size t = n. +Proof. exact: (eqP (valP t)). Qed. + +Lemma tnth_default t : 'I_n -> T. +Proof. by rewrite -(size_tuple t); case: (tval t) => [|//] []. Qed. + +Definition tnth t i := nth (tnth_default t i) t i. + +Lemma tnth_nth x t i : tnth t i = nth x t i. +Proof. by apply: set_nth_default; rewrite size_tuple. Qed. + +Lemma map_tnth_enum t : map (tnth t) (enum 'I_n) = t. +Proof. +case def_t: {-}(val t) => [|x0 t']. + by rewrite [enum _]size0nil // -cardE card_ord -(size_tuple t) def_t. +apply: (@eq_from_nth _ x0) => [|i]; rewrite size_map. + by rewrite -cardE size_tuple card_ord. +move=> lt_i_e; have lt_i_n: i < n by rewrite -cardE card_ord in lt_i_e. +by rewrite (nth_map (Ordinal lt_i_n)) // (tnth_nth x0) nth_enum_ord. +Qed. + +Lemma eq_from_tnth t1 t2 : tnth t1 =1 tnth t2 -> t1 = t2. +Proof. +by move/eq_map=> eq_t; apply: val_inj; rewrite /= -!map_tnth_enum eq_t. +Qed. + +Definition tuple t mkT : tuple_of := + mkT (let: Tuple _ tP := t return size t == n in tP). + +Lemma tupleE t : tuple (fun sP => @Tuple t sP) = t. +Proof. by case: t. Qed. + +End Def. + +Notation "n .-tuple" := (tuple_of n) + (at level 2, format "n .-tuple") : type_scope. + +Notation "{ 'tuple' n 'of' T }" := (n.-tuple T : predArgType) + (at level 0, only parsing) : form_scope. + +Notation "[ 'tuple' 'of' s ]" := (tuple (fun sP => @Tuple _ _ s sP)) + (at level 0, format "[ 'tuple' 'of' s ]") : form_scope. + +Notation "[ 'tnth' t i ]" := (tnth t (@Ordinal (tsize t) i (erefl true))) + (at level 0, t, i at level 8, format "[ 'tnth' t i ]") : form_scope. + +Canonical nil_tuple T := Tuple (isT : @size T [::] == 0). +Canonical cons_tuple n T x (t : n.-tuple T) := + Tuple (valP t : size (x :: t) == n.+1). + +Notation "[ 'tuple' x1 ; .. ; xn ]" := [tuple of x1 :: .. [:: xn] ..] + (at level 0, format "[ 'tuple' '[' x1 ; '/' .. ; '/' xn ']' ]") + : form_scope. + +Notation "[ 'tuple' ]" := [tuple of [::]] + (at level 0, format "[ 'tuple' ]") : form_scope. + +Section CastTuple. + +Variable T : Type. + +Definition in_tuple (s : seq T) := Tuple (eqxx (size s)). + +Definition tcast m n (eq_mn : m = n) t := + let: erefl in _ = n := eq_mn return n.-tuple T in t. + +Lemma tcastE m n (eq_mn : m = n) t i : + tnth (tcast eq_mn t) i = tnth t (cast_ord (esym eq_mn) i). +Proof. by case: n / eq_mn in i *; rewrite cast_ord_id. Qed. + +Lemma tcast_id n (eq_nn : n = n) t : tcast eq_nn t = t. +Proof. by rewrite (eq_axiomK eq_nn). Qed. + +Lemma tcastK m n (eq_mn : m = n) : cancel (tcast eq_mn) (tcast (esym eq_mn)). +Proof. by case: n / eq_mn. Qed. + +Lemma tcastKV m n (eq_mn : m = n) : cancel (tcast (esym eq_mn)) (tcast eq_mn). +Proof. by case: n / eq_mn. Qed. + +Lemma tcast_trans m n p (eq_mn : m = n) (eq_np : n = p) t: + tcast (etrans eq_mn eq_np) t = tcast eq_np (tcast eq_mn t). +Proof. by case: n / eq_mn eq_np; case: p /. Qed. + +Lemma tvalK n (t : n.-tuple T) : in_tuple t = tcast (esym (size_tuple t)) t. +Proof. by apply: val_inj => /=; case: _ / (esym _). Qed. + +Lemma in_tupleE s : in_tuple s = s :> seq T. Proof. by []. Qed. + +End CastTuple. + +Section SeqTuple. + +Variables (n m : nat) (T U rT : Type). +Implicit Type t : n.-tuple T. + +Lemma rcons_tupleP t x : size (rcons t x) == n.+1. +Proof. by rewrite size_rcons size_tuple. Qed. +Canonical rcons_tuple t x := Tuple (rcons_tupleP t x). + +Lemma nseq_tupleP x : @size T (nseq n x) == n. +Proof. by rewrite size_nseq. Qed. +Canonical nseq_tuple x := Tuple (nseq_tupleP x). + +Lemma iota_tupleP : size (iota m n) == n. +Proof. by rewrite size_iota. Qed. +Canonical iota_tuple := Tuple iota_tupleP. + +Lemma behead_tupleP t : size (behead t) == n.-1. +Proof. by rewrite size_behead size_tuple. Qed. +Canonical behead_tuple t := Tuple (behead_tupleP t). + +Lemma belast_tupleP x t : size (belast x t) == n. +Proof. by rewrite size_belast size_tuple. Qed. +Canonical belast_tuple x t := Tuple (belast_tupleP x t). + +Lemma cat_tupleP t (u : m.-tuple T) : size (t ++ u) == n + m. +Proof. by rewrite size_cat !size_tuple. Qed. +Canonical cat_tuple t u := Tuple (cat_tupleP t u). + +Lemma take_tupleP t : size (take m t) == minn m n. +Proof. by rewrite size_take size_tuple eqxx. Qed. +Canonical take_tuple t := Tuple (take_tupleP t). + +Lemma drop_tupleP t : size (drop m t) == n - m. +Proof. by rewrite size_drop size_tuple. Qed. +Canonical drop_tuple t := Tuple (drop_tupleP t). + +Lemma rev_tupleP t : size (rev t) == n. +Proof. by rewrite size_rev size_tuple. Qed. +Canonical rev_tuple t := Tuple (rev_tupleP t). + +Lemma rot_tupleP t : size (rot m t) == n. +Proof. by rewrite size_rot size_tuple. Qed. +Canonical rot_tuple t := Tuple (rot_tupleP t). + +Lemma rotr_tupleP t : size (rotr m t) == n. +Proof. by rewrite size_rotr size_tuple. Qed. +Canonical rotr_tuple t := Tuple (rotr_tupleP t). + +Lemma map_tupleP f t : @size rT (map f t) == n. +Proof. by rewrite size_map size_tuple. Qed. +Canonical map_tuple f t := Tuple (map_tupleP f t). + +Lemma scanl_tupleP f x t : @size rT (scanl f x t) == n. +Proof. by rewrite size_scanl size_tuple. Qed. +Canonical scanl_tuple f x t := Tuple (scanl_tupleP f x t). + +Lemma pairmap_tupleP f x t : @size rT (pairmap f x t) == n. +Proof. by rewrite size_pairmap size_tuple. Qed. +Canonical pairmap_tuple f x t := Tuple (pairmap_tupleP f x t). + +Lemma zip_tupleP t (u : n.-tuple U) : size (zip t u) == n. +Proof. by rewrite size1_zip !size_tuple. Qed. +Canonical zip_tuple t u := Tuple (zip_tupleP t u). + +Lemma allpairs_tupleP f t (u : m.-tuple U) : @size rT (allpairs f t u) == n * m. +Proof. by rewrite size_allpairs !size_tuple. Qed. +Canonical allpairs_tuple f t u := Tuple (allpairs_tupleP f t u). + +Definition thead (u : n.+1.-tuple T) := tnth u ord0. + +Lemma tnth0 x t : tnth [tuple of x :: t] ord0 = x. +Proof. by []. Qed. + +Lemma theadE x t : thead [tuple of x :: t] = x. +Proof. by []. Qed. + +Lemma tuple0 : all_equal_to ([tuple] : 0.-tuple T). +Proof. by move=> t; apply: val_inj; case: t => [[]]. Qed. + +CoInductive tuple1_spec : n.+1.-tuple T -> Type := + Tuple1spec x t : tuple1_spec [tuple of x :: t]. + +Lemma tupleP u : tuple1_spec u. +Proof. +case: u => [[|x s] //= sz_s]; pose t := @Tuple n _ s sz_s. +rewrite (_ : Tuple _ = [tuple of x :: t]) //; exact: val_inj. +Qed. + +Lemma tnth_map f t i : tnth [tuple of map f t] i = f (tnth t i) :> rT. +Proof. by apply: nth_map; rewrite size_tuple. Qed. + +End SeqTuple. + +Lemma tnth_behead n T (t : n.+1.-tuple T) i : + tnth [tuple of behead t] i = tnth t (inord i.+1). +Proof. by case/tupleP: t => x t; rewrite !(tnth_nth x) inordK ?ltnS. Qed. + +Lemma tuple_eta n T (t : n.+1.-tuple T) : t = [tuple of thead t :: behead t]. +Proof. by case/tupleP: t => x t; exact: val_inj. Qed. + +Section TupleQuantifiers. + +Variables (n : nat) (T : Type). +Implicit Types (a : pred T) (t : n.-tuple T). + +Lemma forallb_tnth a t : [forall i, a (tnth t i)] = all a t. +Proof. +apply: negb_inj; rewrite -has_predC -has_map negb_forall. +apply/existsP/(has_nthP true) => [[i a_t_i] | [i lt_i_n a_t_i]]. + by exists i; rewrite ?size_tuple // -tnth_nth tnth_map. +rewrite size_tuple in lt_i_n; exists (Ordinal lt_i_n). +by rewrite -tnth_map (tnth_nth true). +Qed. + +Lemma existsb_tnth a t : [exists i, a (tnth t i)] = has a t. +Proof. by apply: negb_inj; rewrite negb_exists -all_predC -forallb_tnth. Qed. + +Lemma all_tnthP a t : reflect (forall i, a (tnth t i)) (all a t). +Proof. by rewrite -forallb_tnth; apply: forallP. Qed. + +Lemma has_tnthP a t : reflect (exists i, a (tnth t i)) (has a t). +Proof. by rewrite -existsb_tnth; apply: existsP. Qed. + +End TupleQuantifiers. + +Implicit Arguments all_tnthP [n T a t]. +Implicit Arguments has_tnthP [n T a t]. + +Section EqTuple. + +Variables (n : nat) (T : eqType). + +Definition tuple_eqMixin := Eval hnf in [eqMixin of n.-tuple T by <:]. +Canonical tuple_eqType := Eval hnf in EqType (n.-tuple T) tuple_eqMixin. + +Canonical tuple_predType := + Eval hnf in mkPredType (fun t : n.-tuple T => mem_seq t). + +Lemma memtE (t : n.-tuple T) : mem t = mem (tval t). +Proof. by []. Qed. + +Lemma mem_tnth i (t : n.-tuple T) : tnth t i \in t. +Proof. by rewrite mem_nth ?size_tuple. Qed. + +Lemma memt_nth x0 (t : n.-tuple T) i : i < n -> nth x0 t i \in t. +Proof. by move=> i_lt_n; rewrite mem_nth ?size_tuple. Qed. + +Lemma tnthP (t : n.-tuple T) x : reflect (exists i, x = tnth t i) (x \in t). +Proof. +apply: (iffP idP) => [/(nthP x)[i ltin <-] | [i ->]]; last exact: mem_tnth. +by rewrite size_tuple in ltin; exists (Ordinal ltin); rewrite (tnth_nth x). +Qed. + +Lemma seq_tnthP (s : seq T) x : x \in s -> {i | x = tnth (in_tuple s) i}. +Proof. +move=> s_x; pose i := index x s; have lt_i: i < size s by rewrite index_mem. +by exists (Ordinal lt_i); rewrite (tnth_nth x) nth_index. +Qed. + +End EqTuple. + +Definition tuple_choiceMixin n (T : choiceType) := + [choiceMixin of n.-tuple T by <:]. + +Canonical tuple_choiceType n (T : choiceType) := + Eval hnf in ChoiceType (n.-tuple T) (tuple_choiceMixin n T). + +Definition tuple_countMixin n (T : countType) := + [countMixin of n.-tuple T by <:]. + +Canonical tuple_countType n (T : countType) := + Eval hnf in CountType (n.-tuple T) (tuple_countMixin n T). + +Canonical tuple_subCountType n (T : countType) := + Eval hnf in [subCountType of n.-tuple T]. + +Module Type FinTupleSig. +Section FinTupleSig. +Variables (n : nat) (T : finType). +Parameter enum : seq (n.-tuple T). +Axiom enumP : Finite.axiom enum. +Axiom size_enum : size enum = #|T| ^ n. +End FinTupleSig. +End FinTupleSig. + +Module FinTuple : FinTupleSig. +Section FinTuple. +Variables (n : nat) (T : finType). + +Definition enum : seq (n.-tuple T) := + let extend e := flatten (codom (fun x => map (cons x) e)) in + pmap insub (iter n extend [::[::]]). + +Lemma enumP : Finite.axiom enum. +Proof. +case=> /= t t_n; rewrite -(count_map _ (pred1 t)) (pmap_filter (@insubK _ _ _)). +rewrite count_filter -(@eq_count _ (pred1 t)) => [|s /=]; last first. + by rewrite isSome_insub; case: eqP=> // ->. +elim: n t t_n => [|m IHm] [|x t] //= {IHm}/IHm; move: (iter m _ _) => em IHm. +transitivity (x \in T : nat); rewrite // -mem_enum codomE. +elim: (fintype.enum T) (enum_uniq T) => //= y e IHe /andP[/negPf ney]. +rewrite count_cat count_map inE /preim /= {1}/eq_op /= eq_sym => /IHe->. +by case: eqP => [->|_]; rewrite ?(ney, count_pred0, IHm). +Qed. + +Lemma size_enum : size enum = #|T| ^ n. +Proof. +rewrite /= cardE size_pmap_sub; elim: n => //= m IHm. +rewrite expnS /codom /image_mem; elim: {2 3}(fintype.enum T) => //= x e IHe. +by rewrite count_cat {}IHe count_map IHm. +Qed. + +End FinTuple. +End FinTuple. + +Section UseFinTuple. + +Variables (n : nat) (T : finType). + +Canonical tuple_finMixin := Eval hnf in FinMixin (@FinTuple.enumP n T). +Canonical tuple_finType := Eval hnf in FinType (n.-tuple T) tuple_finMixin. +Canonical tuple_subFinType := Eval hnf in [subFinType of n.-tuple T]. + +Lemma card_tuple : #|{:n.-tuple T}| = #|T| ^ n. +Proof. by rewrite [#|_|]cardT enumT unlock FinTuple.size_enum. Qed. + +Lemma enum_tupleP (A : pred T) : size (enum A) == #|A|. +Proof. by rewrite -cardE. Qed. +Canonical enum_tuple A := Tuple (enum_tupleP A). + +Definition ord_tuple : n.-tuple 'I_n := Tuple (introT eqP (size_enum_ord n)). +Lemma val_ord_tuple : val ord_tuple = enum 'I_n. Proof. by []. Qed. + +Lemma tuple_map_ord U (t : n.-tuple U) : t = [tuple of map (tnth t) ord_tuple]. +Proof. by apply: val_inj => /=; rewrite map_tnth_enum. Qed. + +Lemma tnth_ord_tuple i : tnth ord_tuple i = i. +Proof. +apply: val_inj; rewrite (tnth_nth i) -(nth_map _ 0) ?size_tuple //. +by rewrite /= enumT unlock val_ord_enum nth_iota. +Qed. + +Section ImageTuple. + +Variables (T' : Type) (f : T -> T') (A : pred T). + +Canonical image_tuple : #|A|.-tuple T' := [tuple of image f A]. +Canonical codom_tuple : #|T|.-tuple T' := [tuple of codom f]. + +End ImageTuple. + +Section MkTuple. + +Variables (T' : Type) (f : 'I_n -> T'). + +Definition mktuple := map_tuple f ord_tuple. + +Lemma tnth_mktuple i : tnth mktuple i = f i. +Proof. by rewrite tnth_map tnth_ord_tuple. Qed. + +Lemma nth_mktuple x0 (i : 'I_n) : nth x0 mktuple i = f i. +Proof. by rewrite -tnth_nth tnth_mktuple. Qed. + +End MkTuple. + +End UseFinTuple. + +Notation "[ 'tuple' F | i < n ]" := (mktuple (fun i : 'I_n => F)) + (at level 0, i at level 0, + format "[ '[hv' 'tuple' F '/' | i < n ] ']'") : form_scope. + + diff --git a/mathcomp/field/algC.v b/mathcomp/field/algC.v new file mode 100644 index 0000000..e035bc9 --- /dev/null +++ b/mathcomp/field/algC.v @@ -0,0 +1,1854 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq choice div fintype. +Require Import path bigop finset prime ssralg poly polydiv mxpoly. +Require Import generic_quotient countalg ssrnum ssrint rat intdiv. +Require Import algebraics_fundamentals. + +(******************************************************************************) +(* This file provides an axiomatic construction of the algebraic numbers. *) +(* The construction only assumes the existence of an algebraically closed *) +(* filed with an automorphism of order 2; this amounts to the purely *) +(* algebraic contents of the Fundamenta Theorem of Algebra. *) +(* algC == the closed, countable field of algebraic numbers. *) +(* algCeq, algCring, ..., algCnumField == structures for algC. *) +(* z^* == the complex conjugate of z (:= conjC z). *) +(* sqrtC z == a nonnegative square root of z, i.e., 0 <= sqrt x if 0 <= x. *) +(* n.-root z == more generally, for n > 0, an nth root of z, chosen with a *) +(* minimal non-negative argument for n > 1 (i.e., with a *) +(* maximal real part subject to a nonnegative imaginary part). *) +(* Note that n.-root (-1) is a primitive 2nth root of unity, *) +(* an thus not equal to -1 for n odd > 1 (this will be shown in *) +(* file cyclotomic.v). *) +(* The ssrnum interfaces are implemented for algC as follows: *) +(* x <= y <=> (y - x) is a nonnegative real *) +(* x < y <=> (y - x) is a (strictly) positive real *) +(* `|z| == the complex norm of z, i.e., sqrtC (z * z^* ). *) +(* Creal == the subset of real numbers (:= Num.real for algC). *) +(* In addition, we provide: *) +(* 'i == the imaginary number (:= sqrtC (-1)). *) +(* 'Re z == the real component of z. *) +(* 'Im z == the imaginary component of z. *) +(* Crat == the subset of rational numbers. *) +(* Cint == the subset of integers. *) +(* Cnat == the subset of natural integers. *) +(* getCrat z == some a : rat such that ratr a = z, provided z \in Crat. *) +(* floorC z == for z \in Creal, an m : int s.t. m%:~R <= z < (m + 1)%:~R. *) +(* truncC z == for z >= 0, an n : nat s.t. n%:R <= z < n.+1%:R, else 0%N. *) +(* minCpoly z == the minimal (monic) polynomial over Crat with root z. *) +(* algC_invaut nu == an inverse of nu : {rmorphism algC -> algC}. *) +(* (x %| y)%C <=> y is an integer (Cint) multiple of x; if x or y are *) +(* (x %| y)%Cx of type nat or int they are coerced to algC here. *) +(* The (x %| y)%Cx display form is a workaround for *) +(* design limitations of the Coq Notation facilities. *) +(* (x == y %[mod z])%C <=> x and y differ by an integer (Cint) multiple of z; *) +(* as above, arguments of type nat or int are cast to algC. *) +(* (x != y %[mod z])%C <=> x and y do not differ by an integer multiple of z. *) +(* Note that in file algnum we give an alternative definition of divisibility *) +(* based on algebraic integers, overloading the notation in the %A scope. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GRing.Theory Num.Theory. +Local Open Scope ring_scope. + +(* The Num mixin for an algebraically closed field with an automorphism of *) +(* order 2, making it into a field of complex numbers. *) +Lemma ComplexNumMixin (L : closedFieldType) (conj : {rmorphism L -> L}) : + involutive conj -> ~ conj =1 id -> + {numL | forall x : NumDomainType L numL, `|x| ^+ 2 = x * conj x}. +Proof. +move=> conjK conj_nt. +have nz2: 2%:R != 0 :> L. + apply/eqP=> char2; apply: conj_nt => e; apply/eqP/idPn=> eJ. + have opp_id x: - x = x :> L. + by apply/esym/eqP; rewrite -addr_eq0 -mulr2n -mulr_natl char2 mul0r. + have{char2} char2: 2 \in [char L] by exact/eqP. + without loss{eJ} eJ: e / conj e = e + 1. + move/(_ (e / (e + conj e))); apply. + rewrite fmorph_div rmorphD conjK -{1}[conj e](addNKr e) mulrDl. + by rewrite opp_id (addrC e) divff // addr_eq0 opp_id. + pose a := e * conj e; have aJ: conj a = a by rewrite rmorphM conjK mulrC. + have [w Dw] := @solve_monicpoly _ 2 (nth 0 [:: e * a; - 1]) isT. + have{Dw} Dw: w ^+ 2 + w = e * a. + by rewrite Dw !big_ord_recl big_ord0 /= mulr1 mulN1r addr0 subrK. + pose b := w + conj w; have bJ: conj b = b by rewrite rmorphD conjK addrC. + have Db2: b ^+ 2 + b = a. + rewrite -Frobenius_autE // rmorphD addrACA Dw /= Frobenius_autE -rmorphX. + by rewrite -rmorphD Dw rmorphM aJ eJ -mulrDl -{1}[e]opp_id addKr mul1r. + have /eqP[] := oner_eq0 L; apply: (addrI b); rewrite addr0 -{2}bJ. + have: (b + e) * (b + conj e) == 0. + rewrite mulrDl 2!mulrDr -/a addrA addr_eq0 opp_id (mulrC e) -addrA. + by rewrite -mulrDr eJ addrAC -{2}[e]opp_id subrr add0r mulr1 Db2. + rewrite mulf_eq0 !addr_eq0 !opp_id => /pred2P[] -> //. + by rewrite {2}eJ rmorphD rmorph1. +have mul2I: injective (fun z : L => z *+ 2). + by move=> x y; rewrite /= -mulr_natl -(mulr_natl y) => /mulfI->. +pose sqrt x : L := sval (sig_eqW (@solve_monicpoly _ 2 (nth 0 [:: x]) isT)). +have sqrtK x: sqrt x ^+ 2 = x. + rewrite /sqrt; case: sig_eqW => /= y ->. + by rewrite !big_ord_recl big_ord0 /= mulr1 mul0r !addr0. +have sqrtE x y: y ^+ 2 = x -> {b : bool | y = (-1) ^+ b * sqrt x}. + move=> Dx; exists (y != sqrt x); apply/eqP; rewrite mulr_sign if_neg. + by case: ifPn => //; apply/implyP; rewrite implyNb -eqf_sqr Dx sqrtK. +pose i := sqrt (- 1). +have sqrMi x: (i * x) ^+ 2 = - x ^+ 2 by rewrite exprMn sqrtK mulN1r. +have iJ : conj i = - i. + have /sqrtE[b]: conj i ^+ 2 = - 1 by rewrite -rmorphX sqrtK rmorphN1. + rewrite mulr_sign -/i; case: b => // Ri. + case: conj_nt => z; wlog zJ: z / conj z = - z. + move/(_ (z - conj z)); rewrite !rmorphB conjK opprB => zJ. + by apply/mul2I/(canRL (subrK _)); rewrite -addrA zJ // addrC subrK. + have [-> | nz_z] := eqVneq z 0; first exact: rmorph0. + have [u Ru [v Rv Dz]]: + exists2 u, conj u = u & exists2 v, conj v = v & (u + z * v) ^+ 2 = z. + - pose y := sqrt z; exists ((y + conj y) / 2%:R). + by rewrite fmorph_div rmorphD conjK addrC rmorph_nat. + exists ((y - conj y) / (z *+ 2)). + rewrite fmorph_div rmorphMn zJ mulNrn invrN mulrN -mulNr rmorphB opprB. + by rewrite conjK. + rewrite -(mulr_natl z) invfM (mulrC z) !mulrA divfK // -mulrDl addrACA. + by rewrite subrr addr0 -mulr2n -mulr_natr mulfK ?Neq0 ?sqrtK. + suffices u0: u = 0 by rewrite -Dz u0 add0r rmorphX rmorphM Rv zJ mulNr sqrrN. + suffices [b Du]: exists b : bool, u = (-1) ^+ b * i * z * v. + apply: mul2I; rewrite mul0rn mulr2n -{2}Ru. + by rewrite Du !rmorphM rmorph_sign Rv Ri zJ !mulrN mulNr subrr. + have/eqP:= zJ; rewrite -addr_eq0 -{1 2}Dz rmorphX rmorphD rmorphM Ru Rv zJ. + rewrite mulNr sqrrB sqrrD addrACA (addrACA (u ^+ 2)) addNr addr0 -!mulr2n. + rewrite -mulrnDl -(mul0rn _ 2) (inj_eq mul2I) /= -[rhs in _ + rhs]opprK. + rewrite -sqrMi subr_eq0 eqf_sqr -mulNr !mulrA. + by case/pred2P=> ->; [exists false | exists true]; rewrite mulr_sign. +pose norm x := sqrt x * conj (sqrt x). +have normK x : norm x ^+ 2 = x * conj x by rewrite exprMn -rmorphX sqrtK. +have normE x y : y ^+ 2 = x -> norm x = y * conj y. + rewrite /norm => /sqrtE[b /(canLR (signrMK b)) <-]. + by rewrite !rmorphM rmorph_sign mulrACA -mulrA signrMK. +have norm_eq0 x : norm x = 0 -> x = 0. + by move/eqP; rewrite mulf_eq0 fmorph_eq0 -mulf_eq0 -expr2 sqrtK => /eqP. +have normM x y : norm (x * y) = norm x * norm y. + by rewrite mulrACA -rmorphM; apply: normE; rewrite exprMn !sqrtK. +have normN x : norm (- x) = norm x. + by rewrite -mulN1r normM {1}/norm iJ mulrN -expr2 sqrtK opprK mul1r. +pose le x y := norm (y - x) == y - x; pose lt x y := (y != x) && le x y. +have posE x: le 0 x = (norm x == x) by rewrite /le subr0. +have leB x y: le x y = le 0 (y - x) by rewrite posE. +have posP x : reflect (exists y, x = y * conj y) (le 0 x). + rewrite posE; apply: (iffP eqP) => [Dx | [y {x}->]]; first by exists (sqrt x). + by rewrite (normE _ _ (normK y)) rmorphM conjK (mulrC (conj _)) -expr2 normK. +have posJ x : le 0 x -> conj x = x. + by case/posP=> {x}u ->; rewrite rmorphM conjK mulrC. +have pos_linear x y : le 0 x -> le 0 y -> le x y || le y x. + move=> pos_x pos_y; rewrite leB -opprB orbC leB !posE normN -eqf_sqr. + by rewrite normK rmorphB !posJ ?subrr. +have sposDl x y : lt 0 x -> le 0 y -> lt 0 (x + y). + have sqrtJ z : le 0 z -> conj (sqrt z) = sqrt z. + rewrite posE -{2}[z]sqrtK -subr_eq0 -mulrBr mulf_eq0 subr_eq0. + by case/pred2P=> ->; rewrite ?rmorph0. + case/andP=> nz_x /sqrtJ uJ /sqrtJ vJ. + set u := sqrt x in uJ; set v := sqrt y in vJ; pose w := u + i * v. + have ->: x + y = w * conj w. + rewrite rmorphD rmorphM iJ uJ vJ mulNr mulrC -subr_sqr sqrMi opprK. + by rewrite !sqrtK. + apply/andP; split; last by apply/posP; exists w. + rewrite -normK expf_eq0 //=; apply: contraNneq nz_x => /norm_eq0 w0. + rewrite -[x]sqrtK expf_eq0 /= -/u -(inj_eq mul2I) !mulr2n -{2}(rmorph0 conj). + by rewrite -w0 rmorphD rmorphM iJ uJ vJ mulNr addrACA subrr addr0. +have sposD x y : lt 0 x -> lt 0 y -> lt 0 (x + y). + by move=> x_gt0 /andP[_]; apply: sposDl. +have normD x y : le (norm (x + y)) (norm x + norm y). + have sposM u v: lt 0 u -> le 0 (u * v) -> le 0 v. + by rewrite /lt !posE normM andbC => /andP[/eqP-> /mulfI/inj_eq->]. + have posD u v: le 0 u -> le 0 v -> le 0 (u + v). + have [-> | nz_u u_ge0 v_ge0] := eqVneq u 0; first by rewrite add0r. + by have /andP[]: lt 0 (u + v) by rewrite sposDl // /lt nz_u. + have le_sqr u v: conj u = u -> le 0 v -> le (u ^+ 2) (v ^+ 2) -> le u v. + move=> Ru v_ge0; have [-> // | nz_u] := eqVneq u 0. + have [u_gt0 | u_le0 _] := boolP (lt 0 u). + by rewrite leB (leB u) subr_sqr mulrC addrC; apply: sposM; apply: sposDl. + rewrite leB posD // posE normN -addr_eq0; apply/eqP. + rewrite /lt nz_u posE -subr_eq0 in u_le0; apply: (mulfI u_le0). + by rewrite mulr0 -subr_sqr normK Ru subrr. + have pos_norm z: le 0 (norm z) by apply/posP; exists (sqrt z). + rewrite le_sqr ?posJ ?posD // sqrrD !normK -normM rmorphD mulrDl !mulrDr. + rewrite addrA addrC !addrA -(addrC (y * conj y)) !addrA. + move: (y * _ + _) => u; rewrite -!addrA leB opprD addrACA {u}subrr add0r -leB. + rewrite {}le_sqr ?posD //. + by rewrite rmorphD !rmorphM !conjK addrC mulrC (mulrC y). + rewrite -mulr2n -mulr_natr exprMn normK -natrX mulr_natr sqrrD mulrACA. + rewrite -rmorphM (mulrC y x) addrAC leB mulrnA mulr2n opprD addrACA. + rewrite subrr addr0 {2}(mulrC x) rmorphM mulrACA -opprB addrAC -sqrrB -sqrMi. + apply/posP; exists (i * (x * conj y - y * conj x)); congr (_ * _). + rewrite !(rmorphM, rmorphB) iJ !conjK mulNr -mulrN opprB. + by rewrite (mulrC x) (mulrC y). +by exists (Num.Mixin normD sposD norm_eq0 pos_linear normM (rrefl _) (rrefl _)). +Qed. + +Module Algebraics. + +Module Type Specification. + +Parameter type : Type. + +Parameter eqMixin : Equality.class_of type. +Canonical eqType := EqType type eqMixin. + +Parameter choiceMixin : Choice.mixin_of type. +Canonical choiceType := ChoiceType type choiceMixin. + +Parameter countMixin : Countable.mixin_of type. +Canonical countType := CountType type countMixin. + +Parameter zmodMixin : GRing.Zmodule.mixin_of type. +Canonical zmodType := ZmodType type zmodMixin. +Canonical countZmodType := [countZmodType of type]. + +Parameter ringMixin : GRing.Ring.mixin_of zmodType. +Canonical ringType := RingType type ringMixin. +Canonical countRingType := [countRingType of type]. + +Parameter unitRingMixin : GRing.UnitRing.mixin_of ringType. +Canonical unitRingType := UnitRingType type unitRingMixin. + +Axiom mulC : @commutative ringType ringType *%R. +Canonical comRingType := ComRingType type mulC. +Canonical comUnitRingType := [comUnitRingType of type]. + +Axiom idomainAxiom : GRing.IntegralDomain.axiom ringType. +Canonical idomainType := IdomainType type idomainAxiom. + +Axiom fieldMixin : GRing.Field.mixin_of unitRingType. +Canonical fieldType := FieldType type fieldMixin. + +Parameter decFieldMixin : GRing.DecidableField.mixin_of unitRingType. +Canonical decFieldType := DecFieldType type decFieldMixin. + +Axiom closedFieldAxiom : GRing.ClosedField.axiom ringType. +Canonical closedFieldType := ClosedFieldType type closedFieldAxiom. + +Parameter numMixin : Num.mixin_of ringType. +Canonical numDomainType := NumDomainType type numMixin. +Canonical numFieldType := [numFieldType of type]. + +Parameter conj : {rmorphism type -> type}. +Axiom conjK : involutive conj. +Axiom normK : forall x, `|x| ^+ 2 = x * conj x. + +Axiom algebraic : integralRange (@ratr unitRingType). + +End Specification. + +Module Implementation : Specification. + +Definition L := tag Fundamental_Theorem_of_Algebraics. + +Definition conjL : {rmorphism L -> L} := + s2val (tagged Fundamental_Theorem_of_Algebraics). + +Fact conjL_K : involutive conjL. +Proof. exact: s2valP (tagged Fundamental_Theorem_of_Algebraics). Qed. + +Fact conjL_nt : ~ conjL =1 id. +Proof. exact: s2valP' (tagged Fundamental_Theorem_of_Algebraics). Qed. + +Definition LnumMixin := ComplexNumMixin conjL_K conjL_nt. +Definition Lnum := NumDomainType L (sval LnumMixin). + +Definition QtoL := [rmorphism of @ratr [numFieldType of Lnum]]. +Notation pQtoL := (map_poly QtoL). + +Definition rootQtoL p_j := + if p_j.1 == 0 then 0 else + (sval (closed_field_poly_normal (pQtoL p_j.1)))`_p_j.2. + +Definition eq_root p_j q_k := rootQtoL p_j == rootQtoL q_k. +Fact eq_root_is_equiv : equiv_class_of eq_root. +Proof. by rewrite /eq_root; split=> [ ? | ? ? | ? ? ? ] // /eqP->. Qed. +Canonical eq_root_equiv := EquivRelPack eq_root_is_equiv. +Definition type : Type := {eq_quot eq_root}%qT. + +Definition eqMixin : Equality.class_of type := EquivQuot.eqMixin _. +Canonical eqType := EqType type eqMixin. + +Definition choiceMixin : Choice.mixin_of type := EquivQuot.choiceMixin _. +Canonical choiceType := ChoiceType type choiceMixin. + +Definition countMixin : Countable.mixin_of type := CanCountMixin (@reprK _ _). +Canonical countType := CountType type countMixin. + +Definition CtoL (u : type) := rootQtoL (repr u). + +Fact CtoL_inj : injective CtoL. +Proof. by move=> u v /eqP eq_uv; rewrite -[u]reprK -[v]reprK; apply/eqmodP. Qed. + +Fact CtoL_P u : integralOver QtoL (CtoL u). +Proof. +rewrite /CtoL /rootQtoL; case: (repr u) => p j /=. +case: (closed_field_poly_normal _) => r Dp /=. +case: ifPn => [_ | nz_p]; first exact: integral0. +have [/(nth_default 0)-> | lt_j_r] := leqP (size r) j; first exact: integral0. +apply/integral_algebraic; exists p; rewrite // Dp -mul_polyC rootM orbC. +by rewrite root_prod_XsubC mem_nth. +Qed. + +Fact LtoC_subproof z : integralOver QtoL z -> {u | CtoL u = z}. +Proof. +case/sig2_eqW=> p mon_p pz0; rewrite /CtoL. +pose j := index z (sval (closed_field_poly_normal (pQtoL p))). +pose u := \pi_type%qT (p, j); exists u; have /eqmodP/eqP-> := reprK u. +rewrite /rootQtoL -if_neg monic_neq0 //; apply: nth_index => /=. +case: (closed_field_poly_normal _) => r /= Dp. +by rewrite Dp (monicP _) ?(monic_map QtoL) // scale1r root_prod_XsubC in pz0. +Qed. + +Definition LtoC z Az := sval (@LtoC_subproof z Az). +Fact LtoC_K z Az : CtoL (@LtoC z Az) = z. +Proof. exact: (svalP (LtoC_subproof Az)). Qed. + +Fact CtoL_K u : LtoC (CtoL_P u) = u. +Proof. by apply: CtoL_inj; rewrite LtoC_K. Qed. + +Definition zero := LtoC (integral0 _). +Definition add u v := LtoC (integral_add (CtoL_P u) (CtoL_P v)). +Definition opp u := LtoC (integral_opp (CtoL_P u)). + +Fact addA : associative add. +Proof. by move=> u v w; apply: CtoL_inj; rewrite !LtoC_K addrA. Qed. + +Fact addC : commutative add. +Proof. by move=> u v; apply: CtoL_inj; rewrite !LtoC_K addrC. Qed. + +Fact add0 : left_id zero add. +Proof. by move=> u; apply: CtoL_inj; rewrite !LtoC_K add0r. Qed. + +Fact addN : left_inverse zero opp add. +Proof. by move=> u; apply: CtoL_inj; rewrite !LtoC_K addNr. Qed. + +Definition zmodMixin := ZmodMixin addA addC add0 addN. +Canonical zmodType := ZmodType type zmodMixin. +Canonical countZmodType := [countZmodType of type]. + +Fact CtoL_is_additive : additive CtoL. +Proof. by move=> u v; rewrite !LtoC_K. Qed. +Canonical CtoL_additive := Additive CtoL_is_additive. + +Definition one := LtoC (integral1 _). +Definition mul u v := LtoC (integral_mul (CtoL_P u) (CtoL_P v)). +Definition inv u := LtoC (integral_inv (CtoL_P u)). + +Fact mulA : associative mul. +Proof. by move=> u v w; apply: CtoL_inj; rewrite !LtoC_K mulrA. Qed. + +Fact mulC : commutative mul. +Proof. by move=> u v; apply: CtoL_inj; rewrite !LtoC_K mulrC. Qed. + +Fact mul1 : left_id one mul. +Proof. by move=> u; apply: CtoL_inj; rewrite !LtoC_K mul1r. Qed. + +Fact mulD : left_distributive mul +%R. +Proof. by move=> u v w; apply: CtoL_inj; rewrite !LtoC_K mulrDl. Qed. + +Fact one_nz : one != 0 :> type. +Proof. by rewrite -(inj_eq CtoL_inj) !LtoC_K oner_eq0. Qed. + +Definition ringMixin := ComRingMixin mulA mulC mul1 mulD one_nz. +Canonical ringType := RingType type ringMixin. +Canonical comRingType := ComRingType type mulC. +Canonical countRingType := [countRingType of type]. + +Fact CtoL_is_multiplicative : multiplicative CtoL. +Proof. by split=> [u v|]; rewrite !LtoC_K. Qed. +Canonical CtoL_rmorphism := AddRMorphism CtoL_is_multiplicative. + +Fact mulVf : GRing.Field.axiom inv. +Proof. +move=> u; rewrite -(inj_eq CtoL_inj) rmorph0 => nz_u. +by apply: CtoL_inj; rewrite !LtoC_K mulVf. +Qed. +Fact inv0 : inv 0 = 0. Proof. by apply: CtoL_inj; rewrite !LtoC_K invr0. Qed. + +Definition unitRingMixin := FieldUnitMixin mulVf inv0. +Canonical unitRingType := UnitRingType type unitRingMixin. +Canonical comUnitRingType := [comUnitRingType of type]. + +Definition fieldMixin := @FieldMixin _ _ mulVf inv0. +Definition idomainAxiom := FieldIdomainMixin fieldMixin. +Canonical idomainType := IdomainType type idomainAxiom. +Canonical fieldType := FieldType type fieldMixin. + +Fact closedFieldAxiom : GRing.ClosedField.axiom ringType. +Proof. +move=> n a n_gt0; pose p := 'X^n - \poly_(i < n) CtoL (a i). +have Ap: {in p : seq L, integralRange QtoL}. + move=> _ /(nthP 0)[j _ <-]; rewrite coefB coefXn coef_poly. + apply: integral_sub; first exact: integral_nat. + by case: ifP => _; [apply: CtoL_P | apply: integral0]. +have sz_p: size p = n.+1. + by rewrite size_addl size_polyXn // size_opp ltnS size_poly. +have [z pz0]: exists z, root p z by apply/closed_rootP; rewrite sz_p eqSS -lt0n. +have Az: integralOver ratr z. + by apply: integral_root Ap; rewrite // -size_poly_gt0 sz_p. +exists (LtoC Az); apply/CtoL_inj; rewrite -[CtoL _]subr0 -(rootP pz0). +rewrite rmorphX /= LtoC_K hornerD hornerXn hornerN opprD addNKr opprK. +rewrite horner_poly rmorph_sum; apply: eq_bigr => k _. +by rewrite rmorphM rmorphX /= LtoC_K. +Qed. + +Definition decFieldMixin := closed_field.closed_fields_QEMixin closedFieldAxiom. +Canonical decFieldType := DecFieldType type decFieldMixin. +Canonical closedFieldType := ClosedFieldType type closedFieldAxiom. + +Fact conj_subproof u : integralOver QtoL (conjL (CtoL u)). +Proof. +have [p mon_p pu0] := CtoL_P u; exists p => //. +rewrite -(fmorph_root conjL) conjL_K map_poly_id // => _ /(nthP 0)[j _ <-]. +by rewrite coef_map fmorph_rat. +Qed. +Fact conj_is_rmorphism : rmorphism (fun u => LtoC (conj_subproof u)). +Proof. +do 2?split=> [u v|]; apply: CtoL_inj; last by rewrite !LtoC_K rmorph1. +- by rewrite LtoC_K 3!{1}rmorphB /= !LtoC_K. +by rewrite LtoC_K 3!{1}rmorphM /= !LtoC_K. +Qed. +Definition conj : {rmorphism type -> type} := RMorphism conj_is_rmorphism. +Lemma conjK : involutive conj. +Proof. by move=> u; apply: CtoL_inj; rewrite !LtoC_K conjL_K. Qed. + +Fact conj_nt : ~ conj =1 id. +Proof. +have [i i2]: exists i : type, i ^+ 2 = -1. + have [i] := @solve_monicpoly _ 2 (nth 0 [:: -1 : type]) isT. + by rewrite !big_ord_recl big_ord0 /= mul0r mulr1 !addr0; exists i. +move/(_ i)/(congr1 CtoL); rewrite LtoC_K => iL_J. +have/ltr_geF/idP[] := @ltr01 Lnum; rewrite -oppr_ge0 -(rmorphN1 CtoL_rmorphism). +rewrite -i2 rmorphX /= expr2 -{2}iL_J -(svalP LnumMixin). +by rewrite exprn_ge0 ?normr_ge0. +Qed. + +Definition numMixin := sval (ComplexNumMixin conjK conj_nt). +Canonical numDomainType := NumDomainType type numMixin. +Canonical numFieldType := [numFieldType of type]. + +Lemma normK u : `|u| ^+ 2 = u * conj u. +Proof. exact: svalP (ComplexNumMixin conjK conj_nt) u. Qed. + +Lemma algebraic : integralRange (@ratr unitRingType). +Proof. +move=> u; have [p mon_p pu0] := CtoL_P u; exists p => {mon_p}//. +rewrite -(fmorph_root CtoL_rmorphism) -map_poly_comp; congr (root _ _): pu0. +by apply/esym/eq_map_poly; apply: fmorph_eq_rat. +Qed. + +End Implementation. + +Definition divisor := Implementation.type. + +Module Internals. + +Import Implementation. + +Local Notation algC := type. +Local Notation "z ^*" := (conj z) (at level 2, format "z ^*") : ring_scope. +Local Notation QtoC := (ratr : rat -> algC). +Local Notation QtoCm := [rmorphism of QtoC]. +Local Notation pQtoC := (map_poly QtoC). +Local Notation ZtoQ := (intr : int -> rat). +Local Notation ZtoC := (intr : int -> algC). +Local Notation Creal := (Num.real : qualifier 0 algC). + +Fact algCi_subproof : {i : algC | i ^+ 2 = -1}. +Proof. exact: imaginary_exists. Qed. + +Let Re2 z := z + z^*. +Definition nnegIm z := 0 <= sval algCi_subproof * (z^* - z). +Definition argCle y z := nnegIm z ==> nnegIm y && (Re2 z <= Re2 y). + +CoInductive rootC_spec n (x : algC) : Type := + RootCspec (y : algC) of if (n > 0)%N then y ^+ n = x else y = 0 + & forall z, (n > 0)%N -> z ^+ n = x -> argCle y z. + +Fact rootC_subproof n x : rootC_spec n x. +Proof. +have realRe2 u : Re2 u \is Creal. + rewrite realEsqr expr2 {2}/Re2 -{2}[u]conjK addrC -rmorphD -normK. + by rewrite exprn_ge0 ?normr_ge0. +have argCtotal : total argCle. + move=> u v; rewrite /total /argCle. + by do 2!case: (nnegIm _) => //; rewrite ?orbT //= real_leVge. +have argCtrans : transitive argCle. + move=> u v w /implyP geZuv /implyP geZvw; apply/implyP. + by case/geZvw/andP=> /geZuv/andP[-> geRuv] /ler_trans->. +pose p := 'X^n - (x *+ (n > 0))%:P; have [r0 Dp] := closed_field_poly_normal p. +have sz_p: size p = n.+1. + rewrite size_addl ?size_polyXn // ltnS size_opp size_polyC mulrn_eq0. + by case: posnP => //; case: negP. +pose r := sort argCle r0; have r_arg: sorted argCle r by apply: sort_sorted. +have{Dp} Dp: p = \prod_(z <- r) ('X - z%:P). + rewrite Dp lead_coefE sz_p coefB coefXn coefC -mulrb -mulrnA mulnb lt0n andNb. + rewrite subr0 eqxx scale1r; apply: eq_big_perm. + by rewrite perm_eq_sym perm_sort. +have mem_rP z: (n > 0)%N -> reflect (z ^+ n = x) (z \in r). + move=> n_gt0; rewrite -root_prod_XsubC -Dp rootE !hornerE hornerXn n_gt0. + by rewrite subr_eq0; apply: eqP. +exists r`_0 => [|z n_gt0 /(mem_rP z n_gt0) r_z]. + have sz_r: size r = n by apply: succn_inj; rewrite -sz_p Dp size_prod_XsubC. + case: posnP => [n0 | n_gt0]; first by rewrite nth_default // sz_r n0. + by apply/mem_rP=> //; rewrite mem_nth ?sz_r. +case: {Dp mem_rP}r r_z r_arg => // y r1; rewrite inE => /predU1P[-> _|r1z]. + by apply/implyP=> ->; rewrite lerr. +by move/(order_path_min argCtrans)/allP->. +Qed. + +CoInductive getCrat_spec : Type := GetCrat_spec CtoQ of cancel QtoC CtoQ. + +Fact getCrat_subproof : getCrat_spec. +Proof. +have isQ := rat_algebraic_decidable algebraic. +exists (fun z => if isQ z is left Qz then sval (sig_eqW Qz) else 0) => a. +case: (isQ _) => [Qa | []]; last by exists a. +by case: (sig_eqW _) => b /= /fmorph_inj. +Qed. + +Fact floorC_subproof x : {m | x \is Creal -> ZtoC m <= x < ZtoC (m + 1)}. +Proof. +have [Rx | _] := boolP (x \is Creal); last by exists 0. +without loss x_ge0: x Rx / x >= 0. + have [x_ge0 | /ltrW x_le0] := real_ger0P Rx; first exact. + case/(_ (- x)) => [||m /(_ isT)]; rewrite ?rpredN ?oppr_ge0 //. + rewrite ler_oppr ltr_oppl -!rmorphN opprD /= ltr_neqAle ler_eqVlt. + case: eqP => [-> _ | _ /and3P[lt_x_m _ le_m_x]]. + by exists (- m) => _; rewrite lerr rmorphD ltr_addl ltr01. + by exists (- m - 1); rewrite le_m_x subrK. +have /ex_minnP[n lt_x_n1 min_n]: exists n, x < n.+1%:R. + have [n le_x_n] := rat_algebraic_archimedean algebraic x. + by exists n; rewrite -(ger0_norm x_ge0) (ltr_trans le_x_n) ?ltr_nat. +exists n%:Z => _; rewrite addrC -intS lt_x_n1 andbT. +case Dn: n => // [n1]; rewrite -Dn. +have [||//|] := @real_lerP _ n%:R x; rewrite ?rpred_nat //. +by rewrite Dn => /min_n; rewrite Dn ltnn. +Qed. + +Fact minCpoly_subproof (x : algC) : + {p | p \is monic & forall q, root (pQtoC q) x = (p %| q)%R}. +Proof. +have isQ := rat_algebraic_decidable algebraic. +have [p [mon_p px0 irr_p]] := minPoly_decidable_closure isQ (algebraic x). +exists p => // q; apply/idP/idP=> [qx0 | /dvdpP[r ->]]; last first. + by rewrite rmorphM rootM px0 orbT. +suffices /eqp_dvdl <-: gcdp p q %= p by apply: dvdp_gcdr. +rewrite irr_p ?dvdp_gcdl ?gtn_eqF // -(size_map_poly QtoCm) gcdp_map /=. +rewrite (@root_size_gt1 _ x) ?root_gcd ?px0 //. +by rewrite gcdp_eq0 negb_and map_poly_eq0 monic_neq0. +Qed. + +Definition algC_divisor (x : algC) := x : divisor. +Definition int_divisor m := m%:~R : divisor. +Definition nat_divisor n := n%:R : divisor. + +End Internals. + +Module Import Exports. + +Import Implementation Internals. + +Notation algC := type. +Notation conjC := conj. +Delimit Scope C_scope with C. +Delimit Scope C_core_scope with Cc. +Delimit Scope C_expanded_scope with Cx. +Open Scope C_core_scope. +Notation "x ^*" := (conjC x) (at level 2, format "x ^*") : C_core_scope. +Notation "x ^*" := x^* (only parsing) : C_scope. + +Canonical eqType. +Canonical choiceType. +Canonical countType. +Canonical zmodType. +Canonical countZmodType. +Canonical ringType. +Canonical countRingType. +Canonical unitRingType. +Canonical comRingType. +Canonical comUnitRingType. +Canonical idomainType. +Canonical numDomainType. +Canonical fieldType. +Canonical numFieldType. +Canonical decFieldType. +Canonical closedFieldType. + +Notation algCeq := eqType. +Notation algCzmod := zmodType. +Notation algCring := ringType. +Notation algCuring := unitRingType. +Notation algCnum := numDomainType. +Notation algCfield := fieldType. +Notation algCnumField := numFieldType. + +Definition rootC n x := let: RootCspec y _ _ := rootC_subproof n x in y. +Notation "n .-root" := (rootC n) (at level 2, format "n .-root") : C_core_scope. +Notation "n .-root" := (rootC n) (only parsing) : C_scope. +Notation sqrtC := 2.-root. + +Definition algCi := sqrtC (-1). +Notation "'i" := algCi (at level 0) : C_core_scope. +Notation "'i" := 'i (only parsing) : C_scope. + +Definition algRe x := (x + x^*) / 2%:R. +Definition algIm x := 'i * (x^* - x) / 2%:R. +Notation "'Re z" := (algRe z) (at level 10, z at level 8) : C_core_scope. +Notation "'Im z" := (algIm z) (at level 10, z at level 8) : C_core_scope. +Notation "'Re z" := ('Re z) (only parsing) : C_scope. +Notation "'Im z" := ('Im z) (only parsing) : C_scope. + +Notation Creal := (@Num.Def.Rreal numDomainType). + +Definition getCrat := let: GetCrat_spec CtoQ _ := getCrat_subproof in CtoQ. +Definition Crat : pred_class := fun x : algC => ratr (getCrat x) == x. + +Definition floorC x := sval (floorC_subproof x). +Definition Cint : pred_class := fun x : algC => (floorC x)%:~R == x. + +Definition truncC x := if x >= 0 then `|floorC x|%N else 0%N. +Definition Cnat : pred_class := fun x : algC => (truncC x)%:R == x. + +Definition minCpoly x : {poly algC} := + let: exist2 p _ _ := minCpoly_subproof x in map_poly ratr p. + +Coercion nat_divisor : nat >-> divisor. +Coercion int_divisor : int >-> divisor. +Coercion algC_divisor : algC >-> divisor. + +Lemma nCdivE (p : nat) : p = p%:R :> divisor. Proof. by []. Qed. +Lemma zCdivE (p : int) : p = p%:~R :> divisor. Proof. by []. Qed. +Definition CdivE := (nCdivE, zCdivE). + +Definition dvdC (x : divisor) : pred_class := + fun y : algC => if x == 0 then y == 0 else y / x \in Cint. +Notation "x %| y" := (y \in dvdC x) : C_expanded_scope. +Notation "x %| y" := (@in_mem divisor y (mem (dvdC x))) : C_scope. + +Definition eqCmod (e x y : divisor) := (e %| x - y)%C. + +Notation "x == y %[mod e ]" := (eqCmod e x y) : C_scope. +Notation "x != y %[mod e ]" := (~~ (x == y %[mod e])%C) : C_scope. + +End Exports. + +End Algebraics. + +Export Algebraics.Exports. + +Section AlgebraicsTheory. + +Implicit Types (x y z : algC) (n : nat) (m : int) (b : bool). +Import Algebraics.Internals. + +Local Notation ZtoQ := (intr : int -> rat). +Local Notation ZtoC := (intr : int -> algC). +Local Notation QtoC := (ratr : rat -> algC). +Local Notation QtoCm := [rmorphism of QtoC]. +Local Notation CtoQ := getCrat. +Local Notation intrp := (map_poly intr). +Local Notation pZtoQ := (map_poly ZtoQ). +Local Notation pZtoC := (map_poly ZtoC). +Local Notation pQtoC := (map_poly ratr). +Local Hint Resolve (@intr_inj _ : injective ZtoC). + +(* Specialization of a few basic ssrnum order lemmas. *) + +Definition eqC_nat n p : (n%:R == p%:R :> algC) = (n == p) := eqr_nat _ n p. +Definition leC_nat n p : (n%:R <= p%:R :> algC) = (n <= p)%N := ler_nat _ n p. +Definition ltC_nat n p : (n%:R < p%:R :> algC) = (n < p)%N := ltr_nat _ n p. +Definition Cchar : [char algC] =i pred0 := @char_num _. + +(* This can be used in the converse direction to evaluate assertions over *) +(* manifest rationals, such as 3%:R^-1 + 7%:%^-1 < 2%:%^-1 :> algC. *) +(* Missing norm and integer exponent, due to gaps in ssrint and rat. *) +Definition CratrE := + let CnF := Algebraics.Implementation.numFieldType in + let QtoCm := ratr_rmorphism CnF in + ((rmorph0 QtoCm, rmorph1 QtoCm, rmorphMn QtoCm, rmorphN QtoCm, rmorphD QtoCm), + (rmorphM QtoCm, rmorphX QtoCm, fmorphV QtoCm), + (rmorphMz QtoCm, rmorphXz QtoCm, @ratr_norm CnF, @ratr_sg CnF), + =^~ (@ler_rat CnF, @ltr_rat CnF, (inj_eq (fmorph_inj QtoCm)))). + +Definition CintrE := + let CnF := Algebraics.Implementation.numFieldType in + let ZtoCm := intmul1_rmorphism CnF in + ((rmorph0 ZtoCm, rmorph1 ZtoCm, rmorphMn ZtoCm, rmorphN ZtoCm, rmorphD ZtoCm), + (rmorphM ZtoCm, rmorphX ZtoCm), + (rmorphMz ZtoCm, @intr_norm CnF, @intr_sg CnF), + =^~ (@ler_int CnF, @ltr_int CnF, (inj_eq (@intr_inj CnF)))). + +Let nz2 : 2%:R != 0 :> algC. Proof. by rewrite -!CintrE. Qed. + +(* Conjugation and norm. *) + +Definition conjCK : involutive conjC := Algebraics.Implementation.conjK. +Definition normCK x : `|x| ^+ 2 = x * x^* := Algebraics.Implementation.normK x. +Definition algC_algebraic x := Algebraics.Implementation.algebraic x. + +Lemma normCKC x : `|x| ^+ 2 = x^* * x. Proof. by rewrite normCK mulrC. Qed. + +Lemma mul_conjC_ge0 x : 0 <= x * x^*. +Proof. by rewrite -normCK exprn_ge0 ?normr_ge0. Qed. + +Lemma mul_conjC_gt0 x : (0 < x * x^*) = (x != 0). +Proof. +have [->|x_neq0] := altP eqP; first by rewrite rmorph0 mulr0. +by rewrite -normCK exprn_gt0 ?normr_gt0. +Qed. + +Lemma mul_conjC_eq0 x : (x * x^* == 0) = (x == 0). +Proof. by rewrite -normCK expf_eq0 normr_eq0. Qed. + +Lemma conjC_ge0 x : (0 <= x^*) = (0 <= x). +Proof. +wlog suffices: x / 0 <= x -> 0 <= x^*. + by move=> IH; apply/idP/idP=> /IH; rewrite ?conjCK. +rewrite le0r => /predU1P[-> | x_gt0]; first by rewrite rmorph0. +by rewrite -(pmulr_rge0 _ x_gt0) mul_conjC_ge0. +Qed. + +Lemma conjC_nat n : (n%:R)^* = n%:R. Proof. exact: rmorph_nat. Qed. +Lemma conjC0 : 0^* = 0. Proof. exact: rmorph0. Qed. +Lemma conjC1 : 1^* = 1. Proof. exact: rmorph1. Qed. +Lemma conjC_eq0 x : (x^* == 0) = (x == 0). Proof. exact: fmorph_eq0. Qed. + +Lemma invC_norm x : x^-1 = `|x| ^- 2 * x^*. +Proof. +have [-> | nx_x] := eqVneq x 0; first by rewrite conjC0 mulr0 invr0. +by rewrite normCK invfM divfK ?conjC_eq0. +Qed. + +(* Real number subset. *) + +Lemma Creal0 : 0 \is Creal. Proof. exact: rpred0. Qed. +Lemma Creal1 : 1 \is Creal. Proof. exact: rpred1. Qed. +Hint Resolve Creal0 Creal1. (* Trivial cannot resolve a general real0 hint. *) + +Lemma CrealE x : (x \is Creal) = (x^* == x). +Proof. +rewrite realEsqr ger0_def normrX normCK. +by have [-> | /mulfI/inj_eq-> //] := eqVneq x 0; rewrite rmorph0 !eqxx. +Qed. + +Lemma CrealP {x} : reflect (x^* = x) (x \is Creal). +Proof. by rewrite CrealE; apply: eqP. Qed. + +Lemma conj_Creal x : x \is Creal -> x^* = x. +Proof. by move/CrealP. Qed. + +Lemma conj_normC z : `|z|^* = `|z|. +Proof. by rewrite conj_Creal ?normr_real. Qed. + +Lemma geC0_conj x : 0 <= x -> x^* = x. +Proof. by move=> /ger0_real/CrealP. Qed. + +Lemma geC0_unit_exp x n : 0 <= x -> (x ^+ n.+1 == 1) = (x == 1). +Proof. by move=> x_ge0; rewrite pexpr_eq1. Qed. + +(* Elementary properties of roots. *) + +Ltac case_rootC := rewrite /rootC; case: (rootC_subproof _ _). + +Lemma root0C x : 0.-root x = 0. Proof. by case_rootC. Qed. + +Lemma rootCK n : (n > 0)%N -> cancel n.-root (fun x => x ^+ n). +Proof. by case: n => //= n _ x; case_rootC. Qed. + +Lemma root1C x : 1.-root x = x. Proof. exact: (@rootCK 1). Qed. + +Lemma rootC0 n : n.-root 0 = 0. +Proof. +have [-> | n_gt0] := posnP n; first by rewrite root0C. +by have /eqP := rootCK n_gt0 0; rewrite expf_eq0 n_gt0 /= => /eqP. +Qed. + +Lemma rootC_inj n : (n > 0)%N -> injective n.-root. +Proof. by move/rootCK/can_inj. Qed. + +Lemma eqr_rootC n : (n > 0)%N -> {mono n.-root : x y / x == y}. +Proof. by move/rootC_inj/inj_eq. Qed. + +Lemma rootC_eq0 n x : (n > 0)%N -> (n.-root x == 0) = (x == 0). +Proof. by move=> n_gt0; rewrite -{1}(rootC0 n) eqr_rootC. Qed. + +(* Rectangular coordinates. *) + +Lemma sqrCi : 'i ^+ 2 = -1. Proof. exact: rootCK. Qed. + +Lemma nonRealCi : 'i \isn't Creal. +Proof. by rewrite realEsqr sqrCi oppr_ge0 ltr_geF ?ltr01. Qed. + +Lemma neq0Ci : 'i != 0. +Proof. by apply: contraNneq nonRealCi => ->; apply: real0. Qed. + +Lemma normCi : `|'i| = 1. +Proof. +apply/eqP; rewrite -(@pexpr_eq1 _ _ 2) ?normr_ge0 //. +by rewrite -normrX sqrCi normrN1. +Qed. + +Lemma invCi : 'i^-1 = - 'i. +Proof. by rewrite -div1r -[1]opprK -sqrCi mulNr mulfK ?neq0Ci. Qed. + +Lemma conjCi : 'i^* = - 'i. +Proof. by rewrite -invCi invC_norm normCi expr1n invr1 mul1r. Qed. + +Lemma algCrect x : x = 'Re x + 'i * 'Im x. +Proof. +rewrite 2!mulrA -expr2 sqrCi mulN1r opprB -mulrDl addrACA subrr addr0. +by rewrite -mulr2n -mulr_natr mulfK. +Qed. + +Lemma Creal_Re x : 'Re x \is Creal. +Proof. by rewrite CrealE fmorph_div rmorph_nat rmorphD conjCK addrC. Qed. + +Lemma Creal_Im x : 'Im x \is Creal. +Proof. +rewrite CrealE fmorph_div rmorph_nat rmorphM rmorphB conjCK. +by rewrite conjCi -opprB mulrNN. +Qed. +Hint Resolve Creal_Re Creal_Im. + +Fact algRe_is_additive : additive algRe. +Proof. by move=> x y; rewrite /algRe rmorphB addrACA -opprD mulrBl. Qed. +Canonical algRe_additive := Additive algRe_is_additive. + +Fact algIm_is_additive : additive algIm. +Proof. +by move=> x y; rewrite /algIm rmorphB opprD addrACA -opprD mulrBr mulrBl. +Qed. +Canonical algIm_additive := Additive algIm_is_additive. + +Lemma Creal_ImP z : reflect ('Im z = 0) (z \is Creal). +Proof. +rewrite CrealE -subr_eq0 -(can_eq (mulKf neq0Ci)) mulr0. +by rewrite -(can_eq (divfK nz2)) mul0r; apply: eqP. +Qed. + +Lemma Creal_ReP z : reflect ('Re z = z) (z \in Creal). +Proof. +rewrite (sameP (Creal_ImP z) eqP) -(can_eq (mulKf neq0Ci)) mulr0. +by rewrite -(inj_eq (addrI ('Re z))) addr0 -algCrect eq_sym; apply: eqP. +Qed. + +Lemma algReMl : {in Creal, forall x, {morph algRe : z / x * z}}. +Proof. +by move=> x Rx z /=; rewrite /algRe rmorphM (conj_Creal Rx) -mulrDr -mulrA. +Qed. + +Lemma algReMr : {in Creal, forall x, {morph algRe : z / z * x}}. +Proof. by move=> x Rx z /=; rewrite mulrC algReMl // mulrC. Qed. + +Lemma algImMl : {in Creal, forall x, {morph algIm : z / x * z}}. +Proof. +by move=> x Rx z; rewrite /algIm rmorphM (conj_Creal Rx) -mulrBr mulrCA !mulrA. +Qed. + +Lemma algImMr : {in Creal, forall x, {morph algIm : z / z * x}}. +Proof. by move=> x Rx z /=; rewrite mulrC algImMl // mulrC. Qed. + +Lemma algRe_i : 'Re 'i = 0. Proof. by rewrite /algRe conjCi subrr mul0r. Qed. + +Lemma algIm_i : 'Im 'i = 1. +Proof. +rewrite /algIm conjCi -opprD mulrN -mulr2n mulrnAr ['i * _]sqrCi. +by rewrite mulNrn opprK divff. +Qed. + +Lemma algRe_conj z : 'Re z^* = 'Re z. +Proof. by rewrite /algRe addrC conjCK. Qed. + +Lemma algIm_conj z : 'Im z^* = - 'Im z. +Proof. by rewrite /algIm -mulNr -mulrN opprB conjCK. Qed. + +Lemma algRe_rect : {in Creal &, forall x y, 'Re (x + 'i * y) = x}. +Proof. +move=> x y Rx Ry; rewrite /= raddfD /= (Creal_ReP x Rx). +by rewrite algReMr // algRe_i mul0r addr0. +Qed. + +Lemma algIm_rect : {in Creal &, forall x y, 'Im (x + 'i * y) = y}. +Proof. +move=> x y Rx Ry; rewrite /= raddfD /= (Creal_ImP x Rx) add0r. +by rewrite algImMr // algIm_i mul1r. +Qed. + +Lemma conjC_rect : {in Creal &, forall x y, (x + 'i * y)^* = x - 'i * y}. +Proof. +by move=> x y Rx Ry; rewrite /= rmorphD rmorphM conjCi mulNr !conj_Creal. +Qed. + +Lemma addC_rect x1 y1 x2 y2 : + (x1 + 'i * y1) + (x2 + 'i * y2) = x1 + x2 + 'i * (y1 + y2). +Proof. by rewrite addrACA -mulrDr. Qed. + +Lemma oppC_rect x y : - (x + 'i * y) = - x + 'i * (- y). +Proof. by rewrite mulrN -opprD. Qed. + +Lemma subC_rect x1 y1 x2 y2 : + (x1 + 'i * y1) - (x2 + 'i * y2) = x1 - x2 + 'i * (y1 - y2). +Proof. by rewrite oppC_rect addC_rect. Qed. + +Lemma mulC_rect x1 y1 x2 y2 : + (x1 + 'i * y1) * (x2 + 'i * y2) + = x1 * x2 - y1 * y2 + 'i * (x1 * y2 + x2 * y1). +Proof. +rewrite mulrDl !mulrDr mulrCA -!addrA mulrAC -mulrA; congr (_ + _). +by rewrite mulrACA -expr2 sqrCi mulN1r addrA addrC. +Qed. + +Lemma normC2_rect : + {in Creal &, forall x y, `|x + 'i * y| ^+ 2 = x ^+ 2 + y ^+ 2}. +Proof. +move=> x y Rx Ry; rewrite /= normCK rmorphD rmorphM conjCi !conj_Creal //. +by rewrite mulrC mulNr -subr_sqr exprMn sqrCi mulN1r opprK. +Qed. + +Lemma normC2_Re_Im z : `|z| ^+ 2 = 'Re z ^+ 2 + 'Im z ^+ 2. +Proof. by rewrite -normC2_rect -?algCrect. Qed. + +Lemma invC_rect : + {in Creal &, forall x y, (x + 'i * y)^-1 = (x - 'i * y) / (x ^+ 2 + y ^+ 2)}. +Proof. +by move=> x y Rx Ry; rewrite /= invC_norm conjC_rect // mulrC normC2_rect. +Qed. + +Lemma lerif_normC_Re_Creal z : `|'Re z| <= `|z| ?= iff (z \is Creal). +Proof. +rewrite -(mono_in_lerif ler_sqr); try by rewrite qualifE normr_ge0. +rewrite normCK conj_Creal // normC2_Re_Im -expr2. +rewrite addrC -lerif_subLR subrr (sameP (Creal_ImP _) eqP) -sqrf_eq0 eq_sym. +by apply: lerif_eq; rewrite -realEsqr. +Qed. + +Lemma lerif_Re_Creal z : 'Re z <= `|z| ?= iff (0 <= z). +Proof. +have ubRe: 'Re z <= `|'Re z| ?= iff (0 <= 'Re z). + by rewrite ger0_def eq_sym; apply/lerif_eq/real_ler_norm. +congr (_ <= _ ?= iff _): (lerif_trans ubRe (lerif_normC_Re_Creal z)). +apply/andP/idP=> [[zRge0 /Creal_ReP <- //] | z_ge0]. +by have Rz := ger0_real z_ge0; rewrite (Creal_ReP _ _). +Qed. + +(* Equality from polar coordinates, for the upper plane. *) +Lemma eqC_semipolar x y : + `|x| = `|y| -> 'Re x = 'Re y -> 0 <= 'Im x * 'Im y -> x = y. +Proof. +move=> eq_norm eq_Re sign_Im. +rewrite [x]algCrect [y]algCrect eq_Re; congr (_ + 'i * _). +have /eqP := congr1 (fun z => z ^+ 2) eq_norm. +rewrite !normC2_Re_Im eq_Re (can_eq (addKr _)) eqf_sqr => /pred2P[] // eq_Im. +rewrite eq_Im mulNr -expr2 oppr_ge0 real_exprn_even_le0 //= in sign_Im. +by rewrite eq_Im (eqP sign_Im) oppr0. +Qed. + +(* Nth roots. *) + +Let argCleP y z : + reflect (0 <= 'Im z -> 0 <= 'Im y /\ 'Re z <= 'Re y) (argCle y z). +Proof. +suffices dIm x: nnegIm x = (0 <= 'Im x). + rewrite /argCle !dIm ler_pmul2r ?invr_gt0 ?ltr0n //. + by apply: (iffP implyP) => geZyz /geZyz/andP. +rewrite /('Im x) pmulr_lge0 ?invr_gt0 ?ltr0n //; congr (0 <= _ * _). +case Du: algCi_subproof => [u u2N1] /=. +have/eqP := u2N1; rewrite -sqrCi eqf_sqr => /pred2P[] //. +have:= conjCi; rewrite /'i; case_rootC => /= v v2n1 min_v conj_v Duv. +have{min_v} /idPn[] := min_v u isT u2N1; rewrite negb_imply /nnegIm Du /= Duv. +rewrite rmorphN conj_v opprK -opprD mulrNN mulNr -mulr2n mulrnAr -expr2 v2n1. +by rewrite mulNrn opprK ler0n oppr_ge0 (leC_nat 2 0). +Qed. + +Lemma rootC_Re_max n x y : + (n > 0)%N -> y ^+ n = x -> 0 <= 'Im y -> 'Re y <= 'Re (n.-root%C x). +Proof. +by move=> n_gt0 yn_x leI0y; case_rootC=> z /= _ /(_ y n_gt0 yn_x)/argCleP[]. +Qed. + +Let neg_unity_root n : (n > 1)%N -> exists2 w : algC, w ^+ n = 1 & 'Re w < 0. +Proof. +move=> n_gt1; have [|w /eqP pw_0] := closed_rootP (\poly_(i < n) (1 : algC)) _. + by rewrite size_poly_eq ?oner_eq0 // -(subnKC n_gt1). +rewrite horner_poly (eq_bigr _ (fun _ _ => mul1r _)) in pw_0. +have wn1: w ^+ n = 1 by apply/eqP; rewrite -subr_eq0 subrX1 pw_0 mulr0. +suffices /existsP[i ltRwi0]: [exists i : 'I_n, 'Re (w ^+ i) < 0]. + by exists (w ^+ i) => //; rewrite exprAC wn1 expr1n. +apply: contra_eqT (congr1 algRe pw_0); rewrite negb_exists => /forallP geRw0. +rewrite raddf_sum raddf0 /= (bigD1 (Ordinal (ltnW n_gt1))) //=. +rewrite (Creal_ReP _ _) ?rpred1 // gtr_eqF ?ltr_paddr ?ltr01 //=. +by apply: sumr_ge0 => i _; rewrite real_lerNgt. +Qed. + +Lemma Im_rootC_ge0 n x : (n > 1)%N -> 0 <= 'Im (n.-root x). +Proof. +set y := n.-root x => n_gt1; have n_gt0 := ltnW n_gt1. +apply: wlog_neg; rewrite -real_ltrNge // => ltIy0. +suffices [z zn_x leI0z]: exists2 z, z ^+ n = x & 'Im z >= 0. + by rewrite /y; case_rootC => /= y1 _ /(_ z n_gt0 zn_x)/argCleP[]. +have [w wn1 ltRw0] := neg_unity_root n_gt1. +wlog leRI0yw: w wn1 ltRw0 / 0 <= 'Re y * 'Im w. + move=> IHw; have: 'Re y * 'Im w \is Creal by rewrite rpredM. + case/real_ger0P=> [|/ltrW leRIyw0]; first exact: IHw. + apply: (IHw w^*); rewrite ?algRe_conj ?algIm_conj ?mulrN ?oppr_ge0 //. + by rewrite -rmorphX wn1 rmorph1. +exists (w * y); first by rewrite exprMn wn1 mul1r rootCK. +rewrite [w]algCrect [y]algCrect mulC_rect. +by rewrite algIm_rect ?rpredD ?rpredN 1?rpredM // addr_ge0 // ltrW ?nmulr_rgt0. +Qed. + +Lemma rootC_lt0 n x : (1 < n)%N -> (n.-root x < 0) = false. +Proof. +set y := n.-root x => n_gt1; have n_gt0 := ltnW n_gt1. +apply: negbTE; apply: wlog_neg => /negbNE lt0y; rewrite ler_gtF //. +have Rx: x \is Creal by rewrite -[x](rootCK n_gt0) rpredX // ltr0_real. +have Re_y: 'Re y = y by apply/Creal_ReP; rewrite ltr0_real. +have [z zn_x leR0z]: exists2 z, z ^+ n = x & 'Re z >= 0. + have [w wn1 ltRw0] := neg_unity_root n_gt1. + exists (w * y); first by rewrite exprMn wn1 mul1r rootCK. + by rewrite algReMr ?ltr0_real // ltrW // nmulr_lgt0. +without loss leI0z: z zn_x leR0z / 'Im z >= 0. + move=> IHz; have: 'Im z \is Creal by []. + case/real_ger0P=> [|/ltrW leIz0]; first exact: IHz. + apply: (IHz z^*); rewrite ?algRe_conj ?algIm_conj ?oppr_ge0 //. + by rewrite -rmorphX zn_x conj_Creal. +by apply: ler_trans leR0z _; rewrite -Re_y ?rootC_Re_max ?ltr0_real. +Qed. + +Lemma rootC_ge0 n x : (n > 0)%N -> (0 <= n.-root x) = (0 <= x). +Proof. +set y := n.-root x => n_gt0. +apply/idP/idP=> [/(exprn_ge0 n) | x_ge0]; first by rewrite rootCK. +rewrite -(ger_lerif (lerif_Re_Creal y)). +have Ray: `|y| \is Creal by apply: normr_real. +rewrite -(Creal_ReP _ Ray) rootC_Re_max ?(Creal_ImP _ Ray) //. +by rewrite -normrX rootCK // ger0_norm. +Qed. + +Lemma rootC_gt0 n x : (n > 0)%N -> (n.-root x > 0) = (x > 0). +Proof. by move=> n_gt0; rewrite !lt0r rootC_ge0 ?rootC_eq0. Qed. + +Lemma rootC_le0 n x : (1 < n)%N -> (n.-root x <= 0) = (x == 0). +Proof. +by move=> n_gt1; rewrite ler_eqVlt rootC_lt0 // orbF rootC_eq0 1?ltnW. +Qed. + +Lemma ler_rootCl n : (n > 0)%N -> {in Num.nneg, {mono n.-root : x y / x <= y}}. +Proof. +move=> n_gt0 x x_ge0 y; have [y_ge0 | not_y_ge0] := boolP (0 <= y). + by rewrite -(ler_pexpn2r n_gt0) ?qualifE ?rootC_ge0 ?rootCK. +rewrite (contraNF (@ler_trans _ _ 0 _ _)) ?rootC_ge0 //. +by rewrite (contraNF (ler_trans x_ge0)). +Qed. + +Lemma ler_rootC n : (n > 0)%N -> {in Num.nneg &, {mono n.-root : x y / x <= y}}. +Proof. by move=> n_gt0 x y x_ge0 _; apply: ler_rootCl. Qed. + +Lemma ltr_rootCl n : (n > 0)%N -> {in Num.nneg, {mono n.-root : x y / x < y}}. +Proof. by move=> n_gt0 x x_ge0 y; rewrite !ltr_def ler_rootCl ?eqr_rootC. Qed. + +Lemma ltr_rootC n : (n > 0)%N -> {in Num.nneg &, {mono n.-root : x y / x < y}}. +Proof. by move/ler_rootC/lerW_mono_in. Qed. + +Lemma exprCK n x : (0 < n)%N -> 0 <= x -> n.-root (x ^+ n) = x. +Proof. +move=> n_gt0 x_ge0; apply/eqP. +by rewrite -(eqr_expn2 n_gt0) ?rootC_ge0 ?exprn_ge0 ?rootCK. +Qed. + +Lemma norm_rootC n x : `|n.-root x| = n.-root `|x|. +Proof. +have [-> | n_gt0] := posnP n; first by rewrite !root0C normr0. +apply/eqP; rewrite -(eqr_expn2 n_gt0) ?rootC_ge0 ?normr_ge0 //. +by rewrite -normrX !rootCK. +Qed. + +Lemma rootCX n x k : (n > 0)%N -> 0 <= x -> n.-root (x ^+ k) = n.-root x ^+ k. +Proof. +move=> n_gt0 x_ge0; apply/eqP. +by rewrite -(eqr_expn2 n_gt0) ?(exprn_ge0, rootC_ge0) // 1?exprAC !rootCK. +Qed. + +Lemma rootC1 n : (n > 0)%N -> n.-root 1 = 1. +Proof. by move/(rootCX 0)/(_ ler01). Qed. + +Lemma rootCpX n x k : (k > 0)%N -> 0 <= x -> n.-root (x ^+ k) = n.-root x ^+ k. +Proof. +by case: n => [|n] k_gt0; [rewrite !root0C expr0n gtn_eqF | exact: rootCX]. +Qed. + +Lemma rootCV n x : (n > 0)%N -> 0 <= x -> n.-root x^-1 = (n.-root x)^-1. +Proof. +move=> n_gt0 x_ge0; apply/eqP. +by rewrite -(eqr_expn2 n_gt0) ?(invr_ge0, rootC_ge0) // !exprVn !rootCK. +Qed. + +Lemma rootC_eq1 n x : (n > 0)%N -> (n.-root x == 1) = (x == 1). +Proof. by move=> n_gt0; rewrite -{1}(rootC1 n_gt0) eqr_rootC. Qed. + +Lemma rootC_ge1 n x : (n > 0)%N -> (n.-root x >= 1) = (x >= 1). +Proof. +by move=> n_gt0; rewrite -{1}(rootC1 n_gt0) ler_rootCl // qualifE ler01. +Qed. + +Lemma rootC_gt1 n x : (n > 0)%N -> (n.-root x > 1) = (x > 1). +Proof. by move=> n_gt0; rewrite !ltr_def rootC_eq1 ?rootC_ge1. Qed. + +Lemma rootC_le1 n x : (n > 0)%N -> 0 <= x -> (n.-root x <= 1) = (x <= 1). +Proof. by move=> n_gt0 x_ge0; rewrite -{1}(rootC1 n_gt0) ler_rootCl. Qed. + +Lemma rootC_lt1 n x : (n > 0)%N -> 0 <= x -> (n.-root x < 1) = (x < 1). +Proof. by move=> n_gt0 x_ge0; rewrite !ltr_neqAle rootC_eq1 ?rootC_le1. Qed. + +Lemma rootCMl n x z : 0 <= x -> n.-root (x * z) = n.-root x * n.-root z. +Proof. +rewrite le0r => /predU1P[-> | x_gt0]; first by rewrite !(mul0r, rootC0). +have [| n_gt1 | ->] := ltngtP n 1; last by rewrite !root1C. + by case: n => //; rewrite !root0C mul0r. +have [x_ge0 n_gt0] := (ltrW x_gt0, ltnW n_gt1). +have nx_gt0: 0 < n.-root x by rewrite rootC_gt0. +have Rnx: n.-root x \is Creal by rewrite ger0_real ?ltrW. +apply: eqC_semipolar; last 1 first; try apply/eqP. +- by rewrite algImMl // !(Im_rootC_ge0, mulr_ge0, rootC_ge0). +- by rewrite -(eqr_expn2 n_gt0) ?normr_ge0 // -!normrX exprMn !rootCK. +rewrite eqr_le; apply/andP; split; last first. + rewrite rootC_Re_max ?exprMn ?rootCK ?algImMl //. + by rewrite mulr_ge0 ?Im_rootC_ge0 ?ltrW. +rewrite -[n.-root _](mulVKf (negbT (gtr_eqF nx_gt0))) !(algReMl Rnx) //. +rewrite ler_pmul2l // rootC_Re_max ?exprMn ?exprVn ?rootCK ?mulKf ?gtr_eqF //. +by rewrite algImMl ?rpredV // mulr_ge0 ?invr_ge0 ?Im_rootC_ge0 ?ltrW. +Qed. + +Lemma rootCMr n x z : 0 <= x -> n.-root (z * x) = n.-root z * n.-root x. +Proof. by move=> x_ge0; rewrite mulrC rootCMl // mulrC. Qed. + +(* More properties of n.-root will be established in cyclotomic.v. *) + +(* The proper form of the Arithmetic - Geometric Mean inequality. *) + +Lemma lerif_rootC_AGM (I : finType) (A : pred I) (n := #|A|) E : + {in A, forall i, 0 <= E i} -> + n.-root (\prod_(i in A) E i) <= (\sum_(i in A) E i) / n%:R + ?= iff [forall i in A, forall j in A, E i == E j]. +Proof. +move=> Ege0; have [n0 | n_gt0] := posnP n. + rewrite n0 root0C invr0 mulr0; apply/lerif_refl/forall_inP=> i. + by rewrite (card0_eq n0). +rewrite -(mono_in_lerif (ler_pexpn2r n_gt0)) ?rootCK //=; first 1 last. +- by rewrite qualifE rootC_ge0 // prodr_ge0. +- by rewrite rpred_div ?rpred_nat ?rpred_sum. +exact: lerif_AGM. +Qed. + +(* Square root. *) + +Lemma sqrtC0 : sqrtC 0 = 0. Proof. exact: rootC0. Qed. +Lemma sqrtC1 : sqrtC 1 = 1. Proof. exact: rootC1. Qed. +Lemma sqrtCK x : sqrtC x ^+ 2 = x. Proof. exact: rootCK. Qed. +Lemma sqrCK x : 0 <= x -> sqrtC (x ^+ 2) = x. Proof. exact: exprCK. Qed. + +Lemma sqrtC_ge0 x : (0 <= sqrtC x) = (0 <= x). Proof. exact: rootC_ge0. Qed. +Lemma sqrtC_eq0 x : (sqrtC x == 0) = (x == 0). Proof. exact: rootC_eq0. Qed. +Lemma sqrtC_gt0 x : (sqrtC x > 0) = (x > 0). Proof. exact: rootC_gt0. Qed. +Lemma sqrtC_lt0 x : (sqrtC x < 0) = false. Proof. exact: rootC_lt0. Qed. +Lemma sqrtC_le0 x : (sqrtC x <= 0) = (x == 0). Proof. exact: rootC_le0. Qed. + +Lemma ler_sqrtC : {in Num.nneg &, {mono sqrtC : x y / x <= y}}. +Proof. exact: ler_rootC. Qed. +Lemma ltr_sqrtC : {in Num.nneg &, {mono sqrtC : x y / x < y}}. +Proof. exact: ltr_rootC. Qed. +Lemma eqr_sqrtC : {mono sqrtC : x y / x == y}. +Proof. exact: eqr_rootC. Qed. +Lemma sqrtC_inj : injective sqrtC. +Proof. exact: rootC_inj. Qed. +Lemma sqrtCM : {in Num.nneg &, {morph sqrtC : x y / x * y}}. +Proof. by move=> x y _; apply: rootCMr. Qed. + +Lemma sqrCK_P x : reflect (sqrtC (x ^+ 2) = x) ((0 <= 'Im x) && ~~ (x < 0)). +Proof. +apply: (iffP andP) => [[leI0x not_gt0x] | <-]; last first. + by rewrite sqrtC_lt0 Im_rootC_ge0. +have /eqP := sqrtCK (x ^+ 2); rewrite eqf_sqr => /pred2P[] // defNx. +apply: sqrCK; rewrite -real_lerNgt // in not_gt0x; apply/Creal_ImP/ler_anti; +by rewrite leI0x -oppr_ge0 -raddfN -defNx Im_rootC_ge0. +Qed. + +Lemma normC_def x : `|x| = sqrtC (x * x^*). +Proof. by rewrite -normCK sqrCK ?normr_ge0. Qed. + +Lemma norm_conjC x : `|x^*| = `|x|. +Proof. by rewrite !normC_def conjCK mulrC. Qed. + +Lemma normC_rect : + {in Creal &, forall x y, `|x + 'i * y| = sqrtC (x ^+ 2 + y ^+ 2)}. +Proof. by move=> x y Rx Ry; rewrite /= normC_def -normCK normC2_rect. Qed. + +Lemma normC_Re_Im z : `|z| = sqrtC ('Re z ^+ 2 + 'Im z ^+ 2). +Proof. by rewrite normC_def -normCK normC2_Re_Im. Qed. + +(* Norm sum (in)equalities. *) + +Lemma normC_add_eq x y : + `|x + y| = `|x| + `|y| -> + {t : algC | `|t| == 1 & (x, y) = (`|x| * t, `|y| * t)}. +Proof. +move=> lin_xy; apply: sig2_eqW; pose u z := if z == 0 then 1 else z / `|z|. +have uE z: (`|u z| = 1) * (`|z| * u z = z). + rewrite /u; have [->|nz_z] := altP eqP; first by rewrite normr0 normr1 mul0r. + by rewrite normf_div normr_id mulrCA divff ?mulr1 ?normr_eq0. +have [->|nz_x] := eqVneq x 0; first by exists (u y); rewrite uE ?normr0 ?mul0r. +exists (u x); rewrite uE // /u (negPf nz_x); congr (_ , _). +have{lin_xy} def2xy: `|x| * `|y| *+ 2 = x * y ^* + y * x ^*. + apply/(addrI (x * x^*))/(addIr (y * y^*)); rewrite -2!{1}normCK -sqrrD. + by rewrite addrA -addrA -!mulrDr -mulrDl -rmorphD -normCK lin_xy. +have def_xy: x * y^* = y * x^*. + apply/eqP; rewrite -subr_eq0 -[_ == 0](@expf_eq0 _ _ 2). + rewrite (canRL (subrK _) (subr_sqrDB _ _)) opprK -def2xy exprMn_n exprMn. + by rewrite mulrN mulrAC mulrA -mulrA mulrACA -!normCK mulNrn addNr. +have{def_xy def2xy} def_yx: `|y * x| = y * x^*. + by apply: (mulIf nz2); rewrite !mulr_natr mulrC normrM def2xy def_xy. +rewrite -{1}(divfK nz_x y) invC_norm mulrCA -{}def_yx !normrM invfM. +by rewrite mulrCA divfK ?normr_eq0 // mulrAC mulrA. +Qed. + +Lemma normC_sum_eq (I : finType) (P : pred I) (F : I -> algC) : + `|\sum_(i | P i) F i| = \sum_(i | P i) `|F i| -> + {t : algC | `|t| == 1 & forall i, P i -> F i = `|F i| * t}. +Proof. +have [i /andP[Pi nzFi] | F0] := pickP [pred i | P i & F i != 0]; last first. + exists 1 => [|i Pi]; first by rewrite normr1. + by case/nandP: (F0 i) => [/negP[]// | /negbNE/eqP->]; rewrite normr0 mul0r. +rewrite !(bigD1 i Pi) /= => norm_sumF; pose Q j := P j && (j != i). +rewrite -normr_eq0 in nzFi; set c := F i / `|F i|; exists c => [|j Pj]. + by rewrite normrM normfV normr_id divff. +have [Qj | /nandP[/negP[]// | /negbNE/eqP->]] := boolP (Q j); last first. + by rewrite mulrC divfK. +have: `|F i + F j| = `|F i| + `|F j|. + do [rewrite !(bigD1 j Qj) /=; set z := \sum_(k | _) `|_|] in norm_sumF. + apply/eqP; rewrite eqr_le ler_norm_add -(ler_add2r z) -addrA -norm_sumF addrA. + by rewrite (ler_trans (ler_norm_add _ _)) // ler_add2l ler_norm_sum. +by case/normC_add_eq=> k _ [/(canLR (mulKf nzFi)) <-]; rewrite -(mulrC (F i)). +Qed. + +Lemma normC_sum_eq1 (I : finType) (P : pred I) (F : I -> algC) : + `|\sum_(i | P i) F i| = (\sum_(i | P i) `|F i|) -> + (forall i, P i -> `|F i| = 1) -> + {t : algC | `|t| == 1 & forall i, P i -> F i = t}. +Proof. +case/normC_sum_eq=> t t1 defF normF. +by exists t => // i Pi; rewrite defF // normF // mul1r. +Qed. + +Lemma normC_sum_upper (I : finType) (P : pred I) (F G : I -> algC) : + (forall i, P i -> `|F i| <= G i) -> + \sum_(i | P i) F i = \sum_(i | P i) G i -> + forall i, P i -> F i = G i. +Proof. +set sumF := \sum_(i | _) _; set sumG := \sum_(i | _) _ => leFG eq_sumFG. +have posG i: P i -> 0 <= G i by move/leFG; apply: ler_trans; exact: normr_ge0. +have norm_sumG: `|sumG| = sumG by rewrite ger0_norm ?sumr_ge0. +have norm_sumF: `|sumF| = \sum_(i | P i) `|F i|. + apply/eqP; rewrite eqr_le ler_norm_sum eq_sumFG norm_sumG -subr_ge0 -sumrB. + by rewrite sumr_ge0 // => i Pi; rewrite subr_ge0 ?leFG. +have [t _ defF] := normC_sum_eq norm_sumF. +have [/(psumr_eq0P posG) G0 i Pi | nz_sumG] := eqVneq sumG 0. + by apply/eqP; rewrite G0 // -normr_eq0 eqr_le normr_ge0 -(G0 i Pi) leFG. +have t1: t = 1. + apply: (mulfI nz_sumG); rewrite mulr1 -{1}norm_sumG -eq_sumFG norm_sumF. + by rewrite mulr_suml -(eq_bigr _ defF). +have /psumr_eq0P eqFG i: P i -> 0 <= G i - F i. + by move=> Pi; rewrite subr_ge0 defF // t1 mulr1 leFG. +move=> i /eqFG/(canRL (subrK _))->; rewrite ?add0r //. +by rewrite sumrB -/sumF eq_sumFG subrr. +Qed. + +Lemma normC_sub_eq x y : + `|x - y| = `|x| - `|y| -> {t | `|t| == 1 & (x, y) = (`|x| * t, `|y| * t)}. +Proof. +rewrite -{-1}(subrK y x) => /(canLR (subrK _))/esym-Dx; rewrite Dx. +by have [t ? [Dxy Dy]] := normC_add_eq Dx; exists t; rewrite // mulrDl -Dxy -Dy. +Qed. + +(* Integer subset. *) + +(* Not relying on the undocumented interval library, for now. *) +Lemma floorC_itv x : x \is Creal -> (floorC x)%:~R <= x < (floorC x + 1)%:~R. +Proof. by rewrite /floorC => Rx; case: (floorC_subproof x) => //= m; apply. Qed. + +Lemma floorC_def x m : m%:~R <= x < (m + 1)%:~R -> floorC x = m. +Proof. +case/andP=> lemx ltxm1; apply/eqP; rewrite eqr_le -!ltz_addr1. +have /floorC_itv/andP[lefx ltxf1]: x \is Creal. + by rewrite -[x](subrK m%:~R) rpredD ?realz ?ler_sub_real. +by rewrite -!(ltr_int [numFieldType of algC]) 2?(@ler_lt_trans _ x). +Qed. + +Lemma intCK : cancel intr floorC. +Proof. +by move=> m; apply: floorC_def; rewrite ler_int ltr_int ltz_addr1 lerr. +Qed. + +Lemma floorCK : {in Cint, cancel floorC intr}. Proof. by move=> z /eqP. Qed. + +Lemma floorC0 : floorC 0 = 0. Proof. exact: (intCK 0). Qed. +Lemma floorC1 : floorC 1 = 1. Proof. exact: (intCK 1). Qed. +Hint Resolve floorC0 floorC1. + +Lemma floorCpK (p : {poly algC}) : + p \is a polyOver Cint -> map_poly intr (map_poly floorC p) = p. +Proof. +move/(all_nthP 0)=> Zp; apply/polyP=> i. +rewrite coef_map coef_map_id0 //= -[p]coefK coef_poly. +by case: ifP => [/Zp/floorCK // | _]; rewrite floorC0. +Qed. + +Lemma floorCpP (p : {poly algC}) : + p \is a polyOver Cint -> {q | p = map_poly intr q}. +Proof. by exists (map_poly floorC p); rewrite floorCpK. Qed. + +Lemma Cint_int m : m%:~R \in Cint. +Proof. by rewrite unfold_in intCK. Qed. + +Lemma CintP x : reflect (exists m, x = m%:~R) (x \in Cint). +Proof. +by apply: (iffP idP) => [/eqP<-|[m ->]]; [exists (floorC x) | apply: Cint_int]. +Qed. + +Lemma floorCD : {in Cint & Creal, {morph floorC : x y / x + y}}. +Proof. +move=> _ y /CintP[m ->] Ry; apply: floorC_def. +by rewrite -addrA 2!rmorphD /= intCK ler_add2l ltr_add2l floorC_itv. +Qed. + +Lemma floorCN : {in Cint, {morph floorC : x / - x}}. +Proof. by move=> _ /CintP[m ->]; rewrite -rmorphN !intCK. Qed. + +Lemma floorCM : {in Cint &, {morph floorC : x y / x * y}}. +Proof. by move=> _ _ /CintP[m1 ->] /CintP[m2 ->]; rewrite -rmorphM !intCK. Qed. + +Lemma floorCX n : {in Cint, {morph floorC : x / x ^+ n}}. +Proof. by move=> _ /CintP[m ->]; rewrite -rmorphX !intCK. Qed. + +Lemma rpred_Cint S (ringS : subringPred S) (kS : keyed_pred ringS) x : + x \in Cint -> x \in kS. +Proof. by case/CintP=> m ->; apply: rpred_int. Qed. + +Lemma Cint0 : 0 \in Cint. Proof. exact: (Cint_int 0). Qed. +Lemma Cint1 : 1 \in Cint. Proof. exact: (Cint_int 1). Qed. +Hint Resolve Cint0 Cint1. + +Fact Cint_key : pred_key Cint. Proof. by []. Qed. +Fact Cint_subring : subring_closed Cint. +Proof. +by split=> // _ _ /CintP[m ->] /CintP[p ->]; + rewrite -(rmorphB, rmorphM) Cint_int. +Qed. +Canonical Cint_keyed := KeyedPred Cint_key. +Canonical Cint_opprPred := OpprPred Cint_subring. +Canonical Cint_addrPred := AddrPred Cint_subring. +Canonical Cint_mulrPred := MulrPred Cint_subring. +Canonical Cint_zmodPred := ZmodPred Cint_subring. +Canonical Cint_semiringPred := SemiringPred Cint_subring. +Canonical Cint_smulrPred := SmulrPred Cint_subring. +Canonical Cint_subringPred := SubringPred Cint_subring. + +Lemma Creal_Cint : {subset Cint <= Creal}. +Proof. by move=> _ /CintP[m ->]; apply: realz. Qed. + +Lemma conj_Cint x : x \in Cint -> x^* = x. +Proof. by move/Creal_Cint/conj_Creal. Qed. + +Lemma Cint_normK x : x \in Cint -> `|x| ^+ 2 = x ^+ 2. +Proof. by move/Creal_Cint/real_normK. Qed. + +Lemma CintEsign x : x \in Cint -> x = (-1) ^+ (x < 0)%C * `|x|. +Proof. by move/Creal_Cint/realEsign. Qed. + +(* Natural integer subset. *) + +Lemma truncC_itv x : 0 <= x -> (truncC x)%:R <= x < (truncC x).+1%:R. +Proof. +move=> x_ge0; have /andP[lemx ltxm1] := floorC_itv (ger0_real x_ge0). +rewrite /truncC x_ge0 -addn1 !pmulrn PoszD gez0_abs ?lemx //. +by rewrite -ltz_addr1 -(ltr_int [numFieldType of algC]) (ler_lt_trans x_ge0). +Qed. + +Lemma truncC_def x n : n%:R <= x < n.+1%:R -> truncC x = n. +Proof. +move=> ivt_n_x; have /andP[lenx _] := ivt_n_x. +by rewrite /truncC (ler_trans (ler0n _ n)) // (@floorC_def _ n) // addrC -intS. +Qed. + +Lemma natCK n : truncC n%:R = n. +Proof. by apply: truncC_def; rewrite lerr ltr_nat /=. Qed. + +Lemma CnatP x : reflect (exists n, x = n%:R) (x \in Cnat). +Proof. +by apply: (iffP eqP) => [<- | [n ->]]; [exists (truncC x) | rewrite natCK]. +Qed. + +Lemma truncCK : {in Cnat, cancel truncC (GRing.natmul 1)}. +Proof. by move=> x /eqP. Qed. + +Lemma truncC_gt0 x : (0 < truncC x)%N = (1 <= x). +Proof. +apply/idP/idP=> [m_gt0 | x_ge1]. + have /truncC_itv/andP[lemx _]: 0 <= x. + by move: m_gt0; rewrite /truncC; case: ifP. + by apply: ler_trans lemx; rewrite ler1n. +have /truncC_itv/andP[_ ltxm1]:= ler_trans ler01 x_ge1. +by rewrite -ltnS -ltC_nat (ler_lt_trans x_ge1). +Qed. + +Lemma truncC0Pn x : reflect (truncC x = 0%N) (~~ (1 <= x)). +Proof. by rewrite -truncC_gt0 -eqn0Ngt; apply: eqP. Qed. + +Lemma truncC0 : truncC 0 = 0%N. Proof. exact: (natCK 0). Qed. +Lemma truncC1 : truncC 1 = 1%N. Proof. exact: (natCK 1). Qed. + +Lemma truncCD : + {in Cnat & Num.nneg, {morph truncC : x y / x + y >-> (x + y)%N}}. +Proof. +move=> _ y /CnatP[n ->] y_ge0; apply: truncC_def. +by rewrite -addnS !natrD !natCK ler_add2l ltr_add2l truncC_itv. +Qed. + +Lemma truncCM : {in Cnat &, {morph truncC : x y / x * y >-> (x * y)%N}}. +Proof. by move=> _ _ /CnatP[n1 ->] /CnatP[n2 ->]; rewrite -natrM !natCK. Qed. + +Lemma truncCX n : {in Cnat, {morph truncC : x / x ^+ n >-> (x ^ n)%N}}. +Proof. by move=> _ /CnatP[n1 ->]; rewrite -natrX !natCK. Qed. + +Lemma rpred_Cnat S (ringS : semiringPred S) (kS : keyed_pred ringS) x : + x \in Cnat -> x \in kS. +Proof. by case/CnatP=> n ->; apply: rpred_nat. Qed. + +Lemma Cnat_nat n : n%:R \in Cnat. Proof. by apply/CnatP; exists n. Qed. +Lemma Cnat0 : 0 \in Cnat. Proof. exact: (Cnat_nat 0). Qed. +Lemma Cnat1 : 1 \in Cnat. Proof. exact: (Cnat_nat 1). Qed. +Hint Resolve Cnat_nat Cnat0 Cnat1. + +Fact Cnat_key : pred_key Cnat. Proof. by []. Qed. +Fact Cnat_semiring : semiring_closed Cnat. +Proof. +by do 2![split] => //= _ _ /CnatP[n ->] /CnatP[m ->]; rewrite -(natrD, natrM). +Qed. +Canonical Cnat_keyed := KeyedPred Cnat_key. +Canonical Cnat_addrPred := AddrPred Cnat_semiring. +Canonical Cnat_mulrPred := MulrPred Cnat_semiring. +Canonical Cnat_semiringPred := SemiringPred Cnat_semiring. + +Lemma Cnat_ge0 x : x \in Cnat -> 0 <= x. +Proof. by case/CnatP=> n ->; apply: ler0n. Qed. + +Lemma Cnat_gt0 x : x \in Cnat -> (0 < x) = (x != 0). +Proof. by case/CnatP=> n ->; rewrite pnatr_eq0 ltr0n lt0n. Qed. + +Lemma conj_Cnat x : x \in Cnat -> x^* = x. +Proof. by case/CnatP=> n ->; apply: rmorph_nat. Qed. + +Lemma norm_Cnat x : x \in Cnat -> `|x| = x. +Proof. by move/Cnat_ge0/ger0_norm. Qed. + +Lemma Creal_Cnat : {subset Cnat <= Creal}. +Proof. by move=> z /conj_Cnat/CrealP. Qed. + +Lemma Cnat_sum_eq1 (I : finType) (P : pred I) (F : I -> algC) : + (forall i, P i -> F i \in Cnat) -> \sum_(i | P i) F i = 1 -> + {i : I | [/\ P i, F i = 1 & forall j, j != i -> P j -> F j = 0]}. +Proof. +move=> natF sumF1; pose nF i := truncC (F i). +have{natF} defF i: P i -> F i = (nF i)%:R by move/natF/eqP. +have{sumF1} /eqP sumF1: (\sum_(i | P i) nF i == 1)%N. + by rewrite -eqC_nat natr_sum -(eq_bigr _ defF) sumF1. +have [i Pi nZfi]: {i : I | P i & nF i != 0%N}. + by apply/sig2W/exists_inP; rewrite -negb_forall_in -sum_nat_eq0 sumF1. +have F'ge0 := (leq0n _, etrans (eq_sym _ _) (sum_nat_eq0 (predD1 P i) nF)). +rewrite -lt0n in nZfi; have [_] := (leqif_add (leqif_eq nZfi) (F'ge0 _)). +rewrite /= big_andbC -bigD1 // sumF1 => /esym/andP/=[/eqP Fi1 /forall_inP Fi'0]. +exists i; split=> // [|j neq_ji Pj]; first by rewrite defF // -Fi1. +by rewrite defF // (eqP (Fi'0 j _)) // neq_ji. +Qed. + +Lemma Cnat_mul_eq1 x y : + x \in Cnat -> y \in Cnat -> (x * y == 1) = (x == 1) && (y == 1). +Proof. by do 2!move/truncCK <-; rewrite -natrM !pnatr_eq1 muln_eq1. Qed. + +Lemma Cnat_prod_eq1 (I : finType) (P : pred I) (F : I -> algC) : + (forall i, P i -> F i \in Cnat) -> \prod_(i | P i) F i = 1 -> + forall i, P i -> F i = 1. +Proof. +move=> natF prodF1; apply/eqfun_inP; rewrite -big_andE. +move: prodF1; elim/(big_load (fun x => x \in Cnat)): _. +elim/big_rec2: _ => // i all1x x /natF N_Fi [Nx x1all1]. +by split=> [|/eqP]; rewrite ?rpredM ?Cnat_mul_eq1 // => /andP[-> /eqP]. +Qed. + +(* Relating Cint and Cnat. *) + +Lemma Cint_Cnat : {subset Cnat <= Cint}. +Proof. by move=> _ /CnatP[n ->]; rewrite pmulrn Cint_int. Qed. + +Lemma CintE x : (x \in Cint) = (x \in Cnat) || (- x \in Cnat). +Proof. +apply/idP/idP=> [/CintP[[n | n] ->] | ]; first by rewrite Cnat_nat. + by rewrite NegzE opprK Cnat_nat orbT. +by case/pred2P=> [<- | /(canLR (@opprK _)) <-]; rewrite ?rpredN rpred_nat. +Qed. + +Lemma Cnat_norm_Cint x : x \in Cint -> `|x| \in Cnat. +Proof. +case/CintP=> [m ->]; rewrite [m]intEsign rmorphM rmorph_sign. +by rewrite normrM normr_sign mul1r normr_nat rpred_nat. +Qed. + +Lemma CnatEint x : (x \in Cnat) = (x \in Cint) && (0 <= x). +Proof. +apply/idP/andP=> [Nx | [Zx x_ge0]]; first by rewrite Cint_Cnat ?Cnat_ge0. +by rewrite -(ger0_norm x_ge0) Cnat_norm_Cint. +Qed. + +Lemma CintEge0 x : 0 <= x -> (x \in Cint) = (x \in Cnat). +Proof. by rewrite CnatEint andbC => ->. Qed. + +Lemma Cnat_exp_even x n : ~~ odd n -> x \in Cint -> x ^+ n \in Cnat. +Proof. +rewrite -dvdn2 => /dvdnP[m ->] Zx; rewrite mulnC exprM -Cint_normK ?rpredX //. +exact: Cnat_norm_Cint. +Qed. + +Lemma norm_Cint_ge1 x : x \in Cint -> x != 0 -> 1 <= `|x|. +Proof. +rewrite -normr_eq0 => /Cnat_norm_Cint/CnatP[n ->]. +by rewrite pnatr_eq0 ler1n lt0n. +Qed. + +Lemma sqr_Cint_ge1 x : x \in Cint -> x != 0 -> 1 <= x ^+ 2. +Proof. +by move=> Zx nz_x; rewrite -Cint_normK // expr_ge1 ?normr_ge0 ?norm_Cint_ge1. +Qed. + +Lemma Cint_ler_sqr x : x \in Cint -> x <= x ^+ 2. +Proof. +move=> Zx; have [-> | nz_x] := eqVneq x 0; first by rewrite expr0n. +apply: ler_trans (_ : `|x| <= _); first by rewrite real_ler_norm ?Creal_Cint. +by rewrite -Cint_normK // ler_eexpr // norm_Cint_ge1. +Qed. + +(* Integer divisibility. *) + +Lemma dvdCP x y : reflect (exists2 z, z \in Cint & y = z * x) (x %| y)%C. +Proof. +rewrite unfold_in; have [-> | nz_x] := altP eqP. + by apply: (iffP eqP) => [-> | [z _ ->]]; first exists 0; rewrite ?mulr0. +apply: (iffP idP) => [Zyx | [z Zz ->]]; last by rewrite mulfK. +by exists (y / x); rewrite ?divfK. +Qed. + +Lemma dvdCP_nat x y : 0 <= x -> 0 <= y -> (x %| y)%C -> {n | y = n%:R * x}. +Proof. +move=> x_ge0 y_ge0 x_dv_y; apply: sig_eqW. +case/dvdCP: x_dv_y => z Zz -> in y_ge0 *; move: x_ge0 y_ge0 Zz. +rewrite ler_eqVlt => /predU1P[<- | ]; first by exists 22; rewrite !mulr0. +by move=> /pmulr_lge0-> /CintEge0-> /CnatP[n ->]; exists n. +Qed. + +Lemma dvdC0 x : (x %| 0)%C. +Proof. by apply/dvdCP; exists 0; rewrite ?mul0r. Qed. + +Lemma dvd0C x : (0 %| x)%C = (x == 0). +Proof. by rewrite unfold_in eqxx. Qed. + +Lemma dvdC_mull x y z : y \in Cint -> (x %| z)%C -> (x %| y * z)%C. +Proof. +move=> Zy /dvdCP[m Zm ->]; apply/dvdCP. +by exists (y * m); rewrite ?mulrA ?rpredM. +Qed. + +Lemma dvdC_mulr x y z : y \in Cint -> (x %| z)%C -> (x %| z * y)%C. +Proof. by rewrite mulrC; apply: dvdC_mull. Qed. + +Lemma dvdC_mul2r x y z : y != 0 -> (x * y %| z * y)%C = (x %| z)%C. +Proof. +move=> nz_y; rewrite !unfold_in !(mulIr_eq0 _ (mulIf nz_y)). +by rewrite mulrAC invfM mulrA divfK. +Qed. + +Lemma dvdC_mul2l x y z : y != 0 -> (y * x %| y * z)%C = (x %| z)%C. +Proof. by rewrite !(mulrC y); apply: dvdC_mul2r. Qed. + +Lemma dvdC_trans x y z : (x %| y)%C -> (y %| z)%C -> (x %| z)%C. +Proof. by move=> x_dv_y /dvdCP[m Zm ->]; apply: dvdC_mull. Qed. + +Lemma dvdC_refl x : (x %| x)%C. +Proof. by apply/dvdCP; exists 1; rewrite ?mul1r. Qed. +Hint Resolve dvdC_refl. + +Fact dvdC_key x : pred_key (dvdC x). Proof. by []. Qed. +Lemma dvdC_zmod x : zmod_closed (dvdC x). +Proof. +split=> [| _ _ /dvdCP[y Zy ->] /dvdCP[z Zz ->]]; first exact: dvdC0. +by rewrite -mulrBl dvdC_mull ?rpredB. +Qed. +Canonical dvdC_keyed x := KeyedPred (dvdC_key x). +Canonical dvdC_opprPred x := OpprPred (dvdC_zmod x). +Canonical dvdC_addrPred x := AddrPred (dvdC_zmod x). +Canonical dvdC_zmodPred x := ZmodPred (dvdC_zmod x). + +Lemma dvdC_nat (p n : nat) : (p %| n)%C = (p %| n)%N. +Proof. +rewrite unfold_in CintEge0 ?divr_ge0 ?invr_ge0 ?ler0n // !pnatr_eq0. +have [-> | nz_p] := altP eqP; first by rewrite dvd0n. +apply/CnatP/dvdnP=> [[q def_q] | [q ->]]; exists q. + by apply/eqP; rewrite -eqC_nat natrM -def_q divfK ?pnatr_eq0. +by rewrite [num in num / _]natrM mulfK ?pnatr_eq0. +Qed. + +Lemma dvdC_int (p : nat) x : x \in Cint -> (p %| x)%C = (p %| `|floorC x|)%N. +Proof. +move=> Zx; rewrite -{1}(floorCK Zx) {1}[floorC x]intEsign. +by rewrite rmorphMsign rpredMsign dvdC_nat. +Qed. + +(* Elementary modular arithmetic. *) + +Lemma eqCmod_refl e x : (x == x %[mod e])%C. +Proof. by rewrite /eqCmod subrr rpred0. Qed. + +Lemma eqCmodm0 e : (e == 0 %[mod e])%C. Proof. by rewrite /eqCmod subr0. Qed. +Hint Resolve eqCmod_refl eqCmodm0. + +Lemma eqCmod0 e x : (x == 0 %[mod e])%C = (e %| x)%C. +Proof. by rewrite /eqCmod subr0. Qed. + +Lemma eqCmod_sym e x y : ((x == y %[mod e]) = (y == x %[mod e]))%C. +Proof. by rewrite /eqCmod -opprB rpredN. Qed. + +Lemma eqCmod_trans e y x z : + (x == y %[mod e] -> y == z %[mod e] -> x == z %[mod e])%C. +Proof. by move=> Exy Eyz; rewrite /eqCmod -[x](subrK y) -addrA rpredD. Qed. + +Lemma eqCmod_transl e x y z : + (x == y %[mod e])%C -> (x == z %[mod e])%C = (y == z %[mod e])%C. +Proof. by move/(sym_left_transitive (eqCmod_sym e) (@eqCmod_trans e)). Qed. + +Lemma eqCmod_transr e x y z : + (x == y %[mod e])%C -> (z == x %[mod e])%C = (z == y %[mod e])%C. +Proof. by move/(sym_right_transitive (eqCmod_sym e) (@eqCmod_trans e)). Qed. + +Lemma eqCmodN e x y : (- x == y %[mod e])%C = (x == - y %[mod e])%C. +Proof. by rewrite eqCmod_sym /eqCmod !opprK addrC. Qed. + +Lemma eqCmodDr e x y z : (y + x == z + x %[mod e])%C = (y == z %[mod e])%C. +Proof. by rewrite /eqCmod addrAC opprD !addrA subrK. Qed. + +Lemma eqCmodDl e x y z : (x + y == x + z %[mod e])%C = (y == z %[mod e])%C. +Proof. by rewrite !(addrC x) eqCmodDr. Qed. + +Lemma eqCmodD e x1 x2 y1 y2 : + (x1 == x2 %[mod e] -> y1 == y2 %[mod e] -> x1 + y1 == x2 + y2 %[mod e])%C. +Proof. rewrite -(eqCmodDl e x2 y1) -(eqCmodDr e y1); exact: eqCmod_trans. Qed. + +Lemma eqCmod_nat (e m n : nat) : (m == n %[mod e])%C = (m == n %[mod e]). +Proof. +without loss lenm: m n / (n <= m)%N. + by move=> IH; case/orP: (leq_total m n) => /IH //; rewrite eqCmod_sym eq_sym. +by rewrite /eqCmod -natrB // dvdC_nat eqn_mod_dvd. +Qed. + +Lemma eqCmod0_nat (e m : nat) : (m == 0 %[mod e])%C = (e %| m)%N. +Proof. by rewrite eqCmod0 dvdC_nat. Qed. + +Lemma eqCmodMr e : + {in Cint, forall z x y, x == y %[mod e] -> x * z == y * z %[mod e]}%C. +Proof. by move=> z Zz x y; rewrite /eqCmod -mulrBl => /dvdC_mulr->. Qed. + +Lemma eqCmodMl e : + {in Cint, forall z x y, x == y %[mod e] -> z * x == z * y %[mod e]}%C. +Proof. by move=> z Zz x y Exy; rewrite !(mulrC z) eqCmodMr. Qed. + +Lemma eqCmodMl0 e : {in Cint, forall x, x * e == 0 %[mod e]}%C. +Proof. by move=> x Zx; rewrite -(mulr0 x) eqCmodMl. Qed. + +Lemma eqCmodMr0 e : {in Cint, forall x, e * x == 0 %[mod e]}%C. +Proof. by move=> x Zx; rewrite /= mulrC eqCmodMl0. Qed. + +Lemma eqCmod_addl_mul e : {in Cint, forall x y, x * e + y == y %[mod e]}%C. +Proof. by move=> x Zx y; rewrite -{2}[y]add0r eqCmodDr eqCmodMl0. Qed. + +Lemma eqCmodM e : {in Cint & Cint, forall x1 y2 x2 y1, + x1 == x2 %[mod e] -> y1 == y2 %[mod e] -> x1 * y1 == x2 * y2 %[mod e]}%C. +Proof. +move=> x1 y2 Zx1 Zy2 x2 y1 eq_x /(eqCmodMl Zx1)/eqCmod_trans-> //. +exact: eqCmodMr. +Qed. + +(* Rational number subset. *) + +Lemma ratCK : cancel QtoC CtoQ. +Proof. by rewrite /getCrat; case: getCrat_subproof. Qed. + +Lemma getCratK : {in Crat, cancel CtoQ QtoC}. +Proof. by move=> x /eqP. Qed. + +Lemma Crat_rat (a : rat) : QtoC a \in Crat. +Proof. by rewrite unfold_in ratCK. Qed. + +Lemma CratP x : reflect (exists a, x = QtoC a) (x \in Crat). +Proof. +by apply: (iffP eqP) => [<- | [a ->]]; [exists (CtoQ x) | rewrite ratCK]. +Qed. + +Lemma Crat0 : 0 \in Crat. Proof. by apply/CratP; exists 0; rewrite rmorph0. Qed. +Lemma Crat1 : 1 \in Crat. Proof. by apply/CratP; exists 1; rewrite rmorph1. Qed. +Hint Resolve Crat0 Crat1. + +Fact Crat_key : pred_key Crat. Proof. by []. Qed. +Fact Crat_divring_closed : divring_closed Crat. +Proof. +split=> // _ _ /CratP[x ->] /CratP[y ->]. + by rewrite -rmorphB Crat_rat. +by rewrite -fmorph_div Crat_rat. +Qed. +Canonical Crat_keyed := KeyedPred Crat_key. +Canonical Crat_opprPred := OpprPred Crat_divring_closed. +Canonical Crat_addrPred := AddrPred Crat_divring_closed. +Canonical Crat_mulrPred := MulrPred Crat_divring_closed. +Canonical Crat_zmodPred := ZmodPred Crat_divring_closed. +Canonical Crat_semiringPred := SemiringPred Crat_divring_closed. +Canonical Crat_smulrPred := SmulrPred Crat_divring_closed. +Canonical Crat_divrPred := DivrPred Crat_divring_closed. +Canonical Crat_subringPred := SubringPred Crat_divring_closed. +Canonical Crat_sdivrPred := SdivrPred Crat_divring_closed. +Canonical Crat_divringPred := DivringPred Crat_divring_closed. + +Lemma rpred_Crat S (ringS : divringPred S) (kS : keyed_pred ringS) : + {subset Crat <= kS}. +Proof. by move=> _ /CratP[a ->]; apply: rpred_rat. Qed. + +Lemma conj_Crat z : z \in Crat -> z^* = z. +Proof. by move/getCratK <-; rewrite fmorph_div !rmorph_int. Qed. + +Lemma Creal_Crat : {subset Crat <= Creal}. +Proof. by move=> x /conj_Crat/CrealP. Qed. + +Lemma Cint_rat a : (QtoC a \in Cint) = (a \in Qint). +Proof. +apply/idP/idP=> [Za | /numqK <-]; last by rewrite rmorph_int Cint_int. +apply/QintP; exists (floorC (QtoC a)); apply: (can_inj ratCK). +by rewrite rmorph_int floorCK. +Qed. + +Lemma minCpolyP x : + {p | minCpoly x = pQtoC p /\ p \is monic + & forall q, root (pQtoC q) x = (p %| q)%R}. +Proof. by rewrite /minCpoly; case: (minCpoly_subproof x) => p; exists p. Qed. + +Lemma minCpoly_monic x : minCpoly x \is monic. +Proof. by have [p [-> mon_p] _] := minCpolyP x; rewrite map_monic. Qed. + +Lemma minCpoly_eq0 x : (minCpoly x == 0) = false. +Proof. exact/negbTE/monic_neq0/minCpoly_monic. Qed. + +Lemma root_minCpoly x : root (minCpoly x) x. +Proof. by have [p [-> _] ->] := minCpolyP x. Qed. + +Lemma size_minCpoly x : (1 < size (minCpoly x))%N. +Proof. by apply: root_size_gt1 (root_minCpoly x); rewrite ?minCpoly_eq0. Qed. + +(* Basic properties of automorphisms. *) +Section AutC. + +Implicit Type nu : {rmorphism algC -> algC}. + +Lemma aut_Cnat nu : {in Cnat, nu =1 id}. +Proof. by move=> _ /CnatP[n ->]; apply: rmorph_nat. Qed. + +Lemma aut_Cint nu : {in Cint, nu =1 id}. +Proof. by move=> _ /CintP[m ->]; apply: rmorph_int. Qed. + +Lemma aut_Crat nu : {in Crat, nu =1 id}. +Proof. by move=> _ /CratP[a ->]; apply: fmorph_rat. Qed. + +Lemma Cnat_aut nu x : (nu x \in Cnat) = (x \in Cnat). +Proof. +by do [apply/idP/idP=> Nx; have:= aut_Cnat nu Nx] => [/fmorph_inj <- | ->]. +Qed. + +Lemma Cint_aut nu x : (nu x \in Cint) = (x \in Cint). +Proof. by rewrite !CintE -rmorphN !Cnat_aut. Qed. + +Lemma Crat_aut nu x : (nu x \in Crat) = (x \in Crat). +Proof. +apply/idP/idP=> /CratP[a] => [|->]; last by rewrite fmorph_rat Crat_rat. +by rewrite -(fmorph_rat nu) => /fmorph_inj->; apply: Crat_rat. +Qed. + +Lemma algC_invaut_subproof nu x : {y | nu y = x}. +Proof. +have [r Dp] := closed_field_poly_normal (minCpoly x). +suffices /mapP/sig2_eqW[y _ ->]: x \in map nu r by exists y. +rewrite -root_prod_XsubC; congr (root _ x): (root_minCpoly x). +have [q [Dq _] _] := minCpolyP x; rewrite Dq -(eq_map_poly (fmorph_rat nu)). +rewrite (map_poly_comp nu) -{q}Dq Dp (monicP (minCpoly_monic x)) scale1r. +rewrite rmorph_prod big_map; apply: eq_bigr => z _. +by rewrite rmorphB /= map_polyX map_polyC. +Qed. +Definition algC_invaut nu x := sval (algC_invaut_subproof nu x). + +Lemma algC_invautK nu : cancel (algC_invaut nu) nu. +Proof. by move=> x; rewrite /algC_invaut; case: algC_invaut_subproof. Qed. + +Lemma algC_autK nu : cancel nu (algC_invaut nu). +Proof. exact: inj_can_sym (algC_invautK nu) (fmorph_inj nu). Qed. + +Fact algC_invaut_is_rmorphism nu : rmorphism (algC_invaut nu). +Proof. exact: can2_rmorphism (algC_autK nu) (algC_invautK nu). Qed. +Canonical algC_invaut_additive nu := Additive (algC_invaut_is_rmorphism nu). +Canonical algC_invaut_rmorphism nu := RMorphism (algC_invaut_is_rmorphism nu). + +Lemma minCpoly_aut nu x : minCpoly (nu x) = minCpoly x. +Proof. +wlog suffices dvd_nu: nu x / (minCpoly x %| minCpoly (nu x))%R. + apply/eqP; rewrite -eqp_monic ?minCpoly_monic //; apply/andP; split=> //. + by rewrite -{2}(algC_autK nu x) dvd_nu. +have [[q [Dq _] min_q] [q1 [Dq1 _] _]] := (minCpolyP x, minCpolyP (nu x)). +rewrite Dq Dq1 dvdp_map -min_q -(fmorph_root nu) -map_poly_comp. +by rewrite (eq_map_poly (fmorph_rat nu)) -Dq1 root_minCpoly. +Qed. + +End AutC. + +Section AutLmodC. + +Variables (U V : lmodType algC) (f : {additive U -> V}). + +Lemma raddfZ_Cnat a u : a \in Cnat -> f (a *: u) = a *: f u. +Proof. by case/CnatP=> n ->; exact: raddfZnat. Qed. + +Lemma raddfZ_Cint a u : a \in Cint -> f (a *: u) = a *: f u. +Proof. by case/CintP=> m ->; rewrite !scaler_int raddfMz. Qed. + +End AutLmodC. + +Section PredCmod. + +Variable V : lmodType algC. + +Lemma rpredZ_Cnat S (addS : @addrPred V S) (kS : keyed_pred addS) : + {in Cnat & kS, forall z u, z *: u \in kS}. +Proof. by move=> _ u /CnatP[n ->]; apply: rpredZnat. Qed. + +Lemma rpredZ_Cint S (subS : @zmodPred V S) (kS : keyed_pred subS) : + {in Cint & kS, forall z u, z *: u \in kS}. +Proof. by move=> _ u /CintP[m ->]; apply: rpredZint. Qed. + +End PredCmod. + +End AlgebraicsTheory. +Hint Resolve Creal0 Creal1 Cnat_nat Cnat0 Cnat1 Cint0 Cint1 floorC0 Crat0 Crat1. +Hint Resolve dvdC0 dvdC_refl eqCmod_refl eqCmodm0. diff --git a/mathcomp/field/algebraics_fundamentals.v b/mathcomp/field/algebraics_fundamentals.v new file mode 100644 index 0000000..9dc672d --- /dev/null +++ b/mathcomp/field/algebraics_fundamentals.v @@ -0,0 +1,867 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq choice div fintype. +Require Import path tuple bigop finset prime ssralg poly polydiv mxpoly. +Require Import countalg ssrnum ssrint rat intdiv. +Require Import fingroup finalg zmodp cyclic pgroup sylow. +Require Import vector falgebra fieldext separable galois. + +(******************************************************************************) +(* The main result in this file is the existence theorem that underpins the *) +(* construction of the algebraic numbers in file algC.v. This theorem simply *) +(* asserts the existence of an algebraically closed field with an *) +(* automorphism of order 2, and dubbed the Fundamental_Theorem_of_Algebraics *) +(* because it is essentially the Fundamental Theorem of Algebra for algebraic *) +(* numbers (the more familiar version for complex numbers can be derived by *) +(* continuity). *) +(* Although our proof does indeed construct exactly the algebraics, we *) +(* choose not to expose this in the statement of our Theorem. In algC.v we *) +(* construct the norm and partial order of the "complex field" introduced by *) +(* the Theorem; as these imply is has characteristic 0, we then get the *) +(* algebraics as a subfield. To avoid some duplication a few basic properties *) +(* of the algebraics, such as the existence of minimal polynomials, that are *) +(* required by the proof of the Theorem, are also proved here. *) +(* The main theorem of countalg.v supplies us directly with an algebraic *) +(* closure of the rationals (as the rationals are a countable field), so all *) +(* we really need to construct is a conjugation automorphism that exchanges *) +(* the two roots (i and -i) of X^2 + 1, and fixes a (real) subfield of *) +(* index 2. This does not require actually constructing this field: the *) +(* kHomExtend construction from galois.v supplies us with an automorphism *) +(* conj_n of the number field Q[z_n] = Q[x_n, i] for any x_n such that Q[x_n] *) +(* does not contain i (e.g., such that Q[x_n] is real). As conj_n will extend *) +(* conj_m when Q[x_n] contains x_m, it therefore suffices to construct a *) +(* sequence x_n such that *) +(* (1) For each n, Q[x_n] is a REAL field containing Q[x_m] for all m <= n. *) +(* (2) Each z in C belongs to Q[z_n] = Q[x_n, i] for large enough n. *) +(* This, of course, amounts to proving the Fundamental Theorem of Algebra. *) +(* Indeed, we use a constructive variant of Artin's algebraic proof of that *) +(* Theorem to replace (2) by *) +(* (3) Each monic polynomial over Q[x_m] whose constant term is -c^2 for some *) +(* c in Q[x_m] has a root in Q[x_n] for large enough n. *) +(* We then ensure (3) by setting Q[x_n+1] = Q[x_n, y] where y is the root of *) +(* of such a polynomial p found by dichotomy in some interval [0, b] with b *) +(* suitably large (such that p[b] >= 0), and p is obtained by decoding n into *) +(* a triple (m, p, c) that satisfies the conditions of (3) (taking x_n+1=x_n *) +(* if this is not the case), thereby ensuring that all such triples are *) +(* ultimately considered. *) +(* In more detail, the 600-line proof consists in six (uneven) parts: *) +(* (A) - Construction of number fields (~ 100 lines): in order to make use of *) +(* the theory developped in falgebra, fieldext, separable and galois we *) +(* construct a separate fielExtType Q z for the number field Q[z], with *) +(* z in C, the closure of rat supplied by countable_algebraic_closure. *) +(* The morphism (ofQ z) maps Q z to C, and the Primitive Element Theorem *) +(* lets us define a predicate sQ z characterizing the image of (ofQ z), *) +(* as well as a partial inverse (inQ z) to (ofQ z). *) +(* (B) - Construction of the real extension Q[x, y] (~ 230 lines): here y has *) +(* to be a root of a polynomial p over Q[x] satisfying the conditions of *) +(* (3), and Q[x] should be real and archimedean, which we represent by *) +(* a morphism from Q x to some archimedean field R, as the ssrnum and *) +(* fieldext structures are not compatible. The construction starts by *) +(* weakening the condition p[0] = -c^2 to p[0] <= 0 (in R), then reducing *) +(* to the case where p is the minimal polynomial over Q[x] of some y (in *) +(* some Q[w] that contains x and all roots of p). Then we only need to *) +(* construct a realFieldType structure for Q[t] = Q[x,y] (we don't even *) +(* need to show it is consistent with that of R). This amounts to fixing *) +(* the sign of all z != 0 in Q[t], consistently with arithmetic in Q[t]. *) +(* Now any such z is equal to q[y] for some q in Q[x][X] coprime with p. *) +(* Then up + vq = 1 for Bezout coefficients u and v. As p is monic, there *) +(* is some b0 >= 0 in R such that p changes sign in ab0 = [0; b0]. As R *) +(* is archimedean, some iteration of the binary search for a root of p in *) +(* ab0 will yield an interval ab_n such that |up[d]| < 1/2 for d in ab_n. *) +(* Then |q[d]| > 1/2M > 0 for any upper bound M on |v[X]| in ab0, so q *) +(* cannot change sign in ab_n (as then root-finding in ab_n would yield a *) +(* d with |Mq[d]| < 1/2), so we can fix the sign of z to that of q in *) +(* ab_n. *) +(* (C) - Construction of the x_n and z_n (~50 lines): x_ n is obtained by *) +(* iterating (B), starting with x_0 = 0, and then (A) and the PET yield *) +(* z_ n. We establish (1) and (3), and that the minimal polynomial of the *) +(* preimage i_ n of i over the preimage R_ n of Q[x_n] is X^2 + 1. *) +(* (D) - Establish (2), i.e., prove the FTA (~180 lines). We must depart from *) +(* Artin's proof because deciding membership in the union of the Q[x_n] *) +(* requires the FTA, i.e., we cannot (yet) construct a maximal real *) +(* subfield of C. We work around this issue by first reducing to the case *) +(* where Q[z] is Galois over Q and contains i, then using induction over *) +(* the degree of z over Q[z_ n] (i.e., the degree of a monic polynomial *) +(* over Q[z_n] that has z as a root). We can assume that z is not in *) +(* Q[z_n]; then it suffices to find some y in Q[z_n, z] \ Q[z_n] that is *) +(* also in Q[z_m] for some m > n, as then we can apply induction with the *) +(* minimal polynomial of z over Q[z_n, y]. In any Galois extension Q[t] *) +(* of Q that contains both z and z_n, Q[x_n, z] = Q[z_n, z] is Galois *) +(* over both Q[x_n] and Q[z_n]. If Gal(Q[x_n,z] / Q[x_n]) isn't a 2-group *) +(* take one of its Sylow 2-groups P; the minimal polynomial p of any *) +(* generator of the fixed field F of P over Q[x_n] has odd degree, hence *) +(* by (3) - p[X]p[-X] and thus p has a root y in some Q[x_m], hence in *) +(* Q[z_m]. As F is normal, y is in F, with minimal polynomial p, and y *) +(* is not in Q[z_n] = Q[x_n, i] since p has odd degree. Otherwise, *) +(* Gal(Q[z_n,z] / Q[z_n]) is a proper 2-group, and has a maximal subgroup *) +(* P of index 2. The fixed field F of P has a generator w over Q[z_n] *) +(* with w^2 in Q[z_n] \ Q[x_n], i.e. w^2 = u + 2iv with v != 0. From (3) *) +(* X^4 - uX^2 - v^2 has a root x in some Q[x_m]; then x != 0 as v != 0, *) +(* hence w^2 = y^2 for y = x + iv/x in Q[z_m], and y generates F. *) +(* (E) - Construct conj and conclude (~40 lines): conj z is defined as *) +(* conj_ n z with the n provided by (2); since each conj_ m is a morphism *) +(* of order 2 and conj z = conj_ m z for any m >= n, it follows that conj *) +(* is also a morphism of order 2. *) +(* Note that (C), (D) and (E) only depend on Q[x_n] not containing i; the *) +(* order structure is not used (hence we need not prove that the ordering of *) +(* Q[x_m] is consistent with that of Q[x_n] for m >= n). *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory Num.Theory. +Local Open Scope ring_scope. + +Local Notation "p ^ f" := (map_poly f p) : ring_scope. +Local Notation "p ^@" := (p ^ in_alg _) (at level 2, format "p ^@"): ring_scope. +Local Notation "<< E ; u >>" := <>%VS. +Local Notation Qmorphism C := {rmorphism rat -> C}. + +Lemma rat_algebraic_archimedean (C : numFieldType) (QtoC : Qmorphism C) : + integralRange QtoC -> Num.archimedean_axiom C. +Proof. +move=> algC x. +without loss x_ge0: x / 0 <= x by rewrite -normr_id; apply; apply: normr_ge0. +have [-> | nz_x] := eqVneq x 0; first by exists 1%N; rewrite normr0. +have [p mon_p px0] := algC x; exists (\sum_(j < size p) `|numq p`_j|)%N. +rewrite ger0_norm // real_ltrNge ?rpred_nat ?ger0_real //. +apply: contraL px0 => lb_x; rewrite rootE gtr_eqF // horner_coef size_map_poly. +have x_gt0 k: 0 < x ^+ k by rewrite exprn_gt0 // ltr_def nz_x. +move: lb_x; rewrite polySpred ?monic_neq0 // !big_ord_recr coef_map /=. +rewrite -lead_coefE (monicP mon_p) natrD rmorph1 mul1r => lb_x. +case: _.-1 (lb_x) => [|n]; first by rewrite !big_ord0 !add0r ltr01. +rewrite -ltr_subl_addl add0r -(ler_pmul2r (x_gt0 n)) -exprS. +apply: ltr_le_trans; rewrite mulrDl mul1r ltr_spaddr // -sumrN. +rewrite natr_sum mulr_suml ler_sum // => j _. +rewrite coef_map /= fmorph_eq_rat (ler_trans (real_ler_norm _)) //. + by rewrite rpredN rpredM ?rpred_rat ?rpredX // ger0_real. +rewrite normrN normrM ler_pmul //=. + rewrite normf_div -!intr_norm -!abszE ler_pimulr ?ler0n //. + by rewrite invf_le1 ?ler1n ?ltr0n ?absz_gt0 ?denq_eq0. +rewrite normrX ger0_norm ?(ltrW x_gt0) // ler_weexpn2l ?leq_ord //. +by rewrite (ler_trans _ lb_x) // -natrD addn1 ler1n. +Qed. + +Definition decidable_embedding sT T (f : sT -> T) := + forall y, decidable (exists x, y = f x). + +Lemma rat_algebraic_decidable (C : fieldType) (QtoC : Qmorphism C) : + integralRange QtoC -> decidable_embedding QtoC. +Proof. +have QtoCinj: injective QtoC by apply: fmorph_inj. +pose ZtoQ : int -> rat := intr; pose ZtoC : int -> C := intr. +have ZtoQinj: injective ZtoQ by apply: intr_inj. +have defZtoC: ZtoC =1 QtoC \o ZtoQ by move=> m; rewrite /= rmorph_int. +move=> algC x; have /sig2_eqW[q mon_q qx0] := algC x; pose d := (size q).-1. +have [n ub_n]: {n | forall y, root q y -> `|y| < n}. + have [n1 ub_n1] := monic_Cauchy_bound mon_q. + have /monic_Cauchy_bound[n2 ub_n2]: (-1) ^+ d *: (q \Po - 'X) \is monic. + rewrite monicE lead_coefZ lead_coef_comp ?size_opp ?size_polyX // -/d. + by rewrite lead_coef_opp lead_coefX (monicP mon_q) (mulrC 1) signrMK. + exists (Num.max n1 n2) => y; rewrite ltrNge ler_normr !ler_maxl rootE. + apply: contraL => /orP[]/andP[] => [/ub_n1/gtr_eqF->// | _ /ub_n2/gtr_eqF]. + by rewrite hornerZ horner_comp !hornerE opprK mulf_eq0 signr_eq0 => /= ->. +have [p [a nz_a Dq]] := rat_poly_scale q; pose N := Num.bound `|n * a%:~R|. +pose xa : seq rat := [seq (m%:R - N%:R) / a%:~R | m <- iota 0 N.*2]. +have [/sig2_eqW[y _ ->] | xa'x] := @mapP _ _ QtoC xa x; first by left; exists y. +right=> [[y Dx]]; case: xa'x; exists y => //. +have{x Dx qx0} qy0: root q y by rewrite Dx fmorph_root in qx0. +have /dvdzP[b Da]: (denq y %| a)%Z. + have /Gauss_dvdzl <-: coprimez (denq y) (numq y ^+ d). + by rewrite coprimez_sym coprimez_expl //; apply: coprime_num_den. + pose p1 : {poly int} := a *: 'X^d - p. + have Dp1: p1 ^ intr = a%:~R *: ('X^d - q). + by rewrite rmorphB linearZ /= map_polyXn scalerBr Dq scalerKV ?intr_eq0. + apply/dvdzP; exists (\sum_(i < d) p1`_i * numq y ^+ i * denq y ^+ (d - i.+1)). + apply: ZtoQinj; rewrite /ZtoQ rmorphM mulr_suml rmorph_sum /=. + transitivity ((p1 ^ intr).[y] * (denq y ^+ d)%:~R). + rewrite Dp1 !hornerE hornerXn (rootP qy0) subr0. + by rewrite !rmorphX /= numqE exprMn mulrA. + have sz_p1: (size (p1 ^ ZtoQ)%R <= d)%N. + rewrite Dp1 size_scale ?intr_eq0 //; apply/leq_sizeP=> i. + rewrite leq_eqVlt eq_sym -polySpred ?monic_neq0 // coefB coefXn. + case: eqP => [-> _ | _ /(nth_default 0)->//]. + by rewrite -lead_coefE (monicP mon_q). + rewrite (horner_coef_wide _ sz_p1) mulr_suml; apply: eq_bigr => i _. + rewrite -!mulrA -exprSr coef_map !rmorphM !rmorphX /= numqE exprMn -mulrA. + by rewrite -exprD -addSnnS subnKC. +pose m := `|(numq y * b + N)%R|%N. +have Dm: m%:R = `|y * a%:~R + N%:R|. + by rewrite pmulrn abszE intr_norm Da rmorphD !rmorphM /= numqE mulrAC mulrA. +have ltr_Qnat n1 n2 : (n1%:R < n2%:R :> rat = _) := ltr_nat _ n1 n2. +have ub_y: `|y * a%:~R| < N%:R. + apply: ler_lt_trans (archi_boundP (normr_ge0 _)); rewrite !normrM. + by rewrite ler_pmul ?normr_ge0 // (ler_trans _ (ler_norm n)) ?ltrW ?ub_n. +apply/mapP; exists m. + rewrite mem_iota /= add0n -addnn -ltr_Qnat Dm natrD. + by rewrite (ler_lt_trans (ler_norm_add _ _)) // normr_nat ltr_add2r. +rewrite Dm ger0_norm ?addrK ?mulfK ?intr_eq0 // -ler_subl_addl sub0r. +by rewrite (ler_trans (ler_norm _)) ?normrN ?ltrW. +Qed. + +Lemma minPoly_decidable_closure + (F : fieldType) (L : closedFieldType) (FtoL : {rmorphism F -> L}) x : + decidable_embedding FtoL -> integralOver FtoL x -> + {p | [/\ p \is monic, root (p ^ FtoL) x & irreducible_poly p]}. +Proof. +move=> isF /sig2W[p /monicP mon_p px0]. +have [r Dp] := closed_field_poly_normal (p ^ FtoL); pose n := size r. +rewrite lead_coef_map {}mon_p rmorph1 scale1r in Dp. +pose Fpx q := (q \is a polyOver isF) && root q x. +have FpxF q: Fpx (q ^ FtoL) = root (q ^ FtoL) x. + by rewrite /Fpx polyOver_poly // => j _; apply/sumboolP; exists q`_j. +pose p_ (I : {set 'I_n}) := \prod_(i <- enum I) ('X - (r`_i)%:P). +have{px0 Dp} /ex_minset[I /minsetP[/andP[FpI pIx0] minI]]: exists I, Fpx (p_ I). + exists setT; suffices ->: p_ setT = p ^ FtoL by rewrite FpxF. + by rewrite Dp (big_nth 0) big_mkord /p_ (eq_enum (in_set _)) big_filter. +have{p} [p DpI]: {p | p_ I = p ^ FtoL}. + exists (p_ I ^ (fun y => if isF y is left Fy then sval (sig_eqW Fy) else 0)). + rewrite -map_poly_comp map_poly_id // => y /(allP FpI) /=. + by rewrite unfold_in; case: (isF y) => // Fy _; case: (sig_eqW _). +have mon_pI: p_ I \is monic by apply: monic_prod_XsubC. +have mon_p: p \is monic by rewrite -(map_monic FtoL) -DpI. +exists p; rewrite -DpI; split=> //; split=> [|q nCq q_dv_p]. + by rewrite -(size_map_poly FtoL) -DpI (root_size_gt1 _ pIx0) ?monic_neq0. +rewrite -dvdp_size_eqp //; apply/eqP. +without loss mon_q: q nCq q_dv_p / q \is monic. + move=> IHq; pose a := lead_coef q; pose q1 := a^-1 *: q. + have nz_a: a != 0 by rewrite lead_coef_eq0 (dvdpN0 q_dv_p) ?monic_neq0. + have /IHq IHq1: q1 \is monic by rewrite monicE lead_coefZ mulVf. + by rewrite -IHq1 ?size_scale ?dvdp_scalel ?invr_eq0. +without loss{nCq} qx0: q mon_q q_dv_p / root (q ^ FtoL) x. + have /dvdpP[q1 Dp] := q_dv_p; rewrite DpI Dp rmorphM rootM -implyNb in pIx0. + have mon_q1: q1 \is monic by rewrite Dp monicMr in mon_p. + move=> IH; apply: (IH) (implyP pIx0 _) => //; apply: contra nCq => /IH IHq1. + rewrite -(subnn (size q1)) {1}IHq1 ?Dp ?dvdp_mulr // polySpred ?monic_neq0 //. + by rewrite eqSS size_monicM ?monic_neq0 // -!subn1 subnAC addKn. +have /dvdp_prod_XsubC[m Dq]: q ^ FtoL %| p_ I by rewrite DpI dvdp_map. +pose B := [set j in mask m (enum I)]; have{Dq} Dq: q ^ FtoL = p_ B. + apply/eqP; rewrite -eqp_monic ?monic_map ?monic_prod_XsubC //. + congr (_ %= _): Dq; apply: eq_big_perm => //. + by rewrite uniq_perm_eq ?mask_uniq ?enum_uniq // => j; rewrite mem_enum inE. +rewrite -!(size_map_poly FtoL) Dq -DpI (minI B) // -?Dq ?FpxF //. +by apply/subsetP=> j; rewrite inE => /mem_mask; rewrite mem_enum. +Qed. + +Lemma alg_integral (F : fieldType) (L : fieldExtType F) : + integralRange (in_alg L). +Proof. +move=> x; have [/polyOver1P[p Dp]] := (minPolyOver 1 x, monic_minPoly 1 x). +by rewrite Dp map_monic; exists p; rewrite // -Dp root_minPoly. +Qed. +Prenex Implicits alg_integral. + +Lemma imaginary_exists (C : closedFieldType) : {i : C | i ^+ 2 = -1}. +Proof. +have /sig_eqW[i Di2] := @solve_monicpoly C 2 (nth 0 [:: -1]) isT. +by exists i; rewrite Di2 big_ord_recl big_ord1 mul0r mulr1 !addr0. +Qed. + +Import DefaultKeying GRing.DefaultPred. +Implicit Arguments map_poly_inj [[F] [R] x1 x2]. + +Theorem Fundamental_Theorem_of_Algebraics : + {L : closedFieldType & + {conj : {rmorphism L -> L} | involutive conj & ~ conj =1 id}}. +Proof. +have maxn3 n1 n2 n3: {m | [/\ n1 <= m, n2 <= m & n3 <= m]%N}. + by exists (maxn n1 (maxn n2 n3)); apply/and3P; rewrite -!geq_max. +have [C [/= QtoC algC]] := countable_algebraic_closure [countFieldType of rat]. +exists C; have [i Di2] := imaginary_exists C. +pose Qfield := fieldExtType rat; pose Cmorph (L : Qfield) := {rmorphism L -> C}. +have charQ (L : Qfield): [char L] =i pred0 := ftrans (char_lalg L) (char_num _). +have sepQ (L : Qfield) (K E : {subfield L}): separable K E. + by apply/separableP=> u _; apply: charf0_separable. +pose genQfield z L := {LtoC : Cmorph L & {u | LtoC u = z & <<1; u>> = fullv}}. +have /all_tag[Q /all_tag[ofQ genQz]] z: {Qz : Qfield & genQfield z Qz}. + have [|p [/monic_neq0 nzp pz0 irr_p]] := minPoly_decidable_closure _ (algC z). + exact: rat_algebraic_decidable. + pose Qz := SubFieldExtType pz0 irr_p. + pose QzC := subfx_inj_rmorphism QtoC z p. + exists Qz, QzC, (subfx_root QtoC z p); first exact: subfx_inj_root. + apply/vspaceP=> u; rewrite memvf; apply/Fadjoin1_polyP. + by have [q] := subfxEroot pz0 nzp u; exists q. +have pQof z p: p^@ ^ ofQ z = p ^ QtoC. + by rewrite -map_poly_comp; apply: eq_map_poly => x; rewrite !fmorph_eq_rat. +have pQof2 z p u: ofQ z p^@.[u] = (p ^ QtoC).[ofQ z u]. + by rewrite -horner_map pQof. +have PET_Qz z (E : {subfield Q z}): {u | <<1; u>> = E}. + exists (separable_generator 1 E). + by rewrite -eq_adjoin_separable_generator ?sub1v. +pose gen z x := exists q, x = (q ^ QtoC).[z]. +have PET2 x y: {z | gen z x & gen z y}. + pose Gxy := (x, y) = let: (p, q, z) := _ in ((p ^ QtoC).[z], (q ^ QtoC).[z]). + suffices [[[p q] z] []]: {w | Gxy w} by exists z; [exists p | exists q]. + apply/sig_eqW; have /integral_algebraic[px nz_px pxx0] := algC x. + have /integral_algebraic[py nz_py pyy0] := algC y. + have [n [[p Dx] [q Dy]]] := char0_PET nz_px pxx0 nz_py pyy0 (char_num _). + by exists (p, q, y *+ n - x); congr (_, _). +have gen_inQ z x: gen z x -> {u | ofQ z u = x}. + have [u Dz _] := genQz z => /sig_eqW[q ->]. + by exists q^@.[u]; rewrite pQof2 Dz. +have gen_ofP z u v: reflect (gen (ofQ z u) (ofQ z v)) (v \in <<1; u>>). + apply: (iffP Fadjoin1_polyP) => [[q ->]|]; first by rewrite pQof2; exists q. + by case=> q; rewrite -pQof2 => /fmorph_inj->; exists q. +have /all_tag[sQ genP] z: {s : pred C & forall x, reflect (gen z x) (x \in s)}. + apply: all_tag (fun x => reflect (gen z x)) _ => x. + have [w /gen_inQ[u <-] /gen_inQ[v <-]] := PET2 z x. + by exists (v \in <<1; u>>)%VS; apply: gen_ofP. +have sQtrans: transitive (fun x z => x \in sQ z). + move=> x y z /genP[p ->] /genP[q ->]; apply/genP; exists (p \Po q). + by rewrite map_comp_poly horner_comp. +have sQid z: z \in sQ z by apply/genP; exists 'X; rewrite map_polyX hornerX. +have{gen_ofP} sQof2 z u v: (ofQ z u \in sQ (ofQ z v)) = (u \in <<1; v>>%VS). + exact/genP/(gen_ofP z). +have sQof z v: ofQ z v \in sQ z. + by have [u Dz defQz] := genQz z; rewrite -[in sQ z]Dz sQof2 defQz memvf. +have{gen_inQ} sQ_inQ z x z_x := gen_inQ z x (genP z x z_x). +have /all_sig[inQ inQ_K] z: {inQ | {in sQ z, cancel inQ (ofQ z)}}. + by apply: all_sig_cond (fun x u => ofQ z u = x) 0 _ => x /sQ_inQ. +have ofQ_K z: cancel (ofQ z) (inQ z). + by move=> x; have /inQ_K/fmorph_inj := sQof z x. +have sQring z: divring_closed (sQ z). + have sQ_1: 1 \in sQ z by rewrite -(rmorph1 (ofQ z)) sQof. + by split=> // x y /inQ_K<- /inQ_K<- /=; rewrite -(rmorphB, fmorph_div) sQof. +have sQopp z : oppr_closed (sQ z) := sQring z. +have sQadd z : addr_closed (sQ z) := sQring z. +have sQmul z : mulr_closed (sQ z) := sQring z. +have sQinv z : invr_closed (sQ z) := sQring z. +pose morph_ofQ x z Qxz := forall u, ofQ z (Qxz u) = ofQ x u. +have QtoQ z x: x \in sQ z -> {Qxz : 'AHom(Q x, Q z) | morph_ofQ x z Qxz}. + move=> z_x; pose Qxz u := inQ z (ofQ x u). + have QxzE u: ofQ z (Qxz u) = ofQ x u by apply/inQ_K/(sQtrans x). + suffices /rat_lrmorphism QxzM: rmorphism Qxz. + by exists (linfun_ahom (LRMorphism QxzM)) => u; rewrite lfunE QxzE. + split=> [u v|]; first by apply: (canLR (ofQ_K z)); rewrite !rmorphB !QxzE. + by split=> [u v|]; apply: (canLR (ofQ_K z)); rewrite ?rmorph1 ?rmorphM ?QxzE. +pose sQs z s := all (mem (sQ z)) s. +have inQsK z s: sQs z s -> map (ofQ z) (map (inQ z) s) = s. + by rewrite -map_comp => /allP/(_ _ _)/inQ_K; apply: map_id_in. +have inQpK z p: p \is a polyOver (sQ z) -> (p ^ inQ z) ^ ofQ z = p. + by move=> /allP/(_ _ _)/inQ_K/=/map_poly_id; rewrite -map_poly_comp. +have{gen PET2 genP} PET s: {z | sQs z s & <<1 & map (inQ z) s>>%VS = fullv}. + have [y /inQsK Ds]: {y | sQs y s}. + elim: s => [|x s /= [y IHs]]; first by exists 0. + have [z /genP z_x /genP z_y] := PET2 x y. + by exists z; rewrite /= {x}z_x; apply: sub_all IHs => x /sQtrans/= ->. + have [w defQs] := PET_Qz _ <<1 & map (inQ y) s>>%AS; pose z := ofQ y w. + have z_s: sQs z s. + rewrite -Ds /sQs all_map; apply/allP=> u s_u /=. + by rewrite sQof2 defQs seqv_sub_adjoin. + have [[u Dz defQz] [Qzy QzyE]] := (genQz z, QtoQ y z (sQof y w)). + exists z => //; apply/eqP; rewrite eqEsubv subvf /= -defQz. + rewrite -(limg_ker0 _ _ (AHom_lker0 Qzy)) aimg_adjoin_seq aimg_adjoin aimg1. + rewrite -[map _ _](mapK (ofQ_K y)) -(map_comp (ofQ y)) (eq_map QzyE) inQsK //. + by rewrite -defQs -(canLR (ofQ_K y) Dz) -QzyE ofQ_K. +pose rp s := \prod_(z <- s) ('X - z%:P). +have map_rp (f : {rmorphism _}) s: rp _ s ^ f = rp _ (map f s). + rewrite rmorph_prod /rp big_map; apply: eq_bigr => x _. + by rewrite rmorphB /= map_polyX map_polyC. +pose is_Gal z := SplittingField.axiom (Q z). +have galQ x: {z | x \in sQ z & is_Gal z}. + have /sig2W[p mon_p pz0] := algC x. + have [s Dp] := closed_field_poly_normal (p ^ QtoC). + rewrite (monicP _) ?monic_map // scale1r in Dp; have [z z_s defQz] := PET s. + exists z; first by apply/(allP z_s); rewrite -root_prod_XsubC -Dp. + exists p^@; first exact: alg_polyOver. + exists (map (inQ z) s); last by apply/vspaceP=> u; rewrite defQz memvf. + by rewrite -(eqp_map (ofQ z)) pQof Dp map_rp inQsK ?eqpxx. +pose is_realC x := {R : archiFieldType & {rmorphism Q x -> R}}. +pose realC := {x : C & is_realC x}. +pose has_Rroot (xR : realC) p c (Rx := sQ (tag xR)) := + [&& p \is a polyOver Rx, p \is monic, c \in Rx & p.[0] == - c ^+ 2]. +pose root_in (xR : realC) p := exists2 w, w \in sQ (tag xR) & root p w. +pose extendsR (xR yR : realC) := tag xR \in sQ (tag yR). +have add_Rroot xR p c: {yR | extendsR xR yR & has_Rroot xR p c -> root_in yR p}. + rewrite {}/extendsR; case: (has_Rroot xR p c) / and4P; last by exists xR. + case: xR => x [R QxR] /= [/inQpK <-]; move: (p ^ _) => {p}p mon_p /inQ_K<- Dc. + have{c Dc} p0_le0: (p ^ QxR).[0] <= 0. + rewrite horner_coef0 coef_map -[p`_0]ofQ_K -coef_map -horner_coef0 (eqP Dc). + by rewrite -rmorphX -rmorphN ofQ_K /= rmorphN rmorphX oppr_le0 sqr_ge0. + have [s Dp] := closed_field_poly_normal (p ^ ofQ x). + have{Dp} /all_and2[s_p p_s] y: root (p ^ ofQ x) y <-> (y \in s). + by rewrite Dp (monicP mon_p) scale1r root_prod_XsubC. + rewrite map_monic in mon_p; have [z /andP[z_x /allP/=z_s] _] := PET (x :: s). + have{z_x} [[Qxz QxzE] Dx] := (QtoQ z x z_x, inQ_K z x z_x). + pose Qx := <<1; inQ z x>>%AS; pose QxzM := [rmorphism of Qxz]. + have pQwx q1: q1 \is a polyOver Qx -> {q | q1 = q ^ Qxz}. + move/polyOverP=> Qx_q1; exists ((q1 ^ ofQ z) ^ inQ x). + apply: (map_poly_inj (ofQ z)); rewrite -map_poly_comp (eq_map_poly QxzE). + by rewrite inQpK ?polyOver_poly // => j _; rewrite -Dx sQof2 Qx_q1. + have /all_sig[t_ Dt] u: {t | <<1; t>> = <>} by apply: PET_Qz. + suffices{p_s}[u Ry px0]: {u : Q z & is_realC (ofQ z (t_ u)) & ofQ z u \in s}. + exists (Tagged is_realC Ry) => [|_] /=. + by rewrite -Dx sQof2 Dt subvP_adjoin ?memv_adjoin. + by exists (ofQ z u); rewrite ?p_s // sQof2 Dt memv_adjoin. + without loss{z_s s_p} [u Dp s_y]: p mon_p p0_le0 / + {u | minPoly Qx u = p ^ Qxz & ofQ z u \in s}. + - move=> IHp; move: {2}_.+1 (ltnSn (size p)) => d. + elim: d => // d IHd in p mon_p s_p p0_le0 *; rewrite ltnS => le_p_d. + have /closed_rootP/sig_eqW[y py0]: size (p ^ ofQ x) != 1%N. + rewrite size_map_poly size_poly_eq1 eqp_monic ?rpred1 //. + by apply: contraTneq p0_le0 => ->; rewrite rmorph1 hornerC ltr_geF ?ltr01. + have /s_p s_y := py0; have /z_s/sQ_inQ[u Dy] := s_y. + have /pQwx[q Dq] := minPolyOver Qx u. + have mon_q: q \is monic by have:= monic_minPoly Qx u; rewrite Dq map_monic. + have /dvdpP/sig_eqW[r Dp]: q %| p. + rewrite -(dvdp_map QxzM) -Dq minPoly_dvdp //. + by apply: polyOver_poly => j _; rewrite -sQof2 QxzE Dx. + by rewrite -(fmorph_root (ofQ z)) Dy -map_poly_comp (eq_map_poly QxzE). + have mon_r: r \is monic by rewrite Dp monicMr in mon_p. + have [q0_le0 | q0_gt0] := lerP ((q ^ QxR).[0]) 0. + by apply: (IHp q) => //; exists u; rewrite ?Dy. + have r0_le0: (r ^ QxR).[0] <= 0. + by rewrite -(ler_pmul2r q0_gt0) mul0r -hornerM -rmorphM -Dp. + apply: (IHd r mon_r) => // [w rw0|]. + by rewrite s_p // Dp rmorphM rootM rw0. + apply: leq_trans le_p_d; rewrite Dp size_Mmonic ?monic_neq0 // addnC. + by rewrite -(size_map_poly QxzM q) -Dq size_minPoly !ltnS leq_addl. + exists u => {s s_y}//; set y := ofQ z (t_ u); set p1 := minPoly Qx u in Dp. + have /QtoQ[Qyz QyzE]: y \in sQ z := sQof z (t_ u). + pose q1_ v := Fadjoin_poly Qx u (Qyz v). + have{QyzE} QyzE v: Qyz v = (q1_ v).[u]. + by rewrite Fadjoin_poly_eq // -Dt -sQof2 QyzE sQof. + have /all_sig2[q_ coqp Dq] v: {q | v != 0 -> coprimep p q & q ^ Qxz = q1_ v}. + have /pQwx[q Dq]: q1_ v \is a polyOver Qx by apply: Fadjoin_polyOver. + exists q => // nz_v; rewrite -(coprimep_map QxzM) -Dp -Dq -gcdp_eqp1. + have /minPoly_irr/orP[] // := dvdp_gcdl p1 (q1_ v). + by rewrite gcdp_polyOver ?minPolyOver ?Fadjoin_polyOver. + rewrite -/p1 {1}/eqp dvdp_gcd => /and3P[_ _ /dvdp_leq/=/implyP]. + rewrite size_minPoly ltnNge size_poly (contraNneq _ nz_v) // => q1v0. + by rewrite -(fmorph_eq0 [rmorphism of Qyz]) /= QyzE q1v0 horner0. + pose h2 : R := 2%:R^-1; have nz2: 2%:R != 0 :> R by rewrite pnatr_eq0. + pose itv ab := [pred c : R | ab.1 <= c <= ab.2]. + pose wid ab : R := ab.2 - ab.1; pose mid ab := (ab.1 + ab.2) * h2. + pose sub_itv ab cd := cd.1 <= ab.1 :> R /\ ab.2 <= cd.2 :> R. + pose xup q ab := [/\ q.[ab.1] <= 0, q.[ab.2] >= 0 & ab.1 <= ab.2 :> R]. + pose narrow q ab (c := mid ab) := if q.[c] >= 0 then (ab.1, c) else (c, ab.2). + pose find k q := iter k (narrow q). + have findP k q ab (cd := find k q ab): + xup q ab -> [/\ xup q cd, sub_itv cd ab & wid cd = wid ab / (2 ^ k)%:R]. + - rewrite {}/cd; case: ab => a b xq_ab. + elim: k => /= [|k]; first by rewrite divr1. + case: (find k q _) => c d [[/= qc_le0 qd_ge0 le_cd] [/= le_ac le_db] Dcd]. + have [/= le_ce le_ed] := midf_le le_cd; set e := _ / _ in le_ce le_ed. + rewrite expnSr natrM invfM mulrA -{}Dcd /narrow /= -[mid _]/e. + have [qe_ge0 // | /ltrW qe_le0] := lerP 0 q.[e]. + do ?split=> //=; [exact: (ler_trans le_ed) | apply: canRL (mulfK nz2) _]. + by rewrite mulrBl divfK // mulr_natr opprD addrACA subrr add0r. + do ?split=> //=; [exact: (ler_trans le_ac) | apply: canRL (mulfK nz2) _]. + by rewrite mulrBl divfK // mulr_natr opprD addrACA subrr addr0. + have find_root r q ab: + xup q ab -> {n | forall x, x \in itv (find n q ab) ->`|(r * q).[x]| < h2}. + - move=> xab; have ub_ab := poly_itv_bound _ ab.1 ab.2. + have [Mu MuP] := ub_ab r; have /all_sig[Mq MqP] j := ub_ab q^`N(j). + pose d := wid ab; pose dq := \poly_(i < (size q).-1) Mq i.+1. + have d_ge0: 0 <= d by rewrite subr_ge0; case: xab. + have [Mdq MdqP] := poly_disk_bound dq d. + pose n := Num.bound (Mu * Mdq * d); exists n => c /= /andP[]. + have{xab} [[]] := findP n _ _ xab; case: (find n q ab) => a1 b1 /=. + rewrite -/d => qa1_le0 qb1_ge0 le_ab1 [/= le_aa1 le_b1b] Dab1 le_a1c le_cb1. + have /MuP lbMu: c \in itv ab. + by rewrite !inE (ler_trans le_aa1) ?(ler_trans le_cb1). + have Mu_ge0: 0 <= Mu by rewrite (ler_trans _ lbMu) ?normr_ge0. + have Mdq_ge0: 0 <= Mdq. + by rewrite (ler_trans _ (MdqP 0 _)) ?normr_ge0 ?normr0. + suffices lb1 a2 b2 (ab1 := (a1, b1)) (ab2 := (a2, b2)) : + xup q ab2 /\ sub_itv ab2 ab1 -> q.[b2] - q.[a2] <= Mdq * wid ab1. + + apply: ler_lt_trans (_ : Mu * Mdq * wid (a1, b1) < h2); last first. + rewrite {}Dab1 mulrA ltr_pdivr_mulr ?ltr0n ?expn_gt0 //. + rewrite (ltr_le_trans (archi_boundP _)) ?mulr_ge0 ?ltr_nat // -/n. + rewrite ler_pdivl_mull ?ltr0n // -natrM ler_nat. + by case: n => // n; rewrite expnS leq_pmul2l // ltn_expl. + rewrite -mulrA hornerM normrM ler_pmul ?normr_ge0 //. + have [/ltrW qc_le0 | qc_ge0] := ltrP q.[c] 0. + by apply: ler_trans (lb1 c b1 _); rewrite ?ler0_norm ?ler_paddl. + by apply: ler_trans (lb1 a1 c _); rewrite ?ger0_norm ?ler_paddr ?oppr_ge0. + case{c le_a1c le_cb1 lbMu}=> [[/=qa2_le0 qb2_ge0 le_ab2] [/=le_a12 le_b21]]. + pose h := b2 - a2; have h_ge0: 0 <= h by rewrite subr_ge0. + have [-> | nz_q] := eqVneq q 0. + by rewrite !horner0 subrr mulr_ge0 ?subr_ge0. + rewrite -(subrK a2 b2) (addrC h) (nderiv_taylor q (mulrC a2 h)). + rewrite (polySpred nz_q) big_ord_recl /= mulr1 nderivn0 addrC addKr. + have [le_aa2 le_b2b] := (ler_trans le_aa1 le_a12, ler_trans le_b21 le_b1b). + have /MqP MqPx1: a2 \in itv ab by rewrite inE le_aa2 (ler_trans le_ab2). + apply: ler_trans (ler_trans (ler_norm _) (ler_norm_sum _ _ _)) _. + apply: ler_trans (_ : `|dq.[h] * h| <= _); last first. + by rewrite normrM ler_pmul ?normr_ge0 ?MdqP // ?ger0_norm ?ler_sub ?h_ge0. + rewrite horner_poly ger0_norm ?mulr_ge0 ?sumr_ge0 // => [|j _]; last first. + by rewrite mulr_ge0 ?exprn_ge0 // (ler_trans _ (MqPx1 _)) ?normr_ge0. + rewrite mulr_suml ler_sum // => j _; rewrite normrM -mulrA -exprSr. + by rewrite ler_pmul ?normr_ge0 // normrX ger0_norm. + have [ab0 xab0]: {ab | xup (p ^ QxR) ab}. + have /monic_Cauchy_bound[b pb_gt0]: p ^ QxR \is monic by apply: monic_map. + by exists (0, `|b|); rewrite /xup normr_ge0 p0_le0 ltrW ?pb_gt0 ?ler_norm. + pose ab_ n := find n (p ^ QxR) ab0; pose Iab_ n := itv (ab_ n). + pose lim v a := (q_ v ^ QxR).[a]; pose nlim v n := lim v (ab_ n).2. + have lim0 a: lim 0 a = 0. + rewrite /lim; suffices /eqP ->: q_ 0 == 0 by rewrite rmorph0 horner0. + by rewrite -(map_poly_eq0 QxzM) Dq /q1_ !raddf0. + have limN v a: lim (- v) a = - lim v a. + rewrite /lim; suffices ->: q_ (- v) = - q_ v by rewrite rmorphN hornerN. + by apply: (map_poly_inj QxzM); rewrite Dq /q1_ !raddfN /= Dq. + pose lim_nz n v := exists2 e, e > 0 & {in Iab_ n, forall a, e < `|lim v a| }. + have /(all_sig_cond 0%N)[n_ nzP] v: v != 0 -> {n | lim_nz n v}. + move=> nz_v; do [move/(_ v nz_v); rewrite -(coprimep_map QxR)] in coqp. + have /sig_eqW[r r_pq_1] := Bezout_eq1_coprimepP _ _ coqp. + have /(find_root r.1)[n ub_rp] := xab0; exists n. + have [M Mgt0 ubM]: {M | 0 < M & {in Iab_ n, forall a, `|r.2.[a]| <= M}}. + have [M ubM] := poly_itv_bound r.2 (ab_ n).1 (ab_ n).2. + exists (Num.max 1 M) => [|s /ubM vM]; first by rewrite ltr_maxr ltr01. + by rewrite ler_maxr orbC vM. + exists (h2 / M) => [|a xn_a]; first by rewrite divr_gt0 ?invr_gt0 ?ltr0n. + rewrite ltr_pdivr_mulr // -(ltr_add2l h2) -mulr2n -mulr_natl divff //. + rewrite -normr1 -(hornerC 1 a) -[1%:P]r_pq_1 hornerD. + rewrite ?(ler_lt_trans (ler_norm_add _ _)) ?ltr_le_add ?ub_rp //. + by rewrite mulrC hornerM normrM ler_wpmul2l ?ubM. + have ab_le m n: (m <= n)%N -> (ab_ n).2 \in Iab_ m. + move/subnKC=> <-; move: {n}(n - m)%N => n; rewrite /ab_. + have /(findP m)[/(findP n)[[_ _]]] := xab0. + rewrite /find -iter_add -!/(find _ _) -!/(ab_ _) addnC !inE. + by move: (ab_ _) => /= ab_mn le_ab_mn [/ler_trans->]. + pose lt v w := 0 < nlim (w - v) (n_ (w - v)). + have posN v: lt 0 (- v) = lt v 0 by rewrite /lt subr0 add0r. + have posB v w: lt 0 (w - v) = lt v w by rewrite /lt subr0. + have posE n v: (n_ v <= n)%N -> lt 0 v = (0 < nlim v n). + rewrite /lt subr0 /nlim => /ab_le; set a := _.2; set b := _.2 => Iv_a. + have [-> | /nzP[e e_gt0]] := eqVneq v 0; first by rewrite !lim0 ltrr. + move: (n_ v) => m in Iv_a b * => v_gte. + without loss lt0v: v v_gte / 0 < lim v b. + move=> IHv; apply/idP/idP => [v_gt0 | /ltrW]; first by rewrite -IHv. + rewrite ltr_def -normr_gt0 ?(ltr_trans _ (v_gte _ _)) ?ab_le //=. + rewrite !lerNgt -!oppr_gt0 -!limN; apply: contra => v_lt0. + by rewrite -IHv // => c /v_gte; rewrite limN normrN. + rewrite lt0v (ltr_trans e_gt0) ?(ltr_le_trans (v_gte a Iv_a)) //. + rewrite ger0_norm // lerNgt; apply/negP=> /ltrW lev0. + have [le_a le_ab] : _ /\ a <= b := andP Iv_a. + have xab: xup (q_ v ^ QxR) (a, b) by move/ltrW in lt0v. + have /(find_root (h2 / e)%:P)[n1] := xab; have /(findP n1)[[_ _]] := xab. + case: (find _ _ _) => c d /= le_cd [/= le_ac le_db] _ /(_ c)/implyP. + rewrite inE lerr le_cd hornerM hornerC normrM ler_gtF //. + rewrite ger0_norm ?divr_ge0 ?invr_ge0 ?ler0n ?(ltrW e_gt0) // mulrAC. + rewrite ler_pdivl_mulr // ler_wpmul2l ?invr_ge0 ?ler0n // ltrW // v_gte //=. + by rewrite inE -/b (ler_trans le_a) //= (ler_trans le_cd). + pose lim_pos m v := exists2 e, e > 0 & forall n, (m <= n)%N -> e < nlim v n. + have posP v: reflect (exists m, lim_pos m v) (lt 0 v). + apply: (iffP idP) => [v_gt0|[m [e e_gt0 v_gte]]]; last first. + by rewrite (posE _ _ (leq_maxl _ m)) (ltr_trans e_gt0) ?v_gte ?leq_maxr. + have [|e e_gt0 v_gte] := nzP v. + by apply: contraTneq v_gt0 => ->; rewrite /lt subr0 /nlim lim0 ltrr. + exists (n_ v), e => // n le_vn; rewrite (posE n) // in v_gt0. + by rewrite -(ger0_norm (ltrW v_gt0)) v_gte ?ab_le. + have posNneg v: lt 0 v -> ~~ lt v 0. + case/posP=> m [d d_gt0 v_gtd]; rewrite -posN. + apply: contraL d_gt0 => /posP[n [e e_gt0 nv_gte]]. + rewrite ltr_gtF // (ltr_trans (v_gtd _ (leq_maxl m n))) // -oppr_gt0. + by rewrite /nlim -limN (ltr_trans e_gt0) ?nv_gte ?leq_maxr. + have posVneg v: v != 0 -> lt 0 v || lt v 0. + case/nzP=> e e_gt0 v_gte; rewrite -posN; set w := - v. + have [m [le_vm le_wm _]] := maxn3 (n_ v) (n_ w) 0%N; rewrite !(posE m) //. + by rewrite /nlim limN -ltr_normr (ltr_trans e_gt0) ?v_gte ?ab_le. + have posD v w: lt 0 v -> lt 0 w -> lt 0 (v + w). + move=> /posP[m [d d_gt0 v_gtd]] /posP[n [e e_gt0 w_gte]]. + apply/posP; exists (maxn m n), (d + e) => [|k]; first exact: addr_gt0. + rewrite geq_max => /andP[le_mk le_nk]; rewrite /nlim /lim. + have ->: q_ (v + w) = q_ v + q_ w. + by apply: (map_poly_inj QxzM); rewrite rmorphD /= !{1}Dq /q1_ !raddfD. + by rewrite rmorphD hornerD ltr_add ?v_gtd ?w_gte. + have posM v w: lt 0 v -> lt 0 w -> lt 0 (v * w). + move=> /posP[m [d d_gt0 v_gtd]] /posP[n [e e_gt0 w_gte]]. + have /dvdpP[r /(canRL (subrK _))Dqvw]: p %| q_ (v * w) - q_ v * q_ w. + rewrite -(dvdp_map QxzM) rmorphB rmorphM /= !Dq -Dp minPoly_dvdp //. + by rewrite rpredB 1?rpredM ?Fadjoin_polyOver. + by rewrite rootE !hornerE -!QyzE rmorphM subrr. + have /(find_root ((d * e)^-1 *: r ^ QxR))[N ub_rp] := xab0. + pose f := d * e * h2; apply/posP; exists (maxn N (maxn m n)), f => [|k]. + by rewrite !mulr_gt0 ?invr_gt0 ?ltr0n. + rewrite !geq_max => /and3P[/ab_le/ub_rp{ub_rp}ub_rp le_mk le_nk]. + rewrite -(ltr_add2r f) -mulr2n -mulr_natr divfK // /nlim /lim Dqvw. + rewrite rmorphD hornerD /= -addrA -ltr_subl_addl ler_lt_add //. + by rewrite rmorphM hornerM ler_pmul ?ltrW ?v_gtd ?w_gte. + rewrite -ltr_pdivr_mull ?mulr_gt0 // (ler_lt_trans _ ub_rp) //. + by rewrite -scalerAl hornerZ -rmorphM mulrN -normrN ler_norm. + pose le v w := (w == v) || lt v w. + pose abs v := if le 0 v then v else - v. + have absN v: abs (- v) = abs v. + rewrite /abs /le oppr_eq0 opprK posN. + have [-> | /posVneg/orP[v_gt0 | v_lt0]] := altP eqP; first by rewrite oppr0. + by rewrite v_gt0 /= -if_neg posNneg. + by rewrite v_lt0 /= -if_neg -(opprK v) posN posNneg ?posN. + have absE v: le 0 v -> abs v = v by rewrite /abs => ->. + pose QyNum := RealLtMixin posD posM posNneg posB posVneg absN absE (rrefl _). + pose QyNumField := [numFieldType of NumDomainType (Q y) QyNum]. + pose Ry := [realFieldType of RealDomainType _ (RealLeAxiom QyNumField)]. + have archiRy := @rat_algebraic_archimedean Ry _ alg_integral. + by exists (ArchiFieldType Ry archiRy); apply: [rmorphism of idfun]. +have some_realC: realC. + suffices /all_sig[f QfK] x: {a | in_alg (Q 0) a = x}. + exists 0, [archiFieldType of rat], f. + exact: can2_rmorphism (inj_can_sym QfK (fmorph_inj _)) QfK. + have /Fadjoin1_polyP/sig_eqW[q]: x \in <<1; 0>>%VS by rewrite -sQof2 rmorph0. + by exists q.[0]; rewrite -horner_map rmorph0. +pose fix xR n : realC := + if n isn't n'.+1 then some_realC else + if unpickle (nth 0%N (CodeSeq.decode n') 1) isn't Some (p, c) then xR n' else + tag (add_Rroot (xR n') p c). +pose x_ n := tag (xR n). +have sRle m n: (m <= n)%N -> {subset sQ (x_ m) <= sQ (x_ n)}. + move/subnK <-; elim: {n}(n - m)%N => // n IHn x /IHn{IHn}Rx. + rewrite addSn /x_ /=; case: (unpickle _) => [[p c]|] //=. + by case: (add_Rroot _ _ _) => yR /= /(sQtrans _ x)->. +have xRroot n p c: has_Rroot (xR n) p c -> {m | n <= m & root_in (xR m) p}%N. + case/and4P=> Rp mon_p Rc Dc; pose m := CodeSeq.code [:: n; pickle (p, c)]. + have le_n_m: (n <= m)%N by apply/ltnW/(allP (CodeSeq.ltn_code _))/mem_head. + exists m.+1; rewrite ?leqW /x_ //= CodeSeq.codeK pickleK. + case: (add_Rroot _ _ _) => yR /= _; apply; apply/and4P. + by split=> //; first apply: polyOverS Rp; apply: (sRle n). +have /all_sig[z_ /all_and3[Ri_R Ri_i defRi]] n (x := x_ n): + {z | [/\ x \in sQ z, i \in sQ z & <<<<1; inQ z x>>; inQ z i>> = fullv]}. +- have [z /and3P[z_x z_i _] Dzi] := PET [:: x; i]. + by exists z; rewrite -adjoin_seq1 -adjoin_cons. +pose i_ n := inQ (z_ n) i; pose R_ n := <<1; inQ (z_ n) (x_ n)>>%AS. +have memRi n: <> =i predT by move=> u; rewrite defRi memvf. +have sCle m n: (m <= n)%N -> {subset sQ (z_ m) <= sQ (z_ n)}. + move/sRle=> Rmn _ /sQ_inQ[u <-]. + have /Fadjoin_polyP[p /polyOverP Rp ->] := memRi m u. + rewrite -horner_map inQ_K ?rpred_horner //=; apply/polyOver_poly=> j _. + by apply: sQtrans (Ri_R n); rewrite Rmn // -(inQ_K _ _ (Ri_R m)) sQof2. +have R'i n: i \notin sQ (x_ n). + rewrite /x_; case: (xR n) => x [Rn QxR] /=. + apply: contraL (@ltr01 Rn) => /sQ_inQ[v Di]. + suffices /eqP <-: - QxR v ^+ 2 == 1 by rewrite oppr_gt0 -lerNgt sqr_ge0. + rewrite -rmorphX -rmorphN fmorph_eq1 -(fmorph_eq1 (ofQ x)) rmorphN eqr_oppLR. + by rewrite rmorphX Di Di2. +have szX2_1: size ('X^2 + 1) = 3. + by move=> R; rewrite size_addl ?size_polyXn ?size_poly1. +have minp_i n (p_i := minPoly (R_ n) (i_ n)): p_i = 'X^2 + 1. + have p_dv_X2_1: p_i %| 'X^2 + 1. + rewrite minPoly_dvdp ?rpredD ?rpredX ?rpred1 ?polyOverX //. + rewrite -(fmorph_root (ofQ _)) inQ_K // rmorphD rmorph1 /= map_polyXn. + by rewrite rootE hornerD hornerXn hornerC Di2 addNr. + apply/eqP; rewrite -eqp_monic ?monic_minPoly //; last first. + by rewrite monicE lead_coefE szX2_1 coefD coefXn coefC addr0. + rewrite -dvdp_size_eqp // eqn_leq dvdp_leq -?size_poly_eq0 ?szX2_1 //= ltnNge. + by rewrite size_minPoly ltnS leq_eqVlt orbF adjoin_deg_eq1 -sQof2 !inQ_K. +have /all_sig[n_ FTA] z: {n | z \in sQ (z_ n)}. + without loss [z_i gal_z]: z / i \in sQ z /\ is_Gal z. + have [y /and3P[/sQtrans y_z /sQtrans y_i _] _] := PET [:: z; i]. + have [t /sQtrans t_y gal_t] := galQ y. + by case/(_ t)=> [|n]; last exists n; rewrite ?y_z ?y_i ?t_y. + apply/sig_eqW; have n := 0%N. + have [p]: exists p, [&& p \is monic, root p z & p \is a polyOver (sQ (z_ n))]. + have [p mon_p pz0] := algC z; exists (p ^ QtoC). + by rewrite map_monic mon_p pz0 -(pQof (z_ n)); apply/polyOver_poly. + elim: {p}_.+1 {-2}p n (ltnSn (size p)) => // d IHd p n lepd pz0. + have [t [t_C t_z gal_t]]: exists t, [/\ z_ n \in sQ t, z \in sQ t & is_Gal t]. + have [y /and3P[y_C y_z _]] := PET [:: z_ n; z]. + by have [t /(sQtrans y)t_y] := galQ y; exists t; rewrite !t_y. + pose Qt := SplittingFieldType rat (Q t) gal_t; have /QtoQ[CnQt CnQtE] := t_C. + pose Rn : {subfield Qt} := (CnQt @: R_ n)%AS; pose i_t : Qt := CnQt (i_ n). + pose Cn : {subfield Qt} := <>%AS. + have defCn: Cn = limg CnQt :> {vspace Q t} by rewrite /= -aimg_adjoin defRi. + have memRn u: (u \in Rn) = (ofQ t u \in sQ (x_ n)). + by rewrite /= aimg_adjoin aimg1 -sQof2 CnQtE inQ_K. + have memCn u: (u \in Cn) = (ofQ t u \in sQ (z_ n)). + have [v Dv genCn] := genQz (z_ n). + by rewrite -Dv -CnQtE sQof2 defCn -genCn aimg_adjoin aimg1. + have Dit: ofQ t i_t = i by rewrite CnQtE inQ_K. + have Dit2: i_t ^+ 2 = -1. + by apply: (fmorph_inj (ofQ t)); rewrite rmorphX rmorphN1 Dit. + have dimCn: \dim_Rn Cn = 2. + rewrite -adjoin_degreeE adjoin_degree_aimg. + by apply: succn_inj; rewrite -size_minPoly minp_i. + have /sQ_inQ[u_z Dz] := t_z; pose Rz := <>%AS. + have{p lepd pz0} le_Rz_d: (\dim_Cn Rz < d)%N. + rewrite -ltnS -adjoin_degreeE -size_minPoly (leq_trans _ lepd) // !ltnS. + have{pz0} [mon_p pz0 Cp] := and3P pz0. + have{Cp} Dp: ((p ^ inQ (z_ n)) ^ CnQt) ^ ofQ t = p. + by rewrite -map_poly_comp (eq_map_poly CnQtE) inQpK. + rewrite -Dp size_map_poly dvdp_leq ?monic_neq0 -?(map_monic (ofQ _)) ?Dp //. + rewrite defCn minPoly_dvdp //; try by rewrite -(fmorph_root (ofQ t)) Dz Dp. + by apply/polyOver_poly=> j _; rewrite memv_img ?memvf. + have [sRCn sCnRz]: (Rn <= Cn)%VS /\ (Cn <= Rz)%VS by rewrite !subv_adjoin. + have sRnRz := subv_trans sRCn sCnRz. + have{gal_z} galRz: galois Rn Rz. + apply/and3P; split=> //; apply/splitting_normalField=> //. + pose u : SplittingFieldType rat (Q z) gal_z := inQ z z. + have /QtoQ[Qzt QztE] := t_z; exists (minPoly 1 u ^ Qzt). + have /polyOver1P[q ->] := minPolyOver 1 u; apply/polyOver_poly=> j _. + by rewrite coef_map linearZZ rmorph1 rpredZ ?rpred1. + have [s /eqP Ds] := splitting_field_normal 1 u. + rewrite Ds; exists (map Qzt s); first by rewrite map_rp eqpxx. + apply/eqP; rewrite eqEsubv; apply/andP; split. + apply/Fadjoin_seqP; split=> // _ /mapP[w s_w ->]. + by rewrite (subvP (adjoinSl u_z (sub1v _))) // -sQof2 Dz QztE. + rewrite /= adjoinC (Fadjoin_idP _) -/Rz; last first. + by rewrite (subvP (adjoinSl _ (sub1v _))) // -sQof2 Dz Dit. + rewrite /= -adjoin_seq1 adjoin_seqSr //; apply/allP=> /=; rewrite andbT. + rewrite -(mem_map (fmorph_inj (ofQ _))) -map_comp (eq_map QztE); apply/mapP. + by exists u; rewrite ?inQ_K // -root_prod_XsubC -Ds root_minPoly. + have galCz: galois Cn Rz by rewrite (galoisS _ galRz) ?sRCn. + have [Cz | C'z]:= boolP (u_z \in Cn); first by exists n; rewrite -Dz -memCn. + pose G := 'Gal(Rz / Cn)%G; have{C'z} ntG: G :!=: 1%g. + rewrite trivg_card1 -galois_dim 1?(galoisS _ galCz) ?subvv //=. + by rewrite -adjoin_degreeE adjoin_deg_eq1. + pose extRz m := exists2 w, ofQ t w \in sQ (z_ m) & w \in [predD Rz & Cn]. + suffices [m le_n_m [w Cw /andP[C'w Rz_w]]]: exists2 m, (n <= m)%N & extRz m. + pose p := minPoly <> u_z; apply: (IHd (p ^ ofQ t) m). + apply: leq_trans le_Rz_d; rewrite size_map_poly size_minPoly ltnS. + rewrite adjoin_degreeE adjoinC (addv_idPl Rz_w) agenv_id. + rewrite ltn_divLR ?adim_gt0 // mulnC. + rewrite muln_divCA ?field_dimS ?subv_adjoin // ltn_Pmulr ?adim_gt0 //. + by rewrite -adjoin_degreeE ltnNge leq_eqVlt orbF adjoin_deg_eq1. + rewrite map_monic monic_minPoly -Dz fmorph_root root_minPoly /=. + have /polyOverP Cw_p: p \is a polyOver <>%VS by apply: minPolyOver. + apply/polyOver_poly=> j _; have /Fadjoin_polyP[q Cq {j}->] := Cw_p j. + rewrite -horner_map rpred_horner //; apply/polyOver_poly=> j _. + by rewrite (sCle n) // -memCn (polyOverP Cq). + have [evenG | oddG] := boolP (2.-group G); last first. + have [P /and3P[sPG evenP oddPG]] := Sylow_exists 2 'Gal(Rz / Rn). + have [w defQw] := PET_Qz t [aspace of fixedField P]. + pose pw := minPoly Rn w; pose p := (- pw * (pw \Po - 'X)) ^ ofQ t. + have sz_pw: (size pw).-1 = #|'Gal(Rz / Rn) : P|. + rewrite size_minPoly adjoin_degreeE -dim_fixed_galois //= -defQw. + congr (\dim_Rn _); apply/esym/eqP; rewrite eqEsubv adjoinSl ?sub1v //=. + by apply/FadjoinP; rewrite memv_adjoin /= defQw -galois_connection. + have mon_p: p \is monic. + have mon_pw: pw \is monic := monic_minPoly _ _. + rewrite map_monic mulNr -mulrN monicMl // monicE. + rewrite !(lead_coef_opp, lead_coef_comp) ?size_opp ?size_polyX //. + by rewrite lead_coefX sz_pw -signr_odd odd_2'nat oddPG mulrN1 opprK. + have Dp0: p.[0] = - ofQ t pw.[0] ^+ 2. + rewrite -(rmorph0 (ofQ t)) horner_map hornerM rmorphM. + by rewrite horner_comp !hornerN hornerX oppr0 rmorphN mulNr. + have Rpw: pw \is a polyOver Rn by apply: minPolyOver. + have Rp: p \is a polyOver (sQ (x_ n)). + apply/polyOver_poly=> j _; rewrite -memRn; apply: polyOverP j => /=. + by rewrite rpredM 1?polyOver_comp ?rpredN ?polyOverX. + have Rp0: ofQ t pw.[0] \in sQ (x_ n) by rewrite -memRn rpred_horner ?rpred0. + have [|{mon_p Rp Rp0 Dp0}m lenm p_Rm_0] := xRroot n p (ofQ t pw.[0]). + by rewrite /has_Rroot mon_p Rp Rp0 -Dp0 /=. + have{p_Rm_0} [y Ry pw_y]: {y | y \in sQ (x_ m) & root (pw ^ ofQ t) y}. + apply/sig2W; have [y Ry] := p_Rm_0. + rewrite [p]rmorphM /= map_comp_poly !rmorphN /= map_polyX. + rewrite rootM rootN root_comp hornerN hornerX. + by case/orP; [exists y | exists (- y)]; rewrite ?rpredN. + have [u Rz_u Dy]: exists2 u, u \in Rz & y = ofQ t u. + have Rz_w: w \in Rz by rewrite -sub_adjoin1v defQw capvSl. + have [sg [Gsg _ Dpw]] := galois_factors sRnRz galRz w Rz_w. + set s := map _ sg in Dpw. + have /mapP[u /mapP[g Gg Du] ->]: y \in map (ofQ t) s. + by rewrite -root_prod_XsubC -/(rp C _) -map_rp -[rp _ _]Dpw. + by exists u; rewrite // Du memv_gal. + have{pw_y} pw_u: root pw u by rewrite -(fmorph_root (ofQ t)) -Dy. + exists m => //; exists u; first by rewrite -Dy; apply: sQtrans Ry _. + rewrite inE /= Rz_u andbT; apply: contra oddG => Cu. + suffices: 2.-group 'Gal(Rz / Rn). + apply: pnat_dvd; rewrite -!galois_dim // ?(galoisS _ galQr) ?sRCz //. + rewrite dvdn_divLR ?field_dimS ?adim_gt0 //. + by rewrite mulnC muln_divCA ?field_dimS ?dvdn_mulr. + congr (2.-group _): evenP; apply/eqP. + rewrite eqEsubset sPG -indexg_eq1 (pnat_1 _ oddPG) // -sz_pw. + have (pu := minPoly Rn u): (pu %= pw) || (pu %= 1). + by rewrite minPoly_irr ?minPoly_dvdp ?minPolyOver. + rewrite /= -size_poly_eq1 {1}size_minPoly orbF => /eqp_size <-. + rewrite size_minPoly /= adjoin_degreeE (@pnat_dvd _ 2) // -dimCn. + rewrite dvdn_divLR ?divnK ?adim_gt0 ?field_dimS ?subv_adjoin //. + exact/FadjoinP. + have [w Rz_w deg_w]: exists2 w, w \in Rz & adjoin_degree Cn w = 2. + have [P sPG iPG]: exists2 P : {group gal_of Rz}, P \subset G & #|G : P| = 2. + have [_ _ [k oG]] := pgroup_pdiv evenG ntG. + have [P [sPG _ oP]] := normal_pgroup evenG (normal_refl G) (leq_pred _). + by exists P => //; rewrite -divgS // oP oG pfactorK // -expnB ?subSnn. + have [w defQw] := PET_Qz _ [aspace of fixedField P]. + exists w; first by rewrite -sub_adjoin1v defQw capvSl. + rewrite adjoin_degreeE -iPG -dim_fixed_galois // -defQw; congr (\dim_Cn _). + apply/esym/eqP; rewrite eqEsubv adjoinSl ?sub1v //=; apply/FadjoinP. + by rewrite memv_adjoin /= defQw -galois_connection. + have nz2: 2%:R != 0 :> Qt by move/charf0P: (charQ (Q t)) => ->. + without loss{deg_w} [C'w Cw2]: w Rz_w / w \notin Cn /\ w ^+ 2 \in Cn. + pose p := minPoly Cn w; pose v := p`_1 / 2%:R. + have /polyOverP Cp: p \is a polyOver Cn := minPolyOver Cn w. + have Cv: v \in Cn by rewrite rpred_div ?rpred_nat ?Cp. + move/(_ (v + w)); apply; first by rewrite rpredD // subvP_adjoin. + split; first by rewrite rpredDl // -adjoin_deg_eq1 deg_w. + rewrite addrC -[_ ^+ 2]subr0 -(rootP (root_minPoly Cn w)) -/p. + rewrite sqrrD [_ - _]addrAC rpredD ?rpredX // -mulr_natr -mulrA divfK //. + rewrite [w ^+ 2 + _]addrC mulrC -rpredN opprB horner_coef. + have /monicP := monic_minPoly Cn w; rewrite lead_coefE size_minPoly deg_w. + by rewrite 2!big_ord_recl big_ord1 => ->; rewrite mulr1 mul1r addrK Cp. + without loss R'w2: w Rz_w C'w Cw2 / w ^+ 2 \notin Rn. + move=> IHw; have [Rw2 | /IHw] := boolP (w ^+ 2 \in Rn); last exact. + have R'it: i_t \notin Rn by rewrite memRn Dit. + pose v := 1 + i_t; have R'v: v \notin Rn by rewrite rpredDl ?rpred1. + have Cv: v \in Cn by rewrite rpredD ?rpred1 ?memv_adjoin. + have nz_v: v != 0 by rewrite (memPnC R'v) ?rpred0. + apply: (IHw (v * w)); last 1 [|] || by rewrite fpredMl // subvP_adjoin. + by rewrite exprMn rpredM // rpredX. + rewrite exprMn fpredMr //=; last by rewrite expf_eq0 (memPnC C'w) ?rpred0. + by rewrite sqrrD Dit2 expr1n addrC addKr -mulrnAl fpredMl ?rpred_nat. + pose rect_w2 u v := [/\ u \in Rn, v \in Rn & u + i_t * (v * 2%:R) = w ^+ 2]. + have{Cw2} [u [v [Ru Rv Dw2]]]: {u : Qt & {v | rect_w2 u v}}. + rewrite /rect_w2 -(Fadjoin_poly_eq Cw2); set p := Fadjoin_poly Rn i_t _. + have /polyOverP Rp: p \is a polyOver Rn by apply: Fadjoin_polyOver. + exists p`_0, (p`_1 / 2%:R); split; rewrite ?rpred_div ?rpred_nat //. + rewrite divfK // (horner_coef_wide _ (size_Fadjoin_poly _ _ _)) -/p. + by rewrite adjoin_degreeE dimCn big_ord_recl big_ord1 mulr1 mulrC. + pose p := Poly [:: - (ofQ t v ^+ 2); 0; - ofQ t u; 0; 1]. + have [|m lenm [x Rx px0]] := xRroot n p (ofQ t v). + rewrite /has_Rroot 2!unfold_in lead_coefE horner_coef0 -memRn Rv. + rewrite (@PolyK _ 1) ?oner_eq0 //= !eqxx !rpred0 ?rpred1 ?rpredN //=. + by rewrite !andbT rpredX -memRn. + suffices [y Cy Dy2]: {y | y \in sQ (z_ m) & ofQ t w ^+ 2 == y ^+ 2}. + exists m => //; exists w; last by rewrite inE C'w. + by move: Dy2; rewrite eqf_sqr => /pred2P[]->; rewrite ?rpredN. + exists (x + i * (ofQ t v / x)). + rewrite rpredD 1?rpredM ?rpred_div //= (sQtrans (x_ m)) //. + by rewrite (sRle n) // -memRn. + rewrite rootE /horner (@PolyK _ 1) ?oner_eq0 //= ?addr0 ?mul0r in px0. + rewrite add0r mul1r -mulrA -expr2 subr_eq0 in px0. + have nz_x2: x ^+ 2 != 0. + apply: contraNneq R'w2 => y2_0; rewrite -Dw2 mulrCA. + suffices /eqP->: v == 0 by rewrite mul0r addr0. + by rewrite y2_0 mulr0 eq_sym sqrf_eq0 fmorph_eq0 in px0. + apply/eqP/esym/(mulIf nz_x2); rewrite -exprMn -rmorphX -Dw2 rmorphD rmorphM. + rewrite Dit mulrDl -expr2 mulrA divfK; last by rewrite expf_eq0 in nz_x2. + rewrite mulr_natr addrC sqrrD exprMn Di2 mulN1r -(eqP px0) -mulNr opprB. + by rewrite -mulrnAl -mulrnAr -rmorphMn -!mulrDl addrAC subrK. +have inFTA n z: (n_ z <= n)%N -> z = ofQ (z_ n) (inQ (z_ n) z). + by move/sCle=> le_zn; rewrite inQ_K ?le_zn. +pose is_cj n cj := {in R_ n, cj =1 id} /\ cj (i_ n) = - i_ n. +have /all_sig[cj_ /all_and2[cj_R cj_i]] n: {cj : 'AEnd(Q (z_ n)) | is_cj n cj}. + have cj_P: root (minPoly (R_ n) (i_ n) ^ \1%VF) (- i_ n). + rewrite minp_i -(fmorph_root (ofQ _)) !rmorphD !rmorph1 /= !map_polyXn. + by rewrite rmorphN inQ_K // rootE hornerD hornerXn hornerC sqrrN Di2 addNr. + have cj_M: ahom_in fullv (kHomExtend (R_ n) \1 (i_ n) (- i_ n)). + by rewrite -defRi -k1HomE kHomExtendP ?sub1v ?kHom1. + exists (AHom cj_M); split=> [y /kHomExtend_id->|]; first by rewrite ?id_lfunE. + by rewrite (kHomExtend_val (kHom1 1 _)). +pose conj_ n z := ofQ _ (cj_ n (inQ _ z)); pose conj z := conj_ (n_ z) z. +have conjK n m z: (n_ z <= n)%N -> (n <= m)%N -> conj_ m (conj_ n z) = z. + move/sCle=> le_z_n le_n_m; have /le_z_n/sQ_inQ[u <-] := FTA z. + have /QtoQ[Qmn QmnE]: z_ n \in sQ (z_ m) by rewrite (sCle n). + rewrite /conj_ ofQ_K -!QmnE !ofQ_K -!comp_lfunE; congr (ofQ _ _). + move: u (memRi n u); apply/eqlfun_inP/FadjoinP; split=> /=. + apply/eqlfun_inP=> y Ry; rewrite !comp_lfunE !cj_R //. + by move: Ry; rewrite -!sQof2 QmnE !inQ_K //; apply: sRle. + apply/eqlfunP; rewrite !comp_lfunE cj_i !linearN /=. + suffices ->: Qmn (i_ n) = i_ m by rewrite cj_i ?opprK. + by apply: (fmorph_inj (ofQ _)); rewrite QmnE !inQ_K. +have conjE n z: (n_ z <= n)%N -> conj z = conj_ n z. + move/leq_trans=> le_zn; set x := conj z; set y := conj_ n z. + have [m [le_xm le_ym le_nm]] := maxn3 (n_ x) (n_ y) n. + by have /conjK/=/can_in_inj := leqnn m; apply; rewrite ?conjK // le_zn. +suffices conjM: rmorphism conj. + exists (RMorphism conjM) => [z | /(_ i)/eqP/idPn[]] /=. + by have [n [/conjE-> /(conjK (n_ z))->]] := maxn3 (n_ (conj z)) (n_ z) 0%N. + rewrite /conj/conj_ cj_i rmorphN inQ_K // eq_sym -addr_eq0 -mulr2n -mulr_natl. + rewrite mulf_neq0 ?(memPnC (R'i 0%N)) ?rpred0 //. + by have /charf0P-> := ftrans (fmorph_char QtoC) (char_num _). +do 2?split=> [x y|]; last pose n1 := n_ 1. +- have [m [le_xm le_ym le_xym]] := maxn3 (n_ x) (n_ y) (n_ (x - y)). + by rewrite !(conjE m) // (inFTA m x) // (inFTA m y) -?rmorphB /conj_ ?ofQ_K. +- have [m [le_xm le_ym le_xym]] := maxn3 (n_ x) (n_ y) (n_ (x * y)). + by rewrite !(conjE m) // (inFTA m x) // (inFTA m y) -?rmorphM /conj_ ?ofQ_K. +by rewrite /conj -/n1 -(rmorph1 (ofQ (z_ n1))) /conj_ ofQ_K !rmorph1. +Qed. diff --git a/mathcomp/field/algnum.v b/mathcomp/field/algnum.v new file mode 100644 index 0000000..cff3197 --- /dev/null +++ b/mathcomp/field/algnum.v @@ -0,0 +1,835 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg finalg zmodp poly. +Require Import ssrnum ssrint rat polydiv intdiv algC matrix mxalgebra mxpoly. +Require Import vector falgebra fieldext separable galois cyclotomic. + +(******************************************************************************) +(* This file provides a few basic results and constructions in algebraic *) +(* number theory, that are used in the character theory library. Most of *) +(* these could be generalized to a more abstract setting. Note that the type *) +(* of abstract number fields is simply extFieldType rat. We define here: *) +(* x \in Crat_span X <=> x is a Q-linear combination of elements of *) +(* X : seq algC. *) +(* x \in Cint_span X <=> x is a Z-linear combination of elements of *) +(* X : seq algC. *) +(* x \in Aint <=> x : algC is an algebraic integer, i.e., the (monic) *) +(* polynomial of x over Q has integer coeficients. *) +(* (e %| a)%A <=> e divides a with respect to algebraic integers, *) +(* (e %| a)%Ax i.e., a is in the algebraic integer ideal generated *) +(* by e. This is is notation for a \in dvdA e, where *) +(* dvdv is the (collective) predicate for the Aint *) +(* ideal generated by e. As in the (e %| a)%C notation *) +(* e and a can be coerced to algC from nat or int. *) +(* The (e %| a)%Ax display form is a workaround for *) +(* design limitations of the Coq Notation facilities. *) +(* (a == b %[mod e])%A, (a != b %[mod e])%A <=> *) +(* a is equal (resp. not equal) to b mod e, i.e., a and *) +(* b belong to the same e * Aint class. We do not *) +(* force a, b and e to be algebraic integers. *) +(* #[x]%C == the multiplicative order of x, i.e., the n such that *) +(* x is an nth primitive root of unity, or 0 if x is not *) +(* a root of unity. *) +(* In addition several lemmas prove the (constructive) existence of number *) +(* fields and of automorphisms of algC. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GRing.Theory Num.Theory. +Local Open Scope ring_scope. + +Local Notation ZtoQ := (intr : int -> rat). +Local Notation ZtoC := (intr : int -> algC). +Local Notation QtoC := (ratr : rat -> algC). + +Local Notation intrp := (map_poly intr). +Local Notation pZtoQ := (map_poly ZtoQ). +Local Notation pZtoC := (map_poly ZtoC). +Local Notation pQtoC := (map_poly ratr). + +Local Hint Resolve (@intr_inj _ : injective ZtoC). +Local Notation QtoCm := [rmorphism of QtoC]. + +(* Number fields and rational spans. *) +Lemma algC_PET (s : seq algC) : + {z | exists a : nat ^ size s, z = \sum_(i < size s) s`_i *+ a i + & exists ps, s = [seq (pQtoC p).[z] | p <- ps]}. +Proof. +elim: s => [|x s [z /sig_eqW[a Dz] /sig_eqW[ps Ds]]]. + by exists 0; [exists [ffun _ => 2]; rewrite big_ord0 | exists nil]. +have r_exists (y : algC): {r | r != 0 & root (pQtoC r) y}. + have [r [_ mon_r] dv_r] := minCpolyP y. + by exists r; rewrite ?monic_neq0 ?dv_r. +suffices /sig_eqW[[n [|px [|pz []]]]// [Dpx Dpz]]: + exists np, let zn := x *+ np.1 + z in + [:: x; z] = [seq (pQtoC p).[zn] | p <- np.2]. +- exists (x *+ n + z). + exists [ffun i => oapp a n (unlift ord0 i)]. + rewrite /= big_ord_recl ffunE unlift_none Dz; congr (_ + _). + by apply: eq_bigr => i _; rewrite ffunE liftK. + exists (px :: [seq p \Po pz | p <- ps]); rewrite /= -Dpx; congr (_ :: _). + rewrite -map_comp Ds; apply: eq_map => p /=. + by rewrite map_comp_poly horner_comp -Dpz. +have [rx nz_rx rx0] := r_exists x. +have [rz nz_rz rz0] := r_exists (- z). +have char0_Q: [char rat] =i pred0 by exact: char_num. +have [n [[pz Dpz] [px Dpx]]] := char0_PET nz_rz rz0 nz_rx rx0 char0_Q. +by exists (n, [:: px; - pz]); rewrite /= !raddfN hornerN -[z]opprK Dpz Dpx. +Qed. + +Canonical subfx_unitAlgType (F L : fieldType) iota (z : L) p := + Eval hnf in [unitAlgType F of subFExtend iota z p]. + +Lemma num_field_exists (s : seq algC) : + {Qs : fieldExtType rat & {QsC : {rmorphism Qs -> algC} + & {s1 : seq Qs | map QsC s1 = s & <<1 & s1>>%VS = fullv}}}. +Proof. +have [z /sig_eqW[a Dz] /sig_eqW[ps Ds]] := algC_PET s. +suffices [Qs [QsC [z1 z1C z1gen]]]: + {Qs : fieldExtType rat & {QsC : {rmorphism Qs -> algC} & + {z1 : Qs | QsC z1 = z & forall xx, exists p, fieldExt_horner z1 p = xx}}}. +- set inQs := fieldExt_horner z1 in z1gen *; pose s1 := map inQs ps. + have inQsK p: QsC (inQs p) = (pQtoC p).[z]. + rewrite /= -horner_map z1C -map_poly_comp; congr _.[z]. + apply: eq_map_poly => b /=; apply: canRL (mulfK _) _. + by rewrite intr_eq0 denq_eq0. + rewrite /= mulrzr -rmorphMz scalerMzl -{1}[b]divq_num_den -mulrzr. + by rewrite divfK ?intr_eq0 ?denq_eq0 // scaler_int rmorph_int. + exists Qs, QsC, s1; first by rewrite -map_comp Ds (eq_map inQsK). + have sz_ps: size ps = size s by rewrite Ds size_map. + apply/vspaceP=> x; rewrite memvf; have [p {x}<-] := z1gen x. + elim/poly_ind: p => [|p b ApQs]; first by rewrite /inQs rmorph0 mem0v. + rewrite /inQs rmorphD rmorphM /= fieldExt_hornerX fieldExt_hornerC -/inQs /=. + suffices ->: z1 = \sum_(i < size s) s1`_i *+ a i. + rewrite memvD ?memvZ ?mem1v ?memvM ?memv_suml // => i _. + by rewrite rpredMn ?seqv_sub_adjoin ?mem_nth // size_map sz_ps. + apply: (fmorph_inj QsC); rewrite z1C Dz rmorph_sum; apply: eq_bigr => i _. + by rewrite rmorphMn {1}Ds !(nth_map 0) ?sz_ps //= inQsK. +have [r [Dr /monic_neq0 nz_r] dv_r] := minCpolyP z. +have rz0: root (pQtoC r) z by rewrite dv_r. +have irr_r: irreducible_poly r. + by apply/(subfx_irreducibleP rz0 nz_r)=> q qz0 nzq; rewrite dvdp_leq // -dv_r. +exists (SubFieldExtType rz0 irr_r), (subfx_inj_rmorphism QtoCm z r). +exists (subfx_root _ z r) => [|x]; first exact: subfx_inj_root. +by have{x} [p ->] := subfxEroot rz0 nz_r x; exists p. +Qed. + +Definition in_Crat_span s x := + exists a : rat ^ size s, x = \sum_i QtoC (a i) * s`_i. + +Fact Crat_span_subproof s x : decidable (in_Crat_span s x). +Proof. +have [Qxs [QxsC [[|x1 s1] // [<- <-] {x s} _]]] := num_field_exists (x :: s). +have QxsC_Z a zz: QxsC (a *: zz) = QtoC a * QxsC zz. + rewrite mulrAC; apply: (canRL (mulfK _)); first by rewrite intr_eq0 denq_eq0. + by rewrite mulrzr mulrzl -!rmorphMz scalerMzl -mulrzr -numqE scaler_int. +apply: decP (x1 \in <>%VS) _; rewrite /in_Crat_span size_map. +apply: (iffP idP) => [/coord_span-> | [a Dx]]. + move: (coord _) => a; exists [ffun i => a i x1]; rewrite rmorph_sum. + by apply: eq_bigr => i _; rewrite ffunE (nth_map 0). +have{Dx} ->: x1 = \sum_i a i *: s1`_i. + apply: (fmorph_inj QxsC); rewrite Dx rmorph_sum. + by apply: eq_bigr => i _; rewrite QxsC_Z (nth_map 0). +by apply: memv_suml => i _; rewrite memvZ ?memv_span ?mem_nth. +Qed. + +Definition Crat_span s : pred algC := Crat_span_subproof s. +Lemma Crat_spanP s x : reflect (in_Crat_span s x) (x \in Crat_span s). +Proof. exact: sumboolP. Qed. +Fact Crat_span_key s : pred_key (Crat_span s). Proof. by []. Qed. +Canonical Crat_span_keyed s := KeyedPred (Crat_span_key s). + +Lemma mem_Crat_span s : {subset s <= Crat_span s}. +Proof. +move=> _ /(nthP 0)[ix ltxs <-]; pose i0 := Ordinal ltxs. +apply/Crat_spanP; exists [ffun i => (i == i0)%:R]. +rewrite (bigD1 i0) //= ffunE eqxx // rmorph1 mul1r. +by rewrite big1 ?addr0 // => i; rewrite ffunE rmorph_nat mulr_natl => /negbTE->. +Qed. + +Fact Crat_span_zmod_closed s : zmod_closed (Crat_span s). +Proof. +split=> [|_ _ /Crat_spanP[x ->] /Crat_spanP[y ->]]. + apply/Crat_spanP; exists 0. + by apply/esym/big1=> i _; rewrite ffunE rmorph0 mul0r. +apply/Crat_spanP; exists (x - y); rewrite -sumrB; apply: eq_bigr => i _. +by rewrite -mulrBl -rmorphB !ffunE. +Qed. +Canonical Crat_span_opprPred s := OpprPred (Crat_span_zmod_closed s). +Canonical Crat_span_addrPred s := AddrPred (Crat_span_zmod_closed s). +Canonical Crat_span_zmodPred s := ZmodPred (Crat_span_zmod_closed s). + +Section MoreAlgCaut. + +Implicit Type rR : unitRingType. + +Lemma alg_num_field (Qz : fieldExtType rat) a : a%:A = ratr a :> Qz. +Proof. by rewrite -in_algE fmorph_eq_rat. Qed. + +Lemma rmorphZ_num (Qz : fieldExtType rat) rR (f : {rmorphism Qz -> rR}) a x : + f (a *: x) = ratr a * f x. +Proof. by rewrite -mulr_algl rmorphM alg_num_field fmorph_rat. Qed. + +Lemma fmorph_numZ (Qz1 Qz2 : fieldExtType rat) (f : {rmorphism Qz1 -> Qz2}) : + scalable f. +Proof. by move=> a x; rewrite rmorphZ_num -alg_num_field mulr_algl. Qed. +Definition NumLRmorphism Qz1 Qz2 f := AddLRMorphism (@fmorph_numZ Qz1 Qz2 f). + +End MoreAlgCaut. + +Section NumFieldProj. + +Variables (Qn : fieldExtType rat) (QnC : {rmorphism Qn -> algC}). + +Lemma Crat_spanZ b a : {in Crat_span b, forall x, ratr a * x \in Crat_span b}. +Proof. +move=> _ /Crat_spanP[a1 ->]; apply/Crat_spanP; exists [ffun i => a * a1 i]. +by rewrite mulr_sumr; apply: eq_bigr => i _; rewrite ffunE mulrA -rmorphM. +Qed. + +Lemma Crat_spanM b : {in Crat & Crat_span b, forall a x, a * x \in Crat_span b}. +Proof. by move=> _ x /CratP[a ->]; exact: Crat_spanZ. Qed. + +(* In principle CtoQn could be taken to be additive and Q-linear, but this *) +(* would require a limit construction. *) +Lemma num_field_proj : {CtoQn | CtoQn 0 = 0 & cancel QnC CtoQn}. +Proof. +pose b := vbasis {:Qn}. +have Qn_bC (u : {x | x \in Crat_span (map QnC b)}): {y | QnC y = sval u}. + case: u => _ /= /Crat_spanP/sig_eqW[a ->]. + exists (\sum_i a i *: b`_i); rewrite rmorph_sum; apply: eq_bigr => i _. + by rewrite rmorphZ_num (nth_map 0) // -(size_map QnC). +pose CtoQn x := oapp (fun u => sval (Qn_bC u)) 0 (insub x). +suffices QnCK: cancel QnC CtoQn by exists CtoQn; rewrite // -(rmorph0 QnC). +move=> x; rewrite /CtoQn insubT => /= [|Qn_x]; last first. + by case: (Qn_bC _) => x1 /= /fmorph_inj. +rewrite (coord_vbasis (memvf x)) rmorph_sum rpred_sum // => i _. +rewrite rmorphZ_num Crat_spanZ ?mem_Crat_span // -/b. +by rewrite -tnth_nth -tnth_map mem_tnth. +Qed. + +Lemma restrict_aut_to_num_field (nu : {rmorphism algC -> algC}) : + (forall x, exists y, nu (QnC x) = QnC y) -> + {nu0 : {lrmorphism Qn -> Qn} | {morph QnC : x / nu0 x >-> nu x}}. +Proof. +move=> Qn_nu; pose nu0 x := sval (sig_eqW (Qn_nu x)). +have QnC_nu0: {morph QnC : x / nu0 x >-> nu x}. + by rewrite /nu0 => x; case: (sig_eqW _). +suffices nu0M: rmorphism nu0 by exists (NumLRmorphism (RMorphism nu0M)). +do 2?split=> [x y|]; apply: (fmorph_inj QnC); rewrite ?QnC_nu0 ?rmorph1 //. + by rewrite ?(rmorphB, QnC_nu0). +by rewrite ?(rmorphM, QnC_nu0). +Qed. + +Lemma map_Qnum_poly (nu : {rmorphism algC -> algC}) p : + p \in polyOver 1%VS -> map_poly (nu \o QnC) p = (map_poly QnC p). +Proof. +move=> Qp; apply/polyP=> i; rewrite /= !coef_map /=. +have /vlineP[a ->]: p`_i \in 1%VS by exact: polyOverP. +by rewrite alg_num_field !fmorph_rat. +Qed. + +End NumFieldProj. + +Lemma restrict_aut_to_normal_num_field (Qn : splittingFieldType rat) + (QnC : {rmorphism Qn -> algC})(nu : {rmorphism algC -> algC}) : + {nu0 : {lrmorphism Qn -> Qn} | {morph QnC : x / nu0 x >-> nu x}}. +Proof. +apply: restrict_aut_to_num_field => x. +case: (splitting_field_normal 1%AS x) => rs /eqP Hrs. +have: root (map_poly (nu \o QnC) (minPoly 1%AS x)) (nu (QnC x)). + by rewrite fmorph_root root_minPoly. +rewrite map_Qnum_poly ?minPolyOver // Hrs. +rewrite [map_poly _ _](_:_ = \prod_(y <- map QnC rs) ('X - y%:P)); last first. + rewrite big_map rmorph_prod; apply eq_bigr => i _. + by rewrite rmorphB /= map_polyX map_polyC. +rewrite root_prod_XsubC. +by case/mapP => y _ ?; exists y. +Qed. + +(* Integral spans. *) + +Lemma dec_Cint_span (V : vectType algC) m (s : m.-tuple V) v : + decidable (inIntSpan s v). +Proof. +have s_s (i : 'I_m): s`_i \in <>%VS by rewrite memv_span ?memt_nth. +have s_Zs a: \sum_(i < m) s`_i *~ a i \in <>%VS. + by rewrite memv_suml // => i _; rewrite -scaler_int memvZ. +case s_v: (v \in <>%VS); last by right=> [[a Dv]]; rewrite Dv s_Zs in s_v. +pose IzT := {: 'I_m * 'I_(\dim <>)}; pose Iz := 'I_#|IzT|. +pose b := vbasis <>. +pose z_s := [seq coord b ij.2 (tnth s ij.1) | ij : IzT]. +pose rank2 j i: Iz := enum_rank (i, j); pose val21 (p : Iz) := (enum_val p).1. +pose inQzs w := [forall j, Crat_span z_s (coord b j w)]. +have enum_pairK j: {in predT, cancel (rank2 j) val21}. + by move=> i; rewrite /val21 enum_rankK. +have Qz_Zs a: inQzs (\sum_(i < m) s`_i *~ a i). + apply/forallP=> j; apply/Crat_spanP; rewrite /in_Crat_span size_map -cardE. + exists [ffun ij => (a (val21 ij))%:Q *+ ((enum_val ij).2 == j)]. + rewrite linear_sum {1}(reindex_onto _ _ (enum_pairK j)). + rewrite big_mkcond; apply: eq_bigr => ij _ /=; rewrite nth_image (tnth_nth 0). + rewrite (can2_eq (@enum_rankK _) (@enum_valK _)) ffunE -scaler_int /val21. + case Dij: (enum_val ij) => [i j1]; rewrite xpair_eqE eqxx /= eq_sym -mulrb. + by rewrite linearZ rmorphMn rmorph_int mulrnAl; case: eqP => // ->. +case Qz_v: (inQzs v); last by right=> [[a Dv]]; rewrite Dv Qz_Zs in Qz_v. +have [Qz [QzC [z1s Dz_s _]]] := num_field_exists z_s. +have sz_z1s: size z1s = #|IzT| by rewrite -(size_map QzC) Dz_s size_map cardE. +have xv j: {x | coord b j v = QzC x}. + apply: sig_eqW; have /Crat_spanP[x ->] := forallP Qz_v j. + exists (\sum_ij x ij *: z1s`_ij); rewrite rmorph_sum. + apply: eq_bigr => ij _; rewrite mulrAC. + apply: canLR (mulfK _) _; first by rewrite intr_eq0 denq_neq0. + rewrite mulrzr -rmorphMz scalerMzl -(mulrzr (x _)) -numqE scaler_int. + by rewrite rmorphMz mulrzl -(nth_map _ 0) ?Dz_s // -(size_map QzC) Dz_s. +pose sz := [tuple [ffun j => z1s`_(rank2 j i)] | i < m]. +have [Zsv | Zs'v] := dec_Qint_span sz [ffun j => sval (xv j)]. + left; have{Zsv} [a Dv] := Zsv; exists a. + transitivity (\sum_j \sum_(i < m) QzC ((sz`_i *~ a i) j) *: b`_j). + rewrite {1}(coord_vbasis s_v) -/b; apply: eq_bigr => j _. + rewrite -scaler_suml; congr (_ *: _). + have{Dv} /ffunP/(_ j) := Dv; rewrite sum_ffunE !ffunE -rmorph_sum => <-. + by case: (xv j). + rewrite exchange_big; apply: eq_bigr => i _. + rewrite (coord_vbasis (s_s i)) -/b mulrz_suml; apply: eq_bigr => j _. + rewrite scalerMzl ffunMzE rmorphMz; congr ((_ *~ _) *: _). + rewrite nth_mktuple ffunE -(nth_map _ 0) ?sz_z1s // Dz_s. + by rewrite nth_image enum_rankK /= (tnth_nth 0). +right=> [[a Dv]]; case: Zs'v; exists a. +apply/ffunP=> j; rewrite sum_ffunE !ffunE; apply: (fmorph_inj QzC). +case: (xv j) => /= _ <-; rewrite Dv linear_sum rmorph_sum. +apply: eq_bigr => i _; rewrite nth_mktuple raddfMz !ffunMzE rmorphMz ffunE. +by rewrite -(nth_map _ 0 QzC) ?sz_z1s // Dz_s nth_image enum_rankK -tnth_nth. +Qed. + +Definition Cint_span (s : seq algC) : pred algC := + fun x => dec_Cint_span (in_tuple [seq \row_(i < 1) y | y <- s]) (\row_i x). +Fact Cint_span_key s : pred_key (Cint_span s). Proof. by []. Qed. +Canonical Cint_span_keyed s := KeyedPred (Cint_span_key s). + +Lemma Cint_spanP n (s : n.-tuple algC) x : + reflect (inIntSpan s x) (x \in Cint_span s). +Proof. +rewrite unfold_in; case: (dec_Cint_span _ _) => [Zs_x | Zs'x] /=. + left; have{Zs_x} [] := Zs_x; rewrite /= size_map size_tuple => a /rowP/(_ 0). + rewrite !mxE => ->; exists a; rewrite summxE; apply: eq_bigr => i _. + by rewrite -scaler_int (nth_map 0) ?size_tuple // !mxE mulrzl. +right=> [[a Dx]]; have{Zs'x} [] := Zs'x. +rewrite /inIntSpan /= size_map size_tuple; exists a. +apply/rowP=> i0; rewrite !mxE summxE Dx; apply: eq_bigr => i _. +by rewrite -scaler_int mxE mulrzl (nth_map 0) ?size_tuple // !mxE. +Qed. + +Lemma mem_Cint_span s : {subset s <= Cint_span s}. +Proof. +move=> _ /(nthP 0)[ix ltxs <-]; apply/(Cint_spanP (in_tuple s)). +exists [ffun i => i == Ordinal ltxs : int]. +rewrite (bigD1 (Ordinal ltxs)) //= ffunE eqxx. +by rewrite big1 ?addr0 // => i; rewrite ffunE => /negbTE->. +Qed. + +Lemma Cint_span_zmod_closed s : zmod_closed (Cint_span s). +Proof. +have sP := Cint_spanP (in_tuple s); split=> [|_ _ /sP[x ->] /sP[y ->]]. + by apply/sP; exists 0; rewrite big1 // => i; rewrite ffunE. +apply/sP; exists (x - y); rewrite -sumrB; apply: eq_bigr => i _. +by rewrite !ffunE raddfB. +Qed. +Canonical Cint_span_opprPred s := OpprPred (Cint_span_zmod_closed s). +Canonical Cint_span_addrPred s := AddrPred (Cint_span_zmod_closed s). +Canonical Cint_span_zmodPred s := ZmodPred (Cint_span_zmod_closed s). + +(* Automorphism extensions. *) +Lemma extend_algC_subfield_aut (Qs : fieldExtType rat) + (QsC : {rmorphism Qs -> algC}) (phi : {rmorphism Qs -> Qs}) : + {nu : {rmorphism algC -> algC} | {morph QsC : x / phi x >-> nu x}}. +Proof. +pose numF_inj (Qr : fieldExtType rat) := {rmorphism Qr -> algC}. +pose subAut := {Qr : _ & numF_inj Qr * {lrmorphism Qr -> Qr}}%type. +pose SubAut := existS _ _ (_, _) : subAut. +pose Sdom (mu : subAut) := projS1 mu. +pose Sinj (mu : subAut) : {rmorphism Sdom mu -> algC} := (projS2 mu).1. +pose Saut (mu : subAut) : {rmorphism Sdom mu -> Sdom mu} := (projS2 mu).2. +have SinjZ Qr (QrC : numF_inj Qr) a x: QrC (a *: x) = QtoC a * QrC x. + rewrite mulrAC; apply: canRL (mulfK _) _. + by rewrite intr_eq0 denq_neq0. + by rewrite mulrzr mulrzl -!rmorphMz scalerMzl -scaler_int -mulrzr -numqE. +have Sinj_poly Qr (QrC : numF_inj Qr) p: + map_poly QrC (map_poly (in_alg Qr) p) = pQtoC p. +- rewrite -map_poly_comp; apply: eq_map_poly => a. + by rewrite /= SinjZ rmorph1 mulr1. +have ext1 mu0 x: {mu1 | exists y, x = Sinj mu1 y + & exists2 in01 : {lrmorphism _}, Sinj mu0 =1 Sinj mu1 \o in01 + & {morph in01: y / Saut mu0 y >-> Saut mu1 y}}. +- pose b0 := vbasis {:Sdom mu0}. + have [z _ /sig_eqW[[|px ps] // [Dx Ds]]] := algC_PET (x :: map (Sinj mu0) b0). + have [p [_ mon_p] /(_ p) pz0] := minCpolyP z; rewrite dvdpp in pz0. + have [r Dr] := closed_field_poly_normal (pQtoC p : {poly algC}). + rewrite lead_coef_map {mon_p}(monicP mon_p) rmorph1 scale1r in Dr. + have{pz0} rz: z \in r by rewrite -root_prod_XsubC -Dr. + have [Qr [QrC [rr Drr genQr]]] := num_field_exists r. + have{rz} [zz Dz]: {zz | QrC zz = z}. + by move: rz; rewrite -Drr => /mapP/sig2_eqW[zz]; exists zz. + have{ps Ds} [in01 Din01]: {in01 : {lrmorphism _} | Sinj mu0 =1 QrC \o in01}. + have in01P y: {yy | Sinj mu0 y = QrC yy}. + exists (\sum_i coord b0 i y *: (map_poly (in_alg Qr) ps`_i).[zz]). + rewrite {1}(coord_vbasis (memvf y)) !rmorph_sum; apply: eq_bigr => i _. + rewrite !SinjZ; congr (_ * _); rewrite -(nth_map _ 0) ?size_tuple // Ds. + rewrite -horner_map Dz Sinj_poly (nth_map 0) //. + by have:= congr1 size Ds; rewrite !size_map size_tuple => <-. + pose in01 y := sval (in01P y). + have Din01 y: Sinj mu0 y = QrC (in01 y) by rewrite /in01; case: (in01P y). + suffices in01M: lrmorphism in01 by exists (LRMorphism in01M). + pose rwM := (=^~ Din01, SinjZ, rmorph1, rmorphB, rmorphM). + by do 3?split; try move=> ? ?; apply: (fmorph_inj QrC); rewrite !rwM. + have {z zz Dz px Dx} Dx: exists xx, x = QrC xx. + exists (map_poly (in_alg Qr) px).[zz]. + by rewrite -horner_map Dz Sinj_poly Dx. + pose lin01 := linfun in01; pose K := (lin01 @: fullv)%VS. + have memK y: reflect (exists yy, y = in01 yy) (y \in K). + apply: (iffP memv_imgP) => [[yy _ ->] | [yy ->]]; + by exists yy; rewrite ?lfunE ?memvf. + have algK: is_aspace K. + rewrite /is_aspace has_algid1; last first. + by apply/memK; exists 1; rewrite rmorph1. + apply/prodvP=> _ _ /memK[y1 ->] /memK[y2 ->]. + by apply/memK; exists (y1 * y2); rewrite rmorphM. + have ker_in01: lker lin01 == 0%VS. + by apply/lker0P=> y1 y2; rewrite !lfunE; apply: fmorph_inj. + pose f := (lin01 \o linfun (Saut mu0) \o lin01^-1)%VF. + have Df y: f (in01 y) = in01 (Saut mu0 y). + transitivity (f (lin01 y)); first by rewrite !lfunE. + by do 4!rewrite lfunE /=; rewrite lker0_lfunK. + have hom_f: kHom 1 (ASpace algK) f. + apply/kHomP; split=> [_ _ /memK[y1 ->] /memK[y2 ->] |_ /vlineP[a ->]]. + by rewrite -rmorphM !Df !rmorphM. + by rewrite -(rmorph1 in01) -linearZ /= Df {1}linearZ /= rmorph1. + pose pr := map_poly (in_alg Qr) p. + have Qpr: pr \is a polyOver 1%VS. + by apply/polyOverP=> i; rewrite coef_map memvZ ?memv_line. + have splitQr: splittingFieldFor K pr fullv. + apply: splittingFieldForS (sub1v (Sub K algK)) (subvf _) _; exists rr => //. + congr (_ %= _): (eqpxx pr); apply: (@map_poly_inj _ _ QrC). + rewrite Sinj_poly Dr -Drr big_map rmorph_prod; apply: eq_bigr => zz _. + by rewrite rmorphB /= map_polyX map_polyC. + have [f1 aut_f1 Df1]:= kHom_extends (sub1v (ASpace algK)) hom_f Qpr splitQr. + pose nu := LRMorphism (kHom_lrmorphism aut_f1). + exists (SubAut Qr QrC nu) => //; exists in01 => //= y. + by rewrite -Df -Df1 //; apply/memK; exists y. +have phiZ: scalable phi. + move=> a y; do 2!rewrite -mulr_algl -in_algE. + by rewrite -[a]divq_num_den !(fmorph_div, rmorphM, rmorph_int). +pose fix ext n := + if n is i.+1 then oapp (fun x => s2val (ext1 (ext i) x)) (ext i) (unpickle i) + else SubAut Qs QsC (AddLRMorphism phiZ). +have mem_ext x n: (pickle x < n)%N -> {xx | Sinj (ext n) xx = x}. + move=> ltxn; apply: sig_eqW; elim: n ltxn => // n IHn. + rewrite ltnS leq_eqVlt => /predU1P[<- | /IHn[xx <-]] /=. + by rewrite pickleK /=; case: (ext1 _ x) => mu [xx]; exists xx. + case: (unpickle n) => /= [y|]; last by exists xx. + case: (ext1 _ y) => mu /= _ [in_mu inj_in_mu _]. + by exists (in_mu xx); rewrite inj_in_mu. +pose nu x := Sinj _ (Saut _ (sval (mem_ext x _ (ltnSn _)))). +have nu_inj n y: nu (Sinj (ext n) y) = Sinj (ext n) (Saut (ext n) y). + rewrite /nu; case: (mem_ext _ _ _); move: _.+1 => n1 y1 Dy /=. + without loss /subnK Dn1: n n1 y y1 Dy / (n <= n1)%N. + by move=> IH; case/orP: (leq_total n n1) => /IH => [/(_ y) | /(_ y1)]->. + elim: {n}(_ - n)%N {-1}n => [|k IHk] n in Dn1 y Dy *. + by move: y1 Dy; rewrite -Dn1 => y1 /fmorph_inj ->. + rewrite addSnnS in Dn1; move/IHk: Dn1 => /=. + case: (unpickle _) => [z|] /=; last exact. + case: (ext1 _ _) => mu /= _ [in_mu Dinj Daut]. + by rewrite Dy => /(_ _ (Dinj _))->; rewrite -Daut Dinj. +suffices nuM: rmorphism nu. + by exists (RMorphism nuM) => x; rewrite /= (nu_inj 0%N). +pose le_nu (x : algC) n := (pickle x < n)%N. +have max3 x1 x2 x3: exists n, [/\ le_nu x1 n, le_nu x2 n & le_nu x3 n]. + exists (maxn (pickle x1) (maxn (pickle x2) (pickle x3))).+1. + by apply/and3P; rewrite /le_nu !ltnS -!geq_max. +do 2?split; try move=> x1 x2. +- have [n] := max3 (x1 - x2) x1 x2. + case=> /mem_ext[y Dx] /mem_ext[y1 Dx1] /mem_ext[y2 Dx2]. + rewrite -Dx nu_inj; rewrite -Dx1 -Dx2 -rmorphB in Dx. + by rewrite (fmorph_inj _ Dx) !rmorphB -!nu_inj Dx1 Dx2. +- have [n] := max3 (x1 * x2) x1 x2. + case=> /mem_ext[y Dx] /mem_ext[y1 Dx1] /mem_ext[y2 Dx2]. + rewrite -Dx nu_inj; rewrite -Dx1 -Dx2 -rmorphM in Dx. + by rewrite (fmorph_inj _ Dx) !rmorphM -!nu_inj Dx1 Dx2. +by rewrite -(rmorph1 QsC) (nu_inj 0%N) !rmorph1. +Qed. + +(* Extended automorphisms of Q_n. *) +Lemma Qn_aut_exists k n : + coprime k n -> + {u : {rmorphism algC -> algC} | forall z, z ^+ n = 1 -> u z = z ^+ k}. +Proof. +have [-> /eqnP | n_gt0 co_k_n] := posnP n. + by rewrite gcdn0 => ->; exists [rmorphism of idfun]. +have [z prim_z] := C_prim_root_exists n_gt0. +have [Qn [QnC [[|zn []] // [Dz]]] genQn] := num_field_exists [:: z]. +pose phi := kHomExtend 1 \1 zn (zn ^+ k). +have homQn1: kHom 1 1 (\1%VF : 'End(Qn)) by rewrite kHom1. +have pzn_zk0: root (map_poly \1%VF (minPoly 1 zn)) (zn ^+ k). + rewrite -(fmorph_root QnC) rmorphX Dz -map_poly_comp. + rewrite (@eq_map_poly _ _ _ QnC) => [|a]; last by rewrite /= id_lfunE. + set p1 := map_poly _ _. + have [q1 Dp1]: exists q1, p1 = pQtoC q1. + have aP i: (minPoly 1 zn)`_i \in 1%VS. + by apply/polyOverP; exact: minPolyOver. + have{aP} a_ i := sig_eqW (vlineP _ _ (aP i)). + exists (\poly_(i < size (minPoly 1 zn)) sval (a_ i)). + apply/polyP=> i; rewrite coef_poly coef_map coef_poly /=. + case: ifP => _; rewrite ?rmorph0 //; case: (a_ i) => a /= ->. + apply: canRL (mulfK _) _; first by rewrite intr_eq0 denq_eq0. + by rewrite mulrzr -rmorphMz scalerMzl -mulrzr -numqE scaler_int rmorph_int. + have: root p1 z by rewrite -Dz fmorph_root root_minPoly. + rewrite Dp1; have [q2 [Dq2 _] ->] := minCpolyP z. + case/dvdpP=> r1 ->; rewrite rmorphM rootM /= -Dq2; apply/orP; right. + rewrite (minCpoly_cyclotomic prim_z) /cyclotomic. + rewrite (bigD1 (Ordinal (ltn_pmod k n_gt0))) ?coprime_modl //=. + by rewrite rootM root_XsubC prim_expr_mod ?eqxx. +have phiM: lrmorphism phi. + by apply/kHom_lrmorphism; rewrite -genQn span_seq1 /= kHomExtendP. +have [nu Dnu] := extend_algC_subfield_aut QnC (RMorphism phiM). +exists nu => _ /(prim_rootP prim_z)[i ->]. +rewrite rmorphX exprAC -Dz -Dnu /= -{1}[zn]hornerX /phi. +rewrite (kHomExtend_poly homQn1) ?polyOverX //. +rewrite map_polyE map_id_in => [|?]; last by rewrite id_lfunE. +by rewrite polyseqK hornerX rmorphX. +Qed. + +(* Algebraic integers. *) + +Definition Aint : pred_class := + fun x : algC => minCpoly x \is a polyOver Cint. +Fact Aint_key : pred_key Aint. Proof. by []. Qed. +Canonical Aint_keyed := KeyedPred Aint_key. + +Lemma root_monic_Aint p x : + root p x -> p \is monic -> p \is a polyOver Cint -> x \in Aint. +Proof. +have pZtoQtoC pz: pQtoC (pZtoQ pz) = pZtoC pz. + by rewrite -map_poly_comp; apply: eq_map_poly => b; rewrite /= rmorph_int. +move=> px0 mon_p /floorCpP[pz Dp]; rewrite unfold_in. +move: px0; rewrite Dp -pZtoQtoC; have [q [-> mon_q] ->] := minCpolyP x. +case/dvdpP_rat_int=> qz [a nz_a Dq] [r]. +move/(congr1 (fun q1 => lead_coef (a *: pZtoQ q1))). +rewrite rmorphM scalerAl -Dq lead_coefZ lead_coefM /=. +have /monicP->: pZtoQ pz \is monic by rewrite -(map_monic QtoCm) pZtoQtoC -Dp. +rewrite (monicP mon_q) mul1r mulr1 lead_coef_map_inj //; last exact: intr_inj. +rewrite Dq => ->; apply/polyOverP=> i; rewrite !(coefZ, coef_map). +by rewrite -rmorphM /= rmorph_int Cint_int. +Qed. + +Lemma Cint_rat_Aint z : z \in Crat -> z \in Aint -> z \in Cint. +Proof. +case/CratP=> a ->{z} /polyOverP/(_ 0%N). +have [p [Dp mon_p] dv_p] := minCpolyP (ratr a); rewrite Dp coef_map. +suffices /eqP->: p == 'X - a%:P by rewrite polyseqXsubC /= rmorphN rpredN. +rewrite -eqp_monic ?monicXsubC // irredp_XsubC //. + by rewrite -(size_map_poly QtoCm) -Dp neq_ltn size_minCpoly orbT. +by rewrite -dv_p fmorph_root root_XsubC. +Qed. + +Lemma Aint_Cint : {subset Cint <= Aint}. +Proof. +move=> x; rewrite -polyOverXsubC. +by apply: root_monic_Aint; rewrite ?monicXsubC ?root_XsubC. +Qed. + +Lemma Aint_int x : x%:~R \in Aint. +Proof. by rewrite Aint_Cint ?Cint_int. Qed. + +Lemma Aint0 : 0 \in Aint. Proof. exact: (Aint_int 0). Qed. +Lemma Aint1 : 1 \in Aint. Proof. exact: (Aint_int 1). Qed. +Hint Resolve Aint0 Aint1. + +Lemma Aint_unity_root n x : (n > 0)%N -> n.-unity_root x -> x \in Aint. +Proof. +move=> n_gt0 xn1; apply: root_monic_Aint xn1 (monic_Xn_sub_1 _ n_gt0) _. +by apply/polyOverP=> i; rewrite coefB coefC -mulrb coefXn /= rpredB ?rpred_nat. +Qed. + +Lemma Aint_prim_root n z : n.-primitive_root z -> z \in Aint. +Proof. +move=> pr_z; apply/(Aint_unity_root (prim_order_gt0 pr_z))/unity_rootP. +exact: prim_expr_order. +Qed. + +Lemma Aint_Cnat : {subset Cnat <= Aint}. +Proof. by move=> z /Cint_Cnat/Aint_Cint. Qed. + +(* This is Isaacs, Lemma (3.3) *) +Lemma Aint_subring_exists (X : seq algC) : + {subset X <= Aint} -> + {S : pred algC & + (*a*) subring_closed S + /\ (*b*) {subset X <= S} + & (*c*) {Y : {n : nat & n.-tuple algC} & + {subset tagged Y <= S} + & forall x, reflect (inIntSpan (tagged Y) x) (x \in S)}}. +Proof. +move=> AZ_X; pose m := (size X).+1. +pose n (i : 'I_m) := (size (minCpoly X`_i)).-2; pose N := (\max_i n i).+1. +pose IY := family (fun i => [pred e : 'I_N | e <= n i]%N). +have IY_0: 0 \in IY by apply/familyP=> // i; rewrite ffunE. +pose inIY := enum_rank_in IY_0. +pose Y := [seq \prod_(i < m) X`_i ^+ (f : 'I_N ^ m) i | f in IY]. +have S_P := Cint_spanP [tuple of Y]; set S := Cint_span _ in S_P. +have sYS: {subset Y <= S} by exact: mem_Cint_span. +have S_1: 1 \in S. + by apply/sYS/imageP; exists 0 => //; rewrite big1 // => i; rewrite ffunE. +have SmulX (i : 'I_m): {in S, forall x, x * X`_i \in S}. + move=> _ /S_P[x ->]; rewrite mulr_suml rpred_sum // => j _. + rewrite mulrzAl rpredMz {x}// nth_image mulrC (bigD1 i) //= mulrA -exprS. + move: {j}(enum_val j) (familyP (enum_valP j)) => f fP. + have:= fP i; rewrite inE /= leq_eqVlt => /predU1P[-> | fi_ltn]; last first. + apply/sYS/imageP; have fiK: (inord (f i).+1 : 'I_N) = (f i).+1 :> nat. + by rewrite inordK // ltnS (bigmax_sup i). + exists (finfun [eta f with i |-> inord (f i).+1]). + apply/familyP=> i1; rewrite inE ffunE /= fun_if fiK. + by case: eqP => [-> // | _]; exact: fP. + rewrite (bigD1 i isT) ffunE /= eqxx fiK; congr (_ * _). + by apply: eq_bigr => i1; rewrite ffunE /= => /negPf->. + have [/monicP ] := (minCpoly_monic X`_i, root_minCpoly X`_i). + rewrite /root horner_coef lead_coefE -(subnKC (size_minCpoly _)) subn2. + rewrite big_ord_recr /= addrC addr_eq0 => ->; rewrite mul1r => /eqP->. + have /floorCpP[p Dp]: X`_i \in Aint. + by have [/(nth_default 0)-> | /(mem_nth 0)/AZ_X] := leqP (size X) i. + rewrite -/(n i) Dp mulNr rpredN // mulr_suml rpred_sum // => [[e le_e]] /= _. + rewrite coef_map -mulrA mulrzl rpredMz ?sYS //; apply/imageP. + have eK: (inord e : 'I_N) = e :> nat by rewrite inordK // ltnS (bigmax_sup i). + exists (finfun [eta f with i |-> inord e]). + apply/familyP=> i1; rewrite inE ffunE /= fun_if eK. + by case: eqP => [-> // | _]; exact: fP. + rewrite (bigD1 i isT) ffunE /= eqxx eK; congr (_ * _). + by apply: eq_bigr => i1; rewrite ffunE /= => /negPf->. +exists S; last by exists (Tagged (fun n => n.-tuple _) [tuple of Y]). +split=> [|x Xx]; last first. + by rewrite -[x]mul1r -(nth_index 0 Xx) (SmulX (Ordinal _)) // ltnS index_size. +split=> // x y Sx Sy; first by rewrite rpredB. +case/S_P: Sy => {y}[y ->]; rewrite mulr_sumr rpred_sum //= => j. +rewrite mulrzAr rpredMz {y}// nth_image; move: {j}(enum_val j) => f. +elim/big_rec: _ => [|i y _ IHy] in x Sx *; first by rewrite mulr1. +rewrite mulrA {y}IHy //. +elim: {f}(f i : nat) => [|e IHe] in x Sx *; first by rewrite mulr1. +by rewrite exprS mulrA IHe // SmulX. +Qed. + +Section AlgIntSubring. + +Import DefaultKeying GRing.DefaultPred perm. + +(* This is Isaacs, Theorem (3.4). *) +Theorem fin_Csubring_Aint S n (Y : n.-tuple algC) : + mulr_closed S -> (forall x, reflect (inIntSpan Y x) (x \in S)) -> + {subset S <= Aint}. +Proof. +have ZP_C c: (ZtoC c)%:P \is a polyOver Cint by rewrite raddfMz rpred_int. +move=> mulS S_P x Sx; pose v := \row_(i < n) Y`_i. +have [v0 | nz_v] := eqVneq v 0. + case/S_P: Sx => {x}x ->; rewrite big1 ?isAlgInt0 // => i _. + by have /rowP/(_ i) := v0; rewrite !mxE => ->; rewrite mul0rz. +have sYS (i : 'I_n): x * Y`_i \in S. + by rewrite rpredM //; apply/S_P/Cint_spanP/mem_Cint_span/memt_nth. +pose A := \matrix_(i, j < n) sval (sig_eqW (S_P _ (sYS j))) i. +pose p := char_poly (map_mx ZtoC A). +have: p \is a polyOver Cint. + rewrite rpred_sum // => s _; rewrite rpredMsign rpred_prod // => j _. + by rewrite !mxE /= rpredB ?rpredMn ?polyOverX. +apply: root_monic_Aint (char_poly_monic _). +rewrite -eigenvalue_root_char; apply/eigenvalueP; exists v => //. +apply/rowP=> j; case dAj: (sig_eqW (S_P _ (sYS j))) => [a DxY]. +by rewrite !mxE DxY; apply: eq_bigr => i _; rewrite !mxE dAj /= mulrzr. +Qed. + +(* This is Isaacs, Corollary (3.5). *) +Corollary Aint_subring : subring_closed Aint. +Proof. +suff rAZ: {in Aint &, forall x y, (x - y \in Aint) * (x * y \in Aint)}. + by split=> // x y AZx AZy; rewrite rAZ. +move=> x y AZx AZy. +have [|S [ringS] ] := @Aint_subring_exists [:: x; y]; first exact/allP/and3P. +move=> /allP/and3P[Sx Sy _] [Y _ genYS]. +have AZ_S := fin_Csubring_Aint ringS genYS. +by have [_ S_B S_M] := ringS; rewrite !AZ_S ?S_B ?S_M. +Qed. +Canonical Aint_opprPred := OpprPred Aint_subring. +Canonical Aint_addrPred := AddrPred Aint_subring. +Canonical Aint_mulrPred := MulrPred Aint_subring. +Canonical Aint_zmodPred := ZmodPred Aint_subring. +Canonical Aint_semiringPred := SemiringPred Aint_subring. +Canonical Aint_smulrPred := SmulrPred Aint_subring. +Canonical Aint_subringPred := SubringPred Aint_subring. + +End AlgIntSubring. + +Lemma Aint_aut (nu : {rmorphism algC -> algC}) x : + (nu x \in Aint) = (x \in Aint). +Proof. by rewrite !unfold_in minCpoly_aut. Qed. + +Definition dvdA (e : Algebraics.divisor) : pred_class := + fun z : algC => if e == 0 then z == 0 else z / e \in Aint. +Fact dvdA_key e : pred_key (dvdA e). Proof. by []. Qed. +Canonical dvdA_keyed e := KeyedPred (dvdA_key e). +Delimit Scope algC_scope with A. +Delimit Scope algC_expanded_scope with Ax. +Notation "e %| x" := (x \in dvdA e) : algC_expanded_scope. +Notation "e %| x" := (@in_mem Algebraics.divisor x (mem (dvdA e))) : algC_scope. + +Fact dvdA_zmod_closed e : zmod_closed (dvdA e). +Proof. +split=> [|x y]; first by rewrite unfold_in mul0r eqxx rpred0 ?if_same. +rewrite ![(e %| _)%A]unfold_in. +case: ifP => [_ x0 /eqP-> | _]; first by rewrite subr0. +by rewrite mulrBl; apply: rpredB. +Qed. +Canonical dvdA_opprPred e := OpprPred (dvdA_zmod_closed e). +Canonical dvdA_addrPred e := AddrPred (dvdA_zmod_closed e). +Canonical dvdA_zmodPred e := ZmodPred (dvdA_zmod_closed e). + +Definition eqAmod (e x y : Algebraics.divisor) := (e %| x - y)%A. +Notation "x == y %[mod e ]" := (eqAmod e x y) : algC_scope. +Notation "x != y %[mod e ]" := (~~ (eqAmod e x y)) : algC_scope. + +Lemma eqAmod_refl e x : (x == x %[mod e])%A. +Proof. by rewrite /eqAmod subrr rpred0. Qed. +Hint Resolve eqAmod_refl. + +Lemma eqAmod_sym e x y : ((x == y %[mod e]) = (y == x %[mod e]))%A. +Proof. by rewrite /eqAmod -opprB rpredN. Qed. + +Lemma eqAmod_trans e y x z : + (x == y %[mod e] -> y == z %[mod e] -> x == z %[mod e])%A. +Proof. by move=> Exy Eyz; rewrite /eqAmod -[x](subrK y) -addrA rpredD. Qed. + +Lemma eqAmod_transl e x y z : + (x == y %[mod e])%A -> (x == z %[mod e])%A = (y == z %[mod e])%A. +Proof. by move/(sym_left_transitive (eqAmod_sym e) (@eqAmod_trans e)). Qed. + +Lemma eqAmod_transr e x y z : + (x == y %[mod e])%A -> (z == x %[mod e])%A = (z == y %[mod e])%A. +Proof. by move/(sym_right_transitive (eqAmod_sym e) (@eqAmod_trans e)). Qed. + +Lemma eqAmod0 e x : (x == 0 %[mod e])%A = (e %| x)%A. +Proof. by rewrite /eqAmod subr0. Qed. + +Lemma eqAmodN e x y : (- x == y %[mod e])%A = (x == - y %[mod e])%A. +Proof. by rewrite eqAmod_sym /eqAmod !opprK addrC. Qed. + +Lemma eqAmodDr e x y z : (y + x == z + x %[mod e])%A = (y == z %[mod e])%A. +Proof. by rewrite /eqAmod addrAC opprD !addrA subrK. Qed. + +Lemma eqAmodDl e x y z : (x + y == x + z %[mod e])%A = (y == z %[mod e])%A. +Proof. by rewrite !(addrC x) eqAmodDr. Qed. + +Lemma eqAmodD e x1 x2 y1 y2 : + (x1 == x2 %[mod e] -> y1 == y2 %[mod e] -> x1 + y1 == x2 + y2 %[mod e])%A. +Proof. rewrite -(eqAmodDl e x2 y1) -(eqAmodDr e y1); exact: eqAmod_trans. Qed. + +Lemma eqAmodm0 e : (e == 0 %[mod e])%A. +Proof. by rewrite /eqAmod subr0 unfold_in; case: ifPn => // /divff->. Qed. +Hint Resolve eqAmodm0. + +Lemma eqAmodMr e : + {in Aint, forall z x y, x == y %[mod e] -> x * z == y * z %[mod e]}%A. +Proof. +move=> z Zz x y. +rewrite /eqAmod -mulrBl ![(e %| _)%A]unfold_in mulf_eq0 mulrAC. +by case: ifP => [_ -> // | _ Exy]; apply: rpredM. +Qed. + +Lemma eqAmodMl e : + {in Aint, forall z x y, x == y %[mod e] -> z * x == z * y %[mod e]}%A. +Proof. by move=> z Zz x y Exy; rewrite !(mulrC z) eqAmodMr. Qed. + +Lemma eqAmodMl0 e : {in Aint, forall x, x * e == 0 %[mod e]}%A. +Proof. by move=> x Zx; rewrite -(mulr0 x) eqAmodMl. Qed. + +Lemma eqAmodMr0 e : {in Aint, forall x, e * x == 0 %[mod e]}%A. +Proof. by move=> x Zx; rewrite /= mulrC eqAmodMl0. Qed. + +Lemma eqAmod_addl_mul e : {in Aint, forall x y, x * e + y == y %[mod e]}%A. +Proof. by move=> x Zx y; rewrite -{2}[y]add0r eqAmodDr eqAmodMl0. Qed. + +Lemma eqAmodM e : {in Aint &, forall x1 y2 x2 y1, + x1 == x2 %[mod e] -> y1 == y2 %[mod e] -> x1 * y1 == x2 * y2 %[mod e]}%A. +Proof. +move=> x1 y2 Zx1 Zy2 x2 y1 eq_x /(eqAmodMl Zx1)/eqAmod_trans-> //. +exact: eqAmodMr. +Qed. + +Lemma eqAmod_rat : + {in Crat & &, forall e m n, (m == n %[mod e])%A = (m == n %[mod e])%C}. +Proof. +move=> e m n Qe Qm Qn; rewrite /eqCmod unfold_in /eqAmod unfold_in. +case: ifPn => // nz_e; apply/idP/idP=> [/Cint_rat_Aint | /Aint_Cint] -> //. +by rewrite rpred_div ?rpredB. +Qed. + +Lemma eqAmod0_rat : {in Crat &, forall e n, (n == 0 %[mod e])%A = (e %| n)%C}. +Proof. by move=> e n Qe Qn; rewrite /= eqAmod_rat /eqCmod ?subr0 ?Crat0. Qed. + +Lemma eqAmod_nat (e m n : nat) : (m == n %[mod e])%A = (m == n %[mod e])%N. +Proof. by rewrite eqAmod_rat ?rpred_nat // eqCmod_nat. Qed. + +Lemma eqAmod0_nat (e m : nat) : (m == 0 %[mod e])%A = (e %| m)%N. +Proof. by rewrite eqAmod0_rat ?rpred_nat // dvdC_nat. Qed. + +(* Multiplicative order. *) + +Definition orderC x := + let p := minCpoly x in + oapp val 0%N [pick n : 'I_(2 * size p ^ 2) | p == intrp 'Phi_n]. + +Notation "#[ x ]" := (orderC x) : C_scope. + +Lemma exp_orderC x : x ^+ #[x]%C = 1. +Proof. +rewrite /orderC; case: pickP => //= [] [n _] /= /eqP Dp. +have n_gt0: (0 < n)%N. + rewrite lt0n; apply: contraTneq (size_minCpoly x) => n0. + by rewrite Dp n0 Cyclotomic0 rmorph1 size_poly1. +have [z prim_z] := C_prim_root_exists n_gt0. +rewrite prim_expr_order // -(root_cyclotomic prim_z). +by rewrite -Cintr_Cyclotomic // -Dp root_minCpoly. +Qed. + +Lemma dvdn_orderC x n : (#[x]%C %| n)%N = (x ^+ n == 1). +Proof. +apply/idP/eqP=> [|x_n_1]; first by apply: expr_dvd; apply: exp_orderC. +have [-> | n_gt0] := posnP n; first by rewrite dvdn0. +have [m prim_x m_dv_n] := prim_order_exists n_gt0 x_n_1. +have{n_gt0} m_gt0 := dvdn_gt0 n_gt0 m_dv_n; congr (_ %| n)%N: m_dv_n. +pose p := minCpoly x; have Dp: p = cyclotomic x m := minCpoly_cyclotomic prim_x. +rewrite /orderC; case: pickP => /= [k /eqP Dp_k | no_k]; last first. + suffices lt_m_2p: (m < 2 * size p ^ 2)%N. + have /eqP[] := no_k (Ordinal lt_m_2p). + by rewrite /= -/p Dp -Cintr_Cyclotomic. + rewrite Dp size_cyclotomic (sqrnD 1) addnAC mulnDr -add1n leq_add //. + suffices: (m <= \prod_(q <- primes m | q == 2) q * totient m ^ 2)%N. + have [m_even | m_odd] := boolP (2 \in primes m). + by rewrite -big_filter filter_pred1_uniq ?primes_uniq // big_seq1. + by rewrite big_hasC ?has_pred1 // => /leq_trans-> //; apply: leq_addl. + rewrite big_mkcond totientE // -mulnn -!big_split /=. + rewrite {1}[m]prod_prime_decomp // prime_decompE big_map /= !big_seq. + elim/big_ind2: _ => // [n1 m1 n2 m2 | q]; first exact: leq_mul. + rewrite mem_primes => /and3P[q_pr _ q_dv_m]. + rewrite lognE q_pr m_gt0 q_dv_m /=; move: (logn q _) => k. + rewrite !mulnA expnS leq_mul //. + case: (ltngtP q) => // [|q_gt2 | ->]; first by rewrite ltnNge prime_gt1. + rewrite mul1n mulnAC mulnn -{1}[q]muln1 leq_mul ?expn_gt0 ?prime_gt0 //. + by rewrite -(subnKC q_gt2) (ltn_exp2l 1). + by rewrite !muln1 -expnS (ltn_exp2l 0). +have k_prim_x: k.-primitive_root x. + have k_gt0: (0 < k)%N. + rewrite lt0n; apply: contraTneq (size_minCpoly x) => k0. + by rewrite Dp_k k0 Cyclotomic0 rmorph1 size_poly1. + have [z prim_z] := C_prim_root_exists k_gt0. + rewrite -(root_cyclotomic prim_z) -Cintr_Cyclotomic //. + by rewrite -Dp_k root_minCpoly. +apply/eqP; rewrite eqn_dvd !(@prim_order_dvd _ _ x) //. +by rewrite !prim_expr_order ?eqxx. +Qed. diff --git a/mathcomp/field/all.v b/mathcomp/field/all.v new file mode 100644 index 0000000..a57ac19 --- /dev/null +++ b/mathcomp/field/all.v @@ -0,0 +1,11 @@ +Require Export algC. +Require Export algebraics_fundamentals. +Require Export algnum. +Require Export closed_field. +Require Export countalg. +Require Export cyclotomic. +Require Export falgebra. +Require Export fieldext. +Require Export finfield. +Require Export galois. +Require Export separable. diff --git a/mathcomp/field/closed_field.v b/mathcomp/field/closed_field.v new file mode 100644 index 0000000..edd27c5 --- /dev/null +++ b/mathcomp/field/closed_field.v @@ -0,0 +1,634 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq. +Require Import bigop ssralg poly polydiv. + +(******************************************************************************) +(* A proof that algebraically closed field enjoy quantifier elimination, *) +(* as described in *) +(* ``A formal quantifier elimination for algebraically closed fields'', *) +(* proceedings of Calculemus 2010, by Cyril Cohen and Assia Mahboubi *) +(* *) +(* This file constructs an instance of quantifier elimination mixin, *) +(* (see the ssralg library) from the theory of polynomials with coefficients *) +(* is an algebraically closed field (see the polydiv library). *) +(* *) +(* This file hence deals with the transformation of formulae part, which we *) +(* address by implementing one CPS style formula transformer per effective *) +(* operation involved in the proof of quantifier elimination. See the paper *) +(* for more details. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GRing. +Local Open Scope ring_scope. + +Import Pdiv.Ring. +Import PreClosedField. + +Section ClosedFieldQE. + +Variable F : Field.type. + +Variable axiom : ClosedField.axiom F. + +Notation fF := (formula F). +Notation qf f := (qf_form f && rformula f). + +Definition polyF := seq (term F). + +Fixpoint eval_poly (e : seq F) pf := + if pf is c::q then (eval_poly e q)*'X + (eval e c)%:P else 0. + +Definition rpoly (p : polyF) := all (@rterm F) p. + +Fixpoint sizeT (k : nat -> fF) (p : polyF) := + if p is c::q then + sizeT (fun n => + if n is m.+1 then k m.+2 else + GRing.If (c == 0) (k 0%N) (k 1%N)) q + else k O%N. + + +Lemma sizeTP (k : nat -> formula F) (pf : polyF) (e : seq F) : + qf_eval e (sizeT k pf) = qf_eval e (k (size (eval_poly e pf))). +Proof. +elim: pf e k; first by move=> *; rewrite size_poly0. +move=> c qf Pqf e k; rewrite Pqf. +rewrite size_MXaddC -(size_poly_eq0 (eval_poly _ _)). +by case: (size (eval_poly e qf))=> //=; case: eqP; rewrite // orbF. +Qed. + +Lemma sizeT_qf (k : nat -> formula F) (p : polyF) : + (forall n, qf (k n)) -> rpoly p -> qf (sizeT k p). +Proof. +elim: p k => /= [|c q ihp] k kP rp; first exact: kP. +case/andP: rp=> rc rq. +apply: ihp; rewrite ?rq //; case=> [|n]; last exact: kP. +have [/andP[qf0 rf0] /andP[qf1 rf1]] := (kP 0, kP 1)%N. +by rewrite If_form_qf ?If_form_rf //= andbT. +Qed. + +Definition isnull (k : bool -> fF) (p : polyF) := + sizeT (fun n => k (n == 0%N)) p. + +Lemma isnullP (k : bool -> formula F) (p : polyF) (e : seq F) : + qf_eval e (isnull k p) = qf_eval e (k (eval_poly e p == 0)). +Proof. by rewrite sizeTP size_poly_eq0. Qed. + +Lemma isnull_qf (k : bool -> formula F) (p : polyF) : + (forall b, qf (k b)) -> rpoly p -> qf (isnull k p). +Proof. by move=> *; apply: sizeT_qf. Qed. + +Definition lt_sizeT (k : bool -> fF) (p q : polyF) : fF := + sizeT (fun n => sizeT (fun m => k (n [|p c]; first by rewrite /lift polyseq0. +rewrite -cons_poly_def /lift polyseq_cons /nilp. +case pn0: (_ == _) => /=; last by move->; rewrite -cons_poly_def. +move=> _; rewrite polyseqC. +case c0: (_==_)=> /=. + move: pn0; rewrite (eqP c0) size_poly_eq0; move/eqP->. + by apply:val_inj=> /=; rewrite polyseq_cons // polyseq0. +by rewrite mul0r add0r; apply:val_inj=> /=; rewrite polyseq_cons // /nilp pn0. +Qed. + +Fixpoint lead_coefT (k : term F -> fF) p := + if p is c::q then + lead_coefT (fun l => GRing.If (l == 0) (k c) (k l)) q + else k (Const 0). + +Lemma lead_coefTP (k : term F -> formula F) : + (forall x e, qf_eval e (k x) = qf_eval e (k (Const (eval e x)))) -> + forall (p : polyF) (e : seq F), + qf_eval e (lead_coefT k p) = qf_eval e (k (Const (lead_coef (eval_poly e p)))). +Proof. +move=> Pk p e; elim: p k Pk => /= [*|a p' Pp' k Pk]; first by rewrite lead_coef0. +rewrite Pp'; last by move=> *; rewrite //= -Pk. +rewrite GRing.eval_If /= lead_coef_eq0. +case p'0: (_ == _); first by rewrite (eqP p'0) mul0r add0r lead_coefC -Pk. +rewrite lead_coefDl ?lead_coefMX // polyseqC size_mul ?p'0 //; last first. + by rewrite -size_poly_eq0 size_polyX. +rewrite size_polyX addnC /=; case: (_ == _)=> //=. +by rewrite ltnS lt0n size_poly_eq0 p'0. +Qed. + +Lemma lead_coefT_qf (k : term F -> formula F) (p : polyF) : + (forall c, rterm c -> qf (k c)) -> rpoly p -> qf (lead_coefT k p). +Proof. +elim: p k => /= [|c q ihp] k kP rp; first exact: kP. +move: rp; case/andP=> rc rq; apply: ihp; rewrite ?rq // => l rl. +have [/andP[qfc rfc] /andP[qfl rfl]] := (kP c rc, kP l rl). +by rewrite If_form_qf ?If_form_rf //= andbT. +Qed. + +Fixpoint amulXnT (a : term F) (n : nat) : polyF := + if n is n'.+1 then (Const 0) :: (amulXnT a n') else [::a]. + +Lemma eval_amulXnT (a : term F) (n : nat) (e : seq F) : + eval_poly e (amulXnT a n) = (eval e a)%:P * 'X^n. +Proof. +elim: n=> [|n] /=; first by rewrite expr0 mulr1 mul0r add0r. +by move->; rewrite addr0 -mulrA -exprSr. +Qed. + +Lemma ramulXnT: forall a n, rterm a -> rpoly (amulXnT a n). +Proof. by move=> a n; elim: n a=> [a /= -> //|n ihn a ra]; apply: ihn. Qed. + +Fixpoint sumpT (p q : polyF) := + if p is a::p' then + if q is b::q' then (Add a b)::(sumpT p' q') + else p + else q. + +Lemma eval_sumpT (p q : polyF) (e : seq F) : + eval_poly e (sumpT p q) = (eval_poly e p) + (eval_poly e q). +Proof. +elim: p q => [|a p Hp] q /=; first by rewrite add0r. +case: q => [|b q] /=; first by rewrite addr0. +rewrite Hp mulrDl -!addrA; congr (_+_); rewrite polyC_add addrC -addrA. +by congr (_+_); rewrite addrC. +Qed. + +Lemma rsumpT (p q : polyF) : rpoly p -> rpoly q -> rpoly (sumpT p q). +Proof. +elim: p q=> [|a p ihp] q rp rq //; move: rp; case/andP=> ra rp. +case: q rq => [|b q]; rewrite /= ?ra ?rp //=. +by case/andP=> -> rq //=; apply: ihp. +Qed. + +Fixpoint mulpT (p q : polyF) := + if p is a :: p' then sumpT (map (Mul a) q) (Const 0::(mulpT p' q)) else [::]. + +Lemma eval_mulpT (p q : polyF) (e : seq F) : + eval_poly e (mulpT p q) = (eval_poly e p) * (eval_poly e q). +Proof. +elim: p q=> [|a p Hp] q /=; first by rewrite mul0r. +rewrite eval_sumpT /= Hp addr0 mulrDl addrC mulrAC; congr (_+_). +elim: q=> [|b q Hq] /=; first by rewrite mulr0. +by rewrite Hq polyC_mul mulrDr mulrA. +Qed. + +Lemma rpoly_map_mul (t : term F) (p : polyF) (rt : rterm t) : + rpoly (map (Mul t) p) = rpoly p. +Proof. +by rewrite /rpoly all_map /= (@eq_all _ _ (@rterm _)) // => x; rewrite /= rt. +Qed. + +Lemma rmulpT (p q : polyF) : rpoly p -> rpoly q -> rpoly (mulpT p q). +Proof. +elim: p q=> [|a p ihp] q rp rq //=; move: rp; case/andP=> ra rp /=. +apply: rsumpT; last exact: ihp. +by rewrite rpoly_map_mul. +Qed. + +Definition opppT := map (Mul (@Const F (-1))). + +Lemma eval_opppT (p : polyF) (e : seq F) : + eval_poly e (opppT p) = - eval_poly e p. +Proof. +by elim: p; rewrite /= ?oppr0 // => ? ? ->; rewrite !mulNr opprD polyC_opp mul1r. +Qed. + +Definition natmulpT n := map (Mul (@NatConst F n)). + +Lemma eval_natmulpT (p : polyF) (n : nat) (e : seq F) : + eval_poly e (natmulpT n p) = (eval_poly e p) *+ n. +Proof. +elim: p; rewrite //= ?mul0rn // => c p ->. +rewrite mulrnDl mulr_natl polyC_muln; congr (_+_). +by rewrite -mulr_natl mulrAC -mulrA mulr_natl mulrC. +Qed. + +Fixpoint redivp_rec_loopT (q : polyF) sq cq (k : nat * polyF * polyF -> fF) + (c : nat) (qq r : polyF) (n : nat) {struct n}:= + sizeT (fun sr => + if sr < sq then k (c, qq, r) else + lead_coefT (fun lr => + let m := amulXnT lr (sr - sq) in + let qq1 := sumpT (mulpT qq [::cq]) m in + let r1 := sumpT (mulpT r ([::cq])) (opppT (mulpT m q)) in + if n is n1.+1 then redivp_rec_loopT q sq cq k c.+1 qq1 r1 n1 + else k (c.+1, qq1, r1) + ) r + ) r. + +Fixpoint redivp_rec_loop (q : {poly F}) sq cq + (k : nat) (qq r : {poly F})(n : nat) {struct n} := + if size r < sq then (k, qq, r) else + let m := (lead_coef r) *: 'X^(size r - sq) in + let qq1 := qq * cq%:P + m in + let r1 := r * cq%:P - m * q in + if n is n1.+1 then redivp_rec_loop q sq cq k.+1 qq1 r1 n1 else + (k.+1, qq1, r1). + +Lemma redivp_rec_loopTP (k : nat * polyF * polyF -> formula F) : + (forall c qq r e, qf_eval e (k (c,qq,r)) + = qf_eval e (k (c, lift (eval_poly e qq), lift (eval_poly e r)))) + -> forall q sq cq c qq r n e + (d := redivp_rec_loop (eval_poly e q) sq (eval e cq) + c (eval_poly e qq) (eval_poly e r) n), + qf_eval e (redivp_rec_loopT q sq cq k c qq r n) + = qf_eval e (k (d.1.1, lift d.1.2, lift d.2)). +Proof. +move=> Pk q sq cq c qq r n e /=. +elim: n c qq r k Pk e => [|n Pn] c qq r k Pk e; rewrite sizeTP. + case ltrq : (_ < _); first by rewrite /= ltrq /= -Pk. + rewrite lead_coefTP => [|a p]; rewrite Pk. + rewrite ?(eval_mulpT,eval_amulXnT,eval_sumpT,eval_opppT) //=. + by rewrite ltrq //= mul_polyC ?(mul0r,add0r). + by symmetry; rewrite Pk ?(eval_mulpT,eval_amulXnT,eval_sumpT, eval_opppT). +case ltrq : (_<_); first by rewrite /= ltrq Pk. +rewrite lead_coefTP. + rewrite Pn ?(eval_mulpT,eval_amulXnT,eval_sumpT,eval_opppT) //=. + by rewrite ltrq //= mul_polyC ?(mul0r,add0r). +rewrite -/redivp_rec_loopT => x e'. +rewrite Pn; last by move=>*; rewrite Pk. +symmetry; rewrite Pn; last by move=>*; rewrite Pk. +rewrite Pk ?(eval_lift,eval_mulpT,eval_amulXnT,eval_sumpT,eval_opppT). +by rewrite mul_polyC ?(mul0r,add0r). +Qed. + +Lemma redivp_rec_loopT_qf (q : polyF) (sq : nat) (cq : term F) + (k : nat * polyF * polyF -> formula F) (c : nat) (qq r : polyF) (n : nat) : + (forall r, [&& rpoly r.1.2 & rpoly r.2] -> qf (k r)) -> + rpoly q -> rterm cq -> rpoly qq -> rpoly r -> + qf (redivp_rec_loopT q sq cq k c qq r n). +Proof. +elim: n q sq cq k c qq r => [|n ihn] q sq cq k c qq r kP rq rcq rqq rr. + apply: sizeT_qf=> // n; case: (_ < _); first by apply: kP; rewrite // rqq rr. + apply: lead_coefT_qf=> // l rl; apply: kP. + by rewrite /= ?(rsumpT,rmulpT,ramulXnT,rpoly_map_mul) //= rcq. +apply: sizeT_qf=> // m; case: (_ < _); first by apply: kP => //=; rewrite rqq rr. +apply: lead_coefT_qf=> // l rl; apply: ihn; rewrite //= ?rcq //. + by rewrite ?(rsumpT,rmulpT,ramulXnT,rpoly_map_mul) //= rcq. +by rewrite ?(rsumpT,rmulpT,ramulXnT,rpoly_map_mul) //= rcq. +Qed. + +Definition redivpT (p : polyF) (k : nat * polyF * polyF -> fF) + (q : polyF) : fF := + isnull (fun b => + if b then k (0%N, [::Const 0], p) else + sizeT (fun sq => + sizeT (fun sp => + lead_coefT (fun lq => + redivp_rec_loopT q sq lq k 0 [::Const 0] p sp + ) q + ) p + ) q + ) q. + +Lemma redivp_rec_loopP (q : {poly F}) (c : nat) (qq r : {poly F}) (n : nat) : + redivp_rec q c qq r n = redivp_rec_loop q (size q) (lead_coef q) c qq r n. +Proof. by elim: n c qq r => [| n Pn] c qq r //=; rewrite Pn. Qed. + +Lemma redivpTP (k : nat * polyF * polyF -> formula F) : + (forall c qq r e, + qf_eval e (k (c,qq,r)) = + qf_eval e (k (c, lift (eval_poly e qq), lift (eval_poly e r)))) -> + forall p q e (d := redivp (eval_poly e p) (eval_poly e q)), + qf_eval e (redivpT p k q) = qf_eval e (k (d.1.1, lift d.1.2, lift d.2)). +Proof. +move=> Pk p q e /=; rewrite isnullP unlock. +case q0 : (_ == _); first by rewrite Pk /= mul0r add0r polyC0. +rewrite !sizeTP lead_coefTP /=; last by move=> *; rewrite !redivp_rec_loopTP. +rewrite redivp_rec_loopTP /=; last by move=> *; rewrite Pk. +by rewrite mul0r add0r polyC0 redivp_rec_loopP. +Qed. + +Lemma redivpT_qf (p : polyF) (k : nat * polyF * polyF -> formula F) (q : polyF) : + (forall r, [&& rpoly r.1.2 & rpoly r.2] -> qf (k r)) -> + rpoly p -> rpoly q -> qf (redivpT p k q). +Proof. +move=> kP rp rq; rewrite /redivpT; apply: isnull_qf=> // [[]]; first exact: kP. +apply: sizeT_qf => // sq; apply: sizeT_qf=> // sp. +apply: lead_coefT_qf=> // lq rlq; exact: redivp_rec_loopT_qf. +Qed. + +Definition rmodpT (p : polyF) (k : polyF -> fF) (q : polyF) : fF := + redivpT p (fun d => k d.2) q. +Definition rdivpT (p : polyF) (k:polyF -> fF) (q : polyF) : fF := + redivpT p (fun d => k d.1.2) q. +Definition rscalpT (p : polyF) (k: nat -> fF) (q : polyF) : fF := + redivpT p (fun d => k d.1.1) q. +Definition rdvdpT (p : polyF) (k:bool -> fF) (q : polyF) : fF := + rmodpT p (isnull k) q. + +Fixpoint rgcdp_loop n (pp qq : {poly F}) {struct n} := + if rmodp pp qq == 0 then qq + else if n is n1.+1 then rgcdp_loop n1 qq (rmodp pp qq) + else rmodp pp qq. + +Fixpoint rgcdp_loopT (pp : polyF) (k : polyF -> formula F) n (qq : polyF) := + rmodpT pp (isnull + (fun b => if b then (k qq) + else (if n is n1.+1 + then rmodpT pp (rgcdp_loopT qq k n1) qq + else rmodpT pp k qq) + ) + ) qq. + +Lemma rgcdp_loopP (k : polyF -> formula F) : + (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p)))) -> + forall n p q e, + qf_eval e (rgcdp_loopT p k n q) = + qf_eval e (k (lift (rgcdp_loop n (eval_poly e p) (eval_poly e q)))). +Proof. +move=> Pk n p q e. +elim: n p q e => /= [| m Pm] p q e. + rewrite redivpTP; last by move=>*; rewrite !isnullP eval_lift. + rewrite isnullP eval_lift; case: (_ == 0); first by rewrite Pk. + by rewrite redivpTP; last by move=>*; rewrite Pk. +rewrite redivpTP; last by move=>*; rewrite !isnullP eval_lift. +rewrite isnullP eval_lift; case: (_ == 0); first by rewrite Pk. +by rewrite redivpTP; move=>*; rewrite ?Pm !eval_lift. +Qed. + +Lemma rgcdp_loopT_qf (p : polyF) (k : polyF -> formula F) (q : polyF) (n : nat) : + (forall r, rpoly r -> qf (k r)) -> + rpoly p -> rpoly q -> qf (rgcdp_loopT p k n q). +elim: n p k q => [|n ihn] p k q kP rp rq. + apply: redivpT_qf=> // r; case/andP=> _ rr. + apply: isnull_qf=> // [[]]; first exact: kP. + by apply: redivpT_qf=> // r'; case/andP=> _ rr'; apply: kP. +apply: redivpT_qf=> // r; case/andP=> _ rr. +apply: isnull_qf=> // [[]]; first exact: kP. +by apply: redivpT_qf=> // r'; case/andP=> _ rr'; apply: ihn. +Qed. + +Definition rgcdpT (p : polyF) k (q : polyF) : fF := + let aux p1 k q1 := isnull + (fun b => if b + then (k q1) + else (sizeT (fun n => (rgcdp_loopT p1 k n q1)) p1)) p1 + in (lt_sizeT (fun b => if b then (aux q k p) else (aux p k q)) p q). + +Lemma rgcdpTP (k : seq (term F) -> formula F) : + (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p)))) -> + forall p q e, qf_eval e (rgcdpT p k q) = + qf_eval e (k (lift (rgcdp (eval_poly e p) (eval_poly e q)))). +Proof. +move=> Pk p q e; rewrite /rgcdpT !sizeTP; case lqp: (_ < _). + rewrite isnullP; case q0: (_ == _); first by rewrite Pk (eqP q0) rgcdp0. + rewrite sizeTP rgcdp_loopP => [|e' p']; last by rewrite Pk. + by rewrite /rgcdp lqp q0. +rewrite isnullP; case p0: (_ == _); first by rewrite Pk (eqP p0) rgcd0p. +rewrite sizeTP rgcdp_loopP => [|e' p']; last by rewrite Pk. +by rewrite /rgcdp lqp p0. +Qed. + +Lemma rgcdpT_qf (p : polyF) (k : polyF -> formula F) (q : polyF) : + (forall r, rpoly r -> qf (k r)) -> rpoly p -> rpoly q -> qf (rgcdpT p k q). +Proof. +move=> kP rp rq; apply: sizeT_qf=> // n; apply: sizeT_qf=> // m. +by case:(_ < _); + apply: isnull_qf=> //; case; do ?apply: kP=> //; + apply: sizeT_qf=> // n'; apply: rgcdp_loopT_qf. +Qed. + +Fixpoint rgcdpTs k (ps : seq polyF) : fF := + if ps is p::pr then rgcdpTs (rgcdpT p k) pr else k [::Const 0]. + +Lemma rgcdpTsP (k : polyF -> formula F) : + (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p)))) -> + forall ps e, + qf_eval e (rgcdpTs k ps) = + qf_eval e (k (lift (\big[@rgcdp _/0%:P]_(i <- ps)(eval_poly e i)))). +Proof. +move=> Pk ps e. +elim: ps k Pk; first by move=> p Pk; rewrite /= big_nil Pk /= mul0r add0r. +move=> p ps Pps /= k Pk /=; rewrite big_cons Pps => [|p' e']. + by rewrite rgcdpTP // eval_lift. +by rewrite !rgcdpTP // Pk !eval_lift . +Qed. + +Definition rseq_poly ps := all rpoly ps. + +Lemma rgcdpTs_qf (k : polyF -> formula F) (ps : seq polyF) : + (forall r, rpoly r -> qf (k r)) -> rseq_poly ps -> qf (rgcdpTs k ps). +Proof. +elim: ps k=> [|c p ihp] k kP rps=> /=; first exact: kP. +by move: rps; case/andP=> rc rp; apply: ihp=> // r rr; apply: rgcdpT_qf. +Qed. + +Fixpoint rgdcop_recT (q : polyF) k (p : polyF) n := + if n is m.+1 then + rgcdpT p (sizeT (fun sd => + if sd == 1%N then k p + else rgcdpT p (rdivpT p (fun r => rgdcop_recT q k r m)) q + )) q + else isnull (fun b => k [::Const b%:R]) q. + + +Lemma rgdcop_recTP (k : polyF -> formula F) : + (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p)))) + -> forall p q n e, qf_eval e (rgdcop_recT p k q n) + = qf_eval e (k (lift (rgdcop_rec (eval_poly e p) (eval_poly e q) n))). +Proof. +move=> Pk p q n e. +elim: n k Pk p q e => [|n Pn] k Pk p q e /=. + rewrite isnullP /=. + by case: (_ == _); rewrite Pk /= mul0r add0r ?(polyC0, polyC1). +rewrite rgcdpTP ?sizeTP ?eval_lift //. + rewrite /rcoprimep; case se : (_==_); rewrite Pk //. + do ?[rewrite (rgcdpTP,Pn,eval_lift,redivpTP) | move=> * //=]. +by do ?[rewrite (sizeTP,eval_lift) | move=> * //=]. +Qed. + +Lemma rgdcop_recT_qf (p : polyF) (k : polyF -> formula F) (q : polyF) (n : nat) : + (forall r, rpoly r -> qf (k r)) -> + rpoly p -> rpoly q -> qf (rgdcop_recT p k q n). +Proof. +elim: n p k q => [|n ihn] p k q kP rp rq /=. +apply: isnull_qf=> //; first by case; rewrite kP. +apply: rgcdpT_qf=> // g rg; apply: sizeT_qf=> // n'. +case: (_ == _); first exact: kP. +apply: rgcdpT_qf=> // g' rg'; apply: redivpT_qf=> // r; case/andP=> rr _. +exact: ihn. +Qed. + +Definition rgdcopT q k p := sizeT (rgdcop_recT q k p) p. + +Lemma rgdcopTP (k : polyF -> formula F) : + (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p)))) -> + forall p q e, qf_eval e (rgdcopT p k q) = + qf_eval e (k (lift (rgdcop (eval_poly e p) (eval_poly e q)))). +Proof. by move=> *; rewrite sizeTP rgdcop_recTP 1?Pk. Qed. + +Lemma rgdcopT_qf (p : polyF) (k : polyF -> formula F) (q : polyF) : + (forall r, rpoly r -> qf (k r)) -> rpoly p -> rpoly q -> qf (rgdcopT p k q). +Proof. +by move=> kP rp rq; apply: sizeT_qf => // n; apply: rgdcop_recT_qf. +Qed. + + +Definition ex_elim_seq (ps : seq polyF) (q : polyF) := + (rgcdpTs (rgdcopT q (sizeT (fun n => Bool (n != 1%N)))) ps). + +Lemma ex_elim_seqP (ps : seq polyF) (q : polyF) (e : seq F) : + let gp := (\big[@rgcdp _/0%:P]_(p <- ps)(eval_poly e p)) in + qf_eval e (ex_elim_seq ps q) = (size (rgdcop (eval_poly e q) gp) != 1%N). +Proof. +by do ![rewrite (rgcdpTsP,rgdcopTP,sizeTP,eval_lift) //= | move=> * //=]. +Qed. + +Lemma ex_elim_seq_qf (ps : seq polyF) (q : polyF) : + rseq_poly ps -> rpoly q -> qf (ex_elim_seq ps q). +Proof. +move=> rps rq; apply: rgcdpTs_qf=> // g rg; apply: rgdcopT_qf=> // d rd. +exact : sizeT_qf. +Qed. + +Fixpoint abstrX (i : nat) (t : term F) := + match t with + | (Var n) => if n == i then [::Const 0; Const 1] else [::t] + | (Opp x) => opppT (abstrX i x) + | (Add x y) => sumpT (abstrX i x) (abstrX i y) + | (Mul x y) => mulpT (abstrX i x) (abstrX i y) + | (NatMul x n) => natmulpT n (abstrX i x) + | (Exp x n) => let ax := (abstrX i x) in + iter n (mulpT ax) [::Const 1] + | _ => [::t] + end. + +Lemma abstrXP (i : nat) (t : term F) (e : seq F) (x : F) : + rterm t -> (eval_poly e (abstrX i t)).[x] = eval (set_nth 0 e i x) t. +Proof. +elim: t => [n | r | n | t tP s sP | t tP | t tP n | t tP s sP | t tP | t tP n] h. +- move=> /=; case ni: (_ == _); + rewrite //= ?(mul0r,add0r,addr0,polyC1,mul1r,hornerX,hornerC); + by rewrite // nth_set_nth /= ni. +- by rewrite /= mul0r add0r hornerC. +- by rewrite /= mul0r add0r hornerC. +- by case/andP: h => *; rewrite /= eval_sumpT hornerD tP ?sP. +- by rewrite /= eval_opppT hornerN tP. +- by rewrite /= eval_natmulpT hornerMn tP. +- by case/andP: h => *; rewrite /= eval_mulpT hornerM tP ?sP. +- by []. +- elim: n h => [|n ihn] rt; first by rewrite /= expr0 mul0r add0r hornerC. + by rewrite /= eval_mulpT exprSr hornerM ihn // mulrC tP. +Qed. + +Lemma rabstrX (i : nat) (t : term F) : rterm t -> rpoly (abstrX i t). +Proof. +elim: t; do ?[ by move=> * //=; do ?case: (_ == _)]. +- move=> t irt s irs /=; case/andP=> rt rs. + by apply: rsumpT; rewrite ?irt ?irs //. +- by move=> t irt /= rt; rewrite rpoly_map_mul ?irt //. +- by move=> t irt /= n rt; rewrite rpoly_map_mul ?irt //. +- move=> t irt s irs /=; case/andP=> rt rs. + by apply: rmulpT; rewrite ?irt ?irs //. +- move=> t irt /= n rt; move: (irt rt)=> {rt} rt; elim: n => [|n ihn] //=. + exact: rmulpT. +Qed. + +Implicit Types tx ty : term F. + +Lemma abstrX_mulM (i : nat) : {morph abstrX i : x y / Mul x y >-> mulpT x y}. +Proof. done. Qed. + +Lemma abstrX1 (i : nat) : abstrX i (Const 1) = [::Const 1]. +Proof. done. Qed. + +Lemma eval_poly_mulM e : {morph eval_poly e : x y / mulpT x y >-> mul x y}. +Proof. by move=> x y; rewrite eval_mulpT. Qed. + +Lemma eval_poly1 e : eval_poly e [::Const 1] = 1. +Proof. by rewrite /= mul0r add0r. Qed. + +Notation abstrX_bigmul := (big_morph _ (abstrX_mulM _) (abstrX1 _)). +Notation eval_bigmul := (big_morph _ (eval_poly_mulM _) (eval_poly1 _)). +Notation bigmap_id := (big_map _ (fun _ => true) id). + +Lemma rseq_poly_map (x : nat) (ts : seq (term F)) : + all (@rterm _) ts -> rseq_poly (map (abstrX x) ts). +Proof. +by elim: ts => //= t ts iht; case/andP=> rt rts; rewrite rabstrX // iht. +Qed. + +Definition ex_elim (x : nat) (pqs : seq (term F) * seq (term F)) := + ex_elim_seq (map (abstrX x) pqs.1) + (abstrX x (\big[Mul/Const 1]_(q <- pqs.2) q)). + +Lemma ex_elim_qf (x : nat) (pqs : seq (term F) * seq (term F)) : + dnf_rterm pqs -> qf (ex_elim x pqs). +case: pqs => ps qs; case/andP=> /= rps rqs. +apply: ex_elim_seq_qf; first exact: rseq_poly_map. +apply: rabstrX=> /=. +elim: qs rqs=> [|t ts iht] //=; first by rewrite big_nil. +by case/andP=> rt rts; rewrite big_cons /= rt /= iht. +Qed. + +Lemma holds_conj : forall e i x ps, all (@rterm _) ps -> + (holds (set_nth 0 e i x) (foldr (fun t : term F => And (t == 0)) True ps) + <-> all ((@root _)^~ x) (map (eval_poly e \o abstrX i) ps)). +Proof. +move=> e i x; elim=> [|p ps ihps] //=. +case/andP=> rp rps; rewrite rootE abstrXP //. +constructor; first by case=> -> hps; rewrite eqxx /=; apply/ihps. +by case/andP; move/eqP=> -> psr; split=> //; apply/ihps. +Qed. + +Lemma holds_conjn (e : seq F) (i : nat) (x : F) (ps : seq (term F)) : + all (@rterm _) ps -> + (holds (set_nth 0 e i x) (foldr (fun t : term F => And (t != 0)) True ps) <-> + all (fun p => ~~root p x) (map (eval_poly e \o abstrX i) ps)). +Proof. +elim: ps => [|p ps ihps] //=. +case/andP=> rp rps; rewrite rootE abstrXP //. +constructor; first by case=> /eqP-> hps /=; apply/ihps. +by case/andP=> pr psr; split; first apply/eqP=> //; apply/ihps. +Qed. + +Lemma holds_ex_elim : GRing.valid_QE_proj ex_elim. +Proof. +move=> i [ps qs] /= e; case/andP=> /= rps rqs. +rewrite ex_elim_seqP big_map. +have -> : \big[@rgcdp _/0%:P]_(j <- ps) eval_poly e (abstrX i j) = + \big[@rgcdp _/0%:P]_(j <- (map (eval_poly e) (map (abstrX i) (ps)))) j. + by rewrite !big_map. +rewrite -!map_comp. + have aux I (l : seq I) (P : I -> {poly F}) : + \big[(@gcdp F)/0]_(j <- l) P j %= \big[(@rgcdp F)/0]_(j <- l) P j. + elim: l => [| u l ihl] /=; first by rewrite !big_nil eqpxx. + rewrite !big_cons; move: ihl; move/(eqp_gcdr (P u)) => h. + apply: eqp_trans h _; rewrite eqp_sym; exact: eqp_rgcd_gcd. +case g0: (\big[(@rgcdp F)/0%:P]_(j <- map (eval_poly e \o abstrX i) ps) j == 0). + rewrite (eqP g0) rgdcop0. + case m0 : (_ == 0)=> //=; rewrite ?(size_poly1,size_poly0) //=. + rewrite abstrX_bigmul eval_bigmul -bigmap_id in m0. + constructor=> [[x] // []] //. + case=> _; move/holds_conjn=> hc; move/hc:rqs. + by rewrite -root_bigmul //= (eqP m0) root0. + constructor; move/negP:m0; move/negP=>m0. + case: (closed_nonrootP axiom _ m0) => x {m0}. + rewrite abstrX_bigmul eval_bigmul -bigmap_id root_bigmul=> m0. + exists x; do 2?constructor=> //; last by apply/holds_conjn. + apply/holds_conj; rewrite //= -root_biggcd. + by rewrite (eqp_root (aux _ _ _ )) (eqP g0) root0. +apply:(iffP (closed_rootP axiom _)); case=> x Px; exists x; move:Px => //=. + rewrite (eqp_root (eqp_rgdco_gdco _ _)) root_gdco ?g0 //. + rewrite -(eqp_root (aux _ _ _ )) root_biggcd abstrX_bigmul eval_bigmul. + rewrite -bigmap_id root_bigmul; case/andP=> psr qsr. + do 2?constructor; first by apply/holds_conj. + by apply/holds_conjn. +rewrite (eqp_root (eqp_rgdco_gdco _ _)) root_gdco ?g0 // -(eqp_root (aux _ _ _)). +rewrite root_biggcd abstrX_bigmul eval_bigmul -bigmap_id. +rewrite root_bigmul=> [[] // [hps hqs]]; apply/andP. +constructor; first by apply/holds_conj. +by apply/holds_conjn. +Qed. + +Lemma wf_ex_elim : GRing.wf_QE_proj ex_elim. +Proof. by move=> i bc /= rbc; apply: ex_elim_qf. Qed. + +Definition closed_fields_QEMixin := + QEdecFieldMixin wf_ex_elim holds_ex_elim. + +End ClosedFieldQE. diff --git a/mathcomp/field/countalg.v b/mathcomp/field/countalg.v new file mode 100644 index 0000000..68dd16f --- /dev/null +++ b/mathcomp/field/countalg.v @@ -0,0 +1,1107 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype. +Require Import bigop ssralg finalg zmodp matrix mxalgebra. +Require Import poly polydiv mxpoly generic_quotient ring_quotient closed_field. +Require Import ssrint rat. + +(*****************************************************************************) +(* This file clones part of ssralg hierachy for countable types; it does not *) +(* cover the left module / algebra interfaces, providing only *) +(* countZmodType == countable zmodType interface. *) +(* countRingType == countable ringType interface. *) +(* countComRingType == countable comRingType interface. *) +(* countUnitRingType == countable unitRingType interface. *) +(* countComUnitRingType == countable comUnitRingType interface. *) +(* countIdomainType == countable idomainType interface. *) +(* countFieldType == countable fieldType interface. *) +(* countDecFieldType == countable decFieldType interface. *) +(* countClosedFieldType == countable closedFieldType interface. *) +(* The interface cloning syntax is extended to these structures *) +(* [countZmodType of M] == countZmodType structure for an M that has both *) +(* zmodType and countType structures. *) +(* ... etc *) +(* This file provides constructions for both simple extension and algebraic *) +(* closure of countable fields. *) +(*****************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope ring_scope. +Import GRing.Theory CodeSeq. + +Module CountRing. + +Local Notation mixin_of T := (Countable.mixin_of T). + +Section Generic. + +(* Implicits *) +Variables (type base_type : Type) (class_of base_of : Type -> Type). +Variable base_sort : base_type -> Type. + +(* Explicits *) +Variable Pack : forall T, class_of T -> Type -> type. +Variable Class : forall T, base_of T -> mixin_of T -> class_of T. +Variable base_class : forall bT, base_of (base_sort bT). + +Definition gen_pack T := + fun bT b & phant_id (base_class bT) b => + fun fT c m & phant_id (Countable.class fT) (Countable.Class c m) => + Pack (@Class T b m) T. + +End Generic. + +Implicit Arguments gen_pack [type base_type class_of base_of base_sort]. +Local Notation cnt_ c := (@Countable.Class _ c c). +Local Notation do_pack pack T := (pack T _ _ id _ _ _ id). +Import GRing.Theory. + +Module Zmodule. + +Section ClassDef. + +Record class_of M := + Class { base : GRing.Zmodule.class_of M; mixin : mixin_of M }. +Local Coercion base : class_of >-> GRing.Zmodule.class_of. +Local Coercion mixin : class_of >-> mixin_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Definition pack := gen_pack Pack Class GRing.Zmodule.class. +Variable 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 eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (cnt_ xclass) xT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass xT. + +Definition join_countType := @Countable.Pack zmodType (cnt_ xclass) xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> GRing.Zmodule.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 countType : type >-> Countable.type. +Canonical countType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Canonical join_countType. +Notation countZmodType := type. +Notation "[ 'countZmodType' 'of' T ]" := (do_pack pack T) + (at level 0, format "[ 'countZmodType' 'of' T ]") : form_scope. +End Exports. + +End Zmodule. +Import Zmodule.Exports. + +Module Ring. + +Section ClassDef. + +Record class_of R := Class { base : GRing.Ring.class_of R; mixin : mixin_of R }. +Definition base2 R (c : class_of R) := Zmodule.Class (base c) (mixin c). +Local Coercion base : class_of >-> GRing.Ring.class_of. +Local Coercion base2 : class_of >-> Zmodule.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Definition pack := gen_pack Pack Class GRing.Ring.class. +Variable 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 eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (cnt_ xclass) xT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass cT. +Definition countZmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @GRing.Ring.Pack cT xclass xT. +Definition join_countType := @Countable.Pack ringType (cnt_ xclass) xT. +Definition join_countZmodType := @Zmodule.Pack ringType xclass xT. + +End ClassDef. + +Module Import Exports. +Coercion base : class_of >-> GRing.Ring.class_of. +Coercion base2 : class_of >-> Zmodule.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 countType : type >-> Countable.type. +Canonical countType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Coercion countZmodType : type >-> Zmodule.type. +Canonical countZmodType. +Coercion ringType : type >-> GRing.Ring.type. +Canonical ringType. +Canonical join_countType. +Canonical join_countZmodType. +Notation countRingType := type. +Notation "[ 'countRingType' 'of' T ]" := (do_pack pack T) + (at level 0, format "[ 'countRingType' 'of' T ]") : form_scope. +End Exports. + +End Ring. +Import Ring.Exports. + +Module ComRing. + +Section ClassDef. + +Record class_of R := + Class { base : GRing.ComRing.class_of R; mixin : mixin_of R }. +Definition base2 R (c : class_of R) := Ring.Class (base c) (mixin c). +Local Coercion base : class_of >-> GRing.ComRing.class_of. +Local Coercion base2 : class_of >-> Ring.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Definition pack := gen_pack Pack Class GRing.ComRing.class. +Variable 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 eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (cnt_ xclass) xT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass xT. +Definition countZmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @GRing.Ring.Pack cT xclass xT. +Definition countRingType := @Ring.Pack cT xclass xT. +Definition comRingType := @GRing.ComRing.Pack cT xclass xT. +Definition join_countType := @Countable.Pack comRingType (cnt_ xclass) xT. +Definition join_countZmodType := @Zmodule.Pack comRingType xclass xT. +Definition join_countRingType := @Ring.Pack comRingType xclass xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> GRing.ComRing.class_of. +Coercion base2 : class_of >-> Ring.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 countType : type >-> Countable.type. +Canonical countType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Coercion countZmodType : type >-> Zmodule.type. +Canonical countZmodType. +Coercion ringType : type >-> GRing.Ring.type. +Canonical ringType. +Coercion countRingType : type >-> Ring.type. +Canonical countRingType. +Coercion comRingType : type >-> GRing.ComRing.type. +Canonical comRingType. +Canonical join_countType. +Canonical join_countZmodType. +Canonical join_countRingType. +Notation countComRingType := CountRing.ComRing.type. +Notation "[ 'countComRingType' 'of' T ]" := (do_pack pack T) + (at level 0, format "[ 'countComRingType' 'of' T ]") : form_scope. +End Exports. + +End ComRing. +Import ComRing.Exports. + +Module UnitRing. + +Section ClassDef. + +Record class_of R := + Class { base : GRing.UnitRing.class_of R; mixin : mixin_of R }. +Definition base2 R (c : class_of R) := Ring.Class (base c) (mixin c). +Local Coercion base : class_of >-> GRing.UnitRing.class_of. +Local Coercion base2 : class_of >-> Ring.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Definition pack := gen_pack Pack Class GRing.UnitRing.class. +Variable 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 eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (cnt_ xclass) xT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass xT. +Definition countZmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @GRing.Ring.Pack cT xclass xT. +Definition countRingType := @Ring.Pack cT xclass xT. +Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT. + +Definition join_countType := @Countable.Pack unitRingType (cnt_ xclass) xT. +Definition join_countZmodType := @Zmodule.Pack unitRingType xclass xT. +Definition join_countRingType := @Ring.Pack unitRingType xclass xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> GRing.UnitRing.class_of. +Coercion base2 : class_of >-> Ring.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 countType : type >-> Countable.type. +Canonical countType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Coercion countZmodType : type >-> Zmodule.type. +Canonical countZmodType. +Coercion ringType : type >-> GRing.Ring.type. +Canonical ringType. +Coercion countRingType : type >-> Ring.type. +Canonical countRingType. +Coercion unitRingType : type >-> GRing.UnitRing.type. +Canonical unitRingType. +Canonical join_countType. +Canonical join_countZmodType. +Canonical join_countRingType. +Notation countUnitRingType := CountRing.UnitRing.type. +Notation "[ 'countUnitRingType' 'of' T ]" := (do_pack pack T) + (at level 0, format "[ 'countUnitRingType' 'of' T ]") : form_scope. +End Exports. + +End UnitRing. +Import UnitRing.Exports. + +Module ComUnitRing. + +Section ClassDef. + +Record class_of R := + Class { base : GRing.ComUnitRing.class_of R; mixin : mixin_of R }. +Definition base2 R (c : class_of R) := ComRing.Class (base c) (mixin c). +Definition base3 R (c : class_of R) := @UnitRing.Class R (base c) (mixin c). +Local Coercion base : class_of >-> GRing.ComUnitRing.class_of. +Local Coercion base2 : class_of >-> ComRing.class_of. +Local Coercion base3 : class_of >-> UnitRing.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Definition pack := gen_pack Pack Class GRing.ComUnitRing.class. +Variable 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 eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (cnt_ xclass) xT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass xT. +Definition countZmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @GRing.Ring.Pack cT xclass xT. +Definition countRingType := @Ring.Pack cT xclass xT. +Definition comRingType := @GRing.ComRing.Pack cT xclass xT. +Definition countComRingType := @ComRing.Pack cT xclass xT. +Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT. +Definition countUnitRingType := @UnitRing.Pack cT xclass xT. +Definition comUnitRingType := @GRing.ComUnitRing.Pack cT xclass xT. + +Definition join_countType := @Countable.Pack comUnitRingType (cnt_ xclass) xT. +Definition join_countZmodType := @Zmodule.Pack comUnitRingType xclass xT. +Definition join_countRingType := @Ring.Pack comUnitRingType xclass xT. +Definition join_countComRingType := @ComRing.Pack comUnitRingType xclass xT. +Definition join_countUnitRingType := @UnitRing.Pack comUnitRingType xclass xT. +Definition ujoin_countComRingType := @ComRing.Pack unitRingType xclass xT. +Definition cjoin_countUnitRingType := @UnitRing.Pack comRingType xclass xT. +Definition ccjoin_countUnitRingType := + @UnitRing.Pack countComRingType xclass xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> GRing.ComUnitRing.class_of. +Coercion base2 : class_of >-> ComRing.class_of. +Coercion base3 : class_of >-> UnitRing.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 countType : type >-> Countable.type. +Canonical countType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Coercion countZmodType : type >-> Zmodule.type. +Canonical countZmodType. +Coercion ringType : type >-> GRing.Ring.type. +Canonical ringType. +Coercion countRingType : type >-> Ring.type. +Canonical countRingType. +Coercion comRingType : type >-> GRing.ComRing.type. +Canonical comRingType. +Coercion countComRingType : type >-> ComRing.type. +Canonical countComRingType. +Coercion unitRingType : type >-> GRing.UnitRing.type. +Canonical unitRingType. +Coercion countUnitRingType : type >-> UnitRing.type. +Canonical countUnitRingType. +Coercion comUnitRingType : type >-> GRing.ComUnitRing.type. +Canonical comUnitRingType. +Canonical join_countType. +Canonical join_countZmodType. +Canonical join_countRingType. +Canonical join_countComRingType. +Canonical join_countUnitRingType. +Canonical ujoin_countComRingType. +Canonical cjoin_countUnitRingType. +Canonical ccjoin_countUnitRingType. +Notation countComUnitRingType := CountRing.ComUnitRing.type. +Notation "[ 'countComUnitRingType' 'of' T ]" := (do_pack pack T) + (at level 0, format "[ 'countComUnitRingType' 'of' T ]") : form_scope. +End Exports. + +End ComUnitRing. +Import ComUnitRing.Exports. + +Module IntegralDomain. + +Section ClassDef. + +Record class_of R := + Class { base : GRing.IntegralDomain.class_of R; mixin : mixin_of R }. +Definition base2 R (c : class_of R) := ComUnitRing.Class (base c) (mixin c). +Local Coercion base : class_of >-> GRing.IntegralDomain.class_of. +Local Coercion base2 : class_of >-> ComUnitRing.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Definition pack := gen_pack Pack Class GRing.IntegralDomain.class. +Variable 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 eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (cnt_ xclass) xT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass xT. +Definition countZmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @GRing.Ring.Pack cT xclass xT. +Definition countRingType := @Ring.Pack cT xclass xT. +Definition comRingType := @GRing.ComRing.Pack cT xclass xT. +Definition countComRingType := @ComRing.Pack cT xclass xT. +Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT. +Definition countUnitRingType := @UnitRing.Pack cT xclass xT. +Definition comUnitRingType := @GRing.ComUnitRing.Pack cT xclass xT. +Definition countComUnitRingType := @ComUnitRing.Pack cT xclass xT. +Definition idomainType := @GRing.IntegralDomain.Pack cT xclass xT. + +Definition join_countType := @Countable.Pack idomainType (cnt_ xclass) xT. +Definition join_countZmodType := @Zmodule.Pack idomainType xclass xT. +Definition join_countRingType := @Ring.Pack idomainType xclass xT. +Definition join_countUnitRingType := @UnitRing.Pack idomainType xclass xT. +Definition join_countComRingType := @ComRing.Pack idomainType xclass xT. +Definition join_countComUnitRingType := @ComUnitRing.Pack idomainType xclass xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> GRing.IntegralDomain.class_of. +Coercion base2 : class_of >-> ComUnitRing.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 countType : type >-> Countable.type. +Canonical countType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Coercion countZmodType : type >-> Zmodule.type. +Canonical countZmodType. +Coercion ringType : type >-> GRing.Ring.type. +Canonical ringType. +Coercion countRingType : type >-> Ring.type. +Canonical countRingType. +Coercion comRingType : type >-> GRing.ComRing.type. +Canonical comRingType. +Coercion countComRingType : type >-> ComRing.type. +Canonical countComRingType. +Coercion unitRingType : type >-> GRing.UnitRing.type. +Canonical unitRingType. +Coercion countUnitRingType : type >-> UnitRing.type. +Canonical countUnitRingType. +Coercion comUnitRingType : type >-> GRing.ComUnitRing.type. +Canonical comUnitRingType. +Coercion countComUnitRingType : type >-> ComUnitRing.type. +Canonical countComUnitRingType. +Coercion idomainType : type >-> GRing.IntegralDomain.type. +Canonical idomainType. +Canonical join_countType. +Canonical join_countZmodType. +Canonical join_countRingType. +Canonical join_countComRingType. +Canonical join_countUnitRingType. +Canonical join_countComUnitRingType. +Notation countIdomainType := CountRing.IntegralDomain.type. +Notation "[ 'countIdomainType' 'of' T ]" := (do_pack pack T) + (at level 0, format "[ 'countIdomainType' 'of' T ]") : form_scope. +End Exports. + +End IntegralDomain. +Import IntegralDomain.Exports. + +Module Field. + +Section ClassDef. + +Record class_of R := + Class { base : GRing.Field.class_of R; mixin : mixin_of R }. +Definition base2 R (c : class_of R) := IntegralDomain.Class (base c) (mixin c). +Local Coercion base : class_of >-> GRing.Field.class_of. +Local Coercion base2 : class_of >-> IntegralDomain.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Definition pack := gen_pack Pack Class GRing.Field.class. +Variable 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 eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (cnt_ xclass) xT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass xT. +Definition countZmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @GRing.Ring.Pack cT xclass xT. +Definition countRingType := @Ring.Pack cT xclass xT. +Definition comRingType := @GRing.ComRing.Pack cT xclass xT. +Definition countComRingType := @ComRing.Pack cT xclass xT. +Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT. +Definition countUnitRingType := @UnitRing.Pack cT xclass xT. +Definition comUnitRingType := @GRing.ComUnitRing.Pack cT xclass xT. +Definition countComUnitRingType := @ComUnitRing.Pack cT xclass xT. +Definition idomainType := @GRing.IntegralDomain.Pack cT xclass xT. +Definition countIdomainType := @IntegralDomain.Pack cT xclass xT. +Definition fieldType := @GRing.Field.Pack cT xclass xT. + +Definition join_countType := @Countable.Pack fieldType (cnt_ xclass) xT. +Definition join_countZmodType := @Zmodule.Pack fieldType xclass xT. +Definition join_countRingType := @Ring.Pack fieldType xclass xT. +Definition join_countUnitRingType := @UnitRing.Pack fieldType xclass xT. +Definition join_countComRingType := @ComRing.Pack fieldType xclass xT. +Definition join_countComUnitRingType := @ComUnitRing.Pack fieldType xclass xT. +Definition join_countIdomainType := @IntegralDomain.Pack fieldType xclass xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> GRing.Field.class_of. +Coercion base2 : class_of >-> IntegralDomain.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 countType : type >-> Countable.type. +Canonical countType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Coercion countZmodType : type >-> Zmodule.type. +Canonical countZmodType. +Coercion ringType : type >-> GRing.Ring.type. +Canonical ringType. +Coercion countRingType : type >-> Ring.type. +Canonical countRingType. +Coercion comRingType : type >-> GRing.ComRing.type. +Canonical comRingType. +Coercion countComRingType : type >-> ComRing.type. +Canonical countComRingType. +Coercion unitRingType : type >-> GRing.UnitRing.type. +Canonical unitRingType. +Coercion countUnitRingType : type >-> UnitRing.type. +Canonical countUnitRingType. +Coercion comUnitRingType : type >-> GRing.ComUnitRing.type. +Canonical comUnitRingType. +Coercion countComUnitRingType : type >-> ComUnitRing.type. +Canonical countComUnitRingType. +Coercion idomainType : type >-> GRing.IntegralDomain.type. +Canonical idomainType. +Coercion countIdomainType : type >-> IntegralDomain.type. +Canonical countIdomainType. +Coercion fieldType : type >-> GRing.Field.type. +Canonical fieldType. +Canonical join_countType. +Canonical join_countZmodType. +Canonical join_countRingType. +Canonical join_countComRingType. +Canonical join_countUnitRingType. +Canonical join_countComUnitRingType. +Canonical join_countIdomainType. +Notation countFieldType := CountRing.Field.type. +Notation "[ 'countFieldType' 'of' T ]" := (do_pack pack T) + (at level 0, format "[ 'countFieldType' 'of' T ]") : form_scope. +End Exports. + +End Field. +Import Field.Exports. + +Module DecidableField. + +Section ClassDef. + +Record class_of R := + Class { base : GRing.DecidableField.class_of R; mixin : mixin_of R }. +Definition base2 R (c : class_of R) := Field.Class (base c) (mixin c). +Local Coercion base : class_of >-> GRing.DecidableField.class_of. +Local Coercion base2 : class_of >-> Field.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Definition pack := gen_pack Pack Class GRing.DecidableField.class. +Variable 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 eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (cnt_ xclass) xT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass xT. +Definition countZmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @GRing.Ring.Pack cT xclass xT. +Definition countRingType := @Ring.Pack cT xclass xT. +Definition comRingType := @GRing.ComRing.Pack cT xclass xT. +Definition countComRingType := @ComRing.Pack cT xclass xT. +Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT. +Definition countUnitRingType := @UnitRing.Pack cT xclass xT. +Definition comUnitRingType := @GRing.ComUnitRing.Pack cT xclass xT. +Definition countComUnitRingType := @ComUnitRing.Pack cT xclass xT. +Definition idomainType := @GRing.IntegralDomain.Pack cT xclass xT. +Definition countIdomainType := @IntegralDomain.Pack cT xclass xT. +Definition fieldType := @GRing.Field.Pack cT xclass xT. +Definition countFieldType := @Field.Pack cT xclass xT. +Definition decFieldType := @GRing.DecidableField.Pack cT xclass xT. + +Definition join_countType := @Countable.Pack decFieldType (cnt_ xclass) xT. +Definition join_countZmodType := @Zmodule.Pack decFieldType xclass xT. +Definition join_countRingType := @Ring.Pack decFieldType xclass xT. +Definition join_countUnitRingType := @UnitRing.Pack decFieldType xclass xT. +Definition join_countComRingType := @ComRing.Pack decFieldType xclass xT. +Definition join_countComUnitRingType := + @ComUnitRing.Pack decFieldType xclass xT. +Definition join_countIdomainType := @IntegralDomain.Pack decFieldType xclass xT. +Definition join_countFieldType := @Field.Pack decFieldType xclass xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> GRing.DecidableField.class_of. +Coercion base2 : class_of >-> Field.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 countType : type >-> Countable.type. +Canonical countType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Coercion countZmodType : type >-> Zmodule.type. +Canonical countZmodType. +Coercion ringType : type >-> GRing.Ring.type. +Canonical ringType. +Coercion countRingType : type >-> Ring.type. +Canonical countRingType. +Coercion comRingType : type >-> GRing.ComRing.type. +Canonical comRingType. +Coercion countComRingType : type >-> ComRing.type. +Canonical countComRingType. +Coercion unitRingType : type >-> GRing.UnitRing.type. +Canonical unitRingType. +Coercion countUnitRingType : type >-> UnitRing.type. +Canonical countUnitRingType. +Coercion comUnitRingType : type >-> GRing.ComUnitRing.type. +Canonical comUnitRingType. +Coercion countComUnitRingType : type >-> ComUnitRing.type. +Canonical countComUnitRingType. +Coercion idomainType : type >-> GRing.IntegralDomain.type. +Canonical idomainType. +Coercion countIdomainType : type >-> IntegralDomain.type. +Canonical countIdomainType. +Coercion fieldType : type >-> GRing.Field.type. +Canonical fieldType. +Coercion countFieldType : type >-> Field.type. +Canonical countFieldType. +Coercion decFieldType : type >-> GRing.DecidableField.type. +Canonical decFieldType. +Canonical join_countType. +Canonical join_countZmodType. +Canonical join_countRingType. +Canonical join_countComRingType. +Canonical join_countUnitRingType. +Canonical join_countComUnitRingType. +Canonical join_countIdomainType. +Canonical join_countFieldType. +Notation countDecFieldType := CountRing.DecidableField.type. +Notation "[ 'countDecFieldType' 'of' T ]" := (do_pack pack T) + (at level 0, format "[ 'countDecFieldType' 'of' T ]") : form_scope. +End Exports. + +End DecidableField. +Import DecidableField.Exports. + +Module ClosedField. + +Section ClassDef. + +Record class_of R := + Class { base : GRing.ClosedField.class_of R; mixin : mixin_of R }. +Definition base2 R (c : class_of R) := DecidableField.Class (base c) (mixin c). +Local Coercion base : class_of >-> GRing.ClosedField.class_of. +Local Coercion base2 : class_of >-> DecidableField.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Definition pack := gen_pack Pack Class GRing.ClosedField.class. +Variable 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 eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (cnt_ xclass) xT. +Definition zmodType := @GRing.Zmodule.Pack cT xclass xT. +Definition countZmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @GRing.Ring.Pack cT xclass xT. +Definition countRingType := @Ring.Pack cT xclass xT. +Definition comRingType := @GRing.ComRing.Pack cT xclass xT. +Definition countComRingType := @ComRing.Pack cT xclass xT. +Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT. +Definition countUnitRingType := @UnitRing.Pack cT xclass xT. +Definition comUnitRingType := @GRing.ComUnitRing.Pack cT xclass xT. +Definition countComUnitRingType := @ComUnitRing.Pack cT xclass xT. +Definition idomainType := @GRing.IntegralDomain.Pack cT xclass xT. +Definition countIdomainType := @IntegralDomain.Pack cT xclass xT. +Definition fieldType := @GRing.Field.Pack cT xclass xT. +Definition countFieldType := @Field.Pack cT xclass xT. +Definition decFieldType := @GRing.DecidableField.Pack cT xclass xT. +Definition countDecFieldType := @DecidableField.Pack cT xclass xT. +Definition closedFieldType := @GRing.ClosedField.Pack cT xclass xT. + +Definition join_countType := @Countable.Pack closedFieldType (cnt_ xclass) xT. +Definition join_countZmodType := @Zmodule.Pack closedFieldType xclass xT. +Definition join_countRingType := @Ring.Pack closedFieldType xclass xT. +Definition join_countUnitRingType := @UnitRing.Pack closedFieldType xclass xT. +Definition join_countComRingType := @ComRing.Pack closedFieldType xclass xT. +Definition join_countComUnitRingType := + @ComUnitRing.Pack closedFieldType xclass xT. +Definition join_countIdomainType := + @IntegralDomain.Pack closedFieldType xclass xT. +Definition join_countFieldType := @Field.Pack closedFieldType xclass xT. +Definition join_countDecFieldType := + @DecidableField.Pack closedFieldType xclass xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> GRing.ClosedField.class_of. +Coercion base2 : class_of >-> DecidableField.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 countType : type >-> Countable.type. +Canonical countType. +Coercion zmodType : type >-> GRing.Zmodule.type. +Canonical zmodType. +Coercion countZmodType : type >-> Zmodule.type. +Canonical countZmodType. +Coercion ringType : type >-> GRing.Ring.type. +Canonical ringType. +Coercion countRingType : type >-> Ring.type. +Canonical countRingType. +Coercion comRingType : type >-> GRing.ComRing.type. +Canonical comRingType. +Coercion countComRingType : type >-> ComRing.type. +Canonical countComRingType. +Coercion unitRingType : type >-> GRing.UnitRing.type. +Canonical unitRingType. +Coercion countUnitRingType : type >-> UnitRing.type. +Canonical countUnitRingType. +Coercion comUnitRingType : type >-> GRing.ComUnitRing.type. +Canonical comUnitRingType. +Coercion countComUnitRingType : type >-> ComUnitRing.type. +Canonical countComUnitRingType. +Coercion idomainType : type >-> GRing.IntegralDomain.type. +Canonical idomainType. +Coercion fieldType : type >-> GRing.Field.type. +Canonical fieldType. +Coercion countFieldType : type >-> Field.type. +Canonical countFieldType. +Coercion decFieldType : type >-> GRing.DecidableField.type. +Canonical decFieldType. +Coercion countDecFieldType : type >-> DecidableField.type. +Canonical countDecFieldType. +Coercion closedFieldType : type >-> GRing.ClosedField.type. +Canonical closedFieldType. +Canonical join_countType. +Canonical join_countZmodType. +Canonical join_countRingType. +Canonical join_countComRingType. +Canonical join_countUnitRingType. +Canonical join_countComUnitRingType. +Canonical join_countIdomainType. +Canonical join_countFieldType. +Canonical join_countDecFieldType. +Notation countClosedFieldType := CountRing.ClosedField.type. +Notation "[ 'countClosedFieldType' 'of' T ]" := (do_pack pack T) + (at level 0, format "[ 'countClosedFieldType' 'of' T ]") : form_scope. +End Exports. + +End ClosedField. +Import ClosedField.Exports. + +End CountRing. + +Import CountRing. +Export Zmodule.Exports Ring.Exports ComRing.Exports UnitRing.Exports. +Export ComUnitRing.Exports IntegralDomain.Exports. +Export Field.Exports DecidableField.Exports ClosedField.Exports. + +Require Import poly polydiv generic_quotient ring_quotient. +Require Import mxpoly polyXY. +Import GRing.Theory. +Require Import closed_field. + +Canonical Zp_countZmodType m := [countZmodType of 'I_m.+1]. +Canonical Zp_countRingType m := [countRingType of 'I_m.+2]. +Canonical Zp_countComRingType m := [countComRingType of 'I_m.+2]. +Canonical Zp_countUnitRingType m := [countUnitRingType of 'I_m.+2]. +Canonical Zp_countComUnitRingType m := [countComUnitRingType of 'I_m.+2]. +Canonical Fp_countIdomainType p := [countIdomainType of 'F_p]. +Canonical Fp_countFieldType p := [countFieldType of 'F_p]. +Canonical Fp_countDecFieldType p := [countDecFieldType of 'F_p]. + +Canonical matrix_countZmodType (M : countZmodType) m n := + [countZmodType of 'M[M]_(m, n)]. +Canonical matrix_countRingType (R : countRingType) n := + [countRingType of 'M[R]_n.+1]. +Canonical matrix_countUnitRingType (R : countComUnitRingType) n := + [countUnitRingType of 'M[R]_n.+1]. + +Definition poly_countMixin (R : countRingType) := + [countMixin of polynomial R by <:]. +Canonical polynomial_countType R := CountType _ (poly_countMixin R). +Canonical poly_countType (R : countRingType) := [countType of {poly R}]. +Canonical polynomial_countZmodType (R : countRingType) := + [countZmodType of polynomial R]. +Canonical poly_countZmodType (R : countRingType) := [countZmodType of {poly R}]. +Canonical polynomial_countRingType (R : countRingType) := + [countRingType of polynomial R]. +Canonical poly_countRingType (R : countRingType) := [countRingType of {poly R}]. +Canonical polynomial_countComRingType (R : countComRingType) := + [countComRingType of polynomial R]. +Canonical poly_countComRingType (R : countComRingType) := + [countComRingType of {poly R}]. +Canonical polynomial_countUnitRingType (R : countIdomainType) := + [countUnitRingType of polynomial R]. +Canonical poly_countUnitRingType (R : countIdomainType) := + [countUnitRingType of {poly R}]. +Canonical polynomial_countComUnitRingType (R : countIdomainType) := + [countComUnitRingType of polynomial R]. +Canonical poly_countComUnitRingType (R : countIdomainType) := + [countComUnitRingType of {poly R}]. +Canonical polynomial_countIdomainType (R : countIdomainType) := + [countIdomainType of polynomial R]. +Canonical poly_countIdomainType (R : countIdomainType) := + [countIdomainType of {poly R}]. + +Canonical int_countZmodType := [countZmodType of int]. +Canonical int_countRingType := [countRingType of int]. +Canonical int_countComRingType := [countComRingType of int]. +Canonical int_countUnitRingType := [countUnitRingType of int]. +Canonical int_countComUnitRingType := [countComUnitRingType of int]. +Canonical int_countIdomainType := [countIdomainType of int]. + +Canonical rat_countZmodType := [countZmodType of rat]. +Canonical rat_countRingType := [countRingType of rat]. +Canonical rat_countComRingType := [countComRingType of rat]. +Canonical rat_countUnitRingType := [countUnitRingType of rat]. +Canonical rat_countComUnitRingType := [countComUnitRingType of rat]. +Canonical rat_countIdomainType := [countIdomainType of rat]. +Canonical rat_countFieldType := [countFieldType of rat]. + +Lemma countable_field_extension (F : countFieldType) (p : {poly F}) : + size p > 1 -> + {E : countFieldType & {FtoE : {rmorphism F -> E} & + {w : E | root (map_poly FtoE p) w + & forall u : E, exists q, u = (map_poly FtoE q).[w]}}}. +Proof. +pose fix d i := + if i is i1.+1 then + let d1 := oapp (gcdp (d i1)) 0 (unpickle i1) in + if size d1 > 1 then d1 else d i1 + else p. +move=> p_gt1; have sz_d i: size (d i) > 1 by elim: i => //= i IHi; case: ifP. +have dv_d i j: i <= j -> d j %| d i. + move/subnK <-; elim: {j}(j - i)%N => //= j IHj; case: ifP => //=. + case: (unpickle _) => /= [q _|]; last by rewrite size_poly0. + exact: dvdp_trans (dvdp_gcdl _ _) IHj. +pose I : pred {poly F} := [pred q | d (pickle q).+1 %| q]. +have I'co q i: q \notin I -> i > pickle q -> coprimep q (d i). + rewrite inE => I'q /dv_d/coprimep_dvdl-> //; apply: contraR I'q. + rewrite coprimep_sym /coprimep /= pickleK /= neq_ltn. + case: ifP => [_ _| ->]; first exact: dvdp_gcdr. + rewrite orbF ltnS leqn0 size_poly_eq0 gcdp_eq0 -size_poly_eq0. + by rewrite -leqn0 leqNgt ltnW //. +have memI q: reflect (exists i, d i %| q) (q \in I). + apply: (iffP idP) => [|[i dv_di_q]]; first by exists (pickle q).+1. + have [le_i_q | /I'co i_co_q] := leqP i (pickle q). + rewrite inE /= pickleK /=; case: ifP => _; first exact: dvdp_gcdr. + exact: dvdp_trans (dv_d _ _ le_i_q) dv_di_q. + apply: contraR i_co_q _. + by rewrite /coprimep (eqp_size (dvdp_gcd_idr dv_di_q)) neq_ltn sz_d orbT. +have I_ideal : idealr_closed I. + split=> [||a q1 q2 Iq1 Iq2]; first exact: dvdp0. + by apply/memI=> [[i /idPn[]]]; rewrite dvdp1 neq_ltn sz_d orbT. + apply/memI; exists (maxn (pickle q1).+1 (pickle q2).+1); apply: dvdp_add. + by apply: dvdp_mull; apply: dvdp_trans Iq1; apply/dv_d/leq_maxl. + by apply: dvdp_trans Iq2; apply/dv_d/leq_maxr. +pose Iaddkey := GRing.Pred.Add (DefaultPredKey I) I_ideal. +pose Iidkey := MkIdeal (GRing.Pred.Zmod Iaddkey I_ideal) I_ideal. +pose E := ComRingType _ (@Quotient.mulqC _ _ _ (KeyedPred Iidkey)). +pose PtoE : {rmorphism {poly F} -> E} := [rmorphism of \pi_E%qT : {poly F} -> E]. +have PtoEd i: PtoE (d i) = 0. + by apply/eqP; rewrite piE Quotient.equivE subr0; apply/memI; exists i. +pose Einv (z : E) (q := repr z) (dq := d (pickle q).+1) := + let q_unitP := Bezout_eq1_coprimepP q dq in + if q_unitP is ReflectT ex_uv then PtoE (sval (sig_eqW ex_uv)).1 else 0. +have Einv0: Einv 0 = 0. + rewrite /Einv; case: Bezout_eq1_coprimepP => // ex_uv. + case/negP: (oner_neq0 E); rewrite piE -[_ 1]/(PtoE 1); have [uv <-] := ex_uv. + by rewrite rmorphD !rmorphM PtoEd /= reprK !mulr0 addr0. +have EmulV: GRing.Field.axiom Einv. + rewrite /Einv=> z nz_z; case: Bezout_eq1_coprimepP => [ex_uv |]; last first. + move/Bezout_eq1_coprimepP; rewrite I'co //. + by rewrite piE -{1}[z]reprK -Quotient.idealrBE subr0 in nz_z. + apply/eqP; case: sig_eqW => {ex_uv} [uv uv1]; set i := _.+1 in uv1 *. + rewrite piE /= -[z]reprK -(rmorphM PtoE) -Quotient.idealrBE. + by rewrite -uv1 opprD addNKr -mulNr; apply/memI; exists i; exact: dvdp_mull. +pose EringU := [comUnitRingType of UnitRingType _ (FieldUnitMixin EmulV Einv0)]. +have Eunitf := @FieldMixin _ _ EmulV Einv0. +pose Efield := FieldType (IdomainType EringU (FieldIdomainMixin Eunitf)) Eunitf. +pose Ecount := CountType Efield (CanCountMixin (@reprK _ _)). +pose FtoE := [rmorphism of PtoE \o polyC]; pose w : E := PtoE 'X. +have defPtoE q: (map_poly FtoE q).[w] = PtoE q. + by rewrite map_poly_comp horner_map [_.['X]]comp_polyXr. +exists [countFieldType of Ecount], FtoE, w => [|u]. + by rewrite /root defPtoE (PtoEd 0%N). +by exists (repr u); rewrite defPtoE /= reprK. +Qed. + +Lemma countable_algebraic_closure (F : countFieldType) : + {K : countClosedFieldType & {FtoK : {rmorphism F -> K} | integralRange FtoK}}. +Proof. +pose minXp (R : ringType) (p : {poly R}) := if size p > 1 then p else 'X. +have minXp_gt1 R p: size (minXp R p) > 1. + by rewrite /minXp; case: ifP => // _; rewrite size_polyX. +have minXpE (R : ringType) (p : {poly R}) : size p > 1 -> minXp R p = p. + by rewrite /minXp => ->. +have ext1 p := countable_field_extension (minXp_gt1 _ p). +pose ext1fT E p := tag (ext1 E p). +pose ext1to E p : {rmorphism _ -> ext1fT E p} := tag (tagged (ext1 E p)). +pose ext1w E p : ext1fT E p := s2val (tagged (tagged (ext1 E p))). +have ext1root E p: root (map_poly (ext1to E p) (minXp E p)) (ext1w E p). + by rewrite /ext1w; case: (tagged (tagged (ext1 E p))). +have ext1gen E p u: {q | u = (map_poly (ext1to E p) q).[ext1w E p]}. + by apply: sig_eqW; rewrite /ext1w; case: (tagged (tagged (ext1 E p))) u. +pose pExtEnum (E : countFieldType) := nat -> {poly E}. +pose Ext := {E : countFieldType & pExtEnum E}; pose MkExt : Ext := Tagged _ _. +pose EtoInc (E : Ext) i := ext1to (tag E) (tagged E i). +pose incEp E i j := + let v := map_poly (EtoInc E i) (tagged E j) in + if decode j is [:: i1; k] then + if i1 == i then odflt v (unpickle k) else v + else v. +pose fix E_ i := if i is i1.+1 then MkExt _ (incEp (E_ i1) i1) else MkExt F \0. +pose E i := tag (E_ i); pose Krep := {i : nat & E i}. +pose fix toEadd i k : {rmorphism E i -> E (k + i)%N} := + if k is k1.+1 then [rmorphism of EtoInc _ (k1 + i)%N \o toEadd _ _] + else [rmorphism of idfun]. +pose toE i j (le_ij : i <= j) := + ecast j {rmorphism E i -> E j} (subnK le_ij) (toEadd i (j - i)%N). +have toEeq i le_ii: toE i i le_ii =1 id. + by rewrite /toE; move: (subnK _); rewrite subnn => ?; rewrite eq_axiomK. +have toEleS i j leij leiSj z: toE i j.+1 leiSj z = EtoInc _ _ (toE i j leij z). + rewrite /toE; move: (j - i)%N {leij leiSj}(subnK _) (subnK _) => k. + by case: j /; rewrite (addnK i k.+1) => eq_kk; rewrite [eq_kk]eq_axiomK. +have toEirr := congr1 ((toE _ _)^~ _) (bool_irrelevance _ _). +have toEtrans j i k leij lejk leik z: + toE i k leik z = toE j k lejk (toE i j leij z). +- elim: k leik lejk => [|k IHk] leiSk lejSk. + by case: j => // in leij lejSk *; rewrite toEeq. + have:= lejSk; rewrite {1}leq_eqVlt ltnS => /predU1P[Dk | lejk]. + by rewrite -Dk in leiSk lejSk *; rewrite toEeq. + by have leik := leq_trans leij lejk; rewrite !toEleS -IHk. +have [leMl leMr] := (leq_maxl, leq_maxr); pose le_max := (leq_max, leqnn, orbT). +pose pairK (x y : Krep) (m := maxn _ _) := + (toE _ m (leMl _ _) (tagged x), toE _ m (leMr _ _) (tagged y)). +pose eqKrep x y := prod_curry (@eq_op _) (pairK x y). +have eqKrefl : reflexive eqKrep by move=> z; apply/eqP; apply: toEirr. +have eqKsym : symmetric eqKrep. + move=> z1 z2; rewrite {1}/eqKrep /= eq_sym; move: (leMl _ _) (leMr _ _). + by rewrite maxnC => lez1m lez2m; congr (_ == _); apply: toEirr. +have eqKtrans : transitive eqKrep. + rewrite /eqKrep /= => z2 z1 z3 /eqP eq_z12 /eqP eq_z23. + rewrite -(inj_eq (fmorph_inj (toE _ _ (leMr (tag z2) _)))). + rewrite -!toEtrans ?le_max // maxnCA maxnA => lez3m lez1m. + rewrite {lez1m}(toEtrans (maxn (tag z1) (tag z2))) // {}eq_z12. + do [rewrite -toEtrans ?le_max // -maxnA => lez2m] in lez3m *. + by rewrite (toEtrans (maxn (tag z2) (tag z3))) // eq_z23 -toEtrans. +pose K := {eq_quot (EquivRel _ eqKrefl eqKsym eqKtrans)}%qT. +have cntK : Countable.mixin_of K := CanCountMixin (@reprK _ _). +pose EtoKrep i (x : E i) : K := \pi%qT (Tagged E x). +have [EtoK piEtoK]: {EtoK | forall i, EtoKrep i =1 EtoK i} by exists EtoKrep. +pose FtoK := EtoK 0%N; rewrite {}/EtoKrep in piEtoK. +have eqEtoK i j x y: + toE i _ (leMl i j) x = toE j _ (leMr i j) y -> EtoK i x = EtoK j y. +- by move/eqP=> eq_xy; rewrite -!piEtoK; apply/eqmodP. +have toEtoK j i leij x : EtoK j (toE i j leij x) = EtoK i x. + by apply: eqEtoK; rewrite -toEtrans. +have EtoK_0 i: EtoK i 0 = FtoK 0 by apply: eqEtoK; rewrite !rmorph0. +have EtoK_1 i: EtoK i 1 = FtoK 1 by apply: eqEtoK; rewrite !rmorph1. +have EtoKeq0 i x: (EtoK i x == FtoK 0) = (x == 0). + by rewrite /FtoK -!piEtoK eqmodE /= /eqKrep /= rmorph0 fmorph_eq0. +have toErepr m i leim x lerm: + toE _ m lerm (tagged (repr (EtoK i x))) = toE i m leim x. +- have: (Tagged E x == repr (EtoK i x) %[mod K])%qT by rewrite reprK piEtoK. + rewrite eqmodE /= /eqKrep; case: (repr _) => j y /= in lerm * => /eqP /=. + have leijm: maxn i j <= m by rewrite geq_max leim. + by move/(congr1 (toE _ _ leijm)); rewrite -!toEtrans. +pose Kadd (x y : K) := EtoK _ (prod_curry +%R (pairK (repr x) (repr y))). +pose Kopp (x : K) := EtoK _ (- tagged (repr x)). +pose Kmul (x y : K) := EtoK _ (prod_curry *%R (pairK (repr x) (repr y))). +pose Kinv (x : K) := EtoK _ (tagged (repr x))^-1. +have EtoK_D i: {morph EtoK i : x y / x + y >-> Kadd x y}. + move=> x y; apply: eqEtoK; set j := maxn (tag _) _; rewrite !rmorphD. + by rewrite -!toEtrans ?le_max // => lexm leym; rewrite !toErepr. +have EtoK_N i: {morph EtoK i : x / - x >-> Kopp x}. + by move=> x; apply: eqEtoK; set j := tag _; rewrite !rmorphN toErepr. +have EtoK_M i: {morph EtoK i : x y / x * y >-> Kmul x y}. + move=> x y; apply: eqEtoK; set j := maxn (tag _) _; rewrite !rmorphM. + by rewrite -!toEtrans ?le_max // => lexm leym; rewrite !toErepr. +have EtoK_V i: {morph EtoK i : x / x^-1 >-> Kinv x}. + by move=> x; apply: eqEtoK; set j := tag _; rewrite !fmorphV toErepr. +case: {toErepr}I in (Kadd) (Kopp) (Kmul) (Kinv) EtoK_D EtoK_N EtoK_M EtoK_V. +pose inEi i z := {x : E i | z = EtoK i x}; have KtoE z: {i : nat & inEi i z}. + by elim/quotW: z => [[i x] /=]; exists i, x; rewrite piEtoK. +have inEle i j z: i <= j -> inEi i z -> inEi j z. + by move=> leij [x ->]; exists (toE i j leij x); rewrite toEtoK. +have KtoE2 z1 z2: {i : nat & inEi i z1 & inEi i z2}. + have [[i1 Ez1] [i2 Ez2]] := (KtoE z1, KtoE z2). + by exists (maxn i1 i2); [apply: inEle Ez1 | apply: inEle Ez2]. +have KtoE3 z1 z2 z3: {i : nat & inEi i z1 & inEi i z2 * inEi i z3}%type. + have [[i1 Ez1] [i2 Ez2 Ez3]] := (KtoE z1, KtoE2 z2 z3). + by exists (maxn i1 i2); [apply: inEle Ez1 | split; apply: inEle (leMr _ _) _]. +have KaddC: commutative Kadd. + by move=> u v; have [i [x ->] [y ->]] := KtoE2 u v; rewrite -!EtoK_D addrC. +have KaddA: associative Kadd. + move=> u v w; have [i [x ->] [[y ->] [z ->]]] := KtoE3 u v w. + by rewrite -!EtoK_D addrA. +have Kadd0: left_id (FtoK 0) Kadd. + by move=> u; have [i [x ->]] := KtoE u; rewrite -(EtoK_0 i) -EtoK_D add0r. +have KaddN: left_inverse (FtoK 0) Kopp Kadd. + by move=> u; have [i [x ->]] := KtoE u; rewrite -EtoK_N -EtoK_D addNr EtoK_0. +pose Kzmod := ZmodType K (ZmodMixin KaddA KaddC Kadd0 KaddN). +have KmulC: commutative Kmul. + by move=> u v; have [i [x ->] [y ->]] := KtoE2 u v; rewrite -!EtoK_M mulrC. +have KmulA: @associative Kzmod Kmul. + move=> u v w; have [i [x ->] [[y ->] [z ->]]] := KtoE3 u v w. + by rewrite -!EtoK_M mulrA. +have Kmul1: left_id (FtoK 1) Kmul. + by move=> u; have [i [x ->]] := KtoE u; rewrite -(EtoK_1 i) -EtoK_M mul1r. +have KmulD: left_distributive Kmul Kadd. + move=> u v w; have [i [x ->] [[y ->] [z ->]]] := KtoE3 u v w. + by rewrite -!(EtoK_M, EtoK_D) mulrDl. +have Kone_nz: FtoK 1 != FtoK 0 by rewrite EtoKeq0 oner_neq0. +pose KringMixin := ComRingMixin KmulA KmulC Kmul1 KmulD Kone_nz. +pose Kring := ComRingType (RingType Kzmod KringMixin) KmulC. +have KmulV: @GRing.Field.axiom Kring Kinv. + move=> u; have [i [x ->]] := KtoE u; rewrite EtoKeq0 => nz_x. + by rewrite -EtoK_V -[_ * _]EtoK_M mulVf ?EtoK_1. +have Kinv0: Kinv (FtoK 0) = FtoK 0 by rewrite -EtoK_V invr0. +pose Kuring := [comUnitRingType of UnitRingType _ (FieldUnitMixin KmulV Kinv0)]. +pose KfieldMixin := @FieldMixin _ _ KmulV Kinv0. +pose Kidomain := IdomainType Kuring (FieldIdomainMixin KfieldMixin). +pose Kfield := FieldType Kidomain KfieldMixin. +have EtoKrmorphism i: rmorphism (EtoK i : E i -> Kfield). + by do 2?split=> [x y|]; rewrite ?EtoK_D ?EtoK_N ?EtoK_M ?EtoK_1. +pose EtoKM := RMorphism (EtoKrmorphism _); have EtoK_E: EtoK _ = EtoKM _ by []. +have toEtoKp := @eq_map_poly _ Kring _ _(toEtoK _ _ _). +have Kclosed: GRing.ClosedField.axiom Kfield. + move=> n pK n_gt0; pose m0 := \max_(i < n) tag (KtoE (pK i)); pose m := m0.+1. + have /fin_all_exists[pE DpE] (i : 'I_n): exists y, EtoK m y = pK i. + pose u := KtoE (pK i); have leum0: tag u <= m0 by rewrite (bigmax_sup i). + by have [y ->] := tagged u; exists (toE _ _ (leqW leum0) y); rewrite toEtoK. + pose p := 'X^n - rVpoly (\row_i pE i); pose j := code [:: m0; pickle p]. + pose pj := tagged (E_ j) j; pose w : E j.+1 := ext1w (E j) pj. + have lemj: m <= j by rewrite (allP (ltn_code _)) ?mem_head. + exists (EtoKM j.+1 w); apply/eqP; rewrite -subr_eq0; apply/eqP. + transitivity (EtoKM j.+1 (map_poly (toE m j.+1 (leqW lemj)) p).[w]). + rewrite -horner_map -map_poly_comp toEtoKp EtoK_E; move/EtoKM: w => w. + rewrite rmorphB [_ 'X^n]map_polyXn !hornerE hornerXn; congr (_ - _ : Kring). + rewrite (@horner_coef_wide _ n) ?size_map_poly ?size_poly //. + by apply: eq_bigr => i _; rewrite coef_map coef_rVpoly valK mxE /= DpE. + suffices Dpj: map_poly (toE m j lemj) p = pj. + apply/eqP; rewrite EtoKeq0 (eq_map_poly (toEleS _ _ _ _)) map_poly_comp Dpj. + rewrite -rootE -[pj]minXpE ?ext1root // -Dpj size_map_poly. + by rewrite size_addl ?size_polyXn ltnS ?size_opp ?size_poly. + rewrite {w}/pj; elim: {-9}j lemj => // k IHk lemSk. + move: lemSk (lemSk); rewrite {1}leq_eqVlt ltnS => /predU1P[<- | lemk] lemSk. + rewrite {k IHk lemSk}(eq_map_poly (toEeq m _)) map_poly_id //= /incEp. + by rewrite codeK eqxx pickleK. + rewrite (eq_map_poly (toEleS _ _ _ _)) map_poly_comp {}IHk //= /incEp codeK. + by rewrite -if_neg neq_ltn lemk. +suffices{Kclosed} algF_K: {FtoK : {rmorphism F -> Kfield} | integralRange FtoK}. + pose Kdec := DecFieldType Kfield (closed_fields_QEMixin Kclosed). + pose KclosedField := ClosedFieldType Kdec Kclosed. + by exists [countClosedFieldType of CountType KclosedField cntK]. +exists (EtoKM 0%N) => /= z; have [i [{z}z ->]] := KtoE z. +suffices{z} /(_ z)[p mon_p]: integralRange (toE 0%N i isT). + by rewrite -(fmorph_root (EtoKM i)) -map_poly_comp toEtoKp; exists p. +rewrite /toE /E; clear - minXp_gt1 ext1root ext1gen. +move: (i - 0)%N (subnK _) => n; case: i /. +elim: n => [|n IHn] /= z; first exact: integral_id. +have{z} [q ->] := ext1gen _ _ z; set pn := tagged (E_ _) _. +apply: integral_horner. + by apply/integral_poly=> i; rewrite coef_map; apply: integral_rmorph. +apply: integral_root (ext1root _ _) _. + by rewrite map_poly_eq0 -size_poly_gt0 ltnW. +by apply/integral_poly=> i; rewrite coef_map; apply: integral_rmorph. +Qed. diff --git a/mathcomp/field/cyclotomic.v b/mathcomp/field/cyclotomic.v new file mode 100644 index 0000000..edd33c2 --- /dev/null +++ b/mathcomp/field/cyclotomic.v @@ -0,0 +1,320 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg poly finset. +Require Import fingroup finalg zmodp cyclic. +Require Import ssrnum ssrint polydiv rat intdiv. +Require Import mxpoly vector falgebra fieldext separable galois algC. + +(******************************************************************************) +(* This file provides few basic properties of cyclotomic polynomials. *) +(* We define: *) +(* cyclotomic z n == the factorization of the nth cyclotomic polynomial in *) +(* a ring R in which z is an nth primitive root of unity. *) +(* 'Phi_n == the nth cyclotomic polynomial in int. *) +(* This library is quite limited, and should be extended in the future. In *) +(* particular the irreducibity of 'Phi_n is only stated indirectly, as the *) +(* fact that its embedding in the algebraics (algC) is the minimal polynomial *) +(* of an nth primitive root of unity. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GRing.Theory Num.Theory. +Local Open Scope ring_scope. + +Section CyclotomicPoly. + +Section Ring. + +Variable R : ringType. + +Definition cyclotomic (z : R) n := + \prod_(k < n | coprime k n) ('X - (z ^+ k)%:P). + +Lemma cyclotomic_monic z n : cyclotomic z n \is monic. +Proof. exact: monic_prod_XsubC. Qed. + +Lemma size_cyclotomic z n : size (cyclotomic z n) = (totient n).+1. +Proof. +rewrite /cyclotomic -big_filter filter_index_enum size_prod_XsubC; congr _.+1. +rewrite -cardE -sum1_card totient_count_coprime -big_mkcond big_mkord. +by apply: eq_bigl => k; rewrite coprime_sym. +Qed. + +End Ring. + +Lemma separable_Xn_sub_1 (R : idomainType) n : + n%:R != 0 :> R -> @separable_poly R ('X^n - 1). +Proof. +case: n => [/eqP// | n nz_n]; rewrite /separable_poly linearB /=. +rewrite derivC subr0 derivXn -scaler_nat coprimep_scaler //= exprS -scaleN1r. +rewrite coprimep_sym coprimep_addl_mul coprimep_scaler ?coprimep1 //. +by rewrite (signr_eq0 _ 1). +Qed. + +Section Field. + +Variables (F : fieldType) (n : nat) (z : F). +Hypothesis prim_z : n.-primitive_root z. +Let n_gt0 := prim_order_gt0 prim_z. + +Lemma root_cyclotomic x : root (cyclotomic z n) x = n.-primitive_root x. +Proof. +rewrite /cyclotomic -big_filter filter_index_enum. +rewrite -(big_map _ xpredT (fun y => 'X - y%:P)) root_prod_XsubC. +apply/imageP/idP=> [[k co_k_n ->] | prim_x]. + by rewrite prim_root_exp_coprime. +have [k Dx] := prim_rootP prim_z (prim_expr_order prim_x). +exists (Ordinal (ltn_pmod k n_gt0)) => /=. + by rewrite unfold_in /= coprime_modl -(prim_root_exp_coprime k prim_z) -Dx. +by rewrite prim_expr_mod. +Qed. + +Lemma prod_cyclotomic : + 'X^n - 1 = \prod_(d <- divisors n) cyclotomic (z ^+ (n %/ d)) d. +Proof. +have in_d d: (d %| n)%N -> val (@inord n d) = d by move/dvdn_leq/inordK=> /= ->. +have dv_n k: (n %/ gcdn k n %| n)%N. + by rewrite -{3}(divnK (dvdn_gcdr k n)) dvdn_mulr. +have [uDn _ inDn] := divisors_correct n_gt0. +have defDn: divisors n = map val (map (@inord n) (divisors n)). + by rewrite -map_comp map_id_in // => d; rewrite inDn => /in_d. +rewrite defDn big_map big_uniq /=; last first. + by rewrite -(map_inj_uniq val_inj) -defDn. +pose h (k : 'I_n) : 'I_n.+1 := inord (n %/ gcdn k n). +rewrite -(factor_Xn_sub_1 prim_z) big_mkord. +rewrite (partition_big h (dvdn^~ n)) /= => [|k _]; last by rewrite in_d ?dv_n. +apply: eq_big => d; first by rewrite -(mem_map val_inj) -defDn inDn. +set q := (n %/ d)%N => d_dv_n. +have [q_gt0 d_gt0]: (0 < q /\ 0 < d)%N by apply/andP; rewrite -muln_gt0 divnK. +have fP (k : 'I_d): (q * k < n)%N by rewrite divn_mulAC ?ltn_divLR ?ltn_pmul2l. +rewrite (reindex (fun k => Ordinal (fP k))); last first. + have f'P (k : 'I_n): (k %/ q < d)%N by rewrite ltn_divLR // mulnC divnK. + exists (fun k => Ordinal (f'P k)) => [k _ | k /eqnP/=]. + by apply: val_inj; rewrite /= mulKn. + rewrite in_d // => Dd; apply: val_inj; rewrite /= mulnC divnK // /q -Dd. + by rewrite divnA ?mulKn ?dvdn_gcdl ?dvdn_gcdr. +apply: eq_big => k; rewrite ?exprM // -val_eqE in_d //=. +rewrite -eqn_mul ?dvdn_gcdr ?gcdn_gt0 ?n_gt0 ?orbT //. +rewrite -[n in gcdn _ n](divnK d_dv_n) -muln_gcdr mulnCA mulnA divnK //. +by rewrite mulnC eqn_mul // divnn n_gt0 eq_sym. +Qed. + +End Field. + +End CyclotomicPoly. + +Local Notation ZtoQ := (intr : int -> rat). +Local Notation ZtoC := (intr : int -> algC). +Local Notation QtoC := (ratr : rat -> algC). + +Local Notation intrp := (map_poly intr). +Local Notation pZtoQ := (map_poly ZtoQ). +Local Notation pZtoC := (map_poly ZtoC). +Local Notation pQtoC := (map_poly ratr). + +Local Hint Resolve (@intr_inj [numDomainType of algC]). +Local Notation QtoC_M := (ratr_rmorphism [numFieldType of algC]). + +Lemma C_prim_root_exists n : (n > 0)%N -> {z : algC | n.-primitive_root z}. +Proof. +pose p : {poly algC} := 'X^n - 1; have [r Dp] := closed_field_poly_normal p. +move=> n_gt0; apply/sigW; rewrite (monicP _) ?monic_Xn_sub_1 // scale1r in Dp. +have rn1: all n.-unity_root r by apply/allP=> z; rewrite -root_prod_XsubC -Dp. +have sz_r: (n < (size r).+1)%N. + by rewrite -(size_prod_XsubC r id) -Dp size_Xn_sub_1. +have [|z] := hasP (has_prim_root n_gt0 rn1 _ sz_r); last by exists z. +by rewrite -separable_prod_XsubC -Dp separable_Xn_sub_1 // pnatr_eq0 -lt0n. +Qed. + +(* (Integral) Cyclotomic polynomials. *) + +Definition Cyclotomic n : {poly int} := + let: exist z _ := C_prim_root_exists (ltn0Sn n.-1) in + map_poly floorC (cyclotomic z n). + +Notation "''Phi_' n" := (Cyclotomic n) + (at level 8, n at level 2, format "''Phi_' n"). + +Lemma Cyclotomic_monic n : 'Phi_n \is monic. +Proof. +rewrite /'Phi_n; case: (C_prim_root_exists _) => z /= _. +rewrite monicE lead_coefE coef_map_id0 ?(int_algC_K 0) ?getCint0 //. +by rewrite size_poly_eq -lead_coefE (monicP (cyclotomic_monic _ _)) (intCK 1). +Qed. + +Lemma Cintr_Cyclotomic n z : + n.-primitive_root z -> pZtoC 'Phi_n = cyclotomic z n. +Proof. +elim: {n}_.+1 {-2}n z (ltnSn n) => // m IHm n z0 le_mn prim_z0. +rewrite /'Phi_n; case: (C_prim_root_exists _) => z /=. +have n_gt0 := prim_order_gt0 prim_z0; rewrite prednK // => prim_z. +have [uDn _ inDn] := divisors_correct n_gt0. +pose q := \prod_(d <- rem n (divisors n)) 'Phi_d. +have mon_q: q \is monic by apply: monic_prod => d _; exact: Cyclotomic_monic. +have defXn1: cyclotomic z n * pZtoC q = 'X^n - 1. + rewrite (prod_cyclotomic prim_z) (big_rem n) ?inDn //=. + rewrite divnn n_gt0 rmorph_prod /=; congr (_ * _). + apply: eq_big_seq => d; rewrite mem_rem_uniq ?inE //= inDn => /andP[n'd ddvn]. + rewrite -IHm ?dvdn_prim_root // -ltnS (leq_ltn_trans _ le_mn) //. + by rewrite ltn_neqAle n'd dvdn_leq. +have mapXn1 (R1 R2 : ringType) (f : {rmorphism R1 -> R2}): + map_poly f ('X^n - 1) = 'X^n - 1. +- by rewrite rmorphB /= rmorph1 map_polyXn. +have nz_q: pZtoC q != 0. + by rewrite -size_poly_eq0 size_map_inj_poly // size_poly_eq0 monic_neq0. +have [r def_zn]: exists r, cyclotomic z n = pZtoC r. + have defZtoC: ZtoC =1 QtoC \o ZtoQ by move=> a; rewrite /= rmorph_int. + have /dvdpP[r0 Dr0]: map_poly ZtoQ q %| 'X^n - 1. + rewrite -(dvdp_map QtoC_M) mapXn1 -map_poly_comp. + by rewrite -(eq_map_poly defZtoC) -defXn1 dvdp_mull. + have [r [a nz_a Dr]] := rat_poly_scale r0. + exists (zprimitive r); apply: (mulIf nz_q); rewrite defXn1. + rewrite -rmorphM -(zprimitive_monic mon_q) -zprimitiveM /=. + have ->: r * q = a *: ('X^n - 1). + apply: (map_inj_poly (intr_inj : injective ZtoQ)) => //. + rewrite map_polyZ mapXn1 Dr0 Dr -scalerAl scalerKV ?intr_eq0 //. + by rewrite rmorphM. + by rewrite zprimitiveZ // zprimitive_monic ?monic_Xn_sub_1 ?mapXn1. +rewrite floorCpK; last by apply/polyOverP=> i; rewrite def_zn coef_map Cint_int. +pose f e (k : 'I_n) := Ordinal (ltn_pmod (k * e) n_gt0). +have [e Dz0] := prim_rootP prim_z (prim_expr_order prim_z0). +have co_e_n: coprime e n by rewrite -(prim_root_exp_coprime e prim_z) -Dz0. +have injf: injective (f e). + apply: can_inj (f (egcdn e n).1) _ => k; apply: val_inj => /=. + rewrite modnMml -mulnA -modnMmr -{1}(mul1n e). + by rewrite (chinese_modr co_e_n 0) modnMmr muln1 modn_small. +rewrite [_ n](reindex_inj injf); apply: eq_big => k /=. + by rewrite coprime_modl coprime_mull co_e_n andbT. +by rewrite prim_expr_mod // mulnC exprM -Dz0. +Qed. + +Lemma prod_Cyclotomic n : + (n > 0)%N -> \prod_(d <- divisors n) 'Phi_d = 'X^n - 1. +Proof. +move=> n_gt0; have [z prim_z] := C_prim_root_exists n_gt0. +apply: (map_inj_poly (intr_inj : injective ZtoC)) => //. +rewrite rmorphB rmorph1 rmorph_prod /= map_polyXn (prod_cyclotomic prim_z). +apply: eq_big_seq => d; rewrite -dvdn_divisors // => d_dv_n. +by rewrite -Cintr_Cyclotomic ?dvdn_prim_root. +Qed. + +Lemma Cyclotomic0 : 'Phi_0 = 1. +Proof. +rewrite /'Phi_0; case: (C_prim_root_exists _) => z /= _. +by rewrite -[1]polyseqK /cyclotomic big_ord0 map_polyE !polyseq1 /= (intCK 1). +Qed. + +Lemma size_Cyclotomic n : size 'Phi_n = (totient n).+1. +Proof. +have [-> | n_gt0] := posnP n; first by rewrite Cyclotomic0 polyseq1. +have [z prim_z] := C_prim_root_exists n_gt0. +rewrite -(size_map_inj_poly (can_inj intCK)) //. +rewrite (Cintr_Cyclotomic prim_z) -[_ n]big_filter filter_index_enum. +rewrite size_prod_XsubC -cardE totient_count_coprime big_mkord -big_mkcond /=. +by rewrite (eq_card (fun _ => coprime_sym _ _)) sum1_card. +Qed. + +Lemma minCpoly_cyclotomic n z : + n.-primitive_root z -> minCpoly z = cyclotomic z n. +Proof. +move=> prim_z; have n_gt0 := prim_order_gt0 prim_z. +have Dpz := Cintr_Cyclotomic prim_z; set pz := cyclotomic z n in Dpz *. +have mon_pz: pz \is monic by exact: cyclotomic_monic. +have pz0: root pz z by rewrite root_cyclotomic. +have [pf [Dpf mon_pf] dv_pf] := minCpolyP z. +have /dvdpP_rat_int[f [af nz_af Df] [g /esym Dfg]]: pf %| pZtoQ 'Phi_n. + rewrite -dv_pf; congr (root _ z): pz0; rewrite -Dpz -map_poly_comp. + by apply: eq_map_poly => b; rewrite /= rmorph_int. +without loss{nz_af} [mon_f mon_g]: af f g Df Dfg / f \is monic /\ g \is monic. + move=> IH; pose cf := lead_coef f; pose cg := lead_coef g. + have cfg1: cf * cg = 1. + by rewrite -lead_coefM Dfg (monicP (Cyclotomic_monic n)). + apply: (IH (af *~ cf) (f *~ cg) (g *~ cf)). + - by rewrite rmorphMz -scalerMzr scalerMzl -mulrzA cfg1. + - by rewrite mulrzAl mulrzAr -mulrzA cfg1. + by rewrite !(intz, =^~ scaler_int) !monicE !lead_coefZ mulrC cfg1. +have{af Df} Df: pQtoC pf = pZtoC f. + have:= congr1 lead_coef Df. + rewrite lead_coefZ lead_coef_map_inj //; last exact: intr_inj. + rewrite !(monicP _) // mulr1 Df => <-; rewrite scale1r -map_poly_comp. + by apply: eq_map_poly => b; rewrite /= rmorph_int. +have [/size1_polyC Dg | g_gt1] := leqP (size g) 1. + rewrite monicE Dg lead_coefC in mon_g. + by rewrite -Dpz -Dfg Dg (eqP mon_g) mulr1 Dpf. +have [zk gzk0]: exists zk, root (pZtoC g) zk. + have [rg] := closed_field_poly_normal (pZtoC g). + rewrite lead_coef_map_inj // (monicP mon_g) scale1r => Dg. + rewrite -(size_map_inj_poly (can_inj intCK)) // Dg in g_gt1. + rewrite size_prod_XsubC in g_gt1. + by exists rg`_0; rewrite Dg root_prod_XsubC mem_nth. +have [k cokn Dzk]: exists2 k, coprime k n & zk = z ^+ k. + have: root pz zk by rewrite -Dpz -Dfg rmorphM rootM gzk0 orbT. + rewrite -[pz]big_filter -(big_map _ xpredT (fun a => 'X - a%:P)). + by rewrite root_prod_XsubC => /imageP[k]; exists k. +have co_fg (R : idomainType): n%:R != 0 :> R -> @coprimep R (intrp f) (intrp g). + move=> nz_n; have: separable_poly (intrp ('X^n - 1) : {poly R}). + by rewrite rmorphB rmorph1 /= map_polyXn separable_Xn_sub_1. + rewrite -prod_Cyclotomic // (big_rem n) -?dvdn_divisors //= -Dfg. + by rewrite !rmorphM /= !separable_mul => /and3P[] /and3P[]. +suffices fzk0: root (pZtoC f) zk. + have [] // := negP (coprimep_root (co_fg _ _) fzk0). + by rewrite pnatr_eq0 -lt0n. +move: gzk0 cokn; rewrite {zk}Dzk; elim: {k}_.+1 {-2}k (ltnSn k) => // m IHm k. +rewrite ltnS => lekm gzk0 cokn. +have [|k_gt1] := leqP k 1; last have [p p_pr /dvdnP[k1 Dk]] := pdivP k_gt1. + rewrite -[leq k 1](mem_iota 0 2) !inE => /pred2P[k0 | ->]; last first. + by rewrite -Df dv_pf. + have /eqP := size_Cyclotomic n; rewrite -Dfg size_Mmonic ?monic_neq0 //. + rewrite k0 /coprime gcd0n in cokn; rewrite (eqP cokn). + rewrite -(size_map_inj_poly (can_inj intCK)) // -Df -Dpf. + by rewrite -(subnKC g_gt1) -(subnKC (size_minCpoly z)) !addnS. +move: cokn; rewrite Dk coprime_mull => /andP[cok1n]. +rewrite prime_coprime // (dvdn_charf (char_Fp p_pr)) => /co_fg {co_fg}. +have charFpX: p \in [char {poly 'F_p}]. + by rewrite (rmorph_char (polyC_rmorphism _)) ?char_Fp. +rewrite -(coprimep_pexpr _ _ (prime_gt0 p_pr)) -(Frobenius_autE charFpX). +rewrite -[g]comp_polyXr map_comp_poly -horner_map /= Frobenius_autE -rmorphX. +rewrite -!map_poly_comp (@eq_map_poly _ _ _ (polyC \o *~%R 1)); last first. + by move=> a; rewrite /= !rmorph_int. +rewrite map_poly_comp -[_.[_]]map_comp_poly /= => co_fg. +suffices: coprimep (pZtoC f) (pZtoC (g \Po 'X^p)). + move/coprimep_root=> /=/(_ (z ^+ k1))/implyP. + rewrite map_comp_poly map_polyXn horner_comp hornerXn. + rewrite -exprM -Dk [_ == 0]gzk0 implybF => /negP[]. + have: root pz (z ^+ k1). + by rewrite root_cyclotomic // prim_root_exp_coprime. + rewrite -Dpz -Dfg rmorphM rootM => /orP[] //= /IHm-> //. + rewrite (leq_trans _ lekm) // -[k1]muln1 Dk ltn_pmul2l ?prime_gt1 //. + by have:= ltnW k_gt1; rewrite Dk muln_gt0 => /andP[]. +suffices: coprimep f (g \Po 'X^p). + case/Bezout_coprimepP=> [[u v]]; rewrite -size_poly_eq1. + rewrite -(size_map_inj_poly (can_inj intCK)) // rmorphD !rmorphM /=. + rewrite size_poly_eq1 => {co_fg}co_fg; apply/Bezout_coprimepP. + by exists (pZtoC u, pZtoC v). +apply: contraLR co_fg => /coprimepPn[|d]; first exact: monic_neq0. +rewrite andbC -size_poly_eq1 dvdp_gcd => /and3P[sz_d]. +pose d1 := zprimitive d. +have d_dv_mon h: d %| h -> h \is monic -> exists h1, h = d1 * h1. + case/Pdiv.Idomain.dvdpP=> [[c h1] /= nz_c Dh] mon_h; exists (zprimitive h1). + by rewrite -zprimitiveM mulrC -Dh zprimitiveZ ?zprimitive_monic. +case/d_dv_mon=> // f1 Df1 /d_dv_mon[|f2 ->]. + rewrite monicE lead_coefE size_comp_poly size_polyXn /=. + rewrite comp_polyE coef_sum polySpred ?monic_neq0 //= mulnC. + rewrite big_ord_recr /= -lead_coefE (monicP mon_g) scale1r. + rewrite -exprM coefXn eqxx big1 ?add0r // => i _. + rewrite coefZ -exprM coefXn eqn_pmul2l ?prime_gt0 //. + by rewrite eqn_leq leqNgt ltn_ord mulr0. +have monFp h: h \is monic -> size (map_poly intr h) = size h. + by move=> mon_h; rewrite size_poly_eq // -lead_coefE (monicP mon_h) oner_eq0. +apply/coprimepPn; last exists (map_poly intr d1). + by rewrite -size_poly_eq0 monFp // size_poly_eq0 monic_neq0. +rewrite Df1 !rmorphM dvdp_gcd !dvdp_mulr //= -size_poly_eq1. +rewrite monFp ?size_zprimitive //. +rewrite monicE [_ d1]intEsg sgz_lead_primitive -zprimitive_eq0 -/d1. +rewrite -lead_coef_eq0 -absz_eq0. +have/esym/eqP := congr1 (absz \o lead_coef) Df1. +by rewrite /= (monicP mon_f) lead_coefM abszM muln_eq1 => /andP[/eqP-> _]. +Qed. diff --git a/mathcomp/field/falgebra.v b/mathcomp/field/falgebra.v new file mode 100644 index 0000000..d7dfd85 --- /dev/null +++ b/mathcomp/field/falgebra.v @@ -0,0 +1,1199 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path choice fintype. +Require Import div tuple finfun bigop ssralg finalg zmodp matrix vector poly. + +(******************************************************************************) +(* Finite dimensional free algebras, usually known as F-algebras. *) +(* FalgType K == the interface type for F-algebras over K; it simply *) +(* joins the unitAlgType K and vectType K interfaces. *) +(* [FalgType K of aT] == an FalgType K structure for a type aT that has both *) +(* unitAlgType K and vectType K canonical structures. *) +(* [FalgType K of aT for vT] == an FalgType K structure for a type aT with a *) +(* unitAlgType K canonical structure, given a structure *) +(* vT : vectType K whose lmodType K projection matches *) +(* the canonical lmodType for aT. *) +(* FalgUnitRingType T == a default unitRingType structure for a type T with *) +(* both algType and vectType structures. *) +(* Any aT with an FalgType structure inherits all the Vector, Ring and *) +(* Algebra operations, and supports the following additional operations: *) +(* \dim_A M == (\dim M %/ dim A)%N -- free module dimension. *) +(* amull u == the linear function v |-> u * v, for u, v : aT. *) +(* amulr u == the linear function v |-> v * u, for u, v : aT. *) +(* 1, f * g, f ^+ n == the identity function, the composite g \o f, the nth *) +(* iterate of f, for 1, f, g in 'End(aT). This is just *) +(* the usual F-algebra structure on 'End(aT). It is NOT *) +(* canonical by default, but can be activated by the *) +(* line Import FalgLfun. Beware also that (f^-1)%VF is *) +(* the linear function inverse, not the ring inverse of *) +(* f (though they do coincide when f is injective). *) +(* 1%VS == the line generated by 1 : aT. *) +(* (U * V)%VS == the smallest subspace of aT that contains all *) +(* products u * v for u in U, v in V. *) +(* (U ^+ n)%VS == (U * U * ... * U), n-times. U ^+ 0 = 1%VS *) +(* 'C[u]%VS == the centraliser subspace of the vector u. *) +(* 'C_U[v]%VS := (U :&: 'C[v])%VS. *) +(* 'C(V)%VS == the centraliser subspace of the subspace V. *) +(* 'C_U(V)%VS := (U :&: 'C(V))%VS. *) +(* 'Z(V)%VS == the center subspace of the subspace V. *) +(* agenv U == the smallest subalgebra containing U ^+ n for all n. *) +(* <>%VS == agenv (U + <[v]>) (adjoin v to U). *) +(* <>%VS == agenv (U + <>) (adjoin vs to U). *) +(* {aspace aT} == a subType of {vspace aT} consisting of sub-algebras *) +(* of aT (see below); for A : {aspace aT}, subvs_of A *) +(* has a canonical FalgType K structure. *) +(* is_aspace U <=> the characteristic predicate of {aspace aT} stating *) +(* that U is closed under product and contains an *) +(* identity element, := has_algid U && (U * U <= U)%VS. *) +(* algid A == the identity element of A : {aspace aT}, which need *) +(* not be equal to 1 (indeed, in a Wedderburn *) +(* decomposition it is not even a unit in aT). *) +(* is_algid U e <-> e : aT is an identity element for the subspace U: *) +(* e in U, e != 0 & e * u = u * e = u for all u in U. *) +(* has_algid U <=> there is an e such that is_algid U e. *) +(* [aspace of U] == a clone of an existing {aspace aT} structure on *) +(* U : {vspace aT} (more instances of {aspace aT} will *) +(* be defined in extFieldType). *) +(* [aspace of U for A] == a clone of A : {aspace aT} for U : {vspace aT}. *) +(* 1%AS == the canonical sub-algebra 1%VS. *) +(* {:aT}%AS == the canonical full algebra. *) +(* <>%AS == the canonical algebra for agenv U; note that this is *) +(* unrelated to <>%VS, the subspace spanned by vs. *) +(* <>%AS == the canonical algebra for <>%VS. *) +(* <>%AS == the canonical algebra for <>%VS. *) +(* ahom_in U f <=> f : 'Hom(aT, rT) is a multiplicative homomorphism *) +(* inside U, and in addition f 1 = 1 (even if U doesn't *) +(* contain 1). Note that f @: U need not be a *) +(* subalgebra when U is, as f could annilate U. *) +(* 'AHom(aT, rT) == the type of algebra homomorphisms from aT to rT, *) +(* where aT and rT ARE FalgType structures. Elements of *) +(* 'AHom(aT, rT) coerce to 'End(aT, rT) and aT -> rT. *) +(* --> Caveat: aT and rT must denote actual FalgType structures, not their *) +(* projections on Type. *) +(* 'AEnd(aT) == algebra endomorphisms of aT (:= 'AHom(aT, aT)). *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. +Open Local Scope ring_scope. + +Reserved Notation "{ 'aspace' T }" (at level 0, format "{ 'aspace' T }"). +Reserved Notation "<< U & vs >>" (at level 0, format "<< U & vs >>"). +Reserved Notation "<< U ; x >>" (at level 0, format "<< U ; x >>"). +Reserved Notation "''AHom' ( T , rT )" + (at level 8, format "''AHom' ( T , rT )"). +Reserved Notation "''AEnd' ( T )" (at level 8, format "''AEnd' ( T )"). + +Notation "\dim_ E V" := (divn (\dim V) (\dim E)) + (at level 10, E at level 2, V at level 8, format "\dim_ E V") : nat_scope. + +Import GRing.Theory. + +(* Finite dimensional algebra *) +Module Falgebra. + +(* Supply a default unitRing mixin for the default unitAlgType base type. *) +Section DefaultBase. + +Variables (K : fieldType) (A : algType K). + +Lemma BaseMixin : Vector.mixin_of A -> GRing.UnitRing.mixin_of A. +Proof. +move=> vAm; pose vA := VectType K A vAm. +pose am u := linfun (u \o* idfun : vA -> vA). +have amE u v : am u v = v * u by rewrite lfunE. +pose uam := [pred u | lker (am u) == 0%VS]. +pose vam := [fun u => if u \in uam then (am u)^-1%VF 1 else u]. +have vamKl: {in uam, left_inverse 1 vam *%R}. + by move=> u Uu; rewrite /= Uu -amE lker0_lfunVK. +exists uam vam => // [u Uu | u v [_ uv1] | u /negbTE/= -> //]. + by apply/(lker0P Uu); rewrite !amE -mulrA vamKl // mul1r mulr1. +by apply/lker0P=> w1 w2 /(congr1 (am v)); rewrite !amE -!mulrA uv1 !mulr1. +Qed. + +Definition BaseType T := + fun c vAm & phant_id c (GRing.UnitRing.Class (BaseMixin vAm)) => + fun (vT : vectType K) & phant vT + & phant_id (Vector.mixin (Vector.class vT)) vAm => + @GRing.UnitRing.Pack T c T. + +End DefaultBase. + +Section ClassDef. +Variable R : ringType. +Implicit Type phR : phant R. + +Record class_of A := Class { + base1 : GRing.UnitAlgebra.class_of R A; + mixin : Vector.mixin_of (GRing.Lmodule.Pack _ base1 A) +}. +Local Coercion base1 : class_of >-> GRing.UnitAlgebra.class_of. +Definition base2 A c := @Vector.Class _ _ (@base1 A c) (mixin c). +Local Coercion base2 : class_of >-> Vector.class_of. + +Structure type (phR : phant R) := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. + +Variables (phR : phant R) (T : Type) (cT : type phR). +Definition class := let: Pack _ c _ := 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.UnitAlgebra.class R phR bT) + (b : GRing.UnitAlgebra.class_of R T) => + fun mT m & phant_id (@Vector.class R phR mT) (@Vector.Class R T b m) => + Pack (Phant R) (@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 lmodType := @GRing.Lmodule.Pack R phR cT xclass xT. +Definition ringType := @GRing.Ring.Pack cT xclass xT. +Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT. +Definition lalgType := @GRing.Lalgebra.Pack R phR cT xclass xT. +Definition algType := @GRing.Algebra.Pack R phR cT xclass xT. +Definition unitAlgType := @GRing.UnitAlgebra.Pack R phR cT xclass xT. +Definition vectType := @Vector.Pack R phR cT xclass cT. +Definition vect_ringType := @GRing.Ring.Pack vectType xclass xT. +Definition vect_unitRingType := @GRing.UnitRing.Pack vectType xclass xT. +Definition vect_lalgType := @GRing.Lalgebra.Pack R phR vectType xclass xT. +Definition vect_algType := @GRing.Algebra.Pack R phR vectType xclass xT. +Definition vect_unitAlgType := @GRing.UnitAlgebra.Pack R phR vectType xclass xT. + +End ClassDef. + +Module Exports. + +Coercion base1 : class_of >-> GRing.UnitAlgebra.class_of. +Coercion base2 : class_of >-> Vector.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 lmodType : type>-> GRing.Lmodule.type. +Canonical lmodType. +Coercion ringType : type >-> GRing.Ring.type. +Canonical ringType. +Coercion unitRingType : type >-> GRing.UnitRing.type. +Canonical unitRingType. +Coercion lalgType : type >-> GRing.Lalgebra.type. +Canonical lalgType. +Coercion algType : type >-> GRing.Algebra.type. +Canonical algType. +Coercion unitAlgType : type >-> GRing.UnitAlgebra.type. +Canonical unitAlgType. +Coercion vectType : type >-> Vector.type. +Canonical vectType. +Canonical vect_ringType. +Canonical vect_unitRingType. +Canonical vect_lalgType. +Canonical vect_algType. +Canonical vect_unitAlgType. +Notation FalgType R := (type (Phant R)). +Notation "[ 'FalgType' R 'of' A ]" := (@pack _ (Phant R) A _ _ id _ _ id) + (at level 0, format "[ 'FalgType' R 'of' A ]") : form_scope. +Notation "[ 'FalgType' R 'of' A 'for' vT ]" := + (@pack _ (Phant R) A _ _ id vT _ idfun) + (at level 0, format "[ 'FalgType' R 'of' A 'for' vT ]") : form_scope. +Notation FalgUnitRingType T := (@BaseType _ _ T _ _ id _ (Phant T) id). +End Exports. + +End Falgebra. +Export Falgebra.Exports. + +Notation "1" := (vline 1) : vspace_scope. + +Canonical matrix_FalgType (K : fieldType) n := [FalgType K of 'M[K]_n.+1]. + +Section Proper. + +Variables (R : ringType) (aT : FalgType R). +Import Vector.InternalTheory. + +Lemma FalgType_proper : Vector.dim aT > 0. +Proof. +rewrite lt0n; apply: contraNneq (oner_neq0 aT) => aT0. +by apply/eqP/v2r_inj; do 2!move: (v2r _); rewrite aT0 => u v; rewrite !thinmx0. +Qed. + +End Proper. + +Module FalgLfun. + +Section FalgLfun. + +Variable (R : comRingType) (aT : FalgType R). +Implicit Types f g : 'End(aT). + +Canonical Falg_fun_ringType := lfun_ringType (FalgType_proper aT). +Canonical Falg_fun_lalgType := lfun_lalgType (FalgType_proper aT). +Canonical Falg_fun_algType := lfun_algType (FalgType_proper aT). + +Lemma lfun_mulE f g u : (f * g) u = g (f u). Proof. exact: lfunE. Qed. +Lemma lfun_compE f g : (g \o f)%VF = f * g. Proof. by []. Qed. + +End FalgLfun. + +Section InvLfun. + +Variable (K : fieldType) (aT : FalgType K). +Implicit Types f g : 'End(aT). + +Definition lfun_invr f := if lker f == 0%VS then f^-1%VF else f. + +Lemma lfun_mulVr f : lker f == 0%VS -> f^-1%VF * f = 1. +Proof. exact: lker0_compfV. Qed. + +Lemma lfun_mulrV f : lker f == 0%VS -> f * f^-1%VF = 1. +Proof. exact: lker0_compVf. Qed. + +Fact lfun_mulRVr f : lker f == 0%VS -> lfun_invr f * f = 1. +Proof. by move=> Uf; rewrite /lfun_invr Uf lfun_mulVr. Qed. + +Fact lfun_mulrRV f : lker f == 0%VS -> f * lfun_invr f = 1. +Proof. by move=> Uf; rewrite /lfun_invr Uf lfun_mulrV. Qed. + +Fact lfun_unitrP f g : g * f = 1 /\ f * g = 1 -> lker f == 0%VS. +Proof. +case=> _ fK; apply/lker0P; apply: can_inj (g) _ => u. +by rewrite -lfun_mulE fK lfunE. +Qed. + +Lemma lfun_invr_out f : lker f != 0%VS -> lfun_invr f = f. +Proof. by rewrite /lfun_invr => /negPf->. Qed. + +Definition lfun_unitRingMixin := + UnitRingMixin lfun_mulRVr lfun_mulrRV lfun_unitrP lfun_invr_out. +Canonical lfun_unitRingType := UnitRingType 'End(aT) lfun_unitRingMixin. +Canonical lfun_unitAlgType := [unitAlgType K of 'End(aT)]. +Canonical Falg_fun_FalgType := [FalgType K of 'End(aT)]. + +Lemma lfun_invE f : lker f == 0%VS -> f^-1%VF = f^-1. +Proof. by rewrite /f^-1 /= /lfun_invr => ->. Qed. + +End InvLfun. + +End FalgLfun. + +Section FalgebraTheory. + +Variables (K : fieldType) (aT : FalgType K). +Implicit Types (u v : aT) (U V W : {vspace aT}). + +Import FalgLfun. + +Definition amull u : 'End(aT) := linfun (u \*o @idfun aT). +Definition amulr u : 'End(aT) := linfun (u \o* @idfun aT). + +Lemma amull_inj : injective amull. +Proof. by move=> u v /lfunP/(_ 1); rewrite !lfunE /= !mulr1. Qed. + +Lemma amulr_inj : injective amulr. +Proof. by move=> u v /lfunP/(_ 1); rewrite !lfunE /= !mul1r. Qed. + +Fact amull_is_linear : linear amull. +Proof. +move=> a u v; apply/lfunP => w. +by rewrite !lfunE /= scale_lfunE !lfunE /= mulrDl scalerAl. +Qed. +Canonical amull_additive := Eval hnf in Additive amull_is_linear. +Canonical amull_linear := Eval hnf in AddLinear amull_is_linear. + +(* amull is a converse ring morphism *) +Lemma amull1 : amull 1 = \1%VF. +Proof. by apply/lfunP => z; rewrite id_lfunE lfunE /= mul1r. Qed. + +Lemma amullM u v : (amull (u * v) = amull v * amull u)%VF. +Proof. by apply/lfunP => w; rewrite comp_lfunE !lfunE /= mulrA. Qed. + +Lemma amulr_is_lrmorphism : lrmorphism amulr. +Proof. +split=> [|a u]; last by apply/lfunP=> w; rewrite scale_lfunE !lfunE /= scalerAr. +split=> [u v|]; first by apply/lfunP => w; do 3!rewrite !lfunE /= ?mulrBr. +split=> [u v|]; last by apply/lfunP=> w; rewrite id_lfunE !lfunE /= mulr1. +by apply/lfunP=> w; rewrite comp_lfunE !lfunE /= mulrA. +Qed. +Canonical amulr_additive := Eval hnf in Additive amulr_is_lrmorphism. +Canonical amulr_linear := Eval hnf in AddLinear amulr_is_lrmorphism. +Canonical amulr_rmorphism := Eval hnf in AddRMorphism amulr_is_lrmorphism. +Canonical amulr_lrmorphism := Eval hnf in LRMorphism amulr_is_lrmorphism. + +Lemma lker0_amull u : u \is a GRing.unit -> lker (amull u) == 0%VS. +Proof. by move=> Uu; apply/lker0P=> v w; rewrite !lfunE; apply: mulrI. Qed. + +Lemma lker0_amulr u : u \is a GRing.unit -> lker (amulr u) == 0%VS. +Proof. by move=> Uu; apply/lker0P=> v w; rewrite !lfunE; apply: mulIr. Qed. + +Lemma lfun1_poly (p : {poly aT}) : map_poly \1%VF p = p. +Proof. by apply: map_poly_id => u _; apply: id_lfunE. Qed. + +Fact prodv_key : unit. Proof. by []. Qed. +Definition prodv := + locked_with prodv_key (fun U V => <>%VS). +Canonical prodv_unlockable := [unlockable fun prodv]. +Local Notation "A * B" := (prodv A B) : vspace_scope. + +Lemma memv_mul U V : {in U & V, forall u v, u * v \in (U * V)%VS}. +Proof. +move=> u v /coord_vbasis-> /coord_vbasis->. +rewrite mulr_suml; apply: memv_suml => i _. +rewrite mulr_sumr; apply: memv_suml => j _. +rewrite -scalerAl -scalerAr !memvZ // [prodv]unlock memv_span //. +by apply/allpairsP; exists ((vbasis U)`_i, (vbasis V)`_j); rewrite !memt_nth. +Qed. + +Lemma prodvP {U V W} : + reflect {in U & V, forall u v, u * v \in W} (U * V <= W)%VS. +Proof. +apply: (iffP idP) => [sUVW u v Uu Vv | sUVW]. + by rewrite (subvP sUVW) ?memv_mul. +rewrite [prodv]unlock; apply/span_subvP=> _ /allpairsP[[u v] /= [Uu Vv ->]]. +by rewrite sUVW ?vbasis_mem. +Qed. + +Lemma prodv_line u v : (<[u]> * <[v]> = <[u * v]>)%VS. +Proof. +apply: subv_anti; rewrite -memvE memv_mul ?memv_line // andbT. +apply/prodvP=> _ _ /vlineP[a ->] /vlineP[b ->]. +by rewrite -scalerAr -scalerAl !memvZ ?memv_line. +Qed. + +Lemma dimv1: \dim (1%VS : {vspace aT}) = 1%N. +Proof. by rewrite dim_vline oner_neq0. Qed. + +Lemma dim_prodv U V : \dim (U * V) <= \dim U * \dim V. +Proof. by rewrite unlock (leq_trans (dim_span _)) ?size_tuple. Qed. + +Lemma vspace1_neq0 : (1 != 0 :> {vspace aT})%VS. +Proof. by rewrite -dimv_eq0 dimv1. Qed. + +Lemma vbasis1 : exists2 k, k != 0 & vbasis 1 = [:: k%:A] :> seq aT. +Proof. +move: (vbasis 1) (@vbasisP K aT 1); rewrite dim_vline oner_neq0. +case/tupleP=> x X0; rewrite {X0}tuple0 => defX; have Xx := mem_head x nil. +have /vlineP[k def_x] := basis_mem defX Xx; exists k; last by rewrite def_x. +by have:= basis_not0 defX Xx; rewrite def_x scaler_eq0 oner_eq0 orbF. +Qed. + +Lemma prod0v : left_zero 0%VS prodv. +Proof. +move=> U; apply/eqP; rewrite -dimv_eq0 -leqn0 (leq_trans (dim_prodv 0 U)) //. +by rewrite dimv0. +Qed. + +Lemma prodv0 : right_zero 0%VS prodv. +Proof. +move=> U; apply/eqP; rewrite -dimv_eq0 -leqn0 (leq_trans (dim_prodv U 0)) //. +by rewrite dimv0 muln0. +Qed. + +Canonical prodv_muloid := Monoid.MulLaw prod0v prodv0. + +Lemma prod1v : left_id 1%VS prodv. +Proof. +move=> U; apply/subv_anti/andP; split. + by apply/prodvP=> _ u /vlineP[a ->] Uu; rewrite mulr_algl memvZ. +by apply/subvP=> u Uu; rewrite -[u]mul1r memv_mul ?memv_line. +Qed. + +Lemma prodv1 : right_id 1%VS prodv. +Proof. +move=> U; apply/subv_anti/andP; split. + by apply/prodvP=> u _ Uu /vlineP[a ->]; rewrite mulr_algr memvZ. +by apply/subvP=> u Uu; rewrite -[u]mulr1 memv_mul ?memv_line. +Qed. + +Lemma prodvS U1 U2 V1 V2 : (U1 <= U2 -> V1 <= V2 -> U1 * V1 <= U2 * V2)%VS. +Proof. +move/subvP=> sU12 /subvP sV12; apply/prodvP=> u v Uu Vv. +by rewrite memv_mul ?sU12 ?sV12. +Qed. + +Lemma prodvSl U1 U2 V : (U1 <= U2 -> U1 * V <= U2 * V)%VS. +Proof. by move/prodvS->. Qed. + +Lemma prodvSr U V1 V2 : (V1 <= V2 -> U * V1 <= U * V2)%VS. +Proof. exact: prodvS. Qed. + +Lemma prodvDl : left_distributive prodv addv. +Proof. +move=> U1 U2 V; apply/esym/subv_anti/andP; split. + by rewrite subv_add 2?prodvS ?addvSl ?addvSr. +apply/prodvP=> _ v /memv_addP[u1 Uu1 [u2 Uu2 ->]] Vv. +by rewrite mulrDl memv_add ?memv_mul. +Qed. + +Lemma prodvDr : right_distributive prodv addv. +Proof. +move=> U V1 V2; apply/esym/subv_anti/andP; split. + by rewrite subv_add 2?prodvS ?addvSl ?addvSr. +apply/prodvP=> u _ Uu /memv_addP[v1 Vv1 [v2 Vv2 ->]]. +by rewrite mulrDr memv_add ?memv_mul. +Qed. + +Canonical addv_addoid := Monoid.AddLaw prodvDl prodvDr. + +Lemma prodvA : associative prodv. +Proof. +move=> U V W; rewrite -(span_basis (vbasisP U)) span_def !big_distrl /=. +apply: eq_bigr => u _; rewrite -(span_basis (vbasisP W)) span_def !big_distrr. +apply: eq_bigr => w _; rewrite -(span_basis (vbasisP V)) span_def /=. +rewrite !(big_distrl, big_distrr) /=; apply: eq_bigr => v _. +by rewrite !prodv_line mulrA. +Qed. + +Canonical prodv_monoid := Monoid.Law prodvA prod1v prodv1. + +Definition expv U n := iterop n.+1.-1 prodv U 1%VS. +Local Notation "A ^+ n" := (expv A n) : vspace_scope. + +Lemma expv0 U : (U ^+ 0 = 1)%VS. Proof. by []. Qed. +Lemma expv1 U : (U ^+ 1 = U)%VS. Proof. by []. Qed. +Lemma expv2 U : (U ^+ 2 = U * U)%VS. Proof. by []. Qed. + +Lemma expvSl U n : (U ^+ n.+1 = U * U ^+ n)%VS. +Proof. by case: n => //; rewrite prodv1. Qed. + +Lemma expv0n n : (0 ^+ n = if n is _.+1 then 0 else 1)%VS. +Proof. by case: n => // n; rewrite expvSl prod0v. Qed. + +Lemma expv1n n : (1 ^+ n = 1)%VS. +Proof. by elim: n => // n IHn; rewrite expvSl IHn prodv1. Qed. + +Lemma expvD U m n : (U ^+ (m + n) = U ^+ m * U ^+ n)%VS. +Proof. by elim: m => [|m IHm]; rewrite ?prod1v // !expvSl IHm prodvA. Qed. + +Lemma expvSr U n : (U ^+ n.+1 = U ^+ n * U)%VS. +Proof. by rewrite -addn1 expvD. Qed. + +Lemma expvM U m n : (U ^+ (m * n) = U ^+ m ^+ n)%VS. +Proof. by elim: n => [|n IHn]; rewrite ?muln0 // mulnS expvD IHn expvSl. Qed. + +Lemma expvS U V n : (U <= V -> U ^+ n <= V ^+ n)%VS. +Proof. +move=> sUV; elim: n => [|n IHn]; first by rewrite !expv0 subvv. +by rewrite !expvSl prodvS. +Qed. + +Lemma expv_line u n : (<[u]> ^+ n = <[u ^+ n]>)%VS. +Proof. +elim: n => [|n IH]; first by rewrite expr0 expv0. +by rewrite exprS expvSl IH prodv_line. +Qed. + +(* Centralisers and centers. *) + +Definition centraliser1_vspace u := lker (amulr u - amull u). +Local Notation "'C [ u ]" := (centraliser1_vspace u) : vspace_scope. +Definition centraliser_vspace V := (\bigcap_i 'C[tnth (vbasis V) i])%VS. +Local Notation "'C ( V )" := (centraliser_vspace V) : vspace_scope. +Definition center_vspace V := (V :&: 'C(V))%VS. +Local Notation "'Z ( V )" := (center_vspace V) : vspace_scope. + +Lemma cent1vP u v : reflect (u * v = v * u) (u \in 'C[v]%VS). +Proof. by rewrite (sameP eqlfunP eqP) !lfunE /=; apply: eqP. Qed. + +Lemma cent1v1 u : 1 \in 'C[u]%VS. Proof. by apply/cent1vP; rewrite commr1. Qed. +Lemma cent1v_id u : u \in 'C[u]%VS. Proof. exact/cent1vP. Qed. +Lemma cent1vX u n : u ^+ n \in 'C[u]%VS. Proof. exact/cent1vP/esym/commrX. Qed. +Lemma cent1vC u v : (u \in 'C[v])%VS = (v \in 'C[u])%VS. +Proof. exact/cent1vP/cent1vP. Qed. + +Lemma centvP u V : reflect {in V, forall v, u * v = v * u} (u \in 'C(V))%VS. +Proof. +apply: (iffP subv_bigcapP) => [cVu y /coord_vbasis-> | cVu i _]. + apply/esym/cent1vP/rpred_sum=> i _; apply: rpredZ. + by rewrite -tnth_nth cent1vC memvE cVu. +exact/cent1vP/cVu/vbasis_mem/mem_tnth. +Qed. +Lemma centvsP U V : reflect {in U & V, commutative *%R} (U <= 'C(V))%VS. +Proof. by apply: (iffP subvP) => [cUV u v | cUV u] /cUV-/centvP; apply. Qed. + +Lemma subv_cent1 U v : (U <= 'C[v])%VS = (v \in 'C(U)%VS). +Proof. +by apply/subvP/centvP=> cUv u Uu; apply/cent1vP; rewrite 1?cent1vC cUv. +Qed. + +Lemma centv1 V : 1 \in 'C(V)%VS. +Proof. by apply/centvP=> v _; rewrite commr1. Qed. +Lemma centvX V u n : u \in 'C(V)%VS -> u ^+ n \in 'C(V)%VS. +Proof. by move/centvP=> cVu; apply/centvP=> v /cVu/esym/commrX->. Qed. +Lemma centvC U V : (U <= 'C(V))%VS = (V <= 'C(U))%VS. +Proof. by apply/centvsP/centvsP=> cUV u v UVu /cUV->. Qed. + +Lemma centerv_sub V : ('Z(V) <= V)%VS. Proof. exact: capvSl. Qed. +Lemma cent_centerv V : (V <= 'C('Z(V)))%VS. +Proof. by rewrite centvC capvSr. Qed. + +(* Building the predicate that checks is a vspace has a unit *) +Definition is_algid e U := + [/\ e \in U, e != 0 & {in U, forall u, e * u = u /\ u * e = u}]. + +Fact algid_decidable U : decidable (exists e, is_algid e U). +Proof. +have [-> | nzU] := eqVneq U 0%VS. + by right=> [[e []]]; rewrite memv0 => ->. +pose X := vbasis U; pose feq f1 f2 := [tuple of map f1 X ++ map f2 X]. +have feqL f i: tnth (feq _ f _) (lshift _ i) = f X`_i. + set v := f _; rewrite (tnth_nth v) /= nth_cat size_map size_tuple. + by rewrite ltn_ord (nth_map 0) ?size_tuple. +have feqR f i: tnth (feq _ _ f) (rshift _ i) = f X`_i. + set v := f _; rewrite (tnth_nth v) /= nth_cat size_map size_tuple. + by rewrite ltnNge leq_addr addKn /= (nth_map 0) ?size_tuple. +apply: decP (vsolve_eq (feq _ amulr amull) (feq _ id id) U) _. +apply: (iffP (vsolve_eqP _ _ _)) => [[e Ue id_e] | [e [Ue _ id_e]]]. + suffices idUe: {in U, forall u, e * u = u /\ u * e = u}. + exists e; split=> //; apply: contraNneq nzU => e0; rewrite -subv0. + by apply/subvP=> u /idUe[<- _]; rewrite e0 mul0r mem0v. + move=> u /coord_vbasis->; rewrite mulr_sumr mulr_suml. + split; apply/eq_bigr=> i _; rewrite -(scalerAr, scalerAl); congr (_ *: _). + by have:= id_e (lshift _ i); rewrite !feqL lfunE. + by have:= id_e (rshift _ i); rewrite !feqR lfunE. +have{id_e} /all_and2[ideX idXe]:= id_e _ (vbasis_mem (mem_tnth _ X)). +exists e => // k; rewrite -[k]splitK. +by case: (split k) => i; rewrite !(feqL, feqR) lfunE /= -tnth_nth. +Qed. + +Definition has_algid : pred {vspace aT} := algid_decidable. + +Lemma has_algidP {U} : reflect (exists e, is_algid e U) (has_algid U). +Proof. exact: sumboolP. Qed. + +Lemma has_algid1 U : 1 \in U -> has_algid U. +Proof. +move=> U1; apply/has_algidP; exists 1; split; rewrite ?oner_eq0 // => u _. +by rewrite mulr1 mul1r. +Qed. + +Definition is_aspace U := has_algid U && (U * U <= U)%VS. +Structure aspace := ASpace {asval :> {vspace aT}; _ : is_aspace asval}. +Definition aspace_of of phant aT := aspace. +Local Notation "{ 'aspace' T }" := (aspace_of (Phant T)) : type_scope. + +Canonical aspace_subType := Eval hnf in [subType for asval]. +Definition aspace_eqMixin := [eqMixin of aspace by <:]. +Canonical aspace_eqType := Eval hnf in EqType aspace aspace_eqMixin. +Definition aspace_choiceMixin := [choiceMixin of aspace by <:]. +Canonical aspace_choiceType := Eval hnf in ChoiceType aspace aspace_choiceMixin. + +Canonical aspace_of_subType := Eval hnf in [subType of {aspace aT}]. +Canonical aspace_of_eqType := Eval hnf in [eqType of {aspace aT}]. +Canonical aspace_of_choiceType := Eval hnf in [choiceType of {aspace aT}]. + +Definition clone_aspace U (A : {aspace aT}) := + fun algU & phant_id algU (valP A) => @ASpace U algU : {aspace aT}. + +Fact aspace1_subproof : is_aspace 1. +Proof. by rewrite /is_aspace prod1v -memvE has_algid1 memv_line. Qed. +Canonical aspace1 : {aspace aT} := ASpace aspace1_subproof. + +Lemma aspacef_subproof : is_aspace fullv. +Proof. by rewrite /is_aspace subvf has_algid1 ?memvf. Qed. +Canonical aspacef : {aspace aT} := ASpace aspacef_subproof. + +Lemma polyOver1P p : + reflect (exists q, p = map_poly (in_alg aT) q) (p \is a polyOver 1%VS). +Proof. +apply: (iffP idP) => [/allP/=Qp | [q ->]]; last first. + by apply/polyOverP=> j; rewrite coef_map rpredZ ?memv_line. +exists (map_poly (coord [tuple 1] 0) p). +rewrite -map_poly_comp map_poly_id // => _ /Qp/vlineP[a ->] /=. +by rewrite linearZ /= (coord_free 0) ?mulr1 // seq1_free ?oner_eq0. +Qed. + +End FalgebraTheory. + +Delimit Scope aspace_scope with AS. +Bind Scope aspace_scope with aspace. +Bind Scope aspace_scope with aspace_of. +Arguments Scope asval [_ _ aspace_scope]. +Arguments Scope clone_aspace [_ _ vspace_scope aspace_scope _ _]. + +Notation "{ 'aspace' T }" := (aspace_of (Phant T)) : type_scope. +Notation "A * B" := (prodv A B) : vspace_scope. +Notation "A ^+ n" := (expv A n) : vspace_scope. +Notation "'C [ u ]" := (centraliser1_vspace u) : vspace_scope. +Notation "'C_ U [ v ]" := (capv U 'C[v]) : vspace_scope. +Notation "'C_ ( U ) [ v ]" := (capv U 'C[v]) (only parsing) : vspace_scope. +Notation "'C ( V )" := (centraliser_vspace V) : vspace_scope. +Notation "'C_ U ( V )" := (capv U 'C(V)) : vspace_scope. +Notation "'C_ ( U ) ( V )" := (capv U 'C(V)) (only parsing) : vspace_scope. +Notation "'Z ( V )" := (center_vspace V) : vspace_scope. + +Notation "1" := (aspace1 _) : aspace_scope. +Notation "{ : aT }" := (aspacef aT) : aspace_scope. +Notation "[ 'aspace' 'of' U ]" := (@clone_aspace _ _ U _ _ id) + (at level 0, format "[ 'aspace' 'of' U ]") : form_scope. +Notation "[ 'aspace' 'of' U 'for' A ]" := (@clone_aspace _ _ U A _ idfun) + (at level 0, format "[ 'aspace' 'of' U 'for' A ]") : form_scope. + +Implicit Arguments prodvP [K aT U V W]. +Implicit Arguments cent1vP [K aT u v]. +Implicit Arguments centvP [K aT u V]. +Implicit Arguments centvsP [K aT U V]. +Implicit Arguments has_algidP [K aT U]. +Implicit Arguments polyOver1P [K aT p]. + +Section AspaceTheory. + +Variables (K : fieldType) (aT : FalgType K). +Implicit Types (u v e : aT) (U V : {vspace aT}) (A B : {aspace aT}). +Import FalgLfun. + +Lemma algid_subproof U : + {e | e \in U + & has_algid U ==> (U <= lker (amull e - 1) :&: lker (amulr e - 1))%VS}. +Proof. +apply: sig2W; case: has_algidP => [[e]|]; last by exists 0; rewrite ?mem0v. +case=> Ae _ idAe; exists e => //; apply/subvP=> u /idAe[eu_u ue_u]. +by rewrite memv_cap !memv_ker !lfun_simp /= eu_u ue_u subrr eqxx. +Qed. + +Definition algid U := s2val (algid_subproof U). + +Lemma memv_algid U : algid U \in U. +Proof. by rewrite /algid; case: algid_subproof. Qed. + +Lemma algidl A : {in A, left_id (algid A) *%R}. +Proof. +rewrite /algid; case: algid_subproof => e _ /=; have /andP[-> _] := valP A. +move/subvP=> idAe u /idAe/memv_capP[]. +by rewrite memv_ker !lfun_simp /= subr_eq0 => /eqP. +Qed. + +Lemma algidr A : {in A, right_id (algid A) *%R}. +Proof. +rewrite /algid; case: algid_subproof => e _ /=; have /andP[-> _] := valP A. +move/subvP=> idAe u /idAe/memv_capP[_]. +by rewrite memv_ker !lfun_simp /= subr_eq0 => /eqP. +Qed. + +Lemma unitr_algid1 A u : u \in A -> u \is a GRing.unit -> algid A = 1. +Proof. by move=> Eu /mulrI; apply; rewrite mulr1 algidr. Qed. + +Lemma algid_eq1 A : (algid A == 1) = (1 \in A). +Proof. by apply/eqP/idP=> [<- | /algidr <-]; rewrite ?memv_algid ?mul1r. Qed. + +Lemma algid_neq0 A : algid A != 0. +Proof. +have /andP[/has_algidP[u [Au nz_u _]] _] := valP A. +by apply: contraNneq nz_u => e0; rewrite -(algidr Au) e0 mulr0. +Qed. + +Lemma dim_algid A : \dim <[algid A]> = 1%N. +Proof. by rewrite dim_vline algid_neq0. Qed. + +Lemma adim_gt0 A : (0 < \dim A)%N. +Proof. by rewrite -(dim_algid A) dimvS // -memvE ?memv_algid. Qed. + +Lemma not_asubv0 A : ~~ (A <= 0)%VS. +Proof. by rewrite subv0 -dimv_eq0 -lt0n adim_gt0. Qed. + +Lemma adim1P {A} : reflect (A = <[algid A]>%VS :> {vspace aT}) (\dim A == 1%N). +Proof. +rewrite eqn_leq adim_gt0 -(memv_algid A) andbC -(dim_algid A) -eqEdim eq_sym. +exact: eqP. +Qed. + +Lemma asubv A : (A * A <= A)%VS. +Proof. by have /andP[] := valP A. Qed. + +Lemma memvM A : {in A &, forall u v, u * v \in A}. +Proof. exact/prodvP/asubv. Qed. + +Lemma prodv_id A : (A * A)%VS = A. +Proof. +apply/eqP; rewrite eqEsubv asubv; apply/subvP=> u Au. +by rewrite -(algidl Au) memv_mul // memv_algid. +Qed. + +Lemma prodv_sub U V A : (U <= A -> V <= A -> U * V <= A)%VS. +Proof. by move=> sUA sVA; rewrite -prodv_id prodvS. Qed. + +Lemma expv_id A n : (A ^+ n.+1)%VS = A. +Proof. by elim: n => // n IHn; rewrite !expvSl prodvA prodv_id -expvSl. Qed. + +Lemma limg_amulr U v : (amulr v @: U = U * <[v]>)%VS. +Proof. +rewrite -(span_basis (vbasisP U)) limg_span !span_def big_distrl /= big_map. +by apply: eq_bigr => u; rewrite prodv_line lfunE. +Qed. + +Lemma memv_cosetP {U v w} : + reflect (exists2 u, u\in U & w = u * v) (w \in U * <[v]>)%VS. +Proof. +rewrite -limg_amulr. +by apply: (iffP memv_imgP) => [] [u] Uu ->; exists u; rewrite ?lfunE. +Qed. + +Lemma dim_cosetv_unit V u : u \is a GRing.unit -> \dim (V * <[u]>) = \dim V. +Proof. +by move/lker0_amulr/eqP=> Uu; rewrite -limg_amulr limg_dim_eq // Uu capv0. +Qed. + +Lemma memvV A u : (u^-1 \in A) = (u \in A). +Proof. +suffices{u} invA: invr_closed A by apply/idP/idP=> /invA; rewrite ?invrK. +move=> u Au; have [Uu | /invr_out-> //] := boolP (u \is a GRing.unit). +rewrite memvE -(limg_ker0 _ _ (lker0_amulr Uu)) limg_line lfunE /= mulVr //. +suff ->: (amulr u @: A)%VS = A by rewrite -memvE -algid_eq1 (unitr_algid1 Au). +by apply/eqP; rewrite limg_amulr -dimv_leqif_eq ?prodv_sub ?dim_cosetv_unit. +Qed. + +Fact aspace_cap_subproof A B : algid A \in B -> is_aspace (A :&: B). +Proof. +move=> BeA; apply/andP. +split; [apply/has_algidP | by rewrite subv_cap !prodv_sub ?capvSl ?capvSr]. +exists (algid A); rewrite /is_algid algid_neq0 memv_cap memv_algid. +by split=> // u /memv_capP[Au _]; rewrite ?algidl ?algidr. +Qed. +Definition aspace_cap A B BeA := ASpace (@aspace_cap_subproof A B BeA). + +Fact centraliser1_is_aspace u : is_aspace 'C[u]. +Proof. +rewrite /is_aspace has_algid1 ?cent1v1 //=. +apply/prodvP=> v w /cent1vP-cuv /cent1vP-cuw. +by apply/cent1vP; rewrite -mulrA cuw !mulrA cuv. +Qed. +Canonical centraliser1_aspace u := ASpace (centraliser1_is_aspace u). + +Fact centraliser_is_aspace V : is_aspace 'C(V). +Proof. +rewrite /is_aspace has_algid1 ?centv1 //=. +apply/prodvP=> u w /centvP-cVu /centvP-cVw. +by apply/centvP=> v Vv; rewrite /= -mulrA cVw // !mulrA cVu. +Qed. +Canonical centraliser_aspace V := ASpace (centraliser_is_aspace V). + +Lemma centv_algid A : algid A \in 'C(A)%VS. +Proof. by apply/centvP=> u Au; rewrite algidl ?algidr. Qed. +Canonical center_aspace A := [aspace of 'Z(A) for aspace_cap (centv_algid A)]. + +Lemma algid_center A : algid 'Z(A) = algid A. +Proof. +rewrite -(algidl (subvP (centerv_sub A) _ (memv_algid _))) algidr //=. +by rewrite memv_cap memv_algid centv_algid. +Qed. + +Lemma Falgebra_FieldMixin : + GRing.IntegralDomain.axiom aT -> GRing.Field.mixin_of aT. +Proof. +move=> domT u nz_u; apply/unitrP. +have kerMu: lker (amulr u) == 0%VS. + rewrite eqEsubv sub0v andbT; apply/subvP=> v; rewrite memv_ker lfunE /=. + by move/eqP/domT; rewrite (negPf nz_u) orbF memv0. +have /memv_imgP[v _ vu1]: 1 \in limg (amulr u); last rewrite lfunE /= in vu1. + suffices /eqP->: limg (amulr u) == fullv by rewrite memvf. + by rewrite -dimv_leqif_eq ?subvf ?limg_dim_eq // (eqP kerMu) capv0. +exists v; split=> //; apply: (lker0P kerMu). +by rewrite !lfunE /= -mulrA -vu1 mulr1 mul1r. +Qed. + +Section SkewField. + +Hypothesis fieldT : GRing.Field.mixin_of aT. + +Lemma skew_field_algid1 A : algid A = 1. +Proof. by rewrite (unitr_algid1 (memv_algid A)) ?fieldT ?algid_neq0. Qed. + +Lemma skew_field_module_semisimple A M : + let sumA X := (\sum_(x <- X) A * <[x]>)%VS in + (A * M <= M)%VS -> {X | [/\ sumA X = M, directv (sumA X) & 0 \notin X]}. +Proof. +move=> sumA sAM_M; pose X := Nil aT; pose k := (\dim (A * M) - \dim (sumA X))%N. +have: (\dim (A * M) - \dim (sumA X) < k.+1)%N by []. +have: [/\ (sumA X <= A * M)%VS, directv (sumA X) & 0 \notin X]. + by rewrite /sumA directvE /= !big_nil sub0v dimv0. +elim: {X k}k.+1 (X) => // k IHk X [sAX_AM dxAX nzX]; rewrite ltnS => leAXk. +have [sM_AX | /subvPn/sig2W[y My notAXy]] := boolP (M <= sumA X)%VS. + by exists X; split=> //; apply/eqP; rewrite eqEsubv (subv_trans sAX_AM). +have nz_y: y != 0 by rewrite (memPnC notAXy) ?mem0v. +pose AY := sumA (y :: X). +have sAY_AM: (AY <= A * M)%VS by rewrite [AY]big_cons subv_add ?prodvSr. +have dxAY: directv AY. + rewrite directvE /= !big_cons [_ == _]directv_addE dxAX directvE eqxx /=. + rewrite -/(sumA X) eqEsubv sub0v andbT -limg_amulr. + apply/subvP=> _ /memv_capP[/memv_imgP[a Aa ->]]; rewrite lfunE /= => AXay. + rewrite memv0 (mulIr_eq0 a (mulIr _)) ?fieldT //. + apply: contraR notAXy => /fieldT-Ua; rewrite -[y](mulKr Ua) /sumA. + by rewrite -big_distrr -(prodv_id A) /= -prodvA big_distrr memv_mul ?memvV. +apply: (IHk (y :: X)); first by rewrite !inE eq_sym negb_or nz_y. +rewrite -subSn ?dimvS // (directvP dxAY) /= big_cons -(directvP dxAX) /=. +rewrite subnDA (leq_trans _ leAXk) ?leq_sub2r // leq_subLR -add1n leq_add2r. +by rewrite dim_cosetv_unit ?fieldT ?adim_gt0. +Qed. + +Lemma skew_field_module_dimS A M : (A * M <= M)%VS -> \dim A %| \dim M. +Proof. +case/skew_field_module_semisimple=> X [<- /directvP-> nzX] /=. +rewrite big_seq prime.dvdn_sum // => x /(memPn nzX)nz_x. +by rewrite dim_cosetv_unit ?fieldT. +Qed. + +Lemma skew_field_dimS A B : (A <= B)%VS -> \dim A %| \dim B. +Proof. by move=> sAB; rewrite skew_field_module_dimS ?prodv_sub. Qed. + +End SkewField. + +End AspaceTheory. + +(* Note that local centraliser might not be proper sub-algebras. *) +Notation "'C [ u ]" := (centraliser1_aspace u) : aspace_scope. +Notation "'C ( V )" := (centraliser_aspace V) : aspace_scope. +Notation "'Z ( A )" := (center_aspace A) : aspace_scope. + +Implicit Arguments adim1P [K aT A]. +Implicit Arguments memv_cosetP [K aT U v w]. + +Section Closure. + +Variables (K : fieldType) (aT : FalgType K). +Implicit Types (u v : aT) (U V W : {vspace aT}). + +(* Subspaces of an F-algebra form a Kleene algebra *) +Definition agenv U := (\sum_(i < \dim {:aT}) U ^+ i)%VS. +Local Notation "<< U & vs >>" := (agenv (U + <>)) : vspace_scope. +Local Notation "<< U ; x >>" := (agenv (U + <[x]>)) : vspace_scope. + +Lemma agenvEl U : agenv U = (1 + U * agenv U)%VS. +Proof. +pose f V := (1 + U * V)%VS; rewrite -/(f _); pose n := \dim {:aT}. +have ->: agenv U = iter n f 0%VS. + rewrite /agenv -/n; elim: n => [|n IHn]; first by rewrite big_ord0. + rewrite big_ord_recl /= -{}IHn; congr (1 + _)%VS; rewrite big_distrr /=. + by apply: eq_bigr => i; rewrite expvSl. +have fS i j: i <= j -> (iter i f 0 <= iter j f 0)%VS. + by elim: i j => [|i IHi] [|j] leij; rewrite ?sub0v //= addvS ?prodvSr ?IHi. +suffices /(@trajectP _ f _ n.+1)[i le_i_n Dfi]: looping f 0%VS n.+1. + by apply/eqP; rewrite eqEsubv -iterS fS // Dfi fS. +apply: contraLR (dimvS (subvf (iter n.+1 f 0%VS))); rewrite -/n -ltnNge. +rewrite -looping_uniq; elim: n.+1 => // i IHi; rewrite trajectSr rcons_uniq. +rewrite {1}trajectSr mem_rcons inE negb_or eq_sym eqEdim fS ?leqW // -ltnNge. +by rewrite -andbA => /and3P[lt_fi _ /IHi/leq_ltn_trans->]. +Qed. + +Lemma agenvEr U : agenv U = (1 + agenv U * U)%VS. +Proof. +rewrite [lhs in lhs = _]agenvEl big_distrr big_distrl /=; congr (_ + _)%VS. +by apply: eq_bigr => i _ /=; rewrite -expvSr -expvSl. +Qed. + +Lemma agenv_modl U V : (U * V <= V -> agenv U * V <= V)%VS. +Proof. +rewrite big_distrl /= => idlU_V; apply/subv_sumP=> [[i _] /= _]. +elim: i => [|i]; first by rewrite expv0 prod1v. +by apply: subv_trans; rewrite expvSr -prodvA prodvSr. +Qed. + +Lemma agenv_modr U V : (V * U <= V -> V * agenv U <= V)%VS. +Proof. +rewrite big_distrr /= => idrU_V; apply/subv_sumP=> [[i _] /= _]. +elim: i => [|i]; first by rewrite expv0 prodv1. +by apply: subv_trans; rewrite expvSl prodvA prodvSl. +Qed. + +Fact agenv_is_aspace U : is_aspace (agenv U). +Proof. +rewrite /is_aspace has_algid1; last by rewrite memvE agenvEl addvSl. +by rewrite agenv_modl // [V in (_ <= V)%VS]agenvEl addvSr. +Qed. +Canonical agenv_aspace U : {aspace aT} := ASpace (agenv_is_aspace U). + +Lemma agenvE U : agenv U = agenv_aspace U. Proof. by []. Qed. + +(* Kleene algebra properties *) + +Lemma agenvM U : (agenv U * agenv U)%VS = agenv U. Proof. exact: prodv_id. Qed. +Lemma agenvX n U : (agenv U ^+ n.+1)%VS = agenv U. Proof. exact: expv_id. Qed. + +Lemma sub1_agenv U : (1 <= agenv U)%VS. Proof. by rewrite agenvEl addvSl. Qed. + +Lemma sub_agenv U : (U <= agenv U)%VS. +Proof. by rewrite 2!agenvEl addvC prodvDr prodv1 -addvA addvSl. Qed. + +Lemma subX_agenv U n : (U ^+ n <= agenv U)%VS. +Proof. +by case: n => [|n]; rewrite ?sub1_agenv // -(agenvX n) expvS // sub_agenv. +Qed. + +Lemma agenv_sub_modl U V : (1 <= V -> U * V <= V -> agenv U <= V)%VS. +Proof. +move=> s1V /agenv_modl; apply: subv_trans. +by rewrite -[Us in (Us <= _)%VS]prodv1 prodvSr. +Qed. + +Lemma agenv_sub_modr U V : (1 <= V -> V * U <= V -> agenv U <= V)%VS. +Proof. +move=> s1V /agenv_modr; apply: subv_trans. +by rewrite -[Us in (Us <= _)%VS]prod1v prodvSl. +Qed. + +Lemma agenv_id U : agenv (agenv U) = agenv U. +Proof. +apply/eqP; rewrite eqEsubv sub_agenv andbT. +by rewrite agenv_sub_modl ?sub1_agenv ?agenvM. +Qed. + +Lemma agenvS U V : (U <= V -> agenv U <= agenv V)%VS. +Proof. +move=> sUV; rewrite agenv_sub_modl ?sub1_agenv //. +by rewrite -[Vs in (_ <= Vs)%VS]agenvM prodvSl ?(subv_trans sUV) ?sub_agenv. +Qed. + +Lemma agenv_add_id U V : agenv (agenv U + V) = agenv (U + V). +Proof. +apply/eqP; rewrite eqEsubv andbC agenvS ?addvS ?sub_agenv //=. +rewrite agenv_sub_modl ?sub1_agenv //. +rewrite -[rhs in (_ <= rhs)%VS]agenvM prodvSl // subv_add agenvS ?addvSl //=. +exact: subv_trans (addvSr U V) (sub_agenv _). +Qed. + +Lemma subv_adjoin U x : (U <= <>)%VS. +Proof. by rewrite (subv_trans (sub_agenv _)) ?agenvS ?addvSl. Qed. + +Lemma subv_adjoin_seq U xs : (U <= <>)%VS. +Proof. by rewrite (subv_trans (sub_agenv _)) // ?agenvS ?addvSl. Qed. + +Lemma memv_adjoin U x : x \in <>%VS. +Proof. by rewrite memvE (subv_trans (sub_agenv _)) ?agenvS ?addvSr. Qed. + +Lemma seqv_sub_adjoin U xs : {subset xs <= <>%VS}. +Proof. +by apply/span_subvP; rewrite (subv_trans (sub_agenv _)) ?agenvS ?addvSr. +Qed. + +Lemma subvP_adjoin U x y : y \in U -> y \in <>%VS. +Proof. exact/subvP/subv_adjoin. Qed. + +Lemma adjoin_nil V : <>%VS = agenv V. +Proof. by rewrite span_nil addv0. Qed. + +Lemma adjoin_cons V x rs : <>%VS = << <> & rs>>%VS. +Proof. by rewrite span_cons addvA agenv_add_id. Qed. + +Lemma adjoin_rcons V rs x : <>%VS = << <>%VS; x>>%VS. +Proof. by rewrite -cats1 span_cat addvA span_seq1 agenv_add_id. Qed. + +Lemma adjoin_seq1 V x : <>%VS = <>%VS. +Proof. by rewrite adjoin_cons adjoin_nil agenv_id. Qed. + +Lemma adjoinC V x y : << <>; y>>%VS = << <>; x>>%VS. +Proof. by rewrite !agenv_add_id -!addvA (addvC <[x]>%VS). Qed. + +Lemma adjoinSl U V x : (U <= V -> <> <= <>)%VS. +Proof. by move=> sUV; rewrite agenvS ?addvS. Qed. + +Lemma adjoin_seqSl U V rs : (U <= V -> <> <= <>)%VS. +Proof. by move=> sUV; rewrite agenvS ?addvS. Qed. + +Lemma adjoin_seqSr U rs1 rs2 : + {subset rs1 <= rs2} -> (<> <= <>)%VS. +Proof. by move/sub_span=> s_rs12; rewrite agenvS ?addvS. Qed. + +End Closure. + +Notation "<< U >>" := (agenv_aspace U) : aspace_scope. +Notation "<< U & vs >>" := (agenv (U + <>)) : vspace_scope. +Notation "<< U ; x >>" := (agenv (U + <[x]>)) : vspace_scope. +Notation "<< U & vs >>" := << U + <> >>%AS : aspace_scope. +Notation "<< U ; x >>" := << U + <[x]> >>%AS : aspace_scope. + +Section SubFalgType. + +(* The FalgType structure of subvs_of A for A : {aspace aT}. *) +(* We can't use the rpred-based mixin, because A need not contain 1. *) +Variable (K : fieldType) (aT : FalgType K) (A : {aspace aT}). + +Definition subvs_one := Subvs (memv_algid A). +Definition subvs_mul (u v : subvs_of A) := + Subvs (subv_trans (memv_mul (subvsP u) (subvsP v)) (asubv _)). + +Fact subvs_mulA : associative subvs_mul. +Proof. by move=> x y z; apply/val_inj/mulrA. Qed. +Fact subvs_mu1l : left_id subvs_one subvs_mul. +Proof. by move=> x; apply/val_inj/algidl/(valP x). Qed. +Fact subvs_mul1 : right_id subvs_one subvs_mul. +Proof. by move=> x; apply/val_inj/algidr/(valP x). Qed. +Fact subvs_mulDl : left_distributive subvs_mul +%R. +Proof. move=> x y z; apply/val_inj/mulrDl. Qed. +Fact subvs_mulDr : right_distributive subvs_mul +%R. +Proof. move=> x y z; apply/val_inj/mulrDr. Qed. + +Definition subvs_ringMixin := + RingMixin subvs_mulA subvs_mu1l subvs_mul1 subvs_mulDl subvs_mulDr + (algid_neq0 _). +Canonical subvs_ringType := Eval hnf in RingType (subvs_of A) subvs_ringMixin. + +Lemma subvs_scaleAl k (x y : subvs_of A) : k *: (x * y) = (k *: x) * y. +Proof. exact/val_inj/scalerAl. Qed. +Canonical subvs_lalgType := Eval hnf in LalgType K (subvs_of A) subvs_scaleAl. + +Lemma subvs_scaleAr k (x y : subvs_of A) : k *: (x * y) = x * (k *: y). +Proof. exact/val_inj/scalerAr. Qed. +Canonical subvs_algType := Eval hnf in AlgType K (subvs_of A) subvs_scaleAr. + +Canonical subvs_unitRingType := Eval hnf in FalgUnitRingType (subvs_of A). +Canonical subvs_unitAlgType := Eval hnf in [unitAlgType K of subvs_of A]. +Canonical subvs_FalgType := Eval hnf in [FalgType K of subvs_of A]. + +Implicit Type w : subvs_of A. + +Lemma vsval_unitr w : vsval w \is a GRing.unit -> w \is a GRing.unit. +Proof. +case: w => /= u Au Uu; have Au1: u^-1 \in A by rewrite memvV. +apply/unitrP; exists (Subvs Au1). +by split; apply: val_inj; rewrite /= ?mulrV ?mulVr ?(unitr_algid1 Au). +Qed. + +Lemma vsval_invr w : vsval w \is a GRing.unit -> val w^-1 = (val w)^-1. +Proof. +move=> Uu; have def_w: w / w * w = w by rewrite divrK ?vsval_unitr. +by apply: (mulrI Uu); rewrite -[in u in u / _]def_w ?mulrK. +Qed. + +End SubFalgType. + +Section AHom. + +Variable K : fieldType. + +Section Class_Def. + +Variables aT rT : FalgType K. + +Definition ahom_in (U : {vspace aT}) (f : 'Hom(aT, rT)) := + let fM_at x y := f (x * y) == f x * f y in + all (fun x => all (fM_at x) (vbasis U)) (vbasis U) && (f 1 == 1). + +Lemma ahom_inP {f : 'Hom(aT, rT)} {U : {vspace aT}} : + reflect ({in U &, {morph f : x y / x * y >-> x * y}} * (f 1 = 1)) + (ahom_in U f). +Proof. +apply: (iffP andP) => [[/allP fM /eqP f1] | [fM f1]]; last first. + rewrite f1; split=> //; apply/allP=> x Ax; apply/allP=> y Ay. + by rewrite fM // vbasis_mem. +split=> // x y /coord_vbasis -> /coord_vbasis ->. +rewrite !mulr_suml ![f _]linear_sum mulr_suml; apply: eq_bigr => i _ /=. +rewrite !mulr_sumr linear_sum; apply: eq_bigr => j _ /=. +rewrite !linearZ -!scalerAr -!scalerAl 2!linearZ /=; congr (_ *: (_ *: _)). +by apply/eqP/(allP (fM _ _)); apply: memt_nth. +Qed. + +Lemma ahomP {f : 'Hom(aT, rT)} : reflect (lrmorphism f) (ahom_in {:aT} f). +Proof. +apply: (iffP ahom_inP) => [[fM f1] | fRM_P]; last first. + pose fRM := LRMorphism fRM_P. + by split; [apply: in2W (rmorphM fRM) | apply: (rmorph1 fRM)]. +split; last exact: linearZZ; split; first exact: linearB. +by split=> // x y; rewrite fM ?memvf. +Qed. + +Structure ahom := AHom {ahval :> 'Hom(aT, rT); _ : ahom_in {:aT} ahval}. + +Canonical ahom_subType := Eval hnf in [subType for ahval]. +Definition ahom_eqMixin := [eqMixin of ahom by <:]. +Canonical ahom_eqType := Eval hnf in EqType ahom ahom_eqMixin. + +Definition ahom_choiceMixin := [choiceMixin of ahom by <:]. +Canonical ahom_choiceType := Eval hnf in ChoiceType ahom ahom_choiceMixin. + +Fact linfun_is_ahom (f : {lrmorphism aT -> rT}) : ahom_in {:aT} (linfun f). +Proof. by apply/ahom_inP; split=> [x y|]; rewrite !lfunE ?rmorphM ?rmorph1. Qed. +Canonical linfun_ahom f := AHom (linfun_is_ahom f). + +End Class_Def. + +Implicit Arguments ahom_in [aT rT]. +Implicit Arguments ahom_inP [aT rT f U]. +Implicit Arguments ahomP [aT rT f]. + +Section LRMorphism. + +Variables aT rT sT : FalgType K. + +Fact ahom_is_lrmorphism (f : ahom aT rT) : lrmorphism f. +Proof. by apply/ahomP; case: f. Qed. +Canonical ahom_rmorphism f := Eval hnf in AddRMorphism (ahom_is_lrmorphism f). +Canonical ahom_lrmorphism f := Eval hnf in AddLRMorphism (ahom_is_lrmorphism f). + +Lemma ahomWin (f : ahom aT rT) U : ahom_in U f. +Proof. +by apply/ahom_inP; split; [apply: in2W (rmorphM _) | apply: rmorph1]. +Qed. + +Lemma id_is_ahom (V : {vspace aT}) : ahom_in V \1. +Proof. by apply/ahom_inP; split=> [x y|] /=; rewrite !id_lfunE. Qed. +Canonical id_ahom := AHom (id_is_ahom (aspacef aT)). + +Lemma comp_is_ahom (V : {vspace aT}) (f : 'Hom(rT, sT)) (g : 'Hom(aT, rT)) : + ahom_in {:rT} f -> ahom_in V g -> ahom_in V (f \o g). +Proof. +move=> /ahom_inP fM /ahom_inP gM; apply/ahom_inP. +by split=> [x y Vx Vy|] /=; rewrite !comp_lfunE gM // fM ?memvf. +Qed. +Canonical comp_ahom (f : ahom rT sT) (g : ahom aT rT) := + AHom (comp_is_ahom (valP f) (valP g)). + +Lemma aimgM (f : ahom aT rT) U V : (f @: (U * V) = f @: U * f @: V)%VS. +Proof. +apply/eqP; rewrite eqEsubv; apply/andP; split; last first. + apply/prodvP=> _ _ /memv_imgP[u Hu ->] /memv_imgP[v Hv ->]. + by rewrite -rmorphM memv_img // memv_mul. +apply/subvP=> _ /memv_imgP[w UVw ->]; rewrite memv_preim (subvP _ w UVw) //. +by apply/prodvP=> u v Uu Vv; rewrite -memv_preim rmorphM memv_mul // memv_img. +Qed. + +Lemma aimg1 (f : ahom aT rT) : (f @: 1 = 1)%VS. +Proof. by rewrite limg_line rmorph1. Qed. + +Lemma aimgX (f : ahom aT rT) U n : (f @: (U ^+ n) = f @: U ^+ n)%VS. +Proof. +elim: n => [|n IH]; first by rewrite !expv0 aimg1. +by rewrite !expvSl aimgM IH. +Qed. + +Lemma aimg_agen (f : ahom aT rT) U : (f @: agenv U)%VS = agenv (f @: U). +Proof. +apply/eqP; rewrite eqEsubv; apply/andP; split. + by rewrite limg_sum; apply/subv_sumP => i _; rewrite aimgX subX_agenv. +apply: agenv_sub_modl; first by rewrite -(aimg1 f) limgS // sub1_agenv. +by rewrite -aimgM limgS // [rhs in (_ <= rhs)%VS]agenvEl addvSr. +Qed. + +Lemma aimg_adjoin (f : ahom aT rT) U x : (f @: <> = <>)%VS. +Proof. by rewrite aimg_agen limg_add limg_line. Qed. + +Lemma aimg_adjoin_seq (f : ahom aT rT) U xs : + (f @: <> = <>)%VS. +Proof. by rewrite aimg_agen limg_add limg_span. Qed. + +Fact ker_sub_ahom_is_aspace (f g : ahom aT rT) : + is_aspace (lker (ahval f - ahval g)). +Proof. +rewrite /is_aspace has_algid1; last by apply/eqlfunP; rewrite !rmorph1. +apply/prodvP=> a b /eqlfunP Dfa /eqlfunP Dfb. +by apply/eqlfunP; rewrite !rmorphM /= Dfa Dfb. +Qed. +Canonical ker_sub_ahom_aspace f g := ASpace (ker_sub_ahom_is_aspace f g). + +End LRMorphism. + +Canonical fixedSpace_aspace aT (f : ahom aT aT) := [aspace of fixedSpace f]. + +End AHom. + +Implicit Arguments ahom_in [K aT rT]. + +Notation "''AHom' ( aT , rT )" := (ahom aT rT) : type_scope. +Notation "''AEnd' ( aT )" := (ahom aT aT) : type_scope. + +Delimit Scope lrfun_scope with AF. +Bind Scope lrfun_scope with ahom. + +Notation "\1" := (@id_ahom _ _) : lrfun_scope. +Notation "f \o g" := (comp_ahom f g) : lrfun_scope. diff --git a/mathcomp/field/fieldext.v b/mathcomp/field/fieldext.v new file mode 100644 index 0000000..d9b181a --- /dev/null +++ b/mathcomp/field/fieldext.v @@ -0,0 +1,1626 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div choice fintype. +Require Import tuple finfun bigop ssralg finalg zmodp matrix vector falgebra. +Require Import poly polydiv mxpoly generic_quotient. + +(******************************************************************************) +(* * Finite dimensional field extentions *) +(* fieldExtType F == the interface type for finite field extensions of F *) +(* it simply combines the fieldType and FalgType F *) +(* interfaces. *) +(* [fieldExtType F of L] == a fieldExt F structure for a type L that has both *) +(* fieldType and FalgType F canonical structures. *) +(* [fieldExtType F of L for K] == a fieldExtType F structure for a type L *) +(* that has an FalgType F canonical structure, given *) +(* a K : fieldType whose unitRingType projection *) +(* coincides with the canonical unitRingType for F. *) +(* {subfield L} == the type of subfields of L that are also extensions *) +(* of F; since we are in a finite dimensional setting *) +(* these are exactly the F-subalgebras of L, and *) +(* indeed {subfield L} is just display notation for *) +(* {aspace L} when L is an extFieldType. *) +(* --> All aspace operations apply to {subfield L}, but there are several *) +(* additional lemmas and canonical instances specific to {subfield L} *) +(* spaces, e.g., subvs_of E is an extFieldType F when E : {subfield L}. *) +(* --> Also note that not all constructive subfields have type {subfield E} *) +(* in the same way that not all constructive subspaces have type *) +(* {vspace E}. These types only include the so called "detachable" *) +(* subspaces (and subalgebras). *) +(* *) +(* (E :&: F)%AS, (E * F)%AS == the intersection and product (meet and join) *) +(* of E and F as subfields. *) +(* subFExtend iota z p == Given a field morphism iota : F -> L, this is a *) +(* type for the field F^iota(z) obtained by *) +(* adjoining z to the image of F in L under iota. *) +(* The construction requires a non-zero polynomial *) +(* p in F such that z is a root of p^iota; it *) +(* returns the field F^iota if this is not so. *) +(* However, p need not be irredicible. *) +(* subfx_inj x == The injection of F^iota(z) into L. *) +(* inj_subfx iota z p x == The injection of F into F^iota(z). *) +(* subfx_eval iota z p q == Given q : {poly F} returns q.[z] as a value of *) +(* type F^iota(z). *) +(* subfx_root iota z p == The generator of F^iota(z) over F. *) +(* SubFieldExtType pz0 irr_p == A fieldExtType F structure for F^iota(z) *) +(* (more precisely, subFExtend iota z p), given *) +(* proofs pz0: root (map_poly iota p) z and *) +(* irr_p : irreducible_poly p. The corresponding *) +(* vectType substructure (SubfxVectType pz0 irr_p) *) +(* has dimension (size p).-1 over F. *) +(* minPoly K x == the monic minimal polynomial of x over the *) +(* subfield K. *) +(* adjoin_degree K x == the degree of the minimial polynomial or the *) +(* dimension of K(x)/K. *) +(* Fadjoin_poly K x y == a polynomial p over K such that y = p.[x]. *) +(* *) +(* fieldOver F == L, but with an extFieldType (subvs_of F) *) +(* structure, for F : {subfield L} *) +(* vspaceOver F V == the smallest subspace of fieldOver F containing *) +(* V; this coincides with V if V is an F-module. *) +(* baseFieldType L == L, but with an extFieldType F0 structure, when L *) +(* has a canonical extFieldType F structure and F *) +(* in turn has an extFieldType F0 structure. *) +(* baseVspace V == the subspace of baseFieldType L that coincides *) +(* with V : {vspace L}. *) +(* --> Some caution muse be exercised when using fieldOver and basFieldType, *) +(* because these are convertible to L while carrying different Lmodule *) +(* structures. This means that the safeguards engineered in the ssralg *) +(* library that normally curb the Coq kernel's inclination to diverge are *) +(* no longer effectcive, so additional precautions should be taken when *) +(* matching or rewriting terms of the form a *: u, because Coq may take *) +(* forever to realize it's dealing with a *: in the wrong structure. The *) +(* baseField_scaleE and fieldOver_scaleE lemmas should be used to expand *) +(* or fold such "trans-structure" operations explicitly beforehand. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope ring_scope. +Import GRing.Theory. + +Module FieldExt. + +Import GRing. + +Section FieldExt. + +Variable R : ringType. + +Record class_of T := Class { + base : Falgebra.class_of R T; + comm_ext : commutative (Ring.mul base); + idomain_ext : IntegralDomain.axiom (Ring.Pack base T); + field_ext : Field.mixin_of (UnitRing.Pack base T) +}. + +Local Coercion base : class_of >-> Falgebra.class_of. + +Section Bases. +Variables (T : Type) (c : class_of T). +Definition base1 := ComRing.Class (@comm_ext T c). +Definition base2 := @ComUnitRing.Class T base1 c. +Definition base3 := @IntegralDomain.Class T base2 (@idomain_ext T c). +Definition base4 := @Field.Class T base3 (@field_ext T c). +End Bases. +Local Coercion base1 : class_of >-> ComRing.class_of. +Local Coercion base2 : class_of >-> ComUnitRing.class_of. +Local Coercion base3 : class_of >-> IntegralDomain.class_of. +Local Coercion base4 : class_of >-> Field.class_of. + +Structure type (phR : phant R) := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. + +Variables (phR : phant R) (T : Type) (cT : type phR). +Definition class := let: Pack _ c _ := 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 : Falgebra.type phR) b + & phant_id (Falgebra.class bT : Falgebra.class_of R bT) + (b : Falgebra.class_of R T) => + fun mT Cm IDm Fm & phant_id (Field.class mT) (@Field.Class T + (@IntegralDomain.Class T (@ComUnitRing.Class T (@ComRing.Class T b + Cm) b) IDm) Fm) => Pack phR (@Class T b Cm IDm Fm) T. + +Definition pack_eta K := + let cK := Field.class K in let Cm := ComRing.mixin cK in + let IDm := IntegralDomain.mixin cK in let Fm := Field.mixin cK in + fun (bT : Falgebra.type phR) b & phant_id (Falgebra.class bT) b => + fun cT_ & phant_id (@Class T b) cT_ => @Pack phR T (cT_ Cm IDm Fm) T. + +Definition eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition zmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @Ring.Pack cT xclass xT. +Definition unitRingType := @UnitRing.Pack cT xclass xT. +Definition comRingType := @ComRing.Pack cT xclass xT. +Definition comUnitRingType := @ComUnitRing.Pack cT xclass xT. +Definition idomainType := @IntegralDomain.Pack cT xclass xT. +Definition fieldType := @Field.Pack cT xclass xT. +Definition lmodType := @Lmodule.Pack R phR cT xclass xT. +Definition lalgType := @Lalgebra.Pack R phR cT xclass xT. +Definition algType := @Algebra.Pack R phR cT xclass xT. +Definition unitAlgType := @UnitAlgebra.Pack R phR cT xclass xT. +Definition vectType := @Vector.Pack R phR cT xclass xT. +Definition FalgType := @Falgebra.Pack R phR cT xclass xT. + +Definition Falg_comRingType := @ComRing.Pack FalgType xclass xT. +Definition Falg_comUnitRingType := @ComUnitRing.Pack FalgType xclass xT. +Definition Falg_idomainType := @IntegralDomain.Pack FalgType xclass xT. +Definition Falg_fieldType := @Field.Pack FalgType xclass xT. + +Definition vect_comRingType := @ComRing.Pack vectType xclass xT. +Definition vect_comUnitRingType := @ComUnitRing.Pack vectType xclass xT. +Definition vect_idomainType := @IntegralDomain.Pack vectType xclass xT. +Definition vect_fieldType := @Field.Pack vectType xclass xT. + +Definition unitAlg_comRingType := @ComRing.Pack unitAlgType xclass xT. +Definition unitAlg_comUnitRingType := @ComUnitRing.Pack unitAlgType xclass xT. +Definition unitAlg_idomainType := @IntegralDomain.Pack unitAlgType xclass xT. +Definition unitAlg_fieldType := @Field.Pack unitAlgType xclass xT. + +Definition alg_comRingType := @ComRing.Pack algType xclass xT. +Definition alg_comUnitRingType := @ComUnitRing.Pack algType xclass xT. +Definition alg_idomainType := @IntegralDomain.Pack algType xclass xT. +Definition alg_fieldType := @Field.Pack algType xclass xT. + +Definition lalg_comRingType := @ComRing.Pack lalgType xclass xT. +Definition lalg_comUnitRingType := @ComUnitRing.Pack lalgType xclass xT. +Definition lalg_idomainType := @IntegralDomain.Pack lalgType xclass xT. +Definition lalg_fieldType := @Field.Pack lalgType xclass xT. + +Definition lmod_comRingType := @ComRing.Pack lmodType xclass xT. +Definition lmod_comUnitRingType := @ComUnitRing.Pack lmodType xclass xT. +Definition lmod_idomainType := @IntegralDomain.Pack lmodType xclass xT. +Definition lmod_fieldType := @Field.Pack lmodType xclass xT. + +End FieldExt. + +Module Exports. + +Coercion sort : type >-> Sortclass. +Bind Scope ring_scope with sort. +Coercion base : class_of >-> Falgebra.class_of. +Coercion base4 : class_of >-> Field.class_of. +Coercion eqType : type >-> Equality.type. +Canonical eqType. +Coercion choiceType : type >-> Choice.type. +Canonical choiceType. +Coercion zmodType : type >-> Zmodule.type. +Canonical zmodType. +Coercion ringType : type >-> Ring.type. +Canonical ringType. +Coercion unitRingType : type >-> UnitRing.type. +Canonical unitRingType. +Coercion comRingType : type >-> ComRing.type. +Canonical comRingType. +Coercion comUnitRingType : type >-> ComUnitRing.type. +Canonical comUnitRingType. +Coercion idomainType : type >-> IntegralDomain.type. +Canonical idomainType. +Coercion fieldType : type >-> Field.type. +Canonical fieldType. +Coercion lmodType : type >-> Lmodule.type. +Canonical lmodType. +Coercion lalgType : type >-> Lalgebra.type. +Canonical lalgType. +Coercion algType : type >-> Algebra.type. +Canonical algType. +Coercion unitAlgType : type >-> UnitAlgebra.type. +Canonical unitAlgType. +Coercion vectType : type >-> Vector.type. +Canonical vectType. +Coercion FalgType : type >-> Falgebra.type. +Canonical FalgType. + +Canonical Falg_comRingType. +Canonical Falg_comUnitRingType. +Canonical Falg_idomainType. +Canonical Falg_fieldType. +Canonical vect_comRingType. +Canonical vect_comUnitRingType. +Canonical vect_idomainType. +Canonical vect_fieldType. +Canonical unitAlg_comRingType. +Canonical unitAlg_comUnitRingType. +Canonical unitAlg_idomainType. +Canonical unitAlg_fieldType. +Canonical alg_comRingType. +Canonical alg_comUnitRingType. +Canonical alg_idomainType. +Canonical alg_fieldType. +Canonical lalg_comRingType. +Canonical lalg_comUnitRingType. +Canonical lalg_idomainType. +Canonical lalg_fieldType. +Canonical lmod_comRingType. +Canonical lmod_comUnitRingType. +Canonical lmod_idomainType. +Canonical lmod_fieldType. +Notation fieldExtType R := (type (Phant R)). + +Notation "[ 'fieldExtType' F 'of' L ]" := + (@pack _ (Phant F) L _ _ id _ _ _ _ id) + (at level 0, format "[ 'fieldExtType' F 'of' L ]") : form_scope. +(*Notation "[ 'fieldExtType' F 'of' L 'for' K ]" := + (@FieldExt.pack _ (Phant F) L _ _ id K _ _ _ idfun) + (at level 0, format "[ 'fieldExtType' F 'of' L 'for' K ]") : form_scope. +*) +Notation "[ 'fieldExtType' F 'of' L 'for' K ]" := + (@pack_eta _ (Phant F) L K _ _ id _ id) + (at level 0, format "[ 'fieldExtType' F 'of' L 'for' K ]") : form_scope. + +Notation "{ 'subfield' L }" := (@aspace_of _ (FalgType _) (Phant L)) + (at level 0, format "{ 'subfield' L }") : type_scope. + +End Exports. +End FieldExt. +Export FieldExt.Exports. + +Section FieldExtTheory. + +Variables (F0 : fieldType) (L : fieldExtType F0). +Implicit Types (U V M : {vspace L}) (E F K : {subfield L}). + +Lemma dim_cosetv U x : x != 0 -> \dim (U * <[x]>) = \dim U. +Proof. +move=> nz_x; rewrite -limg_amulr limg_dim_eq //. +apply/eqP; rewrite -subv0; apply/subvP=> y. +by rewrite memv_cap memv0 memv_ker lfunE mulf_eq0 (negPf nz_x) orbF => /andP[]. +Qed. + +Lemma prodvC : commutative (@prodv F0 L). +Proof. +move=> U V; without loss suffices subC: U V / (U * V <= V * U)%VS. + by apply/eqP; rewrite eqEsubv !{1}subC. +by apply/prodvP=> x y Ux Vy; rewrite mulrC memv_mul. +Qed. +Canonical prodv_comoid := Monoid.ComLaw prodvC. + +Lemma prodvCA : left_commutative (@prodv F0 L). +Proof. exact: Monoid.mulmCA. Qed. + +Lemma prodvAC : right_commutative (@prodv F0 L). +Proof. exact: Monoid.mulmAC. Qed. + +Lemma algid1 K : algid K = 1. Proof. exact/skew_field_algid1/fieldP. Qed. + +Lemma mem1v K : 1 \in K. Proof. by rewrite -algid_eq1 algid1. Qed. +Lemma sub1v K : (1 <= K)%VS. Proof. exact: mem1v. Qed. + +Lemma subfield_closed K : agenv K = K. +Proof. +by apply/eqP; rewrite eqEsubv sub_agenv agenv_sub_modr ?sub1v ?asubv. +Qed. + +Lemma AHom_lker0 (rT : FalgType F0) (f : 'AHom(L, rT)) : lker f == 0%VS. +Proof. by apply/lker0P; apply: fmorph_inj. Qed. + +Lemma AEnd_lker0 (f : 'AEnd(L)) : lker f == 0%VS. Proof. exact: AHom_lker0. Qed. + +Fact aimg_is_aspace (rT : FalgType F0) (f : 'AHom(L, rT)) (E : {subfield L}) : + is_aspace (f @: E). +Proof. +rewrite /is_aspace -aimgM limgS ?prodv_id // has_algid1 //. +by apply/memv_imgP; exists 1; rewrite ?mem1v ?rmorph1. +Qed. +Canonical aimg_aspace rT f E := ASpace (@aimg_is_aspace rT f E). + +Lemma Fadjoin_idP {K x} : reflect (<>%VS = K) (x \in K). +Proof. +apply: (iffP idP) => [/addv_idPl-> | <-]; first exact: subfield_closed. +exact: memv_adjoin. +Qed. + +Lemma Fadjoin0 K : <>%VS = K. +Proof. by rewrite addv0 subfield_closed. Qed. + +Lemma Fadjoin_nil K : <>%VS = K. +Proof. by rewrite adjoin_nil subfield_closed. Qed. + +Lemma FadjoinP {K x E} : + reflect (K <= E /\ x \in E)%VS (<>%AS <= E)%VS. +Proof. +apply: (iffP idP) => [sKxE | /andP]. + by rewrite (subvP sKxE) ?memv_adjoin // (subv_trans _ sKxE) ?subv_adjoin. +by rewrite -subv_add => /agenvS; rewrite subfield_closed. +Qed. + +Lemma Fadjoin_seqP {K} {rs : seq L} {E} : + reflect (K <= E /\ {subset rs <= E})%VS (<> <= E)%VS. +Proof. +apply: (iffP idP) => [sKrsE | [sKE /span_subvP/(conj sKE)/andP]]. + split=> [|x rs_x]; first exact: subv_trans (subv_adjoin_seq _ _) sKrsE. + by rewrite (subvP sKrsE) ?seqv_sub_adjoin. +by rewrite -subv_add => /agenvS; rewrite subfield_closed. +Qed. + +Lemma alg_polyOver E p : map_poly (in_alg L) p \is a polyOver E. +Proof. by apply/(polyOverS (subvP (sub1v _)))/polyOver1P; exists p. Qed. + +Lemma sub_adjoin1v x E : (<<1; x>> <= E)%VS = (x \in E)%VS. +Proof. by rewrite (sameP FadjoinP andP) sub1v. Qed. + +Fact vsval_multiplicative K : multiplicative (vsval : subvs_of K -> L). +Proof. by split => //=; apply: algid1. Qed. +Canonical vsval_rmorphism K := AddRMorphism (vsval_multiplicative K). +Canonical vsval_lrmorphism K := [lrmorphism of (vsval : subvs_of K -> L)]. + +Lemma vsval_invf K (w : subvs_of K) : val w^-1 = (vsval w)^-1. +Proof. +have [-> | Uv] := eqVneq w 0; first by rewrite !invr0. +by apply: vsval_invr; rewrite unitfE. +Qed. + +Fact aspace_divr_closed K : divr_closed K. +Proof. by split=> [|u v Ku Kv]; rewrite ?mem1v ?memvM ?memvV. Qed. +Canonical aspace_mulrPred K := MulrPred (aspace_divr_closed K). +Canonical aspace_divrPred K := DivrPred (aspace_divr_closed K). +Canonical aspace_smulrPred K := SmulrPred (aspace_divr_closed K). +Canonical aspace_sdivrPred K := SdivrPred (aspace_divr_closed K). +Canonical aspace_semiringPred K := SemiringPred (aspace_divr_closed K). +Canonical aspace_subringPred K := SubringPred (aspace_divr_closed K). +Canonical aspace_subalgPred K := SubalgPred (memv_submod_closed K). +Canonical aspace_divringPred K := DivringPred (aspace_divr_closed K). +Canonical aspace_divalgPred K := DivalgPred (memv_submod_closed K). + +Definition subvs_mulC K := [comRingMixin of subvs_of K by <:]. +Canonical subvs_comRingType K := + Eval hnf in ComRingType (subvs_of K) (@subvs_mulC K). +Canonical subvs_comUnitRingType K := + Eval hnf in [comUnitRingType of subvs_of K]. +Definition subvs_mul_eq0 K := [idomainMixin of subvs_of K by <:]. +Canonical subvs_idomainType K := + Eval hnf in IdomainType (subvs_of K) (@subvs_mul_eq0 K). +Lemma subvs_fieldMixin K : GRing.Field.mixin_of (@subvs_idomainType K). +Proof. +by move=> w nz_w; rewrite unitrE -val_eqE /= vsval_invf algid1 divff. +Qed. +Canonical subvs_fieldType K := + Eval hnf in FieldType (subvs_of K) (@subvs_fieldMixin K). +Canonical subvs_fieldExtType K := Eval hnf in [fieldExtType F0 of subvs_of K]. + +Lemma polyOver_subvs {K} {p : {poly L}} : + reflect (exists q : {poly subvs_of K}, p = map_poly vsval q) + (p \is a polyOver K). +Proof. +apply: (iffP polyOverP) => [Hp | [q ->] i]; last by rewrite coef_map // subvsP. +exists (\poly_(i < size p) (Subvs (Hp i))); rewrite -{1}[p]coefK. +by apply/polyP=> i; rewrite coef_map !coef_poly; case: ifP. +Qed. + +Lemma divp_polyOver K : {in polyOver K &, forall p q, p %/ q \is a polyOver K}. +Proof. +move=> _ _ /polyOver_subvs[p ->] /polyOver_subvs[q ->]. +by apply/polyOver_subvs; exists (p %/ q); rewrite map_divp. +Qed. + +Lemma modp_polyOver K : {in polyOver K &, forall p q, p %% q \is a polyOver K}. +Proof. +move=> _ _ /polyOver_subvs[p ->] /polyOver_subvs[q ->]. +by apply/polyOver_subvs; exists (p %% q); rewrite map_modp. +Qed. + +Lemma gcdp_polyOver K : + {in polyOver K &, forall p q, gcdp p q \is a polyOver K}. +Proof. +move=> _ _ /polyOver_subvs[p ->] /polyOver_subvs[q ->]. +by apply/polyOver_subvs; exists (gcdp p q); rewrite gcdp_map. +Qed. + +Fact prodv_is_aspace E F : is_aspace (E * F). +Proof. +rewrite /is_aspace prodvCA -!prodvA prodvA !prodv_id has_algid1 //=. +by rewrite -[1]mulr1 memv_mul ?mem1v. +Qed. +Canonical prodv_aspace E F : {subfield L} := ASpace (prodv_is_aspace E F). + +Fact field_mem_algid E F : algid E \in F. Proof. by rewrite algid1 mem1v. Qed. +Canonical capv_aspace E F : {subfield L} := aspace_cap (field_mem_algid E F). + +Lemma polyOverSv U V : (U <= V)%VS -> {subset polyOver U <= polyOver V}. +Proof. by move/subvP=> sUV; apply: polyOverS. Qed. + +Lemma field_subvMl F U : (U <= F * U)%VS. +Proof. by rewrite -{1}[U]prod1v prodvSl ?sub1v. Qed. + +Lemma field_subvMr U F : (U <= U * F)%VS. +Proof. by rewrite prodvC field_subvMl. Qed. + +Lemma field_module_eq F M : (F * M <= M)%VS -> (F * M)%VS = M. +Proof. by move=> modM; apply/eqP; rewrite eqEsubv modM field_subvMl. Qed. + +Lemma sup_field_module F E : (F * E <= E)%VS = (F <= E)%VS. +Proof. +apply/idP/idP; first exact: subv_trans (field_subvMr F E). +by move/(prodvSl E)/subv_trans->; rewrite ?asubv. +Qed. + +Lemma field_module_dimS F M : (F * M <= M)%VS -> (\dim F %| \dim M)%N. +Proof. exact/skew_field_module_dimS/fieldP. Qed. + +Lemma field_dimS F E : (F <= E)%VS -> (\dim F %| \dim E)%N. +Proof. exact/skew_field_dimS/fieldP. Qed. + +Lemma dim_field_module F M : (F * M <= M)%VS -> \dim M = (\dim_F M * \dim F)%N. +Proof. by move/field_module_dimS/divnK. Qed. + +Lemma dim_sup_field F E : (F <= E)%VS -> \dim E = (\dim_F E * \dim F)%N. +Proof. by move/field_dimS/divnK. Qed. + +Lemma field_module_semisimple F M (m := \dim_F M) : + (F * M <= M)%VS -> + {X : m.-tuple L | {subset X <= M} /\ 0 \notin X + & let FX := (\sum_(i < m) F * <[X`_i]>)%VS in FX = M /\ directv FX}. +Proof. +move=> modM; have dimM: (m * \dim F)%N = \dim M by rewrite -dim_field_module. +have [X [defM dxFX nzX]] := skew_field_module_semisimple (@fieldP L) modM. +have szX: size X == m. + rewrite -(eqn_pmul2r (adim_gt0 F)) dimM -defM (directvP dxFX) /=. + rewrite -sum1_size big_distrl; apply/eqP/eq_big_seq => x Xx /=. + by rewrite mul1n dim_cosetv ?(memPn nzX). +rewrite directvE /= !(big_nth 0) (eqP szX) !big_mkord -directvE /= in defM dxFX. +exists (Tuple szX) => //; split=> // _ /tnthP[i ->]; rewrite (tnth_nth 0) /=. +by rewrite -defM memvE (sumv_sup i) ?field_subvMl. +Qed. + +Section FadjoinPolyDefinitions. + +Variables (U : {vspace L}) (x : L). + +Definition adjoin_degree := (\dim_U <>).-1.+1. +Local Notation n := adjoin_degree. + +Definition Fadjoin_sum := (\sum_(i < n) U * <[x ^+ i]>)%VS. + +Definition Fadjoin_poly v : {poly L} := + \poly_(i < n) (sumv_pi Fadjoin_sum (inord i) v / x ^+ i). + +Definition minPoly : {poly L} := 'X^n - Fadjoin_poly (x ^+ n). + +Lemma size_Fadjoin_poly v : size (Fadjoin_poly v) <= n. +Proof. exact: size_poly. Qed. + +Lemma Fadjoin_polyOver v : Fadjoin_poly v \is a polyOver U. +Proof. +apply/(all_nthP 0) => i _; rewrite coef_poly /=. +case: ifP => lti; last exact: mem0v. +have /memv_cosetP[y Uy ->] := memv_sum_pi (erefl Fadjoin_sum) (inord i) v. +rewrite inordK //; have [-> | /mulfK-> //] := eqVneq (x ^+ i) 0. +by rewrite mulr0 mul0r mem0v. +Qed. + +Fact Fadjoin_poly_is_linear : linear_for (in_alg L \; *:%R) Fadjoin_poly. +Proof. +move=> a u v; apply/polyP=> i; rewrite coefD coefZ !coef_poly. +case: ifP => lti; last by rewrite mulr0 addr0. +by rewrite linearP mulrA -mulrDl mulr_algl. +Qed. +Canonical Fadjoin_poly_additive := Additive Fadjoin_poly_is_linear. +Canonical Fadjoin_poly_linear := AddLinear Fadjoin_poly_is_linear. + +Lemma size_minPoly : size minPoly = n.+1. +Proof. by rewrite size_addl ?size_polyXn // size_opp ltnS size_poly. Qed. + +Lemma monic_minPoly : minPoly \is monic. +Proof. +rewrite monicE /lead_coef size_minPoly coefB coefXn eqxx. +by rewrite nth_default ?subr0 ?size_poly. +Qed. + +End FadjoinPolyDefinitions. + +Section FadjoinPoly. + +Variables (K : {subfield L}) (x : L). +Local Notation n := (adjoin_degree (asval K) x). +Local Notation sumKx := (Fadjoin_sum (asval K) x). + +Lemma adjoin_degreeE : n = \dim_K <>. +Proof. by rewrite [n]prednK // divn_gt0 ?adim_gt0 // dimvS ?subv_adjoin. Qed. + +Lemma dim_Fadjoin : \dim <> = (n * \dim K)%N. +Proof. by rewrite adjoin_degreeE -dim_sup_field ?subv_adjoin. Qed. + +Lemma adjoin0_deg : adjoin_degree K 0 = 1%N. +Proof. by rewrite /adjoin_degree addv0 subfield_closed divnn adim_gt0. Qed. + +Lemma adjoin_deg_eq1 : (n == 1%N) = (x \in K). +Proof. +rewrite (sameP Fadjoin_idP eqP) adjoin_degreeE; have sK_Kx := subv_adjoin K x. +apply/eqP/idP=> [dimKx1 | /eqP->]; last by rewrite divnn adim_gt0. +by rewrite eq_sym eqEdim sK_Kx /= (dim_sup_field sK_Kx) dimKx1 mul1n. +Qed. + +Lemma Fadjoin_sum_direct : directv sumKx. +Proof. +rewrite directvE /=; case Dn: {-2}n (leqnn n) => // [m] {Dn}. +elim: m => [|m IHm] ltm1n; rewrite ?big_ord1 // !(big_ord_recr m.+1) /=. +do [move/(_ (ltnW ltm1n))/eqP; set S := (\sum_i _)%VS] in IHm *. +rewrite -IHm dimv_add_leqif; apply/subvP=> z; rewrite memv_cap => /andP[Sz]. +case/memv_cosetP=> y Ky Dz; rewrite memv0 Dz mulf_eq0 expf_eq0 /=. +apply: contraLR ltm1n => /norP[nz_y nz_x]. +rewrite -leqNgt -(leq_pmul2r (adim_gt0 K)) -dim_Fadjoin. +have{IHm} ->: (m.+1 * \dim K)%N = \dim S. + rewrite -[m.+1]card_ord -sum_nat_const IHm. + by apply: eq_bigr => i; rewrite dim_cosetv ?expf_neq0. +apply/dimvS/agenv_sub_modl; first by rewrite (sumv_sup 0) //= prodv1 sub1v. +rewrite prodvDl subv_add -[S]big_distrr prodvA prodv_id subvv !big_distrr /=. +apply/subv_sumP=> i _; rewrite -expv_line prodvCA -expvSl expv_line. +have [ltim | lemi] := ltnP i m; first by rewrite (sumv_sup (Sub i.+1 _)). +have{lemi} /eqP->: i == m :> nat by rewrite eqn_leq leq_ord. +rewrite -big_distrr -2!{2}(prodv_id K) /= -!prodvA big_distrr -/S prodvSr //=. +by rewrite -(canLR (mulKf nz_y) Dz) -memvE memv_mul ?rpredV. +Qed. + +Let nz_x_i (i : 'I_n) : x ^+ i != 0. +Proof. +by rewrite expf_eq0; case: eqP i => [->|_] [[]] //; rewrite adjoin0_deg. +Qed. + +Lemma Fadjoin_eq_sum : <>%VS = sumKx. +Proof. +apply/esym/eqP; rewrite eqEdim eq_leq ?andbT. + apply/subv_sumP=> i _; rewrite -agenvM prodvS ?subv_adjoin //. + by rewrite -expv_line (subv_trans (subX_agenv _ _)) ?agenvS ?addvSr. +rewrite dim_Fadjoin -[n]card_ord -sum_nat_const (directvP Fadjoin_sum_direct). +by apply: eq_bigr => i _; rewrite /= dim_cosetv. +Qed. + +Lemma Fadjoin_poly_eq v : v \in <>%VS -> (Fadjoin_poly K x v).[x] = v. +Proof. +move/(sumv_pi_sum Fadjoin_eq_sum)=> {2}<-; rewrite horner_poly. +by apply: eq_bigr => i _; rewrite inord_val mulfVK. +Qed. + +Lemma mempx_Fadjoin p : p \is a polyOver K -> p.[x] \in <>%VS. +Proof. +move=> Kp; rewrite rpred_horner ?memv_adjoin ?(polyOverS _ Kp) //. +exact: subvP_adjoin. +Qed. + +Lemma Fadjoin_polyP {v} : + reflect (exists2 p, p \in polyOver K & v = p.[x]) (v \in <>%VS). +Proof. +apply: (iffP idP) => [Kx_v | [p Kp ->]]; last exact: mempx_Fadjoin. +by exists (Fadjoin_poly K x v); rewrite ?Fadjoin_polyOver ?Fadjoin_poly_eq. +Qed. + +Lemma Fadjoin_poly_unique p v : + p \is a polyOver K -> size p <= n -> p.[x] = v -> Fadjoin_poly K x v = p. +Proof. +have polyKx q i: q \is a polyOver K -> q`_i * x ^+ i \in (K * <[x ^+ i]>)%VS. + by move/polyOverP=> Kq; rewrite memv_mul ?Kq ?memv_line. +move=> Kp szp Dv; have /Fadjoin_poly_eq/eqP := mempx_Fadjoin Kp. +rewrite {1}Dv {Dv} !(@horner_coef_wide _ n) ?size_poly //. +move/polyKx in Kp; have /polyKx K_pv := Fadjoin_polyOver K x v. +rewrite (directv_sum_unique Fadjoin_sum_direct) // => /eqfunP eq_pq. +apply/polyP=> i; have [leni|?] := leqP n i; last exact: mulIf (eq_pq (Sub i _)). +by rewrite !nth_default ?(leq_trans _ leni) ?size_poly. +Qed. + +Lemma Fadjoin_polyC v : v \in K -> Fadjoin_poly K x v = v%:P. +Proof. +move=> Kv; apply: Fadjoin_poly_unique; rewrite ?polyOverC ?hornerC //. +by rewrite size_polyC (leq_trans (leq_b1 _)). +Qed. + +Lemma Fadjoin_polyX : x \notin K -> Fadjoin_poly K x x = 'X. +Proof. +move=> K'x; apply: Fadjoin_poly_unique; rewrite ?polyOverX ?hornerX //. +by rewrite size_polyX ltn_neqAle andbT eq_sym adjoin_deg_eq1. +Qed. + +Lemma minPolyOver : minPoly K x \is a polyOver K. +Proof. by rewrite /minPoly rpredB ?rpredX ?polyOverX ?Fadjoin_polyOver. Qed. + +Lemma minPolyxx : (minPoly K x).[x] = 0. +Proof. +by rewrite !hornerE hornerXn Fadjoin_poly_eq ?subrr ?rpredX ?memv_adjoin. +Qed. + +Lemma root_minPoly : root (minPoly K x) x. Proof. exact/rootP/minPolyxx. Qed. + +Lemma Fadjoin_poly_mod p : + p \is a polyOver K -> Fadjoin_poly K x p.[x] = p %% minPoly K x. +Proof. +move=> Kp; rewrite {1}(divp_eq p (minPoly K x)) 2!hornerE minPolyxx mulr0 add0r. +apply: Fadjoin_poly_unique => //; first by rewrite modp_polyOver // minPolyOver. +by rewrite -ltnS -size_minPoly ltn_modp // monic_neq0 ?monic_minPoly. +Qed. + +Lemma minPoly_XsubC : reflect (minPoly K x = 'X - x%:P) (x \in K). +Proof. +set p := minPoly K x; apply: (iffP idP) => [Kx | Dp]; last first. + suffices ->: x = - p`_0 by rewrite rpredN (polyOverP minPolyOver). + by rewrite Dp coefB coefX coefC add0r opprK. +rewrite (@all_roots_prod_XsubC _ p [:: x]) /= ?root_minPoly //. + by rewrite big_seq1 (monicP (monic_minPoly K x)) scale1r. +by apply/eqP; rewrite size_minPoly eqSS adjoin_deg_eq1. +Qed. + +Lemma root_small_adjoin_poly p : + p \is a polyOver K -> size p <= n -> root p x = (p == 0). +Proof. +move=> Kp szp; apply/rootP/eqP=> [px0 | ->]; last by rewrite horner0. +rewrite -(Fadjoin_poly_unique Kp szp px0). +by apply: Fadjoin_poly_unique; rewrite ?polyOver0 ?size_poly0 ?horner0. +Qed. + +Lemma minPoly_irr p : + p \is a polyOver K -> p %| minPoly K x -> (p %= minPoly K x) || (p %= 1). +Proof. +rewrite dvdp_eq; set q := _ %/ _ => Kp def_pq. +have Kq: q \is a polyOver K by rewrite divp_polyOver // minPolyOver. +move: q Kq def_pq root_minPoly (size_minPoly K x) => q Kq /eqP->. +rewrite rootM => pqx0 szpq. +have [nzq nzp]: q != 0 /\ p != 0. + by apply/norP; rewrite -mulf_eq0 -size_poly_eq0 szpq. +without loss{pqx0} qx0: q p Kp Kq nzp nzq szpq / root q x. + move=> IH; case/orP: pqx0 => /IH{IH}IH; first exact: IH. + have{IH} /orP[]: (q %= p * q) || (q %= 1) by apply: IH => //; rewrite mulrC. + by rewrite orbC -{1}[q]mul1r eqp_mul2r // eqp_sym => ->. + by rewrite -{1}[p]mul1r eqp_sym eqp_mul2r // => ->. +apply/orP; right; rewrite -size_poly_eq1 eqn_leq lt0n size_poly_eq0 nzp andbT. +rewrite -(leq_add2r (size q)) -leq_subLR subn1 -size_mul // mulrC szpq. +by rewrite ltnNge; apply: contra nzq => /(root_small_adjoin_poly Kq) <-. +Qed. + +Lemma minPoly_dvdp p : p \is a polyOver K -> root p x -> (minPoly K x) %| p. +Proof. +move=> Kp rootp. +have gcdK : gcdp (minPoly K x) p \is a polyOver K. + by rewrite gcdp_polyOver ?minPolyOver. +have /orP[gcd_eqK|gcd_eq1] := minPoly_irr gcdK (dvdp_gcdl (minPoly K x) p). + by rewrite -(eqp_dvdl _ gcd_eqK) dvdp_gcdr. +case/negP: (root1 x). +by rewrite -(eqp_root gcd_eq1) root_gcd rootp root_minPoly. +Qed. + +End FadjoinPoly. + +Lemma minPolyS K E a : (K <= E)%VS -> minPoly E a %| minPoly K a. +Proof. +move=> sKE; apply: minPoly_dvdp; last exact: root_minPoly. +by apply: (polyOverSv sKE); rewrite minPolyOver. +Qed. + +Implicit Arguments Fadjoin_polyP [K x v]. +Lemma Fadjoin1_polyP x v : + reflect (exists p, v = (map_poly (in_alg L) p).[x]) (v \in <<1; x>>%VS). +Proof. +apply: (iffP Fadjoin_polyP) => [[_ /polyOver1P]|] [p ->]; first by exists p. +by exists (map_poly (in_alg L) p) => //; apply: alg_polyOver. +Qed. + +Section Horner. + +Variables z : L. + +Definition fieldExt_horner := horner_morph (fun x => mulrC z (in_alg L x)). +Canonical fieldExtHorner_additive := [additive of fieldExt_horner]. +Canonical fieldExtHorner_rmorphism := [rmorphism of fieldExt_horner]. +Lemma fieldExt_hornerC b : fieldExt_horner b%:P = b%:A. +Proof. exact: horner_morphC. Qed. +Lemma fieldExt_hornerX : fieldExt_horner 'X = z. +Proof. exact: horner_morphX. Qed. +Fact fieldExt_hornerZ : scalable fieldExt_horner. +Proof. +move=> a p; rewrite -mul_polyC rmorphM /= fieldExt_hornerC. +by rewrite -scalerAl mul1r. +Qed. +Canonical fieldExt_horner_linear := AddLinear fieldExt_hornerZ. +Canonical fieldExt_horner_lrmorhism := [lrmorphism of fieldExt_horner]. + +End Horner. + +End FieldExtTheory. + +Notation "E :&: F" := (capv_aspace E F) : aspace_scope. +Notation "'C_ E [ x ]" := (capv_aspace E 'C[x]) : aspace_scope. +Notation "'C_ ( E ) [ x ]" := (capv_aspace E 'C[x]) + (only parsing) : aspace_scope. +Notation "'C_ E ( V )" := (capv_aspace E 'C(V)) : aspace_scope. +Notation "'C_ ( E ) ( V )" := (capv_aspace E 'C(V)) + (only parsing) : aspace_scope. +Notation "E * F" := (prodv_aspace E F) : aspace_scope. +Notation "f @: E" := (aimg_aspace f E) : aspace_scope. + +Implicit Arguments Fadjoin_idP [F0 L K x]. +Implicit Arguments FadjoinP [F0 L K x E]. +Implicit Arguments Fadjoin_seqP [F0 L K rs E]. +Implicit Arguments polyOver_subvs [F0 L K p]. +Implicit Arguments Fadjoin_polyP [F0 L K x v]. +Implicit Arguments Fadjoin1_polyP [F0 L x v]. +Implicit Arguments minPoly_XsubC [F0 L K x]. + +Section MapMinPoly. + +Variables (F0 : fieldType) (L rL : fieldExtType F0) (f : 'AHom(L, rL)). +Variables (K : {subfield L}) (x : L). + +Lemma adjoin_degree_aimg : adjoin_degree (f @: K) (f x) = adjoin_degree K x. +Proof. +rewrite !adjoin_degreeE -aimg_adjoin. +by rewrite !limg_dim_eq ?(eqP (AHom_lker0 f)) ?capv0. +Qed. + +Lemma map_minPoly : map_poly f (minPoly K x) = minPoly (f @: K) (f x). +Proof. +set fp := minPoly (f @: K) (f x); pose fM := [rmorphism of f]. +have [p Kp Dp]: exists2 p, p \is a polyOver K & map_poly f p = fp. + have Kfp: fp \is a polyOver (f @: K)%VS by apply: minPolyOver. + exists (map_poly f^-1%VF fp). + apply/polyOver_poly=> j _; have /memv_imgP[y Ky ->] := polyOverP Kfp j. + by rewrite lker0_lfunK ?AHom_lker0. + rewrite -map_poly_comp map_poly_id // => _ /(allP Kfp)/memv_imgP[y _ ->]. + by rewrite /= limg_lfunVK ?memv_img ?memvf. +apply/eqP; rewrite -eqp_monic ?monic_map ?monic_minPoly // -Dp eqp_map. +have: ~~ (p %= 1) by rewrite -size_poly_eq1 -(size_map_poly fM) Dp size_minPoly. +apply: implyP; rewrite implyNb orbC eqp_sym minPoly_irr //. +rewrite -(dvdp_map fM) Dp minPoly_dvdp ?fmorph_root ?root_minPoly //. +by apply/polyOver_poly=> j _; apply/memv_img/polyOverP/minPolyOver. +Qed. + +End MapMinPoly. + +(* Changing up the reference field of a fieldExtType. *) +Section FieldOver. + +Variables (F0 : fieldType) (L : fieldExtType F0) (F : {subfield L}). + +Definition fieldOver of {vspace L} : Type := L. +Local Notation K_F := (subvs_of F). +Local Notation L_F := (fieldOver F). + +Canonical fieldOver_eqType := [eqType of L_F]. +Canonical fieldOver_choiceType := [choiceType of L_F]. +Canonical fieldOver_zmodType := [zmodType of L_F]. +Canonical fieldOver_ringType := [ringType of L_F]. +Canonical fieldOver_unitRingType := [unitRingType of L_F]. +Canonical fieldOver_comRingType := [comRingType of L_F]. +Canonical fieldOver_comUnitRingType := [comUnitRingType of L_F]. +Canonical fieldOver_idomainType := [idomainType of L_F]. +Canonical fieldOver_fieldType := [fieldType of L_F]. + +Definition fieldOver_scale (a : K_F) (u : L_F) : L_F := vsval a * u. +Local Infix "*F:" := fieldOver_scale (at level 40). + +Fact fieldOver_scaleA a b u : a *F: (b *F: u) = (a * b) *F: u. +Proof. exact: mulrA. Qed. + +Fact fieldOver_scale1 u : 1 *F: u = u. +Proof. by rewrite /(1 *F: u) /= algid1 mul1r. Qed. + +Fact fieldOver_scaleDr a u v : a *F: (u + v) = a *F: u + a *F: v. +Proof. exact: mulrDr. Qed. + +Fact fieldOver_scaleDl v a b : (a + b) *F: v = a *F: v + b *F: v. +Proof. exact: mulrDl. Qed. + +Definition fieldOver_lmodMixin := + LmodMixin fieldOver_scaleA fieldOver_scale1 + fieldOver_scaleDr fieldOver_scaleDl. + +Canonical fieldOver_lmodType := LmodType K_F L_F fieldOver_lmodMixin. + +Lemma fieldOver_scaleE a (u : L) : a *: (u : L_F) = vsval a * u. +Proof. by []. Qed. + +Fact fieldOver_scaleAl a u v : a *F: (u * v) = (a *F: u) * v. +Proof. exact: mulrA. Qed. + +Canonical fieldOver_lalgType := LalgType K_F L_F fieldOver_scaleAl. + +Fact fieldOver_scaleAr a u v : a *F: (u * v) = u * (a *F: v). +Proof. exact: mulrCA. Qed. + +Canonical fieldOver_algType := AlgType K_F L_F fieldOver_scaleAr. +Canonical fieldOver_unitAlgType := [unitAlgType K_F of L_F]. + +Fact fieldOver_vectMixin : Vector.mixin_of fieldOver_lmodType. +Proof. +have [bL [_ nz_bL] [defL dxSbL]] := field_module_semisimple (subvf (F * _)). +do [set n := \dim_F {:L} in bL nz_bL *; set SbL := (\sum_i _)%VS] in defL dxSbL. +have in_bL i (a : K_F) : val a * (bL`_i : L_F) \in (F * <[bL`_i]>)%VS. + by rewrite memv_mul ?(valP a) ?memv_line. +have nz_bLi (i : 'I_n): bL`_i != 0 by rewrite (memPn nz_bL) ?memt_nth. +pose r2v (v : 'rV[K_F]_n) : L_F := \sum_i v 0 i *: (bL`_i : L_F). +have r2v_lin: linear r2v. + move=> a u v; rewrite /r2v scaler_sumr -big_split /=; apply: eq_bigr => i _. + by rewrite scalerA -scalerDl !mxE. +have v2rP x: {r : 'rV[K_F]_n | x = r2v r}. + apply: sig_eqW; have /memv_sumP[y Fy ->]: x \in SbL by rewrite defL memvf. + have /fin_all_exists[r Dr] i: exists r, y i = r *: (bL`_i : L_F). + by have /memv_cosetP[a Fa ->] := Fy i isT; exists (Subvs Fa). + by exists (\row_i r i); apply: eq_bigr => i _; rewrite mxE. +pose v2r x := sval (v2rP x). +have v2rK: cancel v2r (Linear r2v_lin) by rewrite /v2r => x; case: (v2rP x). +suffices r2vK: cancel r2v v2r. + by exists n, v2r; [exact: can2_linear v2rK | exists r2v]. +move=> r; apply/rowP=> i; apply/val_inj/(mulIf (nz_bLi i))/eqP; move: i isT. +by apply/forall_inP; move/directv_sum_unique: dxSbL => <- //; exact/eqP/v2rK. +Qed. + +Canonical fieldOver_vectType := VectType K_F L_F fieldOver_vectMixin. +Canonical fieldOver_FalgType := [FalgType K_F of L_F]. +Canonical fieldOver_fieldExtType := [fieldExtType K_F of L_F]. + +Implicit Types (V : {vspace L}) (E : {subfield L}). + +Lemma trivial_fieldOver : (1%VS : {vspace L_F}) =i F. +Proof. +move=> x; apply/vlineP/idP=> [[{x}x ->] | Fx]. + by rewrite fieldOver_scaleE mulr1 (valP x). +by exists (vsproj F x); rewrite fieldOver_scaleE mulr1 vsprojK. +Qed. + +Definition vspaceOver V := <>%VS. + +Lemma mem_vspaceOver V : vspaceOver V =i (F * V)%VS. +Proof. +move=> y; apply/idP/idP; last rewrite unlock; move=> /coord_span->. + rewrite (@memv_suml F0 L) // => i _. + by rewrite memv_mul ?subvsP // vbasis_mem ?memt_nth. +rewrite memv_suml // => ij _; rewrite -tnth_nth; set x := tnth _ ij. +have/allpairsP[[u z] /= [Fu Vz {x}->]]: x \in _ := mem_tnth ij _. +by rewrite scalerAl (memvZ (Subvs _)) ?memvZ ?memv_span //= vbasis_mem. +Qed. + +Lemma mem_aspaceOver E : (F <= E)%VS -> vspaceOver E =i E. +Proof. +by move=> sFE y; rewrite mem_vspaceOver field_module_eq ?sup_field_module. +Qed. + +Fact aspaceOver_suproof E : is_aspace (vspaceOver E). +Proof. +rewrite /is_aspace has_algid1; last by rewrite mem_vspaceOver (@mem1v _ L). +by apply/prodvP=> u v; rewrite !mem_vspaceOver; exact: memvM. +Qed. +Canonical aspaceOver E := ASpace (aspaceOver_suproof E). + +Lemma dim_vspaceOver M : (F * M <= M)%VS -> \dim (vspaceOver M) = \dim_F M. +Proof. +move=> modM; have [] := field_module_semisimple modM. +set n := \dim_F M => b [Mb nz_b] [defM dx_b]. +suff: basis_of (vspaceOver M) b by apply: size_basis. +apply/andP; split. + rewrite eqEsubv; apply/andP; split; apply/span_subvP=> u. + by rewrite mem_vspaceOver field_module_eq // => /Mb. + move/(@vbasis_mem _ _ _ M); rewrite -defM => /memv_sumP[{u}u Fu ->]. + apply: memv_suml => i _; have /memv_cosetP[a Fa ->] := Fu i isT. + by apply: (memvZ (Subvs Fa)); rewrite memv_span ?memt_nth. +apply/freeP=> a /(directv_sum_independent dx_b) a_0 i. +have{a_0}: a i *: (b`_i : L_F) == 0. + by rewrite a_0 {i}// => i _; rewrite memv_mul ?memv_line ?subvsP. +by rewrite scaler_eq0=> /predU1P[] // /idPn[]; rewrite (memPn nz_b) ?memt_nth. +Qed. + +Lemma dim_aspaceOver E : (F <= E)%VS -> \dim (vspaceOver E) = \dim_F E. +Proof. by rewrite -sup_field_module; exact: dim_vspaceOver. Qed. + +Lemma vspaceOverP V_F : + {V | [/\ V_F = vspaceOver V, (F * V <= V)%VS & V_F =i V]}. +Proof. +pose V := (F * <>)%VS. +have idV: (F * V)%VS = V by rewrite prodvA prodv_id. +suffices defVF: V_F = vspaceOver V. + by exists V; split=> [||u]; rewrite ?defVF ?mem_vspaceOver ?idV. +apply/vspaceP=> v; rewrite mem_vspaceOver idV. +do [apply/idP/idP; last rewrite /V unlock] => [/coord_vbasis|/coord_span] ->. + by apply: memv_suml => i _; rewrite memv_mul ?subvsP ?memv_span ?memt_nth. +apply: memv_suml => i _; rewrite -tnth_nth; set xu := tnth _ i. +have /allpairsP[[x u] /=]: xu \in _ := mem_tnth i _. +case=> /vbasis_mem Fx /vbasis_mem Vu ->. +rewrite scalerAl (coord_span Vu) mulr_sumr memv_suml // => j_. +by rewrite -scalerCA (memvZ (Subvs _)) ?memvZ // vbasis_mem ?memt_nth. +Qed. + +Lemma aspaceOverP (E_F : {subfield L_F}) : + {E | [/\ E_F = aspaceOver E, (F <= E)%VS & E_F =i E]}. +Proof. +have [V [defEF modV memV]] := vspaceOverP E_F. +have algE: has_algid V && (V * V <= V)%VS. + rewrite has_algid1; last by rewrite -memV mem1v. + by apply/prodvP=> u v; rewrite -!memV; exact: memvM. +by exists (ASpace algE); rewrite -sup_field_module; split; first exact: val_inj. +Qed. + +End FieldOver. + +(* Changing the reference field to a smaller field. *) +Section BaseField. + +Variables (F0 : fieldType) (F : fieldExtType F0) (L : fieldExtType F). + +Definition baseField_type of phant L : Type := L. +Notation L0 := (baseField_type (Phant (FieldExt.sort L))). + +Canonical baseField_eqType := [eqType of L0]. +Canonical baseField_choiceType := [choiceType of L0]. +Canonical baseField_zmodType := [zmodType of L0]. +Canonical baseField_ringType := [ringType of L0]. +Canonical baseField_unitRingType := [unitRingType of L0]. +Canonical baseField_comRingType := [comRingType of L0]. +Canonical baseField_comUnitRingType := [comUnitRingType of L0]. +Canonical baseField_idomainType := [idomainType of L0]. +Canonical baseField_fieldType := [fieldType of L0]. + +Definition baseField_scale (a : F0) (u : L0) : L0 := in_alg F a *: u. +Local Infix "*F0:" := baseField_scale (at level 40). + +Fact baseField_scaleA a b u : a *F0: (b *F0: u) = (a * b) *F0: u. +Proof. by rewrite [_ *F0: _]scalerA -rmorphM. Qed. + +Fact baseField_scale1 u : 1 *F0: u = u. +Proof. by rewrite /(1 *F0: u) rmorph1 scale1r. Qed. + +Fact baseField_scaleDr a u v : a *F0: (u + v) = a *F0: u + a *F0: v. +Proof. exact: scalerDr. Qed. + +Fact baseField_scaleDl v a b : (a + b) *F0: v = a *F0: v + b *F0: v. +Proof. by rewrite -scalerDl -rmorphD. Qed. + +Definition baseField_lmodMixin := + LmodMixin baseField_scaleA baseField_scale1 + baseField_scaleDr baseField_scaleDl. + +Canonical baseField_lmodType := LmodType F0 L0 baseField_lmodMixin. + +Lemma baseField_scaleE a (u : L) : a *: (u : L0) = a%:A *: u. +Proof. by []. Qed. + +Fact baseField_scaleAl a (u v : L0) : a *F0: (u * v) = (a *F0: u) * v. +Proof. exact: scalerAl. Qed. + +Canonical baseField_lalgType := LalgType F0 L0 baseField_scaleAl. + +Fact baseField_scaleAr a u v : a *F0: (u * v) = u * (a *F0: v). +Proof. exact: scalerAr. Qed. + +Canonical baseField_algType := AlgType F0 L0 baseField_scaleAr. +Canonical baseField_unitAlgType := [unitAlgType F0 of L0]. + +Let n := \dim {:F}. +Let bF : n.-tuple F := vbasis {:F}. +Let coordF (x : F) := (coord_vbasis (memvf x)). + +Fact baseField_vectMixin : Vector.mixin_of baseField_lmodType. +Proof. +pose bL := vbasis {:L}; set m := \dim {:L} in bL. +pose v2r (x : L0) := mxvec (\matrix_(i, j) coord bF j (coord bL i x)). +have v2r_lin: linear v2r. + move=> a x y; rewrite -linearP; congr (mxvec _); apply/matrixP=> i j. + by rewrite !mxE linearP mulr_algl linearP. +pose r2v r := \sum_(i < m) (\sum_(j < n) vec_mx r i j *: bF`_j) *: bL`_i. +have v2rK: cancel v2r r2v. + move=> x; transitivity (\sum_(i < m) coord bL i x *: bL`_i); last first. + by rewrite -coord_vbasis ?memvf. + (* GG: rewrite {2}(coord_vbasis (memvf x)) -/m would take 8s; *) + (* The -/m takes 8s, and without it then apply: eq_bigr takes 12s. *) + (* The time drops to 2s with a -[GRing.Field.ringType F]/(F : fieldType) *) + apply: eq_bigr => i _; rewrite mxvecK; congr (_ *: _ : L). + by rewrite (coordF (coord bL i x)); apply: eq_bigr => j _; rewrite mxE. +exists (m * n)%N, v2r => //; exists r2v => // r. +apply: (canLR vec_mxK); apply/matrixP=> i j; rewrite mxE. +by rewrite !coord_sum_free ?(basis_free (vbasisP _)). +Qed. + +Canonical baseField_vectType := VectType F0 L0 baseField_vectMixin. +Canonical baseField_FalgType := [FalgType F0 of L0]. +Canonical baseField_extFieldType := [fieldExtType F0 of L0]. + +Let F0ZEZ a x v : a *: ((x *: v : L) : L0) = (a *: x) *: v. +Proof. by rewrite [a *: _]scalerA -scalerAl mul1r. Qed. + +Let baseVspace_basis V : seq L0 := + [seq tnth bF ij.2 *: tnth (vbasis V) ij.1 | ij : 'I_(\dim V) * 'I_n]. +Definition baseVspace V := <>%VS. + +Lemma mem_baseVspace V : baseVspace V =i V. +Proof. +move=> y; apply/idP/idP=> [/coord_span->|/coord_vbasis->]; last first. + apply: memv_suml => i _; rewrite (coordF (coord _ i (y : L))) scaler_suml -/n. + apply: memv_suml => j _; rewrite -/bF -F0ZEZ memvZ ?memv_span // -!tnth_nth. + by apply/imageP; exists (i, j). + (* GG: the F0ZEZ lemma avoids serious performance issues here. *) +apply: memv_suml => k _; rewrite nth_image; case: (enum_val k) => i j /=. +by rewrite F0ZEZ memvZ ?vbasis_mem ?mem_tnth. +Qed. + +Lemma dim_baseVspace V : \dim (baseVspace V) = (\dim V * n)%N. +Proof. +pose bV0 := baseVspace_basis V; set m := \dim V in bV0 *. +suffices /size_basis->: basis_of (baseVspace V) bV0. + by rewrite card_prod !card_ord. +rewrite /basis_of eqxx. +apply/freeP=> s sb0 k; rewrite -(enum_valK k); case/enum_val: k => i j. +have free_baseP := freeP (basis_free (vbasisP _)). +move: j; apply: (free_baseP _ _ fullv); move: i; apply: (free_baseP _ _ V). +transitivity (\sum_i \sum_j s (enum_rank (i, j)) *: bV0`_(enum_rank (i, j))). + apply: eq_bigr => i _; rewrite scaler_suml; apply: eq_bigr => j _. + by rewrite -F0ZEZ nth_image enum_rankK -!tnth_nth. +rewrite pair_bigA (reindex _ (onW_bij _ (enum_val_bij _))); apply: etrans sb0. +by apply: eq_bigr => k _; rewrite -{5 6}[k](enum_valK k); case/enum_val: k. +Qed. + +Fact baseAspace_suproof (E : {subfield L}) : is_aspace (baseVspace E). +Proof. +rewrite /is_aspace has_algid1; last by rewrite mem_baseVspace (mem1v E). +by apply/prodvP=> u v; rewrite !mem_baseVspace; exact: memvM. +Qed. +Canonical baseAspace E := ASpace (baseAspace_suproof E). + +Fact refBaseField_key : unit. Proof. by []. Qed. +Definition refBaseField := locked_with refBaseField_key (baseAspace 1). +Canonical refBaseField_unlockable := [unlockable of refBaseField]. +Notation F1 := refBaseField. + +Lemma dim_refBaseField : \dim F1 = n. +Proof. by rewrite [F1]unlock dim_baseVspace dimv1 mul1n. Qed. + +Lemma baseVspace_module V (V0 := baseVspace V) : (F1 * V0 <= V0)%VS. +Proof. +apply/prodvP=> u v; rewrite [F1]unlock !mem_baseVspace => /vlineP[x ->] Vv. +by rewrite -(@scalerAl F L) mul1r; exact: memvZ. +Qed. + +Lemma sub_baseField (E : {subfield L}) : (F1 <= baseVspace E)%VS. +Proof. by rewrite -sup_field_module baseVspace_module. Qed. + +Lemma vspaceOver_refBase V : vspaceOver F1 (baseVspace V) =i V. +Proof. +move=> v; rewrite mem_vspaceOver field_module_eq ?baseVspace_module //. +by rewrite mem_baseVspace. +Qed. + +Lemma module_baseVspace M0 : + (F1 * M0 <= M0)%VS -> {V | M0 = baseVspace V & M0 =i V}. +Proof. +move=> modM0; pose V := <>%VS. +suffices memM0: M0 =i V. + by exists V => //; apply/vspaceP=> v; rewrite mem_baseVspace memM0. +move=> v; rewrite -{1}(field_module_eq modM0) -(mem_vspaceOver M0) {}/V. +move: (vspaceOver F1 M0) => M. +apply/idP/idP=> [/coord_vbasis|/coord_span]->; apply/memv_suml=> i _. + rewrite /(_ *: _) /= /fieldOver_scale; case: (coord _ i _) => /= x. + rewrite {1}[F1]unlock mem_baseVspace => /vlineP[{x}x ->]. + by rewrite -(@scalerAl F L) mul1r memvZ ?memv_span ?memt_nth. +move: (coord _ i _) => x; rewrite -[_`_i]mul1r scalerAl -tnth_nth. +have F1x: x%:A \in F1. + by rewrite [F1]unlock mem_baseVspace (@memvZ F L) // mem1v. +by congr (_ \in M): (memvZ (Subvs F1x) (vbasis_mem (mem_tnth i _))). +Qed. + +Lemma module_baseAspace (E0 : {subfield L0}) : + (F1 <= E0)%VS -> {E | E0 = baseAspace E & E0 =i E}. +Proof. +rewrite -sup_field_module => /module_baseVspace[E defE0 memE0]. +suffices algE: is_aspace E by exists (ASpace algE); first exact: val_inj. +rewrite /is_aspace has_algid1 -?memE0 ?mem1v //. +by apply/prodvP=> u v; rewrite -!memE0; apply: memvM. +Qed. + +End BaseField. + +Notation baseFieldType L := (baseField_type (Phant L)). + +(* Base of fieldOver, finally. *) +Section MoreFieldOver. + +Variables (F0 : fieldType) (L : fieldExtType F0) (F : {subfield L}). + +Lemma base_vspaceOver V : baseVspace (vspaceOver F V) =i (F * V)%VS. +Proof. by move=> v; rewrite mem_baseVspace mem_vspaceOver. Qed. + +Lemma base_moduleOver V : (F * V <= V)%VS -> baseVspace (vspaceOver F V) =i V. +Proof. by move=> /field_module_eq defV v; rewrite base_vspaceOver defV. Qed. + +Lemma base_aspaceOver (E : {subfield L}) : + (F <= E)%VS -> baseVspace (vspaceOver F E) =i E. +Proof. by rewrite -sup_field_module; apply: base_moduleOver. Qed. + +End MoreFieldOver. + +Section SubFieldExtension. + +Local Open Scope quotient_scope. + +Variables (F L : fieldType) (iota : {rmorphism F -> L}). +Variables (z : L) (p : {poly F}). + +Local Notation "p ^iota" := (map_poly (GRing.RMorphism.apply iota) p) + (at level 2, format "p ^iota") : ring_scope. + +Let wf_p := (p != 0) && root p^iota z. +Let p0 : {poly F} := if wf_p then (lead_coef p)^-1 *: p else 'X. +Let z0 := if wf_p then z else 0. +Let n := (size p0).-1. + +Let p0_mon : p0 \is monic. +Proof. +rewrite /p0; case: ifP => [/andP[nz_p _] | _]; last exact: monicX. +by rewrite monicE lead_coefZ mulVf ?lead_coef_eq0. +Qed. + +Let nz_p0 : p0 != 0. Proof. by rewrite monic_neq0 // p0_mon. Qed. + +Let p0z0 : root p0^iota z0. +Proof. +rewrite /p0 /z0; case: ifP => [/andP[_ pz0]|]; last by rewrite map_polyX rootX. +by rewrite map_polyZ rootE hornerZ (rootP pz0) mulr0. +Qed. + +Let n_gt0: 0 < n. +Proof. +rewrite /n -subn1 subn_gt0 -(size_map_poly iota). +by rewrite (root_size_gt1 _ p0z0) ?map_poly_eq0. +Qed. + +Let z0Ciota : commr_rmorph iota z0. Proof. by move=> x; apply: mulrC. Qed. +Local Notation iotaPz := (horner_morph z0Ciota). +Let iotaFz (x : 'rV[F]_n) := iotaPz (rVpoly x). + +Definition equiv_subfext x y := (iotaFz x == iotaFz y). + +Fact equiv_subfext_is_equiv : equiv_class_of equiv_subfext. +Proof. by rewrite /equiv_subfext; split=> x // y w /eqP->. Qed. + +Canonical equiv_subfext_equiv := EquivRelPack equiv_subfext_is_equiv. +Canonical equiv_subfext_encModRel := defaultEncModRel equiv_subfext. + +Definition subFExtend := {eq_quot equiv_subfext}. +Canonical subFExtend_eqType := [eqType of subFExtend]. +Canonical subFExtend_choiceType := [choiceType of subFExtend]. +Canonical subFExtend_quotType := [quotType of subFExtend]. +Canonical subFExtend_eqQuotType := [eqQuotType equiv_subfext of subFExtend]. + +Definition subfx_inj := lift_fun1 subFExtend iotaFz. + +Fact pi_subfx_inj : {mono \pi : x / iotaFz x >-> subfx_inj x}. +Proof. +unlock subfx_inj => x; apply/eqP; rewrite -/(equiv_subfext _ x). +by rewrite -eqmodE reprK. +Qed. +Canonical pi_subfx_inj_morph := PiMono1 pi_subfx_inj. + +Let iotaPz_repr x : iotaPz (rVpoly (repr (\pi_(subFExtend) x))) = iotaFz x. +Proof. by rewrite -/(iotaFz _) -!pi_subfx_inj reprK. Qed. + +Definition subfext0 := lift_cst subFExtend 0. +Canonical subfext0_morph := PiConst subfext0. + +Definition subfext_add := lift_op2 subFExtend +%R. +Fact pi_subfext_add : {morph \pi : x y / x + y >-> subfext_add x y}. +Proof. +unlock subfext_add => x y /=; apply/eqmodP/eqP. +by rewrite /iotaFz !linearD /= !iotaPz_repr. +Qed. +Canonical pi_subfx_add_morph := PiMorph2 pi_subfext_add. + +Definition subfext_opp := lift_op1 subFExtend -%R. +Fact pi_subfext_opp : {morph \pi : x / - x >-> subfext_opp x}. +Proof. +unlock subfext_opp => y /=; apply/eqmodP/eqP. +by rewrite /iotaFz !linearN /= !iotaPz_repr. +Qed. +Canonical pi_subfext_opp_morph := PiMorph1 pi_subfext_opp. + +Fact addfxA : associative subfext_add. +Proof. by move=> x y t; rewrite -[x]reprK -[y]reprK -[t]reprK !piE addrA. Qed. + +Fact addfxC : commutative subfext_add. +Proof. by move=> x y; rewrite -[x]reprK -[y]reprK !piE addrC. Qed. + +Fact add0fx : left_id subfext0 subfext_add. +Proof. by move=> x; rewrite -[x]reprK !piE add0r. Qed. + +Fact addfxN : left_inverse subfext0 subfext_opp subfext_add. +Proof. by move=> x; rewrite -[x]reprK !piE addNr. Qed. + +Definition subfext_zmodMixin := ZmodMixin addfxA addfxC add0fx addfxN. +Canonical subfext_zmodType := + Eval hnf in ZmodType subFExtend subfext_zmodMixin. + +Let poly_rV_modp_K q : rVpoly (poly_rV (q %% p0) : 'rV[F]_n) = q %% p0. +Proof. by apply: poly_rV_K; rewrite -ltnS -polySpred // ltn_modp. Qed. + +Let iotaPz_modp q : iotaPz (q %% p0) = iotaPz q. +Proof. +rewrite {2}(divp_eq q p0) rmorphD rmorphM /=. +by rewrite [iotaPz p0](rootP p0z0) mulr0 add0r. +Qed. + +Definition subfx_mul_rep (x y : 'rV[F]_n) : 'rV[F]_n := + poly_rV ((rVpoly x) * (rVpoly y) %% p0). + +Definition subfext_mul := lift_op2 subFExtend subfx_mul_rep. +Fact pi_subfext_mul : + {morph \pi : x y / subfx_mul_rep x y >-> subfext_mul x y}. +Proof. +unlock subfext_mul => x y /=; apply/eqmodP/eqP. +by rewrite /iotaFz !poly_rV_modp_K !iotaPz_modp !rmorphM /= !iotaPz_repr. +Qed. +Canonical pi_subfext_mul_morph := PiMorph2 pi_subfext_mul. + +Definition subfext1 := lift_cst subFExtend (poly_rV 1). +Canonical subfext1_morph := PiConst subfext1. + +Fact mulfxA : associative (subfext_mul). +Proof. +elim/quotW=> x; elim/quotW=> y; elim/quotW=> w; rewrite !piE /subfx_mul_rep. +by rewrite !poly_rV_modp_K [_ %% p0 * _]mulrC !modp_mul // mulrA mulrC. +Qed. + +Fact mulfxC : commutative subfext_mul. +Proof. +by elim/quotW=> x; elim/quotW=> y; rewrite !piE /subfx_mul_rep /= mulrC. +Qed. + +Fact mul1fx : left_id subfext1 subfext_mul. +Proof. +elim/quotW=> x; rewrite !piE /subfx_mul_rep poly_rV_K ?size_poly1 // mul1r. +by rewrite modp_small ?rVpolyK // (polySpred nz_p0) ltnS size_poly. +Qed. + +Fact mulfx_addl : left_distributive subfext_mul subfext_add. +Proof. +elim/quotW=> x; elim/quotW=> y; elim/quotW=> w; rewrite !piE /subfx_mul_rep. +by rewrite linearD /= mulrDl modp_add linearD. +Qed. + +Fact nonzero1fx : subfext1 != subfext0. +Proof. +rewrite !piE /equiv_subfext /iotaFz !linear0. +by rewrite poly_rV_K ?rmorph1 ?oner_eq0 // size_poly1. +Qed. + +Definition subfext_comRingMixin := + ComRingMixin mulfxA mulfxC mul1fx mulfx_addl nonzero1fx. +Canonical subfext_Ring := Eval hnf in RingType subFExtend subfext_comRingMixin. +Canonical subfext_comRing := Eval hnf in ComRingType subFExtend mulfxC. + +Definition subfx_poly_inv (q : {poly F}) : {poly F} := + if iotaPz q == 0 then 0 else + let r := gdcop q p0 in let: (u, v) := egcdp q r in + ((u * q + v * r)`_0)^-1 *: u. + +Let subfx_poly_invE q : iotaPz (subfx_poly_inv q) = (iotaPz q)^-1. +Proof. +rewrite /subfx_poly_inv. +have [-> | nzq] := altP eqP; first by rewrite rmorph0 invr0. +rewrite [nth]lock -[_^-1]mul1r; apply: canRL (mulfK nzq) _; rewrite -rmorphM /=. +have rz0: iotaPz (gdcop q p0) = 0. + by apply/rootP; rewrite gdcop_map root_gdco ?map_poly_eq0 // p0z0 nzq. +do [case: gdcopP => r _; rewrite (negPf nz_p0) orbF => co_r_q _] in rz0 *. +case: (egcdp q r) (egcdpE q r) => u v /=/eqp_size/esym/eqP. +rewrite coprimep_size_gcd 1?coprimep_sym // => /size_poly1P[a nz_a Da]. +rewrite Da -scalerAl (canRL (addrK _) Da) -lock coefC linearZ linearB /=. +by rewrite rmorphM /= rz0 mulr0 subr0 horner_morphC -rmorphM mulVf ?rmorph1. +Qed. + +Definition subfx_inv_rep (x : 'rV[F]_n) : 'rV[F]_n := + poly_rV (subfx_poly_inv (rVpoly x) %% p0). + +Definition subfext_inv := lift_op1 subFExtend subfx_inv_rep. +Fact pi_subfext_inv : {morph \pi : x / subfx_inv_rep x >-> subfext_inv x}. +Proof. +unlock subfext_inv => x /=; apply/eqmodP/eqP; rewrite /iotaFz. +by rewrite 2!{1}poly_rV_modp_K 2!{1}iotaPz_modp !subfx_poly_invE iotaPz_repr. +Qed. +Canonical pi_subfext_inv_morph := PiMorph1 pi_subfext_inv. + +Fact subfx_fieldAxiom : + GRing.Field.axiom (subfext_inv : subFExtend -> subFExtend). +Proof. +elim/quotW=> x; apply: contraNeq; rewrite !piE /equiv_subfext /iotaFz !linear0. +apply: contraR => nz_x; rewrite poly_rV_K ?size_poly1 // !poly_rV_modp_K. +by rewrite iotaPz_modp rmorph1 rmorphM /= iotaPz_modp subfx_poly_invE mulVf. +Qed. + +Fact subfx_inv0 : subfext_inv (0 : subFExtend) = (0 : subFExtend). +Proof. +apply/eqP; rewrite !piE /equiv_subfext /iotaFz /subfx_inv_rep !linear0. +by rewrite /subfx_poly_inv rmorph0 eqxx mod0p !linear0. +Qed. + +Definition subfext_unitRingMixin := FieldUnitMixin subfx_fieldAxiom subfx_inv0. +Canonical subfext_unitRingType := + Eval hnf in UnitRingType subFExtend subfext_unitRingMixin. +Canonical subfext_comUnitRing := Eval hnf in [comUnitRingType of subFExtend]. +Definition subfext_fieldMixin := @FieldMixin _ _ subfx_fieldAxiom subfx_inv0. +Definition subfext_idomainMixin := FieldIdomainMixin subfext_fieldMixin. +Canonical subfext_idomainType := + Eval hnf in IdomainType subFExtend subfext_idomainMixin. +Canonical subfext_fieldType := + Eval hnf in FieldType subFExtend subfext_fieldMixin. + +Fact subfx_inj_is_rmorphism : rmorphism subfx_inj. +Proof. +do 2?split; last by rewrite piE /iotaFz poly_rV_K ?rmorph1 ?size_poly1. + by elim/quotW=> x; elim/quotW=> y; rewrite !piE /iotaFz linearB rmorphB. +elim/quotW=> x; elim/quotW=> y; rewrite !piE /subfx_mul_rep /iotaFz. +by rewrite poly_rV_modp_K iotaPz_modp rmorphM. +Qed. +Canonical subfx_inj_additive := Additive subfx_inj_is_rmorphism. +Canonical subfx_inj_rmorphism := RMorphism subfx_inj_is_rmorphism. + +Definition subfx_eval := lift_embed subFExtend (fun q => poly_rV (q %% p0)). +Canonical subfx_eval_morph := PiEmbed subfx_eval. + +Definition subfx_root := subfx_eval 'X. + +Lemma subfx_eval_is_rmorphism : rmorphism subfx_eval. +Proof. +do 2?split=> [x y|] /=; apply/eqP; rewrite piE. +- by rewrite -linearB modp_add modNp. +- by rewrite /subfx_mul_rep !poly_rV_modp_K !(modp_mul, mulrC _ y). +by rewrite modp_small // size_poly1 -subn_gt0 subn1. +Qed. +Canonical subfx_eval_additive := Additive subfx_eval_is_rmorphism. +Canonical subfx_eval_rmorphism := AddRMorphism subfx_eval_is_rmorphism. + +Definition inj_subfx := (subfx_eval \o polyC). +Canonical inj_subfx_addidive := [additive of inj_subfx]. +Canonical inj_subfx_rmorphism := [rmorphism of inj_subfx]. + +Lemma subfxE x: exists p, x = subfx_eval p. +Proof. +elim/quotW: x => x; exists (rVpoly x); apply/eqP; rewrite piE /equiv_subfext. +by rewrite /iotaFz poly_rV_modp_K iotaPz_modp. +Qed. + +Definition subfx_scale a x := inj_subfx a * x. +Fact subfx_scalerA a b x : + subfx_scale a (subfx_scale b x) = subfx_scale (a * b) x. +Proof. by rewrite /subfx_scale rmorphM mulrA. Qed. +Fact subfx_scaler1r : left_id 1 subfx_scale. +Proof. by move=> x; rewrite /subfx_scale rmorph1 mul1r. Qed. +Fact subfx_scalerDr : right_distributive subfx_scale +%R. +Proof. by move=> a; exact: mulrDr. Qed. +Fact subfx_scalerDl x : {morph subfx_scale^~ x : a b / a + b}. +Proof. by move=> a b; rewrite /subfx_scale rmorphD mulrDl. Qed. +Definition subfx_lmodMixin := + LmodMixin subfx_scalerA subfx_scaler1r subfx_scalerDr subfx_scalerDl. +Canonical subfx_lmodType := LmodType F subFExtend subfx_lmodMixin. + +Fact subfx_scaleAl : GRing.Lalgebra.axiom ( *%R : subFExtend -> _). +Proof. by move=> a; apply: mulrA. Qed. +Canonical subfx_lalgType := LalgType F subFExtend subfx_scaleAl. + +Fact subfx_scaleAr : GRing.Algebra.axiom subfx_lalgType. +Proof. by move=> a; apply: mulrCA. Qed. +Canonical subfx_algType := AlgType F subFExtend subfx_scaleAr. +Canonical subfext_unitAlgType := [unitAlgType F of subFExtend]. + +Fact subfx_evalZ : scalable subfx_eval. +Proof. by move=> a q; rewrite -mul_polyC rmorphM. Qed. +Canonical subfx_eval_linear := AddLinear subfx_evalZ. +Canonical subfx_eval_lrmorphism := [lrmorphism of subfx_eval]. + +Hypothesis (pz0 : root p^iota z). + +Section NonZero. + +Hypothesis nz_p : p != 0. + +Lemma subfx_inj_eval q : subfx_inj (subfx_eval q) = q^iota.[z]. +Proof. +by rewrite piE /iotaFz poly_rV_modp_K iotaPz_modp /iotaPz /z0 /wf_p nz_p pz0. +Qed. + +Lemma subfx_inj_root : subfx_inj subfx_root = z. +Proof. by rewrite subfx_inj_eval // map_polyX hornerX. Qed. + +Lemma subfx_injZ b x : subfx_inj (b *: x) = iota b * subfx_inj x. +Proof. by rewrite rmorphM /= subfx_inj_eval // map_polyC hornerC. Qed. + +Lemma subfx_inj_base b : subfx_inj b%:A = iota b. +Proof. by rewrite subfx_injZ rmorph1 mulr1. Qed. + +Lemma subfxEroot x : {q | x = (map_poly (in_alg subFExtend) q).[subfx_root]}. +Proof. +have /sig_eqW[q ->] := subfxE x; exists q. +apply: (fmorph_inj subfx_inj_rmorphism). +rewrite -horner_map /= subfx_inj_root subfx_inj_eval //. +by rewrite -map_poly_comp (eq_map_poly subfx_inj_base). +Qed. + +Lemma subfx_irreducibleP : + (forall q, root q^iota z -> q != 0 -> size p <= size q) <-> irreducible_poly p. +Proof. +split=> [min_p | irr_p q qz0 nz_q]. + split=> [|q nonC_q q_dv_p]. + by rewrite -(size_map_poly iota) (root_size_gt1 _ pz0) ?map_poly_eq0. + have /dvdpP[r Dp] := q_dv_p; rewrite -dvdp_size_eqp // eqn_leq dvdp_leq //=. + have [nz_r nz_q]: r != 0 /\ q != 0 by apply/norP; rewrite -mulf_eq0 -Dp. + have: root r^iota z || root q^iota z by rewrite -rootM -rmorphM -Dp. + case/orP=> /min_p; [case/(_ _)/idPn=> // | exact]. + rewrite polySpred // -leqNgt Dp size_mul //= polySpred // -subn2 ltn_subRL. + by rewrite addSnnS addnC ltn_add2l ltn_neqAle eq_sym nonC_q size_poly_gt0. +pose r := gcdp p q; have nz_r: r != 0 by rewrite gcdp_eq0 (negPf nz_p). +suffices /eqp_size <-: r %= p by rewrite dvdp_leq ?dvdp_gcdr. +rewrite (irr_p _) ?dvdp_gcdl // -(size_map_poly iota) gtn_eqF //. +by rewrite (@root_size_gt1 _ z) ?map_poly_eq0 // gcdp_map root_gcd pz0. +Qed. + +End NonZero. + +Section Irreducible. + +Hypothesis irr_p : irreducible_poly p. +Let nz_p : p != 0. Proof. exact: irredp_neq0. Qed. + +(* The Vector axiom requires irreducibility. *) +Lemma min_subfx_vectAxiom : Vector.axiom (size p).-1 subfx_lmodType. +Proof. +move/subfx_irreducibleP: irr_p => /=/(_ nz_p) min_p; set d := (size p).-1. +have Dd: d.+1 = size p by rewrite polySpred. +pose Fz2v x : 'rV_d := poly_rV (sval (sig_eqW (subfxE x)) %% p). +pose vFz : 'rV_d -> subFExtend := subfx_eval \o @rVpoly F d. +have FLinj: injective subfx_inj by apply: fmorph_inj. +have Fz2vK: cancel Fz2v vFz. + move=> x; rewrite /vFz /Fz2v; case: (sig_eqW _) => /= q ->. + apply: FLinj; rewrite !subfx_inj_eval // {2}(divp_eq q p) rmorphD rmorphM /=. + by rewrite !hornerE (eqP pz0) mulr0 add0r poly_rV_K // -ltnS Dd ltn_modpN0. +suffices vFzK: cancel vFz Fz2v. + by exists Fz2v; [apply: can2_linear Fz2vK | exists vFz]. +apply: inj_can_sym Fz2vK _ => v1 v2 /(congr1 subfx_inj)/eqP. +rewrite -subr_eq0 -!raddfB /= subfx_inj_eval // => /min_p/implyP. +rewrite leqNgt implybNN -Dd ltnS size_poly linearB subr_eq0 /=. +by move/eqP/(can_inj (@rVpolyK _ _)). +Qed. + +Definition SubfxVectMixin := VectMixin min_subfx_vectAxiom. +Definition SubfxVectType := VectType F subFExtend SubfxVectMixin. +Definition SubfxFalgType := Eval simpl in [FalgType F of SubfxVectType]. +Definition SubFieldExtType := Eval simpl in [fieldExtType F of SubfxFalgType]. + +End Irreducible. + +End SubFieldExtension. + +Prenex Implicits subfx_inj. + +Lemma irredp_FAdjoin (F : fieldType) (p : {poly F}) : + irreducible_poly p -> + {L : fieldExtType F & \dim {:L} = (size p).-1 & + {z | root (map_poly (in_alg L) p) z & <<1; z>>%VS = fullv}}. +Proof. +case=> p_gt1 irr_p; set n := (size p).-1; pose vL := [vectType F of 'rV_n]. +have Dn: n.+1 = size p := ltn_predK p_gt1. +have nz_p: p != 0 by rewrite -size_poly_eq0 -Dn. +suffices [L dimL [toPF [toL toPF_K toL_K]]]: + {L : fieldExtType F & \dim {:L} = (size p).-1 + & {toPF : {linear L -> {poly F}} & {toL : {lrmorphism {poly F} -> L} | + cancel toPF toL & forall q, toPF (toL q) = q %% p}}}. +- exists L => //; pose z := toL 'X; set iota := in_alg _. + suffices q_z q: toPF (map_poly iota q).[z] = q %% p. + exists z; first by rewrite /root -(can_eq toPF_K) q_z modpp linear0. + apply/vspaceP=> x; rewrite memvf; apply/Fadjoin_polyP. + exists (map_poly iota (toPF x)). + by apply/polyOverP=> i; rewrite coef_map memvZ ?mem1v. + by apply: (can_inj toPF_K); rewrite q_z -toL_K toPF_K. + elim/poly_ind: q => [|a q IHq]. + by rewrite map_poly0 horner0 linear0 mod0p. + rewrite rmorphD rmorphM /= map_polyX map_polyC hornerMXaddC linearD /=. + rewrite linearZ /= -(rmorph1 toL) toL_K -modp_scalel alg_polyC modp_add. + congr (_ + _); rewrite -toL_K rmorphM /= -/z; congr (toPF (_ * z)). + by apply: (can_inj toPF_K); rewrite toL_K. +pose toL q : vL := poly_rV (q %% p); pose toPF (x : vL) := rVpoly x. +have toL_K q : toPF (toL q) = q %% p. + by rewrite /toPF poly_rV_K // -ltnS Dn ?ltn_modp -?Dn. +have toPF_K: cancel toPF toL. + by move=> x; rewrite /toL modp_small ?rVpolyK // -Dn ltnS size_poly. +have toPinj := can_inj toPF_K. +pose mul x y := toL (toPF x * toPF y); pose L1 := toL 1. +have L1K: toPF L1 = 1 by rewrite toL_K modp_small ?size_poly1. +have mulC: commutative mul by rewrite /mul => x y; rewrite mulrC. +have mulA: associative mul. + by move=> x y z; apply: toPinj; rewrite -!(mulC z) !toL_K !modp_mul mulrCA. +have mul1: left_id L1 mul. + by move=> x; apply: toPinj; rewrite mulC !toL_K modp_mul mulr1 -toL_K toPF_K. +have mulD: left_distributive mul +%R. + move=> x y z; apply: toPinj; rewrite /toPF raddfD /= -!/(toPF _). + by rewrite !toL_K /toPF raddfD mulrDl modp_add. +have nzL1: L1 != 0 by rewrite -(inj_eq toPinj) L1K /toPF raddf0 oner_eq0. +pose mulM := ComRingMixin mulA mulC mul1 mulD nzL1. +pose rL := ComRingType (RingType vL mulM) mulC. +have mulZl: GRing.Lalgebra.axiom mul. + move=> a x y; apply: toPinj; rewrite toL_K /toPF !linearZ /= -!/(toPF _). + by rewrite toL_K -scalerAl modp_scalel. +have mulZr: GRing.Algebra.axiom (LalgType F rL mulZl). + by move=> a x y; rewrite !(mulrC x) scalerAl. +pose aL := AlgType F _ mulZr; pose urL := FalgUnitRingType aL. +pose uaL := [unitAlgType F of AlgType F urL mulZr]. +pose faL := [FalgType F of uaL]. +have unitE: GRing.Field.mixin_of urL. + move=> x nz_x; apply/unitrP; set q := toPF x. + have nz_q: q != 0 by rewrite -(inj_eq toPinj) /toPF raddf0 in nz_x. + have /Bezout_eq1_coprimepP[u upq1]: coprimep p q. + apply: contraLR (leq_gcdpr p nz_q) => /irr_p/implyP. + rewrite dvdp_gcdl -ltnNge /= => /eqp_size->. + by rewrite (polySpred nz_p) ltnS size_poly. + suffices: x * toL u.2 = 1 by exists (toL u.2); rewrite mulrC. + apply: toPinj; rewrite !toL_K -upq1 modp_mul modp_add mulrC. + by rewrite modp_mull add0r. +pose ucrL := [comUnitRingType of ComRingType urL mulC]. +have mul0 := GRing.Field.IdomainMixin unitE. +pose fL := FieldType (IdomainType ucrL mul0) unitE. +exists [fieldExtType F of faL for fL]; first by rewrite dimvf; apply: mul1n. +exists [linear of toPF as @rVpoly _ _]. +suffices toLM: lrmorphism (toL : {poly F} -> aL) by exists (LRMorphism toLM). +have toLlin: linear toL. + by move=> a q1 q2; rewrite -linearP -modp_scalel -modp_add. +do ?split; try exact: toLlin; move=> q r /=. +by apply: toPinj; rewrite !toL_K modp_mul -!(mulrC r) modp_mul. +Qed. + +(*Coq 8.3 processes this shorter proof correctly, but then crashes on Qed. +Lemma Xirredp_FAdjoin' (F : fieldType) (p : {poly F}) : + irreducible_poly p -> + {L : fieldExtType F & Vector.dim L = (size p).-1 & + {z | root (map_poly (in_alg L) p) z & <<1; z>>%VS = fullv}}. +Proof. +case=> p_gt1 irr_p; set n := (size p).-1; pose vL := [vectType F of 'rV_n]. +have Dn: n.+1 = size p := ltn_predK p_gt1. +have nz_p: p != 0 by rewrite -size_poly_eq0 -Dn. +pose toL q : vL := poly_rV (q %% p). +have toL_K q : rVpoly (toL q) = q %% p. + by rewrite poly_rV_K // -ltnS Dn ?ltn_modp -?Dn. +pose mul (x y : vL) : vL := toL (rVpoly x * rVpoly y). +pose L1 : vL := poly_rV 1. +have L1K: rVpoly L1 = 1 by rewrite poly_rV_K // size_poly1 -ltnS Dn. +have mulC: commutative mul by rewrite /mul => x y; rewrite mulrC. +have mulA: associative mul. + by move=> x y z; rewrite -!(mulC z) /mul !toL_K /toL !modp_mul mulrCA. +have mul1: left_id L1 mul. + move=> x; rewrite /mul L1K mul1r /toL modp_small ?rVpolyK // -Dn ltnS. + by rewrite size_poly. +have mulD: left_distributive mul +%R. + move=> x y z; apply: canLR (@rVpolyK _ _) _. + by rewrite !raddfD mulrDl /= !toL_K /toL modp_add. +have nzL1: L1 != 0 by rewrite -(can_eq (@rVpolyK _ _)) L1K raddf0 oner_eq0. +pose mulM := ComRingMixin mulA mulC mul1 mulD nzL1. +pose rL := ComRingType (RingType vL mulM) mulC. +have mulZl: GRing.Lalgebra.axiom mul. + move=> a x y; apply: canRL (@rVpolyK _ _) _; rewrite !linearZ /= toL_K. + by rewrite -scalerAl modp_scalel. +have mulZr: @GRing.Algebra.axiom _ (LalgType F rL mulZl). + by move=> a x y; rewrite !(mulrC x) scalerAl. +pose aL := AlgType F _ mulZr; pose urL := FalgUnitRingType aL. +pose uaL := [unitAlgType F of AlgType F urL mulZr]. +pose faL := [FalgType F of uaL]. +have unitE: GRing.Field.mixin_of urL. + move=> x nz_x; apply/unitrP; set q := rVpoly x. + have nz_q: q != 0 by rewrite -(can_eq (@rVpolyK _ _)) raddf0 in nz_x. + have /Bezout_eq1_coprimepP[u upq1]: coprimep p q. + have /contraR := irr_p _ _ (dvdp_gcdl p q); apply. + have: size (gcdp p q) <= size q by exact: leq_gcdpr. + rewrite leqNgt;apply:contra;move/eqp_size ->. + by rewrite (polySpred nz_p) ltnS size_poly. + suffices: x * toL u.2 = 1 by exists (toL u.2); rewrite mulrC. + congr (poly_rV _); rewrite toL_K modp_mul mulrC (canRL (addKr _) upq1). + by rewrite -mulNr modp_addl_mul_small ?size_poly1. +pose ucrL := [comUnitRingType of ComRingType urL mulC]. +pose fL := FieldType (IdomainType ucrL (GRing.Field.IdomainMixin unitE)) unitE. +exists [fieldExtType F of faL for fL]; first exact: mul1n. +pose z : vL := toL 'X; set iota := in_alg _. +have q_z q: rVpoly (map_poly iota q).[z] = q %% p. + elim/poly_ind: q => [|a q IHq]. + by rewrite map_poly0 horner0 linear0 mod0p. + rewrite rmorphD rmorphM /= map_polyX map_polyC hornerMXaddC linearD /=. + rewrite linearZ /= L1K alg_polyC modp_add; congr (_ + _); last first. + by rewrite modp_small // size_polyC; case: (~~ _) => //; apply: ltnW. + by rewrite !toL_K IHq mulrC modp_mul mulrC modp_mul. +exists z; first by rewrite /root -(can_eq (@rVpolyK _ _)) q_z modpp linear0. +apply/vspaceP=> x; rewrite memvf; apply/Fadjoin_polyP. +exists (map_poly iota (rVpoly x)). + by apply/polyOverP=> i; rewrite coef_map memvZ ?mem1v. +apply: (can_inj (@rVpolyK _ _)). +by rewrite q_z modp_small // -Dn ltnS size_poly. +Qed. +*) diff --git a/mathcomp/field/finfield.v b/mathcomp/field/finfield.v new file mode 100644 index 0000000..14a02ef --- /dev/null +++ b/mathcomp/field/finfield.v @@ -0,0 +1,585 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype div. +Require Import tuple bigop prime finset fingroup ssralg poly polydiv. +Require Import morphism action finalg zmodp cyclic center pgroup abelian. +Require Import matrix mxabelem vector falgebra fieldext separable galois. +Require ssrnum ssrint algC cyclotomic. + +(******************************************************************************) +(* Additional constructions and results on finite fields. *) +(* *) +(* FinFieldExtType L == A FinFieldType structure on the carrier of L, *) +(* where L IS a fieldExtType F structure for an *) +(* F that has a finFieldType structure. This *) +(* does not take any existing finType structure *) +(* on L; this should not be made canonical. *) +(* FinSplittingFieldType F L == A SplittingFieldType F structure on the *) +(* carrier of L, where L IS a fieldExtType F for *) +(* an F with a finFieldType structure; this *) +(* should not be made canonical. *) +(* Import FinVector :: Declares canonical default finType, finRing, *) +(* etc structures (including FinFieldExtType *) +(* above) for abstract vectType, FalgType and *) +(* fieldExtType over a finFieldType. This should *) +(* be used with caution (e.g., local to a proof) *) +(* as the finType so obtained may clash with the *) +(* canonical one for standard types like matrix. *) +(* PrimeCharType charRp == The carrier of a ringType R such that *) +(* charRp : p \in [char R] holds. This type has *) +(* canonical ringType, ..., fieldType structures *) +(* compatible with those of R, as well as *) +(* canonical lmodType 'F_p, ..., algType 'F_p *) +(* structures, plus an FalgType structure if R *) +(* is a finUnitRingType and a splittingFieldType *) +(* struture if R is a finFieldType. *) +(* FinDomainFieldType domR == A finFieldType structure on a finUnitRingType *) +(* R, given domR : GRing.IntegralDomain.axiom R. *) +(* This is intended to be used inside proofs, *) +(* where one cannot declare Canonical instances. *) +(* Otherwise one should construct explicitly the *) +(* intermediate structures using the ssralg and *) +(* finalg constructors, and finDomain_mulrC domR *) +(* finDomain_fieldP domR to prove commutativity *) +(* and field axioms (the former is Wedderburn's *) +(* little theorem). *) +(* FinDomainSplittingFieldType domR charRp == A splittingFieldType structure *) +(* that repackages the two constructions above. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory FinRing.Theory. +Local Open Scope ring_scope. + +Section FinRing. + +Variable R : finRingType. + +(* GG: Coq v8.3 fails to unify FinGroup.arg_sort _ with FinRing.sort R here *) +(* because it expands the latter rather than FinGroup.arg_sort, which would *) +(* expose the FinGroup.sort projection, thereby enabling canonical structure *) +(* expansion. We should check whether the improved heuristics in Coq 8.4 have *) +(* resolved this issue. *) +Lemma finRing_nontrivial : [set: R] != 1%g. +Proof. by apply/(@trivgPn R); exists 1; rewrite ?inE ?oner_neq0. Qed. + +(* GG: same issue here. *) +Lemma finRing_gt1 : 1 < #|R|. +Proof. by rewrite -cardsT (@cardG_gt1 R) finRing_nontrivial. Qed. + +End FinRing. + +Section FinField. + +Variable F : finFieldType. + +Lemma card_finField_unit : #|[set: {unit F}]| = #|F|.-1. +Proof. +by rewrite -(cardC1 0) cardsT card_sub; apply: eq_card => x; rewrite unitfE. +Qed. + +Fact finField_unit_subproof x : x != 0 :> F -> x \is a GRing.unit. +Proof. by rewrite unitfE. Qed. + +Definition finField_unit x nz_x := + FinRing.unit F (@finField_unit_subproof x nz_x). + +Lemma expf_card x : x ^+ #|F| = x :> F. +Proof. +apply/eqP; rewrite -{2}[x]mulr1 -[#|F|]prednK; last by rewrite (cardD1 x). +rewrite exprS -subr_eq0 -mulrBr mulf_eq0 -implyNb -unitfE subr_eq0. +apply/implyP=> Ux; rewrite -(val_unitX _ (FinRing.unit F Ux)) -val_unit1. +by rewrite val_eqE -order_dvdn -card_finField_unit order_dvdG ?inE. +Qed. + +Lemma finField_genPoly : 'X^#|F| - 'X = \prod_x ('X - x%:P) :> {poly F}. +Proof. +set n := #|F|; set Xn := 'X^n; set NX := - 'X; set pF := Xn + NX. +have lnNXn: size NX <= n by rewrite size_opp size_polyX finRing_gt1. +have UeF: uniq_roots (enum F) by rewrite uniq_rootsE enum_uniq. +rewrite [pF](all_roots_prod_XsubC _ _ UeF) ?size_addl ?size_polyXn -?cardE //. + by rewrite enumT lead_coefDl ?size_polyXn // (monicP (monicXn _ _)) scale1r. +by apply/allP=> x _; rewrite rootE !hornerE hornerXn expf_card subrr. +Qed. + +Lemma finCharP : {p | prime p & p \in [char F]}. +Proof. +pose e := exponent [set: F]; have e_gt0: e > 0 := exponent_gt0 _. +have: e%:R == 0 :> F by rewrite -zmodXgE expg_exponent // inE. +by case/natf0_char/sigW=> // p charFp; exists p; rewrite ?(charf_prime charFp). +Qed. + +Lemma finField_is_abelem : is_abelem [set: F]. +Proof. +have [p pr_p charFp] := finCharP. +apply/is_abelemP; exists p; rewrite ?abelemE ?zmod_abelian //=. +by apply/exponentP=> x _; rewrite zmodXgE mulrn_char. +Qed. + +Lemma card_finCharP p n : #|F| = (p ^ n)%N -> prime p -> p \in [char F]. +Proof. +move=> oF pr_p; rewrite inE pr_p -order_dvdn. +rewrite (abelem_order_p finField_is_abelem) ?inE ?oner_neq0 //=. +have n_gt0: n > 0 by rewrite -(ltn_exp2l _ _ (prime_gt1 pr_p)) -oF finRing_gt1. +by rewrite cardsT oF -(prednK n_gt0) pdiv_pfactor. +Qed. + +End FinField. + +Section CardVspace. + +Variables (F : finFieldType) (T : finType). + +Section Vector. + +Variable cvT : Vector.class_of F T. +Let vT := Vector.Pack (Phant F) cvT T. + +Lemma card_vspace (V : {vspace vT}) : #|V| = (#|F| ^ \dim V)%N. +Proof. +set n := \dim V; pose V2rV v := \row_i coord (vbasis V) i v. +pose rV2V (rv : 'rV_n) := \sum_i rv 0 i *: (vbasis V)`_i. +have rV2V_K: cancel rV2V V2rV. + have freeV: free (vbasis V) := basis_free (vbasisP V). + by move=> rv; apply/rowP=> i; rewrite mxE coord_sum_free. +rewrite -[n]mul1n -card_matrix -(card_imset _ (can_inj rV2V_K)). +apply: eq_card => v; apply/idP/imsetP=> [/coord_vbasis-> | [rv _ ->]]. + by exists (V2rV v) => //; apply: eq_bigr => i _; rewrite mxE. +by apply: (@rpred_sum vT) => i _; rewrite rpredZ ?vbasis_mem ?memt_nth. +Qed. + +Lemma card_vspacef : #|{: vT}%VS| = #|T|. +Proof. by apply: eq_card => v; rewrite (@memvf _ vT). Qed. + +End Vector. + +Variable caT : Falgebra.class_of F T. +Let aT := Falgebra.Pack (Phant F) caT T. + +Lemma card_vspace1 : #|(1%VS : {vspace aT})| = #|F|. +Proof. by rewrite card_vspace (dimv1 aT). Qed. + +End CardVspace. + +Lemma VectFinMixin (R : finRingType) (vT : vectType R) : Finite.mixin_of vT. +Proof. +have v2rK := @Vector.InternalTheory.v2rK R vT. +exact: CanFinMixin (v2rK : @cancel _ (CountType vT (CanCountMixin v2rK)) _ _). +Qed. + +(* These instacnces are not exported by default because they conflict with *) +(* existing finType instances such as matrix_finType or primeChar_finType. *) +Module FinVector. +Section Interfaces. + +Variable F : finFieldType. +Implicit Types (vT : vectType F) (aT : FalgType F) (fT : fieldExtType F). + +Canonical vect_finType vT := FinType vT (VectFinMixin vT). +Canonical Falg_finType aT := FinType aT (VectFinMixin aT). +Canonical fieldExt_finType fT := FinType fT (VectFinMixin fT). + +Canonical Falg_finRingType aT := [finRingType of aT]. +Canonical fieldExt_finRingType fT := [finRingType of fT]. +Canonical fieldExt_finFieldType fT := [finFieldType of fT]. + +Lemma finField_splittingField_axiom fT : SplittingField.axiom fT. +Proof. +exists ('X^#|fT| - 'X); first by rewrite rpredB 1?rpredX ?polyOverX. +exists (enum fT); first by rewrite enumT finField_genPoly eqpxx. +by apply/vspaceP=> x; rewrite memvf seqv_sub_adjoin ?mem_enum. +Qed. + +End Interfaces. +End FinVector. + +Notation FinFieldExtType := FinVector.fieldExt_finFieldType. +Notation FinSplittingFieldAxiom := (FinVector.finField_splittingField_axiom _). +Notation FinSplittingFieldType F L := + (SplittingFieldType F L FinSplittingFieldAxiom). + +Section PrimeChar. + +Variable p : nat. + +Section PrimeCharRing. + +Variable R0 : ringType. + +Definition PrimeCharType of p \in [char R0] : predArgType := R0. + +Hypothesis charRp : p \in [char R0]. +Local Notation R := (PrimeCharType charRp). +Implicit Types (a b : 'F_p) (x y : R). + +Canonical primeChar_eqType := [eqType of R]. +Canonical primeChar_choiceType := [choiceType of R]. +Canonical primeChar_zmodType := [zmodType of R]. +Canonical primeChar_ringType := [ringType of R]. + +Definition primeChar_scale a x := a%:R * x. +Local Infix "*p:" := primeChar_scale (at level 40). + +Let natrFp n : (inZp n : 'F_p)%:R = n%:R :> R. +Proof. +rewrite {2}(divn_eq n p) natrD mulrnA (mulrn_char charRp) add0r. +by rewrite /= (Fp_cast (charf_prime charRp)). +Qed. + +Lemma primeChar_scaleA a b x : a *p: (b *p: x) = (a * b) *p: x. +Proof. by rewrite /primeChar_scale mulrA -natrM natrFp. Qed. + +Lemma primeChar_scale1 : left_id 1 primeChar_scale. +Proof. by move=> x; rewrite /primeChar_scale mul1r. Qed. + +Lemma primeChar_scaleDr : right_distributive primeChar_scale +%R. +Proof. by move=> a x y /=; rewrite /primeChar_scale mulrDr. Qed. + +Lemma primeChar_scaleDl x : {morph primeChar_scale^~ x: a b / a + b}. +Proof. by move=> a b; rewrite /primeChar_scale natrFp natrD mulrDl. Qed. + +Definition primeChar_lmodMixin := + LmodMixin primeChar_scaleA primeChar_scale1 + primeChar_scaleDr primeChar_scaleDl. +Canonical primeChar_lmodType := LmodType 'F_p R primeChar_lmodMixin. + +Lemma primeChar_scaleAl : GRing.Lalgebra.axiom ( *%R : R -> R -> R). +Proof. by move=> a x y; apply: mulrA. Qed. +Canonical primeChar_LalgType := LalgType 'F_p R primeChar_scaleAl. + +Lemma primeChar_scaleAr : GRing.Algebra.axiom primeChar_LalgType. +Proof. by move=> a x y; rewrite ![a *: _]mulr_natl mulrnAr. Qed. +Canonical primeChar_algType := AlgType 'F_p R primeChar_scaleAr. + +End PrimeCharRing. + +Local Notation type := @PrimeCharType. + +Canonical primeChar_unitRingType (R : unitRingType) charRp := + [unitRingType of type R charRp]. +Canonical primeChar_unitAlgType (R : unitRingType) charRp := + [unitAlgType 'F_p of type R charRp]. +Canonical primeChar_comRingType (R : comRingType) charRp := + [comRingType of type R charRp]. +Canonical primeChar_comUnitRingType (R : comUnitRingType) charRp := + [comUnitRingType of type R charRp]. +Canonical primeChar_idomainType (R : idomainType) charRp := + [idomainType of type R charRp]. +Canonical primeChar_fieldType (F : fieldType) charFp := + [fieldType of type F charFp]. + +Section FinRing. + +Variables (R0 : finRingType) (charRp : p \in [char R0]). +Local Notation R := (type _ charRp). + +Canonical primeChar_finType := [finType of R]. +Canonical primeChar_finZmodType := [finZmodType of R]. +Canonical primeChar_baseGroupType := [baseFinGroupType of R for +%R]. +Canonical primeChar_groupType := [finGroupType of R for +%R]. +Canonical primeChar_finRingType := [finRingType of R]. + +Let pr_p : prime p. Proof. exact: charf_prime charRp. Qed. + +Lemma primeChar_abelem : p.-abelem [set: R]. +Proof. +rewrite abelemE ?zmod_abelian //=. +by apply/exponentP=> x _; rewrite zmodXgE mulrn_char. +Qed. + +Lemma primeChar_pgroup : p.-group [set: R]. +Proof. by case/and3P: primeChar_abelem. Qed. + +Lemma order_primeChar x : x != 0 :> R -> #[x]%g = p. +Proof. by apply: (abelem_order_p primeChar_abelem); rewrite inE. Qed. + +Let n := logn p #|R|. + +Lemma card_primeChar : #|R| = (p ^ n)%N. +Proof. by rewrite /n -cardsT {1}(card_pgroup primeChar_pgroup). Qed. + +Lemma primeChar_vectAxiom : Vector.axiom n (primeChar_lmodType charRp). +Proof. +have /isog_isom/=[f /isomP[injf im_f]]: [set: R] \isog [set: 'rV['F_p]_n]. + have [abelR ntR] := (primeChar_abelem, finRing_nontrivial R0). + by rewrite /n -cardsT -(dim_abelemE abelR) ?isog_abelem_rV. +exists f; last by exists (invm injf) => x; rewrite ?invmE ?invmK ?im_f ?inE. +move=> a x y; rewrite [a *: _]mulr_natl morphM ?morphX ?inE // zmodXgE. +by congr (_ + _); rewrite -scaler_nat natr_Zp. +Qed. + +Definition primeChar_vectMixin := Vector.Mixin primeChar_vectAxiom. +Canonical primeChar_vectType := VectType 'F_p R primeChar_vectMixin. + +Lemma primeChar_dimf : \dim {:primeChar_vectType} = n. +Proof. by rewrite dimvf. Qed. + +End FinRing. + +Canonical primeChar_finUnitRingType (R : finUnitRingType) charRp := + [finUnitRingType of type R charRp]. +Canonical primeChar_finUnitAlgType (R : finUnitRingType) charRp := + [finUnitAlgType 'F_p of type R charRp]. +Canonical primeChar_FalgType (R : finUnitRingType) charRp := + [FalgType 'F_p of type R charRp]. +Canonical primeChar_finComRingType (R : finComRingType) charRp := + [finComRingType of type R charRp]. +Canonical primeChar_finComUnitRingType (R : finComUnitRingType) charRp := + [finComUnitRingType of type R charRp]. +Canonical primeChar_finIdomainType (R : finIdomainType) charRp := + [finIdomainType of type R charRp]. + +Section FinField. + +Variables (F0 : finFieldType) (charFp : p \in [char F0]). +Local Notation F := (type _ charFp). + +Canonical primeChar_finFieldType := [finFieldType of F]. +(* We need to use the eta-long version of the constructor here as projections *) +(* of the Canonical fieldType of F cannot be computed syntactically. *) +Canonical primeChar_fieldExtType := [fieldExtType 'F_p of F for F0]. +Canonical primeChar_splittingFieldType := FinSplittingFieldType 'F_p F. + +End FinField. + +End PrimeChar. + +Section FinSplittingField. + +Variable F : finFieldType. + +(* By card_vspace order K = #|K| for any finType structure on L; however we *) +(* do not want to impose the FinVector instance here. *) +Let order (L : vectType F) (K : {vspace L}) := (#|F| ^ \dim K)%N. + +Section FinGalois. + +Variable L : splittingFieldType F. +Implicit Types (a b : F) (x y : L) (K E : {subfield L}). + +Let galL K : galois K {:L}. +Proof. +without loss {K} ->: K / K = 1%AS. + by move=> IH; apply: galoisS (IH _ (erefl _)); rewrite sub1v subvf. +apply/splitting_galoisField; pose finL := FinFieldExtType L. +exists ('X^#|finL| - 'X); split; first by rewrite rpredB 1?rpredX ?polyOverX. + rewrite (finField_genPoly finL) -big_filter. + by rewrite separable_prod_XsubC ?(enum_uniq finL). +exists (enum finL); first by rewrite enumT (finField_genPoly finL) eqpxx. +by apply/vspaceP=> x; rewrite memvf seqv_sub_adjoin ?(mem_enum finL). +Qed. + +Fact galLgen K : + {alpha | generator 'Gal({:L} / K) alpha & forall x, alpha x = x ^+ order K}. +Proof. +without loss{K} ->: K / K = 1%AS; last rewrite /order dimv1 expn1. + rewrite /generator => /(_ _ (erefl _))[alpha /eqP defGalL]. + rewrite /order dimv1 expn1 => Dalpha. + exists (alpha ^+ \dim K)%g => [|x]; last first. + elim: (\dim K) => [|n IHn]; first by rewrite gal_id. + by rewrite expgSr galM ?memvf // IHn Dalpha expnSr exprM. + rewrite (eq_subG_cyclic (cycle_cyclic alpha)) ?cycleX //=; last first. + by rewrite -defGalL galS ?sub1v. + rewrite eq_sym -orderE orderXdiv orderE -defGalL -{1}(galois_dim (galL 1)). + by rewrite dimv1 divn1 galois_dim. + by rewrite dimv1 divn1 field_dimS // subvf. +pose f x := x ^+ #|F|. +have idfP x: reflect (f x = x) (x \in 1%VS). + rewrite /f; apply: (iffP (vlineP _ _)) => [[a ->] | xFx]. + by rewrite -in_algE -rmorphX expf_card. + pose q := map_poly (in_alg L) ('X^#|F| - 'X). + have: root q x. + rewrite /q rmorphB /= map_polyXn map_polyX. + by rewrite rootE !(hornerE, hornerXn) xFx subrr. + have{q} ->: q = \prod_(z <- [seq b%:A | b : F]) ('X - z%:P). + rewrite /q finField_genPoly rmorph_prod big_map enumT. + by apply: eq_bigr => b _; rewrite rmorphB /= map_polyX map_polyC. + by rewrite root_prod_XsubC => /mapP[a]; exists a. +have fM: rmorphism f. + rewrite /f; do 2?split=> [x y|]; rewrite ?exprMn ?expr1n //. + have [p _ charFp] := finCharP F; rewrite (card_primeChar charFp). + elim: (logn _ _) => // n IHn; rewrite expnSr !exprM {}IHn. + by rewrite -(char_lalg L) in charFp; rewrite -Frobenius_autE rmorphB. +have fZ: linear f. + move=> a x y; rewrite -mulr_algl [f _](rmorphD (RMorphism fM)) rmorphM /=. + by rewrite (idfP _ _) ?mulr_algl ?memvZ // memv_line. +have /kAut_to_gal[alpha galLalpha Dalpha]: kAut 1 {:L} (linfun (Linear fZ)). + rewrite kAutfE; apply/kHomP; split=> [x y _ _ | x /idfP]; rewrite !lfunE //=. + exact: (rmorphM (RMorphism fM)). +exists alpha => [|a]; last by rewrite -Dalpha ?memvf ?lfunE. +suffices <-: fixedField [set alpha] = 1%AS by rewrite gal_generated /generator. +apply/vspaceP => x; apply/fixedFieldP/idfP; rewrite ?memvf // => id_x. + by rewrite -{2}(id_x _ (set11 _)) -Dalpha ?lfunE ?memvf. +by move=> _ /set1P->; rewrite -Dalpha ?memvf ?lfunE. +Qed. + +Lemma finField_galois K E : (K <= E)%VS -> galois K E. +Proof. +move=> sKE; have /galois_fixedField <- := galL E. +rewrite normal_fixedField_galois // -sub_abelian_normal ?galS //. +apply: abelianS (galS _ (sub1v _)) _. +by have [alpha /('Gal(_ / _) =P _)-> _] := galLgen 1; apply: cycle_abelian. +Qed. + +Lemma finField_galois_generator K E : + (K <= E)%VS -> + {alpha | generator 'Gal(E / K) alpha + & {in E, forall x, alpha x = x ^+ order K}}. +Proof. +move=> sKE; have [alpha defGalLK Dalpha] := galLgen K. +have inKL_E: (K <= E <= {:L})%VS by rewrite sKE subvf. +have nKE: normalField K E by have/and3P[] := finField_galois sKE. +have galLKalpha: alpha \in 'Gal({:L} / K). + by rewrite (('Gal(_ / _) =P _) defGalLK) cycle_id. +exists (normalField_cast _ alpha) => [|x Ex]; last first. + by rewrite (normalField_cast_eq inKL_E). +rewrite /generator -(morphim_cycle (normalField_cast_morphism inKL_E nKE)) //. +by rewrite -((_ =P <[alpha]>) defGalLK) normalField_img. +Qed. + +End FinGalois. + +Lemma Fermat's_little_theorem (L : fieldExtType F) (K : {subfield L}) a : + (a \in K) = (a ^+ order K == a). +Proof. +move: K a; wlog [{L}L -> K a]: L / exists galL : splittingFieldType F, L = galL. + by pose galL := (FinSplittingFieldType F L) => /(_ galL); apply; exists galL. +have /galois_fixedField fixLK := finField_galois (subvf K). +have [alpha defGalLK Dalpha] := finField_galois_generator (subvf K). +rewrite -Dalpha ?memvf // -{1}fixLK (('Gal(_ / _) =P _) defGalLK). +rewrite /cycle -gal_generated (galois_fixedField _) ?fixedField_galois //. +by apply/fixedFieldP/eqP=> [|-> | alpha_x _ /set1P->]; rewrite ?memvf ?set11. +Qed. + +End FinSplittingField. + +Section FinDomain. + +Import ssrnum ssrint algC cyclotomic Num.Theory. +Local Infix "%|" := dvdn. (* Hide polynomial divisibility. *) + +Variable R : finUnitRingType. + +Hypothesis domR : GRing.IntegralDomain.axiom R. +Implicit Types x y : R. + +Let lregR x : x != 0 -> GRing.lreg x. +Proof. by move=> xnz; apply: mulrI0_lreg => y /domR/orP[/idPn | /eqP]. Qed. + +Lemma finDomain_field : GRing.Field.mixin_of R. +Proof. +move=> x /lregR-regx; apply/unitrP; exists (invF regx 1). +by split; first apply: (regx); rewrite ?mulrA f_invF // mulr1 mul1r. +Qed. + +(* This is Witt's proof of Wedderburn's little theorem. *) +Theorem finDomain_mulrC : @commutative R R *%R. +Proof. +have fieldR := finDomain_field. +have [p p_pr charRp]: exists2 p, prime p & p \in [char R]. + have [e /prod_prime_decomp->]: {e | (e > 0)%N & e%:R == 0 :> R}. + by exists #|[set: R]%G|; rewrite // -order_dvdn order_dvdG ?inE. + rewrite big_seq; elim/big_rec: _ => [|[p m] /= n]; first by rewrite oner_eq0. + case/mem_prime_decomp=> p_pr _ _ IHn. + elim: m => [|m IHm]; rewrite ?mul1n {IHn}// expnS -mulnA natrM. + by case/eqP/domR/orP=> //; exists p; last exact/andP. +pose Rp := PrimeCharType charRp; pose L : {vspace Rp} := fullv. +pose G := [set: {unit R}]; pose ofG : {unit R} -> Rp := val. +pose projG (E : {vspace Rp}) := [preim ofG of E]. +have inG t nzt: Sub t (finDomain_field nzt) \in G by rewrite inE. +have card_projG E: #|projG E| = (p ^ \dim E - 1)%N. + transitivity #|E|.-1; last by rewrite subn1 card_vspace card_Fp. + rewrite (cardD1 0) mem0v (card_preim val_inj) /=. + apply: eq_card => x; congr (_ && _); rewrite [LHS]codom_val. + by apply/idP/idP=> [/(memPn _ _)-> | /fieldR]; rewrite ?unitr0. +pose C u := 'C[ofG u]%AS; pose Q := 'C(L)%AS; pose q := (p ^ \dim Q)%N. +have defC u: 'C[u] =i projG (C u). + by move=> v; rewrite cent1E !inE (sameP cent1vP eqP). +have defQ: 'Z(G) =i projG Q. + move=> u; rewrite !inE. + apply/centP/centvP=> cGu v _; last exact/val_inj/cGu/memvf. + by have [-> | /inG/cGu[]] := eqVneq v 0; first by rewrite commr0. +have q_gt1: (1 < q)%N by rewrite (ltn_exp2l 0) ?prime_gt1 ?adim_gt0. +pose n := \dim_Q L; have oG: #|G| = (q ^ n - 1)%N. + rewrite -expnM mulnC divnK ?skew_field_dimS ?subvf // -card_projG. + by apply: eq_card => u; rewrite !inE memvf. +have oZ: #|'Z(G)| = (q - 1)%N by rewrite -card_projG; apply: eq_card. +suffices n_le1: (n <= 1)%N. + move=> u v; apply/centvsP: (memvf (u : Rp)) (memvf (v : Rp)) => {u v}. + rewrite -(geq_leqif (dimv_leqif_sup (subvf Q))) -/L. + by rewrite leq_divLR ?mul1n ?skew_field_dimS ?subvf in n_le1. +without loss n_gt1: / (1 < n)%N by rewrite ltnNge; apply: wlog_neg. +have [q_gt0 n_gt0] := (ltnW q_gt1, ltnW n_gt1). +have [z z_prim] := C_prim_root_exists n_gt0. +have zn1: z ^+ n = 1 by apply: prim_expr_order. +have /eqP-n1z: `|z| == 1. + by rewrite -(pexpr_eq1 n_gt0) ?normr_ge0 // -normrX zn1 normr1. +suffices /eqP/normC_sub_eq[t n1t [Dq Dz]]: `|q%:R - z| == `|q%:R| - `|z|. + suffices z1: z == 1 by rewrite leq_eqVlt -dvdn1 (prim_order_dvd z_prim) z1. + by rewrite Dz n1z mul1r -(eqr_pmuln2r q_gt0) Dq normr_nat mulr_natl. +pose aq d : algC := (cyclotomic (z ^+ (n %/ d)) d).[q%:R]. +suffices: `|aq n| <= (q - 1)%:R. + rewrite eqr_le ler_sub_dist andbT n1z normr_nat natrB //; apply: ler_trans. + rewrite {}/aq horner_prod divnn n_gt0 expr1 normr_prod. + rewrite (bigD1 (Ordinal n_gt1)) ?coprime1n //= !hornerE ler_pemulr //. + elim/big_ind: _ => // [|d _]; first exact: mulr_ege1. + rewrite !hornerE; apply: ler_trans (ler_sub_dist _ _). + by rewrite normr_nat normrX n1z expr1n ler_subr_addl (leC_nat 2). +have Zaq d: d %| n -> aq d \in Cint. + move/(dvdn_prim_root z_prim)=> zd_prim. + rewrite rpred_horner ?rpred_nat //= -Cintr_Cyclotomic //. + by apply/polyOverP=> i; rewrite coef_map ?rpred_int. +suffices: (aq n %| (q - 1)%:R)%C. + rewrite {1}[aq n]CintEsign ?Zaq // -(rpredMsign _ (aq n < 0)%R). + rewrite dvdC_mul2l ?signr_eq0 //. + have /CnatP[m ->]: `|aq n| \in Cnat by rewrite Cnat_norm_Cint ?Zaq. + by rewrite leC_nat dvdC_nat; apply: dvdn_leq; rewrite subn_gt0. +have prod_aq m: m %| n -> \prod_(d < n.+1 | d %| m) aq d = (q ^ m - 1)%:R. + move=> m_dv_n; transitivity ('X^m - 1).[q%:R : algC]; last first. + by rewrite !hornerE hornerXn -natrX natrB ?expn_gt0 ?prime_gt0. + rewrite (prod_cyclotomic (dvdn_prim_root z_prim m_dv_n)). + have def_divm: perm_eq (divisors m) [seq d <- index_iota 0 n.+1 | d %| m]. + rewrite uniq_perm_eq ?divisors_uniq ?filter_uniq ?iota_uniq // => d. + rewrite -dvdn_divisors ?(dvdn_gt0 n_gt0) // mem_filter mem_iota ltnS /=. + by apply/esym/andb_idr=> d_dv_m; rewrite dvdn_leq ?(dvdn_trans d_dv_m). + rewrite (eq_big_perm _ def_divm) big_filter big_mkord horner_prod. + by apply: eq_bigr => d d_dv_m; rewrite -exprM muln_divA ?divnK. +have /rpredBl<-: (aq n %| #|G|%:R)%C. + rewrite oG -prod_aq // (bigD1 ord_max) //= dvdC_mulr //. + by apply: rpred_prod => d /andP[/Zaq]. +rewrite center_class_formula addrC oZ natrD addKr natr_sum /=. +apply: rpred_sum => _ /imsetP[u /setDP[_ Z'u] ->]; rewrite -/G /=. +have sQC: (Q <= C u)%VS by apply/subvP=> v /centvP-cLv; apply/cent1vP/cLv/memvf. +have{sQC} /dvdnP[m Dm]: \dim Q %| \dim (C u) by apply: skew_field_dimS. +have m_dv_n: m %| n by rewrite dvdn_divRL // -?Dm ?skew_field_dimS ?subvf. +have m_gt0: (0 < m)%N := dvdn_gt0 n_gt0 m_dv_n. +have{Dm} oCu: #|'C[u]| = (q ^ m - 1)%N. + by rewrite -expnM mulnC -Dm (eq_card (defC u)) card_projG. +have ->: #|u ^: G|%:R = \prod_(d < n.+1 | d %| n) (aq d / aq d ^+ (d %| m)). + rewrite -index_cent1 natf_indexg ?subsetT //= setTI prodf_div prod_aq // -oG. + congr (_ / _); rewrite big_mkcond oCu -prod_aq //= big_mkcond /=. + by apply: eq_bigr => d _; case: ifP => [/dvdn_trans->| _]; rewrite ?if_same. +rewrite (bigD1 ord_max) //= [n %| m](contraNF _ Z'u) => [|n_dv_m]; last first. + rewrite -sub_cent1 subEproper eq_sym eqEcard subsetT oG oCu leq_sub2r //. + by rewrite leq_exp2l // dvdn_leq. +rewrite divr1 dvdC_mulr //; apply/rpred_prod => d /andP[/Zaq-Zaqd _]. +have [-> | nz_aqd] := eqVneq (aq d) 0; first by rewrite mul0r. +by rewrite -[aq d]expr1 -exprB ?leq_b1 ?unitfE ?rpredX. +Qed. + +Definition FinDomainFieldType : finFieldType := + let fin_unit_class := FinRing.UnitRing.class R in + let com_class := GRing.ComRing.Class finDomain_mulrC in + let com_unit_class := @GRing.ComUnitRing.Class R com_class fin_unit_class in + let dom_class := @GRing.IntegralDomain.Class R com_unit_class domR in + let field_class := @GRing.Field.Class R dom_class finDomain_field in + let finfield_class := @FinRing.Field.Class R field_class fin_unit_class in + FinRing.Field.Pack finfield_class R. + +Definition FinDomainSplittingFieldType p (charRp : p \in [char R]) := + let RoverFp := @primeChar_splittingFieldType p FinDomainFieldType charRp in + [splittingFieldType 'F_p of R for RoverFp]. + +End FinDomain. diff --git a/mathcomp/field/galois.v b/mathcomp/field/galois.v new file mode 100644 index 0000000..ccdd8e4 --- /dev/null +++ b/mathcomp/field/galois.v @@ -0,0 +1,1628 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype. +Require Import tuple finfun bigop ssralg poly polydiv. +Require Import finset fingroup morphism quotient perm action zmodp cyclic. +Require Import matrix mxalgebra vector falgebra fieldext separable. + +(******************************************************************************) +(* This file develops some basic Galois field theory, defining: *) +(* splittingFieldFor K p E <-> E is the smallest field over K that splits p *) +(* into linear factors. *) +(* kHom K E f <=> f : 'End(L) is a ring morphism on E and fixes K. *) +(* kAut K E f <=> f : 'End(L) is a kHom K E and f @: E == E. *) +(* kHomExtend E f x y == a kHom K <> that extends f and maps x to y, *) +(* when f \is a kHom K E and root (minPoly E x) y. *) +(* *) +(* splittingFieldFor K p E <-> E is splitting field for p over K: p splits in *) +(* E and its roots generate E from K. *) +(* splittingFieldType F == the interface type of splitting field extensions *) +(* of F, that is, extensions generated by all the *) +(* algebraic roots of some polynomial, or, *) +(* equivalently, normal field extensions of F. *) +(* SplittingField.axiom F L == the axiom stating that L is a splitting field. *) +(* SplittingFieldType F L FsplitL == packs a proof FsplitL of the splitting *) +(* field axiom for L into a splitingFieldType F, *) +(* provided L has a fieldExtType F structure. *) +(* [splittingFieldType F of L] == a clone of the canonical splittingFieldType *) +(* structure for L. *) +(*[splittingFieldType F of L for M] == an L-clone of the canonical *) +(* splittingFieldType structure on M. *) +(* *) +(* gal_of E == the group_type of automorphisms of E over the *) +(* base field F. *) +(* 'Gal(E / K) == the group of automorphisms of E that fix K. *) +(* fixedField s == the field fixed by the set of automorphisms s. *) +(* fixedField set0 = E when set0 : {set: gal_of E} *) +(* normalField K E <=> E is invariant for every 'Gal(L / K) for every L. *) +(* galois K E <=> E is a normal and separable field extension of K. *) +(* galTrace K E a == \sum_(f in 'Gal(E / K)) (f a). *) +(* galNorm K E a == \prod_(f in 'Gal(E / K)) (f a). *) +(* *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Reserved Notation "''Gal' ( A / B )" + (at level 8, A at level 35, format "''Gal' ( A / B )"). + +Import GroupScope GRing.Theory. +Local Open Scope ring_scope. + +Section SplittingFieldFor. + +Variables (F : fieldType) (L : fieldExtType F). + +Definition splittingFieldFor (U : {vspace L}) (p : {poly L}) (V : {vspace L}) := + exists2 rs, p %= \prod_(z <- rs) ('X - z%:P) & <>%VS = V. + +Lemma splittingFieldForS (K M E : {subfield L}) p : + (K <= M)%VS -> (M <= E)%VS -> + splittingFieldFor K p E -> splittingFieldFor M p E. +Proof. +move=> sKM sKE [rs Dp genL]; exists rs => //; apply/eqP. +rewrite eqEsubv -[in X in _ && (X <= _)%VS]genL adjoin_seqSl // andbT. +by apply/Fadjoin_seqP; split; rewrite // -genL; apply: seqv_sub_adjoin. +Qed. + +End SplittingFieldFor. + +Section kHom. + +Variables (F : fieldType) (L : fieldExtType F). +Implicit Types (U V : {vspace L}) (K E : {subfield L}) (f g : 'End(L)). + +Definition kHom U V f := ahom_in V f && (U <= fixedSpace f)%VS. + +Lemma kHomP {K V f} : + reflect [/\ {in V &, forall x y, f (x * y) = f x * f y} + & {in K, forall x, f x = x}] + (kHom K V f). +Proof. +apply: (iffP andP) => [[/ahom_inP[fM _] /subvP idKf] | [fM idKf]]. + by split=> // x /idKf/fixedSpaceP. +split; last by apply/subvP=> x /idKf/fixedSpaceP. +by apply/ahom_inP; split=> //; rewrite idKf ?mem1v. +Qed. + +Lemma kAHomP {U V} {f : 'AEnd(L)} : + reflect {in U, forall x, f x = x} (kHom U V f). +Proof. by rewrite /kHom ahomWin; apply: fixedSpacesP. Qed. + +Lemma kHom1 U V : kHom U V \1. +Proof. by apply/kAHomP => u _; rewrite lfunE. Qed. + +Lemma k1HomE V f : kHom 1 V f = ahom_in V f. +Proof. by apply: andb_idr => /ahom_inP[_ f1]; apply/fixedSpaceP. Qed. + +Lemma kHom_lrmorphism (f : 'End(L)) : reflect (lrmorphism f) (kHom 1 {:L} f). +Proof. by rewrite k1HomE; apply: ahomP. Qed. + +Lemma k1AHom V (f : 'AEnd(L)) : kHom 1 V f. +Proof. by rewrite k1HomE ahomWin. Qed. + +Lemma kHom_poly_id K E f p : + kHom K E f -> p \is a polyOver K -> map_poly f p = p. +Proof. +by case/kHomP=> _ idKf /polyOverP Kp; apply/polyP=> i; rewrite coef_map /= idKf. +Qed. + +Lemma kHomSl U1 U2 V f : (U1 <= U2)%VS -> kHom U2 V f -> kHom U1 V f. +Proof. by rewrite /kHom => sU12 /andP[-> /(subv_trans sU12)]. Qed. + +Lemma kHomSr K V1 V2 f : (V1 <= V2)%VS -> kHom K V2 f -> kHom K V1 f. +Proof. by move/subvP=> sV12 /kHomP[/(sub_in2 sV12)fM idKf]; apply/kHomP. Qed. + +Lemma kHomS K1 K2 V1 V2 f : + (K1 <= K2)%VS -> (V1 <= V2)%VS -> kHom K2 V2 f -> kHom K1 V1 f. +Proof. by move=> sK12 sV12 /(kHomSl sK12)/(kHomSr sV12). Qed. + +Lemma kHom_eq K E f g : + (K <= E)%VS -> {in E, f =1 g} -> kHom K E f = kHom K E g. +Proof. +move/subvP=> sKE eq_fg; wlog suffices: f g eq_fg / kHom K E f -> kHom K E g. + by move=> IH; apply/idP/idP; apply: IH => x /eq_fg. +case/kHomP=> fM idKf; apply/kHomP. +by split=> [x y Ex Ey | x Kx]; rewrite -!eq_fg ?fM ?rpredM // ?idKf ?sKE. +Qed. + +Lemma kHom_inv K E f : kHom K E f -> {in E, {morph f : x / x^-1}}. +Proof. +case/kHomP=> fM idKf x Ex. +case (eqVneq x 0) => [-> | nz_x]; first by rewrite linear0 invr0 linear0. +have fxV: f x * f x^-1 = 1 by rewrite -fM ?rpredV ?divff // idKf ?mem1v. +have Ufx: f x \is a GRing.unit by apply/unitrPr; exists (f x^-1). +by apply: (mulrI Ufx); rewrite divrr. +Qed. + +Lemma kHom_dim K E f : kHom K E f -> \dim (f @: E) = \dim E. +Proof. +move=> homKf; have [fM idKf] := kHomP homKf. +apply/limg_dim_eq/eqP; rewrite -subv0; apply/subvP=> v. +rewrite memv_cap memv0 memv_ker => /andP[Ev]; apply: contraLR => nz_v. +by rewrite -unitfE unitrE -(kHom_inv homKf) // -fM ?rpredV ?divff ?idKf ?mem1v. +Qed. + +Lemma kHom_is_rmorphism K E f : + kHom K E f -> rmorphism (f \o vsval : subvs_of E -> L). +Proof. +case/kHomP=> fM idKf; split=> [a b|]; first exact: raddfB. +by split=> [a b|] /=; [rewrite /= fM ?subvsP | rewrite algid1 idKf // mem1v]. +Qed. +Definition kHom_rmorphism K E f homKEf := + RMorphism (@kHom_is_rmorphism K E f homKEf). + +Lemma kHom_horner K E f p x : + kHom K E f -> p \is a polyOver E -> x \in E -> f p.[x] = (map_poly f p).[f x]. +Proof. +move=> homKf /polyOver_subvs[{p}p -> Ex]; pose fRM := kHom_rmorphism homKf. +by rewrite (horner_map _ _ (Subvs Ex)) -[f _](horner_map fRM) map_poly_comp. +Qed. + +Lemma kHom_root K E f p x : + kHom K E f -> p \is a polyOver E -> x \in E -> root p x -> + root (map_poly f p) (f x). +Proof. +by move/kHom_horner=> homKf Ep Ex /rootP px0; rewrite /root -homKf ?px0 ?raddf0. +Qed. + +Lemma kHom_root_id K E f p x : + (K <= E)%VS -> kHom K E f -> p \is a polyOver K -> x \in E -> root p x -> + root p (f x). +Proof. +move=> sKE homKf Kp Ex /(kHom_root homKf (polyOverSv sKE Kp) Ex). +by rewrite (kHom_poly_id homKf). +Qed. + +Section kHomExtend. + +Variables (K E : {subfield L}) (f : 'End(L)) (x y : L). + +Fact kHomExtend_subproof : + linear (fun z => (map_poly f (Fadjoin_poly E x z)).[y]). +Proof. +move=> k a b; rewrite linearP /= raddfD hornerE; congr (_ + _). +rewrite -[rhs in _ = rhs]mulr_algl -hornerZ /=; congr _.[_]. +by apply/polyP => i; rewrite !(coefZ, coef_map) /= !mulr_algl linearZ. +Qed. +Definition kHomExtend := linfun (Linear kHomExtend_subproof). + +Lemma kHomExtendE z : kHomExtend z = (map_poly f (Fadjoin_poly E x z)).[y]. +Proof. by rewrite lfunE. Qed. + +Hypotheses (sKE : (K <= E)%VS) (homKf : kHom K E f). +Local Notation Px := (minPoly E x). +Hypothesis fPx_y_0 : root (map_poly f Px) y. + +Lemma kHomExtend_id z : z \in E -> kHomExtend z = f z. +Proof. by move=> Ez; rewrite kHomExtendE Fadjoin_polyC ?map_polyC ?hornerC. Qed. + +Lemma kHomExtend_val : kHomExtend x = y. +Proof. +have fX: map_poly f 'X = 'X by rewrite (kHom_poly_id homKf) ?polyOverX. +have [Ex | E'x] := boolP (x \in E); last first. + by rewrite kHomExtendE Fadjoin_polyX // fX hornerX. +have:= fPx_y_0; rewrite (minPoly_XsubC Ex) raddfB /= map_polyC fX root_XsubC /=. +by rewrite (kHomExtend_id Ex) => /eqP->. +Qed. + +Lemma kHomExtend_poly p : + p \in polyOver E -> kHomExtend p.[x] = (map_poly f p).[y]. +Proof. +move=> Ep; rewrite kHomExtendE (Fadjoin_poly_mod x) //. +rewrite (divp_eq (map_poly f p) (map_poly f Px)). +rewrite !hornerE (rootP fPx_y_0) mulr0 add0r. +have [p1 ->] := polyOver_subvs Ep. +have [Px1 ->] := polyOver_subvs (minPolyOver E x). +by rewrite -map_modp -!map_poly_comp (map_modp (kHom_rmorphism homKf)). +Qed. + +Lemma kHomExtendP : kHom K <> kHomExtend. +Proof. +have [fM idKf] := kHomP homKf. +apply/kHomP; split=> [|z Kz]; last by rewrite kHomExtend_id ?(subvP sKE) ?idKf. +move=> _ _ /Fadjoin_polyP[p Ep ->] /Fadjoin_polyP[q Eq ->]. +rewrite -hornerM !kHomExtend_poly ?rpredM // -hornerM; congr _.[_]. +apply/polyP=> i; rewrite coef_map !coefM /= linear_sum /=. +by apply: eq_bigr => j _; rewrite !coef_map /= fM ?(polyOverP _). +Qed. + +End kHomExtend. + +Definition kAut U V f := kHom U V f && (f @: V == V)%VS. + +Lemma kAutE K E f : kAut K E f = kHom K E f && (f @: E <= E)%VS. +Proof. +apply/andP/andP=> [[-> /eqP->] // | [homKf EfE]]. +by rewrite eqEdim EfE /= (kHom_dim homKf). +Qed. + +Lemma kAutS U1 U2 V f : (U1 <= U2)%VS -> kAut U2 V f -> kAut U1 V f. +Proof. by move=> sU12 /andP[/(kHomSl sU12)homU1f EfE]; apply/andP. Qed. + +Lemma kHom_kAut_sub K E f : kAut K E f -> kHom K E f. Proof. by case/andP. Qed. + +Lemma kAut_eq K E (f g : 'End(L)) : + (K <= E)%VS -> {in E, f =1 g} -> kAut K E f = kAut K E g. +Proof. +by move=> sKE eq_fg; rewrite !kAutE (kHom_eq sKE eq_fg) (eq_in_limg eq_fg). +Qed. + +Lemma kAutfE K f : kAut K {:L} f = kHom K {:L} f. +Proof. by rewrite kAutE subvf andbT. Qed. + +Lemma kAut1E E (f : 'AEnd(L)) : kAut 1 E f = (f @: E <= E)%VS. +Proof. by rewrite kAutE k1AHom. Qed. + +Lemma kAutf_lker0 K f : kHom K {:L} f -> lker f == 0%VS. +Proof. +move/(kHomSl (sub1v _))/kHom_lrmorphism=> fM. +by apply/lker0P; apply: (fmorph_inj (RMorphism fM)). +Qed. + +Lemma inv_kHomf K f : kHom K {:L} f -> kHom K {:L} f^-1. +Proof. +move=> homKf; have [[fM idKf] kerf0] := (kHomP homKf, kAutf_lker0 homKf). +have f1K: cancel f^-1%VF f by apply: lker0_lfunVK. +apply/kHomP; split=> [x y _ _ | x Kx]; apply: (lker0P kerf0). + by rewrite fM ?memvf ?{1}f1K. +by rewrite f1K idKf. +Qed. + +Lemma inv_is_ahom (f : 'AEnd(L)) : ahom_in {:L} f^-1. +Proof. +have /ahomP/kHom_lrmorphism hom1f := valP f. +exact/ahomP/kHom_lrmorphism/inv_kHomf. +Qed. + +Canonical inv_ahom (f : 'AEnd(L)) : 'AEnd(L) := AHom (inv_is_ahom f). +Notation "f ^-1" := (inv_ahom f) : lrfun_scope. + +Lemma comp_kHom_img K E f g : + kHom K (g @: E) f -> kHom K E g -> kHom K E (f \o g). +Proof. +move=> /kHomP[fM idKf] /kHomP[gM idKg]; apply/kHomP; split=> [x y Ex Ey | x Kx]. + by rewrite !lfunE /= gM // fM ?memv_img. +by rewrite lfunE /= idKg ?idKf. +Qed. + +Lemma comp_kHom K E f g : kHom K {:L} f -> kHom K E g -> kHom K E (f \o g). +Proof. by move/(kHomSr (subvf (g @: E))); apply: comp_kHom_img. Qed. + +Lemma kHom_extends K E f p U : + (K <= E)%VS -> kHom K E f -> + p \is a polyOver K -> splittingFieldFor E p U -> + {g | kHom K U g & {in E, f =1 g}}. +Proof. +move=> sKE homEf Kp /sig2_eqW[rs Dp <-{U}]. +set r := rs; have rs_r: all (mem rs) r by apply/allP. +elim: r rs_r => [_|z r IHr /=/andP[rs_z rs_r]] /= in E f sKE homEf *. + by exists f; rewrite ?Fadjoin_nil. +set Ez := <>%AS; pose fpEz := map_poly f (minPoly E z). +suffices{IHr} /sigW[y fpEz_y]: exists y, root fpEz y. + have homEz_fz: kHom K Ez (kHomExtend E f z y) by apply: kHomExtendP. + have sKEz: (K <= Ez)%VS := subv_trans sKE (subv_adjoin E z). + have [g homGg Dg] := IHr rs_r _ _ sKEz homEz_fz. + exists g => [|x Ex]; first by rewrite adjoin_cons. + by rewrite -Dg ?subvP_adjoin // kHomExtend_id. +have [m DfpEz]: {m | fpEz %= \prod_(w <- mask m rs) ('X - w%:P)}. + apply: dvdp_prod_XsubC; rewrite -(eqp_dvdr _ Dp) -(kHom_poly_id homEf Kp). + have /polyOver_subvs[q Dq] := polyOverSv sKE Kp. + have /polyOver_subvs[qz Dqz] := minPolyOver E z. + rewrite /fpEz Dq Dqz -2?{1}map_poly_comp (dvdp_map (kHom_rmorphism homEf)). + rewrite -(dvdp_map [rmorphism of @vsval _ _ E]) -Dqz -Dq. + by rewrite minPoly_dvdp ?(polyOverSv sKE) // (eqp_root Dp) root_prod_XsubC. +exists (mask m rs)`_0; rewrite (eqp_root DfpEz) root_prod_XsubC mem_nth //. +rewrite -ltnS -(size_prod_XsubC _ id) -(eqp_size DfpEz). +rewrite size_poly_eq -?lead_coefE ?size_minPoly // (monicP (monic_minPoly E z)). +by have [_ idKf] := kHomP homEf; rewrite idKf ?mem1v ?oner_eq0. +Qed. + +End kHom. + +Notation "f ^-1" := (inv_ahom f) : lrfun_scope. + +Implicit Arguments kHomP [F L K V f]. +Implicit Arguments kAHomP [F L U V f]. +Implicit Arguments kHom_lrmorphism [F L f]. + +Module SplittingField. + +Import GRing. + +Section ClassDef. + +Variable F : fieldType. + +Definition axiom (L : fieldExtType F) := + exists2 p : {poly L}, p \is a polyOver 1%VS & splittingFieldFor 1 p {:L}. + +Record class_of (L : Type) : Type := + Class {base : FieldExt.class_of F L; _ : axiom (FieldExt.Pack _ base L)}. +Local Coercion base : class_of >-> FieldExt.class_of. + +Structure type (phF : phant F) := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variable (phF : phant F) (T : Type) (cT : type phF). +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 phF T c T. + +Definition pack b0 (ax0 : axiom (@FieldExt.Pack F (Phant F) T b0 T)) := + fun bT b & phant_id (@FieldExt.class F phF bT) b => + fun ax & phant_id ax0 ax => Pack (Phant F) (@Class T b ax) T. + +Definition eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition zmodType := @Zmodule.Pack cT xclass xT. +Definition ringType := @Ring.Pack cT xclass xT. +Definition unitRingType := @UnitRing.Pack cT xclass xT. +Definition comRingType := @ComRing.Pack cT xclass xT. +Definition comUnitRingType := @ComUnitRing.Pack cT xclass xT. +Definition idomainType := @IntegralDomain.Pack cT xclass xT. +Definition fieldType := @Field.Pack cT xclass xT. +Definition lmodType := @Lmodule.Pack F phF cT xclass xT. +Definition lalgType := @Lalgebra.Pack F phF cT xclass xT. +Definition algType := @Algebra.Pack F phF cT xclass xT. +Definition unitAlgType := @UnitAlgebra.Pack F phF cT xclass xT. +Definition vectType := @Vector.Pack F phF cT xclass xT. +Definition FalgType := @Falgebra.Pack F phF cT xclass xT. +Definition fieldExtType := @FieldExt.Pack F phF cT xclass xT. + +End ClassDef. + +Module Exports. + +Coercion sort : type >-> Sortclass. +Bind Scope ring_scope with sort. +Coercion base : class_of >-> FieldExt.class_of. +Coercion eqType : type >-> Equality.type. +Canonical eqType. +Coercion choiceType : type >-> Choice.type. +Canonical choiceType. +Coercion zmodType : type >-> Zmodule.type. +Canonical zmodType. +Coercion ringType : type >-> Ring.type. +Canonical ringType. +Coercion unitRingType : type >-> UnitRing.type. +Canonical unitRingType. +Coercion comRingType : type >-> ComRing.type. +Canonical comRingType. +Coercion comUnitRingType : type >-> ComUnitRing.type. +Canonical comUnitRingType. +Coercion idomainType : type >-> IntegralDomain.type. +Canonical idomainType. +Coercion fieldType : type >-> Field.type. +Canonical fieldType. +Coercion lmodType : type >-> Lmodule.type. +Canonical lmodType. +Coercion lalgType : type >-> Lalgebra.type. +Canonical lalgType. +Coercion algType : type >-> Algebra.type. +Canonical algType. +Coercion unitAlgType : type >-> UnitAlgebra.type. +Canonical unitAlgType. +Coercion vectType : type >-> Vector.type. +Canonical vectType. +Coercion FalgType : type >-> Falgebra.type. +Canonical FalgType. +Coercion fieldExtType : type >-> FieldExt.type. +Canonical fieldExtType. + +Notation splittingFieldType F := (type (Phant F)). +Notation SplittingFieldType F L ax := (@pack _ (Phant F) L _ ax _ _ id _ id). +Notation "[ 'splittingFieldType' F 'of' L 'for' K ]" := + (@clone _ (Phant F) L K _ idfun) + (at level 0, format "[ 'splittingFieldType' F 'of' L 'for' K ]") + : form_scope. +Notation "[ 'splittingFieldType' F 'of' L ]" := + (@clone _ (Phant F) L _ _ id) + (at level 0, format "[ 'splittingFieldType' F 'of' L ]") : form_scope. + +End Exports. +End SplittingField. +Export SplittingField.Exports. + +Lemma normal_field_splitting (F : fieldType) (L : fieldExtType F) : + (forall (K : {subfield L}) x, + exists r, minPoly K x == \prod_(y <- r) ('X - y%:P)) -> + SplittingField.axiom L. +Proof. +move=> normalL; pose r i := sval (sigW (normalL 1%AS (tnth (vbasis {:L}) i))). +have sz_r i: size (r i) <= \dim {:L}. + rewrite -ltnS -(size_prod_XsubC _ id) /r; case: sigW => _ /= /eqP <-. + rewrite size_minPoly ltnS; move: (tnth _ _) => x. + by rewrite adjoin_degreeE dimv1 divn1 dimvS // subvf. +pose mkf (z : L) := 'X - z%:P. +exists (\prod_i \prod_(j < \dim {:L} | j < size (r i)) mkf (r i)`_j). + apply: rpred_prod => i _; rewrite big_ord_narrow /= /r; case: sigW => rs /=. + by rewrite (big_nth 0) big_mkord => /eqP <- {rs}; apply: minPolyOver. +rewrite pair_big_dep /= -big_filter filter_index_enum -(big_map _ xpredT mkf). +set rF := map _ _; exists rF; first exact: eqpxx. +apply/eqP; rewrite eqEsubv subvf -(span_basis (vbasisP {:L})). +apply/span_subvP=> _ /tnthP[i ->]; set x := tnth _ i. +have /tnthP[j ->]: x \in in_tuple (r i). + by rewrite -root_prod_XsubC /r; case: sigW => _ /=/eqP<-; apply: root_minPoly. +apply/seqv_sub_adjoin/imageP; rewrite (tnth_nth 0) /in_mem/=. +by exists (i, widen_ord (sz_r i) j) => /=. +Qed. + +Section SplittingFieldTheory. + +Variables (F : fieldType) (L : splittingFieldType F). + +Implicit Types (U V W : {vspace L}). +Implicit Types (K M E : {subfield L}). + +Lemma splittingFieldP : SplittingField.axiom L. +Proof. by case: L => ? []. Qed. + +Lemma splittingPoly : + {p : {poly L} | p \is a polyOver 1%VS & splittingFieldFor 1 p {:L}}. +Proof. +pose factF p s := (p \is a polyOver 1%VS) && (p %= \prod_(z <- s) ('X - z%:P)). +suffices [[p rs] /andP[]]: {ps | factF F L ps.1 ps.2 & <<1 & ps.2>> = {:L}}%VS. + by exists p; last exists rs. +apply: sig2_eqW; have [p F0p [rs splitLp genLrs]] := splittingFieldP. +by exists (p, rs); rewrite // /factF F0p splitLp. +Qed. + +Fact fieldOver_splitting E : SplittingField.axiom (fieldOver_fieldExtType E). +Proof. +have [p Fp [r Dp defL]] := splittingFieldP; exists p. + apply/polyOverP=> j; rewrite trivial_fieldOver. + by rewrite (subvP (sub1v E)) ?(polyOverP Fp). +exists r => //; apply/vspaceP=> x; rewrite memvf. +have [L0 [_ _ defL0]] := @aspaceOverP _ _ E <<1 & r : seq (fieldOver E)>>. +rewrite defL0; have: x \in <<1 & r>>%VS by rewrite defL (@memvf _ L). +apply: subvP; apply/Fadjoin_seqP; rewrite -memvE -defL0 mem1v. +by split=> // y r_y; rewrite -defL0 seqv_sub_adjoin. +Qed. +Canonical fieldOver_splittingFieldType E := + SplittingFieldType (subvs_of E) (fieldOver E) (fieldOver_splitting E). + +Lemma enum_AEnd : {kAutL : seq 'AEnd(L) | forall f, f \in kAutL}. +Proof. +pose isAutL (s : seq 'AEnd(L)) (f : 'AEnd(L)) := kHom 1 {:L} f = (f \in s). +suffices [kAutL in_kAutL] : {kAutL : seq 'AEnd(L) | forall f, isAutL kAutL f}. + by exists kAutL => f; rewrite -in_kAutL k1AHom. +have [p Kp /sig2_eqW[rs Dp defL]] := splittingPoly. +do [rewrite {}/isAutL -(erefl (asval 1)); set r := rs; set E := 1%AS] in defL *. +have [sKE rs_r]: (1 <= E)%VS /\ all (mem rs) r by split; last apply/allP. +elim: r rs_r => [_|z r IHr /=/andP[rs_z rs_r]] /= in (E) sKE defL *. + rewrite Fadjoin_nil in defL; exists [tuple \1%AF] => f; rewrite defL inE. + apply/idP/eqP=> [/kAHomP f1 | ->]; last exact: kHom1. + by apply/val_inj/lfunP=> x; rewrite id_lfunE f1 ?memvf. +do [set Ez := <>%VS; rewrite adjoin_cons] in defL. +have sEEz: (E <= Ez)%VS := subv_adjoin E z; have sKEz := subv_trans sKE sEEz. +have{IHr} [homEz DhomEz] := IHr rs_r _ sKEz defL. +have Ep: p \in polyOver E := polyOverSv sKE Kp. +have{rs_z} pz0: root p z by rewrite (eqp_root Dp) root_prod_XsubC. +pose pEz := minPoly E z; pose n := \dim_E Ez. +have{pz0} [rz DpEz]: {rz : n.-tuple L | pEz %= \prod_(w <- rz) ('X - w%:P)}. + have /dvdp_prod_XsubC[m DpEz]: pEz %| \prod_(w <- rs) ('X - w%:P). + by rewrite -(eqp_dvdr _ Dp) minPoly_dvdp ?(polyOverSv sKE). + suffices sz_rz: size (mask m rs) == n by exists (Tuple sz_rz). + rewrite -[n]adjoin_degreeE -eqSS -size_minPoly. + by rewrite (eqp_size DpEz) size_prod_XsubC. +have fEz i (y := tnth rz i): {f : 'AEnd(L) | kHom E {:L} f & f z = y}. + have homEfz: kHom E Ez (kHomExtend E \1 z y). + rewrite kHomExtendP ?kHom1 // lfun1_poly. + by rewrite (eqp_root DpEz) -/rz root_prod_XsubC mem_tnth. + have splitFp: splittingFieldFor Ez p {:L}. + exists rs => //; apply/eqP; rewrite eqEsubv subvf -defL adjoin_seqSr //. + exact/allP. + have [f homLf Df] := kHom_extends sEEz homEfz Ep splitFp. + have [ahomf _] := andP homLf; exists (AHom ahomf) => //. + rewrite -Df ?memv_adjoin ?(kHomExtend_val (kHom1 E E)) // lfun1_poly. + by rewrite (eqp_root DpEz) root_prod_XsubC mem_tnth. +exists [seq (s2val (fEz i) \o f)%AF| i <- enum 'I_n, f <- homEz] => f. +apply/idP/allpairsP => [homLf | [[i g] [_ Hg ->]] /=]; last first. + by case: (fEz i) => fi /= /comp_kHom->; rewrite ?(kHomSl sEEz) ?DhomEz. +have /tnthP[i Dfz]: f z \in rz. + rewrite memtE /= -root_prod_XsubC -(eqp_root DpEz). + by rewrite (kHom_root_id _ homLf) ?memvf ?subvf ?minPolyOver ?root_minPoly. +case Dfi: (fEz i) => [fi homLfi fi_z]; have kerfi0 := kAutf_lker0 homLfi. +set fj := (fi ^-1 \o f)%AF; suffices Hfj : fj \in homEz. + exists (i, fj) => //=; rewrite mem_enum inE Hfj; split => //. + by apply/val_inj; rewrite {}Dfi /= (lker0_compVKf kerfi0). +rewrite -DhomEz; apply/kAHomP => _ /Fadjoin_polyP[q Eq ->]. +have homLfj: kHom E {:L} fj := comp_kHom (inv_kHomf homLfi) homLf. +have /kHom_lrmorphism fjM := kHomSl (sub1v _) homLfj. +rewrite -[fj _](horner_map (RMorphism fjM)) (kHom_poly_id homLfj) //=. +by rewrite lfunE /= Dfz -fi_z lker0_lfunK. +Qed. + +Lemma splitting_field_normal K x : + exists r, minPoly K x == \prod_(y <- r) ('X - y%:P). +Proof. +pose q1 := minPoly 1 x; pose fx_root q (f : 'AEnd(L)) := root q (f x). +have [[p F0p splitLp] [autL DautL]] := (splittingFieldP, enum_AEnd). +suffices{K} autL_px q: q != 0 -> q %| q1 -> size q > 1 -> has (fx_root q) autL. + set q := minPoly K x; have: q \is monic := monic_minPoly K x. + have: q %| q1 by rewrite minPolyS // sub1v. + elim: {q}_.+1 {-2}q (ltnSn (size q)) => // d IHd q leqd q_dv_q1 mon_q. + have nz_q: q != 0 := monic_neq0 mon_q. + have [|q_gt1|q_1] := ltngtP (size q) 1; last first; last by rewrite polySpred. + by exists nil; rewrite big_nil -eqp_monic ?monic1 // -size_poly_eq1 q_1. + have /hasP[f autLf /factor_theorem[q2 Dq]] := autL_px q nz_q q_dv_q1 q_gt1. + have mon_q2: q2 \is monic by rewrite -(monicMr _ (monicXsubC (f x))) -Dq. + rewrite Dq size_monicM -?size_poly_eq0 ?size_XsubC ?addn2 //= ltnS in leqd. + have q2_dv_q1: q2 %| q1 by rewrite (dvdp_trans _ q_dv_q1) // Dq dvdp_mulr. + rewrite Dq; have [r /eqP->] := IHd q2 leqd q2_dv_q1 mon_q2. + by exists (f x :: r); rewrite big_cons mulrC. +elim: {q}_.+1 {-2}q (ltnSn (size q)) => // d IHd q leqd nz_q q_dv_q1 q_gt1. +without loss{d leqd IHd nz_q q_gt1} irr_q: q q_dv_q1 / irreducible_poly q. + move=> IHq; apply: wlog_neg => not_autLx_q; apply: IHq => //. + split=> // q2 q2_neq1 q2_dv_q; rewrite -dvdp_size_eqp // eqn_leq dvdp_leq //=. + rewrite leqNgt; apply: contra not_autLx_q => ltq2q. + have nz_q2: q2 != 0 by apply: contraTneq q2_dv_q => ->; rewrite dvd0p. + have{q2_neq1} q2_gt1: size q2 > 1 by rewrite neq_ltn polySpred in q2_neq1 *. + have{leqd ltq2q} ltq2d: size q2 < d by apply: leq_trans ltq2q _. + apply: sub_has (IHd _ ltq2d nz_q2 (dvdp_trans q2_dv_q q_dv_q1) q2_gt1) => f. + by rewrite /fx_root !root_factor_theorem => /dvdp_trans->. +have{irr_q} [Lz [inLz [z qz0]]]: {Lz : fieldExtType F & + {inLz : 'AHom(L, Lz) & {z : Lz | root (map_poly inLz q) z}}}. +- have [Lz0 _ [z qz0 defLz]] := irredp_FAdjoin irr_q. + pose Lz := baseField_extFieldType Lz0. + pose inLz : {rmorphism L -> Lz} := [rmorphism of in_alg Lz0]. + have inLzL_linear: linear (locked inLz). + move=> a u v; rewrite -(@mulr_algl F Lz) baseField_scaleE. + by rewrite -{1}mulr_algl rmorphD rmorphM -lock. + have ihLzZ: ahom_in {:L} (linfun (Linear inLzL_linear)). + by apply/ahom_inP; split=> [u v|]; rewrite !lfunE (rmorphM, rmorph1). + exists Lz, (AHom ihLzZ), z; congr (root _ z): qz0. + by apply: eq_map_poly => y; rewrite lfunE /= -lock. +pose imL := [aspace of limg inLz]; pose pz := map_poly inLz p. +have in_imL u: inLz u \in imL by rewrite memv_img ?memvf. +have F0pz: pz \is a polyOver 1%VS. + apply/polyOverP=> i; rewrite -(aimg1 inLz) coef_map /= memv_img //. + exact: (polyOverP F0p). +have{splitLp} splitLpz: splittingFieldFor 1 pz imL. + have [r def_p defL] := splitLp; exists (map inLz r) => [|{def_p}]. + move: def_p; rewrite -(eqp_map [rmorphism of inLz]) rmorph_prod. + rewrite big_map; congr (_ %= _); apply: eq_big => // y _. + by rewrite rmorphB /= map_polyX map_polyC. + apply/eqP; rewrite eqEsubv /= -{2}defL {defL}; apply/andP; split. + by apply/Fadjoin_seqP; rewrite sub1v; split=> // _ /mapP[y r_y ->]. + elim/last_ind: r => [|r y IHr] /=; first by rewrite !Fadjoin_nil aimg1. + rewrite map_rcons !adjoin_rcons /=. + apply/subvP=> _ /memv_imgP[_ /Fadjoin_polyP[p1 r_p1 ->] ->]. + rewrite -horner_map /= mempx_Fadjoin //=; apply/polyOverP=> i. + by rewrite coef_map (subvP IHr) //= memv_img ?(polyOverP r_p1). +have [f homLf fxz]: exists2 f : 'End(Lz), kHom 1 imL f & f (inLz x) = z. + pose q1z := minPoly 1 (inLz x). + have Dq1z: map_poly inLz q1 %| q1z. + have F0q1z i: exists a, q1z`_i = a%:A by apply/vlineP/polyOverP/minPolyOver. + have [q2 Dq2]: exists q2, q1z = map_poly inLz q2. + exists (\poly_(i < size q1z) (sval (sig_eqW (F0q1z i)))%:A). + rewrite -{1}[q1z]coefK; apply/polyP=> i; rewrite coef_map !{1}coef_poly. + by case: sig_eqW => a; case: ifP; rewrite /= ?rmorph0 ?linearZ ?rmorph1. + rewrite Dq2 dvdp_map minPoly_dvdp //. + apply/polyOverP=> i; have[a] := F0q1z i. + rewrite -(rmorph1 [rmorphism of inLz]) -linearZ. + by rewrite Dq2 coef_map => /fmorph_inj->; rewrite rpredZ ?mem1v. + by rewrite -(fmorph_root [rmorphism of inLz]) -Dq2 root_minPoly. + have q1z_z: root q1z z. + rewrite !root_factor_theorem in qz0 *. + by apply: dvdp_trans qz0 (dvdp_trans _ Dq1z); rewrite dvdp_map. + have map1q1z_z: root (map_poly \1%VF q1z) z. + by rewrite map_poly_id => // ? _; rewrite lfunE. + pose f0 := kHomExtend 1 \1 (inLz x) z. + have{map1q1z_z} hom_f0 : kHom 1 <<1; inLz x>> f0. + by apply: kHomExtendP map1q1z_z => //; apply: kHom1. + have{splitLpz} splitLpz: splittingFieldFor <<1; inLz x>> pz imL. + have [r def_pz defLz] := splitLpz; exists r => //. + apply/eqP; rewrite eqEsubv -{2}defLz adjoin_seqSl ?sub1v // andbT. + apply/Fadjoin_seqP; split; last first. + by rewrite /= -[limg _]defLz; apply: seqv_sub_adjoin. + by apply/FadjoinP/andP; rewrite sub1v memv_img ?memvf. + have [f homLzf Df] := kHom_extends (sub1v _) hom_f0 F0pz splitLpz. + have [-> | x'z] := eqVneq (inLz x) z. + by exists \1%VF; rewrite ?lfunE ?kHom1. + exists f => //; rewrite -Df ?memv_adjoin ?(kHomExtend_val (kHom1 1 1)) //. + by rewrite lfun1_poly. +pose f1 := (inLz^-1 \o f \o inLz)%VF; have /kHomP[fM fFid] := homLf. +have Df1 u: inLz (f1 u) = f (inLz u). + rewrite !comp_lfunE limg_lfunVK //= -[limg _]/(asval imL). + have [r def_pz defLz] := splitLpz. + have []: all (mem r) r /\ inLz u \in imL by split; first apply/allP. + rewrite -{1}defLz; elim/last_ind: {-1}r {u}(inLz u) => [|r1 y IHr1] u. + by rewrite Fadjoin_nil => _ Fu; rewrite fFid // (subvP (sub1v _)). + rewrite all_rcons adjoin_rcons => /andP[rr1 ry] /Fadjoin_polyP[pu r1pu ->]. + rewrite (kHom_horner homLf) -defLz; last exact: seqv_sub_adjoin; last first. + by apply: polyOverS r1pu; apply/subvP/adjoin_seqSr/allP. + apply: rpred_horner. + by apply/polyOverP=> i; rewrite coef_map /= defLz IHr1 ?(polyOverP r1pu). + rewrite seqv_sub_adjoin // -root_prod_XsubC -(eqp_root def_pz). + rewrite (kHom_root_id _ homLf) ?sub1v //. + by rewrite -defLz seqv_sub_adjoin. + by rewrite (eqp_root def_pz) root_prod_XsubC. +suffices f1_is_ahom : ahom_in {:L} f1. + apply/hasP; exists (AHom f1_is_ahom); first exact: DautL. + by rewrite /fx_root -(fmorph_root [rmorphism of inLz]) /= Df1 fxz. +apply/ahom_inP; split=> [a b _ _|]; apply: (fmorph_inj [rmorphism of inLz]). + by rewrite rmorphM /= !Df1 rmorphM fM ?in_imL. +by rewrite /= Df1 /= fFid ?rmorph1 ?mem1v. +Qed. + +Lemma kHom_to_AEnd K E f : kHom K E f -> {g : 'AEnd(L) | {in E, f =1 val g}}. +Proof. +move=> homKf; have{homKf} [homFf sFE] := (kHomSl (sub1v K) homKf, sub1v E). +have [p Fp /(splittingFieldForS sFE (subvf E))splitLp] := splittingPoly. +have [g0 homLg0 eq_fg] := kHom_extends sFE homFf Fp splitLp. +by apply: exist (Sub g0 _) _ => //; apply/ahomP/kHom_lrmorphism. +Qed. + +End SplittingFieldTheory. + +(* Hide the finGroup structure on 'AEnd(L) in a module so that we can control *) +(* when it is exported. Most people will want to use the finGroup structure *) +(* on 'Gal(E / K) and will not need this module. *) +Module Import AEnd_FinGroup. +Section AEnd_FinGroup. + +Variables (F : fieldType) (L : splittingFieldType F). +Implicit Types (U V W : {vspace L}) (K M E : {subfield L}). + +Definition inAEnd f := SeqSub (svalP (enum_AEnd L) f). +Fact inAEndK : cancel inAEnd val. Proof. by []. Qed. + +Definition AEnd_countMixin := Eval hnf in CanCountMixin inAEndK. +Canonical AEnd_countType := Eval hnf in CountType 'AEnd(L) AEnd_countMixin. +Canonical AEnd_subCountType := Eval hnf in [subCountType of 'AEnd(L)]. +Definition AEnd_finMixin := Eval hnf in CanFinMixin inAEndK. +Canonical AEnd_finType := Eval hnf in FinType 'AEnd(L) AEnd_finMixin. +Canonical AEnd_subFinType := Eval hnf in [subFinType of 'AEnd(L)]. + +(* the group operation is the categorical composition operation *) +Definition comp_AEnd (f g : 'AEnd(L)) : 'AEnd(L) := (g \o f)%AF. + +Fact comp_AEndA : associative comp_AEnd. +Proof. by move=> f g h; apply: val_inj; symmetry; apply: comp_lfunA. Qed. + +Fact comp_AEnd1l : left_id \1%AF comp_AEnd. +Proof. by move=> f; apply/val_inj/comp_lfun1r. Qed. + +Fact comp_AEndK : left_inverse \1%AF (@inv_ahom _ L) comp_AEnd. +Proof. by move=> f; apply/val_inj; rewrite /= lker0_compfV ?AEnd_lker0. Qed. + +Definition AEnd_baseFinGroupMixin := + FinGroup.Mixin comp_AEndA comp_AEnd1l comp_AEndK. +Canonical AEnd_baseFinGroupType := + BaseFinGroupType 'AEnd(L) AEnd_baseFinGroupMixin. +Canonical AEnd_finGroupType := FinGroupType comp_AEndK. + +Definition kAEnd U V := [set f : 'AEnd(L) | kAut U V f]. +Definition kAEndf U := kAEnd U {:L}. + +Lemma kAEnd_group_set K E : group_set (kAEnd K E). +Proof. +apply/group_setP; split=> [|f g]; first by rewrite inE /kAut kHom1 lim1g eqxx. +rewrite !inE !kAutE => /andP[homKf EfE] /andP[/(kHomSr EfE)homKg EgE]. +by rewrite (comp_kHom_img homKg homKf) limg_comp (subv_trans _ EgE) ?limgS. +Qed. +Canonical kAEnd_group K E := group (kAEnd_group_set K E). +Canonical kAEndf_group K := [group of kAEndf K]. + +Lemma kAEnd_norm K E : kAEnd K E \subset 'N(kAEndf E)%g. +Proof. +apply/subsetP=> x; rewrite -groupV 2!in_set => /andP[_ /eqP ExE]. +apply/subsetP=> _ /imsetP[y homEy ->]; rewrite !in_set !kAutfE in homEy *. +apply/kAHomP=> u Eu; have idEy := kAHomP homEy; rewrite -ExE in idEy. +by rewrite !lfunE /= lfunE /= idEy ?memv_img // lker0_lfunVK ?AEnd_lker0. +Qed. + +Lemma mem_kAut_coset K E (g : 'AEnd(L)) : + kAut K E g -> g \in coset (kAEndf E) g. +Proof. +move=> autEg; rewrite val_coset ?rcoset_refl //. +by rewrite (subsetP (kAEnd_norm K E)) // inE. +Qed. + +Lemma aut_mem_eqP E (x y : coset_of (kAEndf E)) f g : + f \in x -> g \in y -> reflect {in E, f =1 g} (x == y). +Proof. +move=> x_f y_g; rewrite -(coset_mem x_f) -(coset_mem y_g). +have [Nf Ng] := (subsetP (coset_norm x) f x_f, subsetP (coset_norm y) g y_g). +rewrite (sameP eqP (rcoset_kercosetP Nf Ng)) mem_rcoset inE kAutfE. +apply: (iffP kAHomP) => idEfg u Eu. + by rewrite -(mulgKV g f) lfunE /= idEfg. +by rewrite lfunE /= idEfg // lker0_lfunK ?AEnd_lker0. +Qed. + +End AEnd_FinGroup. +End AEnd_FinGroup. + +Section GaloisTheory. + +Variables (F : fieldType) (L : splittingFieldType F). + +Implicit Types (U V W : {vspace L}). +Implicit Types (K M E : {subfield L}). + +(* We take Galois automorphisms for a subfield E to be automorphisms of the *) +(* full field {:L} that operate in E taken modulo those that fix E pointwise. *) +(* The type of Galois automorphisms of E is then the subtype of elements of *) +(* the quotient kAEnd 1 E / kAEndf E, which we encapsulate in a specific *) +(* wrapper to ensure stability of the gal_repr coercion insertion. *) +Section gal_of_Definition. + +Variable V : {vspace L}. + +(* The <<_>>, which becomes redundant when V is a {subfield L}, ensures that *) +(* the argument of [subg _] is syntactically a group. *) +Inductive gal_of := Gal of [subg kAEnd_group 1 <> / kAEndf (agenv V)]. +Definition gal (f : 'AEnd(L)) := Gal (subg _ (coset _ f)). +Definition gal_sgval x := let: Gal u := x in u. + +Fact gal_sgvalK : cancel gal_sgval Gal. Proof. by case. Qed. +Let gal_sgval_inj := can_inj gal_sgvalK. + +Definition gal_eqMixin := CanEqMixin gal_sgvalK. +Canonical gal_eqType := Eval hnf in EqType gal_of gal_eqMixin. +Definition gal_choiceMixin := CanChoiceMixin gal_sgvalK. +Canonical gal_choiceType := Eval hnf in ChoiceType gal_of gal_choiceMixin. +Definition gal_countMixin := CanCountMixin gal_sgvalK. +Canonical gal_countType := Eval hnf in CountType gal_of gal_countMixin. +Definition gal_finMixin := CanFinMixin gal_sgvalK. +Canonical gal_finType := Eval hnf in FinType gal_of gal_finMixin. + +Definition gal_one := Gal 1%g. +Definition gal_inv x := Gal (gal_sgval x)^-1. +Definition gal_mul x y := Gal (gal_sgval x * gal_sgval y). +Fact gal_oneP : left_id gal_one gal_mul. +Proof. by move=> x; apply/gal_sgval_inj/mul1g. Qed. +Fact gal_invP : left_inverse gal_one gal_inv gal_mul. +Proof. by move=> x; apply/gal_sgval_inj/mulVg. Qed. +Fact gal_mulP : associative gal_mul. +Proof. by move=> x y z; apply/gal_sgval_inj/mulgA. Qed. + +Definition gal_finGroupMixin := + FinGroup.Mixin gal_mulP gal_oneP gal_invP. +Canonical gal_finBaseGroupType := + Eval hnf in BaseFinGroupType gal_of gal_finGroupMixin. +Canonical gal_finGroupType := Eval hnf in FinGroupType gal_invP. + +Coercion gal_repr u : 'AEnd(L) := repr (sgval (gal_sgval u)). + +Fact gal_is_morphism : {in kAEnd 1 (agenv V) &, {morph gal : x y / x * y}%g}. +Proof. +move=> f g /= autEa autEb; congr (Gal _). +by rewrite !morphM ?mem_morphim // (subsetP (kAEnd_norm 1 _)). +Qed. +Canonical gal_morphism := Morphism gal_is_morphism. + +Lemma gal_reprK : cancel gal_repr gal. +Proof. by case=> x; rewrite /gal coset_reprK sgvalK. Qed. + +Lemma gal_repr_inj : injective gal_repr. +Proof. exact: can_inj gal_reprK. Qed. + +Lemma gal_AEnd x : gal_repr x \in kAEnd 1 (agenv V). +Proof. +rewrite /gal_repr; case/gal_sgval: x => _ /=/morphimP[g Ng autEg ->]. +rewrite val_coset //=; case: repr_rcosetP => f; rewrite groupMr // !inE kAut1E. +by rewrite kAutE -andbA => /and3P[_ /fixedSpace_limg-> _]. +Qed. + +End gal_of_Definition. + +Prenex Implicits gal_repr. + +Lemma gal_eqP E {x y : gal_of E} : reflect {in E, x =1 y} (x == y). +Proof. +by rewrite -{1}(subfield_closed E); apply: aut_mem_eqP; apply: mem_repr_coset. +Qed. + +Lemma galK E (f : 'AEnd(L)) : (f @: E <= E)%VS -> {in E, gal E f =1 f}. +Proof. +rewrite -kAut1E -{1 2}(subfield_closed E) => autEf. +apply: (aut_mem_eqP (mem_repr_coset _) _ (eqxx _)). +by rewrite subgK /= ?(mem_kAut_coset autEf) // ?mem_quotient ?inE. +Qed. + +Lemma eq_galP E (f g : 'AEnd(L)) : + (f @: E <= E)%VS -> (g @: E <= E)%VS -> + reflect {in E, f =1 g} (gal E f == gal E g). +Proof. +move=> EfE EgE. +by apply: (iffP gal_eqP) => Dfg a Ea; have:= Dfg a Ea; rewrite !{1}galK. +Qed. + +Lemma limg_gal E (x : gal_of E) : (x @: E)%VS = E. +Proof. by have:= gal_AEnd x; rewrite inE subfield_closed => /andP[_ /eqP]. Qed. + +Lemma memv_gal E (x : gal_of E) a : a \in E -> x a \in E. +Proof. by move/(memv_img x); rewrite limg_gal. Qed. + +Lemma gal_id E a : (1 : gal_of E)%g a = a. +Proof. by rewrite /gal_repr repr_coset1 id_lfunE. Qed. + +Lemma galM E (x y : gal_of E) a : a \in E -> (x * y)%g a = y (x a). +Proof. +rewrite /= -comp_lfunE; apply/eq_galP; rewrite ?limg_comp ?limg_gal //. +by rewrite morphM /= ?gal_reprK ?gal_AEnd. +Qed. + +Lemma galV E (x : gal_of E) : {in E, (x^-1)%g =1 x^-1%VF}. +Proof. +move=> a Ea; apply: canRL (lker0_lfunK (AEnd_lker0 _)) _. +by rewrite -galM // mulVg gal_id. +Qed. + +(* Standard mathematical notation for 'Gal(E / K) puts the larger field first.*) +Definition galoisG V U := gal V @* <>. +Local Notation "''Gal' ( V / U )" := (galoisG V U) : group_scope. +Canonical galoisG_group E U := Eval hnf in [group of (galoisG E U)]. +Local Notation "''Gal' ( V / U )" := (galoisG_group V U) : Group_scope. + +Section Automorphism. + +Lemma gal_cap U V : 'Gal(V / U) = 'Gal(V / U :&: V). +Proof. by rewrite /galoisG -capvA capvv. Qed. + +Lemma gal_kAut K E x : (K <= E)%VS -> (x \in 'Gal(E / K)) = kAut K E x. +Proof. +move=> sKE; apply/morphimP/idP=> /= [[g EgE KautEg ->{x}] | KautEx]. + rewrite genGid !inE kAut1E /= subfield_closed (capv_idPl sKE) in KautEg EgE. + by apply: etrans KautEg; apply/(kAut_eq sKE); apply: galK. +exists (x : 'AEnd(L)); rewrite ?gal_reprK ?gal_AEnd //. +by rewrite (capv_idPl sKE) mem_gen ?inE. +Qed. + +Lemma gal_kHom K E x : (K <= E)%VS -> (x \in 'Gal(E / K)) = kHom K E x. +Proof. by move/gal_kAut->; rewrite /kAut limg_gal eqxx andbT. Qed. + +Lemma kAut_to_gal K E f : + kAut K E f -> {x : gal_of E | x \in 'Gal(E / K) & {in E, f =1 x}}. +Proof. +case/andP=> homKf EfE; have [g Df] := kHom_to_AEnd homKf. +have{homKf EfE} autEg: kAut (K :&: E) E g. + rewrite /kAut -(kHom_eq (capvSr _ _) Df) (kHomSl (capvSl _ _) homKf) /=. + by rewrite -(eq_in_limg Df). +have FautEg := kAutS (sub1v _) autEg. +exists (gal E g) => [|a Ea]; last by rewrite {f}Df // galK // -kAut1E. +by rewrite mem_morphim /= ?subfield_closed ?genGid ?inE. +Qed. + +Lemma fixed_gal K E x a : + (K <= E)%VS -> x \in 'Gal(E / K) -> a \in K -> x a = a. +Proof. by move/gal_kHom=> -> /kAHomP idKx /idKx. Qed. + +Lemma fixedPoly_gal K E x p : + (K <= E)%VS -> x \in 'Gal(E / K) -> p \is a polyOver K -> map_poly x p = p. +Proof. +move=> sKE galEKx /polyOverP Kp; apply/polyP => i. +by rewrite coef_map /= (fixed_gal sKE). +Qed. + +Lemma root_minPoly_gal K E x a : + (K <= E)%VS -> x \in 'Gal(E / K) -> a \in E -> root (minPoly K a) (x a). +Proof. +move=> sKE galEKx Ea; have homKx: kHom K E x by rewrite -gal_kHom. +have K_Pa := minPolyOver K a; rewrite -[minPoly K a](fixedPoly_gal _ galEKx) //. +by rewrite (kHom_root homKx) ?root_minPoly // (polyOverS (subvP sKE)). +Qed. + +End Automorphism. + +Lemma gal_adjoin_eq K a x y : + x \in 'Gal(<> / K) -> y \in 'Gal(<> / K) -> + (x == y) = (x a == y a). +Proof. +move=> galKa_x galKa_y; apply/idP/eqP=> [/eqP-> // | eq_xy_a]. +apply/gal_eqP => _ /Fadjoin_polyP[p Kp ->]. +by rewrite -!horner_map !(fixedPoly_gal (subv_adjoin K a)) //= eq_xy_a. +Qed. + +Lemma galS K M E : (K <= M)%VS -> 'Gal(E / M) \subset 'Gal(E / K). +Proof. +rewrite gal_cap (gal_cap K E) => sKM; apply/subsetP=> x. +by rewrite !gal_kAut ?capvSr //; apply: kAutS; apply: capvS. +Qed. + +Lemma gal_conjg K E x : 'Gal(E / K) :^ x = 'Gal(E / x @: K). +Proof. +without loss sKE: K / (K <= E)%VS. + move=> IH_K; rewrite gal_cap {}IH_K ?capvSr //. + transitivity 'Gal(E / x @: K :&: x @: E); last by rewrite limg_gal -gal_cap. + congr 'Gal(E / _); apply/eqP; rewrite eqEsubv limg_cap; apply/subvP=> a. + rewrite memv_cap => /andP[/memv_imgP[b Kb ->] /memv_imgP[c Ec] eq_bc]. + by rewrite memv_img // memv_cap Kb (lker0P (AEnd_lker0 _) _ _ eq_bc). +wlog suffices IHx: x K sKE / 'Gal(E / K) :^ x \subset 'Gal(E / x @: K). + apply/eqP; rewrite eqEsubset IHx // -sub_conjgV (subset_trans (IHx _ _ _)) //. + by apply/subvP=> _ /memv_imgP[a Ka ->]; rewrite memv_gal ?(subvP sKE). + rewrite -limg_comp (etrans (eq_in_limg _) (lim1g _)) // => a /(subvP sKE)Ka. + by rewrite !lfunE /= -galM // mulgV gal_id. +apply/subsetP=> _ /imsetP[y galEy ->]; rewrite gal_cap gal_kHom ?capvSr //=. +apply/kAHomP=> _ /memv_capP[/memv_imgP[a Ka ->] _]; have Ea := subvP sKE a Ka. +by rewrite -galM // -conjgC galM // (fixed_gal sKE galEy). +Qed. + +Definition fixedField V (A : {set gal_of V}) := + (V :&: \bigcap_(x in A) fixedSpace x)%VS. + +Lemma fixedFieldP E {A : {set gal_of E}} a : + a \in E -> reflect (forall x, x \in A -> x a = a) (a \in fixedField A). +Proof. +by rewrite memv_cap => ->; apply: (iffP subv_bigcapP) => cAa x /cAa/fixedSpaceP. +Qed. + +Lemma mem_fixedFieldP E (A : {set gal_of E}) a : + a \in fixedField A -> a \in E /\ (forall x, x \in A -> x a = a). +Proof. +by move=> fixAa; have [Ea _] := memv_capP fixAa; have:= fixedFieldP Ea fixAa. +Qed. + +Fact fixedField_is_aspace E (A : {set gal_of E}) : is_aspace (fixedField A). +Proof. +rewrite /fixedField; elim/big_rec: _ {1}E => [|x K _ IH_K] M. + exact: (valP (M :&: _)%AS). +by rewrite capvA IH_K. +Qed. +Canonical fixedField_aspace E A : {subfield L} := + ASpace (@fixedField_is_aspace E A). + +Lemma fixedField_bound E (A : {set gal_of E}) : (fixedField A <= E)%VS. +Proof. exact: capvSl. Qed. + +Lemma fixedFieldS E (A B : {set gal_of E}) : + A \subset B -> (fixedField B <= fixedField A)%VS. +Proof. +move/subsetP=> sAB; apply/subvP => a /mem_fixedFieldP[Ea cBa]. +by apply/fixedFieldP; last apply: sub_in1 cBa. +Qed. + +Lemma galois_connection_subv K E : + (K <= E)%VS -> (K <= fixedField ('Gal(E / K)))%VS. +Proof. +move=> sKE; apply/subvP => a Ka; have Ea := subvP sKE a Ka. +by apply/fixedFieldP=> // x galEx; apply: (fixed_gal sKE). +Qed. + +Lemma galois_connection_subset E (A : {set gal_of E}): + A \subset 'Gal(E / fixedField A). +Proof. +apply/subsetP => x Ax; rewrite gal_kAut ?capvSl // kAutE limg_gal subvv andbT. +by apply/kAHomP=> a /mem_fixedFieldP[_ ->]. +Qed. + +Lemma galois_connection K E (A : {set gal_of E}): + (K <= E)%VS -> (A \subset 'Gal(E / K)) = (K <= fixedField A)%VS. +Proof. +move=> sKE; apply/idP/idP => [/fixedFieldS | /(galS E)]. + by apply: subv_trans; apply galois_connection_subv. +by apply: subset_trans; apply: galois_connection_subset. +Qed. + +Definition galTrace U V a := \sum_(x in 'Gal(V / U)) (x a). + +Definition galNorm U V a := \prod_(x in 'Gal(V / U)) (x a). + +Section TraceAndNormMorphism. + +Variables U V : {vspace L}. + +Fact galTrace_is_additive : additive (galTrace U V). +Proof. +by move=> a b /=; rewrite -sumrB; apply: eq_bigr => x _; rewrite rmorphB. +Qed. +Canonical galTrace_additive := Additive galTrace_is_additive. + +Lemma galNorm1 : galNorm U V 1 = 1. +Proof. by apply: big1 => x _; rewrite rmorph1. Qed. + +Lemma galNormM : {morph galNorm U V : a b / a * b}. +Proof. +by move=> a b /=; rewrite -big_split; apply: eq_bigr => x _; rewrite rmorphM. +Qed. + +Lemma galNormV : {morph galNorm U V : a / a^-1}. +Proof. +by move=> a /=; rewrite -prodfV; apply: eq_bigr => x _; rewrite fmorphV. +Qed. + +Lemma galNormX n : {morph galNorm U V : a / a ^+ n}. +Proof. +move=> a; elim: n => [|n IHn]; first by apply: galNorm1. +by rewrite !exprS galNormM IHn. +Qed. + +Lemma galNorm_prod (I : Type) (r : seq I) (P : pred I) (B : I -> L) : + galNorm U V (\prod_(i <- r | P i) B i) + = \prod_(i <- r | P i) galNorm U V (B i). +Proof. exact: (big_morph _ galNormM galNorm1). Qed. + +Lemma galNorm0 : galNorm U V 0 = 0. +Proof. by rewrite /galNorm (bigD1 1%g) ?group1 // rmorph0 /= mul0r. Qed. + +Lemma galNorm_eq0 a : (galNorm U V a == 0) = (a == 0). +Proof. +apply/idP/eqP=> [/prodf_eq0[x _] | ->]; last by rewrite galNorm0. +by rewrite fmorph_eq0 => /eqP. +Qed. + +End TraceAndNormMorphism. + +Section TraceAndNormField. + +Variables K E : {subfield L}. + +Lemma galTrace_fixedField a : + a \in E -> galTrace K E a \in fixedField 'Gal(E / K). +Proof. +move=> Ea; apply/fixedFieldP=> [|x galEx]. + by apply: rpred_sum => x _; apply: memv_gal. +rewrite {2}/galTrace (reindex_acts 'R _ galEx) ?astabsR //=. +by rewrite rmorph_sum; apply: eq_bigr => y _; rewrite galM ?lfunE. +Qed. + +Lemma galTrace_gal a x : + a \in E -> x \in 'Gal(E / K) -> galTrace K E (x a) = galTrace K E a. +Proof. +move=> Ea galEx; rewrite {2}/galTrace (reindex_inj (mulgI x)). +by apply: eq_big => [b | b _]; rewrite ?groupMl // galM ?lfunE. +Qed. + +Lemma galNorm_fixedField a : + a \in E -> galNorm K E a \in fixedField 'Gal(E / K). +Proof. +move=> Ea; apply/fixedFieldP=> [|x galEx]. + by apply: rpred_prod => x _; apply: memv_gal. +rewrite {2}/galNorm (reindex_acts 'R _ galEx) ?astabsR //=. +by rewrite rmorph_prod; apply: eq_bigr => y _; rewrite galM ?lfunE. +Qed. + +Lemma galNorm_gal a x : + a \in E -> x \in 'Gal(E / K) -> galNorm K E (x a) = galNorm K E a. +Proof. +move=> Ea galEx; rewrite {2}/galNorm (reindex_inj (mulgI x)). +by apply: eq_big => [b | b _]; rewrite ?groupMl // galM ?lfunE. +Qed. + +End TraceAndNormField. + +Definition normalField U V := [forall x in kAEndf U, x @: V == V]%VS. + +Lemma normalField_kAut K M E f : + (K <= M <= E)%VS -> normalField K M -> kAut K E f -> kAut K M f. +Proof. +case/andP=> sKM sME nKM /kAut_to_gal[x galEx /(sub_in1 (subvP sME))Df]. +have sKE := subv_trans sKM sME; rewrite gal_kHom // in galEx. +rewrite (kAut_eq sKM Df) /kAut (kHomSr sME) //= (forall_inP nKM) // inE. +by rewrite kAutfE; apply/kAHomP; apply: (kAHomP galEx). +Qed. + +Lemma normalFieldP K E : + reflect {in E, forall a, exists2 r, + all (mem E) r & minPoly K a = \prod_(b <- r) ('X - b%:P)} + (normalField K E). +Proof. +apply: (iffP eqfun_inP) => [nKE a Ea | nKE x]; last first. + rewrite inE kAutfE => homKx; suffices: kAut K E x by case/andP=> _ /eqP. + rewrite kAutE (kHomSr (subvf E)) //=; apply/subvP=> _ /memv_imgP[a Ea ->]. + have [r /allP/=srE splitEa] := nKE a Ea. + rewrite srE // -root_prod_XsubC -splitEa. + by rewrite -(kHom_poly_id homKx (minPolyOver K a)) fmorph_root root_minPoly. +have [r /eqP splitKa] := splitting_field_normal K a. +exists r => //; apply/allP => b; rewrite -root_prod_XsubC -splitKa => pKa_b_0. +pose y := kHomExtend K \1 a b; have [hom1K lf1p] := (kHom1 K K, lfun1_poly). +have homKy: kHom K <> y by apply/kHomExtendP; rewrite ?lf1p. +have [[g Dy] [_ idKy]] := (kHom_to_AEnd homKy, kHomP homKy). +have <-: g a = b by rewrite -Dy ?memv_adjoin // (kHomExtend_val hom1K) ?lf1p. +suffices /nKE <-: g \in kAEndf K by apply: memv_img. +by rewrite inE kAutfE; apply/kAHomP=> c Kc; rewrite -Dy ?subvP_adjoin ?idKy. +Qed. + +Lemma normalFieldf K : normalField K {:L}. +Proof. +apply/normalFieldP=> a _; have [r /eqP->] := splitting_field_normal K a. +by exists r => //; apply/allP=> b; rewrite /= memvf. +Qed. + +Lemma normalFieldS K M E : (K <= M)%VS -> normalField K E -> normalField M E. +Proof. +move=> sKM /normalFieldP nKE; apply/normalFieldP=> a Ea. +have [r /allP Er splitKa] := nKE a Ea. +have /dvdp_prod_XsubC[m splitMa]: minPoly M a %| \prod_(b <- r) ('X - b%:P). + by rewrite -splitKa minPolyS. +exists (mask m r); first by apply/allP=> b /mem_mask/Er. +by apply/eqP; rewrite -eqp_monic ?monic_prod_XsubC ?monic_minPoly. +Qed. + +Lemma splitting_normalField E K : + (K <= E)%VS -> + reflect (exists2 p, p \is a polyOver K & splittingFieldFor K p E) + (normalField K E). +Proof. +move=> sKE; apply: (iffP idP) => [nKE| [p Kp [rs Dp defE]]]; last first. + apply/forall_inP=> g; rewrite inE kAutE => /andP[homKg _]. + rewrite -dimv_leqif_eq ?limg_dim_eq ?(eqP (AEnd_lker0 g)) ?capv0 //. + rewrite -defE aimg_adjoin_seq; have [_ /fixedSpace_limg->] := andP homKg. + apply/adjoin_seqSr=> _ /mapP[a rs_a ->]. + rewrite -!root_prod_XsubC -!(eqp_root Dp) in rs_a *. + by apply: kHom_root_id homKg Kp _ rs_a; rewrite ?subvf ?memvf. +pose splitK a r := minPoly K a = \prod_(b <- r) ('X - b%:P). +have{nKE} rK_ a: {r | a \in E -> all (mem E) r /\ splitK a r}. + case Ea: (a \in E); last by exists [::]. + by have /sig2_eqW[r] := normalFieldP _ _ nKE a Ea; exists r. +have sXE := basis_mem (vbasisP E); set X : seq L := vbasis E in sXE. +exists (\prod_(a <- X) minPoly K a). + by apply: rpred_prod => a _; apply: minPolyOver. +exists (flatten [seq (sval (rK_ a)) | a <- X]). + move/allP: sXE; elim: X => [|a X IHX] ; first by rewrite !big_nil eqpxx. + rewrite big_cons /= big_cat /= => /andP[Ea sXE]. + by case: (rK_ a) => /= r [] // _ <-; apply/eqp_mull/IHX. +apply/eqP; rewrite eqEsubv; apply/andP; split. + apply/Fadjoin_seqP; split=> // b /flatten_mapP[a /sXE Ea]. + by apply/allP; case: rK_ => r /= []. +rewrite -{1}(span_basis (vbasisP E)); apply/span_subvP=> a Xa. +apply/seqv_sub_adjoin/flatten_mapP; exists a => //; rewrite -root_prod_XsubC. +by case: rK_ => /= r [| _ <-]; rewrite ?sXE ?root_minPoly. +Qed. + +Lemma kHom_to_gal K M E f : + (K <= M <= E)%VS -> normalField K E -> kHom K M f -> + {x | x \in 'Gal(E / K) & {in M, f =1 x}}. +Proof. +case/andP=> /subvP sKM /subvP sME nKE KhomMf. +have [[g Df] [_ idKf]] := (kHom_to_AEnd KhomMf, kHomP KhomMf). +suffices /kAut_to_gal[x galEx Dg]: kAut K E g. + by exists x => //= a Ma; rewrite Df // Dg ?sME. +have homKg: kHom K {:L} g by apply/kAHomP=> a Ka; rewrite -Df ?sKM ?idKf. +by rewrite /kAut (kHomSr (subvf _)) // (forall_inP nKE) // inE kAutfE. +Qed. + +Lemma normalField_root_minPoly K E a b : + (K <= E)%VS -> normalField K E -> a \in E -> root (minPoly K a) b -> + exists2 x, x \in 'Gal(E / K) & x a = b. +Proof. +move=> sKE nKE Ea pKa_b_0; pose f := kHomExtend K \1 a b. +have homKa_f: kHom K <> f. + by apply: kHomExtendP; rewrite ?kHom1 ?lfun1_poly. +have sK_Ka_E: (K <= <> <= E)%VS. + by rewrite subv_adjoin; apply/FadjoinP; rewrite sKE Ea. +have [x galEx Df] := kHom_to_gal sK_Ka_E nKE homKa_f; exists x => //. +by rewrite -Df ?memv_adjoin // (kHomExtend_val (kHom1 K K)) ?lfun1_poly. +Qed. + +Implicit Arguments normalFieldP [K E]. + +Lemma normalField_factors K E : + (K <= E)%VS -> + reflect {in E, forall a, exists2 r : seq (gal_of E), + r \subset 'Gal(E / K) + & minPoly K a = \prod_(x <- r) ('X - (x a)%:P)} + (normalField K E). +Proof. +move=> sKE; apply: (iffP idP) => [nKE a Ea | nKE]; last first. + apply/normalFieldP=> a Ea; have [r _ ->] := nKE a Ea. + exists [seq x a | x : gal_of E <- r]; last by rewrite big_map. + by rewrite all_map; apply/allP=> b _; apply: memv_gal. +have [r Er splitKa] := normalFieldP nKE a Ea. +pose f b := [pick x in 'Gal(E / K) | x a == b]. +exists (pmap f r). + apply/subsetP=> x; rewrite mem_pmap /f => /mapP[b _]. + by case: (pickP _) => // c /andP[galEc _] [->]. +rewrite splitKa; have{splitKa}: all (root (minPoly K a)) r. + by apply/allP => b; rewrite splitKa root_prod_XsubC. +elim: r Er => /= [|b r IHr]; first by rewrite !big_nil. +case/andP=> Eb Er /andP[pKa_b_0 /(IHr Er){IHr Er}IHr]. +have [x galE /eqP xa_b] := normalField_root_minPoly sKE nKE Ea pKa_b_0. +rewrite /(f b); case: (pickP _) => [y /andP[_ /eqP<-]|/(_ x)/andP[]//]. +by rewrite !big_cons IHr. +Qed. + +Definition galois U V := [&& (U <= V)%VS, separable U V & normalField U V]. + +Lemma galoisS K M E : (K <= M <= E)%VS -> galois K E -> galois M E. +Proof. +case/andP=> sKM sME /and3P[_ sepUV nUV]. +by rewrite /galois sME (separableSl sKM) ?(normalFieldS sKM). +Qed. + +Lemma galois_dim K E : galois K E -> \dim_K E = #|'Gal(E / K)|. +Proof. +case/and3P=> sKE /eq_adjoin_separable_generator-> // nKE. +set a := separable_generator K E in nKE *. +have [r /allP/=Er splitKa] := normalFieldP nKE a (memv_adjoin K a). +rewrite (dim_sup_field (subv_adjoin K a)) mulnK ?adim_gt0 //. +apply/eqP; rewrite -eqSS -adjoin_degreeE -size_minPoly splitKa size_prod_XsubC. +set n := size r; rewrite eqSS -[n]card_ord. +have x_ (i : 'I_n): {x | x \in 'Gal(<> / K) & x a = r`_i}. + apply/sig2_eqW/normalField_root_minPoly; rewrite ?subv_adjoin ?memv_adjoin //. + by rewrite splitKa root_prod_XsubC mem_nth. +have /card_image <-: injective (fun i => s2val (x_ i)). + move=> i j /eqP; case: (x_ i) (x_ j) => y /= galEy Dya [z /= galEx Dza]. + rewrite gal_adjoin_eq // Dya Dza nth_uniq // => [/(i =P j)//|]. + by rewrite -separable_prod_XsubC -splitKa; apply: separable_generatorP. +apply/eqP/eq_card=> x; apply/codomP/idP=> [[i ->] | galEx]; first by case: x_. +have /(nthP 0) [i ltin Dxa]: x a \in r. + rewrite -root_prod_XsubC -splitKa. + by rewrite root_minPoly_gal ?memv_adjoin ?subv_adjoin. +exists (Ordinal ltin); apply/esym/eqP. +by case: x_ => y /= galEy /eqP; rewrite Dxa gal_adjoin_eq. +Qed. + +Lemma galois_factors K E : + (K <= E)%VS -> + reflect {in E, forall a, exists r, let r_a := [seq x a | x : gal_of E <- r] in + [/\ r \subset 'Gal(E / K), uniq r_a + & minPoly K a = \prod_(b <- r_a) ('X - b%:P)]} + (galois K E). +Proof. +move=> sKE; apply: (iffP and3P) => [[_ sepKE nKE] a Ea | galKE]. + have [r galEr splitEa] := normalField_factors sKE nKE a Ea. + exists r; rewrite /= -separable_prod_XsubC !big_map -splitEa. + by split=> //; apply: separableP Ea. +split=> //. + apply/separableP => a /galKE[r [_ Ur_a splitKa]]. + by rewrite /separable_element splitKa separable_prod_XsubC. +apply/(normalField_factors sKE)=> a /galKE[r [galEr _ ->]]. +by rewrite big_map; exists r. +Qed. + +Lemma splitting_galoisField K E : + reflect (exists p, [/\ p \is a polyOver K, separable_poly p + & splittingFieldFor K p E]) + (galois K E). +Proof. +apply: (iffP and3P) => [[sKE sepKE nKE]|[p [Kp sep_p [r Dp defE]]]]. + rewrite (eq_adjoin_separable_generator sepKE) // in nKE *. + set a := separable_generator K E in nKE *; exists (minPoly K a). + split; first 1 [exact: minPolyOver | exact/separable_generatorP]. + have [r /= /allP Er splitKa] := normalFieldP nKE a (memv_adjoin _ _). + exists r; first by rewrite splitKa eqpxx. + apply/eqP; rewrite eqEsubv; apply/andP; split. + by apply/Fadjoin_seqP; split => //; apply: subv_adjoin. + apply/FadjoinP; split; first exact: subv_adjoin_seq. + by rewrite seqv_sub_adjoin // -root_prod_XsubC -splitKa root_minPoly. +have sKE: (K <= E)%VS by rewrite -defE subv_adjoin_seq. +split=> //; last by apply/splitting_normalField=> //; exists p; last exists r. +rewrite -defE; apply/separable_Fadjoin_seq/allP=> a r_a. +by apply/separable_elementP; exists p; rewrite (eqp_root Dp) root_prod_XsubC. +Qed. + +Lemma galois_fixedField K E : + reflect (fixedField 'Gal(E / K) = K) (galois K E). +Proof. +apply (iffP idP) => [/and3P[sKE /separableP sepKE nKE] | fixedKE]. + apply/eqP; rewrite eqEsubv galois_connection_subv ?andbT //. + apply/subvP=> a /mem_fixedFieldP[Ea fixEa]; rewrite -adjoin_deg_eq1. + have [r /allP Er splitKa] := normalFieldP nKE a Ea. + rewrite -eqSS -size_minPoly splitKa size_prod_XsubC eqSS -/(size [:: a]). + have Ur: uniq r by rewrite -separable_prod_XsubC -splitKa; apply: sepKE. + rewrite -uniq_size_uniq {Ur}// => b; rewrite inE -root_prod_XsubC -splitKa. + apply/eqP/idP=> [-> | pKa_b_0]; first exact: root_minPoly. + by have [x /fixEa-> ->] := normalField_root_minPoly sKE nKE Ea pKa_b_0. +have sKE: (K <= E)%VS by rewrite -fixedKE capvSl. +apply/galois_factors=> // a Ea. +pose r_pKa := [seq x a | x : gal_of E in 'Gal(E / K)]. +have /fin_all_exists2[x_ galEx_ Dx_a] (b : seq_sub r_pKa) := imageP (valP b). +exists (codom x_); rewrite -map_comp; set r := map _ _. +have r_xa x: x \in 'Gal(E / K) -> x a \in r. + move=> galEx; have r_pKa_xa: x a \in r_pKa by apply/imageP; exists x. + by rewrite [x a](Dx_a (SeqSub r_pKa_xa)); apply: codom_f. +have Ur: uniq r by apply/injectiveP=> b c /=; rewrite -!Dx_a => /val_inj. +split=> //; first by apply/subsetP=> _ /codomP[b ->]. +apply/eqP; rewrite -eqp_monic ?monic_minPoly ?monic_prod_XsubC //. +apply/andP; split; last first. + rewrite uniq_roots_dvdp ?uniq_rootsE // all_map. + by apply/allP=> b _ /=; rewrite root_minPoly_gal. +apply: minPoly_dvdp; last by rewrite root_prod_XsubC -(gal_id E a) r_xa ?group1. +rewrite -fixedKE; apply/polyOverP => i; apply/fixedFieldP=> [|x galEx]. + rewrite (polyOverP _) // big_map rpred_prod // => b _. + by rewrite polyOverXsubC memv_gal. +rewrite -coef_map rmorph_prod; congr (_ : {poly _})`_i. +symmetry; rewrite (eq_big_perm (map x r)) /= ?(big_map x). + by apply: eq_bigr => b _; rewrite rmorphB /= map_polyX map_polyC. +have Uxr: uniq (map x r) by rewrite map_inj_uniq //; apply: fmorph_inj. +have /leq_size_perm: {subset map x r <= r}. + by rewrite -map_comp => _ /codomP[b ->] /=; rewrite -galM // r_xa ?groupM. +by rewrite (size_map x) perm_eq_sym; case=> // /uniq_perm_eq->. +Qed. + +Lemma mem_galTrace K E a : galois K E -> a \in E -> galTrace K E a \in K. +Proof. by move/galois_fixedField => {2}<- /galTrace_fixedField. Qed. + +Lemma mem_galNorm K E a : galois K E -> a \in E -> galNorm K E a \in K. +Proof. by move/galois_fixedField=> {2}<- /galNorm_fixedField. Qed. + +Lemma gal_independent_contra E (P : pred (gal_of E)) (c_ : gal_of E -> L) x : + P x -> c_ x != 0 -> + exists2 a, a \in E & \sum_(y | P y) c_ y * y a != 0. +Proof. +elim: {P}_.+1 c_ x {-2}P (ltnSn #|P|) => // n IHn c_ x P lePn Px nz_cx. +rewrite ltnS (cardD1x Px) in lePn; move/IHn: lePn => {n IHn}/=IH_P. +have [/eqfun_inP c_Px'_0 | ] := boolP [forall (y | P y && (y != x)), c_ y == 0]. + exists 1; rewrite ?mem1v // (bigD1 x Px) /= rmorph1 mulr1. + by rewrite big1 ?addr0 // => y /c_Px'_0->; rewrite mul0r. +rewrite negb_forall_in => /exists_inP[y Px'y nz_cy]. +have [Py /gal_eqP/eqlfun_inP/subvPn[a Ea]] := andP Px'y. +rewrite memv_ker !lfun_simp => nz_yxa; pose d_ y := c_ y * (y a - x a). +have /IH_P[//|b Eb nz_sumb]: d_ y != 0 by rewrite mulf_neq0. +have [sumb_0|] := eqVneq (\sum_(z | P z) c_ z * z b) 0; last by exists b. +exists (a * b); first exact: rpredM. +rewrite -subr_eq0 -[z in _ - z](mulr0 (x a)) -[in z in _ - z]sumb_0. +rewrite mulr_sumr -sumrB (bigD1 x Px) rmorphM /= mulrCA subrr add0r. +congr (_ != 0): nz_sumb; apply: eq_bigr => z _. +by rewrite mulrCA rmorphM -mulrBr -mulrBl mulrA. +Qed. + +Lemma gal_independent E (P : pred (gal_of E)) (c_ : gal_of E -> L) : + (forall a, a \in E -> \sum_(x | P x) c_ x * x a = 0) -> + (forall x, P x -> c_ x = 0). +Proof. +move=> sum_cP_0 x Px; apply/eqP/idPn=> /(gal_independent_contra Px)[a Ea]. +by rewrite sum_cP_0 ?eqxx. +Qed. + +Lemma Hilbert's_theorem_90 K E x a : + generator 'Gal(E / K) x -> a \in E -> + reflect (exists2 b, b \in E /\ b != 0 & a = b / x b) (galNorm K E a == 1). +Proof. +move/(_ =P <[x]>)=> DgalE Ea. +have galEx: x \in 'Gal(E / K) by rewrite DgalE cycle_id. +apply: (iffP eqP) => [normEa1 | [b [Eb nzb] ->]]; last first. + by rewrite galNormM galNormV galNorm_gal // mulfV // galNorm_eq0. +have [x1 | ntx] := eqVneq x 1%g. + exists 1; first by rewrite mem1v oner_neq0. + by rewrite -{1}normEa1 /galNorm DgalE x1 cycle1 big_set1 !gal_id divr1. +pose c_ y := \prod_(i < invm (injm_Zpm x) y) (x ^+ i)%g a. +have nz_c1: c_ 1%g != 0 by rewrite /c_ morph1 big_ord0 oner_neq0. +have [d] := @gal_independent_contra _ (mem 'Gal(E / K)) _ _ (group1 _) nz_c1. +set b := \sum_(y in _) _ => Ed nz_b; exists b. + split=> //; apply: rpred_sum => y galEy. + by apply: rpredM; first apply: rpred_prod => i _; apply: memv_gal. +apply: canRL (mulfK _) _; first by rewrite fmorph_eq0. +rewrite rmorph_sum mulr_sumr [b](reindex_acts 'R _ galEx) ?astabsR //=. +apply: eq_bigr => y galEy; rewrite galM // rmorphM mulrA; congr (_ * _). +have /morphimP[/= i _ _ ->] /=: y \in Zpm @* Zp #[x] by rewrite im_Zpm -DgalE. +have <-: Zpm (i + 1) = (Zpm i * x)%g by rewrite morphM ?mem_Zp ?order_gt1. +rewrite /c_ !invmE ?mem_Zp ?order_gt1 //= addn1; set n := _.+2. +transitivity (\prod_(j < i.+1) (x ^+ j)%g a). + rewrite big_ord_recl gal_id rmorph_prod; congr (_ * _). + by apply: eq_bigr => j _; rewrite expgSr galM ?lfunE. +have [/modn_small->//||->] := ltngtP i.+1 n; first by rewrite ltnNge ltn_ord. +rewrite modnn big_ord0; apply: etrans normEa1; rewrite /galNorm DgalE -im_Zpm. +rewrite morphimEdom big_imset /=; last exact/injmP/injm_Zpm. +by apply: eq_bigl => j /=; rewrite mem_Zp ?order_gt1. +Qed. + +Section Matrix. + +Variable (E : {subfield L}) (A : {set gal_of E}). + +Let K := fixedField A. + +Lemma gal_matrix : + {w : #|A|.-tuple L | {subset w <= E} /\ 0 \notin w & + [/\ \matrix_(i, j < #|A|) enum_val i (tnth w j) \in unitmx, + directv (\sum_i K * <[tnth w i]>) & + group_set A -> (\sum_i K * <[tnth w i]>)%VS = E] }. +Proof. +pose nzE (w : #|A|.-tuple L) := {subset w <= E} /\ 0 \notin w. +pose M w := \matrix_(i, j < #|A|) nth 1%g (enum A) i (tnth w j). +have [w [Ew nzw] uM]: {w : #|A|.-tuple L | nzE w & M w \in unitmx}. + rewrite {}/nzE {}/M cardE; have: uniq (enum A) := enum_uniq _. + elim: (enum A) => [|x s IHs] Uxs. + by exists [tuple]; rewrite // flatmx0 -(flatmx0 1%:M) unitmx1. + have [s'x Us]: x \notin s /\ uniq s by apply/andP. + have{IHs} [w [Ew nzw] uM] := IHs Us; set M := \matrix_(i, j) _ in uM. + pose a := \row_i x (tnth w i) *m invmx M. + pose c_ y := oapp (a 0) (-1) (insub (index y s)). + have cx_n1 : c_ x = -1 by rewrite /c_ insubN ?index_mem. + have nz_cx : c_ x != 0 by rewrite cx_n1 oppr_eq0 oner_neq0. + have Px: [pred y in x :: s] x := mem_head x s. + have{Px nz_cx} /sig2W[w0 Ew0 nzS] := gal_independent_contra Px nz_cx. + exists [tuple of cons w0 w]. + split; first by apply/allP; rewrite /= Ew0; apply/allP. + rewrite inE negb_or (contraNneq _ nzS) // => <-. + by rewrite big1 // => y _; rewrite rmorph0 mulr0. + rewrite unitmxE -[\det _]mul1r; set M1 := \matrix_(i, j < 1 + size s) _. + have <-: \det (block_mx 1 (- a) 0 1%:M) = 1 by rewrite det_ublock !det1 mulr1. + rewrite -det_mulmx -[M1]submxK mulmx_block !mul0mx !mul1mx !add0r !mulNmx. + have ->: drsubmx M1 = M by apply/matrixP => i j; rewrite !mxE !(tnth_nth 0). + have ->: ursubmx M1 - a *m M = 0. + by apply/rowP=> i; rewrite mulmxKV // !mxE !(tnth_nth 0) subrr. + rewrite det_lblock unitrM andbC -unitmxE uM unitfE -oppr_eq0. + congr (_ != 0): nzS; rewrite [_ - _]mx11_scalar det_scalar !mxE opprB /=. + rewrite -big_uniq // big_cons /= cx_n1 mulN1r addrC; congr (_ + _). + rewrite (big_nth 1%g) big_mkord; apply: eq_bigr => j _. + by rewrite /c_ index_uniq // valK; congr (_ * _); rewrite !mxE. +exists w => [//|]; split=> [||gA]. +- by congr (_ \in unitmx): uM; apply/matrixP=> i j; rewrite !mxE -enum_val_nth. +- apply/directv_sum_independent=> kw_ Kw_kw sum_kw_0 j _. + have /fin_all_exists2[k_ Kk_ Dk_] i := memv_cosetP (Kw_kw i isT). + pose kv := \col_i k_ i. + transitivity (kv j 0 * tnth w j); first by rewrite !mxE. + suffices{j}/(canRL (mulKmx uM))->: M w *m kv = 0 by rewrite mulmx0 mxE mul0r. + apply/colP=> i; rewrite !mxE; pose Ai := nth 1%g (enum A) i. + transitivity (Ai (\sum_j kw_ j)); last by rewrite sum_kw_0 rmorph0. + rewrite rmorph_sum; apply: eq_bigr => j _; rewrite !mxE /= -/Ai. + rewrite Dk_ mulrC rmorphM /=; congr (_ * _). + by have /mem_fixedFieldP[_ -> //] := Kk_ j; rewrite -mem_enum mem_nth -?cardE. +pose G := group gA; have G_1 := group1 G; pose iG := enum_rank_in G_1. +apply/eqP; rewrite eqEsubv; apply/andP; split. + apply/subv_sumP=> i _; apply: subv_trans (asubv _). + by rewrite prodvS ?capvSl // -memvE Ew ?mem_tnth. +apply/subvP=> w0 Ew0; apply/memv_sumP. +pose wv := \col_(i < #|A|) enum_val i w0; pose v := invmx (M w) *m wv. +exists (fun i => tnth w i * v i 0) => [i _|]; last first. + transitivity (wv (iG 1%g) 0); first by rewrite mxE enum_rankK_in ?gal_id. + rewrite -[wv](mulKVmx uM) -/v; rewrite mxE; apply: eq_bigr => i _. + by congr (_ * _); rewrite !mxE -enum_val_nth enum_rankK_in ?gal_id. +rewrite mulrC memv_mul ?memv_line //; apply/fixedFieldP=> [|x Gx]. + rewrite mxE rpred_sum // => j _; rewrite !mxE rpredM //; last exact: memv_gal. + have E_M k l: M w k l \in E by rewrite mxE memv_gal // Ew ?mem_tnth. + have Edet n (N : 'M_n) (E_N : forall i j, N i j \in E): \det N \in E. + by apply: rpred_sum => sigma _; rewrite rpredMsign rpred_prod. + rewrite /invmx uM 2!mxE mulrC rpred_div ?Edet //. + by rewrite rpredMsign Edet // => k l; rewrite 2!mxE. +suffices{i} {2}<-: map_mx x v = v by rewrite [map_mx x v i 0]mxE. +have uMx: map_mx x (M w) \in unitmx by rewrite map_unitmx. +rewrite map_mxM map_invmx /=; apply: canLR {uMx}(mulKmx uMx) _. +apply/colP=> i; rewrite !mxE; pose ix := iG (enum_val i * x)%g. +have Dix b: b \in E -> enum_val ix b = x (enum_val i b). + by move=> Eb; rewrite enum_rankK_in ?groupM ?enum_valP // galM ?lfunE. +transitivity ((M w *m v) ix 0); first by rewrite mulKVmx // mxE Dix. +rewrite mxE; apply: eq_bigr => j _; congr (_ * _). +by rewrite !mxE -!enum_val_nth Dix // ?Ew ?mem_tnth. +Qed. + +End Matrix. + +Lemma dim_fixedField E (G : {group gal_of E}) : #|G| = \dim_(fixedField G) E. +Proof. +have [w [_ nzw] [_ Edirect /(_ (groupP G))defE]] := gal_matrix G. +set n := #|G|; set m := \dim (fixedField G); rewrite -defE (directvP Edirect). +rewrite -[n]card_ord -(@mulnK #|'I_n| m) ?adim_gt0 //= -sum_nat_const. +congr (_ %/ _)%N; apply: eq_bigr => i _. +by rewrite dim_cosetv ?(memPn nzw) ?mem_tnth. +Qed. + +Lemma dim_fixed_galois K E (G : {group gal_of E}) : + galois K E -> G \subset 'Gal(E / K) -> + \dim_K (fixedField G) = #|'Gal(E / K) : G|. +Proof. +move=> galE sGgal; have [sFE _ _] := and3P galE; apply/eqP. +rewrite -divgS // eqn_div ?cardSg // dim_fixedField -galois_dim //. +by rewrite mulnC muln_divA ?divnK ?field_dimS ?capvSl -?galois_connection. +Qed. + +Lemma gal_fixedField E (G : {group gal_of E}): 'Gal(E / fixedField G) = G. +Proof. +apply/esym/eqP; rewrite eqEcard galois_connection_subset /= (dim_fixedField G). +rewrite galois_dim //; apply/galois_fixedField/eqP. +rewrite eqEsubv galois_connection_subv ?capvSl //. +by rewrite fixedFieldS ?galois_connection_subset. +Qed. + +Lemma gal_generated E (A : {set gal_of E}) : 'Gal(E / fixedField A) = <>. +Proof. +apply/eqP; rewrite eqEsubset gen_subG galois_connection_subset. +by rewrite -[<>]gal_fixedField galS // fixedFieldS // subset_gen. +Qed. + +Lemma fixedField_galois E (A : {set gal_of E}): galois (fixedField A) E. +Proof. +have: galois (fixedField <>) E. + by apply/galois_fixedField; rewrite gal_fixedField. +by apply: galoisS; rewrite capvSl fixedFieldS // subset_gen. +Qed. + +Section FundamentalTheoremOfGaloisTheory. + +Variables E K : {subfield L}. +Hypothesis galKE : galois K E. + +Section IntermediateField. + +Variable M : {subfield L}. +Hypothesis (sKME : (K <= M <= E)%VS) (nKM : normalField K M). + +Lemma normalField_galois : galois K M. +Proof. +have [[sKM sME] [_ sepKE nKE]] := (andP sKME, and3P galKE). +by rewrite /galois sKM (separableSr sME). +Qed. + +Definition normalField_cast (x : gal_of E) : gal_of M := gal M x. + +Lemma normalField_cast_eq x : + x \in 'Gal(E / K) -> {in M, normalField_cast x =1 x}. +Proof. +have [sKM sME] := andP sKME; have sKE := subv_trans sKM sME. +rewrite gal_kAut // => /(normalField_kAut sKME nKM). +by rewrite kAutE => /andP[_ /galK]. +Qed. + +Lemma normalField_castM : + {in 'Gal(E / K) &, {morph normalField_cast : x y / (x * y)%g}}. +Proof. +move=> x y galEx galEy /=; apply/eqP/gal_eqP => a Ma. +have Ea: a \in E by have [_ /subvP->] := andP sKME. +rewrite normalField_cast_eq ?groupM ?galM //=. +by rewrite normalField_cast_eq ?memv_gal // normalField_cast_eq. +Qed. +Canonical normalField_cast_morphism := Morphism normalField_castM. + +Lemma normalField_ker : 'ker normalField_cast = 'Gal(E / M). +Proof. +have [sKM sME] := andP sKME. +apply/setP=> x; apply/idP/idP=> [kerMx | galEMx]. + rewrite gal_kHom //; apply/kAHomP=> a Ma. + by rewrite -normalField_cast_eq ?(dom_ker kerMx) // (mker kerMx) gal_id. +have galEM: x \in 'Gal(E / K) := subsetP (galS E sKM) x galEMx. +apply/kerP=> //; apply/eqP/gal_eqP=> a Ma. +by rewrite normalField_cast_eq // gal_id (fixed_gal sME). +Qed. + +Lemma normalField_normal : 'Gal(E / M) <| 'Gal(E / K). +Proof. by rewrite -normalField_ker ker_normal. Qed. + +Lemma normalField_img : normalField_cast @* 'Gal(E / K) = 'Gal(M / K). +Proof. +have [[sKM sME] [sKE _ nKE]] := (andP sKME, and3P galKE). +apply/setP=> x; apply/idP/idP=> [/morphimP[{x}x galEx _ ->] | galMx]. + rewrite gal_kHom //; apply/kAHomP=> a Ka; have Ma := subvP sKM a Ka. + by rewrite normalField_cast_eq // (fixed_gal sKE). +have /(kHom_to_gal sKME nKE)[y galEy eq_xy]: kHom K M x by rewrite -gal_kHom. +apply/morphimP; exists y => //; apply/eqP/gal_eqP => a Ha. +by rewrite normalField_cast_eq // eq_xy. +Qed. + +Lemma normalField_isom : + {f : {morphism ('Gal(E / K) / 'Gal(E / M)) >-> gal_of M} | + isom ('Gal(E / K) / 'Gal (E / M)) 'Gal(M / K) f + & (forall A, f @* (A / 'Gal(E / M)) = normalField_cast @* A) + /\ {in 'Gal(E / K) & M, forall x, f (coset 'Gal (E / M) x) =1 x} }%g. +Proof. +have:= first_isom normalField_cast_morphism; rewrite normalField_ker. +case=> f injf Df; exists f; first by apply/isomP; rewrite Df normalField_img. +split=> [//|x a galEx /normalField_cast_eq<- //]; congr ((_ : gal_of M) a). +apply: set1_inj; rewrite -!morphim_set1 ?mem_quotient ?Df //. +by rewrite (subsetP (normal_norm normalField_normal)). +Qed. + +Lemma normalField_isog : 'Gal(E / K) / 'Gal(E / M) \isog 'Gal(M / K). +Proof. by rewrite -normalField_ker -normalField_img first_isog. Qed. + +End IntermediateField. + +Section IntermediateGroup. + +Variable G : {group gal_of E}. +Hypothesis nsGgalE : G <| 'Gal(E / K). + +Lemma normal_fixedField_galois : galois K (fixedField G). +Proof. +have [[sKE sepKE nKE] [sGgal nGgal]] := (and3P galKE, andP nsGgalE). +rewrite /galois -(galois_connection _ sKE) sGgal. +rewrite (separableSr _ sepKE) ?capvSl //; apply/forall_inP=> f autKf. +rewrite eqEdim limg_dim_eq ?(eqP (AEnd_lker0 _)) ?capv0 // leqnn andbT. +apply/subvP => _ /memv_imgP[a /mem_fixedFieldP[Ea cGa] ->]. +have /kAut_to_gal[x galEx -> //]: kAut K E f. + rewrite /kAut (forall_inP nKE) // andbT; apply/kAHomP. + by move: autKf; rewrite inE kAutfE => /kHomP[]. +apply/fixedFieldP=> [|y Gy]; first exact: memv_gal. +by rewrite -galM // conjgCV galM //= cGa // memJ_norm ?groupV ?(subsetP nGgal). +Qed. + +End IntermediateGroup. + +End FundamentalTheoremOfGaloisTheory. + +End GaloisTheory. + +Notation "''Gal' ( V / U )" := (galoisG V U) : group_scope. +Notation "''Gal' ( V / U )" := (galoisG_group V U) : Group_scope. + +Implicit Arguments fixedFieldP [F L E A a]. +Implicit Arguments normalFieldP [F L K E]. +Implicit Arguments splitting_galoisField [F L K E]. +Implicit Arguments galois_fixedField [F L K E]. diff --git a/mathcomp/field/separable.v b/mathcomp/field/separable.v new file mode 100644 index 0000000..9638500 --- /dev/null +++ b/mathcomp/field/separable.v @@ -0,0 +1,995 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype. +Require Import tuple finfun bigop finset prime binomial ssralg poly polydiv. +Require Import fingroup perm morphism quotient gproduct finalg zmodp cyclic. +Require Import matrix mxalgebra mxpoly polyXY vector falgebra fieldext. + +(******************************************************************************) +(* This file provides a theory of separable and inseparable field extensions. *) +(* *) +(* separable_poly p <=> p has no multiple roots in any field extension. *) +(* separable_element K x <=> the minimal polynomial of x over K is separable. *) +(* separable K E <=> every member of E is separable over K. *) +(* separable_generator K E == some x \in E that generates the largest *) +(* subfield K[x] that is separable over K. *) +(* purely_inseparable_element K x <=> there is a [char L].-nat n such that *) +(* x ^+ n \in K. *) +(* purely_inseparable K E <=> every member of E is purely inseparable over K. *) +(* *) +(* Derivations are introduced to prove the adjoin_separableP Lemma: *) +(* Derivation K D <=> the linear operator D satifies the Leibniz *) +(* product rule inside K. *) +(* extendDerivation x D K == given a derivation D on K and a separable *) +(* element x over K, this function returns the *) +(* unique extension of D to K(x). *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Open Local Scope ring_scope. +Import GRing.Theory. + +Section SeparablePoly. + +Variable R : idomainType. +Implicit Types p q d u v : {poly R}. + +Definition separable_poly p := coprimep p p^`(). + +Local Notation separable := separable_poly. +Local Notation lcn_neq0 := (Pdiv.Idomain.lc_expn_scalp_neq0 _). + +Lemma separable_poly_neq0 p : separable p -> p != 0. +Proof. +by apply: contraTneq => ->; rewrite /separable deriv0 coprime0p eqp01. +Qed. + +Lemma poly_square_freeP p : + (forall u v, u * v %| p -> coprimep u v) + <-> (forall u, size u != 1%N -> ~~ (u ^+ 2 %| p)). +Proof. +split=> [sq'p u | sq'p u v dvd_uv_p]. + by apply: contra => /sq'p; rewrite coprimepp. +rewrite coprimep_def (contraLR (sq'p _)) // (dvdp_trans _ dvd_uv_p) //. +by rewrite dvdp_mul ?dvdp_gcdl ?dvdp_gcdr. +Qed. + +Lemma separable_polyP {p} : + reflect [/\ forall u v, u * v %| p -> coprimep u v + & forall u, u %| p -> 1 < size u -> u^`() != 0] + (separable p). +Proof. +apply: (iffP idP) => [sep_p | [sq'p nz_der1p]]. + split=> [u v | u u_dv_p]; last first. + apply: contraTneq => u'0; rewrite -leqNgt -(eqnP sep_p). + rewrite dvdp_leq -?size_poly_eq0 ?(eqnP sep_p) // dvdp_gcd u_dv_p. + have /dvdp_scaler <-: lead_coef u ^+ scalp p u != 0 by rewrite lcn_neq0. + by rewrite -derivZ -Pdiv.Idomain.divpK //= derivM u'0 mulr0 addr0 dvdp_mull. + rewrite Pdiv.Idomain.dvdp_eq mulrCA mulrA; set c := _ ^+ _ => /eqP Dcp. + have nz_c: c != 0 by rewrite lcn_neq0. + move: sep_p; rewrite coprimep_sym -[separable _](coprimep_scalel _ _ nz_c). + rewrite -(coprimep_scaler _ _ nz_c) -derivZ Dcp derivM coprimep_mull. + by rewrite coprimep_addl_mul !coprimep_mulr -andbA => /and4P[]. +rewrite /separable coprimep_def eqn_leq size_poly_gt0; set g := gcdp _ _. +have nz_g: g != 0. + rewrite -dvd0p dvdp_gcd -(mulr0 0); apply/nandP; left. + by have /poly_square_freeP-> := sq'p; rewrite ?size_poly0. +have [g_p]: g %| p /\ g %| p^`() by rewrite dvdp_gcdr ?dvdp_gcdl. +pose c := lead_coef g ^+ scalp p g; have nz_c: c != 0 by rewrite lcn_neq0. +have Dcp: c *: p = p %/ g * g by rewrite Pdiv.Idomain.divpK. +rewrite nz_g andbT leqNgt -(dvdp_scaler _ _ nz_c) -derivZ Dcp derivM. +rewrite dvdp_addr; last by rewrite dvdp_mull. +rewrite Gauss_dvdpr; last by rewrite sq'p // mulrC -Dcp dvdp_scalel. +by apply: contraL => /nz_der1p nz_g'; rewrite gtNdvdp ?nz_g' ?lt_size_deriv. +Qed. + +Lemma separable_coprime p u v : separable p -> u * v %| p -> coprimep u v. +Proof. by move=> /separable_polyP[sq'p _] /sq'p. Qed. + +Lemma separable_nosquare p u k : + separable p -> 1 < k -> size u != 1%N -> (u ^+ k %| p) = false. +Proof. +move=> /separable_polyP[/poly_square_freeP sq'p _] /subnKC <- /sq'p. +by apply: contraNF; apply: dvdp_trans; rewrite exprD dvdp_mulr. +Qed. + +Lemma separable_deriv_eq0 p u : + separable p -> u %| p -> 1 < size u -> (u^`() == 0) = false. +Proof. by move=> /separable_polyP[_ nz_der1p] u_p /nz_der1p/negPf->. Qed. + +Lemma dvdp_separable p q : q %| p -> separable p -> separable q. +Proof. +move=> /(dvdp_trans _)q_dv_p /separable_polyP[sq'p nz_der1p]. +by apply/separable_polyP; split=> [u v /q_dv_p/sq'p | u /q_dv_p/nz_der1p]. +Qed. + +Lemma separable_mul p q : + separable (p * q) = [&& separable p, separable q & coprimep p q]. +Proof. +apply/idP/and3P => [sep_pq | [sep_p seq_q co_pq]]. + rewrite !(dvdp_separable _ sep_pq) ?dvdp_mulIr ?dvdp_mulIl //. + by rewrite (separable_coprime sep_pq). +rewrite /separable derivM coprimep_mull {1}addrC mulrC !coprimep_addl_mul. +by rewrite !coprimep_mulr (coprimep_sym q p) co_pq !andbT; apply/andP. +Qed. + +Lemma eqp_separable p q : p %= q -> separable p = separable q. +Proof. by case/andP=> p_q q_p; apply/idP/idP=> /dvdp_separable->. Qed. + +Lemma separable_root p x : + separable (p * ('X - x%:P)) = separable p && ~~ root p x. +Proof. +rewrite separable_mul; apply: andb_id2l => seq_p. +by rewrite /separable derivXsubC coprimep1 coprimep_XsubC. +Qed. + +Lemma separable_prod_XsubC (r : seq R) : + separable (\prod_(x <- r) ('X - x%:P)) = uniq r. +Proof. +elim: r => [|x r IH]; first by rewrite big_nil /separable_poly coprime1p. +by rewrite big_cons mulrC separable_root IH root_prod_XsubC andbC. +Qed. + +Lemma make_separable p : p != 0 -> separable (p %/ gcdp p p^`()). +Proof. +set g := gcdp p p^`() => nz_p; apply/separable_polyP. +have max_dvd_u (u : {poly R}): 1 < size u -> exists k, ~~ (u ^+ k %| p). + move=> u_gt1; exists (size p); rewrite gtNdvdp // polySpred //. + by rewrite -(ltn_subRL 1) subn1 size_exp leq_pmull // -(subnKC u_gt1). +split=> [|u u_pg u_gt1]; last first. + apply/eqP=> u'0 /=; have [k /negP[]] := max_dvd_u u u_gt1. + elim: k => [|k IHk]; first by rewrite dvd1p. + suffices: u ^+ k.+1 %| (p %/ g) * g. + by rewrite Pdiv.Idomain.divpK ?dvdp_gcdl // dvdp_scaler ?lcn_neq0. + rewrite exprS dvdp_mul // dvdp_gcd IHk //=. + suffices: u ^+ k %| (p %/ u ^+ k * u ^+ k)^`(). + by rewrite Pdiv.Idomain.divpK // derivZ dvdp_scaler ?lcn_neq0. + by rewrite !derivCE u'0 mul0r mul0rn mulr0 addr0 dvdp_mull. +have pg_dv_p: p %/ g %| p by rewrite divp_dvd ?dvdp_gcdl. +apply/poly_square_freeP=> u; rewrite neq_ltn ltnS leqn0 size_poly_eq0. +case/predU1P=> [-> | /max_dvd_u[k]]. + by apply: contra nz_p; rewrite expr0n -dvd0p => /dvdp_trans->. +apply: contra => u2_dv_pg; case: k; [by rewrite dvd1p | elim=> [|n IHn]]. + exact: dvdp_trans (dvdp_mulr _ _) (dvdp_trans u2_dv_pg pg_dv_p). +suff: u ^+ n.+2 %| (p %/ g) * g. + by rewrite Pdiv.Idomain.divpK ?dvdp_gcdl // dvdp_scaler ?lcn_neq0. +rewrite -add2n exprD dvdp_mul // dvdp_gcd. +rewrite (dvdp_trans _ IHn) ?exprS ?dvdp_mull //=. +suff: u ^+ n %| ((p %/ u ^+ n.+1) * u ^+ n.+1)^`(). + by rewrite Pdiv.Idomain.divpK // derivZ dvdp_scaler ?lcn_neq0. +by rewrite !derivCE dvdp_add // -1?mulr_natl ?exprS !dvdp_mull. +Qed. + +End SeparablePoly. + +Implicit Arguments separable_polyP [R p]. + +Lemma separable_map (F : fieldType) (R : idomainType) + (f : {rmorphism F -> R}) (p : {poly F}) : + separable_poly (map_poly f p) = separable_poly p. +Proof. +by rewrite /separable_poly deriv_map /coprimep -gcdp_map size_map_poly. +Qed. + +Section InfinitePrimitiveElementTheorem. + +Local Notation "p ^ f" := (map_poly f p) : ring_scope. + +Variables (F L : fieldType) (iota : {rmorphism F -> L}). +Variables (x y : L) (p : {poly F}). +Hypotheses (nz_p : p != 0) (px_0 : root (p ^ iota) x). + +Let inFz z w := exists q, (q ^ iota).[z] = w. + +Lemma large_field_PET q : + root (q ^ iota) y -> separable_poly q -> + exists2 r, r != 0 + & forall t (z := iota t * y - x), ~~ root r (iota t) -> inFz z x /\ inFz z y. +Proof. +move=> qy_0 sep_q; have nz_q := separable_poly_neq0 sep_q. +have /factor_theorem[q0 Dq] := qy_0. +set p1 := p ^ iota \Po ('X + x%:P); set q1 := q0 \Po ('X + y%:P). +have nz_p1: p1 != 0. + apply: contraNneq nz_p => /(canRL (fun r => comp_polyXaddC_K r _))/eqP. + by rewrite comp_poly0 map_poly_eq0. +have{sep_q} nz_q10: q1.[0] != 0. + move: sep_q; rewrite -(separable_map iota) Dq separable_root => /andP[_]. + by rewrite horner_comp !hornerE. +have nz_q1: q1 != 0 by apply: contraNneq nz_q10 => ->; rewrite horner0. +pose p2 := p1 ^ polyC \Po ('X * 'Y); pose q2 := q1 ^ polyC. +have /Bezout_coprimepP[[u v]]: coprimep p2 q2. + rewrite coprimep_def eqn_leq leqNgt andbC size_poly_gt0 gcdp_eq0 poly_XmY_eq0. + by rewrite map_polyC_eq0 (negPf nz_p1) -resultant_eq0 div_annihilant_neq0. +rewrite -size_poly_eq1 => /size_poly1P[r nzr Dr]; exists r => {nzr}// t z nz_rt. +have [r1 nz_r1 r1z_0]: algebraicOver iota z. + apply/algebraic_sub; last by exists p. + by apply: algebraic_mul; [apply: algebraic_id | exists q]. +pose Fz := subFExtend iota z r1; pose kappa : Fz -> L := subfx_inj. +pose kappa' := inj_subfx iota z r1. +have /eq_map_poly Diota: kappa \o kappa' =1 iota. + by move=> w; rewrite /kappa /= subfx_inj_eval // map_polyC hornerC. +suffices [y3]: exists y3, y = kappa y3. + have [q3 ->] := subfxE y3; rewrite /kappa subfx_inj_eval // => Dy. + split; [exists (t *: q3 - 'X) | by exists q3]. + by rewrite rmorphB linearZ /= map_polyX !hornerE -Dy opprB addrC addrNK. +pose p0 := p ^ iota \Po (iota t *: 'X - z%:P). +have co_p0_q0: coprimep p0 q0. + pose at_t := horner_eval (iota t); have at_t0: at_t 0 = 0 by apply: rmorph0. + have /map_polyK polyCK: cancel polyC at_t by move=> w; apply: hornerC. + have ->: p0 = p2 ^ at_t \Po ('X - y%:P). + rewrite map_comp_poly polyCK // rmorphM /= map_polyC map_polyX /=. + rewrite horner_evalE hornerX. + rewrite -!comp_polyA comp_polyM comp_polyD !comp_polyC !comp_polyX. + by rewrite mulrC mulrBr mul_polyC addrAC -addrA -opprB -rmorphM -rmorphB. + have ->: q0 = q2 ^ at_t \Po ('X - y%:P) by rewrite polyCK ?comp_polyXaddC_K. + apply/coprimep_comp_poly/Bezout_coprimepP; exists (u ^ at_t, v ^ at_t). + by rewrite -!rmorphM -rmorphD Dr /= map_polyC polyC_eqp1. +have{co_p0_q0}: gcdp p0 (q ^ iota) %= 'X - y%:P. + rewrite /eqp Dq (eqp_dvdl _ (Gauss_gcdpr _ _)) // dvdp_gcdr dvdp_gcd. + rewrite dvdp_mull // -root_factor_theorem rootE horner_comp !hornerE. + by rewrite opprB addrC subrK. +have{p0} [p3 ->]: exists p3, p0 = p3 ^ kappa. + exists (p ^ kappa' \Po (kappa' t *: 'X - (subfx_eval iota z r1 'X)%:P)). + rewrite map_comp_poly rmorphB linearZ /= map_polyC map_polyX /=. + rewrite !subfx_inj_eval // map_polyC hornerC map_polyX hornerX. + by rewrite -map_poly_comp Diota. +rewrite -Diota map_poly_comp -gcdp_map /= -/kappa. +move: (gcdp _ _) => r3 /eqpf_eq[c nz_c Dr3]. +exists (- (r3`_0 / r3`_1)); rewrite [kappa _]rmorphN fmorph_div -!coef_map Dr3. +by rewrite !coefZ polyseqXsubC mulr1 mulrC mulKf ?opprK. +Qed. + +Lemma char0_PET (q : {poly F}) : + q != 0 -> root (q ^ iota) y -> [char F] =i pred0 -> + exists n, let z := y *+ n - x in inFz z x /\ inFz z y. +Proof. +move=> nz_q qy_0 /charf0P charF0. +without loss{nz_q} sep_q: q qy_0 / separable_poly q. + move=> IHq; apply: IHq (make_separable nz_q). + have /dvdpP[q1 Dq] := dvdp_gcdl q q^`(). + rewrite {1}Dq mulpK ?gcdp_eq0; last by apply/nandP; left. + have [n [r nz_ry Dr]] := multiplicity_XsubC (q ^ iota) y. + rewrite map_poly_eq0 nz_q /= in nz_ry. + case: n => [|n] in Dr; first by rewrite Dr mulr1 (negPf nz_ry) in qy_0. + have: ('X - y%:P) ^+ n.+1 %| q ^ iota by rewrite Dr dvdp_mulIr. + rewrite Dq rmorphM /= gcdp_map -(eqp_dvdr _ (gcdp_mul2l _ _ _)) -deriv_map Dr. + rewrite dvdp_gcd derivM deriv_exp derivXsubC mul1r !mulrA dvdp_mulIr /=. + rewrite mulrDr mulrA dvdp_addr ?dvdp_mulIr // exprS -scaler_nat -!scalerAr. + rewrite dvdp_scaler -?(rmorph_nat iota) ?fmorph_eq0 ?charF0 //. + rewrite mulrA dvdp_mul2r ?expf_neq0 ?polyXsubC_eq0 //. + by rewrite Gauss_dvdpl ?dvdp_XsubCl // coprimep_sym coprimep_XsubC. +have [r nz_r PETxy] := large_field_PET qy_0 sep_q. +pose ts := mkseq (fun n => iota n%:R) (size r). +have /(max_ring_poly_roots nz_r)/=/implyP: uniq_roots ts. + rewrite uniq_rootsE mkseq_uniq // => m n eq_mn; apply/eqP; rewrite eqn_leq. + wlog suffices: m n eq_mn / m <= n by move=> IHmn; rewrite !IHmn. + move/fmorph_inj/eqP: eq_mn; rewrite -subr_eq0 leqNgt; apply: contraL => lt_mn. + by rewrite -natrB ?(ltnW lt_mn) // charF0 -lt0n subn_gt0. +rewrite size_mkseq ltnn implybF all_map => /allPn[n _ /= /PETxy]. +by rewrite rmorph_nat mulr_natl; exists n. +Qed. + +End InfinitePrimitiveElementTheorem. + +Section Separable. + +Variables (F : fieldType) (L : fieldExtType F). +Implicit Types (U V W : {vspace L}) (E K M : {subfield L}) (D : 'End(L)). + +Section Derivation. + +Variables (K : {vspace L}) (D : 'End(L)). + +(* A deriviation only needs to be additive and satify Lebniz's law, but all *) +(* the deriviations used here are going to be linear, so we only define *) +(* the Derivation predicate for linear endomorphisms. *) +Definition Derivation (s := vbasis K) : bool := + all (fun u => all (fun v => D (u * v) == D u * v + u * D v) s) s. + +Hypothesis derD : Derivation. + +Lemma Derivation_mul : {in K &, forall u v, D (u * v) = D u * v + u * D v}. +Proof. +move=> u v /coord_vbasis-> /coord_vbasis->. +rewrite !(mulr_sumr, linear_sum) -big_split; apply: eq_bigr => /= j _. +rewrite !mulr_suml linear_sum -big_split; apply: eq_bigr => /= i _. +rewrite !(=^~ scalerAl, linearZZ) -!scalerAr linearZZ -!scalerDr !scalerA /=. +by congr (_ *: _); apply/eqP; rewrite (allP (allP derD _ _)) ?memt_nth. +Qed. + +Lemma Derivation_mul_poly (Dp := map_poly D) : + {in polyOver K &, forall p q, Dp (p * q) = Dp p * q + p * Dp q}. +Proof. +move=> p q Kp Kq; apply/polyP=> i; rewrite {}/Dp coefD coef_map /= !coefM. +rewrite linear_sum -big_split; apply: eq_bigr => /= j _. +by rewrite !{1}coef_map Derivation_mul ?(polyOverP _). +Qed. + +End Derivation. + +Lemma DerivationS E K D : (K <= E)%VS -> Derivation E D -> Derivation K D. +Proof. +move/subvP=> sKE derD; apply/allP=> x Kx; apply/allP=> y Ky; apply/eqP. +by rewrite (Derivation_mul derD) ?sKE // vbasis_mem. +Qed. + +Section DerivationAlgebra. + +Variables (E : {subfield L}) (D : 'End(L)). +Hypothesis derD : Derivation E D. + +Lemma Derivation1 : D 1 = 0. +Proof. +apply: (addIr (D (1 * 1))); rewrite add0r {1}mul1r. +by rewrite (Derivation_mul derD) ?mem1v // mulr1 mul1r. +Qed. + +Lemma Derivation_scalar x : x \in 1%VS -> D x = 0. +Proof. by case/vlineP=> y ->; rewrite linearZ /= Derivation1 scaler0. Qed. + +Lemma Derivation_exp x m : x \in E -> D (x ^+ m) = x ^+ m.-1 *+ m * D x. +Proof. +move=> Ex; case: m; first by rewrite expr0 mulr0n mul0r Derivation1. +elim=> [|m IHm]; first by rewrite mul1r. +rewrite exprS (Derivation_mul derD) //; last by apply: rpredX. +by rewrite mulrC IHm mulrA mulrnAr -exprS -mulrDl. +Qed. + +Lemma Derivation_horner p x : + p \is a polyOver E -> x \in E -> + D p.[x] = (map_poly D p).[x] + p^`().[x] * D x. +Proof. +move=> Ep Ex; elim/poly_ind: p Ep => [|p c IHp] /polyOverP EpXc. + by rewrite !(raddf0, horner0) mul0r add0r. +have Ep: p \is a polyOver E. + by apply/polyOverP=> i; have:= EpXc i.+1; rewrite coefD coefMX coefC addr0. +have->: map_poly D (p * 'X + c%:P) = map_poly D p * 'X + (D c)%:P. + apply/polyP=> i; rewrite !(coefD, coefMX, coef_map) /= linearD /= !coefC. + by rewrite !(fun_if D) linear0. +rewrite derivMXaddC !hornerE mulrDl mulrAC addrAC linearD /=; congr (_ + _). +by rewrite addrCA -mulrDl -IHp // addrC (Derivation_mul derD) ?rpred_horner. +Qed. + +End DerivationAlgebra. + +Definition separable_element U x := separable_poly (minPoly U x). + +Section SeparableElement. + +Variables (K : {subfield L}) (x : L). +(* begin hide *) +Let sKxK : (K <= <>)%VS := subv_adjoin K x. +Let Kx_x : x \in <>%VS := memv_adjoin K x. +(* end hide *) + +Lemma separable_elementP : + reflect (exists f, [/\ f \is a polyOver K, root f x & separable_poly f]) + (separable_element K x). +Proof. +apply: (iffP idP) => [sep_x | [f [Kf /(minPoly_dvdp Kf)/dvdpP[g ->]]]]. + by exists (minPoly K x); rewrite minPolyOver root_minPoly. +by rewrite separable_mul => /and3P[]. +Qed. + +Lemma base_separable : x \in K -> separable_element K x. +Proof. +move=> Kx; apply/separable_elementP; exists ('X - x%:P). +by rewrite polyOverXsubC root_XsubC /separable_poly !derivCE coprimep1. +Qed. + +Lemma separable_nz_der : separable_element K x = ((minPoly K x)^`() != 0). +Proof. +rewrite /separable_element /separable_poly. +apply/idP/idP=> [|nzPx']. + by apply: contraTneq => ->; rewrite coprimep0 -size_poly_eq1 size_minPoly. +have gcdK : gcdp (minPoly K x) (minPoly K x)^`() \in polyOver K. + by rewrite gcdp_polyOver ?polyOver_deriv // minPolyOver. +rewrite -gcdp_eqp1 -size_poly_eq1 -dvdp1. +have /orP[/andP[_]|/andP[]//] := minPoly_irr gcdK (dvdp_gcdl _ _). +rewrite dvdp_gcd dvdpp /= => /(dvdp_leq nzPx')/leq_trans/(_ (size_poly _ _)). +by rewrite size_minPoly ltnn. +Qed. + +Lemma separablePn : + reflect (exists2 p, p \in [char L] & + exists2 g, g \is a polyOver K & minPoly K x = g \Po 'X^p) + (~~ separable_element K x). +Proof. +rewrite separable_nz_der negbK; set f := minPoly K x. +apply: (iffP eqP) => [f'0 | [p Hp [g _ ->]]]; last first. + by rewrite deriv_comp derivXn -scaler_nat (charf0 Hp) scale0r mulr0. +pose n := adjoin_degree K x; have sz_f: size f = n.+1 := size_minPoly K x. +have fn1: f`_n = 1 by rewrite -(monicP (monic_minPoly K x)) lead_coefE sz_f. +have dimKx: (adjoin_degree K x)%:R == 0 :> L. + by rewrite -(coef0 _ n.-1) -f'0 coef_deriv fn1. +have /natf0_char[// | p charLp] := dimKx. +have /dvdnP[r Dn]: (p %| n)%N by rewrite (dvdn_charf charLp). +exists p => //; exists (\poly_(i < r.+1) f`_(i * p)). + by apply: polyOver_poly => i _; rewrite (polyOverP _) ?minPolyOver. +rewrite comp_polyE size_poly_eq -?Dn ?fn1 ?oner_eq0 //. +have pr_p := charf_prime charLp; have p_gt0 := prime_gt0 pr_p. +apply/polyP=> i; rewrite coef_sum. +have [[{i} i ->] | p'i] := altP (@dvdnP p i); last first. + rewrite big1 => [|j _]; last first. + rewrite coefZ -exprM coefXn [_ == _](contraNF _ p'i) ?mulr0 // => /eqP->. + by rewrite dvdn_mulr. + rewrite (dvdn_charf charLp) in p'i; apply: mulfI p'i _ _ _. + by rewrite mulr0 mulr_natl; case: i => // i; rewrite -coef_deriv f'0 coef0. +have [ltri | leir] := leqP r.+1 i. + rewrite nth_default ?sz_f ?Dn ?ltn_pmul2r ?big1 // => j _. + rewrite coefZ -exprM coefXn mulnC gtn_eqF ?mulr0 //. + by rewrite ltn_pmul2l ?(leq_trans _ ltri). +rewrite (bigD1 (Sub i _)) //= big1 ?addr0 => [|j i'j]; last first. + by rewrite coefZ -exprM coefXn mulnC eqn_pmul2l // mulr_natr mulrb ifN_eqC. +by rewrite coef_poly leir coefZ -exprM coefXn mulnC eqxx mulr1. +Qed. + +Lemma separable_root_der : separable_element K x (+) root (minPoly K x)^`() x. +Proof. +have KpKx': _^`() \is a polyOver K := polyOver_deriv (minPolyOver K x). +rewrite separable_nz_der addNb (root_small_adjoin_poly KpKx') ?addbb //. +by rewrite (leq_trans (size_poly _ _)) ?size_minPoly. +Qed. + +Lemma Derivation_separable D : + Derivation <> D -> separable_element K x -> + D x = - (map_poly D (minPoly K x)).[x] / (minPoly K x)^`().[x]. +Proof. +move=> derD sepKx; have:= separable_root_der; rewrite {}sepKx -sub0r => nzKx'x. +apply: canRL (mulfK nzKx'x) (canRL (addrK _) _); rewrite mulrC addrC. +rewrite -(Derivation_horner derD) ?minPolyxx ?linear0 //. +exact: polyOverSv sKxK _ (minPolyOver _ _). +Qed. + +Section ExtendDerivation. + +Variable D : 'End(L). + +Let Dx E := - (map_poly D (minPoly E x)).[x] / ((minPoly E x)^`()).[x]. + +Fact extendDerivation_subproof E (adjEx := Fadjoin_poly E x) : + let body y (p := adjEx y) := (map_poly D p).[x] + p^`().[x] * Dx E in + linear body. +Proof. +move: Dx => C /= a u v. +rewrite /adjEx linearP /= -mul_polyC derivD derivM derivC mul0r add0r -/adjEx. +rewrite !hornerE /= -scalerAl mul1r raddfD /=. +have ->: map_poly D (a%:A%:P * adjEx u) = a%:A%:P * map_poly D (adjEx u). + apply/polyP=> i; rewrite !mul_polyC !coef_map !coefZ !mulr_algl /= linearZ. + by rewrite coef_map. +rewrite !hornerE !mulr_algl mulrDl scalerDr -scalerAl -!addrA; congr (_ + _). +by rewrite addrCA. +Qed. + +Definition extendDerivation E : 'End(L) := + linfun (Linear (extendDerivation_subproof E)). + +Hypothesis derD : Derivation K D. + +Lemma extendDerivation_id y : y \in K -> extendDerivation K y = D y. +Proof. +move=> yK; rewrite lfunE /= Fadjoin_polyC // derivC map_polyC hornerC. +by rewrite horner0 mul0r addr0. +Qed. + +Lemma extendDerivation_horner p : + p \is a polyOver K -> separable_element K x -> + extendDerivation K p.[x] = (map_poly D p).[x] + p^`().[x] * Dx K. +Proof. +move=> Kp sepKx; have:= separable_root_der; rewrite {}sepKx /= => nz_pKx'x. +rewrite {-1}(divp_eq p (minPoly K x)) lfunE /= Fadjoin_poly_mod // raddfD /=. +rewrite {1}(Derivation_mul_poly derD) ?divp_polyOver ?minPolyOver //. +rewrite derivD derivM !{1}hornerD !{1}hornerM minPolyxx !{1}mulr0 !{1}add0r. +rewrite mulrDl addrA [_ + (_ * _ * _)]addrC {2}/Dx -mulrA -/Dx. +by rewrite [_ / _]mulrC (mulVKf nz_pKx'x) mulrN addKr. +Qed. + +Lemma extendDerivationP : + separable_element K x -> Derivation <> (extendDerivation K). +Proof. +move=> sep; apply/allP=> u /vbasis_mem Hu; apply/allP=> v /vbasis_mem Hv. +apply/eqP. +rewrite -(Fadjoin_poly_eq Hu) -(Fadjoin_poly_eq Hv) -hornerM. +rewrite !{1}extendDerivation_horner ?{1}rpredM ?Fadjoin_polyOver //. +rewrite (Derivation_mul_poly derD) ?Fadjoin_polyOver //. +rewrite derivM !{1}hornerD !{1}hornerM !{1}mulrDl !{1}mulrDr -!addrA. +congr (_ + _); rewrite [Dx K]lock -!{1}mulrA !{1}addrA; congr (_ + _). +by rewrite addrC; congr (_ * _ + _); rewrite mulrC. +Qed. + +End ExtendDerivation. + +(* Reference: +http://www.math.uconn.edu/~kconrad/blurbs/galoistheory/separable2.pdf *) +Lemma Derivation_separableP : + reflect + (forall D, Derivation <> D -> K <= lker D -> <> <= lker D)%VS + (separable_element K x). +Proof. +apply: (iffP idP) => [sepKx D derD /subvP DK_0 | derKx_0]. + have{DK_0} DK_0 q: q \is a polyOver K -> map_poly D q = 0. + move=> /polyOverP Kq; apply/polyP=> i; apply/eqP. + by rewrite coef0 coef_map -memv_ker DK_0. + apply/subvP=> _ /Fadjoin_polyP[p Kp ->]; rewrite memv_ker. + rewrite (Derivation_horner derD) ?(polyOverSv sKxK) //. + rewrite (Derivation_separable derD sepKx) !DK_0 ?minPolyOver //. + by rewrite horner0 oppr0 mul0r mulr0 addr0. +apply: wlog_neg; rewrite {1}separable_nz_der negbK => /eqP pKx'_0. +have Dlin: linear (fun y => (Fadjoin_poly K x y)^`().[x]). + move=> a u v; rewrite linearP /= -mul_polyC derivD derivM derivC mul0r add0r. + by rewrite hornerD hornerM hornerC -scalerAl mul1r. +pose D := linfun (Linear Dlin); apply: base_separable. +have DK_0: (K <= lker D)%VS. + apply/subvP=> v Kv; rewrite memv_ker lfunE /= Fadjoin_polyC //. + by rewrite derivC horner0. +have Dder: Derivation <> D. + apply/allP=> u /vbasis_mem Kx_u; apply/allP=> v /vbasis_mem Kx_v. + rewrite !lfunE /= -{-2}(Fadjoin_poly_eq Kx_u) -{-3}(Fadjoin_poly_eq Kx_v). + rewrite -!hornerM -hornerD -derivM. + rewrite Fadjoin_poly_mod ?rpredM ?Fadjoin_polyOver //. + rewrite {2}(divp_eq (_ * _) (minPoly K x)) derivD derivM pKx'_0 mulr0 addr0. + by rewrite hornerD hornerM minPolyxx mulr0 add0r. +have{Dder DK_0}: x \in lker D by apply: subvP Kx_x; apply: derKx_0. +apply: contraLR => K'x; rewrite memv_ker lfunE /= Fadjoin_polyX //. +by rewrite derivX hornerC oner_eq0. +Qed. + +End SeparableElement. + +Implicit Arguments separable_elementP [K x]. + +Lemma separable_elementS K E x : + (K <= E)%VS -> separable_element K x -> separable_element E x. +Proof. +move=> sKE /separable_elementP[f [fK rootf sepf]]; apply/separable_elementP. +by exists f; rewrite (polyOverSv sKE). +Qed. + +Lemma adjoin_separableP {K x} : + reflect (forall y, y \in <>%VS -> separable_element K y) + (separable_element K x). +Proof. +apply: (iffP idP) => [sepKx | -> //]; last exact: memv_adjoin. +move=> _ /Fadjoin_polyP[q Kq ->]; apply/Derivation_separableP=> D derD DK_0. +apply/subvP=> _ /Fadjoin_polyP[p Kp ->]. +rewrite memv_ker -(extendDerivation_id x D (mempx_Fadjoin _ Kp)). +have sepFyx: (separable_element <> x). + by apply: (separable_elementS (subv_adjoin _ _)). +have KyxEqKx: (<< <>; x>> = <>)%VS. + apply/eqP; rewrite eqEsubv andbC adjoinSl ?subv_adjoin //=. + apply/FadjoinP/andP; rewrite memv_adjoin andbT. + by apply/FadjoinP/andP; rewrite subv_adjoin mempx_Fadjoin. +have:= extendDerivationP derD sepFyx; rewrite KyxEqKx => derDx. +rewrite -horner_comp (Derivation_horner derDx) ?memv_adjoin //; last first. + by apply: (polyOverSv (subv_adjoin _ _)); apply: polyOver_comp. +set Dx_p := map_poly _; have Dx_p_0 t: t \is a polyOver K -> (Dx_p t).[x] = 0. + move/polyOverP=> Kt; congr (_.[x] = 0): (horner0 x); apply/esym/polyP => i. + have /eqP Dti_0: D t`_i == 0 by rewrite -memv_ker (subvP DK_0) ?Kt. + by rewrite coef0 coef_map /= {1}extendDerivation_id ?subvP_adjoin. +rewrite (Derivation_separable derDx sepKx) -/Dx_p Dx_p_0 ?polyOver_comp //. +by rewrite add0r mulrCA Dx_p_0 ?minPolyOver ?oppr0 ?mul0r. +Qed. + +Lemma separable_exponent K x : + exists n, [char L].-nat n && separable_element K (x ^+ n). +Proof. +pose d := adjoin_degree K x; move: {2}d.+1 (ltnSn d) => n. +elim: n => // n IHn in x @d *; rewrite ltnS => le_d_n. +have [[p charLp]|] := altP (separablePn K x); last by rewrite negbK; exists 1%N. +case=> g Kg defKx; have p_pr := charf_prime charLp. +suffices /IHn[m /andP[charLm sepKxpm]]: adjoin_degree K (x ^+ p) < n. + by exists (p * m)%N; rewrite pnat_mul pnatE // charLp charLm exprM. +apply: leq_trans le_d_n; rewrite -ltnS -!size_minPoly. +have nzKx: minPoly K x != 0 by rewrite monic_neq0 ?monic_minPoly. +have nzg: g != 0 by apply: contra_eqN defKx => /eqP->; rewrite comp_poly0. +apply: leq_ltn_trans (dvdp_leq nzg _) _. + by rewrite minPoly_dvdp // rootE -hornerXn -horner_comp -defKx minPolyxx. +rewrite (polySpred nzKx) ltnS defKx size_comp_poly size_polyXn /=. +suffices g_gt1: 1 < size g by rewrite -(subnKC g_gt1) ltn_Pmulr ?prime_gt1. +apply: contra_eqT (size_minPoly K x); rewrite defKx -leqNgt => /size1_polyC->. +by rewrite comp_polyC size_polyC; case: (_ != 0). +Qed. + +Lemma charf0_separable K : [char L] =i pred0 -> forall x, separable_element K x. +Proof. +move=> charL0 x; have [n /andP[charLn]] := separable_exponent K x. +by rewrite (pnat_1 charLn (sub_in_pnat _ charLn)) // => p _; rewrite charL0. +Qed. + +Lemma charf_p_separable K x e p : + p \in [char L] -> separable_element K x = (x \in <>%VS). +Proof. +move=> charLp; apply/idP/idP=> [sepKx | /Fadjoin_poly_eq]; last first. + set m := p ^ _;set f := Fadjoin_poly K _ x => Dx; apply/separable_elementP. + have mL0: m%:R = 0 :> L by apply/eqP; rewrite -(dvdn_charf charLp) dvdn_exp. + exists ('X - (f \Po 'X^m)); split. + - by rewrite rpredB ?polyOver_comp ?rpredX ?polyOverX ?Fadjoin_polyOver. + - by rewrite rootE !hornerE horner_comp hornerXn Dx subrr. + rewrite /separable_poly !(derivE, deriv_comp) -mulr_natr -rmorphMn /= mL0. + by rewrite !mulr0 subr0 coprimep1. +without loss{e} ->: e x sepKx / e = 0%N. + move=> IH; elim: {e}e.+1 => [|e]; [exact: memv_adjoin | apply: subvP]. + apply/FadjoinP/andP; rewrite subv_adjoin expnSr exprM (IH 0%N) //. + by have /adjoin_separableP-> := sepKx; rewrite ?rpredX ?memv_adjoin. +set K' := <>%VS; have sKK': (K <= K')%VS := subv_adjoin _ _. +pose q := minPoly K' x; pose g := 'X^p - (x ^+ p)%:P. +have [K'g]: g \is a polyOver K' /\ q \is a polyOver K'. + by rewrite minPolyOver rpredB ?rpredX ?polyOverX // polyOverC memv_adjoin. +have /dvdpP[c Dq]: 'X - x%:P %| q by rewrite dvdp_XsubCl root_minPoly. +have co_c_g: coprimep c g. + have charPp: p \in [char {poly L}] := rmorph_char (polyC_rmorphism _) charLp. + rewrite /g polyC_exp -!(Frobenius_autE charPp) -rmorphB coprimep_expr //. + have: separable_poly q := separable_elementS sKK' sepKx. + by rewrite Dq separable_mul => /and3P[]. +have{g K'g co_c_g} /size_poly1P[a nz_a Dc]: size c == 1%N. + suffices c_dv_g: c %| g by rewrite -(eqp_size (dvdp_gcd_idl c_dv_g)). + have: q %| g by rewrite minPoly_dvdp // rootE !hornerE hornerXn subrr. + by apply: dvdp_trans; rewrite Dq dvdp_mulIl. +rewrite {q}Dq {c}Dc mulrBr -rmorphM -rmorphN -cons_poly_def qualifE. +by rewrite polyseq_cons !polyseqC nz_a /= rpredN andbCA => /and3P[/fpredMl->]. +Qed. + +Lemma charf_n_separable K x n : + [char L].-nat n -> 1 < n -> separable_element K x = (x \in <>%VS). +Proof. +rewrite -pi_pdiv; set p := pdiv n => charLn pi_n_p. +have charLp: p \in [char L] := pnatPpi charLn pi_n_p. +have <-: (n`_p)%N = n by rewrite -(eq_partn n (charf_eq charLp)) part_pnat_id. +by rewrite p_part lognE -mem_primes pi_n_p -charf_p_separable. +Qed. + +Definition purely_inseparable_element U x := + x ^+ ex_minn (separable_exponent <> x) \in U. + +Lemma purely_inseparable_elementP {K x} : + reflect (exists2 n, [char L].-nat n & x ^+ n \in K) + (purely_inseparable_element K x). +Proof. +rewrite /purely_inseparable_element. +case: ex_minnP => n /andP[charLn /=]; rewrite subfield_closed => sepKxn min_xn. +apply: (iffP idP) => [Kxn | [m charLm Kxm]]; first by exists n. +have{min_xn}: n <= m by rewrite min_xn ?charLm ?base_separable. +rewrite leq_eqVlt => /predU1P[-> // | ltnm]; pose p := pdiv m. +have m_gt1: 1 < m by have [/leq_ltn_trans->] := andP charLn. +have charLp: p \in [char L] by rewrite (pnatPpi charLm) ?pi_pdiv. +have [/p_natP[em Dm] /p_natP[en Dn]]: p.-nat m /\ p.-nat n. + by rewrite -!(eq_pnat _ (charf_eq charLp)). +rewrite Dn Dm ltn_exp2l ?prime_gt1 ?pdiv_prime // in ltnm. +rewrite -(Fadjoin_idP Kxm) Dm -(subnKC ltnm) addSnnS expnD exprM -Dn. +by rewrite -charf_p_separable. +Qed. + +Lemma separable_inseparable_element K x : + separable_element K x && purely_inseparable_element K x = (x \in K). +Proof. +rewrite /purely_inseparable_element; case: ex_minnP => [[|m]] //=. +rewrite subfield_closed; case: m => /= [-> //| m _ /(_ 1%N)/implyP/= insepKx]. +by rewrite (negPf insepKx) (contraNF (@base_separable K x) insepKx). +Qed. + +Lemma base_inseparable K x : x \in K -> purely_inseparable_element K x. +Proof. by rewrite -separable_inseparable_element => /andP[]. Qed. + +Lemma sub_inseparable K E x : + (K <= E)%VS -> purely_inseparable_element K x -> + purely_inseparable_element E x. +Proof. +move/subvP=> sKE /purely_inseparable_elementP[n charLn /sKE Exn]. +by apply/purely_inseparable_elementP; exists n. +Qed. + +Section PrimitiveElementTheorem. + +Variables (K : {subfield L}) (x y : L). + +Section FiniteCase. + +Variable N : nat. + +Let K_is_large := exists s, [/\ uniq s, {subset s <= K} & N < size s]. + +Let cyclic_or_large (z : L) : z != 0 -> K_is_large \/ exists a, z ^+ a.+1 = 1. +Proof. +move=> nz_z; pose d := adjoin_degree K z. +pose h0 (i : 'I_(N ^ d).+1) (j : 'I_d) := (Fadjoin_poly K z (z ^+ i))`_j. +pose s := undup [seq h0 i j | i <- enum 'I_(N ^ d).+1, j <- enum 'I_d]. +have s_h0 i j: h0 i j \in s. + by rewrite mem_undup; apply/allpairsP; exists (i, j); rewrite !mem_enum. +pose h i := [ffun j => Ordinal (etrans (index_mem _ _) (s_h0 i j))]. +pose h' (f : {ffun 'I_d -> 'I_(size s)}) := \sum_(j < d) s`_(f j) * z ^+ j. +have hK i: h' (h i) = z ^+ i. + have Kz_zi: z ^+ i \in <>%VS by rewrite rpredX ?memv_adjoin. + rewrite -(Fadjoin_poly_eq Kz_zi) (horner_coef_wide z (size_poly _ _)) -/d. + by apply: eq_bigr => j _; rewrite ffunE /= nth_index. +have [inj_h | ] := altP (@injectiveP _ _ h). + left; exists s; split=> [|zi_j|]; rewrite ?undup_uniq ?mem_undup //=. + by case/allpairsP=> ij [_ _ ->]; apply/polyOverP/Fadjoin_polyOver. + rewrite -[size s]card_ord -(@ltn_exp2r _ _ d) // -{2}[d]card_ord -card_ffun. + by rewrite -[_.+1]card_ord -(card_image inj_h) max_card. +case/injectivePn=> i1 [i2 i1'2 /(congr1 h')]; rewrite !hK => eq_zi12; right. +without loss{i1'2} lti12: i1 i2 eq_zi12 / i1 < i2. + by move=> IH; move: i1'2; rewrite neq_ltn => /orP[]; apply: IH. +by exists (i2 - i1.+1)%N; rewrite subnSK ?expfB // eq_zi12 divff ?expf_neq0. +Qed. + +Lemma finite_PET : K_is_large \/ exists z, (<< <>; x>> = <>)%VS. +Proof. +have [-> | /cyclic_or_large[|[a Dxa]]] := eqVneq x 0; first 2 [by left]. + by rewrite addv0 subfield_closed; right; exists y. +have [-> | /cyclic_or_large[|[b Dyb]]] := eqVneq y 0; first 2 [by left]. + by rewrite addv0 subfield_closed; right; exists x. +pose h0 (ij : 'I_a.+1 * 'I_b.+1) := x ^+ ij.1 * y ^+ ij.2. +pose H := <<[set ij | h0 ij == 1%R]>>%G; pose h (u : coset_of H) := h0 (repr u). +have h0M: {morph h0: ij1 ij2 / (ij1 * ij2)%g >-> ij1 * ij2}. + by rewrite /h0 => [] [i1 j1] [i2 j2] /=; rewrite mulrACA -!exprD !expr_mod. +have memH ij: (ij \in H) = (h0 ij == 1). + rewrite /= gen_set_id ?inE //; apply/group_setP; rewrite inE [h0 _]mulr1. + by split=> // ? ?; rewrite !inE h0M => /eqP-> /eqP->; rewrite mulr1. +have nH ij: ij \in 'N(H)%g. + by apply/(subsetP (cent_sub _))/centP=> ij1 _; congr (_, _); rewrite Zp_mulgC. +have hE ij: h (coset H ij) = h0 ij. + rewrite /h val_coset //; case: repr_rcosetP => ij1. + by rewrite memH h0M => /eqP->; rewrite mul1r. +have h1: h 1%g = 1 by rewrite /h repr_coset1 [h0 _]mulr1. +have hM: {morph h: u v / (u * v)%g >-> u * v}. + by do 2![move=> u; have{u} [? _ ->] := cosetP u]; rewrite -morphM // !hE h0M. +have /cyclicP[w defW]: cyclic [set: coset_of H]. + apply: field_mul_group_cyclic (in2W hM) _ => u _; have [ij _ ->] := cosetP u. + by split=> [/eqP | -> //]; rewrite hE -memH => /coset_id. +have Kw_h ij t: h0 ij = t -> t \in <>%VS. + have /cycleP[k Dk]: coset H ij \in <[w]>%g by rewrite -defW inE. + rewrite -hE {}Dk => <-; elim: k => [|k IHk]; first by rewrite h1 rpred1. + by rewrite expgS hM rpredM // memv_adjoin. +right; exists (h w); apply/eqP; rewrite eqEsubv !(sameP FadjoinP andP). +rewrite subv_adjoin (subv_trans (subv_adjoin K y)) ?subv_adjoin //=. +rewrite (Kw_h (0, inZp 1)) 1?(Kw_h (inZp 1, 0)) /h0 ?mulr1 ?mul1r ?expr_mod //=. +by rewrite rpredM ?rpredX ?memv_adjoin // subvP_adjoin ?memv_adjoin. +Qed. + +End FiniteCase. + +Hypothesis sepKy : separable_element K y. + +Lemma Primitive_Element_Theorem : exists z, (<< <>; x>> = <>)%VS. +Proof. +have /polyOver_subvs[p Dp]: minPoly K x \is a polyOver K := minPolyOver K x. +have nz_pKx: minPoly K x != 0 by rewrite monic_neq0 ?monic_minPoly. +have{nz_pKx} nz_p: p != 0 by rewrite Dp map_poly_eq0 in nz_pKx. +have{Dp} px0: root (map_poly vsval p) x by rewrite -Dp root_minPoly. +have [q0 [Kq0 [q0y0 sepKq0]]] := separable_elementP sepKy. +have /polyOver_subvs[q Dq]: minPoly K y \is a polyOver K := minPolyOver K y. +have qy0: root (map_poly vsval q) y by rewrite -Dq root_minPoly. +have sep_pKy: separable_poly (minPoly K y). + by rewrite (dvdp_separable _ sepKq0) ?minPoly_dvdp. +have{sep_pKy} sep_q: separable_poly q by rewrite Dq separable_map in sep_pKy. +have [r [nz_r PETr]] := large_field_PET nz_p px0 qy0 sep_q. +have [[s [Us Ks /ltnW leNs]] | //] := finite_PET (size r). +have{s Us Ks leNs} /allPn[t /Ks Kt nz_rt]: ~~ all (root r) s. + by apply: contraTN leNs; rewrite -ltnNge => /max_poly_roots->. +have{PETr} [/= [p1 Dx] [q1 Dy]] := PETr (Subvs Kt) nz_rt. +set z := t * y - x in Dx Dy; exists z; apply/eqP. +rewrite eqEsubv !(sameP FadjoinP andP) subv_adjoin. +have Kz_p1z (r1 : {poly subvs_of K}): (map_poly vsval r1).[z] \in <>%VS. + rewrite rpred_horner ?memv_adjoin ?(polyOverSv (subv_adjoin K z)) //. + by apply/polyOver_subvs; exists r1. +rewrite -{1}Dx -{1}Dy !{Dx Dy}Kz_p1z /=. +rewrite (subv_trans (subv_adjoin K y)) ?subv_adjoin // rpredB ?memv_adjoin //. +by rewrite subvP_adjoin // rpredM ?memv_adjoin ?subvP_adjoin. +Qed. + +Lemma adjoin_separable : separable_element <> x -> separable_element K x. +Proof. +have /Derivation_separableP derKy := sepKy => /Derivation_separableP derKy_x. +have [z defKz] := Primitive_Element_Theorem. +suffices /adjoin_separableP: separable_element K z. + by apply; rewrite -defKz memv_adjoin. +apply/Derivation_separableP=> D; rewrite -defKz => derKxyD DK_0. +suffices derKyD: Derivation <>%VS D by rewrite derKy_x // derKy. +by apply: DerivationS derKxyD; apply: subv_adjoin. +Qed. + +End PrimitiveElementTheorem. + +Lemma strong_Primitive_Element_Theorem K x y : + separable_element <> y -> + exists2 z : L, (<< <>; x>> = <>)%VS + & separable_element K x -> separable_element K y. +Proof. +move=> sepKx_y; have [n /andP[charLn sepKyn]] := separable_exponent K y. +have adjK_C z t: (<<<>; t>> = <<<>; z>>)%VS. + by rewrite !agenv_add_id -!addvA (addvC <[_]>%VS). +have [z defKz] := Primitive_Element_Theorem x sepKyn. +exists z => [|/adjoin_separable->]; rewrite ?sepKx_y // -defKz. +have [|n_gt1|-> //] := ltngtP n 1%N; first by case: (n) charLn. +apply/eqP; rewrite !(adjK_C _ x) eqEsubv; apply/andP. +split; apply/FadjoinP/andP; rewrite subv_adjoin ?rpredX ?memv_adjoin //=. +by rewrite -charf_n_separable ?sepKx_y. +Qed. + +Definition separable U W : bool := + all (separable_element U) (vbasis W). + +Definition purely_inseparable U W : bool := + all (purely_inseparable_element U) (vbasis W). + +Lemma separable_add K x y : + separable_element K x -> separable_element K y -> separable_element K (x + y). +Proof. +move/(separable_elementS (subv_adjoin K y))=> sepKy_x sepKy. +have [z defKz] := Primitive_Element_Theorem x sepKy. +have /(adjoin_separableP _): x + y \in <>%VS. + by rewrite -defKz rpredD ?memv_adjoin // subvP_adjoin ?memv_adjoin. +apply; apply: adjoin_separable sepKy (adjoin_separable sepKy_x _). +by rewrite defKz base_separable ?memv_adjoin. +Qed. + +Lemma separable_sum I r (P : pred I) (v_ : I -> L) K : + (forall i, P i -> separable_element K (v_ i)) -> + separable_element K (\sum_(i <- r | P i) v_ i). +Proof. +move=> sepKi. +by elim/big_ind: _; [apply/base_separable/mem0v | apply: separable_add |]. +Qed. + +Lemma inseparable_add K x y : + purely_inseparable_element K x -> purely_inseparable_element K y -> + purely_inseparable_element K (x + y). +Proof. +have insepP := purely_inseparable_elementP. +move=> /insepP[n charLn Kxn] /insepP[m charLm Kym]; apply/insepP. +have charLnm: [char L].-nat (n * m)%N by rewrite pnat_mul charLn. +by exists (n * m)%N; rewrite ?exprDn_char // {2}mulnC !exprM memvD // rpredX. +Qed. + +Lemma inseparable_sum I r (P : pred I) (v_ : I -> L) K : + (forall i, P i -> purely_inseparable_element K (v_ i)) -> + purely_inseparable_element K (\sum_(i <- r | P i) v_ i). +Proof. +move=> insepKi. +by elim/big_ind: _; [apply/base_inseparable/mem0v | apply: inseparable_add |]. +Qed. + +Lemma separableP {K E} : + reflect (forall y, y \in E -> separable_element K y) (separable K E). +Proof. +apply/(iffP idP)=> [/allP|] sepK_E; last by apply/allP=> x /vbasis_mem/sepK_E. +move=> y /coord_vbasis->; apply/separable_sum=> i _. +have: separable_element K (vbasis E)`_i by apply/sepK_E/memt_nth. +by move/adjoin_separableP; apply; rewrite rpredZ ?memv_adjoin. +Qed. + +Lemma purely_inseparableP {K E} : + reflect (forall y, y \in E -> purely_inseparable_element K y) + (purely_inseparable K E). +Proof. +apply/(iffP idP)=> [/allP|] sep'K_E; last by apply/allP=> x /vbasis_mem/sep'K_E. +move=> y /coord_vbasis->; apply/inseparable_sum=> i _. +have: purely_inseparable_element K (vbasis E)`_i by apply/sep'K_E/memt_nth. +case/purely_inseparable_elementP=> n charLn K_Ein. +by apply/purely_inseparable_elementP; exists n; rewrite // exprZn rpredZ. +Qed. + +Lemma adjoin_separable_eq K x : separable_element K x = separable K <>%VS. +Proof. exact: sameP adjoin_separableP separableP. Qed. + +Lemma separable_inseparable_decomposition E K : + {x | x \in E /\ separable_element K x & purely_inseparable <> E}. +Proof. +without loss sKE: K / (K <= E)%VS. + case/(_ _ (capvSr K E)) => x [Ex sepKEx] /purely_inseparableP sep'KExE. + exists x; first by split; last exact/(separable_elementS _ sepKEx)/capvSl. + apply/purely_inseparableP=> y /sep'KExE; apply: sub_inseparable. + exact/adjoinSl/capvSl. +pose E_ i := (vbasis E)`_i; pose fP i := separable_exponent K (E_ i). +pose f i := E_ i ^+ ex_minn (fP i); pose s := mkseq f (\dim E). +pose K' := <>%VS. +have sepKs: all (separable_element K) s. + by rewrite all_map /f; apply/allP=> i _ /=; case: ex_minnP => m /andP[]. +have [x sepKx defKx]: {x | x \in E /\ separable_element K x & K' = <>%VS}. + have: all (mem E) s. + rewrite all_map; apply/allP=> i; rewrite mem_iota => ltis /=. + by rewrite rpredX // vbasis_mem // memt_nth. + rewrite {}/K'; elim/last_ind: s sepKs => [|s t IHs]. + by exists 0; [rewrite base_separable mem0v | rewrite adjoin_nil addv0]. + rewrite adjoin_rcons !all_rcons => /andP[sepKt sepKs] /andP[/= Et Es]. + have{IHs sepKs Es} [y [Ey sepKy] ->{s}] := IHs sepKs Es. + have /sig_eqW[x defKx] := Primitive_Element_Theorem t sepKy. + exists x; [split | exact: defKx]. + suffices: (<> <= E)%VS by case/FadjoinP. + by rewrite -defKx !(sameP FadjoinP andP) sKE Ey Et. + apply/adjoin_separableP=> z; rewrite -defKx => Kyt_z. + apply: adjoin_separable sepKy _; apply: adjoin_separableP Kyt_z. + exact: separable_elementS (subv_adjoin K y) sepKt. +exists x; rewrite // -defKx; apply/(all_nthP 0)=> i; rewrite size_tuple => ltiE. +apply/purely_inseparable_elementP. +exists (ex_minn (fP i)); first by case: ex_minnP => n /andP[]. +by apply/seqv_sub_adjoin/map_f; rewrite mem_iota. +Qed. + +Definition separable_generator K E : L := + s2val (locked (separable_inseparable_decomposition E K)). + +Lemma separable_generator_mem E K : separable_generator K E \in E. +Proof. by rewrite /separable_generator; case: (locked _) => ? []. Qed. + +Lemma separable_generatorP E K : separable_element K (separable_generator K E). +Proof. by rewrite /separable_generator; case: (locked _) => ? []. Qed. + +Lemma separable_generator_maximal E K : + purely_inseparable <> E. +Proof. by rewrite /separable_generator; case: (locked _). Qed. + +Lemma sub_adjoin_separable_generator E K : + separable K E -> (E <= <>)%VS. +Proof. +move/separableP=> sepK_E; apply/subvP=> v Ev. +rewrite -separable_inseparable_element. +have /purely_inseparableP-> // := separable_generator_maximal E K. +by rewrite (separable_elementS _ (sepK_E _ Ev)) // subv_adjoin. +Qed. + +Lemma eq_adjoin_separable_generator E K : + separable K E -> (K <= E)%VS -> + E = <>%VS :> {vspace _}. +Proof. +move=> sepK_E sKE; apply/eqP; rewrite eqEsubv sub_adjoin_separable_generator //. +by apply/FadjoinP/andP; rewrite sKE separable_generator_mem. +Qed. + +Lemma separable_refl K : separable K K. +Proof. by apply/separableP; apply: base_separable. Qed. + +Lemma separable_trans M K E : separable K M -> separable M E -> separable K E. +Proof. +move/sub_adjoin_separable_generator. +set x := separable_generator K M => sMKx /separableP sepM_E. +apply/separableP => w /sepM_E/(separable_elementS sMKx). +case/strong_Primitive_Element_Theorem => _ _ -> //. +exact: separable_generatorP. +Qed. + +Lemma separableS K1 K2 E2 E1 : + (K1 <= K2)%VS -> (E2 <= E1)%VS -> separable K1 E1 -> separable K2 E2. +Proof. +move=> sK12 /subvP sE21 /separableP sepK1_E1. +by apply/separableP=> y /sE21/sepK1_E1/(separable_elementS sK12). +Qed. + +Lemma separableSl K M E : (K <= M)%VS -> separable K E -> separable M E. +Proof. by move/separableS; apply. Qed. + +Lemma separableSr K M E : (M <= E)%VS -> separable K E -> separable K M. +Proof. exact: separableS. Qed. + +Lemma separable_Fadjoin_seq K rs : + all (separable_element K) rs -> separable K <>. +Proof. +elim/last_ind: rs => [|s x IHs] in K *. + by rewrite adjoin_nil subfield_closed separable_refl. +rewrite all_rcons adjoin_rcons => /andP[sepKx /IHs/separable_trans-> //]. +by rewrite -adjoin_separable_eq (separable_elementS _ sepKx) ?subv_adjoin_seq. +Qed. + +Lemma purely_inseparable_refl K : purely_inseparable K K. +Proof. by apply/purely_inseparableP; apply: base_inseparable. Qed. + +Lemma purely_inseparable_trans M K E : + purely_inseparable K M -> purely_inseparable M E -> purely_inseparable K E. +Proof. +have insepP := purely_inseparableP => /insepP insepK_M /insepP insepM_E. +have insepPe := purely_inseparable_elementP. +apply/insepP=> x /insepM_E/insepPe[n charLn /insepK_M/insepPe[m charLm Kxnm]]. +by apply/insepPe; exists (n * m)%N; rewrite ?exprM // pnat_mul charLn charLm. +Qed. + +End Separable. + +Implicit Arguments separable_elementP [F L K x]. +Implicit Arguments separablePn [F L K x]. +Implicit Arguments Derivation_separableP [F L K x]. +Implicit Arguments adjoin_separableP [F L K x]. +Implicit Arguments purely_inseparable_elementP [F L K x]. +Implicit Arguments separableP [F L K E]. +Implicit Arguments purely_inseparableP [F L K E]. diff --git a/mathcomp/fingroup/action.v b/mathcomp/fingroup/action.v new file mode 100644 index 0000000..902e9ca --- /dev/null +++ b/mathcomp/fingroup/action.v @@ -0,0 +1,2719 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat div seq fintype. +Require Import bigop finset fingroup morphism perm automorphism quotient. + +(******************************************************************************) +(* Group action: orbits, stabilisers, transitivity. *) +(* is_action D to == the function to : T -> aT -> T defines an action *) +(* of D : {set aT} on T. *) +(* action D T == structure for a function defining an action of D. *) +(* act_dom to == the domain D of to : action D rT. *) +(* {action: aT &-> T} == structure for a total action. *) +(* := action [set: aT] T *) +(* TotalAction to1 toM == the constructor for total actions; to1 and toM *) +(* are the proofs of the action identities for 1 and *) +(* a * b, respectively. *) +(* is_groupAction R to == to is a group action on range R: for all a in D, *) +(* the permutation induced by to a is in Aut R. Thus *) +(* the action of D must be trivial outside R. *) +(* groupAction D R == the structure for group actions of D on R. This *) +(* is a telescope on action D rT. *) +(* gact_range to == the range R of to : groupAction D R. *) +(* GroupAction toAut == construct a groupAction for action to from *) +(* toAut : actm to @* D \subset Aut R (actm to is *) +(* the morphism to {perm rT} associated to 'to'). *) +(* orbit to A x == the orbit of x under the action of A via to. *) +(* orbit_transversal to A S == a transversal of the partition orbit to A @: S *) +(* of S, provided A acts on S via to. *) +(* amove to A x y == the set of a in A whose action send x to y. *) +(* 'C_A[x | to] == the stabiliser of x : rT in A :&: D. *) +(* 'C_A(S | to) == the point-wise stabiliser of S : {set rT} in D :&: A. *) +(* 'N_A(S | to) == the global stabiliser of S : {set rT} in D :&: A. *) +(* 'Fix_(S | to)[a] == the set of fixpoints of a in S. *) +(* 'Fix_(S | to)(A) == the set of fixpoints of A in S. *) +(* In the first three _A can be omitted and defaults to the domain D of to; *) +(* In the last two S can be omitted and defaults to [set: T], so 'Fix_to[a] *) +(* is the set of all fixpoints of a. *) +(* The domain restriction ensures that stabilisers have a canonical group *) +(* structure, but note that 'Fix sets are generally not groups. Indeed, we *) +(* provide alternative definitions when to is a group action on R: *) +(* 'C_(G | to)(A) == the centraliser in R :&: G of the group action of *) +(* D :&: A via to *) +(* 'C_(G | to)[a] == the centraliser in R :&: G of a \in D, via to. *) +(* These sets are groups when G is. G can be omitted: 'C(|to)(A) is the *) +(* centraliser in R of the action of D :&: A via to. *) +(* [acts A, on S | to] == A \subset D acts on the set S via to. *) +(* {acts A, on S | to} == A acts on the set S (Prop statement). *) +(* {acts A, on group G | to} == [acts A, on S | to] /\ G \subset R, i.e., *) +(* A \subset D acts on G \subset R, via *) +(* to : groupAction D R. *) +(* [transitive A, on S | to] == A acts transitively on S. *) +(* [faithful A, on S | to] == A acts faithfully on S. *) +(* acts_irreducibly to A G == A acts irreducibly via the groupAction to *) +(* on the nontrivial group G, i.e., A does *) +(* not act on any nontrivial subgroup of G. *) +(* Important caveat: the definitions of orbit, amove, 'Fix_(S | to)(A), *) +(* transitive and faithful assume that A is a subset of the domain D. As most *) +(* of the permutation actions we consider are total this is usually harmless. *) +(* (Note that the theory of partial actions is only partially developed.) *) +(* In all of the above, to is expected to be the actual action structure, *) +(* not merely the function. There is a special scope %act for actions, and *) +(* constructions and notations for many classical actions: *) +(* 'P == natural action of a permutation group via aperm. *) +(* 'J == internal group action (conjugation) via conjg (_ ^ _). *) +(* 'R == regular group action (right translation) via mulg (_ * _). *) +(* (but, to limit ambiguity, _ * _ is NOT a canonical action) *) +(* to^* == the action induced by to on {set rT} via to^* (== setact to). *) +(* 'Js == the internal action on subsets via _ :^ _, equivalent to 'J^*. *) +(* 'Rs == the regular action on subsets via rcoset, equivalent to 'R^*. *) +(* 'JG == the conjugation action on {group rT} via (_ :^ _)%G. *) +(* to / H == the action induced by to on coset_of H via qact to H, and *) +(* restricted to qact_dom to H == 'N(rcosets H 'N(H) | to^* ). *) +(* 'Q == the action induced to cosets by conjugation; the domain is *) +(* qact_dom 'J H, which is provably equal to 'N(H). *) +(* to %% A == the action of coset_of A via modact to A, with domain D / A *) +(* and support restricted to 'C(D :&: A | to). *) +(* to \ sAD == the action of A via ract to sAD == to, if sAD : A \subset D. *) +(* [Aut G] == the permutation action restricted to Aut G, via autact G. *) +(* <[nRA]> == the action of A on R via actby nRA == to in A and on R, and *) +(* the trivial action elsewhere; here nRA : [acts A, on R | to] *) +(* or nRA : {acts A, on group R | to}. *) +(* to^? == the action induced by to on sT : @subType rT P, via subact to *) +(* with domain subact_dom P to == 'N([set x | P x] | to). *) +(* <> == the action of phi : D >-> {perm rT}, via mact phi. *) +(* to \o f == the composite action (with domain f @*^-1 D) of the action to *) +(* with f : {morphism G >-> aT}, via comp_act to f. Here f must *) +(* be the actual morphism object (e.g., coset_morphism H), not *) +(* the underlying function (e.g., coset H). *) +(* The explicit application of an action to is usually written (to%act x a), *) +(* where the %act omitted if to is an abstract action or a set action to0^*. *) +(* Note that this form will simplify and expose the acting function. *) +(* There is a %gact scope for group actions; the notations above are *) +(* recognised in %gact when they denote canonical group actions. *) +(* Actions can be used to define morphisms: *) +(* actperm to == the morphism D >-> {perm rT} induced by to. *) +(* actm to a == if a \in D the function on D induced by the action to, else *) +(* the identity function. If to is a group action with range R *) +(* then actm to a is canonically a morphism on R. *) +(* We also define here the restriction operation on permutations (the domain *) +(* of this operations is a stabiliser), and local automorphpism groups: *) +(* restr_perm S p == if p acts on S, the permutation with support in S that *) +(* coincides with p on S; else the identity. Note that *) +(* restr_perm is a permutation group morphism that maps *) +(* Aut G to Aut S when S is a subgroup of G. *) +(* Aut_in A G == the local permutation group 'N_A(G | 'P) / 'C_A(G | 'P) *) +(* Usually A is an automorphism group, and then Aut_in A G *) +(* is isomorphic to a subgroup of Aut G, specifically *) +(* restr_perm @* A. *) +(* Finally, gproduct.v will provide a semi-direct group construction that *) +(* maps an external group action to an internal one; the theory of morphisms *) +(* between such products makes use of the following definition: *) +(* morph_act to to' f fA <=> the action of to' on the images of f and fA is *) +(* the image of the action of to, i.e., for all x and a we *) +(* have f (to x a) = to' (f x) (fA a). Note that there is *) +(* no mention of the domains of to and to'; if needed, this *) +(* predicate should be restricted via the {in ...} notation *) +(* and domain conditions should be added. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section ActionDef. + +Variables (aT : finGroupType) (D : {set aT}) (rT : Type). +Implicit Types a b : aT. +Implicit Type x : rT. + +Definition act_morph to x := forall a b, to x (a * b) = to (to x a) b. + +Definition is_action to := + left_injective to /\ forall x, {in D &, act_morph to x}. + +Record action := Action {act :> rT -> aT -> rT; _ : is_action act}. + +Definition clone_action to := + let: Action _ toP := to return {type of Action for to} -> action in + fun k => k toP. + +End ActionDef. + +(* Need to close the Section here to avoid re-declaring all Argument Scopes *) +Delimit Scope action_scope with act. +Bind Scope action_scope with action. +Arguments Scope act_morph [_ group_scope _ _ group_scope]. +Arguments Scope is_action [_ group_scope _ _]. +Arguments Scope act + [_ group_scope type_scope action_scope group_scope group_scope]. +Arguments Scope clone_action [_ group_scope type_scope action_scope _]. + +Notation "{ 'action' aT &-> T }" := (action [set: aT] T) + (at level 0, format "{ 'action' aT &-> T }") : type_scope. + +Notation "[ 'action' 'of' to ]" := (clone_action (@Action _ _ _ to)) + (at level 0, format "[ 'action' 'of' to ]") : form_scope. + +Definition act_dom aT D rT of @action aT D rT := D. + +Section TotalAction. + +Variables (aT : finGroupType) (rT : Type) (to : rT -> aT -> rT). +Hypotheses (to1 : to^~ 1 =1 id) (toM : forall x, act_morph to x). + +Lemma is_total_action : is_action setT to. +Proof. +split=> [a | x a b _ _] /=; last by rewrite toM. +by apply: can_inj (to^~ a^-1) _ => x; rewrite -toM ?mulgV. +Qed. + +Definition TotalAction := Action is_total_action. + +End TotalAction. + +Section ActionDefs. + +Variables (aT aT' : finGroupType) (D : {set aT}) (D' : {set aT'}). + +Definition morph_act rT rT' (to : action D rT) (to' : action D' rT') f fA := + forall x a, f (to x a) = to' (f x) (fA a). + +Variable rT : finType. (* Most definitions require a finType structure on rT *) +Implicit Type to : action D rT. +Implicit Type A : {set aT}. +Implicit Type S : {set rT}. + +Definition actm to a := if a \in D then to^~ a else id. + +Definition setact to S a := [set to x a | x in S]. + +Definition orbit to A x := to x @: A. + +Definition amove to A x y := [set a in A | to x a == y]. + +Definition afix to A := [set x | A \subset [set a | to x a == x]]. + +Definition astab S to := D :&: [set a | S \subset [set x | to x a == x]]. + +Definition astabs S to := D :&: [set a | S \subset to^~ a @^-1: S]. + +Definition acts_on A S to := {in A, forall a x, (to x a \in S) = (x \in S)}. + +Definition atrans A S to := S \in orbit to A @: S. + +Definition faithful A S to := A :&: astab S to \subset [1]. + +End ActionDefs. + +Arguments Scope setact [_ group_scope _ action_scope group_scope group_scope]. +Arguments Scope orbit [_ group_scope _ action_scope group_scope group_scope]. +Arguments Scope amove + [_ group_scope _ action_scope group_scope group_scope group_scope]. +Arguments Scope afix [_ group_scope _ action_scope group_scope]. +Arguments Scope astab [_ group_scope _ group_scope action_scope]. +Arguments Scope astabs [_ group_scope _ group_scope action_scope]. +Arguments Scope acts_on [_ group_scope _ group_scope group_scope action_scope]. +Arguments Scope atrans [_ group_scope _ group_scope group_scope action_scope]. +Arguments Scope faithful [_ group_scope _ group_scope group_scope action_scope]. + +Notation "to ^*" := (setact to) (at level 2, format "to ^*") : fun_scope. + +Prenex Implicits orbit amove. + +Notation "''Fix_' to ( A )" := (afix to A) + (at level 8, to at level 2, format "''Fix_' to ( A )") : group_scope. + +(* camlp4 grammar factoring *) +Notation "''Fix_' ( to ) ( A )" := 'Fix_to(A) + (at level 8, only parsing) : group_scope. + +Notation "''Fix_' ( S | to ) ( A )" := (S :&: 'Fix_to(A)) + (at level 8, format "''Fix_' ( S | to ) ( A )") : group_scope. + +Notation "''Fix_' to [ a ]" := ('Fix_to([set a])) + (at level 8, to at level 2, format "''Fix_' to [ a ]") : group_scope. + +Notation "''Fix_' ( S | to ) [ a ]" := (S :&: 'Fix_to[a]) + (at level 8, format "''Fix_' ( S | to ) [ a ]") : group_scope. + +Notation "''C' ( S | to )" := (astab S to) + (at level 8, format "''C' ( S | to )") : group_scope. + +Notation "''C_' A ( S | to )" := (A :&: 'C(S | to)) + (at level 8, A at level 2, format "''C_' A ( S | to )") : group_scope. +Notation "''C_' ( A ) ( S | to )" := 'C_A(S | to) + (at level 8, only parsing) : group_scope. + +Notation "''C' [ x | to ]" := ('C([set x] | to)) + (at level 8, format "''C' [ x | to ]") : group_scope. + +Notation "''C_' A [ x | to ]" := (A :&: 'C[x | to]) + (at level 8, A at level 2, format "''C_' A [ x | to ]") : group_scope. +Notation "''C_' ( A ) [ x | to ]" := 'C_A[x | to] + (at level 8, only parsing) : group_scope. + +Notation "''N' ( S | to )" := (astabs S to) + (at level 8, format "''N' ( S | to )") : group_scope. + +Notation "''N_' A ( S | to )" := (A :&: 'N(S | to)) + (at level 8, A at level 2, format "''N_' A ( S | to )") : group_scope. + +Notation "[ 'acts' A , 'on' S | to ]" := (A \subset pred_of_set 'N(S | to)) + (at level 0, format "[ 'acts' A , 'on' S | to ]") : form_scope. + +Notation "{ 'acts' A , 'on' S | to }" := (acts_on A S to) + (at level 0, format "{ 'acts' A , 'on' S | to }") : form_scope. + +Notation "[ 'transitive' A , 'on' S | to ]" := (atrans A S to) + (at level 0, format "[ 'transitive' A , 'on' S | to ]") : form_scope. + +Notation "[ 'faithful' A , 'on' S | to ]" := (faithful A S to) + (at level 0, format "[ 'faithful' A , 'on' S | to ]") : form_scope. + +Section RawAction. +(* Lemmas that do not require the group structure on the action domain. *) +(* Some lemmas like actMin would be actually be valid for arbitrary rT, *) +(* e.g., for actions on a function type, but would be difficult to use *) +(* as a view due to the confusion between parameters and assumptions. *) + +Variables (aT : finGroupType) (D : {set aT}) (rT : finType) (to : action D rT). + +Implicit Types (a : aT) (x y : rT) (A B : {set aT}) (S T : {set rT}). + +Lemma act_inj : left_injective to. Proof. by case: to => ? []. Qed. +Implicit Arguments act_inj []. + +Lemma actMin x : {in D &, act_morph to x}. +Proof. by case: to => ? []. Qed. + +Lemma actmEfun a : a \in D -> actm to a = to^~ a. +Proof. by rewrite /actm => ->. Qed. + +Lemma actmE a : a \in D -> actm to a =1 to^~ a. +Proof. by move=> Da; rewrite actmEfun. Qed. + +Lemma setactE S a : to^* S a = [set to x a | x in S]. +Proof. by []. Qed. + +Lemma mem_setact S a x : x \in S -> to x a \in to^* S a. +Proof. exact: mem_imset. Qed. + +Lemma card_setact S a : #|to^* S a| = #|S|. +Proof. by apply: card_imset; exact: act_inj. Qed. + +Lemma setact_is_action : is_action D to^*. +Proof. +split=> [a R S eqRS | a b Da Db S]; last first. + rewrite /setact /= -imset_comp; apply: eq_imset => x; exact: actMin. +apply/setP=> x; apply/idP/idP=> /(mem_setact a). + by rewrite eqRS => /imsetP[y Sy /act_inj->]. +by rewrite -eqRS => /imsetP[y Sy /act_inj->]. +Qed. + +Canonical set_action := Action setact_is_action. + +Lemma orbitE A x : orbit to A x = to x @: A. Proof. by []. Qed. + +Lemma orbitP A x y : + reflect (exists2 a, a \in A & to x a = y) (y \in orbit to A x). +Proof. by apply: (iffP imsetP) => [] [a]; exists a. Qed. + +Lemma mem_orbit A x a : a \in A -> to x a \in orbit to A x. +Proof. exact: mem_imset. Qed. + +Lemma afixP A x : reflect (forall a, a \in A -> to x a = x) (x \in 'Fix_to(A)). +Proof. +rewrite inE; apply: (iffP subsetP) => [xfix a /xfix | xfix a Aa]. + by rewrite inE => /eqP. +by rewrite inE xfix. +Qed. + +Lemma afixS A B : A \subset B -> 'Fix_to(B) \subset 'Fix_to(A). +Proof. by move=> sAB; apply/subsetP=> u; rewrite !inE; exact: subset_trans. Qed. + +Lemma afixU A B : 'Fix_to(A :|: B) = 'Fix_to(A) :&: 'Fix_to(B). +Proof. by apply/setP=> x; rewrite !inE subUset. Qed. + +Lemma afix1P a x : reflect (to x a = x) (x \in 'Fix_to[a]). +Proof. by rewrite inE sub1set inE; exact: eqP. Qed. + +Lemma astabIdom S : 'C_D(S | to) = 'C(S | to). +Proof. by rewrite setIA setIid. Qed. + +Lemma astab_dom S : {subset 'C(S | to) <= D}. +Proof. by move=> a /setIP[]. Qed. + +Lemma astab_act S a x : a \in 'C(S | to) -> x \in S -> to x a = x. +Proof. +rewrite 2!inE => /andP[_ cSa] Sx; apply/eqP. +by have:= subsetP cSa x Sx; rewrite inE. +Qed. + +Lemma astabS S1 S2 : S1 \subset S2 -> 'C(S2 | to) \subset 'C(S1 | to). +Proof. +move=> sS12; apply/subsetP=> x; rewrite !inE => /andP[->]. +exact: subset_trans. +Qed. + +Lemma astabsIdom S : 'N_D(S | to) = 'N(S | to). +Proof. by rewrite setIA setIid. Qed. + +Lemma astabs_dom S : {subset 'N(S | to) <= D}. +Proof. by move=> a /setIdP[]. Qed. + +Lemma astabs_act S a x : a \in 'N(S | to) -> (to x a \in S) = (x \in S). +Proof. +rewrite 2!inE subEproper properEcard => /andP[_]. +rewrite (card_preimset _ (act_inj _)) ltnn andbF orbF => /eqP{2}->. +by rewrite inE. +Qed. + +Lemma astab_sub S : 'C(S | to) \subset 'N(S | to). +Proof. +apply/subsetP=> a cSa; rewrite !inE (astab_dom cSa). +by apply/subsetP=> x Sx; rewrite inE (astab_act cSa). +Qed. + +Lemma astabsC S : 'N(~: S | to) = 'N(S | to). +Proof. +apply/setP=> a; apply/idP/idP=> nSa; rewrite !inE (astabs_dom nSa). + by rewrite -setCS -preimsetC; apply/subsetP=> x; rewrite inE astabs_act. +by rewrite preimsetC setCS; apply/subsetP=> x; rewrite inE astabs_act. +Qed. + +Lemma astabsI S T : 'N(S | to) :&: 'N(T | to) \subset 'N(S :&: T | to). +Proof. +apply/subsetP=> a; rewrite !inE -!andbA preimsetI => /and4P[-> nSa _ nTa] /=. +by rewrite setISS. +Qed. + +Lemma astabs_setact S a : a \in 'N(S | to) -> to^* S a = S. +Proof. +move=> nSa; apply/eqP; rewrite eqEcard card_setact leqnn andbT. +by apply/subsetP=> _ /imsetP[x Sx ->]; rewrite astabs_act. +Qed. + +Lemma astab1_set S : 'C[S | set_action] = 'N(S | to). +Proof. +apply/setP=> a; apply/idP/idP=> nSa. + case/setIdP: nSa => Da; rewrite !inE Da sub1set inE => /eqP defS. + by apply/subsetP=> x Sx; rewrite inE -defS mem_setact. +by rewrite !inE (astabs_dom nSa) sub1set inE /= astabs_setact. +Qed. + +Lemma astabs_set1 x : 'N([set x] | to) = 'C[x | to]. +Proof. +apply/eqP; rewrite eqEsubset astab_sub andbC setIS //. +by apply/subsetP=> a; rewrite ?(inE,sub1set). +Qed. + +Lemma acts_dom A S : [acts A, on S | to] -> A \subset D. +Proof. by move=> nSA; rewrite (subset_trans nSA) ?subsetIl. Qed. + +Lemma acts_act A S : [acts A, on S | to] -> {acts A, on S | to}. +Proof. by move=> nAS a Aa x; rewrite astabs_act ?(subsetP nAS). Qed. + +Lemma astabCin A S : + A \subset D -> (A \subset 'C(S | to)) = (S \subset 'Fix_to(A)). +Proof. +move=> sAD; apply/subsetP/subsetP=> [sAC x xS | sSF a aA]. + by apply/afixP=> a aA; exact: astab_act (sAC _ aA) xS. +rewrite !inE (subsetP sAD _ aA); apply/subsetP=> x xS. +by move/afixP/(_ _ aA): (sSF _ xS); rewrite inE => ->. +Qed. + +Section ActsSetop. + +Variables (A : {set aT}) (S T : {set rT}). +Hypotheses (AactS : [acts A, on S | to]) (AactT : [acts A, on T | to]). + +Lemma astabU : 'C(S :|: T | to) = 'C(S | to) :&: 'C(T | to). +Proof. by apply/setP=> a; rewrite !inE subUset; case: (a \in D). Qed. + +Lemma astabsU : 'N(S | to) :&: 'N(T | to) \subset 'N(S :|: T | to). +Proof. +by rewrite -(astabsC S) -(astabsC T) -(astabsC (S :|: T)) setCU astabsI. +Qed. + +Lemma astabsD : 'N(S | to) :&: 'N(T | to) \subset 'N(S :\: T| to). +Proof. by rewrite setDE -(astabsC T) astabsI. Qed. + +Lemma actsI : [acts A, on S :&: T | to]. +Proof. by apply: subset_trans (astabsI S T); rewrite subsetI AactS. Qed. + +Lemma actsU : [acts A, on S :|: T | to]. +Proof. by apply: subset_trans astabsU; rewrite subsetI AactS. Qed. + +Lemma actsD : [acts A, on S :\: T | to]. +Proof. by apply: subset_trans astabsD; rewrite subsetI AactS. Qed. + +End ActsSetop. + +Lemma acts_in_orbit A S x y : + [acts A, on S | to] -> y \in orbit to A x -> x \in S -> y \in S. +Proof. +by move=> nSA/imsetP[a Aa ->{y}] Sx; rewrite (astabs_act _ (subsetP nSA a Aa)). +Qed. + +Lemma subset_faithful A B S : + B \subset A -> [faithful A, on S | to] -> [faithful B, on S | to]. +Proof. by move=> sAB; apply: subset_trans; exact: setSI. Qed. + +Section Reindex. + +Variables (vT : Type) (idx : vT) (op : Monoid.com_law idx) (S : {set rT}). + +Lemma reindex_astabs a F : a \in 'N(S | to) -> + \big[op/idx]_(i in S) F i = \big[op/idx]_(i in S) F (to i a). +Proof. +move=> nSa; rewrite (reindex_inj (act_inj a)); apply: eq_bigl => x. +exact: astabs_act. +Qed. + +Lemma reindex_acts A a F : [acts A, on S | to] -> a \in A -> + \big[op/idx]_(i in S) F i = \big[op/idx]_(i in S) F (to i a). +Proof. by move=> nSA /(subsetP nSA); exact: reindex_astabs. Qed. + +End Reindex. + +End RawAction. + +(* Warning: this directive depends on names of bound variables in the *) +(* definition of injective, in ssrfun.v. *) +Implicit Arguments act_inj [[aT] [D] [rT] x1 x2]. + +Notation "to ^*" := (set_action to) : action_scope. + +Implicit Arguments orbitP [aT D rT to A x y]. +Implicit Arguments afixP [aT D rT to A x]. +Implicit Arguments afix1P [aT D rT to a x]. +Prenex Implicits orbitP afixP afix1P. + +Implicit Arguments reindex_astabs [aT D rT vT idx op S F]. +Implicit Arguments reindex_acts [aT D rT vT idx op S A a F]. + +Section PartialAction. +(* Lemmas that require a (partial) group domain. *) + +Variables (aT : finGroupType) (D : {group aT}) (rT : finType). +Variable to : action D rT. + +Implicit Types a : aT. +Implicit Types x y : rT. +Implicit Types A B : {set aT}. +Implicit Types G H : {group aT}. +Implicit Types S : {set rT}. + +Lemma act1 x : to x 1 = x. +Proof. by apply: (act_inj to 1); rewrite -actMin ?mulg1. Qed. + +Lemma actKin : {in D, right_loop invg to}. +Proof. by move=> a Da /= x; rewrite -actMin ?groupV // mulgV act1. Qed. + +Lemma actKVin : {in D, rev_right_loop invg to}. +Proof. by move=> a Da /= x; rewrite -{2}(invgK a) actKin ?groupV. Qed. + +Lemma setactVin S a : a \in D -> to^* S a^-1 = to^~ a @^-1: S. +Proof. +by move=> Da; apply: can2_imset_pre; [exact: actKVin | exact: actKin]. +Qed. + +Lemma actXin x a i : a \in D -> to x (a ^+ i) = iter i (to^~ a) x. +Proof. +move=> Da; elim: i => /= [|i <-]; first by rewrite act1. +by rewrite expgSr actMin ?groupX. +Qed. + +Lemma afix1 : 'Fix_to(1) = setT. +Proof. by apply/setP=> x; rewrite !inE sub1set inE act1 eqxx. Qed. + +Lemma afixD1 G : 'Fix_to(G^#) = 'Fix_to(G). +Proof. by rewrite -{2}(setD1K (group1 G)) afixU afix1 setTI. Qed. + +Lemma orbit_refl G x : x \in orbit to G x. +Proof. by rewrite -{1}[x]act1 mem_orbit. Qed. + +Local Notation orbit_rel A := (fun x y => y \in orbit to A x). + +Lemma contra_orbit G x y : x \notin orbit to G y -> x != y. +Proof. by apply: contraNneq => ->; exact: orbit_refl. Qed. + +Lemma orbit_in_sym G : G \subset D -> symmetric (orbit_rel G). +Proof. +move=> sGD; apply: symmetric_from_pre => x y /imsetP[a Ga]. +by move/(canLR (actKin (subsetP sGD a Ga))) <-; rewrite mem_orbit ?groupV. +Qed. + +Lemma orbit_in_trans G : G \subset D -> transitive (orbit_rel G). +Proof. +move=> sGD _ x _ /imsetP[a Ga ->] /imsetP[b Gb ->]. +by rewrite -actMin ?mem_orbit ?groupM // (subsetP sGD). +Qed. + +Lemma orbit_in_transl G x y : + G \subset D -> y \in orbit to G x -> orbit to G y = orbit to G x. +Proof. +move=> sGD Gxy; apply/setP=> z. +by apply/idP/idP; apply: orbit_in_trans; rewrite // orbit_in_sym. +Qed. + +Lemma orbit_in_transr G x y z : + G \subset D -> y \in orbit to G x -> + (y \in orbit to G z) = (x \in orbit to G z). +Proof. +by move=> sGD Gxy; rewrite !(orbit_in_sym _ z) ?(orbit_in_transl _ Gxy). +Qed. + +Lemma orbit_act_in x a G : + G \subset D -> a \in G -> orbit to G (to x a) = orbit to G x. +Proof. by move=> sGD /mem_orbit/orbit_in_transl->. Qed. + +Lemma orbit_actr_in x a G y : + G \subset D -> a \in G -> (to y a \in orbit to G x) = (y \in orbit to G x). +Proof. by move=> sGD /mem_orbit/orbit_in_transr->. Qed. + +Lemma orbit_inv_in A x y : + A \subset D -> (y \in orbit to A^-1 x) = (x \in orbit to A y). +Proof. +move/subsetP=> sAD; apply/imsetP/imsetP=> [] [a Aa ->]. + by exists a^-1; rewrite -?mem_invg ?actKin // -groupV sAD -?mem_invg. +by exists a^-1; rewrite ?memV_invg ?actKin // sAD. +Qed. + +Lemma orbit_lcoset_in A a x : + A \subset D -> a \in D -> + orbit to (a *: A) x = orbit to A (to x a). +Proof. +move/subsetP=> sAD Da; apply/setP=> y; apply/imsetP/imsetP=> [] [b Ab ->{y}]. + by exists (a^-1 * b); rewrite -?actMin ?mulKVg // ?sAD -?mem_lcoset. +by exists (a * b); rewrite ?mem_mulg ?set11 ?actMin // sAD. +Qed. + +Lemma orbit_rcoset_in A a x y : + A \subset D -> a \in D -> + (to y a \in orbit to (A :* a) x) = (y \in orbit to A x). +Proof. +move=> sAD Da; rewrite -orbit_inv_in ?mul_subG ?sub1set // invMg. +by rewrite invg_set1 orbit_lcoset_in ?inv_subG ?groupV ?actKin ?orbit_inv_in. +Qed. + +Lemma orbit_conjsg_in A a x y : + A \subset D -> a \in D -> + (to y a \in orbit to (A :^ a) (to x a)) = (y \in orbit to A x). +Proof. +move=> sAD Da; rewrite conjsgE. +by rewrite orbit_lcoset_in ?groupV ?mul_subG ?sub1set ?actKin ?orbit_rcoset_in. +Qed. + +Lemma orbit1P G x : reflect (orbit to G x = [set x]) (x \in 'Fix_to(G)). +Proof. +apply: (iffP afixP) => [xfix | xfix a Ga]. + apply/eqP; rewrite eq_sym eqEsubset sub1set -{1}[x]act1 mem_imset //=. + by apply/subsetP=> y; case/imsetP=> a Ga ->; rewrite inE xfix. +by apply/set1P; rewrite -xfix mem_imset. +Qed. + +Lemma card_orbit1 G x : #|orbit to G x| = 1%N -> orbit to G x = [set x]. +Proof. +move=> orb1; apply/eqP; rewrite eq_sym eqEcard {}orb1 cards1. +by rewrite sub1set orbit_refl. +Qed. + +Lemma orbit_partition G S : + [acts G, on S | to] -> partition (orbit to G @: S) S. +Proof. +move=> actsGS; have sGD := acts_dom actsGS. +have eqiG: {in S & &, equivalence_rel [rel x y | y \in orbit to G x]}. + by move=> x y z * /=; rewrite orbit_refl; split=> // /orbit_in_transl->. +congr (partition _ _): (equivalence_partitionP eqiG). +apply: eq_in_imset => x Sx; apply/setP=> y. +by rewrite inE /= andb_idl // => /acts_in_orbit->. +Qed. + +Definition orbit_transversal A S := transversal (orbit to A @: S) S. + +Lemma orbit_transversalP G S (P := orbit to G @: S) + (X := orbit_transversal G S) : + [acts G, on S | to] -> + [/\ is_transversal X P S, X \subset S, + {in X &, forall x y, (y \in orbit to G x) = (x == y)} + & forall x, x \in S -> exists2 a, a \in G & to x a \in X]. +Proof. +move/orbit_partition; rewrite -/P => partP. +have [/eqP defS tiP _] := and3P partP. +have trXP: is_transversal X P S := transversalP partP. +have sXS: X \subset S := transversal_sub trXP. +split=> // [x y Xx Xy /= | x Sx]. + have Sx := subsetP sXS x Xx. + rewrite -(inj_in_eq (pblock_inj trXP)) // eq_pblock ?defS //. + by rewrite (def_pblock tiP (mem_imset _ Sx)) ?orbit_refl. +have /imsetP[y Xy defxG]: orbit to G x \in pblock P @: X. + by rewrite (pblock_transversal trXP) ?mem_imset. +suffices /orbitP[a Ga def_y]: y \in orbit to G x by exists a; rewrite ?def_y. +by rewrite defxG mem_pblock defS (subsetP sXS). +Qed. + +Lemma group_set_astab S : group_set 'C(S | to). +Proof. +apply/group_setP; split=> [|a b cSa cSb]. + by rewrite !inE group1; apply/subsetP=> x _; rewrite inE act1. +rewrite !inE groupM ?(@astab_dom _ _ _ to S) //; apply/subsetP=> x Sx. +by rewrite inE actMin ?(@astab_dom _ _ _ to S) ?(astab_act _ Sx). +Qed. + +Canonical astab_group S := group (group_set_astab S). + +Lemma afix_gen_in A : A \subset D -> 'Fix_to(<>) = 'Fix_to(A). +Proof. +move=> sAD; apply/eqP; rewrite eqEsubset afixS ?sub_gen //=. +by rewrite -astabCin gen_subG ?astabCin. +Qed. + +Lemma afix_cycle_in a : a \in D -> 'Fix_to(<[a]>) = 'Fix_to[a]. +Proof. by move=> Da; rewrite afix_gen_in ?sub1set. Qed. + +Lemma afixYin A B : + A \subset D -> B \subset D -> 'Fix_to(A <*> B) = 'Fix_to(A) :&: 'Fix_to(B). +Proof. by move=> sAD sBD; rewrite afix_gen_in ?afixU // subUset sAD. Qed. + +Lemma afixMin G H : + G \subset D -> H \subset D -> 'Fix_to(G * H) = 'Fix_to(G) :&: 'Fix_to(H). +Proof. +by move=> sGD sHD; rewrite -afix_gen_in ?mul_subG // genM_join afixYin. +Qed. + +Lemma sub_astab1_in A x : + A \subset D -> (A \subset 'C[x | to]) = (x \in 'Fix_to(A)). +Proof. by move=> sAD; rewrite astabCin ?sub1set. Qed. + +Lemma group_set_astabs S : group_set 'N(S | to). +Proof. +apply/group_setP; split=> [|a b cSa cSb]. + by rewrite !inE group1; apply/subsetP=> x Sx; rewrite inE act1. +rewrite !inE groupM ?(@astabs_dom _ _ _ to S) //; apply/subsetP=> x Sx. +by rewrite inE actMin ?(@astabs_dom _ _ _ to S) ?astabs_act. +Qed. + +Canonical astabs_group S := group (group_set_astabs S). + +Lemma astab_norm S : 'N(S | to) \subset 'N('C(S | to)). +Proof. +apply/subsetP=> a nSa; rewrite inE sub_conjg; apply/subsetP=> b cSb. +have [Da Db] := (astabs_dom nSa, astab_dom cSb). +rewrite mem_conjgV !inE groupJ //; apply/subsetP=> x Sx. +rewrite inE !actMin ?groupM ?groupV //. +by rewrite (astab_act cSb) ?actKVin ?astabs_act ?groupV. +Qed. + +Lemma astab_normal S : 'C(S | to) <| 'N(S | to). +Proof. by rewrite /normal astab_sub astab_norm. Qed. + +Lemma acts_sub_orbit G S x : + [acts G, on S | to] -> (orbit to G x \subset S) = (x \in S). +Proof. +move/acts_act=> GactS. +apply/subsetP/idP=> [| Sx y]; first by apply; exact: orbit_refl. +by case/orbitP=> a Ga <-{y}; rewrite GactS. +Qed. + +Lemma acts_orbit G x : G \subset D -> [acts G, on orbit to G x | to]. +Proof. +move/subsetP=> sGD; apply/subsetP=> a Ga; rewrite !inE sGD //. +apply/subsetP=> _ /imsetP[b Gb ->]. +by rewrite inE -actMin ?sGD // mem_imset ?groupM. +Qed. + +Lemma acts_subnorm_fix A : [acts 'N_D(A), on 'Fix_to(D :&: A) | to]. +Proof. +apply/subsetP=> a nAa; have [Da _] := setIP nAa; rewrite !inE Da. +apply/subsetP=> x Cx; rewrite inE; apply/afixP=> b DAb. +have [Db _]:= setIP DAb; rewrite -actMin // conjgCV actMin ?groupJ ?groupV //. +by rewrite /= (afixP Cx) // memJ_norm // groupV (subsetP (normsGI _ _) _ nAa). +Qed. + +Lemma atrans_orbit G x : [transitive G, on orbit to G x | to]. +Proof. by apply: mem_imset; exact: orbit_refl. Qed. + +Section OrbitStabilizer. + +Variables (G : {group aT}) (x : rT). +Hypothesis sGD : G \subset D. +Let ssGD := subsetP sGD. + +Lemma amove_act a : a \in G -> amove to G x (to x a) = 'C_G[x | to] :* a. +Proof. +move=> Ga; apply/setP=> b; have Da := ssGD Ga. +rewrite mem_rcoset !(inE, sub1set) !groupMr ?groupV //. +by case Gb: (b \in G); rewrite //= actMin ?groupV ?ssGD ?(canF_eq (actKVin Da)). +Qed. + +Lemma amove_orbit : amove to G x @: orbit to G x = rcosets 'C_G[x | to] G. +Proof. +apply/setP => Ha; apply/imsetP/rcosetsP=> [[y] | [a Ga ->]]. + by case/imsetP=> b Gb -> ->{Ha y}; exists b => //; rewrite amove_act. +by rewrite -amove_act //; exists (to x a); first exact: mem_orbit. +Qed. + +Lemma amoveK : + {in orbit to G x, cancel (amove to G x) (fun Ca => to x (repr Ca))}. +Proof. +move=> _ /orbitP[a Ga <-]; rewrite amove_act //= -[G :&: _]/(gval _). +case: repr_rcosetP => b; rewrite !(inE, sub1set)=> /and3P[Gb _ xbx]. +by rewrite actMin ?ssGD ?(eqP xbx). +Qed. + +Lemma orbit_stabilizer : + orbit to G x = [set to x (repr Ca) | Ca in rcosets 'C_G[x | to] G]. +Proof. +rewrite -amove_orbit -imset_comp /=; apply/setP=> z. +by apply/idP/imsetP=> [xGz | [y xGy ->]]; first exists z; rewrite /= ?amoveK. +Qed. + +Lemma act_reprK : + {in rcosets 'C_G[x | to] G, cancel (to x \o repr) (amove to G x)}. +Proof. +move=> _ /rcosetsP[a Ga ->] /=; rewrite amove_act ?rcoset_repr //. +rewrite -[G :&: _]/(gval _); case: repr_rcosetP => b /setIP[Gb _]. +exact: groupM. +Qed. + +End OrbitStabilizer. + +Lemma card_orbit_in G x : G \subset D -> #|orbit to G x| = #|G : 'C_G[x | to]|. +Proof. +move=> sGD; rewrite orbit_stabilizer 1?card_in_imset //. +exact: can_in_inj (act_reprK _). +Qed. + +Lemma card_orbit_in_stab G x : + G \subset D -> (#|orbit to G x| * #|'C_G[x | to]|)%N = #|G|. +Proof. by move=> sGD; rewrite mulnC card_orbit_in ?Lagrange ?subsetIl. Qed. + +Lemma acts_sum_card_orbit G S : + [acts G, on S | to] -> \sum_(T in orbit to G @: S) #|T| = #|S|. +Proof. by move/orbit_partition/card_partition. Qed. + +Lemma astab_setact_in S a : a \in D -> 'C(to^* S a | to) = 'C(S | to) :^ a. +Proof. +move=> Da; apply/setP=> b; rewrite mem_conjg !inE -mem_conjg conjGid //. +apply: andb_id2l => Db; rewrite sub_imset_pre; apply: eq_subset_r => x. +by rewrite !inE !actMin ?groupM ?groupV // invgK (canF_eq (actKVin Da)). +Qed. + +Lemma astab1_act_in x a : a \in D -> 'C[to x a | to] = 'C[x | to] :^ a. +Proof. by move=> Da; rewrite -astab_setact_in // /setact imset_set1. Qed. + +Theorem Frobenius_Cauchy G S : [acts G, on S | to] -> + \sum_(a in G) #|'Fix_(S | to)[a]| = (#|orbit to G @: S| * #|G|)%N. +Proof. +move=> GactS; have sGD := acts_dom GactS. +transitivity (\sum_(a in G) \sum_(x in 'Fix_(S | to)[a]) 1%N). + by apply: eq_bigr => a _; rewrite -sum1_card. +rewrite (exchange_big_dep (mem S)) /= => [|a x _]; last by case/setIP. +rewrite (set_partition_big _ (orbit_partition GactS)) -sum_nat_const /=. +apply: eq_bigr => _ /imsetP[x Sx ->]. +rewrite -(card_orbit_in_stab x sGD) -sum_nat_const. +apply: eq_bigr => y; rewrite orbit_in_sym // => /imsetP[a Ga defx]. +rewrite defx astab1_act_in ?(subsetP sGD) //. +rewrite -{2}(conjGid Ga) -conjIg cardJg -sum1_card setIA (setIidPl sGD). +by apply: eq_bigl => b; rewrite !(sub1set, inE) -(acts_act GactS Ga) -defx Sx. +Qed. + +Lemma atrans_dvd_index_in G S : + G \subset D -> [transitive G, on S | to] -> #|S| %| #|G : 'C_G(S | to)|. +Proof. +move=> sGD /imsetP[x Sx {1}->]; rewrite card_orbit_in //. +by rewrite indexgS // setIS // astabS // sub1set. +Qed. + +Lemma atrans_dvd_in G S : + G \subset D -> [transitive G, on S | to] -> #|S| %| #|G|. +Proof. +move=> sGD transG; apply: dvdn_trans (atrans_dvd_index_in sGD transG) _. +exact: dvdn_indexg. +Qed. + +Lemma atransPin G S : + G \subset D -> [transitive G, on S | to] -> + forall x, x \in S -> orbit to G x = S. +Proof. by move=> sGD /imsetP[y _ ->] x; exact: orbit_in_transl. Qed. + +Lemma atransP2in G S : + G \subset D -> [transitive G, on S | to] -> + {in S &, forall x y, exists2 a, a \in G & y = to x a}. +Proof. by move=> sGD transG x y /(atransPin sGD transG) <- /imsetP. Qed. + +Lemma atrans_acts_in G S : + G \subset D -> [transitive G, on S | to] -> [acts G, on S | to]. +Proof. +move=> sGD transG; apply/subsetP=> a Ga; rewrite !inE (subsetP sGD) //. +by apply/subsetP=> x /(atransPin sGD transG) <-; rewrite inE mem_imset. +Qed. + +Lemma subgroup_transitivePin G H S x : + x \in S -> H \subset G -> G \subset D -> [transitive G, on S | to] -> + reflect ('C_G[x | to] * H = G) [transitive H, on S | to]. +Proof. +move=> Sx sHG sGD trG; have sHD := subset_trans sHG sGD. +apply: (iffP idP) => [trH | defG]. + rewrite group_modr //; apply/setIidPl/subsetP=> a Ga. + have Sxa: to x a \in S by rewrite (acts_act (atrans_acts_in sGD trG)). + have [b Hb xab]:= atransP2in sHD trH Sxa Sx. + have Da := subsetP sGD a Ga; have Db := subsetP sHD b Hb. + rewrite -(mulgK b a) mem_mulg ?groupV // !inE groupM //= sub1set inE. + by rewrite actMin -?xab. +apply/imsetP; exists x => //; apply/setP=> y; rewrite -(atransPin sGD trG Sx). +apply/imsetP/imsetP=> [] [a]; last by exists a; first exact: (subsetP sHG). +rewrite -defG => /imset2P[c b /setIP[_ cxc] Hb ->] ->. +exists b; rewrite ?actMin ?(astab_dom cxc) ?(subsetP sHD) //. +by rewrite (astab_act cxc) ?inE. +Qed. + +End PartialAction. + +Arguments Scope orbit_transversal + [_ group_scope _ action_scope group_scope group_scope]. +Implicit Arguments orbit1P [aT D rT to G x]. +Implicit Arguments contra_orbit [aT D rT x y]. +Prenex Implicits orbit1P. + +Notation "''C' ( S | to )" := (astab_group to S) : Group_scope. +Notation "''C_' A ( S | to )" := (setI_group A 'C(S | to)) : Group_scope. +Notation "''C_' ( A ) ( S | to )" := (setI_group A 'C(S | to)) + (only parsing) : Group_scope. +Notation "''C' [ x | to ]" := (astab_group to [set x%g]) : Group_scope. +Notation "''C_' A [ x | to ]" := (setI_group A 'C[x | to]) : Group_scope. +Notation "''C_' ( A ) [ x | to ]" := (setI_group A 'C[x | to]) + (only parsing) : Group_scope. +Notation "''N' ( S | to )" := (astabs_group to S) : Group_scope. +Notation "''N_' A ( S | to )" := (setI_group A 'N(S | to)) : Group_scope. + +Section TotalActions. +(* These lemmas are only established for total actions (domain = [set: rT]) *) + +Variable (aT : finGroupType) (rT : finType). + +Variable to : {action aT &-> rT}. + +Implicit Types (a b : aT) (x y z : rT) (A B : {set aT}) (G H : {group aT}). +Implicit Type S : {set rT}. + +Lemma actM x a b : to x (a * b) = to (to x a) b. +Proof. by rewrite actMin ?inE. Qed. + +Lemma actK : right_loop invg to. +Proof. by move=> a; apply: actKin; rewrite inE. Qed. + +Lemma actKV : rev_right_loop invg to. +Proof. by move=> a; apply: actKVin; rewrite inE. Qed. + +Lemma actX x a n : to x (a ^+ n) = iter n (to^~ a) x. +Proof. by elim: n => [|n /= <-]; rewrite ?act1 // -actM expgSr. Qed. + +Lemma actCJ a b x : to (to x a) b = to (to x b) (a ^ b). +Proof. by rewrite !actM actK. Qed. + +Lemma actCJV a b x : to (to x a) b = to (to x (b ^ a^-1)) a. +Proof. by rewrite (actCJ _ a) conjgKV. Qed. + +Lemma orbit_sym G x y : (y \in orbit to G x) = (x \in orbit to G y). +Proof. by apply: orbit_in_sym; exact: subsetT. Qed. + +Lemma orbit_trans G x y z : + y \in orbit to G x -> z \in orbit to G y -> z \in orbit to G x. +Proof. by apply: orbit_in_trans; exact: subsetT. Qed. + +Lemma orbit_transl G x y : y \in orbit to G x -> orbit to G y = orbit to G x. +Proof. +move=> Gxy; apply/setP=> z; apply/idP/idP; apply: orbit_trans => //. +by rewrite orbit_sym. +Qed. + +Lemma orbit_transr G x y z : + y \in orbit to G x -> (y \in orbit to G z) = (x \in orbit to G z). +Proof. by move=> Gxy; rewrite orbit_sym (orbit_transl Gxy) orbit_sym. Qed. + +Lemma orbit_act G a x: a \in G -> orbit to G (to x a) = orbit to G x. +Proof. by move/mem_orbit/orbit_transl; exact. Qed. + +Lemma orbit_actr G a x y : + a \in G -> (to y a \in orbit to G x) = (y \in orbit to G x). +Proof. by move/mem_orbit/orbit_transr; exact. Qed. + +Lemma orbit_eq_mem G x y : + (orbit to G x == orbit to G y) = (x \in orbit to G y). +Proof. by apply/eqP/idP=> [<-|]; [exact: orbit_refl | exact: orbit_transl]. Qed. + +Lemma orbit_inv A x y : (y \in orbit to A^-1 x) = (x \in orbit to A y). +Proof. by rewrite orbit_inv_in ?subsetT. Qed. + +Lemma orbit_lcoset A a x : orbit to (a *: A) x = orbit to A (to x a). +Proof. by rewrite orbit_lcoset_in ?subsetT ?inE. Qed. + +Lemma orbit_rcoset A a x y : + (to y a \in orbit to (A :* a) x) = (y \in orbit to A x). +Proof. by rewrite orbit_rcoset_in ?subsetT ?inE. Qed. + +Lemma orbit_conjsg A a x y : + (to y a \in orbit to (A :^ a) (to x a)) = (y \in orbit to A x). +Proof. by rewrite orbit_conjsg_in ?subsetT ?inE. Qed. + +Lemma astabP S a : reflect (forall x, x \in S -> to x a = x) (a \in 'C(S | to)). +Proof. +apply: (iffP idP) => [cSa x|cSa]; first exact: astab_act. +by rewrite !inE; apply/subsetP=> x Sx; rewrite inE cSa. +Qed. + +Lemma astab1P x a : reflect (to x a = x) (a \in 'C[x | to]). +Proof. by rewrite !inE sub1set inE; exact: eqP. Qed. + +Lemma sub_astab1 A x : (A \subset 'C[x | to]) = (x \in 'Fix_to(A)). +Proof. by rewrite sub_astab1_in ?subsetT. Qed. + +Lemma astabC A S : (A \subset 'C(S | to)) = (S \subset 'Fix_to(A)). +Proof. by rewrite astabCin ?subsetT. Qed. + +Lemma afix_cycle a : 'Fix_to(<[a]>) = 'Fix_to[a]. +Proof. by rewrite afix_cycle_in ?inE. Qed. + +Lemma afix_gen A : 'Fix_to(<>) = 'Fix_to(A). +Proof. by rewrite afix_gen_in ?subsetT. Qed. + +Lemma afixM G H : 'Fix_to(G * H) = 'Fix_to(G) :&: 'Fix_to(H). +Proof. by rewrite afixMin ?subsetT. Qed. + +Lemma astabsP S a : + reflect (forall x, (to x a \in S) = (x \in S)) (a \in 'N(S | to)). +Proof. +apply: (iffP idP) => [nSa x|nSa]; first exact: astabs_act. +by rewrite !inE; apply/subsetP=> x; rewrite inE nSa. +Qed. + +Lemma card_orbit G x : #|orbit to G x| = #|G : 'C_G[x | to]|. +Proof. by rewrite card_orbit_in ?subsetT. Qed. + +Lemma dvdn_orbit G x : #|orbit to G x| %| #|G|. +Proof. by rewrite card_orbit dvdn_indexg. Qed. + +Lemma card_orbit_stab G x : (#|orbit to G x| * #|'C_G[x | to]|)%N = #|G|. +Proof. by rewrite mulnC card_orbit Lagrange ?subsetIl. Qed. + +Lemma actsP A S : reflect {acts A, on S | to} [acts A, on S | to]. +Proof. +apply: (iffP idP) => [nSA x|nSA]; first exact: acts_act. +by apply/subsetP=> a Aa; rewrite !inE; apply/subsetP=> x; rewrite inE nSA. +Qed. +Implicit Arguments actsP [A S]. + +Lemma setact_orbit A x b : to^* (orbit to A x) b = orbit to (A :^ b) (to x b). +Proof. +apply/setP=> y; apply/idP/idP=> /imsetP[_ /imsetP[a Aa ->] ->{y}]. + by rewrite actCJ mem_orbit ?memJ_conjg. +by rewrite -actCJ mem_setact ?mem_orbit. +Qed. + +Lemma astab_setact S a : 'C(to^* S a | to) = 'C(S | to) :^ a. +Proof. +apply/setP=> b; rewrite mem_conjg. +apply/astabP/astabP=> stab x => [Sx|]. + by rewrite conjgE invgK !actM stab ?actK //; apply/imsetP; exists x. +by case/imsetP=> y Sy ->{x}; rewrite -actM conjgCV actM stab. +Qed. + +Lemma astab1_act x a : 'C[to x a | to] = 'C[x | to] :^ a. +Proof. by rewrite -astab_setact /setact imset_set1. Qed. + +Lemma atransP G S : [transitive G, on S | to] -> + forall x, x \in S -> orbit to G x = S. +Proof. by case/imsetP=> x _ -> y; exact: orbit_transl. Qed. + +Lemma atransP2 G S : [transitive G, on S | to] -> + {in S &, forall x y, exists2 a, a \in G & y = to x a}. +Proof. by move=> GtrS x y /(atransP GtrS) <- /imsetP. Qed. + +Lemma atrans_acts G S : [transitive G, on S | to] -> [acts G, on S | to]. +Proof. +move=> GtrS; apply/subsetP=> a Ga; rewrite !inE. +by apply/subsetP=> x /(atransP GtrS) <-; rewrite inE mem_imset. +Qed. + +Lemma atrans_supgroup G H S : + G \subset H -> [transitive G, on S | to] -> + [transitive H, on S | to] = [acts H, on S | to]. +Proof. +move=> sGH trG; apply/idP/idP=> [|actH]; first exact: atrans_acts. +case/imsetP: trG => x Sx defS; apply/imsetP; exists x => //. +by apply/eqP; rewrite eqEsubset acts_sub_orbit ?Sx // defS imsetS. +Qed. + +Lemma atrans_acts_card G S : + [transitive G, on S | to] = + [acts G, on S | to] && (#|orbit to G @: S| == 1%N). +Proof. +apply/idP/andP=> [GtrS | [nSG]]. + split; first exact: atrans_acts. + rewrite ((_ @: S =P [set S]) _) ?cards1 // eqEsubset sub1set. + apply/andP; split=> //; apply/subsetP=> _ /imsetP[x Sx ->]. + by rewrite inE (atransP GtrS). +rewrite eqn_leq andbC lt0n => /andP[/existsP[X /imsetP[x Sx X_Gx]]]. +rewrite (cardD1 X) {X}X_Gx mem_imset // ltnS leqn0 => /eqP GtrS. +apply/imsetP; exists x => //; apply/eqP. +rewrite eqEsubset acts_sub_orbit // Sx andbT. +apply/subsetP=> y Sy; have:= card0_eq GtrS (orbit to G y). +rewrite !inE /= mem_imset // andbT => /eqP <-; exact: orbit_refl. +Qed. + +Lemma atrans_dvd G S : [transitive G, on S | to] -> #|S| %| #|G|. +Proof. by case/imsetP=> x _ ->; exact: dvdn_orbit. Qed. + +(* Aschbacher 5.2 *) +Lemma acts_fix_norm A B : A \subset 'N(B) -> [acts A, on 'Fix_to(B) | to]. +Proof. +move=> nAB; have:= acts_subnorm_fix to B; rewrite !setTI. +exact: subset_trans. +Qed. + +Lemma faithfulP A S : + reflect (forall a, a \in A -> {in S, to^~ a =1 id} -> a = 1) + [faithful A, on S | to]. +Proof. +apply: (iffP subsetP) => [Cto1 a Aa Ca | Cto1 a]. + apply/set1P; rewrite Cto1 // inE Aa; exact/astabP. +case/setIP=> Aa /astabP Ca; apply/set1P; exact: Cto1. +Qed. + +(* This is the first part of Aschbacher (5.7) *) +Lemma astab_trans_gcore G S u : + [transitive G, on S | to] -> u \in S -> 'C(S | to) = gcore 'C[u | to] G. +Proof. +move=> transG Su; apply/eqP; rewrite eqEsubset. +rewrite gcore_max ?astabS ?sub1set //=; last first. + exact: subset_trans (atrans_acts transG) (astab_norm _ _). +apply/subsetP=> x cSx; apply/astabP=> uy. +case/(atransP2 transG Su) => y Gy ->{uy}. +by apply/astab1P; rewrite astab1_act (bigcapP cSx). +Qed. + +(* Aschbacher 5.20 *) +Theorem subgroup_transitiveP G H S x : + x \in S -> H \subset G -> [transitive G, on S | to] -> + reflect ('C_G[x | to] * H = G) [transitive H, on S | to]. +Proof. by move=> Sx sHG; exact: subgroup_transitivePin (subsetT G). Qed. + +(* Aschbacher 5.21 *) +Lemma trans_subnorm_fixP x G H S : + let C := 'C_G[x | to] in let T := 'Fix_(S | to)(H) in + [transitive G, on S | to] -> x \in S -> H \subset C -> + reflect ((H :^: G) ::&: C = H :^: C) [transitive 'N_G(H), on T | to]. +Proof. +move=> C T trGS Sx sHC; have actGS := acts_act (atrans_acts trGS). +have:= sHC; rewrite subsetI sub_astab1 => /andP[sHG cHx]. +have Tx: x \in T by rewrite inE Sx. +apply: (iffP idP) => [trN | trC]. + apply/setP=> Ha; apply/setIdP/imsetP=> [[]|[a Ca ->{Ha}]]; last first. + by rewrite conj_subG //; case/setIP: Ca => Ga _; rewrite mem_imset. + case/imsetP=> a Ga ->{Ha}; rewrite subsetI !sub_conjg => /andP[_ sHCa]. + have Txa: to x a^-1 \in T. + by rewrite inE -sub_astab1 astab1_act actGS ?Sx ?groupV. + have [b] := atransP2 trN Tx Txa; case/setIP=> Gb nHb cxba. + exists (b * a); last by rewrite conjsgM (normP nHb). + by rewrite inE groupM //; apply/astab1P; rewrite actM -cxba actKV. +apply/imsetP; exists x => //; apply/setP=> y; apply/idP/idP=> [Ty|]. + have [Sy cHy]:= setIP Ty; have [a Ga defy] := atransP2 trGS Sx Sy. + have: H :^ a^-1 \in H :^: C. + rewrite -trC inE subsetI mem_imset 1?conj_subG ?groupV // sub_conjgV. + by rewrite -astab1_act -defy sub_astab1. + case/imsetP=> b /setIP[Gb /astab1P cxb] defHb. + rewrite defy -{1}cxb -actM mem_orbit // inE groupM //. + by apply/normP; rewrite conjsgM -defHb conjsgKV. +case/imsetP=> a /setIP[Ga nHa] ->{y}. +by rewrite inE actGS // Sx (acts_act (acts_fix_norm _) nHa). +Qed. + +End TotalActions. + +Implicit Arguments astabP [aT rT to S a]. +Implicit Arguments astab1P [aT rT to x a]. +Implicit Arguments astabsP [aT rT to S a]. +Implicit Arguments atransP [aT rT to G S]. +Implicit Arguments actsP [aT rT to A S]. +Implicit Arguments faithfulP [aT rT to A S]. +Prenex Implicits astabP astab1P astabsP atransP actsP faithfulP. + +Section Restrict. + +Variables (aT : finGroupType) (D : {set aT}) (rT : Type). +Variables (to : action D rT) (A : {set aT}). + +Definition ract of A \subset D := act to. + +Variable sAD : A \subset D. + +Lemma ract_is_action : is_action A (ract sAD). +Proof. +rewrite /ract; case: to => f [injf fM]. +split=> // x; exact: (sub_in2 (subsetP sAD)). +Qed. + +Canonical raction := Action ract_is_action. + +Lemma ractE : raction =1 to. Proof. by []. Qed. + +(* Other properties of raction need rT : finType; we defer them *) +(* until after the definition of actperm. *) + +End Restrict. + +Notation "to \ sAD" := (raction to sAD) (at level 50) : action_scope. + +Section ActBy. + +Variables (aT : finGroupType) (D : {set aT}) (rT : finType). + +Definition actby_cond (A : {set aT}) R (to : action D rT) : Prop := + [acts A, on R | to]. + +Definition actby A R to of actby_cond A R to := + fun x a => if (x \in R) && (a \in A) then to x a else x. + +Variables (A : {group aT}) (R : {set rT}) (to : action D rT). +Hypothesis nRA : actby_cond A R to. + +Lemma actby_is_action : is_action A (actby nRA). +Proof. +rewrite /actby; split=> [a x y | x a b Aa Ab /=]; last first. + rewrite Aa Ab groupM // !andbT actMin ?(subsetP (acts_dom nRA)) //. + by case Rx: (x \in R); rewrite ?(acts_act nRA) ?Rx. +case Aa: (a \in A); rewrite ?andbF ?andbT //. +case Rx: (x \in R); case Ry: (y \in R) => // eqxy; first exact: act_inj eqxy. + by rewrite -eqxy (acts_act nRA Aa) Rx in Ry. +by rewrite eqxy (acts_act nRA Aa) Ry in Rx. +Qed. + +Canonical action_by := Action actby_is_action. +Local Notation "<[nRA]>" := action_by : action_scope. + +Lemma actbyE x a : x \in R -> a \in A -> <[nRA]>%act x a = to x a. +Proof. by rewrite /= /actby => -> ->. Qed. + +Lemma afix_actby B : 'Fix_<[nRA]>(B) = ~: R :|: 'Fix_to(A :&: B). +Proof. +apply/setP=> x; rewrite !inE /= /actby. +case: (x \in R); last by apply/subsetP=> a _; rewrite !inE. +apply/subsetP/subsetP=> [cBx a | cABx a Ba]; rewrite !inE. + by case/andP=> Aa /cBx; rewrite inE Aa. +by case: ifP => //= Aa; have:= cABx a; rewrite !inE Aa => ->. +Qed. + +Lemma astab_actby S : 'C(S | <[nRA]>) = 'C_A(R :&: S | to). +Proof. +apply/setP=> a; rewrite setIA (setIidPl (acts_dom nRA)) !inE. +case Aa: (a \in A) => //=; apply/subsetP/subsetP=> cRSa x => [|Sx]. + by case/setIP=> Rx /cRSa; rewrite !inE actbyE. +by have:= cRSa x; rewrite !inE /= /actby Aa Sx; case: (x \in R) => //; apply. +Qed. + +Lemma astabs_actby S : 'N(S | <[nRA]>) = 'N_A(R :&: S | to). +Proof. +apply/setP=> a; rewrite setIA (setIidPl (acts_dom nRA)) !inE. +case Aa: (a \in A) => //=; apply/subsetP/subsetP=> nRSa x => [|Sx]. + by case/setIP=> Rx /nRSa; rewrite !inE actbyE ?(acts_act nRA) ?Rx. +have:= nRSa x; rewrite !inE /= /actby Aa Sx ?(acts_act nRA) //. +by case: (x \in R) => //; apply. +Qed. + +Lemma acts_actby (B : {set aT}) S : + [acts B, on S | <[nRA]>] = (B \subset A) && [acts B, on R :&: S | to]. +Proof. by rewrite astabs_actby subsetI. Qed. + +End ActBy. + +Notation "<[ nRA ] >" := (action_by nRA) : action_scope. + +Section SubAction. + +Variables (aT : finGroupType) (D : {group aT}). +Variables (rT : finType) (sP : pred rT) (sT : subFinType sP) (to : action D rT). +Implicit Type A : {set aT}. +Implicit Type u : sT. +Implicit Type S : {set sT}. + +Definition subact_dom := 'N([set x | sP x] | to). +Canonical subact_dom_group := [group of subact_dom]. + +Implicit Type Na : {a | a \in subact_dom}. +Lemma sub_act_proof u Na : sP (to (val u) (val Na)). +Proof. by case: Na => a /= /(astabs_act (val u)); rewrite !inE valP. Qed. + +Definition subact u a := + if insub a is Some Na then Sub _ (sub_act_proof u Na) else u. + +Lemma val_subact u a : + val (subact u a) = if a \in subact_dom then to (val u) a else val u. +Proof. +by rewrite /subact -if_neg; case: insubP => [Na|] -> //=; rewrite SubK => ->. +Qed. + +Lemma subact_is_action : is_action subact_dom subact. +Proof. +split=> [a u v eq_uv | u a b Na Nb]; apply: val_inj. + move/(congr1 val): eq_uv; rewrite !val_subact. + by case: (a \in _); first move/act_inj. +have Da := astabs_dom Na; have Db := astabs_dom Nb. +by rewrite !val_subact Na Nb groupM ?actMin. +Qed. + +Canonical subaction := Action subact_is_action. + +Lemma astab_subact S : 'C(S | subaction) = subact_dom :&: 'C(val @: S | to). +Proof. +apply/setP=> a; rewrite inE in_setI; apply: andb_id2l => sDa. +have [Da _] := setIP sDa; rewrite !inE Da. +apply/subsetP/subsetP=> [cSa _ /imsetP[x Sx ->] | cSa x Sx]; rewrite !inE. + by have:= cSa x Sx; rewrite inE -val_eqE val_subact sDa. +by have:= cSa _ (mem_imset val Sx); rewrite inE -val_eqE val_subact sDa. +Qed. + +Lemma astabs_subact S : 'N(S | subaction) = subact_dom :&: 'N(val @: S | to). +Proof. +apply/setP=> a; rewrite inE in_setI; apply: andb_id2l => sDa. +have [Da _] := setIP sDa; rewrite !inE Da. +apply/subsetP/subsetP=> [nSa _ /imsetP[x Sx ->] | nSa x Sx]; rewrite !inE. + by have:= nSa x Sx; rewrite inE => /(mem_imset val); rewrite val_subact sDa. +have:= nSa _ (mem_imset val Sx); rewrite inE => /imsetP[y Sy def_y]. +by rewrite ((_ a =P y) _) // -val_eqE val_subact sDa def_y. +Qed. + +Lemma afix_subact A : + A \subset subact_dom -> 'Fix_subaction(A) = val @^-1: 'Fix_to(A). +Proof. +move/subsetP=> sAD; apply/setP=> u. +rewrite !inE !(sameP setIidPl eqP); congr (_ == A). +apply/setP=> a; rewrite !inE; apply: andb_id2l => Aa. +by rewrite -val_eqE val_subact sAD. + +Qed. + +End SubAction. + +Notation "to ^?" := (subaction _ to) + (at level 2, format "to ^?") : action_scope. + +Section QuotientAction. + +Variables (aT : finGroupType) (D : {group aT}) (rT : finGroupType). +Variables (to : action D rT) (H : {group rT}). + +Definition qact_dom := 'N(rcosets H 'N(H) | to^*). +Canonical qact_dom_group := [group of qact_dom]. + +Local Notation subdom := (subact_dom (coset_range H) to^*). +Fact qact_subdomE : subdom = qact_dom. +Proof. by congr 'N(_|_); apply/setP=> Hx; rewrite !inE genGid. Qed. +Lemma qact_proof : qact_dom \subset subdom. +Proof. by rewrite qact_subdomE. Qed. + +Definition qact : coset_of H -> aT -> coset_of H := act (to^*^? \ qact_proof). + +Canonical quotient_action := [action of qact]. + +Lemma acts_qact_dom : [acts qact_dom, on 'N(H) | to]. +Proof. +apply/subsetP=> a nNa; rewrite !inE (astabs_dom nNa); apply/subsetP=> x Nx. +have: H :* x \in rcosets H 'N(H) by rewrite -rcosetE mem_imset. +rewrite inE -(astabs_act _ nNa) => /rcosetsP[y Ny defHy]. +have: to x a \in H :* y by rewrite -defHy (mem_imset (to^~a)) ?rcoset_refl. +by apply: subsetP; rewrite mul_subG ?sub1set ?normG. +Qed. + +Lemma qactEcond x a : + x \in 'N(H) -> + quotient_action (coset H x) a = + (if a \in qact_dom then coset H (to x a) else coset H x). +Proof. +move=> Nx; apply: val_inj; rewrite val_subact //= qact_subdomE. +have: H :* x \in rcosets H 'N(H) by rewrite -rcosetE mem_imset. +case nNa: (a \in _); rewrite // -(astabs_act _ nNa). +rewrite !val_coset ?(acts_act acts_qact_dom nNa) //=. +case/rcosetsP=> y Ny defHy; rewrite defHy; apply: rcoset_transl. +by rewrite rcoset_sym -defHy (mem_imset (_^~_)) ?rcoset_refl. +Qed. + +Lemma qactE x a : + x \in 'N(H) -> a \in qact_dom -> + quotient_action (coset H x) a = coset H (to x a). +Proof. by move=> Nx nNa; rewrite qactEcond ?nNa. Qed. + +Lemma acts_quotient (A : {set aT}) (B : {set rT}) : + A \subset 'N_qact_dom(B | to) -> [acts A, on B / H | quotient_action]. +Proof. +move=> nBA; apply: subset_trans {A}nBA _; apply/subsetP=> a /setIP[dHa nBa]. +rewrite inE dHa inE; apply/subsetP=> _ /morphimP[x nHx Bx ->]. +rewrite inE /= qactE //. +by rewrite mem_morphim ?(acts_act acts_qact_dom) ?(astabs_act _ nBa). +Qed. + +Lemma astabs_quotient (G : {group rT}) : + H <| G -> 'N(G / H | quotient_action) = 'N_qact_dom(G | to). +Proof. +move=> nsHG; have [_ nHG] := andP nsHG. +apply/eqP; rewrite eqEsubset acts_quotient // andbT. +apply/subsetP=> a nGa; have dHa := astabs_dom nGa; have [Da _]:= setIdP dHa. +rewrite inE dHa 2!inE Da; apply/subsetP=> x Gx; have nHx := subsetP nHG x Gx. +rewrite -(quotientGK nsHG) 2!inE (acts_act acts_qact_dom) ?nHx //= inE. +by rewrite -qactE // (astabs_act _ nGa) mem_morphim. +Qed. + +End QuotientAction. + +Notation "to / H" := (quotient_action to H) : action_scope. + +Section ModAction. + +Variables (aT : finGroupType) (D : {group aT}) (rT : finType). +Variable to : action D rT. +Implicit Types (G : {group aT}) (S : {set rT}). + +Section GenericMod. + +Variable H : {group aT}. + +Local Notation dom := 'N_D(H). +Local Notation range := 'Fix_to(D :&: H). +Let acts_dom : {acts dom, on range | to} := acts_act (acts_subnorm_fix to H). + +Definition modact x (Ha : coset_of H) := + if x \in range then to x (repr (D :&: Ha)) else x. + +Lemma modactEcond x a : + a \in dom -> modact x (coset H a) = (if x \in range then to x a else x). +Proof. +case/setIP=> Da Na; case: ifP => Cx; rewrite /modact Cx //. +rewrite val_coset // -group_modr ?sub1set //. +case: (repr _) / (repr_rcosetP (D :&: H) a) => a' Ha'. +by rewrite actMin ?(afixP Cx _ Ha') //; case/setIP: Ha'. +Qed. + +Lemma modactE x a : + a \in D -> a \in 'N(H) -> x \in range -> modact x (coset H a) = to x a. +Proof. by move=> Da Na Rx; rewrite modactEcond ?Rx // inE Da. Qed. + +Lemma modact_is_action : is_action (D / H) modact. +Proof. +split=> [Ha x y | x Ha Hb]; last first. + case/morphimP=> a Na Da ->{Ha}; case/morphimP=> b Nb Db ->{Hb}. + rewrite -morphM //= !modactEcond // ?groupM ?(introT setIP _) //. + by case: ifP => Cx; rewrite ?(acts_dom, Cx, actMin, introT setIP _). +case: (set_0Vmem (D :&: Ha)) => [Da0 | [a /setIP[Da NHa]]]. + by rewrite /modact Da0 repr_set0 !act1 !if_same. +have Na := subsetP (coset_norm _) _ NHa. +have NDa: a \in 'N_D(H) by rewrite inE Da. +rewrite -(coset_mem NHa) !modactEcond //. +do 2![case: ifP]=> Cy Cx // eqxy; first exact: act_inj eqxy. + by rewrite -eqxy acts_dom ?Cx in Cy. +by rewrite eqxy acts_dom ?Cy in Cx. +Qed. + +Canonical mod_action := Action modact_is_action. + +Section Stabilizers. + +Variable S : {set rT}. +Hypothesis cSH : H \subset 'C(S | to). + +Let fixSH : S \subset 'Fix_to(D :&: H). +Proof. by rewrite -astabCin ?subsetIl // subIset ?cSH ?orbT. Qed. + +Lemma astabs_mod : 'N(S | mod_action) = 'N(S | to) / H. +Proof. +apply/setP=> Ha; apply/idP/morphimP=> [nSa | [a nHa nSa ->]]. + case/morphimP: (astabs_dom nSa) => a nHa Da defHa. + exists a => //; rewrite !inE Da; apply/subsetP=> x Sx; rewrite !inE. + by have:= Sx; rewrite -(astabs_act x nSa) defHa /= modactE ?(subsetP fixSH). +have Da := astabs_dom nSa; rewrite !inE mem_quotient //; apply/subsetP=> x Sx. +by rewrite !inE /= modactE ?(astabs_act x nSa) ?(subsetP fixSH). +Qed. + +Lemma astab_mod : 'C(S | mod_action) = 'C(S | to) / H. +Proof. +apply/setP=> Ha; apply/idP/morphimP=> [cSa | [a nHa cSa ->]]. + case/morphimP: (astab_dom cSa) => a nHa Da defHa. + exists a => //; rewrite !inE Da; apply/subsetP=> x Sx; rewrite !inE. + by rewrite -{2}[x](astab_act cSa) // defHa /= modactE ?(subsetP fixSH). +have Da := astab_dom cSa; rewrite !inE mem_quotient //; apply/subsetP=> x Sx. +by rewrite !inE /= modactE ?(astab_act cSa) ?(subsetP fixSH). +Qed. + +End Stabilizers. + +Lemma afix_mod G S : + H \subset 'C(S | to) -> G \subset 'N_D(H) -> + 'Fix_(S | mod_action)(G / H) = 'Fix_(S | to)(G). +Proof. +move=> cSH /subsetIP[sGD nHG]. +apply/eqP; rewrite eqEsubset !subsetI !subsetIl /= -!astabCin ?quotientS //. +have cfixH F: H \subset 'C(S :&: F | to). + by rewrite (subset_trans cSH) // astabS ?subsetIl. +rewrite andbC astab_mod ?quotientS //=; last by rewrite astabCin ?subsetIr. +by rewrite -(quotientSGK nHG) //= -astab_mod // astabCin ?quotientS ?subsetIr. +Qed. + +End GenericMod. + +Lemma modact_faithful G S : + [faithful G / 'C_G(S | to), on S | mod_action 'C_G(S | to)]. +Proof. +rewrite /faithful astab_mod ?subsetIr //=. +by rewrite -quotientIG ?subsetIr ?trivg_quotient. +Qed. + +End ModAction. + +Notation "to %% H" := (mod_action to H) : action_scope. + +Section ActPerm. +(* Morphism to permutations induced by an action. *) + +Variables (aT : finGroupType) (D : {set aT}) (rT : finType). +Variable to : action D rT. + +Definition actperm a := perm (act_inj to a). + +Lemma actpermM : {in D &, {morph actperm : a b / a * b}}. +Proof. by move=> a b Da Db; apply/permP=> x; rewrite permM !permE actMin. Qed. + +Canonical actperm_morphism := Morphism actpermM. + +Lemma actpermE a x : actperm a x = to x a. +Proof. by rewrite permE. Qed. + +Lemma actpermK x a : aperm x (actperm a) = to x a. +Proof. exact: actpermE. Qed. + +Lemma ker_actperm : 'ker actperm = 'C(setT | to). +Proof. +congr (_ :&: _); apply/setP=> a; rewrite !inE /=. +apply/eqP/subsetP=> [a1 x _ | a1]; first by rewrite inE -actpermE a1 perm1. +by apply/permP=> x; apply/eqP; have:= a1 x; rewrite !inE actpermE perm1 => ->. +Qed. + +End ActPerm. + +Section RestrictActionTheory. + +Variables (aT : finGroupType) (D : {set aT}) (rT : finType). +Variables (to : action D rT). + +Lemma faithful_isom (A : {group aT}) S (nSA : actby_cond A S to) : + [faithful A, on S | to] -> isom A (actperm <[nSA]> @* A) (actperm <[nSA]>). +Proof. +by move=> ffulAS; apply/isomP; rewrite ker_actperm astab_actby setIT. +Qed. + +Variables (A : {set aT}) (sAD : A \subset D). + +Lemma ractpermE : actperm (to \ sAD) =1 actperm to. +Proof. by move=> a; apply/permP=> x; rewrite !permE. Qed. + +Lemma afix_ract B : 'Fix_(to \ sAD)(B) = 'Fix_to(B). Proof. by []. Qed. + +Lemma astab_ract S : 'C(S | to \ sAD) = 'C_A(S | to). +Proof. by rewrite setIA (setIidPl sAD). Qed. + +Lemma astabs_ract S : 'N(S | to \ sAD) = 'N_A(S | to). +Proof. by rewrite setIA (setIidPl sAD). Qed. + +Lemma acts_ract (B : {set aT}) S : + [acts B, on S | to \ sAD] = (B \subset A) && [acts B, on S | to]. +Proof. by rewrite astabs_ract subsetI. Qed. + +End RestrictActionTheory. + +Section MorphAct. +(* Action induced by a morphism to permutations. *) + +Variables (aT : finGroupType) (D : {group aT}) (rT : finType). +Variable phi : {morphism D >-> {perm rT}}. + +Definition mact x a := phi a x. + +Lemma mact_is_action : is_action D mact. +Proof. +split=> [a x y | x a b Da Db]; first exact: perm_inj. +by rewrite /mact morphM //= permM. +Qed. + +Canonical morph_action := Action mact_is_action. + +Lemma mactE x a : morph_action x a = phi a x. Proof. by []. Qed. + +Lemma injm_faithful : 'injm phi -> [faithful D, on setT | morph_action]. +Proof. +move/injmP=> phi_inj; apply/subsetP=> a /setIP[Da /astab_act a1]. +apply/set1P/phi_inj => //; apply/permP=> x. +by rewrite morph1 perm1 -mactE a1 ?inE. +Qed. + +Lemma perm_mact a : actperm morph_action a = phi a. +Proof. by apply/permP=> x; rewrite permE. Qed. + +End MorphAct. + +Notation "<< phi >>" := (morph_action phi) : action_scope. + +Section CompAct. + +Variables (gT aT : finGroupType) (rT : finType). +Variables (D : {set aT}) (to : action D rT). +Variables (B : {set gT}) (f : {morphism B >-> aT}). + +Definition comp_act x e := to x (f e). +Lemma comp_is_action : is_action (f @*^-1 D) comp_act. +Proof. +split=> [e | x e1 e2]; first exact: act_inj. +case/morphpreP=> Be1 Dfe1; case/morphpreP=> Be2 Dfe2. +by rewrite /comp_act morphM ?actMin. +Qed. +Canonical comp_action := Action comp_is_action. + +Lemma comp_actE x e : comp_action x e = to x (f e). Proof. by []. Qed. + +Lemma afix_comp (A : {set gT}) : + A \subset B -> 'Fix_comp_action(A) = 'Fix_to(f @* A). +Proof. +move=> sAB; apply/setP=> x; rewrite !inE /morphim (setIidPr sAB). +apply/subsetP/subsetP=> [cAx _ /imsetP[a Aa ->] | cfAx a Aa]. + by move/cAx: Aa; rewrite !inE. +by rewrite inE; move/(_ (f a)): cfAx; rewrite inE mem_imset // => ->. +Qed. + +Lemma astab_comp S : 'C(S | comp_action) = f @*^-1 'C(S | to). +Proof. by apply/setP=> x; rewrite !inE -andbA. Qed. + +Lemma astabs_comp S : 'N(S | comp_action) = f @*^-1 'N(S | to). +Proof. by apply/setP=> x; rewrite !inE -andbA. Qed. + +End CompAct. + +Notation "to \o f" := (comp_action to f) : action_scope. + +Section PermAction. +(* Natural action of permutation groups. *) + +Variable rT : finType. +Local Notation gT := {perm rT}. +Implicit Types a b c : gT. + +Lemma aperm_is_action : is_action setT (@aperm rT). +Proof. +by apply: is_total_action => [x|x a b]; rewrite apermE (perm1, permM). +Qed. + +Canonical perm_action := Action aperm_is_action. + +Lemma pcycleE a : pcycle a = orbit perm_action <[a]>%g. +Proof. by []. Qed. + +Lemma perm_act1P a : reflect (forall x, aperm x a = x) (a == 1). +Proof. +apply: (iffP eqP) => [-> x | a1]; first exact: act1. +by apply/permP=> x; rewrite -apermE a1 perm1. +Qed. + +Lemma perm_faithful A : [faithful A, on setT | perm_action]. +Proof. +apply/subsetP=> a /setIP[Da crTa]. +by apply/set1P; apply/permP=> x; rewrite -apermE perm1 (astabP crTa) ?inE. +Qed. + +Lemma actperm_id p : actperm perm_action p = p. +Proof. by apply/permP=> x; rewrite permE. Qed. + +End PermAction. + +Implicit Arguments perm_act1P [rT a]. +Prenex Implicits perm_act1P. + +Notation "'P" := (perm_action _) (at level 8) : action_scope. + +Section ActpermOrbits. + +Variables (aT : finGroupType) (D : {group aT}) (rT : finType). +Variable to : action D rT. + +Lemma orbit_morphim_actperm (A : {set aT}) : + A \subset D -> orbit 'P (actperm to @* A) =1 orbit to A. +Proof. +move=> sAD x; rewrite morphimEsub // /orbit -imset_comp. +by apply: eq_imset => a //=; rewrite actpermK. +Qed. + +Lemma pcycle_actperm (a : aT) : + a \in D -> pcycle (actperm to a) =1 orbit to <[a]>. +Proof. +move=> Da x. +by rewrite pcycleE -orbit_morphim_actperm ?cycle_subG ?morphim_cycle. +Qed. + +End ActpermOrbits. + +Section RestrictPerm. + +Variables (T : finType) (S : {set T}). + +Definition restr_perm := actperm (<[subxx 'N(S | 'P)]>). +Canonical restr_perm_morphism := [morphism of restr_perm]. + +Lemma restr_perm_on p : perm_on S (restr_perm p). +Proof. +apply/subsetP=> x; apply: contraR => notSx. +by rewrite permE /= /actby (negPf notSx). +Qed. + +Lemma triv_restr_perm p : p \notin 'N(S | 'P) -> restr_perm p = 1. +Proof. +move=> not_nSp; apply/permP=> x. +by rewrite !permE /= /actby (negPf not_nSp) andbF. +Qed. + +Lemma restr_permE : {in 'N(S | 'P) & S, forall p, restr_perm p =1 p}. +Proof. by move=> y x nSp Sx; rewrite /= actpermE actbyE. Qed. + +Lemma ker_restr_perm : 'ker restr_perm = 'C(S | 'P). +Proof. by rewrite ker_actperm astab_actby setIT (setIidPr (astab_sub _ _)). Qed. + +Lemma im_restr_perm p : restr_perm p @: S = S. +Proof. exact: im_perm_on (restr_perm_on p). Qed. + +End RestrictPerm. + +Section AutIn. + +Variable gT : finGroupType. + +Definition Aut_in A (B : {set gT}) := 'N_A(B | 'P) / 'C_A(B | 'P). + +Variables G H : {group gT}. +Hypothesis sHG: H \subset G. + +Lemma Aut_restr_perm a : a \in Aut G -> restr_perm H a \in Aut H. +Proof. +move=> AutGa. +case nHa: (a \in 'N(H | 'P)); last by rewrite triv_restr_perm ?nHa ?group1. +rewrite inE restr_perm_on; apply/morphicP=> x y Hx Hy /=. +by rewrite !restr_permE ?groupM // -(autmE AutGa) morphM ?(subsetP sHG). +Qed. + +Lemma restr_perm_Aut : restr_perm H @* Aut G \subset Aut H. +Proof. +by apply/subsetP=> a'; case/morphimP=> a _ AutGa ->{a'}; exact: Aut_restr_perm. +Qed. + +Lemma Aut_in_isog : Aut_in (Aut G) H \isog restr_perm H @* Aut G. +Proof. +rewrite /Aut_in -ker_restr_perm kerE -morphpreIdom -morphimIdom -kerE /=. +by rewrite setIA (setIC _ (Aut G)) first_isog_loc ?subsetIr. +Qed. + +Lemma Aut_sub_fullP : + reflect (forall h : {morphism H >-> gT}, 'injm h -> h @* H = H -> + exists g : {morphism G >-> gT}, + [/\ 'injm g, g @* G = G & {in H, g =1 h}]) + (Aut_in (Aut G) H \isog Aut H). +Proof. +rewrite (isog_transl _ Aut_in_isog) /=; set rG := _ @* _. +apply: (iffP idP) => [iso_rG h injh hH| AutHinG]. + have: aut injh hH \in rG; last case/morphimP=> g nHg AutGg def_g. + suffices ->: rG = Aut H by exact: Aut_aut. + by apply/eqP; rewrite eqEcard restr_perm_Aut /= (card_isog iso_rG). + exists (autm_morphism AutGg); rewrite injm_autm im_autm; split=> // x Hx. + by rewrite -(autE injh hH Hx) def_g actpermE actbyE. +suffices ->: rG = Aut H by exact: isog_refl. +apply/eqP; rewrite eqEsubset restr_perm_Aut /=. +apply/subsetP=> h AutHh; have hH := im_autm AutHh. +have [g [injg gG eq_gh]] := AutHinG _ (injm_autm AutHh) hH. +have [Ng AutGg]: aut injg gG \in 'N(H | 'P) /\ aut injg gG \in Aut G. + rewrite Aut_aut !inE; split=> //; apply/subsetP=> x Hx. + by rewrite inE /= /aperm autE ?(subsetP sHG) // -hH eq_gh ?mem_morphim. +apply/morphimP; exists (aut injg gG) => //; apply: (eq_Aut AutHh) => [|x Hx]. + by rewrite (subsetP restr_perm_Aut) // mem_morphim. +by rewrite restr_permE //= /aperm autE ?eq_gh ?(subsetP sHG). +Qed. + +End AutIn. + +Arguments Scope Aut_in [_ group_scope group_scope]. + +Section InjmAutIn. + +Variables (gT rT : finGroupType) (D G H : {group gT}) (f : {morphism D >-> rT}). +Hypotheses (injf : 'injm f) (sGD : G \subset D) (sHG : H \subset G). +Let sHD := subset_trans sHG sGD. +Local Notation fGisom := (Aut_isom injf sGD). +Local Notation fHisom := (Aut_isom injf sHD). +Local Notation inH := (restr_perm H). +Local Notation infH := (restr_perm (f @* H)). + +Lemma astabs_Aut_isom a : + a \in Aut G -> (fGisom a \in 'N(f @* H | 'P)) = (a \in 'N(H | 'P)). +Proof. +move=> AutGa; rewrite !inE sub_morphim_pre // subsetI sHD /= /aperm. +rewrite !(sameP setIidPl eqP) !eqEsubset !subsetIl; apply: eq_subset_r => x. +rewrite !inE; apply: andb_id2l => Hx; have Gx: x \in G := subsetP sHG x Hx. +have Dax: a x \in D by rewrite (subsetP sGD) // Aut_closed. +by rewrite Aut_isomE // -!sub1set -morphim_set1 // injmSK ?sub1set. +Qed. + +Lemma isom_restr_perm a : a \in Aut G -> fHisom (inH a) = infH (fGisom a). +Proof. +move=> AutGa; case nHa: (a \in 'N(H | 'P)); last first. + by rewrite !triv_restr_perm ?astabs_Aut_isom ?nHa ?morph1. +apply: (eq_Aut (Aut_Aut_isom injf sHD _)) => [|fx Hfx /=]. + by rewrite (Aut_restr_perm (morphimS f sHG)) ?Aut_Aut_isom. +have [x Dx Hx def_fx] := morphimP Hfx; have Gx := subsetP sHG x Hx. +rewrite {1}def_fx Aut_isomE ?(Aut_restr_perm sHG) //. +by rewrite !restr_permE ?astabs_Aut_isom // def_fx Aut_isomE. +Qed. + +Lemma restr_perm_isom : isom (inH @* Aut G) (infH @* Aut (f @* G)) fHisom. +Proof. +apply: sub_isom; rewrite ?restr_perm_Aut ?injm_Aut_isom //=. +rewrite -(im_Aut_isom injf sGD) -!morphim_comp. +apply: eq_in_morphim; last exact: isom_restr_perm. +apply/setP=> a; rewrite 2!in_setI; apply: andb_id2r => AutGa. +rewrite /= inE andbC inE (Aut_restr_perm sHG) //=. +by symmetry; rewrite inE AutGa inE astabs_Aut_isom. +Qed. + +Lemma injm_Aut_sub : Aut_in (Aut (f @* G)) (f @* H) \isog Aut_in (Aut G) H. +Proof. +do 2!rewrite isog_sym (isog_transl _ (Aut_in_isog _ _)). +by rewrite isog_sym (isom_isog _ _ restr_perm_isom) // restr_perm_Aut. +Qed. + +Lemma injm_Aut_full : + (Aut_in (Aut (f @* G)) (f @* H) \isog Aut (f @* H)) + = (Aut_in (Aut G) H \isog Aut H). +Proof. +by rewrite (isog_transl _ injm_Aut_sub) (isog_transr _ (injm_Aut injf sHD)). +Qed. + +End InjmAutIn. + +Section GroupAction. + +Variables (aT rT : finGroupType) (D : {set aT}) (R : {set rT}). +Local Notation actT := (action D rT). + +Definition is_groupAction (to : actT) := + {in D, forall a, actperm to a \in Aut R}. + +Structure groupAction := GroupAction {gact :> actT; _ : is_groupAction gact}. + +Definition clone_groupAction to := + let: GroupAction _ toA := to return {type of GroupAction for to} -> _ in + fun k => k toA : groupAction. + +End GroupAction. + +Delimit Scope groupAction_scope with gact. +Bind Scope groupAction_scope with groupAction. + +Arguments Scope is_groupAction [_ _ group_scope group_scope action_scope]. +Arguments Scope groupAction [_ _ group_scope group_scope]. +Arguments Scope gact [_ _ group_scope group_scope groupAction_scope]. + +Notation "[ 'groupAction' 'of' to ]" := + (clone_groupAction (@GroupAction _ _ _ _ to)) + (at level 0, format "[ 'groupAction' 'of' to ]") : form_scope. + +Section GroupActionDefs. + +Variables (aT rT : finGroupType) (D : {set aT}) (R : {set rT}). +Implicit Type A : {set aT}. +Implicit Type S : {set rT}. +Implicit Type to : groupAction D R. + +Definition gact_range of groupAction D R := R. + +Definition gacent to A := 'Fix_(R | to)(D :&: A). + +Definition acts_on_group A S to := [acts A, on S | to] /\ S \subset R. + +Coercion actby_cond_group A S to : acts_on_group A S to -> actby_cond A S to := + @proj1 _ _. + +Definition acts_irreducibly A S to := + [min S of G | G :!=: 1 & [acts A, on G | to]]. + +End GroupActionDefs. + +Arguments Scope gacent + [_ _ group_scope group_scope groupAction_scope group_scope]. +Arguments Scope acts_on_group + [_ _ group_scope group_scope group_scope group_scope groupAction_scope]. +Arguments Scope acts_irreducibly + [_ _ group_scope group_scope group_scope group_scope groupAction_scope]. + +Notation "''C_' ( | to ) ( A )" := (gacent to A) + (at level 8, format "''C_' ( | to ) ( A )") : group_scope. +Notation "''C_' ( G | to ) ( A )" := (G :&: 'C_(|to)(A)) + (at level 8, format "''C_' ( G | to ) ( A )") : group_scope. +Notation "''C_' ( | to ) [ a ]" := 'C_(|to)([set a]) + (at level 8, format "''C_' ( | to ) [ a ]") : group_scope. +Notation "''C_' ( G | to ) [ a ]" := 'C_(G | to)([set a]) + (at level 8, format "''C_' ( G | to ) [ a ]") : group_scope. + +Notation "{ 'acts' A , 'on' 'group' G | to }" := (acts_on_group A G to) + (at level 0, format "{ 'acts' A , 'on' 'group' G | to }") : form_scope. + +Section RawGroupAction. + +Variables (aT rT : finGroupType) (D : {set aT}) (R : {set rT}). +Variable to : groupAction D R. + +Lemma actperm_Aut : is_groupAction R to. Proof. by case: to. Qed. + +Lemma im_actperm_Aut : actperm to @* D \subset Aut R. +Proof. by apply/subsetP=> _ /morphimP[a _ Da ->]; exact: actperm_Aut. Qed. + +Lemma gact_out x a : a \in D -> x \notin R -> to x a = x. +Proof. by move=> Da Rx; rewrite -actpermE (out_Aut _ Rx) ?actperm_Aut. Qed. + +Lemma gactM : {in D, forall a, {in R &, {morph to^~ a : x y / x * y}}}. +Proof. +move=> a Da /= x y; rewrite -!(actpermE to); apply: morphicP x y. +by rewrite Aut_morphic ?actperm_Aut. +Qed. + +Lemma actmM a : {in R &, {morph actm to a : x y / x * y}}. +Proof. rewrite /actm; case: ifP => //; exact: gactM. Qed. + +Canonical act_morphism a := Morphism (actmM a). + +Lemma morphim_actm : + {in D, forall a (S : {set rT}), S \subset R -> actm to a @* S = to^* S a}. +Proof. by move=> a Da /= S sSR; rewrite /morphim /= actmEfun ?(setIidPr _). Qed. + +Variables (a : aT) (A B : {set aT}) (S : {set rT}). + +Lemma gacentIdom : 'C_(|to)(D :&: A) = 'C_(|to)(A). +Proof. by rewrite /gacent setIA setIid. Qed. + +Lemma gacentIim : 'C_(R | to)(A) = 'C_(|to)(A). +Proof. by rewrite setIA setIid. Qed. + +Lemma gacentS : A \subset B -> 'C_(|to)(B) \subset 'C_(|to)(A). +Proof. by move=> sAB; rewrite !(setIS, afixS). Qed. + +Lemma gacentU : 'C_(|to)(A :|: B) = 'C_(|to)(A) :&: 'C_(|to)(B). +Proof. by rewrite -setIIr -afixU -setIUr. Qed. + +Hypotheses (Da : a \in D) (sAD : A \subset D) (sSR : S \subset R). + +Lemma gacentE : 'C_(|to)(A) = 'Fix_(R | to)(A). +Proof. by rewrite -{2}(setIidPr sAD). Qed. + +Lemma gacent1E : 'C_(|to)[a] = 'Fix_(R | to)[a]. +Proof. by rewrite /gacent [D :&: _](setIidPr _) ?sub1set. Qed. + +Lemma subgacentE : 'C_(S | to)(A) = 'Fix_(S | to)(A). +Proof. by rewrite gacentE setIA (setIidPl sSR). Qed. + +Lemma subgacent1E : 'C_(S | to)[a] = 'Fix_(S | to)[a]. +Proof. by rewrite gacent1E setIA (setIidPl sSR). Qed. + +End RawGroupAction. + +Section GroupActionTheory. + +Variables aT rT : finGroupType. +Variables (D : {group aT}) (R : {group rT}) (to : groupAction D R). +Implicit Type A B : {set aT}. +Implicit Types G H : {group aT}. +Implicit Type S : {set rT}. +Implicit Types M N : {group rT}. + +Lemma gact1 : {in D, forall a, to 1 a = 1}. +Proof. by move=> a Da; rewrite /= -actmE ?morph1. Qed. + +Lemma gactV : {in D, forall a, {in R, {morph to^~ a : x / x^-1}}}. +Proof. by move=> a Da /= x Rx; move; rewrite -!actmE ?morphV. Qed. + +Lemma gactX : {in D, forall a n, {in R, {morph to^~ a : x / x ^+ n}}}. +Proof. by move=> a Da /= n x Rx; rewrite -!actmE // morphX. Qed. + +Lemma gactJ : {in D, forall a, {in R &, {morph to^~ a : x y / x ^ y}}}. +Proof. by move=> a Da /= x Rx y Ry; rewrite -!actmE // morphJ. Qed. + +Lemma gactR : {in D, forall a, {in R &, {morph to^~ a : x y / [~ x, y]}}}. +Proof. by move=> a Da /= x Rx y Ry; rewrite -!actmE // morphR. Qed. + +Lemma gact_stable : {acts D, on R | to}. +Proof. +apply: acts_act; apply/subsetP=> a Da; rewrite !inE Da. +apply/subsetP=> x; rewrite inE; apply: contraLR => R'xa. +by rewrite -(actKin to Da x) gact_out ?groupV. +Qed. + +Lemma group_set_gacent A : group_set 'C_(|to)(A). +Proof. +apply/group_setP; split=> [|x y]. + by rewrite !inE group1; apply/subsetP=> a /setIP[Da _]; rewrite inE gact1. +case/setIP=> Rx /afixP cAx /setIP[Ry /afixP cAy]. +rewrite inE groupM //; apply/afixP=> a Aa. +by rewrite gactM ?cAx ?cAy //; case/setIP: Aa. +Qed. + +Canonical gacent_group A := Group (group_set_gacent A). + +Lemma gacent1 : 'C_(|to)(1) = R. +Proof. by rewrite /gacent (setIidPr (sub1G _)) afix1 setIT. Qed. + +Lemma gacent_gen A : A \subset D -> 'C_(|to)(<>) = 'C_(|to)(A). +Proof. +by move=> sAD; rewrite /gacent ![D :&: _](setIidPr _) ?gen_subG ?afix_gen_in. +Qed. + +Lemma gacentD1 A : 'C_(|to)(A^#) = 'C_(|to)(A). +Proof. +rewrite -gacentIdom -gacent_gen ?subsetIl // setIDA genD1 ?group1 //. +by rewrite gacent_gen ?subsetIl // gacentIdom. +Qed. + +Lemma gacent_cycle a : a \in D -> 'C_(|to)(<[a]>) = 'C_(|to)[a]. +Proof. by move=> Da; rewrite gacent_gen ?sub1set. Qed. + +Lemma gacentY A B : + A \subset D -> B \subset D -> 'C_(|to)(A <*> B) = 'C_(|to)(A) :&: 'C_(|to)(B). +Proof. by move=> sAD sBD; rewrite gacent_gen ?gacentU // subUset sAD. Qed. + +Lemma gacentM G H : + G \subset D -> H \subset D -> 'C_(|to)(G * H) = 'C_(|to)(G) :&: 'C_(|to)(H). +Proof. +by move=> sGD sHB; rewrite -gacent_gen ?mul_subG // genM_join gacentY. +Qed. + +Lemma astab1 : 'C(1 | to) = D. +Proof. +by apply/setP=> x; rewrite ?(inE, sub1set) andb_idr //; move/gact1=> ->. +Qed. + +Lemma astab_range : 'C(R | to) = 'C(setT | to). +Proof. +apply/eqP; rewrite eqEsubset andbC astabS ?subsetT //=. +apply/subsetP=> a cRa; have Da := astab_dom cRa; rewrite !inE Da. +apply/subsetP=> x; rewrite -(setUCr R) !inE. +by case/orP=> ?; [rewrite (astab_act cRa) | rewrite gact_out]. +Qed. + +Lemma gacentC A S : + A \subset D -> S \subset R -> + (S \subset 'C_(|to)(A)) = (A \subset 'C(S | to)). +Proof. by move=> sAD sSR; rewrite subsetI sSR astabCin // (setIidPr sAD). Qed. + +Lemma astab_gen S : S \subset R -> 'C(<> | to) = 'C(S | to). +Proof. +move=> sSR; apply/setP=> a; case Da: (a \in D); last by rewrite !inE Da. +by rewrite -!sub1set -!gacentC ?sub1set ?gen_subG. +Qed. + +Lemma astabM M N : + M \subset R -> N \subset R -> 'C(M * N | to) = 'C(M | to) :&: 'C(N | to). +Proof. +move=> sMR sNR; rewrite -astabU -astab_gen ?mul_subG // genM_join. +by rewrite astab_gen // subUset sMR. +Qed. + +Lemma astabs1 : 'N(1 | to) = D. +Proof. by rewrite astabs_set1 astab1. Qed. + +Lemma astabs_range : 'N(R | to) = D. +Proof. +apply/setIidPl; apply/subsetP=> a Da; rewrite inE. +by apply/subsetP=> x Rx; rewrite inE gact_stable. +Qed. + +Lemma astabsD1 S : 'N(S^# | to) = 'N(S | to). +Proof. +case S1: (1 \in S); last first. + by rewrite (setDidPl _) // disjoint_sym disjoints_subset sub1set inE S1. +apply/eqP; rewrite eqEsubset andbC -{1}astabsIdom -{1}astabs1 setIC astabsD /=. +by rewrite -{2}(setD1K S1) -astabsIdom -{1}astabs1 astabsU. +Qed. + +Lemma gacts_range A : A \subset D -> {acts A, on group R | to}. +Proof. by move=> sAD; split; rewrite ?astabs_range. Qed. + +Lemma acts_subnorm_gacent A : A \subset D -> + [acts 'N_D(A), on 'C_(| to)(A) | to]. +Proof. +move=> sAD; rewrite gacentE // actsI ?astabs_range ?subsetIl //. +by rewrite -{2}(setIidPr sAD) acts_subnorm_fix. +Qed. + +Lemma acts_subnorm_subgacent A B S : + A \subset D -> [acts B, on S | to] -> [acts 'N_B(A), on 'C_(S | to)(A) | to]. +Proof. +move=> sAD actsB; rewrite actsI //; first by rewrite subIset ?actsB. +by rewrite (subset_trans _ (acts_subnorm_gacent sAD)) ?setSI ?(acts_dom actsB). +Qed. + +Lemma acts_gen A S : + S \subset R -> [acts A, on S | to] -> [acts A, on <> | to]. +Proof. +move=> sSR actsA; apply: {A}subset_trans actsA _. +apply/subsetP=> a nSa; have Da := astabs_dom nSa; rewrite !inE Da. +apply: subset_trans (_ : <> \subset actm to a @*^-1 <>) _. + rewrite gen_subG subsetI sSR; apply/subsetP=> x Sx. + by rewrite inE /= actmE ?mem_gen // astabs_act. +by apply/subsetP=> x; rewrite !inE; case/andP=> Rx; rewrite /= actmE. +Qed. + +Lemma acts_joing A M N : + M \subset R -> N \subset R -> [acts A, on M | to] -> [acts A, on N | to] -> + [acts A, on M <*> N | to]. +Proof. by move=> sMR sNR nMA nNA; rewrite acts_gen ?actsU // subUset sMR. Qed. + +Lemma injm_actm a : 'injm (actm to a). +Proof. +apply/injmP=> x y Rx Ry; rewrite /= /actm; case: ifP => Da //. +exact: act_inj. +Qed. + +Lemma im_actm a : actm to a @* R = R. +Proof. +apply/eqP; rewrite eqEcard (card_injm (injm_actm a)) // leqnn andbT. +apply/subsetP=> _ /morphimP[x Rx _ ->] /=. +by rewrite /actm; case: ifP => // Da; rewrite gact_stable. +Qed. + +Lemma acts_char G M : G \subset D -> M \char R -> [acts G, on M | to]. +Proof. +move=> sGD /charP[sMR charM]. +apply/subsetP=> a Ga; have Da := subsetP sGD a Ga; rewrite !inE Da. +apply/subsetP=> x Mx; have Rx := subsetP sMR x Mx. +by rewrite inE -(charM _ (injm_actm a) (im_actm a)) -actmE // mem_morphim. +Qed. + +Lemma gacts_char G M : + G \subset D -> M \char R -> {acts G, on group M | to}. +Proof. by move=> sGD charM; split; rewrite (acts_char, char_sub). Qed. + +Section Restrict. + +Variables (A : {group aT}) (sAD : A \subset D). + +Lemma ract_is_groupAction : is_groupAction R (to \ sAD). +Proof. by move=> a Aa /=; rewrite ractpermE actperm_Aut ?(subsetP sAD). Qed. + +Canonical ract_groupAction := GroupAction ract_is_groupAction. + +Lemma gacent_ract B : 'C_(|ract_groupAction)(B) = 'C_(|to)(A :&: B). +Proof. by rewrite /gacent afix_ract setIA (setIidPr sAD). Qed. + +End Restrict. + +Section ActBy. + +Variables (A : {group aT}) (G : {group rT}) (nGAg : {acts A, on group G | to}). + +Lemma actby_is_groupAction : is_groupAction G <[nGAg]>. +Proof. +move=> a Aa; rewrite /= inE; apply/andP; split. + apply/subsetP=> x; apply: contraR => Gx. + by rewrite actpermE /= /actby (negbTE Gx). +apply/morphicP=> x y Gx Gy; rewrite !actpermE /= /actby Aa groupM ?Gx ?Gy //=. +by case nGAg; move/acts_dom; do 2!move/subsetP=> ?; rewrite gactM; auto. +Qed. + +Canonical actby_groupAction := GroupAction actby_is_groupAction. + +Lemma gacent_actby B : + 'C_(|actby_groupAction)(B) = 'C_(G | to)(A :&: B). +Proof. +rewrite /gacent afix_actby !setIA setIid setIUr setICr set0U. +by have [nAG sGR] := nGAg; rewrite (setIidPr (acts_dom nAG)) (setIidPl sGR). +Qed. + +End ActBy. + +Section Quotient. + +Variable H : {group rT}. + +Lemma acts_qact_dom_norm : {acts qact_dom to H, on 'N(H) | to}. +Proof. +move=> a HDa /= x; rewrite {2}(('N(H) =P to^~ a @^-1: 'N(H)) _) ?inE {x}//. +rewrite eqEcard (card_preimset _ (act_inj _ _)) leqnn andbT. +apply/subsetP=> x Nx; rewrite inE; move/(astabs_act (H :* x)): HDa. +rewrite mem_rcosets mulSGid ?normG // Nx => /rcosetsP[y Ny defHy]. +suffices: to x a \in H :* y by apply: subsetP; rewrite mul_subG ?sub1set ?normG. +by rewrite -defHy; apply: mem_imset; exact: rcoset_refl. +Qed. + +Lemma qact_is_groupAction : is_groupAction (R / H) (to / H). +Proof. +move=> a HDa /=; have Da := astabs_dom HDa. +rewrite inE; apply/andP; split. + apply/subsetP=> Hx /=; case: (cosetP Hx) => x Nx ->{Hx}. + apply: contraR => R'Hx; rewrite actpermE qactE // gact_out //. + by apply: contra R'Hx; apply: mem_morphim. +apply/morphicP=> Hx Hy; rewrite !actpermE. +case/morphimP=> x Nx Gx ->{Hx}; case/morphimP=> y Ny Gy ->{Hy}. +by rewrite -morphM ?qactE ?groupM ?gactM // morphM ?acts_qact_dom_norm. +Qed. + +Canonical quotient_groupAction := GroupAction qact_is_groupAction. + +Lemma qact_domE : H \subset R -> qact_dom to H = 'N(H | to). +Proof. +move=> sHR; apply/setP=> a; apply/idP/idP=> nHa; have Da := astabs_dom nHa. + rewrite !inE Da; apply/subsetP=> x Hx; rewrite inE -(rcoset1 H). + have /rcosetsP[y Ny defHy]: to^~ a @: H \in rcosets H 'N(H). + by rewrite (astabs_act _ nHa) -{1}(mulg1 H) -rcosetE mem_imset ?group1. + by rewrite (@rcoset_transl _ H 1 y) -defHy -1?(gact1 Da) mem_setact. +rewrite !inE Da; apply/subsetP=> Hx; rewrite inE => /rcosetsP[x Nx ->{Hx}]. +apply/imsetP; exists (to x a). + case Rx: (x \in R); last by rewrite gact_out ?Rx. + rewrite inE; apply/subsetP=> _ /imsetP[y Hy ->]. + rewrite -(actKVin to Da y) -gactJ // ?(subsetP sHR, astabs_act, groupV) //. + by rewrite memJ_norm // astabs_act ?groupV. +apply/eqP; rewrite rcosetE eqEcard. +rewrite (card_imset _ (act_inj _ _)) !card_rcoset leqnn andbT. +apply/subsetP=> _ /imsetP[y Hxy ->]; rewrite !mem_rcoset in Hxy *. +have Rxy := subsetP sHR _ Hxy; rewrite -(mulgKV x y). +case Rx: (x \in R); last by rewrite !gact_out ?mulgK // 1?groupMl ?Rx. +by rewrite -gactV // -gactM 1?groupMr ?groupV // mulgK astabs_act. +Qed. + +End Quotient. + +Section Mod. + +Variable H : {group aT}. + +Lemma modact_is_groupAction : is_groupAction 'C_(|to)(H) (to %% H). +Proof. +move=> Ha /morphimP[a Na Da ->]; have NDa: a \in 'N_D(H) by exact/setIP. +rewrite inE; apply/andP; split. + apply/subsetP=> x; rewrite 2!inE andbC actpermE /= modactEcond //. + by apply: contraR; case: ifP => // E Rx; rewrite gact_out. +apply/morphicP=> x y /setIP[Rx cHx] /setIP[Ry cHy]. +rewrite /= !actpermE /= !modactE ?gactM //. +suffices: x * y \in 'C_(|to)(H) by case/setIP. +rewrite groupM //; exact/setIP. +Qed. + +Canonical mod_groupAction := GroupAction modact_is_groupAction. + +Lemma modgactE x a : + H \subset 'C(R | to) -> a \in 'N_D(H) -> (to %% H)%act x (coset H a) = to x a. +Proof. +move=> cRH NDa /=; have [Da Na] := setIP NDa. +have [Rx | notRx] := boolP (x \in R). + by rewrite modactE //; apply/afixP=> b /setIP[_ /(subsetP cRH)/astab_act->]. +rewrite gact_out //= /modact; case: ifP => // _; rewrite gact_out //. +suffices: a \in D :&: coset H a by case/mem_repr/setIP. +by rewrite inE Da val_coset // rcoset_refl. +Qed. + +Lemma gacent_mod G M : + H \subset 'C(M | to) -> G \subset 'N(H) -> + 'C_(M | mod_groupAction)(G / H) = 'C_(M | to)(G). +Proof. +move=> cMH nHG; rewrite -gacentIdom gacentE ?subsetIl // setICA. +have sHD: H \subset D by rewrite (subset_trans cMH) ?subsetIl. +rewrite -quotientGI // afix_mod ?setIS // setICA -gacentIim (setIC R) -setIA. +rewrite -gacentE ?subsetIl // gacentIdom setICA (setIidPr _) //. +by rewrite gacentC // ?(subset_trans cMH) ?astabS ?subsetIl // setICA subsetIl. +Qed. + +Lemma acts_irr_mod G M : + H \subset 'C(M | to) -> G \subset 'N(H) -> acts_irreducibly G M to -> + acts_irreducibly (G / H) M mod_groupAction. +Proof. +move=> cMH nHG /mingroupP[/andP[ntM nMG] minM]. +apply/mingroupP; rewrite ntM astabs_mod ?quotientS //; split=> // L modL ntL. +have cLH: H \subset 'C(L | to) by rewrite (subset_trans cMH) ?astabS //. +apply: minM => //; case/andP: modL => ->; rewrite astabs_mod ?quotientSGK //. +by rewrite (subset_trans cLH) ?astab_sub. +Qed. + +End Mod. + +Lemma modact_coset_astab x a : + a \in D -> (to %% 'C(R | to))%act x (coset _ a) = to x a. +Proof. +move=> Da; apply: modgactE => {x}//. +rewrite !inE Da; apply/subsetP=> _ /imsetP[c Cc ->]. +have Dc := astab_dom Cc; rewrite !inE groupJ //. +apply/subsetP=> x Rx; rewrite inE conjgE !actMin ?groupM ?groupV //. +by rewrite (astab_act Cc) ?actKVin // gact_stable ?groupV. +Qed. + +Lemma acts_irr_mod_astab G M : + acts_irreducibly G M to -> + acts_irreducibly (G / 'C_G(M | to)) M (mod_groupAction _). +Proof. +move=> irrG; have /andP[_ nMG] := mingroupp irrG. +apply: acts_irr_mod irrG; first exact: subsetIr. +by rewrite normsI ?normG // (subset_trans nMG) // astab_norm. +Qed. + +Section CompAct. + +Variables (gT : finGroupType) (G : {group gT}) (f : {morphism G >-> aT}). + +Lemma comp_is_groupAction : is_groupAction R (comp_action to f). +Proof. +move=> a /morphpreP[Ba Dfa]; apply: etrans (actperm_Aut to Dfa). +by congr (_ \in Aut R); apply/permP=> x; rewrite !actpermE. +Qed. +Canonical comp_groupAction := GroupAction comp_is_groupAction. + +Lemma gacent_comp U : 'C_(|comp_groupAction)(U) = 'C_(|to)(f @* U). +Proof. +rewrite /gacent afix_comp ?subIset ?subxx //. +by rewrite -(setIC U) (setIC D) morphim_setIpre. +Qed. + +End CompAct. + +End GroupActionTheory. + +Notation "''C_' ( | to ) ( A )" := (gacent_group to A) : Group_scope. +Notation "''C_' ( G | to ) ( A )" := + (setI_group G 'C_(|to)(A)) : Group_scope. +Notation "''C_' ( | to ) [ a ]" := (gacent_group to [set a%g]) : Group_scope. +Notation "''C_' ( G | to ) [ a ]" := + (setI_group G 'C_(|to)[a]) : Group_scope. + +Notation "to \ sAD" := (ract_groupAction to sAD) : groupAction_scope. +Notation "<[ nGA ] >" := (actby_groupAction nGA) : groupAction_scope. +Notation "to / H" := (quotient_groupAction to H) : groupAction_scope. +Notation "to %% H" := (mod_groupAction to H) : groupAction_scope. +Notation "to \o f" := (comp_groupAction to f) : groupAction_scope. + +(* Operator group isomorphism. *) +Section MorphAction. + +Variables (aT1 aT2 : finGroupType) (rT1 rT2 : finType). +Variables (D1 : {group aT1}) (D2 : {group aT2}). +Variables (to1 : action D1 rT1) (to2 : action D2 rT2). +Variables (A : {set aT1}) (R S : {set rT1}). +Variables (h : rT1 -> rT2) (f : {morphism D1 >-> aT2}). +Hypotheses (actsDR : {acts D1, on R | to1}) (injh : {in R &, injective h}). +Hypothesis defD2 : f @* D1 = D2. +Hypotheses (sSR : S \subset R) (sAD1 : A \subset D1). +Hypothesis hfJ : {in S & D1, morph_act to1 to2 h f}. + +Lemma morph_astabs : f @* 'N(S | to1) = 'N(h @: S | to2). +Proof. +apply/setP=> fx; apply/morphimP/idP=> [[x D1x nSx ->] | nSx]. + rewrite 2!inE -{1}defD2 mem_morphim //=; apply/subsetP=> _ /imsetP[u Su ->]. + by rewrite inE -hfJ ?mem_imset // (astabs_act _ nSx). +have [|x D1x _ def_fx] := morphimP (_ : fx \in f @* D1). + by rewrite defD2 (astabs_dom nSx). +exists x => //; rewrite !inE D1x; apply/subsetP=> u Su. +have /imsetP[u' Su' /injh def_u']: h (to1 u x) \in h @: S. + by rewrite hfJ // -def_fx (astabs_act _ nSx) mem_imset. +by rewrite inE def_u' ?actsDR ?(subsetP sSR). +Qed. + +Lemma morph_astab : f @* 'C(S | to1) = 'C(h @: S | to2). +Proof. +apply/setP=> fx; apply/morphimP/idP=> [[x D1x cSx ->] | cSx]. + rewrite 2!inE -{1}defD2 mem_morphim //=; apply/subsetP=> _ /imsetP[u Su ->]. + by rewrite inE -hfJ // (astab_act cSx). +have [|x D1x _ def_fx] := morphimP (_ : fx \in f @* D1). + by rewrite defD2 (astab_dom cSx). +exists x => //; rewrite !inE D1x; apply/subsetP=> u Su. +rewrite inE -(inj_in_eq injh) ?actsDR ?(subsetP sSR) ?hfJ //. +by rewrite -def_fx (astab_act cSx) ?mem_imset. +Qed. + +Lemma morph_afix : h @: 'Fix_(S | to1)(A) = 'Fix_(h @: S | to2)(f @* A). +Proof. +apply/setP=> hu; apply/imsetP/setIP=> [[u /setIP[Su cAu] ->]|]. + split; first by rewrite mem_imset. + by apply/afixP=> _ /morphimP[x D1x Ax ->]; rewrite -hfJ ?(afixP cAu). +case=> /imsetP[u Su ->] /afixP c_hu_fA; exists u; rewrite // inE Su. +apply/afixP=> x Ax; have Dx := subsetP sAD1 x Ax. +by apply: injh; rewrite ?actsDR ?(subsetP sSR) ?hfJ // c_hu_fA ?mem_morphim. +Qed. + +End MorphAction. + +Section MorphGroupAction. + +Variables (aT1 aT2 rT1 rT2 : finGroupType). +Variables (D1 : {group aT1}) (D2 : {group aT2}). +Variables (R1 : {group rT1}) (R2 : {group rT2}). +Variables (to1 : groupAction D1 R1) (to2 : groupAction D2 R2). +Variables (h : {morphism R1 >-> rT2}) (f : {morphism D1 >-> aT2}). +Hypotheses (iso_h : isom R1 R2 h) (iso_f : isom D1 D2 f). +Hypothesis hfJ : {in R1 & D1, morph_act to1 to2 h f}. +Implicit Types (A : {set aT1}) (S : {set rT1}) (M : {group rT1}). + +Lemma morph_gastabs S : S \subset R1 -> f @* 'N(S | to1) = 'N(h @* S | to2). +Proof. +have [[_ defD2] [injh _]] := (isomP iso_f, isomP iso_h). +move=> sSR1; rewrite (morphimEsub _ sSR1). +apply: (morph_astabs (gact_stable to1) (injmP injh)) => // u x. +by move/(subsetP sSR1); exact: hfJ. +Qed. + +Lemma morph_gastab S : S \subset R1 -> f @* 'C(S | to1) = 'C(h @* S | to2). +Proof. +have [[_ defD2] [injh _]] := (isomP iso_f, isomP iso_h). +move=> sSR1; rewrite (morphimEsub _ sSR1). +apply: (morph_astab (gact_stable to1) (injmP injh)) => // u x. +by move/(subsetP sSR1); exact: hfJ. +Qed. + +Lemma morph_gacent A : A \subset D1 -> h @* 'C_(|to1)(A) = 'C_(|to2)(f @* A). +Proof. +have [[_ defD2] [injh defR2]] := (isomP iso_f, isomP iso_h). +move=> sAD1; rewrite !gacentE //; last by rewrite -defD2 morphimS. +rewrite morphimEsub ?subsetIl // -{1}defR2 morphimEdom. +exact: (morph_afix (gact_stable to1) (injmP injh)). +Qed. + +Lemma morph_gact_irr A M : + A \subset D1 -> M \subset R1 -> + acts_irreducibly (f @* A) (h @* M) to2 = acts_irreducibly A M to1. +Proof. +move=> sAD1 sMR1. +have [[injf defD2] [injh defR2]] := (isomP iso_f, isomP iso_h). +have h_eq1 := morphim_injm_eq1 injh. +apply/mingroupP/mingroupP=> [] [/andP[ntM actAM] minM]. + split=> [|U]; first by rewrite -h_eq1 // ntM -(injmSK injf) ?morph_gastabs. + case/andP=> ntU acts_fAU sUM; have sUR1 := subset_trans sUM sMR1. + apply: (injm_morphim_inj injh) => //; apply: minM; last exact: morphimS. + by rewrite h_eq1 // ntU -morph_gastabs ?morphimS. +split=> [|U]; first by rewrite h_eq1 // ntM -morph_gastabs ?morphimS. +case/andP=> ntU acts_fAU sUhM. +have sUhR1 := subset_trans sUhM (morphimS h sMR1). +have sU'M: h @*^-1 U \subset M by rewrite sub_morphpre_injm. +rewrite /= -(minM _ _ sU'M) ?morphpreK // -h_eq1 ?subsetIl // -(injmSK injf) //. +by rewrite morph_gastabs ?(subset_trans sU'M) // morphpreK ?ntU. +Qed. + +End MorphGroupAction. + +(* Conjugation and right translation actions. *) +Section InternalActionDefs. + +Variable gT : finGroupType. +Implicit Type A : {set gT}. +Implicit Type G : {group gT}. + +(* This is not a Canonical action because it is seldom used, and it would *) +(* cause too many spurious matches (any group product would be viewed as an *) +(* action!). *) +Definition mulgr_action := TotalAction (@mulg1 gT) (@mulgA gT). + +Canonical conjg_action := TotalAction (@conjg1 gT) (@conjgM gT). + +Lemma conjg_is_groupAction : is_groupAction setT conjg_action. +Proof. +move=> a _; rewrite /= inE; apply/andP; split. + by apply/subsetP=> x _; rewrite inE. +by apply/morphicP=> x y _ _; rewrite !actpermE /= conjMg. +Qed. + +Canonical conjg_groupAction := GroupAction conjg_is_groupAction. + +Lemma rcoset_is_action : is_action setT (@rcoset gT). +Proof. +by apply: is_total_action => [A|A x y]; rewrite !rcosetE (mulg1, rcosetM). +Qed. + +Canonical rcoset_action := Action rcoset_is_action. + +Canonical conjsg_action := TotalAction (@conjsg1 gT) (@conjsgM gT). + +Lemma conjG_is_action : is_action setT (@conjG_group gT). +Proof. +apply: is_total_action => [G | G x y]; apply: val_inj; rewrite /= ?act1 //. +exact: actM. +Qed. + +Definition conjG_action := Action conjG_is_action. + +End InternalActionDefs. + +Notation "'R" := (@mulgr_action _) (at level 8) : action_scope. +Notation "'Rs" := (@rcoset_action _) (at level 8) : action_scope. +Notation "'J" := (@conjg_action _) (at level 8) : action_scope. +Notation "'J" := (@conjg_groupAction _) (at level 8) : groupAction_scope. +Notation "'Js" := (@conjsg_action _) (at level 8) : action_scope. +Notation "'JG" := (@conjG_action _) (at level 8) : action_scope. +Notation "'Q" := ('J / _)%act (at level 8) : action_scope. +Notation "'Q" := ('J / _)%gact (at level 8) : groupAction_scope. + +Section InternalGroupAction. + +Variable gT : finGroupType. +Implicit Types A B : {set gT}. +Implicit Types G H : {group gT}. +Implicit Type x : gT. + +(* Various identities for actions on groups. *) + +Lemma orbitR G x : orbit 'R G x = x *: G. +Proof. by rewrite -lcosetE. Qed. + +Lemma astab1R x : 'C[x | 'R] = 1. +Proof. +apply/trivgP/subsetP=> y cxy. +by rewrite -(mulKg x y) [x * y](astab1P cxy) mulVg set11. +Qed. + +Lemma astabR G : 'C(G | 'R) = 1. +Proof. +apply/trivgP/subsetP=> x cGx. +by rewrite -(mul1g x) [1 * x](astabP cGx) group1. +Qed. + +Lemma astabsR G : 'N(G | 'R) = G. +Proof. +apply/setP=> x; rewrite !inE -setactVin ?inE //=. +by rewrite -groupV -{1 3}(mulg1 G) rcoset_sym -sub1set -mulGS -!rcosetE. +Qed. + +Lemma atransR G : [transitive G, on G | 'R]. +Proof. by rewrite /atrans -{1}(mul1g G) -orbitR mem_imset. Qed. + +Lemma faithfulR G : [faithful G, on G | 'R]. +Proof. by rewrite /faithful astabR subsetIr. Qed. + +Definition Cayley_repr G := actperm <[atrans_acts (atransR G)]>. + +Theorem Cayley_isom G : isom G (Cayley_repr G @* G) (Cayley_repr G). +Proof. exact: faithful_isom (faithfulR G). Qed. + +Theorem Cayley_isog G : G \isog Cayley_repr G @* G. +Proof. exact: isom_isog (Cayley_isom G). Qed. + +Lemma orbitJ G x : orbit 'J G x = x ^: G. Proof. by []. Qed. + +Lemma afixJ A : 'Fix_('J)(A) = 'C(A). +Proof. +apply/setP=> x; apply/afixP/centP=> cAx y Ay /=. + by rewrite /commute conjgC cAx. +by rewrite conjgE cAx ?mulKg. +Qed. + +Lemma astabJ A : 'C(A |'J) = 'C(A). +Proof. +apply/setP=> x; apply/astabP/centP=> cAx y Ay /=. + by apply: esym; rewrite conjgC cAx. +by rewrite conjgE -cAx ?mulKg. +Qed. + +Lemma astab1J x : 'C[x |'J] = 'C[x]. +Proof. by rewrite astabJ cent_set1. Qed. + +Lemma astabsJ A : 'N(A | 'J) = 'N(A). +Proof. by apply/setP=> x; rewrite -2!groupV !inE -conjg_preim -sub_conjg. Qed. + +Lemma setactJ A x : 'J^*%act A x = A :^ x. Proof. by []. Qed. + +Lemma gacentJ A : 'C_(|'J)(A) = 'C(A). +Proof. by rewrite gacentE ?setTI ?subsetT ?afixJ. Qed. + +Lemma orbitRs G A : orbit 'Rs G A = rcosets A G. Proof. by []. Qed. + +Lemma sub_afixRs_norms G x A : (G :* x \in 'Fix_('Rs)(A)) = (A \subset G :^ x). +Proof. +rewrite inE /=; apply: eq_subset_r => a. +rewrite inE rcosetE -(can2_eq (rcosetKV x) (rcosetK x)) -!rcosetM. +rewrite eqEcard card_rcoset leqnn andbT mulgA (conjgCV x) mulgK. +by rewrite -{2 3}(mulGid G) mulGS sub1set -mem_conjg. +Qed. + +Lemma sub_afixRs_norm G x : (G :* x \in 'Fix_('Rs)(G)) = (x \in 'N(G)). +Proof. by rewrite sub_afixRs_norms -groupV inE sub_conjgV. Qed. + +Lemma afixRs_rcosets A G : 'Fix_(rcosets G A | 'Rs)(G) = rcosets G 'N_A(G). +Proof. +apply/setP=> Gx; apply/setIP/rcosetsP=> [[/rcosetsP[x Ax ->]]|[x]]. + by rewrite sub_afixRs_norm => Nx; exists x; rewrite // inE Ax. +by case/setIP=> Ax Nx ->; rewrite -{1}rcosetE mem_imset // sub_afixRs_norm. +Qed. + +Lemma astab1Rs G : 'C[G : {set gT} | 'Rs] = G. +Proof. +apply/setP=> x. +by apply/astab1P/idP=> /= [<- | Gx]; rewrite rcosetE ?rcoset_refl ?rcoset_id. +Qed. + +Lemma actsRs_rcosets H G : [acts G, on rcosets H G | 'Rs]. +Proof. by rewrite -orbitRs acts_orbit ?subsetT. Qed. + +Lemma transRs_rcosets H G : [transitive G, on rcosets H G | 'Rs]. +Proof. by rewrite -orbitRs atrans_orbit. Qed. + +(* This is the second part of Aschbacher (5.7) *) +Lemma astabRs_rcosets H G : 'C(rcosets H G | 'Rs) = gcore H G. +Proof. +have transGH := transRs_rcosets H G. +by rewrite (astab_trans_gcore transGH (orbit_refl _ G _)) astab1Rs. +Qed. + +Lemma orbitJs G A : orbit 'Js G A = A :^: G. Proof. by []. Qed. + +Lemma astab1Js A : 'C[A | 'Js] = 'N(A). +Proof. by apply/setP=> x; apply/astab1P/normP. Qed. + +Lemma card_conjugates A G : #|A :^: G| = #|G : 'N_G(A)|. +Proof. by rewrite card_orbit astab1Js. Qed. + +Lemma afixJG G A : (G \in 'Fix_('JG)(A)) = (A \subset 'N(G)). +Proof. by apply/afixP/normsP=> nG x Ax; apply/eqP; move/eqP: (nG x Ax). Qed. + +Lemma astab1JG G : 'C[G | 'JG] = 'N(G). +Proof. +by apply/setP=> x; apply/astab1P/normP=> [/congr_group | /group_inj]. +Qed. + +Lemma dom_qactJ H : qact_dom 'J H = 'N(H). +Proof. by rewrite qact_domE ?subsetT ?astabsJ. Qed. + +Lemma qactJ H (Hy : coset_of H) x : + 'Q%act Hy x = if x \in 'N(H) then Hy ^ coset H x else Hy. +Proof. +case: (cosetP Hy) => y Ny ->{Hy}. +by rewrite qactEcond // dom_qactJ; case Nx: (x \in 'N(H)); rewrite ?morphJ. +Qed. + +Lemma actsQ A B H : + A \subset 'N(H) -> A \subset 'N(B) -> [acts A, on B / H | 'Q]. +Proof. +by move=> nHA nBA; rewrite acts_quotient // subsetI dom_qactJ nHA astabsJ. +Qed. + +Lemma astabsQ G H : H <| G -> 'N(G / H | 'Q) = 'N(H) :&: 'N(G). +Proof. by move=> nsHG; rewrite astabs_quotient // dom_qactJ astabsJ. Qed. + +Lemma astabQ H Abar : 'C(Abar |'Q) = coset H @*^-1 'C(Abar). +Proof. +apply/setP=> x; rewrite inE /= dom_qactJ morphpreE in_setI /=. +apply: andb_id2l => Nx; rewrite !inE -sub1set centsC cent_set1. +apply: eq_subset_r => {Abar} Hy; rewrite inE qactJ Nx (sameP eqP conjg_fixP). +by rewrite (sameP cent1P eqP) (sameP commgP eqP). +Qed. + +Lemma sub_astabQ A H Bbar : + (A \subset 'C(Bbar | 'Q)) = (A \subset 'N(H)) && (A / H \subset 'C(Bbar)). +Proof. +rewrite astabQ -morphpreIdom subsetI; apply: andb_id2l => nHA. +by rewrite -sub_quotient_pre. +Qed. + +Lemma sub_astabQR A B H : + A \subset 'N(H) -> B \subset 'N(H) -> + (A \subset 'C(B / H | 'Q)) = ([~: A, B] \subset H). +Proof. +move=> nHA nHB; rewrite sub_astabQ nHA /= (sameP commG1P eqP). +by rewrite eqEsubset sub1G andbT -quotientR // quotient_sub1 // comm_subG. +Qed. + +Lemma astabQR A H : A \subset 'N(H) -> + 'C(A / H | 'Q) = [set x in 'N(H) | [~: [set x], A] \subset H]. +Proof. +move=> nHA; apply/setP=> x; rewrite astabQ -morphpreIdom 2!inE -astabQ. +by case nHx: (x \in _); rewrite //= -sub1set sub_astabQR ?sub1set. +Qed. + +Lemma quotient_astabQ H Abar : 'C(Abar | 'Q) / H = 'C(Abar). +Proof. by rewrite astabQ cosetpreK. Qed. + +Lemma conj_astabQ A H x : + x \in 'N(H) -> 'C(A / H | 'Q) :^ x = 'C(A :^ x / H | 'Q). +Proof. +move=> nHx; apply/setP=> y; rewrite !astabQ mem_conjg !in_setI -mem_conjg. +rewrite -normJ (normP nHx) quotientJ //; apply/andb_id2l => nHy. +by rewrite !inE centJ morphJ ?groupV ?morphV // -mem_conjg. +Qed. + +Section CardClass. + +Variable G : {group gT}. + +Lemma index_cent1 x : #|G : 'C_G[x]| = #|x ^: G|. +Proof. by rewrite -astab1J -card_orbit. Qed. + +Lemma classes_partition : partition (classes G) G. +Proof. by apply: orbit_partition; apply/actsP=> x Gx y; exact: groupJr. Qed. + +Lemma sum_card_class : \sum_(C in classes G) #|C| = #|G|. +Proof. by apply: acts_sum_card_orbit; apply/actsP=> x Gx y; exact: groupJr. Qed. + +Lemma class_formula : \sum_(C in classes G) #|G : 'C_G[repr C]| = #|G|. +Proof. +rewrite -sum_card_class; apply: eq_bigr => _ /imsetP[x Gx ->]. +have: x \in x ^: G by rewrite -{1}(conjg1 x) mem_imset. +by case/mem_repr/imsetP=> y Gy ->; rewrite index_cent1 classGidl. +Qed. + +Lemma abelian_classP : reflect {in G, forall x, x ^: G = [set x]} (abelian G). +Proof. +rewrite /abelian -astabJ astabC. +by apply: (iffP subsetP) => cGG x Gx; apply/orbit1P; exact: cGG. +Qed. + +Lemma card_classes_abelian : abelian G = (#|classes G| == #|G|). +Proof. +have cGgt0 C: C \in classes G -> 1 <= #|C| ?= iff (#|C| == 1)%N. + by case/imsetP=> x _ ->; rewrite eq_sym -index_cent1. +rewrite -sum_card_class -sum1_card (leqif_sum cGgt0). +apply/abelian_classP/forall_inP=> [cGG _ /imsetP[x Gx ->]| cGG x Gx]. + by rewrite cGG ?cards1. +apply/esym/eqP; rewrite eqEcard sub1set cards1 class_refl leq_eqVlt cGG //. +exact: mem_imset. +Qed. + +End CardClass. + +End InternalGroupAction. + +Lemma gacentQ (gT : finGroupType) (H : {group gT}) (A : {set gT}) : + 'C_(|'Q)(A) = 'C(A / H). +Proof. +apply/setP=> Hx; case: (cosetP Hx) => x Nx ->{Hx}. +rewrite -sub_cent1 -astab1J astabC sub1set -(quotientInorm H A). +have defD: qact_dom 'J H = 'N(H) by rewrite qact_domE ?subsetT ?astabsJ. +rewrite !(inE, mem_quotient) //= defD setIC. +apply/subsetP/subsetP=> [cAx _ /morphimP[a Na Aa ->] | cAx a Aa]. + by move/cAx: Aa; rewrite !inE qactE ?defD ?morphJ. +have [_ Na] := setIP Aa; move/implyP: (cAx (coset H a)); rewrite mem_morphim //. +by rewrite !inE qactE ?defD ?morphJ. +Qed. + +Section AutAct. + +Variable (gT : finGroupType) (G : {set gT}). + +Definition autact := act ('P \ subsetT (Aut G)). +Canonical aut_action := [action of autact]. + +Lemma autactK a : actperm aut_action a = a. +Proof. by apply/permP=> x; rewrite permE. Qed. + +Lemma autact_is_groupAction : is_groupAction G aut_action. +Proof. by move=> a Aa /=; rewrite autactK. Qed. +Canonical aut_groupAction := GroupAction autact_is_groupAction. + +End AutAct. + +Arguments Scope aut_action [_ group_scope]. +Arguments Scope aut_groupAction [_ group_scope]. +Notation "[ 'Aut' G ]" := (aut_action G) : action_scope. +Notation "[ 'Aut' G ]" := (aut_groupAction G) : groupAction_scope. + + diff --git a/mathcomp/fingroup/all.v b/mathcomp/fingroup/all.v new file mode 100644 index 0000000..0cf8995 --- /dev/null +++ b/mathcomp/fingroup/all.v @@ -0,0 +1,10 @@ +Require Export action. +Require Export automorphism. +Require Export cyclic. +Require Export fingroup. +Require Export gproduct. +Require Export morphism. +Require Export perm. +Require Export presentation. +Require Export quotient. +Require Export zmodp. diff --git a/mathcomp/fingroup/automorphism.v b/mathcomp/fingroup/automorphism.v new file mode 100644 index 0000000..1644ebf --- /dev/null +++ b/mathcomp/fingroup/automorphism.v @@ -0,0 +1,489 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat fintype finset. +Require Import fingroup perm morphism. + +(******************************************************************************) +(* Group automorphisms and characteristic subgroups. *) +(* Unlike morphisms on a group G, which are functions of type gT -> rT, with *) +(* a canonical structure of dependent type {morphim G >-> rT}, automorphisms *) +(* are permutations of type {perm gT} contained in Aut G : {set {perm gT}}. *) +(* This lets us use the finGroupType of {perm gT}. Note also that while *) +(* morphisms on G are undefined outside G, automorphisms have their support *) +(* in G, i.e., they are the identity ouside G. *) +(* Definitions: *) +(* Aut G (or [Aut G]) == the automorphism group of G. *) +(* [Aut G]%G == the group structure for Aut G. *) +(* autm AutGa == the morphism on G induced by a, given *) +(* AutGa : a \in Aut G. *) +(* perm_in injf fA == the permutation with support B in induced by f, *) +(* given injf : {in A &, injective f} and *) +(* fA : f @: A \subset A. *) +(* aut injf fG == the automorphism of G induced by the morphism f, *) +(* given injf : 'injm f and fG : f @* G \subset G. *) +(* Aut_isom injf sDom == the injective homomorphism that maps Aut G to *) +(* Aut (f @* G), with f : {morphism D >-> rT} and *) +(* given injf: 'injm f and sDom : G \subset D. *) +(* conjgm G == the conjugation automorphism on G. *) +(* H \char G == H is a characteristic subgroup of G. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +(***********************************************************************) +(* A group automorphism, defined as a permutation on a subset of a *) +(* finGroupType that respects the morphism law. *) +(* Here perm_on is used as a closure rule for the set A. *) +(***********************************************************************) + +Section Automorphism. + +Variable gT : finGroupType. +Implicit Type A : {set gT}. +Implicit Types a b : {perm gT}. + +Definition Aut A := [set a | perm_on A a & morphic A a]. + +Lemma Aut_morphic A a : a \in Aut A -> morphic A a. +Proof. by case/setIdP. Qed. + +Lemma out_Aut A a x : a \in Aut A -> x \notin A -> a x = x. +Proof. by case/setIdP=> Aa _; exact: out_perm. Qed. + +Lemma eq_Aut A : {in Aut A &, forall a b, {in A, a =1 b} -> a = b}. +Proof. +move=> a g Aa Ag /= eqag; apply/permP=> x. +by have [/eqag // | /out_Aut out] := boolP (x \in A); rewrite !out. +Qed. + +(* The morphism that is represented by a given element of Aut A. *) + +Definition autm A a (AutAa : a \in Aut A) := morphm (Aut_morphic AutAa). +Lemma autmE A a (AutAa : a \in Aut A) : autm AutAa = a. +Proof. by []. Qed. + +Canonical autm_morphism A a aM := Eval hnf in [morphism of @autm A a aM]. + +Section AutGroup. + +Variable G : {group gT}. + +Lemma Aut_group_set : group_set (Aut G). +Proof. +apply/group_setP; split=> [|a b]. + by rewrite inE perm_on1; apply/morphicP=> ? *; rewrite !permE. +rewrite !inE => /andP[Ga aM] /andP[Gb bM]; rewrite perm_onM //=. +apply/morphicP=> x y Gx Gy; rewrite !permM (morphicP aM) //. +by rewrite (morphicP bM) ?perm_closed. +Qed. + +Canonical Aut_group := group Aut_group_set. + +Variable (a : {perm gT}) (AutGa : a \in Aut G). +Notation f := (autm AutGa). +Notation fE := (autmE AutGa). + +Lemma injm_autm : 'injm f. +Proof. apply/injmP; apply: in2W; exact: perm_inj. Qed. + +Lemma ker_autm : 'ker f = 1. Proof. by move/trivgP: injm_autm. Qed. + +Lemma im_autm : f @* G = G. +Proof. +apply/setP=> x; rewrite morphimEdom (can_imset_pre _ (permK a)) inE. +by have:= AutGa; rewrite inE => /andP[/perm_closed <-]; rewrite permKV. +Qed. + +Lemma Aut_closed x : x \in G -> a x \in G. +Proof. by move=> Gx; rewrite -im_autm; exact: mem_morphim. Qed. + +End AutGroup. + +Lemma Aut1 : Aut 1 = 1. +Proof. +apply/trivgP/subsetP=> a /= AutGa; apply/set1P. +apply: eq_Aut (AutGa) (group1 _) _ => _ /set1P->. +by rewrite -(autmE AutGa) morph1 perm1. +Qed. + +End Automorphism. + +Arguments Scope Aut [_ group_scope]. +Notation "[ 'Aut' G ]" := (Aut_group G) + (at level 0, format "[ 'Aut' G ]") : Group_scope. +Notation "[ 'Aut' G ]" := (Aut G) + (at level 0, only parsing) : group_scope. + +Prenex Implicits Aut autm. + +(* The permutation function (total on the underlying groupType) that is the *) +(* representant of a given morphism f with domain A in (Aut A). *) + +Section PermIn. + +Variables (T : finType) (A : {set T}) (f : T -> T). + +Hypotheses (injf : {in A &, injective f}) (sBf : f @: A \subset A). + +Lemma perm_in_inj : injective (fun x => if x \in A then f x else x). +Proof. +move=> x y /=; wlog Ay: x y / y \in A. + by move=> IH eqfxy; case: ifP (eqfxy); [symmetry | case: ifP => //]; auto. +rewrite Ay; case: ifP => [Ax | nAx def_x]; first exact: injf. +by case/negP: nAx; rewrite def_x (subsetP sBf) ?mem_imset. +Qed. + +Definition perm_in := perm perm_in_inj. + +Lemma perm_in_on : perm_on A perm_in. +Proof. +by apply/subsetP=> x; rewrite inE /= permE; case: ifP => // _; case/eqP. +Qed. + +Lemma perm_inE : {in A, perm_in =1 f}. +Proof. by move=> x Ax; rewrite /= permE Ax. Qed. + +End PermIn. + +(* properties of injective endomorphisms *) + +Section MakeAut. + +Variables (gT : finGroupType) (G : {group gT}) (f : {morphism G >-> gT}). +Implicit Type A : {set gT}. + +Hypothesis injf : 'injm f. + +Lemma morphim_fixP A : A \subset G -> reflect (f @* A = A) (f @* A \subset A). +Proof. +rewrite /morphim => sAG; have:= eqEcard (f @: A) A. +rewrite (setIidPr sAG) card_in_imset ?leqnn ?andbT => [<-|]; first exact: eqP. +move/injmP: injf; apply: sub_in2; exact/subsetP. +Qed. + +Hypothesis Gf : f @* G = G. + +Lemma aut_closed : f @: G \subset G. +Proof. by rewrite -morphimEdom; exact/morphim_fixP. Qed. + +Definition aut := perm_in (injmP injf) aut_closed. + +Lemma autE : {in G, aut =1 f}. +Proof. exact: perm_inE. Qed. + +Lemma morphic_aut : morphic G aut. +Proof. by apply/morphicP=> x y Gx Gy /=; rewrite !autE ?groupM // morphM. Qed. + +Lemma Aut_aut : aut \in Aut G. +Proof. by rewrite inE morphic_aut perm_in_on. Qed. + +Lemma imset_autE A : A \subset G -> aut @: A = f @* A. +Proof. +move=> sAG; rewrite /morphim (setIidPr sAG). +apply: eq_in_imset; apply: sub_in1 autE; exact/subsetP. +Qed. + +Lemma preim_autE A : A \subset G -> aut @^-1: A = f @*^-1 A. +Proof. +move=> sAG; apply/setP=> x; rewrite !inE permE /=. +by case Gx: (x \in G) => //; apply/negP=> Ax; rewrite (subsetP sAG) in Gx. +Qed. + +End MakeAut. + +Implicit Arguments morphim_fixP [gT G f]. +Prenex Implicits aut morphim_fixP. + +Section AutIsom. + +Variables (gT rT : finGroupType) (G D : {group gT}) (f : {morphism D >-> rT}). + +Hypotheses (injf : 'injm f) (sGD : G \subset D). +Let domG := subsetP sGD. + +Lemma Aut_isom_subproof a : + {a' | a' \in Aut (f @* G) & a \in Aut G -> {in G, a' \o f =1 f \o a}}. +Proof. +set Aut_a := autm (subgP (subg [Aut G] a)). +have aDom: 'dom (f \o Aut_a \o invm injf) = f @* G. + rewrite /dom /= morphpre_invm -morphpreIim; congr (f @* _). + by rewrite [_ :&: D](setIidPl _) ?injmK ?injm_autm ?im_autm. +have [af [def_af ker_af _ im_af]] := domP _ aDom. +have inj_a': 'injm af by rewrite ker_af !injm_comp ?injm_autm ?injm_invm. +have im_a': af @* (f @* G) = f @* G. + by rewrite im_af !morphim_comp morphim_invm // im_autm. +pose a' := aut inj_a' im_a'; exists a' => [|AutGa x Gx]; first exact: Aut_aut. +have Dx := domG Gx; rewrite /= [a' _]autE ?mem_morphim //. +by rewrite def_af /= invmE // autmE subgK. +Qed. + +Definition Aut_isom a := s2val (Aut_isom_subproof a). + +Lemma Aut_Aut_isom a : Aut_isom a \in Aut (f @* G). +Proof. by rewrite /Aut_isom; case: (Aut_isom_subproof a). Qed. + +Lemma Aut_isomE a : a \in Aut G -> {in G, forall x, Aut_isom a (f x) = f (a x)}. +Proof. by rewrite /Aut_isom; case: (Aut_isom_subproof a). Qed. + +Lemma Aut_isomM : {in Aut G &, {morph Aut_isom: x y / x * y}}. +Proof. +move=> a b AutGa AutGb. +apply: (eq_Aut (Aut_Aut_isom _)); rewrite ?groupM ?Aut_Aut_isom // => fx. +case/morphimP=> x Dx Gx ->{fx}. +by rewrite permM !Aut_isomE ?groupM /= ?permM ?Aut_closed. +Qed. +Canonical Aut_isom_morphism := Morphism Aut_isomM. + +Lemma injm_Aut_isom : 'injm Aut_isom. +Proof. +apply/injmP=> a b AutGa AutGb eq_ab'; apply: (eq_Aut AutGa AutGb) => x Gx. +by apply: (injmP injf); rewrite ?domG ?Aut_closed // -!Aut_isomE //= eq_ab'. +Qed. + +End AutIsom. + +Section InjmAut. + +Variables (gT rT : finGroupType) (G D : {group gT}) (f : {morphism D >-> rT}). + +Hypotheses (injf : 'injm f) (sGD : G \subset D). +Let domG := subsetP sGD. + +Lemma im_Aut_isom : Aut_isom injf sGD @* Aut G = Aut (f @* G). +Proof. +apply/eqP; rewrite eqEcard; apply/andP; split. + by apply/subsetP=> _ /morphimP[a _ AutGa ->]; exact: Aut_Aut_isom. +have inj_isom' := injm_Aut_isom (injm_invm injf) (morphimS _ sGD). +rewrite card_injm ?injm_Aut_isom // -(card_injm inj_isom') ?subset_leq_card //. +apply/subsetP=> a /morphimP[a' _ AutfGa' def_a]. +by rewrite -(morphim_invm injf sGD) def_a Aut_Aut_isom. +Qed. + +Lemma Aut_isomP : isom (Aut G) (Aut (f @* G)) (Aut_isom injf sGD). +Proof. by apply/isomP; split; [exact: injm_Aut_isom | exact: im_Aut_isom]. Qed. + +Lemma injm_Aut : Aut (f @* G) \isog Aut G. +Proof. by rewrite isog_sym (isom_isog _ _ Aut_isomP). Qed. + +End InjmAut. + +(* conjugation automorphism *) + +Section ConjugationMorphism. + +Variable gT : finGroupType. +Implicit Type A : {set gT}. + +Definition conjgm of {set gT} := fun x y : gT => y ^ x. + +Lemma conjgmE A x y : conjgm A x y = y ^ x. Proof. by []. Qed. + +Canonical conjgm_morphism A x := + @Morphism _ _ A (conjgm A x) (in2W (fun y z => conjMg y z x)). + +Lemma morphim_conj A x B : conjgm A x @* B = (A :&: B) :^ x. +Proof. by []. Qed. + +Variable G : {group gT}. + +Lemma injm_conj x : 'injm (conjgm G x). +Proof. by apply/injmP; apply: in2W; exact: conjg_inj. Qed. + +Lemma conj_isom x : isom G (G :^ x) (conjgm G x). +Proof. by apply/isomP; rewrite morphim_conj setIid injm_conj. Qed. + +Lemma conj_isog x : G \isog G :^ x. +Proof. exact: isom_isog (conj_isom x). Qed. + +Lemma norm_conjg_im x : x \in 'N(G) -> conjgm G x @* G = G. +Proof. by rewrite morphimEdom; exact: normP. Qed. + +Lemma norm_conj_isom x : x \in 'N(G) -> isom G G (conjgm G x). +Proof. by move/norm_conjg_im/restr_isom_to/(_ (conj_isom x))->. Qed. + +Definition conj_aut x := aut (injm_conj _) (norm_conjg_im (subgP (subg _ x))). + +Lemma norm_conj_autE : {in 'N(G) & G, forall x y, conj_aut x y = y ^ x}. +Proof. by move=> x y nGx Gy; rewrite /= autE //= subgK. Qed. + +Lemma conj_autE : {in G &, forall x y, conj_aut x y = y ^ x}. +Proof. by apply: sub_in11 norm_conj_autE => //; exact: subsetP (normG G). Qed. + +Lemma conj_aut_morphM : {in 'N(G) &, {morph conj_aut : x y / x * y}}. +Proof. +move=> x y nGx nGy; apply/permP=> z /=; rewrite permM. +case Gz: (z \in G); last by rewrite !permE /= !Gz. +by rewrite !norm_conj_autE // (conjgM, memJ_norm, groupM). +Qed. + +Canonical conj_aut_morphism := Morphism conj_aut_morphM. + +Lemma ker_conj_aut : 'ker conj_aut = 'C(G). +Proof. +apply/setP=> x; rewrite inE; case nGx: (x \in 'N(G)); last first. + by symmetry; apply/idP=> cGx; rewrite (subsetP (cent_sub G)) in nGx. +rewrite 2!inE /=; apply/eqP/centP=> [cx1 y Gy | cGx]. + by rewrite /commute (conjgC y) -norm_conj_autE // cx1 perm1. +apply/permP=> y; case Gy: (y \in G); last by rewrite !permE Gy. +by rewrite perm1 norm_conj_autE // conjgE -cGx ?mulKg. +Qed. + +Lemma Aut_conj_aut A : conj_aut @* A \subset Aut G. +Proof. by apply/subsetP=> _ /imsetP[x _ ->]; exact: Aut_aut. Qed. + +End ConjugationMorphism. + +Arguments Scope conjgm [_ group_scope]. +Prenex Implicits conjgm conj_aut. + +Reserved Notation "G \char H" (at level 70). + +(* Characteristic subgroup *) + +Section Characteristicity. + +Variable gT : finGroupType. +Implicit Types A B : {set gT}. +Implicit Types G H K L : {group gT}. + +Definition characteristic A B := + (A \subset B) && [forall f in Aut B, f @: A \subset A]. + +Infix "\char" := characteristic. + +Lemma charP H G : + reflect [/\ H \subset G + & forall f : {morphism G >-> gT}, + 'injm f -> f @* G = G -> f @* H = H] + (H \char G). +Proof. +apply: (iffP andP) => [] [sHG chHG]; split=> //. + move=> f injf Gf; apply/morphim_fixP=> //. + by have:= forallP chHG (aut injf Gf); rewrite Aut_aut imset_autE. +apply/forall_inP=> f Af; have injf := injm_autm Af. +move/(morphim_fixP injf _ sHG): (chHG _ injf (im_autm Af)). +by rewrite /morphim (setIidPr _). +Qed. + +(* Characteristic subgroup properties : composition, relational properties *) + +Lemma char1 G : 1 \char G. +Proof. by apply/charP; split=> [|f _ _]; rewrite (sub1G, morphim1). Qed. + +Lemma char_refl G : G \char G. +Proof. exact/charP. Qed. + +Lemma char_trans H G K : K \char H -> H \char G -> K \char G. +Proof. +case/charP=> sKH chKH; case/charP=> sHG chHG. +apply/charP; split=> [|f injf Gf]; first exact: subset_trans sHG. +rewrite -{1}(setIidPr sKH) -(morphim_restrm sHG) chKH //. + rewrite ker_restrm; move/trivgP: injf => ->; exact: subsetIr. +by rewrite morphim_restrm setIid chHG. +Qed. + +Lemma char_norms H G : H \char G -> 'N(G) \subset 'N(H). +Proof. +case/charP=> sHG chHG; apply/normsP=> x /normP Nx. +have:= chHG [morphism of conjgm G x] => /=. +by rewrite !morphimEsub //=; apply; rewrite // injm_conj. +Qed. + +Lemma char_sub A B : A \char B -> A \subset B. +Proof. by case/andP. Qed. + +Lemma char_norm_trans H G A : H \char G -> A \subset 'N(G) -> A \subset 'N(H). +Proof. by move/char_norms=> nHnG nGA; exact: subset_trans nHnG. Qed. + +Lemma char_normal_trans H G K : K \char H -> H <| G -> K <| G. +Proof. +move=> chKH /andP[sHG nHG]. +by rewrite /normal (subset_trans (char_sub chKH)) // (char_norm_trans chKH). +Qed. + +Lemma char_normal H G : H \char G -> H <| G. +Proof. by move/char_normal_trans; apply; apply/andP; rewrite normG. Qed. + +Lemma char_norm H G : H \char G -> G \subset 'N(H). +Proof. by case/char_normal/andP. Qed. + +Lemma charI G H K : H \char G -> K \char G -> H :&: K \char G. +Proof. +case/charP=> sHG chHG; case/charP=> _ chKG. +apply/charP; split=> [|f injf Gf]; first by rewrite subIset // sHG. +rewrite morphimGI ?(chHG, chKG) //; exact: subset_trans (sub1G H). +Qed. + +Lemma charMgen G H K : H \char G -> K \char G -> H <*> K \char G. +Proof. +case/charP=> sHG chHG; case/charP=> sKG chKG. +apply/charP; split=> [|f injf Gf]; first by rewrite gen_subG subUset sHG. +by rewrite morphim_gen ?(morphimU, subUset, sHG, chHG, chKG). +Qed. + +Lemma charM G H K : H \char G -> K \char G -> H * K \char G. +Proof. +move=> chHG chKG; rewrite -norm_joinEl ?charMgen //. +exact: subset_trans (char_sub chHG) (char_norm chKG). +Qed. + +Lemma lone_subgroup_char G H : + H \subset G -> (forall K, K \subset G -> K \isog H -> K \subset H) -> + H \char G. +Proof. +move=> sHG Huniq; apply/charP; split=> // f injf Gf; apply/eqP. +have{injf} injf: {in H &, injective f}. + by move/injmP: injf; apply: sub_in2; exact/subsetP. +have fH: f @* H = f @: H by rewrite /morphim (setIidPr sHG). +rewrite eqEcard {2}fH card_in_imset ?{}Huniq //=. + by rewrite -{3}Gf morphimS. +rewrite isog_sym; apply/isogP. +exists [morphism of restrm sHG f] => //=; first exact/injmP. +by rewrite morphimEdom fH. +Qed. + +End Characteristicity. + +Arguments Scope characteristic [_ group_scope group_scope]. +Notation "H \char G" := (characteristic H G) : group_scope. + +Section InjmChar. + +Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}). + +Hypothesis injf : 'injm f. + +Lemma injm_char (G H : {group aT}) : + G \subset D -> H \char G -> f @* H \char f @* G. +Proof. +move=> sGD /charP[sHG charH]. +apply/charP; split=> [|g injg gfG]; first exact: morphimS. +have /domP[h [_ ker_h _ im_h]]: 'dom (invm injf \o g \o f) = G. + by rewrite /dom /= -(morphpreIim g) (setIidPl _) ?injmK // gfG morphimS. +have hH: h @* H = H. + apply: charH; first by rewrite ker_h !injm_comp ?injm_invm. + by rewrite im_h !morphim_comp gfG morphim_invm. +rewrite /= -{2}hH im_h !morphim_comp morphim_invmE morphpreK //. +by rewrite (subset_trans _ (morphimS f sGD)) //= -{3}gfG !morphimS. +Qed. + +End InjmChar. + +Section CharInjm. + +Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}). +Hypothesis injf : 'injm f. + +Lemma char_injm (G H : {group aT}) : + G \subset D -> H \subset D -> (f @* H \char f @* G) = (H \char G). +Proof. +move=> sGD sHD; apply/idP/idP; last exact: injm_char. +by move/(injm_char (injm_invm injf)); rewrite !morphim_invm ?morphimS // => ->. +Qed. + +End CharInjm. + +Unset Implicit Arguments. diff --git a/mathcomp/fingroup/cyclic.v b/mathcomp/fingroup/cyclic.v new file mode 100644 index 0000000..ad10492 --- /dev/null +++ b/mathcomp/fingroup/cyclic.v @@ -0,0 +1,865 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +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. diff --git a/mathcomp/fingroup/fingroup.v b/mathcomp/fingroup/fingroup.v new file mode 100644 index 0000000..fe78559 --- /dev/null +++ b/mathcomp/fingroup/fingroup.v @@ -0,0 +1,3096 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype. +Require Import div path bigop prime finset. + +(******************************************************************************) +(* This file defines the main interface for finite groups : *) +(* finGroupType == the structure for finite types with a group law. *) +(* {group gT} == type of groups with elements of type gT. *) +(* baseFinGroupType == the structure for finite types with a monoid law *) +(* and an involutive antimorphism; finGroupType is *) +(* derived from baseFinGroupType (via a telescope). *) +(* FinGroupType mulVg == the finGroupType structure for an existing *) +(* baseFinGroupType structure, built from a proof of *) +(* the left inverse group axiom for that structure's *) +(* operations. *) +(* BaseFinGroupType bgm == the baseFingroupType structure built by packaging *) +(* bgm : FinGroup.mixin_of T for a type T with an *) +(* existing finType structure. *) +(* FinGroup.BaseMixin mulA mul1x invK invM == *) +(* the mixin for a baseFinGroupType structure, built *) +(* from proofs of the baseFinGroupType axioms. *) +(* FinGroup.Mixin mulA mul1x mulVg == *) +(* the mixin for a baseFinGroupType structure, built *) +(* from proofs of the group axioms. *) +(* [baseFinGroupType of T] == a clone of an existing baseFinGroupType *) +(* structure on T, for T (the existing structure *) +(* might be for som delta-expansion of T). *) +(* [finGroupType of T] == a clone of an existing finGroupType structure on *) +(* T, for the canonical baseFinGroupType structure *) +(* of T (the existing structure might be for the *) +(* baseFinGroupType of some delta-expansion of T). *) +(* [group of G] == a clone for an existing {group gT} structure on *) +(* G : {set gT} (the existing structure might be for *) +(* some delta-expansion of G). *) +(* If gT implements finGroupType, then we can form {set gT}, the type of *) +(* finite sets with elements of type gT (as finGroupType extends finType). *) +(* The group law extends pointwise to {set gT}, which thus implements a sub- *) +(* interface baseFinGroupType of finGroupType. To be consistent with the *) +(* predType interface, this is done by coercion to FinGroup.arg_sort, an *) +(* alias for FinGroup.sort. Accordingly, all pointwise group operations below *) +(* have arguments of type (FinGroup.arg_sort) gT and return results of type *) +(* FinGroup.sort gT. *) +(* The notations below are declared in two scopes: *) +(* group_scope (delimiter %g) for point operations and set constructs. *) +(* Group_scope (delimiter %G) for explicit {group gT} structures. *) +(* These scopes should not be opened globally, although group_scope is often *) +(* opened locally in group-theory files (via Import GroupScope). *) +(* As {group gT} is both a subtype and an interface structure for {set gT}, *) +(* the fact that a given G : {set gT} is a group can (and usually should) be *) +(* inferred by type inference with canonical structures. This means that all *) +(* `group' constructions (e.g., the normaliser 'N_G(H)) actually define sets *) +(* with a canonical {group gT} structure; the %G delimiter can be used to *) +(* specify the actual {group gT} structure (e.g., 'N_G(H)%G). *) +(* Operations on elements of a group: *) +(* x * y == the group product of x and y. *) +(* x ^+ n == the nth power of x, i.e., x * ... * x (n times). *) +(* x^-1 == the group inverse of x. *) +(* x ^- n == the inverse of x ^+ n (notation for (x ^+ n)^-1). *) +(* 1 == the unit element. *) +(* x ^ y == the conjugate of x by y. *) +(* \prod_(i ...) x i == the product of the x i (order-sensitive). *) +(* commute x y <-> x and y commute. *) +(* centralises x A <-> x centralises A. *) +(* 'C[x] == the set of elements that commute with x. *) +(* 'C_G[x] == the set of elements of G that commute with x. *) +(* <[x]> == the cyclic subgroup generated by the element x. *) +(* #[x] == the order of the element x, i.e., #|<[x]>|. *) +(* [~ x1, ..., xn] == the commutator of x1, ..., xn. *) +(* Operations on subsets/subgroups of a finite group: *) +(* H * G == {xy | x \in H, y \in G}. *) +(* 1 or [1] or [1 gT] == the unit group. *) +(* [set: gT]%G == the group of all x : gT (in Group_scope). *) +(* [subg G] == the subtype, set, or group of all x \in G: this *) +(* notation is defined simultaneously in %type, %g *) +(* and %G scopes, and G must denote a {group gT} *) +(* structure (G is in the %G scope). *) +(* subg, sgval == the projection into and injection from [subg G]. *) +(* H^# == the set H minus the unit element *) +(* repr H == some element of H if 1 \notin H != set0, else 1. *) +(* (repr is defined over sets of a baseFinGroupType, *) +(* so it can be used, e.g., to pick right cosets.) *) +(* x *: H == left coset of H by x. *) +(* lcosets H G == the set of the left cosets of H by elements of G. *) +(* H :* x == right coset of H by x. *) +(* rcosets H G == the set of the right cosets of H by elements of G. *) +(* #|G : H| == the index of H in G, i.e., #|rcosets G H|. *) +(* H :^ x == the conjugate of H by x. *) +(* x ^: H == the conjugate class of x in H. *) +(* classes G == the set of all conjugate classes of G. *) +(* G :^: H == {G :^ x | x \in H}. *) +(* class_support G H == {x ^ y | x \in G, y \in H}. *) +(* [~: H1, ..., Hn] == commutator subgroup of H1, ..., Hn. *) +(*{in G, centralised H} <-> G centralises H. *) +(* {in G, normalised H} <-> G normalises H. *) +(* <-> forall x, x \in G -> H :^ x = H. *) +(* 'N(H) == the normaliser of H. *) +(* 'N_G(H) == the normaliser of H in G. *) +(* H <| G <=> H is normal in G. *) +(* 'C(H) == the centraliser of H. *) +(* 'C_G(H) == the centraliser of H in G. *) +(* <> == the subgroup generated by the set H. *) +(* H <*> G == the subgroup generated by sets H and G (H join G). *) +(* (H * G)%G == the join of G H : {group gT} (convertible, but not *) +(* identical to (G <*> H)%G). *) +(* (\prod_(i ...) H i)%G == the group generated by the H i. *) +(* gcore H G == the largest subgroup of H normalised by G. *) +(* If H is a subgroup of G, this is the largest *) +(* normal subgroup of G contained in H). *) +(* abelian H <=> H is abelian. *) +(* subgroups G == the set of subgroups of G, i.e., the set of all *) +(* H : {group gT} such that H \subset G. *) +(* In the notation below G is a variable that is bound in P. *) +(* [max G | P] <=> G is the largest group such that P holds. *) +(* [max H of G | P] <=> H is the largest group G such that P holds. *) +(* [max G | P & Q] := [max G | P && Q], likewise [max H of G | P & Q]. *) +(* [min G | P] <=> G is the smallest group such that P holds. *) +(* [min G | P & Q] := [min G | P && Q], likewise [min H of G | P & Q]. *) +(* [min H of G | P] <=> H is the smallest group G such that P holds. *) +(* In addition to the generic suffixes described in ssrbool.v and finset.v, *) +(* we associate the following suffixes to group operations: *) +(* 1 - identity element, as in group1 : 1 \in G. *) +(* M - multiplication, as is invMg : (x * y)^-1 = x^-1 * y^-1. *) +(* Also nat multiplication, for expgM : x ^+ (m * n) = x ^+ m ^+ n. *) +(* D - (nat) addition, for expgD : x ^+ (m + n) = x ^+ m * x ^+ n. *) +(* V - inverse, as in mulgV : x * x^-1 = 1. *) +(* X - exponentiation, as in conjXg : (x ^+ n) ^ y = (x ^ y) ^+ n. *) +(* J - conjugation, as in orderJ : #[x ^ y] = #[x]. *) +(* R - commutator, as in conjRg : [~ x, y] ^ z = [~ x ^ z, y ^ z]. *) +(* Y - join, as in centY : 'C(G <*> H) = 'C(G) :&: 'C(H). *) +(* We sometimes prefix these with an `s' to indicate a set-lifted operation, *) +(* e.g., conjsMg : (A * B) :^ x = A :^ x * B :^ x. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Delimit Scope group_scope with g. +Delimit Scope Group_scope with G. + +(* This module can be imported to open the scope for group element *) +(* operations locally to a file, without exporing the Open to *) +(* clients of that file (as Open would do). *) +Module GroupScope. +Open Scope group_scope. +End GroupScope. +Import GroupScope. + +(* These are the operation notations introduced by this file. *) +Reserved Notation "[ ~ x1 , x2 , .. , xn ]" (at level 0, + format "'[ ' [ ~ x1 , '/' x2 , '/' .. , '/' xn ] ']'"). +Reserved Notation "[ 1 gT ]" (at level 0, format "[ 1 gT ]"). +Reserved Notation "[ 1 ]" (at level 0, format "[ 1 ]"). +Reserved Notation "[ 'subg' G ]" (at level 0, format "[ 'subg' G ]"). +Reserved Notation "A ^#" (at level 2, format "A ^#"). +Reserved Notation "A :^ x" (at level 35, right associativity). +Reserved Notation "x ^: B" (at level 35, right associativity). +Reserved Notation "A :^: B" (at level 35, right associativity). +Reserved Notation "#| B : A |" (at level 0, B, A at level 99, + format "#| B : A |"). +Reserved Notation "''N' ( A )" (at level 8, format "''N' ( A )"). +Reserved Notation "''N_' G ( A )" (at level 8, G at level 2, + format "''N_' G ( A )"). +Reserved Notation "A <| B" (at level 70, no associativity). +Reserved Notation "#[ x ]" (at level 0, format "#[ x ]"). +Reserved Notation "A <*> B" (at level 40, left associativity). +Reserved Notation "[ ~: A1 , A2 , .. , An ]" (at level 0, + format "[ ~: '[' A1 , '/' A2 , '/' .. , '/' An ']' ]"). +Reserved Notation "[ 'max' A 'of' G | gP ]" (at level 0, + format "[ '[hv' 'max' A 'of' G '/ ' | gP ']' ]"). +Reserved Notation "[ 'max' G | gP ]" (at level 0, + format "[ '[hv' 'max' G '/ ' | gP ']' ]"). +Reserved Notation "[ 'max' A 'of' G | gP & gQ ]" (at level 0, + format "[ '[hv' 'max' A 'of' G '/ ' | gP '/ ' & gQ ']' ]"). +Reserved Notation "[ 'max' G | gP & gQ ]" (at level 0, + format "[ '[hv' 'max' G '/ ' | gP '/ ' & gQ ']' ]"). +Reserved Notation "[ 'min' A 'of' G | gP ]" (at level 0, + format "[ '[hv' 'min' A 'of' G '/ ' | gP ']' ]"). +Reserved Notation "[ 'min' G | gP ]" (at level 0, + format "[ '[hv' 'min' G '/ ' | gP ']' ]"). +Reserved Notation "[ 'min' A 'of' G | gP & gQ ]" (at level 0, + format "[ '[hv' 'min' A 'of' G '/ ' | gP '/ ' & gQ ']' ]"). +Reserved Notation "[ 'min' G | gP & gQ ]" (at level 0, + format "[ '[hv' 'min' G '/ ' | gP '/ ' & gQ ']' ]"). + +Module FinGroup. + +(* We split the group axiomatisation in two. We define a *) +(* class of "base groups", which are basically monoids *) +(* with an involutive antimorphism, from which we derive *) +(* the class of groups proper. This allows use to reuse *) +(* much of the group notation and algebraic axioms for *) +(* group subsets, by defining a base group class on them. *) +(* We use class/mixins here rather than telescopes to *) +(* be able to interoperate with the type coercions. *) +(* Another potential benefit (not exploited here) would *) +(* be to define a class for infinite groups, which could *) +(* share all of the algebraic laws. *) +Record mixin_of (T : Type) : Type := BaseMixin { + mul : T -> T -> T; + one : T; + inv : T -> T; + _ : associative mul; + _ : left_id one mul; + _ : involutive inv; + _ : {morph inv : x y / mul x y >-> mul y x} +}. + +Structure base_type : Type := PackBase { + sort : Type; + _ : mixin_of sort; + _ : Finite.class_of sort +}. + +(* We want to use sort as a coercion class, both to infer *) +(* argument scopes properly, and to allow groups and cosets to *) +(* coerce to the base group of group subsets. *) +(* However, the return type of group operations should NOT be a *) +(* coercion class, since this would trump the real (head-normal) *) +(* coercion class for concrete group types, thus spoiling the *) +(* coercion of A * B to pred_sort in x \in A * B, or rho * tau to *) +(* ffun and Funclass in (rho * tau) x, when rho tau : perm T. *) +(* Therefore we define an alias of sort for argument types, and *) +(* make it the default coercion FinGroup.base_class >-> Sortclass *) +(* so that arguments of a functions whose parameters are of type, *) +(* say, gT : finGroupType, can be coerced to the coercion class *) +(* of arg_sort. Care should be taken, however, to declare the *) +(* return type of functions and operators as FinGroup.sort gT *) +(* rather than gT, e.g., mulg : gT -> gT -> FinGroup.sort gT. *) +(* Note that since we do this here and in quotient.v for all the *) +(* basic functions, the inferred return type should generally be *) +(* correct. *) +Definition arg_sort := sort. + +Definition mixin T := + let: PackBase _ m _ := T return mixin_of (sort T) in m. + +Definition finClass T := + let: PackBase _ _ m := T return Finite.class_of (sort T) in m. + +Structure type : Type := Pack { + base : base_type; + _ : left_inverse (one (mixin base)) (inv (mixin base)) (mul (mixin base)) +}. + +(* We only need three axioms to make a true group. *) + +Section Mixin. + +Variables (T : Type) (one : T) (mul : T -> T -> T) (inv : T -> T). + +Hypothesis mulA : associative mul. +Hypothesis mul1 : left_id one mul. +Hypothesis mulV : left_inverse one inv mul. +Notation "1" := one. +Infix "*" := mul. +Notation "x ^-1" := (inv x). + +Lemma mk_invgK : involutive inv. +Proof. +have mulV21 x: x^-1^-1 * 1 = x by rewrite -(mulV x) mulA mulV mul1. +by move=> x; rewrite -[_ ^-1]mulV21 -(mul1 1) mulA !mulV21. +Qed. + +Lemma mk_invMg : {morph inv : x y / x * y >-> y * x}. +Proof. +have mulxV x: x * x^-1 = 1 by rewrite -{1}[x]mk_invgK mulV. +move=> x y /=; rewrite -[y^-1 * _]mul1 -(mulV (x * y)) -2!mulA (mulA y). +by rewrite mulxV mul1 mulxV -(mulxV (x * y)) mulA mulV mul1. +Qed. + +Definition Mixin := BaseMixin mulA mul1 mk_invgK mk_invMg. + +End Mixin. + +Definition pack_base T m := + fun c cT & phant_id (Finite.class cT) c => @PackBase T m c. + +Definition clone_base T := + fun bT & sort bT -> T => + fun m c (bT' := @PackBase T m c) & phant_id bT' bT => bT'. + +Definition clone T := + fun bT gT & sort bT * sort (base gT) -> T * T => + fun m (gT' := @Pack bT m) & phant_id gT' gT => gT'. + +Section InheritedClasses. + +Variable bT : base_type. +Local Notation T := (arg_sort bT). +Local Notation rT := (sort bT). +Local Notation class := (finClass bT). + +Canonical eqType := Equality.Pack class rT. +Canonical choiceType := Choice.Pack class rT. +Canonical countType := Countable.Pack class rT. +Canonical finType := Finite.Pack class rT. +Definition arg_eqType := Eval hnf in [eqType of T]. +Definition arg_choiceType := Eval hnf in [choiceType of T]. +Definition arg_countType := Eval hnf in [countType of T]. +Definition arg_finType := Eval hnf in [finType of T]. + +End InheritedClasses. + +Module Import Exports. +(* Declaring sort as a Coercion is clearly redundant; it only *) +(* serves the purpose of eliding FinGroup.sort in the display of *) +(* return types. The warning could be eliminated by using the *) +(* functor trick to replace Sortclass by a dummy target. *) +Coercion arg_sort : base_type >-> Sortclass. +Coercion sort : base_type >-> Sortclass. +Coercion mixin : base_type >-> mixin_of. +Coercion base : type >-> base_type. +Canonical eqType. +Canonical choiceType. +Canonical countType. +Canonical finType. +Coercion arg_eqType : base_type >-> Equality.type. +Canonical arg_eqType. +Coercion arg_choiceType : base_type >-> Choice.type. +Canonical arg_choiceType. +Coercion arg_countType : base_type >-> Countable.type. +Canonical arg_countType. +Coercion arg_finType : base_type >-> Finite.type. +Canonical arg_finType. +Bind Scope group_scope with sort. +Bind Scope group_scope with arg_sort. +Notation baseFinGroupType := base_type. +Notation finGroupType := type. +Notation BaseFinGroupType T m := (@pack_base T m _ _ id). +Notation FinGroupType := Pack. +Notation "[ 'baseFinGroupType' 'of' T ]" := (@clone_base T _ id _ _ id) + (at level 0, format "[ 'baseFinGroupType' 'of' T ]") : form_scope. +Notation "[ 'finGroupType' 'of' T ]" := (@clone T _ _ id _ id) + (at level 0, format "[ 'finGroupType' 'of' T ]") : form_scope. +End Exports. + +End FinGroup. +Export FinGroup.Exports. + +Section ElementOps. + +Variable T : baseFinGroupType. +Notation rT := (FinGroup.sort T). + +Definition oneg : rT := FinGroup.one T. +Definition mulg : T -> T -> rT := FinGroup.mul T. +Definition invg : T -> rT := FinGroup.inv T. +Definition expgn_rec (x : T) n : rT := iterop n mulg x oneg. + +End ElementOps. + +Definition expgn := nosimpl expgn_rec. + +Notation "1" := (oneg _) : group_scope. +Notation "x1 * x2" := (mulg x1 x2) : group_scope. +Notation "x ^-1" := (invg x) : group_scope. +Notation "x ^+ n" := (expgn x n) : group_scope. +Notation "x ^- n" := (x ^+ n)^-1 : group_scope. + +(* Arguments of conjg are restricted to true groups to avoid an *) +(* improper interpretation of A ^ B with A and B sets, namely: *) +(* {x^-1 * (y * z) | y \in A, x, z \in B} *) +Definition conjg (T : finGroupType) (x y : T) := y^-1 * (x * y). +Notation "x1 ^ x2" := (conjg x1 x2) : group_scope. + +Definition commg (T : finGroupType) (x y : T) := x^-1 * x ^ y. +Notation "[ ~ x1 , x2 , .. , xn ]" := (commg .. (commg x1 x2) .. xn) + : group_scope. + +Prenex Implicits mulg invg expgn conjg commg. + +Notation "\prod_ ( i <- r | P ) F" := + (\big[mulg/1]_(i <- r | P%B) F%g) : group_scope. +Notation "\prod_ ( i <- r ) F" := + (\big[mulg/1]_(i <- r) F%g) : group_scope. +Notation "\prod_ ( m <= i < n | P ) F" := + (\big[mulg/1]_(m <= i < n | P%B) F%g) : group_scope. +Notation "\prod_ ( m <= i < n ) F" := + (\big[mulg/1]_(m <= i < n) F%g) : group_scope. +Notation "\prod_ ( i | P ) F" := + (\big[mulg/1]_(i | P%B) F%g) : group_scope. +Notation "\prod_ i F" := + (\big[mulg/1]_i F%g) : group_scope. +Notation "\prod_ ( i : t | P ) F" := + (\big[mulg/1]_(i : t | P%B) F%g) (only parsing) : group_scope. +Notation "\prod_ ( i : t ) F" := + (\big[mulg/1]_(i : t) F%g) (only parsing) : group_scope. +Notation "\prod_ ( i < n | P ) F" := + (\big[mulg/1]_(i < n | P%B) F%g) : group_scope. +Notation "\prod_ ( i < n ) F" := + (\big[mulg/1]_(i < n) F%g) : group_scope. +Notation "\prod_ ( i 'in' A | P ) F" := + (\big[mulg/1]_(i in A | P%B) F%g) : group_scope. +Notation "\prod_ ( i 'in' A ) F" := + (\big[mulg/1]_(i in A) F%g) : group_scope. + +Section PreGroupIdentities. + +Variable T : baseFinGroupType. +Implicit Types x y z : T. +Local Notation mulgT := (@mulg T). + +Lemma mulgA : associative mulgT. Proof. by case: T => ? []. Qed. +Lemma mul1g : left_id 1 mulgT. Proof. by case: T => ? []. Qed. +Lemma invgK : @involutive T invg. Proof. by case: T => ? []. Qed. +Lemma invMg x y : (x * y)^-1 = y^-1 * x^-1. Proof. by case: T x y => ? []. Qed. + +Lemma invg_inj : @injective T T invg. Proof. exact: can_inj invgK. Qed. + +Lemma eq_invg_sym x y : (x^-1 == y) = (x == y^-1). +Proof. by exact: (inv_eq invgK). Qed. + +Lemma invg1 : 1^-1 = 1 :> T. +Proof. by apply: invg_inj; rewrite -{1}[1^-1]mul1g invMg invgK mul1g. Qed. + +Lemma eq_invg1 x : (x^-1 == 1) = (x == 1). +Proof. by rewrite eq_invg_sym invg1. Qed. + +Lemma mulg1 : right_id 1 mulgT. +Proof. by move=> x; apply: invg_inj; rewrite invMg invg1 mul1g. Qed. + +Canonical finGroup_law := Monoid.Law mulgA mul1g mulg1. + +Lemma expgnE x n : x ^+ n = expgn_rec x n. Proof. by []. Qed. + +Lemma expg0 x : x ^+ 0 = 1. Proof. by []. Qed. +Lemma expg1 x : x ^+ 1 = x. Proof. by []. Qed. + +Lemma expgS x n : x ^+ n.+1 = x * x ^+ n. +Proof. by case: n => //; rewrite mulg1. Qed. + +Lemma expg1n n : 1 ^+ n = 1 :> T. +Proof. by elim: n => // n IHn; rewrite expgS mul1g. Qed. + +Lemma expgD x n m : x ^+ (n + m) = x ^+ n * x ^+ m. +Proof. by elim: n => [|n IHn]; rewrite ?mul1g // !expgS IHn mulgA. Qed. + +Lemma expgSr x n : x ^+ n.+1 = x ^+ n * x. +Proof. by rewrite -addn1 expgD expg1. Qed. + +Lemma expgM x n m : x ^+ (n * m) = x ^+ n ^+ m. +Proof. +elim: m => [|m IHm]; first by rewrite muln0 expg0. +by rewrite mulnS expgD IHm expgS. +Qed. + +Lemma expgAC x m n : x ^+ m ^+ n = x ^+ n ^+ m. +Proof. by rewrite -!expgM mulnC. Qed. + +Definition commute x y := x * y = y * x. + +Lemma commute_refl x : commute x x. +Proof. by []. Qed. + +Lemma commute_sym x y : commute x y -> commute y x. +Proof. by []. Qed. + +Lemma commute1 x : commute x 1. +Proof. by rewrite /commute mulg1 mul1g. Qed. + +Lemma commuteM x y z : commute x y -> commute x z -> commute x (y * z). +Proof. by move=> cxy cxz; rewrite /commute -mulgA -cxz !mulgA cxy. Qed. + +Lemma commuteX x y n : commute x y -> commute x (y ^+ n). +Proof. +move=> cxy; elim: n => [|n]; [exact: commute1 | rewrite expgS; exact: commuteM]. +Qed. + +Lemma commuteX2 x y m n : commute x y -> commute (x ^+ m) (y ^+ n). +Proof. by move=> cxy; exact/commuteX/commute_sym/commuteX. Qed. + +Lemma expgVn x n : x^-1 ^+ n = x ^- n. +Proof. by elim: n => [|n IHn]; rewrite ?invg1 // expgSr expgS invMg IHn. Qed. + +Lemma expgMn x y n : commute x y -> (x * y) ^+ n = x ^+ n * y ^+ n. +Proof. +move=> cxy; elim: n => [|n IHn]; first by rewrite mulg1. +by rewrite !expgS IHn -mulgA (mulgA y) (commuteX _ (commute_sym cxy)) !mulgA. +Qed. + +End PreGroupIdentities. + +Hint Resolve commute1. +Implicit Arguments invg_inj [T]. +Prenex Implicits commute invgK invg_inj. + +Section GroupIdentities. + +Variable T : finGroupType. +Implicit Types x y z : T. +Local Notation mulgT := (@mulg T). + +Lemma mulVg : left_inverse 1 invg mulgT. +Proof. by case T. Qed. + +Lemma mulgV : right_inverse 1 invg mulgT. +Proof. by move=> x; rewrite -{1}(invgK x) mulVg. Qed. + +Lemma mulKg : left_loop invg mulgT. +Proof. by move=> x y; rewrite mulgA mulVg mul1g. Qed. + +Lemma mulKVg : rev_left_loop invg mulgT. +Proof. by move=> x y; rewrite mulgA mulgV mul1g. Qed. + +Lemma mulgI : right_injective mulgT. +Proof. move=> x; exact: can_inj (mulKg x). Qed. + +Lemma mulgK : right_loop invg mulgT. +Proof. by move=> x y; rewrite -mulgA mulgV mulg1. Qed. + +Lemma mulgKV : rev_right_loop invg mulgT. +Proof. by move=> x y; rewrite -mulgA mulVg mulg1. Qed. + +Lemma mulIg : left_injective mulgT. +Proof. move=> x; exact: can_inj (mulgK x). Qed. + +Lemma eq_invg_mul x y : (x^-1 == y :> T) = (x * y == 1 :> T). +Proof. by rewrite -(inj_eq (@mulgI x)) mulgV eq_sym. Qed. + +Lemma eq_mulgV1 x y : (x == y) = (x * y^-1 == 1 :> T). +Proof. by rewrite -(inj_eq invg_inj) eq_invg_mul. Qed. + +Lemma eq_mulVg1 x y : (x == y) = (x^-1 * y == 1 :> T). +Proof. by rewrite -eq_invg_mul invgK. Qed. + +Lemma commuteV x y : commute x y -> commute x y^-1. +Proof. by move=> cxy; apply: (@mulIg y); rewrite mulgKV -mulgA cxy mulKg. Qed. + +Lemma conjgE x y : x ^ y = y^-1 * (x * y). Proof. by []. Qed. + +Lemma conjgC x y : x * y = y * x ^ y. +Proof. by rewrite mulKVg. Qed. + +Lemma conjgCV x y : x * y = y ^ x^-1 * x. +Proof. by rewrite -mulgA mulgKV invgK. Qed. + +Lemma conjg1 x : x ^ 1 = x. +Proof. by rewrite conjgE commute1 mulKg. Qed. + +Lemma conj1g x : 1 ^ x = 1. +Proof. by rewrite conjgE mul1g mulVg. Qed. + +Lemma conjMg x y z : (x * y) ^ z = x ^ z * y ^ z. +Proof. by rewrite !conjgE !mulgA mulgK. Qed. + +Lemma conjgM x y z : x ^ (y * z) = (x ^ y) ^ z. +Proof. by rewrite !conjgE invMg !mulgA. Qed. + +Lemma conjVg x y : x^-1 ^ y = (x ^ y)^-1. +Proof. by rewrite !conjgE !invMg invgK mulgA. Qed. + +Lemma conjJg x y z : (x ^ y) ^ z = (x ^ z) ^ y ^ z. +Proof. by rewrite 2!conjMg conjVg. Qed. + +Lemma conjXg x y n : (x ^+ n) ^ y = (x ^ y) ^+ n. +Proof. by elim: n => [|n IHn]; rewrite ?conj1g // !expgS conjMg IHn. Qed. + +Lemma conjgK : @right_loop T T invg conjg. +Proof. by move=> y x; rewrite -conjgM mulgV conjg1. Qed. + +Lemma conjgKV : @rev_right_loop T T invg conjg. +Proof. by move=> y x; rewrite -conjgM mulVg conjg1. Qed. + +Lemma conjg_inj : @left_injective T T T conjg. +Proof. move=> y; exact: can_inj (conjgK y). Qed. + +Lemma conjg_eq1 x y : (x ^ y == 1) = (x == 1). +Proof. by rewrite -(inj_eq (@conjg_inj y) x) conj1g. Qed. + +Lemma conjg_prod I r (P : pred I) F z : + (\prod_(i <- r | P i) F i) ^ z = \prod_(i <- r | P i) (F i ^ z). +Proof. +by apply: (big_morph (conjg^~ z)) => [x y|]; rewrite ?conj1g ?conjMg. +Qed. + +Lemma commgEl x y : [~ x, y] = x^-1 * x ^ y. Proof. by []. Qed. + +Lemma commgEr x y : [~ x, y] = y^-1 ^ x * y. +Proof. by rewrite -!mulgA. Qed. + +Lemma commgC x y : x * y = y * x * [~ x, y]. +Proof. by rewrite -mulgA !mulKVg. Qed. + +Lemma commgCV x y : x * y = [~ x^-1, y^-1] * (y * x). +Proof. by rewrite commgEl !mulgA !invgK !mulgKV. Qed. + +Lemma conjRg x y z : [~ x, y] ^ z = [~ x ^ z, y ^ z]. +Proof. by rewrite !conjMg !conjVg. Qed. + +Lemma invg_comm x y : [~ x, y]^-1 = [~ y, x]. +Proof. by rewrite commgEr conjVg invMg invgK. Qed. + +Lemma commgP x y : reflect (commute x y) ([~ x, y] == 1 :> T). +Proof. by rewrite [[~ x, y]]mulgA -invMg -eq_mulVg1 eq_sym; exact: eqP. Qed. + +Lemma conjg_fixP x y : reflect (x ^ y = x) ([~ x, y] == 1 :> T). +Proof. by rewrite -eq_mulVg1 eq_sym; exact: eqP. Qed. + +Lemma commg1_sym x y : ([~ x, y] == 1 :> T) = ([~ y, x] == 1 :> T). +Proof. by rewrite -invg_comm (inv_eq invgK) invg1. Qed. + +Lemma commg1 x : [~ x, 1] = 1. +Proof. exact/eqP/commgP. Qed. + +Lemma comm1g x : [~ 1, x] = 1. +Proof. by rewrite -invg_comm commg1 invg1. Qed. + +Lemma commgg x : [~ x, x] = 1. +Proof. by exact/eqP/commgP. Qed. + +Lemma commgXg x n : [~ x, x ^+ n] = 1. +Proof. exact/eqP/commgP/commuteX. Qed. + +Lemma commgVg x : [~ x, x^-1] = 1. +Proof. by exact/eqP/commgP/commuteV. Qed. + +Lemma commgXVg x n : [~ x, x ^- n] = 1. +Proof. exact/eqP/commgP/commuteV/commuteX. Qed. + +(* Other commg identities should slot in here. *) + +End GroupIdentities. + +Hint Rewrite mulg1 mul1g invg1 mulVg mulgV (@invgK) mulgK mulgKV + invMg mulgA : gsimpl. + +Ltac gsimpl := autorewrite with gsimpl; try done. + +Definition gsimp := (mulg1 , mul1g, (invg1, @invgK), (mulgV, mulVg)). +Definition gnorm := (gsimp, (mulgK, mulgKV, (mulgA, invMg))). + +Implicit Arguments mulgI [T]. +Implicit Arguments mulIg [T]. +Implicit Arguments conjg_inj [T]. +Implicit Arguments commgP [T x y]. +Implicit Arguments conjg_fixP [T x y]. +Prenex Implicits conjg_fixP commgP. + +Section Repr. +(* Plucking a set representative. *) + +Variable gT : baseFinGroupType. +Implicit Type A : {set gT}. + +Definition repr A := if 1 \in A then 1 else odflt 1 [pick x in A]. + +Lemma mem_repr A x : x \in A -> repr A \in A. +Proof. +by rewrite /repr; case: ifP => // _; case: pickP => // A0; rewrite [x \in A]A0. +Qed. + +Lemma card_mem_repr A : #|A| > 0 -> repr A \in A. +Proof. by rewrite lt0n => /existsP[x]; exact: mem_repr. Qed. + +Lemma repr_set1 x : repr [set x] = x. +Proof. by apply/set1P/card_mem_repr; rewrite cards1. Qed. + +Lemma repr_set0 : repr set0 = 1. +Proof. by rewrite /repr; case: pickP => [x|_]; rewrite !inE. Qed. + +End Repr. + +Implicit Arguments mem_repr [gT A]. + +Section BaseSetMulDef. +(* We only assume a baseFinGroupType to allow this construct to be iterated. *) +Variable gT : baseFinGroupType. +Implicit Types A B : {set gT}. + +(* Set-lifted group operations. *) + +Definition set_mulg A B := mulg @2: (A, B). +Definition set_invg A := invg @^-1: A. + +(* The pre-group structure of group subsets. *) + +Lemma set_mul1g : left_id [set 1] set_mulg. +Proof. +move=> A; apply/setP=> y; apply/imset2P/idP=> [[_ x /set1P-> Ax ->] | Ay]. + by rewrite mul1g. +by exists (1 : gT) y; rewrite ?(set11, mul1g). +Qed. + +Lemma set_mulgA : associative set_mulg. +Proof. +move=> A B C; apply/setP=> y. +apply/imset2P/imset2P=> [[x1 z Ax1 /imset2P[x2 x3 Bx2 Cx3 ->] ->]| [z x3]]. + by exists (x1 * x2) x3; rewrite ?mulgA //; apply/imset2P; exists x1 x2. +case/imset2P=> x1 x2 Ax1 Bx2 -> Cx3 ->. +by exists x1 (x2 * x3); rewrite ?mulgA //; apply/imset2P; exists x2 x3. +Qed. + +Lemma set_invgK : involutive set_invg. +Proof. by move=> A; apply/setP=> x; rewrite !inE invgK. Qed. + +Lemma set_invgM : {morph set_invg : A B / set_mulg A B >-> set_mulg B A}. +Proof. +move=> A B; apply/setP=> z; rewrite inE. +apply/imset2P/imset2P=> [[x y Ax By /(canRL invgK)->] | [y x]]. + by exists y^-1 x^-1; rewrite ?invMg // inE invgK. +by rewrite !inE => By1 Ax1 ->; exists x^-1 y^-1; rewrite ?invMg. +Qed. + +Definition group_set_baseGroupMixin : FinGroup.mixin_of (set_type gT) := + FinGroup.BaseMixin set_mulgA set_mul1g set_invgK set_invgM. + +Canonical group_set_baseGroupType := + Eval hnf in BaseFinGroupType (set_type gT) group_set_baseGroupMixin. + +Canonical group_set_of_baseGroupType := + Eval hnf in [baseFinGroupType of {set gT}]. + +End BaseSetMulDef. + +(* Time to open the bag of dirty tricks. When we define groups down below *) +(* as a subtype of {set gT}, we need them to be able to coerce to sets in *) +(* both set-style contexts (x \in G) and monoid-style contexts (G * H), *) +(* and we need the coercion function to be EXACTLY the structure *) +(* projection in BOTH cases -- otherwise the canonical unification breaks.*) +(* Alas, Coq doesn't let us use the same coercion function twice, even *) +(* when the targets are convertible. Our workaround (ab)uses the module *) +(* system to declare two different identity coercions on an alias class. *) + +Module GroupSet. +Definition sort (gT : baseFinGroupType) := {set gT}. +End GroupSet. +Identity Coercion GroupSet_of_sort : GroupSet.sort >-> set_of. + +Module Type GroupSetBaseGroupSig. +Definition sort gT := group_set_of_baseGroupType gT : Type. +End GroupSetBaseGroupSig. + +Module MakeGroupSetBaseGroup (Gset_base : GroupSetBaseGroupSig). +Identity Coercion of_sort : Gset_base.sort >-> FinGroup.arg_sort. +End MakeGroupSetBaseGroup. + +Module Export GroupSetBaseGroup := MakeGroupSetBaseGroup GroupSet. + +Canonical group_set_eqType gT := Eval hnf in [eqType of GroupSet.sort gT]. +Canonical group_set_choiceType gT := + Eval hnf in [choiceType of GroupSet.sort gT]. +Canonical group_set_countType gT := Eval hnf in [countType of GroupSet.sort gT]. +Canonical group_set_finType gT := Eval hnf in [finType of GroupSet.sort gT]. + +Section GroupSetMulDef. +(* Some of these constructs could be defined on a baseFinGroupType. *) +(* We restrict them to proper finGroupType because we only develop *) +(* the theory for that case. *) +Variable gT : finGroupType. +Implicit Types A B : {set gT}. +Implicit Type x y : gT. + +Definition lcoset A x := mulg x @: A. +Definition rcoset A x := mulg^~ x @: A. +Definition lcosets A B := lcoset A @: B. +Definition rcosets A B := rcoset A @: B. +Definition indexg B A := #|rcosets A B|. + +Definition conjugate A x := conjg^~ x @: A. +Definition conjugates A B := conjugate A @: B. +Definition class x B := conjg x @: B. +Definition classes A := class^~ A @: A. +Definition class_support A B := conjg @2: (A, B). + +Definition commg_set A B := commg @2: (A, B). + +(* These will only be used later, but are defined here so that we can *) +(* keep all the Notation together. *) +Definition normaliser A := [set x | conjugate A x \subset A]. +Definition centraliser A := \bigcap_(x in A) normaliser [set x]. +Definition abelian A := A \subset centraliser A. +Definition normal A B := (A \subset B) && (B \subset normaliser A). + +(* "normalised" and "centralise[s|d]" are intended to be used with *) +(* the {in ...} form, as in abelian below. *) +Definition normalised A := forall x, conjugate A x = A. +Definition centralises x A := forall y, y \in A -> commute x y. +Definition centralised A := forall x, centralises x A. + +End GroupSetMulDef. + +Arguments Scope lcoset [_ group_scope group_scope]. +Arguments Scope rcoset [_ group_scope group_scope]. +Arguments Scope rcosets [_ group_scope group_scope]. +Arguments Scope lcosets [_ group_scope group_scope]. +Arguments Scope indexg [_ group_scope group_scope]. +Arguments Scope conjugate [_ group_scope group_scope]. +Arguments Scope conjugates [_ group_scope group_scope]. +Arguments Scope class [_ group_scope group_scope]. +Arguments Scope classes [_ group_scope]. +Arguments Scope class_support [_ group_scope group_scope]. +Arguments Scope commg_set [_ group_scope group_scope]. +Arguments Scope normaliser [_ group_scope]. +Arguments Scope centraliser [_ group_scope]. +Arguments Scope abelian [_ group_scope]. +Arguments Scope normal [_ group_scope group_scope]. +Arguments Scope centralised [_ group_scope]. +Arguments Scope normalised [_ group_scope]. +Arguments Scope centralises [_ group_scope group_scope]. +Arguments Scope centralised [_ group_scope]. + +Notation "[ 1 gT ]" := (1 : {set gT}) : group_scope. +Notation "[ 1 ]" := [1 FinGroup.sort _] : group_scope. + +Notation "A ^#" := (A :\ 1) : group_scope. + +Notation "x *: A" := ([set x%g] * A) : group_scope. +Notation "A :* x" := (A * [set x%g]) : group_scope. +Notation "A :^ x" := (conjugate A x) : group_scope. +Notation "x ^: B" := (class x B) : group_scope. +Notation "A :^: B" := (conjugates A B) : group_scope. + +Notation "#| B : A |" := (indexg B A) : group_scope. + +(* No notation for lcoset and rcoset, which are to be used mostly *) +(* in curried form; x *: B and A :* 1 denote singleton products, *) +(* so thus we can use mulgA, mulg1, etc, on, say, A :* 1 * B :* x. *) +(* No notation for the set commutator generator set set_commg. *) + +Notation "''N' ( A )" := (normaliser A) : group_scope. +Notation "''N_' G ( A )" := (G%g :&: 'N(A)) : group_scope. +Notation "A <| B" := (normal A B) : group_scope. +Notation "''C' ( A )" := (centraliser A) : group_scope. +Notation "''C_' G ( A )" := (G%g :&: 'C(A)) : group_scope. +Notation "''C_' ( G ) ( A )" := 'C_G(A) (only parsing) : group_scope. +Notation "''C' [ x ]" := 'N([set x%g]) : group_scope. +Notation "''C_' G [ x ]" := 'N_G([set x%g]) : group_scope. +Notation "''C_' ( G ) [ x ]" := 'C_G[x] (only parsing) : group_scope. + +Prenex Implicits repr lcoset rcoset lcosets rcosets normal. +Prenex Implicits conjugate conjugates class classes class_support. +Prenex Implicits commg_set normalised centralised abelian. + +Section BaseSetMulProp. +(* Properties of the purely multiplicative structure. *) +Variable gT : baseFinGroupType. +Implicit Types A B C D : {set gT}. +Implicit Type x y z : gT. + +(* Set product. We already have all the pregroup identities, so we *) +(* only need to add the monotonicity rules. *) + +Lemma mulsgP A B x : + reflect (imset2_spec mulg (mem A) (fun _ => mem B) x) (x \in A * B). +Proof. exact: imset2P. Qed. + +Lemma mem_mulg A B x y : x \in A -> y \in B -> x * y \in A * B. +Proof. by move=> Ax By; apply/mulsgP; exists x y. Qed. + +Lemma prodsgP (I : finType) (P : pred I) (A : I -> {set gT}) x : + reflect (exists2 c, forall i, P i -> c i \in A i & x = \prod_(i | P i) c i) + (x \in \prod_(i | P i) A i). +Proof. +rewrite -big_filter filter_index_enum; set r := enum P. +pose inA c i := c i \in A i; set RHS := x \in _. +suffices IHr: reflect (exists2 c, all (inA c) r & x = \prod_(i <- r) c i) RHS. + apply: (iffP IHr) => [][c inAc ->]. + rewrite -[r]filter_index_enum big_filter; exists c => // i Pi. + by apply: (allP inAc); rewrite mem_enum. + rewrite -big_filter filter_index_enum; exists c => //; apply/allP=> i. + rewrite mem_enum; exact: inAc. +have: uniq r by [rewrite enum_uniq]; rewrite {}/RHS. +elim: {P}r x => /= [x _|i r IHr x /andP[r'i Ur]]. + by rewrite unlock; apply: (iffP set1P) => [-> | [] //]; exists (fun _ => 1). +rewrite big_cons; apply: (iffP idP) => [|[c /andP[Aci Ac] ->]]; last first. + by rewrite big_cons mem_mulg //; apply/IHr=> //; exists c. +case/mulsgP=> y _ Ai_y /IHr[//| c Ac ->] ->{x}. +exists [eta c with i |-> y] => /=. + rewrite /inA /= eqxx Ai_y; apply/allP=> j rj. + by case: eqP rj r'i => [-> -> // | _ rj _]; exact: (allP Ac). +rewrite big_cons eqxx !big_seq; congr (_ * _). +by apply: eq_bigr => j rj; case: eqP rj r'i => // -> ->. +Qed. + +Lemma mem_prodg (I : finType) (P : pred I) (A : I -> {set gT}) c : + (forall i, P i -> c i \in A i) -> \prod_(i | P i) c i \in \prod_(i | P i) A i. +Proof. by move=> Ac; apply/prodsgP; exists c. Qed. + +Lemma mulSg A B C : A \subset B -> A * C \subset B * C. +Proof. exact: imset2Sl. Qed. + +Lemma mulgS A B C : B \subset C -> A * B \subset A * C. +Proof. exact: imset2Sr. Qed. + +Lemma mulgSS A B C D : A \subset B -> C \subset D -> A * C \subset B * D. +Proof. exact: imset2S. Qed. + +Lemma mulg_subl A B : 1 \in B -> A \subset A * B. +Proof. by move=> B1; rewrite -{1}(mulg1 A) mulgS ?sub1set. Qed. + +Lemma mulg_subr A B : 1 \in A -> B \subset A * B. +Proof. by move=> A1; rewrite -{1}(mul1g B) mulSg ?sub1set. Qed. + +Lemma mulUg A B C : (A :|: B) * C = (A * C) :|: (B * C). +Proof. exact: imset2Ul. Qed. + +Lemma mulgU A B C : A * (B :|: C) = (A * B) :|: (A * C). +Proof. exact: imset2Ur. Qed. + +(* Set (pointwise) inverse. *) + +Lemma invUg A B : (A :|: B)^-1 = A^-1 :|: B^-1. +Proof. exact: preimsetU. Qed. + +Lemma invIg A B : (A :&: B)^-1 = A^-1 :&: B^-1. +Proof. exact: preimsetI. Qed. + +Lemma invDg A B : (A :\: B)^-1 = A^-1 :\: B^-1. +Proof. exact: preimsetD. Qed. + +Lemma invCg A : (~: A)^-1 = ~: A^-1. +Proof. exact: preimsetC. Qed. + +Lemma invSg A B : (A^-1 \subset B^-1) = (A \subset B). +Proof. by rewrite !(sameP setIidPl eqP) -invIg (inj_eq invg_inj). Qed. + +Lemma mem_invg x A : (x \in A^-1) = (x^-1 \in A). +Proof. by rewrite inE. Qed. + +Lemma memV_invg x A : (x^-1 \in A^-1) = (x \in A). +Proof. by rewrite inE invgK. Qed. + +Lemma card_invg A : #|A^-1| = #|A|. +Proof. by apply: card_preimset; exact: invg_inj. Qed. + +(* Product with singletons. *) + +Lemma set1gE : 1 = [set 1] :> {set gT}. Proof. by []. Qed. + +Lemma set1gP x : reflect (x = 1) (x \in [1]). +Proof. exact: set1P. Qed. + +Lemma mulg_set1 x y : [set x] :* y = [set x * y]. +Proof. by rewrite [_ * _]imset2_set1l imset_set1. Qed. + +Lemma invg_set1 x : [set x]^-1 = [set x^-1]. +Proof. by apply/setP=> y; rewrite !inE inv_eq //; exact: invgK. Qed. + +End BaseSetMulProp. + +Implicit Arguments set1gP [gT x]. +Implicit Arguments mulsgP [gT A B x]. +Implicit Arguments prodsgP [gT I P A x]. + +Section GroupSetMulProp. +(* Constructs that need a finGroupType *) +Variable gT : finGroupType. +Implicit Types A B C D : {set gT}. +Implicit Type x y z : gT. + +(* Left cosets. *) + +Lemma lcosetE A x : lcoset A x = x *: A. +Proof. by rewrite [_ * _]imset2_set1l. Qed. + +Lemma card_lcoset A x : #|x *: A| = #|A|. +Proof. by rewrite -lcosetE (card_imset _ (mulgI _)). Qed. + +Lemma mem_lcoset A x y : (y \in x *: A) = (x^-1 * y \in A). +Proof. by rewrite -lcosetE [_ x](can_imset_pre _ (mulKg _)) inE. Qed. + +Lemma lcosetP A x y : reflect (exists2 a, a \in A & y = x * a) (y \in x *: A). +Proof. rewrite -lcosetE; exact: imsetP. Qed. + +Lemma lcosetsP A B C : + reflect (exists2 x, x \in B & C = x *: A) (C \in lcosets A B). +Proof. by apply: (iffP imsetP) => [] [x Bx ->]; exists x; rewrite ?lcosetE. Qed. + +Lemma lcosetM A x y : (x * y) *: A = x *: (y *: A). +Proof. by rewrite -mulg_set1 mulgA. Qed. + +Lemma lcoset1 A : 1 *: A = A. +Proof. exact: mul1g. Qed. + +Lemma lcosetK : left_loop invg (fun x A => x *: A). +Proof. by move=> x A; rewrite -lcosetM mulVg mul1g. Qed. + +Lemma lcosetKV : rev_left_loop invg (fun x A => x *: A). +Proof. by move=> x A; rewrite -lcosetM mulgV mul1g. Qed. + +Lemma lcoset_inj : right_injective (fun x A => x *: A). +Proof. by move=> x; exact: can_inj (lcosetK x). Qed. + +Lemma lcosetS x A B : (x *: A \subset x *: B) = (A \subset B). +Proof. +apply/idP/idP=> sAB; last exact: mulgS. +by rewrite -(lcosetK x A) -(lcosetK x B) mulgS. +Qed. + +Lemma sub_lcoset x A B : (A \subset x *: B) = (x^-1 *: A \subset B). +Proof. by rewrite -(lcosetS x^-1) lcosetK. Qed. + +Lemma sub_lcosetV x A B : (A \subset x^-1 *: B) = (x *: A \subset B). +Proof. by rewrite sub_lcoset invgK. Qed. + +(* Right cosets. *) + +Lemma rcosetE A x : rcoset A x = A :* x. +Proof. by rewrite [_ * _]imset2_set1r. Qed. + +Lemma card_rcoset A x : #|A :* x| = #|A|. +Proof. by rewrite -rcosetE (card_imset _ (mulIg _)). Qed. + +Lemma mem_rcoset A x y : (y \in A :* x) = (y * x^-1 \in A). +Proof. by rewrite -rcosetE [_ x](can_imset_pre A (mulgK _)) inE. Qed. + +Lemma rcosetP A x y : reflect (exists2 a, a \in A & y = a * x) (y \in A :* x). +Proof. by rewrite -rcosetE; exact: imsetP. Qed. + +Lemma rcosetsP A B C : + reflect (exists2 x, x \in B & C = A :* x) (C \in rcosets A B). +Proof. by apply: (iffP imsetP) => [] [x Bx ->]; exists x; rewrite ?rcosetE. Qed. + +Lemma rcosetM A x y : A :* (x * y) = A :* x :* y. +Proof. by rewrite -mulg_set1 mulgA. Qed. + +Lemma rcoset1 A : A :* 1 = A. +Proof. exact: mulg1. Qed. + +Lemma rcosetK : right_loop invg (fun A x => A :* x). +Proof. by move=> x A; rewrite -rcosetM mulgV mulg1. Qed. + +Lemma rcosetKV : rev_right_loop invg (fun A x => A :* x). +Proof. by move=> x A; rewrite -rcosetM mulVg mulg1. Qed. + +Lemma rcoset_inj : left_injective (fun A x => A :* x). +Proof. by move=> x; exact: can_inj (rcosetK x). Qed. + +Lemma rcosetS x A B : (A :* x \subset B :* x) = (A \subset B). +Proof. +apply/idP/idP=> sAB; last exact: mulSg. +by rewrite -(rcosetK x A) -(rcosetK x B) mulSg. +Qed. + +Lemma sub_rcoset x A B : (A \subset B :* x) = (A :* x ^-1 \subset B). +Proof. by rewrite -(rcosetS x^-1) rcosetK. Qed. + +Lemma sub_rcosetV x A B : (A \subset B :* x^-1) = (A :* x \subset B). +Proof. by rewrite sub_rcoset invgK. Qed. + +(* Inverse map lcosets to rcosets *) + +Lemma lcosets_invg A B : lcosets A^-1 B^-1 = invg @^-1: rcosets A B. +Proof. +apply/setP=> C; rewrite inE. +apply/imsetP/imsetP=> [] [a]; rewrite -memV_invg ?invgK => Aa; + try move/(canRL invgK); move->; exists a^-1; + by rewrite // lcosetE rcosetE invMg invg_set1 ?invgK. +Qed. + +(* Conjugates. *) + +Lemma conjg_preim A x : A :^ x = (conjg^~ x^-1) @^-1: A. +Proof. exact: can_imset_pre (conjgK _). Qed. + +Lemma mem_conjg A x y : (y \in A :^ x) = (y ^ x^-1 \in A). +Proof. by rewrite conjg_preim inE. Qed. + +Lemma mem_conjgV A x y : (y \in A :^ x^-1) = (y ^ x \in A). +Proof. by rewrite mem_conjg invgK. Qed. + +Lemma memJ_conjg A x y : (y ^ x \in A :^ x) = (y \in A). +Proof. by rewrite mem_conjg conjgK. Qed. + +Lemma conjsgE A x : A :^ x = x^-1 *: (A :* x). +Proof. by apply/setP=> y; rewrite mem_lcoset mem_rcoset -mulgA mem_conjg. Qed. + +Lemma conjsg1 A : A :^ 1 = A. +Proof. by rewrite conjsgE invg1 mul1g mulg1. Qed. + +Lemma conjsgM A x y : A :^ (x * y) = (A :^ x) :^ y. +Proof. by rewrite !conjsgE invMg -!mulg_set1 !mulgA. Qed. + +Lemma conjsgK : @right_loop _ gT invg conjugate. +Proof. by move=> x A; rewrite -conjsgM mulgV conjsg1. Qed. + +Lemma conjsgKV : @rev_right_loop _ gT invg conjugate. +Proof. by move=> x A; rewrite -conjsgM mulVg conjsg1. Qed. + +Lemma conjsg_inj : @left_injective _ gT _ conjugate. +Proof. by move=> x; exact: can_inj (conjsgK x). Qed. + +Lemma cardJg A x : #|A :^ x| = #|A|. +Proof. by rewrite (card_imset _ (conjg_inj x)). Qed. + +Lemma conjSg A B x : (A :^ x \subset B :^ x) = (A \subset B). +Proof. by rewrite !conjsgE lcosetS rcosetS. Qed. + +Lemma properJ A B x : (A :^ x \proper B :^ x) = (A \proper B). +Proof. by rewrite /proper !conjSg. Qed. + +Lemma sub_conjg A B x : (A :^ x \subset B) = (A \subset B :^ x^-1). +Proof. by rewrite -(conjSg A _ x) conjsgKV. Qed. + +Lemma sub_conjgV A B x : (A :^ x^-1 \subset B) = (A \subset B :^ x). +Proof. by rewrite -(conjSg _ B x) conjsgKV. Qed. + +Lemma conjg_set1 x y : [set x] :^ y = [set x ^ y]. +Proof. by rewrite [_ :^ _]imset_set1. Qed. + +Lemma conjs1g x : 1 :^ x = 1. +Proof. by rewrite conjg_set1 conj1g. Qed. + +Lemma conjsg_eq1 A x : (A :^ x == 1%g) = (A == 1%g). +Proof. by rewrite (canF_eq (conjsgK x)) conjs1g. Qed. + +Lemma conjsMg A B x : (A * B) :^ x = A :^ x * B :^ x. +Proof. by rewrite !conjsgE !mulgA rcosetK. Qed. + +Lemma conjIg A B x : (A :&: B) :^ x = A :^ x :&: B :^ x. +Proof. by rewrite !conjg_preim preimsetI. Qed. + +Lemma conj0g x : set0 :^ x = set0. +Proof. exact: imset0. Qed. + +Lemma conjTg x : [set: gT] :^ x = [set: gT]. +Proof. by rewrite conjg_preim preimsetT. Qed. + +Lemma bigcapJ I r (P : pred I) (B : I -> {set gT}) x : + \bigcap_(i <- r | P i) (B i :^ x) = (\bigcap_(i <- r | P i) B i) :^ x. +Proof. +by rewrite (big_endo (conjugate^~ x)) => // [B1 B2|]; rewrite (conjTg, conjIg). +Qed. + +Lemma conjUg A B x : (A :|: B) :^ x = A :^ x :|: B :^ x. +Proof. by rewrite !conjg_preim preimsetU. Qed. + +Lemma bigcupJ I r (P : pred I) (B : I -> {set gT}) x : + \bigcup_(i <- r | P i) (B i :^ x) = (\bigcup_(i <- r | P i) B i) :^ x. +Proof. +rewrite (big_endo (conjugate^~ x)) => // [B1 B2|]; first by rewrite conjUg. +exact: imset0. +Qed. + +Lemma conjCg A x : (~: A) :^ x = ~: A :^ x. +Proof. by rewrite !conjg_preim preimsetC. Qed. + +Lemma conjDg A B x : (A :\: B) :^ x = A :^ x :\: B :^ x. +Proof. by rewrite !setDE !(conjCg, conjIg). Qed. + +Lemma conjD1g A x : A^# :^ x = (A :^ x)^#. +Proof. by rewrite conjDg conjs1g. Qed. + +(* Classes; not much for now. *) + +Lemma memJ_class x y A : y \in A -> x ^ y \in x ^: A. +Proof. exact: mem_imset. Qed. + +Lemma classS x A B : A \subset B -> x ^: A \subset x ^: B. +Proof. exact: imsetS. Qed. + +Lemma class_set1 x y : x ^: [set y] = [set x ^ y]. +Proof. exact: imset_set1. Qed. + +Lemma class1g x A : x \in A -> 1 ^: A = 1. +Proof. +move=> Ax; apply/setP=> y. +by apply/imsetP/set1P=> [[a Aa]|] ->; last exists x; rewrite ?conj1g. +Qed. + +Lemma classVg x A : x^-1 ^: A = (x ^: A)^-1. +Proof. +apply/setP=> xy; rewrite inE; apply/imsetP/imsetP=> [] [y Ay def_xy]. + by rewrite def_xy conjVg invgK; exists y. +by rewrite -[xy]invgK def_xy -conjVg; exists y. +Qed. + +Lemma mem_classes x A : x \in A -> x ^: A \in classes A. +Proof. exact: mem_imset. Qed. + +Lemma memJ_class_support A B x y : + x \in A -> y \in B -> x ^ y \in class_support A B. +Proof. by move=> Ax By; apply: mem_imset2. Qed. + +Lemma class_supportM A B C : + class_support A (B * C) = class_support (class_support A B) C. +Proof. +apply/setP=> x; apply/imset2P/imset2P=> [[a y Aa] | [y c]]. + case/mulsgP=> b c Bb Cc -> ->{x y}. + by exists (a ^ b) c; rewrite ?(mem_imset2, conjgM). +case/imset2P=> a b Aa Bb -> Cc ->{x y}. +by exists a (b * c); rewrite ?(mem_mulg, conjgM). +Qed. + +Lemma class_support_set1l A x : class_support [set x] A = x ^: A. +Proof. exact: imset2_set1l. Qed. + +Lemma class_support_set1r A x : class_support A [set x] = A :^ x. +Proof. exact: imset2_set1r. Qed. + +Lemma classM x A B : x ^: (A * B) = class_support (x ^: A) B. +Proof. by rewrite -!class_support_set1l class_supportM. Qed. + +Lemma class_lcoset x y A : x ^: (y *: A) = (x ^ y) ^: A. +Proof. by rewrite classM class_set1 class_support_set1l. Qed. + +Lemma class_rcoset x A y : x ^: (A :* y) = (x ^: A) :^ y. +Proof. by rewrite -class_support_set1r classM. Qed. + +(* Conjugate set. *) + +Lemma conjugatesS A B C : B \subset C -> A :^: B \subset A :^: C. +Proof. exact: imsetS. Qed. + +Lemma conjugates_set1 A x : A :^: [set x] = [set A :^ x]. +Proof. exact: imset_set1. Qed. + +Lemma conjugates_conj A x B : (A :^ x) :^: B = A :^: (x *: B). +Proof. +rewrite /conjugates [x *: B]imset2_set1l -imset_comp. +by apply: eq_imset => y /=; rewrite conjsgM. +Qed. + +(* Class support. *) + +Lemma class_supportEl A B : class_support A B = \bigcup_(x in A) x ^: B. +Proof. exact: curry_imset2l. Qed. + +Lemma class_supportEr A B : class_support A B = \bigcup_(x in B) A :^ x. +Proof. exact: curry_imset2r. Qed. + +(* Groups (at last!) *) + +Definition group_set A := (1 \in A) && (A * A \subset A). + +Lemma group_setP A : + reflect (1 \in A /\ {in A & A, forall x y, x * y \in A}) (group_set A). +Proof. +apply: (iffP andP) => [] [A1 AM]; split=> {A1}//. + by move=> x y Ax Ay; apply: (subsetP AM); rewrite mem_mulg. +apply/subsetP=> _ /mulsgP[x y Ax Ay ->]; exact: AM. +Qed. + +Structure group_type : Type := Group { + gval :> GroupSet.sort gT; + _ : group_set gval +}. + +Definition group_of of phant gT : predArgType := group_type. +Notation Local groupT := (group_of (Phant gT)). +Identity Coercion type_of_group : group_of >-> group_type. + +Canonical group_subType := Eval hnf in [subType for gval]. +Definition group_eqMixin := Eval hnf in [eqMixin of group_type by <:]. +Canonical group_eqType := Eval hnf in EqType group_type group_eqMixin. +Definition group_choiceMixin := [choiceMixin of group_type by <:]. +Canonical group_choiceType := + Eval hnf in ChoiceType group_type group_choiceMixin. +Definition group_countMixin := [countMixin of group_type by <:]. +Canonical group_countType := Eval hnf in CountType group_type group_countMixin. +Canonical group_subCountType := Eval hnf in [subCountType of group_type]. +Definition group_finMixin := [finMixin of group_type by <:]. +Canonical group_finType := Eval hnf in FinType group_type group_finMixin. +Canonical group_subFinType := Eval hnf in [subFinType of group_type]. + +(* No predType or baseFinGroupType structures, as these would hide the *) +(* group-to-set coercion and thus spoil unification. *) + +Canonical group_of_subType := Eval hnf in [subType of groupT]. +Canonical group_of_eqType := Eval hnf in [eqType of groupT]. +Canonical group_of_choiceType := Eval hnf in [choiceType of groupT]. +Canonical group_of_countType := Eval hnf in [countType of groupT]. +Canonical group_of_subCountType := Eval hnf in [subCountType of groupT]. +Canonical group_of_finType := Eval hnf in [finType of groupT]. +Canonical group_of_subFinType := Eval hnf in [subFinType of groupT]. + +Definition group (A : {set gT}) gA : groupT := @Group A gA. + +Definition clone_group G := + let: Group _ gP := G return {type of Group for G} -> groupT in fun k => k gP. + +Lemma group_inj : injective gval. Proof. exact: val_inj. Qed. +Lemma groupP (G : groupT) : group_set G. Proof. by case: G. Qed. + +Lemma congr_group (H K : groupT) : H = K -> H :=: K. +Proof. exact: congr1. Qed. + +Lemma isgroupP A : reflect (exists G : groupT, A = G) (group_set A). +Proof. by apply: (iffP idP) => [gA | [[B gB] -> //]]; exists (Group gA). Qed. + +Lemma group_set_one : group_set 1. +Proof. by rewrite /group_set set11 mulg1 subxx. Qed. + +Canonical one_group := group group_set_one. +Canonical set1_group := @group [set 1] group_set_one. + +Lemma group_setT (phT : phant gT) : group_set (setTfor phT). +Proof. by apply/group_setP; split=> [|x y _ _]; rewrite inE. Qed. + +Canonical setT_group phT := group (group_setT phT). + +(* These definitions come early so we can establish the Notation. *) +Definition generated A := \bigcap_(G : groupT | A \subset G) G. +Definition gcore A B := \bigcap_(x in B) A :^ x. +Definition joing A B := generated (A :|: B). +Definition commutator A B := generated (commg_set A B). +Definition cycle x := generated [set x]. +Definition order x := #|cycle x|. + +End GroupSetMulProp. + +Implicit Arguments lcosetP [gT A x y]. +Implicit Arguments lcosetsP [gT A B C]. +Implicit Arguments rcosetP [gT A x y]. +Implicit Arguments rcosetsP [gT A B C]. +Implicit Arguments group_setP [gT A]. +Prenex Implicits group_set mulsgP set1gP. +Prenex Implicits lcosetP lcosetsP rcosetP rcosetsP group_setP. + +Arguments Scope commutator [_ group_scope group_scope]. +Arguments Scope joing [_ group_scope group_scope]. +Arguments Scope generated [_ group_scope]. + +Notation "{ 'group' gT }" := (group_of (Phant gT)) + (at level 0, format "{ 'group' gT }") : type_scope. + +Notation "[ 'group' 'of' G ]" := (clone_group (@group _ G)) + (at level 0, format "[ 'group' 'of' G ]") : form_scope. + +Bind Scope Group_scope with group_type. +Bind Scope Group_scope with group_of. +Notation "1" := (one_group _) : Group_scope. +Notation "[ 1 gT ]" := (1%G : {group gT}) : Group_scope. +Notation "[ 'set' : gT ]" := (setT_group (Phant gT)) : Group_scope. + +(* Helper notation for defining new groups that need a bespoke finGroupType. *) +(* The actual group for such a type (say, my_gT) will be the full group, *) +(* i.e., [set: my_gT] or [set: my_gT]%G, but Coq will not recognize *) +(* specific notation for these because of the coercions inserted during type *) +(* inference, unless they are defined as [set: gsort my_gT] using the *) +(* Notation below. *) +Notation gsort gT := (FinGroup.arg_sort (FinGroup.base gT%type)) (only parsing). +Notation "<< A >>" := (generated A) : group_scope. +Notation "<[ x ] >" := (cycle x) : group_scope. +Notation "#[ x ]" := (order x) : group_scope. +Notation "A <*> B" := (joing A B) : group_scope. +Notation "[ ~: A1 , A2 , .. , An ]" := + (commutator .. (commutator A1 A2) .. An) : group_scope. + +Prenex Implicits order cycle gcore. + +Section GroupProp. + +Variable gT : finGroupType. +Notation sT := {set gT}. +Implicit Types A B C D : sT. +Implicit Types x y z : gT. +Implicit Types G H K : {group gT}. + +Section OneGroup. + +Variable G : {group gT}. + +Lemma valG : val G = G. Proof. by []. Qed. + +(* Non-triviality. *) + +Lemma group1 : 1 \in G. Proof. by case/group_setP: (valP G). Qed. +Hint Resolve group1. + +(* Loads of silly variants to placate the incompleteness of trivial. *) +(* An alternative would be to upgrade done, pending better support *) +(* in the ssreflect ML code. *) +Notation gTr := (FinGroup.sort gT). +Notation Gcl := (pred_of_set G : pred gTr). +Lemma group1_class1 : (1 : gTr) \in G. Proof. by []. Qed. +Lemma group1_class2 : 1 \in Gcl. Proof. by []. Qed. +Lemma group1_class12 : (1 : gTr) \in Gcl. Proof. by []. Qed. +Lemma group1_eqType : (1 : gT : eqType) \in G. Proof. by []. Qed. +Lemma group1_finType : (1 : gT : finType) \in G. Proof. by []. Qed. + +Lemma group1_contra x : x \notin G -> x != 1. +Proof. by apply: contraNneq => ->. Qed. + +Lemma sub1G : [1 gT] \subset G. Proof. by rewrite sub1set. Qed. +Lemma subG1 : (G \subset [1]) = (G :==: 1). +Proof. by rewrite eqEsubset sub1G andbT. Qed. + +Lemma setI1g : 1 :&: G = 1. Proof. exact: (setIidPl sub1G). Qed. +Lemma setIg1 : G :&: 1 = 1. Proof. exact: (setIidPr sub1G). Qed. + +Lemma subG1_contra H : G \subset H -> G :!=: 1 -> H :!=: 1. +Proof. by move=> sGH; rewrite -subG1; apply: contraNneq => <-. Qed. + +Lemma repr_group : repr G = 1. Proof. by rewrite /repr group1. Qed. + +Lemma cardG_gt0 : 0 < #|G|. +Proof. by rewrite lt0n; apply/existsP; exists (1 : gT). Qed. +(* Workaround for the fact that the simple matching used by Trivial does not *) +(* always allow conversion. In particular cardG_gt0 always fails to apply to *) +(* subgoals that have been simplified (by /=) because type inference in the *) +(* notation #|G| introduces redexes of the form *) +(* Finite.sort (arg_finGroupType (FinGroup.base gT)) *) +(* which get collapsed to Fingroup.arg_sort (FinGroup.base gT). *) +Definition cardG_gt0_reduced : 0 < card (@mem gT (predPredType gT) G) + := cardG_gt0. + +Lemma indexg_gt0 A : 0 < #|G : A|. +Proof. +rewrite lt0n; apply/existsP; exists A. +rewrite -{2}[A]mulg1 -rcosetE; exact: mem_imset. +Qed. + +Lemma trivgP : reflect (G :=: 1) (G \subset [1]). +Proof. by rewrite subG1; exact: eqP. Qed. + +Lemma trivGP : reflect (G = 1%G) (G \subset [1]). +Proof. by rewrite subG1; exact: eqP. Qed. + +Lemma proper1G : ([1] \proper G) = (G :!=: 1). +Proof. by rewrite properEneq sub1G andbT eq_sym. Qed. + +Lemma trivgPn : reflect (exists2 x, x \in G & x != 1) (G :!=: 1). +Proof. +rewrite -subG1. +by apply: (iffP subsetPn) => [] [x Gx x1]; exists x; rewrite ?inE in x1 *. +Qed. + +Lemma trivg_card_le1 : (G :==: 1) = (#|G| <= 1). +Proof. by rewrite eq_sym eqEcard cards1 sub1G. Qed. + +Lemma trivg_card1 : (G :==: 1) = (#|G| == 1%N). +Proof. by rewrite trivg_card_le1 eqn_leq cardG_gt0 andbT. Qed. + +Lemma cardG_gt1 : (#|G| > 1) = (G :!=: 1). +Proof. by rewrite trivg_card_le1 ltnNge. Qed. + +Lemma card_le1_trivg : #|G| <= 1 -> G :=: 1. +Proof. by rewrite -trivg_card_le1; move/eqP. Qed. + +Lemma card1_trivg : #|G| = 1%N -> G :=: 1. +Proof. by move=> G1; rewrite card_le1_trivg ?G1. Qed. + +(* Inclusion and product. *) + +Lemma mulG_subl A : A \subset A * G. +Proof. exact: mulg_subl group1. Qed. + +Lemma mulG_subr A : A \subset G * A. +Proof. exact: mulg_subr group1. Qed. + +Lemma mulGid : G * G = G. +Proof. +by apply/eqP; rewrite eqEsubset mulG_subr andbT; case/andP: (valP G). +Qed. + +Lemma mulGS A B : (G * A \subset G * B) = (A \subset G * B). +Proof. +apply/idP/idP; first exact: subset_trans (mulG_subr A). +by move/(mulgS G); rewrite mulgA mulGid. +Qed. + +Lemma mulSG A B : (A * G \subset B * G) = (A \subset B * G). +Proof. +apply/idP/idP; first exact: subset_trans (mulG_subl A). +by move/(mulSg G); rewrite -mulgA mulGid. +Qed. + +Lemma mul_subG A B : A \subset G -> B \subset G -> A * B \subset G. +Proof. by move=> sAG sBG; rewrite -mulGid mulgSS. Qed. + +(* Membership lemmas *) + +Lemma groupM x y : x \in G -> y \in G -> x * y \in G. +Proof. by case/group_setP: (valP G) x y. Qed. + +Lemma groupX x n : x \in G -> x ^+ n \in G. +Proof. by move=> Gx; elim: n => [|n IHn]; rewrite ?group1 // expgS groupM. Qed. + +Lemma groupVr x : x \in G -> x^-1 \in G. +Proof. +move=> Gx; rewrite -(mul1g x^-1) -mem_rcoset ((G :* x =P G) _) //. +by rewrite eqEcard card_rcoset leqnn mul_subG ?sub1set. +Qed. + +Lemma groupVl x : x^-1 \in G -> x \in G. +Proof. by move/groupVr; rewrite invgK. Qed. + +Lemma groupV x : (x^-1 \in G) = (x \in G). +Proof. by apply/idP/idP; [exact: groupVl | exact: groupVr]. Qed. + +Lemma groupMl x y : x \in G -> (x * y \in G) = (y \in G). +Proof. +move=> Gx; apply/idP/idP=> Gy; last exact: groupM. +rewrite -(mulKg x y); exact: groupM (groupVr _) _. +Qed. + +Lemma groupMr x y : x \in G -> (y * x \in G) = (y \in G). +Proof. by move=> Gx; rewrite -[_ \in G]groupV invMg groupMl groupV. Qed. + +Definition in_group := (group1, groupV, (groupMl, groupX)). + +Lemma groupJ x y : x \in G -> y \in G -> x ^ y \in G. +Proof. by move=> Gx Gy; rewrite !in_group. Qed. + +Lemma groupJr x y : y \in G -> (x ^ y \in G) = (x \in G). +Proof. by move=> Gy; rewrite groupMl (groupMr, groupV). Qed. + +Lemma groupR x y : x \in G -> y \in G -> [~ x, y] \in G. +Proof. by move=> Gx Gy; rewrite !in_group. Qed. + +Lemma group_prod I r (P : pred I) F : + (forall i, P i -> F i \in G) -> \prod_(i <- r | P i) F i \in G. +Proof. by move=> G_P; elim/big_ind: _ => //; exact: groupM. Qed. + +(* Inverse is an anti-morphism. *) + +Lemma invGid : G^-1 = G. Proof. by apply/setP=> x; rewrite inE groupV. Qed. + +Lemma inv_subG A : (A^-1 \subset G) = (A \subset G). +Proof. by rewrite -{1}invGid invSg. Qed. + +Lemma invg_lcoset x : (x *: G)^-1 = G :* x^-1. +Proof. by rewrite invMg invGid invg_set1. Qed. + +Lemma invg_rcoset x : (G :* x)^-1 = x^-1 *: G. +Proof. by rewrite invMg invGid invg_set1. Qed. + +Lemma memV_lcosetV x y : (y^-1 \in x^-1 *: G) = (y \in G :* x). +Proof. by rewrite -invg_rcoset memV_invg. Qed. + +Lemma memV_rcosetV x y : (y^-1 \in G :* x^-1) = (y \in x *: G). +Proof. by rewrite -invg_lcoset memV_invg. Qed. + +(* Product idempotence *) + +Lemma mulSgGid A x : x \in A -> A \subset G -> A * G = G. +Proof. +move=> Ax sAG; apply/eqP; rewrite eqEsubset -{2}mulGid mulSg //=. +apply/subsetP=> y Gy; rewrite -(mulKVg x y) mem_mulg // groupMr // groupV. +exact: (subsetP sAG). +Qed. + +Lemma mulGSgid A x : x \in A -> A \subset G -> G * A = G. +Proof. +rewrite -memV_invg -invSg invGid => Ax sAG. +by apply: invg_inj; rewrite invMg invGid (mulSgGid Ax). +Qed. + +(* Left cosets *) + +Lemma lcoset_refl x : x \in x *: G. +Proof. by rewrite mem_lcoset mulVg group1. Qed. + +Lemma lcoset_sym x y : (x \in y *: G) = (y \in x *: G). +Proof. by rewrite !mem_lcoset -groupV invMg invgK. Qed. + +Lemma lcoset_transl x y : x \in y *: G -> x *: G = y *: G. +Proof. +move=> Gyx; apply/setP=> u; rewrite !mem_lcoset in Gyx *. +by rewrite -{2}(mulKVg x u) mulgA (groupMl _ Gyx). +Qed. + +Lemma lcoset_transr x y z : x \in y *: G -> (x \in z *: G) = (y \in z *: G). +Proof. by move=> Gyx; rewrite -2!(lcoset_sym z) (lcoset_transl Gyx). Qed. + +Lemma lcoset_trans x y z : x \in y *: G -> y \in z *: G -> x \in z *: G. +Proof. by move/lcoset_transr->. Qed. + +Lemma lcoset_id x : x \in G -> x *: G = G. +Proof. rewrite -{-2}(mul1g G); exact: lcoset_transl. Qed. + +(* Right cosets, with an elimination form for repr. *) + +Lemma rcoset_refl x : x \in G :* x. +Proof. by rewrite mem_rcoset mulgV group1. Qed. + +Lemma rcoset_sym x y : (x \in G :* y) = (y \in G :* x). +Proof. by rewrite -!memV_lcosetV lcoset_sym. Qed. + +Lemma rcoset_transl x y : x \in G :* y -> G :* x = G :* y. +Proof. +move=> Gyx; apply: invg_inj; rewrite !invg_rcoset. +by apply: lcoset_transl; rewrite memV_lcosetV. +Qed. + +Lemma rcoset_transr x y z : x \in G :* y -> (x \in G :* z) = (y \in G :* z). +Proof. by move=> Gyx; rewrite -2!(rcoset_sym z) (rcoset_transl Gyx). Qed. + +Lemma rcoset_trans x y z : y \in G :* x -> z \in G :* y -> z \in G :* x. +Proof. by move/rcoset_transl->. Qed. + +Lemma rcoset_id x : x \in G -> G :* x = G. +Proof. by rewrite -{-2}(mulg1 G); exact: rcoset_transl. Qed. + +(* Elimination form. *) + +CoInductive rcoset_repr_spec x : gT -> Type := + RcosetReprSpec g : g \in G -> rcoset_repr_spec x (g * x). + +Lemma mem_repr_rcoset x : repr (G :* x) \in G :* x. +Proof. exact: mem_repr (rcoset_refl x). Qed. + +(* This form sometimes fails because ssreflect 1.1 delegates matching to the *) +(* (weaker) primitive Coq algorithm for general (co)inductive type families. *) +Lemma repr_rcosetP x : rcoset_repr_spec x (repr (G :* x)). +Proof. +by rewrite -[repr _](mulgKV x); split; rewrite -mem_rcoset mem_repr_rcoset. +Qed. + +Lemma rcoset_repr x : G :* (repr (G :* x)) = G :* x. +Proof. by apply: rcoset_transl; exact: mem_repr (rcoset_refl x). Qed. + +(* Coset spaces. *) + +Lemma mem_lcosets A x : (x *: G \in lcosets G A) = (x \in A * G). +Proof. +apply/imsetP/mulsgP=> [[a Aa eqxaG] | [a g Aa Gg ->{x}]]. + exists a (a^-1 * x); rewrite ?mulKVg //. + by rewrite -mem_lcoset -lcosetE -eqxaG lcoset_refl. +by exists a; rewrite // lcosetM lcosetE lcoset_id. +Qed. + +Lemma mem_rcosets A x : (G :* x \in rcosets G A) = (x \in G * A). +Proof. +rewrite -memV_invg invMg invGid -mem_lcosets. +by rewrite -{4}invGid lcosets_invg inE invg_lcoset invgK. +Qed. + +(* Conjugates. *) + +Lemma group_setJ A x : group_set (A :^ x) = group_set A. +Proof. by rewrite /group_set mem_conjg conj1g -conjsMg conjSg. Qed. + +Lemma group_set_conjG x : group_set (G :^ x). +Proof. by rewrite group_setJ groupP. Qed. + +Canonical conjG_group x := group (group_set_conjG x). + +Lemma conjGid : {in G, normalised G}. +Proof. by move=> x Gx; apply/setP=> y; rewrite mem_conjg groupJr ?groupV. Qed. + +Lemma conj_subG x A : x \in G -> A \subset G -> A :^ x \subset G. +Proof. by move=> Gx sAG; rewrite -(conjGid Gx) conjSg. Qed. + +(* Classes *) + +Lemma class1G : 1 ^: G = 1. Proof. exact: class1g group1. Qed. + +Lemma classes1 : [1] \in classes G. Proof. by rewrite -class1G mem_classes. Qed. + +Lemma classGidl x y : y \in G -> (x ^ y) ^: G = x ^: G. +Proof. by move=> Gy; rewrite -class_lcoset lcoset_id. Qed. + +Lemma classGidr x : {in G, normalised (x ^: G)}. +Proof. by move=> y Gy /=; rewrite -class_rcoset rcoset_id. Qed. + +Lemma class_refl x : x \in x ^: G. +Proof. by apply/imsetP; exists (1 : gT); rewrite ?conjg1. Qed. +Hint Resolve class_refl. + +Lemma class_transr x y : x \in y ^: G -> x ^: G = y ^: G. +Proof. by case/imsetP=> z Gz ->; rewrite classGidl. Qed. + +Lemma class_sym x y : (x \in y ^: G) = (y \in x ^: G). +Proof. by apply/idP/idP=> /class_transr->. Qed. + +Lemma class_transl x y z : x \in y ^: G -> (x \in z ^: G) = (y \in z ^: G). +Proof. by rewrite -!(class_sym z) => /class_transr->. Qed. + +Lemma class_trans x y z : x \in y ^: G -> y \in z ^: G -> x \in z ^: G. +Proof. by move/class_transl->. Qed. + +Lemma repr_class x : {y | y \in G & repr (x ^: G) = x ^ y}. +Proof. +set z := repr _; have: #|[set y in G | z == x ^ y]| > 0. + have: z \in x ^: G by exact: (mem_repr x). + by case/imsetP=> y Gy ->; rewrite (cardD1 y) inE Gy eqxx. +by move/card_mem_repr; move: (repr _) => y /setIdP[Gy /eqP]; exists y. +Qed. + +Lemma classG_eq1 x : (x ^: G == 1) = (x == 1). +Proof. +apply/eqP/eqP=> [xG1 | ->]; last exact: class1G. +by have:= class_refl x; rewrite xG1 => /set1P. +Qed. + +Lemma class_subG x A : x \in G -> A \subset G -> x ^: A \subset G. +Proof. +move=> Gx sAG; apply/subsetP=> _ /imsetP[y Ay ->]. +by rewrite groupJ // (subsetP sAG). +Qed. + +Lemma repr_classesP xG : + reflect (repr xG \in G /\ xG = repr xG ^: G) (xG \in classes G). +Proof. +apply: (iffP imsetP) => [[x Gx ->] | []]; last by exists (repr xG). +by have [y Gy ->] := repr_class x; rewrite classGidl ?groupJ. +Qed. + +Lemma mem_repr_classes xG : xG \in classes G -> repr xG \in xG. +Proof. by case/repr_classesP=> _ {2}->; exact: class_refl. Qed. + +Lemma classes_gt0 : 0 < #|classes G|. +Proof. by rewrite (cardsD1 1) classes1. Qed. + +Lemma classes_gt1 : (#|classes G| > 1) = (G :!=: 1). +Proof. +rewrite (cardsD1 1) classes1 ltnS lt0n cards_eq0. +apply/set0Pn/trivgPn=> [[xG /setD1P[nt_xG]] | [x Gx ntx]]. + by case/imsetP=> x Gx def_xG; rewrite def_xG classG_eq1 in nt_xG; exists x. +by exists (x ^: G); rewrite !inE classG_eq1 ntx; exact: mem_imset. +Qed. + +Lemma mem_class_support A x : x \in A -> x \in class_support A G. +Proof. by move=> Ax; rewrite -[x]conjg1 memJ_class_support. Qed. + +Lemma class_supportGidl A x : + x \in G -> class_support (A :^ x) G = class_support A G. +Proof. +by move=> Gx; rewrite -class_support_set1r -class_supportM lcoset_id. +Qed. + +Lemma class_supportGidr A : {in G, normalised (class_support A G)}. +Proof. +by move=> x Gx /=; rewrite -class_support_set1r -class_supportM rcoset_id. +Qed. + +Lemma class_support_subG A : A \subset G -> class_support A G \subset G. +Proof. +by move=> sAG; rewrite class_supportEr; apply/bigcupsP=> x Gx; exact: conj_subG. +Qed. + +Lemma sub_class_support A : A \subset class_support A G. +Proof. by rewrite class_supportEr (bigcup_max 1) ?conjsg1. Qed. + +Lemma class_support_id : class_support G G = G. +Proof. +by apply/eqP; rewrite eqEsubset sub_class_support class_support_subG. +Qed. + +Lemma class_supportD1 A : (class_support A G)^# = cover (A^# :^: G). +Proof. +rewrite cover_imset class_supportEr setDE big_distrl /=. +by apply: eq_bigr => x _; rewrite -setDE conjD1g. +Qed. + +(* Subgroup Type construction. *) +(* We only expect to use this for abstract groups, so we don't project *) +(* the argument to a set. *) + +Inductive subg_of : predArgType := Subg x & x \in G. +Definition sgval u := let: Subg x _ := u in x. +Canonical subg_subType := Eval hnf in [subType for sgval]. +Definition subg_eqMixin := Eval hnf in [eqMixin of subg_of by <:]. +Canonical subg_eqType := Eval hnf in EqType subg_of subg_eqMixin. +Definition subg_choiceMixin := [choiceMixin of subg_of by <:]. +Canonical subg_choiceType := Eval hnf in ChoiceType subg_of subg_choiceMixin. +Definition subg_countMixin := [countMixin of subg_of by <:]. +Canonical subg_countType := Eval hnf in CountType subg_of subg_countMixin. +Canonical subg_subCountType := Eval hnf in [subCountType of subg_of]. +Definition subg_finMixin := [finMixin of subg_of by <:]. +Canonical subg_finType := Eval hnf in FinType subg_of subg_finMixin. +Canonical subg_subFinType := Eval hnf in [subFinType of subg_of]. + +Lemma subgP u : sgval u \in G. +Proof. exact: valP. Qed. +Lemma subg_inj : injective sgval. +Proof. exact: val_inj. Qed. +Lemma congr_subg u v : u = v -> sgval u = sgval v. +Proof. exact: congr1. Qed. + +Definition subg_one := Subg group1. +Definition subg_inv u := Subg (groupVr (subgP u)). +Definition subg_mul u v := Subg (groupM (subgP u) (subgP v)). +Lemma subg_oneP : left_id subg_one subg_mul. +Proof. move=> u; apply: val_inj; exact: mul1g. Qed. + +Lemma subg_invP : left_inverse subg_one subg_inv subg_mul. +Proof. move=> u; apply: val_inj; exact: mulVg. Qed. +Lemma subg_mulP : associative subg_mul. +Proof. move=> u v w; apply: val_inj; exact: mulgA. Qed. + +Definition subFinGroupMixin := FinGroup.Mixin subg_mulP subg_oneP subg_invP. +Canonical subBaseFinGroupType := + Eval hnf in BaseFinGroupType subg_of subFinGroupMixin. +Canonical subFinGroupType := FinGroupType subg_invP. + +Lemma sgvalM : {in setT &, {morph sgval : x y / x * y}}. Proof. by []. Qed. +Lemma valgM : {in setT &, {morph val : x y / (x : subg_of) * y >-> x * y}}. +Proof. by []. Qed. + +Definition subg : gT -> subg_of := insubd (1 : subg_of). +Lemma subgK x : x \in G -> val (subg x) = x. +Proof. by move=> Gx; rewrite insubdK. Qed. +Lemma sgvalK : cancel sgval subg. +Proof. case=> x Gx; apply: val_inj; exact: subgK. Qed. +Lemma subg_default x : (x \in G) = false -> val (subg x) = 1. +Proof. by move=> Gx; rewrite val_insubd Gx. Qed. +Lemma subgM : {in G &, {morph subg : x y / x * y}}. +Proof. by move=> x y Gx Gy; apply: val_inj; rewrite /= !subgK ?groupM. Qed. + +End OneGroup. + +Hint Resolve group1. + +Lemma groupD1_inj G H : G^# = H^# -> G :=: H. +Proof. by move/(congr1 (setU 1)); rewrite !setD1K. Qed. + +Lemma invMG G H : (G * H)^-1 = H * G. +Proof. by rewrite invMg !invGid. Qed. + +Lemma mulSGid G H : H \subset G -> H * G = G. +Proof. exact: mulSgGid (group1 H). Qed. + +Lemma mulGSid G H : H \subset G -> G * H = G. +Proof. exact: mulGSgid (group1 H). Qed. + +Lemma mulGidPl G H : reflect (G * H = G) (H \subset G). +Proof. by apply: (iffP idP) => [|<-]; [exact: mulGSid | exact: mulG_subr]. Qed. + +Lemma mulGidPr G H : reflect (G * H = H) (G \subset H). +Proof. by apply: (iffP idP) => [|<-]; [exact: mulSGid | exact: mulG_subl]. Qed. + +Lemma comm_group_setP G H : reflect (commute G H) (group_set (G * H)). +Proof. +rewrite /group_set (subsetP (mulG_subl _ _)) ?group1 // andbC. +have <-: #|G * H| <= #|H * G| by rewrite -invMG card_invg. +rewrite -mulgA mulGS mulgA mulSG -eqEcard eq_sym; exact: eqP. +Qed. + +Lemma card_lcosets G H : #|lcosets H G| = #|G : H|. +Proof. +by rewrite -[#|G : H|](card_preimset _ invg_inj) -lcosets_invg !invGid. +Qed. + +(* Group Modularity equations *) + +Lemma group_modl A B G : A \subset G -> A * (B :&: G) = A * B :&: G. +Proof. +move=> sAG; apply/eqP; rewrite eqEsubset subsetI mulgS ?subsetIl //. +rewrite -{2}mulGid mulgSS ?subsetIr //. +apply/subsetP => _ /setIP[/mulsgP[a b Aa Bb ->] Gab]. +by rewrite mem_mulg // inE Bb -(groupMl _ (subsetP sAG _ Aa)). +Qed. + +Lemma group_modr A B G : B \subset G -> (G :&: A) * B = G :&: A * B. +Proof. +move=> sBG; apply: invg_inj; rewrite !(invMg, invIg) invGid !(setIC G). +by rewrite group_modl // -invGid invSg. +Qed. + +End GroupProp. + +Hint Resolve group1 group1_class1 group1_class12 group1_class12. +Hint Resolve group1_eqType group1_finType. +Hint Resolve cardG_gt0 cardG_gt0_reduced indexg_gt0. + +Notation "G :^ x" := (conjG_group G x) : Group_scope. + +Notation "[ 'subg' G ]" := (subg_of G) : type_scope. +Notation "[ 'subg' G ]" := [set: subg_of G] : group_scope. +Notation "[ 'subg' G ]" := [set: subg_of G]%G : Group_scope. + +Prenex Implicits subg sgval subg_of. +Bind Scope group_scope with subg_of. + +Implicit Arguments trivgP [gT G]. +Implicit Arguments trivGP [gT G]. +Implicit Arguments mulGidPl [gT G H]. +Implicit Arguments mulGidPr [gT G H]. +Implicit Arguments comm_group_setP [gT G H]. +Implicit Arguments repr_classesP [gT G xG]. +Prenex Implicits trivgP trivGP comm_group_setP. + +Section GroupInter. + +Variable gT : finGroupType. +Implicit Types A B : {set gT}. +Implicit Types G H : {group gT}. + +Lemma group_setI G H : group_set (G :&: H). +Proof. +apply/group_setP; split=> [|x y]; rewrite !inE ?group1 //. +by case/andP=> Gx Hx; rewrite !groupMl. +Qed. + +Canonical setI_group G H := group (group_setI G H). + +Section Nary. + +Variables (I : finType) (P : pred I) (F : I -> {group gT}). + +Lemma group_set_bigcap : group_set (\bigcap_(i | P i) F i). +Proof. +elim/big_rec: _ => [|i G _ gG]; first exact: groupP. +exact: group_setI (Group gG). +Qed. + +Canonical bigcap_group := group group_set_bigcap. + +End Nary. + +Canonical generated_group A : {group _} := Eval hnf in [group of <>]. +Canonical gcore_group G A : {group _} := Eval hnf in [group of gcore G A]. +Canonical commutator_group A B : {group _} := Eval hnf in [group of [~: A, B]]. +Canonical joing_group A B : {group _} := Eval hnf in [group of A <*> B]. +Canonical cycle_group x : {group _} := Eval hnf in [group of <[x]>]. + +Lemma order_gt0 (x : gT) : 0 < #[x]. +Proof. exact: cardG_gt0. Qed. + +End GroupInter. + +Hint Resolve order_gt0. + +Definition joinG (gT : finGroupType) (G H : {group gT}) := joing_group G H. + +Definition subgroups (gT : finGroupType) (G : {set gT}) := + [set H : {group gT} | H \subset G]. + +Arguments Scope generated_group [_ group_scope]. +Arguments Scope joing_group [_ group_scope group_scope]. + +Notation "G :&: H" := (setI_group G H) : Group_scope. +Notation "<< A >>" := (generated_group A) : Group_scope. +Notation "<[ x ] >" := (cycle_group x) : Group_scope. +Notation "[ ~: A1 , A2 , .. , An ]" := + (commutator_group .. (commutator_group A1 A2) .. An) : Group_scope. +Notation "A <*> B" := (joing_group A B) : Group_scope. +Notation "G * H" := (joinG G H) : Group_scope. +Prenex Implicits joinG. + +Notation "\prod_ ( i <- r | P ) F" := + (\big[joinG/1%G]_(i <- r | P%B) F%G) : Group_scope. +Notation "\prod_ ( i <- r ) F" := + (\big[joinG/1%G]_(i <- r) F%G) : Group_scope. +Notation "\prod_ ( m <= i < n | P ) F" := + (\big[joinG/1%G]_(m <= i < n | P%B) F%G) : Group_scope. +Notation "\prod_ ( m <= i < n ) F" := + (\big[joinG/1%G]_(m <= i < n) F%G) : Group_scope. +Notation "\prod_ ( i | P ) F" := + (\big[joinG/1%G]_(i | P%B) F%G) : Group_scope. +Notation "\prod_ i F" := + (\big[joinG/1%G]_i F%G) : Group_scope. +Notation "\prod_ ( i : t | P ) F" := + (\big[joinG/1%G]_(i : t | P%B) F%G) (only parsing) : Group_scope. +Notation "\prod_ ( i : t ) F" := + (\big[joinG/1%G]_(i : t) F%G) (only parsing) : Group_scope. +Notation "\prod_ ( i < n | P ) F" := + (\big[joinG/1%G]_(i < n | P%B) F%G) : Group_scope. +Notation "\prod_ ( i < n ) F" := + (\big[joinG/1%G]_(i < n) F%G) : Group_scope. +Notation "\prod_ ( i 'in' A | P ) F" := + (\big[joinG/1%G]_(i in A | P%B) F%G) : Group_scope. +Notation "\prod_ ( i 'in' A ) F" := + (\big[joinG/1%G]_(i in A) F%G) : Group_scope. + +Section Lagrange. + +Variable gT : finGroupType. +Implicit Types G H K : {group gT}. + +Lemma LagrangeI G H : (#|G :&: H| * #|G : H|)%N = #|G|. +Proof. +rewrite -[#|G|]sum1_card (partition_big_imset (rcoset H)) /=. +rewrite mulnC -sum_nat_const; apply: eq_bigr => _ /rcosetsP[x Gx ->]. +rewrite -(card_rcoset _ x) -sum1_card; apply: eq_bigl => y. +rewrite rcosetE eqEcard mulGS !card_rcoset leqnn andbT. +by rewrite group_modr sub1set // inE. +Qed. + +Lemma divgI G H : #|G| %/ #|G :&: H| = #|G : H|. +Proof. by rewrite -(LagrangeI G H) mulKn ?cardG_gt0. Qed. + +Lemma divg_index G H : #|G| %/ #|G : H| = #|G :&: H|. +Proof. by rewrite -(LagrangeI G H) mulnK. Qed. + +Lemma dvdn_indexg G H : #|G : H| %| #|G|. +Proof. by rewrite -(LagrangeI G H) dvdn_mull. Qed. + +Theorem Lagrange G H : H \subset G -> (#|H| * #|G : H|)%N = #|G|. +Proof. by move/setIidPr=> sHG; rewrite -{1}sHG LagrangeI. Qed. + +Lemma cardSg G H : H \subset G -> #|H| %| #|G|. +Proof. by move/Lagrange <-; rewrite dvdn_mulr. Qed. + +Lemma lognSg p G H : G \subset H -> logn p #|G| <= logn p #|H|. +Proof. by move=> sGH; rewrite dvdn_leq_log ?cardSg. Qed. + +Lemma piSg G H : G \subset H -> {subset \pi(gval G) <= \pi(gval H)}. +Proof. +move=> sGH p; rewrite !mem_primes !cardG_gt0 => /and3P[-> _ pG]. +exact: dvdn_trans (cardSg sGH). +Qed. + +Lemma divgS G H : H \subset G -> #|G| %/ #|H| = #|G : H|. +Proof. by move/Lagrange <-; rewrite mulKn. Qed. + +Lemma divg_indexS G H : H \subset G -> #|G| %/ #|G : H| = #|H|. +Proof. by move/Lagrange <-; rewrite mulnK. Qed. + +Lemma coprimeSg G H p : H \subset G -> coprime #|G| p -> coprime #|H| p. +Proof. by move=> sHG; exact: coprime_dvdl (cardSg sHG). Qed. + +Lemma coprimegS G H p : H \subset G -> coprime p #|G| -> coprime p #|H|. +Proof. by move=> sHG; exact: coprime_dvdr (cardSg sHG). Qed. + +Lemma indexJg G H x : #|G :^ x : H :^ x| = #|G : H|. +Proof. by rewrite -!divgI -conjIg !cardJg. Qed. + +Lemma indexgg G : #|G : G| = 1%N. +Proof. by rewrite -divgS // divnn cardG_gt0. Qed. + +Lemma rcosets_id G : rcosets G G = [set G : {set gT}]. +Proof. +apply/esym/eqP; rewrite eqEcard sub1set [#|_|]indexgg cards1 andbT. +by apply/rcosetsP; exists 1; rewrite ?mulg1. +Qed. + +Lemma Lagrange_index G H K : + H \subset G -> K \subset H -> (#|G : H| * #|H : K|)%N = #|G : K|. +Proof. +move=> sHG sKH; apply/eqP; rewrite mulnC -(eqn_pmul2l (cardG_gt0 K)). +by rewrite mulnA !Lagrange // (subset_trans sKH). +Qed. + +Lemma indexgI G H : #|G : G :&: H| = #|G : H|. +Proof. by rewrite -divgI divgS ?subsetIl. Qed. + +Lemma indexgS G H K : H \subset K -> #|G : K| %| #|G : H|. +Proof. +move=> sHK; rewrite -(@dvdn_pmul2l #|G :&: K|) ?cardG_gt0 // LagrangeI. +by rewrite -(Lagrange (setIS G sHK)) mulnAC LagrangeI dvdn_mulr. +Qed. + +Lemma indexSg G H K : H \subset K -> K \subset G -> #|K : H| %| #|G : H|. +Proof. +move=> sHK sKG; rewrite -(@dvdn_pmul2l #|H|) ?cardG_gt0 //. +by rewrite !Lagrange ?(cardSg, subset_trans sHK). +Qed. + +Lemma indexg_eq1 G H : (#|G : H| == 1%N) = (G \subset H). +Proof. +rewrite eqn_leq -(leq_pmul2l (cardG_gt0 (G :&: H))) LagrangeI muln1. +by rewrite indexg_gt0 andbT (sameP setIidPl eqP) eqEcard subsetIl. +Qed. + +Lemma indexg_gt1 G H : (#|G : H| > 1) = ~~ (G \subset H). +Proof. by rewrite -indexg_eq1 eqn_leq indexg_gt0 andbT -ltnNge. Qed. + +Lemma index1g G H : H \subset G -> #|G : H| = 1%N -> H :=: G. +Proof. by move=> sHG iHG; apply/eqP; rewrite eqEsubset sHG -indexg_eq1 iHG. Qed. + +Lemma indexg1 G : #|G : 1| = #|G|. +Proof. by rewrite -divgS ?sub1G // cards1 divn1. Qed. + +Lemma indexMg G A : #|G * A : G| = #|A : G|. +Proof. +congr #|(_ : {set _})|; apply/eqP; rewrite eqEsubset andbC imsetS ?mulG_subr //. +by apply/subsetP=> _ /imsetP[x GAx ->]; rewrite rcosetE mem_rcosets. +Qed. + +Lemma rcosets_partition_mul G H : partition (rcosets H G) (H * G). +Proof. +have eqiR: {in H * G & &, equivalence_rel [rel x y | y \in rcoset H x]}. + by move=> *; rewrite /= !rcosetE rcoset_refl; split=> // /rcoset_transl->. +congr (partition _ _): (equivalence_partitionP eqiR); apply/setP=> Hx. +apply/imsetP/idP=> [[x HGx defHx] | /rcosetsP[x Gx ->]]. + suffices ->: Hx = H :* x by rewrite mem_rcosets. + apply/setP=> y; rewrite defHx inE /= rcosetE andb_idl //. + by apply: subsetP y; rewrite mulGS sub1set. +exists (1 * x); rewrite ?mem_mulg // mul1g. +apply/setP=> y; rewrite inE /= rcosetE andb_idl //. +by apply: subsetP y; rewrite mulgS ?sub1set. +Qed. + +Lemma rcosets_partition G H : H \subset G -> partition (rcosets H G) G. +Proof. by move/mulSGid=> {2}<-; exact: rcosets_partition_mul. Qed. + +Lemma LagrangeMl G H : (#|G| * #|H : G|)%N = #|G * H|. +Proof. +rewrite mulnC -(card_uniform_partition _ (rcosets_partition_mul H G)) //. +by move=> _ /rcosetsP[x Hx ->]; rewrite card_rcoset. +Qed. + +Lemma LagrangeMr G H : (#|G : H| * #|H|)%N = #|G * H|. +Proof. by rewrite mulnC LagrangeMl -card_invg invMg !invGid. Qed. + +Lemma mul_cardG G H : (#|G| * #|H| = #|G * H|%g * #|G :&: H|)%N. +Proof. by rewrite -LagrangeMr -(LagrangeI G H) -mulnA mulnC. Qed. + +Lemma dvdn_cardMg G H : #|G * H| %| #|G| * #|H|. +Proof. by rewrite mul_cardG dvdn_mulr. Qed. + +Lemma cardMg_divn G H : #|G * H| = (#|G| * #|H|) %/ #|G :&: H|. +Proof. by rewrite mul_cardG mulnK ?cardG_gt0. Qed. + +Lemma cardIg_divn G H : #|G :&: H| = (#|G| * #|H|) %/ #|G * H|. +Proof. by rewrite mul_cardG mulKn // (cardD1 (1 * 1)) mem_mulg. Qed. + +Lemma TI_cardMg G H : G :&: H = 1 -> #|G * H| = (#|G| * #|H|)%N. +Proof. by move=> tiGH; rewrite mul_cardG tiGH cards1 muln1. Qed. + +Lemma cardMg_TI G H : #|G| * #|H| <= #|G * H| -> G :&: H = 1. +Proof. +move=> leGH; apply: card_le1_trivg. +rewrite -(@leq_pmul2l #|G * H|); first by rewrite -mul_cardG muln1. +by apply: leq_trans leGH; rewrite muln_gt0 !cardG_gt0. +Qed. + +Lemma coprime_TIg G H : coprime #|G| #|H| -> G :&: H = 1. +Proof. +move=> coGH; apply/eqP; rewrite trivg_card1 -dvdn1 -{}(eqnP coGH). +by rewrite dvdn_gcd /= {2}setIC !cardSg ?subsetIl. +Qed. + +Lemma prime_TIg G H : prime #|G| -> ~~ (G \subset H) -> G :&: H = 1. +Proof. +case/primeP=> _; move/(_ _ (cardSg (subsetIl G H))). +rewrite (sameP setIidPl eqP) eqEcard subsetIl -ltnNge ltn_neqAle -trivg_card1. +by case/predU1P=> ->. +Qed. + +Lemma prime_meetG G H : prime #|G| -> G :&: H != 1 -> G \subset H. +Proof. by move=> prG; apply: contraR; move/prime_TIg->. Qed. + +Lemma coprime_cardMg G H : coprime #|G| #|H| -> #|G * H| = (#|G| * #|H|)%N. +Proof. by move=> coGH; rewrite TI_cardMg ?coprime_TIg. Qed. + +Lemma coprime_index_mulG G H K : + H \subset G -> K \subset G -> coprime #|G : H| #|G : K| -> H * K = G. +Proof. +move=> sHG sKG co_iG_HK; apply/eqP; rewrite eqEcard mul_subG //=. +rewrite -(@leq_pmul2r #|H :&: K|) ?cardG_gt0 // -mul_cardG. +rewrite -(Lagrange sHG) -(LagrangeI K H) mulnAC setIC -mulnA. +rewrite !leq_pmul2l ?cardG_gt0 // dvdn_leq // -(Gauss_dvdr _ co_iG_HK). +by rewrite -(indexgI K) Lagrange_index ?indexgS ?subsetIl ?subsetIr. +Qed. + +End Lagrange. + +Section GeneratedGroup. + +Variable gT : finGroupType. +Implicit Types x y z : gT. +Implicit Types A B C D : {set gT}. +Implicit Types G H K : {group gT}. + +Lemma subset_gen A : A \subset <>. +Proof. exact/bigcapsP. Qed. + +Lemma sub_gen A B : A \subset B -> A \subset <>. +Proof. by move/subset_trans=> -> //; exact: subset_gen. Qed. + +Lemma mem_gen x A : x \in A -> x \in <>. +Proof. exact: subsetP (subset_gen A) x. Qed. + +Lemma generatedP x A : reflect (forall G, A \subset G -> x \in G) (x \in <>). +Proof. exact: bigcapP. Qed. + +Lemma gen_subG A G : (<> \subset G) = (A \subset G). +Proof. +apply/idP/idP=> [|sAG]; first exact: subset_trans (subset_gen A). +by apply/subsetP=> x /generatedP; apply. +Qed. + +Lemma genGid G : <> = G. +Proof. by apply/eqP; rewrite eqEsubset gen_subG subset_gen andbT. Qed. + +Lemma genGidG G : <>%G = G. +Proof. by apply: val_inj; exact: genGid. Qed. + +Lemma gen_set_id A : group_set A -> <> = A. +Proof. by move=> gA; exact: (genGid (group gA)). Qed. + +Lemma genS A B : A \subset B -> <> \subset <>. +Proof. by move=> sAB; rewrite gen_subG sub_gen. Qed. + +Lemma gen0 : <> = 1 :> {set gT}. +Proof. by apply/eqP; rewrite eqEsubset sub1G gen_subG sub0set. Qed. + +Lemma gen_expgs A : {n | <> = (1 |: A) ^+ n}. +Proof. +set B := (1 |: A); pose N := #|gT|. +have BsubG n : B ^+ n \subset <>. + by elim: n => [|n IHn]; rewrite ?expgS ?mul_subG ?subUset ?sub1G ?subset_gen. +have B_1 n : 1 \in B ^+ n. + by elim: n => [|n IHn]; rewrite ?set11 // expgS mulUg mul1g inE IHn. +case: (pickP (fun i : 'I_N => B ^+ i.+1 \subset B ^+ i)) => [n fixBn | no_fix]. + exists n; apply/eqP; rewrite eqEsubset BsubG andbT. + rewrite -[B ^+ n]gen_set_id ?genS ?subsetUr //. + by apply: subset_trans fixBn; rewrite expgS mulUg subsetU ?mulg_subl ?orbT. + rewrite /group_set B_1 /=. + elim: {2}(n : nat) => [|m IHm]; first by rewrite mulg1. + by apply: subset_trans fixBn; rewrite !expgSr mulgA mulSg. +suffices: N < #|B ^+ N| by rewrite ltnNge max_card. +elim: {-2}N (leqnn N) => [|n IHn] lt_nN; first by rewrite cards1. +apply: leq_ltn_trans (IHn (ltnW lt_nN)) (proper_card _). +by rewrite /proper (no_fix (Ordinal lt_nN)) expgS mulUg mul1g subsetUl. +Qed. + +Lemma gen_prodgP A x : + reflect (exists n, exists2 c, forall i : 'I_n, c i \in A & x = \prod_i c i) + (x \in <>). +Proof. +apply: (iffP idP) => [|[n [c Ac ->]]]; last first. + by apply: group_prod => i _; rewrite mem_gen ?Ac. +have [n ->] := gen_expgs A; rewrite /expgn /expgn_rec Monoid.iteropE. +have ->: n = count 'I_n (index_enum _). + by rewrite -size_filter filter_index_enum -cardT card_ord. +rewrite -big_const_seq; case/prodsgP=> /= c Ac def_x. +have{Ac def_x} ->: x = \prod_(i | c i \in A) c i. + rewrite big_mkcond {x}def_x; apply: eq_bigr => i _. + by case/setU1P: (Ac i isT) => -> //; rewrite if_same. +rewrite -big_filter; set e := filter _ _; case def_e: e => [|i e']. + by exists 0; exists (fun _ => 1) => [[] // |]; rewrite big_nil big_ord0. +rewrite -{e'}def_e (big_nth i) big_mkord. +exists (size e); exists (c \o nth i e \o val) => // j /=. +have: nth i e j \in e by rewrite mem_nth. +by rewrite mem_filter; case/andP. +Qed. + +Lemma genD A B : A \subset <> -> <> = <>. +Proof. +by move=> sAB; apply/eqP; rewrite eqEsubset genS (subsetDl, gen_subG). +Qed. + +Lemma genV A : <> = <>. +Proof. +apply/eqP; rewrite eqEsubset !gen_subG -!(invSg _ <<_>>) invgK. +by rewrite !invGid !subset_gen. +Qed. + +Lemma genJ A z : <> = <> :^ z. +Proof. +by apply/eqP; rewrite eqEsubset sub_conjg !gen_subG conjSg -?sub_conjg !sub_gen. +Qed. + +Lemma conjYg A B z : (A <*> B) :^z = A :^ z <*> B :^ z. +Proof. by rewrite -genJ conjUg. Qed. + +Lemma genD1 A x : x \in <> -> <> = <>. +Proof. +move=> gA'x; apply/eqP; rewrite eqEsubset genS; last by rewrite subsetDl. +rewrite gen_subG; apply/subsetP=> y Ay. +by case: (y =P x) => [-> //|]; move/eqP=> nyx; rewrite mem_gen // !inE nyx. +Qed. + +Lemma genD1id A : <> = <>. +Proof. by rewrite genD1 ?group1. Qed. + +Notation joingT := (@joing gT) (only parsing). +Notation joinGT := (@joinG gT) (only parsing). + +Lemma joingE A B : A <*> B = <>. Proof. by []. Qed. + +Lemma joinGE G H : (G * H)%G = (G <*> H)%G. Proof. by []. Qed. + +Lemma joingC : commutative joingT. +Proof. by move=> A B; rewrite /joing setUC. Qed. + +Lemma joing_idr A B : A <*> <> = A <*> B. +Proof. +apply/eqP; rewrite eqEsubset gen_subG subUset gen_subG /=. +by rewrite -subUset subset_gen genS // setUS // subset_gen. +Qed. + +Lemma joing_idl A B : <> <*> B = A <*> B. +Proof. by rewrite -!(joingC B) joing_idr. Qed. + +Lemma joing_subl A B : A \subset A <*> B. +Proof. by rewrite sub_gen ?subsetUl. Qed. + +Lemma joing_subr A B : B \subset A <*> B. +Proof. by rewrite sub_gen ?subsetUr. Qed. + +Lemma join_subG A B G : (A <*> B \subset G) = (A \subset G) && (B \subset G). +Proof. by rewrite gen_subG subUset. Qed. + +Lemma joing_idPl G A : reflect (G <*> A = G) (A \subset G). +Proof. +apply: (iffP idP) => [sHG | <-]; last by rewrite joing_subr. +by rewrite joingE (setUidPl sHG) genGid. +Qed. + +Lemma joing_idPr A G : reflect (A <*> G = G) (A \subset G). +Proof. by rewrite joingC; exact: joing_idPl. Qed. + +Lemma joing_subP A B G : + reflect (A \subset G /\ B \subset G) (A <*> B \subset G). +Proof. by rewrite join_subG; exact: andP. Qed. + +Lemma joing_sub A B C : A <*> B = C -> A \subset C /\ B \subset C. +Proof. by move <-; exact/joing_subP. Qed. + +Lemma genDU A B C : A \subset C -> <> = <> -> <> = <>. +Proof. +move=> sAC; rewrite -joingE -joing_idr => <- {B}; rewrite joing_idr. +by congr <<_>>; rewrite setDE setUIr setUCr setIT; exact/setUidPr. +Qed. + +Lemma joingA : associative joingT. +Proof. by move=> A B C; rewrite joing_idl joing_idr /joing setUA. Qed. + +Lemma joing1G G : 1 <*> G = G. +Proof. by rewrite -gen0 joing_idl /joing set0U genGid. Qed. + +Lemma joingG1 G : G <*> 1 = G. +Proof. by rewrite joingC joing1G. Qed. + +Lemma genM_join G H : <> = G <*> H. +Proof. +apply/eqP; rewrite eqEsubset gen_subG /= -{1}[G <*> H]mulGid. +rewrite genS; last by rewrite subUset mulG_subl mulG_subr. +by rewrite mulgSS ?(sub_gen, subsetUl, subsetUr). +Qed. + +Lemma mulG_subG G H K : (G * H \subset K) = (G \subset K) && (H \subset K). +Proof. by rewrite -gen_subG genM_join join_subG. Qed. + +Lemma mulGsubP K H G : reflect (K \subset G /\ H \subset G) (K * H \subset G). +Proof. by rewrite mulG_subG; exact: andP. Qed. + +Lemma mulG_sub K H A : K * H = A -> K \subset A /\ H \subset A. +Proof. by move <-; rewrite mulG_subl mulG_subr. Qed. + +Lemma trivMg G H : (G * H == 1) = (G :==: 1) && (H :==: 1). +Proof. +by rewrite !eqEsubset -{2}[1]mulGid mulgSS ?sub1G // !andbT mulG_subG. +Qed. + +Lemma comm_joingE G H : commute G H -> G <*> H = G * H. +Proof. +by move/comm_group_setP=> gGH; rewrite -genM_join; exact: (genGid (group gGH)). +Qed. + +Lemma joinGC : commutative joinGT. +Proof. by move=> G H; apply: val_inj; exact: joingC. Qed. + +Lemma joinGA : associative joinGT. +Proof. by move=> G H K; apply: val_inj; exact: joingA. Qed. + +Lemma join1G : left_id 1%G joinGT. +Proof. by move=> G; apply: val_inj; exact: joing1G. Qed. + +Lemma joinG1 : right_id 1%G joinGT. +Proof. by move=> G; apply: val_inj; exact: joingG1. Qed. + +Canonical joinG_law := Monoid.Law joinGA join1G joinG1. +Canonical joinG_abelaw := Monoid.ComLaw joinGC. + +Lemma bigprodGEgen I r (P : pred I) (F : I -> {set gT}) : + (\prod_(i <- r | P i) <>)%G :=: << \bigcup_(i <- r | P i) F i >>. +Proof. +elim/big_rec2: _ => /= [|i A _ _ ->]; first by rewrite gen0. +by rewrite joing_idl joing_idr. +Qed. + +Lemma bigprodGE I r (P : pred I) (F : I -> {group gT}) : + (\prod_(i <- r | P i) F i)%G :=: << \bigcup_(i <- r | P i) F i >>. +Proof. +rewrite -bigprodGEgen /=; apply: congr_group. +by apply: eq_bigr => i _; rewrite genGidG. +Qed. + +Lemma mem_commg A B x y : x \in A -> y \in B -> [~ x, y] \in [~: A, B]. +Proof. by move=> Ax By; rewrite mem_gen ?mem_imset2. Qed. + +Lemma commSg A B C : A \subset B -> [~: A, C] \subset [~: B, C]. +Proof. by move=> sAC; rewrite genS ?imset2S. Qed. + +Lemma commgS A B C : B \subset C -> [~: A, B] \subset [~: A, C]. +Proof. by move=> sBC; rewrite genS ?imset2S. Qed. + +Lemma commgSS A B C D : + A \subset B -> C \subset D -> [~: A, C] \subset [~: B, D]. +Proof. by move=> sAB sCD; rewrite genS ?imset2S. Qed. + +Lemma der1_subG G : [~: G, G] \subset G. +Proof. +by rewrite gen_subG; apply/subsetP=> _ /imset2P[x y Gx Gy ->]; exact: groupR. +Qed. + +Lemma comm_subG A B G : A \subset G -> B \subset G -> [~: A, B] \subset G. +Proof. +by move=> sAG sBG; apply: subset_trans (der1_subG G); exact: commgSS. +Qed. + +Lemma commGC A B : [~: A, B] = [~: B, A]. +Proof. +rewrite -[[~: A, B]]genV; congr <<_>>; apply/setP=> z; rewrite inE. +by apply/imset2P/imset2P=> [] [x y Ax Ay]; last rewrite -{1}(invgK z); + rewrite -invg_comm => /invg_inj->; exists y x. +Qed. + +Lemma conjsRg A B x : [~: A, B] :^ x = [~: A :^ x, B :^ x]. +Proof. +wlog suffices: A B x / [~: A, B] :^ x \subset [~: A :^ x, B :^ x]. + move=> subJ; apply/eqP; rewrite eqEsubset subJ /= -sub_conjgV. + by rewrite -{2}(conjsgK x A) -{2}(conjsgK x B). +rewrite -genJ gen_subG; apply/subsetP=> _ /imsetP[_ /imset2P[y z Ay Bz ->] ->]. +by rewrite conjRg mem_commg ?memJ_conjg. +Qed. + +End GeneratedGroup. + +Implicit Arguments gen_prodgP [gT A x]. +Implicit Arguments joing_idPl [gT G A]. +Implicit Arguments joing_idPr [gT A G]. +Implicit Arguments mulGsubP [gT K H G]. +Implicit Arguments joing_subP [gT A B G]. + +Section Cycles. + +(* Elementary properties of cycles and order, needed in perm.v. *) +(* More advanced results on the structure of cyclic groups will *) +(* be given in cyclic.v. *) + +Variable gT : finGroupType. +Implicit Types x y : gT. +Implicit Types G : {group gT}. + +Import Monoid.Theory. + +Lemma cycle1 : <[1]> = [1 gT]. +Proof. exact: genGid. Qed. + +Lemma order1 : #[1 : gT] = 1%N. +Proof. by rewrite /order cycle1 cards1. Qed. + +Lemma cycle_id x : x \in <[x]>. +Proof. by rewrite mem_gen // set11. Qed. + +Lemma mem_cycle x i : x ^+ i \in <[x]>. +Proof. by rewrite groupX // cycle_id. Qed. + +Lemma cycle_subG x G : (<[x]> \subset G) = (x \in G). +Proof. by rewrite gen_subG sub1set. Qed. + +Lemma cycle_eq1 x : (<[x]> == 1) = (x == 1). +Proof. by rewrite eqEsubset sub1G andbT cycle_subG inE. Qed. + +Lemma orderE x : #[x] = #|<[x]>|. Proof. by []. Qed. + +Lemma order_eq1 x : (#[x] == 1%N) = (x == 1). +Proof. by rewrite -trivg_card1 cycle_eq1. Qed. + +Lemma order_gt1 x : (#[x] > 1) = (x != 1). +Proof. by rewrite ltnNge -trivg_card_le1 cycle_eq1. Qed. + +Lemma cycle_traject x : <[x]> =i traject (mulg x) 1 #[x]. +Proof. +set t := _ 1; apply: fsym; apply/subset_cardP; last first. + by apply/subsetP=> _ /trajectP[i _ ->]; rewrite -iteropE mem_cycle. +rewrite (card_uniqP _) ?size_traject //; case def_n: #[_] => // [n]. +rewrite looping_uniq; apply: contraL (card_size (t n)) => /loopingP t_xi. +rewrite -ltnNge size_traject -def_n ?subset_leq_card //. +rewrite -(eq_subset_r (in_set _)) {}/t; set G := finset _. +rewrite -[x]mulg1 -[G]gen_set_id ?genS ?sub1set ?inE ?(t_xi 1%N)//. +apply/group_setP; split=> [|y z]; rewrite !inE ?(t_xi 0) //. +by do 2!case/trajectP=> ? _ ->; rewrite -!iteropE -expgD [x ^+ _]iteropE. +Qed. + +Lemma cycle2g x : #[x] = 2 -> <[x]> = [set 1; x]. +Proof. by move=> ox; apply/setP=> y; rewrite cycle_traject ox !inE mulg1. Qed. + +Lemma cyclePmin x y : y \in <[x]> -> {i | i < #[x] & y = x ^+ i}. +Proof. +rewrite cycle_traject; set tx := traject _ _ #[x] => tx_y; pose i := index y tx. +have lt_i_x : i < #[x] by rewrite -index_mem size_traject in tx_y. +by exists i; rewrite // [x ^+ i]iteropE /= -(nth_traject _ lt_i_x) nth_index. +Qed. + +Lemma cycleP x y : reflect (exists i, y = x ^+ i) (y \in <[x]>). +Proof. +by apply: (iffP idP) => [/cyclePmin[i _]|[i ->]]; [exists i | exact: mem_cycle]. +Qed. + +Lemma expg_order x : x ^+ #[x] = 1. +Proof. +have: uniq (traject (mulg x) 1 #[x]). + by apply/card_uniqP; rewrite size_traject -(eq_card (cycle_traject x)). +case/cyclePmin: (mem_cycle x #[x]) => [] [//|i] ltix. +rewrite -(subnKC ltix) addSnnS /= expgD; move: (_ - _) => j x_j1. +case/andP=> /trajectP[]; exists j; first exact: leq_addl. +by apply: (mulgI (x ^+ i.+1)); rewrite -iterSr iterS -iteropE -expgS mulg1. +Qed. + +Lemma expg_mod p k x : x ^+ p = 1 -> x ^+ (k %% p) = x ^+ k. +Proof. +move=> xp. +by rewrite {2}(divn_eq k p) expgD mulnC expgM xp expg1n mul1g. +Qed. + +Lemma expg_mod_order x i : x ^+ (i %% #[x]) = x ^+ i. +Proof. by rewrite expg_mod // expg_order. Qed. + +Lemma invg_expg x : x^-1 = x ^+ #[x].-1. +Proof. by apply/eqP; rewrite eq_invg_mul -expgS prednK ?expg_order. Qed. + +Lemma invg2id x : #[x] = 2 -> x^-1 = x. +Proof. by move=> ox; rewrite invg_expg ox. Qed. + +Lemma cycleX x i : <[x ^+ i]> \subset <[x]>. +Proof. rewrite cycle_subG; exact: mem_cycle. Qed. + +Lemma cycleV x : <[x^-1]> = <[x]>. +Proof. +by apply/eqP; rewrite eq_sym eqEsubset !cycle_subG groupV -groupV !cycle_id. +Qed. + +Lemma orderV x : #[x^-1] = #[x]. +Proof. by rewrite /order cycleV. Qed. + +Lemma cycleJ x y : <[x ^ y]> = <[x]> :^ y. +Proof. by rewrite -genJ conjg_set1. Qed. + +Lemma orderJ x y : #[x ^ y] = #[x]. +Proof. by rewrite /order cycleJ cardJg. Qed. + +End Cycles. + +Section Normaliser. + +Variable gT : finGroupType. +Implicit Types x y z : gT. +Implicit Types A B C D : {set gT}. +Implicit Type G H K : {group gT}. + +Lemma normP x A : reflect (A :^ x = A) (x \in 'N(A)). +Proof. +suffices ->: (x \in 'N(A)) = (A :^ x == A) by exact: eqP. +by rewrite eqEcard cardJg leqnn andbT inE. +Qed. +Implicit Arguments normP [x A]. + +Lemma group_set_normaliser A : group_set 'N(A). +Proof. +apply/group_setP; split=> [|x y Nx Ny]; rewrite inE ?conjsg1 //. +by rewrite conjsgM !(normP _). +Qed. + +Canonical normaliser_group A := group (group_set_normaliser A). + +Lemma normsP A B : reflect {in A, normalised B} (A \subset 'N(B)). +Proof. +apply: (iffP subsetP) => nBA x Ax; last by rewrite inE nBA //. +by apply/normP; exact: nBA. +Qed. +Implicit Arguments normsP [A B]. + +Lemma memJ_norm x y A : x \in 'N(A) -> (y ^ x \in A) = (y \in A). +Proof. by move=> Nx; rewrite -{1}(normP Nx) memJ_conjg. Qed. + +Lemma norms_cycle x y : (<[y]> \subset 'N(<[x]>)) = (x ^ y \in <[x]>). +Proof. by rewrite cycle_subG inE -cycleJ cycle_subG. Qed. + +Lemma norm1 : 'N(1) = setT :> {set gT}. +Proof. by apply/setP=> x; rewrite !inE conjs1g subxx. Qed. + +Lemma norms1 A : A \subset 'N(1). +Proof. by rewrite norm1 subsetT. Qed. + +Lemma normCs A : 'N(~: A) = 'N(A). +Proof. by apply/setP=> x; rewrite -groupV !inE conjCg setCS sub_conjg. Qed. + +Lemma normG G : G \subset 'N(G). +Proof. by apply/normsP; exact: conjGid. Qed. + +Lemma normT : 'N([set: gT]) = [set: gT]. +Proof. by apply/eqP; rewrite -subTset normG. Qed. + +Lemma normsG A G : A \subset G -> A \subset 'N(G). +Proof. move=> sAG; exact: subset_trans (normG G). Qed. + +Lemma normC A B : A \subset 'N(B) -> commute A B. +Proof. +move/subsetP=> nBA; apply/setP=> u. +apply/mulsgP/mulsgP=> [[x y Ax By] | [y x By Ax]] -> {u}. + by exists (y ^ x^-1) x; rewrite -?conjgCV // memJ_norm // groupV nBA. +by exists x (y ^ x); rewrite -?conjgC // memJ_norm // nBA. +Qed. + +Lemma norm_joinEl G H : G \subset 'N(H) -> G <*> H = G * H. +Proof. by move/normC/comm_joingE. Qed. + +Lemma norm_joinEr G H : H \subset 'N(G) -> G <*> H = G * H. +Proof. by move/normC=> cHG; exact: comm_joingE. Qed. + +Lemma norm_rlcoset G x : x \in 'N(G) -> G :* x = x *: G. +Proof. by rewrite -sub1set => /normC. Qed. + +Lemma rcoset_mul G x y : x \in 'N(G) -> (G :* x) * (G :* y) = G :* (x * y). +Proof. +move/norm_rlcoset=> GxxG. +by rewrite mulgA -(mulgA _ _ G) -GxxG mulgA mulGid -mulgA mulg_set1. +Qed. + +Lemma normJ A x : 'N(A :^ x) = 'N(A) :^ x. +Proof. +by apply/setP=> y; rewrite mem_conjg !inE -conjsgM conjgCV conjsgM conjSg. +Qed. + +Lemma norm_conj_norm x A B : + x \in 'N(A) -> (A \subset 'N(B :^ x)) = (A \subset 'N(B)). +Proof. by move=> Nx; rewrite normJ -sub_conjgV (normP _) ?groupV. Qed. + +Lemma norm_gen A : 'N(A) \subset 'N(<>). +Proof. by apply/normsP=> x Nx; rewrite -genJ (normP Nx). Qed. + +Lemma class_norm x G : G \subset 'N(x ^: G). +Proof. by apply/normsP=> y; exact: classGidr. Qed. + +Lemma class_normal x G : x \in G -> x ^: G <| G. +Proof. by move=> Gx; rewrite /normal class_norm class_subG. Qed. + +Lemma class_sub_norm G A x : G \subset 'N(A) -> (x ^: G \subset A) = (x \in A). +Proof. +move=> nAG; apply/subsetP/idP=> [-> // | Ax xy]; first exact: class_refl. +by case/imsetP=> y Gy ->; rewrite memJ_norm ?(subsetP nAG). +Qed. + +Lemma class_support_norm A G : G \subset 'N(class_support A G). +Proof. by apply/normsP; exact: class_supportGidr. Qed. + +Lemma class_support_sub_norm A B G : + A \subset G -> B \subset 'N(G) -> class_support A B \subset G. +Proof. +move=> sAG nGB; rewrite class_supportEr. +by apply/bigcupsP=> x Bx; rewrite -(normsP nGB x Bx) conjSg. +Qed. + +Section norm_trans. + +Variables (A B C D : {set gT}). +Hypotheses (nBA : A \subset 'N(B)) (nCA : A \subset 'N(C)). + +Lemma norms_gen : A \subset 'N(<>). +Proof. exact: subset_trans nBA (norm_gen B). Qed. + +Lemma norms_norm : A \subset 'N('N(B)). +Proof. by apply/normsP=> x Ax; rewrite -normJ (normsP nBA). Qed. + +Lemma normsI : A \subset 'N(B :&: C). +Proof. by apply/normsP=> x Ax; rewrite conjIg !(normsP _ x Ax). Qed. + +Lemma normsU : A \subset 'N(B :|: C). +Proof. by apply/normsP=> x Ax; rewrite conjUg !(normsP _ x Ax). Qed. + +Lemma normsIs : B \subset 'N(D) -> A :&: B \subset 'N(C :&: D). +Proof. +move/normsP=> nDB; apply/normsP=> x; case/setIP=> Ax Bx. +by rewrite conjIg (normsP nCA) ?nDB. +Qed. + +Lemma normsD : A \subset 'N(B :\: C). +Proof. by apply/normsP=> x Ax; rewrite conjDg !(normsP _ x Ax). Qed. + +Lemma normsM : A \subset 'N(B * C). +Proof. by apply/normsP=> x Ax; rewrite conjsMg !(normsP _ x Ax). Qed. + +Lemma normsY : A \subset 'N(B <*> C). +Proof. by apply/normsP=> x Ax; rewrite -genJ conjUg !(normsP _ x Ax). Qed. + +Lemma normsR : A \subset 'N([~: B, C]). +Proof. by apply/normsP=> x Ax; rewrite conjsRg !(normsP _ x Ax). Qed. + +Lemma norms_class_support : A \subset 'N(class_support B C). +Proof. +apply/subsetP=> x Ax; rewrite inE sub_conjg class_supportEr. +apply/bigcupsP=> y Cy; rewrite -sub_conjg -conjsgM conjgC conjsgM. +by rewrite (normsP nBA) // bigcup_sup ?memJ_norm ?(subsetP nCA). +Qed. + +End norm_trans. + +Lemma normsIG A B G : A \subset 'N(B) -> A :&: G \subset 'N(B :&: G). +Proof. by move/normsIs->; rewrite ?normG. Qed. + +Lemma normsGI A B G : A \subset 'N(B) -> G :&: A \subset 'N(G :&: B). +Proof. by move=> nBA; rewrite !(setIC G) normsIG. Qed. + +Lemma norms_bigcap I r (P : pred I) A (B_ : I -> {set gT}) : + A \subset \bigcap_(i <- r | P i) 'N(B_ i) -> + A \subset 'N(\bigcap_(i <- r | P i) B_ i). +Proof. +elim/big_rec2: _ => [|i B N _ IH /subsetIP[nBiA /IH]]; last exact: normsI. +by rewrite normT. +Qed. + +Lemma norms_bigcup I r (P : pred I) A (B_ : I -> {set gT}) : + A \subset \bigcap_(i <- r | P i) 'N(B_ i) -> + A \subset 'N(\bigcup_(i <- r | P i) B_ i). +Proof. +move=> nBA; rewrite -normCs setC_bigcup norms_bigcap //. +by rewrite (eq_bigr _ (fun _ _ => normCs _)). +Qed. + +Lemma normsD1 A B : A \subset 'N(B) -> A \subset 'N(B^#). +Proof. by move/normsD->; rewrite ?norms1. Qed. + +Lemma normD1 A : 'N(A^#) = 'N(A). +Proof. +apply/eqP; rewrite eqEsubset normsD1 //. +rewrite -{2}(setID A 1) setIC normsU //; apply/normsP=> x _; apply/setP=> y. +by rewrite conjIg conjs1g !inE mem_conjg; case: eqP => // ->; rewrite conj1g. +Qed. + +Lemma normalP A B : reflect (A \subset B /\ {in B, normalised A}) (A <| B). +Proof. by apply: (iffP andP)=> [] [sAB]; move/normsP. Qed. + +Lemma normal_sub A B : A <| B -> A \subset B. +Proof. by case/andP. Qed. + +Lemma normal_norm A B : A <| B -> B \subset 'N(A). +Proof. by case/andP. Qed. + +Lemma normalS G H K : K \subset H -> H \subset G -> K <| G -> K <| H. +Proof. +by move=> sKH sHG /andP[_ nKG]; rewrite /(K <| _) sKH (subset_trans sHG). +Qed. + +Lemma normal1 G : 1 <| G. +Proof. by rewrite /normal sub1set group1 norms1. Qed. + +Lemma normal_refl G : G <| G. +Proof. by rewrite /(G <| _) normG subxx. Qed. + +Lemma normalG G : G <| 'N(G). +Proof. by rewrite /(G <| _) normG subxx. Qed. + +Lemma normalSG G H : H \subset G -> H <| 'N_G(H). +Proof. by move=> sHG; rewrite /normal subsetI sHG normG subsetIr. Qed. + +Lemma normalJ A B x : (A :^ x <| B :^ x) = (A <| B). +Proof. by rewrite /normal normJ !conjSg. Qed. + +Lemma normalM G A B : A <| G -> B <| G -> A * B <| G. +Proof. +by case/andP=> sAG nAG /andP[sBG nBG]; rewrite /normal mul_subG ?normsM. +Qed. + +Lemma normalY G A B : A <| G -> B <| G -> A <*> B <| G. +Proof. +by case/andP=> sAG ? /andP[sBG ?]; rewrite /normal join_subG sAG sBG ?normsY. +Qed. + +Lemma normalYl G H : (H <| H <*> G) = (G \subset 'N(H)). +Proof. by rewrite /normal joing_subl join_subG normG. Qed. + +Lemma normalYr G H : (H <| G <*> H) = (G \subset 'N(H)). +Proof. by rewrite joingC normalYl. Qed. + +Lemma normalI G A B : A <| G -> B <| G -> A :&: B <| G. +Proof. +by case/andP=> sAG nAG /andP[_ nBG]; rewrite /normal subIset ?sAG // normsI. +Qed. + +Lemma norm_normalI G A : G \subset 'N(A) -> G :&: A <| G. +Proof. by move=> nAG; rewrite /normal subsetIl normsI ?normG. Qed. + +Lemma normalGI G H A : H \subset G -> A <| G -> H :&: A <| H. +Proof. +by move=> sHG /andP[_ nAG]; exact: norm_normalI (subset_trans sHG nAG). +Qed. + +Lemma normal_subnorm G H : (H <| 'N_G(H)) = (H \subset G). +Proof. by rewrite /normal subsetIr subsetI normG !andbT. Qed. + +Lemma normalD1 A G : (A^# <| G) = (A <| G). +Proof. by rewrite /normal normD1 subDset (setUidPr (sub1G G)). Qed. + +Lemma gcore_sub A G : gcore A G \subset A. +Proof. by rewrite (bigcap_min 1) ?conjsg1. Qed. + +Lemma gcore_norm A G : G \subset 'N(gcore A G). +Proof. +apply/subsetP=> x Gx; rewrite inE; apply/bigcapsP=> y Gy. +by rewrite sub_conjg -conjsgM bigcap_inf ?groupM ?groupV. +Qed. + +Lemma gcore_normal A G : A \subset G -> gcore A G <| G. +Proof. +by move=> sAG; rewrite /normal gcore_norm (subset_trans (gcore_sub A G)). +Qed. + +Lemma gcore_max A B G : B \subset A -> G \subset 'N(B) -> B \subset gcore A G. +Proof. +move=> sBA nBG; apply/bigcapsP=> y Gy. +by rewrite -sub_conjgV (normsP nBG) ?groupV. +Qed. + +Lemma sub_gcore A B G : + G \subset 'N(B) -> (B \subset gcore A G) = (B \subset A). +Proof. +move=> nBG; apply/idP/idP=> [sBAG | sBA]; last exact: gcore_max. +exact: subset_trans (gcore_sub A G). +Qed. + +(* An elementary proof that subgroups of index 2 are normal; it is almost as *) +(* short as the "advanced" proof using group actions; besides, the fact that *) +(* the coset is equal to the complement is used in extremal.v. *) +Lemma rcoset_index2 G H x : + H \subset G -> #|G : H| = 2 -> x \in G :\: H -> H :* x = G :\: H. +Proof. +move=> sHG indexHG => /setDP[Gx notHx]; apply/eqP. +rewrite eqEcard -(leq_add2l #|G :&: H|) cardsID -(LagrangeI G H) indexHG muln2. +rewrite (setIidPr sHG) card_rcoset addnn leqnn andbT. +apply/subsetP=> _ /rcosetP[y Hy ->]; apply/setDP. +by rewrite !groupMl // (subsetP sHG). +Qed. + +Lemma index2_normal G H : H \subset G -> #|G : H| = 2 -> H <| G. +Proof. +move=> sHG indexHG; rewrite /normal sHG; apply/subsetP=> x Gx. +case Hx: (x \in H); first by rewrite inE conjGid. +rewrite inE conjsgE mulgA -sub_rcosetV -invg_rcoset. +by rewrite !(rcoset_index2 sHG) ?inE ?groupV ?Hx // invDg !invGid. +Qed. + +Lemma cent1P x y : reflect (commute x y) (x \in 'C[y]). +Proof. +rewrite inE conjg_set1 sub1set inE (sameP eqP conjg_fixP)commg1_sym. +exact: commgP. +Qed. + +Lemma cent1id x : x \in 'C[x]. Proof. exact/cent1P. Qed. + +Lemma cent1E x y : (x \in 'C[y]) = (x * y == y * x). +Proof. by rewrite (sameP (cent1P x y) eqP). Qed. + +Lemma cent1C x y : (x \in 'C[y]) = (y \in 'C[x]). +Proof. by rewrite !cent1E eq_sym. Qed. + +Canonical centraliser_group A : {group _} := Eval hnf in [group of 'C(A)]. + +Lemma cent_set1 x : 'C([set x]) = 'C[x]. +Proof. by apply: big_pred1 => y /=; rewrite inE. Qed. + +Lemma cent1J x y : 'C[x ^ y] = 'C[x] :^ y. +Proof. by rewrite -conjg_set1 normJ. Qed. + +Lemma centP A x : reflect (centralises x A) (x \in 'C(A)). +Proof. by apply: (iffP bigcapP) => cxA y /cxA/cent1P. Qed. + +Lemma centsP A B : reflect {in A, centralised B} (A \subset 'C(B)). +Proof. by apply: (iffP subsetP) => cAB x /cAB/centP. Qed. + +Lemma centsC A B : (A \subset 'C(B)) = (B \subset 'C(A)). +Proof. by apply/centsP/centsP=> cAB x ? y ?; rewrite /commute -cAB. Qed. + +Lemma cents1 A : A \subset 'C(1). +Proof. by rewrite centsC sub1G. Qed. + +Lemma cent1T : 'C(1) = setT :> {set gT}. +Proof. by apply/eqP; rewrite -subTset cents1. Qed. + +Lemma cent11T : 'C[1] = setT :> {set gT}. +Proof. by rewrite -cent_set1 cent1T. Qed. + +Lemma cent_sub A : 'C(A) \subset 'N(A). +Proof. +apply/subsetP=> x /centP cAx; rewrite inE. +by apply/subsetP=> _ /imsetP[y Ay ->]; rewrite /conjg -cAx ?mulKg. +Qed. + +Lemma cents_norm A B : A \subset 'C(B) -> A \subset 'N(B). +Proof. by move=> cAB; exact: subset_trans (cent_sub B). Qed. + +Lemma centC A B : A \subset 'C(B) -> commute A B. +Proof. by move=> cAB; exact: normC (cents_norm cAB). Qed. + +Lemma cent_joinEl G H : G \subset 'C(H) -> G <*> H = G * H. +Proof. by move=> cGH; exact: norm_joinEl (cents_norm cGH). Qed. + +Lemma cent_joinEr G H : H \subset 'C(G) -> G <*> H = G * H. +Proof. by move=> cGH; exact: norm_joinEr (cents_norm cGH). Qed. + +Lemma centJ A x : 'C(A :^ x) = 'C(A) :^ x. +Proof. +apply/setP=> y; rewrite mem_conjg; apply/centP/centP=> cAy z Az. + by apply: (conjg_inj x); rewrite 2!conjMg conjgKV cAy ?memJ_conjg. +by apply: (conjg_inj x^-1); rewrite 2!conjMg cAy -?mem_conjg. +Qed. + +Lemma cent_norm A : 'N(A) \subset 'N('C(A)). +Proof. by apply/normsP=> x nCx; rewrite -centJ (normP nCx). Qed. + +Lemma norms_cent A B : A \subset 'N(B) -> A \subset 'N('C(B)). +Proof. move=> nBA; exact: subset_trans nBA (cent_norm B). Qed. + +Lemma cent_normal A : 'C(A) <| 'N(A). +Proof. by rewrite /(_ <| _) cent_sub cent_norm. Qed. + +Lemma centS A B : B \subset A -> 'C(A) \subset 'C(B). +Proof. by move=> sAB; rewrite centsC (subset_trans sAB) 1?centsC. Qed. + +Lemma centsS A B C : A \subset B -> C \subset 'C(B) -> C \subset 'C(A). +Proof. by move=> sAB cCB; exact: subset_trans cCB (centS sAB). Qed. + +Lemma centSS A B C D : + A \subset C -> B \subset D -> C \subset 'C(D) -> A \subset 'C(B). +Proof. move=> sAC sBD cCD; exact: subset_trans (centsS sBD cCD). Qed. + +Lemma centI A B : 'C(A) <*> 'C(B) \subset 'C(A :&: B). +Proof. by rewrite gen_subG subUset !centS ?(subsetIl, subsetIr). Qed. + +Lemma centU A B : 'C(A :|: B) = 'C(A) :&: 'C(B). +Proof. +apply/eqP; rewrite eqEsubset subsetI 2?centS ?(subsetUl, subsetUr) //=. +by rewrite centsC subUset -centsC subsetIl -centsC subsetIr. +Qed. + +Lemma cent_gen A : 'C(<>) = 'C(A). +Proof. by apply/setP=> x; rewrite -!sub1set centsC gen_subG centsC. Qed. + +Lemma cent_cycle x : 'C(<[x]>) = 'C[x]. +Proof. by rewrite cent_gen cent_set1. Qed. + +Lemma sub_cent1 A x : (A \subset 'C[x]) = (x \in 'C(A)). +Proof. by rewrite -cent_cycle centsC cycle_subG. Qed. + +Lemma cents_cycle x y : commute x y -> <[x]> \subset 'C(<[y]>). +Proof. move=> cxy; rewrite cent_cycle cycle_subG; exact/cent1P. Qed. + +Lemma cycle_abelian x : abelian <[x]>. +Proof. exact: cents_cycle. Qed. + +Lemma centY A B : 'C(A <*> B) = 'C(A) :&: 'C(B). +Proof. by rewrite cent_gen centU. Qed. + +Lemma centM G H : 'C(G * H) = 'C(G) :&: 'C(H). +Proof. by rewrite -cent_gen genM_join centY. Qed. + +Lemma cent_classP x G : reflect (x ^: G = [set x]) (x \in 'C(G)). +Proof. +apply: (iffP (centP _ _)) => [Cx | Cx1 y Gy]. + apply/eqP; rewrite eqEsubset sub1set class_refl andbT. + by apply/subsetP=> _ /imsetP[y Gy ->]; rewrite inE conjgE Cx ?mulKg. +by apply/commgP/conjg_fixP/set1P; rewrite -Cx1; apply/imsetP; exists y. +Qed. + +Lemma commG1P A B : reflect ([~: A, B] = 1) (A \subset 'C(B)). +Proof. +apply: (iffP (centsP A B)) => [cAB | cAB1 x Ax y By]. + apply/trivgP; rewrite gen_subG; apply/subsetP=> _ /imset2P[x y Ax Ay ->]. + by rewrite inE; apply/commgP; exact: cAB. +by apply/commgP; rewrite -in_set1 -[[set 1]]cAB1 mem_commg. +Qed. + +Lemma abelianE A : abelian A = (A \subset 'C(A)). Proof. by []. Qed. + +Lemma abelian1 : abelian [1 gT]. Proof. exact: sub1G. Qed. + +Lemma abelianS A B : A \subset B -> abelian B -> abelian A. +Proof. by move=> sAB; exact: centSS. Qed. + +Lemma abelianJ A x : abelian (A :^ x) = abelian A. +Proof. by rewrite /abelian centJ conjSg. Qed. + +Lemma abelian_gen A : abelian <> = abelian A. +Proof. by rewrite /abelian cent_gen gen_subG. Qed. + +Lemma abelianY A B : + abelian (A <*> B) = [&& abelian A, abelian B & B \subset 'C(A)]. +Proof. +rewrite /abelian join_subG /= centY !subsetI -!andbA; congr (_ && _). +by rewrite centsC andbA andbb andbC. +Qed. + +Lemma abelianM G H : + abelian (G * H) = [&& abelian G, abelian H & H \subset 'C(G)]. +Proof. by rewrite -abelian_gen genM_join abelianY. Qed. + +Section SubAbelian. + +Variable A B C : {set gT}. +Hypothesis cAA : abelian A. + +Lemma sub_abelian_cent : C \subset A -> A \subset 'C(C). +Proof. by move=> sCA; rewrite centsC (subset_trans sCA). Qed. + +Lemma sub_abelian_cent2 : B \subset A -> C \subset A -> B \subset 'C(C). +Proof. by move=> sBA; move/sub_abelian_cent; exact: subset_trans. Qed. + +Lemma sub_abelian_norm : C \subset A -> A \subset 'N(C). +Proof. by move=> sCA; rewrite cents_norm ?sub_abelian_cent. Qed. + +Lemma sub_abelian_normal : (C \subset A) = (C <| A). +Proof. +by rewrite /normal; case sHG: (C \subset A); rewrite // sub_abelian_norm. +Qed. + +End SubAbelian. + +End Normaliser. + +Implicit Arguments normP [gT x A]. +Implicit Arguments centP [gT x A]. +Implicit Arguments normsP [gT A B]. +Implicit Arguments cent1P [gT x y]. +Implicit Arguments normalP [gT A B]. +Implicit Arguments centsP [gT A B]. +Implicit Arguments commG1P [gT A B]. + +Prenex Implicits normP normsP cent1P normalP centP centsP commG1P. + +Arguments Scope normaliser_group [_ group_scope]. +Arguments Scope centraliser_group [_ group_scope]. + +Notation "''N' ( A )" := (normaliser_group A) : Group_scope. +Notation "''C' ( A )" := (centraliser_group A) : Group_scope. +Notation "''C' [ x ]" := (normaliser_group [set x%g]) : Group_scope. +Notation "''N_' G ( A )" := (setI_group G 'N(A)) : Group_scope. +Notation "''C_' G ( A )" := (setI_group G 'C(A)) : Group_scope. +Notation "''C_' ( G ) ( A )" := (setI_group G 'C(A)) + (only parsing) : Group_scope. +Notation "''C_' G [ x ]" := (setI_group G 'C[x]) : Group_scope. +Notation "''C_' ( G ) [ x ]" := (setI_group G 'C[x]) + (only parsing) : Group_scope. + +Hint Resolve normG normal_refl. + +Section MinMaxGroup. + +Variable gT : finGroupType. +Variable gP : pred {group gT}. +Arguments Scope gP [Group_scope]. + +Definition maxgroup := maxset (fun A => group_set A && gP <>). +Definition mingroup := minset (fun A => group_set A && gP <>). + +Lemma ex_maxgroup : (exists G, gP G) -> {G : {group gT} | maxgroup G}. +Proof. +move=> exP; have [A maxA]: {A | maxgroup A}. + apply: ex_maxset; case: exP => G gPG. + by exists (G : {set gT}); rewrite groupP genGidG. +by exists <>%G; rewrite /= gen_set_id; case/andP: (maxsetp maxA). +Qed. + +Lemma ex_mingroup : (exists G, gP G) -> {G : {group gT} | mingroup G}. +Proof. +move=> exP; have [A minA]: {A | mingroup A}. + apply: ex_minset; case: exP => G gPG. + by exists (G : {set gT}); rewrite groupP genGidG. +by exists <>%G; rewrite /= gen_set_id; case/andP: (minsetp minA). +Qed. + +Variable G : {group gT}. + +Lemma mingroupP : + reflect (gP G /\ forall H, gP H -> H \subset G -> H :=: G) (mingroup G). +Proof. +apply: (iffP minsetP); rewrite /= groupP genGidG /= => [] [-> minG]. + by split=> // H gPH sGH; apply: minG; rewrite // groupP genGidG. +split=> // A; case/andP=> gA gPA; rewrite -(gen_set_id gA); exact: minG. +Qed. + +Lemma maxgroupP : + reflect (gP G /\ forall H, gP H -> G \subset H -> H :=: G) (maxgroup G). +Proof. +apply: (iffP maxsetP); rewrite /= groupP genGidG /= => [] [-> maxG]. + by split=> // H gPH sGH; apply: maxG; rewrite // groupP genGidG. +split=> // A; case/andP=> gA gPA; rewrite -(gen_set_id gA); exact: maxG. +Qed. + +Lemma maxgroupp : maxgroup G -> gP G. Proof. by case/maxgroupP. Qed. + +Lemma mingroupp : mingroup G -> gP G. Proof. by case/mingroupP. Qed. + +Hypothesis gPG : gP G. + +Lemma maxgroup_exists : {H : {group gT} | maxgroup H & G \subset H}. +Proof. +have [A maxA sGA]: {A | maxgroup A & G \subset A}. + by apply: maxset_exists; rewrite groupP genGidG. +by exists <>%G; rewrite /= gen_set_id; case/andP: (maxsetp maxA). +Qed. + +Lemma mingroup_exists : {H : {group gT} | mingroup H & H \subset G}. +Proof. +have [A maxA sGA]: {A | mingroup A & A \subset G}. + by apply: minset_exists; rewrite groupP genGidG. +by exists <>%G; rewrite /= gen_set_id; case/andP: (minsetp maxA). +Qed. + +End MinMaxGroup. + +Notation "[ 'max' A 'of' G | gP ]" := + (maxgroup (fun G : {group _} => gP) A) : group_scope. +Notation "[ 'max' G | gP ]" := [max gval G of G | gP] : group_scope. +Notation "[ 'max' A 'of' G | gP & gQ ]" := + [max A of G | gP && gQ] : group_scope. +Notation "[ 'max' G | gP & gQ ]" := [max G | gP && gQ] : group_scope. +Notation "[ 'min' A 'of' G | gP ]" := + (mingroup (fun G : {group _} => gP) A) : group_scope. +Notation "[ 'min' G | gP ]" := [min gval G of G | gP] : group_scope. +Notation "[ 'min' A 'of' G | gP & gQ ]" := + [min A of G | gP && gQ] : group_scope. +Notation "[ 'min' G | gP & gQ ]" := [min G | gP && gQ] : group_scope. + +Implicit Arguments mingroupP [gT gP G]. +Implicit Arguments maxgroupP [gT gP G]. +Prenex Implicits mingroupP maxgroupP. diff --git a/mathcomp/fingroup/gproduct.v b/mathcomp/fingroup/gproduct.v new file mode 100644 index 0000000..924779f --- /dev/null +++ b/mathcomp/fingroup/gproduct.v @@ -0,0 +1,1703 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +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 <

> <

>. +Proof. +move=> H1_1 H2_1; apply/eqP. +rewrite eqEsubset gen_subG setXS ?subset_gen //. +rewrite -setX_prod -morphim_pair1g -morphim_pairg1 !morphim_gen ?subsetT //. +by rewrite morphim_pair1g morphim_pairg1 mul_subG // genS // setXS ?sub1set. +Qed. + +End ExternalDirProd. + +Section ExternalSDirProd. + +Variables (aT rT : finGroupType) (D : {group aT}) (R : {group rT}). + +(* The pair (a, x) denotes the product sdpair2 a * sdpair1 x *) + +Inductive sdprod_by (to : groupAction D R) : predArgType := + SdPair (ax : aT * rT) of ax \in setX D R. + +Coercion pair_of_sd to (u : sdprod_by to) := let: SdPair ax _ := u in ax. + +Variable to : groupAction D R. + +Notation sdT := (sdprod_by to). +Notation sdval := (@pair_of_sd to). + +Canonical sdprod_subType := Eval hnf in [subType for sdval]. +Definition sdprod_eqMixin := Eval hnf in [eqMixin of sdT by <:]. +Canonical sdprod_eqType := Eval hnf in EqType sdT sdprod_eqMixin. +Definition sdprod_choiceMixin := [choiceMixin of sdT by <:]. +Canonical sdprod_choiceType := ChoiceType sdT sdprod_choiceMixin. +Definition sdprod_countMixin := [countMixin of sdT by <:]. +Canonical sdprod_countType := CountType sdT sdprod_countMixin. +Canonical sdprod_subCountType := Eval hnf in [subCountType of sdT]. +Definition sdprod_finMixin := [finMixin of sdT by <:]. +Canonical sdprod_finType := FinType sdT sdprod_finMixin. +Canonical sdprod_subFinType := Eval hnf in [subFinType of sdT]. + +Definition sdprod_one := SdPair to (group1 _). + +Lemma sdprod_inv_proof (u : sdT) : (u.1^-1, to u.2^-1 u.1^-1) \in setX D R. +Proof. +by case: u => [[a x]] /= /setXP[Da Rx]; rewrite inE gact_stable !groupV ?Da. +Qed. + +Definition sdprod_inv u := SdPair to (sdprod_inv_proof u). + +Lemma sdprod_mul_proof (u v : sdT) : + (u.1 * v.1, to u.2 v.1 * v.2) \in setX D R. +Proof. +case: u v => [[a x] /= /setXP[Da Rx]] [[b y] /= /setXP[Db Ry]]. +by rewrite inE !groupM //= gact_stable. +Qed. + +Definition sdprod_mul u v := SdPair to (sdprod_mul_proof u v). + +Lemma sdprod_mul1g : left_id sdprod_one sdprod_mul. +Proof. +move=> u; apply: val_inj; case: u => [[a x] /=]; case/setXP=> Da _. +by rewrite gact1 // !mul1g. +Qed. + +Lemma sdprod_mulVg : left_inverse sdprod_one sdprod_inv sdprod_mul. +Proof. +move=> u; apply: val_inj; case: u => [[a x] /=]; case/setXP=> Da _. +by rewrite actKVin ?mulVg. +Qed. + +Lemma sdprod_mulgA : associative sdprod_mul. +Proof. +move=> u v w; apply: val_inj; case: u => [[a x]] /=; case/setXP=> Da Rx. +case: v w => [[b y]] /=; case/setXP=> Db Ry [[c z]] /=; case/setXP=> Dc Rz. +by rewrite !(actMin to) // gactM ?gact_stable // !mulgA. +Qed. + +Canonical sdprod_groupMixin := + FinGroup.Mixin sdprod_mulgA sdprod_mul1g sdprod_mulVg. + +Canonical sdprod_baseFinGroupType := + Eval hnf in BaseFinGroupType sdT sdprod_groupMixin. + +Canonical sdprod_groupType := FinGroupType sdprod_mulVg. + +Definition sdpair1 x := insubd sdprod_one (1, x) : sdT. +Definition sdpair2 a := insubd sdprod_one (a, 1) : sdT. + +Lemma sdpair1_morphM : {in R &, {morph sdpair1 : x y / x * y}}. +Proof. +move=> x y Rx Ry; apply: val_inj. +by rewrite /= !val_insubd !inE !group1 !groupM ?Rx ?Ry //= mulg1 act1. +Qed. + +Lemma sdpair2_morphM : {in D &, {morph sdpair2 : a b / a * b}}. +Proof. +move=> a b Da Db; apply: val_inj. +by rewrite /= !val_insubd !inE !group1 !groupM ?Da ?Db //= mulg1 gact1. +Qed. + +Canonical sdpair1_morphism := Morphism sdpair1_morphM. + +Canonical sdpair2_morphism := Morphism sdpair2_morphM. + +Lemma injm_sdpair1 : 'injm sdpair1. +Proof. +apply/subsetP=> x /setIP[Rx]. +by rewrite !inE -val_eqE val_insubd inE Rx group1 /=; case/andP. +Qed. + +Lemma injm_sdpair2 : 'injm sdpair2. +Proof. +apply/subsetP=> a /setIP[Da]. +by rewrite !inE -val_eqE val_insubd inE Da group1 /=; case/andP. +Qed. + +Lemma sdpairE (u : sdT) : u = sdpair2 u.1 * sdpair1 u.2. +Proof. +apply: val_inj; case: u => [[a x] /= /setXP[Da Rx]]. +by rewrite !val_insubd !inE Da Rx !(group1, gact1) // mulg1 mul1g. +Qed. + +Lemma sdpair_act : {in R & D, + forall x a, sdpair1 (to x a) = sdpair1 x ^ sdpair2 a}. +Proof. +move=> x a Rx Da; apply: val_inj. +rewrite /= !val_insubd !inE !group1 gact_stable ?Da ?Rx //=. +by rewrite !mul1g mulVg invg1 mulg1 actKVin ?mul1g. +Qed. + +Lemma sdpair_setact (G : {set rT}) a : G \subset R -> a \in D -> + sdpair1 @* (to^~ a @: G) = (sdpair1 @* G) :^ sdpair2 a. +Proof. +move=> sGR Da; have GtoR := subsetP sGR; apply/eqP. +rewrite eqEcard cardJg !(card_injm injm_sdpair1) //; last first. + by apply/subsetP=> _ /imsetP[x Gx ->]; rewrite gact_stable ?GtoR. +rewrite (card_imset _ (act_inj _ _)) leqnn andbT. +apply/subsetP=> _ /morphimP[xa Rxa /imsetP[x Gx def_xa ->]]. +rewrite mem_conjg -morphV // -sdpair_act ?groupV // def_xa actKin //. +by rewrite mem_morphim ?GtoR. +Qed. + +Lemma im_sdpair_norm : sdpair2 @* D \subset 'N(sdpair1 @* R). +Proof. +apply/subsetP=> _ /morphimP[a _ Da ->]. +rewrite inE -sdpair_setact // morphimS //. +by apply/subsetP=> _ /imsetP[x Rx ->]; rewrite gact_stable. +Qed. + +Lemma im_sdpair_TI : (sdpair1 @* R) :&: (sdpair2 @* D) = 1. +Proof. +apply/trivgP; apply/subsetP=> _ /setIP[/morphimP[x _ Rx ->]]. +case/morphimP=> a _ Da /eqP; rewrite inE -!val_eqE. +by rewrite !val_insubd !inE Da Rx !group1 /eq_op /= eqxx; case/andP. +Qed. + +Lemma im_sdpair : (sdpair1 @* R) * (sdpair2 @* D) = setT. +Proof. +apply/eqP; rewrite -subTset -(normC im_sdpair_norm). +apply/subsetP=> /= u _; rewrite [u]sdpairE. +by case: u => [[a x] /= /setXP[Da Rx]]; rewrite mem_mulg ?mem_morphim. +Qed. + +Lemma sdprod_sdpair : sdpair1 @* R ><| sdpair2 @* D = setT. +Proof. by rewrite sdprodE ?(im_sdpair_norm, im_sdpair, im_sdpair_TI). Qed. + +Variables (A : {set aT}) (G : {set rT}). + +Lemma gacentEsd : 'C_(|to)(A) = sdpair1 @*^-1 'C(sdpair2 @* A). +Proof. +apply/setP=> x; apply/idP/idP. + case/setIP=> Rx /afixP cDAx; rewrite mem_morphpre //. + apply/centP=> _ /morphimP[a Da Aa ->]; red. + by rewrite conjgC -sdpair_act // cDAx // inE Da. +case/morphpreP=> Rx cAx; rewrite inE Rx; apply/afixP=> a /setIP[Da Aa]. +apply: (injmP injm_sdpair1); rewrite ?gact_stable /= ?sdpair_act //=. +by rewrite /conjg (centP cAx) ?mulKg ?mem_morphim. +Qed. + +Hypotheses (sAD : A \subset D) (sGR : G \subset R). + +Lemma astabEsd : 'C(G | to) = sdpair2 @*^-1 'C(sdpair1 @* G). +Proof. +have ssGR := subsetP sGR; apply/setP=> a; apply/idP/idP=> [cGa|]. + rewrite mem_morphpre ?(astab_dom cGa) //. + apply/centP=> _ /morphimP[x Rx Gx ->]; symmetry. + by rewrite conjgC -sdpair_act ?(astab_act cGa) ?(astab_dom cGa). +case/morphpreP=> Da cGa; rewrite !inE Da; apply/subsetP=> x Gx; rewrite inE. +apply/eqP; apply: (injmP injm_sdpair1); rewrite ?gact_stable ?ssGR //=. +by rewrite sdpair_act ?ssGR // /conjg -(centP cGa) ?mulKg ?mem_morphim ?ssGR. +Qed. + +Lemma astabsEsd : 'N(G | to) = sdpair2 @*^-1 'N(sdpair1 @* G). +Proof. +apply/setP=> a; apply/idP/idP=> [nGa|]. + have Da := astabs_dom nGa; rewrite mem_morphpre // inE sub_conjg. + apply/subsetP=> _ /morphimP[x Rx Gx ->]. + by rewrite mem_conjgV -sdpair_act // mem_morphim ?gact_stable ?astabs_act. +case/morphpreP=> Da nGa; rewrite !inE Da; apply/subsetP=> x Gx. +have Rx := subsetP sGR _ Gx; have Rxa: to x a \in R by rewrite gact_stable. +rewrite inE -sub1set -(injmSK injm_sdpair1) ?morphim_set1 ?sub1set //=. +by rewrite sdpair_act ?memJ_norm ?mem_morphim. +Qed. + +Lemma actsEsd : [acts A, on G | to] = (sdpair2 @* A \subset 'N(sdpair1 @* G)). +Proof. by rewrite sub_morphim_pre -?astabsEsd. Qed. + +End ExternalSDirProd. + +Section ProdMorph. + +Variables gT rT : finGroupType. +Implicit Types A B : {set gT}. +Implicit Types G H K : {group gT}. +Implicit Types C D : {set rT}. +Implicit Type L : {group rT}. + +Section defs. + +Variables (A B : {set gT}) (fA fB : gT -> FinGroup.sort rT). + +Definition pprodm of B \subset 'N(A) & {in A & B, morph_act 'J 'J fA fB} + & {in A :&: B, fA =1 fB} := + fun x => fA (divgr A B x) * fB (remgr A B x). + +End defs. + +Section Props. + +Variables H K : {group gT}. +Variables (fH : {morphism H >-> rT}) (fK : {morphism K >-> rT}). +Hypothesis nHK : K \subset 'N(H). +Hypothesis actf : {in H & K, morph_act 'J 'J fH fK}. +Hypothesis eqfHK : {in H :&: K, fH =1 fK}. + +Notation Local f := (pprodm nHK actf eqfHK). + +Lemma pprodmE x a : x \in H -> a \in K -> f (x * a) = fH x * fK a. +Proof. +move=> Hx Ka; have: x * a \in H * K by rewrite mem_mulg. +rewrite -remgrP inE /f rcoset_sym mem_rcoset /divgr -mulgA groupMl //. +case/andP; move: (remgr H K _) => b Hab Kb; rewrite morphM // -mulgA. +have Kab: a * b^-1 \in K by rewrite groupM ?groupV. +by congr (_ * _); rewrite eqfHK 1?inE ?Hab // -morphM // mulgKV. +Qed. + +Lemma pprodmEl : {in H, f =1 fH}. +Proof. by move=> x Hx; rewrite -(mulg1 x) pprodmE // morph1 !mulg1. Qed. + +Lemma pprodmEr : {in K, f =1 fK}. +Proof. by move=> a Ka; rewrite -(mul1g a) pprodmE // morph1 !mul1g. Qed. + +Lemma pprodmM : {in H <*> K &, {morph f: x y / x * y}}. +Proof. +move=> xa yb; rewrite norm_joinEr //. +move=> /imset2P[x a Ha Ka ->{xa}] /imset2P[y b Hy Kb ->{yb}]. +have Hya: y ^ a^-1 \in H by rewrite -mem_conjg (normsP nHK). +rewrite mulgA -(mulgA x) (conjgCV a y) (mulgA x) -mulgA !pprodmE 1?groupMl //. +by rewrite morphM // actf ?groupV ?morphV // morphM // !mulgA mulgKV invgK. +Qed. + +Canonical pprodm_morphism := Morphism pprodmM. + +Lemma morphim_pprodm A B : + A \subset H -> B \subset K -> f @* (A * B) = fH @* A * fK @* B. +Proof. +move=> sAH sBK; rewrite [f @* _]morphimEsub /=; last first. + by rewrite norm_joinEr // mulgSS. +apply/setP=> y; apply/imsetP/idP=> [[_ /mulsgP[x a Ax Ba ->] ->{y}] |]. + have Hx := subsetP sAH x Ax; have Ka := subsetP sBK a Ba. + by rewrite pprodmE // mem_imset2 ?mem_morphim. +case/mulsgP=> _ _ /morphimP[x Hx Ax ->] /morphimP[a Ka Ba ->] ->{y}. +by exists (x * a); rewrite ?mem_mulg ?pprodmE. +Qed. + +Lemma morphim_pprodml A : A \subset H -> f @* A = fH @* A. +Proof. +by move=> sAH; rewrite -{1}(mulg1 A) morphim_pprodm ?sub1G // morphim1 mulg1. +Qed. + +Lemma morphim_pprodmr B : B \subset K -> f @* B = fK @* B. +Proof. +by move=> sBK; rewrite -{1}(mul1g B) morphim_pprodm ?sub1G // morphim1 mul1g. +Qed. + +Lemma ker_pprodm : 'ker f = [set x * a^-1 | x in H, a in K & fH x == fK a]. +Proof. +apply/setP=> y; rewrite 3!inE {1}norm_joinEr //=. +apply/andP/imset2P=> [[/mulsgP[x a Hx Ka ->{y}]]|[x a Hx]]. + rewrite pprodmE // => fxa1. + by exists x a^-1; rewrite ?invgK // inE groupVr ?morphV // eq_mulgV1 invgK. +case/setIdP=> Kx /eqP fx ->{y}. +by rewrite mem_imset2 ?pprodmE ?groupV ?morphV // fx mulgV. +Qed. + +Lemma injm_pprodm : + 'injm f = [&& 'injm fH, 'injm fK & fH @* H :&: fK @* K == fH @* K]. +Proof. +apply/idP/and3P=> [injf | [injfH injfK]]. + rewrite eq_sym -{1}morphimIdom -(morphim_pprodml (subsetIl _ _)) injmI //. + rewrite morphim_pprodml // morphim_pprodmr //=; split=> //. + apply/injmP=> x y Hx Hy /=; rewrite -!pprodmEl //. + by apply: (injmP injf); rewrite ?mem_gen ?inE ?Hx ?Hy. + apply/injmP=> a b Ka Kb /=; rewrite -!pprodmEr //. + by apply: (injmP injf); rewrite ?mem_gen //; apply/setUP; right. +move/eqP=> fHK; rewrite ker_pprodm; apply/subsetP=> y. +case/imset2P=> x a Hx /setIdP[Ka /eqP fxa] ->. +have: fH x \in fH @* K by rewrite -fHK inE {2}fxa !mem_morphim. +case/morphimP=> z Hz Kz /(injmP injfH) def_x. +rewrite def_x // eqfHK ?inE ?Hz // in fxa. +by rewrite def_x // (injmP injfK _ _ Kz Ka fxa) mulgV set11. +Qed. + +End Props. + +Section Sdprodm. + +Variables H K G : {group gT}. +Variables (fH : {morphism H >-> rT}) (fK : {morphism K >-> rT}). +Hypothesis eqHK_G : H ><| K = G. +Hypothesis actf : {in H & K, morph_act 'J 'J fH fK}. + +Lemma sdprodm_norm : K \subset 'N(H). +Proof. by case/sdprodP: eqHK_G. Qed. + +Lemma sdprodm_sub : G \subset H <*> K. +Proof. by case/sdprodP: eqHK_G => _ <- nHK _; rewrite norm_joinEr. Qed. + +Lemma sdprodm_eqf : {in H :&: K, fH =1 fK}. +Proof. +by case/sdprodP: eqHK_G => _ _ _ -> _ /set1P->; rewrite !morph1. +Qed. + +Definition sdprodm := + restrm sdprodm_sub (pprodm sdprodm_norm actf sdprodm_eqf). + +Canonical sdprodm_morphism := Eval hnf in [morphism of sdprodm]. + +Lemma sdprodmE a b : a \in H -> b \in K -> sdprodm (a * b) = fH a * fK b. +Proof. exact: pprodmE. Qed. + +Lemma sdprodmEl a : a \in H -> sdprodm a = fH a. +Proof. exact: pprodmEl. Qed. + +Lemma sdprodmEr b : b \in K -> sdprodm b = fK b. +Proof. exact: pprodmEr. Qed. + +Lemma morphim_sdprodm A B : + A \subset H -> B \subset K -> sdprodm @* (A * B) = fH @* A * fK @* B. +Proof. +move=> sAH sBK; rewrite morphim_restrm /= (setIidPr _) ?morphim_pprodm //. +case/sdprodP: eqHK_G => _ <- _ _; exact: mulgSS. +Qed. + +Lemma im_sdprodm : sdprodm @* G = fH @* H * fK @* K. +Proof. by rewrite -morphim_sdprodm //; case/sdprodP: eqHK_G => _ ->. Qed. + +Lemma morphim_sdprodml A : A \subset H -> sdprodm @* A = fH @* A. +Proof. +by move=> sHA; rewrite -{1}(mulg1 A) morphim_sdprodm ?sub1G // morphim1 mulg1. +Qed. + +Lemma morphim_sdprodmr B : B \subset K -> sdprodm @* B = fK @* B. +Proof. +by move=> sBK; rewrite -{1}(mul1g B) morphim_sdprodm ?sub1G // morphim1 mul1g. +Qed. + +Lemma ker_sdprodm : + 'ker sdprodm = [set a * b^-1 | a in H, b in K & fH a == fK b]. +Proof. +rewrite ker_restrm (setIidPr _) ?subIset ?ker_pprodm //; apply/orP; left. +by case/sdprodP: eqHK_G => _ <- nHK _; rewrite norm_joinEr. +Qed. + +Lemma injm_sdprodm : + 'injm sdprodm = [&& 'injm fH, 'injm fK & fH @* H :&: fK @* K == 1]. +Proof. +rewrite ker_sdprodm -(ker_pprodm sdprodm_norm actf sdprodm_eqf) injm_pprodm. +congr [&& _, _ & _ == _]; have [_ _ _ tiHK] := sdprodP eqHK_G. +by rewrite -morphimIdom tiHK morphim1. +Qed. + +End Sdprodm. + +Section Cprodm. + +Variables H K G : {group gT}. +Variables (fH : {morphism H >-> rT}) (fK : {morphism K >-> rT}). +Hypothesis eqHK_G : H \* K = G. +Hypothesis cfHK : fK @* K \subset 'C(fH @* H). +Hypothesis eqfHK : {in H :&: K, fH =1 fK}. + +Lemma cprodm_norm : K \subset 'N(H). +Proof. by rewrite cents_norm //; case/cprodP: eqHK_G. Qed. + +Lemma cprodm_sub : G \subset H <*> K. +Proof. by case/cprodP: eqHK_G => _ <- cHK; rewrite cent_joinEr. Qed. + +Lemma cprodm_actf : {in H & K, morph_act 'J 'J fH fK}. +Proof. +case/cprodP: eqHK_G => _ _ cHK a b Ha Kb /=. +by rewrite /conjg -(centsP cHK b) // -(centsP cfHK (fK b)) ?mulKg ?mem_morphim. +Qed. + +Definition cprodm := restrm cprodm_sub (pprodm cprodm_norm cprodm_actf eqfHK). + +Canonical cprodm_morphism := Eval hnf in [morphism of cprodm]. + +Lemma cprodmE a b : a \in H -> b \in K -> cprodm (a * b) = fH a * fK b. +Proof. exact: pprodmE. Qed. + +Lemma cprodmEl a : a \in H -> cprodm a = fH a. +Proof. exact: pprodmEl. Qed. + +Lemma cprodmEr b : b \in K -> cprodm b = fK b. +Proof. exact: pprodmEr. Qed. + +Lemma morphim_cprodm A B : + A \subset H -> B \subset K -> cprodm @* (A * B) = fH @* A * fK @* B. +Proof. +move=> sAH sBK; rewrite morphim_restrm /= (setIidPr _) ?morphim_pprodm //. +case/cprodP: eqHK_G => _ <- _; exact: mulgSS. +Qed. + +Lemma im_cprodm : cprodm @* G = fH @* H * fK @* K. +Proof. +by have [_ defHK _] := cprodP eqHK_G; rewrite -{2}defHK morphim_cprodm. +Qed. + +Lemma morphim_cprodml A : A \subset H -> cprodm @* A = fH @* A. +Proof. +by move=> sHA; rewrite -{1}(mulg1 A) morphim_cprodm ?sub1G // morphim1 mulg1. +Qed. + +Lemma morphim_cprodmr B : B \subset K -> cprodm @* B = fK @* B. +Proof. +by move=> sBK; rewrite -{1}(mul1g B) morphim_cprodm ?sub1G // morphim1 mul1g. +Qed. + +Lemma ker_cprodm : 'ker cprodm = [set a * b^-1 | a in H, b in K & fH a == fK b]. +Proof. +rewrite ker_restrm (setIidPr _) ?subIset ?ker_pprodm //; apply/orP; left. +by case/cprodP: eqHK_G => _ <- cHK; rewrite cent_joinEr. +Qed. + +Lemma injm_cprodm : + 'injm cprodm = [&& 'injm fH, 'injm fK & fH @* H :&: fK @* K == fH @* K]. +Proof. +by rewrite ker_cprodm -(ker_pprodm cprodm_norm cprodm_actf eqfHK) injm_pprodm. +Qed. + +End Cprodm. + +Section Dprodm. + +Variables G H K : {group gT}. +Variables (fH : {morphism H >-> rT}) (fK : {morphism K >-> rT}). +Hypothesis eqHK_G : H \x K = G. +Hypothesis cfHK : fK @* K \subset 'C(fH @* H). + +Lemma dprodm_cprod : H \* K = G. +Proof. +by rewrite -eqHK_G /dprod; case/dprodP: eqHK_G => _ _ _ ->; rewrite subxx. +Qed. + +Lemma dprodm_eqf : {in H :&: K, fH =1 fK}. +Proof. by case/dprodP: eqHK_G => _ _ _ -> _ /set1P->; rewrite !morph1. Qed. + +Definition dprodm := cprodm dprodm_cprod cfHK dprodm_eqf. + +Canonical dprodm_morphism := Eval hnf in [morphism of dprodm]. + +Lemma dprodmE a b : a \in H -> b \in K -> dprodm (a * b) = fH a * fK b. +Proof. exact: pprodmE. Qed. + +Lemma dprodmEl a : a \in H -> dprodm a = fH a. +Proof. exact: pprodmEl. Qed. + +Lemma dprodmEr b : b \in K -> dprodm b = fK b. +Proof. exact: pprodmEr. Qed. + +Lemma morphim_dprodm A B : + A \subset H -> B \subset K -> dprodm @* (A * B) = fH @* A * fK @* B. +Proof. exact: morphim_cprodm. Qed. + +Lemma im_dprodm : dprodm @* G = fH @* H * fK @* K. +Proof. exact: im_cprodm. Qed. + +Lemma morphim_dprodml A : A \subset H -> dprodm @* A = fH @* A. +Proof. exact: morphim_cprodml. Qed. + +Lemma morphim_dprodmr B : B \subset K -> dprodm @* B = fK @* B. +Proof. exact: morphim_cprodmr. Qed. + +Lemma ker_dprodm : 'ker dprodm = [set a * b^-1 | a in H, b in K & fH a == fK b]. +Proof. exact: ker_cprodm. Qed. + +Lemma injm_dprodm : + 'injm dprodm = [&& 'injm fH, 'injm fK & fH @* H :&: fK @* K == 1]. +Proof. +rewrite injm_cprodm -(morphimIdom fH K). +by case/dprodP: eqHK_G => _ _ _ ->; rewrite morphim1. +Qed. + +End Dprodm. + +Lemma isog_dprod A B G C D L : + A \x B = G -> C \x D = L -> isog A C -> isog B D -> isog G L. +Proof. +move=> defG {C D} /dprodP[[C D -> ->] defL cCD trCD]. +case/dprodP: defG (defG) => {A B} [[A B -> ->] defG _ _] dG defC defD. +case/isogP: defC defL cCD trCD => fA injfA <-{C}. +case/isogP: defD => fB injfB <-{D} defL cCD trCD. +apply/isogP; exists (dprodm_morphism dG cCD). + by rewrite injm_dprodm injfA injfB trCD eqxx. +by rewrite /= -{2}defG morphim_dprodm. +Qed. + +End ProdMorph. + +Section ExtSdprodm. + +Variables gT aT rT : finGroupType. +Variables (H : {group gT}) (K : {group aT}) (to : groupAction K H). +Variables (fH : {morphism H >-> rT}) (fK : {morphism K >-> rT}). + +Hypothesis actf : {in H & K, morph_act to 'J fH fK}. + +Local Notation fsH := (fH \o invm (injm_sdpair1 to)). +Local Notation fsK := (fK \o invm (injm_sdpair2 to)). +Let DgH := sdpair1 to @* H. +Let DgK := sdpair2 to @* K. + +Lemma xsdprodm_dom1 : DgH \subset 'dom fsH. +Proof. by rewrite ['dom _]morphpre_invm. Qed. +Local Notation gH := (restrm xsdprodm_dom1 fsH). + +Lemma xsdprodm_dom2 : DgK \subset 'dom fsK. +Proof. by rewrite ['dom _]morphpre_invm. Qed. +Local Notation gK := (restrm xsdprodm_dom2 fsK). + +Lemma im_sdprodm1 : gH @* DgH = fH @* H. +Proof. by rewrite morphim_restrm setIid morphim_comp im_invm. Qed. + +Lemma im_sdprodm2 : gK @* DgK = fK @* K. +Proof. by rewrite morphim_restrm setIid morphim_comp im_invm. Qed. + +Lemma xsdprodm_act : {in DgH & DgK, morph_act 'J 'J gH gK}. +Proof. +move=> fh fk; case/morphimP=> h _ Hh ->{fh}; case/morphimP=> k _ Kk ->{fk}. +by rewrite /= -sdpair_act // /restrm /= !invmE ?actf ?gact_stable. +Qed. + +Definition xsdprodm := sdprodm (sdprod_sdpair to) xsdprodm_act. +Canonical xsdprod_morphism := [morphism of xsdprodm]. + +Lemma im_xsdprodm : xsdprodm @* setT = fH @* H * fK @* K. +Proof. by rewrite -im_sdpair morphim_sdprodm // im_sdprodm1 im_sdprodm2. Qed. + +Lemma injm_xsdprodm : + 'injm xsdprodm = [&& 'injm fH, 'injm fK & fH @* H :&: fK @* K == 1]. +Proof. +rewrite injm_sdprodm im_sdprodm1 im_sdprodm2 !subG1 /= !ker_restrm !ker_comp. +rewrite !morphpre_invm !morphimIim. +by rewrite !morphim_injm_eq1 ?subsetIl ?injm_sdpair1 ?injm_sdpair2. +Qed. + +End ExtSdprodm. + +Section DirprodIsom. + +Variable gT : finGroupType. +Implicit Types G H : {group gT}. + +Definition mulgm : gT * gT -> _ := prod_curry mulg. + +Lemma imset_mulgm (A B : {set gT}) : mulgm @: setX A B = A * B. +Proof. by rewrite -curry_imset2X. Qed. + +Lemma mulgmP H1 H2 G : reflect (H1 \x H2 = G) (misom (setX H1 H2) G mulgm). +Proof. +apply: (iffP misomP) => [[pM /isomP[injf /= <-]] | ]. + have /dprodP[_ /= defX cH12] := setX_dprod H1 H2. + rewrite -{4}defX {}defX => /(congr1 (fun A => morphm pM @* A)). + move/(morphimS (morphm_morphism pM)): cH12 => /=. + have sH1H: setX H1 1 \subset setX H1 H2 by rewrite setXS ?sub1G. + have sH2H: setX 1 H2 \subset setX H1 H2 by rewrite setXS ?sub1G. + rewrite morphim1 injm_cent ?injmI //= subsetI => /andP[_]. + by rewrite !morphimEsub //= !imset_mulgm mulg1 mul1g; exact: dprodE. +case/dprodP=> _ defG cH12 trH12. +have fM: morphic (setX H1 H2) mulgm. + apply/morphicP=> [[x1 x2] [y1 y2] /setXP[_ Hx2] /setXP[Hy1 _]]. + by rewrite /= mulgA -(mulgA x1) -(centsP cH12 x2) ?mulgA. +exists fM; apply/isomP; split; last by rewrite morphimEsub //= imset_mulgm. +apply/subsetP=> [[x1 x2]]; rewrite !inE /= andbC -eq_invg_mul. +case: eqP => //= <-; rewrite groupV -in_setI trH12 => /set1P->. +by rewrite invg1 eqxx. +Qed. + +End DirprodIsom. + +Implicit Arguments mulgmP [gT H1 H2 G]. +Prenex Implicits mulgm mulgmP. diff --git a/mathcomp/fingroup/morphism.v b/mathcomp/fingroup/morphism.v new file mode 100644 index 0000000..7013264 --- /dev/null +++ b/mathcomp/fingroup/morphism.v @@ -0,0 +1,1539 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype finfun. +Require Import bigop finset fingroup. + +(******************************************************************************) +(* This file contains the definitions of: *) +(* *) +(* {morphism D >-> rT} == *) +(* the structure type of functions that are group morphisms mapping a *) +(* domain set D : {set aT} to a type rT; rT must have a finGroupType *) +(* structure, and D is usually a group (most of the theory expects this). *) +(* mfun == the coercion projecting {morphism D >-> rT} to aT -> rT *) +(* *) +(* Basic examples: *) +(* idm D == the identity morphism with domain D, or more precisely *) +(* the identity function, but with a canonical *) +(* {morphism G -> gT} structure. *) +(* trivm D == the trivial morphism with domain D *) +(* If f has a {morphism D >-> rT} structure *) +(* 'dom f == D *) +(* f @* A == the image of A by f, where f is defined *) +(* := f @: (D :&: A) *) +(* f @*^-1 R == the pre-image of R by f, where f is defined *) +(* := D :&: f @^-1: R *) +(* 'ker f == the kernel of f *) +(* := f @^-1: 1 *) +(* 'ker_G f == the kernel of f restricted to G *) +(* := G :&: 'ker f (this is a pure notation) *) +(* 'injm f <=> f injective on D *) +(* <-> ker f \subset 1 (this is a pure notation) *) +(* invm injf == the inverse morphism of f, with domain f @* D, when f *) +(* is injective (injf : 'injm f) *) +(* restrm f sDom == the restriction of f to a subset A of D, given *) +(* (sDom : A \subset D); restrm f sDom is transparently *) +(* identical to f; the restrmP and domP lemmas provide *) +(* opaque restrictions. *) +(* invm f infj == the inverse morphism for an injective f, with domain *) +(* f @* D, given (injf : 'injm f) *) +(* *) +(* G \isog H <=> G and H are isomorphic as groups *) +(* H \homg G <=> H is a homomorphic image of G *) +(* isom G H f <=> f maps G isomorphically to H, provided D contains G *) +(* <-> f @: G^# == H^# *) +(* *) +(* If, moreover, g : {morphism G >-> gT} with G : {group aT}, *) +(* factm sKer sDom == the (natural) factor morphism mapping f @* G to g @* G *) +(* given sDom : G \subset D, sKer : 'ker f \subset 'ker g *) +(* ifactm injf g == the (natural) factor morphism mapping f @* G to g @* G *) +(* when f is injective (injf : 'injm f); here g must *) +(* be an actual morphism structure, not its function *) +(* projection. *) +(* *) +(* If g has a {morphism G >-> aT} structure for any G : {group gT}, then *) +(* f \o g has a canonical {morphism g @*^-1 D >-> rT} structure *) +(* *) +(* Finally, for an arbitrary function f : aT -> rT *) +(* morphic D f <=> f preserves group multiplication in D, i.e., *) +(* f (x * y) = (f x) * (f y) for all x, y in D *) +(* morphm fM == a function identical to f, but with a canonical *) +(* {morphism D >-> rT} structure, given fM : morphic D f *) +(* misom D C f <=> f maps D isomorphically to C *) +(* := morphic D f && isom D C f *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Reserved Notation "x \isog y" (at level 70). + +Section MorphismStructure. + +Variables aT rT : finGroupType. + +Structure morphism (D : {set aT}) : Type := Morphism { + mfun :> aT -> FinGroup.sort rT; + _ : {in D &, {morph mfun : x y / x * y}} +}. + +(* We give the most 'lightweight' possible specification to define morphisms:*) +(* local congruence with the group law of aT. We then provide the properties *) +(* for the 'textbook' notion of morphism, when the required structures are *) +(* available (e.g. its domain is a group). *) + +Definition morphism_for D of phant rT := morphism D. + +Definition clone_morphism D f := + let: Morphism _ fM := f + return {type of @Morphism D for f} -> morphism_for D (Phant rT) + in fun k => k fM. + +Variables (D A : {set aT}) (R : {set rT}) (x : aT) (y : rT) (f : aT -> rT). + +CoInductive morphim_spec : Prop := MorphimSpec z & z \in D & z \in A & y = f z. + +Lemma morphimP : reflect morphim_spec (y \in f @: (D :&: A)). +Proof. +apply: (iffP imsetP) => [] [z]; first by case/setIP; exists z. +by exists z; first apply/setIP. +Qed. + +Lemma morphpreP : reflect (x \in D /\ f x \in R) (x \in D :&: f @^-1: R). +Proof. rewrite !inE; exact: andP. Qed. + +End MorphismStructure. + +Notation "{ 'morphism' D >-> T }" := (morphism_for D (Phant T)) + (at level 0, format "{ 'morphism' D >-> T }") : group_scope. +Notation "[ 'morphism' D 'of' f ]" := + (@clone_morphism _ _ D _ (fun fM => @Morphism _ _ D f fM)) + (at level 0, format "[ 'morphism' D 'of' f ]") : form_scope. +Notation "[ 'morphism' 'of' f ]" := (clone_morphism (@Morphism _ _ _ f)) + (at level 0, format "[ 'morphism' 'of' f ]") : form_scope. + +Implicit Arguments morphimP [aT rT D A f y]. +Implicit Arguments morphpreP [aT rT D R f x]. +Prenex Implicits morphimP morphpreP. + +(* domain, image, preimage, kernel, using phantom types to infer the domain *) + +Section MorphismOps1. + +Variables (aT rT : finGroupType) (D : {set aT}) (f : {morphism D >-> rT}). + +Lemma morphM : {in D &, {morph f : x y / x * y}}. +Proof. by case f. Qed. + +Notation morPhantom := (phantom (aT -> rT)). +Definition MorPhantom := Phantom (aT -> rT). + +Definition dom of morPhantom f := D. + +Definition morphim of morPhantom f := fun A => f @: (D :&: A). + +Definition morphpre of morPhantom f := fun R : {set rT} => D :&: f @^-1: R. + +Definition ker mph := morphpre mph 1. + +End MorphismOps1. + +Arguments Scope morphim [_ _ group_scope _ _ group_scope]. +Arguments Scope morphpre [_ _ group_scope _ _ group_scope]. + +Notation "''dom' f" := (dom (MorPhantom f)) + (at level 10, f at level 8, format "''dom' f") : group_scope. + +Notation "''ker' f" := (ker (MorPhantom f)) + (at level 10, f at level 8, format "''ker' f") : group_scope. + +Notation "''ker_' H f" := (H :&: 'ker f) + (at level 10, H at level 2, f at level 8, format "''ker_' H f") + : group_scope. + +Notation "f @* A" := (morphim (MorPhantom f) A) + (at level 24, format "f @* A") : group_scope. + +Notation "f @*^-1 R" := (morphpre (MorPhantom f) R) + (at level 24, format "f @*^-1 R") : group_scope. + +Notation "''injm' f" := (pred_of_set ('ker f) \subset pred_of_set 1) + (at level 10, f at level 8, format "''injm' f") : group_scope. + +Section MorphismTheory. + +Variables aT rT : finGroupType. +Implicit Types A B : {set aT}. +Implicit Types G H : {group aT}. +Implicit Types R S : {set rT}. +Implicit Types M : {group rT}. + +(* Most properties of morphims hold only when the domain is a group. *) +Variables (D : {group aT}) (f : {morphism D >-> rT}). + +Lemma morph1 : f 1 = 1. +Proof. by apply: (mulgI (f 1)); rewrite -morphM ?mulg1. Qed. + +Lemma morph_prod I r (P : pred I) F : + (forall i, P i -> F i \in D) -> + f (\prod_(i <- r | P i) F i) = \prod_( i <- r | P i) f (F i). +Proof. +move=> D_F; elim/(big_load (fun x => x \in D)): _. +elim/big_rec2: _ => [|i _ x Pi [Dx <-]]; first by rewrite morph1. +by rewrite groupM ?morphM // D_F. +Qed. + +Lemma morphV : {in D, {morph f : x / x^-1}}. +Proof. +move=> x Dx; apply: (mulgI (f x)). +by rewrite -morphM ?groupV // !mulgV morph1. +Qed. + +Lemma morphJ : {in D &, {morph f : x y / x ^ y}}. +Proof. by move=> * /=; rewrite !morphM ?morphV // ?groupM ?groupV. Qed. + +Lemma morphX n : {in D, {morph f : x / x ^+ n}}. +Proof. +by elim: n => [|n IHn] x Dx; rewrite ?morph1 // !expgS morphM ?(groupX, IHn). +Qed. + +Lemma morphR : {in D &, {morph f : x y / [~ x, y]}}. +Proof. by move=> * /=; rewrite morphM ?(groupV, groupJ) // morphJ ?morphV. Qed. + +(* morphic image,preimage properties w.r.t. set-theoretic operations *) + +Lemma morphimE A : f @* A = f @: (D :&: A). Proof. by []. Qed. +Lemma morphpreE R : f @*^-1 R = D :&: f @^-1: R. Proof. by []. Qed. +Lemma kerE : 'ker f = f @*^-1 1. Proof. by []. Qed. + +Lemma morphimEsub A : A \subset D -> f @* A = f @: A. +Proof. by move=> sAD; rewrite /morphim (setIidPr sAD). Qed. + +Lemma morphimEdom : f @* D = f @: D. +Proof. exact: morphimEsub. Qed. + +Lemma morphimIdom A : f @* (D :&: A) = f @* A. +Proof. by rewrite /morphim setIA setIid. Qed. + +Lemma morphpreIdom R : D :&: f @*^-1 R = f @*^-1 R. +Proof. by rewrite /morphim setIA setIid. Qed. + +Lemma morphpreIim R : f @*^-1 (f @* D :&: R) = f @*^-1 R. +Proof. +apply/setP=> x; rewrite morphimEdom !inE. +by case Dx: (x \in D); rewrite // mem_imset. +Qed. + +Lemma morphimIim A : f @* D :&: f @* A = f @* A. +Proof. by apply/setIidPr; rewrite imsetS // setIid subsetIl. Qed. + +Lemma mem_morphim A x : x \in D -> x \in A -> f x \in f @* A. +Proof. by move=> Dx Ax; apply/morphimP; exists x. Qed. + +Lemma mem_morphpre R x : x \in D -> f x \in R -> x \in f @*^-1 R. +Proof. by move=> Dx Rfx; exact/morphpreP. Qed. + +Lemma morphimS A B : A \subset B -> f @* A \subset f @* B. +Proof. by move=> sAB; rewrite imsetS ?setIS. Qed. + +Lemma morphim_sub A : f @* A \subset f @* D. +Proof. by rewrite imsetS // setIid subsetIl. Qed. + +Lemma leq_morphim A : #|f @* A| <= #|A|. +Proof. +by apply: (leq_trans (leq_imset_card _ _)); rewrite subset_leq_card ?subsetIr. +Qed. + +Lemma morphpreS R S : R \subset S -> f @*^-1 R \subset f @*^-1 S. +Proof. by move=> sRS; rewrite setIS ?preimsetS. Qed. + +Lemma morphpre_sub R : f @*^-1 R \subset D. +Proof. exact: subsetIl. Qed. + +Lemma morphim_setIpre A R : f @* (A :&: f @*^-1 R) = f @* A :&: R. +Proof. +apply/setP=> fa; apply/morphimP/setIP=> [[a Da] | [/morphimP[a Da Aa ->] Rfa]]. + by rewrite !inE Da /= => /andP[Aa Rfa] ->; rewrite mem_morphim. +by exists a; rewrite // !inE Aa Da. +Qed. + +Lemma morphim0 : f @* set0 = set0. +Proof. by rewrite morphimE setI0 imset0. Qed. + +Lemma morphim_eq0 A : A \subset D -> (f @* A == set0) = (A == set0). +Proof. by rewrite imset_eq0 => /setIidPr->. Qed. + +Lemma morphim_set1 x : x \in D -> f @* [set x] = [set f x]. +Proof. by rewrite /morphim -sub1set => /setIidPr->; exact: imset_set1. Qed. + +Lemma morphim1 : f @* 1 = 1. +Proof. by rewrite morphim_set1 ?morph1. Qed. + +Lemma morphimV A : f @* A^-1 = (f @* A)^-1. +Proof. +wlog suffices: A / f @* A^-1 \subset (f @* A)^-1. + by move=> IH; apply/eqP; rewrite eqEsubset IH -invSg invgK -{1}(invgK A) IH. +apply/subsetP=> _ /morphimP[x Dx Ax' ->]; rewrite !inE in Ax' *. +by rewrite -morphV // mem_imset // inE groupV Dx. +Qed. + +Lemma morphpreV R : f @*^-1 R^-1 = (f @*^-1 R)^-1. +Proof. +apply/setP=> x; rewrite !inE groupV; case Dx: (x \in D) => //=. +by rewrite morphV. +Qed. + +Lemma morphimMl A B : A \subset D -> f @* (A * B) = f @* A * f @* B. +Proof. +move=> sAD; rewrite /morphim setIC -group_modl // (setIidPr sAD). +apply/setP=> fxy; apply/idP/idP. + case/imsetP=> _ /imset2P[x y Ax /setIP[Dy By] ->] ->{fxy}. + by rewrite morphM // (subsetP sAD, mem_imset2) // mem_imset // inE By. +case/imset2P=> _ _ /imsetP[x Ax ->] /morphimP[y Dy By ->] ->{fxy}. +by rewrite -morphM // (subsetP sAD, mem_imset) // mem_mulg // inE By. +Qed. + +Lemma morphimMr A B : B \subset D -> f @* (A * B) = f @* A * f @* B. +Proof. +move=> sBD; apply: invg_inj. +by rewrite invMg -!morphimV invMg morphimMl // -invGid invSg. +Qed. + +Lemma morphpreMl R S : + R \subset f @* D -> f @*^-1 (R * S) = f @*^-1 R * f @*^-1 S. +Proof. +move=> sRfD; apply/setP=> x; rewrite !inE. +apply/andP/imset2P=> [[Dx] | [y z]]; last first. + rewrite !inE => /andP[Dy Rfy] /andP[Dz Rfz] ->. + by rewrite ?(groupM, morphM, mem_imset2). +case/imset2P=> fy fz Rfy Rfz def_fx. +have /morphimP[y Dy _ def_fy]: fy \in f @* D := subsetP sRfD fy Rfy. +exists y (y^-1 * x); last by rewrite mulKVg. + by rewrite !inE Dy -def_fy. +by rewrite !inE groupM ?(morphM, morphV, groupV) // def_fx -def_fy mulKg. +Qed. + +Lemma morphimJ A x : x \in D -> f @* (A :^ x) = f @* A :^ f x. +Proof. +move=> Dx; rewrite !conjsgE morphimMl ?(morphimMr, sub1set, groupV) //. +by rewrite !(morphim_set1, groupV, morphV). +Qed. + +Lemma morphpreJ R x : x \in D -> f @*^-1 (R :^ f x) = f @*^-1 R :^ x. +Proof. +move=> Dx; apply/setP=> y; rewrite conjIg !inE conjGid // !mem_conjg inE. +by case Dy: (y \in D); rewrite // morphJ ?(morphV, groupV). +Qed. + +Lemma morphim_class x A : + x \in D -> A \subset D -> f @* (x ^: A) = f x ^: f @* A. +Proof. +move=> Dx sAD; rewrite !morphimEsub ?class_subG // /class -!imset_comp. +by apply: eq_in_imset => y Ay /=; rewrite morphJ // (subsetP sAD). +Qed. + +Lemma classes_morphim A : + A \subset D -> classes (f @* A) = [set f @* xA | xA in classes A]. +Proof. +move=> sAD; rewrite morphimEsub // /classes -!imset_comp. +apply: eq_in_imset => x /(subsetP sAD) Dx /=. +by rewrite morphim_class ?morphimEsub. +Qed. + +Lemma morphimT : f @* setT = f @* D. +Proof. by rewrite -morphimIdom setIT. Qed. + +Lemma morphimU A B : f @* (A :|: B) = f @* A :|: f @* B. +Proof. by rewrite -imsetU -setIUr. Qed. + +Lemma morphimI A B : f @* (A :&: B) \subset f @* A :&: f @* B. +Proof. by rewrite subsetI // ?morphimS ?(subsetIl, subsetIr). Qed. + +Lemma morphpre0 : f @*^-1 set0 = set0. +Proof. by rewrite morphpreE preimset0 setI0. Qed. + +Lemma morphpreT : f @*^-1 setT = D. +Proof. by rewrite morphpreE preimsetT setIT. Qed. + +Lemma morphpreU R S : f @*^-1 (R :|: S) = f @*^-1 R :|: f @*^-1 S. +Proof. by rewrite -setIUr -preimsetU. Qed. + +Lemma morphpreI R S : f @*^-1 (R :&: S) = f @*^-1 R :&: f @*^-1 S. +Proof. by rewrite -setIIr -preimsetI. Qed. + +Lemma morphpreD R S : f @*^-1 (R :\: S) = f @*^-1 R :\: f @*^-1 S. +Proof. by apply/setP=> x; rewrite !inE; case: (x \in D). Qed. + +(* kernel, domain properties *) + +Lemma kerP x : x \in D -> reflect (f x = 1) (x \in 'ker f). +Proof. move=> Dx; rewrite 2!inE Dx; exact: set1P. Qed. + +Lemma dom_ker : {subset 'ker f <= D}. +Proof. by move=> x /morphpreP[]. Qed. + +Lemma mker x : x \in 'ker f -> f x = 1. +Proof. by move=> Kx; apply/kerP=> //; exact: dom_ker. Qed. + +Lemma mkerl x y : x \in 'ker f -> y \in D -> f (x * y) = f y. +Proof. by move=> Kx Dy; rewrite morphM // ?(dom_ker, mker Kx, mul1g). Qed. + +Lemma mkerr x y : x \in D -> y \in 'ker f -> f (x * y) = f x. +Proof. by move=> Dx Ky; rewrite morphM // ?(dom_ker, mker Ky, mulg1). Qed. + +Lemma rcoset_kerP x y : + x \in D -> y \in D -> reflect (f x = f y) (x \in 'ker f :* y). +Proof. +move=> Dx Dy; rewrite mem_rcoset !inE groupM ?morphM ?groupV //=. +rewrite morphV // -eq_mulgV1; exact: eqP. +Qed. + +Lemma ker_rcoset x y : + x \in D -> y \in D -> f x = f y -> exists2 z, z \in 'ker f & x = z * y. +Proof. move=> Dx Dy eqfxy; apply/rcosetP; exact/rcoset_kerP. Qed. + +Lemma ker_norm : D \subset 'N('ker f). +Proof. +apply/subsetP=> x Dx; rewrite inE; apply/subsetP=> _ /imsetP[y Ky ->]. +by rewrite !inE groupJ ?morphJ // ?dom_ker //= mker ?conj1g. +Qed. + +Lemma ker_normal : 'ker f <| D. +Proof. by rewrite /(_ <| D) subsetIl ker_norm. Qed. + +Lemma morphimGI G A : 'ker f \subset G -> f @* (G :&: A) = f @* G :&: f @* A. +Proof. +move=> sKG; apply/eqP; rewrite eqEsubset morphimI setIC. +apply/subsetP=> _ /setIP[/morphimP[x Dx Ax ->] /morphimP[z Dz Gz]]. +case/ker_rcoset=> {Dz}// y Ky def_x. +have{z Gz y Ky def_x} Gx: x \in G by rewrite def_x groupMl // (subsetP sKG). +by rewrite mem_imset ?inE // Dx Gx Ax. +Qed. + +Lemma morphimIG A G : 'ker f \subset G -> f @* (A :&: G) = f @* A :&: f @* G. +Proof. by move=> sKG; rewrite setIC morphimGI // setIC. Qed. + +Lemma morphimD A B : f @* A :\: f @* B \subset f @* (A :\: B). +Proof. +rewrite subDset -morphimU morphimS //. +by rewrite setDE setUIr setUCr setIT subsetUr. +Qed. + +Lemma morphimDG A G : 'ker f \subset G -> f @* (A :\: G) = f @* A :\: f @* G. +Proof. +move=> sKG; apply/eqP; rewrite eqEsubset morphimD andbT !setDE subsetI. +rewrite morphimS ?subsetIl // -[~: f @* G]setU0 -subDset setDE setCK. +by rewrite -morphimIG //= setIAC -setIA setICr setI0 morphim0. +Qed. + +Lemma morphimD1 A : (f @* A)^# \subset f @* A^#. +Proof. by rewrite -!set1gE -morphim1 morphimD. Qed. + +(* group structure preservation *) + +Lemma morphpre_groupset M : group_set (f @*^-1 M). +Proof. +apply/group_setP; split=> [|x y]; rewrite !inE ?(morph1, group1) //. +by case/andP=> Dx Mfx /andP[Dy Mfy]; rewrite morphM ?groupM. +Qed. + +Lemma morphim_groupset G : group_set (f @* G). +Proof. +apply/group_setP; split=> [|_ _ /morphimP[x Dx Gx ->] /morphimP[y Dy Gy ->]]. + by rewrite -morph1 mem_imset ?group1. +by rewrite -morphM ?mem_imset ?inE ?groupM. +Qed. + +Canonical morphpre_group fPh M := + @group _ (morphpre fPh M) (morphpre_groupset M). +Canonical morphim_group fPh G := @group _ (morphim fPh G) (morphim_groupset G). +Canonical ker_group fPh : {group aT} := Eval hnf in [group of ker fPh]. + +Lemma morph_dom_groupset : group_set (f @: D). +Proof. by rewrite -morphimEdom groupP. Qed. + +Canonical morph_dom_group := group morph_dom_groupset. + +Lemma morphpreMr R S : + S \subset f @* D -> f @*^-1 (R * S) = f @*^-1 R * f @*^-1 S. +Proof. +move=> sSfD; apply: invg_inj. +by rewrite invMg -!morphpreV invMg morphpreMl // -invSg invgK invGid. +Qed. + +Lemma morphimK A : A \subset D -> f @*^-1 (f @* A) = 'ker f * A. +Proof. +move=> sAD; apply/setP=> x; rewrite !inE. +apply/idP/idP=> [/andP[Dx /morphimP[y Dy Ay eqxy]] | /imset2P[z y Kz Ay ->{x}]]. + rewrite -(mulgKV y x) mem_mulg // !inE !(groupM, morphM, groupV) //. + by rewrite morphV //= eqxy mulgV. +have [Dy Dz]: y \in D /\ z \in D by rewrite (subsetP sAD) // dom_ker. +by rewrite groupM // morphM // mker // mul1g mem_imset // inE Dy. +Qed. + +Lemma morphimGK G : 'ker f \subset G -> G \subset D -> f @*^-1 (f @* G) = G. +Proof. by move=> sKG sGD; rewrite morphimK // mulSGid. Qed. + +Lemma morphpre_set1 x : x \in D -> f @*^-1 [set f x] = 'ker f :* x. +Proof. by move=> Dx; rewrite -morphim_set1 // morphimK ?sub1set. Qed. + +Lemma morphpreK R : R \subset f @* D -> f @* (f @*^-1 R) = R. +Proof. +move=> sRfD; apply/setP=> y; apply/morphimP/idP=> [[x _] | Ry]. + by rewrite !inE; case/andP=> _ Rfx ->. +have /morphimP[x Dx _ defy]: y \in f @* D := subsetP sRfD y Ry. +by exists x; rewrite // !inE Dx -defy. +Qed. + +Lemma morphim_ker : f @* 'ker f = 1. +Proof. by rewrite morphpreK ?sub1G. Qed. + +Lemma ker_sub_pre M : 'ker f \subset f @*^-1 M. +Proof. by rewrite morphpreS ?sub1G. Qed. + +Lemma ker_normal_pre M : 'ker f <| f @*^-1 M. +Proof. by rewrite /normal ker_sub_pre subIset ?ker_norm. Qed. + +Lemma morphpreSK R S : + R \subset f @* D -> (f @*^-1 R \subset f @*^-1 S) = (R \subset S). +Proof. +move=> sRfD; apply/idP/idP=> [sf'RS|]; last exact: morphpreS. +suffices: R \subset f @* D :&: S by rewrite subsetI sRfD. +rewrite -(morphpreK sRfD) -[_ :&: S]morphpreK (morphimS, subsetIl) //. +by rewrite morphpreI morphimGK ?subsetIl // setIA setIid. +Qed. + +Lemma sub_morphim_pre A R : + A \subset D -> (f @* A \subset R) = (A \subset f @*^-1 R). +Proof. +move=> sAD; rewrite -morphpreSK (morphimS, morphimK) //. +apply/idP/idP; first by apply: subset_trans; exact: mulG_subr. +by move/(mulgS ('ker f)); rewrite -morphpreMl ?(sub1G, mul1g). +Qed. + +Lemma morphpre_proper R S : + R \subset f @* D -> S \subset f @* D -> + (f @*^-1 R \proper f @*^-1 S) = (R \proper S). +Proof. by move=> dQ dR; rewrite /proper !morphpreSK. Qed. + +Lemma sub_morphpre_im R G : + 'ker f \subset G -> G \subset D -> R \subset f @* D -> + (f @*^-1 R \subset G) = (R \subset f @* G). +Proof. by symmetry; rewrite -morphpreSK ?morphimGK. Qed. + +Lemma ker_trivg_morphim A : + (A \subset 'ker f) = (A \subset D) && (f @* A \subset [1]). +Proof. +case sAD: (A \subset D); first by rewrite sub_morphim_pre. +by rewrite subsetI sAD. +Qed. + +Lemma morphimSK A B : + A \subset D -> (f @* A \subset f @* B) = (A \subset 'ker f * B). +Proof. +move=> sAD; transitivity (A \subset 'ker f * (D :&: B)). + by rewrite -morphimK ?subsetIl // -sub_morphim_pre // /morphim setIA setIid. +by rewrite setIC group_modl (subsetIl, subsetI) // andbC sAD. +Qed. + +Lemma morphimSGK A G : + A \subset D -> 'ker f \subset G -> (f @* A \subset f @* G) = (A \subset G). +Proof. by move=> sGD skfK; rewrite morphimSK // mulSGid. Qed. + +Lemma ltn_morphim A : [1] \proper 'ker_A f -> #|f @* A| < #|A|. +Proof. +case/properP; rewrite sub1set => /setIP[A1 _] [x /setIP[Ax kx] x1]. +rewrite (cardsD1 1 A) A1 ltnS -{1}(setD1K A1) morphimU morphim1. +rewrite (setUidPr _) ?sub1set; last first. + by rewrite -(mker kx) mem_morphim ?(dom_ker kx) // inE x1. +by rewrite (leq_trans (leq_imset_card _ _)) ?subset_leq_card ?subsetIr. +Qed. + +(* injectivity of image and preimage *) + +Lemma morphpre_inj : + {in [pred R : {set rT} | R \subset f @* D] &, injective (fun R => f @*^-1 R)}. +Proof. exact: can_in_inj morphpreK. Qed. + +Lemma morphim_injG : + {in [pred G : {group aT} | 'ker f \subset G & G \subset D] &, + injective (fun G => f @* G)}. +Proof. +move=> G H /andP[sKG sGD] /andP[sKH sHD] eqfGH. +by apply: val_inj; rewrite /= -(morphimGK sKG sGD) eqfGH morphimGK. +Qed. + +Lemma morphim_inj G H : + ('ker f \subset G) && (G \subset D) -> + ('ker f \subset H) && (H \subset D) -> + f @* G = f @* H -> G :=: H. +Proof. by move=> nsGf nsHf /morphim_injG->. Qed. + +(* commutation with generated groups and cycles *) + +Lemma morphim_gen A : A \subset D -> f @* <> = <>. +Proof. +move=> sAD; apply/eqP. +rewrite eqEsubset andbC gen_subG morphimS; last exact: subset_gen. +by rewrite sub_morphim_pre gen_subG // -sub_morphim_pre // subset_gen. +Qed. + +Lemma morphim_cycle x : x \in D -> f @* <[x]> = <[f x]>. +Proof. by move=> Dx; rewrite morphim_gen (sub1set, morphim_set1). Qed. + +Lemma morphimY A B : + A \subset D -> B \subset D -> f @* (A <*> B) = f @* A <*> f @* B. +Proof. by move=> sAD sBD; rewrite morphim_gen ?morphimU // subUset sAD. Qed. + +Lemma morphpre_gen R : + 1 \in R -> R \subset f @* D -> f @*^-1 <> = <>. +Proof. +move=> R1 sRfD; apply/eqP. +rewrite eqEsubset andbC gen_subG morphpreS; last exact: subset_gen. +rewrite -{1}(morphpreK sRfD) -morphim_gen ?subsetIl // morphimGK //=. + by rewrite sub_gen // setIS // preimsetS ?sub1set. +by rewrite gen_subG subsetIl. +Qed. + +(* commutator, normaliser, normal, center properties*) + +Lemma morphimR A B : + A \subset D -> B \subset D -> f @* [~: A, B] = [~: f @* A, f @* B]. +Proof. +move/subsetP=> sAD /subsetP sBD. +rewrite morphim_gen; last first; last congr <<_>>. + by apply/subsetP=> _ /imset2P[x y Ax By ->]; rewrite groupR; auto. +apply/setP=> fz; apply/morphimP/imset2P=> [[z _] | [fx fy]]. + case/imset2P=> x y Ax By -> -> {z fz}. + have Dx := sAD x Ax; have Dy := sBD y By. + by exists (f x) (f y); rewrite ?(mem_imset, morphR) // ?(inE, Dx, Dy). +case/morphimP=> x Dx Ax ->{fx}; case/morphimP=> y Dy By ->{fy} -> {fz}. +by exists [~ x, y]; rewrite ?(inE, morphR, groupR, mem_imset2). +Qed. + +Lemma morphim_norm A : f @* 'N(A) \subset 'N(f @* A). +Proof. +apply/subsetP=> fx; case/morphimP=> x Dx Nx -> {fx}. +by rewrite inE -morphimJ ?(normP Nx). +Qed. + +Lemma morphim_norms A B : A \subset 'N(B) -> f @* A \subset 'N(f @* B). +Proof. +by move=> nBA; apply: subset_trans (morphim_norm B); exact: morphimS. +Qed. + +Lemma morphim_subnorm A B : f @* 'N_A(B) \subset 'N_(f @* A)(f @* B). +Proof. exact: subset_trans (morphimI A _) (setIS _ (morphim_norm B)). Qed. + +Lemma morphim_normal A B : A <| B -> f @* A <| f @* B. +Proof. by case/andP=> sAB nAB; rewrite /(_ <| _) morphimS // morphim_norms. Qed. + +Lemma morphim_cent1 x : x \in D -> f @* 'C[x] \subset 'C[f x]. +Proof. by move=> Dx; rewrite -(morphim_set1 Dx) morphim_norm. Qed. + +Lemma morphim_cent1s A x : x \in D -> A \subset 'C[x] -> f @* A \subset 'C[f x]. +Proof. +by move=> Dx cAx; apply: subset_trans (morphim_cent1 Dx); exact: morphimS. +Qed. + +Lemma morphim_subcent1 A x : x \in D -> f @* 'C_A[x] \subset 'C_(f @* A)[f x]. +Proof. by move=> Dx; rewrite -(morphim_set1 Dx) morphim_subnorm. Qed. + +Lemma morphim_cent A : f @* 'C(A) \subset 'C(f @* A). +Proof. +apply/bigcapsP=> fx; case/morphimP=> x Dx Ax ->{fx}. +by apply: subset_trans (morphim_cent1 Dx); apply: morphimS; exact: bigcap_inf. +Qed. + +Lemma morphim_cents A B : A \subset 'C(B) -> f @* A \subset 'C(f @* B). +Proof. +by move=> cBA; apply: subset_trans (morphim_cent B); exact: morphimS. +Qed. + +Lemma morphim_subcent A B : f @* 'C_A(B) \subset 'C_(f @* A)(f @* B). +Proof. exact: subset_trans (morphimI A _) (setIS _ (morphim_cent B)). Qed. + +Lemma morphim_abelian A : abelian A -> abelian (f @* A). +Proof. exact: morphim_cents. Qed. + +Lemma morphpre_norm R : f @*^-1 'N(R) \subset 'N(f @*^-1 R). +Proof. +apply/subsetP=> x; rewrite !inE => /andP[Dx Nfx]. +by rewrite -morphpreJ ?morphpreS. +Qed. + +Lemma morphpre_norms R S : R \subset 'N(S) -> f @*^-1 R \subset 'N(f @*^-1 S). +Proof. +by move=> nSR; apply: subset_trans (morphpre_norm S); exact: morphpreS. +Qed. + +Lemma morphpre_normal R S : + R \subset f @* D -> S \subset f @* D -> (f @*^-1 R <| f @*^-1 S) = (R <| S). +Proof. +move=> sRfD sSfD; apply/idP/andP=> [|[sRS nSR]]. + by move/morphim_normal; rewrite !morphpreK //; case/andP. +by rewrite /(_ <| _) (subset_trans _ (morphpre_norm _)) morphpreS. +Qed. + +Lemma morphpre_subnorm R S : f @*^-1 'N_R(S) \subset 'N_(f @*^-1 R)(f @*^-1 S). +Proof. by rewrite morphpreI setIS ?morphpre_norm. Qed. + +Lemma morphim_normG G : + 'ker f \subset G -> G \subset D -> f @* 'N(G) = 'N_(f @* D)(f @* G). +Proof. +move=> sKG sGD; apply/eqP; rewrite eqEsubset -{1}morphimIdom morphim_subnorm. +rewrite -(morphpreK (subsetIl _ _)) morphimS //= morphpreI subIset // orbC. +by rewrite -{2}(morphimGK sKG sGD) morphpre_norm. +Qed. + +Lemma morphim_subnormG A G : + 'ker f \subset G -> G \subset D -> f @* 'N_A(G) = 'N_(f @* A)(f @* G). +Proof. +move=> sKB sBD; rewrite morphimIG ?normsG // morphim_normG //. +by rewrite setICA setIA morphimIim. +Qed. + +Lemma morphpre_cent1 x : x \in D -> 'C_D[x] \subset f @*^-1 'C[f x]. +Proof. +move=> Dx; rewrite -sub_morphim_pre ?subsetIl //. +by apply: subset_trans (morphim_cent1 Dx); rewrite morphimS ?subsetIr. +Qed. + +Lemma morphpre_cent1s R x : + x \in D -> R \subset f @* D -> f @*^-1 R \subset 'C[x] -> R \subset 'C[f x]. +Proof. by move=> Dx sRfD; move/(morphim_cent1s Dx); rewrite morphpreK. Qed. + +Lemma morphpre_subcent1 R x : + x \in D -> 'C_(f @*^-1 R)[x] \subset f @*^-1 'C_R[f x]. +Proof. +move=> Dx; rewrite -morphpreIdom -setIA setICA morphpreI setIS //. +exact: morphpre_cent1. +Qed. + +Lemma morphpre_cent A : 'C_D(A) \subset f @*^-1 'C(f @* A). +Proof. +rewrite -sub_morphim_pre ?subsetIl // morphimGI ?(subsetIl, subIset) // orbC. +by rewrite (subset_trans (morphim_cent _)). +Qed. + +Lemma morphpre_cents A R : + R \subset f @* D -> f @*^-1 R \subset 'C(A) -> R \subset 'C(f @* A). +Proof. by move=> sRfD; move/morphim_cents; rewrite morphpreK. Qed. + +Lemma morphpre_subcent R A : 'C_(f @*^-1 R)(A) \subset f @*^-1 'C_R(f @* A). +Proof. +by rewrite -morphpreIdom -setIA setICA morphpreI setIS //; exact: morphpre_cent. +Qed. + +(* local injectivity properties *) + +Lemma injmP : reflect {in D &, injective f} ('injm f). +Proof. +apply: (iffP subsetP) => [injf x y Dx Dy | injf x /= Kx]. + by case/ker_rcoset=> // z /injf/set1P->; rewrite mul1g. +have Dx := dom_ker Kx; apply/set1P/injf => //. +by apply/rcoset_kerP; rewrite // mulg1. +Qed. + +Lemma card_im_injm : (#|f @* D| == #|D|) = 'injm f. +Proof. by rewrite morphimEdom (sameP imset_injP injmP). Qed. + +Section Injective. + +Hypothesis injf : 'injm f. + +Lemma ker_injm : 'ker f = 1. +Proof. exact/trivgP. Qed. + +Lemma injmK A : A \subset D -> f @*^-1 (f @* A) = A. +Proof. by move=> sAD; rewrite morphimK // ker_injm // mul1g. Qed. + +Lemma injm_morphim_inj A B : + A \subset D -> B \subset D -> f @* A = f @* B -> A = B. +Proof. by move=> sAD sBD eqAB; rewrite -(injmK sAD) eqAB injmK. Qed. + +Lemma card_injm A : A \subset D -> #|f @* A| = #|A|. +Proof. +move=> sAD; rewrite morphimEsub // card_in_imset //. +exact: (sub_in2 (subsetP sAD) (injmP injf)). +Qed. + +Lemma order_injm x : x \in D -> #[f x] = #[x]. +Proof. +by move=> Dx; rewrite orderE -morphim_cycle // card_injm ?cycle_subG. +Qed. + +Lemma injm1 x : x \in D -> f x = 1 -> x = 1. +Proof. by move=> Dx; move/(kerP Dx); rewrite ker_injm; move/set1P. Qed. + +Lemma morph_injm_eq1 x : x \in D -> (f x == 1) = (x == 1). +Proof. by move=> Dx; rewrite -morph1 (inj_in_eq (injmP injf)) ?group1. Qed. + +Lemma injmSK A B : + A \subset D -> (f @* A \subset f @* B) = (A \subset B). +Proof. by move=> sAD; rewrite morphimSK // ker_injm mul1g. Qed. + +Lemma sub_morphpre_injm R A : + A \subset D -> R \subset f @* D -> + (f @*^-1 R \subset A) = (R \subset f @* A). +Proof. by move=> sAD sRfD; rewrite -morphpreSK ?injmK. Qed. + +Lemma injm_eq A B : A \subset D -> B \subset D -> (f @* A == f @* B) = (A == B). +Proof. by move=> sAD sBD; rewrite !eqEsubset !injmSK. Qed. + +Lemma morphim_injm_eq1 A : A \subset D -> (f @* A == 1) = (A == 1). +Proof. by move=> sAD; rewrite -morphim1 injm_eq ?sub1G. Qed. + +Lemma injmI A B : f @* (A :&: B) = f @* A :&: f @* B. +Proof. +rewrite -morphimIdom setIIr -4!(injmK (subsetIl D _), =^~ morphimIdom). +by rewrite -morphpreI morphpreK // subIset ?morphim_sub. +Qed. + +Lemma injmD1 A : f @* A^# = (f @* A)^#. +Proof. by have:= morphimDG A injf; rewrite morphim1. Qed. + +Lemma nclasses_injm A : A \subset D -> #|classes (f @* A)| = #|classes A|. +Proof. +move=> sAD; rewrite classes_morphim // card_in_imset //. +move=> _ _ /imsetP[x Ax ->] /imsetP[y Ay ->]. +by apply: injm_morphim_inj; rewrite // class_subG ?(subsetP sAD). +Qed. + +Lemma injm_norm A : A \subset D -> f @* 'N(A) = 'N_(f @* D)(f @* A). +Proof. +move=> sAD; apply/eqP; rewrite -morphimIdom eqEsubset morphim_subnorm. +rewrite -sub_morphpre_injm ?subsetIl // morphpreI injmK // setIS //. +by rewrite -{2}(injmK sAD) morphpre_norm. +Qed. + +Lemma injm_norms A B : + A \subset D -> B \subset D -> (f @* A \subset 'N(f @* B)) = (A \subset 'N(B)). +Proof. by move=> sAD sBD; rewrite -injmSK // injm_norm // subsetI morphimS. Qed. + +Lemma injm_normal A B : + A \subset D -> B \subset D -> (f @* A <| f @* B) = (A <| B). +Proof. by move=> sAD sBD; rewrite /normal injmSK ?injm_norms. Qed. + +Lemma injm_subnorm A B : B \subset D -> f @* 'N_A(B) = 'N_(f @* A)(f @* B). +Proof. by move=> sBD; rewrite injmI injm_norm // setICA setIA morphimIim. Qed. + +Lemma injm_cent1 x : x \in D -> f @* 'C[x] = 'C_(f @* D)[f x]. +Proof. by move=> Dx; rewrite injm_norm ?morphim_set1 ?sub1set. Qed. + +Lemma injm_subcent1 A x : x \in D -> f @* 'C_A[x] = 'C_(f @* A)[f x]. +Proof. by move=> Dx; rewrite injm_subnorm ?morphim_set1 ?sub1set. Qed. + +Lemma injm_cent A : A \subset D -> f @* 'C(A) = 'C_(f @* D)(f @* A). +Proof. +move=> sAD; apply/eqP; rewrite -morphimIdom eqEsubset morphim_subcent. +apply/subsetP=> fx; case/setIP; case/morphimP=> x Dx _ ->{fx} cAfx. +rewrite mem_morphim // inE Dx -sub1set centsC cent_set1 -injmSK //. +by rewrite injm_cent1 // subsetI morphimS // -cent_set1 centsC sub1set. +Qed. + +Lemma injm_cents A B : + A \subset D -> B \subset D -> (f @* A \subset 'C(f @* B)) = (A \subset 'C(B)). +Proof. by move=> sAD sBD; rewrite -injmSK // injm_cent // subsetI morphimS. Qed. + +Lemma injm_subcent A B : B \subset D -> f @* 'C_A(B) = 'C_(f @* A)(f @* B). +Proof. by move=> sBD; rewrite injmI injm_cent // setICA setIA morphimIim. Qed. + +Lemma injm_abelian A : A \subset D -> abelian (f @* A) = abelian A. +Proof. +by move=> sAD; rewrite /abelian -subsetIidl -injm_subcent // injmSK ?subsetIidl. +Qed. + +End Injective. + +Lemma eq_morphim (g : {morphism D >-> rT}): + {in D, f =1 g} -> forall A, f @* A = g @* A. +Proof. +by move=> efg A; apply: eq_in_imset; apply: sub_in1 efg => x /setIP[]. +Qed. + +Lemma eq_in_morphim B A (g : {morphism B >-> rT}) : + D :&: A = B :&: A -> {in A, f =1 g} -> f @* A = g @* A. +Proof. +move=> eqDBA eqAfg; rewrite /morphim /= eqDBA. +by apply: eq_in_imset => x /setIP[_]/eqAfg. +Qed. + +End MorphismTheory. + +Notation "''ker' f" := (ker_group (MorPhantom f)) : Group_scope. +Notation "''ker_' G f" := (G :&: 'ker f)%G : Group_scope. +Notation "f @* G" := (morphim_group (MorPhantom f) G) : Group_scope. +Notation "f @*^-1 M" := (morphpre_group (MorPhantom f) M) : Group_scope. +Notation "f @: D" := (morph_dom_group f D) : Group_scope. + +Implicit Arguments injmP [aT rT D f]. + +Section IdentityMorphism. + +Variable gT : finGroupType. +Implicit Types A B : {set gT}. +Implicit Type G : {group gT}. + +Definition idm of {set gT} := fun x : gT => x : FinGroup.sort gT. + +Lemma idm_morphM A : {in A & , {morph idm A : x y / x * y}}. +Proof. by []. Qed. + +Canonical idm_morphism A := Morphism (@idm_morphM A). + +Lemma injm_idm G : 'injm (idm G). +Proof. by apply/injmP=> x y _ _. Qed. + +Lemma ker_idm G : 'ker (idm G) = 1. +Proof. by apply/trivgP; exact: injm_idm. Qed. + +Lemma morphim_idm A B : B \subset A -> idm A @* B = B. +Proof. +rewrite /morphim /= /idm => /setIidPr->. +by apply/setP=> x; apply/imsetP/idP=> [[y By ->]|Bx]; last exists x. +Qed. + +Lemma morphpre_idm A B : idm A @*^-1 B = A :&: B. +Proof. by apply/setP=> x; rewrite !inE. Qed. + +Lemma im_idm A : idm A @* A = A. +Proof. exact: morphim_idm. Qed. + +End IdentityMorphism. + +Arguments Scope idm [_ group_scope group_scope]. +Prenex Implicits idm. + +Section RestrictedMorphism. + +Variables aT rT : finGroupType. +Variables A D : {set aT}. +Implicit Type B : {set aT}. +Implicit Type R : {set rT}. + +Definition restrm of A \subset D := @id (aT -> FinGroup.sort rT). + +Section Props. + +Hypothesis sAD : A \subset D. +Variable f : {morphism D >-> rT}. +Local Notation fA := (restrm sAD (mfun f)). + +Canonical restrm_morphism := + @Morphism aT rT A fA (sub_in2 (subsetP sAD) (morphM f)). + +Lemma morphim_restrm B : fA @* B = f @* (A :&: B). +Proof. by rewrite {2}/morphim setIA (setIidPr sAD). Qed. + +Lemma restrmEsub B : B \subset A -> fA @* B = f @* B. +Proof. by rewrite morphim_restrm => /setIidPr->. Qed. + +Lemma im_restrm : fA @* A = f @* A. +Proof. exact: restrmEsub. Qed. + +Lemma morphpre_restrm R : fA @*^-1 R = A :&: f @*^-1 R. +Proof. by rewrite setIA (setIidPl sAD). Qed. + +Lemma ker_restrm : 'ker fA = 'ker_A f. +Proof. exact: morphpre_restrm. Qed. + +Lemma injm_restrm : 'injm f -> 'injm fA. +Proof. by apply: subset_trans; rewrite ker_restrm subsetIr. Qed. + +End Props. + +Lemma restrmP (f : {morphism D >-> rT}) : A \subset 'dom f -> + {g : {morphism A >-> rT} | [/\ g = f :> (aT -> rT), 'ker g = 'ker_A f, + forall R, g @*^-1 R = A :&: f @*^-1 R + & forall B, B \subset A -> g @* B = f @* B]}. +Proof. +move=> sAD; exists (restrm_morphism sAD f). +split=> // [|R|B sBA]; first 1 [exact: ker_restrm | exact: morphpre_restrm]. +by rewrite morphim_restrm (setIidPr sBA). +Qed. + +Lemma domP (f : {morphism D >-> rT}) : 'dom f = A -> + {g : {morphism A >-> rT} | [/\ g = f :> (aT -> rT), 'ker g = 'ker f, + forall R, g @*^-1 R = f @*^-1 R + & forall B, g @* B = f @* B]}. +Proof. by move <-; exists f. Qed. + +End RestrictedMorphism. + +Arguments Scope restrm [_ _ group_scope group_scope _ group_scope]. +Prenex Implicits restrm. +Implicit Arguments restrmP [aT rT D A]. +Implicit Arguments domP [aT rT D A]. + +Section TrivMorphism. + +Variables aT rT : finGroupType. + +Definition trivm of {set aT} & aT := 1 : FinGroup.sort rT. + +Lemma trivm_morphM (A : {set aT}) : {in A &, {morph trivm A : x y / x * y}}. +Proof. by move=> x y /=; rewrite mulg1. Qed. + +Canonical triv_morph A := Morphism (@trivm_morphM A). + +Lemma morphim_trivm (G H : {group aT}) : trivm G @* H = 1. +Proof. +apply/setP=> /= y; rewrite inE; apply/idP/eqP=> [|->]; first by case/morphimP. +by apply/morphimP; exists (1 : aT); rewrite /= ?group1. +Qed. + +Lemma ker_trivm (G : {group aT}) : 'ker (trivm G) = G. +Proof. by apply/setIidPl/subsetP=> x _; rewrite !inE /=. Qed. + +End TrivMorphism. + +Arguments Scope trivm [_ _ group_scope group_scope]. +Implicit Arguments trivm [[aT] [rT]]. + +(* The composition of two morphisms is a Canonical morphism instance. *) +Section MorphismComposition. + +Variables gT hT rT : finGroupType. +Variables (G : {group gT}) (H : {group hT}). + +Variable f : {morphism G >-> hT}. +Variable g : {morphism H >-> rT}. + +Notation Local gof := (mfun g \o mfun f). + +Lemma comp_morphM : {in f @*^-1 H &, {morph gof: x y / x * y}}. +Proof. +by move=> x y; rewrite /= !inE => /andP[? ?] /andP[? ?]; rewrite !morphM. +Qed. + +Canonical comp_morphism := Morphism comp_morphM. + +Lemma ker_comp : 'ker gof = f @*^-1 'ker g. +Proof. by apply/setP=> x; rewrite !inE andbA. Qed. + +Lemma injm_comp : 'injm f -> 'injm g -> 'injm gof. +Proof. by move=> injf; rewrite ker_comp; move/trivgP=> ->. Qed. + +Lemma morphim_comp (A : {set gT}) : gof @* A = g @* (f @* A). +Proof. +apply/setP=> z; apply/morphimP/morphimP=> [[x]|[y Hy fAy ->{z}]]. + rewrite !inE => /andP[Gx Hfx]; exists (f x) => //. + by apply/morphimP; exists x. +by case/morphimP: fAy Hy => x Gx Ax ->{y} Hfx; exists x; rewrite ?inE ?Gx. +Qed. + +Lemma morphpre_comp (C : {set rT}) : gof @*^-1 C = f @*^-1 (g @*^-1 C). +Proof. by apply/setP=> z; rewrite !inE andbA. Qed. + +End MorphismComposition. + +(* The factor morphism *) +Section FactorMorphism. + +Variables aT qT rT : finGroupType. + +Variables G H : {group aT}. +Variable f : {morphism G >-> rT}. +Variable q : {morphism H >-> qT}. + +Definition factm of 'ker q \subset 'ker f & G \subset H := + fun x => f (repr (q @*^-1 [set x])). + +Hypothesis sKqKf : 'ker q \subset 'ker f. +Hypothesis sGH : G \subset H. + +Notation ff := (factm sKqKf sGH). + +Lemma factmE x : x \in G -> ff (q x) = f x. +Proof. +rewrite /ff => Gx; have Hx := subsetP sGH x Gx. +have /mem_repr: x \in q @*^-1 [set q x] by rewrite !inE Hx /=. +case/morphpreP; move: (repr _) => y Hy /set1P. +by case/ker_rcoset=> // z Kz ->; rewrite mkerl ?(subsetP sKqKf). +Qed. + +Lemma factm_morphM : {in q @* G &, {morph ff : x y / x * y}}. +Proof. +move=> _ _ /morphimP[x Hx Gx ->] /morphimP[y Hy Gy ->]. +by rewrite -morphM ?factmE ?groupM // morphM. +Qed. + +Canonical factm_morphism := Morphism factm_morphM. + +Lemma morphim_factm (A : {set aT}) : ff @* (q @* A) = f @* A. +Proof. +rewrite -morphim_comp /= {1}/morphim /= morphimGK //; last first. + by rewrite (subset_trans sKqKf) ?subsetIl. +apply/setP=> y; apply/morphimP/morphimP; + by case=> x Gx Ax ->{y}; exists x; rewrite //= factmE. +Qed. + +Lemma morphpre_factm (C : {set rT}) : ff @*^-1 C = q @* (f @*^-1 C). +Proof. +apply/setP=> y; rewrite !inE /=; apply/andP/morphimP=> [[]|[x Hx]]; last first. + by case/morphpreP=> Gx Cfx ->; rewrite factmE ?mem_imset ?inE ?Hx. +case/morphimP=> x Hx Gx ->; rewrite factmE //. +by exists x; rewrite // !inE Gx. +Qed. + +Lemma ker_factm : 'ker ff = q @* 'ker f. +Proof. exact: morphpre_factm. Qed. + +Lemma injm_factm : 'injm f -> 'injm ff. +Proof. by rewrite ker_factm => /trivgP->; rewrite morphim1. Qed. + +Lemma injm_factmP : reflect ('ker f = 'ker q) ('injm ff). +Proof. +rewrite ker_factm -morphimIdom sub_morphim_pre ?subsetIl //. +rewrite setIA (setIidPr sGH) (sameP setIidPr eqP) (setIidPl _) // eq_sym. +exact: eqP. +Qed. + +Lemma ker_factm_loc (K : {group aT}) : 'ker_(q @* K) ff = q @* 'ker_K f. +Proof. by rewrite ker_factm -morphimIG. Qed. + +End FactorMorphism. + +Prenex Implicits factm. + +Section InverseMorphism. + +Variables aT rT : finGroupType. +Implicit Types A B : {set aT}. +Implicit Types C D : {set rT}. +Variables (G : {group aT}) (f : {morphism G >-> rT}). +Hypothesis injf : 'injm f. + +Lemma invm_subker : 'ker f \subset 'ker (idm G). +Proof. by rewrite ker_idm. Qed. + +Definition invm := factm invm_subker (subxx _). + +Canonical invm_morphism := Eval hnf in [morphism of invm]. + +Lemma invmE : {in G, cancel f invm}. +Proof. exact: factmE. Qed. + +Lemma invmK : {in f @* G, cancel invm f}. +Proof. by move=> fx; case/morphimP=> x _ Gx ->; rewrite invmE. Qed. + +Lemma morphpre_invm A : invm @*^-1 A = f @* A. +Proof. by rewrite morphpre_factm morphpre_idm morphimIdom. Qed. + +Lemma morphim_invm A : A \subset G -> invm @* (f @* A) = A. +Proof. by move=> sAG; rewrite morphim_factm morphim_idm. Qed. + +Lemma morphim_invmE C : invm @* C = f @*^-1 C. +Proof. +rewrite -morphpreIdom -(morphim_invm (subsetIl _ _)). +by rewrite morphimIdom -morphpreIim morphpreK (subsetIl, morphimIdom). +Qed. + +Lemma injm_proper A B : + A \subset G -> B \subset G -> (f @* A \proper f @* B) = (A \proper B). +Proof. +move=> dA dB; rewrite -morphpre_invm -(morphpre_invm B). +by rewrite morphpre_proper ?morphim_invm. +Qed. + +Lemma injm_invm : 'injm invm. +Proof. by move/can_in_inj/injmP: invmK. Qed. + +Lemma ker_invm : 'ker invm = 1. +Proof. by move/trivgP: injm_invm. Qed. + +Lemma im_invm : invm @* (f @* G) = G. +Proof. exact: morphim_invm. Qed. + +End InverseMorphism. + +Prenex Implicits invm. + +Section InjFactm. + +Variables (gT aT rT : finGroupType) (D G : {group gT}). +Variables (g : {morphism G >-> rT}) (f : {morphism D >-> aT}) (injf : 'injm f). + +Definition ifactm := + tag (domP [morphism of g \o invm injf] (morphpre_invm injf G)). + +Lemma ifactmE : {in D, forall x, ifactm (f x) = g x}. +Proof. +rewrite /ifactm => x Dx; case: domP => f' /= [def_f' _ _ _]. +by rewrite {f'}def_f' //= invmE. +Qed. + +Lemma morphim_ifactm (A : {set gT}) : + A \subset D -> ifactm @* (f @* A) = g @* A. +Proof. +rewrite /ifactm => sAD; case: domP => _ /= [_ _ _ ->]. +by rewrite morphim_comp morphim_invm. +Qed. + +Lemma im_ifactm : G \subset D -> ifactm @* (f @* G) = g @* G. +Proof. exact: morphim_ifactm. Qed. + +Lemma morphpre_ifactm C : ifactm @*^-1 C = f @* (g @*^-1 C). +Proof. +rewrite /ifactm; case: domP => _ /= [_ _ -> _]. +by rewrite morphpre_comp morphpre_invm. +Qed. + +Lemma ker_ifactm : 'ker ifactm = f @* 'ker g. +Proof. exact: morphpre_ifactm. Qed. + +Lemma injm_ifactm : 'injm g -> 'injm ifactm. +Proof. by rewrite ker_ifactm => /trivgP->; rewrite morphim1. Qed. + +End InjFactm. + +(* Reflected (boolean) form of morphism and isomorphism properties *) + +Section ReflectProp. + +Variables aT rT : finGroupType. + +Section Defs. + +Variables (A : {set aT}) (B : {set rT}). + +(* morphic is the morphM property of morphisms seen through morphicP *) +Definition morphic (f : aT -> rT) := + [forall u in [predX A & A], f (u.1 * u.2) == f u.1 * f u.2]. + +Definition isom f := f @: A^# == B^#. + +Definition misom f := morphic f && isom f. + +Definition isog := [exists f : {ffun aT -> rT}, misom f]. + +Section MorphicProps. + +Variable f : aT -> rT. + +Lemma morphicP : reflect {in A &, {morph f : x y / x * y}} (morphic f). +Proof. +apply: (iffP forallP) => [fM x y Ax Ay | fM [x y] /=]. + by apply/eqP; have:= fM (x, y); rewrite inE /= Ax Ay. +by apply/implyP=> /andP[Ax Ay]; rewrite fM. +Qed. + +Definition morphm of morphic f := f : aT -> FinGroup.sort rT. + +Lemma morphmE fM : morphm fM = f. Proof. by []. Qed. + +Canonical morphm_morphism fM := @Morphism _ _ A (morphm fM) (morphicP fM). + +End MorphicProps. + +Lemma misomP f : reflect {fM : morphic f & isom (morphm fM)} (misom f). +Proof. by apply: (iffP andP) => [] [fM fiso] //; exists fM. Qed. + +Lemma misom_isog f : misom f -> isog. +Proof. +case/andP=> fM iso_f; apply/existsP; exists (finfun f). +apply/andP; split; last by rewrite /misom /isom !(eq_imset _ (ffunE f)). +apply/forallP=> u; rewrite !ffunE; exact: forallP fM u. +Qed. + +Lemma isom_isog (D : {group aT}) (f : {morphism D >-> rT}) : + A \subset D -> isom f -> isog. +Proof. +move=> sAD isof; apply: (@misom_isog f); rewrite /misom isof andbT. +apply/morphicP; exact: (sub_in2 (subsetP sAD) (morphM f)). +Qed. + +Lemma isog_isom : isog -> {f : {morphism A >-> rT} | isom f}. +Proof. +by case/existsP/sigW=> f /misomP[fM isom_f]; exists (morphm_morphism fM). +Qed. + +End Defs. + +Infix "\isog" := isog. + +Implicit Arguments isom_isog [A B D]. + +(* The real reflection properties only hold for true groups and morphisms. *) + +Section Main. + +Variables (G : {group aT}) (H : {group rT}). + +Lemma isomP (f : {morphism G >-> rT}) : + reflect ('injm f /\ f @* G = H) (isom G H f). +Proof. +apply: (iffP eqP) => [eqfGH | [injf <-]]; last first. + by rewrite -injmD1 // morphimEsub ?subsetDl. +split. + apply/subsetP=> x /morphpreP[Gx fx1]; have: f x \notin H^# by rewrite inE fx1. + by apply: contraR => ntx; rewrite -eqfGH mem_imset // inE ntx. +rewrite morphimEdom -{2}(setD1K (group1 G)) imsetU eqfGH. +by rewrite imset_set1 morph1 setD1K. +Qed. + +Lemma isogP : + reflect (exists2 f : {morphism G >-> rT}, 'injm f & f @* G = H) (G \isog H). +Proof. +apply: (iffP idP) => [/isog_isom[f /isomP[]] | [f injf fG]]; first by exists f. +by apply: (isom_isog f) => //; apply/isomP. +Qed. + +Variable f : {morphism G >-> rT}. +Hypothesis isoGH : isom G H f. + +Lemma isom_inj : 'injm f. Proof. by have /isomP[] := isoGH. Qed. +Lemma isom_im : f @* G = H. Proof. by have /isomP[] := isoGH. Qed. +Lemma isom_card : #|G| = #|H|. +Proof. by rewrite -isom_im card_injm ?isom_inj. Qed. +Lemma isom_sub_im : H \subset f @* G. Proof. by rewrite isom_im. Qed. +Definition isom_inv := restrm isom_sub_im (invm isom_inj). + +End Main. + +Variables (G : {group aT}) (f : {morphism G >-> rT}). + +Lemma morphim_isom (H : {group aT}) (K : {group rT}) : + H \subset G -> isom H K f -> f @* H = K. +Proof. by case/(restrmP f)=> g [gf _ _ <- //]; rewrite -gf; case/isomP. Qed. + +Lemma sub_isom (A : {set aT}) (C : {set rT}) : + A \subset G -> f @* A = C -> 'injm f -> isom A C f. +Proof. +move=> sAG; case: (restrmP f sAG) => g [_ _ _ img] <-{C} injf. +rewrite /isom -morphimEsub ?morphimDG ?morphim1 //. +by rewrite subDset setUC subsetU ?sAG. +Qed. + +Lemma sub_isog (A : {set aT}) : A \subset G -> 'injm f -> isog A (f @* A). +Proof. by move=> sAG injf; apply: (isom_isog f sAG); exact: sub_isom. Qed. + +Lemma restr_isom_to (A : {set aT}) (C R : {group rT}) (sAG : A \subset G) : + f @* A = C -> isom G R f -> isom A C (restrm sAG f). +Proof. by move=> defC /isomP[inj_f _]; apply: sub_isom. Qed. + +Lemma restr_isom (A : {group aT}) (R : {group rT}) (sAG : A \subset G) : + isom G R f -> isom A (f @* A) (restrm sAG f). +Proof. exact: restr_isom_to. Qed. + +End ReflectProp. + +Arguments Scope isom [_ _ group_scope group_scope _]. +Arguments Scope morphic [_ _ group_scope _]. +Arguments Scope misom [_ _ group_scope group_scope _]. +Arguments Scope isog [_ _ group_scope group_scope]. + +Implicit Arguments morphicP [aT rT A f]. +Implicit Arguments misomP [aT rT A B f]. +Implicit Arguments isom_isog [aT rT A B D]. +Implicit Arguments isomP [aT rT G H f]. +Implicit Arguments isogP [aT rT G H]. +Prenex Implicits morphic morphicP morphm isom isog isomP misomP isogP. +Notation "x \isog y":= (isog x y). + +Section Isomorphisms. + +Variables gT hT kT : finGroupType. +Variables (G : {group gT}) (H : {group hT}) (K : {group kT}). + +Lemma idm_isom : isom G G (idm G). +Proof. exact: sub_isom (im_idm G) (injm_idm G). Qed. + +Lemma isog_refl : G \isog G. Proof. exact: isom_isog idm_isom. Qed. + +Lemma card_isog : G \isog H -> #|G| = #|H|. +Proof. case/isogP=> f injf <-; apply: isom_card (f) _; exact/isomP. Qed. + +Lemma isog_abelian : G \isog H -> abelian G = abelian H. +Proof. by case/isogP=> f injf <-; rewrite injm_abelian. Qed. + +Lemma trivial_isog : G :=: 1 -> H :=: 1 -> G \isog H. +Proof. +move=> -> ->; apply/isogP. +exists [morphism of @trivm gT hT 1]; rewrite /= ?morphim1 //. +rewrite ker_trivm; exact: subxx. +Qed. + +Lemma isog_eq1 : G \isog H -> (G :==: 1) = (H :==: 1). +Proof. by move=> isoGH; rewrite !trivg_card1 card_isog. Qed. + +Lemma isom_sym (f : {morphism G >-> hT}) (isoGH : isom G H f) : + isom H G (isom_inv isoGH). +Proof. +rewrite sub_isom 1?injm_restrm ?injm_invm // im_restrm. +by rewrite -(isom_im isoGH) im_invm. +Qed. + +Lemma isog_symr : G \isog H -> H \isog G. +Proof. by case/isog_isom=> f /isom_sym/isom_isog->. Qed. + +Lemma isog_trans : G \isog H -> H \isog K -> G \isog K. +Proof. +case/isogP=> f injf <-; case/isogP=> g injg <-. +have defG: f @*^-1 (f @* G) = G by rewrite morphimGK ?subsetIl. +rewrite -morphim_comp -{1 8}defG. +by apply/isogP; exists [morphism of g \o f]; rewrite ?injm_comp. +Qed. + +Lemma nclasses_isog : G \isog H -> #|classes G| = #|classes H|. +Proof. by case/isogP=> f injf <-; rewrite nclasses_injm. Qed. + +End Isomorphisms. + +Section IsoBoolEquiv. + +Variables gT hT kT : finGroupType. +Variables (G : {group gT}) (H : {group hT}) (K : {group kT}). + +Lemma isog_sym : (G \isog H) = (H \isog G). +Proof. apply/idP/idP; exact: isog_symr. Qed. + +Lemma isog_transl : G \isog H -> (G \isog K) = (H \isog K). +Proof. +by move=> iso; apply/idP/idP; apply: isog_trans; rewrite // -isog_sym. +Qed. + +Lemma isog_transr : G \isog H -> (K \isog G) = (K \isog H). +Proof. +by move=> iso; apply/idP/idP; move/isog_trans; apply; rewrite // -isog_sym. +Qed. + +End IsoBoolEquiv. + +Section Homg. + +Implicit Types rT gT aT : finGroupType. + +Definition homg rT aT (C : {set rT}) (D : {set aT}) := + [exists (f : {ffun aT -> rT} | morphic D f), f @: D == C]. + +Lemma homgP rT aT (C : {set rT}) (D : {set aT}) : + reflect (exists f : {morphism D >-> rT}, f @* D = C) (homg C D). +Proof. +apply: (iffP exists_eq_inP) => [[f fM <-] | [f <-]]. + by exists (morphm_morphism fM); rewrite /morphim /= setIid. +exists (finfun f); first by apply/morphicP=> x y Dx Dy; rewrite !ffunE morphM. +by rewrite /morphim setIid; apply: eq_imset => x; rewrite ffunE. +Qed. + +Lemma morphim_homg aT rT (A D : {set aT}) (f : {morphism D >-> rT}) : + A \subset D -> homg (f @* A) A. +Proof. +move=> sAD; apply/homgP; exists (restrm_morphism sAD f). +by rewrite morphim_restrm setIid. +Qed. + +Lemma leq_homg rT aT (C : {set rT}) (G : {group aT}) : + homg C G -> #|C| <= #|G|. +Proof. by case/homgP=> f <-; apply: leq_morphim. Qed. + +Lemma homg_refl aT (A : {set aT}) : homg A A. +Proof. by apply/homgP; exists (idm_morphism A); rewrite im_idm. Qed. + +Lemma homg_trans aT (B : {set aT}) rT (C : {set rT}) gT (G : {group gT}) : + homg C B -> homg B G -> homg C G. +Proof. +move=> homCB homBG; case/homgP: homBG homCB => fG <- /homgP[fK <-]. +by rewrite -morphim_comp morphim_homg // -sub_morphim_pre. +Qed. + +Lemma isogEcard rT aT (G : {group rT}) (H : {group aT}) : + (G \isog H) = (homg G H) && (#|H| <= #|G|). +Proof. +rewrite isog_sym; apply/isogP/andP=> [[f injf <-] | []]. + by rewrite leq_eqVlt eq_sym card_im_injm injf morphim_homg. +case/homgP=> f <-; rewrite leq_eqVlt eq_sym card_im_injm. +by rewrite ltnNge leq_morphim orbF; exists f. +Qed. + +Lemma isog_hom rT aT (G : {group rT}) (H : {group aT}) : G \isog H -> homg G H. +Proof. by rewrite isogEcard; case/andP. Qed. + +Lemma isogEhom rT aT (G : {group rT}) (H : {group aT}) : + (G \isog H) = homg G H && homg H G. +Proof. +apply/idP/andP=> [isoGH | [homGH homHG]]. + by rewrite !isog_hom // isog_sym. +by rewrite isogEcard homGH leq_homg. +Qed. + +Lemma eq_homgl gT aT rT (G : {group gT}) (H : {group aT}) (K : {group rT}) : + G \isog H -> homg G K = homg H K. +Proof. +by rewrite isogEhom => /andP[homGH homHG]; apply/idP/idP; exact: homg_trans. +Qed. + +Lemma eq_homgr gT rT aT (G : {group gT}) (H : {group rT}) (K : {group aT}) : + G \isog H -> homg K G = homg K H. +Proof. +rewrite isogEhom => /andP[homGH homHG]. +by apply/idP/idP=> homK; exact: homg_trans homK _. +Qed. + +End Homg. + +Arguments Scope homg [_ _ group_scope group_scope]. +Notation "G \homg H" := (homg G H) + (at level 70, no associativity) : group_scope. + +Implicit Arguments homgP [rT aT C D]. + +(* Isomorphism between a group and its subtype. *) + +Section SubMorphism. + +Variables (gT : finGroupType) (G : {group gT}). + +Canonical sgval_morphism := Morphism (@sgvalM _ G). +Canonical subg_morphism := Morphism (@subgM _ G). + +Lemma injm_sgval : 'injm sgval. +Proof. apply/injmP; apply: in2W; exact: subg_inj. Qed. + +Lemma injm_subg : 'injm (subg G). +Proof. apply/injmP; exact: can_in_inj (@subgK _ _). Qed. +Hint Resolve injm_sgval injm_subg. + +Lemma ker_sgval : 'ker sgval = 1. Proof. exact/trivgP. Qed. +Lemma ker_subg : 'ker (subg G) = 1. Proof. exact/trivgP. Qed. + +Lemma im_subg : subg G @* G = [subg G]. +Proof. +apply/eqP; rewrite -subTset morphimEdom. +by apply/subsetP=> u _; rewrite -(sgvalK u) mem_imset ?subgP. +Qed. + +Lemma sgval_sub A : sgval @* A \subset G. +Proof. apply/subsetP=> x; case/imsetP=> u _ ->; exact: subgP. Qed. + +Lemma sgvalmK A : subg G @* (sgval @* A) = A. +Proof. +apply/eqP; rewrite eqEcard !card_injm ?subsetT ?sgval_sub // leqnn andbT. +rewrite -morphim_comp; apply/subsetP=> _ /morphimP[v _ Av ->] /=. +by rewrite sgvalK. +Qed. + +Lemma subgmK (A : {set gT}) : A \subset G -> sgval @* (subg G @* A) = A. +Proof. +move=> sAG; apply/eqP; rewrite eqEcard !card_injm ?subsetT //. +rewrite leqnn andbT -morphim_comp morphimE /= morphpreT. +by apply/subsetP=> _ /morphimP[v Gv Av ->] /=; rewrite subgK. +Qed. + +Lemma im_sgval : sgval @* [subg G] = G. +Proof. by rewrite -{2}im_subg subgmK. Qed. + +Lemma isom_subg : isom G [subg G] (subg G). +Proof. by apply/isomP; rewrite im_subg. Qed. + +Lemma isom_sgval : isom [subg G] G sgval. +Proof. by apply/isomP; rewrite im_sgval. Qed. + +Lemma isog_subg : isog G [subg G]. +Proof. exact: isom_isog isom_subg. Qed. + +End SubMorphism. + diff --git a/mathcomp/fingroup/perm.v b/mathcomp/fingroup/perm.v new file mode 100644 index 0000000..9c31176 --- /dev/null +++ b/mathcomp/fingroup/perm.v @@ -0,0 +1,576 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path choice fintype. +Require Import tuple finfun bigop finset binomial fingroup. + +(******************************************************************************) +(* This file contains the definition and properties associated to the group *) +(* of permutations of an arbitrary finite type. *) +(* {perm T} == the type of permutations of a finite type T, i.e., *) +(* injective (finite) functions from T to T. Permutations *) +(* coerce to CiC functions. *) +(* 'S_n == the set of all permutations of 'I_n, i.e., of {0,.., n-1} *) +(* perm_on A u == u is a permutation with support A, i.e., u only displaces *) +(* elements of A (u x != x implies x \in A). *) +(* tperm x y == the transposition of x, y *) +(* aperm x s == the image of x under the action of the permutation s *) +(* := s x *) +(* pcycle s x == the set of all elements that are in the same cycle of the *) +(* permutation s as x, i.e., {x, s x, (s ^+ 2) x, ...} *) +(* pcycles s == the set of all the cycles of the permutation s *) +(* (s : bool) == s is an odd permutation (the coercion is called odd_perm) *) +(* dpair u == u is a pair (x, y) of distinct objects (i.e., x != y) *) +(* lift_perm i j s == the permutation obtained by lifting s : 'S_n.-1 over *) +(* (i |-> j), that maps i to j and lift i k to lift j (s k). *) +(* Canonical structures are defined allowing permutations to be an eqType, *) +(* choiceType, countType, finType, subType, finGroupType; permutations with *) +(* composition form a group, therefore inherit all generic group notations: *) +(* 1 == identity permutation, * == composition, ^-1 == inverse permutation. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section PermDefSection. + +Variable T : finType. + +Inductive perm_type : predArgType := + Perm (pval : {ffun T -> T}) & injectiveb pval. +Definition pval p := let: Perm f _ := p in f. +Definition perm_of of phant T := perm_type. +Identity Coercion type_of_perm : perm_of >-> perm_type. + +Notation pT := (perm_of (Phant T)). + +Canonical perm_subType := Eval hnf in [subType for pval]. +Definition perm_eqMixin := Eval hnf in [eqMixin of perm_type by <:]. +Canonical perm_eqType := Eval hnf in EqType perm_type perm_eqMixin. +Definition perm_choiceMixin := [choiceMixin of perm_type by <:]. +Canonical perm_choiceType := Eval hnf in ChoiceType perm_type perm_choiceMixin. +Definition perm_countMixin := [countMixin of perm_type by <:]. +Canonical perm_countType := Eval hnf in CountType perm_type perm_countMixin. +Canonical perm_subCountType := Eval hnf in [subCountType of perm_type]. +Definition perm_finMixin := [finMixin of perm_type by <:]. +Canonical perm_finType := Eval hnf in FinType perm_type perm_finMixin. +Canonical perm_subFinType := Eval hnf in [subFinType of perm_type]. + +Canonical perm_for_subType := Eval hnf in [subType of pT]. +Canonical perm_for_eqType := Eval hnf in [eqType of pT]. +Canonical perm_for_choiceType := Eval hnf in [choiceType of pT]. +Canonical perm_for_countType := Eval hnf in [countType of pT]. +Canonical perm_for_subCountType := Eval hnf in [subCountType of pT]. +Canonical perm_for_finType := Eval hnf in [finType of pT]. +Canonical perm_for_subFinType := Eval hnf in [subFinType of pT]. + +Lemma perm_proof (f : T -> T) : injective f -> injectiveb (finfun f). +Proof. +by move=> f_inj; apply/injectiveP; apply: eq_inj f_inj _ => x; rewrite ffunE. +Qed. + +End PermDefSection. + +Notation "{ 'perm' T }" := (perm_of (Phant T)) + (at level 0, format "{ 'perm' T }") : type_scope. + +Arguments Scope pval [_ group_scope]. + +Bind Scope group_scope with perm_type. +Bind Scope group_scope with perm_of. + +Notation "''S_' n" := {perm 'I_n} + (at level 8, n at level 2, format "''S_' n"). + +Notation Local fun_of_perm_def := (fun T (u : perm_type T) => val u : T -> T). +Notation Local perm_def := (fun T f injf => Perm (@perm_proof T f injf)). + +Module Type PermDefSig. +Parameter fun_of_perm : forall T, perm_type T -> T -> T. +Parameter perm : forall (T : finType) (f : T -> T), injective f -> {perm T}. +Axiom fun_of_permE : fun_of_perm = fun_of_perm_def. +Axiom permE : perm = perm_def. +End PermDefSig. + +Module PermDef : PermDefSig. +Definition fun_of_perm := fun_of_perm_def. +Definition perm := perm_def. +Lemma fun_of_permE : fun_of_perm = fun_of_perm_def. Proof. by []. Qed. +Lemma permE : perm = perm_def. Proof. by []. Qed. +End PermDef. + +Notation fun_of_perm := PermDef.fun_of_perm. +Notation "@ 'perm'" := (@PermDef.perm) (at level 10, format "@ 'perm'"). +Notation perm := (@PermDef.perm _ _). +Canonical fun_of_perm_unlock := Unlockable PermDef.fun_of_permE. +Canonical perm_unlock := Unlockable PermDef.permE. +Coercion fun_of_perm : perm_type >-> Funclass. + +Section Theory. + +Variable T : finType. +Implicit Types (x y : T) (s t : {perm T}) (S : {set T}). + +Lemma permP s t : s =1 t <-> s = t. +Proof. by split=> [| -> //]; rewrite unlock => eq_sv; exact/val_inj/ffunP. Qed. + +Lemma pvalE s : pval s = s :> (T -> T). +Proof. by rewrite [@fun_of_perm]unlock. Qed. + +Lemma permE f f_inj : @perm T f f_inj =1 f. +Proof. by move=> x; rewrite -pvalE [@perm]unlock ffunE. Qed. + +Lemma perm_inj s : injective s. +Proof. by rewrite -!pvalE; exact: (injectiveP _ (valP s)). Qed. + +Implicit Arguments perm_inj []. +Hint Resolve perm_inj. + +Lemma perm_onto s : codom s =i predT. +Proof. by apply/subset_cardP; rewrite ?card_codom ?subset_predT. Qed. + +Definition perm_one := perm (@inj_id T). + +Lemma perm_invK s : cancel (fun x => iinv (perm_onto s x)) s. +Proof. by move=> x /=; rewrite f_iinv. Qed. + +Definition perm_inv s := perm (can_inj (perm_invK s)). + +Definition perm_mul s t := perm (inj_comp (perm_inj t) (perm_inj s)). + +Lemma perm_oneP : left_id perm_one perm_mul. +Proof. by move=> s; apply/permP => x; rewrite permE /= permE. Qed. + +Lemma perm_invP : left_inverse perm_one perm_inv perm_mul. +Proof. by move=> s; apply/permP=> x; rewrite !permE /= permE f_iinv. Qed. + +Lemma perm_mulP : associative perm_mul. +Proof. by move=> s t u; apply/permP=> x; do !rewrite permE /=. Qed. + +Definition perm_of_baseFinGroupMixin : FinGroup.mixin_of (perm_type T) := + FinGroup.Mixin perm_mulP perm_oneP perm_invP. +Canonical perm_baseFinGroupType := + Eval hnf in BaseFinGroupType (perm_type T) perm_of_baseFinGroupMixin. +Canonical perm_finGroupType := @FinGroupType perm_baseFinGroupType perm_invP. + +Canonical perm_of_baseFinGroupType := + Eval hnf in [baseFinGroupType of {perm T}]. +Canonical perm_of_finGroupType := Eval hnf in [finGroupType of {perm T} ]. + +Lemma perm1 x : (1 : {perm T}) x = x. +Proof. by rewrite permE. Qed. + +Lemma permM s t x : (s * t) x = t (s x). +Proof. by rewrite permE. Qed. + +Lemma permK s : cancel s s^-1. +Proof. by move=> x; rewrite -permM mulgV perm1. Qed. + +Lemma permKV s : cancel s^-1 s. +Proof. by have:= permK s^-1; rewrite invgK. Qed. + +Lemma permJ s t x : (s ^ t) (t x) = t (s x). +Proof. by rewrite !permM permK. Qed. + +Lemma permX s x n : (s ^+ n) x = iter n s x. +Proof. by elim: n => [|n /= <-]; rewrite ?perm1 // -permM expgSr. Qed. + +Lemma im_permV s S : s^-1 @: S = s @^-1: S. +Proof. exact: can2_imset_pre (permKV s) (permK s). Qed. + +Lemma preim_permV s S : s^-1 @^-1: S = s @: S. +Proof. by rewrite -im_permV invgK. Qed. + +Definition perm_on S : pred {perm T} := fun s => [pred x | s x != x] \subset S. + +Lemma perm_closed S s x : perm_on S s -> (s x \in S) = (x \in S). +Proof. +move/subsetP=> s_on_S; have [-> // | nfix_s_x] := eqVneq (s x) x. +by rewrite !s_on_S // inE /= ?(inj_eq (perm_inj s)). +Qed. + +Lemma perm_on1 H : perm_on H 1. +Proof. by apply/subsetP=> x; rewrite inE /= perm1 eqxx. Qed. + +Lemma perm_onM H s t : perm_on H s -> perm_on H t -> perm_on H (s * t). +Proof. +move/subsetP=> sH /subsetP tH; apply/subsetP => x; rewrite inE /= permM. +by have [-> /tH | /sH] := eqVneq (s x) x. +Qed. + +Lemma out_perm S u x : perm_on S u -> x \notin S -> u x = x. +Proof. by move=> uS; exact: contraNeq (subsetP uS x). Qed. + +Lemma im_perm_on u S : perm_on S u -> u @: S = S. +Proof. +move=> Su; rewrite -preim_permV; apply/setP=> x. +by rewrite !inE -(perm_closed _ Su) permKV. +Qed. + +Lemma tperm_proof x y : involutive [fun z => z with x |-> y, y |-> x]. +Proof. +move=> z /=; case: (z =P x) => [-> | ne_zx]; first by rewrite eqxx; case: eqP. +by case: (z =P y) => [->| ne_zy]; [rewrite eqxx | do 2?case: eqP]. +Qed. + +Definition tperm x y := perm (can_inj (tperm_proof x y)). + +CoInductive tperm_spec x y z : T -> Type := + | TpermFirst of z = x : tperm_spec x y z y + | TpermSecond of z = y : tperm_spec x y z x + | TpermNone of z <> x & z <> y : tperm_spec x y z z. + +Lemma tpermP x y z : tperm_spec x y z (tperm x y z). +Proof. by rewrite permE /=; do 2?[case: eqP => /=]; constructor; auto. Qed. + +Lemma tpermL x y : tperm x y x = y. +Proof. by case: tpermP. Qed. + +Lemma tpermR x y : tperm x y y = x. +Proof. by case: tpermP. Qed. + +Lemma tpermD x y z : x != z -> y != z -> tperm x y z = z. +Proof. by case: tpermP => // ->; rewrite eqxx. Qed. + +Lemma tpermC x y : tperm x y = tperm y x. +Proof. by apply/permP => z; do 2![case: tpermP => //] => ->. Qed. + +Lemma tperm1 x : tperm x x = 1. +Proof. by apply/permP => z; rewrite perm1; case: tpermP. Qed. + +Lemma tpermK x y : involutive (tperm x y). +Proof. by move=> z; rewrite !permE tperm_proof. Qed. + +Lemma tpermKg x y : involutive (mulg (tperm x y)). +Proof. by move=> s; apply/permP=> z; rewrite !permM tpermK. Qed. + +Lemma tpermV x y : (tperm x y)^-1 = tperm x y. +Proof. by set t := tperm x y; rewrite -{2}(mulgK t t) -mulgA tpermKg. Qed. + +Lemma tperm2 x y : tperm x y * tperm x y = 1. +Proof. by rewrite -{1}tpermV mulVg. Qed. + +Lemma card_perm A : #|perm_on A| = (#|A|)`!. +Proof. +pose ffA := {ffun {x | x \in A} -> T}. +rewrite -ffactnn -{2}(card_sig (mem A)) /= -card_inj_ffuns_on. +pose fT (f : ffA) := [ffun x => oapp f x (insub x)]. +pose pfT f := insubd (1 : {perm T}) (fT f). +pose fA s : ffA := [ffun u => s (val u)]. +rewrite -!sum1dep_card -sum1_card (reindex_onto fA pfT) => [|f]. + apply: eq_bigl => p; rewrite andbC; apply/idP/and3P=> [onA | []]; first split. + - apply/eqP; suffices fTAp: fT (fA p) = pval p. + by apply/permP=> x; rewrite -!pvalE insubdK fTAp //; exact: (valP p). + apply/ffunP=> x; rewrite ffunE pvalE. + by case: insubP => [u _ <- | /out_perm->] //=; rewrite ffunE. + - by apply/forallP=> [[x Ax]]; rewrite ffunE /= perm_closed. + - by apply/injectiveP=> u v; rewrite !ffunE => /perm_inj; exact: val_inj. + move/eqP=> <- _ _; apply/subsetP=> x; rewrite !inE -pvalE val_insubd fun_if. + by rewrite if_arg ffunE; case: insubP; rewrite // pvalE perm1 if_same eqxx. +case/andP=> /forallP-onA /injectiveP-f_inj. +apply/ffunP=> u; rewrite ffunE -pvalE insubdK; first by rewrite ffunE valK. +apply/injectiveP=> {u} x y; rewrite !ffunE. +case: insubP => [u _ <-|]; case: insubP => [v _ <-|] //=; first by move/f_inj->. + by move=> Ay' def_y; rewrite -def_y [_ \in A]onA in Ay'. +by move=> Ax' def_x; rewrite def_x [_ \in A]onA in Ax'. +Qed. + +End Theory. + +Prenex Implicits tperm. + +Lemma inj_tperm (T T' : finType) (f : T -> T') x y z : + injective f -> f (tperm x y z) = tperm (f x) (f y) (f z). +Proof. by move=> injf; rewrite !permE /= !(inj_eq injf) !(fun_if f). Qed. + +Lemma tpermJ (T : finType) x y (s : {perm T}) : + (tperm x y) ^ s = tperm (s x) (s y). +Proof. +apply/permP => z; rewrite -(permKV s z) permJ; apply: inj_tperm. +exact: perm_inj. +Qed. + +Lemma tuple_perm_eqP {T : eqType} {n} {s : seq T} {t : n.-tuple T} : + reflect (exists p : 'S_n, s = [tuple tnth t (p i) | i < n]) (perm_eq s t). +Proof. +apply: (iffP idP) => [|[p ->]]; last first. + rewrite /= (map_comp (tnth t)) -{1}(map_tnth_enum t) perm_map //. + apply: uniq_perm_eq => [||i]; rewrite ?enum_uniq //. + by apply/injectiveP; apply: perm_inj. + by rewrite mem_enum -[i](permKV p) image_f. +case: n => [|n] in t *; last have x0 := tnth t ord0. + rewrite tuple0 => /perm_eq_small-> //. + by exists 1; rewrite [mktuple _]tuple0. +case/(perm_eq_iotaP x0); rewrite size_tuple => Is eqIst ->{s}. +have uniqIs: uniq Is by rewrite (perm_eq_uniq eqIst) iota_uniq. +have szIs: size Is == n.+1 by rewrite (perm_eq_size eqIst) !size_tuple. +have pP i : tnth (Tuple szIs) i < n.+1. + by rewrite -[_ < _](mem_iota 0) -(perm_eq_mem eqIst) mem_tnth. +have inj_p: injective (fun i => Ordinal (pP i)). + by apply/injectiveP/(@map_uniq _ _ val); rewrite -map_comp map_tnth_enum. +exists (perm inj_p); rewrite -[Is]/(tval (Tuple szIs)); congr (tval _). +by apply: eq_from_tnth => i; rewrite tnth_map tnth_mktuple permE (tnth_nth x0). +Qed. + +Section PermutationParity. + +Variable T : finType. + +Implicit Types (s t u v : {perm T}) (x y z a b : T). + +(* Note that pcycle s x is the orbit of x by <[s]> under the action aperm. *) +(* Hence, the pcycle lemmas below are special cases of more general lemmas *) +(* on orbits that will be stated in action.v. *) +(* Defining pcycle directly here avoids a dependency of matrix.v on *) +(* action.v and hence morphism.v. *) + +Definition aperm x s := s x. +Definition pcycle s x := aperm x @: <[s]>. +Definition pcycles s := pcycle s @: T. +Definition odd_perm (s : perm_type T) := odd #|T| (+) odd #|pcycles s|. + +Lemma apermE x s : aperm x s = s x. Proof. by []. Qed. + +Lemma mem_pcycle s i x : (s ^+ i) x \in pcycle s x. +Proof. by rewrite (mem_imset (aperm x)) ?mem_cycle. Qed. + +Lemma pcycle_id s x : x \in pcycle s x. +Proof. by rewrite -{1}[x]perm1 (mem_pcycle s 0). Qed. + +Lemma uniq_traject_pcycle s x : uniq (traject s x #|pcycle s x|). +Proof. +case def_n: #|_| => // [n]; rewrite looping_uniq. +apply: contraL (card_size (traject s x n)) => /loopingP t_sx. +rewrite -ltnNge size_traject -def_n ?subset_leq_card //. +by apply/subsetP=> _ /imsetP[_ /cycleP[i ->] ->]; rewrite /aperm permX t_sx. +Qed. + +Lemma pcycle_traject s x : pcycle s x =i traject s x #|pcycle s x|. +Proof. +apply: fsym; apply/subset_cardP. + by rewrite (card_uniqP _) ?size_traject ?uniq_traject_pcycle. +by apply/subsetP=> _ /trajectP[i _ ->]; rewrite -permX mem_pcycle. +Qed. + +Lemma iter_pcycle s x : iter #|pcycle s x| s x = x. +Proof. +case def_n: #|_| (uniq_traject_pcycle s x) => [//|n] Ut. +have: looping s x n.+1. + by rewrite -def_n -[looping _ _ _]pcycle_traject -permX mem_pcycle. +rewrite /looping => /trajectP[[|i] //= lt_i_n /perm_inj eq_i_n_sx]. +move: lt_i_n; rewrite ltnS ltn_neqAle andbC => /andP[le_i_n /negP[]]. +by rewrite -(nth_uniq x _ _ Ut) ?size_traject ?nth_traject // eq_i_n_sx. +Qed. + +Lemma eq_pcycle_mem s x y : (pcycle s x == pcycle s y) = (x \in pcycle s y). +Proof. +apply/eqP/idP=> [<- | /imsetP[si s_si ->]]; first exact: pcycle_id. +apply/setP => z; apply/imsetP/imsetP=> [] [sj s_sj ->]. + by exists (si * sj); rewrite ?groupM /aperm ?permM. +exists (si^-1 * sj); first by rewrite groupM ?groupV. +by rewrite /aperm permM permK. +Qed. + +Lemma pcycle_sym s x y : (x \in pcycle s y) = (y \in pcycle s x). +Proof. by rewrite -!eq_pcycle_mem eq_sym. Qed. + +Lemma pcycle_perm s i x : pcycle s ((s ^+ i) x) = pcycle s x. +Proof. by apply/eqP; rewrite eq_pcycle_mem mem_pcycle. Qed. + +Lemma ncycles_mul_tperm s x y : let t := tperm x y in + #|pcycles (t * s)| + (x \notin pcycle s y).*2 = #|pcycles s| + (x != y). +Proof. +pose xf a b u := find (pred2 a b) (traject u (u a) #|pcycle u a|). +have xf_size a b u: xf a b u <= #|pcycle u a|. + by rewrite (leq_trans (find_size _ _)) ?size_traject. +have lt_xf a b u n : n < xf a b u -> ~~ pred2 a b ((u ^+ n.+1) a). + move=> lt_n; apply: contraFN (before_find (u a) lt_n). + by rewrite permX iterSr nth_traject // (leq_trans lt_n). +pose t a b u := tperm a b * u. +have tC a b u : t a b u = t b a u by rewrite /t tpermC. +have tK a b: involutive (t a b) by move=> u; exact: tpermKg. +have tXC a b u n: n <= xf a b u -> (t a b u ^+ n.+1) b = (u ^+ n.+1) a. + elim: n => [|n IHn] lt_n_f; first by rewrite permM tpermR. + rewrite !(expgSr _ n.+1) !permM {}IHn 1?ltnW //; congr (u _). + by case/lt_xf/norP: lt_n_f => ne_a ne_b; rewrite tpermD // eq_sym. +have eq_xf a b u: pred2 a b ((u ^+ (xf a b u).+1) a). + have ua_a: a \in pcycle u (u a) by rewrite pcycle_sym (mem_pcycle _ 1). + have has_f: has (pred2 a b) (traject u (u a) #|pcycle u (u a)|). + by apply/hasP; exists a; rewrite /= ?eqxx -?pcycle_traject. + have:= nth_find (u a) has_f; rewrite has_find size_traject in has_f. + rewrite -eq_pcycle_mem in ua_a. + by rewrite nth_traject // -iterSr -permX -(eqP ua_a). +have xfC a b u: xf b a (t a b u) = xf a b u. + without loss lt_a: a b u / xf b a (t a b u) < xf a b u. + move=> IHab; set m := xf b a _; set n := xf a b u. + by case: (ltngtP m n) => // ltx; [exact: IHab | rewrite -[m]IHab tC tK]. + by move/lt_xf: (lt_a); rewrite -(tXC a b) 1?ltnW //= orbC [_ || _]eq_xf. +pose ts := t x y s; rewrite /= -[_ * s]/ts. +pose dp u := #|pcycles u :\ pcycle u y :\ pcycle u x|. +rewrite !(addnC #|_|) (cardsD1 (pcycle ts y)) mem_imset ?inE //. +rewrite (cardsD1 (pcycle ts x)) inE mem_imset ?inE //= -/(dp ts) {}/ts. +rewrite (cardsD1 (pcycle s y)) (cardsD1 (pcycle s x)) !(mem_imset, inE) //. +rewrite -/(dp s) !addnA !eq_pcycle_mem andbT; congr (_ + _); last first. + wlog suffices: s / dp s <= dp (t x y s). + by move=> IHs; apply/eqP; rewrite eqn_leq -{2}(tK x y s) !IHs. + apply/subset_leq_card/subsetP=> {dp} C. + rewrite !inE andbA andbC !(eq_sym C) => /and3P[/imsetP[z _ ->{C}]]. + rewrite 2!eq_pcycle_mem => sxz syz. + suffices ts_z: pcycle (t x y s) z = pcycle s z. + by rewrite -ts_z !eq_pcycle_mem {1 2}ts_z sxz syz mem_imset ?inE. + suffices exp_id n: ((t x y s) ^+ n) z = (s ^+ n) z. + apply/setP=> u; apply/idP/idP=> /imsetP[_ /cycleP[i ->] ->]. + by rewrite /aperm exp_id mem_pcycle. + by rewrite /aperm -exp_id mem_pcycle. + elim: n => // n IHn; rewrite !expgSr !permM {}IHn tpermD //. + apply: contraNneq sxz => ->; exact: mem_pcycle. + apply: contraNneq syz => ->; exact: mem_pcycle. +case: eqP {dp} => [<- | ne_xy]; first by rewrite /t tperm1 mul1g pcycle_id. +suff ->: (x \in pcycle (t x y s) y) = (x \notin pcycle s y) by case: (x \in _). +without loss xf_x: s x y ne_xy / (s ^+ (xf x y s).+1) x = x. + move=> IHs; have ne_yx := nesym ne_xy; have:= eq_xf x y s; set n := xf x y s. + case/pred2P=> [|snx]; first exact: IHs. + by rewrite -[x \in _]negbK ![x \in _]pcycle_sym -{}IHs ?xfC ?tXC // tC tK. +rewrite -{1}xf_x -(tXC _ _ _ _ (leqnn _)) mem_pcycle; symmetry. +rewrite -eq_pcycle_mem eq_sym eq_pcycle_mem pcycle_traject. +apply/trajectP=> [[n _ snx]]. +have: looping s x (xf x y s).+1 by rewrite /looping -permX xf_x inE eqxx. +move/loopingP/(_ n); rewrite -{n}snx. +case/trajectP=> [[_|i]]; first exact: nesym; rewrite ltnS -permX => lt_i def_y. +by move/lt_xf: lt_i; rewrite def_y /= eqxx orbT. +Qed. + +Lemma odd_perm1 : odd_perm 1 = false. +Proof. +rewrite /odd_perm card_imset ?addbb // => x y; move/eqP. +by rewrite eq_pcycle_mem /pcycle cycle1 imset_set1 /aperm perm1; move/set1P. +Qed. + +Lemma odd_mul_tperm x y s : odd_perm (tperm x y * s) = (x != y) (+) odd_perm s. +Proof. +rewrite addbC -addbA -[~~ _]oddb -odd_add -ncycles_mul_tperm. +by rewrite odd_add odd_double addbF. +Qed. + +Lemma odd_tperm x y : odd_perm (tperm x y) = (x != y). +Proof. by rewrite -[_ y]mulg1 odd_mul_tperm odd_perm1 addbF. Qed. + +Definition dpair (eT : eqType) := [pred t | t.1 != t.2 :> eT]. +Implicit Arguments dpair [eT]. + +Lemma prod_tpermP s : + {ts : seq (T * T) | s = \prod_(t <- ts) tperm t.1 t.2 & all dpair ts}. +Proof. +elim: {s}_.+1 {-2}s (ltnSn #|[pred x | s x != x]|) => // n IHn s. +rewrite ltnS => le_s_n; case: (pickP (fun x => s x != x)) => [x s_x | s_id]. + have [|ts def_s ne_ts] := IHn (tperm x (s^-1 x) * s). + rewrite (cardD1 x) !inE s_x in le_s_n; apply: leq_ltn_trans le_s_n. + apply: subset_leq_card; apply/subsetP=> y. + rewrite !inE permM permE /= -(canF_eq (permK _)). + have [-> | ne_yx] := altP (y =P x); first by rewrite permKV eqxx. + by case: (s y =P x) => // -> _; rewrite eq_sym. + exists ((x, s^-1 x) :: ts); last by rewrite /= -(canF_eq (permK _)) s_x. + by rewrite big_cons -def_s mulgA tperm2 mul1g. +exists nil; rewrite // big_nil; apply/permP=> x. +by apply/eqP/idPn; rewrite perm1 s_id. +Qed. + +Lemma odd_perm_prod ts : + all dpair ts -> odd_perm (\prod_(t <- ts) tperm t.1 t.2) = odd (size ts). +Proof. +elim: ts => [_|t ts IHts] /=; first by rewrite big_nil odd_perm1. +by case/andP=> dt12 dts; rewrite big_cons odd_mul_tperm dt12 IHts. +Qed. + +Lemma odd_permM : {morph odd_perm : s1 s2 / s1 * s2 >-> s1 (+) s2}. +Proof. +move=> s1 s2; case: (prod_tpermP s1) => ts1 ->{s1} dts1. +case: (prod_tpermP s2) => ts2 ->{s2} dts2. +by rewrite -big_cat !odd_perm_prod ?all_cat ?dts1 // size_cat odd_add. +Qed. + +Lemma odd_permV s : odd_perm s^-1 = odd_perm s. +Proof. by rewrite -{2}(mulgK s s) !odd_permM -addbA addKb. Qed. + +Lemma odd_permJ s1 s2 : odd_perm (s1 ^ s2) = odd_perm s1. +Proof. by rewrite !odd_permM odd_permV addbC addbK. Qed. + +End PermutationParity. + +Coercion odd_perm : perm_type >-> bool. +Implicit Arguments dpair [eT]. +Prenex Implicits pcycle dpair pcycles aperm. + +Section LiftPerm. +(* Somewhat more specialised constructs for permutations on ordinals. *) + +Variable n : nat. +Implicit Types i j : 'I_n.+1. +Implicit Types s t : 'S_n. + +Definition lift_perm_fun i j s k := + if unlift i k is Some k' then lift j (s k') else j. + +Lemma lift_permK i j s : + cancel (lift_perm_fun i j s) (lift_perm_fun j i s^-1). +Proof. +rewrite /lift_perm_fun => k. +by case: (unliftP i k) => [j'|] ->; rewrite (liftK, unlift_none) ?permK. +Qed. + +Definition lift_perm i j s := perm (can_inj (lift_permK i j s)). + +Lemma lift_perm_id i j s : lift_perm i j s i = j. +Proof. by rewrite permE /lift_perm_fun unlift_none. Qed. + +Lemma lift_perm_lift i j s k' : + lift_perm i j s (lift i k') = lift j (s k') :> 'I_n.+1. +Proof. by rewrite permE /lift_perm_fun liftK. Qed. + +Lemma lift_permM i j k s t : + lift_perm i j s * lift_perm j k t = lift_perm i k (s * t). +Proof. +apply/permP=> i1; case: (unliftP i i1) => [i2|] ->{i1}. + by rewrite !(permM, lift_perm_lift). +by rewrite permM !lift_perm_id. +Qed. + +Lemma lift_perm1 i : lift_perm i i 1 = 1. +Proof. by apply: (mulgI (lift_perm i i 1)); rewrite lift_permM !mulg1. Qed. + +Lemma lift_permV i j s : (lift_perm i j s)^-1 = lift_perm j i s^-1. +Proof. by apply/eqP; rewrite eq_invg_mul lift_permM mulgV lift_perm1. Qed. + +Lemma odd_lift_perm i j s : lift_perm i j s = odd i (+) odd j (+) s :> bool. +Proof. +rewrite -{1}(mul1g s) -(lift_permM _ j) odd_permM. +congr (_ (+) _); last first. + case: (prod_tpermP s) => ts ->{s} _. + elim: ts => [|t ts IHts] /=; first by rewrite big_nil lift_perm1 !odd_perm1. + rewrite big_cons odd_mul_tperm -(lift_permM _ j) odd_permM {}IHts //. + congr (_ (+) _); transitivity (tperm (lift j t.1) (lift j t.2)); last first. + by rewrite odd_tperm (inj_eq (@lift_inj _ _)). + congr odd_perm; apply/permP=> k; case: (unliftP j k) => [k'|] ->. + rewrite lift_perm_lift inj_tperm //; exact: lift_inj. + by rewrite lift_perm_id tpermD // eq_sym neq_lift. +suff{i j s} odd_lift0 (k : 'I_n.+1): lift_perm ord0 k 1 = odd k :> bool. + rewrite -!odd_lift0 -{2}invg1 -lift_permV odd_permV -odd_permM. + by rewrite lift_permM mulg1. +elim: {k}(k : nat) {1 3}k (erefl (k : nat)) => [|m IHm] k def_k. + rewrite (_ : k = ord0) ?lift_perm1 ?odd_perm1 //; exact: val_inj. +have le_mn: m < n.+1 by [rewrite -def_k ltnW]; pose j := Ordinal le_mn. +rewrite -(mulg1 1)%g -(lift_permM _ j) odd_permM {}IHm // addbC. +rewrite (_ : _ 1 = tperm j k); first by rewrite odd_tperm neq_ltn def_k leqnn. +apply/permP=> i; case: (unliftP j i) => [i'|] ->; last first. + by rewrite lift_perm_id tpermL. +apply: ord_inj; rewrite lift_perm_lift !permE /= eq_sym -if_neg neq_lift. +rewrite fun_if -val_eqE /= def_k /bump ltn_neqAle andbC. +case: leqP => [_ | lt_i'm] /=; last by rewrite -if_neg neq_ltn leqW. +by rewrite add1n eqSS eq_sym; case: eqP. +Qed. + +End LiftPerm. + + + diff --git a/mathcomp/fingroup/presentation.v b/mathcomp/fingroup/presentation.v new file mode 100644 index 0000000..46658d5 --- /dev/null +++ b/mathcomp/fingroup/presentation.v @@ -0,0 +1,254 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +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. + diff --git a/mathcomp/fingroup/quotient.v b/mathcomp/fingroup/quotient.v new file mode 100644 index 0000000..6688509 --- /dev/null +++ b/mathcomp/fingroup/quotient.v @@ -0,0 +1,972 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div choice. +Require Import fintype prime finset fingroup morphism automorphism. + +(******************************************************************************) +(* This file contains the definitions of: *) +(* coset_of H == the (sub)type of bilateral cosets of H (see below) *) +(* coset H == the canonical projection into coset_of H *) +(* A / H == the quotient of A by H, that is, the morphic image *) +(* of A by coset H. We do not require H <| A, so in a *) +(* textbook A / H would be written 'N_A(H) * H / H. *) +(* quotm f (nHG : H <| G) == the quotient morphism induced by f, *) +(* mapping G / H onto f @* G / f @* H *) +(* qisom f (eqHG : H = G) == the identity isomorphism between *) +(* [set: coset_of G] and [set: coset_of H]. *) +(* We also prove the three isomorphism theorems, and counting lemmas for *) +(* morphisms. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section Cosets. + +Variables (gT : finGroupType) (Q A : {set gT}). + +(******************************************************************************) +(* Cosets are right cosets of elements in the normaliser *) +(* We let cosets coerce to GroupSet.sort, so they inherit the group subset *) +(* base group structure. Later we will define a proper group structure on *) +(* cosets, which will then hide the inherited structure once coset_of unifies *) +(* with FinGroup.sort; the coercion to GroupSet.sort will no longer be used. *) +(* Note that for Hx Hy : coset_of H, Hx * Hy : {set gT} can mean either *) +(* set_of_coset (mulg Hx Hy) OR mulg (set_of_coset Hx) (set_of_coset Hy) *) +(* However, since the two terms are actually convertible, we can live with *) +(* this ambiguity. *) +(* We take great care that neither the type coset_of H, nor its Canonical *) +(* finGroupType structure, nor the coset H morphism depend on the actual *) +(* group structure of H. Otherwise, rewriting would be extremely awkward *) +(* because all our equalities are stated at the set level. *) +(* The trick we use is to interpret coset_of A, when A is any set, as the *) +(* type of cosets of the group generated by A, in the group A <*> N(A) *) +(* generated by A and its normaliser. This coincides with the type of *) +(* bilateral cosets of A when A is a group. We restrict the domain of coset A *) +(* to 'N(A), so that we get almost all the same conversion equalities as if *) +(* we had forced A to be a group in the first place; the only exception, that *) +(* 1 : coset_of A : set _ = <> rather than A, is covered by genGid. *) +(******************************************************************************) + +Notation H := <>. +Definition coset_range := [pred B in rcosets H 'N(A)]. + +Record coset_of : Type := + Coset { set_of_coset :> GroupSet.sort gT; _ : coset_range set_of_coset }. + +Canonical coset_subType := Eval hnf in [subType for set_of_coset]. +Definition coset_eqMixin := Eval hnf in [eqMixin of coset_of by <:]. +Canonical coset_eqType := Eval hnf in EqType coset_of coset_eqMixin. +Definition coset_choiceMixin := [choiceMixin of coset_of by <:]. +Canonical coset_choiceType := Eval hnf in ChoiceType coset_of coset_choiceMixin. +Definition coset_countMixin := [countMixin of coset_of by <:]. +Canonical coset_countType := Eval hnf in CountType coset_of coset_countMixin. +Canonical coset_subCountType := Eval hnf in [subCountType of coset_of]. +Definition coset_finMixin := [finMixin of coset_of by <:]. +Canonical coset_finType := Eval hnf in FinType coset_of coset_finMixin. +Canonical coset_subFinType := Eval hnf in [subFinType of coset_of]. + +(* We build a new (canonical) structure of groupType for cosets. *) +(* When A is a group, this is the largest possible quotient 'N(A) / A. *) + +Lemma coset_one_proof : coset_range H. +Proof. by apply/rcosetsP; exists (1 : gT); rewrite (group1, mulg1). Qed. +Definition coset_one := Coset coset_one_proof. + +Let nNH := subsetP (norm_gen A). + +Lemma coset_range_mul (B C : coset_of) : coset_range (B * C). +Proof. +case: B C => _ /= /rcosetsP[x Nx ->] [_ /= /rcosetsP[y Ny ->]]. +by apply/rcosetsP; exists (x * y); rewrite !(groupM, rcoset_mul, nNH). +Qed. + +Definition coset_mul B C := Coset (coset_range_mul B C). + +Lemma coset_range_inv (B : coset_of) : coset_range B^-1. +Proof. +case: B => _ /= /rcosetsP[x Nx ->]; rewrite norm_rlcoset ?nNH // invg_lcoset. +by apply/rcosetsP; exists x^-1; rewrite ?groupV. +Qed. + +Definition coset_inv B := Coset (coset_range_inv B). + +Lemma coset_mulP : associative coset_mul. +Proof. by move=> B C D; apply: val_inj; rewrite /= mulgA. Qed. + +Lemma coset_oneP : left_id coset_one coset_mul. +Proof. +case=> B coB; apply: val_inj => /=; case/rcosetsP: coB => x Hx ->{B}. +by rewrite mulgA mulGid. +Qed. + +Lemma coset_invP : left_inverse coset_one coset_inv coset_mul. +Proof. +case=> B coB; apply: val_inj => /=; case/rcosetsP: coB => x Hx ->{B}. +rewrite invg_rcoset -mulgA (mulgA H) mulGid. +by rewrite norm_rlcoset ?nNH // -lcosetM mulVg mul1g. +Qed. + +Definition coset_of_groupMixin := + FinGroup.Mixin coset_mulP coset_oneP coset_invP. + +Canonical coset_baseGroupType := + Eval hnf in BaseFinGroupType coset_of coset_of_groupMixin. +Canonical coset_groupType := FinGroupType coset_invP. + +(* Projection of the initial group type over the cosets groupType *) + +Definition coset x : coset_of := insubd (1 : coset_of) (H :* x). + +(* This is a primitive lemma -- we'll need to restate it for *) +(* the case where A is a group. *) +Lemma val_coset_prim x : x \in 'N(A) -> coset x :=: H :* x. +Proof. +by move=> Nx; rewrite val_insubd /= mem_rcosets -{1}(mul1g x) mem_mulg. +Qed. + +Lemma coset_morphM : {in 'N(A) &, {morph coset : x y / x * y}}. +Proof. +move=> x y Nx Ny; apply: val_inj. +by rewrite /= !val_coset_prim ?groupM //= rcoset_mul ?nNH. +Qed. + +Canonical coset_morphism := Morphism coset_morphM. + +Lemma ker_coset_prim : 'ker coset = 'N_H(A). +Proof. +apply/setP=> z; rewrite !in_setI andbC 2!inE -val_eqE /=. +case Nz: (z \in 'N(A)); rewrite ?andbF ?val_coset_prim // !andbT. +by apply/eqP/idP=> [<-| Az]; rewrite (rcoset_refl, rcoset_id). +Qed. + +Implicit Type xbar : coset_of. + +Lemma coset_mem y xbar : y \in xbar -> coset y = xbar. +Proof. +case: xbar => /= Hx NHx Hxy; apply: val_inj=> /=. +case/rcosetsP: NHx (NHx) Hxy => x Nx -> NHx Hxy. +by rewrite val_insubd /= (rcoset_transl Hxy) NHx. +Qed. + +(* coset is an inverse to repr *) + +Lemma mem_repr_coset xbar : repr xbar \in xbar. +Proof. case: xbar => /= _ /rcosetsP[x _ ->]; exact: mem_repr_rcoset. Qed. + +Lemma repr_coset1 : repr (1 : coset_of) = 1. +Proof. exact: repr_group. Qed. + +Lemma coset_reprK : cancel (fun xbar => repr xbar) coset. +Proof. by move=> xbar; exact: coset_mem (mem_repr_coset xbar). Qed. + +(* cosetP is slightly stronger than using repr because we only *) +(* guarantee repr xbar \in 'N(A) when A is a group. *) +Lemma cosetP xbar : {x | x \in 'N(A) & xbar = coset x}. +Proof. +pose x := repr 'N_xbar(A). +have [xbar_x Nx]: x \in xbar /\ x \in 'N(A). + apply/setIP; rewrite {}/x; case: xbar => /= _ /rcosetsP[y Ny ->]. + by apply: (mem_repr y); rewrite inE rcoset_refl. +by exists x; last rewrite (coset_mem xbar_x). +Qed. + +Lemma coset_id x : x \in A -> coset x = 1. +Proof. by move=> Ax; apply: coset_mem; exact: mem_gen. Qed. + +Lemma im_coset : coset @* 'N(A) = setT. +Proof. +by apply/setP=> xbar; case: (cosetP xbar) => x Nx ->; rewrite inE mem_morphim. +Qed. + +Lemma sub_im_coset (C : {set coset_of}) : C \subset coset @* 'N(A). +Proof. by rewrite im_coset subsetT. Qed. + +Lemma cosetpre_proper C D : + (coset @*^-1 C \proper coset @*^-1 D) = (C \proper D). +Proof. by rewrite morphpre_proper ?sub_im_coset. Qed. + +Definition quotient : {set coset_of} := coset @* Q. + +Lemma quotientE : quotient = coset @* Q. Proof. by []. Qed. + +End Cosets. + +Arguments Scope coset_of [_ group_scope]. +Arguments Scope coset [_ group_scope group_scope]. +Arguments Scope quotient [_ group_scope group_scope]. +Prenex Implicits coset_of coset. + +Bind Scope group_scope with coset_of. + +Notation "A / B" := (quotient A B) : group_scope. + +Section CosetOfGroupTheory. + +Variables (gT : finGroupType) (H : {group gT}). +Implicit Types (A B : {set gT}) (G K : {group gT}) (xbar yb : coset_of H). +Implicit Types (C D : {set coset_of H}) (L M : {group coset_of H}). + +Canonical quotient_group G A : {group coset_of A} := + Eval hnf in [group of G / A]. + +Infix "/" := quotient_group : Group_scope. + +Lemma val_coset x : x \in 'N(H) -> coset H x :=: H :* x. +Proof. by move=> Nx; rewrite val_coset_prim // genGid. Qed. + +Lemma coset_default x : (x \in 'N(H)) = false -> coset H x = 1. +Proof. +move=> Nx; apply: val_inj. +by rewrite val_insubd /= mem_rcosets /= genGid mulSGid ?normG ?Nx. +Qed. + +Lemma coset_norm xbar : xbar \subset 'N(H). +Proof. +case: xbar => /= _ /rcosetsP[x Nx ->]. +by rewrite genGid mul_subG ?sub1set ?normG. +Qed. + +Lemma ker_coset : 'ker (coset H) = H. +Proof. by rewrite ker_coset_prim genGid (setIidPl _) ?normG. Qed. + +Lemma coset_idr x : x \in 'N(H) -> coset H x = 1 -> x \in H. +Proof. by move=> Nx Hx1; rewrite -ker_coset mem_morphpre //= Hx1 set11. Qed. + +Lemma repr_coset_norm xbar : repr xbar \in 'N(H). +Proof. exact: subsetP (coset_norm _) _ (mem_repr_coset _). Qed. + +Lemma imset_coset G : coset H @: G = G / H. +Proof. +apply/eqP; rewrite eqEsubset andbC imsetS ?subsetIr //=. +apply/subsetP=> _ /imsetP[x Gx ->]. +by case Nx: (x \in 'N(H)); rewrite ?(coset_default Nx) ?mem_morphim ?group1. +Qed. + +Lemma val_quotient A : val @: (A / H) = rcosets H 'N_A(H). +Proof. +apply/setP=> B; apply/imsetP/rcosetsP=> [[xbar Axbar]|[x /setIP[Ax Nx]]] ->{B}. + case/morphimP: Axbar => x Nx Ax ->{xbar}. + by exists x; [rewrite inE Ax | rewrite /= val_coset]. +by exists (coset H x); [apply/morphimP; exists x | rewrite /= val_coset]. +Qed. + +Lemma card_quotient_subnorm A : #|A / H| = #|'N_A(H) : H|. +Proof. by rewrite -(card_imset _ val_inj) val_quotient. Qed. + +Lemma leq_quotient A : #|A / H| <= #|A|. +Proof. exact: leq_morphim. Qed. + +Lemma ltn_quotient A : H :!=: 1 -> H \subset A -> #|A / H| < #|A|. +Proof. +by move=> ntH sHA; rewrite ltn_morphim // ker_coset (setIidPr sHA) proper1G. +Qed. + +Lemma card_quotient A : A \subset 'N(H) -> #|A / H| = #|A : H|. +Proof. by move=> nHA; rewrite card_quotient_subnorm (setIidPl nHA). Qed. + +Lemma divg_normal G : H <| G -> #|G| %/ #|H| = #|G / H|. +Proof. by case/andP=> sHG nHG; rewrite divgS ?card_quotient. Qed. + +(* Specializing all the morphisms lemmas that have different assumptions *) +(* (e.g., because 'ker (coset H) = H), or conclusions (e.g., because we use *) +(* A / H rather than coset H @* A). We may want to reevaluate later, and *) +(* eliminate variants that aren't used . *) + +(* Variant of morph1; no specialization for other morph lemmas. *) +Lemma coset1 : coset H 1 :=: H. +Proof. by rewrite morph1 /= genGid. Qed. + +(* Variant of kerE. *) +Lemma cosetpre1 : coset H @*^-1 1 = H. +Proof. by rewrite -kerE ker_coset. Qed. + +(* Variant of morphimEdom; mophimE[sub] covered by imset_coset. *) +(* morph[im|pre]Iim are also covered by im_quotient. *) +Lemma im_quotient : 'N(H) / H = setT. +Proof. exact: im_coset. Qed. + +Lemma quotientT : setT / H = setT. +Proof. by rewrite -im_quotient; exact: morphimT. Qed. + +(* Variant of morphimIdom. *) +Lemma quotientInorm A : 'N_A(H) / H = A / H. +Proof. by rewrite /quotient setIC morphimIdom. Qed. + +Lemma quotient_setIpre A D : (A :&: coset H @*^-1 D) / H = A / H :&: D. +Proof. exact: morphim_setIpre. Qed. + +Lemma mem_quotient x G : x \in G -> coset H x \in G / H. +Proof. by move=> Gx; rewrite -imset_coset mem_imset. Qed. + +Lemma quotientS A B : A \subset B -> A / H \subset B / H. +Proof. exact: morphimS. Qed. + +Lemma quotient0 : set0 / H = set0. +Proof. exact: morphim0. Qed. + +Lemma quotient_set1 x : x \in 'N(H) -> [set x] / H = [set coset H x]. +Proof. exact: morphim_set1. Qed. + +Lemma quotient1 : 1 / H = 1. +Proof. exact: morphim1. Qed. + +Lemma quotientV A : A^-1 / H = (A / H)^-1. +Proof. exact: morphimV. Qed. + +Lemma quotientMl A B : A \subset 'N(H) -> A * B / H = (A / H) * (B / H). +Proof. exact: morphimMl. Qed. + +Lemma quotientMr A B : B \subset 'N(H) -> A * B / H = (A / H) * (B / H). +Proof. exact: morphimMr. Qed. + +Lemma cosetpreM C D : coset H @*^-1 (C * D) = coset H @*^-1 C * coset H @*^-1 D. +Proof. by rewrite morphpreMl ?sub_im_coset. Qed. + +Lemma quotientJ A x : x \in 'N(H) -> A :^ x / H = (A / H) :^ coset H x. +Proof. exact: morphimJ. Qed. + +Lemma quotientU A B : (A :|: B) / H = A / H :|: B / H. +Proof. exact: morphimU. Qed. + +Lemma quotientI A B : (A :&: B) / H \subset A / H :&: B / H. +Proof. exact: morphimI. Qed. + +Lemma quotientY A B : + A \subset 'N(H) -> B \subset 'N(H) -> (A <*> B) / H = (A / H) <*> (B / H). +Proof. exact: morphimY. Qed. + +Lemma quotient_homg A : A \subset 'N(H) -> homg (A / H) A. +Proof. exact: morphim_homg. Qed. + +Lemma coset_kerl x y : x \in H -> coset H (x * y) = coset H y. +Proof. +move=> Hx; case Ny: (y \in 'N(H)); first by rewrite mkerl ?ker_coset. +by rewrite !coset_default ?groupMl // (subsetP (normG H)). +Qed. + +Lemma coset_kerr x y : y \in H -> coset H (x * y) = coset H x. +Proof. +move=> Hy; case Nx: (x \in 'N(H)); first by rewrite mkerr ?ker_coset. +by rewrite !coset_default ?groupMr // (subsetP (normG H)). +Qed. + +Lemma rcoset_kercosetP x y : + x \in 'N(H) -> y \in 'N(H) -> reflect (coset H x = coset H y) (x \in H :* y). +Proof. rewrite -{6}ker_coset; exact: rcoset_kerP. Qed. + +Lemma kercoset_rcoset x y : + x \in 'N(H) -> y \in 'N(H) -> + coset H x = coset H y -> exists2 z, z \in H & x = z * y. +Proof. by move=> Nx Ny eqfxy; rewrite -ker_coset; exact: ker_rcoset. Qed. + +Lemma quotientGI G A : H \subset G -> (G :&: A) / H = G / H :&: A / H. +Proof. by rewrite -{1}ker_coset; exact: morphimGI. Qed. + +Lemma quotientIG A G : H \subset G -> (A :&: G) / H = A / H :&: G / H. +Proof. by rewrite -{1}ker_coset; exact: morphimIG. Qed. + +Lemma quotientD A B : A / H :\: B / H \subset (A :\: B) / H. +Proof. exact: morphimD. Qed. + +Lemma quotientD1 A : (A / H)^# \subset A^# / H. +Proof. exact: morphimD1. Qed. + +Lemma quotientDG A G : H \subset G -> (A :\: G) / H = A / H :\: G / H. +Proof. by rewrite -{1}ker_coset; exact: morphimDG. Qed. + +Lemma quotientK A : A \subset 'N(H) -> coset H @*^-1 (A / H) = H * A. +Proof. by rewrite -{8}ker_coset; exact: morphimK. Qed. + +Lemma quotientYK G : G \subset 'N(H) -> coset H @*^-1 (G / H) = H <*> G. +Proof. by move=> nHG; rewrite quotientK ?norm_joinEr. Qed. + +Lemma quotientGK G : H <| G -> coset H @*^-1 (G / H) = G. +Proof. by case/andP; rewrite -{1}ker_coset; exact: morphimGK. Qed. + +Lemma quotient_class x A : + x \in 'N(H) -> A \subset 'N(H) -> x ^: A / H = coset H x ^: (A / H). +Proof. exact: morphim_class. Qed. + +Lemma classes_quotient A : + A \subset 'N(H) -> classes (A / H) = [set xA / H | xA in classes A]. +Proof. exact: classes_morphim. Qed. + +Lemma cosetpre_set1 x : + x \in 'N(H) -> coset H @*^-1 [set coset H x] = H :* x. +Proof. by rewrite -{9}ker_coset; exact: morphpre_set1. Qed. + +Lemma cosetpre_set1_coset xbar : coset H @*^-1 [set xbar] = xbar. +Proof. by case: (cosetP xbar) => x Nx ->; rewrite cosetpre_set1 ?val_coset. Qed. + +Lemma cosetpreK C : coset H @*^-1 C / H = C. +Proof. by rewrite /quotient morphpreK ?sub_im_coset. Qed. + +(* Variant of morhphim_ker *) +Lemma trivg_quotient : H / H = 1. +Proof. by rewrite -{3}ker_coset /quotient morphim_ker. Qed. + +Lemma quotientS1 G : G \subset H -> G / H = 1. +Proof. by move=> sGH; apply/trivgP; rewrite -trivg_quotient quotientS. Qed. + +Lemma sub_cosetpre M : H \subset coset H @*^-1 M. +Proof. by rewrite -{1}ker_coset; exact: ker_sub_pre. Qed. + +Lemma quotient_proper G K : + H <| G -> H <| K -> (G / H \proper K / H) = (G \proper K). +Proof. by move=> nHG nHK; rewrite -cosetpre_proper ?quotientGK. Qed. + +Lemma normal_cosetpre M : H <| coset H @*^-1 M. +Proof. rewrite -{1}ker_coset; exact: ker_normal_pre. Qed. + +Lemma cosetpreSK C D : + (coset H @*^-1 C \subset coset H @*^-1 D) = (C \subset D). +Proof. by rewrite morphpreSK ?sub_im_coset. Qed. + +Lemma sub_quotient_pre A C : + A \subset 'N(H) -> (A / H \subset C) = (A \subset coset H @*^-1 C). +Proof. exact: sub_morphim_pre. Qed. + +Lemma sub_cosetpre_quo C G : + H <| G -> (coset H @*^-1 C \subset G) = (C \subset G / H). +Proof. by move=> nHG; rewrite -cosetpreSK quotientGK. Qed. + +(* Variant of ker_trivg_morphim. *) +Lemma quotient_sub1 A : A \subset 'N(H) -> (A / H \subset [1]) = (A \subset H). +Proof. by move=> nHA /=; rewrite -{10}ker_coset ker_trivg_morphim nHA. Qed. + +Lemma quotientSK A B : + A \subset 'N(H) -> (A / H \subset B / H) = (A \subset H * B). +Proof. by move=> nHA; rewrite morphimSK ?ker_coset. Qed. + +Lemma quotientSGK A G : + A \subset 'N(H) -> H \subset G -> (A / H \subset G / H) = (A \subset G). +Proof. by rewrite -{2}ker_coset; exact: morphimSGK. Qed. + +Lemma quotient_injG : + {in [pred G : {group gT} | H <| G] &, injective (fun G => G / H)}. +Proof. by rewrite /normal -{1}ker_coset; exact: morphim_injG. Qed. + +Lemma quotient_inj G1 G2 : + H <| G1 -> H <| G2 -> G1 / H = G2 / H -> G1 :=: G2. +Proof. by rewrite /normal -{1 3}ker_coset; exact: morphim_inj. Qed. + +Lemma quotient_neq1 A : H <| A -> (A / H != 1) = (H \proper A). +Proof. +case/andP=> sHA nHA; rewrite /proper sHA -trivg_quotient eqEsubset andbC. +by rewrite quotientS //= quotientSGK. +Qed. + +Lemma quotient_gen A : A \subset 'N(H) -> <> / H = <>. +Proof. exact: morphim_gen. Qed. + +Lemma cosetpre_gen C : + 1 \in C -> coset H @*^-1 <> = <>. +Proof. by move=> C1; rewrite morphpre_gen ?sub_im_coset. Qed. + +Lemma quotientR A B : + A \subset 'N(H) -> B \subset 'N(H) -> [~: A, B] / H = [~: A / H, B / H]. +Proof. exact: morphimR. Qed. + +Lemma quotient_norm A : 'N(A) / H \subset 'N(A / H). +Proof. exact: morphim_norm. Qed. + +Lemma quotient_norms A B : A \subset 'N(B) -> A / H \subset 'N(B / H). +Proof. exact: morphim_norms. Qed. + +Lemma quotient_subnorm A B : 'N_A(B) / H \subset 'N_(A / H)(B / H). +Proof. exact: morphim_subnorm. Qed. + +Lemma quotient_normal A B : A <| B -> A / H <| B / H. +Proof. exact: morphim_normal. Qed. + +Lemma quotient_cent1 x : 'C[x] / H \subset 'C[coset H x]. +Proof. +case Nx: (x \in 'N(H)); first exact: morphim_cent1. +by rewrite coset_default // cent11T subsetT. +Qed. + +Lemma quotient_cent1s A x : A \subset 'C[x] -> A / H \subset 'C[coset H x]. +Proof. +by move=> sAC; exact: subset_trans (quotientS sAC) (quotient_cent1 x). +Qed. + +Lemma quotient_subcent1 A x : 'C_A[x] / H \subset 'C_(A / H)[coset H x]. +Proof. exact: subset_trans (quotientI _ _) (setIS _ (quotient_cent1 x)). Qed. + +Lemma quotient_cent A : 'C(A) / H \subset 'C(A / H). +Proof. exact: morphim_cent. Qed. + +Lemma quotient_cents A B : A \subset 'C(B) -> A / H \subset 'C(B / H). +Proof. exact: morphim_cents. Qed. + +Lemma quotient_abelian A : abelian A -> abelian (A / H). +Proof. exact: morphim_abelian. Qed. + +Lemma quotient_subcent A B : 'C_A(B) / H \subset 'C_(A / H)(B / H). +Proof. exact: morphim_subcent. Qed. + +Lemma norm_quotient_pre A C : + A \subset 'N(H) -> A / H \subset 'N(C) -> A \subset 'N(coset H @*^-1 C). +Proof. +by move/sub_quotient_pre=> -> /subset_trans-> //; exact: morphpre_norm. +Qed. + +Lemma cosetpre_normal C D : (coset H @*^-1 C <| coset H @*^-1 D) = (C <| D). +Proof. by rewrite morphpre_normal ?sub_im_coset. Qed. + +Lemma quotient_normG G : H <| G -> 'N(G) / H = 'N(G / H). +Proof. +case/andP=> sHG nHG. +by rewrite [_ / _]morphim_normG ?ker_coset // im_coset setTI. +Qed. + +Lemma quotient_subnormG A G : H <| G -> 'N_A(G) / H = 'N_(A / H)(G / H). +Proof. by case/andP=> sHG nHG; rewrite -morphim_subnormG ?ker_coset. Qed. + +Lemma cosetpre_cent1 x : 'C_('N(H))[x] \subset coset H @*^-1 'C[coset H x]. +Proof. +case Nx: (x \in 'N(H)); first by rewrite morphpre_cent1. +by rewrite coset_default // cent11T morphpreT subsetIl. +Qed. + +Lemma cosetpre_cent1s C x : + coset H @*^-1 C \subset 'C[x] -> C \subset 'C[coset H x]. +Proof. +move=> sC; rewrite -cosetpreSK; apply: subset_trans (cosetpre_cent1 x). +by rewrite subsetI subsetIl. +Qed. + +Lemma cosetpre_subcent1 C x : + 'C_(coset H @*^-1 C)[x] \subset coset H @*^-1 'C_C[coset H x]. +Proof. +by rewrite -morphpreIdom -setIA setICA morphpreI setIS // cosetpre_cent1. +Qed. + +Lemma cosetpre_cent A : 'C_('N(H))(A) \subset coset H @*^-1 'C(A / H). +Proof. exact: morphpre_cent. Qed. + +Lemma cosetpre_cents A C : coset H @*^-1 C \subset 'C(A) -> C \subset 'C(A / H). +Proof. by apply: morphpre_cents; rewrite ?sub_im_coset. Qed. + +Lemma cosetpre_subcent C A : + 'C_(coset H @*^-1 C)(A) \subset coset H @*^-1 'C_C(A / H). +Proof. exact: morphpre_subcent. Qed. + +Lemma restrm_quotientE G A (nHG : G \subset 'N(H)) : + A \subset G -> restrm nHG (coset H) @* A = A / H. +Proof. exact: restrmEsub. Qed. + +Section InverseImage. + +Variables (G : {group gT}) (Kbar : {group coset_of H}). + +Hypothesis nHG : H <| G. + +CoInductive inv_quotient_spec (P : pred {group gT}) : Prop := + InvQuotientSpec K of Kbar :=: K / H & H \subset K & P K. + +Lemma inv_quotientS : + Kbar \subset G / H -> inv_quotient_spec (fun K => K \subset G). +Proof. +case/andP: nHG => sHG nHG' sKbarG. +have sKdH: Kbar \subset 'N(H) / H by rewrite (subset_trans sKbarG) ?morphimS. +exists (coset H @*^-1 Kbar)%G; first by rewrite cosetpreK. + by rewrite -{1}ker_coset morphpreS ?sub1G. +by rewrite sub_cosetpre_quo. +Qed. + +Lemma inv_quotientN : Kbar <| G / H -> inv_quotient_spec (fun K => K <| G). +Proof. +move=> nKbar; case/inv_quotientS: (normal_sub nKbar) => K defKbar sHK sKG. +exists K => //; rewrite defKbar -cosetpre_normal !quotientGK // in nKbar. +exact: normalS nHG. +Qed. + +End InverseImage. + +Lemma quotientMidr A : A * H / H = A / H. +Proof. +by rewrite [_ /_]morphimMr ?normG //= -!quotientE trivg_quotient mulg1. +Qed. + +Lemma quotientMidl A : H * A / H = A / H. +Proof. +by rewrite [_ /_]morphimMl ?normG //= -!quotientE trivg_quotient mul1g. +Qed. + +Lemma quotientYidr G : G \subset 'N(H) -> G <*> H / H = G / H. +Proof. +move=> nHG; rewrite -genM_join quotient_gen ?mul_subG ?normG //. +by rewrite quotientMidr genGid. +Qed. + +Lemma quotientYidl G : G \subset 'N(H) -> H <*> G / H = G / H. +Proof. by move=> nHG; rewrite joingC quotientYidr. Qed. + +Section Injective. + +Variables (G : {group gT}). +Hypotheses (nHG : G \subset 'N(H)) (tiHG : H :&: G = 1). + +Lemma quotient_isom : isom G (G / H) (restrm nHG (coset H)). +Proof. by apply/isomP; rewrite ker_restrm setIC ker_coset tiHG im_restrm. Qed. + +Lemma quotient_isog : isog G (G / H). +Proof. exact: isom_isog quotient_isom. Qed. + +End Injective. + +End CosetOfGroupTheory. + +Notation "A / H" := (quotient_group A H) : Group_scope. + +Section Quotient1. + +Variables (gT : finGroupType) (A : {set gT}). + +Lemma coset1_injm : 'injm (@coset gT 1). +Proof. by rewrite ker_coset /=. Qed. + +Lemma quotient1_isom : isom A (A / 1) (coset 1). +Proof. by apply: sub_isom coset1_injm; rewrite ?norms1. Qed. + +Lemma quotient1_isog : isog A (A / 1). +Proof. apply: isom_isog quotient1_isom; exact: norms1. Qed. + +End Quotient1. + +Section QuotientMorphism. + +Variable (gT rT : finGroupType) (G H : {group gT}) (f : {morphism G >-> rT}). + +Implicit Types A : {set gT}. +Implicit Types B : {set (coset_of H)}. +Hypotheses (nsHG : H <| G). +Let sHG : H \subset G := normal_sub nsHG. +Let nHG : G \subset 'N(H) := normal_norm nsHG. +Let nfHfG : f @* G \subset 'N(f @* H) := morphim_norms f nHG. + +Notation fH := (coset (f @* H) \o f). + +Lemma quotm_dom_proof : G \subset 'dom fH. +Proof. by rewrite -sub_morphim_pre. Qed. + +Notation fH_G := (restrm quotm_dom_proof fH). + +Lemma quotm_ker_proof : 'ker (coset H) \subset 'ker fH_G. +Proof. +by rewrite ker_restrm ker_comp !ker_coset morphpreIdom morphimK ?mulG_subr. +Qed. + +Definition quotm := factm quotm_ker_proof nHG. + +Canonical quotm_morphism := [morphism G / H of quotm]. + +Lemma quotmE x : x \in G -> quotm (coset H x) = coset (f @* H) (f x). +Proof. exact: factmE. Qed. + +Lemma morphim_quotm A : quotm @* (A / H) = f @* A / f @* H. +Proof. by rewrite morphim_factm morphim_restrm morphim_comp morphimIdom. Qed. + +Lemma morphpre_quotm Abar : quotm @*^-1 (Abar / f @* H) = f @*^-1 Abar / H. +Proof. +rewrite morphpre_factm morphpre_restrm morphpre_comp /=. +rewrite morphpreIdom -[Abar / _]quotientInorm quotientK ?subsetIr //=. +rewrite morphpreMl ?morphimS // morphimK // [_ * H]normC ?subIset ?nHG //. +rewrite -quotientE -mulgA quotientMidl /= setIC -morphpreIim setIA. +by rewrite (setIidPl nfHfG) morphpreIim -morphpreMl ?sub1G ?mul1g. +Qed. + +Lemma ker_quotm : 'ker quotm = 'ker f / H. +Proof. by rewrite -morphpre_quotm /quotient morphim1. Qed. + +Lemma injm_quotm : 'injm f -> 'injm quotm. +Proof. by move/trivgP=> /= kf1; rewrite ker_quotm kf1 quotientE morphim1. Qed. + +End QuotientMorphism. + +Section EqIso. + +Variables (gT : finGroupType) (G H : {group gT}). + +Hypothesis (eqGH : G :=: H). + +Lemma im_qisom_proof : 'N(H) \subset 'N(G). Proof. by rewrite eqGH. Qed. +Lemma qisom_ker_proof : 'ker (coset G) \subset 'ker (coset H). +Proof. by rewrite eqGH. Qed. +Lemma qisom_restr_proof : setT \subset 'N(H) / G. +Proof. by rewrite eqGH im_quotient. Qed. + +Definition qisom := + restrm qisom_restr_proof (factm qisom_ker_proof im_qisom_proof). + +Canonical qisom_morphism := Eval hnf in [morphism of qisom]. + +Lemma qisomE x : qisom (coset G x) = coset H x. +Proof. +case Nx: (x \in 'N(H)); first exact: factmE. +by rewrite !coset_default ?eqGH ?morph1. +Qed. + +Lemma val_qisom Gx : val (qisom Gx) = val Gx. +Proof. +by case: (cosetP Gx) => x Nx ->{Gx}; rewrite qisomE /= !val_coset -?eqGH. +Qed. + +Lemma morphim_qisom A : qisom @* (A / G) = A / H. +Proof. by rewrite morphim_restrm setTI morphim_factm. Qed. + +Lemma morphpre_qisom A : qisom @*^-1 (A / H) = A / G. +Proof. +rewrite morphpre_restrm setTI morphpre_factm eqGH. +by rewrite morphpreK // im_coset subsetT. +Qed. + +Lemma injm_qisom : 'injm qisom. +Proof. by rewrite -quotient1 -morphpre_qisom morphpreS ?sub1G. Qed. + +Lemma im_qisom : qisom @* setT = setT. +Proof. by rewrite -{2}im_quotient morphim_qisom eqGH im_quotient. Qed. + +Lemma qisom_isom : isom setT setT qisom. +Proof. by apply/isomP; rewrite injm_qisom im_qisom. Qed. + +Lemma qisom_isog : [set: coset_of G] \isog [set: coset_of H]. +Proof. exact: isom_isog qisom_isom. Qed. + +Lemma qisom_inj : injective qisom. +Proof. by move=> x y; apply: (injmP injm_qisom); rewrite inE. Qed. + +Lemma morphim_qisom_inj : injective (fun Gx => qisom @* Gx). +Proof. +by move=> Gx Gy; apply: injm_morphim_inj; rewrite (injm_qisom, subsetT). +Qed. + +End EqIso. + +Implicit Arguments qisom_inj [gT G H]. +Implicit Arguments morphim_qisom_inj [gT G H]. + +Section FirstIsomorphism. + +Variables aT rT : finGroupType. + +Lemma first_isom (G : {group aT}) (f : {morphism G >-> rT}) : + {g : {morphism G / 'ker f >-> rT} | 'injm g & + forall A : {set aT}, g @* (A / 'ker f) = f @* A}. +Proof. +have nkG := ker_norm f. +have skk: 'ker (coset ('ker f)) \subset 'ker f by rewrite ker_coset. +exists (factm_morphism skk nkG) => /=; last exact: morphim_factm. +by rewrite ker_factm -quotientE trivg_quotient. +Qed. + +Variables (G H : {group aT}) (f : {morphism G >-> rT}). +Hypothesis sHG : H \subset G. + +Lemma first_isog : (G / 'ker f) \isog (f @* G). +Proof. +by case: (first_isom f) => g injg im_g; apply/isogP; exists g; rewrite ?im_g. +Qed. + +Lemma first_isom_loc : {g : {morphism H / 'ker_H f >-> rT} | + 'injm g & forall A : {set aT}, A \subset H -> g @* (A / 'ker_H f) = f @* A}. +Proof. +case: (first_isom (restrm_morphism sHG f)). +rewrite ker_restrm => g injg im_g; exists g => // A sAH. +by rewrite im_g morphim_restrm (setIidPr sAH). +Qed. + +Lemma first_isog_loc : (H / 'ker_H f) \isog (f @* H). +Proof. +by case: first_isom_loc => g injg im_g; apply/isogP; exists g; rewrite ?im_g. +Qed. + +End FirstIsomorphism. + +Section SecondIsomorphism. + +Variables (gT : finGroupType) (H K : {group gT}). + +Hypothesis nKH : H \subset 'N(K). + +Lemma second_isom : {f : {morphism H / (K :&: H) >-> coset_of K} | + 'injm f & forall A : {set gT}, A \subset H -> f @* (A / (K :&: H)) = A / K}. +Proof. +have ->: K :&: H = 'ker_H (coset K) by rewrite ker_coset setIC. +exact: first_isom_loc. +Qed. + +Lemma second_isog : H / (K :&: H) \isog H / K. +Proof. by rewrite setIC -{1 3}(ker_coset K); exact: first_isog_loc. Qed. + +Lemma weak_second_isog : H / (K :&: H) \isog H * K / K. +Proof. by rewrite quotientMidr; exact: second_isog. Qed. + +End SecondIsomorphism. + +Section ThirdIsomorphism. + +Variables (gT : finGroupType) (G H K : {group gT}). + +Lemma homg_quotientS (A : {set gT}) : + A \subset 'N(H) -> A \subset 'N(K) -> H \subset K -> A / K \homg A / H. +Proof. +rewrite -!(gen_subG A) /=; set L := <> => nHL nKL sKH. +have sub_ker: 'ker (restrm nHL (coset H)) \subset 'ker (restrm nKL (coset K)). + by rewrite !ker_restrm !ker_coset setIS. +have sAL: A \subset L := subset_gen A; rewrite -(setIidPr sAL). +rewrite -[_ / H](morphim_restrm nHL) -[_ / K](morphim_restrm nKL) /=. +by rewrite -(morphim_factm sub_ker (subxx L)) morphim_homg ?morphimS. +Qed. + +Hypothesis sHK : H \subset K. +Hypothesis snHG : H <| G. +Hypothesis snKG : K <| G. + +Theorem third_isom : {f : {morphism (G / H) / (K / H) >-> coset_of K} | 'injm f + & forall A : {set gT}, A \subset G -> f @* (A / H / (K / H)) = A / K}. +Proof. +have [[sKG nKG] [sHG nHG]] := (andP snKG, andP snHG). +have sHker: 'ker (coset H) \subset 'ker (restrm nKG (coset K)). + by rewrite ker_restrm !ker_coset subsetI sHG. +have:= first_isom_loc (factm_morphism sHker nHG) (subxx _) => /=. +rewrite ker_factm_loc ker_restrm ker_coset !(setIidPr sKG) /= -!quotientE. +case=> f injf im_f; exists f => // A sAG; rewrite im_f ?morphimS //. +by rewrite morphim_factm morphim_restrm (setIidPr sAG). +Qed. + +Theorem third_isog : (G / H / (K / H)) \isog (G / K). +Proof. +by case: third_isom => f inj_f im_f; apply/isogP; exists f; rewrite ?im_f. +Qed. + +End ThirdIsomorphism. + +Lemma char_from_quotient (gT : finGroupType) (G H K : {group gT}) : + H <| K -> H \char G -> K / H \char G / H -> K \char G. +Proof. +case/andP=> sHK nHK chHG. +have nsHG := char_normal chHG; have [sHG nHG] := andP nsHG. +case/charP; rewrite quotientSGK // => sKG /= chKG. +apply/charP; split=> // f injf Gf; apply/morphim_fixP => //. +rewrite -(quotientSGK _ sHK); last by rewrite -morphimIim Gf subIset ?nHG. +have{chHG} Hf: f @* H = H by case/charP: chHG => _; apply. +set q := quotm_morphism f nsHG; have{injf}: 'injm q by exact: injm_quotm. +have: q @* _ = _ := morphim_quotm _ _ _; move: q; rewrite Hf => q im_q injq. +by rewrite -im_q chKG // im_q Gf. +Qed. + +(* Counting lemmas for morphisms. *) + +Section CardMorphism. + +Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}). +Implicit Types G H : {group aT}. +Implicit Types L M : {group rT}. + +Lemma card_morphim G : #|f @* G| = #|D :&: G : 'ker f|. +Proof. +rewrite -morphimIdom -indexgI -card_quotient; last first. + by rewrite normsI ?normG ?subIset ?ker_norm. +by apply: esym (card_isog _); rewrite first_isog_loc ?subsetIl. +Qed. + +Lemma dvdn_morphim G : #|f @* G| %| #|G|. +Proof. +rewrite card_morphim (dvdn_trans (dvdn_indexg _ _)) //. +by rewrite cardSg ?subsetIr. +Qed. + +Lemma logn_morphim p G : logn p #|f @* G| <= logn p #|G|. +Proof. by rewrite dvdn_leq_log ?dvdn_morphim. Qed. + +Lemma coprime_morphl G p : coprime #|G| p -> coprime #|f @* G| p. +Proof. exact: coprime_dvdl (dvdn_morphim G). Qed. + +Lemma coprime_morphr G p : coprime p #|G| -> coprime p #|f @* G|. +Proof. exact: coprime_dvdr (dvdn_morphim G). Qed. + +Lemma coprime_morph G H : coprime #|G| #|H| -> coprime #|f @* G| #|f @* H|. +Proof. by move=> coGH; rewrite coprime_morphl // coprime_morphr. Qed. + +Lemma index_morphim_ker G H : + H \subset G -> G \subset D -> + (#|f @* G : f @* H| * #|'ker_G f : H|)%N = #|G : H|. +Proof. +move=> sHG sGD; apply/eqP. +rewrite -(eqn_pmul2l (cardG_gt0 (f @* H))) mulnA Lagrange ?morphimS //. +rewrite !card_morphim (setIidPr sGD) (setIidPr (subset_trans sHG sGD)). +rewrite -(eqn_pmul2l (cardG_gt0 ('ker_H f))) /=. +by rewrite -{1}(setIidPr sHG) setIAC mulnCA mulnC mulnA !LagrangeI Lagrange. +Qed. + +Lemma index_morphim G H : G :&: H \subset D -> #|f @* G : f @* H| %| #|G : H|. +Proof. +move=> dGH; rewrite -(indexgI G) -(setIidPr dGH) setIA. +apply: dvdn_trans (indexSg (subsetIl _ H) (subsetIr D G)). +rewrite -index_morphim_ker ?subsetIl ?subsetIr ?dvdn_mulr //= morphimIdom. +by rewrite indexgS ?morphimS ?subsetIr. +Qed. + +Lemma index_injm G H : 'injm f -> G \subset D -> #|f @* G : f @* H| = #|G : H|. +Proof. +move=> injf dG; rewrite -{2}(setIidPr dG) -(indexgI _ H) /=. +rewrite -index_morphim_ker ?subsetIl ?subsetIr //= setIAC morphimIdom setIC. +rewrite injmI ?subsetIr // indexgI /= morphimIdom setIC ker_injm //. +by rewrite -(indexgI (1 :&: _)) /= -setIA !(setIidPl (sub1G _)) indexgg muln1. +Qed. + +Lemma card_morphpre L : L \subset f @* D -> #|f @*^-1 L| = (#|'ker f| * #|L|)%N. +Proof. +move/morphpreK=> {2} <-; rewrite card_morphim morphpreIdom. +by rewrite Lagrange // morphpreS ?sub1G. +Qed. + +Lemma index_morphpre L M : + L \subset f @* D -> #|f @*^-1 L : f @*^-1 M| = #|L : M|. +Proof. +move=> dL; rewrite -!divgI -morphpreI card_morphpre //. +have: L :&: M \subset f @* D by rewrite subIset ?dL. +by move/card_morphpre->; rewrite divnMl ?cardG_gt0. +Qed. + +End CardMorphism. + +Lemma card_homg (aT rT : finGroupType) (G : {group aT}) (R : {group rT}) : + G \homg R -> #|G| %| #|R|. +Proof. by case/homgP=> f <-; rewrite card_morphim setIid dvdn_indexg. Qed. + +Section CardCosetpre. + +Variables (gT : finGroupType) (G H K : {group gT}) (L M : {group coset_of H}). + +Lemma dvdn_quotient : #|G / H| %| #|G|. +Proof. exact: dvdn_morphim. Qed. + +Lemma index_quotient_ker : + K \subset G -> G \subset 'N(H) -> + (#|G / H : K / H| * #|G :&: H : K|)%N = #|G : K|. +Proof. by rewrite -{5}(ker_coset H); exact: index_morphim_ker. Qed. + +Lemma index_quotient : G :&: K \subset 'N(H) -> #|G / H : K / H| %| #|G : K|. +Proof. exact: index_morphim. Qed. + +Lemma index_quotient_eq : + G :&: H \subset K -> K \subset G -> G \subset 'N(H) -> + #|G / H : K / H| = #|G : K|. +Proof. +move=> sGH_K sKG sGN; rewrite -index_quotient_ker {sKG sGN}//. +by rewrite -(indexgI _ K) (setIidPl sGH_K) indexgg muln1. +Qed. + +Lemma card_cosetpre : #|coset H @*^-1 L| = (#|H| * #|L|)%N. +Proof. by rewrite card_morphpre ?ker_coset ?sub_im_coset. Qed. + +Lemma index_cosetpre : #|coset H @*^-1 L : coset H @*^-1 M| = #|L : M|. +Proof. by rewrite index_morphpre ?sub_im_coset. Qed. + +End CardCosetpre. diff --git a/mathcomp/fingroup/zmodp.v b/mathcomp/fingroup/zmodp.v new file mode 100644 index 0000000..df5b378 --- /dev/null +++ b/mathcomp/fingroup/zmodp.v @@ -0,0 +1,362 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div. +Require Import fintype bigop finset prime fingroup ssralg finalg. + +(******************************************************************************) +(* Definition of the additive group and ring Zp, represented as 'I_p *) +(******************************************************************************) +(* Definitions: *) +(* From fintype.v: *) +(* 'I_p == the subtype of integers less than p, taken here as the type of *) +(* the integers mod p. *) +(* This file: *) +(* inZp == the natural projection from nat into the integers mod p, *) +(* represented as 'I_p. Here p is implicit, but MUST be of the *) +(* form n.+1. *) +(* The operations: *) +(* Zp0 == the identity element for addition *) +(* Zp1 == the identity element for multiplication, and a generator of *) +(* additive group *) +(* Zp_opp == inverse function for addition *) +(* Zp_add == addition *) +(* Zp_mul == multiplication *) +(* Zp_inv == inverse function for multiplication *) +(* Note that while 'I_n.+1 has canonical finZmodType and finGroupType *) +(* structures, only 'I_n.+2 has a canonical ring structure (it has, in fact, *) +(* a canonical finComUnitRing structure), and hence an associated *) +(* multiplicative unit finGroupType. To mitigate the issues caused by the *) +(* trivial "ring" (which is, indeed is NOT a ring in the ssralg/finalg *) +(* formalization), we define additional notation: *) +(* 'Z_p == the type of integers mod (max p 2); this is always a proper *) +(* ring, by constructions. Note that 'Z_p is provably equal to *) +(* 'I_p if p > 1, and convertible to 'I_p if p is of the form *) +(* n.+2. *) +(* Zp p == the subgroup of integers mod (max p 1) in 'Z_p; this is thus *) +(* is thus all of 'Z_p if p > 1, and else the trivial group. *) +(* units_Zp p == the group of all units of 'Z_p -- i.e., the group of *) +(* (multiplicative) automorphisms of Zp p. *) +(* We show that Zp and units_Zp are abelian, and compute their orders. *) +(* We use a similar technique to represent the prime fields: *) +(* 'F_p == the finite field of integers mod the first prime divisor of *) +(* maxn p 2. This is provably equal to 'Z_p and 'I_p if p is *) +(* provably prime, and indeed convertible to the above if p is *) +(* a concrete prime such as 2, 5 or 23. *) +(* Note finally that due to the canonical structures it is possible to use *) +(* 0%R instead of Zp0, and 1%R instead of Zp1 (for the latter, p must be of *) +(* the form n.+2, and 1%R : nat will simplify to 1%N). *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope ring_scope. + +Section ZpDef. + +(***********************************************************************) +(* *) +(* Mod p arithmetic on the finite set {0, 1, 2, ..., p - 1} *) +(* *) +(***********************************************************************) + +Variable p' : nat. +Local Notation p := p'.+1. + +Implicit Types x y z : 'I_p. + +(* Standard injection; val (inZp i) = i %% p *) +Definition inZp i := Ordinal (ltn_pmod i (ltn0Sn p')). +Lemma modZp x : x %% p = x. +Proof. by rewrite modn_small ?ltn_ord. Qed. +Lemma valZpK x : inZp x = x. +Proof. by apply: val_inj; rewrite /= modZp. Qed. + +(* Operations *) +Definition Zp0 : 'I_p := ord0. +Definition Zp1 := inZp 1. +Definition Zp_opp x := inZp (p - x). +Definition Zp_add x y := inZp (x + y). +Definition Zp_mul x y := inZp (x * y). +Definition Zp_inv x := if coprime p x then inZp (egcdn x p).1 else x. + +(* Additive group structure. *) + +Lemma Zp_add0z : left_id Zp0 Zp_add. +Proof. exact: valZpK. Qed. + +Lemma Zp_addNz : left_inverse Zp0 Zp_opp Zp_add. +Proof. +by move=> x; apply: val_inj; rewrite /= modnDml subnK ?modnn // ltnW. +Qed. + +Lemma Zp_addA : associative Zp_add. +Proof. +by move=> x y z; apply: val_inj; rewrite /= modnDml modnDmr addnA. +Qed. + +Lemma Zp_addC : commutative Zp_add. +Proof. by move=> x y; apply: val_inj; rewrite /= addnC. Qed. + +Definition Zp_zmodMixin := ZmodMixin Zp_addA Zp_addC Zp_add0z Zp_addNz. +Canonical Zp_zmodType := Eval hnf in ZmodType 'I_p Zp_zmodMixin. +Canonical Zp_finZmodType := Eval hnf in [finZmodType of 'I_p]. +Canonical Zp_baseFinGroupType := Eval hnf in [baseFinGroupType of 'I_p for +%R]. +Canonical Zp_finGroupType := Eval hnf in [finGroupType of 'I_p for +%R]. + +(* Ring operations *) + +Lemma Zp_mul1z : left_id Zp1 Zp_mul. +Proof. by move=> x; apply: val_inj; rewrite /= modnMml mul1n modZp. Qed. + +Lemma Zp_mulC : commutative Zp_mul. +Proof. by move=> x y; apply: val_inj; rewrite /= mulnC. Qed. + +Lemma Zp_mulz1 : right_id Zp1 Zp_mul. +Proof. by move=> x; rewrite Zp_mulC Zp_mul1z. Qed. + +Lemma Zp_mulA : associative Zp_mul. +Proof. +by move=> x y z; apply: val_inj; rewrite /= modnMml modnMmr mulnA. +Qed. + +Lemma Zp_mul_addr : right_distributive Zp_mul Zp_add. +Proof. +by move=> x y z; apply: val_inj; rewrite /= modnMmr modnDm mulnDr. +Qed. + +Lemma Zp_mul_addl : left_distributive Zp_mul Zp_add. +Proof. by move=> x y z; rewrite -!(Zp_mulC z) Zp_mul_addr. Qed. + +Lemma Zp_mulVz x : coprime p x -> Zp_mul (Zp_inv x) x = Zp1. +Proof. +move=> co_p_x; apply: val_inj; rewrite /Zp_inv co_p_x /= modnMml. +by rewrite -(chinese_modl co_p_x 1 0) /chinese addn0 mul1n mulnC. +Qed. + +Lemma Zp_mulzV x : coprime p x -> Zp_mul x (Zp_inv x) = Zp1. +Proof. by move=> Ux; rewrite /= Zp_mulC Zp_mulVz. Qed. + +Lemma Zp_intro_unit x y : Zp_mul y x = Zp1 -> coprime p x. +Proof. +case=> yx1; have:= coprimen1 p. +by rewrite -coprime_modr -yx1 coprime_modr coprime_mulr; case/andP. +Qed. + +Lemma Zp_inv_out x : ~~ coprime p x -> Zp_inv x = x. +Proof. by rewrite /Zp_inv => /negPf->. Qed. + +Lemma Zp_mulrn x n : x *+ n = inZp (x * n). +Proof. +apply: val_inj => /=; elim: n => [|n IHn]; first by rewrite muln0 modn_small. +by rewrite !GRing.mulrS /= IHn modnDmr mulnS. +Qed. + +Import GroupScope. + +Lemma Zp_mulgC : @commutative 'I_p _ mulg. +Proof. exact: Zp_addC. Qed. + +Lemma Zp_abelian : abelian [set: 'I_p]. +Proof. exact: FinRing.zmod_abelian. Qed. + +Lemma Zp_expg x n : x ^+ n = inZp (x * n). +Proof. exact: Zp_mulrn. Qed. + +Lemma Zp1_expgz x : Zp1 ^+ x = x. +Proof. by rewrite Zp_expg; exact: Zp_mul1z. Qed. + +Lemma Zp_cycle : setT = <[Zp1]>. +Proof. by apply/setP=> x; rewrite -[x]Zp1_expgz inE groupX ?mem_gen ?set11. Qed. + +Lemma order_Zp1 : #[Zp1] = p. +Proof. by rewrite orderE -Zp_cycle cardsT card_ord. Qed. + +End ZpDef. + +Implicit Arguments Zp0 [[p']]. +Implicit Arguments Zp1 [[p']]. +Implicit Arguments inZp [[p']]. + +Lemma ord1 : all_equal_to (0 : 'I_1). +Proof. by case=> [[] // ?]; exact: val_inj. Qed. + +Lemma lshift0 m n : lshift m (0 : 'I_n.+1) = (0 : 'I_(n + m).+1). +Proof. exact: val_inj. Qed. + +Lemma rshift1 n : @rshift 1 n =1 lift (0 : 'I_n.+1). +Proof. by move=> i; exact: val_inj. Qed. + +Lemma split1 n i : + split (i : 'I_(1 + n)) = oapp (@inr _ _) (inl _ 0) (unlift 0 i). +Proof. +case: unliftP => [i'|] -> /=. + by rewrite -rshift1 (unsplitK (inr _ _)). +by rewrite -(lshift0 n 0) (unsplitK (inl _ _)). +Qed. + +Lemma big_ord1 R idx (op : @Monoid.law R idx) F : + \big[op/idx]_(i < 1) F i = F 0. +Proof. by rewrite big_ord_recl big_ord0 Monoid.mulm1. Qed. + +Lemma big_ord1_cond R idx (op : @Monoid.law R idx) P F : + \big[op/idx]_(i < 1 | P i) F i = if P 0 then F 0 else idx. +Proof. by rewrite big_mkcond big_ord1. Qed. + +Section ZpRing. + +Variable p' : nat. +Local Notation p := p'.+2. + +Lemma Zp_nontrivial : Zp1 != 0 :> 'I_p. Proof. by []. Qed. + +Definition Zp_ringMixin := + ComRingMixin (@Zp_mulA _) (@Zp_mulC _) (@Zp_mul1z _) (@Zp_mul_addl _) + Zp_nontrivial. +Canonical Zp_ringType := Eval hnf in RingType 'I_p Zp_ringMixin. +Canonical Zp_finRingType := Eval hnf in [finRingType of 'I_p]. +Canonical Zp_comRingType := Eval hnf in ComRingType 'I_p (@Zp_mulC _). +Canonical Zp_finComRingType := Eval hnf in [finComRingType of 'I_p]. + +Definition Zp_unitRingMixin := + ComUnitRingMixin (@Zp_mulVz _) (@Zp_intro_unit _) (@Zp_inv_out _). +Canonical Zp_unitRingType := Eval hnf in UnitRingType 'I_p Zp_unitRingMixin. +Canonical Zp_finUnitRingType := Eval hnf in [finUnitRingType of 'I_p]. +Canonical Zp_comUnitRingType := Eval hnf in [comUnitRingType of 'I_p]. +Canonical Zp_finComUnitRingType := Eval hnf in [finComUnitRingType of 'I_p]. + +Lemma Zp_nat n : n%:R = inZp n :> 'I_p. +Proof. by apply: val_inj; rewrite [n%:R]Zp_mulrn /= modnMml mul1n. Qed. + +Lemma natr_Zp (x : 'I_p) : x%:R = x. +Proof. by rewrite Zp_nat valZpK. Qed. + +Lemma natr_negZp (x : 'I_p) : (- x)%:R = - x. +Proof. by apply: val_inj; rewrite /= Zp_nat /= modn_mod. Qed. + +Import GroupScope. + +Lemma unit_Zp_mulgC : @commutative {unit 'I_p} _ mulg. +Proof. by move=> u v; apply: val_inj; rewrite /= GRing.mulrC. Qed. + +Lemma unit_Zp_expg (u : {unit 'I_p}) n : + val (u ^+ n) = inZp (val u ^ n) :> 'I_p. +Proof. +apply: val_inj => /=; elim: n => [|n IHn] //. +by rewrite expgS /= IHn expnS modnMmr. +Qed. + +End ZpRing. + +Definition Zp_trunc p := p.-2. + +Notation "''Z_' p" := 'I_(Zp_trunc p).+2 + (at level 8, p at level 2, format "''Z_' p") : type_scope. +Notation "''F_' p" := 'Z_(pdiv p) + (at level 8, p at level 2, format "''F_' p") : type_scope. + +Section Groups. + +Variable p : nat. + +Definition Zp := if p > 1 then [set: 'Z_p] else 1%g. +Definition units_Zp := [set: {unit 'Z_p}]. + +Lemma Zp_cast : p > 1 -> (Zp_trunc p).+2 = p. +Proof. by case: p => [|[]]. Qed. + +Lemma val_Zp_nat (p_gt1 : p > 1) n : (n%:R : 'Z_p) = (n %% p)%N :> nat. +Proof. by rewrite Zp_nat /= Zp_cast. Qed. + +Lemma Zp_nat_mod (p_gt1 : p > 1)m : (m %% p)%:R = m%:R :> 'Z_p. +Proof. by apply: ord_inj; rewrite !val_Zp_nat // modn_mod. Qed. + +Lemma char_Zp : p > 1 -> p%:R = 0 :> 'Z_p. +Proof. by move=> p_gt1; rewrite -Zp_nat_mod ?modnn. Qed. + +Lemma unitZpE x : p > 1 -> ((x%:R : 'Z_p) \is a GRing.unit) = coprime p x. +Proof. +by move=> p_gt1; rewrite qualifE /= val_Zp_nat ?Zp_cast ?coprime_modr. +Qed. + +Lemma Zp_group_set : group_set Zp. +Proof. rewrite /Zp; case: (p > 1); exact: groupP. Qed. +Canonical Zp_group := Group Zp_group_set. + +Lemma card_Zp : p > 0 -> #|Zp| = p. +Proof. +rewrite /Zp; case: p => [|[|p']] //= _; first by rewrite cards1. +by rewrite cardsT card_ord. +Qed. + +Lemma mem_Zp x : p > 1 -> x \in Zp. Proof. by rewrite /Zp => ->. Qed. + +Canonical units_Zp_group := [group of units_Zp]. + +Lemma card_units_Zp : p > 0 -> #|units_Zp| = totient p. +Proof. +move=> p_gt0; transitivity (totient p.-2.+2); last by case: p p_gt0 => [|[|p']]. +rewrite cardsT card_sub -sum1_card big_mkcond /=. +by rewrite totient_count_coprime big_mkord. +Qed. + +Lemma units_Zp_abelian : abelian units_Zp. +Proof. apply/centsP=> u _ v _; exact: unit_Zp_mulgC. Qed. + +End Groups. + +(* Field structure for primes. *) + +Section PrimeField. + +Open Scope ring_scope. + +Variable p : nat. + +Section F_prime. + +Hypothesis p_pr : prime p. + +Lemma Fp_Zcast : (Zp_trunc (pdiv p)).+2 = (Zp_trunc p).+2. +Proof. by rewrite /pdiv primes_prime. Qed. + +Lemma Fp_cast : (Zp_trunc (pdiv p)).+2 = p. +Proof. by rewrite Fp_Zcast ?Zp_cast ?prime_gt1. Qed. + +Lemma card_Fp : #|'F_p| = p. +Proof. by rewrite card_ord Fp_cast. Qed. + +Lemma val_Fp_nat n : (n%:R : 'F_p) = (n %% p)%N :> nat. +Proof. by rewrite Zp_nat /= Fp_cast. Qed. + +Lemma Fp_nat_mod m : (m %% p)%:R = m%:R :> 'F_p. +Proof. by apply: ord_inj; rewrite !val_Fp_nat // modn_mod. Qed. + +Lemma char_Fp : p \in [char 'F_p]. +Proof. by rewrite !inE -Fp_nat_mod p_pr ?modnn. Qed. + +Lemma char_Fp_0 : p%:R = 0 :> 'F_p. +Proof. exact: GRing.charf0 char_Fp. Qed. + +Lemma unitFpE x : ((x%:R : 'F_p) \is a GRing.unit) = coprime p x. +Proof. by rewrite pdiv_id // unitZpE // prime_gt1. Qed. + +End F_prime. + +Lemma Fp_fieldMixin : GRing.Field.mixin_of [the unitRingType of 'F_p]. +Proof. +move=> x nzx; rewrite qualifE /= prime_coprime ?gtnNdvd ?lt0n //. +case: (ltnP 1 p) => [lt1p | ]; last by case: p => [|[|p']]. +by rewrite Zp_cast ?prime_gt1 ?pdiv_prime. +Qed. + +Definition Fp_idomainMixin := FieldIdomainMixin Fp_fieldMixin. + +Canonical Fp_idomainType := Eval hnf in IdomainType 'F_p Fp_idomainMixin. +Canonical Fp_finIdomainType := Eval hnf in [finIdomainType of 'F_p]. +Canonical Fp_fieldType := Eval hnf in FieldType 'F_p Fp_fieldMixin. +Canonical Fp_finFieldType := Eval hnf in [finFieldType of 'F_p]. +Canonical Fp_decFieldType := + Eval hnf in [decFieldType of 'F_p for Fp_finFieldType]. + +End PrimeField. diff --git a/mathcomp/odd_order/BGappendixAB.v b/mathcomp/odd_order/BGappendixAB.v new file mode 100644 index 0000000..4cbafd0 --- /dev/null +++ b/mathcomp/odd_order/BGappendixAB.v @@ -0,0 +1,508 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div. +Require Import fintype bigop prime finset ssralg fingroup morphism. +Require Import automorphism quotient gfunctor commutator zmodp center pgroup. +Require Import sylow gseries nilpotent abelian maximal. +Require Import matrix mxalgebra mxrepresentation mxabelem. +Require Import BGsection1 BGsection2. + +(******************************************************************************) +(* This file contains the useful material in B & G, appendices A and B, i.e., *) +(* the proof of the p-stability properties and the ZL-Theorem (the Puig *) +(* replacement for the Glaubermann ZJ-theorem). The relevant definitions are *) +(* given in BGsection1. *) +(* Theorem A.4(a) has not been formalised: it is a result on external *) +(* p-stability, which concerns faithful representations of group with a *) +(* trivial p-core on a field of characteristic p. It's the historical concept *) +(* that was studied by Hall and Higman, but it's not used for FT. Note that *) +(* the finite field case can be recovered from A.4(c) with a semi-direct *) +(* product. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Open Local Scope ring_scope. +Import GroupScope GRing.Theory. + +Section AppendixA. + +Implicit Type gT : finGroupType. +Implicit Type p : nat. + +Import MatrixGenField. + +(* This is B & G, Theorem A.4(c) (in Appendix A, not section 16!). We follow *) +(* both B & G and Gorenstein in using the general form of the p-stable *) +(* property. We could simplify the property because the conditions under *) +(* which we prove p-stability are inherited by sections (morphic image in our *) +(* framework), and restrict to the case where P is normal in G. (Clearly the *) +(* 'O_p^'(G) * P <| G premise plays no part in the proof.) *) +(* Theorems A.1-A.3 are essentially inlined in this proof. *) + +Theorem odd_p_stable gT p (G : {group gT}) : odd #|G| -> p.-stable G. +Proof. +move: gT G. +pose p_xp gT (E : {group gT}) x := p.-elt x && (x \in 'C([~: E, [set x]])). +suffices IH gT (E : {group gT}) x y (G := <<[set x; y]>>) : + [&& odd #|G|, p.-group E & G \subset 'N(E)] -> p_xp gT E x && p_xp gT E y -> + p.-group (G / 'C(E)). +- move=> gT G oddG P A pP /andP[/mulGsubP[_ sPG] _] /andP[sANG pA] cRA. + apply/subsetP=> _ /morphimP[x Nx Ax ->]; have NGx := subsetP sANG x Ax. + apply: Baer_Suzuki => [|_ /morphimP[y Ny NGy ->]]; first exact: mem_quotient. + rewrite -morphJ // -!morphim_set1 -?[<<_>>]morphimY ?sub1set ?groupJ //. + set G1 := _ <*> _; rewrite /pgroup -(card_isog (second_isog _)); last first. + by rewrite join_subG !sub1set Nx groupJ. + have{Nx NGx Ny NGy} [[Gx Nx] [Gy Ny]] := (setIP NGx, setIP NGy). + have sG1G: G1 \subset G by rewrite join_subG !sub1set groupJ ?andbT. + have nPG1: G1 \subset 'N(P) by rewrite join_subG !sub1set groupJ ?andbT. + rewrite -setIA setICA (setIidPr sG1G). + rewrite (card_isog (second_isog _)) ?norms_cent //. + apply: IH => //; first by rewrite pP nPG1 (oddSg sG1G). + rewrite /p_xp -{2}(normP Ny) -conjg_set1 -conjsRg centJ memJ_conjg. + rewrite p_eltJ andbb (mem_p_elt pA) // -sub1set centsC (sameP commG1P trivgP). + by rewrite -cRA !commgSS ?sub1set. +move: {2}_.+1 (ltnSn #|E|) => n; elim: n => // n IHn in gT E x y G *. +rewrite ltnS => leEn /and3P[oddG pE nEG] /and3P[/andP[p_x cRx] p_y cRy]. +have [Gx Gy]: x \in G /\ y \in G by apply/andP; rewrite -!sub1set -join_subG. +apply: wlog_neg => p'Gc; apply/pgroupP=> q q_pr qGc; apply/idPn => p'q. +have [Q sylQ] := Sylow_exists q [group of G]. +have [sQG qQ]: Q \subset G /\ q.-group Q by case/and3P: sylQ. +have{qQ p'q} p'Q: p^'.-group Q by apply: sub_in_pnat qQ => q' _ /eqnP->. +have{q q_pr sylQ qGc} ncEQ: ~~ (Q \subset 'C(E)). + apply: contraL qGc => cEQ; rewrite -p'natE // -partn_eq1 //. + have nCQ: Q \subset 'N('C(E)) by exact: subset_trans (normG _). + have sylQc: q.-Sylow(G / 'C(E)) (Q / 'C(E)) by rewrite morphim_pSylow. + by rewrite -(card_Hall sylQc) -trivg_card1 (sameP eqP trivgP) quotient_sub1. +have solE: solvable E := pgroup_sol pE. +have ntE: E :!=: 1 by apply: contra ncEQ; move/eqP->; rewrite cents1. +have{Q ncEQ p'Q sQG} minE_EG: minnormal E (E <*> G). + apply/mingroupP; split=> [|D]; rewrite join_subG ?ntE ?normG //. + case/and3P=> ntD nDE nDG sDE; have nDGi := subsetP nDG. + apply/eqP; rewrite eqEcard sDE leqNgt; apply: contra ncEQ => ltDE. + have nDQ: Q \subset 'N(D) by rewrite (subset_trans sQG). + have cDQ: Q \subset 'C(D). + rewrite -quotient_sub1 ?norms_cent // ?[_ / _]card1_trivg //. + apply: pnat_1 (morphim_pgroup _ p'Q); apply: pgroupS (quotientS _ sQG) _. + apply: IHn (leq_trans ltDE leEn) _ _; first by rewrite oddG (pgroupS sDE). + rewrite /p_xp p_x p_y /=; apply/andP. + by split; [move: cRx | move: cRy]; apply: subsetP; rewrite centS ?commSg. + apply: (stable_factor_cent cDQ) solE; rewrite ?(pnat_coprime pE) //. + apply/and3P; split; rewrite // -quotient_cents2 // centsC. + rewrite -quotient_sub1 ?norms_cent ?quotient_norms ?(subset_trans sQG) //=. + rewrite [(_ / _) / _]card1_trivg //=. + apply: pnat_1 (morphim_pgroup _ (morphim_pgroup _ p'Q)). + apply: pgroupS (quotientS _ (quotientS _ sQG)) _. + have defGq: G / D = <<[set coset D x; coset D y]>>. + by rewrite quotient_gen -1?gen_subG ?quotientU ?quotient_set1 ?nDGi. + rewrite /= defGq IHn ?(leq_trans _ leEn) ?ltn_quotient // -?defGq. + by rewrite quotient_odd // quotient_pgroup // quotient_norms. + rewrite /p_xp -!sub1set !morph_p_elt -?quotient_set1 ?nDGi //=. + by rewrite -!quotientR ?quotient_cents ?sub1set ?nDGi. +have abelE: p.-abelem E. + by rewrite -is_abelem_pgroup //; case: (minnormal_solvable minE_EG _ solE). +have cEE: abelian E by case/and3P: abelE. +have{minE_EG} minE: minnormal E G. + case/mingroupP: minE_EG => _ minE; apply/mingroupP; rewrite ntE. + split=> // D ntD sDE; apply: minE => //; rewrite join_subG cents_norm //. + by rewrite centsC (subset_trans sDE). +have nCG: G \subset 'N('C_G(E)) by rewrite normsI ?normG ?norms_cent. +suffices{p'Gc} pG'c: p.-group (G / 'C_G(E))^`(1). + have [Pc sylPc sGc'Pc]:= Sylow_superset (der_subS _ _) pG'c. + have nsPc: Pc <| G / 'C_G(E) by rewrite sub_der1_normal ?(pHall_sub sylPc). + case/negP: p'Gc; rewrite /pgroup -(card_isog (second_isog _)) ?norms_cent //. + rewrite setIC; apply: pgroupS (pHall_pgroup sylPc) => /=. + rewrite sub_quotient_pre // join_subG !sub1set !(subsetP nCG, inE) //=. + by rewrite !(mem_normal_Hall sylPc) ?mem_quotient ?morph_p_elt ?(subsetP nCG). +have defC := rker_abelem abelE ntE nEG; rewrite /= -/G in defC. +set rG := abelem_repr _ _ _ in defC. +case ncxy: (rG x *m rG y == rG y *m rG x). + have Cxy: [~ x, y] \in 'C_G(E). + rewrite -defC inE groupR //= !repr_mxM ?groupM ?groupV // mul1mx -/rG. + by rewrite (eqP ncxy) -!repr_mxM ?groupM ?groupV // mulKg mulVg repr_mx1. + rewrite [_^`(1)](commG1P _) ?pgroup1 //= quotient_gen -gen_subG //= -/G. + rewrite !gen_subG centsC gen_subG quotient_cents2r ?gen_subG //= -/G. + rewrite /commg_set imset2Ul !imset2_set1l !imsetU !imset_set1. + by rewrite !subUset andbC !sub1set !commgg group1 /= -invg_comm groupV Cxy. +pose Ax : 'M(E) := rG x - 1; pose Ay : 'M(E) := rG y - 1. +have Ax2: Ax *m Ax = 0. + apply/row_matrixP=> i; apply/eqP; rewrite row_mul mulmxBr mulmx1. + rewrite row0 subr_eq0 -(inj_eq (@rVabelem_inj _ _ _ abelE ntE)). + rewrite rVabelemJ // conjgE -(centP cRx) ?mulKg //. + rewrite linearB /= addrC row1 rowE rVabelemD rVabelemN rVabelemJ //=. + by rewrite mem_commg ?set11 ?mem_rVabelem. +have Ay2: Ay *m Ay = 0. + apply/row_matrixP=> i; apply/eqP; rewrite row_mul mulmxBr mulmx1. + rewrite row0 subr_eq0 -(inj_eq (@rVabelem_inj _ _ _ abelE ntE)). + rewrite rVabelemJ // conjgE -(centP cRy) ?mulKg //. + rewrite linearB /= addrC row1 rowE rVabelemD rVabelemN rVabelemJ //=. + by rewrite mem_commg ?set11 ?mem_rVabelem. +pose A := Ax *m Ay + Ay *m Ax. +have cAG: centgmx rG A. + rewrite /centgmx gen_subG subUset !sub1set !inE Gx Gy /=; apply/andP. + rewrite -[rG x](subrK 1%R) -[rG y](subrK 1%R) -/Ax -/Ay. + rewrite 2!(mulmxDl _ 1 A) 2!(mulmxDr A _ 1) !mulmx1 !mul1mx. + rewrite !(inj_eq (addIr A)) ![_ *m A]mulmxDr ![A *m _]mulmxDl. + by rewrite -!mulmxA Ax2 Ay2 !mulmx0 !mulmxA Ax2 Ay2 !mul0mx !addr0 !add0r. +have irrG: mx_irreducible rG by exact/abelem_mx_irrP. +pose rAG := gen_repr irrG cAG; pose inFA := in_gen irrG cAG. +pose valFA := @val_gen _ _ _ _ _ _ irrG cAG. +set dA := gen_dim A in rAG inFA valFA. +rewrite -(rker_abelem abelE ntE nEG) -/rG -(rker_gen irrG cAG) -/rAG. +have dA_gt0: dA > 0 by rewrite (gen_dim_gt0 irrG cAG). +have irrAG: mx_irreducible rAG by exact: gen_mx_irr. +have: dA <= 2. + case Ax0: (Ax == 0). + by rewrite subr_eq0 in Ax0; case/eqP: ncxy; rewrite (eqP Ax0) mulmx1 mul1mx. + case/rowV0Pn: Ax0 => v; case/submxP => u def_v nzv. + pose U := col_mx v (v *m Ay); pose UA := <>%MS. + pose rvalFA := @rowval_gen _ _ _ _ _ _ irrG cAG. + have Umod: mxmodule rAG UA. + rewrite /mxmodule gen_subG subUset !sub1set !inE Gx Gy /= andbC. + apply/andP; split; rewrite (eqmxMr _ (genmxE _)) -in_genJ // genmxE. + rewrite submx_in_gen // -[rG y](subrK 1%R) -/Ay mulmxDr mulmx1. + rewrite addmx_sub // mul_col_mx -mulmxA Ay2 mulmx0. + by rewrite -!addsmxE addsmx0 addsmxSr. + rewrite -[rG x](subrK 1%R) -/Ax mulmxDr mulmx1 in_genD mul_col_mx. + rewrite -mulmxA -[Ay *m Ax](addKr (Ax *m Ay)) (mulmxDr v _ A) -mulmxN. + rewrite mulmxA {1 2}def_v -(mulmxA u) Ax2 mulmx0 mul0mx add0r. + pose B := A; rewrite -(mul0mx _ B) -mul_col_mx -[B](mxval_groot irrG cAG). + rewrite {B} -[_ 0 v](in_genK irrG cAG) -val_genZ val_genK. + rewrite addmx_sub ?scalemx_sub ?submx_in_gen //. + by rewrite -!addsmxE adds0mx addsmxSl. + have nzU: UA != 0. + rewrite -mxrank_eq0 genmxE mxrank_eq0; apply/eqP. + move/(canRL ((in_genK _ _) _)); rewrite val_gen0; apply/eqP. + by rewrite -submx0 -addsmxE addsmx_sub submx0 negb_and nzv. + case/mx_irrP: irrAG => _ /(_ UA Umod nzU)/eqnP <-. + by rewrite genmxE rank_leq_row. +rewrite leq_eqVlt ltnS leq_eqVlt ltnNge dA_gt0 orbF orbC; case/pred2P=> def_dA. + rewrite [_^`(1)](commG1P _) ?pgroup1 // quotient_cents2r // gen_subG. + apply/subsetP=> zt; case/imset2P=> z t Gz Gt ->{zt}. + rewrite !inE groupR //= mul1mx; have Gtz := groupM Gt Gz. + rewrite -(inj_eq (can_inj (mulKmx (repr_mx_unit rAG Gtz)))) mulmx1. + rewrite [eq_op]lock -repr_mxM ?groupR ?groupM // -commgC !repr_mxM // -lock. + apply/eqP; move: (rAG z) (rAG t); rewrite /= -/dA def_dA => Az At. + by rewrite [Az]mx11_scalar scalar_mxC. +move: (kquo_repr _) (kquo_mx_faithful rAG) => /=; set K := rker _. +rewrite def_dA => r2G; move/der1_odd_GL2_charf; move/implyP. +rewrite quotient_odd //= -/G; apply: etrans; apply: eq_pgroup => p'. +have [p_pr _ _] := pgroup_pdiv pE ntE. +by rewrite (fmorph_char (gen_rmorphism _ _)) (charf_eq (char_Fp _)). +Qed. + +Section A5. + +Variables (gT : finGroupType) (p : nat) (G P X : {group gT}). + +Hypotheses (oddG : odd #|G|) (solG : solvable G) (pP : p.-group P). +Hypotheses (nsPG : P <| G) (sXG : X \subset G). +Hypotheses (genX : generated_by (p_norm_abelian p P) X). + +Let C := 'C_G(P). +Let defN : 'N_G(P) = G. Proof. by rewrite (setIidPl _) ?normal_norm. Qed. +Let nsCG : C <| G. Proof. by rewrite -defN subcent_normal. Qed. +Let nCG := normal_norm nsCG. +Let nCX := subset_trans sXG nCG. + +(* This is B & G, Theorem A.5.1; it does not depend on the solG assumption. *) +Theorem odd_abelian_gen_stable : X / C \subset 'O_p(G / C). +Proof. +case/exists_eqP: genX => gX defX. +rewrite -defN sub_quotient_pre // -defX gen_subG. +apply/bigcupsP=> A gX_A; have [_ pA nAP cAA] := and4P gX_A. +have{gX_A} sAX: A \subset X by rewrite -defX sub_gen ?bigcup_sup. +rewrite -sub_quotient_pre ?(subset_trans sAX nCX) //=. +rewrite odd_p_stable ?normalM ?pcore_normal //. + by rewrite /psubgroup pA defN (subset_trans sAX sXG). +by apply/commG1P; rewrite (subset_trans _ cAA) // commg_subr. +Qed. + +(* This is B & G, Theorem A.5.2. *) +Theorem odd_abelian_gen_constrained : + 'O_p^'(G) = 1 -> 'C_('O_p(G))(P) \subset P -> X \subset 'O_p(G). +Proof. +set Q := 'O_p(G) => p'G1 sCQ_P. +have sPQ: P \subset Q by rewrite pcore_max. +have defQ: 'O_{p^', p}(G) = Q by rewrite pseries_pop2. +have pQ: p.-group Q by exact: pcore_pgroup. +have sCQ: 'C_G(Q) \subset Q. + by rewrite -{2}defQ solvable_p_constrained //= defQ /pHall pQ indexgg subxx. +have pC: p.-group C. + apply/pgroupP=> q q_pr; case/Cauchy=> // u Cu q_u; apply/idPn=> p'q. + suff cQu: u \in 'C_G(Q). + case/negP: p'q; have{q_u}: q %| #[u] by rewrite q_u. + by apply: pnatP q q_pr => //; apply: mem_p_elt pQ _; exact: (subsetP sCQ). + have [Gu cPu] := setIP Cu; rewrite inE Gu /= -cycle_subG. + rewrite coprime_nil_faithful_cent_stab ?(pgroup_nil pQ) //= -/C -/Q. + - by rewrite cycle_subG; apply: subsetP Gu; rewrite normal_norm ?pcore_normal. + - by rewrite (pnat_coprime pQ) // [#|_|]q_u pnatE. + have sPcQu: P \subset 'C_Q(<[u]>) by rewrite subsetI sPQ centsC cycle_subG. + by apply: subset_trans (subset_trans sCQ_P sPcQu); rewrite setIS // centS. +rewrite -(quotientSGK nCX) ?pcore_max // -pquotient_pcore //. +exact: odd_abelian_gen_stable. +Qed. + +End A5. + +End AppendixA. + +Section AppendixB. + +Local Notation "X --> Y" := (generated_by (norm_abelian X) Y) + (at level 70, no associativity) : group_scope. + +Variable gT : finGroupType. +Implicit Types G H A : {group gT}. +Implicit Types D E : {set gT}. +Implicit Type p : nat. + +Lemma Puig_char G : 'L(G) \char G. +Proof. exact: gFchar. Qed. + +Lemma center_Puig_char G : 'Z('L(G)) \char G. +Proof. exact: char_trans (center_char _) (Puig_char _). Qed. + +(* This is B & G, Lemma B.1(a). *) +Lemma Puig_succS G D E : D \subset E -> 'L_[G](E) \subset 'L_[G](D). +Proof. +move=> sDE; apply: Puig_max (Puig_succ_sub _ _). +exact: norm_abgenS sDE (Puig_gen _ _). +Qed. + +(* This is part of B & G, Lemma B.1(b) (see also BGsection1.Puig1). *) +Lemma Puig_sub_even m n G : m <= n -> 'L_{m.*2}(G) \subset 'L_{n.*2}(G). +Proof. +move/subnKC <-; move: {n}(n - m)%N => n. +by elim: m => [|m IHm] /=; rewrite ?sub1G ?Puig_succS. +Qed. + +(* This is part of B & G, Lemma B.1(b). *) +Lemma Puig_sub_odd m n G : m <= n -> 'L_{n.*2.+1}(G) \subset 'L_{m.*2.+1}(G). +Proof. by move=> le_mn; rewrite Puig_succS ?Puig_sub_even. Qed. + +(* This is part of B & G, Lemma B.1(b). *) +Lemma Puig_sub_even_odd m n G : 'L_{m.*2}(G) \subset 'L_{n.*2.+1}(G). +Proof. +elim: n m => [|n IHn] m; first by rewrite Puig1 Puig_at_sub. +by case: m => [|m]; rewrite ?sub1G ?Puig_succS ?IHn. +Qed. + +(* This is B & G, Lemma B.1(c). *) +Lemma Puig_limit G : + exists m, forall k, m <= k -> + 'L_{k.*2}(G) = 'L_*(G) /\ 'L_{k.*2.+1}(G) = 'L(G). +Proof. +pose L2G m := 'L_{m.*2}(G); pose n := #|G|. +have []: #|L2G n| <= n /\ n <= n by rewrite subset_leq_card ?Puig_at_sub. +elim: {1 2 3}n => [| m IHm leLm1 /ltnW]; first by rewrite leqNgt cardG_gt0. +have [eqLm le_mn|] := eqVneq (L2G m.+1) (L2G m); last first. + rewrite eq_sym eqEcard Puig_sub_even ?leqnSn // -ltnNge => lt_m1_m. + exact: IHm (leq_trans lt_m1_m leLm1). +have{eqLm} eqLm k: m <= k -> 'L_{k.*2}(G) = L2G m. + rewrite leq_eqVlt => /predU1P[-> // |]; elim: k => // k IHk. + by rewrite leq_eqVlt => /predU1P[<- //| ltmk]; rewrite -eqLm !PuigS IHk. +by exists m => k le_mk; rewrite Puig_def PuigS /Puig_inf /= !eqLm. +Qed. + +(* This is B & G, Lemma B.1(d), second part; the first part is covered by *) +(* BGsection1.Puig_inf_sub. *) +Lemma Puig_inf_sub_Puig G : 'L_*(G) \subset 'L(G). +Proof. exact: Puig_sub_even_odd. Qed. + +(* This is B & G, Lemma B.1(e). *) +Lemma abelian_norm_Puig n G A : + n > 0 -> abelian A -> A <| G -> A \subset 'L_{n}(G). +Proof. +case: n => // n _ cAA /andP[sAG nAG]. +rewrite PuigS sub_gen // bigcup_sup // inE sAG /norm_abelian cAA andbT. +exact: subset_trans (Puig_at_sub n G) nAG. +Qed. + +(* This is B & G, Lemma B.1(f), first inclusion. *) +Lemma sub_cent_Puig_at n p G : + n > 0 -> p.-group G -> 'C_G('L_{n}(G)) \subset 'L_{n}(G). +Proof. +move=> n_gt0 pG. +have /ex_maxgroup[M /(max_SCN pG)SCN_M]: exists M, (gval M <| G) && abelian M. + by exists 1%G; rewrite normal1 abelian1. +have{SCN_M} [cMM [nsMG defCM]] := (SCN_abelian SCN_M, SCN_P SCN_M). +have sML: M \subset 'L_{n}(G) by apply: abelian_norm_Puig. +by apply: subset_trans (sML); rewrite -defCM setIS // centS. +Qed. + +(* This is B & G, Lemma B.1(f), second inclusion. *) +Lemma sub_center_cent_Puig_at n G : 'Z(G) \subset 'C_G('L_{n}(G)). +Proof. by rewrite setIS ?centS ?Puig_at_sub. Qed. + +(* This is B & G, Lemma B.1(f), third inclusion (the fourth is trivial). *) +Lemma sub_cent_Puig_inf p G : p.-group G -> 'C_G('L_*(G)) \subset 'L_*(G). +Proof. by apply: sub_cent_Puig_at; rewrite double_gt0. Qed. + +(* This is B & G, Lemma B.1(f), fifth inclusion (the sixth is trivial). *) +Lemma sub_cent_Puig p G : p.-group G -> 'C_G('L(G)) \subset 'L(G). +Proof. exact: sub_cent_Puig_at. Qed. + +(* This is B & G, Lemma B.1(f), final remark (we prove the contrapositive). *) +Lemma trivg_center_Puig_pgroup p G : p.-group G -> 'Z('L(G)) = 1 -> G :=: 1. +Proof. +move=> pG LG1; apply/(trivg_center_pgroup pG)/trivgP. +rewrite -(trivg_center_pgroup (pgroupS (Puig_sub _) pG) LG1). +by apply: subset_trans (sub_cent_Puig pG); apply: sub_center_cent_Puig_at. +Qed. + +(* This is B & G, Lemma B.1(g), second part; the first part is simply the *) +(* definition of 'L(G) in terms of 'L_*(G). *) +Lemma Puig_inf_def G : 'L_*(G) = 'L_[G]('L(G)). +Proof. +have [k defL] := Puig_limit G. +by case: (defL k) => // _ <-; case: (defL k.+1) => [|<- //]; apply: leqnSn. +Qed. + +(* This is B & G, Lemma B.2. *) +Lemma sub_Puig_eq G H : H \subset G -> 'L(G) \subset H -> 'L(H) = 'L(G). +Proof. +move=> sHG sLG_H; apply/setP/subset_eqP/andP. +have sLH_G := subset_trans (Puig_succ_sub _ _) sHG. +have gPuig := norm_abgenS _ (Puig_gen _ _). +have [[kG defLG] [kH defLH]] := (Puig_limit G, Puig_limit H). +have [/defLG[_ {1}<-] /defLH[_ <-]] := (leq_maxl kG kH, leq_maxr kG kH). +split; do [elim: (maxn _ _) => [|k IHk /=]; first by rewrite !Puig1]. + rewrite doubleS !(PuigS _.+1) Puig_max ?gPuig // Puig_max ?gPuig //. + exact: subset_trans (Puig_sub_even_odd _.+1 _ _) sLG_H. +rewrite doubleS Puig_max // -!PuigS Puig_def gPuig //. +by rewrite Puig_inf_def Puig_max ?gPuig ?sLH_G. +Qed. + +Lemma norm_abgen_pgroup p X G : + p.-group G -> X --> G -> generated_by (p_norm_abelian p X) G. +Proof. +move=> pG /exists_eqP[gG defG]. +have:= subxx G; rewrite -{1 3}defG gen_subG /= => /bigcupsP-sGG. +apply/exists_eqP; exists gG; congr <<_>>; apply: eq_bigl => A. +by rewrite andbA andbAC andb_idr // => /sGG/pgroupS->. +Qed. + +Variables (p : nat) (G S : {group gT}). +Hypotheses (oddG : odd #|G|) (solG : solvable G) (sylS : p.-Sylow(G) S). +Hypothesis p'G1 : 'O_p^'(G) = 1. + +Let T := 'O_p(G). +Let nsTG : T <| G := pcore_normal _ _. +Let pT : p.-group T := pcore_pgroup _ _. +Let pS : p.-group S := pHall_pgroup sylS. +Let sSG := pHall_sub sylS. + +(* This is B & G, Lemma B.3. *) +Lemma pcore_Sylow_Puig_sub : 'L_*(S) \subset 'L_*(T) /\ 'L(T) \subset 'L(S). +Proof. +have [[kS defLS] [kT defLT]] := (Puig_limit S, Puig_limit [group of T]). +have [/defLS[<- <-] /defLT[<- <-]] := (leq_maxl kS kT, leq_maxr kS kT). +have sL_ := subset_trans (Puig_succ_sub _ _). +elim: (maxn kS kT) => [|k [_ sL1]]; first by rewrite !Puig1 pcore_sub_Hall. +have{sL1} gL: 'L_{k.*2.+1}(T) --> 'L_{k.*2.+2}(S). + exact: norm_abgenS sL1 (Puig_gen _ _). +have sCT_L: 'C_T('L_{k.*2.+1}(T)) \subset 'L_{k.*2.+1}(T). + exact: sub_cent_Puig_at pT. +have{sCT_L} sLT: 'L_{k.*2.+2}(S) \subset T. + apply: odd_abelian_gen_constrained sCT_L => //. + - exact: pgroupS (Puig_at_sub _ _) pT. + - by apply: char_normal_trans nsTG; apply: gFchar. + - exact: sL_ sSG. + by rewrite norm_abgen_pgroup // (pgroupS _ pS) ?Puig_at_sub. +have sL2: 'L_{k.*2.+2}(S) \subset 'L_{k.*2.+2}(T) by apply: Puig_max. +split; [exact: sL2 | rewrite doubleS; apply: subset_trans (Puig_succS _ sL2) _]. +by rewrite Puig_max -?PuigS ?Puig_gen // sL_ // pcore_sub_Hall. +Qed. + +Let Y := 'Z('L(T)). +Let L := 'L(S). + +(* This is B & G, Theorem B.4(b). *) +Theorem Puig_center_normal : 'Z(L) <| G. +Proof. +have [sLiST sLTS] := pcore_Sylow_Puig_sub. +have sLiLT: 'L_*(T) \subset 'L(T) by exact: Puig_sub_even_odd. +have sZY: 'Z(L) \subset Y. + rewrite subsetI andbC subIset ?centS ?orbT //=. + suffices: 'C_S('L_*(S)) \subset 'L(T). + by apply: subset_trans; rewrite setISS ?Puig_sub ?centS ?Puig_sub_even_odd. + apply: subset_trans (subset_trans sLiST sLiLT). + by apply: sub_cent_Puig_at pS; rewrite double_gt0. +have chY: Y \char G := char_trans (center_Puig_char _) (pcore_char _ _). +have nsCY_G: 'C_G(Y) <| G by rewrite char_normal 1?subcent_char ?char_refl. +have [C defC sCY_C nsCG] := inv_quotientN nsCY_G (pcore_normal p _). +have sLG: L \subset G by rewrite (subset_trans _ (pHall_sub sylS)) ?Puig_sub. +have nsL_nCS: L <| 'N_G(C :&: S). + have sYLiS: Y \subset 'L_*(S). + rewrite abelian_norm_Puig ?double_gt0 ?center_abelian //. + apply: normalS (pHall_sub sylS) (char_normal chY). + by rewrite subIset // (subset_trans sLTS) ?Puig_sub. + have gYL: Y --> L := norm_abgenS sYLiS (Puig_gen _ _). + have sLCS: L \subset C :&: S. + rewrite subsetI Puig_sub andbT. + rewrite -(quotientSGK _ sCY_C) ?(subset_trans sLG) ?normal_norm // -defC. + rewrite odd_abelian_gen_stable ?char_normal ?norm_abgen_pgroup //. + by rewrite (pgroupS _ pT) ?subIset // Puig_sub. + by rewrite (pgroupS _ pS) ?Puig_sub. + rewrite -[L](sub_Puig_eq _ sLCS) ?subsetIr //. + by rewrite (char_normal_trans (Puig_char _)) ?normalSG // subIset // sSG orbT. +have sylCS: p.-Sylow(C) (C :&: S) := Sylow_setI_normal nsCG sylS. +have{defC} defC: 'C_G(Y) * (C :&: S) = C. + apply/eqP; rewrite eqEsubset mulG_subG sCY_C subsetIl /=. + have nCY_C: C \subset 'N('C_G(Y)). + exact: subset_trans (normal_sub nsCG) (normal_norm nsCY_G). + rewrite -quotientSK // -defC /= -pseries1. + rewrite -(pseries_catr_id [:: p : nat_pred]) (pseries_rcons_id [::]) /=. + rewrite pseries1 /= pseries1 defC pcore_sub_Hall // morphim_pHall //. + by rewrite subIset ?nCY_C. +have defG: 'C_G(Y) * 'N_G(C :&: S) = G. + have sCS_N: C :&: S \subset 'N_G(C :&: S). + by rewrite subsetI normG subIset // sSG orbT. + by rewrite -(mulSGid sCS_N) mulgA defC (Frattini_arg _ sylCS). +have nsZ_N: 'Z(L) <| 'N_G(C :&: S) := char_normal_trans (center_char _) nsL_nCS. +rewrite /normal subIset ?sLG //= -{1}defG mulG_subG /=. +rewrite cents_norm ?normal_norm // centsC. +by rewrite (subset_trans sZY) // centsC subsetIr. +Qed. + +End AppendixB. + +Section Puig_factorization. + +Variables (gT : finGroupType) (p : nat) (G S : {group gT}). +Hypotheses (oddG : odd #|G|) (solG : solvable G) (sylS : p.-Sylow(G) S). + +(* This is B & G, Theorem B.4(a). *) +Theorem Puig_factorization : 'O_p^'(G) * 'N_G('Z('L(S))) = G. +Proof. +set D := 'O_p^'(G); set Z := 'Z(_); have [sSG pS _] := and3P sylS. +have sSN: S \subset 'N(D) by rewrite (subset_trans sSG) ?gFnorm. +have p'D: p^'.-group D := pcore_pgroup _ _. +have tiSD: S :&: D = 1 := coprime_TIg (pnat_coprime pS p'D). +have def_Zq: Z / D = 'Z('L(S / D)). + rewrite !quotientE -(setIid S) -(morphim_restrm sSN); set f := restrm _ _. + have injf: 'injm f by rewrite ker_restrm ker_coset tiSD. + rewrite -!(injmF _ injf) ?Puig_sub //= morphim_restrm. + by rewrite (setIidPr _) // subIset ?Puig_sub. +have{def_Zq} nZq: Z / D <| G / D. + have sylSq: p.-Sylow(G / D) (S / D) by exact: morphim_pHall. + rewrite def_Zq (Puig_center_normal _ _ sylSq) ?quotient_odd ?quotient_sol //. + exact: trivg_pcore_quotient. +have sZS: Z \subset S by rewrite subIset ?Puig_sub. +have sZN: Z \subset 'N_G(Z) by rewrite subsetI normG (subset_trans sZS). +have nDZ: Z \subset 'N(D) by rewrite (subset_trans sZS). +rewrite -(mulSGid sZN) mulgA -(norm_joinEr nDZ) (@Frattini_arg p) //= -/D -/Z. + rewrite -cosetpre_normal quotientK ?quotientGK ?pcore_normal // in nZq. + by rewrite norm_joinEr. +rewrite /pHall -divgS joing_subr ?(pgroupS sZS) /= ?norm_joinEr //= -/Z. +by rewrite TI_cardMg ?mulnK //; apply/trivgP; rewrite /= setIC -tiSD setSI. +Qed. + +End Puig_factorization. + + + + + diff --git a/mathcomp/odd_order/BGappendixC.v b/mathcomp/odd_order/BGappendixC.v new file mode 100644 index 0000000..31bccfb --- /dev/null +++ b/mathcomp/odd_order/BGappendixC.v @@ -0,0 +1,749 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype choice ssrnat seq div fintype. +Require Import tuple finfun bigop ssralg finset prime binomial poly polydiv. +Require Import fingroup morphism quotient automorphism action finalg zmodp. +Require Import gproduct cyclic commutator pgroup abelian frobenius BGsection1. +Require Import matrix mxalgebra mxabelem vector falgebra fieldext galois. +Require Import finfield ssrnum algC classfun character integral_char inertia. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory FinRing.Theory Num.Theory. +Local Open Scope ring_scope. + +Section AppendixC. + +Variables (gT : finGroupType) (p q : nat) (H P P0 U Q : {group gT}). +Let nU := ((p ^ q).-1 %/ p.-1)%N. + +(* External statement of the finite field assumption. *) +CoInductive finFieldImage : Prop := + FinFieldImage (F : finFieldType) (sigma : {morphism P >-> F}) of + isom P [set: F] sigma & sigma @*^-1 <[1 : F]> = P0 + & exists2 sigmaU : {morphism U >-> {unit F}}, + 'injm sigmaU & {in P & U, morph_act 'J 'U sigma sigmaU}. + +(* These correspond to hypothesis (A) of B & G, Appendix C, Theorem C. *) +Hypotheses (pr_p : prime p) (pr_q : prime q) (coUp1 : coprime nU p.-1). +Hypotheses (defH : P ><| U = H) (fieldH : finFieldImage). +Hypotheses (oP : #|P| = (p ^ q)%N) (oU : #|U| = nU). + +(* These correspond to hypothesis (B) of B & G, Appendix C, Theorem C. *) +Hypotheses (abelQ : q.-abelem Q) (nQP0 : P0 \subset 'N(Q)). +Hypothesis nU_P0Q : exists2 y, y \in Q & P0 :^ y \subset 'N(U). + +Section ExpandHypotheses. + +(* Negation of the goal of B & G, Appendix C, Theorem C. *) +Hypothesis ltqp : (q < p)%N. + +(* From the fieldH assumption. *) +Variables (fT : finFieldType) (charFp : p \in [char fT]). +Local Notation F := (PrimeCharType charFp). +Local Notation galF := [splittingFieldType 'F_p of F]. +Let Fpq : {vspace F} := fullv. +Let Fp : {vspace F} := 1%VS. + +Hypothesis oF : #|F| = (p ^ q)%N. +Let oF_p : #|'F_p| = p. Proof. exact: card_Fp. Qed. +Let oFp : #|Fp| = p. Proof. by rewrite card_vspace1. Qed. +Let oFpq : #|Fpq| = (p ^ q)%N. Proof. by rewrite card_vspacef. Qed. +Let dimFpq : \dim Fpq = q. Proof. by rewrite primeChar_dimf oF pfactorK. Qed. + +Variables (sigma : {morphism P >-> F}) (sigmaU : {morphism U >-> {unit F}}). +Hypotheses (inj_sigma : 'injm sigma) (inj_sigmaU : 'injm sigmaU). +Hypothesis im_sigma : sigma @* P = [set: F]. +Variable s : gT. +Hypotheses (sP0P : P0 \subset P) (sigma_s : sigma s = 1) (defP0 : <[s]> = P0). + +Let psi u : F := val (sigmaU u). +Let inj_psi : {in U &, injective psi}. +Proof. by move=> u v Uu Uv /val_inj/(injmP inj_sigmaU)->. Qed. + +Hypothesis sigmaJ : {in P & U, forall x u, sigma (x ^ u) = sigma x * psi u}. + +Let Ps : s \in P. Proof. by rewrite -cycle_subG defP0. Qed. +Let P0s : s \in P0. Proof. by rewrite -defP0 cycle_id. Qed. + +Let nz_psi u : psi u != 0. Proof. by rewrite -unitfE (valP (sigmaU u)). Qed. + +Let sigma1 : sigma 1%g = 0. Proof. exact: morph1. Qed. +Let sigmaM : {in P &, {morph sigma : x1 x2 / (x1 * x2)%g >-> x1 + x2}}. +Proof. exact: morphM. Qed. +Let sigmaV : {in P, {morph sigma : x / x^-1%g >-> - x}}. +Proof. exact: morphV. Qed. +Let sigmaX n : {in P, {morph sigma : x / (x ^+ n)%g >-> x *+ n}}. +Proof. exact: morphX. Qed. + +Let psi1 : psi 1%g = 1. Proof. by rewrite /psi morph1. Qed. +Let psiM : {in U &, {morph psi : u1 u2 / (u1 * u2)%g >-> u1 * u2}}. +Proof. by move=> u1 u2 Uu1 Uu2; rewrite /psi morphM. Qed. +Let psiV : {in U, {morph psi : u / u^-1%g >-> u^-1}}. +Proof. by move=> u Uu; rewrite /psi morphV. Qed. +Let psiX n : {in U, {morph psi : u / (u ^+ n)%g >-> u ^+ n}}. +Proof. by move=> u Uu; rewrite /psi morphX // val_unitX. Qed. + +Let sigmaE := (sigma1, sigma_s, mulr1, mul1r, + (sigmaJ, sigmaX, sigmaM, sigmaV), (psi1, psiX, psiM, psiV)). + +Let psiE u : u \in U -> psi u = sigma (s ^ u). +Proof. by move=> Uu; rewrite !sigmaE. Qed. + +Let nPU : U \subset 'N(P). Proof. by have [] := sdprodP defH. Qed. +Let memJ_P : {in P & U, forall x u, x ^ u \in P}. +Proof. by move=> x u Px Uu; rewrite /= memJ_norm ?(subsetP nPU). Qed. +Let in_PU := (memJ_P, in_group). + +Let sigmaP0 : sigma @* P0 =i Fp. +Proof. +rewrite -defP0 morphim_cycle // sigma_s => x. +apply/cycleP/vlineP=> [] [n ->]; first by exists n%:R; rewrite scaler_nat. +by exists (val n); rewrite -{1}[n]natr_Zp -in_algE rmorph_nat zmodXgE. +Qed. + +Let nt_s : s != 1%g. +Proof. by rewrite -(morph_injm_eq1 inj_sigma) // sigmaE oner_eq0. Qed. + +Let p_gt0 : (0 < p)%N. Proof. exact: prime_gt0. Qed. +Let q_gt0 : (0 < q)%N. Proof. exact: prime_gt0. Qed. +Let p1_gt0 : (0 < p.-1)%N. Proof. by rewrite -subn1 subn_gt0 prime_gt1. Qed. + +(* This is B & G, Appendix C, Remark I. *) +Let not_dvd_q_p1 : ~~ (q %| p.-1)%N. +Proof. +rewrite -prime_coprime // -[q]card_ord -sum1_card -coprime_modl -modn_summ. +have:= coUp1; rewrite /nU predn_exp mulKn //= -coprime_modl -modn_summ. +congr (coprime (_ %% _) _); apply: eq_bigr => i _. +by rewrite -{1}[p](subnK p_gt0) subn1 -modnXm modnDl modnXm exp1n. +Qed. + +(* This is the first assertion of B & G, Appendix C, Remark V. *) +Let odd_p : odd p. +Proof. +by apply: contraLR ltqp => /prime_oddPn-> //; rewrite -leqNgt prime_gt1. +Qed. + +(* This is the second assertion of B & G, Appendix C, Remark V. *) +Let odd_q : odd q. +Proof. +apply: contraR not_dvd_q_p1 => /prime_oddPn-> //. +by rewrite -subn1 dvdn2 odd_sub ?odd_p. +Qed. + +Let qgt2 : (2 < q)%N. Proof. by rewrite odd_prime_gt2. Qed. +Let pgt4 : (4 < p)%N. Proof. by rewrite odd_geq ?(leq_ltn_trans qgt2). Qed. +Let qgt1 : (1 < q)%N. Proof. exact: ltnW. Qed. + +Local Notation Nm := (galNorm Fp Fpq). +Local Notation uval := (@FinRing.uval _). + +Let cycFU (FU : {group {unit F}}) : cyclic FU. +Proof. exact: field_unit_group_cyclic. Qed. +Let cUU : abelian U. +Proof. by rewrite cyclic_abelian // -(injm_cyclic inj_sigmaU) ?cycFU. Qed. + +(* This is B & G, Appendix C, Remark VII. *) +Let im_psi (x : F) : (x \in psi @: U) = (Nm x == 1). +Proof. +have /cyclicP[u0 defFU]: cyclic [set: {unit F}] by exact: cycFU. +have o_u0: #[u0] = (p ^ q).-1 by rewrite orderE -defFU card_finField_unit oF. +have ->: psi @: U = uval @: (sigmaU @* U) by rewrite morphimEdom -imset_comp. +have /set1P[->]: (sigmaU @* U)%G \in [set <[u0 ^+ (#[u0] %/ nU)]>%G]. + rewrite -cycle_sub_group ?inE; last first. + by rewrite o_u0 -(divnK (dvdn_pred_predX p q)) dvdn_mulr. + by rewrite -defFU subsetT card_injm //= oU. +rewrite divnA ?dvdn_pred_predX // -o_u0 mulKn //. +have [/= alpha alpha_gen Dalpha] := finField_galois_generator (subvf Fp). +have{Dalpha} Dalpha x1: x1 != 0 -> x1 / alpha x1 = x1^-1 ^+ p.-1. + move=> nz_x1; rewrite -[_ ^+ _](mulVKf nz_x1) -exprS Dalpha ?memvf // exprVn. + by rewrite dimv1 oF_p prednK ?prime_gt0. +apply/idP/(Hilbert's_theorem_90 alpha_gen (memvf _)) => [|[u [_ nz_u] ->]]. + case/imsetP=> /= _ /cycleP[n ->] ->; rewrite expgAC; set u := (u0 ^+ n)%g. + have nz_u: (val u)^-1 != 0 by rewrite -unitfE unitrV (valP u). + by exists (val u)^-1; rewrite ?memvf ?Dalpha //= invrK val_unitX. +have /cycleP[n Du]: (insubd u0 u)^-1%g \in <[u0]> by rewrite -defFU inE. +have{Du} Du: u^-1 = val (u0 ^+ n)%g by rewrite -Du /= insubdK ?unitfE. +by rewrite Dalpha // Du -val_unitX mem_imset // expgAC mem_cycle. +Qed. + +(* This is B & G, Appendix C, Remark VIII. *) +Let defFU : sigmaU @* U \x [set u | uval u \in Fp] = [set: {unit F}]. +Proof. +have fP v: in_alg F (uval v) \is a GRing.unit by rewrite rmorph_unit ?(valP v). +pose f (v : {unit 'F_p}) := FinRing.unit F (fP v). +have fM: {in setT &, {morph f: v1 v2 / (v1 * v2)%g}}. + by move=> v1 v2 _ _; apply: val_inj; rewrite /= -in_algE rmorphM. +pose galFpU := Morphism fM @* [set: {unit 'F_p}]. +have ->: [set u | uval u \in Fp] = galFpU. + apply/setP=> u; rewrite inE /galFpU morphimEdom. + apply/idP/imsetP=> [|[v _ ->]]; last by rewrite /= rpredZ // memv_line. + case/vlineP=> v Du; have nz_v: v != 0. + by apply: contraTneq (valP u) => v0; rewrite unitfE /= Du v0 scale0r eqxx. + exists (insubd (1%g : {unit 'F_p}) v); rewrite ?inE //. + by apply: val_inj; rewrite /= insubdK ?unitfE. +have oFpU: #|galFpU| = p.-1. + rewrite card_injm ?card_finField_unit ?oF_p //. + by apply/injmP=> v1 v2 _ _ []/(fmorph_inj [rmorphism of in_alg F])/val_inj. +have oUU: #|sigmaU @* U| = nU by rewrite card_injm. +rewrite dprodE ?coprime_TIg ?oUU ?oFpU //; last first. + by rewrite (sub_abelian_cent2 (cyclic_abelian (cycFU [set: _]))) ?subsetT. +apply/eqP; rewrite eqEcard subsetT coprime_cardMg oUU oFpU //=. +by rewrite card_finField_unit oF divnK ?dvdn_pred_predX. +Qed. + +(* This is B & G, Appendix C, Remark IX. *) +Let frobH : [Frobenius H = P ><| U]. +Proof. +apply/Frobenius_semiregularP=> // [||u /setD1P[ntu Uu]]. +- by rewrite -(morphim_injm_eq1 inj_sigma) // im_sigma finRing_nontrivial. +- rewrite -cardG_gt1 oU ltn_divRL ?dvdn_pred_predX // mul1n -!subn1. + by rewrite ltn_sub2r ?(ltn_exp2l 0) ?(ltn_exp2l 1) ?prime_gt1. +apply/trivgP/subsetP=> x /setIP[Px /cent1P/commgP]. +rewrite inE -!(morph_injm_eq1 inj_sigma) ?(sigmaE, in_PU) //. +rewrite -mulrN1 addrC -mulrDr mulf_eq0 subr_eq0 => /orP[] // /idPn[]. +by rewrite (inj_eq val_inj (sigmaU u) 1%g) morph_injm_eq1. +Qed. + +(* From the abelQ assumption of Peterfalvi, Theorem (14.2) to the assumptions *) +(* of part (B) of the assumptions of Theorem C. *) +Let p'q : q != p. Proof. by rewrite ltn_eqF. Qed. +Let cQQ : abelian Q. Proof. exact: abelem_abelian abelQ. Qed. +Let p'Q : p^'.-group Q. Proof. exact: pi_pgroup (abelem_pgroup abelQ) _. Qed. + +Let pP : p.-group P. Proof. by rewrite /pgroup oP pnat_exp ?pnat_id. Qed. +Let coQP : coprime #|Q| #|P|. Proof. exact: p'nat_coprime p'Q pP. Qed. +Let sQP0Q : [~: Q, P0] \subset Q. Proof. by rewrite commg_subl. Qed. + +(* This is B & G, Appendix C, Remark X. *) +Let defQ : 'C_Q(P0) \x [~: Q, P0] = Q. +Proof. by rewrite dprodC coprime_abelian_cent_dprod // (coprimegS sP0P). Qed. + +(* This is B & G, Appendix C, Remark XI. *) +Let nU_P0QP0 : exists2 y, y \in [~: Q, P0] & P0 :^ y \subset 'N(U). +Proof. +have [_ /(mem_dprod defQ)[z [y [/setIP[_ cP0z] QP0y -> _]]]] := nU_P0Q. +by rewrite conjsgM (normsP (cent_sub P0)) //; exists y. +Qed. + +Let E := [set x : galF | Nm x == 1 & Nm (2%:R - x) == 1]. + +Let E_1 : 1 \in E. +Proof. by rewrite !inE -addrA subrr addr0 galNorm1 eqxx. Qed. + +(* This is B & G, Appendix C, Lemma C.1. *) +Let Einv_gt1_le_pq : E = [set x^-1 | x in E] -> (1 < #|E|)%N -> (p <= q)%N. +Proof. +rewrite (cardsD1 1) E_1 ltnS card_gt0 => Einv /set0Pn[/= a /setD1P[not_a1 Ea]]. +pose tau (x : F) := (2%:R - x)^-1. +have Etau x: x \in E -> tau x \in E. + rewrite inE => Ex; rewrite Einv (mem_imset (fun y => y^-1)) //. + by rewrite inE andbC opprD addNKr opprK. +pose Pa := \prod_(beta in 'Gal(Fpq / Fp)) (beta (1 - a) *: 'X + 1). +have galPoly_roots: all (root (Pa - 1)) (enum Fp). + apply/allP=> x; rewrite mem_enum => /vlineP[b ->]. + rewrite rootE !hornerE horner_prod subr_eq0 /=; apply/eqP. + pose h k := (1 - a) *+ k + 1; transitivity (Nm (h b)). + apply: eq_bigr => beta _; rewrite !(rmorphB, rmorphD, rmorphMn) rmorph1 /=. + by rewrite -mulr_natr -scaler_nat natr_Zp hornerD hornerZ hornerX hornerC. + elim: (b : nat) => [|k IHk]; first by rewrite /h add0r galNorm1. + suffices{IHk}: h k / h k.+1 \in E. + rewrite inE -invr_eq1 => /andP[/eqP <- _]. + by rewrite galNormM galNormV /= [galNorm _ _ (h k)]IHk mul1r invrK. + elim: k => [|k IHk]; first by rewrite /h add0r mul1r addrAC Etau. + have nz_hk1: h k.+1 != 0. + apply: contraTneq IHk => ->; rewrite invr0 mulr0. + by rewrite inE galNorm0 eq_sym oner_eq0. + congr (_ \in E): (Etau _ IHk); apply: canLR (@invrK _) _; rewrite invfM invrK. + apply: canRL (mulKf nz_hk1) _; rewrite mulrC mulrBl divfK // mulrDl mul1r. + by rewrite {2}/h mulrS -2!addrA addrK addrAC -mulrSr. +have sizePa: size Pa = q.+1. + have sizePaX (beta : {rmorphism F -> F}) : size (beta (1 - a) *: 'X + 1) = 2. + rewrite -mul_polyC size_MXaddC oner_eq0 andbF size_polyC fmorph_eq0. + by rewrite subr_eq0 eq_sym (negbTE not_a1). + rewrite size_prod => [|i _]; last by rewrite -size_poly_eq0 sizePaX. + rewrite (eq_bigr (fun _ => 2)) => [|beta _]; last by rewrite sizePaX. + rewrite sum_nat_const muln2 -addnn -addSn addnK. + by rewrite -galois_dim ?finField_galois ?subvf // dimv1 divn1 dimFpq. +have sizePa1: size (Pa - 1) = q.+1. + by rewrite size_addl // size_opp size_poly1 sizePa. +have nz_Pa1 : Pa - 1 != 0 by rewrite -size_poly_eq0 sizePa1. +by rewrite -ltnS -oFp -sizePa1 cardE max_poly_roots ?enum_uniq. +Qed. + +(* This is B & G, Appendix C, Lemma C.2. *) +Let E_gt1 : (1 < #|E|)%N. +Proof. +have [q_gt4 | q_le4] := ltnP 4 q. + pose inK x := enum_rank_in (classes1 H) (x ^: H). + have inK_E x: x \in H -> enum_val (inK x) = x ^: H. + by move=> Hx; rewrite enum_rankK_in ?mem_classes. + pose j := inK s; pose k := inK (s ^+ 2)%g; pose e := gring_classM_coef j j k. + have cPP: abelian P by rewrite -(injm_abelian inj_sigma) ?zmod_abelian. + have Hs: s \in H by rewrite -(sdprodW defH) -[s]mulg1 mem_mulg. + have DsH n: (s ^+ n) ^: H = (s ^+ n) ^: U. + rewrite -(sdprodW defH) classM (abelian_classP _ cPP) ?groupX //. + by rewrite class_support_set1l. + have injJU: {in U &, injective (conjg s)}. + by move=> u v Uu Uv eq_s_uv; apply/inj_psi; rewrite ?psiE ?eq_s_uv. + have ->: #|E| = e. + rewrite /e /gring_classM_coef !inK_E ?groupX //. + transitivity #|[set u in U | s^-1 ^ u * s ^+ 2 \in s ^: U]%g|. + rewrite -(card_in_imset (sub_in2 _ inj_psi)) => [|u /setIdP[] //]. + apply: eq_card => x; rewrite inE -!im_psi. + apply/andP/imsetP=> [[/imsetP[u Uu ->] /imsetP[v Uv Dv]]{x} | ]. + exists u; rewrite // inE Uu /=; apply/imsetP; exists v => //. + by apply: (injmP inj_sigma); rewrite ?(sigmaE, in_PU) // mulN1r addrC. + case=> u /setIdP[Uu /imsetP[v Uv /(congr1 sigma)]]. + rewrite ?(sigmaE, in_PU) // mulN1r addrC => Dv ->. + by rewrite Dv !mem_imset. + rewrite DsH (DsH 1%N) expg1; have [w Uw ->] := repr_class U (s ^+ 2). + pose f u := (s ^ (u * w), (s^-1 ^ u * s ^+ 2) ^ w). + rewrite -(@card_in_imset _ _ f) => [|u v]; last first. + by move=> /setIdP[Uu _] /setIdP[Uv _] [/injJU/mulIg-> //]; apply: groupM. + apply: eq_card => [[x1 x2]]; rewrite inE -andbA. + apply/imsetP/and3P=> [[u /setIdP[Uu sUs2u'] [-> ->]{x1 x2}] | []]. + rewrite /= conjgM -(rcoset_id Uw) class_rcoset !memJ_conjg mem_orbit //. + by rewrite sUs2u' -conjMg conjVg mulKVg. + case/imsetP=> u Uu /= -> sUx2 /eqP/(canRL (mulKg _)) Dx2. + exists (u * w^-1)%g; last first. + by rewrite /f /= conjMg -conjgM mulgKV conjVg -Dx2. + rewrite inE !in_PU // Uw -(memJ_conjg _ w) -class_rcoset rcoset_id //. + by rewrite conjMg -conjgM mulgKV conjVg -Dx2. + pose chi_s2 i := 'chi[H]_i s ^+ 2 * ('chi_i (s ^+ 2)%g)^* / 'chi_i 1%g. + have De: e%:R = #|U|%:R / #|P|%:R * (\sum_i chi_s2 i). + have Ks: s \in enum_val j by rewrite inK_E ?class_refl. + have Ks2: (s ^+ 2)%g \in enum_val k by rewrite inK_E ?groupX ?class_refl. + rewrite (gring_classM_coef_sum_eq Ks Ks Ks2) inK_E //; congr (_ * _). + have ->: #|s ^: H| = #|U| by rewrite (DsH 1%N) (card_in_imset injJU). + by rewrite -(sdprod_card defH) mulnC !natrM invfM mulrA mulfK ?neq0CG. + pose linH := [pred i | P \subset cfker 'chi[H]_i]. + have nsPH: P <| H by have [] := sdprod_context defH. + have sum_linH: \sum_(i in linH) chi_s2 i = #|U|%:R. + have isoU: U \isog H / P := sdprod_isog defH. + have abHbar: abelian (H / P) by rewrite -(isog_abelian isoU). + rewrite (card_isog isoU) -(card_Iirr_abelian abHbar) -sumr_const. + rewrite (reindex _ (mod_Iirr_bij nsPH)) /chi_s2 /=. + apply: eq_big => [i | i _]; rewrite ?mod_IirrE ?cfker_mod //. + have lin_i: ('chi_i %% P)%CF \is a linear_char. + exact/cfMod_lin_char/char_abelianP. + rewrite lin_char1 // divr1 -lin_charX // -normCK. + by rewrite normC_lin_char ?groupX ?expr1n. + have degU i: i \notin linH -> 'chi_i 1%g = #|U|%:R. + case/(Frobenius_Ind_irrP (FrobeniusWker frobH)) => {i}i _ ->. + rewrite cfInd1 ?normal_sub // -(index_sdprod defH) lin_char1 ?mulr1 //. + exact/char_abelianP. + have ub_linH' m (s_m := (s ^+ m)%g): + (0 < m < 5)%N -> \sum_(i in predC linH) `|'chi_i s_m| ^+ 2 <= #|P|%:R. + - case/andP=> m_gt0 m_lt5; have{m_gt0 m_lt5} P1sm: s_m \in P^#. + rewrite !inE groupX // -order_dvdn -(order_injm inj_sigma) // sigmaE. + by rewrite andbT order_primeChar ?oner_neq0 ?gtnNdvd ?(leq_trans m_lt5). + have ->: #|P| = (#|P| * (s_m \in s_m ^: H))%N by rewrite class_refl ?muln1. + have{P1sm} /eqP <-: 'C_H[s ^+ m] == P. + rewrite eqEsubset (Frobenius_cent1_ker frobH) // subsetI normal_sub //=. + by rewrite sub_cent1 groupX // (subsetP cPP). + rewrite mulrnA -second_orthogonality_relation ?groupX // big_mkcond. + by apply: ler_sum => i _; rewrite normCK; case: ifP; rewrite ?mul_conjC_ge0. + have sqrtP_gt0: 0 < sqrtC #|P|%:R by rewrite sqrtC_gt0 ?gt0CG. + have{De ub_linH'}: `|(#|P| * e)%:R - #|U|%:R ^+ 2| <= #|P|%:R * sqrtC #|P|%:R. + rewrite natrM De mulrCA mulrA divfK ?neq0CG // (bigID linH) /= sum_linH. + rewrite mulrDr addrC addKr mulrC mulr_suml /chi_s2. + rewrite (ler_trans (ler_norm_sum _ _ _)) // -ler_pdivr_mulr // mulr_suml. + apply: ler_trans (ub_linH' 1%N isT); apply: ler_sum => i linH'i. + rewrite ler_pdivr_mulr // degU ?divfK ?neq0CG //. + rewrite normrM -normrX norm_conjC ler_wpmul2l ?normr_ge0 //. + rewrite -ler_sqr ?qualifE ?normr_ge0 ?(@ltrW _ 0) // sqrtCK. + apply: ler_trans (ub_linH' 2 isT); rewrite (bigD1 i) ?ler_paddr //=. + by apply: sumr_ge0 => i1 _; rewrite exprn_ge0 ?normr_ge0. + rewrite natrM real_ler_distl ?rpredB ?rpredM ?rpred_nat // => /andP[lb_Pe _]. + rewrite -ltC_nat -(ltr_pmul2l (gt0CG P)) {lb_Pe}(ltr_le_trans _ lb_Pe) //. + rewrite ltr_subr_addl (@ler_lt_trans _ ((p ^ q.-1)%:R ^+ 2)) //; last first. + rewrite -!natrX ltC_nat ltn_sqr oU ltn_divRL ?dvdn_pred_predX //. + rewrite -(subnKC qgt1) /= -!subn1 mulnBr muln1 -expnSr. + by rewrite ltn_sub2l ?(ltn_exp2l 0) // prime_gt1. + rewrite -mulrDr -natrX -expnM muln2 -subn1 doubleB -addnn -addnBA // subn2. + rewrite expnD natrM -oP ler_wpmul2l ?ler0n //. + apply: ler_trans (_ : 2%:R * sqrtC #|P|%:R <= _). + rewrite mulrDl mul1r ler_add2l -(@expr_ge1 _ 2) ?(ltrW sqrtP_gt0) // sqrtCK. + by rewrite oP natrX expr_ge1 ?ler0n ?ler1n. + rewrite -ler_sqr ?rpredM ?rpred_nat ?qualifE ?(ltrW sqrtP_gt0) //. + rewrite exprMn sqrtCK -!natrX -natrM leC_nat -expnM muln2 oP. + rewrite -(subnKC q_gt4) doubleS (expnS p _.*2.+1) -(subnKC pgt4) leq_mul //. + by rewrite ?leq_exp2l // !doubleS !ltnS -addnn leq_addl. +have q3: q = 3 by apply/eqP; rewrite eqn_leq qgt2 andbT -ltnS -(odd_ltn 5). +rewrite (cardsD1 1) E_1 ltnS card_gt0; apply/set0Pn => /=. +pose f (c : 'F_p) : {poly 'F_p} := 'X * ('X - 2%:R%:P) * ('X - c%:P) + ('X - 1). +have fc0 c: (f c).[0] = -1 by rewrite !hornerE. +have fc2 c: (f c).[2%:R] = 1 by rewrite !(subrr, hornerE) /= addrK. +have /existsP[c nz_fc]: [exists c, ~~ [exists d, root (f c) d]]. + have nz_f_0 c: ~~ root (f c) 0 by rewrite /root fc0 oppr_eq0. + rewrite -negb_forall; apply/negP=> /'forall_existsP/fin_all_exists[/= rf rfP]. + suffices inj_rf: injective rf. + by have /negP[] := nz_f_0 (invF inj_rf 0); rewrite -{2}[0](f_invF inj_rf). + move=> a b eq_rf_ab; apply/oppr_inj/(addrI (rf a)). + have: (f a).[rf a] = (f b).[rf a] by rewrite {2}eq_rf_ab !(rootP _). + rewrite !(hornerXsubC, hornerD, hornerM) hornerX => /addIr/mulfI-> //. + rewrite mulf_neq0 ?subr_eq0 1?(contraTneq _ (rfP a)) // => -> //. + by rewrite /root fc2. +have{nz_fc} /= nz_fc: ~~ root (f c) _ by apply/forallP; rewrite -negb_exists. +have sz_fc_lhs: size ('X * ('X - 2%:R%:P) * ('X - c%:P)) = 4. + by rewrite !(size_mul, =^~ size_poly_eq0) ?size_polyX ?size_XsubC. +have sz_fc: size (f c) = 4 by rewrite size_addl ?size_XsubC sz_fc_lhs. +have irr_fc: irreducible_poly (f c) by apply: cubic_irreducible; rewrite ?sz_fc. +have fc_monic : f c \is monic. + rewrite monicE lead_coefDl ?size_XsubC ?sz_fc_lhs // -monicE. + by rewrite !monicMl ?monicXsubC ?monicX. +pose inF := [rmorphism of in_alg F]; pose fcF := map_poly inF (f c). +have /existsP[a fcFa_0]: [exists a : F, root fcF a]. + suffices: ~~ coprimep (f c) ('X ^+ #|F| - 'X). + apply: contraR; rewrite -(coprimep_map inF) negb_exists => /forallP-nz_fcF. + rewrite -/fcF rmorphB rmorphX /= map_polyX finField_genPoly. + elim/big_rec: _ => [|x gF _ co_fcFg]; first exact: coprimep1. + by rewrite coprimep_mulr coprimep_XsubC nz_fcF. + have /irredp_FAdjoin[L dimL [z /coprimep_root fcz0 _]] := irr_fc. + pose finL := [vectType 'F_p of FinFieldExtType L]. + set fcL := map_poly _ _ in fcz0; pose inL := [rmorphism of in_alg L]. + rewrite -(coprimep_map inL) -/fcL rmorphB rmorphX /= map_polyX. + apply: contraL (fcz0 _) _; rewrite hornerD hornerN hornerXn hornerX subr_eq0. + have ->: #|F| = #|{: finL}%VS| by rewrite oF card_vspace dimL sz_fc oF_p q3. + by rewrite card_vspacef (expf_card (z : finL)). +have Fp_fcF: fcF \is a polyOver Fp. + by apply/polyOverP => i; rewrite coef_map /= memvZ ?memv_line. +pose G := 'Gal(Fpq / Fp). +have galG: galois Fp Fpq by rewrite finField_galois ?subvf. +have oG: #|G| = 3 by rewrite -galois_dim // dimv1 dimFpq q3. +have Fp'a: a \notin Fp. + by apply: contraL fcFa_0 => /vlineP[d ->]; rewrite fmorph_root. +have DfcF: fcF = \prod_(beta in G) ('X - (beta a)%:P). + pose Pa : {poly F} := minPoly Fp a. + have /eqP szPa: size Pa == 4. + rewrite size_minPoly eqSS. + rewrite (sameP eqP (prime_nt_dvdP _ _)) ?adjoin_deg_eq1 //. + by rewrite adjoin_degreeE dimv1 divn1 -q3 -dimFpq field_dimS ?subvf. + have dvd_Pa_fcF: Pa %| fcF by apply: minPoly_dvdp fcFa_0. + have{dvd_Pa_fcF} /eqP <-: Pa == fcF. + rewrite -eqp_monic ?monic_minPoly ?monic_map // -dvdp_size_eqp //. + by rewrite szPa size_map_poly sz_fc. + have [r [srG /map_uniq Ur defPa]]:= galois_factors (subvf _) galG a (memvf a). + rewrite -/Pa big_map in defPa; rewrite defPa big_uniq //=. + apply/eq_bigl/subset_cardP=> //; apply/eqP. + by rewrite -eqSS (card_uniqP Ur) oG -szPa defPa size_prod_XsubC. +exists a; rewrite !inE; apply/and3P; split. +- by apply: contraNneq Fp'a => ->; apply: mem1v. +- apply/eqP; transitivity ((- 1) ^+ #|G| * fcF.[inF 0]). + rewrite DfcF horner_prod -prodrN; apply: eq_bigr => beta _. + by rewrite rmorph0 hornerXsubC add0r opprK. + by rewrite -signr_odd mulr_sign oG horner_map fc0 rmorphN1 opprK. +apply/eqP; transitivity (fcF.[inF 2%:R]); last by rewrite horner_map fc2 rmorph1. +rewrite DfcF horner_prod; apply: eq_bigr => beta _. +by rewrite hornerXsubC rmorphB !rmorph_nat. +Qed. + +Section AppendixC3. + +Import GroupScope. + +Variables y : gT. +Hypotheses (QP0y : y \in [~: Q, P0]) (nUP0y : P0 :^ y \subset 'N(U)). +Let Qy : y \in Q. Proof. by rewrite (subsetP sQP0Q). Qed. + +Let t := s ^ y. +Let P1 := P0 :^ y. + +(* This is B & G, Appendix C, Lemma C.3, Step 1. *) +Let splitH x : + x \in H -> + exists2 u, u \in U & exists2 v, v \in U & exists2 s1, s1 \in P0 + & x = u * s1 * v. +Proof. +case/(mem_sdprod defH) => z [v [Pz Uv -> _]]. +have [-> | nt_z] := eqVneq z 1. + by exists 1 => //; exists v => //; exists 1; rewrite ?mulg1. +have nz_z: sigma z != 0 by rewrite (morph_injm_eq1 inj_sigma). +have /(mem_dprod defFU)[]: finField_unit nz_z \in setT := in_setT _. +move=> _ [w [/morphimP[u Uu _ ->] Fp_w /(congr1 val)/= Dz _]]. +have{Fp_w Dz} [n Dz]: exists n, sigma z = sigma ((s ^+ n) ^ u). + move: Fp_w; rewrite {}Dz inE => /vlineP[n ->]; exists n. + by rewrite -{1}(natr_Zp n) scaler_nat mulr_natr conjXg !sigmaE ?in_PU. +exists u^-1; last exists (u * v); rewrite ?groupV ?groupM //. +exists (s ^+ n); rewrite ?groupX // mulgA; congr (_ * _). +by apply: (injmP inj_sigma); rewrite -?mulgA ?in_PU. +Qed. + +(* This is B & G, Appendix C, Lemma C.3, Step 2. *) +Let not_splitU s1 s2 u : + s1 \in P0 -> s2 \in P0 -> u \in U -> s1 * u * s2 \in U -> + (s1 == 1) && (s2 == 1) || (u == 1) && (s1 * s2 == 1). +Proof. +move=> P0s1 P0s2 Uu; have [_ _ _ tiPU] := sdprodP defH. +have [Ps1 Ps2]: s1 \in P /\ s2 \in P by rewrite !(subsetP sP0P). +have [-> | nt_s1 /=] := altP (s1 =P 1). + by rewrite mul1g groupMl // -in_set1 -set1gE -tiPU inE Ps2 => ->. +have [-> | nt_u /=] := altP (u =P 1). + by rewrite mulg1 -in_set1 -set1gE -tiPU inE (groupM Ps1). +rewrite (conjgC _ u) -mulgA groupMl // => Us12; case/negP: nt_u. +rewrite -(morph_injm_eq1 inj_sigmaU) // -in_set1 -set1gE. +have [_ _ _ <-] := dprodP defFU; rewrite !inE mem_morphim //= -/(psi u). +have{Us12}: s1 ^ u * s2 == 1. + by rewrite -in_set1 -set1gE -tiPU inE Us12 andbT !in_PU. +rewrite -(morph_injm_eq1 inj_sigma) ?(in_PU, sigmaE) // addr_eq0. +move/eqP/(canRL (mulKf _))->; rewrite ?morph_injm_eq1 //. +by rewrite mulrC rpred_div ?rpredN //= -sigmaP0 mem_morphim. +Qed. + +(* This is B & G, Appendix C, Lemma C.3, Step 3. *) +Let tiH_P1 t1 : t1 \in P1^# -> H :&: H :^ t1 = U. +Proof. +case/setD1P=>[nt_t1 P1t1]; set X := H :&: _. +have [nsPH sUH _ _ tiPU] := sdprod_context defH. +have sUX: U \subset X. + by rewrite subsetI sUH -(normsP nUP0y t1 P1t1) conjSg. +have defX: (P :&: X) * U = X. + by rewrite setIC group_modr // (sdprodW defH) setIAC setIid. +have [tiPX | ntPX] := eqVneq (P :&: X) 1; first by rewrite -defX tiPX mul1g. +have irrPU: acts_irreducibly U P 'J. + apply/mingroupP; (split=> [|V /andP[ntV]]; rewrite astabsJ) => [|nVU sVP]. + by have [_ ->] := Frobenius_context frobH. + apply/eqP; rewrite eqEsubset sVP; apply/subsetP=> x Px. + have [-> // | ntx] := eqVneq x 1. + have [z Vz ntz] := trivgPn _ ntV; have Pz := subsetP sVP z Vz. + have nz_z: sigma z != 0%R by rewrite morph_injm_eq1. + have uP: (sigma x / sigma z)%R \is a GRing.unit. + by rewrite unitfE mulf_neq0 ?invr_eq0 ?morph_injm_eq1. + have: FinRing.unit F uP \in setT := in_setT _. + case/(mem_dprod defFU)=> _ [s1 [/morphimP[u Uu _ ->]]]. + rewrite inE => /vlineP[n Ds1] /(congr1 val)/= Dx _. + suffices ->: x = (z ^ u) ^+ n by rewrite groupX ?memJ_norm ?(subsetP nVU). + apply: (injmP inj_sigma); rewrite ?(in_PU, sigmaE) //. + by rewrite -mulr_natr -scaler_nat natr_Zp -Ds1 -mulrA -Dx mulrC divfK. +have{ntPX defX irrPU} defX: X :=: H. + rewrite -(sdprodW defH) -defX; congr (_ * _). + have [_ -> //] := mingroupP irrPU; rewrite ?subsetIl //= -/X astabsJ ntPX. + by rewrite normsI // normsG. +have nHt1: t1 \in 'N(H) by rewrite -groupV inE sub_conjgV; apply/setIidPl. +have oP0: #|P0| = p by rewrite -(card_injm inj_sigma) // (eq_card sigmaP0) oFp. +have{nHt1} nHP1: P1 \subset 'N(H). + apply: prime_meetG; first by rewrite cardJg oP0. + by apply/trivgPn; exists t1; rewrite // inE P1t1. +have{nHP1} nPP1: P1 \subset 'N(P). + have /Hall_pi hallP: Hall H P by apply: Frobenius_ker_Hall frobH. + by rewrite -(normal_Hall_pcore hallP nsPH) (char_norm_trans (pcore_char _ _)). +have sylP0: p.-Sylow(Q <*> P0) P0. + rewrite /pHall -divgS joing_subr ?(pgroupS sP0P) //=. + by rewrite norm_joinEr // coprime_cardMg ?(coprimegS sP0P) ?mulnK. +have sP1QP0: P1 \subset Q <*> P0. + by rewrite conj_subG ?joing_subr ?mem_gen // inE Qy. +have nP10: P1 \subset 'N(P0). + have: P1 \subset 'N(P :&: (Q <*> P0)) by rewrite normsI // normsG. + by rewrite norm_joinEr // -group_modr // setIC coprime_TIg // mul1g. +have eqP10: P1 :=: P0. + apply/eqP; rewrite eqEcard cardJg leqnn andbT. + rewrite (comm_sub_max_pgroup (Hall_max sylP0)) //; last exact: normC. + by rewrite pgroupJ (pHall_pgroup sylP0). +have /idPn[] := prime_gt1 pr_p. +rewrite -oP0 cardG_gt1 negbK -subG1 -(Frobenius_trivg_cent frobH) subsetI sP0P. +apply/commG1P/trivgP; rewrite -tiPU commg_subI // subsetI ?subxx //. +by rewrite sP0P -eqP10. +Qed. + +(* This is B & G, Appendix C, Lemma C.3, Step 4. *) +Fact BGappendixC3_Ediv : E = [set x^-1 | x in E]%R. +Proof. +suffices sEV_E: [set x^-1 | x in E]%R \subset E. + by apply/esym/eqP; rewrite eqEcard sEV_E card_imset //=; apply: invr_inj. +have /mulG_sub[/(subset_trans sP0P)/subsetP sP0H /subsetP sUH] := sdprodW defH. +have Hs := sP0H s P0s; have P1t: t \in P1 by rewrite memJ_conjg. +have nUP1 t1: t1 \in P1 -> U :^ t1 = U by move/(subsetP nUP0y)/normP. +have nUtn n u: u \in U -> u ^ (t ^+ n) \in U. + by rewrite -mem_conjgV nUP1 ?groupV ?groupX. +have nUtVn n u: u \in U -> u ^ (t ^- n) \in U. + by rewrite -mem_conjg nUP1 ?groupX. +have Qsti i: s ^- i * t ^+ i \in Q. + by rewrite -conjXg -commgEl (subsetP sQP0Q) // commGC mem_commg ?groupX. +pose is_sUs m a j n u s1 v := + [/\ a \in U, u \in U, v \in U, s1 \in P0 + & s ^+ m * a ^ t ^+ j * s ^- n = u * s1 * v]. +have split_sUs m a j n: + a \in U -> exists u, exists s1, exists v, is_sUs m a j n u s1 v. +- move=> Ua; suffices: s ^+ m * a ^ t ^+ j * s ^- n \in H. + by case/splitH=> u Uu [v Uv [s1 P0s1 Dusv1]]; exists u, s1, v. + by rewrite 2?groupM ?groupV ?groupX // sUH ?nUtn. +have nt_sUs m j n a u s1 v: + (m == n.+1) || (n == m.+1) -> is_sUs m a j n u s1 v -> s1 != 1. +- move/pred2P=> Dmn [Ua Uu Uv _ Dusv]; have{Dmn}: s ^+ m != s ^+ n. + by case: Dmn => ->; last rewrite eq_sym; rewrite expgS eq_mulgV1 ?mulgK. + apply: contraNneq => s1_1; rewrite {s1}s1_1 mulg1 in Dusv. + have:= groupM Uu Uv; rewrite -Dusv => /(not_splitU _ _ (nUtn j a Ua))/orP. + by rewrite !in_group // eq_invg1 -eq_mulgV1 => -[]// /andP[? /eqP->]. +have sUs_modP m a j n u s1 v: is_sUs m a j n u s1 v -> a ^ t ^+ j = u * v. + have [nUP /isom_inj/injmP/=quoUP_inj] := sdprod_isom defH. + case=> Ua Uu Uv P0s1 /(congr1 (coset P)); rewrite (conjgCV u) -(mulgA _ u). + rewrite coset_kerr ?groupV 2?coset_kerl ?groupX //; last first. + by rewrite -mem_conjg (normsP nUP) // (subsetP sP0P). + by move/quoUP_inj->; rewrite ?nUtn ?groupM. +have expUMp u v Uu Uv := expgMn p (centsP cUU u v Uu Uv). +have sUsXp m a j n u s1 v: + is_sUs m a j n u s1 v -> is_sUs m (a ^+ p) j n (u ^+ p) s1 (v ^+ p). +- move=> Dusv; have{Dusv} [/sUs_modP Duv [Ua Uu Vv P0s1 Dusv]] := (Dusv, Dusv). + split; rewrite ?groupX //; move: P0s1 Dusv; rewrite -defP0 => /cycleP[k ->]. + rewrite conjXg -!(mulgA _ (s ^+ k)) ![s ^+ k * _]conjgC 2!mulgA -expUMp //. + rewrite {}Duv ![s ^+ m * _]conjgC !conjXg -![_ * _ * s ^- n]mulgA. + move/mulgI/(congr1 (Frobenius_aut charFp \o sigma))=> /= Duv_p. + congr (_ * _); apply/(injmP inj_sigma); rewrite ?in_PU //. + by rewrite !{1}sigmaE ?in_PU // rmorphB !rmorphMn rmorph1 in Duv_p *. +have odd_P: odd #|P| by rewrite oP odd_exp odd_p orbT. +suffices EpsiV a: a \in U -> psi a \in E -> psi (a^-1 ^ t ^+ 3) \in E. + apply/subsetP => _ /imsetP[x Ex ->]. + have /imsetP[a Ua Dx]: x \in psi @: U by rewrite im_psi; case/setIdP: Ex. + suffices: psi (a^-1 ^ t ^+ (3 * #|P|)) \in E. + rewrite Dx -psiV // -{2}(conjg1 a^-1); congr (psi (_ ^ _) \in E). + by apply/eqP; rewrite -order_dvdn orderJ dvdn_mull ?order_dvdG. + rewrite -(odd_double_half #|P|) odd_P addnC. + elim: _./2 => [|n /EpsiV/EpsiV/=]; first by rewrite EpsiV -?Dx. + by rewrite conjVg invgK -!conjgM -!expgD -!mulnSr !(groupV, nUtn) //; apply. +move=> Ua Ea; have{Ea} [b Ub Dab]: exists2 b, b \in U & psi a + psi b = 2%:R. + case/setIdP: Ea => _; rewrite -im_psi => /imsetP[b Ub Db]; exists b => //. + by rewrite -Db addrC subrK. +(* In the book k is arbitrary in Fp; however only k := 3 is used. *) +have [u2 [s2 [v2 usv2P]]] := split_sUs 3 (a * _) 2 1%N (groupM Ua (groupVr Ub)). +have{Ua} [u1 [s1 [v1 usv1P]]] := split_sUs 1%N a^-1 3 2 (groupVr Ua). +have{Ub} [u3 [s3 [v3 usv3P]]] := split_sUs 2 b 1%N 3 Ub. +pose s2def w1 w2 w3 := t * s2^-1 * t = w1 * s3 * w2 * t ^+ 2 * s1 * w3. +pose w1 := v2 ^ t^-1 * u3; pose w2 := v3 * u1 ^ t ^- 2; pose w3 := v1 * u2 ^ t. +have stXC m n: (m <= n)%N -> s ^- n ^ t ^+ m = s ^- m ^ t ^+ n * s ^- (n - m). + move/subnK=> Dn; apply/(mulgI (s ^- (n - m) * t ^+ n))/(mulIg (t ^+ (n - m))). + rewrite -{1}[in t ^+ n]Dn expgD !mulgA !mulgK -invMg -2!mulgA -!expgD. + by rewrite addnC Dn (centsP (abelem_abelian abelQ)) ?mulgA. +wlog suffices Ds2: a b u1 v1 u2 v2 u3 v3 @w1 @w2 @w3 Dab usv1P usv2P usv3P / + s2def w1 w2 w3; last first. +- apply/esym; rewrite -[_ * t]mulgA [_ * t]conjgC mulgA -(expgS _ 1) conjVg. + rewrite /w2 mulgA; apply: (canRL (mulKVg _)); rewrite 2!mulgA -conjgE. + rewrite conjMg conjgKV /w3 mulgA; apply: (canLR (mulgKV _)). + rewrite /w1 -4!mulgA (mulgA u1) (mulgA u3) conjMg -conjgM mulKg -mulgA. + have [[[Ua _ _ _ <-] [_ _ _ _ Ds2]] [Ub _ _ _ <-]] := (usv1P, usv2P, usv3P). + apply: (canLR (mulKVg _)); rewrite -!invMg -!conjMg -{}Ds2 groupV in Ua *. + rewrite -[t]expg1 2!conjMg -conjgM -expgS 2!conjMg -conjgM -expgSr mulgA. + apply: (canLR (mulgK _)); rewrite 2!invMg -!conjVg invgK invMg invgK -4!mulgA. + rewrite (mulgA _ s) stXC // mulgKV -!conjMg stXC // mulgKV -conjMg conjgM. + apply: (canLR (mulKVg _)); rewrite -2!conjVg 2!mulgA -conjMg (stXC 1%N) //. + rewrite mulgKV -conjgM -expgSr -mulgA -!conjMg; congr (_ ^ t ^+ 3). + apply/(canLR (mulKVg _))/(canLR (mulgK _))/(canLR invgK). + rewrite -!mulgA (mulgA _ b) mulgA invMg -!conjVg !invgK. + by apply/(injmP inj_sigma); rewrite 1?groupM ?sigmaE ?memJ_P. +have [[Ua Uu1 Uv1 P0s1 Dusv1] /sUs_modP-Duv1] := (usv1P, usv1P). +have [[_ Uu2 Uv2 P0s2 _] [Ub Uu3 Uv3 P0s3 _]] := (usv2P, usv3P). +suffices /(congr1 sigma): s ^+ 2 = s ^ v1 * s ^ a^-1 ^ t ^+ 3. + rewrite inE sigmaX // sigma_s sigmaM ?memJ_P -?psiE ?nUtn // => ->. + by rewrite addrK -!im_psi !mem_imset ?nUtn. +rewrite groupV in Ua; have [Hs1 Hs3]: s1 \in H /\ s3 \in H by rewrite !sP0H. +have nt_s1: s1 != 1 by apply: nt_sUs usv1P. +have nt_s3: s3 != 1 by apply: nt_sUs usv3P. +have{sUsXp} Ds2p: s2def (w1 ^+ p) (w2 ^+ p) (w3 ^+ p). + have [/sUsXp-usv1pP /sUsXp-usv2pP /sUsXp-usv3pP] := And3 usv1P usv2P usv3P. + rewrite expUMp ?groupV // !expgVn in usv1pP usv2pP. + rewrite !(=^~ conjXg _ _ p, expUMp) ?groupV -1?[t]expg1 ?nUtn ?nUtVn //. + apply: Ds2 usv1pP usv2pP usv3pP => //. + by rewrite !psiX // -!Frobenius_autE -rmorphD Dab rmorph_nat. +have{Ds2} Ds2: s2def w1 w2 w3 by apply: Ds2 usv1P usv2P usv3P. +wlog [Uw1 Uw2 Uw3]: w1 w2 w3 Ds2p Ds2 / [/\ w1 \in U, w2 \in U & w3 \in U]. + by move/(_ w1 w2 w3)->; rewrite ?(nUtVn, nUtVn 1%N, nUtn 1%N, in_group). +have{Ds2p} Dw3p: (w2 ^- p * w1 ^- p.-1 ^ s3 * w2) ^ t ^+ 2 = w3 ^+ p.-1 ^ s1^-1. + rewrite -[w1 ^+ _](mulKg w1) -[w3 ^+ _](mulgK w3) -expgS -expgSr !prednK //. + rewrite -(canLR (mulKg _) Ds2p) -(canLR (mulKg _) Ds2) 6!invMg !invgK. + by rewrite mulgA mulgK [2]lock /conjg !mulgA mulVg mul1g mulgK. +have w_id w: w \in U -> w ^+ p.-1 == 1 -> w = 1. + by move=> Uw /eqP/(canRL_in (expgK _) Uw)->; rewrite ?expg1n ?oU. +have{Uw3} Dw3: w3 = 1. + apply: w_id => //; have:= @not_splitU s1^-1^-1 s1^-1 (w3 ^+ p.-1). + rewrite !groupV mulVg eqxx andbT {2}invgK (negPf nt_s1) groupX //= => -> //. + have /tiH_P1 <-: t ^+ 2 \in P1^#. + rewrite 2!inE groupX // andbT -order_dvdn gtnNdvd // orderJ. + by rewrite odd_gt2 ?order_gt1 // orderE defP0 (oddSg sP0P). + by rewrite -mulgA -conjgE inE -{2}Dw3p memJ_conjg !in_group ?Hs1 // sUH. +have{Dw3p} Dw2p: w2 ^+ p.-1 = w1 ^- p.-1 ^ s3. + apply/(mulIg w2)/eqP; rewrite -expgSr prednK // eq_mulVg1 mulgA. + by rewrite (canRL (conjgK _) Dw3p) Dw3 expg1n !conj1g. +have{Uw1} Dw1: w1 = 1. + apply: w_id => //; have:= @not_splitU s3^-1 s3 (w1 ^- p.-1). + rewrite mulVg (negPf nt_s3) andbF -mulgA -conjgE -Dw2p !in_group //=. + by rewrite eqxx andbT eq_invg1 /= => ->. +have{w1 w2 w3 Dw1 Dw3 w_id Uw2 Dw2p Ds2} Ds2: t * s2^-1 * t = s3 * t ^+ 2 * s1. + by rewrite Ds2 Dw3 [w2]w_id ?mulg1 ?Dw2p ?Dw1 ?mul1g // expg1n invg1 conj1g. +have /centsP abP0: abelian P0 by rewrite -defP0 cycle_abelian. +have QP0ys := memJ_norm y (subsetP (commg_normr P0 Q) _ _). +have{QP0ys} memQP0 := (QP0ys, groupV, groupM); have nQ_P0 := subsetP nQP0. +have sQP0_Q: [~: Q, P0] \subset Q by rewrite commg_subl. +have /centsP abQP0 := abelianS sQP0_Q (abelem_abelian abelQ). +have{s2def} Ds312: s3 * s1 * s2 = 1. + apply/set1P; rewrite -set1gE -(coprime_TIg coQP) inE. + rewrite coset_idr ?(subsetP sP0P) ?nQ_P0 ?groupM //. + rewrite -mulgA -[s2](mulgK s) [_ * s]abP0 // -[s2](mulKVg s). + rewrite -!mulgA [s * _]mulgA [s1 * _]mulgA [s1 * _]abP0 ?groupM //. + rewrite 2!(mulgA s3) [s^-1 * _]mulgA !(morphM, morphV) ?nQ_P0 ?in_group //=. + have ->: coset Q s = coset Q t by rewrite coset_kerl ?groupV ?coset_kerr. + have nQt: t \in 'N(Q) by rewrite -(conjGid Qy) normJ memJ_conjg nQ_P0. + rewrite -morphV // -!morphM ?(nQt, groupM) ?groupV // ?nQ_P0 //= -Ds2. + by rewrite 2!mulgA mulgK mulgKV mulgV morph1. +pose x := (y ^ s3)^-1 * y ^ s^-1 * (y ^ (s * s1)^-1)^-1 * y. +have{abP0} Dx: x ^ s^-1 = x. + rewrite 3!conjMg !conjVg -!conjgM -!invMg (mulgA s) -(expgS _ 1). + rewrite [x]abQP0 ?memQP0 // [rhs in y * rhs]abQP0 ?memQP0 //. + apply/(canRL (mulKVg _)); rewrite 4!mulgA; congr (_ * _). + rewrite [RHS]abQP0 ?memQP0 //; apply/(canRL (mulgK _))/eqP. + rewrite -3!mulgA [rhs in y^-1 * rhs]abQP0 ?memQP0 // -eq_invg_sym eq_invg_mul. + apply/eqP; transitivity (t ^+ 2 * s1 * (t^-1 * s2 * t^-1) * s3); last first. + by rewrite -[s2]invgK -!invMg mulgA Ds2 -(mulgA s3) invMg mulKVg mulVg. + rewrite (canRL (mulKg _) Ds312) -2![_ * t^-1]mulgA. + have Dt1 si: si \in P0 -> t^-1 = (s^-1 ^ si) ^ y. + by move=> P0si; rewrite {2}/conjg -conjVg -(abP0 si) ?groupV ?mulKg. + by rewrite {1}(Dt1 s1) // (Dt1 s3^-1) ?groupV // -conjXg /conjg !{1}gnorm. +have{Dx memQP0} Dx1: x = 1. + apply/set1P; rewrite -set1gE; have [_ _ _ <-] := dprodP defQ. + rewrite setIAC (setIidPr sQP0_Q) inE -{2}defP0 -cycleV cent_cycle. + by rewrite (sameP cent1P commgP) commgEl Dx mulVg eqxx !memQP0. +pose t1 := s1 ^ y; pose t3 := s3 ^ y. +have{x Dx1} Ds13: s1 * (t * t1)^-1 = (t3 * t)^-1 * s3. + by apply/eqP; rewrite eq_sym eq_mulVg1 invMg invgK -Dx1 /x /conjg !gnorm. +suffices Ds1: s1 = s^-1. + rewrite -(canLR (mulKg _) (canRL (mulgKV _) Dusv1)) Ds1 Duv1. + by rewrite !invMg invgK /conjg !gnorm. +have [_ _ /trivgPn[u Uu nt_u] _ _] := Frobenius_context frobH. +apply: (conjg_inj y); apply: contraNeq nt_u. +rewrite -/t1 conjVg -/t eq_mulVg1 -invMg => nt_tt1. +have Hu := sUH u Uu; have P1tt1: t * t1 \in P1 by rewrite groupM ?memJ_conjg. +have /tiH_P1 defU: (t * t1)^-1 \in P1^# by rewrite 2!inE nt_tt1 groupV. +suffices: (u ^ s1) ^ (t * t1)^-1 \in U. + rewrite -mem_conjg nUP1 // conjgE mulgA => /(not_splitU _ _ Uu). + by rewrite groupV (negPf nt_s1) andbF mulVg eqxx andbT /= => /(_ _ _)/eqP->. +rewrite -defU inE memJ_conjg -conjgM Ds13 conjgM groupJ ?(groupJ _ Hs1) //. +by rewrite sUH // -mem_conjg nUP1 // groupM ?memJ_conjg. +Qed. + +End AppendixC3. + +Fact BGappendixC_inner_subproof : (p <= q)%N. +Proof. +have [y QP0y nUP0y] := nU_P0QP0. +by apply: Einv_gt1_le_pq E_gt1; apply: BGappendixC3_Ediv nUP0y. +Qed. + +End ExpandHypotheses. + +(* This is B & G, Appendix C, Theorem C. *) +Theorem prime_dim_normed_finField : (p <= q)%N. +Proof. +apply: wlog_neg; rewrite -ltnNge => ltqp. +have [F sigma /isomP[inj_sigma im_sigma] defP0] := fieldH. +case=> sigmaU inj_sigmaU sigmaJ. +have oF: #|F| = (p ^ q)%N by rewrite -cardsT -im_sigma card_injm. +have charFp: p \in [char F] := card_finCharP oF pr_p. +have sP0P: P0 \subset P by rewrite -defP0 subsetIl. +pose s := invm inj_sigma 1%R. +have sigma_s: sigma s = 1%R by rewrite invmK ?im_sigma ?inE. +have{defP0} defP0: <[s]> = P0. + by rewrite -morphim_cycle /= ?im_sigma ?inE // morphim_invmE. +exact: BGappendixC_inner_subproof defP0 sigmaJ. +Qed. + +End AppendixC. diff --git a/mathcomp/odd_order/BGsection1.v b/mathcomp/odd_order/BGsection1.v new file mode 100644 index 0000000..98a2d08 --- /dev/null +++ b/mathcomp/odd_order/BGsection1.v @@ -0,0 +1,1340 @@ +Set Printing Width 50. +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div fintype. +Require Import bigop prime binomial finset fingroup morphism perm automorphism. +Require Import quotient action gproduct gfunctor commutator. +Require Import ssralg finalg zmodp cyclic center pgroup finmodule gseries. +Require Import nilpotent sylow abelian maximal hall extremal. +Require Import matrix mxalgebra mxrepresentation mxabelem. + +(******************************************************************************) +(* This file contains most of the material in B & G, section 1, including the *) +(* definitions: *) +(* p.-length_1 G == the upper p-series of G has length <= 1, i.e., *) +(* 'O_{p^',p,p^'}(G) = G *) +(* p_elt_gen p G == the subgroup of G generated by its p-elements. *) +(* This file currently covers B & G 1.3-4, 1.6, 1.8-1.21, and also *) +(* Gorenstein 8.1.3 and 2.8.1 (maximal order of a p-subgroup of GL(2,p)). *) +(* This file also provides, mostly for future reference, the following *) +(* definitions, drawn from Gorenstein, Chapter 8, and B & G, Appendix B: *) +(* p.-constrained G <-> the p',p core of G contains the centralisers of *) +(* all its Sylow p-subgroups. The Hall-Higman Lemma *) +(* 1.2.3 (B & G, 1.15a) asserts that this holds for *) +(* all solvable groups. *) +(* p.-stable G <-> a rather group theoretic generalization of the *) +(* Hall-Higman type condition that in a faithful *) +(* p-modular linear representation of G no p-element *) +(* has a quadratic minimal polynomial, to groups G *) +(* with a non-trivial p-core. *) +(* p.-abelian_constrained <-> the p',p core of G contains all the normal *) +(* abelian subgroups of the Sylow p-subgroups of G. *) +(* It is via this property and the ZL theorem (the *) +(* substitute for the ZJ theorem) that the *) +(* p-stability of groups of odd order is exploited *) +(* in the proof of the Odd Order Theorem. *) +(* generated_by p G == G is generated by a set of subgroups satisfying *) +(* p : pred {group gT} *) +(* norm_abelian X A == A is abelian and normalised by X. *) +(* p_norm_abelian p X A == A is an abelian p-group normalised by X. *) +(* 'L_[G](X) == the group generated by the abelian subgroups of G *) +(* normalized by X. *) +(* 'L_{n}(G) == the Puig group series, defined by the recurrence *) +(* 'L_{0}(G) = 1, 'L_{n.+1}(G) = 'L_[G]('L_{n}(G)). *) +(* 'L_*(G) == the lower limit of the Puig series. *) +(* 'L(G) == the Puig subgroup: the upper limit of the Puig *) +(* series: 'L(G) = 'L_[G]('L_*(G)) and conversely. *) +(* The following notation is used locally here and in AppendixB, but is NOT *) +(* exported: *) +(* D --> G == G is generated by abelian groups normalised by D *) +(* := generated_by (norm_abelian D) G *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section Definitions. + +Variables (n : nat) (gT : finGroupType). +Implicit Type p : nat. + +Definition plength_1 p (G : {set gT}) := 'O_{p^', p, p^'}(G) == G. + +Definition p_elt_gen p (G : {set gT}) := <<[set x in G | p.-elt x]>>. + +Definition p_constrained p (G : {set gT}) := + forall P : {group gT}, + p.-Sylow('O_{p^',p}(G)) P -> + 'C_G(P) \subset 'O_{p^',p}(G). + +Definition p_abelian_constrained p (G : {set gT}) := + forall S A : {group gT}, + p.-Sylow(G) S -> abelian A -> A <| S -> + A \subset 'O_{p^',p}(G). + +Definition p_stable p (G : {set gT}) := + forall P A : {group gT}, + p.-group P -> 'O_p^'(G) * P <| G -> + p.-subgroup('N_G(P)) A -> [~: P, A, A] = 1 -> + A / 'C_G(P) \subset 'O_p('N_G(P) / 'C_G(P)). + +Definition generated_by (gp : pred {group gT}) (E : {set gT}) := + [exists gE : {set {group gT}}, <<\bigcup_(G in gE | gp G) G>> == E]. + +Definition norm_abelian (D : {set gT}) : pred {group gT} := + fun A => (D \subset 'N(A)) && abelian A. + +Definition p_norm_abelian p (D : {set gT}) : pred {group gT} := + fun A => p.-group A && norm_abelian D A. + +Definition Puig_succ (D E : {set gT}) := + <<\bigcup_(A in subgroups D | norm_abelian E A) A>>. + +Definition Puig_rec D := iter n (Puig_succ D) 1. + +End Definitions. + +(* This must be defined outside a Section to avoid spurrious delta-reduction *) +Definition Puig_at := nosimpl Puig_rec. + +Definition Puig_inf (gT : finGroupType) (G : {set gT}) := Puig_at #|G|.*2 G. + +Definition Puig (gT : finGroupType) (G : {set gT}) := Puig_at #|G|.*2.+1 G. + +Notation "p .-length_1" := (plength_1 p) + (at level 2, format "p .-length_1") : group_scope. + +Notation "p .-constrained" := (p_constrained p) + (at level 2, format "p .-constrained") : group_scope. +Notation "p .-abelian_constrained" := (p_abelian_constrained p) + (at level 2, format "p .-abelian_constrained") : group_scope. +Notation "p .-stable" := (p_stable p) + (at level 2, format "p .-stable") : group_scope. + +Notation "''L_[' G ] ( L )" := (Puig_succ G L) + (at level 8, format "''L_[' G ] ( L )") : group_scope. +Notation "''L_{' n } ( G )" := (Puig_at n G) + (at level 8, format "''L_{' n } ( G )") : group_scope. +Notation "''L_*' ( G )" := (Puig_inf G) + (at level 8, format "''L_*' ( G )") : group_scope. +Notation "''L' ( G )" := (Puig G) + (at level 8, format "''L' ( G )") : group_scope. + +Section BGsection1. + +Implicit Types (gT : finGroupType) (p : nat). + +(* This is B & G, Lemma 1.1, first part. *) +Lemma minnormal_solvable_abelem gT (M G : {group gT}) : + minnormal M G -> solvable M -> is_abelem M. +Proof. by move=> minM solM; case: (minnormal_solvable minM (subxx _) solM). Qed. + +(* This is B & G, Lemma 1.2, second part. *) +Lemma minnormal_solvable_Fitting_center gT (M G : {group gT}) : + minnormal M G -> M \subset G -> solvable M -> M \subset 'Z('F(G)). +Proof. +have nZG: 'Z('F(G)) <| G. + by apply: (char_normal_trans (center_char _)); exact: Fitting_normal. +move=> minM sMG solM; have[/andP[ntM nMG] minM'] := mingroupP minM. +apply/setIidPl/minM'; last exact: subsetIl. +apply/andP; split; last by rewrite normsI // normal_norm. +apply: meet_center_nil => //; first by apply: Fitting_nil. +apply/andP; split; last by apply: subset_trans nMG; exact: Fitting_sub. +apply: Fitting_max; rewrite // /normal ?sMG //; apply: abelian_nil. +by move: (minnormal_solvable_abelem minM solM) => /abelem_abelian. +Qed. + +Lemma sol_chief_abelem gT (G V U : {group gT}) : + solvable G -> chief_factor G V U -> is_abelem (U / V). +Proof. +move=> solG chiefUV; have minUV := chief_factor_minnormal chiefUV. +have [|//] := minnormal_solvable minUV (quotientS _ _) (quotient_sol _ solG). +by case/and3P: chiefUV. +Qed. + +Section HallLemma. + +Variables (gT : finGroupType) (G G' : {group gT}). + +Hypothesis solG : solvable G. +Hypothesis nsG'G : G' <| G. +Let sG'G : G' \subset G := normal_sub nsG'G. +Let nG'G : G \subset 'N(G') := normal_norm nsG'G. + +Let nsF'G : 'F(G') <| G := char_normal_trans (Fitting_char G') nsG'G. + +Let Gchief (UV : {group gT} * {group gT}) := chief_factor G UV.2 UV.1. +Let H := \bigcap_(UV | Gchief UV) 'C(UV.1 / UV.2 | 'Q). +Let H' := + G' :&: \bigcap_(UV | Gchief UV && (UV.1 \subset 'F(G'))) 'C(UV.1 / UV.2 | 'Q). + +(* This is B & G Proposition 1.2, non trivial inclusion of the first equality.*) +Proposition Fitting_stab_chief : 'F(G') \subset H. +Proof. +apply/bigcapsP=> [[U V] /= chiefUV]. +have minUV: minnormal (U / V) (G / V) := chief_factor_minnormal chiefUV. +have{chiefUV} [/=/maxgroupp/andP[_ nVG] sUG nUG] := and3P chiefUV. +have solUV: solvable (U / V) by rewrite quotient_sol // (solvableS sUG). +have{solUV minUV}: U / V \subset 'Z('F(G / V)). + exact: minnormal_solvable_Fitting_center minUV (quotientS V sUG) solUV. +rewrite sub_astabQ (subset_trans (normal_sub nsF'G) nVG) /=. +rewrite subsetI centsC => /andP[_]; apply: subset_trans. +by rewrite Fitting_max ?quotient_normal ?quotient_nil ?Fitting_nil. +Qed. + +(* This is B & G Proposition 1.2, non trivial inclusion of the second *) +(* equality. *) +Proposition chief_stab_sub_Fitting : H' \subset 'F(G'). +Proof. +without loss: / {K | [min K | K <| G & ~~ (K \subset 'F(G'))] & K \subset H'}. + move=> IH; apply: wlog_neg => s'H'F; apply/IH/mingroup_exists=> {IH}/=. + rewrite /normal subIset ?sG'G ?normsI ?norms_bigcap {s'H'F}//. + apply/bigcapsP=> /= U /andP[/and3P[/maxgroupp/andP/=[_ nU2G] _ nU1G] _]. + exact: subset_trans (actsQ nU2G nU1G) (astab_norm 'Q (U.1 / U.2)). +case=> K /mingroupP[/andP[nsKG s'KF] minK] /subsetIP[sKG' nFK]. +have [[Ks chiefKs defK] sKG]:= (chief_series_exists nsKG, normal_sub nsKG). +suffices{nsKG s'KF} cKsK: (K.-central).-series 1%G Ks. + by rewrite Fitting_max ?(normalS _ sG'G) ?(centrals_nil cKsK) in s'KF. +move: chiefKs; rewrite -!(rev_path _ _ Ks) {}defK. +case: {Ks}(rev _) => //= K1 Kr /andP[chiefK1 chiefKr]. +have [/maxgroupp/andP[/andP[sK1K ltK1K] nK1G] _] := andP chiefK1. +suffices{chiefK1} cKrK: [rel U V | central_factor K V U].-series K1 Kr. + have cKK1: abelian (K / K1) := abelem_abelian (sol_chief_abelem solG chiefK1). + by rewrite /central_factor subxx sK1K der1_min //= (subset_trans sKG). +have{minK ltK1K nK1G} sK1F: K1 \subset 'F(G'). + have nsK1G: K1 <| G by rewrite /normal (subset_trans sK1K). + by apply: contraR ltK1K => s'K1F; rewrite (minK K1) ?nsK1G. +elim: Kr K1 chiefKr => //= K2 Kr IHr K1 /andP[chiefK2 chiefKr] in sK1F sK1K *. +have [/maxgroupp/andP[/andP[sK21 _] /(subset_trans sKG)nK2K] _] := andP chiefK2. +rewrite /central_factor sK1K {}IHr ?(subset_trans sK21) {chiefKr}// !andbT. +rewrite commGC -sub_astabQR ?(subset_trans _ nK2K) //. +exact/(subset_trans nFK)/(bigcap_inf (K1, K2))/andP. +Qed. + +End HallLemma. + +(* This is B & G, Proposition 1.3 (due to P. Hall). *) +Proposition cent_sub_Fitting gT (G : {group gT}) : + solvable G -> 'C_G('F(G)) \subset 'F(G). +Proof. +move=> solG; apply: subset_trans (chief_stab_sub_Fitting solG _) => //. +rewrite subsetI subsetIl; apply/bigcapsP=> [[U V]] /=. +case/andP=> /andP[/maxgroupp/andP[_ nVG] _] sUF. +by rewrite astabQ (subset_trans _ (morphpre_cent _ _)) // setISS ?centS. +Qed. + +(* This is B & G, Proposition 1.4, for internal actions. *) +Proposition coprime_trivg_cent_Fitting gT (A G : {group gT}) : + A \subset 'N(G) -> coprime #|G| #|A| -> solvable G -> + 'C_A(G) = 1 -> 'C_A('F(G)) = 1. +Proof. +move=> nGA coGA solG regAG; without loss cycA: A nGA coGA regAG / cyclic A. + move=> IH; apply/trivgP/subsetP=> a; rewrite -!cycle_subG subsetI. + case/andP=> saA /setIidPl <-. + rewrite {}IH ?cycle_cyclic ?(coprimegS saA) ?(subset_trans saA) //. + by apply/trivgP; rewrite -regAG setSI. +pose X := G <*> A; pose F := 'F(X); pose pi := \pi(A); pose Q := 'O_pi(F). +have pi'G: pi^'.-group G by rewrite /pgroup -coprime_pi' //= coprime_sym. +have piA: pi.-group A by exact: pgroup_pi. +have oX: #|X| = (#|G| * #|A|)%N by rewrite [X]norm_joinEr ?coprime_cardMg. +have hallG: pi^'.-Hall(X) G. + by rewrite /pHall -divgS joing_subl //= pi'G pnatNK oX mulKn. +have nsGX: G <| X by rewrite /normal joing_subl join_subG normG. +have{oX pi'G piA} hallA: pi.-Hall(X) A. + by rewrite /pHall -divgS joing_subr //= piA oX mulnK. +have nsQX: Q <| X := char_normal_trans (pcore_char _ _) (Fitting_normal _). +have{solG cycA} solX: solvable X. + rewrite (series_sol nsGX) {}solG /= norm_joinEr // quotientMidl //. + by rewrite morphim_sol // abelian_sol // cyclic_abelian. +have sQA: Q \subset A. + by apply: normal_sub_max_pgroup (Hall_max hallA) (pcore_pgroup _ _) nsQX. +have pi'F: 'O_pi(F) = 1. + suff cQG: G \subset 'C(Q) by apply/trivgP; rewrite -regAG subsetI sQA centsC. + apply/commG1P/trivgP; rewrite -(coprime_TIg coGA) subsetI commg_subl. + rewrite (subset_trans sQA) // (subset_trans _ sQA) // commg_subr. + by rewrite (subset_trans _ (normal_norm nsQX)) ?joing_subl. +have sFG: F \subset G. + have /dprodP[_ defF _ _]: _ = F := nilpotent_pcoreC pi (Fitting_nil _). + by rewrite (sub_normal_Hall hallG) ?gFsub //= -defF pi'F mul1g pcore_pgroup. +have <-: F = 'F(G). + apply/eqP; rewrite eqEsubset -{1}(setIidPr sFG) FittingS ?joing_subl //=. + by rewrite Fitting_max ?Fitting_nil // (char_normal_trans (Fitting_char _)). +apply/trivgP; rewrite /= -(coprime_TIg coGA) subsetI subsetIl andbT. +apply: subset_trans (subset_trans (cent_sub_Fitting solX) sFG). +by rewrite setSI ?joing_subr. +Qed. + +(* A "contrapositive" of Proposition 1.4 above. *) +Proposition coprime_cent_Fitting gT (A G : {group gT}) : + A \subset 'N(G) -> coprime #|G| #|A| -> solvable G -> + 'C_A('F(G)) \subset 'C(G). +Proof. +move=> nGA coGA solG; apply: subset_trans (subsetIr A _); set C := 'C_A(G). +rewrite -quotient_sub1 /= -/C; last first. + by rewrite subIset // normsI ?normG // norms_cent. +apply: subset_trans (quotient_subcent _ _ _) _; rewrite /= -/C. +have nCG: G \subset 'N(C) by rewrite cents_norm // centsC subsetIr. +rewrite /= -(setIidPr (Fitting_sub _)) -[(G :&: _) / _](morphim_restrm nCG). +rewrite injmF //=; last first. + by rewrite ker_restrm ker_coset setIA (coprime_TIg coGA) subIset ?subxx. +rewrite morphim_restrm -quotientE setIid. +rewrite coprime_trivg_cent_Fitting ?quotient_norms ?coprime_morph //=. + exact: morphim_sol. +rewrite -strongest_coprime_quotient_cent ?trivg_quotient ?solG ?orbT //. + by rewrite -setIA subsetIl. +by rewrite coprime_sym -setIA (coprimegS (subsetIl _ _)). +Qed. + +(* B & G Proposition 1.5 is covered by several lemmas in hall.v : *) +(* 1.5a -> coprime_Hall_exists (internal action) *) +(* ext_coprime_Hall_exists (general group action) *) +(* 1.5b -> coprime_Hall_subset (internal action) *) +(* ext_coprime_Hall_subset (general group action) *) +(* 1.5c -> coprime_Hall_trans (internal action) *) +(* ext_coprime_Hall_trans (general group action) *) +(* 1.5d -> coprime_quotient_cent (internal action) *) +(* ext_coprime_quotient_cent (general group action) *) +(* several stronger variants are proved for internal action *) +(* 1.5e -> coprime_comm_pcore (internal action only) *) + +(* A stronger variant of B & G, Proposition 1.6(a). *) +Proposition coprimeR_cent_prod gT (A G : {group gT}) : + A \subset 'N(G) -> coprime #|[~: G, A]| #|A| -> solvable [~: G, A] -> + [~: G, A] * 'C_G(A) = G. +Proof. +move=> nGA coRA solR; apply/eqP; rewrite eqEsubset mulG_subG commg_subl nGA. +rewrite subsetIl -quotientSK ?commg_norml //=. +rewrite coprime_norm_quotient_cent ?commg_normr //=. +by rewrite subsetI subxx quotient_cents2r. +Qed. + +(* This is B & G, Proposition 1.6(a). *) +Proposition coprime_cent_prod gT (A G : {group gT}) : + A \subset 'N(G) -> coprime #|G| #|A| -> solvable G -> + [~: G, A] * 'C_G(A) = G. +Proof. +move=> nGA; have sRG: [~: G, A] \subset G by rewrite commg_subl. +rewrite -(Lagrange sRG) coprime_mull => /andP[coRA _] /(solvableS sRG). +exact: coprimeR_cent_prod. +Qed. + +(* This is B & G, Proposition 1.6(b). *) +Proposition coprime_commGid gT (A G : {group gT}) : + A \subset 'N(G) -> coprime #|G| #|A| -> solvable G -> + [~: G, A, A] = [~: G, A]. +Proof. +move=> nGA coGA solG; apply/eqP; rewrite eqEsubset commSg ?commg_subl //. +have nAC: 'C_G(A) \subset 'N(A) by rewrite subIset ?cent_sub ?orbT. +rewrite -{1}(coprime_cent_prod nGA) // commMG //=; first 1 last. + by rewrite !normsR // subIset ?normG. +by rewrite (commG1P (subsetIr _ _)) mulg1. +Qed. + +(* This is B & G, Proposition 1.6(c). *) +Proposition coprime_commGG1P gT (A G : {group gT}) : + A \subset 'N(G) -> coprime #|G| #|A| -> solvable G -> + [~: G, A, A] = 1 -> A \subset 'C(G). +Proof. +by move=> nGA coGA solG; rewrite centsC coprime_commGid // => /commG1P. +Qed. + +(* This is B & G, Proposition 1.6(d), TI-part, from finmod.v *) +Definition coprime_abel_cent_TI := coprime_abel_cent_TI. + +(* This is B & G, Proposition 1.6(d) (direct product) *) +Proposition coprime_abelian_cent_dprod gT (A G : {group gT}) : + A \subset 'N(G) -> coprime #|G| #|A| -> abelian G -> + [~: G, A] \x 'C_G(A) = G. +Proof. +move=> nGA coGA abelG; rewrite dprodE ?coprime_cent_prod ?abelian_sol //. + by rewrite subIset 1?(subset_trans abelG) // centS // commg_subl. +by apply/trivgP; rewrite /= setICA coprime_abel_cent_TI ?subsetIr. +Qed. + +(* This is B & G, Proposition 1.6(e), which generalises Aschbacher (24.3). *) +Proposition coprime_abelian_faithful_Ohm1 gT (A G : {group gT}) : + A \subset 'N(G) -> coprime #|G| #|A| -> abelian G -> + A \subset 'C('Ohm_1(G)) -> A \subset 'C(G). +Proof. +move=> nGA coGA cGG; rewrite !(centsC A) => cAG1. +have /dprodP[_ defG _ tiRC] := coprime_abelian_cent_dprod nGA coGA cGG. +have sRG: [~: G, A] \subset G by rewrite commg_subl. +rewrite -{}defG -(setIidPl sRG) TI_Ohm1 ?mul1g ?subsetIr //. +by apply/trivgP; rewrite -{}tiRC setIS // subsetI Ohm_sub. +Qed. + +(* B & G, Lemma 1.7 is covered by several lemmas in maximal.v : *) +(* 1.7a -> Phi_nongen *) +(* 1.7b -> Phi_quotient_abelem *) +(* 1.7c -> trivg_Phi *) +(* 1.7d -> Phi_joing *) + +(* This is B & G, Proposition 1.8, or Aschbacher 24.1. Note that the coprime *) +(* assumption is slightly weaker than requiring that A be a p'-group. *) +Proposition coprime_cent_Phi gT p (A G : {group gT}) : + p.-group G -> coprime #|G| #|A| -> [~: G, A] \subset 'Phi(G) -> + A \subset 'C(G). +Proof. +move=> pG coGA sRphi; rewrite centsC; apply/setIidPl. +rewrite -['C_G(A)]genGid; apply/Phi_nongen/eqP. +rewrite eqEsubset join_subG Phi_sub subsetIl -genM_join sub_gen //=. +rewrite -{1}(coprime_cent_prod _ coGA) ?(pgroup_sol pG) ?mulSg //. +by rewrite -commg_subl (subset_trans sRphi) ?Phi_sub. +Qed. + +(* This is B & G, Proposition 1.9, base (and most common) case, for internal *) +(* coprime action. *) +Proposition stable_factor_cent gT (A G H : {group gT}) : + A \subset 'C(H) -> stable_factor A H G -> + coprime #|G| #|A| -> solvable G -> + A \subset 'C(G). +Proof. +move=> cHA /and3P[sRH sHG nHG] coGA solG. +suffices: G \subset 'C_G(A) by rewrite subsetI subxx centsC. +rewrite -(quotientSGK nHG) ?subsetI ?sHG 1?centsC //. +by rewrite coprime_quotient_cent ?cents_norm ?subsetI ?subxx ?quotient_cents2r. +Qed. + +(* This is B & G, Proposition 1.9 (for internal coprime action) *) +Proposition stable_series_cent gT (A G : {group gT}) s : + last 1%G s :=: G -> (A.-stable).-series 1%G s -> + coprime #|G| #|A| -> solvable G -> + A \subset 'C(G). +Proof. +move=> <-{G}; elim/last_ind: s => /= [|s G IHs]; first by rewrite cents1. +rewrite last_rcons rcons_path /= => /andP[/IHs{IHs}]. +move: {s}(last _ _) => H IH_H nHGA coGA solG; have [_ sHG _] := and3P nHGA. +by rewrite (stable_factor_cent _ nHGA) ?IH_H ?(solvableS sHG) ?(coprimeSg sHG). +Qed. + +(* This is B & G, Proposition 1.10. *) +Proposition coprime_nil_faithful_cent_stab gT (A G : {group gT}) : + A \subset 'N(G) -> coprime #|G| #|A| -> nilpotent G -> + let C := 'C_G(A) in 'C_G(C) \subset C -> A \subset 'C(G). +Proof. +move=> nGA coGA nilG C; rewrite subsetI subsetIl centsC /= -/C => cCA. +pose N := 'N_G(C); have sNG: N \subset G by rewrite subsetIl. +have sCG: C \subset G by rewrite subsetIl. +suffices cNA : A \subset 'C(N). + rewrite centsC (sameP setIidPl eqP) -(nilpotent_sub_norm nilG sCG) //= -/C. + by rewrite subsetI subsetIl centsC. +have{nilG} solN: solvable N by rewrite(solvableS sNG) ?nilpotent_sol. +rewrite (stable_factor_cent cCA) ?(coprimeSg sNG) /stable_factor //= -/N -/C. +rewrite subcent_normal subsetI (subset_trans (commSg A sNG)) ?commg_subl //=. +rewrite comm_norm_cent_cent 1?centsC ?subsetIr // normsI // !norms_norm //. +by rewrite cents_norm 1?centsC ?subsetIr. +Qed. + +(* B & G, Theorem 1.11, via Aschbacher 24.7 rather than Gorenstein 5.3.10. *) +Theorem coprime_odd_faithful_Ohm1 gT p (A G : {group gT}) : + p.-group G -> A \subset 'N(G) -> coprime #|G| #|A| -> odd #|G| -> + A \subset 'C('Ohm_1(G)) -> A \subset 'C(G). +Proof. +move=> pG nGA coGA oddG; rewrite !(centsC A) => cAG1. +have [-> | ntG] := eqsVneq G 1; first exact: sub1G. +have{oddG ntG} [p_pr oddp]: prime p /\ odd p. + have [p_pr p_dv_G _] := pgroup_pdiv pG ntG. + by rewrite !odd_2'nat in oddG *; rewrite pnatE ?(pgroupP oddG). +without loss defR: G pG nGA coGA cAG1 / [~: G, A] = G. + move=> IH; have solG := pgroup_sol pG. + rewrite -(coprime_cent_prod nGA) ?mul_subG ?subsetIr //=. + have sRG: [~: G, A] \subset G by rewrite commg_subl. + rewrite IH ?coprime_commGid ?(pgroupS sRG) ?commg_normr ?(coprimeSg sRG) //. + by rewrite (subset_trans (OhmS 1 sRG)). +have [|[defPhi defG'] defC] := abelian_charsimple_special pG coGA defR. + apply/bigcupsP=> H /andP[chH abH]; have sHG := char_sub chH. + have nHA := char_norm_trans chH nGA. + rewrite centsC coprime_abelian_faithful_Ohm1 ?(coprimeSg sHG) //. + by rewrite centsC (subset_trans (OhmS 1 sHG)). +have abelZ: p.-abelem 'Z(G) by exact: center_special_abelem. +have cAZ: {in 'Z(G), centralised A} by apply/centsP; rewrite -defC subsetIr. +have cGZ: {in 'Z(G), centralised G} by apply/centsP; rewrite subsetIr. +have defG1: 'Ohm_1(G) = 'Z(G). + apply/eqP; rewrite eqEsubset -{1}defC subsetI Ohm_sub cAG1 /=. + by rewrite -(Ohm1_id abelZ) OhmS ?center_sub. +rewrite (subset_trans _ (subsetIr G _)) // defC -defG1 -{1}defR gen_subG /=. +apply/subsetP=> xa; case/imset2P=> x a Gx Aa ->{xa}; rewrite commgEl. +set u := x^-1; set v := x ^ a; pose w := [~ v, u]. +have [Gu Gv]: u \in G /\ v \in G by rewrite groupV memJ_norm ?(subsetP nGA). +have Zw: w \in 'Z(G) by rewrite -defG' mem_commg. +rewrite (OhmE 1 pG) mem_gen // !inE expn1 groupM //=. +rewrite expMg_Rmul /commute ?(cGZ w) // bin2odd // expgM. +case/(abelemP p_pr): abelZ => _ /(_ w)-> //. +rewrite expg1n mulg1 expgVn -conjXg (sameP commgP eqP) cAZ // -defPhi. +by rewrite (Phi_joing pG) joingC mem_gen // inE (Mho_p_elt 1) ?(mem_p_elt pG). +Qed. + +(* This is B & G, Corollary 1.12. *) +Corollary coprime_odd_faithful_cent_abelem gT p (A G E : {group gT}) : + E \in 'E_p(G) -> p.-group G -> + A \subset 'N(G) -> coprime #|G| #|A| -> odd #|G| -> + A \subset 'C('Ldiv_p('C_G(E))) -> A \subset 'C(G). +Proof. +case/pElemP=> sEG abelE pG nGA coGA oddG cCEA. +have [-> | ntG] := eqsVneq G 1; first by rewrite cents1. +have [p_pr _ _] := pgroup_pdiv pG ntG. +have{cCEA} cCEA: A \subset 'C('Ohm_1('C_G(E))). + by rewrite (OhmE 1 (pgroupS _ pG)) ?subsetIl ?cent_gen. +apply: coprime_nil_faithful_cent_stab (pgroup_nil pG) _ => //. +rewrite subsetI subsetIl centsC /=; set CC := 'C_G(_). +have sCCG: CC \subset G := subsetIl _ _; have pCC := pgroupS sCCG pG. +rewrite (coprime_odd_faithful_Ohm1 pCC) ?(coprimeSg sCCG) ?(oddSg sCCG) //. + by rewrite !(normsI, norms_cent, normG). +rewrite (subset_trans cCEA) // centS // OhmS // setIS // centS //. +rewrite subsetI sEG /= centsC (subset_trans cCEA) // centS //. +have cEE: abelian E := abelem_abelian abelE. +by rewrite -{1}(Ohm1_id abelE) OhmS // subsetI sEG. +Qed. + +(* This is B & G, Theorem 1.13. *) +Theorem critical_odd gT p (G : {group gT}) : + p.-group G -> odd #|G| -> G :!=: 1 -> + {H : {group gT} | + [/\ H \char G, [~: H, G] \subset 'Z(H), nil_class H <= 2, exponent H = p + & p.-group 'C(H | [Aut G])]}. +Proof. +move=> pG oddG ntG; have [H krH]:= Thompson_critical pG. +have [chH sPhiZ sGH_Z scH] := krH; have clH := critical_class2 krH. +have sHG := char_sub chH; set D := 'Ohm_1(H)%G; exists D. +have chD: D \char G := char_trans (Ohm_char 1 H) chH. +have sDH: D \subset H := Ohm_sub 1 H. +have sDG_Z: [~: D, G] \subset 'Z(D). + rewrite subsetI commg_subl char_norm // commGC. + apply: subset_trans (subset_trans sGH_Z _); first by rewrite commgS. + by rewrite subIset // orbC centS. +rewrite nil_class2 !(subset_trans (commgS D _) sDG_Z) ?(char_sub chD) {sDH}//. +have [p_pr p_dv_G _] := pgroup_pdiv pG ntG; have odd_p := dvdn_odd p_dv_G oddG. +split=> {chD sDG_Z}//. + apply/prime_nt_dvdP=> //; last by rewrite exponent_Ohm1_class2 ?(pgroupS sHG). + rewrite -dvdn1 -trivg_exponent /= Ohm1_eq1; apply: contraNneq ntG => H1. + by rewrite -(setIidPl (cents1 G)) -{1}H1 scH H1 center1. +apply/pgroupP=> q q_pr /Cauchy[] //= f. +rewrite astab_ract => /setIdP[Af cDf] ofq; apply: wlog_neg => p'q. +suffices: f \in 'C(H | [Aut G]). + move/(mem_p_elt (critical_p_stab_Aut krH pG))/pnatP=> -> //. + by rewrite ofq. +rewrite astab_ract inE Af; apply/astabP=> x Hx; rewrite /= /aperm /=. +rewrite nil_class2 in clH; have pH := pgroupS sHG pG. +have /p_natP[i ox]: p.-elt x by apply: mem_p_elt Hx. +have{ox}: x ^+ (p ^ i) = 1 by rewrite -ox expg_order. +elim: i x Hx => [|[|i] IHi] x Hx xp1. +- by rewrite [x]xp1 -(autmE Af) morph1. +- by apply: (astabP cDf); rewrite (OhmE 1 pH) mem_gen // !inE Hx xp1 eqxx. +have expH': {in H &, forall y z, [~ y, z] ^+ p = 1}. + move=> y z Hy Hz; apply/eqP. + have /setIP[_ cHyz]: [~ y, z] \in 'Z(H) by rewrite (subsetP clH) // mem_commg. + rewrite -commXg; last exact/commute_sym/(centP cHyz). + suffices /setIP[_ cHyp]: y ^+ p \in 'Z(H) by exact/commgP/(centP cHyp). + rewrite (subsetP sPhiZ) // (Phi_joing pH) mem_gen // inE orbC. + by rewrite (Mho_p_elt 1) ?(mem_p_elt pH). +have Hfx: f x \in H. + case/charP: chH => _ /(_ _ (injm_autm Af) (im_autm Af)) <-. + by rewrite -{1}(autmE Af) mem_morphim // (subsetP sHG). +set y := x^-1 * f x; set z := [~ f x, x^-1]. +have Hy: y \in H by rewrite groupM ?groupV. +have /centerP[_ Zz]: z \in 'Z(H) by rewrite (subsetP clH) // mem_commg ?groupV. +have fy: f y = y. + apply: (IHi); first by rewrite groupM ?groupV. + rewrite expMg_Rmul; try by apply: commute_sym; apply: Zz; rewrite ?groupV. + rewrite -/z bin2odd ?odd_exp // {3}expnS -mulnA expgM expH' ?groupV //. + rewrite expg1n mulg1 expgVn -(autmE Af) -morphX ?(subsetP sHG) //= autmE. + rewrite IHi ?mulVg ?groupX // {2}expnS expgM -(expgM x _ p) -expnSr. + by rewrite xp1 expg1n. +have /eqP: (f ^+ q) x = x * y ^+ q. + elim: (q) => [|j IHj]; first by rewrite perm1 mulg1. + rewrite expgSr permM {}IHj -(autmE Af). + rewrite morphM ?morphX ?groupX ?(subsetP sHG) //= autmE. + by rewrite fy expgS mulgA mulKVg. +rewrite -{1}ofq expg_order perm1 eq_mulVg1 mulKg -order_dvdn. +case: (primeP q_pr) => _ dv_q /dv_q; rewrite order_eq1 -eq_mulVg1. +case/pred2P=> // oyq; case/negP: p'q. +by apply: (pgroupP pH); rewrite // -oyq order_dvdG. +Qed. + +Section CoprimeQuotientPgroup. + +(* This is B & G, Lemma 1.14, which we divide in four lemmas, each one giving *) +(* the (sub)centraliser or (sub)normaliser of a quotient by a coprime p-group *) +(* acting on it. Note that we weaken the assumptions of B & G -- M does not *) +(* need to be normal in G, T need not be a subgroup of G, p need not be a *) +(* prime, and M only needs to be coprime with T. Note also that the subcenter *) +(* quotient lemma is special case of a lemma in coprime_act. *) + +Variables (gT : finGroupType) (p : nat) (T M G : {group gT}). +Hypothesis pT : p.-group T. +Hypotheses (nMT : T \subset 'N(M)) (coMT : coprime #|M| #|T|). + +(* This is B & G, Lemma 1.14, for a global normaliser. *) +Lemma coprime_norm_quotient_pgroup : 'N(T / M) = 'N(T) / M. +Proof. +have [-> | ntT] := eqsVneq T 1; first by rewrite quotient1 !norm1 quotientT. +have [p_pr _ [m oMpm]] := pgroup_pdiv pT ntT. +apply/eqP; rewrite eqEsubset morphim_norms // andbT; apply/subsetP=> Mx. +case: (cosetP Mx) => x Nx ->{Mx} nTqMx. +have sylT: p.-Sylow(M <*> T) T. + rewrite /pHall pT -divgS joing_subr //= norm_joinEr ?coprime_cardMg //. + rewrite mulnK // ?p'natE -?prime_coprime // coprime_sym. + by rewrite -(@coprime_pexpr m.+1) -?oMpm. +have sylTx: p.-Sylow(M <*> T) (T :^ x). + have nMTx: x \in 'N(M <*> T). + rewrite norm_joinEr // inE -quotientSK ?conj_subG ?mul_subG ?normG //. + by rewrite quotientJ // quotientMidl (normP nTqMx). + by rewrite pHallE /= -{1}(normP nMTx) conjSg cardJg -pHallE. +have{sylT sylTx} [ay] := Sylow_trans sylT sylTx. +rewrite /= joingC norm_joinEl //; case/imset2P=> a y Ta. +rewrite -groupV => My ->{ay} defTx; rewrite -(coset_kerr x My). +rewrite mem_morphim //; first by rewrite groupM // (subsetP (normG M)). +by rewrite inE !(conjsgM, defTx) conjsgK conjGid. +Qed. + +(* This is B & G, Lemma 1.14, for a global centraliser. *) +Lemma coprime_cent_quotient_pgroup : 'C(T / M) = 'C(T) / M. +Proof. +symmetry; rewrite -quotientInorm -quotientMidl -['C(T / M)]cosetpreK. +congr (_ / M); set Cq := _ @*^-1 _; set C := 'N_('C(T))(M). +suffices <-: 'N_Cq(T) = C. + rewrite setIC group_modl ?sub_cosetpre //= -/Cq; apply/setIidPr. + rewrite -quotientSK ?subsetIl // cosetpreK. + by rewrite -coprime_norm_quotient_pgroup cent_sub. +apply/eqP; rewrite eqEsubset subsetI -sub_quotient_pre ?subsetIr //. +rewrite quotientInorm quotient_cents //= andbC subIset ?cent_sub //=. +have nMC': 'N_Cq(T) \subset 'N(M) by rewrite subIset ?subsetIl. +rewrite subsetI nMC' andbT (sameP commG1P trivgP) /=. +rewrite -(coprime_TIg coMT) subsetI commg_subr subsetIr andbT. +by rewrite -quotient_cents2 ?sub_quotient_pre ?subsetIl. +Qed. + +Hypothesis sMG : M \subset G. + +(* This is B & G, Lemma 1.14, for a local normaliser. *) +Lemma coprime_subnorm_quotient_pgroup : 'N_(G / M)(T / M) = 'N_G(T) / M. +Proof. by rewrite quotientGI -?coprime_norm_quotient_pgroup. Qed. + +(* This is B & G, Lemma 1.14, for a local centraliser. *) +Lemma coprime_subcent_quotient_pgroup : 'C_(G / M)(T / M) = 'C_G(T) / M. +Proof. by rewrite quotientGI -?coprime_cent_quotient_pgroup. Qed. + +End CoprimeQuotientPgroup. + +Section Constrained. + +Variables (gT : finGroupType) (p : nat) (G : {group gT}). + +(* This is B & G, Proposition 1.15a (Lemma 1.2.3 of P. Hall & G. Higman). *) +Proposition solvable_p_constrained : solvable G -> p.-constrained G. +Proof. +move=> solG P sylP; have [sPO pP _] := and3P sylP; pose K := 'O_p^'(G). +have nKG: G \subset 'N(K) by rewrite normal_norm ?pcore_normal. +have nKC: 'C_G(P) \subset 'N(K) by rewrite subIset ?nKG. +rewrite -(quotientSGK nKC) //; last first. + by rewrite /= -pseries1 (pseries_sub_catl [::_]). +apply: subset_trans (quotient_subcent _ _ _) _ ;rewrite /= -/K. +suffices ->: P / K = 'O_p(G / K). + rewrite quotient_pseries2 -Fitting_eq_pcore ?trivg_pcore_quotient // -/K. + by rewrite cent_sub_Fitting ?morphim_sol. +apply/eqP; rewrite eqEcard -(part_pnat_id (pcore_pgroup _ _)). +have sylPK: p.-Sylow('O_p(G / K)) (P / K). + rewrite -quotient_pseries2 morphim_pHall //. + exact: subset_trans (subset_trans sPO (pseries_sub _ _)) nKG. +by rewrite -(card_Hall sylPK) leqnn -quotient_pseries2 quotientS. +Qed. + +(* This is Gorenstein, Proposition 8.1.3. *) +Proposition p_stable_abelian_constrained : + p.-constrained G -> p.-stable G -> p.-abelian_constrained G. +Proof. +move=> constrG stabG P A sylP cAA /andP[sAP nAP]. +have [sPG pP _] := and3P sylP; have sAG := subset_trans sAP sPG. +set K2 := 'O_{p^', p}(G); pose K1 := 'O_p^'(G); pose Q := P :&: K2. +have sQG: Q \subset G by rewrite subIset ?sPG. +have nK1G: G \subset 'N(K1) by rewrite normal_norm ?pcore_normal. +have nsK2G: K2 <| G := pseries_normal _ _; have [sK2G nK2G] := andP nsK2G. +have sylQ: p.-Sylow(K2) Q by rewrite /Q setIC (Sylow_setI_normal nsK2G). +have defK2: K1 * Q = K2. + have sK12: K1 \subset K2 by rewrite /K1 -pseries1 (pseries_sub_catl [::_]). + apply/eqP; rewrite eqEsubset mulG_subG /= sK12 subsetIr /=. + rewrite -quotientSK ?(subset_trans sK2G) //= quotientIG //= -/K1 -/K2. + rewrite subsetI subxx andbT quotient_pseries2. + by rewrite pcore_sub_Hall // morphim_pHall // ?(subset_trans sPG). +have{cAA} rQAA_1: [~: Q, A, A] = 1. + by apply/commG1P; apply: subset_trans cAA; rewrite commg_subr subIset // nAP. +have nK2A := subset_trans sAG nK2G. +have sAN: A \subset 'N_G(Q) by rewrite subsetI sAG normsI // normsG. +have{stabG rQAA_1 defK2 sQG} stabA: A / 'C_G(Q) \subset 'O_p('N_G(Q) / 'C_G(Q)). + apply: stabG; rewrite //= /psubgroup -/Q ?sAN ?(pgroupS _ pP) ?subsetIl //. + by rewrite defK2 pseries_normal. +rewrite -quotient_sub1 //= -/K2 -(setIidPr sAN). +have nK2N: 'N_G(Q) \subset 'N(K2) by rewrite subIset ?nK2G. +rewrite -[_ / _](morphim_restrm nK2N); set qK2 := restrm _ _. +have{constrG} fqKp: 'ker (coset 'C_G(Q)) \subset 'ker qK2. + by rewrite ker_restrm !ker_coset subsetI subcent_sub constrG. +rewrite -(morphim_factm fqKp (subcent_norm _ _)) -(quotientE A _). +apply: subset_trans {stabA}(morphimS _ stabA) _. +apply: subset_trans (morphim_pcore _ _ _) _. +rewrite morphim_factm morphim_restrm setIid -quotientE. +rewrite /= -quotientMidl /= -/K2 (Frattini_arg _ sylQ) ?pseries_normal //. +by rewrite -quotient_pseries //= (pseries_rcons_id [::_]) trivg_quotient. +Qed. + +End Constrained. + +(* This is B & G, Proposition 1.15b (due to D. Goldschmith). *) +Proposition p'core_cent_pgroup gT p (G R : {group gT}) : + p.-subgroup(G) R -> solvable G -> 'O_p^'('C_G(R)) \subset 'O_p^'(G). +Proof. +case/andP=> sRG pR solG. +without loss p'G1: gT G R sRG pR solG / 'O_p^'(G) = 1. + have nOG_CR: 'C_G(R) \subset 'N('O_p^'(G)) by rewrite subIset ?gFnorm. + move=> IH; rewrite -quotient_sub1 ?(subset_trans (pcore_sub _ _)) //. + apply: subset_trans (morphimF _ _ nOG_CR) _; rewrite /= -quotientE. + rewrite -(coprime_subcent_quotient_pgroup pR) ?pcore_sub //; first 1 last. + - by rewrite (subset_trans sRG) ?gFnorm. + - by rewrite coprime_sym (pnat_coprime _ (pcore_pgroup _ _)). + have p'Gq1 : 'O_p^'(G / 'O_p^'(G)) = 1 := trivg_pcore_quotient p^' G. + by rewrite -p'Gq1 IH ?morphimS ?morphim_pgroup ?morphim_sol. +set M := 'O_p^'('C_G(R)); pose T := 'O_p(G). +have /subsetIP[sMG cMR]: M \subset 'C_G(R) by exact: pcore_sub. +have [p'M pT]: p^'.-group M /\ p.-group T by rewrite !pcore_pgroup. +have nRT: R \subset 'N(T) by rewrite (subset_trans sRG) ?gFnorm. +have pRT: p.-group (R <*> T). + rewrite -(pquotient_pgroup pT) ?join_subG ?nRT ?normG //=. + by rewrite norm_joinEl // quotientMidr morphim_pgroup. +have nRT_M: M \subset 'N(R <*> T). + by rewrite normsY ?(cents_norm cMR) // (subset_trans sMG) ?gFnorm. +have coRT_M: coprime #|R <*> T| #|M| := pnat_coprime pRT p'M. +have cMcR: 'C_(R <*> T)(R) \subset 'C(M). + apply/commG1P; apply/trivgP; rewrite -(coprime_TIg coRT_M) subsetI commg_subr. + rewrite (subset_trans (commSg _ (subsetIl _ _))) ?commg_subl //= -/M. + by apply: subset_trans (gFnorm _ _); rewrite setSI // join_subG sRG pcore_sub. +have cRT_M: M \subset 'C(R <*> T). + rewrite coprime_nil_faithful_cent_stab ?(pgroup_nil pRT) //= -/M. + rewrite subsetI subsetIl (subset_trans _ cMcR) // ?setIS ?centS //. + by rewrite subsetI joing_subl centsC. +have sMT: M \subset T. + have defT: 'F(G) = T := Fitting_eq_pcore p'G1. + rewrite -defT (subset_trans _ (cent_sub_Fitting solG)) // defT subsetI sMG. + by rewrite (subset_trans cRT_M) // centY subsetIr. +by rewrite -(setIidPr sMT) p'G1 coprime_TIg // (pnat_coprime pT). +Qed. + +(* This is B & G, Proposition 1.16, second assertion. Contrary to the text, *) +(* we derive this directly, rather than by induction on the first, because *) +(* this is actually how the proof is done in Gorenstein. Note that the non *) +(* cyclic assumption for A is not needed here. *) +Proposition coprime_abelian_gen_cent gT (A G : {group gT}) : + abelian A -> A \subset 'N(G) -> coprime #|G| #|A| -> + <<\bigcup_(B : {group gT} | cyclic (A / B) && (B <| A)) 'C_G(B)>> = G. +Proof. +move=> abelA nGA coGA; symmetry; move: {2}_.+1 (ltnSn #|G|) => n. +elim: n gT => // n IHn gT in A G abelA nGA coGA *; rewrite ltnS => leGn. +without loss nilG: G nGA coGA leGn / nilpotent G. + move=> {IHn} IHn; apply/eqP; rewrite eqEsubset gen_subG. + apply/andP; split; last by apply/bigcupsP=> B _; exact: subsetIl. + pose T := [set P : {group gT} | Sylow G P & A \subset 'N(P)]. + rewrite -{1}(@Sylow_transversal_gen _ T G) => [|P | p _]; first 1 last. + - by rewrite inE -!andbA; case/and4P. + - have [//|P sylP nPA] := sol_coprime_Sylow_exists p (abelian_sol abelA) nGA. + by exists P; rewrite ?inE ?(p_Sylow sylP). + rewrite gen_subG; apply/bigcupsP=> P {T}/setIdP[/SylowP[p _ sylP] nPA]. + have [sPG pP _] := and3P sylP. + rewrite (IHn P) ?(pgroup_nil pP) ?(coprimeSg sPG) ?genS //. + by apply/bigcupsP=> B cycBq; rewrite (bigcup_max B) ?setSI. + by rewrite (leq_trans (subset_leq_card sPG)). +apply/eqP; rewrite eqEsubset gen_subG. +apply/andP; split; last by apply/bigcupsP=> B _; exact: subsetIl. +have [Z1 | ntZ] := eqsVneq 'Z(G) 1. + by rewrite (TI_center_nil _ (normal_refl G)) ?Z1 ?(setIidPr _) ?sub1G. +have nZA: A \subset 'N('Z(G)) := char_norm_trans (center_char G) nGA. +have{ntZ nZA} [M /= minM] := minnormal_exists ntZ nZA. +rewrite subsetI centsC => /andP[sMG /cents_norm nMG]. +have coMA := coprimeSg sMG coGA; have{nilG} solG := nilpotent_sol nilG. +have [nMA ntM abelM] := minnormal_solvable minM sMG solG. +set GC := <<_>>; have sMGC: M \subset GC. + rewrite sub_gen ?(bigcup_max 'C_A(M)%G) //=; last first. + by rewrite subsetI sMG centsC subsetIr. + case/is_abelemP: abelM => p _ abelM; rewrite -(rker_abelem abelM ntM nMA). + rewrite rker_normal -(setIidPl (quotient_abelian _ _)) ?center_kquo_cyclic //. + exact/abelem_mx_irrP. +rewrite -(quotientSGK nMG sMGC). +have: A / M \subset 'N(G / M) by rewrite morphim_norms. +move/IHn->; rewrite ?morphim_abelian ?coprime_morph {IHn}//; first 1 last. + by rewrite (leq_trans _ leGn) ?ltn_quotient. +rewrite gen_subG; apply/bigcupsP=> Bq; rewrite andbC => /andP[]. +have: M :&: A = 1 by rewrite coprime_TIg. +move/(quotient_isom nMA); case/isomP=> /=; set qM := restrm _ _ => injqM <-. +move=> nsBqA; have sBqA := normal_sub nsBqA. +rewrite -(morphpreK sBqA) /= -/qM; set B := qM @*^-1 Bq. +move: nsBqA; rewrite -(morphpre_normal sBqA) ?injmK //= -/B => nsBA. +rewrite -(morphim_quotm _ nsBA) /= -/B injm_cyclic ?injm_quotm //= => cycBA. +rewrite morphim_restrm -quotientE morphpreIdom -/B; have sBA := normal_sub nsBA. +rewrite -coprime_quotient_cent ?(coprimegS sBA, subset_trans sBA) //= -/B. +by rewrite quotientS ?sub_gen // (bigcup_max [group of B]) ?cycBA. +Qed. + +(* B & G, Proposition 1.16, first assertion. *) +Proposition coprime_abelian_gen_cent1 gT (A G : {group gT}) : + abelian A -> ~~ cyclic A -> A \subset 'N(G) -> coprime #|G| #|A| -> + <<\bigcup_(a in A^#) 'C_G[a]>> = G. +Proof. +move=> abelA ncycA nGA coGA. +apply/eqP; rewrite eq_sym eqEsubset /= gen_subG. +apply/andP; split; last by apply/bigcupsP=> B _; exact: subsetIl. +rewrite -{1}(coprime_abelian_gen_cent abelA nGA) ?genS //. +apply/bigcupsP=> B; have [-> | /trivgPn[a Ba n1a]] := eqsVneq B 1. + by rewrite injm_cyclic ?coset1_injm ?norms1 ?(negbTE ncycA). +case/and3P=> _ sBA _; rewrite (bigcup_max a) ?inE ?n1a ?(subsetP sBA) //. +by rewrite setIS // -cent_set1 centS // sub1set. +Qed. + +Section Focal_Subgroup. + +Variables (gT : finGroupType) (G S : {group gT}) (p : nat). +Hypothesis sylS : p.-Sylow(G) S. + +Import finalg FiniteModule GRing.Theory. + +(* This is B & G, Theorem 1.17 ("Focal Subgroup Theorem", D. G. Higman), also *) +(* Gorenstein Theorem 7.3.4 and Aschbacher (37.4). *) +Theorem focal_subgroup_gen : + S :&: G^`(1) = <<[set [~ x, u] | x in S, u in G & x ^ u \in S]>>. +Proof. +set K := <<_>>; set G' := G^`(1); have [sSG coSiSG] := andP (pHall_Hall sylS). +apply/eqP; rewrite eqEsubset gen_subG andbC; apply/andP; split. + apply/subsetP=> _ /imset2P[x u Sx /setIdP[Gu Sxu] ->]. + by rewrite inE groupM ?groupV // mem_commg // (subsetP sSG). +apply/subsetP=> g /setIP[Sg G'g]; have Gg := subsetP sSG g Sg. +have nKS: S \subset 'N(K). + rewrite norms_gen //; apply/subsetP=> y Sy; rewrite inE. + apply/subsetP=> _ /imsetP[_ /imset2P[x u Sx /setIdP[Gu Sxu] ->] ->]. + have Gy: y \in G := subsetP sSG y Sy. + by rewrite conjRg mem_imset2 ?groupJ // inE -conjJg /= 2?groupJ. +set alpha := restrm_morphism nKS (coset_morphism K). +have alphim: (alpha @* S) = (S / K) by rewrite morphim_restrm setIid. +have abelSK : abelian (alpha @* S). + rewrite alphim sub_der1_abelian // genS //. + apply/subsetP=> _ /imset2P[x y Sx Sy ->]. + by rewrite mem_imset2 // inE (subsetP sSG) ?groupJ. +set ker_trans := 'ker (transfer G abelSK). +have G'ker : G' \subset ker_trans. + rewrite gen_subG; apply/subsetP=> h; case/imset2P=> h1 h2 Gh1 Gh2 ->{h}. + by rewrite !inE groupR // morphR //; apply/commgP; exact: addrC. +have transg0: transfer G abelSK g = 0%R. + by move/kerP: (subsetP G'ker g G'g); exact. +have partX := rcosets_cycle_partition sSG Gg. +have trX := transversalP partX; set X := transversal _ _ in trX. +have /and3P[_ sXG _] := trX. +have gGSeq0: (fmod abelSK (alpha g) *+ #|G : S| = 0)%R. + rewrite -transg0 (transfer_cycle_expansion sSG abelSK Gg trX). + rewrite -(sum_index_rcosets_cycle sSG Gg trX) -sumrMnr /restrm. + apply: eq_bigr=> x Xx; rewrite -[(_ *+ _)%R]morphX ?mem_morphim //=. + rewrite -morphX //= /restrm; congr fmod. + apply/rcoset_kercosetP; rewrite /= -/K. + - by rewrite (subsetP nKS) ?groupX. + - rewrite (subsetP nKS) // conjgE invgK mulgA -mem_rcoset. + exact: mulg_exp_card_rcosets. + rewrite mem_rcoset -{1}[g ^+ _]invgK -conjVg -commgEl mem_gen ?mem_imset2 //. + by rewrite groupV groupX. + rewrite inE conjVg !groupV (subsetP sXG) //= conjgE invgK mulgA -mem_rcoset. + exact: mulg_exp_card_rcosets. +move: (congr_fmod gGSeq0). +rewrite fmval0 morphX ?inE //= fmodK ?mem_morphim // /restrm /=. +move/((congr1 (expgn^~ (expg_invn (S / K) #|G : S|))) _). +rewrite expg1n expgK ?mem_quotient ?coprime_morphl // => Kg1. +by rewrite coset_idr ?(subsetP nKS). +Qed. + +(* This is B & G, Theorem 1.18 (due to Burnside). *) +Theorem Burnside_normal_complement : + 'N_G(S) \subset 'C(S) -> 'O_p^'(G) ><| S = G. +Proof. +move=> cSN; set K := 'O_p^'(G); have [sSG pS _] := and3P sylS. +have /andP[sKG nKG]: K <| G by exact: pcore_normal. +have{nKG} nKS := subset_trans sSG nKG. +have p'K: p^'.-group K by exact: pcore_pgroup. +have{pS p'K} tiKS: K :&: S = 1 by rewrite setIC coprime_TIg ?(pnat_coprime pS). +suffices{tiKS nKS} hallK: p^'.-Hall(G) K. + rewrite sdprodE //= -/K; apply/eqP; rewrite eqEcard ?mul_subG //=. + by rewrite TI_cardMg //= (card_Hall sylS) (card_Hall hallK) mulnC partnC. +pose G' := G^`(1); have nsG'G : G' <| G by rewrite der_normalS. +suffices{K sKG} p'G': p^'.-group G'. + have nsG'K: G' <| K by rewrite (normalS _ sKG) ?pcore_max. + rewrite -(pquotient_pHall p'G') -?pquotient_pcore //= -/G'. + by rewrite nilpotent_pcore_Hall ?abelian_nil ?der_abelian. +suffices{nsG'G} tiSG': S :&: G' = 1. + have sylG'S : p.-Sylow(G') (G' :&: S) by rewrite (Sylow_setI_normal _ sylS). + rewrite /pgroup -[#|_|](partnC p) ?cardG_gt0 // -{sylG'S}(card_Hall sylG'S). + by rewrite /= setIC tiSG' cards1 mul1n part_pnat. +apply/trivgP; rewrite /= focal_subgroup_gen ?(p_Sylow sylS) // gen_subG. +apply/subsetP=> _ /imset2P[x u Sx /setIdP[Gu Sxu] ->]. +have cSS y: y \in S -> S \subset 'C_G[y]. + rewrite subsetI sSG -cent_set1 centsC sub1set; apply: subsetP. + by apply: subset_trans cSN; rewrite subsetI sSG normG. +have{cSS} [v]: exists2 v, v \in 'C_G[x ^ u | 'J] & S :=: (S :^ u) :^ v. + have sylSu : p.-Sylow(G) (S :^ u) by rewrite pHallJ. + have [sSC sCG] := (cSS _ Sxu, subsetIl G 'C[x ^ u]). + rewrite astab1J; apply: (@Sylow_trans p); apply: pHall_subl sCG _ => //=. + by rewrite -conjg_set1 normJ -(conjGid Gu) -conjIg conjSg cSS. +rewrite in_set1 -conjsgM => /setIP[Gv /astab1P cx_uv] nSuv. +apply/conjg_fixP; rewrite -cx_uv /= -conjgM; apply: astabP Sx. +by rewrite astabJ (subsetP cSN) // !inE -nSuv groupM /=. +Qed. + +(* This is B & G, Corollary 1.19(a). *) +Corollary cyclic_Sylow_tiVsub_der1 : + cyclic S -> S :&: G^`(1) = 1 \/ S \subset G^`(1). +Proof. +move=> cycS; have [sSG pS _] := and3P sylS. +have nsSN: S <| 'N_G(S) by rewrite normalSG. +have hallSN: Hall 'N_G(S) S. + by apply: pHall_Hall (pHall_subl _ _ sylS); rewrite ?subsetIl ?normal_sub. +have /splitsP[K /complP[tiSK /= defN]] := SchurZassenhaus_split hallSN nsSN. +have sKN: K \subset 'N_G(S) by rewrite -defN mulG_subr. +have [sKG nSK] := subsetIP sKN. +have coSK: coprime #|S| #|K|. + by case/andP: hallSN => sSN; rewrite -divgS //= -defN TI_cardMg ?mulKn. +have:= coprime_abelian_cent_dprod nSK coSK (cyclic_abelian cycS). +case/(cyclic_pgroup_dprod_trivg pS cycS) => [[_ cSK]|[_ <-]]; last first. + by right; rewrite commgSS. +have cSN: 'N_G(S) \subset 'C(S). + by rewrite -defN mulG_subG -abelianE cyclic_abelian // centsC -cSK subsetIr. +have /sdprodP[_ /= defG _ _] := Burnside_normal_complement cSN. +set Q := 'O_p^'(G) in defG; have nQG: G \subset 'N(Q) := gFnorm _ _. +left; rewrite coprime_TIg ?(pnat_coprime pS) //. +apply: pgroupS (pcore_pgroup _ G); rewrite /= -/Q. +rewrite -quotient_sub1 ?(subset_trans (der_sub _ _)) ?quotientR //= -/Q. +rewrite -defG quotientMidl (sameP trivgP commG1P) -abelianE. +by rewrite morphim_abelian ?cyclic_abelian. +Qed. + +End Focal_Subgroup. + +(* This is B & G, Corollary 1.19(b). *) +Corollary Zgroup_der1_Hall gT (G : {group gT}) : + Zgroup G -> Hall G G^`(1). +Proof. +move=> ZgG; set G' := G^`(1). +rewrite /Hall der_sub coprime_sym coprime_pi' ?cardG_gt0 //=. +apply/pgroupP=> p p_pr pG'; have [P sylP] := Sylow_exists p G. +have cycP: cyclic P by have:= forallP ZgG P; rewrite (p_Sylow sylP). +case: (cyclic_Sylow_tiVsub_der1 sylP cycP) => [tiPG' | sPG']. + have: p.-Sylow(G') (P :&: G'). + by rewrite setIC (Sylow_setI_normal _ sylP) ?gFnormal. + move/card_Hall/eqP; rewrite /= tiPG' cards1 eq_sym. + by rewrite partn_eq1 ?cardG_gt0 // p'natE ?pG'. +rewrite inE /= mem_primes p_pr indexg_gt0 -?p'natE // -partn_eq1 //. +have sylPq: p.-Sylow(G / G') (P / G') by rewrite morphim_pHall ?normsG. +rewrite -card_quotient ?gFnorm // -(card_Hall sylPq) -trivg_card1. +by rewrite /= -quotientMidr mulSGid ?trivg_quotient. +Qed. + +(* This is Aschbacher (39.2). *) +Lemma cyclic_pdiv_normal_complement gT (S G : {group gT}) : + (pdiv #|G|).-Sylow(G) S -> cyclic S -> exists H : {group gT}, H ><| S = G. +Proof. +set p := pdiv _ => sylS cycS; have cSS := cyclic_abelian cycS. +exists 'O_p^'(G)%G; apply: Burnside_normal_complement => //. +have [-> | ntS] := eqsVneq S 1; first exact: cents1. +have [sSG pS p'iSG] := and3P sylS; have [pr_p _ _] := pgroup_pdiv pS ntS. +rewrite -['C(S)]mulg1 -ker_conj_aut -morphimSK ?subsetIr // setIC morphimIdom. +set A_G := _ @* _; pose A := Aut S. +have [_ [_ [cAA _ oAp' _]] _] := cyclic_pgroup_Aut_structure pS cycS ntS. +have{cAA cSS p'iSG} /setIidPl <-: A_G \subset 'O_p^'(A). + rewrite pcore_max -?sub_abelian_normal ?Aut_conj_aut //=. + apply: pnat_dvd p'iSG; rewrite card_morphim ker_conj_aut /= setIC. + have sSN: S \subset 'N_G(S) by rewrite subsetI sSG normG. + by apply: dvdn_trans (indexSg sSN (subsetIl G 'N(S))); apply: indexgS. +rewrite coprime_TIg ?sub1G // coprime_morphl // coprime_sym coprime_pi' //. +apply/pgroupP=> q pr_q q_dv_G; rewrite !inE mem_primes gtnNdvd ?andbF // oAp'. +by rewrite prednK ?prime_gt0 ?pdiv_min_dvd ?prime_gt1. +Qed. + +(* This is Aschbacher (39.3). *) +Lemma Zgroup_metacyclic gT (G : {group gT}) : Zgroup G -> metacyclic G. +Proof. +elim: {G}_.+1 {-2}G (ltnSn #|G|) => // n IHn G; rewrite ltnS => leGn ZgG. +have{n IHn leGn} solG: solvable G. + have [-> | ntG] := eqsVneq G 1; first exact: solvable1. + have [S sylS] := Sylow_exists (pdiv #|G|) G. + have cycS: cyclic S := forall_inP ZgG S (p_Sylow sylS). + have [H defG] := cyclic_pdiv_normal_complement sylS cycS. + have [nsHG _ _ _ _] := sdprod_context defG; rewrite (series_sol nsHG) andbC. + rewrite -(isog_sol (sdprod_isog defG)) (abelian_sol (cyclic_abelian cycS)). + rewrite metacyclic_sol ?IHn ?(ZgroupS _ ZgG) ?normal_sub //. + rewrite (leq_trans _ leGn) // -(sdprod_card defG) ltn_Pmulr // cardG_gt1. + by rewrite -rank_gt0 (rank_Sylow sylS) p_rank_gt0 pi_pdiv cardG_gt1. +pose K := 'F(G)%G; apply/metacyclicP; exists K. +have nsKG: K <| G := Fitting_normal G; have [sKG nKG] := andP nsKG. +have cycK: cyclic K by rewrite nil_Zgroup_cyclic ?Fitting_nil ?(ZgroupS sKG). +have cKK: abelian K := cyclic_abelian cycK. +have{solG cKK} defK: 'C_G(K) = K. + by apply/setP/subset_eqP; rewrite cent_sub_Fitting // subsetI sKG. +rewrite cycK nil_Zgroup_cyclic ?morphim_Zgroup ?abelian_nil //. +rewrite -defK -ker_conj_aut (isog_abelian (first_isog_loc _ _)) //. +exact: abelianS (Aut_conj_aut K G) (Aut_cyclic_abelian cycK). +Qed. + +(* This is B & G, Theorem 1.20 (Maschke's Theorem) for internal action on *) +(* elementary abelian subgroups; a more general case, for linear *) +(* represenations on matrices, can be found in mxrepresentation.v. *) +Theorem Maschke_abelem gT p (G V U : {group gT}) : + p.-abelem V -> p^'.-group G -> U \subset V -> + G \subset 'N(V) -> G \subset 'N(U) -> + exists2 W : {group gT}, U \x W = V & G \subset 'N(W). +Proof. +move=> pV p'G sUV nVG nUG. +have splitU: [splits V, over U] := abelem_splits pV sUV. +case/and3P: pV => pV abV; have cUV := subset_trans sUV abV. +have sVVG := joing_subl V G. +have{nUG} nUVG: U <| V <*> G. + by rewrite /(U <| _) join_subG (subset_trans sUV) // cents_norm // centsC. +rewrite -{nUVG}(Gaschutz_split nUVG) ?(abelianS sUV) // in splitU; last first. + rewrite -divgS ?joing_subl //= norm_joinEr //. + have coVG: coprime #|V| #|G| := pnat_coprime pV p'G. + by rewrite coprime_cardMg // mulnC mulnK // (coprimeSg sUV). +case/splitsP: splitU => WG /complP[tiUWG /= defVG]. +exists (WG :&: V)%G. + rewrite dprodE; last by rewrite setIA tiUWG (setIidPl _) ?sub1G. + by rewrite group_modl // defVG (setIidPr _). + by rewrite subIset // orbC centsC cUV. +rewrite (subset_trans (joing_subr V _)) // -defVG mul_subG //. + by rewrite cents_norm ?(subset_trans cUV) ?centS ?subsetIr. +rewrite normsI ?normG // (subset_trans (mulG_subr U _)) //. +by rewrite defVG join_subG normG. +Qed. + +Section Plength1. + +Variables (gT : finGroupType) (p : nat). +Implicit Types G H : {group gT}. + +(* Some basic properties of p.-length_1 that are direct consequences of their *) +(* definition using p-series. *) + +Lemma plength1_1 : p.-length_1 (1 : {set gT}). +Proof. by rewrite -[_ 1]subG1 pseries_sub. Qed. + +Lemma plength1_p'group G : p^'.-group G -> p.-length_1 G. +Proof. +move=> p'G; rewrite [p.-length_1 G]eqEsubset pseries_sub /=. +by rewrite -{1}(pcore_pgroup_id p'G) -pseries1 pseries_sub_catl. +Qed. + +Lemma plength1_nonprime G : ~~ prime p -> p.-length_1 G. +Proof. +move=> not_p_pr; rewrite plength1_p'group // p'groupEpi mem_primes. +by rewrite (negPf not_p_pr). +Qed. + +Lemma plength1_pcore_quo_Sylow G (Gb := G / 'O_p^'(G)) : + p.-length_1 G = p.-Sylow(Gb) 'O_p(Gb). +Proof. +rewrite /plength_1 eqEsubset pseries_sub /=. +rewrite (pseries_rcons _ [:: _; _]) -sub_quotient_pre ?gFnorm //=. +rewrite /pHall pcore_sub pcore_pgroup /= -card_quotient ?gFnorm //=. +rewrite -quotient_pseries2 /= {}/Gb -(pseries1 _ G). +rewrite (card_isog (third_isog _ _ _)) ?pseries_normal ?pseries_sub_catl //. +apply/idP/idP=> p'Gbb; last by rewrite (pcore_pgroup_id p'Gbb). +exact: pgroupS p'Gbb (pcore_pgroup _ _). +Qed. + +Lemma plength1_pcore_Sylow G : + 'O_p^'(G) = 1 -> p.-length_1 G = p.-Sylow(G) 'O_p(G). +Proof. +move=> p'G1; rewrite plength1_pcore_quo_Sylow -quotient_pseries2. +by rewrite p'G1 pseries_pop2 // pquotient_pHall ?normal1 ?pgroup1. +Qed. + +(* This is the characterization given in Section 10 of B & G, p. 75, just *) +(* before Theorem 10.6. *) +Lemma plength1_pseries2_quo G : p.-length_1 G = p^'.-group (G / 'O_{p^', p}(G)). +Proof. +rewrite /plength_1 eqEsubset pseries_sub lastI pseries_rcons /=. +rewrite -sub_quotient_pre ?gFnorm //. +by apply/idP/idP=> pl1G; rewrite ?pcore_pgroup_id ?(pgroupS pl1G) ?pcore_pgroup. +Qed. + +(* This is B & G, Lemma 1.21(a). *) +Lemma plength1S G H : H \subset G -> p.-length_1 G -> p.-length_1 H. +Proof. +rewrite /plength_1 => sHG pG1; rewrite eqEsubset pseries_sub. +by apply: subset_trans (pseriesS _ sHG); rewrite (eqP pG1) (setIidPr _). +Qed. + +Lemma plength1_quo G H : p.-length_1 G -> p.-length_1 (G / H). +Proof. +rewrite /plength_1 => pG1; rewrite eqEsubset pseries_sub. +by rewrite -{1}(eqP pG1) morphim_pseries. +Qed. + +(* This is B & G, Lemma 1.21(b). *) +Lemma p'quo_plength1 G H : + H <| G -> p^'.-group H -> p.-length_1 (G / H) = p.-length_1 G. +Proof. +rewrite /plength_1 => nHG p'H; apply/idP/idP; last exact: plength1_quo. +move=> pGH1; rewrite eqEsubset pseries_sub. +have nOG: 'O_{p^'}(G) <| G by exact: pseries_normal. +rewrite -(quotientSGK (normal_norm nOG)) ?(pseries_sub_catl [:: _]) //. +have [|f f_inj im_f] := third_isom _ nHG nOG. + by rewrite /= pseries1 pcore_max. +rewrite (quotient_pseries_cat [:: _]) -{}im_f //= -injmF //. +rewrite {f f_inj}morphimS // pseries1 -pquotient_pcore // -pseries1 /=. +by rewrite -quotient_pseries_cat /= (eqP pGH1). +Qed. + +(* This is B & G, Lemma 1.21(c). *) +Lemma pquo_plength1 G H : + H <| G -> p.-group H -> 'O_p^'(G / H) = 1-> + p.-length_1 (G / H) = p.-length_1 G. +Proof. +rewrite /plength_1 => nHG pH trO; apply/idP/idP; last exact: plength1_quo. +rewrite (pseries_pop _ trO) => pGH1; rewrite eqEsubset pseries_sub /=. +rewrite pseries_pop //; last first. + apply/eqP; rewrite -subG1; have <-: H :&: 'O_p^'(G) = 1. + by apply: coprime_TIg; exact: pnat_coprime (pcore_pgroup _ _). + rewrite setIC subsetI subxx -quotient_sub1. + by rewrite -trO morphim_pcore. + apply: subset_trans (normal_norm nHG); exact: pcore_sub. +have nOG: 'O_{p}(G) <| G by exact: pseries_normal. +rewrite -(quotientSGK (normal_norm nOG)) ?(pseries_sub_catl [:: _]) //. +have [|f f_inj im_f] := third_isom _ nHG nOG. + by rewrite /= pseries1 pcore_max. +rewrite (quotient_pseries [::_]) -{}im_f //= -injmF //. +rewrite {f f_inj}morphimS // pseries1 -pquotient_pcore // -(pseries1 p) /=. +by rewrite -quotient_pseries /= (eqP pGH1). +Qed. + +Canonical p_elt_gen_group A : {group gT} := + Eval hnf in [group of p_elt_gen p A]. + +(* Note that p_elt_gen could be a functor. *) +Lemma p_elt_gen_normal G : p_elt_gen p G <| G. +Proof. +apply/normalP; split=> [|x Gx]. + by rewrite gen_subG; apply/subsetP=> x; rewrite inE; case/andP. +rewrite -genJ; congr <<_>>; apply/setP=> y; rewrite mem_conjg !inE. +by rewrite p_eltJ -mem_conjg conjGid. +Qed. + +(* This is B & G, Lemma 1.21(d). *) +Lemma p_elt_gen_length1 G : + p.-length_1 G = p^'.-Hall(p_elt_gen p G) 'O_p^'(p_elt_gen p G). +Proof. +rewrite /pHall pcore_sub pcore_pgroup pnatNK /= /plength_1. +have nUG := p_elt_gen_normal G; have [sUG nnUG]:= andP nUG. +apply/idP/idP=> [p1G | pU]. + apply: (@pnat_dvd _ #|p_elt_gen p G : 'O_p^'(G)|). + by rewrite -[#|_ : 'O_p^'(G)|]indexgI indexgS ?pcoreS. + apply: (@pnat_dvd _ #|'O_p(G / 'O_{p^'}(G))|); last exact: pcore_pgroup. + rewrite -card_quotient; last first. + by rewrite (subset_trans sUG) // normal_norm ?pcore_normal. + rewrite -quotient_pseries pseries1 cardSg ?morphimS //=. + rewrite gen_subG; apply/subsetP=> x; rewrite inE; case/andP=> Gx p_x. + have nOx: x \in 'N('O_{p^',p}(G)). + by apply: subsetP Gx; rewrite normal_norm ?pseries_normal. + rewrite coset_idr //; apply/eqP; rewrite -[coset _ x]expg1 -order_dvdn. + rewrite [#[_]](@pnat_1 p) //; first exact: morph_p_elt. + apply: mem_p_elt (pcore_pgroup _ (G / _)) _. + by rewrite /= -quotient_pseries /= (eqP p1G); apply/morphimP; exists x. +have nOG: 'O_{p^', p}(G) <| G by exact: pseries_normal. +rewrite eqEsubset pseries_sub. +rewrite -(quotientSGK (normal_norm nOG)) ?(pseries_sub_catl [:: _; _]) //=. +rewrite (quotient_pseries [::_;_]) pcore_max //. +rewrite /pgroup card_quotient ?normal_norm //. +apply: (@pnat_dvd _ #|G : p_elt_gen p G|); last first. + case p_pr: (prime p); last by rewrite p'natEpi // mem_primes p_pr. + rewrite -card_quotient // p'natE //; apply/negP=> /Cauchy[] // Ux. + case/morphimP=> x Nx Gx -> /= oUx_p; have:= prime_gt1 p_pr. + rewrite -(part_pnat_id (pnat_id p_pr)) -{1}oUx_p {oUx_p} -order_constt. + rewrite -morph_constt //= coset_id ?order1 //. + by rewrite mem_gen // inE groupX // p_elt_constt. +apply: indexgS. +have nOU: p_elt_gen p G \subset 'N('O_{p^'}(G)). + by rewrite (subset_trans sUG) // normal_norm ?pseries_normal. +rewrite -(quotientSGK nOU) ?(pseries_sub_catl [:: _]) //=. +rewrite (quotient_pseries [::_]) pcore_max ?morphim_normal //. +rewrite /pgroup card_quotient //= pseries1; apply: pnat_dvd pU. +apply: indexgS; rewrite pcore_max ?pcore_pgroup //. +apply: char_normal_trans nUG; exact: pcore_char. +Qed. + +End Plength1. + +(* This is B & G, Lemma 1.21(e). *) +Lemma quo2_plength1 gT p (G H K : {group gT}) : + H <| G -> K <| G -> H :&: K = 1 -> + p.-length_1 (G / H) && p.-length_1 (G / K) = p.-length_1 G. +Proof. +move=> nHG nKG trHK. +have [p_pr | p_nonpr] := boolP (prime p); last by rewrite !plength1_nonprime. +apply/andP/idP=> [[pH1 pK1] | pG1]; last by rewrite !plength1_quo. +pose U := p_elt_gen p G; have nU : U <| G by exact: p_elt_gen_normal. +have exB (N : {group gT}) : + N <| G -> p.-length_1 (G / N) -> + exists B : {group gT}, + [/\ U \subset 'N(B), + forall x, x \in B -> #[x] = p -> x \in N + & forall Q : {group gT}, p^'.-subgroup(U) Q -> Q \subset B]. +- move=> nsNG; have [sNG nNG] := andP nsNG. + rewrite p_elt_gen_length1 // (_ : p_elt_gen _ _ = U / N); last first. + rewrite /quotient morphim_gen -?quotientE //; last first. + by rewrite setIdE subIset ?nNG. + congr <<_>>; apply/setP=> Nx; rewrite inE setIdE quotientGI // inE. + apply: andb_id2l => /morphimP[x NNx Gx ->{Nx}] /=. + apply/idP/idP=> [pNx | /morphimP[y NNy]]; last first. + by rewrite inE => p_y ->; exact: morph_p_elt. + rewrite -(constt_p_elt pNx) -morph_constt // mem_morphim ?groupX //. + by rewrite inE p_elt_constt. + have nNU: U \subset 'N(N) := subset_trans (normal_sub nU) nNG. + have nN_UN: U <*> N \subset 'N(N) by rewrite gen_subG subUset normG nNU. + case/(inv_quotientN _): (pcore_normal p^' [group of U <*> N / N]) => /= [|B]. + by rewrite /normal sub_gen ?subsetUr. + rewrite /= quotientYidr //= /U => defB sNB; case/andP=> sB nB hallB. + exists B; split=> [| x Ux p_x | Q /andP[sQU p'Q]]. + - by rewrite (subset_trans (sub_gen _) nB) ?subsetUl. + - have nNx: x \in 'N(N) by rewrite (subsetP nN_UN) ?(subsetP sB). + apply: coset_idr => //; rewrite -[coset N x](consttC p). + rewrite !(constt1P _) ?mulg1 // ?p_eltNK. + by rewrite morph_p_elt // /p_elt p_x pnat_id. + have: coset N x \in B / N by apply/morphimP; exists x. + by apply: mem_p_elt; rewrite /= -defB pcore_pgroup. + rewrite -(quotientSGK (subset_trans sQU nNU) sNB). + by rewrite -defB (sub_Hall_pcore hallB) ?quotientS ?quotient_pgroup. +have{pH1} [A [nAU pA p'A]] := exB H nHG pH1. +have{pK1 exB} [B [nBU pB p'B]] := exB K nKG pK1. +rewrite p_elt_gen_length1 //; apply: normal_max_pgroup_Hall (pcore_normal _ _). +apply/maxgroupP; split; first by rewrite /psubgroup pcore_sub pcore_pgroup. +move=> Q p'Q sOQ; apply/eqP; rewrite eqEsubset sOQ andbT. +apply: subset_trans (_ : U :&: (A :&: B) \subset _); last rewrite /U. + by rewrite !subsetI p'A ?p'B //; case/andP: p'Q => ->. +apply: pcore_max; last by rewrite /normal subsetIl !normsI ?normG. +rewrite /pgroup p'natE //. +apply/negP=> /Cauchy[] // x /setIP[_ /setIP[Ax Bx]] oxp. +suff: x \in 1%G by move/set1P=> x1; rewrite -oxp x1 order1 in p_pr. +by rewrite /= -trHK inE pA ?pB. +Qed. + +(* B & G Lemma 1.22 is covered by sylow.normal_pgroup. *) + +(* Encapsulation of the use of the order of GL_2(p), via abelem groups. *) +Lemma logn_quotient_cent_abelem gT p (A E : {group gT}) : + A \subset 'N(E) -> p.-abelem E -> logn p #|E| <= 2 -> + logn p #|A : 'C_A(E)| <= 1. +Proof. +move=> nEA abelE maxdimE; have [-> | ntE] := eqsVneq E 1. + by rewrite (setIidPl (cents1 _)) indexgg logn1. +pose rP := abelem_repr abelE ntE nEA. +have [p_pr _ _] := pgroup_pdiv (abelem_pgroup abelE) ntE. +have ->: 'C_A(E) = 'ker (reprGLm rP) by rewrite ker_reprGLm rker_abelem. +rewrite -card_quotient ?ker_norm // (card_isog (first_isog _)). +apply: leq_trans (dvdn_leq_log _ _ (cardSg (subsetT _))) _ => //. +rewrite logn_card_GL_p ?(dim_abelemE abelE) //. +by case: logn maxdimE; do 2?case. +Qed. + +End BGsection1. + +Section PuigSeriesGroups. + +Implicit Type gT : finGroupType. + +Canonical Puig_succ_group gT (D E : {set gT}) := [group of 'L_[D](E)]. + +Fact Puig_at_group_set n gT D : @group_set gT 'L_{n}(D). +Proof. case: n => [|n]; exact: groupP. Qed. + +Canonical Puig_at_group n gT D := Group (@Puig_at_group_set n gT D). +Canonical Puig_inf_group gT (D : {set gT}) := [group of 'L_*(D)]. +Canonical Puig_group gT (D : {set gT}) := [group of 'L(D)]. + +End PuigSeriesGroups. + +Notation "''L_[' G ] ( L )" := (Puig_succ_group G L) : Group_scope. +Notation "''L_{' n } ( G )" := (Puig_at_group n G) + (at level 8, format "''L_{' n } ( G )") : Group_scope. +Notation "''L_*' ( G )" := (Puig_inf_group G) : Group_scope. +Notation "''L' ( G )" := (Puig_group G) : Group_scope. + +(* Elementary properties of the Puig series. *) +Section PuigBasics. + +Variable gT : finGroupType. +Implicit Types (D E : {set gT}) (G H : {group gT}). + +Lemma Puig0 D : 'L_{0}(D) = 1. Proof. by []. Qed. +Lemma PuigS n D : 'L_{n.+1}(D) = 'L_[D]('L_{n}(D)). Proof. by []. Qed. +Lemma Puig_recE n D : Puig_rec n D = 'L_{n}(D). Proof. by []. Qed. +Lemma Puig_def D : 'L(D) = 'L_[D]('L_*(D)). Proof. by []. Qed. + +Local Notation "D --> E" := (generated_by (norm_abelian D) E) + (at level 70, no associativity) : group_scope. + +Lemma Puig_gen D E : E --> 'L_[D](E). +Proof. by apply/existsP; exists (subgroups D). Qed. + +Lemma Puig_max G D E : D --> E -> E \subset G -> E \subset 'L_[G](D). +Proof. +case/existsP=> gE /eqP <-{E}; rewrite !gen_subG. +move/bigcupsP=> sEG; apply/bigcupsP=> A gEA; have [_ abnA]:= andP gEA. +by rewrite sub_gen // bigcup_sup // inE sEG. +Qed. + +Lemma norm_abgenS D1 D2 E : D1 \subset D2 -> D2 --> E -> D1 --> E. +Proof. +move=> sD12 /exists_eqP[gE <-{E}]. +apply/exists_eqP; exists [set A in gE | norm_abelian D2 A]. +congr <<_>>; apply: eq_bigl => A; rewrite !inE. +apply: andb_idr => /and3P[_ nAD cAA]. +by apply/andP; rewrite (subset_trans sD12). +Qed. + +Lemma Puig_succ_sub G D : 'L_[G](D) \subset G. +Proof. by rewrite gen_subG; apply/bigcupsP=> A /andP[]; rewrite inE. Qed. + +Lemma Puig_at_sub n G : 'L_{n}(G) \subset G. +Proof. by case: n => [|n]; rewrite ?sub1G ?Puig_succ_sub. Qed. + +(* This is B & G, Lemma B.1(d), first part. *) +Lemma Puig_inf_sub G : 'L_*(G) \subset G. +Proof. exact: Puig_at_sub. Qed. + +Lemma Puig_sub G : 'L(G) \subset G. +Proof. exact: Puig_at_sub. Qed. + +(* This is part of B & G, Lemma B.1(b). *) +Lemma Puig1 G : 'L_{1}(G) = G. +Proof. +apply/eqP; rewrite eqEsubset Puig_at_sub; apply/subsetP=> x Gx. +rewrite -cycle_subG sub_gen // -[<[x]>]/(gval _) bigcup_sup //=. +by rewrite inE cycle_subG Gx /= /norm_abelian cycle_abelian sub1G. +Qed. + +End PuigBasics. + +(* Functoriality of the Puig series. *) + +Fact Puig_at_cont n : GFunctor.iso_continuous (Puig_at n). +Proof. +elim: n => [|n IHn] aT rT G f injf; first by rewrite morphim1. +have IHnS := Puig_at_sub n; pose func_n := [igFun by IHnS & !IHn]. +rewrite !PuigS sub_morphim_pre ?Puig_succ_sub // gen_subG; apply/bigcupsP=> A. +rewrite inE => /and3P[sAG nAL cAA]; rewrite -sub_morphim_pre ?sub_gen //. +rewrite -[f @* A]/(gval _) bigcup_sup // inE morphimS // /norm_abelian. +rewrite morphim_abelian // -['L_{n}(_)](injmF func_n injf) //=. +by rewrite morphim_norms. +Qed. + +Canonical Puig_at_igFun n := [igFun by Puig_at_sub^~ n & !Puig_at_cont n]. + +Fact Puig_inf_cont : GFunctor.iso_continuous Puig_inf. +Proof. +by move=> aT rT G f injf; rewrite /Puig_inf card_injm // Puig_at_cont. +Qed. + +Canonical Puig_inf_igFun := [igFun by Puig_inf_sub & !Puig_inf_cont]. + +Fact Puig_cont : GFunctor.iso_continuous Puig. +Proof. by move=> aT rT G f injf; rewrite /Puig card_injm // Puig_at_cont. Qed. + +Canonical Puig_igFun := [igFun by Puig_sub & !Puig_cont]. diff --git a/mathcomp/odd_order/BGsection10.v b/mathcomp/odd_order/BGsection10.v new file mode 100644 index 0000000..88b4c39 --- /dev/null +++ b/mathcomp/odd_order/BGsection10.v @@ -0,0 +1,1497 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div path fintype. +Require Import bigop finset prime fingroup morphism perm automorphism quotient. +Require Import action gproduct gfunctor pgroup cyclic center commutator. +Require Import gseries nilpotent sylow abelian maximal hall. +Require Import BGsection1 BGsection3 BGsection4 BGsection5 BGsection6. +Require Import BGsection7 BGsection9. + +(******************************************************************************) +(* This file covers B & G, section 10, including with the definitions: *) +(* \alpha(M) == the primes p such that M has p-rank at least 3. *) +(* \beta(M) == the primes p in \alpha(M) such that Sylow p-subgroups of M *) +(* are not narrow (see BGsection5), i.e., such that M contains *) +(* no maximal elementary abelian subgroups of rank 2. In a *) +(* minimal counter-example G, \beta(M) is the intersection of *) +(* \alpha(M) and \beta(G). Note that B & G refers to primes in *) +(* \beta(G) as ``ideal'' primes, somewhat inconsistently. *) +(* \sigma(M) == the primes p such that there exists a p-Sylow subgroup P *) +(* of M whose normaliser (in the minimal counter-example) is *) +(* contained in M. *) +(* M`_\alpha == the \alpha(M)-core of M. *) +(* M`_\beta == the \beta(M)-core of M. *) +(* M`_\sigma == the \sigma(M)-core of M. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Reserved Notation "\alpha ( M )" (at level 2, format "\alpha ( M )"). +Reserved Notation "\beta ( M )" (at level 2, format "\beta ( M )"). +Reserved Notation "\sigma ( M )" (at level 2, format "\sigma ( M )"). + +Reserved Notation "M `_ \alpha" (at level 3, format "M `_ \alpha"). +Reserved Notation "M `_ \beta" (at level 3, format "M `_ \beta"). +Reserved Notation "M `_ \sigma" (at level 3, format "M `_ \sigma"). + +Section Def. + +Variable gT : finGroupType. +Implicit Type p : nat. + +Variable M : {set gT}. + +Definition alpha := [pred p | 2 < 'r_p(M)]. +Definition alpha_core := 'O_alpha(M). +Canonical Structure alpha_core_group := Eval hnf in [group of alpha_core]. + +Definition beta := + [pred p | [forall (P : {group gT} | p.-Sylow(M) P), ~~ p.-narrow P]]. +Definition beta_core := 'O_beta(M). +Canonical Structure beta_core_group := Eval hnf in [group of beta_core]. + +Definition sigma := + [pred p | [exists (P : {group gT} | p.-Sylow(M) P), 'N(P) \subset M]]. +Definition sigma_core := 'O_sigma(M). +Canonical Structure sigma_core_group := Eval hnf in [group of sigma_core]. + +End Def. + +Notation "\alpha ( M )" := (alpha M) : group_scope. +Notation "M `_ \alpha" := (alpha_core M) : group_scope. +Notation "M `_ \alpha" := (alpha_core_group M) : Group_scope. + +Notation "\beta ( M )" := (beta M) : group_scope. +Notation "M `_ \beta" := (beta_core M) : group_scope. +Notation "M `_ \beta" := (beta_core_group M) : Group_scope. + +Notation "\sigma ( M )" := (sigma M) : group_scope. +Notation "M `_ \sigma" := (sigma_core M) : group_scope. +Notation "M `_ \sigma" := (sigma_core_group M) : Group_scope. + +Section CoreTheory. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). +Implicit Type x : gT. +Implicit Type P : {group gT}. + +Section GenericCores. + +Variables H K : {group gT}. + +Lemma sigmaJ x : \sigma(H :^ x) =i \sigma(H). +Proof. +move=> p; apply/exists_inP/exists_inP=> [] [P sylP sNH]; last first. + by exists (P :^ x)%G; rewrite ?pHallJ2 // normJ conjSg. +by exists (P :^ x^-1)%G; rewrite ?normJ ?sub_conjgV // -(pHallJ2 _ _ _ x) actKV. +Qed. + +Lemma MsigmaJ x : (H :^ x)`_\sigma = H`_\sigma :^ x. +Proof. by rewrite /sigma_core -(eq_pcore H (sigmaJ x)) pcoreJ. Qed. + +Lemma alphaJ x : \alpha(H :^ x) =i \alpha(H). +Proof. by move=> p; rewrite !inE /= p_rankJ. Qed. + +Lemma MalphaJ x : (H :^ x)`_\alpha = H`_\alpha :^ x. +Proof. by rewrite /alpha_core -(eq_pcore H (alphaJ x)) pcoreJ. Qed. + +Lemma betaJ x : \beta(H :^ x) =i \beta(H). +Proof. +move=> p; apply/forall_inP/forall_inP=> nnSylH P sylP. + by rewrite -(@narrowJ _ _ _ x) nnSylH ?pHallJ2. +by rewrite -(@narrowJ _ _ _ x^-1) nnSylH // -(pHallJ2 _ _ _ x) actKV. +Qed. + +Lemma MbetaJ x : (H :^ x)`_\beta = H`_\beta :^ x. +Proof. by rewrite /beta_core -(eq_pcore H (betaJ x)) pcoreJ. Qed. + +End GenericCores. + +(* This remark appears at the start (p. 70) of B & G, Section 10, just after *) +(* the definition of ideal, which we do not include, since it is redundant *) +(* with the notation p \in \beta(G) that is used later. *) +Remark not_narrow_ideal p P : p.-Sylow(G) P -> ~~ p.-narrow P -> p \in \beta(G). +Proof. +move=> sylP nnP; apply/forall_inP=> Q sylQ. +by have [x _ ->] := Sylow_trans sylP sylQ; rewrite narrowJ. +Qed. + +Section MaxCores. + +Variables M : {group gT}. +Hypothesis maxM : M \in 'M. + +(* This is the first inclusion in the remark following the preliminary *) +(* definitions in B & G, p. 70. *) +Remark beta_sub_alpha : {subset \beta(M) <= \alpha(M)}. +Proof. +move=> p; rewrite !inE /= => /forall_inP nnSylM. +have [P sylP] := Sylow_exists p M; have:= nnSylM P sylP. +by rewrite negb_imply (p_rank_Sylow sylP) => /andP[]. +Qed. + +Remark alpha_sub_sigma : {subset \alpha(M) <= \sigma(M)}. +Proof. +move=> p a_p; have [P sylP] := Sylow_exists p M; have [sPM pP _ ] := and3P sylP. +have{a_p} rP: 2 < 'r(P) by rewrite (rank_Sylow sylP). +apply/exists_inP; exists P; rewrite ?uniq_mmax_norm_sub //. +exact: def_uniq_mmax (rank3_Uniqueness (mFT_pgroup_proper pP) rP) maxM sPM. +Qed. + +Remark beta_sub_sigma : {subset \beta(M) <= \sigma(M)}. +Proof. by move=> p; move/beta_sub_alpha; exact: alpha_sub_sigma. Qed. + +Remark Mbeta_sub_Malpha : M`_\beta \subset M`_\alpha. +Proof. exact: sub_pcore beta_sub_alpha. Qed. + +Remark Malpha_sub_Msigma : M`_\alpha \subset M`_\sigma. +Proof. exact: sub_pcore alpha_sub_sigma. Qed. + +Remark Mbeta_sub_Msigma : M`_\beta \subset M`_\sigma. +Proof. exact: sub_pcore beta_sub_sigma. Qed. + +(* This is the first part of the remark just above B & G, Theorem 10.1. *) +Remark norm_sigma_Sylow p P : + p \in \sigma(M) -> p.-Sylow(M) P -> 'N(P) \subset M. +Proof. +case/exists_inP=> Q sylQ sNPM sylP. +by case: (Sylow_trans sylQ sylP) => m mM ->; rewrite normJ conj_subG. +Qed. + +(* This is the second part of the remark just above B & G, Theorem 10.1. *) +Remark sigma_Sylow_G p P : p \in \sigma(M) -> p.-Sylow(M) P -> p.-Sylow(G) P. +Proof. +move=> sMp sylP; apply: (mmax_sigma_Sylow maxM) => //. +exact: norm_sigma_Sylow sMp sylP. +Qed. + +Lemma sigma_Sylow_neq1 p P : p \in \sigma(M) -> p.-Sylow(M) P -> P :!=: 1. +Proof. +move=> sMp /(norm_sigma_Sylow sMp); apply: contraTneq => ->. +by rewrite norm1 subTset -properT mmax_proper. +Qed. + +Lemma sigma_sub_pi : {subset \sigma(M) <= \pi(M)}. +Proof. +move=> p sMp; have [P sylP]:= Sylow_exists p M. +by rewrite -p_rank_gt0 -(rank_Sylow sylP) rank_gt0 (sigma_Sylow_neq1 sMp sylP). +Qed. + +Lemma predI_sigma_alpha : [predI \sigma(M) & \alpha(G)] =i \alpha(M). +Proof. +move=> p; rewrite inE /= -(andb_idl (@alpha_sub_sigma p)). +apply: andb_id2l => sMp; have [P sylP] := Sylow_exists p M. +by rewrite !inE -(rank_Sylow sylP) -(rank_Sylow (sigma_Sylow_G sMp sylP)). +Qed. + +Lemma predI_sigma_beta : [predI \sigma(M) & \beta(G)] =i \beta(M). +Proof. +move=> p; rewrite inE /= -(andb_idl (@beta_sub_sigma p)). +apply: andb_id2l => sMp; apply/idP/forall_inP=> [bGp P sylP | nnSylM]. + exact: forall_inP bGp P (sigma_Sylow_G sMp sylP). +have [P sylP] := Sylow_exists p M. +exact: not_narrow_ideal (sigma_Sylow_G sMp sylP) (nnSylM P sylP). +Qed. + +End MaxCores. + +End CoreTheory. + +Section Ten. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). + +Implicit Type p : nat. +Implicit Type A E H K M N P Q R S V W X Y : {group gT}. + +(* This is B & G, Theorem 10.1(d); note that we do not assume M is maximal. *) +Theorem sigma_Sylow_trans M p X g : + p \in \sigma(M) -> p.-Sylow(M) X -> X :^ g \subset M -> g \in M. +Proof. +move=> sMp sylX sXgM; have pX := pHall_pgroup sylX. +have [|h hM /= sXghX] := Sylow_Jsub sylX sXgM; first by rewrite pgroupJ. +by rewrite -(groupMr _ hM) (subsetP (norm_sigma_Sylow _ sylX)) ?inE ?conjsgM. +Qed. + +(* This is B & G, Theorem 10.1 (a, b, c). *) +(* Part (e) of Theorem 10.1 is obviously stated incorrectly, and this is *) +(* difficult to correct because it is not used in the rest of the proof. *) +Theorem sigma_group_trans M p X : + M \in 'M -> p \in \sigma(M) -> p.-group X -> + [/\ (*a*) forall g, X \subset M -> X :^ g \subset M -> + exists2 c, c \in 'C(X) & exists2 m, m \in M & g = c * m, + (*b*) [transitive 'C(X), on [set Mg in M :^: G | X \subset Mg] | 'Js ] + & (*c*) X \subset M -> 'C(X) * 'N_M(X) = 'N(X)]. +Proof. +move=> maxM sMp pX; have defNM := norm_mmax maxM. +pose OM (Y : {set gT}) : {set {set gT}} := [set Mg in M :^: G | Y \subset Mg]. +pose trM (Y : {set gT}) := [transitive 'C(Y), on OM Y | 'Js]. +have actsOM Y: [acts 'N(Y), on OM Y | 'Js]. + apply/actsP=> z nYz Q; rewrite !inE -{1}(normP nYz) conjSg. + by rewrite (acts_act (acts_orbit _ _ _)) ?inE. +have OMid Y: (gval M \in OM Y) = (Y \subset M) by rewrite inE orbit_refl. +have ntOM Y: p.-group Y -> exists B, gval B \in OM Y. + have [S sylS] := Sylow_exists p M; have sSM := pHall_sub sylS. + have sylS_G := sigma_Sylow_G maxM sMp sylS. + move=> pY; have [g Gg sXSg] := Sylow_subJ sylS_G (subsetT Y) pY. + by exists (M :^ g)%G; rewrite inE mem_orbit // (subset_trans sXSg) ?conjSg. +have maxOM Y H: gval H \in OM Y -> H \in 'M. + by case/setIdP=> /imsetP[g _ /val_inj->]; rewrite mmaxJ. +have part_c Y H: trM Y -> gval H \in OM Y -> 'C(Y) * 'N_H(Y) = 'N(Y). + move=> trMY O_H; rewrite -(norm_mmax (maxOM Y H O_H)) -(astab1Js H) setIC. + have [sCN nCN] := andP (cent_normal Y); rewrite -normC 1?subIset ?nCN //. + by apply/(subgroup_transitiveP O_H); rewrite ?(atrans_supgroup sCN) ?actsOM. +suffices trMX: trM X. + do [split; rewrite // -OMid] => [g O_M sXgM |]; last exact: part_c. + have O_Mg': M :^ g^-1 \in OM X by rewrite inE mem_orbit -?sub_conjg ?inE. + have [c Cc /= Mc] := atransP2 trMX O_M O_Mg'; exists c^-1; rewrite ?groupV //. + by exists (c * g); rewrite ?mulKg // -defNM inE conjsgM -Mc conjsgKV. +elim: {X}_.+1 {-2}X (ltnSn (#|G| - #|X|)) => // n IHn X geXn in pX *. +have{n IHn geXn} IHX Y: X \proper Y -> p.-group Y -> trM Y. + move=> ltXY; apply: IHn; rewrite -ltnS (leq_trans _ geXn) // ltnS. + by rewrite ltn_sub2l ?(leq_trans (proper_card ltXY)) // cardsT max_card. +have [-> | ntX] := eqsVneq X 1. + rewrite /trM cent1T /OM setIdE (setIidPl _) ?atrans_orbit //. + by apply/subsetP=> Mg; case/imsetP=> g _ ->; rewrite inE sub1G. +pose L := 'N(X)%G; have ltLG := mFT_norm_proper ntX (mFT_pgroup_proper pX). +have IH_L: {in OM X &, forall B B', + B != B' -> exists2 X1, X \proper gval X1 & p.-Sylow(B :&: L) X1}. +- move=> _ _ /setIdP[/imsetP[a Ga ->] sXMa] /setIdP[/imsetP[b Gb ->] sXMb]. + move=> neqMab. + have [S sylS sXS] := Sylow_superset sXMa pX; have [sSMa pS _] := and3P sylS. + have [defS | ltXS] := eqVproper sXS. + case/eqP: neqMab; apply: (canRL (actKV _ _)); apply: (act_inj 'Js a). + rewrite /= -conjsgM [_ :^ _]conjGid ?(sigma_Sylow_trans _ sylS) ?sigmaJ //. + by rewrite -defS conjsgM conjSg sub_conjgV. + have pSL: p.-group (S :&: L) := pgroupS (subsetIl _ _) pS. + have [X1 sylX1 sNX1] := Sylow_superset (setSI L sSMa) pSL; exists X1 => //. + by rewrite (proper_sub_trans (nilpotent_proper_norm (pgroup_nil pS) _)). +have [M1 O_M1] := ntOM X pX; apply/imsetP; exists (gval M1) => //; apply/eqP. +rewrite eqEsubset andbC acts_sub_orbit ?(subset_trans (cent_sub X)) // O_M1 /=. +apply/subsetP=> M2 O_M2. +have [-> | neqM12] := eqsVneq M1 M2; first exact: orbit_refl. +have [|X2 ltXX2 sylX2] := IH_L _ _ O_M2 O_M1; first by rewrite eq_sym. +have{IH_L neqM12} [X1 ltXX1 sylX1] := IH_L _ _ O_M1 O_M2 neqM12. +have [[sX1L1 pX1 _] [sX2L2 pX2 _]] := (and3P sylX1, and3P sylX2). +have [[sX1M1 sX1L] [sX2M2 sX2L]] := (subsetIP sX1L1, subsetIP sX2L2). +have [P sylP sX1P] := Sylow_superset sX1L pX1; have [sPL pP _] := and3P sylP. +have [M0 O_M0] := ntOM P pP; have [MG_M0 sPM0] := setIdP O_M0. +have [t Lt sX2Pt] := Sylow_subJ sylP sX2L pX2. +have [sX1M0 ltXP] := (subset_trans sX1P sPM0, proper_sub_trans ltXX1 sX1P). +have M0C_M1: gval M1 \in orbit 'Js 'C(X) M0. + rewrite (subsetP (imsetS _ (centS (proper_sub ltXX1)))) // -orbitE. + by rewrite (atransP (IHX _ ltXX1 pX1)) inE ?MG_M0 //; case/setIdP: O_M1 => ->. +have M0tC_M2: M2 \in orbit 'Js 'C(X) (M0 :^ t). + rewrite (subsetP (imsetS _ (centS (proper_sub ltXX2)))) // -orbitE. + rewrite (atransP (IHX _ ltXX2 pX2)) inE; first by case/setIdP: O_M2 => ->. + rewrite (acts_act (acts_orbit _ _ _)) ?inE ?MG_M0 //. + by rewrite (subset_trans sX2Pt) ?conjSg. +rewrite (orbit_transl M0C_M1) (orbit_transr _ M0tC_M2). +have maxM0 := maxOM _ _ O_M0; have ltMG := mmax_proper maxM0. +have [rPgt2 | rPle2] := ltnP 2 'r(P). + have uP: P \in 'U by rewrite rank3_Uniqueness ?(mFT_pgroup_proper pP). + have uP_M0: 'M(P) = [set M0] := def_uniq_mmax uP maxM0 sPM0. + by rewrite conjGid ?orbit_refl ?(subsetP (sub_uniq_mmax uP_M0 sPL ltLG)). +have pl1L: p.-length_1 L. + have [oddL]: odd #|L| /\ 'r_p(L) <= 2 by rewrite mFT_odd -(rank_Sylow sylP). + by case/rank2_der1_complement; rewrite ?mFT_sol ?plength1_pseries2_quo. +have [|u v nLPu Lp'_v ->] := imset2P (_ : t \in 'N_L(P) * 'O_p^'(L)). + by rewrite normC ?plength1_Frattini // subIset ?gFnorm. +rewrite actM (orbit_transr _ (mem_orbit _ _ _)); last first. + have coLp'X: coprime #|'O_p^'(L)| #|X| := p'nat_coprime (pcore_pgroup _ _) pX. + apply: subsetP Lp'_v; have [sLp'L nLp'L] := andP (pcore_normal p^' L). + rewrite -subsetIidl -coprime_norm_cent ?subsetIidl //. + exact: subset_trans (normG X) nLp'L. +have [|w x nM0Pw cPx ->] := imset2P (_ : u \in 'N_M0(P) * 'C(P)). + rewrite normC ?part_c ?IHX //; first by case/setIP: nLPu. + by rewrite setIC subIset ?cent_norm. +rewrite actM /= conjGid ?mem_orbit //; last by case/setIP: nM0Pw. +by rewrite (subsetP (centS (subset_trans (proper_sub ltXX1) sX1P))). +Qed. + +Section OneMaximal. + +Variable M : {group gT}. +Hypothesis maxM : M \in 'M. + +Let ltMG := mmax_proper maxM. +Let solM := mmax_sol maxM. + +Let aMa : \alpha(M).-group (M`_\alpha). Proof. exact: pcore_pgroup. Qed. +Let nsMaM : M`_\alpha <| M. Proof. exact: pcore_normal. Qed. +Let sMaMs : M`_\alpha \subset M`_\sigma. Proof. exact: Malpha_sub_Msigma. Qed. + +Let F := 'F(M / M`_\alpha). +Let nsFMa : F <| M / M`_\alpha. Proof. exact: Fitting_normal. Qed. + +Let alpha'F : \alpha(M)^'.-group F. +Proof. +rewrite -[F](nilpotent_pcoreC \alpha(M) (Fitting_nil _)) -Fitting_pcore /=. +by rewrite trivg_pcore_quotient (trivgP (Fitting_sub 1)) dprod1g pcore_pgroup. +Qed. + +Let Malpha_quo_sub_Fitting : M^`(1) / M`_\alpha \subset F. +Proof. +have [/= K defF sMaK nsKM] := inv_quotientN nsMaM nsFMa; rewrite -/F in defF. +have [sKM _] := andP nsKM; have nsMaK: M`_\alpha <| K := normalS sMaK sKM nsMaM. +have [[_ nMaK] [_ nMaM]] := (andP nsMaK, andP nsMaM). +have hallMa: \alpha(M).-Hall(K) M`_\alpha. + by rewrite /pHall sMaK pcore_pgroup -card_quotient -?defF. +have [H hallH] := Hall_exists \alpha(M)^' (solvableS sKM solM). +have{hallH} defK := sdprod_normal_p'HallP nsMaK hallH hallMa. +have{defK} [_ sHK defK nMaH tiMaH] := sdprod_context defK. +have{defK} isoHF: H \isog F by rewrite [F]defF -defK quotientMidl quotient_isog. +have{sHK nMaH} sHM := subset_trans sHK sKM. +have{tiMaH isoHF sHM H} rF: 'r(F) <= 2. + rewrite -(isog_rank isoHF); have [p p_pr -> /=] := rank_witness H. + have [|a_p] := leqP 'r_p(M) 2; first exact: leq_trans (p_rankS p sHM). + rewrite 2?leqW // leqNgt p_rank_gt0 /= (card_isog isoHF) /= -/F. + exact: contraL (pnatPpi alpha'F) a_p. +by rewrite quotient_der // rank2_der1_sub_Fitting ?mFT_quo_odd ?quotient_sol. +Qed. + +Let sigma_Hall_sub_der1 H : \sigma(M).-Hall(M) H -> H \subset M^`(1). +Proof. +move=> hallH; have [sHM sH _] := and3P hallH. +rewrite -(Sylow_gen H) gen_subG; apply/bigcupsP=> P /SylowP[p p_pr sylP]. +have [-> | ntP] := eqsVneq P 1; first by rewrite sub1G. +have [sPH pP _] := and3P sylP; have{ntP} [_ p_dv_P _] := pgroup_pdiv pP ntP. +have{p_dv_P} s_p: p \in \sigma(M) := pgroupP (pgroupS sPH sH) p p_pr p_dv_P. +have{sylP} sylP: p.-Sylow(M) P := subHall_Sylow hallH s_p sylP. +have [sPM nMP] := (pHall_sub sylP, norm_sigma_Sylow s_p sylP). +have sylP_G := sigma_Sylow_G maxM s_p sylP. +have defG': G^`(1) = G. + have [_ simpG] := simpleP _ (mFT_simple gT). + by have [?|//] := simpG _ (der_normal 1 _); case/derG1P: (mFT_nonAbelian gT). +rewrite -subsetIidl -{1}(setIT P) -defG'. +rewrite (focal_subgroup_gen sylP_G) (focal_subgroup_gen sylP) genS //. +apply/subsetP=> _ /imset2P[x g Px /setIdP[Gg Pxg] ->]. +pose X := <[x]>; have sXM : X \subset M by rewrite cycle_subG (subsetP sPM). +have sXgM: X :^ g \subset M by rewrite -cycleJ cycle_subG (subsetP sPM). +have [trMX _ _] := sigma_group_trans maxM s_p (mem_p_elt pP Px). +have [c cXc [m Mm def_g]] := trMX _ sXM sXgM; rewrite cent_cycle in cXc. +have def_xg: x ^ g = x ^ m by rewrite def_g conjgM /conjg -(cent1P cXc) mulKg. +by rewrite commgEl def_xg -commgEl mem_imset2 // inE Mm -def_xg. +Qed. + +(* This is B & G, Theorem 10.2(a1). *) +Theorem Malpha_Hall : \alpha(M).-Hall(M) M`_\alpha. +Proof. +have [H hallH] := Hall_exists \sigma(M) solM; have [sHM sH _] := and3P hallH. +rewrite (subHall_Hall hallH (alpha_sub_sigma maxM)) // /pHall pcore_pgroup /=. +rewrite -(card_quotient (subset_trans sHM (normal_norm nsMaM))) -pgroupE. +rewrite (subset_trans sMaMs) ?pcore_sub_Hall ?(pgroupS _ alpha'F) //=. +exact: subset_trans (quotientS _ (sigma_Hall_sub_der1 hallH)) _. +Qed. + +(* This is B & G, Theorem 10.2(b1). *) +Theorem Msigma_Hall : \sigma(M).-Hall(M) M`_\sigma. +Proof. +have [H hallH] := Hall_exists \sigma(M) solM; have [sHM sH _] := and3P hallH. +rewrite /M`_\sigma (normal_Hall_pcore hallH) // -(quotientGK nsMaM). +rewrite -(quotientGK (normalS _ sHM nsMaM)) ?cosetpre_normal //; last first. + by rewrite (subset_trans sMaMs) ?pcore_sub_Hall. +have hallHa: \sigma(M).-Hall(F) (H / M`_\alpha). + apply: pHall_subl (subset_trans _ Malpha_quo_sub_Fitting) (Fitting_sub _) _. + by rewrite quotientS ?sigma_Hall_sub_der1. + exact: quotient_pHall (subset_trans sHM (normal_norm nsMaM)) hallH. +rewrite (nilpotent_Hall_pcore (Fitting_nil _) hallHa) /=. +exact: char_normal_trans (pcore_char _ _) nsFMa. +Qed. + +Lemma pi_Msigma : \pi(M`_\sigma) =i \sigma(M). +Proof. +move=> p; apply/idP/idP=> [|s_p /=]; first exact: pnatPpi (pcore_pgroup _ _). +by rewrite (card_Hall Msigma_Hall) pi_of_part // inE /= sigma_sub_pi. +Qed. + +(* This is B & G, Theorem 10.2(b2). *) +Theorem Msigma_Hall_G : \sigma(M).-Hall(G) M`_\sigma. +Proof. +rewrite pHallE subsetT /= eqn_dvd {1}(card_Hall Msigma_Hall). +rewrite partn_dvd ?cardG_gt0 ?cardSg ?subsetT //=. +apply/dvdn_partP; rewrite ?part_gt0 // => p. +rewrite pi_of_part ?cardG_gt0 // => /andP[_ s_p]. +rewrite partn_part => [|q /eqnP-> //]. +have [P sylP] := Sylow_exists p M; have [sPM pP _] := and3P sylP. +rewrite -(card_Hall (sigma_Sylow_G _ _ sylP)) ?cardSg //. +by rewrite (sub_Hall_pcore Msigma_Hall) ?(pi_pgroup pP). +Qed. + +(* This is B & G, Theorem 10.2(a2). *) +Theorem Malpha_Hall_G : \alpha(M).-Hall(G) M`_\alpha. +Proof. +apply: subHall_Hall Msigma_Hall_G (alpha_sub_sigma maxM) _. +exact: pHall_subl sMaMs (pcore_sub _ _) Malpha_Hall. +Qed. + +(* This is B & G, Theorem 10.2(c). *) +Theorem Msigma_der1 : M`_\sigma \subset M^`(1). +Proof. exact: sigma_Hall_sub_der1 Msigma_Hall. Qed. + +(* This is B & G, Theorem 10.2(d1). *) +Theorem Malpha_quo_rank2 : 'r(M / M`_\alpha) <= 2. +Proof. +have [p p_pr ->] := rank_witness (M / M`_\alpha). +have [P sylP] := Sylow_exists p M; have [sPM pP _] := and3P sylP. +have nMaP := subset_trans sPM (normal_norm nsMaM). +rewrite -(rank_Sylow (quotient_pHall nMaP sylP)) /= leqNgt. +have [a_p | a'p] := boolP (p \in \alpha(M)). + by rewrite quotientS1 ?rank1 ?(sub_Hall_pcore Malpha_Hall) ?(pi_pgroup pP). +rewrite -(isog_rank (quotient_isog _ _)) ?coprime_TIg ?(rank_Sylow sylP) //. +exact: pnat_coprime aMa (pi_pnat pP _). +Qed. + +(* This is B & G, Theorem 10.2(d2). *) +Theorem Malpha_quo_nil : nilpotent (M^`(1) / M`_\alpha). +Proof. exact: nilpotentS Malpha_quo_sub_Fitting (Fitting_nil _). Qed. + +(* This is B & G, Theorem 10.2(e). *) +Theorem Msigma_neq1 : M`_\sigma :!=: 1. +Proof. +without loss Ma1: / M`_\alpha = 1. + by case: eqP => // Ms1 -> //; apply/trivgP; rewrite -Ms1 Malpha_sub_Msigma. +have{Ma1} rFM: 'r('F(M)) <= 2. + rewrite (leq_trans _ Malpha_quo_rank2) // Ma1. + by rewrite -(isog_rank (quotient1_isog _)) rankS ?Fitting_sub. +pose q := max_pdiv #|M|; pose Q := 'O_q(M)%G. +have sylQ: q.-Sylow(M) Q := rank2_max_pcore_Sylow (mFT_odd M) solM rFM. +have piMq: q \in \pi(M) by rewrite pi_max_pdiv cardG_gt1 mmax_neq1. +have{piMq} ntQ: Q :!=: 1 by rewrite -rank_gt0 (rank_Sylow sylQ) p_rank_gt0. +rewrite (subG1_contra _ ntQ) ?(sub_Hall_pcore Msigma_Hall) ?pcore_sub //. +rewrite (pi_pgroup (pcore_pgroup _ _)) //; apply/exists_inP; exists Q => //. +by rewrite (mmax_normal maxM) ?pcore_normal. +Qed. + +(* This is B & G, Lemma 10.3. *) +Theorem cent_alpha'_uniq X : + X \subset M -> \alpha(M)^'.-group X -> 'r('C_(M`_\alpha)(X)) >= 2 -> + 'C_M(X)%G \in 'U. +Proof. +have ltM_G := sub_proper_trans (subsetIl M _) ltMG. +move=> sXM a'X; have [p p_pr -> rCX] := rank_witness 'C_(M`_\alpha)(X). +have{rCX} [B EpB] := p_rank_geP rCX; have{EpB} [sBCX abelB dimB] := pnElemP EpB. +have [[sBMa cXB] [pB cBB _]] := (subsetIP sBCX, and3P abelB). +have rMa: 1 < 'r_p(M`_\alpha) by rewrite -dimB -p_rank_abelem ?p_rankS. +have{rMa} a_p: p \in \alpha(M) by rewrite (pnatPpi aMa) // -p_rank_gt0 ltnW. +have nBX: X \subset 'N(B) by rewrite cents_norm // centsC. +have coMaX: coprime #|M`_\alpha| #|X| := pnat_coprime aMa a'X. +have [sMaM nMaM] := andP nsMaM; have solMa := solvableS sMaM solM. +have nMaX := subset_trans sXM nMaM. +have [P [sylP nPX sBP]] := coprime_Hall_subset nMaX coMaX solMa sBMa pB nBX. +have [sPMa pP _] := and3P sylP; have sPM := subset_trans sPMa sMaM. +have EpCB: B \in 'E_p^2('C_P(B)) by rewrite !inE subsetI sBP abelB dimB !andbT. +have: 1 < 'r_p('C_P(B)) by apply/p_rank_geP; exists B. +rewrite leq_eqVlt; case: ltngtP => // rCPB _. + apply: (uniq_mmaxS (subset_trans sBCX (setSI _ sMaM))) => //=. + have pCPB := pgroupS (subsetIl P 'C(B)) pP; rewrite -rank_pgroup // in rCPB. + have: 2 < 'r('C(B)) by rewrite (leq_trans rCPB) ?rankS ?subsetIr. + by apply: cent_rank3_Uniqueness; rewrite -dimB -rank_abelem. +have cPX: P \subset 'C(X). + have EpPB: B \in 'E_p(P) by exact/pElemP. + have coPX: coprime #|P| #|X| := coprimeSg sPMa coMaX. + rewrite centsC (coprime_odd_faithful_cent_abelem EpPB) ?mFT_odd //. + rewrite -(setIid 'C(B)) setIA (pmaxElem_LdivP p_pr _) 1?centsC //. + by rewrite (subsetP (p_rankElem_max _ _)) -?rCPB. +have sylP_M := subHall_Sylow Malpha_Hall a_p sylP. +have{sylP_M} rP: 2 < 'r(P) by rewrite (rank_Sylow sylP_M). +by rewrite rank3_Uniqueness ?(leq_trans rP (rankS _)) //= subsetI sPM. +Qed. + +Variable p : nat. + +(* This is B & G, Lemma 10.4(a). *) +(* We omit the redundant assumption p \in \pi(M). *) +Lemma der1_quo_sigma' : p %| #|M / M^`(1)| -> p \in \sigma(M)^'. +Proof. +apply: contraL => /= s_p; have piMp := sigma_sub_pi maxM s_p. +have p_pr: prime p by move: piMp; rewrite mem_primes; case/andP. +rewrite -p'natE ?(pi'_p'nat _ s_p) // -pgroupE -partG_eq1. +rewrite -(card_Hall (quotient_pHall _ Msigma_Hall)) /=; last first. + exact: subset_trans (pcore_sub _ _) (der_norm _ _). +by rewrite quotientS1 ?cards1 // Msigma_der1. +Qed. + +Hypothesis s'p : p \in \sigma(M)^'. + +(* This is B & G, Lemma 10.4(b). *) +(* We do not need the assumption M`_\alpha != 1; the assumption p \in \pi(M) *) +(* is restated as P != 1. *) +Lemma cent1_sigma'_Zgroup P : + p.-Sylow(M) P -> P :!=: 1 -> + exists x, + [/\ x \in 'Ohm_1('Z(P))^#, 'M('C[x]) != [set M] & Zgroup 'C_(M`_\alpha)[x]]. +Proof. +move=> sylP ntP; set T := 'Ohm_1(_); have [sPM pP _] := and3P sylP. +have [charT nilP] := (char_trans (Ohm_char 1 _) (center_char P), pgroup_nil pP). +suffices [x Tx not_uCx]: exists2 x, x \in T^# & 'M('C[x]) != [set M]. + exists x; split=> //; rewrite odd_rank1_Zgroup ?mFT_odd //= leqNgt. + apply: contra not_uCx; rewrite -cent_cycle; set X := <[x]> => rCMaX. + have{Tx} [ntX Tx] := setD1P Tx; rewrite -cycle_eq1 -/X in ntX. + have sXP: X \subset P by rewrite cycle_subG (subsetP (char_sub charT)). + rewrite (@def_uniq_mmaxS _ M 'C_M(X)) ?subsetIr ?mFT_cent_proper //. + apply: def_uniq_mmax; rewrite ?subsetIl //. + rewrite cent_alpha'_uniq ?(subset_trans sXP) ?(pi_pgroup (pgroupS sXP pP)) //. + by apply: contra s'p; apply: alpha_sub_sigma. +apply/exists_inP; rewrite -negb_forall_in; apply: contra s'p. +move/forall_inP => uCT; apply/exists_inP; exists P => //. +apply/subsetP=> u nPu; have [y Ty]: exists y, y \in T^#. + by apply/set0Pn; rewrite setD_eq0 subG1 Ohm1_eq1 center_nil_eq1. +rewrite -(norm_mmax maxM) (sameP normP eqP) (inj_eq (@group_inj gT)) -in_set1. +have Tyu: y ^ u \in T^#. + by rewrite memJ_norm // normD1 (subsetP (char_norms charT)). +by rewrite -(eqP (uCT _ Tyu)) -conjg_set1 normJ mmax_ofJ (eqP (uCT _ Ty)) set11. +Qed. + +(* This is B & G, Lemma 10.4(c), part 1. *) +(* The redundant assumption p \in \pi(M) is omitted. *) +Lemma sigma'_rank2_max : 'r_p(M) = 2 -> 'E_p^2(M) \subset 'E*_p(G). +Proof. +move=> rpM; apply: contraR s'p => /subsetPn[A Ep2A not_maxA]. +have{Ep2A} [sAM abelA dimA] := pnElemP Ep2A; have [pA _ _] := and3P abelA. +have [P sylP sAP] := Sylow_superset sAM pA; have [_ pP _] := and3P sylP. +apply/exists_inP; exists P; rewrite ?uniq_mmax_norm_sub //. +apply: def_uniq_mmaxS (mFT_pgroup_proper pP) (def_uniq_mmax _ _ sAM) => //. +by rewrite (@nonmaxElem2_Uniqueness _ p) // !(not_maxA, inE) abelA dimA subsetT. +Qed. + +(* This is B & G, Lemma 10.4(c), part 2 *) +(* The redundant assumption p \in \pi(M) is omitted. *) +Lemma sigma'_rank2_beta' : 'r_p(M) = 2 -> p \notin \beta(G). +Proof. +move=> rpM; rewrite -[p \in _]negb_exists_in negbK; apply/exists_inP. +have [A Ep2A]: exists A, A \in 'E_p^2(M) by apply/p_rank_geP; rewrite rpM. +have [_ abelA dimA] := pnElemP Ep2A; have [pA _] := andP abelA. +have [P sylP sAP] := Sylow_superset (subsetT _) pA. +exists P; rewrite ?inE //; apply/implyP=> _; apply/set0Pn. +exists A; rewrite 3!inE abelA dimA sAP (subsetP (pmaxElemS _ (subsetT P))) //. +by rewrite inE (subsetP (sigma'_rank2_max rpM)) // inE. +Qed. + +(* This is B & G, Lemma 10.5, part 1; the condition on X has been weakened, *) +(* because the proof of Lemma 12.2(a) requires the stronger result. *) +Lemma sigma'_norm_mmax_rank2 X : p.-group X -> 'N(X) \subset M -> 'r_p(M) = 2. +Proof. +move=> pX sNX_M; have sXM: X \subset M := subset_trans (normG X) sNX_M. +have [P sylP sXP] := Sylow_superset sXM pX; have [sPM pP _] := and3P sylP. +apply: contraNeq s'p; case: ltngtP => // rM _; last exact: alpha_sub_sigma. +apply/exists_inP; exists P; rewrite ?(subset_trans _ sNX_M) ?char_norms //. +rewrite sub_cyclic_char // (odd_pgroup_rank1_cyclic pP) ?mFT_odd //. +by rewrite (p_rank_Sylow sylP). +Qed. + +(* This is B & G, Lemma 10.5, part 2. We omit the second claim of B & G 10.5 *) +(* as it is an immediate consequence of sigma'_rank2_beta' (i.e., 10.4(c)). *) +Lemma sigma'1Elem_sub_p2Elem X : + X \in 'E_p^1(G) -> 'N(X) \subset M -> + exists2 A, A \in 'E_p^2(G) & X \subset A. +Proof. +move=> EpX sNXM; have sXM := subset_trans (normG X) sNXM. +have [[_ abelX dimX] p_pr] := (pnElemP EpX, pnElem_prime EpX). +have pX := abelem_pgroup abelX; have rpM2 := sigma'_norm_mmax_rank2 pX sNXM. +have [P sylP sXP] := Sylow_superset sXM pX; have [sPM pP _] := and3P sylP. +pose T := 'Ohm_1('Z(P)); pose A := X <*> T; have nilP := pgroup_nil pP. +have charT: T \char P := char_trans (Ohm_char 1 _) (center_char P). +have neqTX: T != X. + apply: contraNneq s'p => defX; apply/exists_inP; exists P => //. + by rewrite (subset_trans _ sNXM) // -defX char_norms. +have rP: 'r(P) = 2 by rewrite (rank_Sylow sylP) rpM2. +have ntT: T != 1 by rewrite Ohm1_eq1 center_nil_eq1 // -rank_gt0 rP. +have sAP: A \subset P by rewrite join_subG sXP char_sub. +have cTX: T \subset 'C(X) := centSS (Ohm_sub 1 _) sXP (subsetIr P _). +have{cTX} defA: X \* T = A by rewrite cprodEY. +have{defA} abelA : p.-abelem A. + have pZ: p.-group 'Z(P) := pgroupS (center_sub P) pP. + by rewrite (cprod_abelem _ defA) abelX Ohm1_abelem ?center_abelian. +exists [group of A]; last exact: joing_subl. +rewrite !inE subsetT abelA eqn_leq -{1}rP -{1}(rank_abelem abelA) rankS //=. +rewrite -dimX (properG_ltn_log (pgroupS sAP pP)) // /proper join_subG subxx. +rewrite joing_subl /=; apply: contra ntT => sTX; rewrite eqEsubset sTX in neqTX. +by rewrite -(setIidPr sTX) prime_TIg ?(card_pnElem EpX). +Qed. + +End OneMaximal. + +(* This is B & G, Theorem 10.6. *) +Theorem mFT_proper_plength1 p H : H \proper G -> p.-length_1 H. +Proof. +case/mmax_exists=> M /setIdP[maxM sHM]. +suffices{H sHM}: p.-length_1 M by apply: plength1S. +have [solM oddM] := (mmax_sol maxM, mFT_odd M). +have [rpMle2 | a_p] := leqP 'r_p(M) 2. + by rewrite plength1_pseries2_quo; case/rank2_der1_complement: rpMle2. +pose Ma := M`_\alpha; have hallMa: \alpha(M).-Hall(M) Ma := Malpha_Hall maxM. +have [[K hallK] [sMaM aMa _]] := (Hall_exists \alpha(M)^' solM, and3P hallMa). +have defM: Ma ><| K = M by apply/sdprod_Hall_pcoreP. +have{aMa} coMaK: coprime #|Ma| #|K| := pnat_coprime aMa (pHall_pgroup hallK). +suffices{a_p hallMa}: p.-length_1 Ma. + rewrite !p_elt_gen_length1 /p_elt_gen setIdE /= -/Ma -(setIidPl sMaM) -setIA. + rewrite -(setIdE M) (setIidPr _) //; apply/subsetP=> x; case/setIdP=> Mx p_x. + by rewrite (mem_Hall_pcore hallMa) /p_elt ?(pi_pnat p_x). +have{sMaM} <-: [~: Ma, K] = Ma. + have sMaMs: Ma \subset M`_\sigma := Malpha_sub_Msigma maxM. + have sMaM': Ma \subset M^`(1) := subset_trans sMaMs (Msigma_der1 maxM). + by have [] := coprime_der1_sdprod defM coMaK (solvableS sMaM solM) sMaM'. +have [q q_pr q_dv_Mq]: {q | prime q & q %| #|M / M^`(1)| }. + apply: pdivP; rewrite card_quotient ?der_norm // indexg_gt1 proper_subn //. + by rewrite (sol_der1_proper solM) ?mmax_neq1. +have s'q: q \in \sigma(M)^' by apply: der1_quo_sigma' q_dv_Mq. +have [Q sylQ] := Sylow_exists q K; have [sQK qQ _] := and3P sylQ. +have a'q: q \in \alpha(M)^' by apply: contra s'q; apply: alpha_sub_sigma. +have{a'q sylQ hallK} sylQ: q.-Sylow(M) Q := subHall_Sylow hallK a'q sylQ. +have{q_dv_Mq} ntQ: Q :!=: 1. + rewrite -rank_gt0 (rank_Sylow sylQ) p_rank_gt0 mem_primes q_pr cardG_gt0. + exact: dvdn_trans q_dv_Mq (dvdn_quotient _ _). +have{s'q sylQ ntQ} [x [Q1x _ ZgCx]] := cent1_sigma'_Zgroup maxM s'q sylQ ntQ. +have{Q1x} [ntx Q1x] := setD1P Q1x. +have sZQ := center_sub Q; have{sQK} sZK := subset_trans sZQ sQK. +have{sZK} Kx: x \in K by rewrite (subsetP sZK) // (subsetP (Ohm_sub 1 _)). +have{sZQ qQ} abelQ1 := Ohm1_abelem (pgroupS sZQ qQ) (center_abelian Q). +have{q q_pr Q abelQ1 Q1x} ox: prime #[x] by rewrite (abelem_order_p abelQ1). +move: Kx ox ZgCx; rewrite -cycle_subG -cent_cycle. +exact: odd_sdprod_Zgroup_cent_prime_plength1 solM oddM defM coMaK. +Qed. + +Section OneSylow. + +Variables (p : nat) (P : {group gT}). +Hypothesis sylP_G: p.-Sylow(G) P. +Let pP : p.-group P := pHall_pgroup sylP_G. + +(* This is an B & G, Corollary 10.7(a), second part (which does not depend on *) +(* a particular complement). *) +Corollary mFT_Sylow_der1 : P \subset 'N(P)^`(1). +Proof. +have [-> | ntP] := eqsVneq P 1; first exact: sub1G. +have ltNG: 'N(P) \proper G := mFT_norm_proper ntP (mFT_pgroup_proper pP). +have [M] := mmax_exists ltNG; case/setIdP=> /= maxM sNM. +have [ltMG solM] := (mmax_proper maxM, mmax_sol maxM). +have [pl1M sPM] := (mFT_proper_plength1 p ltMG, subset_trans (normG P) sNM). +have sylP := pHall_subl sPM (subsetT M) sylP_G. +have sMp: p \in \sigma(M) by apply/exists_inP; exists P. +apply: subset_trans (dergS 1 (subsetIr M 'N(P))) => /=. +apply: plength1_Sylow_sub_der1 sylP pl1M (subset_trans _ (Msigma_der1 maxM)). +by rewrite (sub_Hall_pcore (Msigma_Hall maxM)) ?(pi_pgroup pP). +Qed. + +(* This is B & G, Corollary 10.7(a), first part. *) +Corollary mFT_Sylow_sdprod_commg V : P ><| V = 'N(P) -> [~: P, V] = P. +Proof. +move=> defV; have sPN' := mFT_Sylow_der1. +have sylP := pHall_subl (normG P) (subsetT 'N(P)) sylP_G. +have [|//] := coprime_der1_sdprod defV _ (pgroup_sol pP) sPN'. +by rewrite (coprime_sdprod_Hall_l defV) // (pHall_Hall sylP). +Qed. + +(* This is B & G, Corollary 10.7(b). *) +Corollary mFT_rank2_Sylow_cprod : + 'r(P) < 3 -> ~~ abelian P -> + exists2 S, [/\ ~~ abelian (gval S), logn p #|S| = 3 & exponent S %| p] + & exists2 C, cyclic (gval C) & S \* C = P /\ 'Ohm_1(C) = 'Z(S). +Proof. +move=> rP not_cPP; have sylP := pHall_subl (normG P) (subsetT 'N(P)) sylP_G. +have ntP: P :!=: 1 by apply: contraNneq not_cPP => ->; apply: abelian1. +have ltNG: 'N(P) \proper G := mFT_norm_proper ntP (mFT_pgroup_proper pP). +have [V hallV] := Hall_exists p^' (mFT_sol ltNG); have [_ p'V _] := and3P hallV. +have defNP: P ><| V = 'N(P) := sdprod_normal_p'HallP (normalG P) hallV sylP. +have defP: [~: P, V] = P := mFT_Sylow_sdprod_commg defNP. +have [_] := rank2_coprime_comm_cprod pP (mFT_odd _) ntP rP defP p'V (mFT_odd _). +case=> [/idPn// | [S esS [C [mulSC cycC defC1]]]]. +exists S => //; exists C => //; split=> //; rewrite defC1. +have sSP: S \subset P by case/cprodP: mulSC => _ /mulG_sub[]. +have [[not_cSS dimS _] pS] := (esS, pgroupS sSP pP). +by have [||[]] := p3group_extraspecial pS; rewrite ?dimS. +Qed. + +(* This is B & G, Corollary 10.7(c). *) +Corollary mFT_sub_Sylow_trans : forall Q x, + Q \subset P -> Q :^ x \subset P -> exists2 y, y \in 'N(P) & Q :^ x = Q :^ y. +Proof. +move=> Q x; have [-> /trivgP-> /trivgP-> | ntP sQP sQxP] := eqsVneq P 1. + by exists 1; rewrite ?group1 ?conjs1g. +have ltNG: 'N(P) \proper G := mFT_norm_proper ntP (mFT_pgroup_proper pP). +have [M /=] := mmax_exists ltNG; case/setIdP=> maxM sNM. +have [ltMG solM] := (mmax_proper maxM, mmax_sol maxM). +have [pl1M sPM] := (mFT_proper_plength1 p ltMG, subset_trans (normG P) sNM). +have sylP := pHall_subl sPM (subsetT M) sylP_G. +have sMp: p \in \sigma(M) by apply/exists_inP; exists P. +have [transCQ _ _] := sigma_group_trans maxM sMp (pgroupS sQP pP). +have [||q cQq [u Mu defx]] := transCQ x; try exact: subset_trans _ sPM. +have nQC := normP (subsetP (cent_sub Q) _ _). +have [|q' cMQq' [y nMPy defu]] := plength1_Sylow_trans sylP pl1M solM sQP Mu. + by rewrite defx conjsgM nQC in sQxP. +have [[_ nPy] [_ cQq']] := (setIP nMPy, setIP cMQq'). +by exists y; rewrite // defx defu !conjsgM 2?nQC. +Qed. + +(* This is B & G, Corollary 10.7(d). *) +Corollary mFT_subnorm_Sylow Q : Q \subset P -> p.-Sylow('N(Q)) 'N_P(Q). +Proof. +move=> sQP; have pQ := pgroupS sQP pP. +have [S /= sylS] := Sylow_exists p 'N(Q); have [sNS pS _] := and3P sylS. +have sQS: Q \subset S := normal_sub_max_pgroup (Hall_max sylS) pQ (normalG Q). +have [x _ sSxP] := Sylow_Jsub sylP_G (subsetT S) pS. +have sQxP: Q :^ x \subset P by rewrite (subset_trans _ sSxP) ?conjSg. +have [y nPy defQy] := mFT_sub_Sylow_trans sQP sQxP. +have nQxy: x * y^-1 \in 'N(Q) by rewrite inE conjsgM defQy actK. +have sSxyP: S :^ (x * y^-1) \subset P by rewrite conjsgM sub_conjgV (normP nPy). +have sylSxy: p.-Sylow('N(Q)) (S :^ (x * y^-1)) by rewrite pHallJ. +have pNPQ: p.-group 'N_P(Q) := pgroupS (subsetIl P 'N(Q)) pP. +by rewrite (sub_pHall sylSxy pNPQ) ?subsetIr // subsetI sSxyP (@pHall_sub _ p). +Qed. + +(* This is B & G, Corollary 10.7(e). *) +Corollary mFT_Sylow_normalS Q R : + p.-group R -> Q \subset P :&: R -> Q <| 'N(P) -> Q <| 'N(R). +Proof. +move=> pR /subsetIP[sQP sQR] /andP[nQP nQ_NP]. +have [x _ sRxP] := Sylow_Jsub sylP_G (subsetT R) pR. +rewrite /normal normsG //; apply/subsetP=> y nRy. +have sQxP: Q :^ x \subset P by rewrite (subset_trans _ sRxP) ?conjSg. +have sQyxP: Q :^ (y * x) \subset P. + by rewrite actM (subset_trans _ sRxP) // -(normP nRy) !conjSg. +have [t tNP defQx] := mFT_sub_Sylow_trans sQP sQxP. +have [z zNP defQxy] := mFT_sub_Sylow_trans sQP sQyxP. +by rewrite inE -(conjSg _ _ x) -actM /= defQx defQxy !(normsP nQ_NP). +Qed. + +End OneSylow. + +Section AnotherMaximal. + +Variable M : {group gT}. +Hypothesis maxM : M \in 'M. + +Let solM : solvable M := mmax_sol maxM. +Let ltMG : M \proper G := mmax_proper maxM. + +Let sMbMs : M`_\beta \subset M`_\sigma := Mbeta_sub_Msigma maxM. +Let nsMbM : M`_\beta <| M := pcore_normal _ _. + +Let hallMs : \sigma(M).-Hall(M) M`_\sigma := Msigma_Hall maxM. +Let nsMsM : M`_\sigma <| M := pcore_normal _ M. +Let sMsM' : M`_\sigma \subset M^`(1) := Msigma_der1 maxM. + +Lemma Mbeta_der1 : M`_\beta \subset M^`(1). +Proof. exact: subset_trans sMbMs sMsM'. Qed. + +Let sM'M : M^`(1) \subset M := der_sub 1 M. +Let nsMsM' : M`_\sigma <| M^`(1) := normalS sMsM' sM'M nsMsM. +Let nsMbM' : M`_\beta <| M^`(1) := normalS Mbeta_der1 sM'M nsMbM. +Let nMbM' := normal_norm nsMbM'. + +(* This is B & G, Lemma 10.8(c). *) +Lemma beta_max_pdiv p : + p \notin \beta(M) -> + [/\ p^'.-Hall(M^`(1)) 'O_p^'(M^`(1)), + p^'.-Hall(M`_\sigma) 'O_p^'(M`_\sigma) + & forall q, q \in \pi(M / 'O_p^'(M)) -> q <= p]. +Proof. +rewrite !inE -negb_exists_in negbK => /exists_inP[P sylP nnP]. +have [|ncM' p_max] := narrow_der1_complement_max_pdiv (mFT_odd M) solM sylP nnP. + by rewrite mFT_proper_plength1 ?implybT. +by rewrite -(pcore_setI_normal _ nsMsM') (Hall_setI_normal nsMsM'). +Qed. + +(* This is B & G, Lemma 10.8(a), first part. *) +Lemma Mbeta_Hall : \beta(M).-Hall(M) M`_\beta. +Proof. +have [H hallH] := Hall_exists \beta(M) solM; have [sHM bH _]:= and3P hallH. +rewrite [M`_\beta](sub_pHall hallH) ?pcore_pgroup ?pcore_sub //=. +rewrite -(setIidPl sMbMs) pcore_setI_normal ?pcore_normal //. +have sH: \sigma(M).-group H := sub_pgroup (beta_sub_sigma maxM) bH. +have sHMs: H \subset M`_\sigma by rewrite (sub_Hall_pcore hallMs). +rewrite -pcoreNK -bigcap_p'core subsetI sHMs. +apply/bigcapsP=> p b'p; have [_ hallKp' _] := beta_max_pdiv b'p. +by rewrite (sub_Hall_pcore hallKp') ?(pi_p'group bH). +Qed. + +(* This is B & G, Lemma 10.8(a), second part. *) +Lemma Mbeta_Hall_G : \beta(M).-Hall(G) M`_\beta. +Proof. +apply: (subHall_Hall (Msigma_Hall_G maxM) (beta_sub_sigma maxM)). +exact: pHall_subl sMbMs (pcore_sub _ _) Mbeta_Hall. +Qed. + +(* This is an equivalent form of B & G, Lemma 10.8(b), which is used directly *) +(* later in the proof (e.g., Corollary 10.9a below, and Lemma 12.11), and is *) +(* proved as an intermediate step of the proof of of 12.8(b). *) +Lemma Mbeta_quo_nil : nilpotent (M^`(1) / M`_\beta). +Proof. +have /and3P[_ bMb b'M'Mb] := pHall_subl Mbeta_der1 sM'M Mbeta_Hall. +apply: nilpotentS (Fitting_nil (M^`(1) / M`_\beta)) => /=. +rewrite -{1}[_ / _]Sylow_gen gen_subG. +apply/bigcupsP=> Q /SylowP[q _ /and3P[sQM' qQ _]]. +apply: subset_trans (pcore_sub q _). +rewrite p_core_Fitting -pcoreNK -bigcap_p'core subsetI sQM' /=. +apply/bigcapsP=> [[p /= _] q'p]; have [b_p | b'p] := boolP (p \in \beta(M)). + by rewrite pcore_pgroup_id ?(pi'_p'group _ b_p) // /pgroup card_quotient. +have p'Mb: p^'.-group M`_\beta := pi_p'group bMb b'p. +rewrite sub_Hall_pcore ?(pi_p'group qQ) {Q qQ sQM'}//. +rewrite pquotient_pcore ?quotient_pHall ?(subset_trans (pcore_sub _ _)) //. +by have [-> _ _] := beta_max_pdiv b'p. +Qed. + +(* This is B & G, Lemma 10.8(b), generalized to arbitrary beta'-subgroups of *) +(* M^`(1) (which includes Hall beta'-subgroups of M^`(1) and M`_\beta). *) +Lemma beta'_der1_nil H : \beta(M)^'.-group H -> H \subset M^`(1) -> nilpotent H. +Proof. +move=> b'H sHM'; have [_ bMb _] := and3P Mbeta_Hall. +have{b'H} tiMbH: M`_\beta :&: H = 1 := coprime_TIg (pnat_coprime bMb b'H). +rewrite {tiMbH}(isog_nil (quotient_isog (subset_trans sHM' nMbM') tiMbH)). +exact: nilpotentS (quotientS _ sHM') Mbeta_quo_nil. +Qed. + +(* This is B & G, Corollary 10.9(a). *) +Corollary beta'_cent_Sylow p q X : + p \notin \beta(M) -> q \notin \beta(M) -> q.-group X -> + (p != q) && (X \subset M^`(1)) || (p < q) && (X \subset M) -> + [/\ (*a1*) exists2 P, p.-Sylow(M`_\sigma) (gval P) & X \subset 'C(P), + (*a2*) p \in \alpha(M) -> 'C_M(X)%G \in 'U + & (*a3*) q.-Sylow(M^`(1)) X -> + exists2 P, p.-Sylow(M^`(1)) (gval P) & P \subset 'N_M(X)^`(1)]. +Proof. +move=> b'p b'q qX q'p_sXM'; pose pq : nat_pred := pred2 p q. +have [q'p sXM]: p \in q^' /\ X \subset M. + case/orP: q'p_sXM' => /andP[q'p /subset_trans-> //]. + by rewrite !inE neq_ltn q'p. +have sXM'M: X <*> M^`(1) \subset M by rewrite join_subG sXM. +have solXM': solvable (X <*> M^`(1)) := solvableS sXM'M solM. +have pqX: pq.-group X by rewrite (pi_pgroup qX) ?inE ?eqxx ?orbT. +have{solXM' pqX} [W /= hallW sXW] := Hall_superset solXM' (joing_subl _ _) pqX. +have [sWXM' pqW _] := and3P hallW; have sWM := subset_trans sWXM' sXM'M. +have{b'q} b'W: \beta(M)^'.-group W. (* GG -- Coq diverges on b'p <> b'q *) + by apply: sub_pgroup pqW => r /pred2P[]->; [exact: b'p | exact: b'q]. +have nilM'W: nilpotent (M^`(1) :&: W). + by rewrite beta'_der1_nil ?subsetIl ?(pgroupS (subsetIr _ _)). +have{nilM'W} nilW: nilpotent W. + do [case/orP: q'p_sXM'=> /andP[]] => [_ sXM' | lt_pq _]. + by rewrite -(setIidPr sWXM') (joing_idPr sXM'). + pose Wq := 'O_p^'(M) :&: W; pose Wp := 'O_p(M^`(1) :&: W). + have nMp'M := char_norm (pcore_char p^' M). + have nMp'W := subset_trans sWM nMp'M. + have sylWq: q.-Sylow(W) Wq. + have [sWqMp' sWp'W] := subsetIP (subxx Wq). + have [Q sylQ] := Sylow_exists q W; have [sQW qQ _] := and3P sylQ. + rewrite [Wq](sub_pHall sylQ _ _ (subsetIr _ W)) //= -/Wq. + apply/pgroupP=> r r_pr r_dv_Wp'. + have:= pgroupP (pgroupS sWqMp' (pcore_pgroup _ _)) r r_pr r_dv_Wp'. + by apply/implyP; rewrite implyNb; exact: (pgroupP (pgroupS sWp'W pqW)). + have [[_ _ max_p] sQM] := (beta_max_pdiv b'p, subset_trans sQW sWM). + rewrite subsetI sQW -quotient_sub1 ?(subset_trans sQM nMp'M) //. + apply: contraLR lt_pq; rewrite -leqNgt andbT subG1 -rank_gt0. + rewrite (rank_pgroup (quotient_pgroup _ qQ)) p_rank_gt0 => piQb_q. + exact: max_p (piSg (quotientS _ sQM) piQb_q). + have nM'W: W \subset 'N(M^`(1)) by rewrite (subset_trans sWM) ?der_norm. + have qWWM': q.-group (W / (M^`(1) :&: W)). + rewrite (isog_pgroup _ (second_isog _)) ?(pgroupS (quotientS _ sWXM')) //=. + by rewrite (quotientYidr (subset_trans sXW nM'W)) quotient_pgroup. + have{qWWM'} sylWp: p.-Sylow(W) Wp. + rewrite /pHall pcore_pgroup (subset_trans (pcore_sub _ _)) ?subsetIr //=. + rewrite -(Lagrange_index (subsetIr _ _) (pcore_sub _ _)) pnat_mul //. + rewrite -(divgS (pcore_sub _ _)) -card_quotient ?normsI ?normG //= -pgroupE. + rewrite (pi_p'group qWWM') //= -(dprod_card (nilpotent_pcoreC p nilM'W)). + by rewrite mulKn ?cardG_gt0 // -pgroupE pcore_pgroup. + have [[sWqW qWq _] [sWpW pWp _]] := (and3P sylWq, and3P sylWp). + have <-: Wp * Wq = W. + apply/eqP; rewrite eqEcard mul_subG //= -(partnC q (cardG_gt0 W)). + rewrite (coprime_cardMg (p'nat_coprime (pi_pnat pWp _) qWq)) //. + rewrite (card_Hall sylWp) (card_Hall sylWq) -{2}(part_pnat_id pqW) -partnI. + rewrite mulnC (@eq_partn _ p) // => r. + by rewrite !inE andb_orl andbN orbF; apply: andb_idr; move/eqP->. + apply: nilpotentS (mul_subG _ _) (Fitting_nil W). + rewrite Fitting_max ?(pgroup_nil pWp) //. + by rewrite (char_normal_trans (pcore_char _ _)) //= setIC norm_normalI. + by rewrite Fitting_max ?(pgroup_nil qWq) //= setIC norm_normalI. +have part1: exists2 P : {group gT}, p.-Sylow(M`_\sigma) P & X \subset 'C(P). + have sMsXM' := subset_trans sMsM' (joing_subr X _). + have nsMsXM': M`_\sigma <| X <*> M^`(1) := normalS sMsXM' sXM'M nsMsM. + have sylWp: p.-Hall(M`_\sigma) ('O_p(W) :&: M`_\sigma). + rewrite setIC (Sylow_setI_normal nsMsXM') //. + exact: subHall_Sylow hallW (predU1l _ _) (nilpotent_pcore_Hall p nilW). + have [_ _ cWpWp' _] := dprodP (nilpotent_pcoreC p nilW). + exists ('O_p(W) :&: M`_\sigma)%G; rewrite ?(centSS _ _ cWpWp') ?subsetIl //. + by rewrite (sub_Hall_pcore (nilpotent_pcore_Hall _ _)) ?(pi_p'group qX). +split=> // [a_p | {part1}sylX]. + have ltCMX_G := sub_proper_trans (subsetIl M 'C(X)) ltMG. + have [P sylP cPX] := part1; have s_p := alpha_sub_sigma maxM a_p. + have{sylP} sylP := subHall_Sylow hallMs s_p sylP. + apply: rank3_Uniqueness ltCMX_G (leq_trans a_p _). + by rewrite -(rank_Sylow sylP) rankS //= subsetI (pHall_sub sylP) // centsC. +do [move: sWXM'; rewrite (joing_idPr (pHall_sub sylX)) => sWM'] in hallW. +have nMbX: X \subset 'N(M`_\beta) := subset_trans sXM (normal_norm nsMbM). +have nsMbXM : M`_\beta <*> X <| M. + rewrite -{2}(quotientGK nsMbM) -quotientYK ?cosetpre_normal //=. + rewrite (eq_Hall_pcore _ (quotient_pHall nMbX sylX)); last first. + exact: nilpotent_pcore_Hall Mbeta_quo_nil. + by rewrite (char_normal_trans (pcore_char _ _)) ?quotient_normal ?der_normal. +pose U := 'N_M(X); have defM: M`_\beta * U = M. + have sXU : X \subset U by rewrite subsetI sXM normG. + rewrite -[U](mulSGid sXU) /= -/U mulgA -norm_joinEr //. + apply: Frattini_arg nsMbXM (pHall_subl (joing_subr _ X) _ sylX). + by rewrite join_subG Mbeta_der1 (pHall_sub sylX). +have sWpU: 'O_p(W) \subset U. + rewrite (subset_trans (pcore_sub _ _)) // subsetI sWM normal_norm //=. + have sylX_W: q.-Sylow(W) X := pHall_subl sXW sWM' sylX. + by rewrite (eq_Hall_pcore (nilpotent_pcore_Hall q nilW) sylX_W) pcore_normal. +have sylWp: p.-Sylow(M^`(1)) 'O_p(W). + exact: subHall_Sylow hallW (predU1l _ _) (nilpotent_pcore_Hall p nilW). +exists 'O_p(W)%G; rewrite //= -(setIidPl (pHall_sub sylWp)). +rewrite (pprod_focal_coprime defM) ?pcore_normal ?subsetIr //. +exact: pnat_coprime (pcore_pgroup _ _) (pi_pnat (pcore_pgroup _ _) _). +Qed. + +(* This is B & G, Corollary 10.9(b). *) +Corollary nonuniq_norm_Sylow_pprod p H S : + H \in 'M -> H :!=: M -> p.-Sylow(G) S -> 'N(S) \subset H :&: M -> + M`_\beta * (H :&: M) = M /\ \alpha(M) =i \beta(M). +Proof. +move=> maxH neqHM sylS_G sN_HM; have [sNH sNM] := subsetIP sN_HM. +have [sSM sSH] := (subset_trans (normG S) sNM, subset_trans (normG S) sNH). +have [sylS pS] := (pHall_subl sSM (subsetT M) sylS_G, pHall_pgroup sylS_G). +have sMp: p \in \sigma(M) by apply/exists_inP; exists S. +have aM'p: p \in \alpha(M)^'. + apply: contra neqHM; rewrite !inE -(rank_Sylow sylS) => rS. + have uniqS: S \in 'U := rank3_Uniqueness (mFT_pgroup_proper pS) rS. + by rewrite (eq_uniq_mmax (def_uniq_mmax uniqS maxM sSM) maxH sSH). +have sSM': S \subset M^`(1). + by rewrite (subset_trans _ sMsM') ?(sub_Hall_pcore hallMs) ?(pi_pgroup pS). +have nMbS := subset_trans sSM (normal_norm nsMbM). +have nMbSM: M`_\beta <*> S <| M. + rewrite -{2}(quotientGK nsMbM) -quotientYK ?cosetpre_normal //=. + have sylS_M' := pHall_subl sSM' sM'M sylS. + rewrite (eq_Hall_pcore _ (quotient_pHall nMbS sylS_M')); last first. + exact: nilpotent_pcore_Hall Mbeta_quo_nil. + by rewrite (char_normal_trans (pcore_char _ _)) ?quotient_normal ?der_normal. +have defM: M`_\beta * 'N_M(S) = M. + have sSNM: S \subset 'N_M(S) by rewrite subsetI sSM normG. + rewrite -(mulSGid sSNM) /= mulgA -norm_joinEr //. + by rewrite (Frattini_arg _ (pHall_subl _ _ sylS_G)) ?joing_subr ?subsetT. +split=> [|q]. + apply/eqP; rewrite setIC eqEsubset mulG_subG subsetIl pcore_sub /=. + by rewrite -{1}defM mulgS ?setIS. +apply/idP/idP=> [aMq|]; last exact: beta_sub_alpha. +apply: contraR neqHM => bM'q; have bM'p := contra (@beta_sub_alpha _ M p) aM'p. +have [|_ uniqNM _] := beta'_cent_Sylow bM'q bM'p pS. + by apply: contraR aM'p; rewrite sSM'; case: eqP => //= <- _. +rewrite (eq_uniq_mmax (def_uniq_mmax (uniqNM aMq) maxM (subsetIl _ _)) maxH) //. +by rewrite subIset ?(subset_trans (cent_sub _)) ?orbT. +Qed. + +(* This is B & G, Proposition 10.10. *) +Proposition max_normed_2Elem_signaliser p q (A Q : {group gT}) : + p != q -> A \in 'E_p^2(G) :&: 'E*_p(G) -> Q \in |/|*(A; q) -> + q %| #|'C(A)| -> + exists2 P : {group gT}, p.-Sylow(G) P /\ A \subset P + & [/\ (*a*) 'O_p^'('C(P)) * ('N(P) :&: 'N(Q)) = 'N(P), + (*b*) P \subset 'N(Q)^`(1) + & (*c*) q.-narrow Q -> P \subset 'C(Q)]. +Proof. +move=> neq_pq /setIP[Ep2A EpmA] maxQ piCAq. +have [_ abelA dimA] := pnElemP Ep2A; have [pA cAA _] := and3P abelA. +have [p_pr oA] := (pnElem_prime Ep2A, card_pnElem Ep2A). +have{dimA} rA2: 'r(A) = 2 by rewrite (rank_abelem abelA). +have{EpmA} ncA: normed_constrained A. + have ntA: A :!=: 1 by rewrite -rank_gt0 rA2. + exact: plength_1_normed_constrained ntA EpmA (mFT_proper_plength1 _). +pose pi := \pi(A); pose K := 'O_pi^'('C(A)). +have def_pi : pi =i (p : nat_pred). + by move=> r; rewrite !inE /= oA primes_exp ?primes_prime ?inE. +have pi'q : q \notin pi by rewrite def_pi !inE eq_sym. +have transKA: [transitive K, on |/|*(A; q) | 'JG]. + by rewrite normed_constrained_rank2_trans // (center_idP cAA) rA2. +have [P0 sylP0 sAP0] := Sylow_superset (subsetT _) pA. +have pP0: p.-group P0 := pHall_pgroup sylP0. +have piP0: pi.-group P0 by rewrite (eq_pgroup _ def_pi). +have{pP0} snAP0: A <|<| P0 := nilpotent_subnormal (pgroup_nil pP0) sAP0. +have{pi'q snAP0 ncA piP0} [//|] := normed_trans_superset ncA pi'q snAP0 piP0. +rewrite /= -/pi -/K => -> transKP submaxPA maxPfactoring. +have{transKP} [Q0 maxQ0 _] := imsetP transKP. +have{transKA} [k Kk defQ] := atransP2 transKA (subsetP submaxPA _ maxQ0) maxQ. +set P := P0 :^ k; have{sylP0} sylP: p.-Sylow(G) P by rewrite pHallJ ?in_setT. +have nAK: K \subset 'N(A) by rewrite cents_norm ?pcore_sub. +have{sAP0 nAK K Kk} sAP: A \subset P by rewrite -(normsP nAK k Kk) conjSg. +exists [group of P] => //. +have{maxPfactoring} [sPNQ' defNP] := maxPfactoring _ maxQ0. +move/(congr1 ('Js%act^~ k)): defNP sPNQ'; rewrite -(conjSg _ _ k) /=. +rewrite conjsMg !conjIg !conjsRg -!derg1 -!normJ -pcoreJ -centJ -/P. +rewrite -(congr_group defQ) (eq_pcore _ (eq_negn def_pi)) => defNP sPNQ'. +have{sPNQ'} sPNQ': P \subset 'N(Q)^`(1). + by rewrite (setIidPl (mFT_Sylow_der1 sylP)) in sPNQ'. +split=> // narrowQ; have [-> | ntQ] := eqsVneq Q 1; first exact: cents1. +pose AutQ := conj_aut Q @* 'N(Q). +have qQ: q.-group Q by case/mem_max_normed: maxQ. +have ltNG: 'N(Q) \proper G by rewrite mFT_norm_proper // (mFT_pgroup_proper qQ). +have{ltNG} qAutQ': q.-group AutQ^`(1). + have qAutQq: q.-group 'O_q(AutQ) := pcore_pgroup _ _. + rewrite (pgroupS _ qAutQq) // der1_min ?gFnorm //. + have solAutQ: solvable AutQ by rewrite morphim_sol -?mFT_sol_proper. + have [oddQ oddAutQ]: odd #|Q| /\ odd #|AutQ| by rewrite morphim_odd mFT_odd. + by have /(Aut_narrow qQ)[] := Aut_conj_aut Q 'N(Q). +have nQP: P \subset 'N(Q) := subset_trans sPNQ' (der_sub 1 _). +rewrite (sameP setIidPl eqP) eqEsubset subsetIl /=. +rewrite -quotient_sub1 ?normsI ?normG ?norms_cent //= -ker_conj_aut subG1. +rewrite trivg_card1 (card_isog (first_isog_loc _ _)) //= -trivg_card1 -subG1. +have q'AutP: q^'.-group (conj_aut Q @* P). + by rewrite morphim_pgroup //; apply: pi_pnat (pHall_pgroup sylP) _. +rewrite -(coprime_TIg (pnat_coprime qAutQ' q'AutP)) subsetI subxx. +by rewrite /= -morphim_der // morphimS. +Qed. + +(* Notation for Proposition 11, which is the last to appear in this segment. *) +Local Notation sigma' := \sigma(gval M)^'. + +(* This is B & G, Proposition 10.11(a). *) +Proposition sigma'_not_uniq K : K \subset M -> sigma'.-group K -> K \notin 'U. +Proof. +move=> sKM sg'K; have [E hallE sKE] := Hall_superset solM sKM sg'K. +have [sEM sg'E _] := and3P hallE. +have rEle2: 'r(E) <= 2. + have [q _ ->] := rank_witness E; rewrite leqNgt; apply/negP=> rEgt2. + have: q \in sigma' by rewrite (pnatPpi sg'E) // -p_rank_gt0 -(subnKC rEgt2). + by rewrite inE /= alpha_sub_sigma //; apply: leq_trans (p_rankS q sEM). +have [E1 | ntE]:= eqsVneq E 1. + by apply: contraL (@uniq_mmax_neq1 _ K) _; rewrite -subG1 -E1. +pose p := max_pdiv #|E|; pose P := 'O_p(E). +have piEp: p \in \pi(E) by rewrite pi_max_pdiv cardG_gt1. +have sg'p: p \in sigma' by rewrite (pnatPpi sg'E). +have sylP: p.-Sylow(E) P. + rewrite rank2_max_pcore_Sylow ?mFT_odd ?(solvableS sEM solM) //. + exact: leq_trans (rankS (Fitting_sub E)) rEle2. +apply: contra (sg'p) => uniqK; apply/existsP; exists [group of P]. +have defMK := def_uniq_mmax uniqK maxM (subset_trans sKE sEM). +rewrite (subHall_Sylow hallE) // (sub_uniq_mmax defMK) //; last first. + rewrite mFT_norm_proper ?(mFT_pgroup_proper (pcore_pgroup _ _)) //. + by rewrite -cardG_gt1 (card_Hall sylP) p_part_gt1. +by rewrite (subset_trans sKE) // gFnorm. +Qed. + +(* This is B & G, Proposition 10.11(b). *) +Proposition sub'cent_sigma_rank1 K : + K \subset M -> sigma'.-group K -> 'r('C_K(M`_\sigma)) <= 1. +Proof. +move=> sKM sg'K; rewrite leqNgt; apply/rank_geP=> [[A /nElemP[p Ep2A]]]. +have p_pr := pnElem_prime Ep2A. +have [sACKMs abelA dimA] := pnElemP Ep2A; rewrite subsetI centsC in sACKMs. +have{sACKMs} [sAK cAMs]: A \subset K /\ M`_\sigma \subset 'C(A) := andP sACKMs. +have sg'p: p \in sigma'. + by rewrite (pgroupP (pgroupS sAK sg'K)) // (card_pnElem Ep2A) dvdn_mull. +have [Ms1 | [q q_pr q_dvd_Ms]] := trivgVpdiv M`_\sigma. + by case/eqP: (Msigma_neq1 maxM). +have sg_q: q \in \sigma(M) := pgroupP (pcore_pgroup _ _) _ q_pr q_dvd_Ms. +have neq_pq: p != q by apply: contraNneq sg'p => ->. +have [Q sylQ] := Sylow_exists q M`_\sigma; have [sQMs qQ _] := and3P sylQ. +have cAQ: Q \subset 'C(A) := subset_trans sQMs cAMs. +have{q_dvd_Ms} q_dv_CA: q %| #|'C(A)|. + rewrite (dvdn_trans _ (cardSg cAQ)) // -(part_pnat_id (pnat_id q_pr)). + by rewrite (card_Hall sylQ) partn_dvd. +have{cAQ} maxQ: Q \in |/|*(A; q). + rewrite inE; apply/maxgroupP; rewrite qQ cents_norm 1?centsC //. + split=> // Y /andP[qY _] sQY; apply: sub_pHall qY sQY (subsetT Y). + by rewrite (subHall_Sylow (Msigma_Hall_G maxM)). +have sNQM: 'N(Q) \subset M. + by rewrite (norm_sigma_Sylow sg_q) // (subHall_Sylow hallMs). +have rCAle2: 'r('C(A)) <= 2. + apply: contraR (sigma'_not_uniq sKM sg'K); rewrite -ltnNge => rCAgt2. + apply: uniq_mmaxS sAK (sub_mmax_proper maxM sKM) _. + by apply: cent_rank3_Uniqueness rCAgt2; rewrite (rank_abelem abelA) dimA. +have max2A: A \in 'E_p^2(G) :&: 'E*_p(G). + rewrite 3!inE subsetT abelA dimA; apply/pmaxElemP; rewrite inE subsetT. + split=> // Y /pElemP[_ abelY /eqVproper[]//ltAY]. + have [pY cYY _] := and3P abelY. + suffices: 'r_p('C(A)) > 2 by rewrite ltnNge (leq_trans (p_rank_le_rank p _)). + rewrite -dimA (leq_trans (properG_ltn_log pY ltAY)) //. + by rewrite logn_le_p_rank // inE centsC (subset_trans (proper_sub ltAY)). +have{rCAle2 cAMs} Ma1: M`_\alpha = 1. + apply: contraTeq rCAle2; rewrite -rank_gt0 -ltnNge. + have [r _ ->] := rank_witness M`_\alpha; rewrite p_rank_gt0. + move/(pnatPpi (pcore_pgroup _ _))=> a_r; apply: (leq_trans a_r). + have [R sylR] := Sylow_exists r M`_\sigma. + have sylR_M: r.-Sylow(M) R. + by rewrite (subHall_Sylow (Msigma_Hall maxM)) ?alpha_sub_sigma. + rewrite -(p_rank_Sylow sylR_M) (p_rank_Sylow sylR). + by rewrite (leq_trans (p_rank_le_rank r _)) // rankS // centsC. +have{Ma1} nilM': nilpotent M^`(1). + by rewrite (isog_nil (quotient1_isog _)) -Ma1 Malpha_quo_nil. +have{max2A maxQ neq_pq q_dv_CA} [P [sylP sAP] sPNQ']: + exists2 P : {group gT}, p.-Sylow(G) P /\ A \subset P & P \subset 'N(Q)^`(1). +- by case/(max_normed_2Elem_signaliser neq_pq): maxQ => // P ? []; exists P. +have{sNQM} defP: 'O_p(M^`(1)) = P. + rewrite (nilpotent_Hall_pcore nilM' (pHall_subl _ _ sylP)) ?subsetT //. + by rewrite (subset_trans sPNQ') ?dergS. +have charP: P \char M by rewrite -defP (char_trans (pcore_char p _)) ?der_char. +have [sPM nsPM] := (char_sub charP, char_normal charP). +case/exists_inP: sg'p; exists P; first exact: pHall_subl (subsetT M) sylP. +by rewrite (mmax_normal maxM) // -rank_gt0 ltnW // -dimA -rank_abelem ?rankS. +Qed. + +(* This is B & G, Proposition 10.11(c). *) +Proposition sub'cent_sigma_cyclic K (Y := 'C_K(M`_\sigma) :&: M^`(1)) : + K \subset M -> sigma'.-group K -> cyclic Y /\ Y <| M. +Proof. +move=> sKM sg'K; pose Z := 'O_sigma'('F(M)). +have nsZM: Z <| M := char_normal_trans (pcore_char _ _) (Fitting_normal M). +have [sZM nZM] := andP nsZM; have Fnil := Fitting_nil M. +have rZle1: 'r(Z) <= 1. + apply: leq_trans (rankS _) (sub'cent_sigma_rank1 sZM (pcore_pgroup _ _)). + rewrite subsetI subxx (sameP commG1P trivgP) /=. + rewrite -(TI_pcoreC \sigma(M) M 'F(M)) subsetI commg_subl commg_subr. + by rewrite (subset_trans sZM) ?gFnorm ?(subset_trans (pcore_sub _ _)). +have{rZle1} cycZ: cyclic Z. + have nilZ: nilpotent Z := nilpotentS (pcore_sub _ _) Fnil. + by rewrite nil_Zgroup_cyclic // odd_rank1_Zgroup // mFT_odd. +have cZM': M^`(1) \subset 'C_M(Z). + rewrite der1_min ?normsI ?normG ?norms_cent //= -ker_conj_aut. + rewrite (isog_abelian (first_isog_loc _ _)) //. + by rewrite (abelianS (Aut_conj_aut _ _)) // Aut_cyclic_abelian. +have sYF: Y \subset 'F(M). + apply: subset_trans (cent_sub_Fitting (mmax_sol maxM)). + have [_ /= <- _ _] := dprodP (nilpotent_pcoreC \sigma(M) Fnil). + by rewrite centM setICA setISS // setIC subIset ?centS // pcore_Fitting. +have{sYF} sYZ: Y \subset Z. + rewrite (sub_Hall_pcore (nilpotent_pcore_Hall _ Fnil)) //=. + by rewrite -setIA (pgroupS (subsetIl K _)). +by rewrite (cyclicS sYZ cycZ) (char_normal_trans _ nsZM) // sub_cyclic_char. +Qed. + +(* This is B & G, Proposition 10.11(d). *) +Proposition commG_sigma'_1Elem_cyclic p K P (K0 := [~: K, P]) : + K \subset M -> sigma'.-group K -> p \in sigma' -> P \in 'E_p^1('N_M(K)) -> + 'C_(M`_\sigma)(P) = 1 -> p^'.-group K -> abelian K -> + [/\ K0 \subset 'C(M`_\sigma), cyclic K0 & K0 <| M]. +Proof. +move=> sKM sg'K sg'p EpP regP p'K cKK. +have nK0P: P \subset 'N(K0) := commg_normr P K. +have p_pr := pnElem_prime EpP; have [sPMN _ oP] := pnElemPcard EpP. +have [sPM nKP]: P \subset M /\ P \subset 'N(K) by apply/subsetIP. +have /andP[sMsM nMsM]: M`_\sigma <| M := pcore_normal _ _. +have sK0K: K0 \subset K by rewrite commg_subl. +have [sK0M sg'K0]:= (subset_trans sK0K sKM, pgroupS sK0K sg'K). +have [nMsK0 nMsP] := (subset_trans sK0M nMsM, subset_trans sPM nMsM). +have coKP: coprime #|K| #|P| by rewrite oP coprime_sym prime_coprime -?p'natE. +have coK0Ms: coprime #|K0| #|M`_\sigma|. + by rewrite coprime_sym (pnat_coprime (pcore_pgroup _ _)). +have nilK0Ms: nilpotent (K0 <*> M`_\sigma). + have mulK0MsP: K0 <*> M`_\sigma ><| P = K0 <*> M`_\sigma <*> P. + rewrite sdprodEY ?normsY // coprime_TIg //= norm_joinEl //. + rewrite coprime_cardMg // coprime_mull (coprimeSg sK0K) //. + by rewrite oP (pnat_coprime (pcore_pgroup _ _)) ?pnatE. + apply: (prime_Frobenius_sol_kernel_nil mulK0MsP); rewrite ?oP //=. + by rewrite (solvableS _ solM) // !join_subG sK0M pcore_sub. + rewrite norm_joinEl // -subcent_TImulg ?subsetI ?nK0P //. + by rewrite coprime_abel_cent_TI ?mul1g. + exact: coprime_TIg. +have cMsK0: K0 \subset 'C(M`_\sigma). + rewrite (sub_nilpotent_cent2 nilK0Ms) ?joing_subl ?joing_subr //. + exact: pnat_coprime (pcore_pgroup _ _) sg'K0. +have [cycY nsYM] := sub'cent_sigma_cyclic sK0M sg'K0. +set Y := _ :&: _ in cycY nsYM. +have sK0Y: K0 \subset Y by rewrite !subsetI subxx cMsK0 commgSS. +split=> //; first exact: cyclicS sK0Y cycY. +by apply: char_normal_trans nsYM; rewrite sub_cyclic_char. +Qed. + +End AnotherMaximal. + +(* This is B & G, Lemma 10.12. *) +Lemma sigma_disjoint M H : + M \in 'M -> H \in 'M -> gval H \notin M :^: G -> + [/\ (*a*) M`_\alpha :&: H`_\sigma = 1, + [predI \alpha(M) & \sigma(H)] =i pred0 + & (*b*) nilpotent M`_\sigma -> + M`_\sigma :&: H`_\sigma = 1 + /\ [predI \sigma(M) & \sigma(H)] =i pred0]. +Proof. +move=> maxM maxH notjMH. +suffices sigmaMHnil p: p \in [predI \sigma(M) & \sigma(H)] -> + p \notin \alpha(M) /\ ~~ nilpotent M`_\sigma. +- have a2: [predI \alpha(M) & \sigma(H)] =i pred0. + move=> p; apply/andP=> [[/= aMp sHp]]. + by case: (sigmaMHnil p); rewrite /= ?aMp // inE /= alpha_sub_sigma. + split=> // [|nilMs]. + rewrite coprime_TIg // (pnat_coprime (pcore_pgroup _ _)) //. + apply: sub_in_pnat (pcore_pgroup _ _) => p _ sHp. + by apply: contraFN (a2 p) => aMp; rewrite inE /= sHp andbT. + have b2: [predI \sigma(M) & \sigma(H)] =i pred0. + by move=> p; apply/negP; case/sigmaMHnil => _; rewrite nilMs. + rewrite coprime_TIg // (pnat_coprime (pcore_pgroup _ _)) //. + apply: sub_in_pnat (pcore_pgroup _ _) => p _ sHp. + by apply: contraFN (b2 p) => bMp; rewrite inE /= sHp andbT. +case/andP=> sMp sHp; have [S sylS]:= Sylow_exists p M. +have [sSM pS _] := and3P sylS. +have sylS_G: p.-Sylow(G) S := sigma_Sylow_G maxM sMp sylS. +have [g sSHg]: exists g, S \subset H :^ g. + have [Sg' sylSg']:= Sylow_exists p H. + have [g _ ->] := Sylow_trans (sigma_Sylow_G maxH sHp sylSg') sylS_G. + by exists g; rewrite conjSg (pHall_sub sylSg'). +have{notjMH} neqHgM: H :^ g != M. + by apply: contraNneq notjMH => <-; rewrite orbit_sym mem_orbit ?in_setT. +do [split; apply: contra neqHgM] => [|nilMs]. + rewrite !inE -(p_rank_Sylow sylS) -rank_pgroup //= => rS_gt3. + have uniqS: S \in 'U := rank3_Uniqueness (mFT_pgroup_proper pS) rS_gt3. + have defUS: 'M(S) = [set M] := def_uniq_mmax uniqS maxM sSM. + by rewrite (eq_uniq_mmax defUS _ sSHg) ?mmaxJ. +have nsSM: S <| M. + have nsMsM: M`_\sigma <| M by exact: pcore_normal. + have{sylS} sylS: p.-Sylow(M`_\sigma) S. + apply: pHall_subl (pcore_sub _ _) sylS => //. + by rewrite (sub_Hall_pcore (Msigma_Hall maxM)) ?(pi_pgroup pS). + rewrite (nilpotent_Hall_pcore nilMs sylS). + by rewrite (char_normal_trans (pcore_char _ _)). +have sNS_Hg: 'N(S) \subset H :^ g. + rewrite -sub_conjgV -normJ (norm_sigma_Sylow sHp) //. + by rewrite (pHall_subl _ (subsetT _)) ?sub_conjgV // pHallJ ?in_setT. +have ltHg: H :^ g \proper G by rewrite mmax_proper ?mmaxJ //. +rewrite (mmax_max maxM ltHg) // -(mmax_normal maxM nsSM) //. +by apply: contraTneq sNS_Hg => ->; rewrite norm1 proper_subn. +Qed. + +(* This is B & G, Lemma 10.13. *) +Lemma basic_p2maxElem_structure p A P : + A \in 'E_p^2(G) :&: 'E*_p(G) -> p.-group P -> A \subset P -> ~~ abelian P -> + let Z0 := ('Ohm_1('Z(P)))%G in + [/\ (*a*) Z0 \in 'E_p^1(A), + (*b*) exists Y : {group gT}, + [/\ cyclic Y, Z0 \subset Y + & forall A0, A0 \in 'E_p^1(A) :\ Z0 -> A0 \x Y = 'C_P(A)] + & (*c*) [transitive 'N_P(A), on 'E_p^1(A) :\ Z0| 'JG]]. +Proof. +case/setIP=> Ep2A maxA pP sAP not_cPP Z0; set E1A := 'E_p^1(A). +have p_pr: prime p := pnElem_prime Ep2A; have [_ abelA dimA] := pnElemP Ep2A. +have [oA [pA cAA _]] := (card_pnElem Ep2A, and3P abelA). +have [p_gt0 p_gt1] := (prime_gt0 p_pr, prime_gt1 p_pr). +have{maxA} maxA S: + p.-group S -> A \subset S -> A \in 'E*_p(S) /\ 'Ohm_1('C_S(A)) = A. +- move=> pS sAS; suff maxAS: A \in 'E*_p(S) by rewrite (Ohm1_cent_max maxAS). + by rewrite (subsetP (pmaxElemS p (subsetT S))) // inE maxA inE. +have [S sylS sPS] := Sylow_superset (subsetT P) pP. +pose Z1 := 'Ohm_1('Z(S))%G; have sZ1Z: Z1 \subset 'Z(S) := Ohm_sub 1 _. +have [pS sAS] := (pHall_pgroup sylS, subset_trans sAP sPS). +have [maxAS defC1] := maxA S pS sAS; set C := 'C_S(A) in defC1. +have sZ0A: Z0 \subset A by rewrite -defC1 OhmS // setISS // centS. +have sZ1A: Z1 \subset A by rewrite -defC1 OhmS // setIS // centS. +have [pZ0 pZ1]: p.-group Z0 /\ p.-group Z1 by split; exact: pgroupS pA. +have sZ10: Z1 \subset Z0. + rewrite -[gval Z1]Ohm_id OhmS // subsetI (subset_trans sZ1A) //=. + by rewrite (subset_trans sZ1Z) // subIset // centS ?orbT. +have ntZ1: Z1 :!=: 1. + have: A :!=: 1 by rewrite -cardG_gt1 oA (ltn_exp2l 0). + apply: contraNneq; rewrite -subG1 -(setIidPr sZ1Z) => /TI_Ohm1. + by rewrite setIid => /(trivg_center_pgroup pS) <-. +have EpZ01: abelian C -> Z1 = Z0 /\ Z0 \in E1A. + move=> cCC; have [eqZ0A | ltZ0A] := eqVproper sZ0A. + rewrite (abelianS _ cCC) // in not_cPP. + by rewrite subsetI sPS centsC -eqZ0A (subset_trans (Ohm_sub _ _)) ?subsetIr. + have leZ0p: #|Z0| <= p ^ 1. + by rewrite (card_pgroup pZ0) leq_exp2l // -ltnS -dimA properG_ltn_log. + have [_ _ [e oZ1]] := pgroup_pdiv pZ1 ntZ1. + have{e oZ1}: #|Z1| >= p by rewrite oZ1 (leq_exp2l 1). + rewrite (geq_leqif (leqif_trans (subset_leqif_card sZ10) (leqif_eq leZ0p))). + rewrite [E1A]p1ElemE // !inE sZ0A; case/andP=> sZ01 ->. + by split=> //; apply/eqP; rewrite -val_eqE eqEsubset sZ10. +have [A1 neqA1Z EpA1]: exists2 A1, A1 != Z1 & #|Z1| = p -> A1 \in E1A. + have [oZ1 |] := #|Z1| =P p; last by exists 1%G; rewrite // eq_sym. + have [A1 defA]:= abelem_split_dprod abelA sZ1A. + have{defA} [_ defA _ tiA1Z1] := dprodP defA. + have EpZ1: Z1 \in E1A by rewrite [E1A]p1ElemE // !inE sZ1A /= oZ1. + suffices: A1 \in E1A by exists A1; rewrite // eq_sym; exact/(TIp1ElemP EpZ1). + rewrite [E1A]p1ElemE // !inE -defA mulG_subr /=. + by rewrite -(mulKn #|A1| p_gt0) -{1}oZ1 -TI_cardMg // defA oA mulKn. +pose cplA1C Y := [/\ cyclic Y, Z0 \subset Y, A1 \x Y = C & abelian C]. +have [Y [{cplA1C} cycY sZ0Y defC cCC]]: exists Y, cplA1C Y. + have [rSgt2 | rSle2] := ltnP 2 'r(S). + rewrite (rank_pgroup pS) in rSgt2; have oddS := mFT_odd S. + have max2AS: A \in 'E_p^2(S) :&: 'E*_p(S) by rewrite 3!inE sAS abelA dimA. + have oZ1: #|Z1| = p by case/Ohm1_ucn_p2maxElem: max2AS => // _ []. + have{EpA1} EpA1 := EpA1 oZ1; have [sA1A abelA1 oA1] := pnElemPcard EpA1. + have EpZ1: Z1 \in E1A by rewrite [E1A]p1ElemE // !inE sZ1A /= oZ1. + have [_ defA cA1Z tiA1Z] := dprodP (p2Elem_dprodP Ep2A EpA1 EpZ1 neqA1Z). + have defC: 'C_S(A1) = C. + rewrite /C -defA centM setICA setIC ['C_S(Z1)](setIidPl _) // centsC. + by rewrite (subset_trans sZ1Z) ?subsetIr. + have rCSA1: 'r_p('C_S(A1)) <= 2. + by rewrite defC -p_rank_Ohm1 defC1 (p_rank_abelem abelA) dimA. + have sA1S := subset_trans sA1A sAS. + have nnS: p.-narrow S by apply/implyP=> _; apply/set0Pn; exists A. + have [] := narrow_cent_dprod pS oddS rSgt2 nnS oA1 sA1S rCSA1. + set Y := _ :&: _; rewrite {}defC => cycY _ _ defC; exists [group of Y]. + have cCC: abelian C; last split=> //. + apply/center_idP; rewrite -(center_dprod defC). + rewrite (center_idP (abelem_abelian abelA1)). + by rewrite (center_idP (cyclic_abelian cycY)). + have{EpZ01} [<- _] := EpZ01 cCC; rewrite subsetI (subset_trans sZ1Z) //. + by rewrite setIS ?centS // (subset_trans (Ohm_sub 1 _)) ?ucn_sub. + have not_cSS := contra (abelianS sPS) not_cPP. + have:= mFT_rank2_Sylow_cprod sylS rSle2 not_cSS. + case=> E [_ dimE3 eE] [Y cycY [defS defY1]]. + have [[_ mulEY cEY] cYY] := (cprodP defS, cyclic_abelian cycY). + have defY: 'Z(S) = Y. + case/cprodP: (center_cprod defS) => _ <- _. + by rewrite (center_idP cYY) -defY1 mulSGid ?Ohm_sub. + have pY: p.-group Y by rewrite -defY (pgroupS (center_sub S)). + have sES: E \subset S by rewrite -mulEY mulG_subl. + have pE := pgroupS sES pS. + have defS1: 'Ohm_1(S) = E. + apply/eqP; rewrite (OhmE 1 pS) eqEsubset gen_subG andbC. + rewrite sub_gen; last by rewrite subsetI sES sub_LdivT. + apply/subsetP=> ey /LdivP[]; rewrite -mulEY. + case/imset2P=> e y Ee Yy -> eyp; rewrite groupM //. + rewrite (subsetP (center_sub E)) // -defY1 (OhmE 1 pY) mem_gen //. + rewrite expgMn in eyp; last by red; rewrite -(centsP cEY). + by rewrite (exponentP eE) // mul1g in eyp; rewrite !inE Yy eyp eqxx. + have sAE: A \subset E by rewrite -defS1 -(Ohm1_id abelA) OhmS. + have defC: A * Y = C. + rewrite /C -mulEY setIC -group_modr; last first. + by rewrite -defY subIset // orbC centS. + congr (_ * _); apply/eqP; rewrite /= setIC eqEcard subsetI sAE. + have pCEA: p.-group 'C_E(A) := pgroupS (subsetIl E _) pE. + rewrite -abelianE cAA (card_pgroup pCEA) oA leq_exp2l //= leqNgt. + apply: contraL cycY => dimCEA3. + have sAZE: A \subset 'Z(E). + rewrite subsetI sAE // centsC (sameP setIidPl eqP) eqEcard subsetIl /=. + by rewrite (card_pgroup pE) (card_pgroup pCEA) dimE3 leq_exp2l. + rewrite abelian_rank1_cyclic // -ltnNge (rank_pgroup pY). + by rewrite (p_rank_abelian p cYY) defY1 -dimA lognSg. + have cAY: Y \subset 'C(A) by apply: centSS cEY. + have cCC: abelian C by rewrite -defC abelianM cAA cYY. + have{EpZ01} [eqZ10 EpZ1] := EpZ01 cCC; rewrite -eqZ10 in EpZ1. + have sZ0Y: Z0 \subset Y by rewrite -eqZ10 -defY Ohm_sub. + have{EpA1} EpA1 := EpA1 (card_pnElem EpZ1). + have [sA1A _ oA1] := pnElemPcard EpA1. + have [_ defA _ tiA1Z] := dprodP (p2Elem_dprodP Ep2A EpA1 EpZ1 neqA1Z). + exists Y; split; rewrite // dprodE ?(centSS _ sA1A cAY) ?prime_TIg ?oA1 //. + by rewrite -(mulSGid sZ0Y) -eqZ10 mulgA defA. + apply: contraL cycY => sA1Y; rewrite abelian_rank1_cyclic // -ltnNge. + by rewrite -dimA -rank_abelem ?rankS // -defA eqZ10 mul_subG. +have{EpZ01} [eqZ10 EpZ0] := EpZ01 cCC; have oZ0 := card_pnElem EpZ0. +have{EpA1} EpA1: A1 \in E1A by rewrite EpA1 ?eqZ10. +have [sA1A _ oA1] := pnElemPcard EpA1; rewrite {}eqZ10 in neqA1Z. +have [_ defA _ tiA1Z] := dprodP (p2Elem_dprodP Ep2A EpA1 EpZ0 neqA1Z). +split=> //; first exists (P :&: Y)%G. + have sPY_Y := subsetIr P Y; rewrite (cyclicS sPY_Y) //. + rewrite subsetI (subset_trans sZ0A) //= sZ0Y. + split=> // A0 /setD1P[neqA0Z EpA0]; have [sA0A _ _] := pnElemP EpA0. + have [_ mulA0Z _ tiA0Z] := dprodP (p2Elem_dprodP Ep2A EpA0 EpZ0 neqA0Z). + have{defC} [_ defC cA1Y tiA1Y] := dprodP defC. + rewrite setIC -{2}(setIidPr sPS) setIAC. + apply: dprod_modl (subset_trans sA0A sAP); rewrite -defC dprodE /=. + - by rewrite -(mulSGid sZ0Y) !mulgA mulA0Z defA. + - rewrite (centSS (subxx Y) sA0A) // -defA centM subsetI cA1Y /=. + by rewrite sub_abelian_cent ?cyclic_abelian. + rewrite setIC -(setIidPr sA0A) setIA -defA -group_modr //. + by rewrite (setIC Y) tiA1Y mul1g setIC. +apply/imsetP; exists A1; first by rewrite 2!inE neqA1Z. +apply/eqP; rewrite eq_sym eqEcard; apply/andP; split. + apply/subsetP=> _ /imsetP[x /setIP[Px nAx] ->]. + rewrite 2!inE /E1A -(normP nAx) pnElemJ EpA1 andbT -val_eqE /=. + have nZ0P: P \subset 'N(Z0). + by rewrite (char_norm_trans (Ohm_char 1 _)) // gFnorm. + by rewrite -(normsP nZ0P x Px) (inj_eq (@conjsg_inj _ x)). +have pN: p.-group 'N_P(_) := pgroupS (subsetIl P _) pP. +have defCPA: 'N_('N_P(A))(A1) = 'C_P(A). + apply/eqP; rewrite eqEsubset andbC subsetI setIS ?cent_sub //. + rewrite subIset /=; last by rewrite orbC cents_norm ?centS. + rewrite setIAC (subset_trans (subsetIl _ _)) //= subsetI subsetIl /=. + rewrite -defA centM subsetI andbC subIset /=; last first. + by rewrite centsC (subset_trans (Ohm_sub 1 _)) ?subsetIr. + have nC_NP: 'N_P(A1) \subset 'N('C(A1)) by rewrite norms_cent ?subsetIr. + rewrite -quotient_sub1 // subG1 trivg_card1. + rewrite (pnat_1 (quotient_pgroup _ (pN _))) //. + rewrite -(card_isog (second_isog nC_NP)) /= (setIC 'C(A1)). + by apply: p'group_quotient_cent_prime; rewrite ?subsetIr ?oA1. +have sCN: 'C_P(A) \subset 'N_P(A) by rewrite setIS ?cent_sub. +have nA_NCPA: 'N_P('C_P(A)) \subset 'N_P(A). + have [_ defCPA1] := maxA P pP sAP. + by rewrite -{2}defCPA1 setIS // (char_norm_trans (Ohm_char 1 _)). +rewrite card_orbit astab1JG /= {}defCPA. +rewrite -(leq_add2l (Z0 \in E1A)) -cardsD1 EpZ0 (card_p1Elem_p2Elem Ep2A) ltnS. +rewrite dvdn_leq ?(pfactor_dvdn 1) ?indexg_gt0 // -divgS // logn_div ?cardSg //. +rewrite subn_gt0 properG_ltn_log ?pN //= (proper_sub_trans _ nA_NCPA) //. +rewrite (nilpotent_proper_norm (pgroup_nil pP)) // properEneq subsetIl andbT. +by apply: contraNneq not_cPP => <-; rewrite (abelianS (setSI _ sPS)). +Qed. + +(* This is B & G, Proposition 10.14(a). *) +Proposition beta_not_narrow p : p \in \beta(G) -> + [disjoint 'E_p^2(G) & 'E*_p(G)] + /\ (forall P, p.-Sylow(G) P -> [disjoint 'E_p^2(P) & 'E*_p(P)]). +Proof. +move/forall_inP=> nnG. +have nnSyl P: p.-Sylow(G) P -> [disjoint 'E_p^2(P) & 'E*_p(P)]. + by move/nnG; rewrite negb_imply negbK setI_eq0 => /andP[]. +split=> //; apply/pred0Pn=> [[E /andP[/= Ep2E EpmE]]]. +have [_ abelE dimE]:= pnElemP Ep2E; have pE := abelem_pgroup abelE. +have [P sylP sEP] := Sylow_superset (subsetT E) pE. +case/pred0Pn: (nnSyl P sylP); exists E; rewrite /= 2!inE sEP abelE dimE /=. +by rewrite (subsetP (pmaxElemS p (subsetT P))) // inE EpmE inE. +Qed. + +(* This is B & G, Proposition 10.14(b). *) +Proposition beta_noncyclic_uniq p R : + p \in \beta(G) -> p.-group R -> 'r(R) > 1 -> R \in 'U. +Proof. +move=> b_p pR rRgt1; have [P sylP sRP] := Sylow_superset (subsetT R) pR. +rewrite (rank_pgroup pR) in rRgt1; have [A Ep2A] := p_rank_geP rRgt1. +have [sAR abelA dimA] := pnElemP Ep2A; have p_pr := pnElem_prime Ep2A. +case: (pickP [pred F in 'E_p(P) | A \proper F]) => [F | maxA]; last first. + have [_ nnSyl] := beta_not_narrow b_p; case/pred0Pn: (nnSyl P sylP). + exists A; rewrite /= (subsetP (pnElemS p 2 sRP)) //. + apply/pmaxElemP; split=> [|F EpF]; first by rewrite inE (subset_trans sAR). + by case/eqVproper=> [// | ltAF]; case/andP: (maxA F). +case/andP=> /pElemP[_ abelF] ltAF; have [pF cFF _] := and3P abelF. +apply: uniq_mmaxS sAR (mFT_pgroup_proper pR) _. +have rCAgt2: 'r('C(A)) > 2. + rewrite -dimA (leq_trans (properG_ltn_log pF ltAF)) // -(rank_abelem abelF). + by rewrite rankS // centsC (subset_trans (proper_sub ltAF)). +by apply: cent_rank3_Uniqueness rCAgt2; rewrite (rank_abelem abelA) dimA. +Qed. + +(* This is B & G, Proposition 10.14(c). *) +Proposition beta_subnorm_uniq p P X : + p \in \beta(G) -> p.-Sylow(G) P -> X \subset P -> 'N_P(X)%G \in 'U. +Proof. +move=> b_p sylP sXP; set Q := 'N_P(X)%G. +have pP := pHall_pgroup sylP; have pQ: p.-group Q := pgroupS (subsetIl _ _) pP. +have [| rQle1] := ltnP 1 'r(Q); first exact: beta_noncyclic_uniq pQ. +have cycQ: cyclic Q. + by rewrite (odd_pgroup_rank1_cyclic pQ) ?mFT_odd -?rank_pgroup. +have defQ: P :=: Q. + apply: (nilpotent_sub_norm (pgroup_nil pP) (subsetIl _ _)). + by rewrite setIS // char_norms // sub_cyclic_char // subsetI sXP normG. +have:= forall_inP b_p P; rewrite inE negb_imply ltnNge; move/(_ sylP). +by rewrite defQ -(rank_pgroup pQ) (leq_trans rQle1). +Qed. + +(* This is B & G, Proposition 10.14(d). *) +Proposition beta_norm_sub_mmax M Y : + M \in 'M -> \beta(M).-subgroup(M) Y -> Y :!=: 1 -> 'N(Y) \subset M. +Proof. +move=> maxM /andP[sYM bY] ntY. +have [F1 | [q q_pr q_dv_FY]] := trivgVpdiv 'F(Y). + by rewrite -(trivg_Fitting (solvableS sYM (mmax_sol maxM))) F1 eqxx in ntY. +pose X := 'O_q(Y); have qX: q.-group X := pcore_pgroup q _. +have ntX: X != 1. + apply: contraTneq q_dv_FY => X1; rewrite -p'natE // -partn_eq1 //. + rewrite -(card_Hall (nilpotent_pcore_Hall q (Fitting_nil Y))). + by rewrite /= p_core_Fitting -/X X1 cards1. +have bMq: q \in \beta(M) by apply: (pgroupP (pgroupS (Fitting_sub Y) bY)). +have b_q: q \in \beta(G) by move: bMq; rewrite -predI_sigma_beta //; case/andP. +have sXM: X \subset M := subset_trans (pcore_sub q Y) sYM. +have [P sylP sXP] := Sylow_superset sXM qX; have [sPM qP _] := and3P sylP. +have sylPG: q.-Sylow(G) P by rewrite (sigma_Sylow_G maxM) ?beta_sub_sigma. +have uniqNX: 'M('N_P(X)) = [set M]. + apply: def_uniq_mmax => //; last by rewrite subIset ?sPM. + exact: (beta_subnorm_uniq b_q). +rewrite (subset_trans (char_norms (pcore_char q Y))) //. +rewrite (sub_uniq_mmax uniqNX) ?subsetIr // mFT_norm_proper //. +by rewrite (sub_mmax_proper maxM). +Qed. + +End Ten. + + diff --git a/mathcomp/odd_order/BGsection11.v b/mathcomp/odd_order/BGsection11.v new file mode 100644 index 0000000..6fccf96 --- /dev/null +++ b/mathcomp/odd_order/BGsection11.v @@ -0,0 +1,438 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div path fintype. +Require Import bigop finset prime fingroup morphism perm automorphism quotient. +Require Import action gproduct gfunctor pgroup cyclic center commutator. +Require Import gseries nilpotent sylow abelian maximal hall. +Require Import BGsection1 BGsection3 BGsection4 BGsection5 BGsection6. +Require Import BGsection7 BGsection10. + +(******************************************************************************) +(* This file covers B & G, section 11; it has only one definition: *) +(* exceptional_FTmaximal p M A0 A <=> *) +(* p, M and A0 satisfy the conditions of Hypothesis 11.1 in B & G, i.e., *) +(* M is an "exceptional" maximal subgroup in the terminology of B & G. *) +(* In addition, A is elementary abelian p-subgroup of M of rank 2, that *) +(* contains A0. The existence of A is guaranteed by Lemma 10.5, but as *) +(* in the only two lemmas that make use of the results in this section *) +(* (Lemma 12.3 and Theorem 12.5) A is known, we elected to make the *) +(* dependency on A explicit. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section Section11. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). + +Implicit Types p q r : nat. +Implicit Types A E H K M N P Q R S T U V W X Y : {group gT}. + +Variables (p : nat) (M A0 A P : {group gT}). + +(* This definition corresponsd to Hypothesis 11.1, where the condition on A *) +(* has been made explicit. *) +Definition exceptional_FTmaximal := + [/\ p \in \sigma(M)^', A \in 'E_p^2(M), A0 \in 'E_p^1(A) & 'N(A0) \subset M]. + +Hypotheses (maxM : M \in 'M) (excM : exceptional_FTmaximal). +Hypotheses (sylP : p.-Sylow(M) P) (sAP : A \subset P). + +(* Splitting the excM hypothesis. *) +Let sM'p : p \in \sigma(M)^'. Proof. by case: excM. Qed. +Let Ep2A : A \in 'E_p^2(M). Proof. by case: excM. Qed. +Let Ep1A0 : A0 \in 'E_p^1(A). Proof. by case: excM. Qed. +Let sNA0_M : 'N(A0) \subset M. Proof. by case: excM. Qed. + +(* Arithmetics of p. *) +Let p_pr : prime p := pnElem_prime Ep2A. +Let p_gt1 : p > 1 := prime_gt1 p_pr. +Let p_gt0 : p > 0 := prime_gt0 p_pr. + +(* Group orders. *) +Let oA : #|A| = (p ^ 2)%N := card_pnElem Ep2A. +Let oA0 : #|A0| = p := card_pnElem Ep1A0. + +(* Structure of A. *) +Let abelA : p.-abelem A. Proof. by case/pnElemP: Ep2A. Qed. +Let pA : p.-group A := abelem_pgroup abelA. +Let cAA : abelian A := abelem_abelian abelA. + +(* Various set inclusions. *) +Let sA0A : A0 \subset A. Proof. by case/pnElemP: Ep1A0. Qed. +Let sPM : P \subset M := pHall_sub sylP. +Let sAM : A \subset M := subset_trans sAP sPM. +Let sCA0_M : 'C(A0) \subset M := subset_trans (cent_sub A0) sNA0_M. +Let sCA_M : 'C(A) \subset M := subset_trans (centS sA0A) sCA0_M. + +(* Alternative E_p^1 memberships for A0; the first is the one used to state *) +(* Hypothesis 11.1 in B & G, the second is the form expected by Lemma 10.5. *) +(* Note that #|A0| = p (oA0 above) would wokr just as well. *) +Let Ep1A0_M : A0 \in 'E_p^1(M) := subsetP (pnElemS p 1 sAM) A0 Ep1A0. +Let Ep1A0_G : A0 \in 'E_p^1(G) := subsetP (pnElemS p 1 (subsetT M)) A0 Ep1A0_M. + +(* This does not depend on exceptionalM, and could move to Section 10. *) +Lemma sigma'_Sylow_contra : p \in \sigma(M)^' -> ~~ ('N(P) \subset M). +Proof. by apply: contra => sNM; apply/exists_inP; exists P. Qed. + +(* First preliminary remark of Section 11; only depends on sM'p and sylP. *) +Let not_sNP_M: ~~ ('N(P) \subset M) := sigma'_Sylow_contra sM'p. + +(* Second preliminary remark of Section 11; only depends on sM'p, Ep1A0_M, *) +(* and sNA0_M. *) +Lemma p_rank_exceptional : 'r_p(M) = 2. +Proof. exact: sigma'_norm_mmax_rank2 (pgroupS sA0A pA) _. Qed. +Let rM := p_rank_exceptional. + +(* Third preliminary remark of Section 11. *) +Lemma exceptional_pmaxElem : A \in 'E*_p(G). +Proof. +have [_ _ dimA]:= pnElemP Ep2A. +apply/pmaxElemP; split=> [|E EpE sAE]; first by rewrite !inE subsetT. +have [//|ltAE]: A :=: E \/ A \proper E := eqVproper sAE. +have [_ abelE] := pElemP EpE; have [pE cEE _] := and3P abelE. +suffices: logn p #|E| <= 'r_p(M) by rewrite leqNgt rM -dimA properG_ltn_log. +by rewrite logn_le_p_rank // inE (subset_trans cEE) ?(subset_trans (centS sAE)). +Qed. +Let EpmA := exceptional_pmaxElem. + +(* This is B & G, Lemma 11.1. *) +Lemma exceptional_TIsigmaJ g q Q1 Q2 : + g \notin M -> A \subset M :^ g -> + q.-Sylow(M`_\sigma) Q1 -> A \subset 'N(Q1) -> + q.-Sylow(M`_\sigma :^ g) Q2 -> A \subset 'N(Q2) -> + (*a*) Q1 :&: Q2 = 1 + /\ (*b*) (forall X, X \in 'E_p^1(A) -> 'C_Q1(X) = 1 \/ 'C_Q2(X) = 1). +Proof. +move=> notMg sAMg sylQ1 nQ1A sylQ2 nQ2A. +have [-> | ntQ1] := eqsVneq Q1 1. + by split=> [|? _]; last left; apply: (setIidPl (sub1G _)). +have [sQ1Ms qQ1 _] := and3P sylQ1. +have{qQ1} [q_pr q_dv_Q1 _] := pgroup_pdiv qQ1 ntQ1. +have{sQ1Ms q_dv_Q1} sMq: q \in \sigma(M). + exact: pgroupP (pgroupS sQ1Ms (pcore_pgroup _ _)) q q_pr q_dv_Q1. +have{sylQ1} sylQ1: q.-Sylow(M) Q1. + by rewrite (subHall_Sylow (Msigma_Hall maxM)). +have sQ1M := pHall_sub sylQ1. +have{sylQ2} sylQ2g': q.-Sylow(M) (Q2 :^ g^-1). + by rewrite (subHall_Sylow (Msigma_Hall _)) // -(pHallJ2 _ _ _ g) actKV. +have sylQ2: q.-Sylow(G) Q2. + by rewrite -(pHallJ _ _ (in_setT g^-1)) (sigma_Sylow_G maxM). +suffices not_Q1_CA_Q2: gval Q2 \notin Q1 :^: 'O_\pi(A)^'('C(A)). + have ncA: normed_constrained A. + have ntA: A :!=: 1 by rewrite -cardG_gt1 oA (ltn_exp2l 0). + exact: plength_1_normed_constrained ntA EpmA (mFT_proper_plength1 _). + have q'A: q \notin \pi(A). + by apply: contraL sMq; move/(pnatPpi pA); move/eqnP->. + have maxnAq Q: q.-Sylow(G) Q -> A \subset 'N(Q) -> Q \in |/|*(A; q). + move=> sylQ; case/(max_normed_exists (pHall_pgroup sylQ)) => R maxR sQR. + have [qR _] := mem_max_normed maxR. + by rewrite -(group_inj (sub_pHall sylQ qR sQR (subsetT R))). + have maxQ1 := maxnAq Q1 (sigma_Sylow_G maxM sMq sylQ1) nQ1A. + have maxQ2 := maxnAq Q2 sylQ2 nQ2A. + have transCAQ := normed_constrained_meet_trans ncA q'A _ _ maxQ1 maxQ2. + split=> [|X EpX]. + apply: contraNeq not_Q1_CA_Q2 => ntQ12; apply/imsetP. + apply: transCAQ (sAM) (mmax_proper maxM) _ _. + by rewrite (setIidPl sQ1M). + by apply: contraNneq ntQ12 => tiQ2M; rewrite setIC -subG1 -tiQ2M setIS. + apply/pred2P; apply: contraR not_Q1_CA_Q2; case/norP=> ntCQ1 ntCQ2. + have [sXA _ oX] := pnElemPcard EpX. + apply/imsetP; apply: transCAQ (centSS _ sXA cAA) _ ntCQ1 ntCQ2 => //. + by rewrite mFT_cent_proper // -cardG_gt1 oX prime_gt1. +apply: contra notMg; case/imsetP=> k cAk defQ2. +have{cAk} Mk := subsetP sCA_M k (subsetP (pcore_sub _ _) k cAk). +have{k Mk defQ2} sQ2M: Q2 \subset M by rewrite defQ2 conj_subG. +have [sQ2g'M qQ2g' _] := and3P sylQ2g'. +by rewrite (sigma_Sylow_trans _ sylQ2g') // actKV. +Qed. + +(* This is B & G, Corollary 11.2. *) +Corollary exceptional_TI_MsigmaJ g : + g \notin M -> A \subset M :^ g -> + (*a*) M`_\sigma :&: M :^ g = 1 + /\ (*b*) M`_\sigma :&: 'C(A0 :^ g) = 1. +Proof. +move=> notMg sAMg; set Ms := M`_\sigma; set H := [group of Ms :&: M :^ g]. +have [H1 | ntH] := eqsVneq H 1. + by split=> //; apply/trivgP; rewrite -H1 setIS //= centJ conjSg. +pose q := pdiv #|H|. +suffices: #|H|`_q == 1%N by rewrite p_part_eq1 pi_pdiv cardG_gt1 ntH. +have nsMsM: Ms <| M := pcore_normal _ _; have [_ nMsM] := andP nsMsM. +have sHMs: H \subset Ms := subsetIl _ _. +have sHMsg: H \subset Ms :^ g. + rewrite -sub_conjgV (sub_Hall_pcore (Msigma_Hall _)) //. + by rewrite pgroupJ (pgroupS sHMs) ?pcore_pgroup. + by rewrite sub_conjgV subsetIr. +have nMsA := subset_trans sAM nMsM. +have nHA: A \subset 'N(H) by rewrite normsI // normsG. +have nMsgA: A \subset 'N(Ms :^ g) by rewrite normJ (subset_trans sAMg) ?conjSg. +have coMsA: coprime #|Ms| #|A|. + by rewrite oA coprime_expr ?(pnat_coprime (pcore_pgroup _ _)) ?pnatE. +have coHA: coprime #|H| #|A| := coprimeSg sHMs coMsA. +have coMsgA: coprime #|Ms :^ g| #|A| by rewrite cardJg. +have solA: solvable A := abelian_sol cAA. +have [Q0 sylQ0 nQ0A] := sol_coprime_Sylow_exists q solA nHA coHA. +have [sQ0H qQ0 _] := and3P sylQ0. +have supQ0 := sol_coprime_Sylow_subset _ _ solA (subset_trans sQ0H _) qQ0 nQ0A. +have [Q1 [sylQ1 nQ1A sQ01]] := supQ0 _ nMsA coMsA sHMs. +have [Q2 [sylQ2 nQ2A sQ02]] := supQ0 _ nMsgA coMsgA sHMsg. +have tiQ12: Q1 :&: Q2 = 1. + by have [-> _] := exceptional_TIsigmaJ notMg sAMg sylQ1 nQ1A sylQ2 nQ2A. +by rewrite -(card_Hall sylQ0) -trivg_card1 -subG1 -tiQ12 subsetI sQ01. +Qed. + +(* This is B & G, Theorem 11.3. *) +Theorem exceptional_sigma_nil : nilpotent M`_\sigma. +Proof. +have [g nPg notMg] := subsetPn not_sNP_M. +set Ms := M`_\sigma; set F := Ms <*> A0 :^ g. +have sA0gM: A0 :^ g \subset M. + by rewrite (subset_trans _ sPM) // -(normP nPg) conjSg (subset_trans sA0A). +have defF: Ms ><| A0 :^ g = F. + rewrite sdprodEY ?coprime_TIg //. + by rewrite (subset_trans sA0gM) ?gFnorm. + by rewrite cardJg oA0 (pnat_coprime (pcore_pgroup _ _)) ?pnatE. +have regA0g: 'C_Ms(A0 :^ g) = 1. + case/exceptional_TI_MsigmaJ: notMg => //. + by rewrite -sub_conjgV (subset_trans _ sPM) // sub_conjgV (normP _). +rewrite (prime_Frobenius_sol_kernel_nil defF) ?cardJg ?oA0 //. +by rewrite (solvableS _ (mmax_sol maxM)) // join_subG pcore_sub. +Qed. + +(* This is B & G, Corollary 11.4. *) +Corollary exceptional_sigma_uniq H : + H \in 'M(A) -> H`_\sigma :&: M `_\sigma != 1 -> H :=: M. +Proof. +rewrite setIC => /setIdP[maxH sAH] ntMsHs. +have [g _ defH]: exists2 g, g \in G & H :=: M :^ g. + apply/imsetP; apply: contraR ntMsHs => /sigma_disjoint[] // _ _. + by case/(_ exceptional_sigma_nil)=> ->. +rewrite defH conjGid //; apply: contraR ntMsHs => notMg. +have [|tiMsMg _] := exceptional_TI_MsigmaJ notMg; first by rewrite -defH. +by rewrite -subG1 -tiMsMg -defH setIS ?pcore_sub. +Qed. + +(* This is B & G, Theorem 11.5. *) +Theorem exceptional_Sylow_abelian P1 : p.-Sylow(M) P1 -> abelian P1. +Proof. +have nregA Q: gval Q != 1 -> A \subset 'N(Q) -> coprime #|Q| #|A| -> + exists2 X, X \in 'E_p^1(A) & 'C_Q(X) != 1. +- move=> ntQ nQA coQA; apply/exists_inP; apply: contraR ntQ. + rewrite negb_exists_in -subG1; move/forall_inP=> regA. + have ncycA: ~~ cyclic A by rewrite (abelem_cyclic abelA) oA pfactorK. + rewrite -(coprime_abelian_gen_cent1 _ _ nQA) // gen_subG. + apply/bigcupsP=> x /setD1P[ntx Ax]. + apply/negPn; rewrite /= -cent_cycle subG1 regA // p1ElemE // !inE. + by rewrite cycle_subG Ax /= -orderE (abelem_order_p abelA). +suffices{P1} cPP: abelian P. + by move=> sylP1; have [m _ ->] := Sylow_trans sylP sylP1; rewrite abelianJ. +have [g nPg notMg] := subsetPn not_sNP_M. +pose Ms := M`_\sigma; pose q := pdiv #|Ms|; have pP := pHall_pgroup sylP. +have nMsP: P \subset 'N(Ms) by rewrite (subset_trans sPM) ?gFnorm. +have coMsP: coprime #|Ms| #|P|. + exact: pnat_coprime (pcore_pgroup _ _) (pi_pnat pP sM'p). +have [Q1 sylQ1 nQ1P]:= sol_coprime_Sylow_exists q (pgroup_sol pP) nMsP coMsP. +have ntQ1: Q1 :!=: 1. + rewrite -cardG_gt1 (card_Hall sylQ1) p_part_gt1 pi_pdiv cardG_gt1. + by rewrite Msigma_neq1. +have nQ1A: A \subset 'N(Q1) := subset_trans sAP nQ1P. +have coQ1A: coprime #|Q1| #|A|. + by rewrite (coprimeSg (pHall_sub sylQ1)) // (coprimegS sAP). +have [X1 EpX1 nregX11] := nregA _ ntQ1 nQ1A coQ1A. +pose Q2 := Q1 :^ g; have sylQ2: q.-Sylow(Ms :^ g) Q2 by rewrite pHallJ2. +have{ntQ1} ntQ2: Q2 != 1 by rewrite -!cardG_gt1 cardJg in ntQ1 *. +have nQ2A: A \subset 'N(Q2) by rewrite (subset_trans sAP) ?norm_conj_norm. +have{coQ1A} coQ2A: coprime #|Q2| #|A| by rewrite cardJg. +have{nregA ntQ2 coQ2A} [X2 EpX2 nregX22] := nregA _ ntQ2 nQ2A coQ2A. +have [|_ regA]:= exceptional_TIsigmaJ notMg _ sylQ1 nQ1A sylQ2 nQ2A. + by rewrite (subset_trans sAP) // -(normP nPg) conjSg. +have regX21: 'C_Q1(X2) = 1 by case: (regA X2) nregX22 => // ->; rewrite eqxx. +have regX12: 'C_Q2(X1) = 1 by case: (regA X1) nregX11 => // ->; rewrite eqxx. +pose X := 'Ohm_1('Z(P))%G. +have eqCQ12_X: ('C_Q1(X) == 1) = ('C_Q2(X) == 1). + rewrite -(inj_eq (@conjsg_inj _ g)) conjs1g conjIg -/Q2 -centJ (normP _) //. + rewrite (subsetP (char_norm_trans (Ohm_char 1 _) _) g nPg) //. + by rewrite char_norms ?center_char. +have{EpX1} EpX1: X1 \in 'E_p^1(A) :\ X. + rewrite 2!inE EpX1 andbT; apply: contraNneq nregX11 => defX1. + by rewrite defX1 eqCQ12_X -defX1 regX12. +have{EpX2 eqCQ12_X} EpX2: X2 \in 'E_p^1(A) :\ X. + rewrite 2!inE EpX2 andbT; apply: contraNneq nregX22 => defX2. + by rewrite defX2 -eqCQ12_X -defX2 regX21. +apply: contraR nregX11 => not_cPP. +have{not_cPP} transNPA: [transitive 'N_P(A), on 'E_p^1(A) :\ X | 'JG]. + have [|_ _]:= basic_p2maxElem_structure _ pP sAP not_cPP; last by []. + by rewrite inE (subsetP (pnElemS p 2 (subsetT M))). +have [y PnAy ->] := atransP2 transNPA EpX2 EpX1; have [Py _] := setIP PnAy. +by rewrite centJ -(normsP nQ1P y Py) -conjIg regX21 conjs1g. +Qed. + +(* This is B & G, Corollary 11.6. *) +Corollary exceptional_structure (Ms := M`_\sigma) : + [/\ (*a*) A :=: 'Ohm_1(P), + (*b*) 'C_Ms(A) = 1 + & (*c*) exists2 A1, A1 \in 'E_p^1(A) & exists2 A2, A2 \in 'E_p^1(A) & + [/\ A1 :!=: A2, 'C_Ms(A1) = 1 & 'C_Ms(A2) = 1]]. +Proof. +pose iMNA := #|'N(A) : M|. +have defA: A :=: 'Ohm_1(P). + apply/eqP; rewrite eqEcard -{1}(Ohm1_id abelA) OhmS //= oA -rM. + rewrite -(p_rank_Sylow sylP) p_rank_abelian ?exceptional_Sylow_abelian //. + by rewrite -card_pgroup // (pgroupS _ (pHall_pgroup sylP)) ?Ohm_sub. +have iMNAgt1: iMNA > 1. + rewrite indexg_gt1 defA; apply: contra (subset_trans _) not_sNP_M. + by rewrite char_norms ?Ohm_char. +have iMNAgt2: iMNA > 2. + pose q := pdiv iMNA; have q_iMNA: q %| iMNA := pdiv_dvd iMNA. + rewrite (leq_trans _ (dvdn_leq (ltnW _) q_iMNA)) // ltn_neqAle eq_sym. + rewrite (sameP eqP (prime_oddPn _)) ?prime_gt1 ?pdiv_prime //. + by rewrite (dvdn_odd q_iMNA) // (dvdn_odd (dvdn_indexg _ _)) ?mFT_odd. +rewrite [iMNA](cardD1 (gval M)) orbit_refl !ltnS lt0n in iMNAgt1 iMNAgt2. +have{iMNAgt1} [Mg1 /= NM_Mg1] := pred0Pn iMNAgt1. +rewrite (cardD1 Mg1) inE /= NM_Mg1 ltnS lt0n in iMNAgt2. +have{iMNAgt2} [Mg2 /= NM_Mg2] := pred0Pn iMNAgt2. +case/andP: NM_Mg1 => neM_Mg1 /rcosetsP[g1 nAg1 defMg1]. +have{neM_Mg1} notMg1: g1 \notin M. + by apply: contra neM_Mg1 => M_g1; rewrite defMg1 rcoset_id. +case/and3P: NM_Mg2 => neMg12 neM_Mg2 /rcosetsP[g2 nAg2 defMg2]. +have{neM_Mg2} notMg2: g2 \notin M. + by apply: contra neM_Mg2 => M_g2; rewrite defMg2 rcoset_id. +pose A1 := (A0 :^ g1)%G; pose A2 := (A0 :^ g2)%G. +have EpA1: A1 \in 'E_p^1(A) by rewrite -(normP nAg1) pnElemJ. +have EpA2: A2 \in 'E_p^1(A) by rewrite -(normP nAg2) pnElemJ. +have{neMg12} neqA12: A1 :!=: A2. + rewrite -(canF_eq (conjsgKV g2)) -conjsgM (sameP eqP normP). + rewrite (contra (subsetP sNA0_M _)) // -mem_rcoset. + by apply: contra neMg12 => g1Mg2; rewrite defMg1 defMg2 (rcoset_transl g1Mg2). +have{notMg1 nAg1} regA1: 'C_Ms(A1) = 1. + by case/exceptional_TI_MsigmaJ: notMg1; rewrite // -(normP nAg1) conjSg. +have{notMg2 nAg2} regA2: 'C_Ms(A2) = 1. + by case/exceptional_TI_MsigmaJ: notMg2; rewrite // -(normP nAg2) conjSg. +split=> //; last by exists A1 => //; exists A2 => //. +by apply/trivgP; rewrite -regA1 setIS ?centS //; case/pnElemP: EpA1. +Qed. + +(* This is B & G, Theorem 11.7 (the main result on exceptional subgroups). *) +Theorem exceptional_mul_sigma_normal : M`_\sigma <*> A <| M. +Proof. +set Ms := M`_\sigma; have pP := pHall_pgroup sylP; have solM := mmax_sol maxM. +have [E hallE sPE] := Hall_superset solM sPM (pi_pnat pP sM'p). +have sAE := subset_trans sAP sPE; have [sEM s'E _] := and3P hallE. +have [_ _ dimA] := pnElemP Ep2A. +have rE: 'r(E) = 2. + apply/eqP; rewrite eqn_leq -{2}dimA -rank_abelem ?rankS // andbT leqNgt. + have [q q_pr ->]:= rank_witness E; apply/negP=> rqEgt2. + have piEq: q \in \pi(E) by rewrite -p_rank_gt0 -(subnKC rqEgt2). + case/negP: (pnatPpi s'E piEq); rewrite /= alpha_sub_sigma // !inE. + by rewrite (leq_trans rqEgt2) ?p_rankS. +have rFEle2: 'r('F(E)) <= 2 by rewrite -rE rankS ?Fitting_sub. +have solE := solvableS sEM solM; have oddE := mFT_odd E. +pose tau : nat_pred := [pred q | q > p]; pose K := 'O_tau(E). +have hallK: tau.-Hall(E) K by rewrite rank2_ge_pcore_Hall. +pose ptau : nat_pred := [pred q | q >= p]; pose KP := K <*> P. +have nKP: P \subset 'N(K) by rewrite (subset_trans sPE) ?gFnorm. +have coKP: coprime #|K| #|P|. + by rewrite (pnat_coprime (pcore_pgroup _ _)) ?(pi_pnat pP) //= !inE ltnn. +have hallKP: ptau.-Hall(E) KP. + rewrite pHallE join_subG pcore_sub sPE /= norm_joinEr ?coprime_cardMg //. + apply/eqP; rewrite -(partnC tau (part_gt0 _ _)) (card_Hall sylP). + rewrite (card_Hall hallK) partn_part => [|q]; last exact: leqW. + rewrite (card_Hall hallE) -!partnI; congr (_ * _)%N; apply: eq_partn => q. + by rewrite 4!inE andbC /= 8!inE -leqNgt -eqn_leq eq_sym; case: eqP => // <-. +have nsKP_E: KP <| E. + by rewrite [KP](eq_Hall_pcore _ hallKP) ?pcore_normal ?rank2_ge_pcore_Hall. +have [cKA | not_cKA]:= boolP (A \subset 'C(K)). + pose KA := K <*> A; have defKA: K \x A = KA. + by rewrite dprodEY // coprime_TIg // (coprimegS sAP). + have defA: 'Ohm_1(P) = A by case exceptional_structure. + have{defA} defA: 'Ohm_1('O_p(KP)) = A. + apply/eqP; rewrite -defA eqEsubset OhmS /=; last first. + rewrite pcore_sub_Hall ?(pHall_subl _ _ sylP) ?joing_subr //. + exact: subset_trans (pHall_sub hallKP) sEM. + rewrite -Ohm_id defA OhmS // pcore_max // /normal join_subG. + rewrite (subset_trans sAP) ?joing_subr // cents_norm 1?centsC //=. + by rewrite -defA gFnorm. + have nMsE: E \subset 'N(Ms) by rewrite (subset_trans sEM) ?gFnorm. + have tiMsE: Ms :&: E = 1. + by rewrite coprime_TIg ?(pnat_coprime (pcore_pgroup _ _)). + have <-: Ms * E = M. + apply/eqP; rewrite eqEcard mulG_subG pcore_sub sEM /= TI_cardMg //. + by rewrite (card_Hall hallE) (card_Hall (Msigma_Hall maxM)) ?partnC. + rewrite norm_joinEr -?quotientK ?(subset_trans sAE) //= cosetpre_normal. + rewrite quotient_normal // -defA (char_normal_trans (Ohm_char _ _)) //. + by rewrite (char_normal_trans (pcore_char p _)). +pose q := pdiv #|K : 'C_K(A)|. +have q_pr: prime q by rewrite pdiv_prime // indexg_gt1 subsetI subxx centsC. +have [nKA coKA] := (subset_trans sAP nKP, coprimegS sAP coKP). +have [Q sylQ nQA]: exists2 Q : {group gT}, q.-Sylow(K) Q & A \subset 'N(Q). + by apply: sol_coprime_Sylow_exists => //; exact: (pgroup_sol pA). +have [sQK qQ q'iQK] := and3P sylQ; have [sKE tauK _]:= and3P hallK. +have{q'iQK} not_cQA: ~~ (A \subset 'C(Q)). + apply: contraL q'iQK => cQA; rewrite p'natE // negbK. + rewrite -(Lagrange_index (subsetIl K 'C(A))) ?dvdn_mulr ?pdiv_dvd //. + by rewrite subsetI sQK centsC. +have ntQ: Q :!=: 1 by apply: contraNneq not_cQA => ->; exact: cents1. +have q_dv_K: q %| #|K| := dvdn_trans (pdiv_dvd _) (dvdn_indexg _ _). +have sM'q: q \in (\sigma(M))^' := pgroupP (pgroupS sKE s'E) q q_pr q_dv_K. +have{q_dv_K} tau_q: q \in tau := pgroupP tauK q q_pr q_dv_K. +have sylQ_E: q.-Sylow(E) Q := subHall_Sylow hallK tau_q sylQ. +have sylQ_M: q.-Sylow(M) Q := subHall_Sylow hallE sM'q sylQ_E. +have q'p: p != q by rewrite neq_ltn [p < q]tau_q. +have [regQ | nregQ] := eqVneq 'C_Q(A) 1; last first. + have ncycQ: ~~ cyclic Q. + apply: contra not_cQA => cycQ. + rewrite (coprime_odd_faithful_Ohm1 qQ) ?mFT_odd ?(coprimeSg sQK) //. + rewrite centsC; apply: contraR nregQ => not_sQ1_CA. + rewrite setIC TI_Ohm1 // setIC prime_TIg //. + by rewrite (Ohm1_cyclic_pgroup_prime cycQ qQ ntQ). + have {ncycQ} rQ: 'r_q(Q) = 2. + apply/eqP; rewrite eqn_leq ltnNge -odd_pgroup_rank1_cyclic ?mFT_odd //. + by rewrite -rE -rank_pgroup ?rankS // (pHall_sub sylQ_E). + have [B Eq2B]: exists B, B \in 'E_q^2(Q) by apply/p_rank_geP; rewrite rQ. + have maxB: B \in 'E*_q(G). + apply: subsetP (subsetP (pnElemS q 2 (pHall_sub sylQ_M)) B Eq2B). + by rewrite sigma'_rank2_max // -(p_rank_Sylow sylQ_M). + have CAq: q %| #|'C(A)|. + apply: dvdn_trans (cardSg (subsetIr Q _)). + by have [_ ? _] := pgroup_pdiv (pgroupS (subsetIl Q _) qQ) nregQ. + have [Qstar maxQstar sQ_Qstar] := max_normed_exists qQ nQA. + have [|Qm] := max_normed_2Elem_signaliser q'p _ maxQstar CAq. + by rewrite inE (subsetP (pnElemS p 2 (subsetT M))). + case=> _ sAQm [_ _ cQstarQm]; rewrite (centSS sAQm sQ_Qstar) // in not_cQA. + apply: cQstarQm; apply/implyP=> _; apply/set0Pn; exists B. + have{Eq2B} Eq2B := subsetP (pnElemS q 2 sQ_Qstar) B Eq2B. + rewrite inE Eq2B (subsetP (pmaxElemS q (subsetT _))) // inE maxB inE. + by have [? _ _] := pnElemP Eq2B. +pose Q0 := 'Z(Q); have charQ0: Q0 \char Q := center_char Q. +have nQ0A: A \subset 'N(Q0) := char_norm_trans charQ0 nQA. +have defQ0: [~: A, Q0] = Q0. + rewrite -{2}[Q0](coprime_abelian_cent_dprod nQ0A) ?center_abelian //. + by rewrite setIAC regQ (setIidPl (sub1G _)) dprodg1 commGC. + by rewrite (coprimeSg (subset_trans (center_sub Q) sQK)). +have [_ _ [A1 EpA1 [A2 EpA2 [neqA12 regA1 regA2]]]] := exceptional_structure. +have defA: A1 \x A2 = A by apply/(p2Elem_dprodP Ep2A EpA1 EpA2). +have{defQ0} defQ0: [~: A1, Q0] * [~: A2, Q0] = Q0. + have{defA} [[_ defA cA12 _] [sA2A _ _]] := (dprodP defA, pnElemP EpA2). + by rewrite -commMG ?defA // normsR ?(cents_norm cA12) // (subset_trans sA2A). +have nsQ0M: Q0 <| M. + have sQ0M: Q0 \subset M := subset_trans (center_sub Q) (pHall_sub sylQ_M). + have qQ0: q.-group Q0 := pgroupS (center_sub Q) qQ. + have p'Q0: p^'.-group Q0 by apply: (pi_pnat qQ0); rewrite eq_sym in q'p. + have sM'Q0: \sigma(M)^'.-group Q0 := pi_pnat qQ0 sM'q. + have cQ0Q0: abelian Q0 := center_abelian Q. + have sA_NQ0: A \subset 'N_M(Q0) by rewrite subsetI sAM. + have sEpA_EpN := subsetP (pnElemS p 1 sA_NQ0). + have nsRQ0 := commG_sigma'_1Elem_cyclic maxM sQ0M sM'Q0 sM'p (sEpA_EpN _ _). + rewrite -defQ0 -!(commGC Q0). + by apply: normalM; [case/nsRQ0: EpA1 | case/nsRQ0: EpA2]. +case/exists_inP: sM'q; exists Q => //. +rewrite (subset_trans (char_norms charQ0)) ?(mmax_normal maxM nsQ0M) //= -/Q0. +by apply: contraNneq ntQ; move/(trivg_center_pgroup qQ)->. +Qed. + +End Section11. diff --git a/mathcomp/odd_order/BGsection12.v b/mathcomp/odd_order/BGsection12.v new file mode 100644 index 0000000..b831ebc --- /dev/null +++ b/mathcomp/odd_order/BGsection12.v @@ -0,0 +1,2688 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice div fintype. +Require Import path bigop finset prime fingroup morphism perm automorphism. +Require Import quotient action gproduct gfunctor pgroup cyclic commutator. +Require Import center gseries nilpotent sylow abelian maximal hall frobenius. +Require Import BGsection1 BGsection3 BGsection4 BGsection5 BGsection6. +Require Import BGsection7 BGsection9 BGsection10 BGsection11. + +(******************************************************************************) +(* This file covers B & G, section 12; it defines the prime sets for the *) +(* complements of M`_\sigma in a maximal group M: *) +(* \tau1(M) == the set of p not in \pi(M^`(1)) (thus not in \sigma(M)), *) +(* such that M has p-rank 1. *) +(* \tau2(M) == the set of p not in \sigma(M), such that M has p-rank 2. *) +(* \tau3(M) == the set of p not in \sigma(M), but in \pi(M^`(1)), such *) +(* that M has p-rank 1. *) +(* We also define the following helper predicate, which encapsulates the *) +(* notation conventions defined at the beginning of B & G, Section 12: *) +(* sigma_complement M E E1 E2 E3 <=> *) +(* E is a Hall \sigma(M)^'-subgroup of M, the Ei are Hall *) +(* \tau_i(M)-subgroups of E, and E2 * E1 is a group. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. +Section Definitions. + +Variables (gT : finGroupType) (M : {set gT}). +Local Notation sigma' := \sigma(M)^'. + +Definition tau1 := [pred p in sigma' | 'r_p(M) == 1%N & ~~ (p %| #|M^`(1)|)]. +Definition tau2 := [pred p in sigma' | 'r_p(M) == 2]. +Definition tau3 := [pred p in sigma' | 'r_p(M) == 1%N & p %| #|M^`(1)|]. + +Definition sigma_complement E E1 E2 E3 := + [/\ sigma'.-Hall(M) E, tau1.-Hall(E) E1, tau2.-Hall(E) E2, tau3.-Hall(E) E3 + & group_set (E2 * E1)]. + +End Definitions. + +Notation "\tau1 ( M )" := (tau1 M) + (at level 2, format "\tau1 ( M )") : group_scope. +Notation "\tau2 ( M )" := (tau2 M) + (at level 2, format "\tau2 ( M )") : group_scope. +Notation "\tau3 ( M )" := (tau3 M) + (at level 2, format "\tau3 ( M )") : group_scope. + +Section Section12. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). +Implicit Types p q r : nat. +Implicit Types A E H K M Mstar N P Q R S T U V W X Y Z : {group gT}. + +Section Introduction. + +Variables M E : {group gT}. +Hypotheses (maxM : M \in 'M) (hallE : \sigma(M)^'.-Hall(M) E). + +Lemma tau1J x : \tau1(M :^ x) =i \tau1(M). +Proof. by move=> p; rewrite 3!inE sigmaJ p_rankJ derg1 -conjsRg cardJg. Qed. + +Lemma tau2J x : \tau2(M :^ x) =i \tau2(M). +Proof. by move=> p; rewrite 3!inE sigmaJ p_rankJ. Qed. + +Lemma tau3J x : \tau3(M :^ x) =i \tau3(M). +Proof. by move=> p; rewrite 3!inE sigmaJ p_rankJ derg1 -conjsRg cardJg. Qed. + +Lemma tau2'1 : {subset \tau1(M) <= \tau2(M)^'}. +Proof. by move=> p; rewrite !inE; case/and3P=> ->; move/eqP->. Qed. + +Lemma tau3'1 : {subset \tau1(M) <= \tau3(M)^'}. +Proof. by move=> p; rewrite !inE; case/and3P=> -> ->. Qed. + +Lemma tau3'2 : {subset \tau2(M) <= \tau3(M)^'}. +Proof. by move=> p; rewrite !inE; case/andP=> ->; move/eqP->. Qed. + +Lemma ex_sigma_compl : exists F : {group gT}, \sigma(M)^'.-Hall(M) F. +Proof. exact: Hall_exists (mmax_sol maxM). Qed. + +Let s'E : \sigma(M)^'.-group E := pHall_pgroup hallE. +Let sEM : E \subset M := pHall_sub hallE. + +(* For added convenience, this lemma does NOT depend on the maxM assumption. *) +Lemma sigma_compl_sol : solvable E. +Proof. +have [-> | [p p_pr pE]] := trivgVpdiv E; first exact: solvable1. +rewrite (solvableS sEM) // mFT_sol // properT. +apply: contraNneq (pgroupP s'E p p_pr pE) => ->. +have [P sylP] := Sylow_exists p [set: gT]. +by apply/exists_inP; exists P; rewrite ?subsetT. +Qed. +Let solE := sigma_compl_sol. + +Let exHallE pi := exists Ei : {group gT}, pi.-Hall(E) Ei. +Lemma ex_tau13_compl : exHallE \tau1(M) /\ exHallE \tau3(M). +Proof. by split; exact: Hall_exists. Qed. + +Lemma ex_tau2_compl E1 E3 : + \tau1(M).-Hall(E) E1 -> \tau3(M).-Hall(E) E3 -> + exists2 E2 : {group gT}, \tau2(M).-Hall(E) E2 & sigma_complement M E E1 E2 E3. +Proof. +move=> hallE1 hallE3; have [sE1E t1E1 _] := and3P hallE1. +pose tau12 := [predU \tau1(M) & \tau2(M)]. +have t12E1: tau12.-group E1 by apply: sub_pgroup t1E1 => p t1p; apply/orP; left. +have [E21 hallE21 sE1E21] := Hall_superset solE sE1E t12E1. +have [sE21E t12E21 _] := and3P hallE21. +have [E2 hallE2] := Hall_exists \tau2(M) (solvableS sE21E solE). +have [sE2E21 t2E2 _] := and3P hallE2. +have hallE2_E: \tau2(M).-Hall(E) E2. + by apply: subHall_Hall hallE21 _ hallE2 => p t2p; apply/orP; right. +exists E2 => //; split=> //. +suffices ->: E2 * E1 = E21 by apply: groupP. +have coE21: coprime #|E2| #|E1| := sub_pnat_coprime tau2'1 t2E2 t1E1. +apply/eqP; rewrite eqEcard mul_subG ?coprime_cardMg //=. +rewrite -(partnC \tau1(M) (cardG_gt0 E21)) (card_Hall hallE2) mulnC. +rewrite (card_Hall (pHall_subl sE1E21 sE21E hallE1)) leq_pmul2r //. +rewrite dvdn_leq // sub_in_partn // => p t12p t1'p. +by apply: contraLR (pnatPpi t12E21 t12p) => t2'p; apply/norP. +Qed. + +Lemma coprime_sigma_compl : coprime #|M`_\sigma| #|E|. +Proof. exact: pnat_coprime (pcore_pgroup _ _) (pHall_pgroup hallE). Qed. +Let coMsE := coprime_sigma_compl. + +Lemma pi_sigma_compl : \pi(E) =i [predD \pi(M) & \sigma(M)]. +Proof. by move=> p; rewrite /= (card_Hall hallE) pi_of_part // !inE andbC. Qed. + +Lemma sdprod_sigma : M`_\sigma ><| E = M. +Proof. +rewrite sdprodE ?coprime_TIg ?(subset_trans sEM) ?gFnorm //. +apply/eqP; rewrite eqEcard mul_subG ?pcore_sub ?coprime_cardMg //=. +by rewrite (card_Hall (Msigma_Hall maxM)) (card_Hall hallE) partnC. +Qed. + +(* The preliminary remarks in the introduction of B & G, section 12. *) + +Remark der1_sigma_compl : M^`(1) :&: E = E^`(1). +Proof. +have [nsMsM _ defM _ _] := sdprod_context sdprod_sigma. +by rewrite setIC (pprod_focal_coprime defM _ (subxx E)) ?(setIidPr _) ?der_sub. +Qed. + +Remark partition_pi_mmax p : + (p \in \pi(M)) = + [|| p \in \tau1(M), p \in \tau2(M), p \in \tau3(M) | p \in \sigma(M)]. +Proof. +symmetry; rewrite 2!orbA -!andb_orr orbAC -andb_orr orNb andbT. +rewrite orb_andl orNb /= -(orb_idl ((alpha_sub_sigma maxM) p)) orbA orbC -orbA. +rewrite !(eq_sym 'r_p(M)) -!leq_eqVlt p_rank_gt0 orb_idl //. +exact: sigma_sub_pi. +Qed. + +Remark partition_pi_sigma_compl p : + (p \in \pi(E)) = [|| p \in \tau1(M), p \in \tau2(M) | p \in \tau3(M)]. +Proof. +rewrite pi_sigma_compl inE /= partition_pi_mmax !andb_orr /=. +by rewrite andNb orbF !(andbb, andbA) -2!andbA. +Qed. + +Remark tau2E p : (p \in \tau2(M)) = (p \in \pi(E)) && ('r_p(E) == 2). +Proof. +have [P sylP] := Sylow_exists p E. +rewrite -(andb_idl (pnatPpi s'E)) -p_rank_gt0 -andbA; apply: andb_id2l => s'p. +have sylP_M := subHall_Sylow hallE s'p sylP. +by rewrite -(p_rank_Sylow sylP_M) (p_rank_Sylow sylP); case: posnP => // ->. +Qed. + +Remark tau3E p : (p \in \tau3(M)) = (p \in \pi(E^`(1))) && ('r_p(E) == 1%N). +Proof. +have [P sylP] := Sylow_exists p E. +have hallE': \sigma(M)^'.-Hall(M^`(1)) E^`(1). + by rewrite -der1_sigma_compl setIC (Hall_setI_normal _ hallE) ?der_normal. +rewrite 4!inE -(andb_idl (pnatPpi (pHall_pgroup hallE'))) -andbA. +apply: andb_id2l => s'p; have sylP_M := subHall_Sylow hallE s'p sylP. +rewrite -(p_rank_Sylow sylP_M) (p_rank_Sylow sylP) andbC; apply: andb_id2r. +rewrite eqn_leq p_rank_gt0 mem_primes => /and3P[_ p_pr _]. +rewrite (card_Hall hallE') pi_of_part 3?inE ?mem_primes ?cardG_gt0 //=. +by rewrite p_pr inE /= s'p andbT. +Qed. + +Remark tau1E p : + (p \in \tau1(M)) = [&& p \in \pi(E), p \notin \pi(E^`(1)) & 'r_p(E) == 1%N]. +Proof. +rewrite partition_pi_sigma_compl; apply/idP/idP=> [t1p|]. + have [s'p rpM _] := and3P t1p; have [P sylP] := Sylow_exists p E. + have:= tau3'1 t1p; rewrite t1p /= inE /= tau3E -(p_rank_Sylow sylP). + by rewrite (p_rank_Sylow (subHall_Sylow hallE s'p sylP)) rpM !andbT. +rewrite orbC andbC -andbA => /and3P[not_piE'p /eqP rpE]. +by rewrite tau3E tau2E rpE (negPf not_piE'p) andbF. +Qed. + +(* Generate a rank 2 elementary abelian tau2 subgroup in a given complement. *) +Lemma ex_tau2Elem p : + p \in \tau2(M) -> exists2 A, A \in 'E_p^2(E) & A \in 'E_p^2(M). +Proof. +move=> t2p; have [A Ep2A] := p_rank_witness p E. +have <-: 'r_p(E) = 2 by apply/eqP; move: t2p; rewrite tau2E; case/andP. +by exists A; rewrite // (subsetP (pnElemS p _ sEM)). +Qed. + +(* A converse to the above Lemma: if E has an elementary abelian subgroup of *) +(* order p^2, then p must be in tau2. *) +Lemma sigma'2Elem_tau2 p A : A \in 'E_p^2(E) -> p \in \tau2(M). +Proof. +move=> Ep2A; have rE: 'r_p(E) > 1 by apply/p_rank_geP; exists A. +have: p \in \pi(E) by rewrite -p_rank_gt0 ltnW. +rewrite partition_pi_sigma_compl orbCA => /orP[] //. +by rewrite -!andb_orr eqn_leq leqNgt (leq_trans rE) ?andbF ?p_rankS. +Qed. + +(* This is B & G, Lemma 12.1(a). *) +Lemma der1_sigma_compl_nil : nilpotent E^`(1). +Proof. +have sE'E := der_sub 1 E. +have nMaE: E \subset 'N(M`_\alpha) by rewrite (subset_trans sEM) ?gFnorm. +have tiMaE': M`_\alpha :&: E^`(1) = 1. + by apply/trivgP; rewrite -(coprime_TIg coMsE) setISS ?Malpha_sub_Msigma. +rewrite (isog_nil (quotient_isog (subset_trans sE'E nMaE) tiMaE')). +by rewrite (nilpotentS (quotientS _ (dergS 1 sEM))) ?Malpha_quo_nil. +Qed. + +(* This is B & G, Lemma 12.1(g). *) +Lemma tau2_not_beta p : + p \in \tau2(M) -> p \notin \beta(G) /\ {subset 'E_p^2(M) <= 'E*_p(G)}. +Proof. +case/andP=> s'p /eqP rpM; split; first exact: sigma'_rank2_beta' rpM. +by apply/subsetP; exact: sigma'_rank2_max. +Qed. + +End Introduction. + +Implicit Arguments tau2'1 [[M] x]. +Implicit Arguments tau3'1 [[M] x]. +Implicit Arguments tau3'2 [[M] x]. + +(* This is the rest of B & G, Lemma 12.1 (parts b, c, d,e, and f). *) +Lemma sigma_compl_context M E E1 E2 E3 : + M \in 'M -> sigma_complement M E E1 E2 E3 -> + [/\ (*b*) E3 \subset E^`(1) /\ E3 <| E, + (*c*) E2 :==: 1 -> E1 :!=: 1, + (*d*) cyclic E1 /\ cyclic E3, + (*e*) E3 ><| (E2 ><| E1) = E /\ E3 ><| E2 ><| E1 = E + & (*f*) 'C_E3(E) = 1]. +Proof. +move=> maxM [hallE hallE1 hallE2 hallE3 groupE21]. +have [sEM solM] := (pHall_sub hallE, mmax_sol maxM). +have [[sE1E t1E1 _] [sE3E t3E3 _]] := (and3P hallE1, and3P hallE3). +have tiE'E1: E^`(1) :&: E1 = 1. + rewrite coprime_TIg // coprime_pi' ?cardG_gt0 //. + by apply: sub_pgroup t1E1 => p; rewrite (tau1E maxM hallE) => /and3P[]. +have cycE1: cyclic E1. + apply: nil_Zgroup_cyclic. + rewrite odd_rank1_Zgroup ?mFT_odd //; apply: wlog_neg; rewrite -ltnNge. + have [p p_pr ->]:= rank_witness E1; move/ltnW; rewrite p_rank_gt0. + move/(pnatPpi t1E1); rewrite (tau1E maxM hallE) => /and3P[_ _ /eqP <-]. + by rewrite p_rankS. + rewrite abelian_nil // /abelian (sameP commG1P trivgP) -tiE'E1. + by rewrite subsetI (der_sub 1) (dergS 1). +have solE: solvable E := solvableS sEM solM. +have nilE': nilpotent E^`(1) := der1_sigma_compl_nil maxM hallE. +have nsE'piE pi: 'O_pi(E^`(1)) <| E. + exact: char_normal_trans (pcore_char _ _) (der_normal _ _). +have SylowE3 P: Sylow E3 P -> [/\ cyclic P, P \subset E^`(1) & 'C_P(E) = 1]. +- case/SylowP=> p p_pr sylP; have [sPE3 pP _] := and3P sylP. + have [-> | ntP] := eqsVneq P 1. + by rewrite cyclic1 sub1G (setIidPl (sub1G _)). + have t3p: p \in \tau3(M). + rewrite (pnatPpi t3E3) // -p_rank_gt0 -(p_rank_Sylow sylP) -rank_pgroup //. + by rewrite rank_gt0. + have sPE: P \subset E := subset_trans sPE3 sE3E. + have cycP: cyclic P. + rewrite (odd_pgroup_rank1_cyclic pP) ?mFT_odd //. + rewrite (tau3E maxM hallE) in t3p. + by case/andP: t3p => _ /eqP <-; rewrite p_rankS. + have nEp'E: E \subset 'N('O_p^'(E)) by exact: gFnorm. + have nEp'P := subset_trans sPE nEp'E. + have sylP_E := subHall_Sylow hallE3 t3p sylP. + have nsEp'P_E: 'O_p^'(E) <*> P <| E. + rewrite sub_der1_normal ?join_subG ?pcore_sub //=. + rewrite norm_joinEr // -quotientSK //=; last first. + by rewrite (subset_trans (der_sub 1 E)). + have [_ /= <- _ _] := dprodP (nilpotent_pcoreC p nilE'). + rewrite -quotientMidr -mulgA (mulSGid (pcore_max _ _)) ?pcore_pgroup //=. + rewrite quotientMidr quotientS //. + apply: subset_trans (pcore_sub_Hall sylP_E). + by rewrite pcore_max ?pcore_pgroup /=. + have nEP_sol: solvable 'N_E(P) by rewrite (solvableS _ solE) ?subsetIl. + have [K hallK] := Hall_exists p^' nEP_sol; have [sKNEP p'K _] := and3P hallK. + have coPK: coprime #|P| #|K| := pnat_coprime pP p'K. + have sP_NEP: P \subset 'N_E(P) by rewrite subsetI sPE normG. + have mulPK: P * K = 'N_E(P). + apply/eqP; rewrite eqEcard mul_subG //= coprime_cardMg // (card_Hall hallK). + by rewrite (card_Hall (pHall_subl sP_NEP (subsetIl E _) sylP_E)) partnC. + rewrite subsetI in sKNEP; case/andP: sKNEP => sKE nPK. + have nEp'K := subset_trans sKE nEp'E. + have defE: 'O_p^'(E) <*> K * P = E. + have sP_Ep'P: P \subset 'O_p^'(E) <*> P := joing_subr _ _. + have sylP_Ep'P := pHall_subl sP_Ep'P (normal_sub nsEp'P_E) sylP_E. + rewrite -{2}(Frattini_arg nsEp'P_E sylP_Ep'P) /= !norm_joinEr //. + by rewrite -mulgA (normC nPK) -mulPK -{1}(mulGid P) !mulgA. + have ntPE': P :&: E^`(1) != 1. + have sylPE' := Hall_setI_normal (der_normal 1 E) sylP_E. + rewrite -rank_gt0 (rank_Sylow sylPE') p_rank_gt0. + by rewrite (tau3E maxM hallE) in t3p; case/andP: t3p. + have defP := coprime_abelian_cent_dprod nPK coPK (cyclic_abelian cycP). + have{defP} [[PK1 _]|[regKP defP]] := cyclic_pgroup_dprod_trivg pP cycP defP. + have coP_Ep'K: coprime #|P| #|'O_p^'(E) <*> K|. + rewrite (pnat_coprime pP) // -pgroupE norm_joinEr //. + by rewrite pgroupM pcore_pgroup. + rewrite -subG1 -(coprime_TIg coP_Ep'K) setIS ?der1_min // in ntPE'. + rewrite -{1}defE mulG_subG normG normsY // cents_norm //. + exact/commG1P. + by rewrite -{2}defE quotientMidl quotient_abelian ?cyclic_abelian. + split=> //; first by rewrite -defP commgSS. + by apply/trivgP; rewrite -regKP setIS ?centS. +have sE3E': E3 \subset E^`(1). + by rewrite -(Sylow_gen E3) gen_subG; apply/bigcupsP=> P; case/SylowE3. +have cycE3: cyclic E3. + rewrite nil_Zgroup_cyclic ?(nilpotentS sE3E') //. + by apply/forall_inP => P; case/SylowE3. +have regEE3: 'C_E3(E) = 1. + have [// | [p p_pr]] := trivgVpdiv 'C_E3(E). + case/Cauchy=> // x /setIP[]; rewrite -!cycle_subG => sXE3 cEX ox. + have pX: p.-elt x by rewrite /p_elt ox pnat_id. + have [P sylP sXP] := Sylow_superset sXE3 pX. + suffices: <[x]> == 1 by case/idPn; rewrite cycle_eq1 -order_gt1 ox prime_gt1. + rewrite -subG1; case/SylowE3: (p_Sylow sylP) => _ _ <-. + by rewrite subsetI sXP. +have nsE3E: E3 <| E. + have hallE3_E' := pHall_subl sE3E' (der_sub 1 E) hallE3. + by rewrite (nilpotent_Hall_pcore nilE' hallE3_E') /=. +have [sE2E t2E2 _] := and3P hallE2; have [_ nE3E] := andP nsE3E. +have coE21: coprime #|E2| #|E1| := sub_pnat_coprime tau2'1 t2E2 t1E1. +have coE31: coprime #|E3| #|E1| := sub_pnat_coprime tau3'1 t3E3 t1E1. +have coE32: coprime #|E3| #|E2| := sub_pnat_coprime tau3'2 t3E3 t2E2. +have{groupE21} defE: E3 ><| (E2 ><| E1) = E. + have defE21: E2 * E1 = E2 <*> E1 by rewrite -genM_join gen_set_id. + have sE21E: E2 <*> E1 \subset E by rewrite join_subG sE2E. + have nE3E21 := subset_trans sE21E nE3E. + have coE312: coprime #|E3| #|E2 <*> E1|. + by rewrite -defE21 coprime_cardMg // coprime_mulr coE32. + have nE21: E1 \subset 'N(E2). + rewrite (subset_trans (joing_subr E2 E1)) ?sub_der1_norm ?joing_subl //. + rewrite /= -{2}(mulg1 E2) -(setIidPr (der_sub 1 _)) /=. + rewrite -(coprime_mulG_setI_norm defE21) ?gFnorm //. + by rewrite mulgSS ?subsetIl // -tiE'E1 setIC setSI ?dergS. + rewrite (sdprodEY nE21) ?sdprodE ?coprime_TIg //=. + apply/eqP; rewrite eqEcard mul_subG // coprime_cardMg //= -defE21. + rewrite -(partnC \tau3(M) (cardG_gt0 E)) (card_Hall hallE3) leq_mul //. + rewrite coprime_cardMg // (card_Hall hallE1) (card_Hall hallE2). + rewrite -[#|E|`__](partnC \tau2(M)) ?leq_mul ?(partn_part _ tau3'2) //. + rewrite -partnI dvdn_leq // sub_in_partn // => p piEp; apply/implyP. + rewrite inE /= -negb_or /= orbC implyNb orbC. + by rewrite -(partition_pi_sigma_compl maxM hallE). +split=> // [/eqP E2_1|]; last split=> //. + apply: contraTneq (sol_der1_proper solM (subxx _) (mmax_neq1 maxM)) => E1_1. + case/sdprodP: (sdprod_sigma maxM hallE) => _ defM _ _. + rewrite properE der_sub /= negbK -{1}defM mulG_subG Msigma_der1 //. + by rewrite -defE E1_1 E2_1 !sdprodg1 (subset_trans sE3E') ?dergS //. +case/sdprodP: defE => [[_ E21 _ defE21]]; rewrite defE21 => defE nE321 tiE321. +have{defE21} [_ defE21 nE21 tiE21] := sdprodP defE21. +have [nE32 nE31] := (subset_trans sE2E nE3E, subset_trans sE1E nE3E). +rewrite [E3 ><| _]sdprodEY ? sdprodE ?coprime_TIg ?normsY //=. + by rewrite norm_joinEr // -mulgA defE21. +by rewrite norm_joinEr // coprime_cardMg // coprime_mull coE31. +Qed. + +(* This is B & G, Lemma 12.2(a). *) +Lemma prime_class_mmax_norm M p X : + M \in 'M -> p.-group X -> 'N(X) \subset M -> + (p \in \sigma(M)) || (p \in \tau2(M)). +Proof. +move=> maxM pX sNM; rewrite -implyNb; apply/implyP=> sM'p. +by rewrite 3!inE /= sM'p (sigma'_norm_mmax_rank2 _ _ pX). +Qed. + +(* This is B & G, Lemma 12.2(b). *) +Lemma mmax_norm_notJ M Mstar p X : + M \in 'M -> Mstar \in 'M -> + p.-group X -> X \subset M -> 'N(X) \subset Mstar -> + [|| [&& p \in \sigma(M) & M :!=: Mstar], p \in \tau1(M) | p \in \tau3(M)] -> + gval Mstar \notin M :^: G. +Proof. +move: Mstar => H maxM maxH pX sXM sNH; apply: contraL => MG_H. +have [x Gx defH] := imsetP MG_H. +have [sMp | sM'p] := boolP (p \in \sigma(M)); last first. + have:= prime_class_mmax_norm maxH pX sNH. + rewrite defH /= sigmaJ tau2J !negb_or (negPf sM'p) /= => t2Mp. + by rewrite (contraL (@tau2'1 _ p)) // [~~ _]tau3'2. +rewrite 3!inE sMp 3!inE sMp orbF negbK. +have [_ transCX _] := sigma_group_trans maxM sMp pX. +set maxMX := finset _ in transCX. +have maxMX_H: gval H \in maxMX by rewrite inE MG_H (subset_trans (normG X)). +have maxMX_M: gval M \in maxMX by rewrite inE orbit_refl. +have [y cXy ->] := atransP2 transCX maxMX_H maxMX_M. +by rewrite /= conjGid // (subsetP sNH) // (subsetP (cent_sub X)). +Qed. + +(* This is B & G, Lemma 12.3. *) +Lemma nonuniq_p2Elem_cent_sigma M Mstar p A A0 : + M \in 'M -> Mstar \in 'M -> Mstar :!=: M -> A \in 'E_p^2(M) -> + A0 \in 'E_p^1(A) -> 'N(A0) \subset Mstar -> + [/\ (*a*) p \notin \sigma(M) -> A \subset 'C(M`_\sigma :&: Mstar) + & (*b*) p \notin \alpha(M) -> A \subset 'C(M`_\alpha :&: Mstar)]. +Proof. +move: Mstar => H maxM maxH neqMH Ep2A EpA0 sNH. +have p_pr := pnElem_prime Ep2A. +have [sAM abelA dimA] := pnElemP Ep2A; have [pA cAA _] := and3P abelA. +have [sA0A _ _] := pnElemP EpA0; have pA0 := pgroupS sA0A pA. +have sAH: A \subset H. + by apply: subset_trans (cents_norm _) sNH; exact: subset_trans (centS sA0A). +have nsHsH: H`_\sigma <| H by exact: pcore_normal. +have [sHsH nHsH] := andP nsHsH; have nHsA := subset_trans sAH nHsH. +have nsHsA_H: H`_\sigma <*> A <| H. + have [sHp | sH'p] := boolP (p \in \sigma(H)). + rewrite (joing_idPl _) ?pcore_normal //. + by rewrite (sub_Hall_pcore (Msigma_Hall _)) // (pi_pgroup pA). + have [P sylP sAP] := Sylow_superset sAH pA. + have excH: exceptional_FTmaximal p H A0 A by split=> //; apply/pnElemP. + exact: exceptional_mul_sigma_normal excH sylP sAP. +have cAp' K: + p^'.-group K -> A \subset 'N(K) -> K \subset H -> + [~: K, A] \subset K :&: H`_\sigma. +- move=> p'K nKA sKH; have nHsK := subset_trans sKH nHsH. + rewrite subsetI commg_subl nKA /= -quotient_sub1 ?comm_subG // quotientR //=. + have <-: K / H`_\sigma :&: A / H`_\sigma = 1. + by rewrite setIC coprime_TIg ?coprime_morph ?(pnat_coprime pA p'K). + rewrite subsetI commg_subl commg_subr /= -{2}(quotientYidr nHsA). + by rewrite !quotient_norms //= joingC (subset_trans sKH) ?normal_norm. +have [sMp | sM'p] := boolP (p \in \sigma(M)). + split=> // aM'p; have notMGH: gval H \notin M :^: G. + apply: mmax_norm_notJ maxM maxH pA0 (subset_trans sA0A sAM) sNH _. + by rewrite sMp eq_sym neqMH. + rewrite centsC (sameP commG1P trivgP). + apply: subset_trans (cAp' _ _ _ (subsetIr _ _)) _. + - exact: pi_p'group (pgroupS (subsetIl _ _) (pcore_pgroup _ _)) aM'p. + - by rewrite (normsI _ (normsG sAH)) // (subset_trans sAM) ?gFnorm. + by rewrite setIAC; case/sigma_disjoint: notMGH => // -> _ _; exact: subsetIl. +suffices cMaA: A \subset 'C(M`_\sigma :&: H). + by rewrite !{1}(subset_trans cMaA) ?centS ?setSI // Malpha_sub_Msigma. +have [sHp | sH'p] := boolP (p \in \sigma(H)); last first. + apply/commG1P; apply: contraNeq neqMH => ntA_MsH. + have [P sylP sAP] := Sylow_superset sAH pA. + have excH: exceptional_FTmaximal p H A0 A by split=> //; exact/pnElemP. + have maxAM: M \in 'M(A) by exact/setIdP. + rewrite (exceptional_sigma_uniq maxH excH sylP sAP maxAM) //. + apply: contraNneq ntA_MsH => tiMsHs; rewrite -subG1. + have [sHsA_H nHsA_H] := andP nsHsA_H. + have <-: H`_\sigma <*> A :&: M`_\sigma = 1. + apply/trivgP; rewrite -tiMsHs subsetI subsetIr /=. + rewrite -quotient_sub1 ?subIset ?(subset_trans sHsA_H) //. + rewrite quotientGI ?joing_subl //= joingC quotientYidr //. + rewrite setIC coprime_TIg ?coprime_morph //. + rewrite (pnat_coprime (pcore_pgroup _ _)) // (card_pnElem Ep2A). + by rewrite pnat_exp ?orbF ?pnatE. + rewrite commg_subI // subsetI ?joing_subr ?subsetIl. + by rewrite (subset_trans sAM) ?gFnorm. + by rewrite setIC subIset ?nHsA_H. +have sAHs: A \subset H`_\sigma. + by rewrite (sub_Hall_pcore (Msigma_Hall maxH)) // (pi_pgroup pA). +have [S sylS sAS] := Sylow_superset sAHs pA; have [sSHs pS _] := and3P sylS. +have nsHaH: H`_\alpha <| H := pcore_normal _ _; have [_ nHaH] := andP nsHaH. +have nHaS := subset_trans (subset_trans sSHs sHsH) nHaH. +have nsHaS_H: H`_\alpha <*> S <| H. + rewrite -{2}(quotientGK nsHaH) (norm_joinEr nHaS) -quotientK //. + rewrite cosetpre_normal; apply: char_normal_trans (quotient_normal _ nsHsH). + rewrite /= (nilpotent_Hall_pcore _ (quotient_pHall _ sylS)) ?pcore_char //. + exact: nilpotentS (quotientS _ (Msigma_der1 maxH)) (Malpha_quo_nil maxH). +rewrite (sameP commG1P trivgP). +have <-: H`_\alpha <*> S :&: M`_\sigma = 1. + have: gval M \notin H :^: G. + by apply: contra sM'p; case/imsetP=> x _ ->; rewrite sigmaJ. + case/sigma_disjoint=> // _ ti_aHsM _. + rewrite setIC coprime_TIg ?(pnat_coprime (pcore_pgroup _ _)) //=. + rewrite norm_joinEr // [pnat _ _]pgroupM (pi_pgroup pS) // andbT. + apply: sub_pgroup (pcore_pgroup _ _) => q aHq. + by apply: contraFN (ti_aHsM q) => sMq; rewrite inE /= aHq. +rewrite commg_subI // subsetI ?subsetIl. + by rewrite (subset_trans sAS) ?joing_subr ?(subset_trans sAM) ?gFnorm. +by rewrite setIC subIset 1?normal_norm. +Qed. + +(* This is B & G, Proposition 12.4. *) +Proposition p2Elem_mmax M p A : + M \in 'M -> A \in 'E_p^2(M) -> + (*a*) 'C(A) \subset M + /\ (*b*) ([forall A0 in 'E_p^1(A), 'M('N(A0)) != [set M]] -> + [/\ p \in \sigma(M), M`_\alpha = 1 & nilpotent M`_\sigma]). +Proof. +move=> maxM Ep2A; have p_pr := pnElem_prime Ep2A. +have [sAM abelA dimA] := pnElemP Ep2A; have [pA cAA _] := and3P abelA. +have [EpAnonuniq |] := altP forall_inP; last first. + rewrite negb_forall_in; case/exists_inP=> A0 EpA0; rewrite negbK. + case/eqP/mem_uniq_mmax=> _ sNA0_M; rewrite (subset_trans _ sNA0_M) //. + by have [sA0A _ _] := pnElemP EpA0; rewrite cents_norm // centS. +have{EpAnonuniq} sCMkApCA y: y \in A^# -> + [/\ 'r('C_M(<[y]>)) <= 2, + p \in \sigma(M)^' -> 'C_(M`_\sigma)[y] \subset 'C_M(A) + & p \in \alpha(M)^' -> 'C_(M`_\alpha)[y] \subset 'C_M(A)]. +- case/setD1P=> nty Ay; pose Y := <[y]>%G. + rewrite -cent_cycle -[<[y]>]/(gval Y). + have EpY: Y \in 'E_p^1(A). + by rewrite p1ElemE // 2!inE cycle_subG Ay -orderE (abelem_order_p abelA) /=. + have [sYA abelY dimY] := pnElemP EpY; have [pY _] := andP abelY. + have [H maxNYH neqHM]: exists2 H, H \in 'M('N(Y)) & H \notin [set M]. + apply/subsetPn; rewrite subset1 negb_or EpAnonuniq //=. + apply/set0Pn; have [|H] := (@mmax_exists _ 'N(Y)); last by exists H. + rewrite mFT_norm_proper ?(mFT_pgroup_proper pY) //. + by rewrite -rank_gt0 (rank_abelem abelY) dimY. + have{maxNYH} [maxH sNYH] := setIdP maxNYH; rewrite inE -val_eqE /= in neqHM. + have ->: 'r('C_M(Y)) <= 2. + apply: contraR neqHM; rewrite -ltnNge => rCMYgt2. + have uniqCMY: 'C_M(Y)%G \in 'U. + by rewrite rank3_Uniqueness ?(sub_mmax_proper maxM) ?subsetIl. + have defU: 'M('C_M(Y)) = [set M] by apply: def_uniq_mmax; rewrite ?subsetIl. + rewrite (eq_uniq_mmax defU maxH) ?subIset //. + by rewrite orbC (subset_trans (cent_sub Y)). + have [cAMs cAMa] := nonuniq_p2Elem_cent_sigma maxM maxH neqHM Ep2A EpY sNYH. + rewrite !{1}subsetI !{1}(subset_trans (subsetIl _ _) (pcore_sub _ _)). + by split=> // [/cAMs | /cAMa]; rewrite centsC; apply: subset_trans; + rewrite setIS ?(subset_trans (cent_sub Y)). +have ntA: A :!=: 1 by rewrite -rank_gt0 (rank_abelem abelA) dimA. +have ncycA: ~~ cyclic A by rewrite (abelem_cyclic abelA) dimA. +have rCMAle2: 'r('C_M(A)) <= 2. + have [y Ay]: exists y, y \in A^# by apply/set0Pn; rewrite setD_eq0 subG1. + have [rCMy _ _] := sCMkApCA y Ay; apply: leq_trans rCMy. + by rewrite rankS // setIS // centS // cycle_subG; case/setIdP: Ay. +have sMp: p \in \sigma(M). + apply: contraFT (ltnn 1) => sM'p; rewrite -dimA -(rank_abelem abelA). + suffices cMsA: A \subset 'C(M`_\sigma). + by rewrite -(setIidPl cMsA) sub'cent_sigma_rank1 // (pi_pgroup pA). + have nMsA: A \subset 'N(M`_\sigma) by rewrite (subset_trans sAM) ?gFnorm. + rewrite centsC /= -(coprime_abelian_gen_cent1 _ _ nMsA) //; last first. + exact: pnat_coprime (pcore_pgroup _ _) (pi_pnat pA _). + rewrite gen_subG; apply/bigcupsP=> y; case/sCMkApCA=> _ sCMsyCA _. + by rewrite (subset_trans (sCMsyCA sM'p)) ?subsetIr. +have [P sylP sAP] := Sylow_superset sAM pA; have [sPM pP _] := and3P sylP. +pose Z := 'Ohm_1('Z(P)). +have sZA: Z \subset A. + have maxA: A \in 'E*_p('C_M(A)). + have sACMA: A \subset 'C_M(A) by rewrite subsetI sAM. + rewrite (subsetP (p_rankElem_max _ _)) // !inE abelA sACMA. + rewrite eqn_leq logn_le_p_rank /=; last by rewrite !inE sACMA abelA. + by rewrite dimA (leq_trans (p_rank_le_rank _ _)). + rewrite [Z](OhmE 1 (pgroupS (center_sub P) pP)) gen_subG. + rewrite -(pmaxElem_LdivP p_pr maxA) -(setIA M) setIid setSI //=. + by rewrite setISS // centS. +have{ntA} ntZ: Z != 1. + by rewrite Ohm1_eq1 (center_nil_eq1 (pgroup_nil pP)) (subG1_contra sAP). +have rPle2: 'r(P) <= 2. + have [z Zz ntz]: exists2 z, z \in Z & z \notin [1]. + by apply/subsetPn; rewrite subG1. + have [|rCMz _ _] := sCMkApCA z; first by rewrite inE ntz (subsetP sZA). + rewrite (leq_trans _ rCMz) ?rankS // subsetI sPM centsC cycle_subG. + by rewrite (subsetP _ z Zz) // (subset_trans (Ohm_sub 1 _)) ?subsetIr. +have aM'p: p \in \alpha(M)^'. + by rewrite !inE -leqNgt -(p_rank_Sylow sylP) -rank_pgroup. +have sMaCMA: M`_\alpha \subset 'C_M(A). +have nMaA: A \subset 'N(M`_\alpha) by rewrite (subset_trans sAM) ?gFnorm. + rewrite -(coprime_abelian_gen_cent1 _ _ nMaA) //; last first. + exact: (pnat_coprime (pcore_pgroup _ _) (pi_pnat pA _)). + rewrite gen_subG; apply/bigcupsP=> y; case/sCMkApCA=> _ _ sCMayCA. + by rewrite (subset_trans (sCMayCA aM'p)) ?subsetIr. +have Ma1: M`_\alpha = 1. + have [q q_pr rMa]:= rank_witness M`_\alpha. + apply: contraTeq rCMAle2; rewrite -ltnNge -rank_gt0 rMa p_rank_gt0 => piMa_q. + have aMq: q \in \alpha(M) := pnatPpi (pcore_pgroup _ _) piMa_q. + apply: leq_trans (rankS sMaCMA); rewrite rMa. + have [Q sylQ] := Sylow_exists q M`_\alpha; rewrite -(p_rank_Sylow sylQ). + by rewrite (p_rank_Sylow (subHall_Sylow (Malpha_Hall maxM) aMq sylQ)). +have nilMs: nilpotent M`_\sigma. + rewrite (nilpotentS (Msigma_der1 maxM)) // (isog_nil (quotient1_isog _)). + by rewrite -Ma1 Malpha_quo_nil. +rewrite (subset_trans (cents_norm (centS sZA))) ?(mmax_normal maxM) //. +apply: char_normal_trans (char_trans (Ohm_char 1 _) (center_char P)) _. +have{sylP} sylP: p.-Sylow(M`_\sigma) P. + apply: pHall_subl _ (pcore_sub _ _) sylP. + by rewrite (sub_Hall_pcore (Msigma_Hall maxM)) // (pi_pgroup pP). +by rewrite (nilpotent_Hall_pcore _ sylP) ?(char_normal_trans (pcore_char _ _)). +Qed. + +(* This is B & G, Theorem 12.5(a) -- this part does not mention a specific *) +(* rank 2 elementary abelian \tau_2(M) subgroup of M. *) + +Theorem tau2_Msigma_nil M p : M \in 'M -> p \in \tau2(M) -> nilpotent M`_\sigma. +Proof. +move=> maxM t2Mp; have [sM'p /eqP rpM] := andP t2Mp. +have [A Ep2A] := p_rank_witness p M; rewrite rpM in Ep2A. +have [_]:= p2Elem_mmax maxM Ep2A; rewrite -negb_exists_in [p \in _](negPf sM'p). +have [[A0 EpA0 /eqP/mem_uniq_mmax[_ sNA0M _]] | _ [] //] := exists_inP. +have{EpA0 sNA0M} excM: exceptional_FTmaximal p M A0 A by []. +have [sAM abelA _] := pnElemP Ep2A; have [pA _] := andP abelA. +have [P sylP sAP] := Sylow_superset sAM pA. +exact: exceptional_sigma_nil maxM excM sylP sAP. +Qed. + +(* This is B & G, Theorem 12.5 (b-f) -- the bulk of the Theorem. *) +Theorem tau2_context M p A (Ms := M`_\sigma) : + M \in 'M -> p \in \tau2(M) -> A \in 'E_p^2(M) -> + [/\ (*b*) forall P, p.-Sylow(M) P -> + abelian P + /\ (A \subset P -> 'Ohm_1(P) = A /\ ~~ ('N(P) \subset M)), + (*c*) Ms <*> A <| M, + (*d*) 'C_Ms(A) = 1, + (*e*) forall Mstar, Mstar \in 'M(A) :\ M -> Ms :&: Mstar = 1 + & (*f*) exists2 A1, A1 \in 'E_p^1(A) & 'C_Ms(A1) = 1]. +Proof. +move=> maxM t2Mp Ep2A; have [sM'p _] := andP t2Mp. +have [_]:= p2Elem_mmax maxM Ep2A; rewrite -negb_exists_in [p \in _](negPf sM'p). +have [[A0 EpA0 /eqP/mem_uniq_mmax[_ sNA0M _]] | _ [] //] := exists_inP. +have{EpA0 sNA0M} excM: exceptional_FTmaximal p M A0 A by []. +have strM := exceptional_structure maxM excM. +have [sAM abelA dimA] := pnElemP Ep2A; have [pA cAA _] := and3P abelA. +have [P sylP sAP] := Sylow_superset sAM pA. +have nsMsA_M : Ms <*> A <| M := exceptional_mul_sigma_normal maxM excM sylP sAP. +have [_ regA [A1 EpA1 [_ _ [_ regA1 _]]]] := strM P sylP sAP. +split=> // [P1 sylP1 | {P sylP sAP A0 excM}H| ]; last by exists A1. + split=> [|sAP1]; first exact: (exceptional_Sylow_abelian _ excM sylP). + split; first by case/strM: sylP1. + by apply: contra sM'p => sNP1M; apply/exists_inP; exists P1; rewrite // ?inE. +case/setD1P; rewrite -val_eqE /= => neqHM /setIdP[maxH sAH]. +apply/trivgP; rewrite -regA subsetI subsetIl /=. +have Ep2A_H: A \in 'E_p^2(H) by apply/pnElemP. +have [_]:= p2Elem_mmax maxH Ep2A_H; rewrite -negb_exists_in. +have [[A0 EpA0 /eqP/mem_uniq_mmax[_ sNA0H _]]|_ [//|sHp _ nilHs]] := exists_inP. + have [cMSH_A _]:= nonuniq_p2Elem_cent_sigma maxM maxH neqHM Ep2A EpA0 sNA0H. + by rewrite centsC cMSH_A. +have [P sylP sAP] := Sylow_superset sAH pA; have [sPH pP _] := and3P sylP. +have sylP_Hs: p.-Sylow(H`_\sigma) P. + rewrite (pHall_subl _ (pcore_sub _ _) sylP) //. + by rewrite (sub_Hall_pcore (Msigma_Hall maxH)) // (pi_pgroup pP). +have nPH: H \subset 'N(P). + rewrite (nilpotent_Hall_pcore nilHs sylP_Hs). + by rewrite !(char_norm_trans (pcore_char _ _)) ?normG. +have coMsP: coprime #|M`_\sigma| #|P|. + exact: pnat_coprime (pcore_pgroup _ _) (pi_pnat pP _). +rewrite (sameP commG1P trivgP) -(coprime_TIg coMsP) commg_subI ?setIS //. +by rewrite subsetI sAP (subset_trans sAM) ?gFnorm. +Qed. + +(* This is B & G, Corollary 12.6 (a, b, c & f) -- i.e., the assertions that *) +(* do not depend on the decomposition of the complement. *) +Corollary tau2_compl_context M E p A (Ms := M`_\sigma) : + M \in 'M -> \sigma(M)^'.-Hall(M) E -> p \in \tau2(M) -> A \in 'E_p^2(E) -> + [/\ (*a*) A <| E /\ 'E_p^1(E) = 'E_p^1(A), + (*b*) [/\ 'C(A) \subset E, 'N_M(A) = E & ~~ ('N(A) \subset M)], + (*c*) forall X, X \in 'E_p^1(E) -> 'C_Ms(X) != 1 -> 'M('C(X)) = [set M] + & (*f*) forall Mstar, + Mstar \in 'M -> gval Mstar \notin M :^: G -> + Ms :&: Mstar`_\sigma = 1 + /\ [predI \sigma(M) & \sigma(Mstar)] =i pred0]. +Proof. +move=> maxM hallE t2Mp Ep2A; have [sEM sM'E _] := and3P hallE. +have [p_pr [sM'p _]] := (pnElem_prime Ep2A, andP t2Mp). +have [sAE abelA dimA] := pnElemP Ep2A; have [pA cAA _] := and3P abelA. +have [_ mulMsE nMsE tiMsE] := sdprodP (sdprod_sigma maxM hallE). +have Ep2A_M: A \in 'E_p^2(M) by rewrite (subsetP (pnElemS _ _ sEM)). +have [syl_p_M nsMsAM regA tiMsMA _] := tau2_context maxM t2Mp Ep2A_M. +have nMsA: A \subset 'N(Ms) := subset_trans sAE nMsE. +have nsAE: A <| E. + rewrite /normal sAE -(mul1g A) -tiMsE setIC group_modr // normsI ?normG //. + by rewrite (subset_trans sEM) // -(norm_joinEr nMsA) normal_norm. +have sAsylE P: p.-Sylow(E) P -> 'Ohm_1(P) = A /\ ~~ ('N(P) \subset M). + move=> sylP; have sylP_M: p.-Sylow(M) P by apply: (subHall_Sylow hallE). + have [_] := syl_p_M P sylP_M; apply. + exact: subset_trans (pcore_max pA nsAE) (pcore_sub_Hall sylP). +have not_sNA_M: ~~ ('N(A) \subset M). + have [P sylP] := Sylow_exists p E; have [<-]:= sAsylE P sylP. + exact: contra (subset_trans (char_norms (Ohm_char 1 P))). +have{sAsylE syl_p_M} defEpE: 'E_p^1(E) = 'E_p^1(A). + apply/eqP; rewrite eqEsubset andbC pnElemS //. + apply/subsetP=> X /pnElemP[sXE abelX dimX]; apply/pnElemP; split=> //. + have [pX _ eX] := and3P abelX; have [P sylP sXP] := Sylow_superset sXE pX. + have [<- _]:= sAsylE P sylP; have [_ pP _] := and3P sylP. + by rewrite (OhmE 1 pP) sub_gen // subsetI sXP sub_LdivT. +have defNMA: 'N_M(A) = E. + rewrite -mulMsE setIC -group_modr ?normal_norm //= setIC. + rewrite coprime_norm_cent ?regA ?mul1g //. + exact: (pnat_coprime (pcore_pgroup _ _) (pi_pnat pA _)). +have [sCAM _]: 'C(A) \subset M /\ _ := p2Elem_mmax maxM Ep2A_M. +have sCAE: 'C(A) \subset E by rewrite -defNMA subsetI sCAM cent_sub. +split=> // [X EpX | H maxH not_MGH]; last first. + by case/sigma_disjoint: not_MGH => // _ _; apply; apply: tau2_Msigma_nil t2Mp. +rewrite defEpE in EpX; have [sXA abelX dimX] := pnElemP EpX. +have ntX: X :!=: 1 by rewrite -rank_gt0 (rank_abelem abelX) dimX. +apply: contraNeq => neq_maxCX_M. +have{neq_maxCX_M} [H]: exists2 H, H \in 'M('C(X)) & H \notin [set M]. + apply/subsetPn; rewrite subset1 negb_or neq_maxCX_M. + by have [H maxH]:= mmax_exists (mFT_cent_proper ntX); apply/set0Pn; exists H. +case/setIdP=> maxH sCXH neqHM. +rewrite -subG1 -(tiMsMA H) ?setIS // inE neqHM inE maxH. +exact: subset_trans (sub_abelian_cent cAA sXA) sCXH. +Qed. + +(* This is B & G, Corollary 12.6 (d, e) -- the parts that apply to a *) +(* particular decomposition of the complement. We included an easy consequece *) +(* of part (a), that A is a subgroup of E2, as this is used implicitly later *) +(* in sections 12 and 13. *) +Corollary tau2_regular M E E1 E2 E3 p A (Ms := M`_\sigma) : + M \in 'M -> sigma_complement M E E1 E2 E3 -> + p \in \tau2(M) -> A \in 'E_p^2(E) -> + [/\ (*d*) semiregular Ms E3, + (*e*) semiregular Ms 'C_E1(A) + & A \subset E2]. +Proof. +move=> maxM complEi t2Mp Ep2A; have p_pr := pnElem_prime Ep2A. +have [hallE hallE1 hallE2 hallE3 _] := complEi. +have [sEM sM'E _] := and3P hallE; have [sM'p _] := andP t2Mp. +have [sAE abelA dimA] := pnElemP Ep2A; have [pA cAA _] := and3P abelA. +have Ep2A_M: A \in 'E_p^2(M) by rewrite (subsetP (pnElemS _ _ sEM)). +have [_ _ _ tiMsMA _] := tau2_context maxM t2Mp Ep2A_M. +have [[nsAE _] _ _ _] := tau2_compl_context maxM hallE t2Mp Ep2A. +have [sCAM _]: 'C(A) \subset M /\ _ := p2Elem_mmax maxM Ep2A_M. +have sAE2: A \subset E2. + exact: normal_sub_max_pgroup (Hall_max hallE2) (pi_pnat pA _) nsAE. +split=> // x /setD1P[ntx]; last first. + case/setIP; rewrite -cent_cycle -!cycle_subG => sXE1 cAX. + pose q := pdiv #[x]; have piXq: q \in \pi(#[x]) by rewrite pi_pdiv order_gt1. + have [Q sylQ] := Sylow_exists q <[x]>; have [sQX qQ _] := and3P sylQ. + have [sE1E t1E1 _] := and3P hallE1; have sQE1 := subset_trans sQX sXE1. + have sQM := subset_trans sQE1 (subset_trans sE1E sEM). + have [H /setIdP[maxH sNQH]]: {H | H \in 'M('N(Q))}. + apply: mmax_exists; rewrite mFT_norm_proper ?(mFT_pgroup_proper qQ) //. + by rewrite -rank_gt0 (rank_pgroup qQ) (p_rank_Sylow sylQ) p_rank_gt0. + apply/trivgP; rewrite -(tiMsMA H) ?setIS //. + by rewrite (subset_trans _ sNQH) ?cents_norm ?centS. + rewrite 3!inE maxH /=; apply/andP; split. + apply: contra_orbit (mmax_norm_notJ maxM maxH qQ sQM sNQH _). + by rewrite (pnatPpi (pgroupS sXE1 t1E1)) ?orbT. + by rewrite (subset_trans _ sNQH) ?cents_norm // centsC (subset_trans sQX). +rewrite -cent_cycle -cycle_subG => sXE3. +pose q := pdiv #[x]; have piXq: q \in \pi(#[x]) by rewrite pi_pdiv order_gt1. +have [Q sylQ] := Sylow_exists q <[x]>; have [sQX qQ _] := and3P sylQ. +have [sE3E t3E3 _] := and3P hallE3; have sQE3 := subset_trans sQX sXE3. +have sQM := subset_trans sQE3 (subset_trans sE3E sEM). +have [H /setIdP[maxH sNQH]]: {H | H \in 'M('N(Q))}. + apply: mmax_exists; rewrite mFT_norm_proper ?(mFT_pgroup_proper qQ) //. + by rewrite -rank_gt0 (rank_pgroup qQ) (p_rank_Sylow sylQ) p_rank_gt0. +apply/trivgP; rewrite -(tiMsMA H) ?setIS //. + by rewrite (subset_trans _ sNQH) ?cents_norm ?centS. +rewrite 3!inE maxH /=; apply/andP; split. + apply: contra_orbit (mmax_norm_notJ maxM maxH qQ sQM sNQH _). + by rewrite (pnatPpi (pgroupS sXE3 t3E3)) ?orbT. +rewrite (subset_trans _ sNQH) ?cents_norm // (subset_trans _ (centS sQE3)) //. +have coE3A: coprime #|E3| #|A|. + by rewrite (pnat_coprime t3E3 (pi_pnat pA _)) ?tau3'2. +rewrite (sameP commG1P trivgP) -(coprime_TIg coE3A) subsetI commg_subl. +have [[_ nsE3E] _ _ _ _] := sigma_compl_context maxM complEi. +by rewrite commg_subr (subset_trans sE3E) ?(subset_trans sAE) ?normal_norm. +Qed. + +(* This is B & G, Theorem 12.7. *) +Theorem nonabelian_tau2 M E p A P0 (Ms := M`_\sigma) (A0 := 'C_A(Ms)%G) : + M \in 'M -> \sigma(M)^'.-Hall(M) E -> p \in \tau2(M) -> A \in 'E_p^2(E) -> + p.-group P0 -> ~~ abelian P0 -> + [/\ (*a*) \tau2(M) =i (p : nat_pred), + (*b*) #|A0| = p /\ Ms \x A0 = 'F(M), + (*c*) forall X, + X \in 'E_p^1(E) :\ A0 -> 'C_Ms(X) = 1 /\ ~~ ('C(X) \subset M) + & (*d*) exists2 E0 : {group gT}, A0 ><| E0 = E + & (*e*) forall x, x \in Ms^# -> {subset \pi('C_E0[x]) <= \tau1(M)}]. +Proof. +rewrite {}/A0 => maxM hallE t2Mp Ep2A pP0 not_cP0P0 /=. +have p_pr := pnElem_prime Ep2A. +have [sEM sM'E _] := and3P hallE; have [sM'p _] := andP t2Mp. +have [sAE abelA dimA] := pnElemP Ep2A; have [pA cAA _] := and3P abelA. +have Ep2A_M: A \in 'E_p^2(M) by rewrite (subsetP (pnElemS _ _ sEM)). +have [[E1 hallE1] [E3 hallE3]] := ex_tau13_compl hallE. +have [E2 hallE2 complEi] := ex_tau2_compl hallE hallE1 hallE3. +have [regE3 _ sAE2] := tau2_regular maxM complEi t2Mp Ep2A. +have [P sylP sAP] := Sylow_superset sAE2 pA; have [sPE2 pP _] := and3P sylP. +have [S /= sylS sPS] := Sylow_superset (subsetT P) pP. +have pS := pHall_pgroup sylS; have sAS := subset_trans sAP sPS. +have sylP_E: p.-Sylow(E) P := subHall_Sylow hallE2 t2Mp sylP. +have sylP_M: p.-Sylow(M) P := subHall_Sylow hallE sM'p sylP_E. +have [syl_p_M _ regA _ _] := tau2_context maxM t2Mp Ep2A_M. +have{syl_p_M} cPP: abelian P by case: (syl_p_M P). +have{P0 pP0 not_cP0P0} not_cSS: ~~ abelian S. + have [x _ sP0Sx] := Sylow_subJ sylS (subsetT P0) pP0. + by apply: contra not_cP0P0 => cSS; rewrite (abelianS sP0Sx) ?abelianJ. +have [defP | ltPS] := eqVproper sPS; first by rewrite -defP cPP in not_cSS. +have [[nsAE defEp] [sCAE _ _] nregA _] := + tau2_compl_context maxM hallE t2Mp Ep2A. +have defCSA: 'C_S(A) = P. + apply: (sub_pHall sylP_E (pgroupS (subsetIl _ _) pS)). + by rewrite subsetI sPS (sub_abelian_cent2 cPP). + by rewrite subIset // sCAE orbT. +have max2A: A \in 'E_p^2(G) :&: 'E*_p(G). + by rewrite 3!inE subsetT abelA dimA; case: (tau2_not_beta maxM t2Mp) => _ ->. +have def_t2: \tau2(M) =i (p : nat_pred). + move=> q; apply/idP/idP=> [t2Mq |]; last by move/eqnP->. + apply: contraLR (proper_card ltPS); rewrite !inE /= eq_sym -leqNgt => q'p. + apply: wlog_neg => p'q; have [B EqB] := p_rank_witness q E. + have{EqB} Eq2B: B \in 'E_q^2(E). + by move: t2Mq; rewrite (tau2E hallE) => /andP[_ /eqP <-]. + have [sBE abelB dimB]:= pnElemP Eq2B; have [qB _] := andP abelB. + have coBA: coprime #|B| #|A| by exact: pnat_coprime qB (pi_pnat pA _). + have [[nsBE _] [sCBE _ _] _ _] := tau2_compl_context maxM hallE t2Mq Eq2B. + have nBA: A \subset 'N(B) by rewrite (subset_trans sAE) ?normal_norm. + have cAB: B \subset 'C(A). + rewrite (sameP commG1P trivgP) -(coprime_TIg coBA) subsetI commg_subl nBA. + by rewrite commg_subr (subset_trans sBE) ?normal_norm. + have{cAB} qCA: q %| #|'C(A)|. + by apply: dvdn_trans (cardSg cAB); rewrite (card_pnElem Eq2B) dvdn_mull. + have [Q maxQ sBQ] := max_normed_exists qB nBA. + have nnQ: q.-narrow Q. + apply/implyP=> _; apply/set0Pn; exists B. + rewrite 3!inE sBQ abelB dimB (subsetP (pmaxElemS q (subsetT Q))) //=. + rewrite setIC 2!inE sBQ; case: (tau2_not_beta maxM t2Mq) => _ -> //. + by rewrite (subsetP (pnElemS _ _ sEM)). + have [P1 [sylP1 _] [_ _]] := max_normed_2Elem_signaliser q'p max2A maxQ qCA. + move/(_ nnQ)=> cQP1; have sylP1_E: p.-Sylow(E) P1. + apply: pHall_subl (subset_trans _ sCBE) (subsetT E) sylP1. + exact: subset_trans (centS sBQ). + rewrite (card_Hall sylS) -(card_Hall sylP1). + by rewrite (card_Hall sylP_E) -(card_Hall sylP1_E). +have coMsA: coprime #|Ms| #|A|. + by exact: pnat_coprime (pcore_pgroup _ _) (pi_pnat pA _). +have defMs: <<\bigcup_(X in 'E_p^1(A)) 'C_Ms(X)>> = Ms. + have ncycA: ~~ cyclic A by rewrite (abelem_cyclic abelA) dimA. + have [sAM _ _] := pnElemP Ep2A_M. + have{sAM} nMsA: A \subset 'N(Ms) by rewrite (subset_trans sAM) ?gFnorm. + apply/eqP; rewrite eqEsubset andbC gen_subG. + rewrite -{1}[Ms](coprime_abelian_gen_cent1 cAA ncycA nMsA coMsA). + rewrite genS; apply/bigcupsP=> x; rewrite ?subsetIl //; case/setD1P=> ntx Ax. + rewrite /= -cent_cycle (bigcup_max <[x]>%G) // p1ElemE // . + by rewrite 2!inE cycle_subG Ax /= -orderE (abelem_order_p abelA). +have [A0 EpA0 nregA0]: exists2 A0, A0 \in 'E_p^1(A) & 'C_Ms(A0) != 1. + apply/exists_inP; rewrite -negb_forall_in. + apply: contra (Msigma_neq1 maxM); move/forall_inP => regAp. + rewrite -/Ms -defMs -subG1 gen_subG; apply/bigcupsP=> X EpX. + by rewrite subG1 regAp. +have uniqCA0: 'M('C(A0)) = [set M]. + by rewrite nregA // (subsetP (pnElemS _ _ sAE)). +have defSM: S :&: M = P. + apply: sub_pHall (pgroupS (subsetIl S M) pS) _ (subsetIr S M) => //. + by rewrite subsetI sPS (pHall_sub sylP_M). +have{ltPS} not_sSM: ~~ (S \subset M). + by rewrite (sameP setIidPl eqP) defSM proper_neq. +have not_sA0Z: ~~ (A0 \subset 'Z(S)). + apply: contra not_sSM; rewrite subsetI centsC; case/andP=> _ sS_CA0. + by case/mem_uniq_mmax: uniqCA0 => _; exact: subset_trans sS_CA0. +have [EpZ0 dxCSA transNSA] := basic_p2maxElem_structure max2A pS sAS not_cSS. +do [set Z0 := 'Ohm_1('Z(S))%G; set EpA' := _ :\ Z0] in EpZ0 dxCSA transNSA. +have sZ0Z: Z0 \subset 'Z(S) := Ohm_sub 1 _. +have [sA0A _ _] := pnElemP EpA0; have sA0P := subset_trans sA0A sAP. +have EpA'_A0: A0 \in EpA'. + by rewrite 2!inE EpA0 andbT; apply: contraNneq not_sA0Z => ->. +have{transNSA sAP not_sSM defSM} regA0' X: + X \in 'E_p^1(E) :\ A0 -> 'C_Ms(X) = 1 /\ ~~ ('C(X) \subset M). +- case/setD1P=> neqXA0 EpX. + suffices not_sCXM: ~~ ('C(X) \subset M). + split=> //; apply: contraNeq not_sCXM => nregX. + by case/mem_uniq_mmax: (nregA X EpX nregX). + have [sXZ | not_sXZ] := boolP (X \subset 'Z(S)). + apply: contra (subset_trans _) not_sSM. + by rewrite centsC (subset_trans sXZ) ?subsetIr. + have EpA'_X: X \in EpA'. + by rewrite 2!inE -defEp EpX andbT; apply: contraNneq not_sXZ => ->. + have [g NSAg /= defX] := atransP2 transNSA EpA'_A0 EpA'_X. + have{NSAg} [Sg nAg] := setIP NSAg. + have neqMgM: M :^ g != M. + rewrite (sameP eqP normP) (norm_mmax maxM); apply: contra neqXA0 => Mg. + rewrite defX [_ == _](sameP eqP normP) (subsetP (cent_sub A0)) //. + by rewrite (subsetP (centSS (subxx _) sA0P cPP)) // -defSM inE Sg. + apply: contra neqMgM; rewrite defX centJ sub_conjg. + by move/(eq_uniq_mmax uniqCA0) => defM; rewrite -{1}defM ?mmaxJ ?actKV. +have{defMs} defA0: 'C_A(Ms) = A0. + apply/eqP; rewrite eq_sym eqEcard subsetI sA0A (card_pnElem EpA0). + have pCA: p.-group 'C_A(Ms) := pgroupS (subsetIl A _) pA. + rewrite andbC (card_pgroup pCA) leq_exp2l ?prime_gt1 // -ltnS -dimA. + rewrite properG_ltn_log //=; last first. + rewrite properE subsetIl /= subsetI subxx centsC -(subxx Ms) -subsetI. + by rewrite regA subG1 Msigma_neq1. + rewrite centsC -defMs gen_subG (big_setD1 A0) //= subUset subsetIr /=. + by apply/bigcupsP=> X; rewrite -defEp; case/regA0'=> -> _; rewrite sub1G. +rewrite defA0 (group_inj defA0) (card_pnElem EpA0). +have{dxCSA} [Y [cycY sZ0Y]] := dxCSA; move/(_ _ EpA'_A0)=> dxCSA. +have defCP_Ms: 'C_P(Ms) = A0. + move: dxCSA; rewrite defCSA => /dprodP[_ mulA0Y cA0Y tiA0Y]. + rewrite -mulA0Y -group_modl /=; last by rewrite -defA0 subsetIr. + rewrite setIC TI_Ohm1 ?mulg1 // setIC. + have pY: p.-group Y by rewrite (pgroupS _ pP) // -mulA0Y mulG_subr. + have cYY: abelian Y := cyclic_abelian cycY. + have ->: 'Ohm_1(Y) = Z0. + apply/eqP; rewrite eq_sym eqEcard (card_pnElem EpZ0) /= -['Ohm_1(_)]Ohm_id. + rewrite OhmS // (card_pgroup (pgroupS (Ohm_sub 1 Y) pY)). + rewrite leq_exp2l ?prime_gt1 -?p_rank_abelian // -rank_pgroup //. + by rewrite -abelian_rank1_cyclic. + rewrite prime_TIg ?(card_pnElem EpZ0) // centsC (sameP setIidPl eqP) eq_sym. + case: (regA0' Z0) => [|-> _]; last exact: Msigma_neq1. + by rewrite 2!inE defEp EpZ0 andbT; apply: contraNneq not_sA0Z => <-. +have [sPM pA0] := (pHall_sub sylP_M, pgroupS sA0A pA). +have cMsA0: A0 \subset 'C(Ms) by rewrite -defA0 subsetIr. +have nsA0M: A0 <| M. + have [_ defM nMsE _] := sdprodP (sdprod_sigma maxM hallE). + rewrite /normal (subset_trans sA0P) // -defM mulG_subG cents_norm 1?centsC //. + by rewrite -defA0 normsI ?norms_cent // normal_norm. +have defFM: Ms \x A0 = 'F(M). + have nilF := Fitting_nil M. + rewrite dprodE ?(coprime_TIg (coprimegS sA0A coMsA)) //. + have [_ /= defFM cFpp' _] := dprodP (nilpotent_pcoreC p nilF). + have defFp': 'O_p^'('F(M)) = Ms. + apply/eqP; rewrite eqEsubset. + rewrite (sub_Hall_pcore (Msigma_Hall maxM)); last first. + exact: subset_trans (pcore_sub _ _) (Fitting_sub _). + rewrite /pgroup (sub_in_pnat _ (pcore_pgroup _ _)) => [|q piFq]; last first. + have [Q sylQ] := Sylow_exists q 'F(M); have [sQF qQ _] := and3P sylQ. + have ntQ: Q :!=: 1. + rewrite -rank_gt0 (rank_pgroup qQ) (p_rank_Sylow sylQ) p_rank_gt0. + by rewrite (piSg _ piFq) ?pcore_sub. + have sNQM: 'N(Q) \subset M. + rewrite (mmax_normal maxM) // (nilpotent_Hall_pcore nilF sylQ). + by rewrite p_core_Fitting pcore_normal. + apply/implyP; rewrite implyNb /= -def_t2 orbC. + by rewrite (prime_class_mmax_norm maxM qQ). + rewrite pcore_max ?(pi_p'group (pcore_pgroup _ _)) //. + rewrite /normal (subset_trans (Fitting_sub M)) ?gFnorm //. + rewrite Fitting_max ?pcore_normal ?(tau2_Msigma_nil _ t2Mp) //. + rewrite p_core_Fitting defFp' centsC in defFM cFpp'. + rewrite -defFM (centC cFpp'); congr (Ms * _). + apply/eqP; rewrite eqEsubset pcore_max //. + by rewrite -defCP_Ms subsetI cFpp' pcore_sub_Hall. +split=> {defFM}//. +have [[sE1E t1E1 _] t2E2] := (and3P hallE1, pHall_pgroup hallE2). +have defE2: E2 :=: P by rewrite (sub_pHall sylP) // -(eq_pgroup _ def_t2) t2E2. +have [[_ nsE3E] _ _ [defEr _] _] := sigma_compl_context maxM complEi. +have [sE3E nE3E] := andP nsE3E; have{nE3E} nE3E := subset_trans _ nE3E. +have [[_ E21 _ defE21]] := sdprodP defEr; rewrite defE21 => defE nE321 tiE321. +rewrite defE2 in defE21; have{defE21} [_ defPE1 nPE1 tiPE1] := sdprodP defE21. +have [P0 defP nP0E1]: exists2 P0 : {group gT}, A0 \x P0 = P & E1 \subset 'N(P0). + have p'E1b: p^'.-group (E1 / 'Phi(P)). + rewrite quotient_pgroup //; apply: sub_pgroup t1E1 => q /tau2'1. + by rewrite inE /= def_t2. + have defPhiP: 'Phi(P) = 'Phi(Y). + have [_ _ cA0Y tiA0Y] := dprodP dxCSA. + rewrite defCSA dprodEcp // in dxCSA. + have [_ abelA0 _] := pnElemP EpA0; rewrite -trivg_Phi // in abelA0. + by rewrite -(Phi_cprod pP dxCSA) (eqP abelA0) cprod1g. + have abelPb := Phi_quotient_abelem pP; have sA0Pb := quotientS 'Phi(P) sA0P. + have [||P0b] := Maschke_abelem abelPb p'E1b sA0Pb; rewrite ?quotient_norms //. + by rewrite (subset_trans (subset_trans sE1E sEM)) ?normal_norm. + case/dprodP=> _ defPb _ tiAP0b nP0E1b. + have sP0Pb: P0b \subset P / 'Phi(P) by rewrite -defPb mulG_subr. + have [P0 defP0b sPhiP0 sP0P] := inv_quotientS (Phi_normal P) sP0Pb. + exists P0; last first. + rewrite -(quotientSGK (char_norm_trans (Phi_char P) nPE1)); last first. + by rewrite cents_norm ?(sub_abelian_cent2 cPP (Phi_sub P) sP0P). + by rewrite quotient_normG -?defP0b ?(normalS _ _ (Phi_normal P)). + rewrite dprodEY ?(sub_abelian_cent2 cPP) //. + apply/eqP; rewrite eqEsubset join_subG sA0P sP0P /=. + rewrite -(quotientSGK (normal_norm (Phi_normal P))) //=; last first. + by rewrite sub_gen // subsetU // sPhiP0 orbT. + rewrite cent_joinEr ?(sub_abelian_cent2 cPP) //. + rewrite quotientMr //; last by rewrite (subset_trans sP0P) ?gFnorm. + by rewrite -defP0b defPb. + apply/trivgP; case/dprodP: dxCSA => _ _ _ <-. + rewrite subsetI subsetIl (subset_trans _ (Phi_sub Y)) // -defPhiP. + rewrite -quotient_sub1 ?subIset ?(subset_trans sA0P) ?gFnorm //. + by rewrite quotientIG // -defP0b tiAP0b. +have nA0E := subset_trans _ (subset_trans sEM (normal_norm nsA0M)). +have{defP} [_ defAP0 _ tiAP0] := dprodP defP. +have sP0P: P0 \subset P by rewrite -defAP0 mulG_subr. +have sP0E := subset_trans sP0P (pHall_sub sylP_E). +pose E0 := (E3 <*> (P0 <*> E1))%G. +have sP0E1_E: P0 <*> E1 \subset E by rewrite join_subG sP0E. +have sE0E: E0 \subset E by rewrite join_subG sE3E. +have mulA0E0: A0 * E0 = E. + rewrite /= (norm_joinEr (nE3E _ sP0E1_E)) mulgA -(normC (nA0E _ sE3E)). + by rewrite /= -mulgA (norm_joinEr nP0E1) (mulgA A0) defAP0 defPE1. +have tiA0E0: A0 :&: E0 = 1. + rewrite cardMg_TI // mulA0E0 -defE /= (norm_joinEr (nE3E _ sP0E1_E)). + rewrite !TI_cardMg //; last first. + by apply/trivgP; rewrite -tiE321 setIS //= ?norm_joinEr // -defPE1 mulSg. + rewrite mulnCA /= leq_mul // norm_joinEr //= -defPE1. + rewrite !TI_cardMg //; last by apply/trivgP; rewrite -tiPE1 setSI. + by rewrite mulnA -(TI_cardMg tiAP0) defAP0. +have defAE0: A0 ><| E0 = E by rewrite sdprodE ?nA0E. +exists E0 => // x /setD1P[ntx Ms_x] q piCE0x_q. +have: q \in \pi(E) by apply: piSg piCE0x_q; rewrite subIset ?sE0E. +rewrite mem_primes in piCE0x_q; case/and3P: piCE0x_q => q_pr _. +case/Cauchy=> // z /setIP[E0z cxz] oz. +have ntz: z != 1 by rewrite -order_gt1 oz prime_gt1. +have ntCMs_z: 'C_Ms[z] != 1. + apply: contraNneq ntx => reg_z; rewrite (sameP eqP set1gP) -reg_z inE Ms_x. + by rewrite cent1C. +rewrite (partition_pi_sigma_compl maxM hallE) def_t2. +case/or3P => [-> // | pq | t3Mq]. + have EpA0'_z: <[z]>%G \in 'E_p^1(E) :\ A0. + rewrite p1ElemE // !inE -orderE oz (eqnP pq) eqxx cycle_subG. + rewrite (subsetP sE0E) // !andbT; apply: contraNneq ntz => eqA0z. + by rewrite (sameP eqP set1gP) -tiA0E0 inE -eqA0z cycle_id E0z. + have [reg_z _] := regA0' _ EpA0'_z. + by rewrite -cent_cycle reg_z eqxx in ntCMs_z. +rewrite regE3 ?eqxx // !inE ntz /= in ntCMs_z. +by rewrite (mem_normal_Hall hallE3 nsE3E) ?(subsetP sE0E) // /p_elt oz pnatE. +Qed. + +(* This is B & G, Theorem 12.8(c). This part does not use the decompotision *) +(* of the complement, and needs to be proved ahead because it is used with *) +(* different primes in \tau_2(M) in the main argument. We also include an *) +(* auxiliary identity, which is needed in another part of the proof of 12.8. *) +Theorem abelian_tau2_sub_Fitting M E p A S : + M \in 'M -> \sigma(M)^'.-Hall(M) E -> + p \in \tau2(M) -> A \in 'E_p^2(E) -> + p.-Sylow(G) S -> A \subset S -> abelian S -> + [/\ S \subset 'N(S)^`(1), + 'N(S)^`(1) \subset 'F(E), + 'F(E) \subset 'C(S), + 'C(S) \subset E + & 'F('N(A)) = 'F(E)]. +Proof. +move=> maxM hallE t2Mp Ep2A sylS sAS cSS. +have [sAE abelA dimA]:= pnElemP Ep2A; have [pA cAA _] := and3P abelA. +have [sEM sM'E _] := and3P hallE. +have Ep2A_M := subsetP (pnElemS p 2 sEM) A Ep2A. +have eqFC H: A <| H -> 'C(A) \subset H -> 'F(H) = 'F('C(A)). + move=> nsAH sCH; have [_ nAH] := andP nsAH. + apply/eqP; rewrite eqEsubset !Fitting_max ?Fitting_nil //. + by rewrite (char_normal_trans (Fitting_char _)) // /normal sCH norms_cent. + apply: normalS sCH (Fitting_normal H). + have [_ defF cFpFp' _] := dprodP (nilpotent_pcoreC p (Fitting_nil H)). + have sAFp: A \subset 'O_p('F(H)) by rewrite p_core_Fitting pcore_max. + have [x _ sFpSx] := Sylow_subJ sylS (subsetT _) (pcore_pgroup p 'F(H)). + have cFpFp: abelian 'O_p('F(H)) by rewrite (abelianS sFpSx) ?abelianJ. + by rewrite -defF mulG_subG (centSS _ _ cFpFp) // (centSS _ _ cFpFp'). +have [[nsAE _] [sCAE _] _ _ _] := tau2_compl_context maxM hallE t2Mp Ep2A. +have eqFN_FE: 'F('N(A)) = 'F(E) by rewrite (eqFC E) // eqFC ?cent_sub ?normalG. +have sN'FN: 'N(A)^`(1) \subset 'F('N(A)). + rewrite rank2_der1_sub_Fitting ?mFT_odd //. + rewrite ?mFT_sol // mFT_norm_proper ?(mFT_pgroup_proper pA) //. + by rewrite -rank_gt0 (rank_abelem abelA) dimA. + rewrite eqFN_FE (leq_trans (rankS (Fitting_sub E))) //. + have [q q_pr ->]:= rank_witness E; apply: wlog_neg; rewrite -ltnNge => rEgt2. + rewrite (leq_trans (p_rankS q sEM)) // leqNgt. + apply: contra ((alpha_sub_sigma maxM) q) (pnatPpi sM'E _). + by rewrite -p_rank_gt0 (leq_trans _ rEgt2). +have sSE: S \subset E by rewrite (subset_trans _ sCAE) // (centSS _ _ cSS). +have nA_NS: 'N(S) \subset 'N(A). + have [ ] := tau2_context maxM t2Mp Ep2A_M; have sSM := subset_trans sSE sEM. + have sylS_M: p.-Sylow(M) S := pHall_subl sSM (subsetT M) sylS. + by case/(_ S) => // _ [// |<- _] _ _ _ _; exact: char_norms (Ohm_char 1 _). +have sS_NS': S \subset 'N(S)^`(1) := mFT_Sylow_der1 sylS. +have sNS'_FE: 'N(S)^`(1) \subset 'F(E). + by rewrite -eqFN_FE (subset_trans (dergS 1 nA_NS)). +split=> //; last by rewrite (subset_trans (centS sAS)). +have sSFE := subset_trans sS_NS' sNS'_FE; have nilFE := Fitting_nil E. +have sylS_FE := pHall_subl sSFE (subsetT 'F(E)) sylS. +suff sSZF: S \subset 'Z('F(E)) by rewrite centsC (subset_trans sSZF) ?subsetIr. +have [_ <- _ _] := dprodP (center_dprod (nilpotent_pcoreC p nilFE)). +by rewrite -(nilpotent_Hall_pcore nilFE sylS_FE) (center_idP cSS) mulG_subl. +Qed. + +(* This is B & G, Theorem 12.8(a,b,d,e) -- the bulk of the Theorem. We prove *) +(* part (f) separately below, as it does not depend on a decomposition of the *) +(* complement. *) +Theorem abelian_tau2 M E E1 E2 E3 p A S (Ms := M`_\sigma) : + M \in 'M -> sigma_complement M E E1 E2 E3 -> + p \in \tau2(M) -> A \in 'E_p^2(E) -> + p.-Sylow(G) S -> A \subset S -> abelian S -> + [/\ (*a*) E2 <| E /\ abelian E2, + (*b*) \tau2(M).-Hall(G) E2, + (*d*) [/\ 'N(A) = 'N(S), + 'N(S) = 'N(E2), + 'N(E2) = 'N(E3 <*> E2) + & 'N(E3 <*> E2) = 'N('F(E))] + & (*e*) forall X, X \in 'E^1(E1) -> 'C_Ms(X) = 1 -> X \subset 'Z(E)]. +Proof. +move=> maxM complEi t2Mp Ep2A sylS sAS cSS. +have [hallE hallE1 hallE2 hallE3 _] := complEi. +have [sEM sM'E _] := and3P hallE. +have [sE1E t1E1 _] := and3P hallE1. +have [sE2E t2E2 _] := and3P hallE2. +have [sE3E t3E3 _] := and3P hallE3. +have nilF: nilpotent 'F(E) := Fitting_nil E. +have sylE2_sylG_ZFE q Q: + q.-Sylow(E2) Q -> Q :!=: 1 -> q.-Sylow(G) Q /\ Q \subset 'Z('F(E)). +- move=> sylQ ntQ; have [sQE2 qQ _] := and3P sylQ. + have piQq: q \in \pi(Q) by rewrite -p_rank_gt0 -rank_pgroup // rank_gt0. + have t2Mq: q \in \tau2(M) by rewrite (pnatPpi t2E2) // (piSg sQE2). + have sylQ_E: q.-Sylow(E) Q := subHall_Sylow hallE2 t2Mq sylQ. + have rqQ: 'r_q(Q) = 2. + rewrite (tau2E hallE) !inE -(p_rank_Sylow sylQ_E) in t2Mq. + by case/andP: t2Mq => _ /eqP. + have [B Eq2B sBQ]: exists2 B, B \in 'E_q^2(E) & B \subset Q. + have [B Eq2B] := p_rank_witness q Q; have [sBQ abelB rBQ] := pnElemP Eq2B. + exists B; rewrite // !inE rBQ rqQ abelB !andbT. + exact: subset_trans sBQ (pHall_sub sylQ_E). + have [T /= sylT sQT] := Sylow_superset (subsetT Q) qQ. + have qT: q.-group T := pHall_pgroup sylT. + have cTT: abelian T. + apply: wlog_neg => not_cTT. + have [def_t2 _ _ _] := nonabelian_tau2 maxM hallE t2Mq Eq2B qT not_cTT. + rewrite def_t2 !inE in t2Mp; rewrite (eqP t2Mp) in sylS. + by have [x _ ->] := Sylow_trans sylS sylT; rewrite abelianJ. + have sTF: T \subset 'F(E). + have subF := abelian_tau2_sub_Fitting maxM hallE t2Mq Eq2B sylT. + have [sTN' sN'F _ _ _] := subF (subset_trans sBQ sQT) cTT. + exact: subset_trans sTN' sN'F. + have sTE: T \subset E := subset_trans sTF (Fitting_sub E). + have <-: T :=: Q by apply: (sub_pHall sylQ_E). + have sylT_F: q.-Sylow('F(E)) T := pHall_subl sTF (subsetT _) sylT. + have [_ <- _ _] := dprodP (center_dprod (nilpotent_pcoreC q nilF)). + by rewrite -(nilpotent_Hall_pcore nilF sylT_F) (center_idP cTT) mulG_subl. +have hallE2_G: \tau2(M).-Hall(G) E2. + rewrite pHallE subsetT /= -(part_pnat_id t2E2); apply/eqnP. + rewrite !(widen_partn _ (subset_leq_card (subsetT _))). + apply: eq_bigr => q t2q; rewrite -!p_part. + have [Q sylQ] := Sylow_exists q E2; have qQ := pHall_pgroup sylQ. + have sylQ_E: q.-Sylow(E) Q := subHall_Sylow hallE2 t2q sylQ. + have ntQ: Q :!=: 1. + rewrite -rank_gt0 (rank_pgroup qQ) (p_rank_Sylow sylQ_E) p_rank_gt0. + by rewrite (tau2E hallE) in t2q; case/andP: t2q. + have [sylQ_G _] := sylE2_sylG_ZFE q Q sylQ ntQ. + by rewrite -(card_Hall sylQ) -(card_Hall sylQ_G). +have sE2_ZFE: E2 \subset 'Z('F(E)). + rewrite -Sylow_gen gen_subG; apply/bigcupsP=> Q; case/SylowP=> q q_pr sylQ. + have [-> | ntQ] := eqsVneq Q 1; first exact: sub1G. + by have [_ ->] := sylE2_sylG_ZFE q Q sylQ ntQ. +have cE2E2: abelian E2 := abelianS sE2_ZFE (center_abelian _). +have sE2FE: E2 \subset 'F(E) := subset_trans sE2_ZFE (center_sub _). +have nsE2E: E2 <| E. + have hallE2_F := pHall_subl sE2FE (Fitting_sub E) hallE2. + rewrite (nilpotent_Hall_pcore nilF hallE2_F). + exact: char_normal_trans (pcore_char _ _) (Fitting_normal E). +have [_ _ [cycE1 cycE3] [_ defEl] _] := sigma_compl_context maxM complEi. +have [[K _ defK _] _ _ _] := sdprodP defEl; rewrite defK in defEl. +have [nsKE _ mulKE1 nKE1 _] := sdprod_context defEl; have [sKE _] := andP nsKE. +have [nsE3K sE2K _ nE32 tiE32] := sdprod_context defK. +rewrite -sdprodEY // defK. +have{defK} defK: E3 \x E2 = K. + rewrite dprodEsd // (sameP commG1P trivgP) -tiE32 subsetI commg_subr nE32. + by rewrite commg_subl (subset_trans sE3E) ?normal_norm. +have cKK: abelian K. + by have [_ <- cE23 _] := dprodP defK; rewrite abelianM cE2E2 cyclic_abelian. +have [_ sNS'F _ sCS_E defFN] := + abelian_tau2_sub_Fitting maxM hallE t2Mp Ep2A sylS sAS cSS. +have{sCS_E} sSE2: S \subset E2. + rewrite (sub_normal_Hall hallE2 nsE2E (subset_trans cSS sCS_E)). + by rewrite (pi_pgroup (pHall_pgroup sylS)). +have charS: S \char E2. + have sylS_E2: p.-Sylow(E2) S := pHall_subl sSE2 (subsetT E2) sylS. + by rewrite (nilpotent_Hall_pcore (abelian_nil cE2E2) sylS_E2) pcore_char. +have nsSE: S <| E := char_normal_trans charS nsE2E; have [sSE nSE] := andP nsSE. +have charA: A \char S. + have Ep2A_M := subsetP (pnElemS p 2 sEM) A Ep2A. + have sylS_M := pHall_subl (subset_trans sSE sEM) (subsetT M) sylS. + have [] := tau2_context maxM t2Mp Ep2A_M; case/(_ S sylS_M)=> _ [//|<- _]. + by rewrite Ohm_char. +have charE2: E2 \char K. + have hallE2_K := pHall_subl sE2K sKE hallE2. + by rewrite (nilpotent_Hall_pcore (abelian_nil cKK) hallE2_K) pcore_char. +have coKE1: coprime #|K| #|E1|. + rewrite -(dprod_card defK) coprime_mull (sub_pnat_coprime tau3'1 t3E3 t1E1). + by rewrite (sub_pnat_coprime tau2'1 t2E2 t1E1). +have hallK: Hall 'F(E) K. + have hallK: Hall E K. + by rewrite /Hall -divgS sKE //= -(sdprod_card defEl) mulKn. + have sKFE: K \subset 'F(E) by rewrite Fitting_max ?abelian_nil. + exact: pHall_Hall (pHall_subl sKFE (Fitting_sub E) (Hall_pi hallK)). +have charK: K \char 'F(E). + by rewrite (nilpotent_Hall_pcore nilF (Hall_pi hallK)) pcore_char. +have{defFN} [eqNAS eqNSE2 eqNE2K eqNKF]: + [/\ 'N(A) = 'N(S), 'N(S) = 'N(E2), 'N(E2) = 'N(K) & 'N(K) = 'N('F(E))]. + have: #|'N(A)| <= #|'N('F(E))|. + by rewrite subset_leq_card // -defFN gFnorm. + have leCN := subset_leqif_cards (@char_norms gT _ _ _). + have trCN := leqif_trans (leCN _ _ _). + have leq_KtoA := trCN _ _ _ _ charE2 (trCN _ _ _ _ charS (leCN _ _ charA)). + rewrite (geq_leqif (trCN _ _ _ _ charK leq_KtoA)). + by case/and4P; do 4!move/eqP->. +split=> // X E1_1_X regX. +have cK_NK': 'N(K)^`(1) \subset 'C(K). + suffices sKZ: K \subset 'Z('F(E)). + by rewrite -eqNE2K -eqNSE2 (centSS sNS'F sKZ) // centsC subsetIr. + have{hallK} [pi hallK] := HallP hallK. + have [_ <- _ _] := dprodP (center_dprod (nilpotent_pcoreC pi nilF)). + by rewrite -(nilpotent_Hall_pcore nilF hallK) (center_idP cKK) mulG_subl. +have [q EqX] := nElemP E1_1_X; have [sXE1 abelX dimX] := pnElemP EqX. +have sXE := subset_trans sXE1 sE1E. +have nKX := subset_trans sXE (normal_norm nsKE). +have nCSX_NS: 'N(K) \subset 'N('C(K) * X). + rewrite -(quotientGK (cent_normal _)) -quotientK ?norms_cent //. + by rewrite morphpre_norms // sub_abelian_norm ?quotientS ?sub_der1_abelian. +have nKX_NS: 'N(S) \subset 'N([~: K, X]). + have CK_K_1: [~: 'C(K), K] = 1 by apply/commG1P. + rewrite eqNSE2 eqNE2K commGC -[[~: X, K]]mul1g -CK_K_1. + by rewrite -commMG ?CK_K_1 ?norms1 ?normsR. +have not_sNKX_M: ~~ ('N([~: K, X]) \subset M). + have [[sM'p _] sSM] := (andP t2Mp, subset_trans sSE sEM). + apply: contra sM'p => sNKX_M; apply/existsP; exists S. + by rewrite (pHall_subl sSM (subsetT _) sylS) // (subset_trans _ sNKX_M). +have cKX: K \subset 'C(X). + apply: contraR not_sNKX_M; rewrite (sameP commG1P eqP) => ntKX. + rewrite (mmax_normal maxM) //. + have [sKM sM'K] := (subset_trans sKE sEM, pgroupS sKE sM'E). + have piE1q: q \in \pi(E1). + by rewrite -p_rank_gt0 -dimX logn_le_p_rank // inE sXE1. + have sM'q: q \in \sigma(M)^' by rewrite (pnatPpi sM'E) // (piSg sE1E). + have EpX_NK: X \in 'E_q^1('N_M(K)). + by apply: subsetP EqX; rewrite pnElemS // subsetI (subset_trans sE1E). + have q'K: q^'.-group K. + by rewrite p'groupEpi ?coprime_pi' // in coKE1 *; apply: (pnatPpi coKE1). + by have []:= commG_sigma'_1Elem_cyclic maxM sKM sM'K sM'q EpX_NK regX. +rewrite subsetI sXE /= -mulKE1 centM subsetI centsC cKX. +exact: subset_trans sXE1 (cyclic_abelian cycE1). +Qed. + +(* This is B & G, Theorem 12.8(f). *) +Theorem abelian_tau2_norm_Sylow M E p A S : + M \in 'M -> \sigma(M)^'.-Hall(M) E -> p \in \tau2(M) -> A \in 'E_p^2(E) -> + p.-Sylow(G) S -> A \subset S -> abelian S -> + forall X, X \subset 'N(S) -> 'C_S(X) <| 'N(S) /\ [~: S, X] <| 'N(S). +Proof. +move=> maxM hallE t2Mp Ep2A sylS sAS cSS X nSX. +have [_ sNS'F sFCS _ _] := + abelian_tau2_sub_Fitting maxM hallE t2Mp Ep2A sylS sAS cSS. +have{sNS'F sFCS} sNS'CS: 'N(S)^`(1) \subset 'C(S) := subset_trans sNS'F sFCS. +have nCSX_NS: 'N(S) \subset 'N('C(S) * X). + rewrite -quotientK ?norms_cent // -{1}(quotientGK (cent_normal S)). + by rewrite morphpre_norms // sub_abelian_norm ?quotientS ?sub_der1_abelian. +rewrite /normal subIset ?comm_subG ?normG //=; split. + have ->: 'C_S(X) = 'C_S('C(S) * X). + by rewrite centM setIA; congr (_ :&: _); rewrite (setIidPl _) // centsC. + by rewrite normsI ?norms_cent. +have CS_S_1: [~: 'C(S), S] = 1 by exact/commG1P. +by rewrite commGC -[[~: X, S]]mul1g -CS_S_1 -commMG ?CS_S_1 ?norms1 ?normsR. +Qed. + +(* This is B & G, Corollary 12.9. *) +Corollary tau1_act_tau2 M E p A q Q (Ms := M`_\sigma) : + M \in 'M -> \sigma(M)^'.-Hall(M) E -> p \in \tau2(M) -> A \in 'E_p^2(E) -> + q \in \tau1(M) -> Q \in 'E_q^1(E) -> 'C_Ms(Q) = 1 -> [~: A, Q] != 1 -> + let A0 := [~: A, Q]%G in let A1 := ('C_A(Q))%G in + [/\ (*a*) [/\ A0 \in 'E_p^1(A), 'C_A(Ms) = A0 & A0 <| M], + (*b*) gval A0 \notin A1 :^: G + & (*c*) A1 \in 'E_p^1(A) /\ ~~ ('C(A1) \subset M)]. +Proof. +move=> maxM hallE t2Mp Ep2A t1Mq EqQ regQ ntA0 A0 A1. +have [sEM sM'E _] := and3P hallE. +have [sAE abelA dimA] := pnElemP Ep2A; have [pA cAA _] := and3P abelA. +have [sQE abelQ dimQ] := pnElemP EqQ; have [qQ _ _] := and3P abelQ. +have [p_pr q_pr] := (pnElem_prime Ep2A, pnElem_prime EqQ). +have p_gt1 := prime_gt1 p_pr. +have Ep2A_M := subsetP (pnElemS p 2 sEM) A Ep2A. +have [_ _ regA _ _] := tau2_context maxM t2Mp Ep2A_M. +have [[nsAE _] _ _ _] := tau2_compl_context maxM hallE t2Mp Ep2A. +have [_ nAE] := andP nsAE; have nAQ := subset_trans sQE nAE. +have coAQ: coprime #|A| #|Q|. + exact: sub_pnat_coprime tau2'1 (pi_pnat pA t2Mp) (pi_pnat qQ t1Mq). +have defA: A0 \x A1 = A := coprime_abelian_cent_dprod nAQ coAQ cAA. +have [_ _ _ tiA01] := dprodP defA. +have [sAM sM'A] := (subset_trans sAE sEM, pgroupS sAE sM'E). +have sM'q: q \in \sigma(M)^' by case/andP: t1Mq. +have EqQ_NA: Q \in 'E_q^1('N_M(A)). + by apply: subsetP EqQ; rewrite pnElemS // subsetI sEM. +have q'A: q^'.-group A. + rewrite p'groupEpi ?coprime_pi' // in coAQ *. + by apply: (pnatPpi coAQ); rewrite -p_rank_gt0 (p_rank_abelem abelQ) dimQ. +have [] := commG_sigma'_1Elem_cyclic maxM sAM sM'A sM'q EqQ_NA regQ q'A cAA. +rewrite -[[~: A, Q]]/(gval A0) -/Ms => cMsA0 cycA0 nsA0M. +have sA0A: A0 \subset A by rewrite commg_subl. +have EpA0: A0 \in 'E_p^1(A). + have abelA0 := abelemS sA0A abelA; have [pA0 _] := andP abelA0. + rewrite p1ElemE // !inE sA0A -(Ohm1_id abelA0) /=. + by rewrite (Ohm1_cyclic_pgroup_prime cycA0 pA0). +have defA0: 'C_A(Ms) = A0. + apply/eqP; rewrite eq_sym eqEcard subsetI sA0A cMsA0 (card_pnElem EpA0). + have pCAMs: p.-group 'C_A(Ms) := pgroupS (subsetIl A _) pA. + rewrite (card_pgroup pCAMs) leq_exp2l //= leqNgt. + apply: contra (Msigma_neq1 maxM) => dimCAMs. + rewrite eq_sym -regA (sameP eqP setIidPl) centsC (sameP setIidPl eqP). + by rewrite eqEcard subsetIl (card_pnElem Ep2A) (card_pgroup pCAMs) leq_exp2l. +have EpA1: A1 \in 'E_p^1(A). + rewrite p1ElemE // !inE subsetIl -(eqn_pmul2l (ltnW p_gt1)). + by rewrite -{1}[p](card_pnElem EpA0) (dprod_card defA) (card_pnElem Ep2A) /=. +have defNA0: 'N(A0) = M by apply: mmax_normal. +have not_cA0Q: ~~ (Q \subset 'C(A0)). + apply: contra ntA0 => cA0Q. + by rewrite -subG1 -tiA01 !subsetI subxx sA0A centsC cA0Q. +have rqM: 'r_q(M) = 1%N by apply/eqP; case/and3P: t1Mq. +have q'CA0: q^'.-group 'C(A0). + have [S sylS sQS] := Sylow_superset (subset_trans sQE sEM) qQ. + have qS := pHall_pgroup sylS; rewrite -(p_rank_Sylow sylS) in rqM. + have cycS: cyclic S by rewrite (odd_pgroup_rank1_cyclic qS) ?mFT_odd ?rqM. + have ntS: S :!=: 1 by rewrite -rank_gt0 (rank_pgroup qS) rqM. + have defS1: 'Ohm_1(S) = Q. + apply/eqP; rewrite eq_sym eqEcard -{1}(Ohm1_id abelQ) OhmS //=. + by rewrite (card_pnElem EqQ) (Ohm1_cyclic_pgroup_prime cycS qS). + have sylSC: q.-Sylow('C(A0)) 'C_S(A0). + by rewrite (Hall_setI_normal _ sylS) // -defNA0 cent_normal. + rewrite -partG_eq1 ?cardG_gt0 // -(card_Hall sylSC) -trivg_card1 /=. + by rewrite setIC TI_Ohm1 // defS1 setIC prime_TIg ?(card_pnElem EqQ). +do 2?split=> //. + have: ~~ q^'.-group Q by rewrite /pgroup (card_pnElem EqQ) pnatE ?inE ?negbK. + apply: contra; case/imsetP=> x _ defA01. + rewrite defA01 centJ pgroupJ in q'CA0. + by apply: pgroupS q'CA0; rewrite centsC subsetIr. +have [S sylS sAS] := Sylow_superset (subsetT A) pA. +have [cSS | not_cSS] := boolP (abelian S). + have solE := sigma_compl_sol hallE. + have [E1 hallE1 sQE1] := Hall_superset solE sQE (pi_pnat qQ t1Mq). + have [E3 hallE3] := Hall_exists \tau3(M) solE. + have [E2 _ complEi] := ex_tau2_compl hallE hallE1 hallE3. + have [_ _ _ reg1Z] := abelian_tau2 maxM complEi t2Mp Ep2A sylS sAS cSS. + have E1Q: Q \in 'E^1(E1). + by apply/nElemP; exists q; rewrite // !inE sQE1 abelQ dimQ. + rewrite (subset_trans (reg1Z Q E1Q regQ)) ?subIset // in not_cA0Q. + by rewrite centS ?orbT // (subset_trans sA0A). +have pS := pHall_pgroup sylS. +have [_ _ not_cent_reg _] := nonabelian_tau2 maxM hallE t2Mp Ep2A pS not_cSS. +case: (not_cent_reg A1); rewrite // 2!inE (subsetP (pnElemS p 1 sAE)) // andbT. +by rewrite -val_eqE /= defA0 eq_sym; apply/(TIp1ElemP EpA0 EpA1). +Qed. + +(* This is B & G, Corollary 12.10(a). *) +Corollary sigma'_nil_abelian M N : + M \in 'M -> N \subset M -> \sigma(M)^'.-group N -> nilpotent N -> abelian N. +Proof. +move=> maxM sNM sM'N /nilpotent_Fitting defN. +apply/center_idP; rewrite -{2}defN -{defN}(center_bigdprod defN). +apply: eq_bigr => p _; apply/center_idP; set P := 'O_p(N). +have [-> | ntP] := eqVneq P 1; first exact: abelian1. +have [pP sPN]: p.-group P /\ P \subset N by rewrite pcore_sub pcore_pgroup. +have{sPN sNM sM'N} [sPM sM'P] := (subset_trans sPN sNM, pgroupS sPN sM'N). +have{sPM sM'P} [E hallE sPE] := Hall_superset (mmax_sol maxM) sPM sM'P. +suffices [S sylS cSS]: exists2 S : {group gT}, p.-Sylow(E) S & abelian S. + by have [x _ sPS] := Sylow_subJ sylS sPE pP; rewrite (abelianS sPS) ?abelianJ. +have{N P sPE pP ntP} piEp: p \in \pi(E). + by rewrite (piSg sPE) // -p_rank_gt0 -rank_pgroup // rank_gt0. +rewrite (partition_pi_sigma_compl maxM hallE) orbCA orbC -orbA in piEp. +have [[E1 hallE1] [E3 hallE3]] := ex_tau13_compl hallE. +have [E2 hallE2 complEi] := ex_tau2_compl hallE hallE1 hallE3. +have{complEi} [_ _ [cycE1 cycE3] _ _] := sigma_compl_context maxM complEi. +have{piEp} [t1p | t3p | t2p] := or3P piEp. +- have [S sylS] := Sylow_exists p E1. + exists S; first exact: subHall_Sylow hallE1 t1p sylS. + exact: abelianS (pHall_sub sylS) (cyclic_abelian cycE1). +- have [S sylS] := Sylow_exists p E3. + exists S; first exact: subHall_Sylow hallE3 t3p sylS. + exact: abelianS (pHall_sub sylS) (cyclic_abelian cycE3). +have [s'p rpM] := andP t2p; have [S sylS] := Sylow_exists p E; exists S => //. +have sylS_M := subHall_Sylow hallE s'p sylS. +have [A _ Ep2A] := ex_tau2Elem hallE t2p. +by have [/(_ S sylS_M)[]] := tau2_context maxM t2p Ep2A. +Qed. + +(* This is B & G, Corollary 12.10(b), first assertion. *) +Corollary der_mmax_compl_abelian M E : + M \in 'M -> \sigma(M)^'.-Hall(M) E -> abelian E^`(1). +Proof. +move=> maxM hallE; have [sEM s'E _] := and3P hallE. +have sE'E := der_sub 1 E; have sE'M := subset_trans sE'E sEM. +exact: sigma'_nil_abelian (pgroupS _ s'E) (der1_sigma_compl_nil maxM hallE). +Qed. + +(* This is B & G, Corollary 12.10(b), second assertion. *) +(* Note that we do not require the full decomposition of the complement. *) +Corollary tau2_compl_abelian M E E2 : + M \in 'M -> \sigma(M)^'.-Hall(M) E -> \tau2(M).-Hall(E) E2 -> abelian E2. +Proof. +move: E2 => F2 maxM hallE hallF2; have [sEM s'E _] := and3P hallE. +have [[E1 hallE1] [E3 hallE3]] := ex_tau13_compl hallE. +have [E2 hallE2 complEi] := ex_tau2_compl hallE hallE1 hallE3. +have solE: solvable E := sigma_compl_sol hallE. +have{solE hallF2} [x _ ->{F2}] := Hall_trans solE hallF2 hallE2. +have [-> | ntE] := eqsVneq E2 1; rewrite {x}abelianJ ?abelian1 //. +have [[p p_pr rpE2] [sE2E t2E2 _]] := (rank_witness E2, and3P hallE2). +have piE2p: p \in \pi(E2) by rewrite -p_rank_gt0 -rpE2 rank_gt0. +have t2p := pnatPpi t2E2 piE2p; have [A Ep2A _] := ex_tau2Elem hallE t2p. +have [_ abelA _] := pnElemP Ep2A; have [pA _] := andP abelA. +have [S /= sylS sAS] := Sylow_superset (subsetT A) pA. +have [cSS | not_cSS] := boolP (abelian S). + by have [[_ cE2E2] _ _ _] := abelian_tau2 maxM complEi t2p Ep2A sylS sAS cSS. +have pS := pHall_pgroup sylS. +have [def_t2 _ _ _] := nonabelian_tau2 maxM hallE t2p Ep2A pS not_cSS. +apply: sigma'_nil_abelian (subset_trans _ sEM) (pgroupS _ s'E) _ => //. +by rewrite (eq_pgroup _ def_t2) in t2E2; exact: pgroup_nil t2E2. +Qed. + +(* This is B & G, Corollary 12.10(c). *) +(* We do not really need a full decomposition of the complement in the first *) +(* part, but this reduces the number of assumptions. *) +Corollary tau1_cent_tau2Elem_factor M E p A : + M \in 'M -> \sigma(M)^'.-Hall(M) E -> p \in \tau2(M) -> A \in 'E_p^2(E) -> + [/\ forall E1 E2 E3, sigma_complement M E E1 E2 E3 -> E3 * E2 \subset 'C_E(A), + 'C_E(A) <| E + & \tau1(M).-group (E / 'C_E(A))]. +Proof. +move=> maxM hallE t2p Ep2A; have sEM: E \subset M := pHall_sub hallE. +have nsAE: A <| E by case/(tau2_compl_context maxM): Ep2A => //; case. +have [sAE nAE]: A \subset E /\ E \subset 'N(A) := andP nsAE. +have nsCAE: 'C_E(A) <| E by rewrite norm_normalI ?norms_cent. +have [[E1 hallE1] [E3 hallE3]] := ex_tau13_compl hallE. +have [E2 hallE2 complEi] := ex_tau2_compl hallE hallE1 hallE3. +have{hallE1} [t1E1 sE3E] := (pHall_pgroup hallE1, pHall_sub hallE3). +have{nsAE} sAE2: A \subset E2. + apply: subset_trans (pcore_max _ nsAE) (pcore_sub_Hall hallE2). + by apply: pi_pnat t2p; case/pnElemP: Ep2A => _; case/andP. +have{complEi} defE: (E3 ><| E2) ><| E1 = E. + by case/sigma_compl_context: complEi => // _ _ _ [_ ->]. +have [[K _ defK _] _ _ _] := sdprodP defE; rewrite defK in defE. +have nsKE: K <| E by case/sdprod_context: defE. +have [[sKE nKE] [_ mulE32 nE32 tiE32]] := (andP nsKE, sdprodP defK). +have{sE3E} sK_CEA: K \subset 'C_E(A). + have cE2E2: abelian E2 := tau2_compl_abelian maxM hallE hallE2. + rewrite subsetI sKE -mulE32 mulG_subG (centsS sAE2 cE2E2) (sameP commG1P eqP). + rewrite -subG1 -tiE32 subsetI commg_subl (subset_trans sAE2) //=. + by rewrite (subset_trans _ sAE2) // commg_subr (subset_trans sE3E). +split=> // [_ F2 F3 [_ _ hallF2 hallF3 _] | ]. + have solE: solvable E := solvableS sEM (mmax_sol maxM). + have [x2 Ex2 ->] := Hall_trans solE hallF2 hallE2. + have [x3 Ex3 ->] := Hall_trans solE hallF3 hallE3. + rewrite mulG_subG !sub_conjg !(normsP (normal_norm nsCAE)) ?groupV //. + by rewrite -mulG_subG mulE32. +have [f <-] := homgP (homg_quotientS nKE (normal_norm nsCAE) sK_CEA). +by rewrite morphim_pgroup // /pgroup -divg_normal // -(sdprod_card defE) mulKn. +Qed. + +(* This is B & G, Corollary 12.10(d). *) +Corollary norm_noncyclic_sigma M p P : + M \in 'M -> p \in \sigma(M) -> p.-group P -> P \subset M -> ~~ cyclic P -> + 'N(P) \subset M. +Proof. +move=> maxM sMp pP sPM ncycP. +have [A Ep2A]: exists A, A \in 'E_p^2(P). + by apply/p_rank_geP; rewrite ltnNge -odd_pgroup_rank1_cyclic ?mFT_odd. +have [[sAP _ _] Ep2A_M] := (pnElemP Ep2A, subsetP (pnElemS p 2 sPM) A Ep2A). +have sCAM: 'C(A) \subset M by case/p2Elem_mmax: Ep2A_M. +have [_ _ <- //] := sigma_group_trans maxM sMp pP. +by rewrite mulG_subG subsetIl (subset_trans (centS sAP)). +Qed. + +(* This is B & G, Corollary 12.10(e). *) +Corollary cent1_nreg_sigma_uniq M (Ms := M`_\sigma) x : + M \in 'M -> x \in M^# -> \tau2(M).-elt x -> 'C_Ms[x] != 1 -> + 'M('C[x]) = [set M]. +Proof. +move=> maxM /setD1P[ntx]; rewrite -cycle_subG => sMX t2x. +apply: contraNeq => MCx_neqM. +have{MCx_neqM} [H maxCxH neqHM]: exists2 H, H \in 'M('C[x]) & H \notin [set M]. + apply/subsetPn; have [H MCxH] := mmax_exists (mFT_cent1_proper ntx). + by rewrite eqEcard cards1 (cardD1 H) MCxH andbT in MCx_neqM. +have sCxH: 'C[x] \subset H by case/setIdP: maxCxH. +have s'x: \sigma(M)^'.-elt x by apply: sub_pgroup t2x => p; case/andP. +have [E hallE sXE] := Hall_superset (mmax_sol maxM) sMX s'x. +have [sEM solE] := (pHall_sub hallE, sigma_compl_sol hallE). +have{sXE} [E2 hallE2 sXE2] := Hall_superset solE sXE t2x. +pose p := pdiv #[x]. +have t2p: p \in \tau2(M) by rewrite (pnatPpi t2x) ?pi_pdiv ?order_gt1. +have [A Ep2A sAE2]: exists2 A, A \in 'E_p^2(M) & A \subset E2. + have [A Ep2A_E EpA] := ex_tau2Elem hallE t2p. + have [sAE abelA _] := pnElemP Ep2A_E; have [pA _] := andP abelA. + have [z Ez sAzE2] := Hall_Jsub solE hallE2 sAE (pi_pnat pA t2p). + by exists (A :^ z)%G; rewrite // -(normsP (normsG sEM) z Ez) pnElemJ. +have cE2E2: abelian E2 := tau2_compl_abelian maxM hallE hallE2. +have cxA: A \subset 'C[x] by rewrite -cent_cycle (sub_abelian_cent2 cE2E2). +have maxAH: H \in 'M(A) :\ M by rewrite inE neqHM (subsetP (mmax_ofS cxA)). +have [_ _ _ tiMsMA _] := tau2_context maxM t2p Ep2A. +by rewrite -subG1 -(tiMsMA H maxAH) setIS. +Qed. + +(* This is B & G, Lemma 12.11. *) +Lemma primes_norm_tau2Elem M E p A Mstar : + M \in 'M -> \sigma(M)^'.-Hall(M) E -> p \in \tau2(M) -> A \in 'E_p^2(E) -> + Mstar \in 'M('N(A)) -> + [/\ (*a*) {subset \tau2(M) <= [predD \sigma(Mstar) & \beta(Mstar)]}, + (*b*) [predU \tau1(Mstar) & \tau2(Mstar)].-group (E / 'C_E(A)) + & (*c*) forall q, q \in \pi(E / 'C_E(A)) -> q \in \pi('C_E(A)) -> + [/\ q \in \tau2(Mstar), + exists2 P, P \in 'Syl_p(G) & P <| Mstar + & exists Q, [/\ Q \in 'Syl_q(G), Q \subset Mstar & abelian Q]]]. +Proof. +move=> maxM hallE t2Mp Ep2A; move: Mstar. +have [sAE abelA dimA] := pnElemP Ep2A; have [pA cAA _] := and3P abelA. +have ntA: A :!=: 1 by exact: (nt_pnElem Ep2A). +have [sEM solE] := (pHall_sub hallE, sigma_compl_sol hallE). +have [_ nsCA_E t1CEAb] := tau1_cent_tau2Elem_factor maxM hallE t2Mp Ep2A. +have [sAM nCA_E] := (subset_trans sAE sEM, normal_norm nsCA_E). +have part_a H: + H \in 'M('N(A)) -> {subset \tau2(M) <= [predD \sigma(H) & \beta(H)]}. +- case/setIdP=> maxH sNA_H q t2Mq. + have sCA_H: 'C(A) \subset H := subset_trans (cent_sub A) sNA_H. + have sAH := subset_trans cAA sCA_H. + have sHp: p \in \sigma(H). + have [// | t2Hp] := orP (prime_class_mmax_norm maxH pA sNA_H). + apply: contraLR sNA_H => sH'p. + have sH'A: \sigma(H)^'.-group A by apply: pi_pnat pA _. + have [F hallF sAF] := Hall_superset (mmax_sol maxH) sAH sH'A. + have Ep2A_F: A \in 'E_p^2(F) by apply/pnElemP. + by have [_ [_ _ ->]]:= tau2_compl_context maxH hallF t2Hp Ep2A_F. + rewrite inE /= -predI_sigma_beta //= negb_and /= orbC. + have [-> /= _] := tau2_not_beta maxM t2Mq. + have [B Eq2B]: exists B, B \in 'E_q^2('C(A)). + have [E2 hallE2 sAE2] := Hall_superset solE sAE (pi_pnat pA t2Mp). + have cE2E2: abelian E2 := tau2_compl_abelian maxM hallE hallE2. + have [Q sylQ] := Sylow_exists q E2; have sQE2 := pHall_sub sylQ. + have sylQ_E := subHall_Sylow hallE2 t2Mq sylQ. + apply/p_rank_geP; apply: leq_trans (p_rankS q (centsS sAE2 cE2E2)). + rewrite -(p_rank_Sylow sylQ) (p_rank_Sylow sylQ_E). + by move: t2Mq; rewrite (tau2E hallE) => /andP[_ /eqP->]. + have [cAB abelB dimB] := pnElemP Eq2B; have sBH := subset_trans cAB sCA_H. + have{Eq2B} Eq2B: B \in 'E_q^2(H) by apply/pnElemP. + have rqHgt1: 'r_q(H) > 1 by apply/p_rank_geP; exists B. + have piHq: q \in \pi(H) by rewrite -p_rank_gt0 ltnW. + rewrite partition_pi_mmax // in piHq. + case/or4P: piHq rqHgt1 => // [|t2Hq _|]; try by case/and3P=> _ /eqP->. + have [_ _ regB _ _] := tau2_context maxH t2Hq Eq2B. + case/negP: ntA; rewrite -subG1 -regB subsetI centsC cAB andbT. + by rewrite (sub_Hall_pcore (Msigma_Hall maxH)) // (pi_pgroup pA). +have part_b H: + H \in 'M('N(A)) -> [predU \tau1(H) & \tau2(H)].-group (E / 'C_E(A)). +- move=> maxNA_H; have [maxH sNA_H] := setIdP maxNA_H. + have [/= bH'p sHp] := andP (part_a H maxNA_H p t2Mp). + have sCA_H: 'C(A) \subset H := subset_trans (cent_sub A) sNA_H. + have sAH := subset_trans cAA sCA_H. + apply/pgroupP=> q q_pr q_dv_CEAb; apply: contraR bH'p => t12H'q. + have [Q sylQ] := Sylow_exists q E; have [sQE qQ _] := and3P sylQ. + have nsAE: A <| E by case/(tau2_compl_context maxM): Ep2A => //; case. + have nAE := normal_norm nsAE; have nAQ := subset_trans sQE nAE. + have sAQ_A: [~: A, Q] \subset A by rewrite commg_subl. + have ntAQ: [~: A, Q] != 1. + apply: contraTneq q_dv_CEAb => /commG1P cAQ. + have nCEA_Q := subset_trans sQE nCA_E. + rewrite -p'natE // -partn_eq1 ?cardg_gt0 //. + rewrite -(card_Hall (quotient_pHall nCEA_Q sylQ)) -trivg_card1 -subG1. + by rewrite quotient_sub1 // subsetI sQE centsC. + have sQH: Q \subset H := subset_trans nAQ sNA_H. + have sHsubH' r X: + r \in \sigma(H) -> X \subset H -> r.-group X -> X \subset H^`(1). + + move=> sHr sXH rX; apply: subset_trans (Msigma_der1 maxH). + by rewrite (sub_Hall_pcore (Msigma_Hall maxH)) // (pi_pgroup rX sHr). + have sAH': A \subset H^`(1) by apply: sHsubH' pA. + have{t12H'q} sQH': Q \subset H^`(1). + have [sHq | sH'q] := boolP (q \in \sigma(H)); first exact: sHsubH' qQ. + have{sH'q} sH'Q: \sigma(H)^'.-group Q by apply: (pi_pnat qQ). + have{sH'Q} [F hallF sQF] := Hall_superset (mmax_sol maxH) sQH sH'Q. + have [-> | ntQ] := eqsVneq Q 1; first exact: sub1G. + have{t12H'q} t3Hq: q \in \tau3(H). + apply: implyP t12H'q; rewrite implyNb -orbA. + rewrite -(partition_pi_sigma_compl maxH hallF) -p_rank_gt0. + by rewrite (leq_trans _ (p_rankS q sQF)) // -rank_pgroup // rank_gt0. + have solF: solvable F := sigma_compl_sol hallF. + have [F3 hallF3 sQF3] := Hall_superset solF sQF (pi_pnat qQ t3Hq). + have [[F1 hallF1] _] := ex_tau13_compl hallF. + have [F2 _ complFi] := ex_tau2_compl hallF hallF1 hallF3. + have [[sF3H' _] _ _ _ _] := sigma_compl_context maxH complFi. + exact: subset_trans sQF3 (subset_trans sF3H' (dergS 1 (pHall_sub hallF))). + have hallHb: \beta(H).-Hall(H) H`_\beta := Mbeta_Hall maxH. + have nilH'b: nilpotent (H^`(1) / H`_\beta) := Mbeta_quo_nil maxH. + have{nilH'b} sAQ_Hb: [~: A, Q] \subset H`_\beta. + rewrite -quotient_cents2 ?(subset_trans _ (gFnorm _ _)) // centsC. + rewrite (sub_nilpotent_cent2 nilH'b) ?quotientS ?coprime_morph //. + rewrite (pnat_coprime (pi_pnat pA t2Mp) (pi_pnat qQ _)) ?tau2'1 //. + by rewrite (pnatPpi t1CEAb) // mem_primes q_pr cardG_gt0. + rewrite (pnatPpi (pHall_pgroup hallHb)) // (piSg sAQ_Hb) // -p_rank_gt0. + by rewrite -(rank_pgroup (pgroupS sAQ_A pA)) rank_gt0. +move=> H maxNA_H; split; last 1 [move=> q piCEAb_q piCEAq] || by auto. +have [_ sHp]: _ /\ p \in \sigma(H) := andP (part_a H maxNA_H p t2Mp). +have{maxNA_H} [maxH sNA_H] := setIdP maxNA_H. +have{sNA_H} sCA_H: 'C(A) \subset H := subset_trans (cent_sub A) sNA_H. +have{piCEAq} [Q0 EqQ0]: exists Q0, Q0 \in 'E_q^1('C_E(A)). + by apply/p_rank_geP; rewrite p_rank_gt0. +have [sQ0_CEA abelQ0 dimQ0]:= pnElemP EqQ0; have [qQ0 cQ0Q0 _] := and3P abelQ0. +have{sQ0_CEA} [sQ0E cAQ0]: Q0 \subset E /\ Q0 \subset 'C(A). + by apply/andP; rewrite -subsetI. +have ntQ0: Q0 :!=: 1 by apply: (nt_pnElem EqQ0). +have{t1CEAb} t1Mq: q \in \tau1(M) := pnatPpi t1CEAb piCEAb_q. +have [Q sylQ sQ0Q] := Sylow_superset sQ0E qQ0; have [sQE qQ _] := and3P sylQ. +have [E1 hallE1 sQE1] := Hall_superset solE sQE (pi_pnat qQ t1Mq). +have rqE: 'r_q(E) = 1%N. + by move: t1Mq; rewrite (tau1E maxM hallE) andbA andbC; case: eqP. +have cycQ: cyclic Q. + by rewrite (odd_pgroup_rank1_cyclic qQ) ?mFT_odd // (p_rank_Sylow sylQ) rqE. +have sCAE: 'C(A) \subset E by case/(tau2_compl_context maxM): Ep2A => // _ []. +have{sCAE} sylCQA: q.-Sylow('C(A)) 'C_Q(A). + by apply: Hall_setI_normal sylQ; rewrite /= -(setIidPr sCAE). +have{sylCQA} defNA: 'C(A) * 'N_('N(A))(Q0) = 'N(A). + apply/eqP; rewrite eqEsubset mulG_subG cent_sub subsetIl /=. + rewrite -{1}(Frattini_arg (cent_normal A) sylCQA) mulgS ?setIS ?char_norms //. + by rewrite (sub_cyclic_char Q0 (cyclicS (subsetIl Q _) cycQ)) subsetI sQ0Q. +have [L maxNQ0_L]: {L | L \in 'M('N(Q0))}. + by apply: mmax_exists; rewrite mFT_norm_proper ?(mFT_pgroup_proper qQ0). +have{maxNQ0_L} [maxL sNQ0_L] := setIdP maxNQ0_L. +have sCQ0_L: 'C(Q0) \subset L := subset_trans (cent_sub Q0) sNQ0_L. +have sAL: A \subset L by rewrite (subset_trans _ sCQ0_L) // centsC. +have sCA_L: 'C(A) \subset L. + by have /p2Elem_mmax[]: A \in 'E_p^2(L) by apply/pnElemP. +have{sCA_L defNA} maxNA_L: L \in 'M('N(A)). + by rewrite inE maxL -defNA setIC mul_subG // subIset ?sNQ0_L. +have t2Lq: q \in \tau2(L). + have /orP[sLq | //] := prime_class_mmax_norm maxL qQ0 sNQ0_L. + by have /orP[/andP[/negP] | ] := pnatPpi (part_b L maxNA_L) piCEAb_q. +have [cQQ [/= sL'q _]] := (cyclic_abelian cycQ, andP t2Lq). +have sQL: Q \subset L := subset_trans (centsS sQ0Q cQQ) sCQ0_L. +have [F hallF sQF] := Hall_superset (mmax_sol maxL) sQL (pi_pnat qQ sL'q). +have [B Eq2B _] := ex_tau2Elem hallF t2Lq. +have [_ sLp]: _ /\ p \in \sigma(L) := andP (part_a L maxNA_L p t2Mp). +have{H sHp maxH sCA_H} <-: L :=: H. + have sLHp: p \in [predI \sigma(L) & \sigma(H)] by apply/andP. + have [_ transCA _] := sigma_group_trans maxH sHp pA. + set S := finset _ in transCA; have sAH := subset_trans cAA sCA_H. + suffices [SH SL]: gval H \in S /\ gval L \in S. + have [c cAc -> /=]:= atransP2 transCA SH SL. + by rewrite conjGid // (subsetP sCA_H). + have [_ _ _ TIsL] := tau2_compl_context maxL hallF t2Lq Eq2B. + apply/andP; rewrite !inE sAH sAL orbit_refl orbit_sym /= andbT. + by apply: contraLR sLHp => /TIsL[] // _ ->. +split=> //. + exists ('O_p(L`_\sigma))%G; last by rewrite /= -pcoreI pcore_normal. + rewrite inE (subHall_Sylow (Msigma_Hall_G maxL) sLp) //. + by rewrite nilpotent_pcore_Hall // (tau2_Msigma_nil maxL t2Lq). +have [Q1 sylQ1 sQQ1] := Sylow_superset (subsetT Q) qQ. +have [sQ0Q1 qQ1] := (subset_trans sQ0Q sQQ1, pHall_pgroup sylQ1). +have [cQ1Q1 | not_cQ1Q1] := boolP (abelian Q1). + by exists Q1; rewrite inE (subset_trans (centsS sQ0Q1 cQ1Q1)). +have [_ _ regB [F0 /=]] := nonabelian_tau2 maxL hallF t2Lq Eq2B qQ1 not_cQ1Q1. +have{regB} ->: 'C_B(L`_\sigma) = Q0; last move=> defF _. + apply: contraTeq sCQ0_L => neqQ0B; case: (regB Q0) => //. + by rewrite 2!inE eq_sym neqQ0B; apply/pnElemP; rewrite (subset_trans sQ0Q). +have{defF} defQ: Q0 \x (F0 :&: Q) = Q. + rewrite dprodEsd ?(centSS (subsetIr F0 Q) sQ0Q) //. + by rewrite (sdprod_modl defF sQ0Q) (setIidPr sQF). +have [[/eqP/idPn//] | [_ eqQ0Q]] := cyclic_pgroup_dprod_trivg qQ cycQ defQ. +have nCEA_Q := subset_trans sQE nCA_E. +case/idPn: piCEAb_q; rewrite -p'natEpi -?partn_eq1 ?cardG_gt0 //. +rewrite -(card_Hall (quotient_pHall nCEA_Q sylQ)) -trivg_card1 -subG1. +by rewrite quotient_sub1 // subsetI sQE -eqQ0Q. +Qed. + +(* This is a generalization of B & G, Theorem 12.12. *) +(* In the B & G text, Theorem 12.12 only establishes the type F structure *) +(* for groups of type I, whereas it is required for the derived groups of *) +(* groups of type II (in the sense of Peterfalvi). Indeed this is exactly *) +(* what is stated in Lemma 15.15(e) and then Theorem B(3). The proof of *) +(* 15.15(c) cites 12.12 in the type I case (K = 1) and then loosely invokes *) +(* a "short and easy argument" inside the proof of 12.12 for the K != 1 case. *) +(* In fact, this involves copying roughly 25% of the proof, whereas the proof *) +(* remains essentially unchanged when Theorem 12.12 is generalized to a *) +(* normal Hall subgroup of E as below. *) +(* Also, we simplify the argument for central tau2 Sylow subgroup S of U by *) +(* by replacing the considerations on the abelian structure of S by a *) +(* comparison of Mho^n-1(S) and Ohm_1(S) (with exponent S = p ^ n), as the *) +(* former is needed anyway to prove regularity when S is not homocyclic. *) +Theorem FTtypeF_complement M (Ms := M`_\sigma) E U : + M \in 'M -> \sigma(M)^'.-Hall(M) E -> Hall E U -> U <| E -> U :!=: 1 -> + {in U^#, forall e, [predU \tau1(M) & \tau3(M)].-elt e -> 'C_Ms[e] = 1} -> + [/\ (*a*) exists A0 : {group gT}, + [/\ A0 <| U, abelian A0 & {in Ms^#, forall x, 'C_U[x] \subset A0}] + & (*b*) exists E0 : {group gT}, + [/\ E0 \subset U, exponent E0 = exponent U + & [Frobenius Ms <*> E0 = Ms ><| E0]]]. +Proof. +set p13 := predU _ _ => maxM hallE /Hall_pi hallU nsUE ntU regU13. +have [[E1 hallE1] [E3 hallE3]] := ex_tau13_compl hallE. +have [E2 hallE2 complEi] := ex_tau2_compl hallE hallE1 hallE3. +have [[sE1E _] [sE2E t2E2 _]] := (andP hallE1, and3P hallE2). +have [[_ nsE3E] _ [cycE1 _] [defE _] _] := sigma_compl_context maxM complEi. +have [[[sE3E t3E3 _][_ nE3E]] [sUE _]] := (and3P hallE3, andP nsE3E, andP nsUE). +have defM: Ms ><| E = M := sdprod_sigma maxM hallE. +have [nsMsM sEM mulMsE nMsE tiMsE] := sdprod_context defM. +have ntMs: Ms != 1 := Msigma_neq1 maxM. +have{defM} defMsU: Ms ><| U = Ms <*> U := sdprod_subr defM sUE. +pose U2 := (E2 :&: U)%G. +have hallU2: \tau2(M).-Hall(U) U2 := Hall_setI_normal nsUE hallE2. +have [U2_1 | ntU2] := eqsVneq U2 1. + have frobMsU: [Frobenius Ms <*> U = Ms ><| U]. + apply/Frobenius_semiregularP=> // e Ue. + apply: regU13 => //; case/setD1P: Ue => _; apply: mem_p_elt. + have: \tau2(M)^'.-group U. + by rewrite -partG_eq1 -(card_Hall hallU2) U2_1 cards1. + apply: sub_in_pnat => p /(piSg sUE). + by rewrite (partition_pi_sigma_compl maxM hallE) orbCA => /orP[] // /idPn. + split; [exists 1%G; rewrite normal1 abelian1 | by exists U]. + by split=> //= x Ux; rewrite (Frobenius_reg_compl frobMsU). +have [[sU2U t2U2 _] [p p_pr rU2]] := (and3P hallU2, rank_witness U2). +have piU2p: p \in \pi(U2) by rewrite -p_rank_gt0 -rU2 rank_gt0. +have t2p: p \in \tau2(M) := pnatPpi t2U2 piU2p. +have [A Ep2A Ep2A_M] := ex_tau2Elem hallE t2p. +have [sAE abelA _] := pnElemP Ep2A; have{abelA} [pA cAA _] := and3P abelA. +have [S sylS sAS] := Sylow_superset (subsetT A) pA. +have [cSS | not_cSS] := boolP (abelian S); last first. + have [_] := nonabelian_tau2 maxM hallE t2p Ep2A (pHall_pgroup sylS) not_cSS. + set A0 := ('C_A(_))%G => [] [oA0 _] _ {defE} [E0 defE regE0]. + have [nsA0E sE0E mulAE0 nAE0 tiAE0] := sdprod_context defE. + have [P sylP] := Sylow_exists p U; have [sPU _] := andP sylP. + have sylP_E := subHall_Sylow hallU (piSg sU2U piU2p) sylP. + have pA0: p.-group A0 by rewrite /pgroup oA0 pnat_id. + have sA0P: A0 \subset P. + by apply: subset_trans (pcore_sub_Hall sylP_E); apply: pcore_max. + have sA0U: A0 \subset U := subset_trans sA0P sPU. + pose U0 := (E0 :&: U)%G. + have defU: A0 ><| U0 = U by rewrite (sdprod_modl defE) // (setIidPr sUE). + have piU0p: p \in \pi(U0). + have:= lognSg p sAE; rewrite (card_pnElem Ep2A) pfactorK //. + rewrite -logn_part -(card_Hall sylP_E) (card_Hall sylP) logn_part. + rewrite -(sdprod_card defU) oA0 lognM // ?prime_gt0 // logn_prime // eqxx. + by rewrite ltnS logn_gt0. + have defM0: Ms ><| U0 = Ms <*> U0 := sdprod_subr defMsU (subsetIr _ _). + have frobM0: [Frobenius Ms <*> U0 = Ms ><| U0]. + apply/Frobenius_semiregularP=> // [|e /setD1P[nte /setIP[E0e Ue]]]. + by rewrite -rank_gt0 (leq_trans _ (p_rank_le_rank p _)) ?p_rank_gt0. + have [ | ] := boolP (p13.-elt e); first by apply: regU13; rewrite !inE nte. + apply: contraNeq => /trivgPn[x /setIP[Ms_x cex] ntx]. + apply/pgroupP=> q q_pr q_dv_x ; rewrite inE /= (regE0 x) ?inE ?ntx //. + rewrite mem_primes q_pr cardG_gt0 (dvdn_trans q_dv_x) ?order_dvdG //. + by rewrite inE E0e cent1C. + have [nsA0U sU0U _ _ _] := sdprod_context defU. + split; [exists A0 | exists U0]. + split=> // [|x Ms_x]; first by rewrite (abelianS (subsetIl A _) cAA). + rewrite -(sdprodW defU) -group_modl ?(Frobenius_reg_compl frobM0) ?mulg1 //. + by rewrite subIset //= orbC -cent_set1 centS // sub1set; case/setD1P: Ms_x. + split=> //; apply/eqP; rewrite eqn_dvd exponentS //=. + rewrite -(partnC p (exponent_gt0 U0)) -(partnC p (exponent_gt0 U)). + apply: dvdn_mul; last first. + rewrite (partn_exponentS sU0U) // -(sdprod_card defU) partnM ?cardG_gt0 //. + by rewrite part_p'nat ?pnatNK // mul1n dvdn_part. + have cPP: abelian P. + have [/(_ P)[] //] := tau2_context maxM t2p Ep2A_M. + by apply: subHall_Sylow hallE _ sylP_E; case/andP: t2p. + have defP: A0 \x (U0 :&: P) = P. + rewrite dprodEsd ?(sub_abelian_cent2 cPP) ?subsetIr //. + by rewrite (sdprod_modl defU) // (setIidPr sPU). + have sylP_U0: p.-Sylow(U0) (U0 :&: P). + rewrite pHallE subsetIl /= -(eqn_pmul2l (cardG_gt0 A0)). + rewrite (dprod_card defP) (card_Hall sylP) -(sdprod_card defU). + by rewrite partnM // part_pnat_id. + rewrite -(exponent_Hall sylP) -(dprod_exponent defP) (exponent_Hall sylP_U0). + rewrite dvdn_lcm (dvdn_trans (exponent_dvdn A0)) //= oA0. + apply: contraLR piU0p; rewrite -p'natE // -partn_eq1 // partn_part //. + by rewrite partn_eq1 ?exponent_gt0 // pnat_exponent -p'groupEpi. +have{t2p Ep2A sylS sAS cSS} [[nsE2E cE2E2] hallE2_G _ _] + := abelian_tau2 maxM complEi t2p Ep2A sylS sAS cSS. +clear p p_pr rU2 piU2p A S Ep2A_M sAE pA cAA. +have nsU2U: U2 <| U by rewrite (normalS sU2U sUE) ?normalI. +have cU2U2: abelian U2 := abelianS (subsetIl _ _) cE2E2. +split. + exists U2; rewrite -set1gE; split=> // x /setDP[Ms_x ntx]. + rewrite (sub_normal_Hall hallU2) ?subsetIl //=. + apply: sub_in_pnat (pgroup_pi _) => q /(piSg (subsetIl U _))/(piSg sUE). + rewrite (partition_pi_sigma_compl maxM) // orbCA => /orP[] // t13q. + rewrite mem_primes => /and3P[q_pr _ /Cauchy[] // y /setIP[Uy cxy] oy]. + case/negP: ntx; rewrite -(regU13 y); first by rewrite inE Ms_x cent1C. + by rewrite !inE -order_gt1 oy prime_gt1. + by rewrite /p_elt oy pnatE. +pose sylU2 S := (S :!=: 1) && Sylow U2 S. +pose cyclicRegular Z S := + [/\ Z <| U, cyclic Z, 'C_Ms('Ohm_1(Z)) = 1 & exponent Z = exponent S]. +suffices /fin_all_exists[Z_ Z_P] S: exists Z, sylU2 S -> cyclicRegular Z S. + pose Z2 := <<\bigcup_(S | sylU2 S) Z_ S>>. + have sZU2: Z2 \subset U2. + rewrite gen_subG; apply/bigcupsP=> S sylS. + have [[/andP[sZE _] _ _ eq_expZS] [_ _ sSU2 _]] := (Z_P S sylS, and4P sylS). + rewrite (sub_normal_Hall hallU2) // -pnat_exponent eq_expZS. + by rewrite pnat_exponent (pgroupS sSU2 t2U2). + have nZ2U: U \subset 'N(Z2). + by rewrite norms_gen ?norms_bigcup //; apply/bigcapsP => S /Z_P[/andP[]]. + have solU: solvable U := solvableS sUE (sigma_compl_sol hallE). + have [U31 hallU31] := Hall_exists \tau2(M)^' solU. + have [[sU31U t2'U31 _] t2Z2] := (and3P hallU31, pgroupS sZU2 t2U2). + pose U0 := (Z2 <*> U31)%G; have /joing_sub[sZ2U0 sU310] := erefl (gval U0). + have sU0U: U0 \subset U by rewrite join_subG (subset_trans sZU2). + have nsZ2U0: Z2 <| U0 by rewrite /normal sZ2U0 (subset_trans sU0U). + have defU0: Z2 * U31 = U0 by rewrite -norm_joinEr // (subset_trans sU31U). + have [hallZ2 hallU31_0] := coprime_mulpG_Hall defU0 t2Z2 t2'U31. + have expU0U: exponent U0 = exponent U. + have exp_t2c U' := partnC \tau2(M) (exponent_gt0 U'). + rewrite -(exp_t2c U) -(exponent_Hall hallU31) -(exponent_Hall hallU2). + rewrite -{}exp_t2c -(exponent_Hall hallU31_0) -(exponent_Hall hallZ2). + congr (_ * _)%N; apply/eqP; rewrite eqn_dvd exponentS //=. + apply/dvdn_partP=> [|p]; first exact: exponent_gt0. + have [S sylS] := Sylow_exists p U2; rewrite -(exponent_Hall sylS). + rewrite pi_of_exponent -p_rank_gt0 -(rank_Sylow sylS) rank_gt0 => ntS. + have{sylS} sylS: sylU2 S by rewrite /sylU2 ntS (p_Sylow sylS). + by have /Z_P[_ _ _ <-] := sylS; rewrite exponentS ?sub_gen ?(bigcup_max S). + exists U0; split=> //. + have ntU0: U0 :!=: 1 by rewrite trivg_exponent expU0U -trivg_exponent. + apply/Frobenius_semiregularP=> //; first by rewrite (sdprod_subr defMsU). + apply: semiregular_sym => x /setD1P[ntx Ms_x]; apply: contraNeq ntx. + rewrite -rank_gt0; have [p p_pr ->] := rank_witness [group of 'C_U0[x]]. + rewrite -in_set1 -set1gE p_rank_gt0 => piCp. + have [e /setIP[U0e cxe] oe]: {e | e \in 'C_U0[x] & #[e] = p}. + by move: piCp; rewrite mem_primes p_pr cardG_gt0; apply: Cauchy. + have nte: e != 1 by rewrite -order_gt1 oe prime_gt1. + have{piCp} piUp: p \in \pi(U). + by rewrite -pi_of_exponent -expU0U pi_of_exponent (piSg _ piCp) ?subsetIl. + have:= piSg sUE piUp; rewrite (partition_pi_sigma_compl maxM) // orbCA orbC. + case/orP=> [t13p | t2p]. + rewrite -(regU13 e) 1?inE ?Ms_x 1?cent1C //. + by rewrite inE nte (subsetP sU0U). + by rewrite /p_elt oe pnatE. + have Z2e: e \in Z2 by rewrite (mem_normal_Hall hallZ2) // /p_elt oe pnatE. + have [S sylS] := Sylow_exists p U2; have [sSU2 pS _] := and3P sylS. + have sylS_U: p.-Sylow(U) S := subHall_Sylow hallU2 t2p sylS. + have ntS: S :!=: 1 by rewrite -rank_gt0 (rank_Sylow sylS_U) p_rank_gt0. + have sylS_U2: sylU2 S by rewrite /sylU2 ntS (p_Sylow sylS). + have [nsZU cycZ regZ1 eqexpZS] := Z_P S sylS_U2. + suffices defZ1: 'Ohm_1(Z_ S) == <[e]>. + by rewrite -regZ1 (eqP defZ1) cent_cycle inE Ms_x cent1C. + have pZ: p.-group (Z_ S) by rewrite -pnat_exponent eqexpZS pnat_exponent. + have sylZ: p.-Sylow(Z2) (Z_ S). + have:= sZU2; rewrite pHallE /Z2 /= -bigprodGE (bigD1 S) //=. + set Z2' := (\prod_(T | _) _)%G => /joing_subP[sZ_U2 sZ2'_U2]. + rewrite joing_subl cent_joinEl ?(sub_abelian_cent2 cU2U2) //=. + suffices p'Z2': p^'.-group Z2'. + rewrite coprime_cardMg ?(pnat_coprime pZ) //. + by rewrite partnM // part_pnat_id // part_p'nat // muln1. + elim/big_ind: Z2' sZ2'_U2 => [_||T /andP[sylT neqTS]]; first exact: pgroup1. + move=> X Y IHX IHY /joing_subP[sXU2 sYU2] /=. + by rewrite cent_joinEl ?(sub_abelian_cent2 cU2U2) // pgroupM IHX ?IHY. + have /Z_P[_ _ _ expYT _] := sylT. + have{sylT} [_ /SylowP[q _ sylT]] := andP sylT. + rewrite -pnat_exponent expYT pnat_exponent. + apply: (pi_pnat (pHall_pgroup sylT)); apply: contraNneq neqTS => eq_qp. + have defOE2 := nilpotent_Hall_pcore (abelian_nil cU2U2). + by rewrite -val_eqE /= (defOE2 _ _ sylS) (defOE2 _ _ sylT) eq_qp. + have nZZ2 := normalS (pHall_sub sylZ) (subset_trans sZU2 sU2U) nsZU. + have Ze: e \in Z_ S by rewrite (mem_normal_Hall sylZ) // /p_elt oe pnat_id. + rewrite (eq_subG_cyclic cycZ) ?Ohm_sub ?cycle_subG // -orderE oe. + by rewrite (Ohm1_cyclic_pgroup_prime _ pZ) //; apply/trivgPn; exists e. +case: (sylU2 S) / andP => [[ntS /SylowP[p p_pr sylS_U2]]|]; last by exists E. +have [sSU2 pS _] := and3P sylS_U2; have [sSE2 sSU] := subsetIP sSU2. +have piSp: p \in \pi(S) by rewrite -p_rank_gt0 -rank_pgroup ?rank_gt0. +have t2p: p \in \tau2(M) := pnatPpi t2U2 (piSg sSU2 piSp). +have sylS_U: p.-Sylow(U) S := subHall_Sylow hallU2 t2p sylS_U2. +have sylS_E: p.-Sylow(E) S := subHall_Sylow hallU (piSg sSU piSp) sylS_U. +have sylS: p.-Sylow(E2) S := pHall_subl sSE2 sE2E sylS_E. +have sylS_G: p.-Sylow(G) S := subHall_Sylow hallE2_G t2p sylS. +have [cSS [/= s'p rpM]] := (abelianS sSU2 cU2U2, andP t2p). +have sylS_M: p.-Sylow(M) S := subHall_Sylow hallE s'p sylS_E. +have rpS: 'r_p(S) = 2 by apply/eqP; rewrite (p_rank_Sylow sylS_M). +have [A] := p_rank_witness p S; rewrite rpS -(setIidPr (pHall_sub sylS_E)). +rewrite pnElemI setIC 2!inE => /andP[sAS Ep2A]. +have [[nsAE defEp] _ nregEp_uniq _] := tau2_compl_context maxM hallE t2p Ep2A. +have [_ sNS'FE _ sCSE _] + := abelian_tau2_sub_Fitting maxM hallE t2p Ep2A sylS_G sAS cSS. +have [_ _ [defNS _ _ _] regE1subZ] + := abelian_tau2 maxM complEi t2p Ep2A sylS_G sAS cSS. +have nSE: E \subset 'N(S) by rewrite -defNS normal_norm. +have [sSE nSU] := (subset_trans sSE2 sE2E, subset_trans sUE nSE). +have n_subNS := abelian_tau2_norm_Sylow maxM hallE t2p Ep2A sylS_G sAS cSS. +have not_sNS_M: ~~ ('N(S) \subset M). + by apply: contra s'p => sNS_M; apply/exists_inP; exists S; rewrite // inE. +have regNNS Z (Z1 := 'Ohm_1(Z)%G): + Z \subset S -> cyclic Z -> Z :!=: 1 -> 'N(S) \subset 'N(Z1) -> 'C_Ms(Z1) = 1. +- move=> sZS cycZ ntZ nZ1_NS; apply: contraNeq not_sNS_M => nregZ1. + have sZ1S: Z1 \subset S := subset_trans (Ohm_sub 1 Z) sZS. + have EpZ1: Z1 \in 'E_p^1(E). + rewrite p1ElemE // !inE (subset_trans sZ1S) //=. + by rewrite (Ohm1_cyclic_pgroup_prime _ (pgroupS sZS pS)). + have /= uCZ1 := nregEp_uniq _ EpZ1 nregZ1. + apply: (subset_trans nZ1_NS); apply: (sub_uniq_mmax uCZ1 (cent_sub _)). + by rewrite mFT_norm_proper ?(mFT_pgroup_proper (pgroupS sZ1S pS)) ?Ohm1_eq1. +have [_ nsCEA t1CEAb] := tau1_cent_tau2Elem_factor maxM hallE t2p Ep2A. +have [cSU | not_cSU] := boolP (U \subset 'C(S)). + pose n := logn p (exponent S); pose Sn := 'Mho^n.-1(S)%G. + have n_gt0: 0 < n by rewrite -pi_of_exponent -logn_gt0 in piSp. + have expS: (exponent S = p ^ n.-1 * p)%N. + rewrite -expnSr prednK -?p_part //. + by rewrite part_pnat_id ?pnat_exponent ?expg_exponent. + have sSnS1: Sn \subset 'Ohm_1(S). + rewrite (OhmE 1 pS) /= (MhoE _ pS); apply/genS/subsetP=> _ /imsetP[x Sx ->]. + by rewrite !inE groupX //= -expgM -expS expg_exponent. + have sSZ: S \subset 'Z(U) by rewrite subsetI sSU centsC. + have{sSZ} nsZU z: z \in S -> <[z]> <| U. + by move/(subsetP sSZ)=> ZUz; rewrite sub_center_normal ?cycle_subG. + have [homoS | ltSnS1] := eqVproper sSnS1. + have Ep2A_M := subsetP (pnElemS p 2 sEM) A Ep2A. + have [_ _ _ _ [A1 EpA1 regA1]] := tau2_context maxM t2p Ep2A_M. + have [sA1A _ oA1] := pnElemPcard EpA1. + have /cyclicP[zn defA1]: cyclic A1 by rewrite prime_cyclic ?oA1. + have [z Sz def_zn]: exists2 z, z \in S & zn = z ^+ (p ^ n.-1). + apply/imsetP; rewrite -(MhoEabelian _ pS cSS) homoS (OhmE 1 pS). + rewrite mem_gen // !inE -cycle_subG -defA1 (subset_trans sA1A) //=. + by rewrite -oA1 defA1 expg_order. + have oz: #[z] = exponent S. + by rewrite expS; apply: orderXpfactor; rewrite // -def_zn orderE -defA1. + exists <[z]>%G; split; rewrite ?cycle_cyclic ?exponent_cycle ?nsZU //. + by rewrite (Ohm_p_cycle _ (mem_p_elt pS Sz)) subn1 oz -def_zn -defA1. + have [z Sz /esym oz] := exponent_witness (abelian_nil cSS). + exists <[z]>%G; split; rewrite ?cycle_cyclic ?exponent_cycle ?nsZU //. + have ntz: <[z]> != 1 by rewrite trivg_card1 -orderE oz -dvdn1 -trivg_exponent. + rewrite regNNS ?cycle_cyclic ?cycle_subG //=. + suffices /eqP->: 'Ohm_1(<[z]>) == Sn by apply: char_norms; apply: gFchar. + have [p_z pS1] := (mem_p_elt pS Sz, pgroupS (Ohm_sub 1 S) pS). + rewrite eqEcard (Ohm1_cyclic_pgroup_prime _ p_z) ?cycle_cyclic //. + rewrite (Ohm_p_cycle _ p_z) oz -/n subn1 cycle_subG Mho_p_elt //=. + rewrite (card_pgroup (pgroupS sSnS1 pS1)) (leq_exp2l _ 1) ?prime_gt1 //. + by rewrite -ltnS -rpS p_rank_abelian ?properG_ltn_log. +have{not_cSU} [q q_pr piUq]: {q | prime q & q \in \pi(U / 'C(S))}. + have [q q_pr rCE] := rank_witness (U / 'C(S)); exists q => //. + by rewrite -p_rank_gt0 -rCE rank_gt0 -subG1 quotient_sub1 ?norms_cent. +have{piUq} [piCESbq piUq]: q \in \pi(E / 'C_E(S)) /\ q \in \pi(U). + rewrite /= setIC (card_isog (second_isog (norms_cent nSE))). + by rewrite (piSg _ piUq) ?quotientS // (pi_of_dvd _ _ piUq) ?dvdn_quotient. +have [Q1 sylQ1_U] := Sylow_exists q U; have [sQ1U qQ1 _] := and3P sylQ1_U. +have sylQ1: q.-Sylow(E) Q1 := subHall_Sylow hallU piUq sylQ1_U. +have sQ1E := subset_trans sQ1U sUE; have nSQ1 := subset_trans sQ1E nSE. +have [Q sylQ sQ1Q] := Sylow_superset nSQ1 qQ1; have [nSQ qQ _] := and3P sylQ. +have Ep2A_M := subsetP (pnElemS p 2 sEM) A Ep2A. +have ltCQ1_S: 'C_S(Q1) \proper S. + rewrite properE subsetIl /= subsetI subxx centsC -sQ1E -subsetI. + have nCES_Q1: Q1 \subset 'N('C_E(S)) by rewrite (setIidPr sCSE) norms_cent. + rewrite -quotient_sub1 // subG1 -rank_gt0. + by rewrite (rank_Sylow (quotient_pHall nCES_Q1 sylQ1)) p_rank_gt0. +have coSQ: coprime #|S| #|Q|. + suffices p'q: q != p by rewrite (pnat_coprime pS) // (pi_pnat qQ). + apply: contraNneq (proper_subn ltCQ1_S) => eq_qp; rewrite subsetI subxx. + rewrite (sub_abelian_cent2 cE2E2) // (sub_normal_Hall hallE2) //. + by rewrite (pi_pgroup qQ1) ?eq_qp. +have not_sQ1CEA: ~~ (Q1 \subset 'C_E(A)). + rewrite subsetI sQ1E; apply: contra (proper_subn ltCQ1_S) => /= cAQ1. + rewrite subsetIidl centsC coprime_abelian_faithful_Ohm1 ?(coprimegS sQ1Q) //. + by case: (tau2_context maxM t2p Ep2A_M); case/(_ S sylS_M)=> _ [|->] //. +have t1q: q \in \tau1(M). + rewrite (pnatPpi t1CEAb) // -p_rank_gt0. + have nCEA_Q1: Q1 \subset 'N('C_E(A)) := subset_trans sQ1E (normal_norm nsCEA). + rewrite -(rank_Sylow (quotient_pHall nCEA_Q1 sylQ1)) rank_gt0. + by rewrite -subG1 quotient_sub1. +have cycQ1: cyclic Q1. + have [x _ sQ1E1x] := Hall_psubJ hallE1 t1q sQ1E qQ1. + by rewrite (cyclicS sQ1E1x) ?cyclicJ. +have defQ1: Q :&: E = Q1. + apply: (sub_pHall sylQ1) (subsetIr Q E); last by rewrite subsetI sQ1Q. + by rewrite (pgroupS (subsetIl Q _)). +pose Q0 := 'C_Q(S); have nsQ0Q: Q0 <| Q by rewrite norm_normalI ?norms_cent. +have [sQ0Q nQ0Q] := andP nsQ0Q; have nQ01 := subset_trans sQ1Q nQ0Q. +have coSQ0: coprime #|S| #|Q0| := coprimegS sQ0Q coSQ. +have ltQ01: Q0 \proper Q1. + rewrite /proper -{1}defQ1 setIS //. + apply: contra (proper_subn ltCQ1_S) => sQ10. + by rewrite subsetIidl (centsS sQ10) // centsC subsetIr. +have [X]: exists2 X, X \in subgroups Q & ('C_S(X) != 1) && ([~: S, X] != 1). + apply/exists_inP; apply: contraFT (ltnn 1); rewrite negb_exists_in => irrS. + have [sQ01 not_sQ10] := andP ltQ01. + have qQb: q.-group (Q / Q0) by exact: quotient_pgroup. + have ntQ1b: Q1 / Q0 != 1 by rewrite -subG1 quotient_sub1. + have ntQb: Q / Q0 != 1 := subG1_contra (quotientS _ sQ1Q) ntQ1b. + have{irrS} regQ: semiregular (S / Q0) (Q / Q0). + move=> Q0x; rewrite 2!inE -cycle_subG -cycle_eq1 -cent_cycle andbC. + case/andP; case/(inv_quotientS nsQ0Q)=> X /= -> {Q0x} sQ0X sXQ ntXb. + have [nSX nQ0X] := (subset_trans sXQ nSQ, subset_trans sXQ nQ0Q). + rewrite -quotient_TI_subcent ?(coprime_TIg coSQ0) //. + apply: contraTeq (forallP irrS X) => ntCSXb; rewrite inE sXQ negbK. + apply/andP; split. + by apply: contraNneq ntCSXb => ->; rewrite quotient1. + apply: contraNneq ntXb; move/commG1P => cXS. + by rewrite quotientS1 // subsetI sXQ centsC. + have{regQ} cycQb: cyclic (Q / Q0). + have nSQb: Q / Q0 \subset 'N(S / Q0) by exact: quotient_norms. + apply: odd_regular_pgroup_cyclic qQb (mFT_quo_odd _ _) _ nSQb regQ. + rewrite -(isog_eq1 (quotient_isog _ _)) ?coprime_TIg 1?coprime_sym //. + by rewrite cents_norm // centsC subsetIr. + have rQ1: 'r(Q1) = 1%N. + apply/eqP; rewrite (rank_Sylow sylQ1). + by rewrite (tau1E maxM hallE) in t1q; case/and3P: t1q. + have: 'r(Q) <= 1; last apply: leq_trans. + have nQ0_Ohm1Q := subset_trans (Ohm_sub 1 Q) nQ0Q. + rewrite -rQ1 -rank_Ohm1 rankS // -(quotientSGK _ sQ01) //. + rewrite (subset_trans (morphim_Ohm _ _ nQ0Q)) //= -quotientE -/Q0. + rewrite -(cardSg_cyclic cycQb) ?Ohm_sub ?quotientS //. + have [_ q_dv_Q1b _] := pgroup_pdiv (pgroupS (quotientS _ sQ1Q) qQb) ntQ1b. + by rewrite (Ohm1_cyclic_pgroup_prime cycQb qQb ntQb). + have ltNA_G: 'N(A) \proper G. + by rewrite defNS mFT_norm_proper // (mFT_pgroup_proper pS). + have [H maxNA_H] := mmax_exists ltNA_G. + have nCEA_Q1 := subset_trans sQ1E (normal_norm nsCEA). + have [_ _] := primes_norm_tau2Elem maxM hallE t2p Ep2A maxNA_H. + case/(_ q)=> [||t2Hq [S2 sylS2 nsS2H] _]. + - rewrite -p_rank_gt0 -(rank_Sylow (quotient_pHall _ sylQ1)) //. + by rewrite rank_gt0 -subG1 quotient_sub1. + - rewrite -p_rank_gt0 -rQ1 (rank_pgroup qQ1) -p_rank_Ohm1 p_rankS //. + have: 'Z(E) \subset 'C_E(A); last apply: subset_trans. + by rewrite setIS ?centS // normal_sub. + have [x Ex sQ1xE1] := Hall_pJsub hallE1 t1q sQ1E qQ1. + rewrite -(conjSg _ _ x) (normsP (normal_norm (center_normal E))) //. + set Q11x := _ :^ x; have oQ11x: #|Q11x| = q. + by rewrite cardJg (Ohm1_cyclic_pgroup_prime _ qQ1) // -rank_gt0 rQ1. + apply: regE1subZ. + apply/nElemP; exists q; rewrite p1ElemE // !inE oQ11x. + by rewrite (subset_trans _ sQ1xE1) //= conjSg Ohm_sub. + have: cyclic Q11x by rewrite prime_cyclic ?oQ11x. + case/cyclicP=> y defQ11x; rewrite /= -/Q11x defQ11x cent_cycle regU13 //. + rewrite !inE -order_gt1 -cycle_subG /order -defQ11x oQ11x prime_gt1 //. + rewrite sub_conjg (subset_trans (Ohm_sub 1 Q1)) //. + by rewrite (normsP (normal_norm nsUE)) ?groupV. + by rewrite /p_elt /order -defQ11x oQ11x pnatE //; apply/orP; left. + rewrite inE in sylS2; have [sS2H _]:= andP nsS2H. + have sylS2_H := pHall_subl sS2H (subsetT H) sylS2. + have [maxH sNS_H] := setIdP maxNA_H; rewrite /= defNS in sNS_H. + have sylS_H := pHall_subl (subset_trans (normG S) sNS_H) (subsetT H) sylS_G. + have defS2: S :=: S2 := uniq_normal_Hall sylS2_H nsS2H (Hall_max sylS_H). + have sylQ_H: q.-Sylow(H) Q by rewrite -(mmax_normal maxH nsS2H) -defS2. + by rewrite (rank_Sylow sylQ_H); case/andP: t2Hq => _ /eqP->. +rewrite inE => sXQ /=; have nSX := subset_trans sXQ nSQ. +set S1 := [~: S, X]; set S2 := 'C_S(X) => /andP[ntS2 ntS1]. +have defS12: S1 \x S2 = S. + by apply: coprime_abelian_cent_dprod; rewrite ?(coprimegS sXQ). +have /mulG_sub[sS1S sS2S] := dprodW defS12. +have [cycS1 cycS2]: cyclic S1 /\ cyclic S2. + apply/andP; rewrite !(abelian_rank1_cyclic (abelianS _ cSS)) //. + rewrite -(leqif_add (leqif_geq _) (leqif_geq _)) ?rank_gt0 // addn1 -rpS. + rewrite !(rank_pgroup (pgroupS _ pS)) ?(p_rank_abelian p (abelianS _ cSS)) //. + by rewrite -lognM ?cardG_gt0 // (dprod_card (Ohm_dprod 1 defS12)). +have [nsS2NS nsS1NS]: S2 <| 'N(S) /\ S1 <| 'N(S) := n_subNS X nSX. +pose Z := if #|S1| < #|S2| then [group of S2] else [group of S1]. +have [ntZ sZS nsZN cycZ]: [/\ Z :!=: 1, Z \subset S, Z <| 'N(S) & cyclic Z]. + by rewrite /Z; case: ifP. +have nsZU: Z <| U := normalS (subset_trans sZS sSU) nSU nsZN. +exists Z; split=> //=. + by rewrite regNNS // (char_norm_trans (Ohm_char 1 Z)) // normal_norm. +rewrite -(dprod_exponent defS12) /= (fun_if val) fun_if !exponent_cyclic //=. +rewrite (card_pgroup (pgroupS sS1S pS)) (card_pgroup (pgroupS sS2S pS)) //. +by rewrite /= -/S1 -/S2 ltn_exp2l ?prime_gt1 // -fun_if expn_max. +Qed. + +(* This is B & G, Theorem 12.13. *) +Theorem nonabelian_Uniqueness p P : p.-group P -> ~~ abelian P -> P \in 'U. +Proof. +move=> pP not_cPP; have [M maxP_M] := mmax_exists (mFT_pgroup_proper pP). +have sigma_p L: L \in 'M(P) -> p \in \sigma(L). + case/setIdP=> maxL sPL; apply: contraR not_cPP => sL'p. + exact: sigma'_nil_abelian maxL sPL (pi_pnat pP _) (pgroup_nil pP). +have{maxP_M} [[maxM sPM] sMp] := (setIdP maxP_M, sigma_p M maxP_M). +rewrite (uniq_mmax_subset1 maxM sPM); apply/subsetP=> H maxP_H; rewrite inE. +have{sigma_p maxP_H} [[maxH sPH] sHp] := (setIdP maxP_H, sigma_p H maxP_H). +without loss{pP sPH sPM} sylP: P not_cPP / p.-Sylow(M :&: H) P. + move=> IH; have sP_MH: P \subset M :&: H by rewrite subsetI sPM. + have [S sylS sPS] := Sylow_superset sP_MH pP. + exact: IH (contra (abelianS sPS) not_cPP) sylS. +have [sP_MH pP _] := and3P sylP; have [sPM sPH] := subsetIP sP_MH. +have ncycP := contra (@cyclic_abelian _ _) not_cPP. +have{sHp} sNMH: 'N(P) \subset M :&: H. + by rewrite subsetI !(@norm_noncyclic_sigma _ p). +have{sylP} sylP_M: p.-Sylow(M) P. + have [S sylS sPS] := Sylow_superset sPM pP; have pS := pHall_pgroup sylS. + have [-> // | ltPS] := eqVproper sPS. + have /andP[sNP] := nilpotent_proper_norm (pgroup_nil pS) ltPS. + rewrite (sub_pHall sylP _ sNP) ?subxx ?(pgroupS (subsetIl _ _)) //. + by rewrite subIset // orbC sNMH. +have{sMp} sylP_G: p.-Sylow(G) P := sigma_Sylow_G maxM sMp sylP_M. +have sylP_H: p.-Sylow(H) P := pHall_subl sPH (subsetT H) sylP_G. +have [rPgt2 | rPle2] := ltnP 2 'r(P). + have uniqP: P \in 'U by rewrite rank3_Uniqueness ?(mFT_pgroup_proper pP). + have defMP: 'M(P) = [set M] := def_uniq_mmax uniqP maxM sPM. + by rewrite -val_eqE /= (eq_uniq_mmax defMP maxH). +have rpP: 'r_p(P) = 2. + apply/eqP; rewrite eqn_leq -{1}rank_pgroup // rPle2 ltnNge. + by rewrite -odd_pgroup_rank1_cyclic ?mFT_odd. +have:= mFT_rank2_Sylow_cprod sylP_G rPle2 not_cPP. +case=> Q [not_cQQ dimQ eQ] [R cycR [defP defR1]]. +have sQP: Q \subset P by have /mulG_sub[] := cprodW defP. +have pQ: p.-group Q := pgroupS sQP pP. +have oQ: #|Q| = (p ^ 3)%N by rewrite (card_pgroup pQ) dimQ. +have esQ: extraspecial Q by apply: (p3group_extraspecial pQ); rewrite ?dimQ. +have p_pr := extraspecial_prime pQ esQ; have p_gt1 := prime_gt1 p_pr. +pose Z := 'Z(Q)%G; have oZ: #|Z| = p := card_center_extraspecial pQ esQ. +have nsZQ: Z <| Q := center_normal Q; have [sZQ nZQ] := andP nsZQ. +have [[defPhiQ defQ'] _]: ('Phi(Q) = Z /\ Q^`(1) = Z) /\ _ := esQ. +have defZ: 'Ohm_1 ('Z(P)) = Z. + have [_ <- _] := cprodP (center_cprod defP). + by rewrite (center_idP (cyclic_abelian cycR)) -defR1 mulSGid ?Ohm_sub. +have ncycQ: ~~ cyclic Q := contra (@cyclic_abelian _ Q) not_cQQ. +have rQgt1: 'r_p(Q) > 1. + by rewrite ltnNge -(odd_pgroup_rank1_cyclic pQ) ?mFT_odd. +have [A Ep2A]: exists A, A \in 'E_p^2(Q) by exact/p_rank_geP. +wlog uniqNEpA: M H maxM maxH sP_MH sNMH sPM sPH sylP_M sylP_H / + ~~ [exists A0 in 'E_p^1(A) :\ Z, 'M('N(A0)) == [set M]]. +- move=> IH; case: exists_inP (IH M H) => [[A0 EpA0 defMA0] _ | _ -> //]. + case: exists_inP {IH}(IH H M) => [[A1 EpA1 defMA1] _ | _]; last first. + by rewrite setIC eq_sym => ->. + have [sAQ abelA dimA] := pnElemP Ep2A; have sAP := subset_trans sAQ sQP. + have transNP: [transitive 'N_P(A), on 'E_p^1(A) :\ Z | 'JG]. + have [|_ _] := basic_p2maxElem_structure _ pP sAP not_cPP. + have Ep2A_G := subsetP (pnElemS p 2 (subsetT Q)) A Ep2A. + rewrite inE Ep2A_G (subsetP (p_rankElem_max p G)) //. + by rewrite -(p_rank_Sylow sylP_G) rpP. + by rewrite (group_inj defZ). + have [x NPx defA1] := atransP2 transNP EpA0 EpA1. + have Mx: x \in M by rewrite (subsetP sPM) //; case/setIP: NPx. + rewrite eq_sym -in_set1 -(group_inj (conjGid Mx)). + by rewrite -(eqP defMA1) defA1 /= normJ mmax_ofJ (eqP defMA0) set11. +apply: contraR uniqNEpA => neqHM; have sQM := subset_trans sQP sPM. +suffices{A Ep2A} [ntMa nonuniqNZ]: M`_\alpha != 1 /\ 'M('N(Z)) != [set M]. + have [A0 EpA0 defMNA0]: exists2 A0, A0 \in 'E_p^1(A) & 'M('N(A0)) == [set M]. + apply/exists_inP; apply: contraR ntMa; rewrite negb_exists_in => uniqNA1. + have{Ep2A} Ep2A: A \in 'E_p^2(M) := subsetP (pnElemS p 2 sQM) A Ep2A. + by have [_ [//|_ ->]] := p2Elem_mmax maxM Ep2A. + apply/exists_inP; exists A0; rewrite // 2!inE EpA0 andbT. + by apply: contraNneq nonuniqNZ => <-. +have coMaQ: coprime #|M`_\alpha| #|Q|. + apply: pnat_coprime (pcore_pgroup _ _) (pi_pnat pQ _). + by rewrite !inE -(p_rank_Sylow sylP_M) rpP. +have nMaQ: Q \subset 'N(M`_\alpha) by rewrite (subset_trans sQM) ?gFnorm. +have [coMaZ nMaZ] := (coprimegS sZQ coMaQ, subset_trans sZQ nMaQ). +pose K := 'N_(M`_\alpha)(Z). +have defKC: 'C_(M`_\alpha)(Z) = K by rewrite -coprime_norm_cent. +have coKQ: coprime #|K| #|Q| := coprimeSg (subsetIl _ _) coMaQ. +have nKQ: Q \subset 'N(K) by rewrite normsI ?norms_norm. +have [coKZ nKZ] := (coprimegS sZQ coKQ, subset_trans sZQ nKQ). +have sKH: K \subset H. + have sZH := subset_trans sZQ (subset_trans sQP sPH). + rewrite -(quotientSGK (subsetIr _ _) sZH) /= -/Z -/K. + have cQQb: abelian (Q / Z) by rewrite -defQ' sub_der1_abelian. + rewrite -(coprime_abelian_gen_cent cQQb) ?coprime_morph ?quotient_norms //. + rewrite gen_subG /= -/K -/Z; apply/bigcupsP=> Ab; rewrite andbC; case/andP. + case/(inv_quotientN nsZQ)=> A -> sZA nsAQ; have sAQ := normal_sub nsAQ. + rewrite (isog_cyclic (third_isog _ _ _)) // -/Z => cycQA. + have pA: p.-group A := pgroupS sAQ pQ. + have rAgt1: 'r_p(A) > 1. + have [-> // | ltAQ] := eqVproper sAQ. + rewrite ltnNge -(odd_pgroup_rank1_cyclic pA) ?mFT_odd //. + apply: contraL cycQA => cycA /=; have cAA := cyclic_abelian cycA. + suff <-: Z :=: A by rewrite -defPhiQ (contra (@Phi_quotient_cyclic _ Q)). + apply/eqP; rewrite eqEcard sZA /= oZ (card_pgroup pA) (leq_exp2l _ 1) //. + by rewrite -abelem_cyclic // /abelem pA cAA (dvdn_trans (exponentS sAQ)). + have [A1 EpA1] := p_rank_geP rAgt1. + rewrite -(setIidPr (subset_trans sAQ (subset_trans sQP sPH))) pnElemI in EpA1. + have{EpA1} [Ep2A1 sA1A]:= setIdP EpA1; rewrite inE in sA1A. + have [sCA1_H _]: 'C(A1) \subset H /\ _ := p2Elem_mmax maxH Ep2A1. + rewrite -quotient_TI_subcent ?(subset_trans sAQ) ?(coprime_TIg coKZ) //= -/K. + by rewrite quotientS // subIset // orbC (subset_trans (centS sA1A)). +have defM: M`_\alpha * (M :&: H) = M. + rewrite setIC in sNMH *. + have [defM eq_aM_bM] := nonuniq_norm_Sylow_pprod maxM maxH neqHM sylP_G sNMH. + by rewrite [M`_\alpha](eq_pcore M eq_aM_bM). +do [split; apply: contraNneq neqHM] => [Ma1 | uniqNZ]. + by rewrite -val_eqE /= (eq_mmax maxM maxH) // -defM Ma1 mul1g subsetIr. +have [_ sNZM]: _ /\ 'N(Z) \subset M := mem_uniq_mmax uniqNZ. +rewrite -val_eqE /= (eq_uniq_mmax uniqNZ maxH) //= -(setIidPr sNZM). +have sZ_MH: Z \subset M :&: H := subset_trans sZQ (subset_trans sQP sP_MH). +rewrite -(pprod_norm_coprime_prod defM) ?pcore_normal ?mmax_sol //. +by rewrite mulG_subG /= defKC sKH setIAC subsetIr. +Qed. + +(* This is B & G, Corollary 12.14. We have removed the redundant assumption *) +(* p \in \sigma(M), and restricted the quantification over P to the part of *) +(* the conclusion where it is mentioned. *) +(* Usage note: it might be more convenient to state that P is a Sylow *) +(* subgroup of M rather than M`_\sigma; check later use. *) +Corollary cent_der_sigma_uniq M p X (Ms := M`_\sigma) : + M \in 'M -> X \in 'E_p^1(M) -> (p \in \beta(M)) || (X \subset Ms^`(1)) -> + 'M('C(X)) = [set M] /\ (forall P, p.-Sylow(Ms) P -> 'M(P) = [set M]). +Proof. +move=> maxM EpX bMp_sXMs'; have p_pr := pnElem_prime EpX. +have [sXM abelX oX] := pnElemPcard EpX; have [pX _] := andP abelX. +have ntX: X :!=: 1 := nt_pnElem EpX isT; have ltCXG := mFT_cent_proper ntX. +have sMp: p \in \sigma(M). + have [bMp | sXMs'] := orP bMp_sXMs'; first by rewrite beta_sub_sigma. + rewrite -pnatE // -[p]oX; apply: pgroupS (subset_trans sXMs' (der_sub 1 _)) _. + exact: pcore_pgroup. +have hallMs: \sigma(M).-Hall(M) Ms by exact: Msigma_Hall. +have sXMs: X \subset Ms by rewrite (sub_Hall_pcore hallMs) // /pgroup oX pnatE. +have [P sylP sXP]:= Sylow_superset sXMs pX. +have sylP_M: p.-Sylow(M) P := subHall_Sylow hallMs sMp sylP. +have sylP_G := sigma_Sylow_G maxM sMp sylP_M. +have [sPM pP _] := and3P sylP_M; have ltPG := mFT_pgroup_proper pP. +suffices [-> uniqP]: 'M('C(X)) = [set M] /\ 'M(P) = [set M]. + split=> // Py sylPy; have [y Ms_y ->] := Sylow_trans sylP sylPy. + rewrite (def_uniq_mmaxJ _ uniqP) (group_inj (conjGid _)) //. + exact: subsetP (pcore_sub _ _) y Ms_y. +have [rCPXgt2 | rCPXle2] := ltnP 2 'r_p('C_P(X)). + have [sCPX_P sCPX_CX] := subsetIP (subxx 'C_P(X)). + have [ltP ltCX] := (mFT_pgroup_proper pP, mFT_cent_proper ntX). + have sCPX_M := subset_trans sCPX_P sPM. + have ltCPX_G := sub_proper_trans sCPX_P ltPG. + suff uniqCPX: 'M('C_P(X)) = [set M] by rewrite !(def_uniq_mmaxS _ _ uniqCPX). + apply: (def_uniq_mmax (rank3_Uniqueness _ _)) => //. + exact: leq_trans (p_rank_le_rank p _). +have nnP: p.-narrow P. + apply: wlog_neg; rewrite negb_imply; case/andP=> rP _. + by apply/narrow_centP; rewrite ?mFT_odd //; exists X. +have{bMp_sXMs'} [bM'p sXMs']: p \notin \beta(M) /\ X \subset Ms^`(1). + move: bMp_sXMs'; rewrite !inE -negb_exists_in. + by case: exists_inP => // [[]]; exists P. +have defMs: 'O_p^'(Ms) ><| P = Ms. + by have [_ hallMp' _] := beta_max_pdiv maxM bM'p; exact/sdprod_Hall_p'coreP. +have{defMs} sXP': X \subset P^`(1). + have{defMs} [_ defMs nMp'P tiMp'P] := sdprodP defMs. + have [injMp'P imMp'P] := isomP (quotient_isom nMp'P tiMp'P). + rewrite -(injmSK injMp'P) // morphim_der // {injMp'P}imMp'P morphim_restrm. + rewrite (setIidPr sXP) /= -quotientMidl defMs -quotient_der ?quotientS //. + by rewrite -defMs mul_subG ?normG. +have [rPgt2 | rPle2] := ltnP 2 'r_p(P). + case/eqP: ntX; rewrite -(setIidPl sXP'). + by case/(narrow_cent_dprod pP (mFT_odd P)): rCPXle2. +have not_cPP: ~~ abelian P. + by rewrite (sameP derG1P eqP) (subG1_contra sXP') ?ntX. +have sXZ: X \subset 'Z(P). + rewrite -rank_pgroup // in rPle2. + have := mFT_rank2_Sylow_cprod sylP_G rPle2 not_cPP. + case=> Q [not_cQQ dimQ _] [R]; move/cyclic_abelian=> cRR [defP _]. + have [_ mulQR _] := cprodP defP; have [sQP _] := mulG_sub mulQR. + rewrite (subset_trans sXP') // -(der_cprod 1 defP) (derG1P cRR) cprodg1. + have{dimQ} dimQ: logn p #|Q| <= 3 by rewrite dimQ. + have [[_ ->] _] := p3group_extraspecial (pgroupS sQP pP) not_cQQ dimQ. + by case/cprodP: (center_cprod defP) => _ <- _; exact: mulG_subl. +have uniqP: 'M(P) = [set M]. + exact: def_uniq_mmax (nonabelian_Uniqueness pP not_cPP) maxM sPM. +rewrite (def_uniq_mmaxS _ ltCXG uniqP) //. +by rewrite centsC (subset_trans sXZ) // subsetIr. +Qed. + +(* This is B & G, Proposition 12.15. *) +Proposition sigma_subgroup_embedding M q X Mstar : + M \in 'M -> q \in \sigma(M) -> X \subset M -> q.-group X -> X :!=: 1 -> + Mstar \in 'M('N(X)) :\ M -> + [/\ (*a*) gval Mstar \notin M :^: G, + forall S, q.-Sylow(M :&: Mstar) S -> X \subset S -> + (*b*) 'N(S) \subset M + /\ (*c*) q.-Sylow(Mstar) S + & if q \in \sigma(Mstar) + (*d*) then + [/\ (*1*) Mstar`_\beta * (M :&: Mstar) = Mstar, + (*2*) {subset \tau1(Mstar) <= [predU \tau1(M) & \alpha(M)]} + & (*3*) M`_\beta = M`_\alpha /\ M`_\alpha != 1] + (*e*) else + [/\ (*1*) q \in \tau2(Mstar), + (*2*) {subset [predI \pi(M) & \sigma(Mstar)] <= \beta(Mstar)} + & (*3*) \sigma(Mstar)^'.-Hall(Mstar) (M :&: Mstar)]]. +Proof. +move: Mstar => H maxM sMq sXM qX ntX /setD1P[neqHM maxNX_H]. +have [q_pr _ _] := pgroup_pdiv qX ntX; have [maxH sNX_H] := setIdP maxNX_H. +have sXH := subset_trans (normG X) sNX_H. +have sX_MH: X \subset M :&: H by apply/subsetIP. +have parts_bc S: + q.-Sylow(M :&: H) S -> X \subset S -> 'N(S) \subset M /\ q.-Sylow(H) S. +- move=> sylS sXS; have [sS_MH qS _] := and3P sylS. + have [sSM sSH] := subsetIP sS_MH. + have sNS_M: 'N(S) \subset M. + have [cycS|] := boolP (cyclic S); last exact: norm_noncyclic_sigma qS _. + have [T sylT sST] := Sylow_superset sSM qS; have [sTM qT _] := and3P sylT. + rewrite -(nilpotent_sub_norm (pgroup_nil qT) sST). + exact: norm_sigma_Sylow sylT. + rewrite (sub_pHall sylS (pgroupS (subsetIl T _) qT)) //. + by rewrite subsetI sST normG. + by rewrite setISS // (subset_trans (char_norms _) sNX_H) // sub_cyclic_char. + split=> //; have [T sylT sST] := Sylow_superset sSH qS. + have [sTH qT _] := and3P sylT. + rewrite -(nilpotent_sub_norm (pgroup_nil qT) sST) //. + rewrite (sub_pHall sylS (pgroupS (subsetIl T _) qT)) //=. + by rewrite subsetI sST normG. + by rewrite /= setIC setISS. +have [S sylS sXS] := Sylow_superset sX_MH qX; have [sS_MH qS _] := and3P sylS. +have [sSM sSH] := subsetIP sS_MH; have [sNS_M sylS_H] := parts_bc S sylS sXS. +have notMGH: gval H \notin M :^: G. + by apply: mmax_norm_notJ maxM maxH qX sXM sNX_H _; rewrite sMq eq_sym neqHM. +have /orP[sHq | t2Hq] := prime_class_mmax_norm maxH qX sNX_H; last first. + have [/= sH'q rqH] := andP t2Hq; rewrite [q \in _](negPf sH'q); split=> //. + have [A Eq2A] := p_rank_witness q S; have [sAS abelA dimA] := pnElemP Eq2A. + rewrite (p_rank_Sylow sylS_H) (eqP rqH) in dimA; have [qA _] := andP abelA. + have [sAH sAM] := (subset_trans sAS sSH, subset_trans sAS sSM). + have [F hallF sAF] := Hall_superset (mmax_sol maxH) sAH (pi_pnat qA sH'q). + have tiHsM: H`_\sigma :&: M = 1. + have{Eq2A} Eq2A: A \in 'E_q^2(H) by apply/pnElemP. + have [_ _ _ -> //] := tau2_context maxH t2Hq Eq2A. + by rewrite 3!inE eq_sym neqHM maxM. + have{Eq2A} Eq2A_F: A \in 'E_q^2(F) by apply/pnElemP. + have [[nsAF _] [sCA_F _ _] _ TIsH] + := tau2_compl_context maxH hallF t2Hq Eq2A_F. + have sNA_M: 'N(A) \subset M. + apply: norm_noncyclic_sigma maxM sMq qA sAM _. + by rewrite (abelem_cyclic abelA) dimA. + have ->: M :&: H = F. + have [[_ <- _ _] [_ nAF]] := (sdprodP (sdprod_sigma maxH hallF), andP nsAF). + by rewrite -(group_modr _ (subset_trans nAF sNA_M)) setIC tiHsM mul1g. + split=> // p /andP[/= piMp sHp]; apply: wlog_neg => bH'p. + have bM'q: q \notin \beta(M). + by rewrite -predI_sigma_beta // inE /= sMq; case/tau2_not_beta: t2Hq. + have sM'p: p \notin \sigma(M). + rewrite orbit_sym in notMGH; have [_ TIsHM] := TIsH M maxM notMGH. + by have:= TIsHM p; rewrite inE /= sHp /= => ->. + have p'CA: p^'.-group 'C(A). + by rewrite (pgroupS sCA_F) // (pi'_p'group (pHall_pgroup hallF)). + have p_pr: prime p by rewrite mem_primes in piMp; case/andP: piMp. + have [lt_pq | lt_qp | eq_pq] := ltngtP p q; last 1 first. + - by rewrite eq_pq sMq in sM'p. + - have bH'q: q \notin \beta(H) by apply: contra sH'q; apply: beta_sub_sigma. + have [|[P sylP cPA] _ _] := beta'_cent_Sylow maxH bH'p bH'q qA. + by rewrite lt_pq sAH orbT. + have sylP_H := subHall_Sylow (Msigma_Hall maxH) sHp sylP. + have piPp: p \in \pi(P). + by rewrite -p_rank_gt0 (p_rank_Sylow sylP_H) p_rank_gt0 sigma_sub_pi. + by rewrite centsC in cPA; case/eqnP: (pnatPpi (pgroupS cPA p'CA) piPp). + have bM'p: p \notin \beta(M) by apply: contra sM'p; apply: beta_sub_sigma. + have [P sylP] := Sylow_exists p M; have [sMP pP _] := and3P sylP. + have [|[Q1 sylQ1 cQ1P] _ _] := beta'_cent_Sylow maxM bM'q bM'p pP. + by rewrite lt_qp sMP orbT. + have sylQ1_M := subHall_Sylow (Msigma_Hall maxM) sMq sylQ1. + have [x Mx sAQ1x] := Sylow_subJ sylQ1_M sAM qA. + have sPxCA: P :^ x \subset 'C(A) by rewrite (centsS sAQ1x) // centJ conjSg. + have piPx_p: p \in \pi(P :^ x). + by rewrite /= cardJg -p_rank_gt0 (p_rank_Sylow sylP) p_rank_gt0. + by case/eqnP: (pnatPpi (pgroupS sPxCA p'CA) piPx_p). +rewrite sHq; split=> //. +have sNS_HM: 'N(S) \subset H :&: M by rewrite subsetI (norm_sigma_Sylow sHq). +have sylS_G: q.-Sylow(G) S := sigma_Sylow_G maxH sHq sylS_H. +have [defM eq_abM] := nonuniq_norm_Sylow_pprod maxM maxH neqHM sylS_G sNS_HM. +rewrite setIC eq_sym in sNS_HM neqHM defM. +have [defH eq_abH] := nonuniq_norm_Sylow_pprod maxH maxM neqHM sylS_G sNS_HM. +rewrite [M`_\alpha](eq_pcore M eq_abM) -/M`_\beta. +split=> // [r t1Hr|]; last first. + split=> //; apply: contraNneq neqHM => Mb1. + by rewrite -val_eqE /= (eq_mmax maxM maxH) // -defM Mb1 mul1g subsetIr. +have [R sylR] := Sylow_exists r (M :&: H); have [sR_MH rR _] := and3P sylR. +have [sRM sRH] := subsetIP sR_MH; have [sH'r rrH not_rH'] := and3P t1Hr. +have bH'r: r \notin \beta(H). + by apply: contra sH'r; rewrite -eq_abH; apply: alpha_sub_sigma. +have sylR_H: r.-Sylow(H) R. + rewrite pHallE sRH -defH -LagrangeMr partnM ?cardG_gt0 //. + rewrite -(card_Hall sylR) part_p'nat ?mul1n ?(pnat_dvd (dvdn_indexg _ _)) //=. + by rewrite (pi_p'nat (pcore_pgroup _ _)). +rewrite inE /= orbC -implyNb eq_abM; apply/implyP=> bM'r. +have sylR_M: r.-Sylow(M) R. + rewrite pHallE sRM -defM -LagrangeMr partnM ?cardG_gt0 //. + rewrite -(card_Hall sylR) part_p'nat ?mul1n ?(pnat_dvd (dvdn_indexg _ _)) //=. + by rewrite (pi_p'nat (pcore_pgroup _ _)). +have rrR: 'r_r(R) = 1%N by rewrite (p_rank_Sylow sylR_H) (eqP rrH). +have piRr: r \in \pi(R) by rewrite -p_rank_gt0 rrR. +suffices not_piM'r: r \notin \pi(M^`(1)). + rewrite inE /= -(p_rank_Sylow sylR_M) rrR /= -negb_or /=. + apply: contra not_piM'r; case/orP=> [sMr | rM']. + have sRMs: R \subset M`_\sigma. + by rewrite (sub_Hall_pcore (Msigma_Hall maxM)) ?(pi_pgroup rR). + by rewrite (piSg (Msigma_der1 maxM)) // (piSg sRMs). + by move: piRr; rewrite !mem_primes !cardG_gt0; case/andP=> ->. +have coMbR: coprime #|M`_\beta| #|R|. + exact: pnat_coprime (pcore_pgroup _ _) (pi_pnat rR _). +have sylRM': r.-Sylow(M^`(1)) _ := Hall_setI_normal (der_normal 1 M) sylR_M. +rewrite -p'groupEpi -partG_eq1 -(card_Hall sylRM') -trivg_card1 /=. +rewrite (pprod_focal_coprime defM (pcore_normal _ _)) //. +rewrite coprime_TIg ?(pnat_coprime rR (pgroupS (dergS 1 (subsetIr _ _)) _)) //. +by rewrite p'groupEpi mem_primes (negPf not_rH') !andbF. +Qed. + +(* This is B & G, Corollary 12.16. *) +Corollary sigma_Jsub M Y : + M \in 'M -> \sigma(M).-group Y -> Y :!=: 1 -> + [/\ exists x, Y :^ x \subset M`_\sigma + & forall E p H, + \sigma(M)^'.-Hall(M) E -> p \in \pi(E) -> p \notin \beta(G) -> + H \in 'M(Y) -> gval H \notin M :^: G -> + [/\ (*a*) 'r_p('N_H(Y)) <= 1 + & (*b*) p \in \tau1(M) -> p \notin \pi(('N_H(Y))^`(1))]]. +Proof. +move=> maxM sM_Y ntY. +have ltYG: Y \proper G. + have ltMsG: M`_\sigma \proper G. + exact: sub_proper_trans (pcore_sub _ _) (mmax_proper maxM). + rewrite properEcard subsetT (leq_ltn_trans _ (proper_card ltMsG)) //. + rewrite dvdn_leq ?cardG_gt0 // (card_Hall (Msigma_Hall_G maxM)). + by rewrite -(part_pnat_id sM_Y) partn_dvd // cardSg ?subsetT. +have [q q_pr rFY] := rank_witness 'F(Y). +have [X [ntX qX charX]]: exists X, [/\ gval X :!=: 1, q.-group X & X \char Y]. + exists ('O_q(Y))%G; rewrite pcore_pgroup pcore_char //. + rewrite -rank_gt0 /= -p_core_Fitting. + rewrite (rank_Sylow (nilpotent_pcore_Hall q (Fitting_nil Y))) -rFY. + by rewrite rank_gt0 (trivg_Fitting (mFT_sol ltYG)). +have sXY: X \subset Y := char_sub charX. +have sMq: q \in \sigma(M). + apply: (pnatPpi (pgroupS sXY sM_Y)). + by rewrite -p_rank_gt0 -(rank_pgroup qX) rank_gt0. +without loss sXMs: M maxM sM_Y sMq / X \subset M`_\sigma. + move=> IH; have [Q sylQ] := Sylow_exists q M`_\sigma. + have sQMs := pHall_sub sylQ. + have sylQ_G := subHall_Sylow (Msigma_Hall_G maxM) sMq sylQ. + have [x Gx sXQx] := Sylow_subJ sylQ_G (subsetT X) qX. + have: X \subset M`_\sigma :^ x by rewrite (subset_trans sXQx) ?conjSg. + rewrite -MsigmaJ => /IH; rewrite sigmaJ mmaxJ (eq_pgroup _ (sigmaJ _ _)). + case => // [[y sYyMx] parts_ab]. + split=> [|E p H hallE piEp bG'p maxY_H notMGH]. + by exists (y * x^-1); rewrite conjsgM sub_conjgV -MsigmaJ. + have:= parts_ab (E :^ x)%G p H; rewrite tau1J /= cardJg pHallJ2. + rewrite (eq_pHall _ _ (eq_negn (sigmaJ _ _))). + by rewrite 2!orbit_sym (orbit_transl (mem_orbit _ _ _)) //; apply. +have pre_part_a E p H: + \sigma(M)^'.-Hall(M) E -> p \in \pi(E) -> + H \in 'M(Y) -> gval H \notin M :^: G -> 'r_p(H :&: M) <= 1. +- move=> hallE piEp /setIdP[maxH sYH] notMGH; rewrite leqNgt. + apply: contra ntX => /p_rank_geP[A /pnElemP[/subsetIP[sAH sAM] abelA dimA]]. + have{abelA dimA} Ep2A: A \in 'E_p^2(M) by apply/pnElemP. + have rpMgt1: 'r_p(M) > 1 by apply/p_rank_geP; exists A. + have t2Mp: p \in \tau2(M). + move: piEp; rewrite (partition_pi_sigma_compl maxM hallE) orbCA orbC. + by rewrite -2!andb_orr orNb eqn_leq leqNgt rpMgt1 !andbF. + have sM'p := pnatPpi (pHall_pgroup hallE) piEp. + have [_ _ _ tiMsH _] := tau2_context maxM t2Mp Ep2A. + rewrite -subG1 -(tiMsH H); first by rewrite subsetI sXMs (subset_trans sXY). + by rewrite 3!inE maxH (contra_orbit _ _ notMGH). +have [sNX_M | not_sNX_M] := boolP ('N(X) \subset M). + have sNY_M: 'N(Y) \subset M := subset_trans (char_norms charX) sNX_M. + split=> [|E p H hallE piEp bG'p maxY_H notMGH]; last split. + - exists 1; rewrite act1 (sub_Hall_pcore (Msigma_Hall maxM)) //. + exact: subset_trans (normG Y) sNY_M. + - rewrite (leq_trans (p_rankS p (setIS H sNY_M))) ?(pre_part_a E) //. + case/and3P=> _ _; apply: contra; rewrite mem_primes => /and3P[_ _ pM']. + by apply: dvdn_trans pM' (cardSg (dergS 1 _)); rewrite subIset ?sNY_M ?orbT. +have [L maxNX_L] := mmax_exists (mFT_norm_proper ntX (mFT_pgroup_proper qX)). +have [maxL sNX_L] := setIdP maxNX_L. +have{maxNX_L} maxNX_L: L \in 'M('N(X)) :\ M. + by rewrite 2!inE maxNX_L andbT; apply: contraNneq not_sNX_M => <-. +have sXM := subset_trans sXMs (pcore_sub _ M). +have [notMGL _ embedL] := sigma_subgroup_embedding maxM sMq sXM qX ntX maxNX_L. +pose K := (if q \in \sigma(L) then L`_\beta else L`_\sigma)%G. +have sM'K: \sigma(M)^'.-group K. + rewrite orbit_sym in notMGL. + rewrite /K; case: (boolP (q \in _)) embedL => [sLq _ | sL'q [t2Lq _ _]]. + have [_ TIaLsM _] := sigma_disjoint maxL maxM notMGL. + apply: sub_pgroup (pcore_pgroup _ _) => p bLp. + by apply: contraFN (TIaLsM p) => /= sMp; rewrite inE /= beta_sub_alpha. + have [F hallF] := ex_sigma_compl maxL. + have [A Ep2A _] := ex_tau2Elem hallF t2Lq. + have [_ _ _ TIsLs] := tau2_compl_context maxL hallF t2Lq Ep2A. + have{TIsLs} [_ TIsLsM] := TIsLs M maxM notMGL. + apply: sub_pgroup (pcore_pgroup _ _) => p sLp. + by apply: contraFN (TIsLsM p) => /= sMp; rewrite inE /= sLp. +have defL: K * (M :&: L) = L. + rewrite /K; case: (q \in _) embedL => [] [] // _ _. + by move/(sdprod_Hall_pcoreP (Msigma_Hall maxL)); case/sdprodP. +have sYL := subset_trans (char_norm charX) sNX_L. +have [x sYxMs]: exists x, Y :^ x \subset M`_\sigma. + have solML := solvableS (subsetIl M L) (mmax_sol maxM). + have [H hallH] := Hall_exists \sigma(M) solML. + have [sHM sHL] := subsetIP (pHall_sub hallH). + have hallH_L: \sigma(M).-Hall(L) H. + rewrite pHallE sHL -defL -LagrangeMr partnM ?cardG_gt0 //. + rewrite -(card_Hall hallH) part_p'nat ?mul1n //=. + exact: pnat_dvd (dvdn_indexg _ _) sM'K. + have [x _ sYxH]:= Hall_Jsub (mmax_sol maxL) hallH_L sYL sM_Y. + exists x; rewrite (sub_Hall_pcore (Msigma_Hall maxM)) ?pgroupJ //. + exact: subset_trans sYxH sHM. +split=> [|E p H hallE piEp bG'p maxY_H notMGH]; first by exists x. +have p'K: p^'.-group K. + have bL'p: p \notin \beta(L). + by rewrite -predI_sigma_beta // negb_and bG'p orbT. + rewrite /K; case: (q \in _) embedL => [_ | [_ bLp _]]. + by rewrite (pi_p'group (pcore_pgroup _ _)). + rewrite (pi_p'group (pcore_pgroup _ _)) //; apply: contra bL'p => /= sLp. + by rewrite bLp // inE /= (piSg (pHall_sub hallE)). +have sNHY_L: 'N_H(Y) \subset L. + by rewrite subIset ?(subset_trans (char_norms charX)) ?orbT. +rewrite (leq_trans (p_rankS p sNHY_L)); last first. + have [P sylP] := Sylow_exists p (M :&: L). + have [_ sPL] := subsetIP (pHall_sub sylP). + have{sPL} sylP_L: p.-Sylow(L) P. + rewrite pHallE sPL -defL -LagrangeMr partnM ?cardG_gt0 //. + rewrite -(card_Hall sylP) part_p'nat ?mul1n //=. + exact: pnat_dvd (dvdn_indexg _ _) p'K. + rewrite -(p_rank_Sylow sylP_L) {P sylP sylP_L}(p_rank_Sylow sylP). + by rewrite /= setIC (pre_part_a E) // inE maxL. +split=> // t1Mp; rewrite (contra ((piSg (dergS 1 sNHY_L)) p)) // -p'groupEpi. +have nsKL: K <| L by rewrite /K; case: ifP => _; apply: pcore_normal. +have [sKL nKL] := andP nsKL; have nKML := subset_trans (subsetIr M L) nKL. +suffices: p^'.-group (K * (M :&: L)^`(1)). + have sder := subset_trans (der_sub 1 _). + rewrite -norm_joinEr ?sder //; apply: pgroupS => /=. + rewrite norm_joinEr -?quotientSK ?sder //= !quotient_der //. + by rewrite -{1}defL quotientMidl. +rewrite pgroupM p'K (pgroupS (dergS 1 (subsetIl M L))) // p'groupEpi. +by rewrite mem_primes andbA andbC negb_and; case/and3P: t1Mp => _ _ ->. +Qed. + +(* This is B & G, Lemma 12.17. *) +Lemma sigma_compl_embedding M E (Ms := M`_\sigma) : + M \in 'M -> \sigma(M)^'.-Hall(M) E -> + [/\ 'C_Ms(E) \subset Ms^`(1), [~: Ms, E] = Ms + & forall g (MsMg := Ms :&: M :^ g), g \notin M -> + [/\ cyclic MsMg, \beta(M)^'.-group MsMg & MsMg :&: Ms^`(1) = 1]]. +Proof. +move=> maxM hallE; have [sEM s'E _] := and3P hallE. +have solMs: solvable Ms := solvableS (pcore_sub _ _) (mmax_sol maxM). +have defM := coprime_der1_sdprod (sdprod_sigma maxM hallE). +have{s'E} coMsE: coprime #|Ms| #|E| := pnat_coprime (pcore_pgroup _ _) s'E. +have{defM coMsE} [-> ->] := defM coMsE solMs (Msigma_der1 maxM). +split=> // g MsMg notMg. +have sMsMg: \sigma(M).-group MsMg := pgroupS (subsetIl _ _) (pcore_pgroup _ _). +have EpMsMg p n X: X \in 'E_p^n(MsMg) -> n > 0 -> + n = 1%N /\ ~~ ((p \in \beta(M)) || (X \subset Ms^`(1))). +- move=> EpX n_gt0; have [sXMsMg abelX dimX] := pnElemP EpX. + have [[sXMs sXMg] [pX _]] := (subsetIP sXMsMg, andP abelX). + have sXM := subset_trans sXMs (pcore_sub _ _). + have piXp: p \in \pi(X) by rewrite -p_rank_gt0 p_rank_abelem ?dimX. + have sMp: p \in \sigma(M) := pnatPpi (pgroupS sXMs (pcore_pgroup _ _)) piXp. + have not_sCX_M: ~~ ('C(X) \subset M). + apply: contra notMg => sCX_M; rewrite -groupV. + have [transCX _ _] := sigma_group_trans maxM sMp pX. + have [|c CXc [m Mm ->]] := transCX g^-1 sXM; rewrite ?sub_conjgV //. + by rewrite groupM // (subsetP sCX_M). + have cycX: cyclic X. + apply: contraR not_sCX_M => ncycX; apply: subset_trans (cent_sub _) _. + exact: norm_noncyclic_sigma maxM sMp pX sXM ncycX. + have n1: n = 1%N by apply/eqP; rewrite eqn_leq -{1}dimX -abelem_cyclic ?cycX. + rewrite n1 in dimX *; split=> //; apply: contra not_sCX_M. + by case/cent_der_sigma_uniq=> //; [apply/pnElemP | case/mem_uniq_mmax]. +have tiMsMg_Ms': MsMg :&: Ms^`(1) = 1. + apply/eqP/idPn; rewrite -rank_gt0 => /rank_geP[X /nElemP[p]]. + case/pnElemP=> /subsetIP[sXMsMg sXMs'] abelX dimX. + by case: (EpMsMg p 1%N X) => //; [apply/pnElemP | rewrite sXMs' orbT]. +split=> //; last first. + apply: sub_in_pnat sMsMg => p. + by rewrite -p_rank_gt0 => /p_rank_geP[X /EpMsMg[] // _ /norP[]]. +rewrite abelian_rank1_cyclic. + by rewrite leqNgt; apply/rank_geP=> [[X /nElemP[p /EpMsMg[]]]]. +by rewrite (sameP derG1P trivgP) -tiMsMg_Ms' subsetI der_sub dergS ?subsetIl. +Qed. + +(* This is B & G, Lemma 12.18. *) +(* We corrected an omission in the text, which fails to quote Lemma 10.3 to *) +(* justify the two p-rank inequalities (12.5) and (12.6), and indeed *) +(* erroneously refers to 12.2(a) for (12.5). Note also that the loosely *) +(* justified equalities of Ohm_1 subgroups are in fact unnecessary. *) +Lemma cent_Malpha_reg_tau1 M p q P Q (Ma := M`_\alpha) : + M \in 'M -> p \in \tau1(M) -> q \in p^' -> P \in 'E_p^1(M) -> Q :!=: 1 -> + P \subset 'N(Q) -> 'C_Q(P) = 1 -> 'M('N(Q)) != [set M] -> + [/\ (*a*) Ma != 1 -> q \notin \alpha(M) -> q.-group Q -> Q \subset M -> + 'C_Ma(P) != 1 /\ 'C_Ma(Q <*> P) = 1 + & (*b*) q.-Sylow(M) Q -> + [/\ \alpha(M) =i \beta(M), Ma != 1, q \notin \alpha(M), + 'C_Ma(P) != 1 & 'C_Ma(Q <*> P) = 1]]. +Proof. +move=> maxM t1p p'q EpP ntQ nQP regPQ nonuniqNQ. +set QP := Q <*> P; set CaQP := 'C_Ma(QP); set part_a := _ -> _. +have ssolM := solvableS _ (mmax_sol maxM). +have [sPM abelP oP] := pnElemPcard EpP; have{abelP} [pP _] := andP abelP. +have p_pr := pnElem_prime EpP; have [s'p _] := andP t1p. +have a'p: p \in \alpha(M)^' by apply: contra s'p; apply: alpha_sub_sigma. +have{a'p} [a'P t2'p] := (pi_pgroup pP a'p, tau2'1 t1p). +have uniqCMX: 'M('C_M(_)) = [set M] := def_uniq_mmax _ maxM (subsetIl _ _). +have nQ_CMQ: 'C_M(Q) \subset 'N(Q) by rewrite setIC subIset ?cent_sub. +have part_a_holds: part_a. + move=> ntMa a'q qQ sQM; have{p'q} p'Q := pi_pgroup qQ p'q. + have{p'Q} coQP: coprime #|Q| #|P| by rewrite coprime_sym (pnat_coprime pP). + have{a'q} a'Q: \alpha(M)^'.-group Q by rewrite (pi_pgroup qQ). + have rCMaQle1: 'r('C_Ma(Q)) <= 1. + rewrite leqNgt; apply: contra nonuniqNQ => rCMaQgt1; apply/eqP. + apply: def_uniq_mmaxS (uniqCMX Q _) => //; last exact: cent_alpha'_uniq. + exact: mFT_norm_proper (mFT_pgroup_proper qQ). + have rCMaPle1: 'r('C_Ma(P)) <= 1. + have: ~~ ('N(P) \subset M). + by apply: contra (prime_class_mmax_norm maxM pP) _; apply/norP. + rewrite leqNgt; apply: contra => rCMaPgt1. + apply: (sub_uniq_mmax (uniqCMX P _)); first exact: cent_alpha'_uniq. + by rewrite /= setIC subIset ?cent_sub. + exact: mFT_norm_proper (nt_pnElem EpP _) (mFT_pgroup_proper pP). + have [sMaM nMaM] := andP (pcore_normal _ M : Ma <| M). + have aMa: \alpha(M).-group Ma by rewrite pcore_pgroup. + have nMaQP: QP \subset 'N(Ma) by rewrite join_subG !(subset_trans _ nMaM). + have{nMaM} coMaQP: coprime #|Ma| #|QP|. + by rewrite (pnat_coprime aMa) ?[QP]norm_joinEr // [pnat _ _]pgroupM ?a'Q. + pose r := pdiv #|if CaQP == 1 then Ma else CaQP|. + have{ntMa} piMar: r \in \pi(Ma). + rewrite /r; case: ifPn => [_| ntCaQP]; first by rewrite pi_pdiv cardG_gt1. + by rewrite (piSg (subsetIl Ma 'C(QP))) // pi_pdiv cardG_gt1. + have{aMa} a_r: r \in \alpha(M) := pnatPpi aMa piMar. + have [r'Q r'P] : r^'.-group Q /\ r^'.-group P by rewrite !(pi'_p'group _ a_r). + have [Rc /= sylRc] := Sylow_exists r [group of CaQP]. + have [sRcCaQP rRc _] := and3P sylRc; have [sRcMa cQPRc] := subsetIP sRcCaQP. + have nRcQP: QP \subset 'N(Rc) by rewrite cents_norm // centsC. + have{nMaQP rRc coMaQP sRcCaQP sRcMa nRcQP} [R [sylR nR_QP sRcR]] := + coprime_Hall_subset nMaQP coMaQP (ssolM _ sMaM) sRcMa rRc nRcQP. + have{nR_QP} [[sRMa rR _] [nRQ nRP]] := (and3P sylR, joing_subP nR_QP). + have{piMar} ntR: R :!=: 1 by rewrite -rank_gt0 (rank_Sylow sylR) p_rank_gt0. + have [r_pr _ _] := pgroup_pdiv rR ntR. + have sylR_M := subHall_Sylow (Malpha_Hall maxM) a_r sylR. + have{rCMaQle1 a_r} not_cRQ: ~~ (Q \subset 'C(R)). + apply: contraL rCMaQle1; rewrite centsC => cQR; rewrite -ltnNge ltnW //. + by rewrite (leq_trans a_r) // -(rank_Sylow sylR_M) rankS // subsetI sRMa. + have [R1 [charR1 _ _ expR1 rCR1_AutR]] := critical_odd rR (mFT_odd R) ntR. + have [sR1R nR1R] := andP (char_normal charR1); have rR1 := pgroupS sR1R rR. + have [nR1P nR1Q] := (char_norm_trans charR1 nRP, char_norm_trans charR1 nRQ). + have [coR1Q coR1P] := (pnat_coprime rR1 r'Q, pnat_coprime rR1 r'P). + have {rCR1_AutR not_cRQ} not_cR1Q: ~~ (Q \subset 'C(R1)). + apply: contra not_cRQ => cR1Q; rewrite -subsetIidl. + rewrite -quotient_sub1 ?normsI ?normG ?norms_cent // subG1 trivg_card1. + rewrite (pnat_1 _ (quotient_pgroup _ r'Q)) //= -ker_conj_aut. + rewrite (card_isog (first_isog_loc _ _)) //; apply: pgroupS rCR1_AutR. + apply/subsetP=> za; case/morphimP=> z nRz Qz ->; rewrite inE Aut_aut inE. + apply/subsetP=> x R1x; rewrite inE [_ x _]norm_conj_autE ?(subsetP sR1R) //. + by rewrite /conjg -(centsP cR1Q z) ?mulKg. + pose R0 := 'C_R1(Q); have sR0R1: R0 \subset R1 := subsetIl R1 'C(Q). + have nR0P: P \subset 'N(R0) by rewrite normsI ?norms_cent. + have nR0Q: Q \subset 'N(R0) by rewrite normsI ?norms_cent ?normG. + pose R1Q := R1 <*> Q; have defR1Q: R1 * Q = R1Q by rewrite -norm_joinEr. + have [[sR1_R1Q sQ_R1Q] tiR1Q] := (joing_sub (erefl R1Q), coprime_TIg coR1Q). + have not_nilR1Q: ~~ nilpotent R1Q. + by apply: contra not_cR1Q => /sub_nilpotent_cent2; apply. + have not_nilR1Qb: ~~ nilpotent (R1Q / R0). + apply: contra not_cR1Q => nilR1Qb. + have [nilR1 solR1] := (pgroup_nil rR1, pgroup_sol rR1). + rewrite centsC -subsetIidl -(nilpotent_sub_norm nilR1 sR0R1) //= -/R0. + rewrite -(quotientSGK (subsetIr R1 _)) ?coprime_quotient_cent //= -/R0. + rewrite quotientInorm subsetIidl /= centsC -/R0. + by rewrite (sub_nilpotent_cent2 nilR1Qb) ?quotientS ?coprime_morph. + have coR1QP: coprime #|R1Q| #|P|. + by rewrite -defR1Q TI_cardMg // coprime_mull coR1P. + have defR1QP: R1Q ><| P = R1Q <*> P. + by rewrite sdprodEY ?normsY ?coprime_TIg. + have sR1Ma := subset_trans sR1R sRMa; have sR1M := subset_trans sR1Ma sMaM. + have solR1Q: solvable R1Q by rewrite ssolM // !join_subG sR1M. + have solR1QP: solvable (R1Q <*> P) by rewrite ssolM // !join_subG sR1M sQM. + have defCR1QP: 'C_R1Q(P) = 'C_R1(P). + by rewrite -defR1Q -subcent_TImulg ?regPQ ?mulg1 //; apply/subsetIP. + have ntCR1P: 'C_R1(P) != 1. + apply: contraNneq not_nilR1Q => regPR1. + by rewrite (prime_Frobenius_sol_kernel_nil defR1QP) ?oP ?defCR1QP. + split; first exact: subG1_contra (setSI _ sR1Ma) ntCR1P. + have{rCMaPle1} cycCRP: cyclic 'C_R(P). + have rCRP: r.-group 'C_R(P) := pgroupS (subsetIl R _) rR. + rewrite (odd_pgroup_rank1_cyclic rCRP) ?mFT_odd -?rank_pgroup {rCRP}//. + by rewrite (leq_trans (rankS _) rCMaPle1) ?setSI. + have{ntCR1P} oCR1P: #|'C_R1(P)| = r. + have cycCR1P: cyclic 'C_R1(P) by rewrite (cyclicS _ cycCRP) ?setSI. + apply: cyclic_abelem_prime ntCR1P => //. + by rewrite abelemE ?cyclic_abelian // -expR1 exponentS ?subsetIl. + apply: contraNeq not_nilR1Qb => ntCaQP. + have{Rc sRcR sylRc cQPRc ntCaQP} ntCRQP: 'C_R(QP) != 1. + suffices: Rc :!=: 1 by apply: subG1_contra; apply/subsetIP. + rewrite -rank_gt0 (rank_Sylow sylRc) p_rank_gt0. + by rewrite /r (negPf ntCaQP) pi_pdiv cardG_gt1. + have defR1QPb: (R1Q / R0) ><| (P / R0) = R1Q <*> P / R0. + have [_ <- nR1QP _] := sdprodP defR1QP; rewrite quotientMr //. + by rewrite sdprodE ?quotient_norms // coprime_TIg ?coprime_morph. + have tiPR0: R0 :&: P = 1 by rewrite coprime_TIg // (coprimeSg sR0R1). + have prPb: prime #|P / R0| by rewrite -(card_isog (quotient_isog _ _)) ?oP. + rewrite (prime_Frobenius_sol_kernel_nil defR1QPb) ?quotient_sol //. + rewrite -coprime_quotient_cent ?(subset_trans sR0R1) // quotientS1 //=. + rewrite defCR1QP -{2}(setIidPl sR1R) -setIA subsetI subsetIl. + apply: subset_trans (setIS R (centS (joing_subl Q P))). + rewrite -(cardSg_cyclic cycCRP) ?setIS ?setSI ?centS ?joing_subr // oCR1P. + by have [_ -> _] := pgroup_pdiv (pgroupS (subsetIl R _) rR) ntCRQP. +split=> // sylQ; have [sQM qQ _] := and3P sylQ. +have ltQG := mFT_pgroup_proper qQ; have ltNQG := mFT_norm_proper ntQ ltQG. +have{p'q} p'Q := pi_pgroup qQ p'q. +have{p'Q} coQP: coprime #|Q| #|P| by rewrite coprime_sym (pnat_coprime pP). +have sQM': Q \subset M^`(1). + by rewrite -(coprime_cent_prod nQP) ?ssolM // regPQ mulg1 commgSS. +have ntMa: Ma != 1. + apply: contraNneq nonuniqNQ => Ma1. + rewrite (mmax_normal maxM _ ntQ) ?mmax_sup_id //. + apply: char_normal_trans (der_normal 1 M). + have sylQ_M': q.-Sylow(M^`(1)) Q := pHall_subl sQM' (der_sub 1 M) sylQ. + rewrite (nilpotent_Hall_pcore _ sylQ_M') ?pcore_char //. + by rewrite (isog_nil (quotient1_isog _)) -Ma1 Malpha_quo_nil. +have a'q: q \notin \alpha(M). + apply: contra nonuniqNQ => a_q. + have uniqQ: Q \in 'U by rewrite rank3_Uniqueness ?(rank_Sylow sylQ). + by rewrite (def_uniq_mmaxS _ _ (def_uniq_mmax _ _ sQM)) ?normG. +have b'q := contra (@beta_sub_alpha _ M _) a'q. +case: part_a_holds => // ntCaP regQP; split=> {ntCaP regQP}// r. +apply/idP/idP=> [a_r | ]; last exact: beta_sub_alpha. +apply: contraR nonuniqNQ => b'r; apply/eqP. +apply: def_uniq_mmaxS (uniqCMX Q _) => //. +have q'r: r != q by apply: contraNneq a'q => <-. +by have [|_ -> //] := beta'_cent_Sylow maxM b'r b'q qQ; rewrite q'r sQM'. +Qed. + +(* This is B & G, Lemma 12.19. *) +(* We have used lemmas 10.8(b) and 10.2(c) rather than 10.9(a) as suggested *) +(* in the text; this avoids a quantifier inversion! *) +Lemma der_compl_cent_beta' M E : + M \in 'M -> \sigma(M)^'.-Hall(M) E -> + exists2 H : {group gT}, \beta(M)^'.-Hall(M`_\sigma) H & E^`(1) \subset 'C(H). +Proof. +move=> maxM hallE; have [sEM s'E _] := and3P hallE. +have s'E': \sigma(M)^'.-group E^`(1) := pgroupS (der_sub 1 E) s'E. +have b'E': \beta(M)^'.-group E^`(1). + by apply: sub_pgroup s'E' => p; apply: contra; apply: beta_sub_sigma. +have solM': solvable M^`(1) := solvableS (der_sub 1 M) (mmax_sol maxM). +have [K hallK sE'K] := Hall_superset solM' (dergS 1 sEM) b'E'. +exists (K :&: M`_\sigma)%G. + apply: Hall_setI_normal hallK. + exact: normalS (Msigma_der1 maxM) (der_sub 1 M) (pcore_normal _ M). +have nilK: nilpotent K. + by have [sKM' b'K _] := and3P hallK; apply: beta'_der1_nil sKM'. +rewrite (sub_nilpotent_cent2 nilK) ?subsetIl ?(coprimeSg (subsetIr _ _)) //. +exact: pnat_coprime (pcore_pgroup _ _) s'E'. +Qed. + +End Section12. + +Implicit Arguments tau2'1 [[gT] [M] x]. +Implicit Arguments tau3'1 [[gT] [M] x]. +Implicit Arguments tau3'2 [[gT] [M] x]. + diff --git a/mathcomp/odd_order/BGsection13.v b/mathcomp/odd_order/BGsection13.v new file mode 100644 index 0000000..be68f9d --- /dev/null +++ b/mathcomp/odd_order/BGsection13.v @@ -0,0 +1,1116 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div path fintype. +Require Import bigop finset prime fingroup morphism perm automorphism quotient. +Require Import action gproduct gfunctor pgroup cyclic center commutator. +Require Import gseries nilpotent sylow abelian maximal hall frobenius. +Require Import BGsection1 BGsection3 BGsection4 BGsection5 BGsection6. +Require Import BGsection7 BGsection9 BGsection10 BGsection12. + +(******************************************************************************) +(* This file covers B & G, section 13; the title subject of the section, *) +(* prime and regular actions, was defined in the frobenius.v file. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section Section13. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). +Implicit Types p q q_star r : nat. +Implicit Types A E H K L M Mstar N P Q Qstar R S T U V W X Y Z : {group gT}. + +Section OneComplement. + +Variables M E : {group gT}. +Hypotheses (maxM : M \in 'M) (hallE : \sigma(M)^'.-Hall(M) E). + +Let sEM : E \subset M := pHall_sub hallE. +Let sM'E : \sigma(M)^'.-group E := pHall_pgroup hallE. + +(* This is B & G, Lemma 13.1. *) +Lemma Msigma_setI_mmax_central p H : + H \in 'M -> p \in \pi(E) -> p \in \pi(H) -> p \notin \tau1(H) -> + [~: M`_\sigma :&: H, M :&: H] != 1 -> gval H \notin M :^: G -> + [/\ (*a*) forall P, P \subset M :&: H -> p.-group P -> + P \subset 'C(M`_\sigma :&: H), + (*b*) p \notin \tau2(H) + & (*c*) p \in \tau1(M) -> p \in \beta(G)]. +Proof. +move=> maxH piEp piHp t1H'p; set R := [~: _, _] => ntR notMGH. +have [q sMq piH'q]: exists2 q, q \in \sigma(M) & q \in \pi(H^`(1)). + pose q := pdiv #|R|; have q_pr: prime q by rewrite pdiv_prime ?cardG_gt1. + have q_dv : q %| _ := dvdn_trans (pdiv_dvd _) (cardSg _). + exists q; last by rewrite mem_primes q_pr cardG_gt0 q_dv ?commgSS ?subsetIr. + rewrite (pgroupP (pcore_pgroup _ M)) ?q_dv //. + have sR_MsM: R \subset [~: M`_\sigma, M] by rewrite commgSS ?subsetIl. + by rewrite (subset_trans sR_MsM) // commg_subl gFnorm. +have [Y sylY] := Sylow_exists q H^`(1); have [sYH' qY _] := and3P sylY. +have nsHbH: H`_\beta <| H := pcore_normal _ _; have [_ nHbH] := andP nsHbH. +have sYH := subset_trans sYH' (der_sub 1 H); have nHbY := subset_trans sYH nHbH. +have nsHbY_H: H`_\beta <*> Y <| H. + rewrite -{2}(quotientGK nsHbH) -quotientYK ?cosetpre_normal //. + rewrite (char_normal_trans _ (der_normal 1 _)) //= -quotient_der //. + rewrite (nilpotent_Hall_pcore _ (quotient_pHall nHbY sylY)) ?pcore_char //. + exact: Mbeta_quo_nil. +have sYNY: Y \subset 'N_H(Y) by rewrite subsetI sYH normG. +have{nsHbY_H} defH: H`_\beta * 'N_H(Y) = H. + rewrite -(mulSGid sYNY) mulgA -(norm_joinEr nHbY). + rewrite (Frattini_arg _ (pHall_subl _ _ sylY)) ?joing_subr //. + by rewrite join_subG Mbeta_der1. +have ntY: Y :!=: 1 by rewrite -cardG_gt1 (card_Hall sylY) p_part_gt1. +have{ntY} [_] := sigma_Jsub maxM (pi_pgroup qY sMq) ntY. +have maxY_H: H \in 'M(Y) by apply/setIdP. +move/(_ E p H hallE piEp _ maxY_H notMGH) => b'p_t3Hp. +case t2Hp: (p \in \tau2(H)). + have b'p: p \notin \beta(G) by case/tau2_not_beta: t2Hp. + have rpH: 'r_p(H) = 2 by apply/eqP; case/andP: t2Hp. + have p'Hb: p^'.-group H`_\beta. + rewrite (pi_p'group (pcore_pgroup _ H)) // inE /=. + by rewrite -predI_sigma_beta // negb_and b'p orbT. + case: b'p_t3Hp; rewrite // -(p_rank_p'quotient p'Hb) ?subIset ?nHbH //=. + by rewrite -quotientMidl defH p_rank_p'quotient ?rpH. +have [S sylS] := Sylow_exists p H; have [sSH pS _] := and3P sylS. +have sSH': S \subset H^`(1). + have [sHp | sH'p] := boolP (p \in \sigma(H)). + apply: subset_trans (Msigma_der1 maxH). + by rewrite (sub_Hall_pcore (Msigma_Hall _)) // (pi_pgroup pS). + have sH'_S: \sigma(H)^'.-group S by rewrite (pi_pgroup pS). + have [F hallF sSF] := Hall_superset (mmax_sol maxH) sSH sH'_S. + have t3Hp: p \in \tau3(H). + have:= partition_pi_sigma_compl maxH hallF p. + by rewrite (pi_sigma_compl hallF) inE /= sH'p piHp (negPf t1H'p) t2Hp. + have [[F1 hallF1] [F3 hallF3]] := ex_tau13_compl hallF. + have [F2 _ complFi] := ex_tau2_compl hallF hallF1 hallF3. + have [[sF3F' nsF3F] _ _ _ _] := sigma_compl_context maxH complFi. + apply: subset_trans (subset_trans sF3F' (dergS 1 (pHall_sub hallF))). + by rewrite (sub_normal_Hall hallF3) ?(pi_pgroup pS). +have sylS_H' := pHall_subl sSH' (der_sub 1 H) sylS. +split=> // [P sPMH pP | t1Mp]; last first. + apply/idPn=> b'p; have [_ /(_ t1Mp)/negP[]] := b'p_t3Hp b'p. + have p'Hb: p^'.-group H`_\beta. + rewrite (pi_p'group (pcore_pgroup _ H)) // inE /=. + by rewrite -predI_sigma_beta // negb_and b'p orbT. + rewrite -p_rank_gt0 -(p_rank_p'quotient p'Hb) ?comm_subG ?subIset ?nHbH //=. + rewrite quotient_der ?subIset ?nHbH // -quotientMidl defH -quotient_der //=. + rewrite p_rank_p'quotient ?comm_subG // -(rank_Sylow sylS_H'). + by rewrite (rank_Sylow sylS) p_rank_gt0. +have nsHaH: H`_\alpha <| H := pcore_normal _ _; have [_ nHaH] := andP nsHaH. +have [sPM sPH] := subsetIP sPMH; have nHaS := subset_trans sSH nHaH. +have nsHaS_H: H`_\alpha <*> S <| H. + rewrite -{2}(quotientGK nsHaH) -quotientYK ?cosetpre_normal //. + rewrite (char_normal_trans _ (der_normal 1 _)) //= -quotient_der //. + rewrite (nilpotent_Hall_pcore _ (quotient_pHall nHaS sylS_H')) ?pcore_char //. + exact: Malpha_quo_nil. +have [sHaS_H nHaS_H] := andP nsHaS_H. +have sP_HaS: P \subset H`_\alpha <*> S. + have [x Hx sPSx] := Sylow_subJ sylS sPH pP; apply: subset_trans sPSx _. + by rewrite sub_conjg (normsP nHaS_H) ?groupV ?joing_subr. +have coHaS_Ms: coprime #|H`_\alpha <*> S| #|M`_\sigma|. + rewrite (p'nat_coprime _ (pcore_pgroup _ _)) // -pgroupE norm_joinEr //. + rewrite pgroupM andbC (pi_pgroup pS) ?(pnatPpi (pHall_pgroup hallE)) //=. + apply: sub_pgroup (pcore_pgroup _ _) => r aHr. + have [|_ ti_aH_sM _] := sigma_disjoint maxH maxM; first by rewrite orbit_sym. + by apply: contraFN (ti_aH_sM r) => sMr; apply/andP. +rewrite (sameP commG1P trivgP) -(coprime_TIg coHaS_Ms) commg_subI ?setIS //. +by rewrite subsetI sP_HaS (subset_trans sPM) ?gFnorm. +Qed. + +(* This is B & G, Corollary 13.2. *) +Corollary cent_norm_tau13_mmax p P H : + (p \in \tau1(M)) || (p \in \tau3(M)) -> + P \subset M -> p.-group P -> H \in 'M('N(P)) -> + [/\ (*a*) forall P1, P1 \subset M :&: H -> p.-group P1 -> + P1 \subset 'C(M`_\sigma :&: H), + (*b*) forall X, X \subset E :&: H -> \tau1(H)^'.-group X -> + X \subset 'C(M`_\sigma :&: H) + & (*c*) [~: M`_\sigma :&: H, M :&: H] != 1 -> + p \in \sigma(H) /\ (p \in \tau1(M) -> p \in \beta(H))]. +Proof. +move=> t13Mp sPM pP /setIdP[maxH sNP_H]. +have ntP: P :!=: 1. + by apply: contraTneq sNP_H => ->; rewrite norm1 proper_subn ?mmax_proper. +have st2Hp: (p \in \sigma(H)) || (p \in \tau2(H)). + exact: (prime_class_mmax_norm maxH pP sNP_H). +have not_MGH: gval H \notin M :^: G. + apply: contraL st2Hp => /imsetP[x _ ->]; rewrite sigmaJ tau2J negb_or. + by have:= t13Mp; rewrite -2!andb_orr !inE => /and3P[-> /eqP->]. +set R := [~: _, _]; have [/commG1P | ntR] := altP (R =P 1). + rewrite centsC => cMH; split=> // X sX_EH _; apply: subset_trans cMH => //. + by rewrite (subset_trans sX_EH) ?setSI. +have piEp: p \in \pi(E). + by rewrite (partition_pi_sigma_compl maxM) // orbCA t13Mp orbT. +have piHp: p \in \pi(H). + by rewrite (partition_pi_mmax maxH) orbCA orbC -!orbA st2Hp !orbT. +have t1H'p: p \notin \tau1(H). + by apply: contraL st2Hp; rewrite negb_or !inE => /and3P[-> /eqP->]. +case: (Msigma_setI_mmax_central maxH piEp) => // cMsH t2H'p b_p. +split=> // [X sX_EH t1'X | _]. + have [sXE sXH] := subsetIP sX_EH. + rewrite -(Sylow_gen X) gen_subG; apply/bigcupsP=> Q; case/SylowP=> q _ sylQ. + have [-> | ntQ] := eqsVneq Q 1; first exact: sub1G. + have piXq: q \in \pi(X) by rewrite -p_rank_gt0 -(rank_Sylow sylQ) rank_gt0. + have [[piEq piHq] t1H'q] := (piSg sXE piXq, piSg sXH piXq, pnatPpi t1'X piXq). + have [sQX qQ _] := and3P sylQ; have sXM := subset_trans sXE sEM. + case: (Msigma_setI_mmax_central maxH piEq) => // -> //. + by rewrite subsetI !(subset_trans sQX). +rewrite (negPf t2H'p) orbF in st2Hp. +by rewrite -predI_sigma_beta // {3}/in_mem /= st2Hp. +Qed. + +(* This is B & G, Corollary 13.3(a). *) +Lemma cyclic_primact_Msigma p P : + p.-Sylow(E) P -> cyclic P -> semiprime M`_\sigma P. +Proof. +move=> sylP cycP x /setD1P[]; rewrite -cycle_eq1 -cycle_subG => ntX sXP. +have [sPE pP _] := and3P sylP; rewrite -cent_cycle. +have sPM := subset_trans sPE sEM; have sXM := subset_trans sXP sPM. +have pX := pgroupS sXP pP; have ltXG := mFT_pgroup_proper pX. +have t13p: (p \in \tau1(M)) || (p \in \tau3(M)). + rewrite (tau1E maxM hallE) (tau3E maxM hallE) -p_rank_gt0 -(rank_Sylow sylP). + rewrite eqn_leq rank_gt0 (subG1_contra sXP) //= andbT -andb_orl orNb. + by rewrite -abelian_rank1_cyclic ?cyclic_abelian. +have [H maxNH] := mmax_exists (mFT_norm_proper ntX ltXG). +have [cMsX _ _] := cent_norm_tau13_mmax t13p sXM pX maxNH. +have [_ sNH] := setIdP maxNH. +apply/eqP; rewrite eqEsubset andbC setIS ?centS // subsetI subsetIl /= centsC. +apply: subset_trans (cMsX P _ pP) (centS _). + rewrite subsetI sPM (subset_trans (cents_norm _) sNH) //. + by rewrite sub_abelian_cent // cyclic_abelian. +by rewrite setIS // (subset_trans (cent_sub _) sNH). +Qed. + +(* This is B & G, Corollary 13.3(b). *) +Corollary tau3_primact_Msigma E3 : + \tau3(M).-Hall(E) E3 -> semiprime M`_\sigma E3. +Proof. +move=> hallE3 x /setD1P[]; rewrite -cycle_eq1 -cycle_subG => ntX sXE3. +have [sE3E t3E3 _] := and3P hallE3; rewrite -cent_cycle. +have [[E1 hallE1] _] := ex_tau13_compl hallE. +have [E2 _ complEi] := ex_tau2_compl hallE hallE1 hallE3. +have [[sE3E' nsE3E] _ [_ cycE3] _ _] := sigma_compl_context maxM complEi. +apply/eqP; rewrite eqEsubset andbC setIS ?centS // subsetI subsetIl /= centsC. +pose p := pdiv #[x]; have p_pr: prime p by rewrite pdiv_prime ?cardG_gt1. +have t3p: p \in \tau3(M) by rewrite (pgroupP (pgroupS sXE3 t3E3)) ?pdiv_dvd. +have t13p: [|| p \in \tau1(M) | p \in \tau3(M)] by rewrite t3p orbT. +have [y Xy oy]:= Cauchy p_pr (pdiv_dvd _). +have ntY: <[y]> != 1 by rewrite -cardG_gt1 -orderE oy prime_gt1. +have pY: p.-group <[y]> by rewrite /pgroup -orderE oy pnat_id. +have [H maxNH] := mmax_exists (mFT_norm_proper ntY (mFT_pgroup_proper pY)). +have sYE3: <[y]> \subset E3 by rewrite cycle_subG (subsetP sXE3). +have sYE := subset_trans sYE3 sE3E; have sYM := subset_trans sYE sEM. +have [_ cMsY _] := cent_norm_tau13_mmax t13p sYM pY maxNH. +have [_ sNH] := setIdP maxNH. +have sE3H': E3 \subset H^`(1). + rewrite (subset_trans sE3E') ?dergS // (subset_trans _ sNH) ?normal_norm //. + by rewrite (char_normal_trans _ nsE3E) // sub_cyclic_char. +apply: subset_trans (cMsY E3 _ _) (centS _). +- rewrite subsetI sE3E (subset_trans (cents_norm _) sNH) //. + by rewrite sub_abelian_cent ?cyclic_abelian. +- rewrite (pgroupS sE3H') //; apply/pgroupP=> q _ q_dv_H'. + by rewrite !inE q_dv_H' !andbF. +by rewrite setIS // (subset_trans _ sNH) // cents_norm ?centS ?cycle_subG. +Qed. + +(* This is B & G, Theorem 13.4. *) +(* Note how the non-structural steps in the proof (top of p. 99, where it is *) +(* deduced that C_M_alpha(P) <= C_M_alpha(R) from q \notin \alpha, and then *) +(* C_M_alpha(P) = C_M_alpha(R) from r \in tau_1(M) !!), are handled cleanly *) +(* on lines 5-12 of the proof by a conditional expression for the former, and *) +(* a without loss tactic for the latter. *) +(* Also note that the references to 10.12 and 12.2 are garbled (some are *) +(* missing, and some are exchanged!). *) +Theorem cent_tau1Elem_Msigma p r P R (Ms := M`_\sigma) : + p \in \tau1(M) -> P \in 'E_p^1(E) -> R \in 'E_r^1('C_E(P)) -> + 'C_Ms(P) \subset 'C_Ms(R). +Proof. +have /andP[sMsM nMsM]: Ms <| M := pcore_normal _ M. +have coMsE: coprime #|Ms| #|E| := coprime_sigma_compl hallE. +pose Ma := M`_\alpha; have sMaMs: Ma \subset Ms := Malpha_sub_Msigma maxM. +rewrite pnElemI -setIdE => t1Mp EpP /setIdP[ErR cPR]. +without loss symPR: p r P R EpP ErR cPR t1Mp / + r \in \tau1(M) -> 'C_Ma(P) \subset 'C_Ma(R) -> 'C_Ma(P) = 'C_Ma(R). +- move=> IH; apply: (IH p r) => // t1Mr sCaPR; apply/eqP; rewrite eqEsubset. + rewrite sCaPR -(setIidPl sMaMs) -!setIA setIS ?(IH r p) 1?centsC // => _. + by case/eqVproper; rewrite // /proper sCaPR andbF. +do [rewrite !subsetI !subsetIl /=; set cRCaP := _ \subset _] in symPR *. +pose Mz := 'O_(if cRCaP then \sigma(M) else \alpha(M))(M); pose C := 'C_Mz(P). +suffices: C \subset 'C(R) by rewrite /C /Mz /cRCaP; case: ifP => // ->. +have sMzMs: Mz \subset Ms by rewrite /Mz; case: ifP => // _. +have sCMs: C \subset Ms by rewrite subIset ?sMzMs. +have [[sPE abelP dimP] [sRE abelR dimR]] := (pnElemP EpP, pnElemP ErR). +have [sPM sRM] := (subset_trans sPE sEM, subset_trans sRE sEM). +have [[pP cPP _] [rR _]] := (and3P abelP, andP abelR). +have coCR: coprime #|C| #|R| := coprimeSg sCMs (coprimegS sRE coMsE). +have ntP: P :!=: 1 by exact: nt_pnElem EpP _. +pose ST := [set S | Sylow C (gval S) & R \subset 'N(S)]. +have sST_CP S: S \in ST -> S \subset C by case/setIdP=> /SylowP[q _ /andP[]]. +rewrite -{sST_CP}[C](Sylow_transversal_gen sST_CP) => [|q _]; last first. + have nMzR: R \subset 'N(Mz) by rewrite (subset_trans sRM) // gFnorm. + have{nMzR} nCR: R \subset 'N(C) by rewrite normsI // norms_cent // cents_norm. + have solC := solvableS (subset_trans sCMs sMsM) (mmax_sol maxM). + have [S sylS nSR] := coprime_Hall_exists q nCR coCR solC. + by exists S; rewrite // inE (p_Sylow sylS) nSR. +rewrite gen_subG; apply/bigcupsP=> S /setIdP[/SylowP[q _ sylS] nSR] {ST}. +have [sSC qS _] := and3P sylS. +have [sSMs [sSMz cPS]] := (subset_trans sSC sCMs, subsetIP sSC). +rewrite (sameP commG1P eqP) /=; set Q := [~: S, R]; apply/idPn => ntQ. +have sQS: Q \subset S by [rewrite commg_subl]; have qQ := pgroupS sQS qS. +have piQq: q \in \pi(Q) by rewrite -p_rank_gt0 -(rank_pgroup qQ) rank_gt0. +have{piQq} [nQR piSq] := (commg_normr R S : R \subset 'N(Q), piSg sQS piQq). +have [H maxNH] := mmax_exists (mFT_norm_proper ntP (mFT_pgroup_proper pP)). +have [maxH sNH] := setIdP maxNH; have sCPH := subset_trans (cent_sub _) sNH. +have [sPH sRH] := (subset_trans cPP sCPH, subset_trans cPR sCPH). +have [sSM sSH] := (subset_trans sSMs sMsM, subset_trans cPS sCPH). +have [sQM sQH] := (subset_trans sQS sSM, subset_trans sQS sSH). +have ntMsH_R: [~: Ms :&: H, R] != 1. + by rewrite (subG1_contra _ ntQ) ?commSg // subsetI sSMs. +have sR_EH: R \subset E :&: H by apply/subsetIP. +have ntMsH_MH: [~: Ms :&: H, M :&: H] != 1. + by rewrite (subG1_contra _ ntMsH_R) ?commgS // (subset_trans sR_EH) ?setSI. +have t13Mp: p \in [predU \tau1(M) & \tau3(M)] by apply/orP; left. +have [_ cMsH_t1H' [//|sHp bHp]] := cent_norm_tau13_mmax t13Mp sPM pP maxNH. +have{cMsH_t1H'} t1Hr: r \in \tau1(H). + apply: contraR ntMsH_R => t1H'r; rewrite (sameP eqP commG1P) centsC. + by rewrite cMsH_t1H' // (pi_pgroup rR). +have ntCHaRQ: 'C_(H`_\alpha)(R <*> Q) != 1. + rewrite centY (subG1_contra _ ntP) ?subsetI //= centsC cPR centsC. + rewrite (subset_trans sQS cPS) (subset_trans _ (Mbeta_sub_Malpha H)) //. + by rewrite (sub_Hall_pcore (Mbeta_Hall maxH)) // (pi_pgroup pP) ?bHp. +have not_MGH: gval H \notin M :^: G. + by apply: contraL sHp => /imsetP[x _ ->]; rewrite sigmaJ; case/andP: t1Mp. +have neqHM: H :!=: M := contra_orbit _ _ not_MGH. +have cSS: abelian S. + apply: contraR neqHM => /(nonabelian_Uniqueness qS)uniqS. + by rewrite (eq_uniq_mmax (def_uniq_mmax uniqS maxM sSM) maxH sSH). +have tiQcR: 'C_Q(R) = 1 by rewrite coprime_abel_cent_TI // (coprimeSg sSC). +have sMq: q \in \sigma(M) := pnatPpi (pcore_pgroup _ M) (piSg sSMs piSq). +have aH'q: q \notin \alpha(H). + have [|_ tiHaMs _] := sigma_disjoint maxH maxM; first by rewrite orbit_sym. + by apply: contraFN (tiHaMs q) => aHq; apply/andP. +have piRr: r \in \pi(R) by rewrite -p_rank_gt0 p_rank_abelem ?dimR. +have ErH_R: R \in 'E_r^1(H) by rewrite !inE sRH abelR dimR. +have{piRr} sM'r: r \in \sigma(M)^' := pnatPpi (pgroupS sRE sM'E) piRr. +have r'q: q \in r^' by apply: contraTneq sMq => ->. +have ntHa: H`_\alpha != 1 by rewrite (subG1_contra _ ntCHaRQ) ?subsetIl. +have uniqNQ: 'M('N(Q)) = [set H]. + apply: contraNeq ntCHaRQ; rewrite joingC. + by case/(cent_Malpha_reg_tau1 _ _ r'q ErH_R) => //; case=> //= _ -> _. +have maxNQ_H: H \in 'M('N(Q)) :\ M by rewrite uniqNQ !inE neqHM /=. +have{maxNQ_H} [_ _] := sigma_subgroup_embedding maxM sMq sQM qQ ntQ maxNQ_H. +have [sHq [_ st1HM [_ ntMa]] | _ [_ _ sM'MH]] := ifP; last first. + have piPp: p \in \pi(P) by rewrite -p_rank_gt0 p_rank_abelem ?dimP. + have sPMH: P \subset M :&: H by apply/subsetIP. + by have/negP[] := pnatPpi (pgroupS sPMH (pHall_pgroup sM'MH)) piPp. +have{st1HM} t1Mr: r \in \tau1(M). + by case/orP: (st1HM r t1Hr); rewrite //= (contraNF ((alpha_sub_sigma _) r)). +have aM'q: q \notin \alpha(M). + have [_ tiMaHs _] := sigma_disjoint maxM maxH not_MGH. + by apply: contraFN (tiMaHs q) => aMq; apply/andP. +have ErM_R: R \in 'E_r^1(M) by rewrite !inE sRM abelR dimR. +have: 'M('N(Q)) != [set M] by rewrite uniqNQ (inj_eq (@set1_inj _)). +case/(cent_Malpha_reg_tau1 _ _ r'q ErM_R) => //. +case=> //= ntCMaP tiCMaPQ _; case/negP: ntCMaP. +rewrite -subG1 -{}tiCMaPQ centY setICA subsetIidr /= -/Ma -/Q centsC. +apply/commG1P/three_subgroup; apply/commG1P. + by rewrite commGC (commG1P _) ?sub1G ?subsetIr. +apply: subset_trans (subsetIr Ma _); rewrite /= -symPR //. + rewrite commg_subl normsI //; last by rewrite norms_cent // cents_norm. + by rewrite (subset_trans sSM) ?gFnorm. +apply: contraR aM'q => not_cRCaP; apply: pnatPpi (pgroupS sSMz _) piSq. +by rewrite (negPf not_cRCaP) pcore_pgroup. +Qed. + +(* This is B & G, Theorem 13.5. *) +Theorem tau1_primact_Msigma E1 : \tau1(M).-Hall(E) E1 -> semiprime M`_\sigma E1. +Proof. +move=> hallE1 x /setD1P[]; rewrite -cycle_eq1 -cycle_subG => ntX sXE1. +rewrite -cent_cycle; have [sE1E t1E1 _] := and3P hallE1. +have [_ [E3 hallE3]] := ex_tau13_compl hallE. +have{hallE3} [E2 _ complEi] := ex_tau2_compl hallE hallE1 hallE3. +have [_ _ [cycE1 _] _ _ {E2 E3 complEi}] := sigma_compl_context maxM complEi. +apply/eqP; rewrite eqEsubset andbC setIS ?centS //= subsetI subsetIl /=. +have [p _ rX] := rank_witness <[x]>; rewrite -rank_gt0 {}rX in ntX. +have t1p: p \in \tau1(M) by rewrite (pnatPpi t1E1) // (piSg sXE1) -?p_rank_gt0. +have{ntX} [P EpP] := p_rank_geP ntX; have{EpP} [sPX abelP dimP] := pnElemP EpP. +have{sXE1} sPE1 := subset_trans sPX sXE1. +have{dimP} EpP: P \in 'E_p^1(E) by rewrite !inE abelP dimP (subset_trans sPE1). +apply: {x sPX abelP} subset_trans (setIS _ (centS sPX)) _; rewrite centsC. +rewrite -(Sylow_gen E1) gen_subG; apply/bigcupsP=> S; case/SylowP=> r _ sylS. +have [[sSE1 rS _] [-> | ntS]] := (and3P sylS, eqsVneq S 1); first exact: sub1G. +have [cycS sSE] := (cyclicS sSE1 cycE1, subset_trans sSE1 sE1E). +have /p_rank_geP[R ErR]: 0 < 'r_r(S) by rewrite -rank_pgroup ?rank_gt0. +have{ErR} [sRS abelR dimR] := pnElemP ErR; have sRE1 := subset_trans sRS sSE1. +have{abelR dimR} ErR: R \in 'E_r^1('C_E(P)). + rewrite !inE abelR dimR (subset_trans sRE1) // subsetI sE1E. + by rewrite sub_abelian_cent ?cyclic_abelian. +rewrite centsC (subset_trans (cent_tau1Elem_Msigma t1p EpP ErR)) //. +have [y defR]: exists y, R :=: <[y]> by apply/cyclicP; exact: cyclicS cycS. +have sylS_E: r.-Sylow(E) S. + apply: subHall_Sylow hallE1 (pnatPpi t1E1 _) (sylS). + by rewrite -p_rank_gt0 -(rank_Sylow sylS) rank_gt0. +rewrite defR cent_cycle (cyclic_primact_Msigma sylS_E cycS) ?subsetIr //. +by rewrite !inE -cycle_subG -cycle_eq1 -defR (nt_pnElem ErR). +Qed. + +(* This is B & G, Lemma 13.6. *) +(* The wording at the top of the proof is misleading: it should say: by *) +(* Corollary 12.14, it suffices to show that we can't have both q \in beta(M) *) +(* and X \notsubset M_sigma^(1). Also, the reference to 12.13 should be 12.19 *) +(* or 10.9 (we've used 12.19 here). *) +Lemma cent_cent_Msigma_tau1_uniq E1 P q X (Ms := M`_\sigma) : + \tau1(M).-Hall(E) E1 -> P \subset E1 -> P :!=: 1 -> + X \in 'E_q^1('C_Ms(P)) -> + 'M('C(X)) = [set M] /\ (forall S, q.-Sylow(Ms) S -> 'M(S) = [set M]). +Proof. +move=> hallE1 sPE1 ntP EqX; have [sE1E t1E1 _] := and3P hallE1. +rewrite (cent_semiprime (tau1_primact_Msigma hallE1)) //= -/Ms in EqX. +have{P ntP sPE1} ntE1 := subG1_contra sPE1 ntP. +have /andP[sMsM nMsM]: Ms <| M := pcore_normal _ M. +have coMsE: coprime #|Ms| #|E| := coprime_sigma_compl hallE. +have [solMs nMsE] := (solvableS sMsM (mmax_sol maxM), subset_trans sEM nMsM). +apply: cent_der_sigma_uniq => //. + by move: EqX; rewrite -(setIidPr sMsM) -setIA pnElemI => /setIP[]. +have{EqX} [[sXcMsE1 abelX _] ntX] := (pnElemP EqX, nt_pnElem EqX isT). +apply: contraR ntX => /norP[b'q not_sXMs']; rewrite -subG1. +have [S sylS nSE] := coprime_Hall_exists q nMsE coMsE solMs. +have{abelX} [[sSMs qS _] [qX _]] := (and3P sylS, andP abelX). +have sScMsE': S \subset 'C_Ms(E^`(1)). + have [H hallH cHE'] := der_compl_cent_beta' maxM hallE. + have [Q sylQ] := Sylow_exists q H; have [sQH qQ _] := and3P sylQ. + have{cHE' sQH} cQE' := centsS sQH cHE'; have sE'E := der_sub 1 E. + have [nMsE' coMsE'] := (coprimegS sE'E coMsE, subset_trans sE'E nMsE). + have{H hallH sylQ} sylQ := subHall_Sylow hallH b'q sylQ. + have nSE' := subset_trans sE'E nSE; have nQE' := cents_norm cQE'. + have [x cE'x ->] := coprime_Hall_trans coMsE' nMsE' solMs sylS nSE' sylQ nQE'. + by rewrite conj_subG // subsetI (pHall_sub sylQ) centsC. +without loss{qX} sXS: X sXcMsE1 not_sXMs' / X \subset S. + have [nMsE1 coMsE1 IH] := (subset_trans sE1E nMsE, coprimegS sE1E coMsE). + have [nSE1 [sXMs cE1X]] := (subset_trans sE1E nSE, subsetIP sXcMsE1). + have [|Q [sylQ nQE1 sXQ]] := coprime_Hall_subset nMsE1 coMsE1 solMs sXMs qX. + by rewrite cents_norm // centsC. + have [//|x cE1x defS] := coprime_Hall_trans nMsE1 _ solMs sylS nSE1 sylQ nQE1. + have Ms_x: x \in Ms by case/setIP: cE1x. + rewrite -(conjs1g x^-1) -sub_conjg IH //; last by rewrite defS conjSg. + by rewrite -(conjGid cE1x) conjSg. + by rewrite -(normsP (der_norm 1 _) x) ?conjSg. +have [sXMs cE1X] := subsetIP sXcMsE1. +have [_ [E3 hallE3]] := ex_tau13_compl hallE. +have{hallE3} [E2 hallE2 complEi] := ex_tau2_compl hallE hallE1 hallE3. +have{not_sXMs' E3 complEi} ntE2: E2 :!=: 1. + apply: contraNneq not_sXMs' => E2_1. + have [[sE3E' _] _ _ [defE _] _] := sigma_compl_context maxM complEi. + have [sCMsE_Ms' _ _] := sigma_compl_embedding maxM hallE. + have{defE} [_ defE _ _] := sdprodP defE; rewrite E2_1 sdprod1g in defE. + rewrite (subset_trans _ sCMsE_Ms') // -defE centM setIA subsetI. + by rewrite (subset_trans (subset_trans sXS sScMsE')) ?setIS ?centS. +have{ntE2 E2 hallE2} [p p_pr t2p]: exists2 p, prime p & p \in \tau2(M). + have [[p p_pr rE2] [_ t2E2 _]] := (rank_witness E2, and3P hallE2). + by exists p; rewrite ?(pnatPpi t2E2) // -p_rank_gt0 -rE2 rank_gt0. +have [A Ep2A Ep2A_M] := ex_tau2Elem hallE t2p. +have [_ _ tiCMsA _ _] := tau2_context maxM t2p Ep2A_M. +have [[nsAE _] _ _ _] := tau2_compl_context maxM hallE t2p Ep2A. +have [sAE abelA _] := pnElemP Ep2A; have [pA cAA _] := and3P abelA. +have cCAE1_X: X \subset 'C('C_A(E1)). + rewrite centsC; apply/subsetP=> y; case/setIP=> Ay cE1y. + have [-> | nty] := eqVneq y 1; first exact: group1. + have oY: #[y] = p := abelem_order_p abelA Ay nty. + have [r _ rE1] := rank_witness E1. + have{rE1} rE1: 'r_r(E1) > 0 by rewrite -rE1 rank_gt0. + have [R ErR] := p_rank_geP rE1; have{ErR} [sRE1 abelR dimR] := pnElemP ErR. + have t1r: r \in \tau1(M) by rewrite (pnatPpi t1E1) -?p_rank_gt0. + have ErR: R \in 'E_r^1(E) by rewrite !inE abelR dimR (subset_trans sRE1). + have EpY: <[y]>%G \in 'E_p^1('C_E(R)). + rewrite p1ElemE // !inE -oY eqxx subsetI (centsS sRE1) cycle_subG //=. + by rewrite (subsetP sAE). + rewrite -sub_cent1 -cent_cycle (subset_trans sXcMsE1) //. + apply: subset_trans (setIS _ (centS sRE1)) _. + rewrite -subsetIidl setIAC subsetI subsetIr andbT. + exact: cent_tau1Elem_Msigma t1r ErR EpY. +have nAE1 := subset_trans sE1E (normal_norm nsAE). +have coAE1: coprime #|A| #|E1|. + by apply: pnat_coprime pA (pi_p'group t1E1 (contraL _ t2p)); apply: tau2'1. +rewrite -tiCMsA -(coprime_cent_prod nAE1 coAE1) ?abelian_sol // centM setIA. +rewrite subsetI cCAE1_X (subset_trans (subset_trans sXS sScMsE')) ?setIS //. +by rewrite centS ?commgSS. +Qed. + +End OneComplement. + +(* This is B & G, Lemma 13.7. *) +(* We've had to plug a gap in this proof: on p. 100, l. 6-7 it is asserted *) +(* the conclusion (E1 * E3 acts in a prime manner on M_sigma) follows from *) +(* the fact that E1 and E3 have coprime orders and act in a prime manner with *) +(* the same set of fixed points. This seems to imply the following argument: *) +(* For any x \in M_sigma, *) +(* C_(E1 * E3)[x] = C_E1[x] * C_E3[x] is either E1 * E3 or 1, *) +(* i.e., E1 * E3 acts in a prime manner on M_sigma. *) +(* This is improper because the distributivity of centralisers over coprime *) +(* products only hold under normality conditions that do not hold in this *) +(* instance. The correct argument, which involves using the prime action *) +(* assumption a second time, only relies on the fact that E1 and E3 are Hall *) +(* subgroups of the group E1 * E3. The fact that E3 <| E (Lemma 12.1(a)), *) +(* implicitly needed to justify that E1 * E3 is a group, can also be used to *) +(* simplify the argument, and we do so. *) +Lemma tau13_primact_Msigma M E E1 E2 E3 : + M \in 'M -> sigma_complement M E E1 E2 E3 -> ~ semiregular E3 E1 -> + semiprime M`_\sigma (E3 <*> E1). +Proof. +move=> maxM complEi not_regE13; set Ms := M`_\sigma. +have [hallE hallE1 hallE2 hallE3 _] := complEi. +have [[sE1E t1E1 _] [sE3E t3E3 _]] := (and3P hallE1, and3P hallE3). +have [[sEM _ _] [_ t2E2 _]] := (and3P hallE, and3P hallE2). +have [[_ nsE3E] _ [_ cycE3] [defE _] tiE3cE]:= sigma_compl_context maxM complEi. +have [[_ nE3E] [sMsM nMsM]] := (andP nsE3E, andP (pcore_normal _ M : Ms <| M)). +have [P]: exists2 P, P \in 'E^1(E1) & 'C_E3(P) != 1. + apply/exists_inP; rewrite -negb_forall_in; apply/forall_inP=> regE13. + apply: not_regE13 => x /setD1P[]; rewrite -cycle_subG -cycle_eq1 -rank_gt0. + case/rank_geP=> P E1xP sXE1; apply/trivgP; move: E1xP. + rewrite /= -(setIidPr sXE1) nElemI -setIdE => /setIdP[E1_P sPX]. + by rewrite -(eqP (regE13 P E1_P)) -cent_cycle setIS ?centS. +rewrite -{1}(setIidPr sE1E) nElemI -setIdE => /setIdP[/nElemP[p EpP] sPE1]. +rewrite -{1}(setIidPl sE3E) -setIA setIC -rank_gt0 => /rank_geP[R]. +rewrite nElemI -setIdE => /setIdP[/nElemP[r ErR] sRE3]. +have t1p: p \in \tau1(M). + rewrite (pnatPpi (pgroupS sPE1 t1E1)) //= (card_p1Elem EpP). + by rewrite pi_of_prime ?inE ?(pnElem_prime EpP) //. +have prE1 := tau1_primact_Msigma maxM hallE hallE1. +have prE3 := tau3_primact_Msigma maxM hallE hallE3. +have sCsPR: 'C_Ms(P) \subset 'C_Ms(R) by apply: cent_tau1Elem_Msigma EpP ErR. +have [eqCsPR | ltCsPR] := eqVproper sCsPR. + move=> x; case/setD1P; rewrite -cycle_eq1 -cycle_subG => ntX sXE31. + apply/eqP; rewrite -cent_cycle eqEsubset andbC setIS ?centS //=. + have eqCsE13: 'C_Ms(E1) = 'C_Ms(E3). + rewrite -(cent_semiprime prE1 sPE1) ?(nt_pnElem EpP) //. + by rewrite -(cent_semiprime prE3 sRE3) ?(nt_pnElem ErR). + rewrite centY setICA eqCsE13 -setICA setIid. + have sE31E: E3 <*> E1 \subset E by apply/joing_subP. + have nE3E1 := subset_trans sE1E nE3E. + pose y := x.`_\tau1(M); have sYX: <[y]> \subset <[x]> := cycleX x _. + have sXE := subset_trans sXE31 sE31E; have sYE := subset_trans sYX sXE. + have [t1'x | not_t1'x] := boolP (\tau1(M)^'.-elt x). + rewrite (cent_semiprime prE3 _ ntX) // (sub_normal_Hall hallE3) //. + apply: pnat_dvd t3E3; rewrite -(Gauss_dvdr _ (p'nat_coprime t1'x t1E1)). + by rewrite mulnC (dvdn_trans _ (dvdn_cardMg _ _)) -?norm_joinEr ?cardSg. + have{not_t1'x} ntY: #[y] != 1%N by rewrite order_constt partn_eq1. + apply: subset_trans (setIS _ (centS sYX)) _. + have [solE nMsE] := (sigma_compl_sol hallE, subset_trans sEM nMsM). + have [u Eu sYuE1] := Hall_Jsub solE hallE1 sYE (p_elt_constt _ _). + rewrite -(conjSg _ _ u) !conjIg -!centJ (normsP nMsE) ?(normsP nE3E) //=. + by rewrite -eqCsE13 (cent_semiprime prE1 sYuE1) // trivg_card1 cardJg. +have ntCsR: 'C_Ms(R) != 1. + by rewrite -proper1G (sub_proper_trans _ ltCsPR) ?sub1G. +have ntR: R :!=: 1 by rewrite (nt_pnElem ErR). +have [cEPR abelR dimR] := pnElemP ErR; have [rR _ _] := and3P abelR. +have{cEPR} [sRE cPR] := subsetIP cEPR; have sRM := subset_trans sRE sEM. +have E2_1: E2 :=: 1. + have [x defR] := cyclicP (cyclicS sRE3 cycE3). + apply: contraNeq ntCsR; rewrite -rank_gt0; have [q _ ->] := rank_witness E2. + rewrite p_rank_gt0 defR cent_cycle. move/(pnatPpi t2E2) => t2q. + have [A Eq2A _] := ex_tau2Elem hallE t2q. + have [-> //] := tau2_regular maxM complEi t2q Eq2A. + by rewrite !inE -cycle_subG -cycle_eq1 -defR sRE3 (nt_pnElem ErR). +have nRE: E \subset 'N(R) by rewrite (char_norm_trans _ nE3E) ?sub_cyclic_char. +have [H maxNH] := mmax_exists (mFT_norm_proper ntR (mFT_pgroup_proper rR)). +have [maxH sNH] := setIdP maxNH; have sEH := subset_trans nRE sNH. +have ntCsR_P: [~: 'C_Ms(R), P] != 1. + rewrite (sameP eqP commG1P); apply: contra (proper_subn ltCsPR). + by rewrite subsetI subsetIl. +have sCsR_MsH: 'C_Ms(R) \subset Ms :&: H. + exact: setIS Ms (subset_trans (cent_sub R) sNH). +have ntMsH_P: [~: Ms :&: H, P] != 1 by rewrite (subG1_contra _ ntCsR_P) ?commSg. +have tiE1cMsH: 'C_E1(Ms :&: H) = 1. + apply: contraNeq (proper_subn ltCsPR) => ntCE1MsH. + rewrite (cent_semiprime prE1 sPE1) ?(nt_pnElem EpP) //. + rewrite -(cent_semiprime prE1 (subsetIl _ _) ntCE1MsH) /=. + by rewrite subsetI subsetIl centsC subIset // orbC centS. +have t3r: r \in \tau3(M). + by rewrite (pnatPpi t3E3) ?(piSg sRE3) // -p_rank_gt0 p_rank_abelem ?dimR. +have t13r: (r \in \tau1(M)) || (r \in \tau3(M)) by rewrite t3r orbT. +have [sE1H sRH] := (subset_trans sE1E sEH, subset_trans sRE sEH). +have [_ ct1H'R [|sHr _]] := cent_norm_tau13_mmax maxM hallE t13r sRM rR maxNH. + rewrite (subG1_contra _ ntMsH_P) // commgS // (subset_trans sPE1) //. + by rewrite subsetI (subset_trans sE1E). +have t1H_E1: \tau1(H).-group E1. + apply/pgroupP=> q q_pr /Cauchy[] // x E1x ox. + apply: contraLR (prime_gt1 q_pr) => t1H'q; rewrite -ox cardG_gt1 negbK. + rewrite -subG1 -tiE1cMsH subsetI cycle_subG E1x /= ct1H'R //. + by rewrite (setIidPl sEH) cycle_subG (subsetP sE1E). + by rewrite /pgroup -orderE ox pnatE. +have sH'_E1: \sigma(H)^'.-group E1 by apply: sub_pgroup t1H_E1 => q /andP[]. +have [F hallF sE1F] := Hall_superset (mmax_sol maxH) sE1H sH'_E1. +have [F1 hallF1 sE1F1] := Hall_superset (sigma_compl_sol hallF) sE1F t1H_E1. +have{sHr} sRHs: R \subset H`_\sigma. + by rewrite (sub_Hall_pcore (Msigma_Hall maxH)) ?(pi_pgroup rR). +have cRE1: E1 \subset 'C(R). + rewrite centsC (centsS sE1F1) // -subsetIidl subsetI subxx -sRHs -subsetI. + have prF1 := tau1_primact_Msigma maxH hallF hallF1. + rewrite -(cent_semiprime prF1 (subset_trans sPE1 sE1F1)); last first. + exact: nt_pnElem EpP _. + by rewrite subsetI sRHs. +case/negP: ntR; rewrite -subG1 -tiE3cE subsetI sRE3 centsC -(sdprodW defE). +by rewrite E2_1 sdprod1g mul_subG // sub_abelian_cent ?cyclic_abelian. +Qed. + +(* This is B & G, Lemma 13.8. *) +(* We had to plug a significant hole in the proof text: in the sixth *) +(* paragraph of the proof, it is asserted that because M = N_M(Q)M_alpha and *) +(* r is in pi(C_M(P)), P centralises some non-trivial r-subgroup of N_M(Q). *) +(* This does not seem to follow directly, even taking into account that r is *) +(* not in alpha(M): while it is true that N_M(Q) contains a Sylow r-subgroup *) +(* of M, this subgroup does not need to contain an r-group centralized by P. *) +(* We can only establish the required result by making use of the fact that M *) +(* has a normal p-complement K (because p is in tau_1(M)), as then N_K(Q) *) +(* will contain a p-invariant Sylow r-subgroup S of K and M (coprime action) *) +(* and then any r-subgroup of M centralised by P will be in K, and hence *) +(* conjugate in C_K(P) to a subgroup of S (coprime action again). *) +Lemma tau1_mmaxI_asymmetry M Mstar p P q Q q_star Qstar : + (*1*) [/\ M \in 'M, Mstar \in 'M & gval Mstar \notin M :^: G] -> + (*2*) [/\ p \in \tau1(M), p \in \tau1(Mstar) & P \in 'E_p^1(M :&: Mstar)] -> + (*3*) [/\ q.-Sylow(M :&: Mstar) Q, q_star.-Sylow(M :&: Mstar) Qstar, + P \subset 'N(Q) & P \subset 'N(Qstar)] -> + (*4*) 'C_Q(P) = 1 /\ 'C_Qstar(P) = 1 -> + (*5*) 'N(Q) \subset Mstar /\ 'N(Qstar) \subset M -> + False. +Proof. +move: Mstar q_star Qstar => L u U. (* Abbreviate Mstar by L, Qstar by U. *) +move=> [maxM maxL notMGL] [t1Mp t1Lp EpP] [sylQ sylU nQP nUP]. +move=> [regPQ regPU] [sNQL sNUM]; rewrite setIC in sylU. (* for symmetry *) +have notLGM: gval M \notin L :^: G by rewrite orbit_sym. (* for symmetry *) +have{EpP} [ntP [sPML abelP dimP]] := (nt_pnElem EpP isT, pnElemP EpP). +have{sPML} [[sPM sPL] [pP _ _]] := (subsetIP sPML, and3P abelP). +have solCP: solvable 'C(P) by rewrite mFT_sol ?mFT_cent_proper. +pose Qprops M q Q := [&& q.-Sylow(M) Q, q != p, q \notin \beta(M), + 'C_(M`_\beta)(P) != 1 & 'C_(M`_\beta)(P <*> Q) == 1]. +have{sylQ sylU} [hypQ hypU]: Qprops M q Q /\ Qprops L u U. + apply/andP; apply/nandP=> not_hypQ. + without loss{not_hypQ}: L u U M q Q maxM maxL notMGL notLGM t1Mp t1Lp sPM sPL + sylQ sylU nQP nUP regPQ regPU sNQL sNUM / ~~ Qprops M q Q. + - by move=> IH; case: not_hypQ; [apply: (IH L u U) | apply: (IH M q Q)]. + case/and5P; have [_ qQ _] := and3P sylQ. + have{sylQ} sylQ: q.-Sylow(M) Q. + by rewrite -Sylow_subnorm -(setIidPr sNQL) setIA Sylow_subnorm. + have ntQ: Q :!=: 1. + by apply: contraTneq sNQL => ->; rewrite norm1 proper_subn ?mmax_proper. + have p'q: q != p. + apply: contraNneq ntQ => def_q; rewrite (trivg_center_pgroup qQ) //. + apply/trivgP; rewrite -regPQ setIS // centS //. + by rewrite (norm_sub_max_pgroup (Hall_max sylQ)) ?def_q. + have EpP: P \in 'E_p^1(M) by apply/pnElemP. + have [|_ [// | abM]] := cent_Malpha_reg_tau1 maxM t1Mp p'q EpP ntQ nQP regPQ. + apply: contraNneq notMGL => uniqNQ. + by rewrite (eq_uniq_mmax uniqNQ) ?orbit_refl. + by rewrite joingC /alpha_core abM !(eq_pcore _ abM) => _ -> -> ->. +have bML_CMbP: forall M L, [predU \beta(M) & \beta(L)].-group 'C_(M`_\beta)(P). + move=> ? ?; apply: pgroupS (subsetIl _ _) (sub_pgroup _ (pcore_pgroup _ _)). + by move=> ?; rewrite !inE => ->. +have [H hallH sCMbP_H] := Hall_superset solCP (subsetIr _ _) (bML_CMbP M L). +have [[s _ rFH] [cPH bH _]] := (rank_witness 'F(H), and3P hallH). +have{sCMbP_H rFH cPH} piFHs: s \in \pi('F(H)). + rewrite -p_rank_gt0 -rFH rank_gt0 (trivg_Fitting (solvableS cPH solCP)). + by rewrite (subG1_contra sCMbP_H) //; case/and5P: hypQ. +without loss{bH} bMs: L u U M q Q maxM maxL notMGL notLGM t1Mp t1Lp sPM sPL + nQP nUP regPQ regPU sNQL sNUM hypQ hypU hallH / s \in \beta(M). +- move=> IH; have:= pnatPpi bH (piSg (Fitting_sub H) piFHs). + case/orP; [apply: IH hypQ hypU hallH | apply: IH hypU hypQ _] => //. + by apply: etrans (eq_pHall _ _ _) hallH => ?; apply: orbC. +without loss{bML_CMbP} sCMbP_H: H hallH piFHs / 'C_(M`_\beta)(P) \subset H. + have [x cPx sCMbP_Hx] := Hall_subJ solCP hallH (subsetIr _ _) (bML_CMbP M L). + by move=> IH; apply: IH sCMbP_Hx; rewrite ?pHallJ //= FittingJ cardJg. +pose X := 'O_s(H); have sylX := nilpotent_pcore_Hall s (Fitting_nil H). +have{piFHs sylX} ntX: X != 1. + by rewrite -rank_gt0 /= -p_core_Fitting (rank_Sylow sylX) p_rank_gt0. +have [[cPH bH _] [sXH nXH]] := (and3P hallH, andP (pcore_normal s H : X <| H)). +have [cPX sX] := (subset_trans sXH cPH, pcore_pgroup s H : s.-group X). +have{hypQ} [sylQ p'q bM'q ntCMbP] := and5P hypQ; apply: negP. +apply: subG1_contra (ntX); rewrite /= centY !subsetI (subset_trans _ cPH) //=. +have nsMbM : M`_\beta <| M := pcore_normal _ M; have [sMbM nMbM] := andP nsMbM. +have hallMb := Mbeta_Hall maxM; have [_ bMb _] := and3P hallMb. +have{ntX} sHM: H \subset M. + have [g sXMg]: exists g, X \subset M :^ g. + have [S sylS] := Sylow_exists s M`_\beta; have [sSMb _ _] := and3P sylS. + have sylS_G := subHall_Sylow (Mbeta_Hall_G maxM) bMs sylS. + have [g _ sXSg] := Sylow_subJ sylS_G (subsetT X) sX. + by exists g; rewrite (subset_trans sXSg) // conjSg (subset_trans sSMb). + have [t _ rFC] := rank_witness 'F('C_(M`_\beta)(P)). + pose Y := 'O_t('C_(M`_\beta)(P)). + have [sYC tY] := (pcore_sub t _ : Y \subset _, pcore_pgroup t _ : t.-group Y). + have sYMb := subset_trans sYC (subsetIl _ _); have bMY := pgroupS sYMb bMb. + have{rFC} ntY: Y != 1. + rewrite -rank_gt0 /= -p_core_Fitting. + rewrite (rank_Sylow (nilpotent_pcore_Hall t (Fitting_nil _))) -rFC. + by rewrite rank_gt0 (trivg_Fitting (solvableS (subsetIr _ _) solCP)). + have bMt: t \in \beta(M). + by rewrite (pnatPpi bMY) // -p_rank_gt0 -rank_pgroup ?rank_gt0. + have sHMg: H \subset M :^ g. + rewrite (subset_trans nXH) // beta_norm_sub_mmax ?mmaxJ // /psubgroup sXMg. + by rewrite (pi_pgroup sX) 1?betaJ. + have sYMg: Y \subset M :^ g := subset_trans (subset_trans sYC sCMbP_H) sHMg. + have sNY_M: 'N(Y) \subset M. + by rewrite beta_norm_sub_mmax // /psubgroup (subset_trans sYMb). + have [_ trCY _] := sigma_group_trans maxM (beta_sub_sigma maxM bMt) tY. + have [|| h cYh /= defMg] := (atransP2 trCY) M (M :^ g). + - by rewrite inE orbit_refl (subset_trans (normG _) sNY_M). + - by rewrite inE mem_orbit ?in_setT. + by rewrite defMg conjGid // (subsetP sNY_M) ?(subsetP (cent_sub _)) in sHMg. +have sXMb: X \subset M`_\beta. + by rewrite (sub_Hall_pcore hallMb) ?(subset_trans sXH sHM) ?(pi_pgroup sX). +rewrite sXMb (sameP commG1P eqP) /= -/X -subG1. +have [sQL [sQM qQ _]] := (subset_trans (normG Q) sNQL, and3P sylQ). +have nsLbL : L`_\beta <| L := pcore_normal _ L; have [sLbL nLbL] := andP nsLbL. +have nLbQ := subset_trans sQL nLbL. +have [<- ti_aLsM _] := sigma_disjoint maxL maxM notLGM. +rewrite subsetI (subset_trans _ (Mbeta_sub_Msigma maxM)) ?andbT; last first. + by rewrite (subset_trans (commgSS sXMb sQM)) // commg_subl nMbM. +have defQ: [~: Q, P] = Q. + rewrite -{2}(coprime_cent_prod nQP) ?(pgroup_sol qQ) ?regPQ ?mulg1 //. + by rewrite (p'nat_coprime (pi_pnat qQ _) pP). +suffices sXL: X \subset L. + apply: subset_trans (Mbeta_sub_Malpha L). + rewrite -quotient_sub1 ?comm_subG ?quotientR ?(subset_trans _ nLbL) //. + have <-: (M`_\beta :&: L) / L`_\beta :&: 'O_q(L^`(1) / L`_\beta) = 1. + rewrite coprime_TIg // coprime_morphl // (coprimeSg (subsetIl _ _)) //. + exact: pnat_coprime (pcore_pgroup _ _) (pi_pnat (pcore_pgroup _ _) _). + rewrite commg_subI // subsetI. + rewrite quotientS; last by rewrite subsetI sXMb. + rewrite (char_norm_trans (pcore_char _ _)) ?quotient_norms //. + by rewrite (subset_trans sXL) ?der_norm. + rewrite (sub_Hall_pcore (nilpotent_pcore_Hall _ (Mbeta_quo_nil _))) //. + rewrite quotient_pgroup ?quotient_norms //. + by rewrite normsI ?(subset_trans sQM nMbM) ?normsG. + by rewrite quotientS // -defQ commgSS // (subset_trans nQP). +have{hypU} [r bLr piHr]: exists2 r, r \in \beta(L) & r \in \pi(H). + have [_ _ _] := and5P hypU; rewrite -rank_gt0. + have [r _ ->] := rank_witness 'C_(L`_\beta)(P); rewrite p_rank_gt0 => piCr _. + have [piLb_r piCPr] := (piSg (subsetIl _ _) piCr, piSg (subsetIr _ _) piCr). + have bLr: r \in \beta(L) := pnatPpi (pcore_pgroup _ L) piLb_r. + exists r; rewrite //= (card_Hall hallH) pi_of_part // inE /= piCPr. + by rewrite inE /= bLr orbT. +have sM'r: r \notin \sigma(M). + by apply: contraFN (ti_aLsM r) => sMr; rewrite inE /= beta_sub_alpha. +have defM: M`_\beta * 'N_M(Q) = M. + have nMbQ := subset_trans sQM nMbM. + have nsMbQ_M: M`_\beta <*> Q <| M. + rewrite -{2}(quotientGK nsMbM) -quotientYK ?cosetpre_normal //. + rewrite (eq_Hall_pcore (nilpotent_pcore_Hall q (Mbeta_quo_nil _))) //. + apply: char_normal_trans (pcore_char _ _) (quotient_normal _ _). + exact: der_normal. + rewrite quotient_pHall // (pHall_subl _ (der_sub 1 M) sylQ) //. + by rewrite -defQ commgSS // (subset_trans nUP). + have sylQ_MbQ := pHall_subl (joing_subr _ Q) (normal_sub nsMbQ_M) sylQ. + rewrite -{3}(Frattini_arg nsMbQ_M sylQ_MbQ) /= norm_joinEr // -mulgA. + by congr (_ * _); rewrite mulSGid // subsetI sQM normG. +have [[sM'p _ not_pM'] [sL'p _]] := (and3P t1Mp, andP t1Lp). +have{not_pM'} [R ErR nQR]: exists2 R, R \in 'E_r^1('C_M(P)) & R \subset 'N(Q). + have p'r: r \in p^' by apply: contraNneq sL'p => <-; apply: beta_sub_sigma. + have p'M': p^'.-group M^`(1). + by rewrite p'groupEpi mem_primes (negPf not_pM') !andbF. + pose K := 'O_p^'(M); have [sKM nKM] := andP (pcore_normal _ M : K <| M). + have hallK: p^'.-Hall(M) K. + rewrite -(pquotient_pHall _ (der_normal 1 M)) ?quotient_pgroup //. + rewrite -pquotient_pcore ?der_normal // nilpotent_pcore_Hall //. + by rewrite abelian_nil ?der_abelian. + by rewrite (normalS _ sKM) ?pcore_max ?der_normal. + have sMbK: M`_\beta \subset K. + by rewrite (subset_trans (Mbeta_der1 maxM)) // pcore_max ?der_normal. + have coKP: coprime #|K| #|P| := p'nat_coprime (pcore_pgroup _ M) pP. + have [solK sNK] := (solvableS sKM (mmax_sol maxM), subsetIl K 'N(Q)). + have [nKP coNP] := (subset_trans sPM nKM, coprimeSg sNK coKP). + have nNP: P \subset 'N('N_K(Q)) by rewrite normsI // norms_norm. + have [S sylS nSP] := coprime_Hall_exists r nNP coNP (solvableS sNK solK). + have /subsetIP[sSK nQS]: S \subset 'N_K(Q) := pHall_sub sylS. + have sylS_K: r.-Sylow(K) S. + rewrite pHallE sSK /= -/K -(setIidPr sKM) -defM -group_modl // setIAC. + rewrite (setIidPr sKM) -LagrangeMr partnM // -(card_Hall sylS). + rewrite part_p'nat ?mul1n 1?(pnat_dvd (dvdn_indexg _ _)) //. + by apply: (pi_p'nat bMb); apply: contra sM'r; exact: beta_sub_sigma. + have rC: 'r_r('C_M(P)) > 0 by rewrite p_rank_gt0 (piSg _ piHr) // subsetI sHM. + have{rC} [R ErR] := p_rank_geP rC; have [sRcMP abelR _] := pnElemP ErR. + have{sRcMP abelR} [[sRM cPR] [rR _]] := (subsetIP sRcMP, andP abelR). + have nRP: P \subset 'N(R) by rewrite cents_norm 1?centsC. + have sRK: R \subset K by rewrite sub_Hall_pcore ?(pi_pgroup rR). + have [T [sylT nTP sRT]] := coprime_Hall_subset nKP coKP solK sRK rR nRP. + have [x cKPx defS] := coprime_Hall_trans nKP coKP solK sylS_K nSP sylT nTP. + rewrite -(conjGid (subsetP (setSI _ sKM) x cKPx)). + by exists (R :^ x)%G; rewrite ?pnElemJ ?(subset_trans _ nQS) // defS conjSg. +have [sRcMP abelR _] := pnElemP ErR; have ntR := nt_pnElem ErR isT. +have{sRcMP abelR} [[sRM cPR] [rR _]] := (subsetIP sRcMP, andP abelR). +have sNR_L: 'N(R) \subset L. + by rewrite beta_norm_sub_mmax /psubgroup ?(subset_trans nQR) ?(pi_pgroup rR). +have sPR_M: P <*> R \subset M by rewrite join_subG (subset_trans nUP). +have sM'_PR: \sigma(M)^'.-group (P <*> R). + by rewrite cent_joinEr // pgroupM (pi_pgroup rR) // (pi_pgroup pP). +have [E hallE sPRE] := Hall_superset (mmax_sol maxM) sPR_M sM'_PR. +have{sPRE} [sPE sRE] := joing_subP sPRE. +have EpP: P \in 'E_p^1(E) by apply/pnElemP. +have{ErR} ErR: R \in 'E_r^1('C_E(P)). + by rewrite -(setIidPr (pHall_sub hallE)) setIAC pnElemI inE ErR inE. +apply: subset_trans (cents_norm (subset_trans _ (subsetIr M`_\sigma _))) sNR_L. +apply: subset_trans (cent_tau1Elem_Msigma maxM hallE t1Mp EpP ErR). +by rewrite subsetI cPX (subset_trans sXMb) ?Mbeta_sub_Msigma. +Qed. + +(* This is B & G, Theorem 13.9. *) +Theorem sigma_partition M Mstar : + M \in 'M -> Mstar \in 'M -> gval Mstar \notin M :^: G -> + [predI \sigma(M) & \sigma(Mstar)] =i pred0. +Proof. +move: Mstar => L maxM maxL notMGL q; apply/andP=> [[/= sMq sLq]]. +have [E hallE] := ex_sigma_compl maxM; have [sEM sM'E _] := and3P hallE. +have [_ _ nMsE _] := sdprodP (sdprod_sigma maxM hallE). +have coMsE: coprime #|M`_\sigma| #|E| := pnat_coprime (pcore_pgroup _ _) sM'E. +have [|S sylS nSE] := coprime_Hall_exists q nMsE coMsE. + exact: solvableS (pcore_sub _ _) (mmax_sol maxM). +have [sSMs qS _] := and3P sylS. +have sylS_M := subHall_Sylow (Msigma_Hall maxM) sMq sylS. +have ntS: S :!=: 1. + by rewrite -rank_gt0 (rank_Sylow sylS_M) p_rank_gt0 sigma_sub_pi. +without loss sylS_L: L maxL sLq notMGL / q.-Sylow(L) S. + have sylS_G := sigma_Sylow_G maxM sMq sylS_M. + have [T sylT] := Sylow_exists q L; have sylT_G := sigma_Sylow_G maxL sLq sylT. + have [x Gx ->] := Sylow_trans sylT_G (sigma_Sylow_G maxM sMq sylS_M). + case/(_ (L :^ x)%G); rewrite ?mmaxJ ?sigmaJ ?pHallJ2 //. + by rewrite (orbit_transr _ (mem_orbit 'Js L Gx)). +have [[sSL _] [[E1 hallE1] [E3 hallE3]]] := (andP sylS_L, ex_tau13_compl hallE). +have [E2 hallE2 complEi] := ex_tau2_compl hallE hallE1 hallE3. +have E2_1: E2 :==: 1. + apply: contraR ntS; rewrite -rank_gt0; have [p _ ->] := rank_witness E2. + rewrite p_rank_gt0 => /(pnatPpi (pHall_pgroup hallE2))t2p. + have [A Ep2A _] := ex_tau2Elem hallE t2p. + have [_ _ _ ti_sM] := tau2_compl_context maxM hallE t2p Ep2A. + rewrite -subG1; have [<- _] := ti_sM L maxL notMGL; rewrite subsetI sSMs /=. + by rewrite (sub_Hall_pcore (Msigma_Hall maxL) sSL) (pi_pgroup qS). +have: E1 :!=: 1 by have [_ -> //] := sigma_compl_context maxM complEi. +rewrite -rank_gt0; have [p _ ->] := rank_witness E1; case/p_rank_geP=> P EpP. +have [[sPE1 abelP dimP] [sE1E t1E1 _]] := (pnElemP EpP, and3P hallE1). +have ntP: P :!=: 1 by rewrite (nt_pnElem EpP). +have piPp: p \in \pi(P) by rewrite -p_rank_gt0 ?p_rank_abelem ?dimP. +have t1Mp: p \in \tau1(M) by rewrite (pnatPpi _ (piSg sPE1 _)). +have sPE := subset_trans sPE1 sE1E; have sPM := subset_trans sPE sEM. +have [sNM sNL] := (norm_sigma_Sylow sMq sylS_M, norm_sigma_Sylow sLq sylS_L). +have nSP := subset_trans sPE nSE; have sPL := subset_trans nSP sNL. +have regPS: 'C_S(P) = 1. + apply: contraNeq (contra_orbit _ _ notMGL); rewrite -rank_gt0. + rewrite (rank_pgroup (pgroupS _ qS)) ?subsetIl //; case/p_rank_geP=> Q /=. + rewrite -(setIidPr sSMs) setIAC pnElemI; case/setIdP=> EqQ _. + have [_ uniqSq] := cent_cent_Msigma_tau1_uniq maxM hallE hallE1 sPE1 ntP EqQ. + by rewrite (eq_uniq_mmax (uniqSq S sylS) maxL sSL). +have t1Lp: p \in \tau1(L). + have not_cMsL_P: ~~ (P \subset 'C(M`_\sigma :&: L)). + apply: contra ntS => cMsL_P; rewrite -subG1 -regPS subsetIidl centsC. + by rewrite (subset_trans cMsL_P) ?centS // subsetI sSMs. + apply: contraR (not_cMsL_P) => t1L'p. + have [piEp piLp] := (piSg sPE piPp, piSg sPL piPp). + have [] := Msigma_setI_mmax_central maxM hallE maxL piEp piLp t1L'p _ notMGL. + apply: contraNneq not_cMsL_P; move/commG1P; rewrite centsC. + by apply: subset_trans; rewrite subsetI sPM. + by move->; rewrite ?(abelem_pgroup abelP) // subsetI sPM. +case: (@tau1_mmaxI_asymmetry M L p P q S q S) => //. + by rewrite !inE subsetI sPM sPL abelP dimP. +by rewrite (pHall_subl _ (subsetIl M L) sylS_M) // subsetI (pHall_sub sylS_M). +Qed. + +(* This is B & G, Theorem 13.10. *) +Theorem tau13_regular M E E1 E2 E3 p P : + M \in 'M -> sigma_complement M E E1 E2 E3 -> + P \in 'E_p^1(E1) -> ~~ (P \subset 'C(E3)) -> + [/\ (*a*) semiregular E3 E1, + (*b*) semiregular M`_\sigma E3 + & (*c*) 'C_(M`_\sigma)(P) != 1]. +Proof. +move=> maxM complEi EpP not_cE3P. +have nsMsM: M`_\sigma <| M := pcore_normal _ M; have [sMsM nMsM] := andP nsMsM. +have [hallMs sMaMs] := (Msigma_Hall maxM, Malpha_sub_Msigma maxM). +have [[sE3E' nsE3E] _ [_ cycE3] _ _] := sigma_compl_context maxM complEi. +have [hallE hallE1 _ hallE3] := complEi. +have [[_ sM_Ms _] [sEM sM'E _]] := (and3P hallMs, and3P hallE). +have [[sE1E t1E1 _] [sE3E t3E3 _] _] := (and3P hallE1, and3P hallE3). +have [sPE1 abelP dimP] := pnElemP EpP; have [pP _ _] := and3P abelP. +have [ntP t1MP] := (nt_pnElem EpP isT, pgroupS sPE1 t1E1). +have sPE := subset_trans sPE1 sE1E; have sPM := subset_trans sPE sEM. +have piPp: p \in \pi(P) by rewrite -p_rank_gt0 p_rank_abelem ?dimP. +have t1Mp: p \in \tau1(M) := pnatPpi t1MP piPp. +have [Q sylQ not_cPQ]: exists2 Q, Sylow E3 (gval Q) & ~~ (P \subset 'C(Q)). + apply/exists_inP; rewrite -negb_forall_in; apply: contra not_cE3P. + move/forall_inP=> cPE3; rewrite centsC -(Sylow_gen E3) gen_subG. + by apply/bigcupsP=> Q sylQ; rewrite centsC cPE3. +have{sylQ} [q q_pr sylQ] := SylowP _ _ sylQ; have [sQE3 qQ _] := and3P sylQ. +have ntQ: Q :!=: 1 by apply: contraNneq not_cPQ => ->; apply: cents1. +have t3Mq: q \in \tau3(M). + by rewrite (pnatPpi t3E3) // -p_rank_gt0 -(rank_Sylow sylQ) rank_gt0. +have nQP: P \subset 'N(Q). + rewrite (subset_trans sPE) ?normal_norm //. + by rewrite (char_normal_trans _ nsE3E) ?sub_cyclic_char. +have regPQ: 'C_Q(P) = 1. + apply: contraNeq not_cPQ; rewrite setIC => /meet_Ohm1. + rewrite setIC => /prime_meetG/=/implyP. + rewrite (Ohm1_cyclic_pgroup_prime (cyclicS sQE3 cycE3) qQ) // q_pr centsC. + apply: (coprime_odd_faithful_Ohm1 qQ) nQP _ (mFT_odd _). + exact: sub_pnat_coprime tau3'1 (pgroupS sQE3 t3E3) t1MP. +have sQE' := subset_trans sQE3 sE3E'. +have sQM := subset_trans (subset_trans sQE3 sE3E) sEM. +have [L maxNL] := mmax_exists (mFT_norm_proper ntQ (mFT_pgroup_proper qQ)). +have [maxL sNQL] := setIdP maxNL; have sQL := subset_trans (normG Q) sNQL. +have notMGL: gval L \notin M :^: G. + by apply: mmax_norm_notJ maxM maxL qQ sQM sNQL _; rewrite t3Mq !orbT. +have [ntCMaP tiCMaQP]: 'C_(M`_\alpha)(P) != 1 /\ 'C_(M`_\alpha)(Q <*> P) = 1. + have EpMP: P \in 'E_p^1(M) by apply/pnElemP. + have p'q: q != p by apply: contraNneq (tau3'1 t1Mp) => <-. + have [|_ [] //] := cent_Malpha_reg_tau1 maxM t1Mp p'q EpMP ntQ nQP regPQ. + by apply: contraTneq maxNL => ->; rewrite inE (contra_orbit _ _ notMGL). + have sM'q: q \in \sigma(M)^' by case/andP: t3Mq. + exact: subHall_Sylow hallE sM'q (subHall_Sylow hallE3 t3Mq sylQ). +split=> [x E1x | x E3x |]; last exact: subG1_contra (setSI _ sMaMs) ntCMaP. + apply: contraNeq ntCMaP => ntCE3X. + have prE31: semiprime M`_\sigma (E3 <*> E1). + apply: tau13_primact_Msigma maxM complEi _ => regE13. + by rewrite regE13 ?eqxx in ntCE3X. + rewrite -subG1 -tiCMaQP /= -(setIidPl sMaMs) -!setIA setIS //. + rewrite (cent_semiprime prE31 _ ntP) ?setIS ?centS //=. + by rewrite -!genM_join genS ?mulgSS. + by rewrite sub_gen // subsetU // sPE1 orbT. +have prE3 := tau3_primact_Msigma maxM hallE hallE3. +apply/eqP; apply/idPn; rewrite prE3 {x E3x}// -rank_gt0. +have [u _ -> ruC] := rank_witness 'C_(M`_\sigma)(E3). +have sCMs := subsetIl M`_\sigma 'C(E3). +have sMu: u \in \sigma(M) by rewrite (pnatPpi (pgroupS sCMs _)) -?p_rank_gt0. +have nCE: E \subset 'N('C_(M`_\sigma)(E3)). + by rewrite normsI ?norms_cent ?(normal_norm nsE3E) // (subset_trans sEM). +have coCE := coprimeSg sCMs (pnat_coprime (pcore_pgroup _ _) sM'E). +have solC := solvableS (subset_trans sCMs sMsM) (mmax_sol maxM). +have{nCE coCE solC} [U sylU nUE] := coprime_Hall_exists u nCE coCE solC. +have ntU: U :!=: 1 by rewrite -rank_gt0 (rank_Sylow sylU). +have cMsL_Q: Q \subset 'C(M`_\sigma :&: L). + have t13q: (q \in \tau1(M)) || (q \in \tau3(M)) by rewrite t3Mq orbT. + have [-> //] := cent_norm_tau13_mmax maxM hallE t13q sQM qQ maxNL. + by rewrite subsetI sQM. +rewrite /= -(cent_semiprime prE3 sQE3 ntQ) in sylU. +have [sUMs cQU] := subsetIP (pHall_sub sylU). +have{cMsL_Q} sylU_MsL: u.-Sylow(M`_\sigma :&: L) U. + apply: pHall_subl sylU; last by rewrite subsetI subsetIl centsC. + by rewrite subsetI sUMs (subset_trans (cents_norm _) sNQL). +have sylU_ML: u.-Sylow(M :&: L) U. + apply: subHall_Sylow sMu sylU_MsL. + by rewrite /= -(setIidPl sMsM) -setIA (setI_normal_Hall nsMsM) ?subsetIl. +have [sUML uU _] := and3P sylU_ML; have{sUML} [sUM sUL] := subsetIP sUML. +have [sNUM regPU]: 'N(U) \subset M /\ 'C_U(P) = 1. + have [bMu | bM'u] := boolP (u \in \beta(M)). + have [bM_U sMbMa] := (pi_pgroup uU bMu, Mbeta_sub_Malpha M). + split; first by rewrite beta_norm_sub_mmax /psubgroup ?sUM. + apply/trivgP; rewrite -tiCMaQP centY setIA setSI // subsetI cQU. + by rewrite (subset_trans _ sMbMa) // (sub_Hall_pcore (Mbeta_Hall maxM)). + have sylU_Ms: u.-Sylow(M`_\sigma) U. + have [H hallH cHE'] := der_compl_cent_beta' maxM hallE. + rewrite pHallE sUMs (card_Hall sylU) eqn_dvd. + rewrite partn_dvd ?cardG_gt0 ?cardSg ?subsetIl //=. + rewrite -(@partn_part u \beta(M)^') => [|v /eqnP-> //]. + rewrite -(card_Hall hallH) partn_dvd ?cardG_gt0 ?cardSg //. + by rewrite subsetI (pHall_sub hallH) centsC (subset_trans sQE'). + split; first exact: norm_sigma_Sylow (subHall_Sylow hallMs sMu sylU_Ms). + apply: contraNeq (contra_orbit _ _ notMGL); rewrite -rank_gt0. + rewrite (rank_pgroup (pgroupS _ uU)) ?subsetIl // => /p_rank_geP[X] /=. + rewrite -(setIidPr sUMs) setIAC pnElemI -setIdE => /setIdP[EuX sXU]. + have [_ uniqU] := cent_cent_Msigma_tau1_uniq maxM hallE hallE1 sPE1 ntP EuX. + by rewrite (eq_uniq_mmax (uniqU U sylU_Ms) maxL). +have sPL := subset_trans nQP sNQL. +have sPML: P \subset M :&: L by apply/subsetIP. +have t1Lp: p \in \tau1(L). + have not_cMsL_P: ~~ (P \subset 'C(M`_\sigma :&: L)). + apply: contra ntU => cMsL_P; rewrite -subG1 -regPU subsetIidl. + by rewrite centsC (centsS (pHall_sub sylU_MsL)). + apply: contraR (not_cMsL_P) => t1L'p. + have [piEp piLp] := (piSg sPE piPp, piSg sPL piPp). + case: (Msigma_setI_mmax_central maxM hallE maxL piEp piLp) => // [|->] //. + apply: contraNneq not_cMsL_P => /commG1P. + by rewrite centsC; apply: subset_trans sPML. +have EpMLP: P \in 'E_p^1(M :&: L) by apply/pnElemP. +case: (@tau1_mmaxI_asymmetry M L p P q Q u U) => //. +have [sylQ_E [sM'q _]] := (subHall_Sylow hallE3 t3Mq sylQ, andP t3Mq). +have sylQ_M := subHall_Sylow hallE sM'q sylQ_E. +have sQML: Q \subset M :&: L by apply/subsetIP. +by rewrite (subset_trans sPE nUE) (pHall_subl sQML _ sylQ_M) ?subsetIl. +Qed. + +(* This is B & G, Corollary 13.11. *) +Corollary tau13_nonregular M E E1 E2 E3 : + M \in 'M -> sigma_complement M E E1 E2 E3 -> ~ semiregular M`_\sigma E3 -> + [/\ (*a*) E1 :!=: 1, + (*b*) E3 ><| E1 = E, + (*c*) semiprime M`_\sigma E + & (*d*) forall X, X \in 'E^1(E) -> X <| E]. +Proof. +move=> maxM complEi not_regE3Ms. +have [hallE hallE1 hallE2 hallE3 _] := complEi. +have [[sE1E t1E1 _] [sE3E t3E3 _]] := (and3P hallE1, and3P hallE3). +have{hallE2} E2_1: E2 :==: 1. + apply/idPn; rewrite -rank_gt0; have [p _ ->] := rank_witness E2. + rewrite p_rank_gt0 => /(pnatPpi (pHall_pgroup hallE2))t2p. + have [A Ep2A _] := ex_tau2Elem hallE t2p. + by apply: not_regE3Ms; case: (tau2_regular maxM complEi t2p Ep2A). +have [_ ntE1 [cycE1 cycE3] [defE _] _] := sigma_compl_context maxM complEi. +rewrite (eqP E2_1) sdprod1g in defE; have{ntE1} ntE1 := ntE1 E2_1. +have [nsE3E _ mulE31 nE31 _] := sdprod_context defE. +have cE3E1 P: P \in 'E^1(E1) -> P \subset 'C(E3). + by case/nElemP=> p EpP; apply/idPn => /(tau13_regular maxM complEi EpP)[]. +split=> // [|X EpX]. + rewrite -mulE31 -norm_joinEr //. + have [-> | ntE3] := eqsVneq E3 1. + by rewrite joing1G; apply: (tau1_primact_Msigma maxM hallE hallE1). + apply: tau13_primact_Msigma maxM complEi _ => regE13. + have:= ntE1; rewrite -rank_gt0; case/rank_geP=> P EpP. + have cPE3: E3 \subset 'C(P) by rewrite centsC cE3E1. + have [p Ep1P] := nElemP EpP; have [sPE1 _ _] := pnElemP Ep1P. + have ntP: P :!=: 1 by apply: (nt_pnElem Ep1P). + by case/negP: ntE3; rewrite -(setIidPl cPE3) (cent_semiregular regE13 _ ntP). +have [p Ep1X] := nElemP EpX; have [sXE abelX oX] := pnElemPcard Ep1X. +have [p_pr ntX] := (pnElem_prime Ep1X, nt_pnElem Ep1X isT). +have tau31p: p \in [predU \tau3(M) & \tau1(M)]. + rewrite (pgroupP (pgroupS sXE _)) ?oX // -mulE31 pgroupM. + rewrite (sub_pgroup _ t3E3) => [|q t3q]; last by rewrite inE /= t3q. + by rewrite (sub_pgroup _ t1E1) // => q t1q; rewrite inE /= t1q orbT. +have [/= t3p | t1p] := orP tau31p. + rewrite (char_normal_trans _ nsE3E) ?sub_cyclic_char //. + by rewrite (sub_normal_Hall hallE3) // (pi_pgroup (abelem_pgroup abelX)). +have t1X := pi_pgroup (abelem_pgroup abelX) t1p. +have [e Ee sXeE1] := Hall_Jsub (sigma_compl_sol hallE) hallE1 sXE t1X. +rewrite /normal sXE -(conjSg _ _ e) conjGid //= -normJ -mulE31 mulG_subG. +rewrite andbC sub_abelian_norm ?cyclic_abelian ?cents_norm // centsC cE3E1 //. +rewrite -(setIidPr sE1E) nElemI !inE sXeE1 andbT. +by rewrite -(pnElemJ e) conjGid // def_pnElem in Ep1X; case/setIP: Ep1X. +Qed. + +(* This is B & G, Lemma 13.12. *) +Lemma tau12_regular M E p q P A : + M \in 'M -> \sigma(M)^'.-Hall(M) E -> + p \in \tau1(M) -> P \in 'E_p^1(E) -> q \in \tau2(M) -> A \in 'E_q^2(E) -> + 'C_A(P) != 1 -> + 'C_(M`_\sigma)(P) = 1. +Proof. +move=> maxM hallE t1p EpP t2q Eq2A ntCAP; apply: contraNeq (ntCAP) => ntCMsP. +have [[nsAE _] _ uniq_cMs _] := tau2_compl_context maxM hallE t2q Eq2A. +have [sPE abelP dimP] := pnElemP EpP; have [pP _] := andP abelP. +have ntP: P :!=: 1 by apply: nt_pnElem EpP _. +have [solE t1P] := (sigma_compl_sol hallE, pi_pgroup pP t1p). +have [E1 hallE1 sPE1] := Hall_superset solE sPE t1P. +have [_ [E3 hallE3]] := ex_tau13_compl hallE. +have [E2 _ complEi] := ex_tau2_compl hallE hallE1 hallE3. +have not_cAP: ~~ (P \subset 'C(A)). + have [_ regCE1A _] := tau2_regular maxM complEi t2q Eq2A. + apply: contra ntCMsP => cAP; rewrite (cent_semiregular regCE1A _ ntP) //. + exact/subsetIP. +have [sAE abelA dimA] := pnElemP Eq2A; have [qA _] := andP abelA. +pose Y := 'C_A(P)%G; have{abelA dimA} EqY: Y \in 'E_q^1('C_E(P)). + have sYA: Y \subset A := subsetIl A _; have abelY := abelemS sYA abelA. + rewrite !inE setSI // abelY eqn_leq -{2}rank_abelem // rank_gt0 -ltnS -dimA. + by rewrite properG_ltn_log //= /proper subsetIl subsetIidl centsC. +have ntCMsY: 'C_(M`_\sigma)(Y) != 1. + by apply: subG1_contra ntCMsP; apply: cent_tau1Elem_Msigma t1p EpP EqY. +have EqEY: Y \in 'E_q^1(E) by rewrite pnElemI in EqY; case/setIP: EqY. +have uniqCY := uniq_cMs _ EqEY ntCMsY. +have [ntA nAE] := (nt_pnElem Eq2A isT, normal_norm nsAE). +have [L maxNL] := mmax_exists (mFT_norm_proper ntA (mFT_pgroup_proper qA)). +have [sLq t12Lp]: q \in \sigma(L) /\ (p \in \tau1(L)) || (p \in \tau2(L)). + have [sLt2 t12cA' _] := primes_norm_tau2Elem maxM hallE t2q Eq2A maxNL. + split; first by have /andP[] := sLt2 q t2q. + apply: pnatPpi (pgroupS (quotientS _ sPE) t12cA') _. + rewrite -p_rank_gt0 -rank_pgroup ?quotient_pgroup // rank_gt0. + rewrite -subG1 quotient_sub1 ?subsetI ?sPE // (subset_trans sPE) //. + by rewrite normsI ?normG ?norms_cent. +have [maxL sNL] := setIdP maxNL; have sEL := subset_trans nAE sNL. +have sL'p: p \in \sigma(L)^' by move: t12Lp; rewrite -andb_orr => /andP[]. +have [sPL sL'P] := (subset_trans sPE sEL, pi_pgroup pP sL'p). +have{sL'P} [F hallF sPF] := Hall_superset (mmax_sol maxL) sPL sL'P. +have solF := sigma_compl_sol hallF. +have [sAL sL_A] := (subset_trans (normG A) sNL, pi_pgroup qA sLq). +have sALs: A \subset L`_\sigma by rewrite (sub_Hall_pcore (Msigma_Hall maxL)). +have neqLM: L != M by apply: contraTneq sLq => ->; case/andP: t2q. +have{t12Lp} [t1Lp | t2Lp] := orP t12Lp. + have [F1 hallF1 sPF1] := Hall_superset solF sPF (pi_pgroup pP t1Lp). + have EqLsY: Y \in 'E_q^1('C_(L`_\sigma)(P)). + by rewrite !inE setSI //; case/pnElemP: EqY => _ -> ->. + have [defL _] := cent_cent_Msigma_tau1_uniq maxL hallF hallF1 sPF1 ntP EqLsY. + by rewrite -in_set1 -uniqCY defL set11 in neqLM. +have sCPL: 'C(P) \subset L. + have [B Ep2B _] := ex_tau2Elem hallF t2Lp. + have EpFP: P \in 'E_p^1(F) by apply/pnElemP. + have [_ _ uniq_cLs _] := tau2_compl_context maxL hallF t2Lp Ep2B. + by case/mem_uniq_mmax: (uniq_cLs _ EpFP (subG1_contra (setSI _ sALs) ntCAP)). +have Eq2MA: A \in 'E_q^2(M). + by move: Eq2A; rewrite -(setIidPr (pHall_sub hallE)) pnElemI => /setIP[]. +have [_ _ _ tiMsL _] := tau2_context maxM t2q Eq2MA. +by case/negP: ntCMsP; rewrite -subG1 -(tiMsL L) ?setIS // 3!inE neqLM maxL. +Qed. + +(* This is B & G, Lemma 13.13. *) +Lemma tau13_nonregular_sigma M E p P : + M \in 'M -> \sigma(M)^'.-Hall(M) E -> + P \in 'E_p^1(E) -> (p \in \tau1(M)) || (p \in \tau3(M)) -> + 'C_(M`_\sigma)(P) != 1 -> + {in 'M('N(P)), forall Mstar, p \in \sigma(Mstar)}. +Proof. +move=> maxM hallE EpP t13Mp ntCMsP L maxNL /=. +have [maxL sNL] := setIdP maxNL. +have [sPE abelP dimP] := pnElemP EpP; have [pP _] := andP abelP. +have [solE ntP] := (sigma_compl_sol hallE, nt_pnElem EpP isT). +have /orP[// | t2Lp] := prime_class_mmax_norm maxL pP sNL. +have:= ntCMsP; rewrite -rank_gt0 => /rank_geP[Q /nElemP[q EqQ]]. +have [sQcMsP abelQ dimQ] := pnElemP EqQ; have [sQMs cPQ] := subsetIP sQcMsP. +have piQq: q \in \pi(Q) by rewrite -p_rank_gt0 p_rank_abelem ?dimQ. +have sMq: q \in \sigma(M) := pnatPpi (pgroupS sQMs (pcore_pgroup _ M)) piQq. +have rpM: 'r_p(M) = 1%N by move: t13Mp; rewrite -2!andb_orr andbCA; case: eqP. +have sL'q: q \notin \sigma(L). + have notMGL: gval L \notin M :^: G. + by apply: contraL t2Lp => /imsetP[x _ ->]; rewrite tau2J 2!inE rpM andbF. + by apply: contraFN (sigma_partition maxM maxL notMGL q) => sLq; apply/andP. +have [[sL'p _] [qQ _]] := (andP t2Lp, andP abelQ). +have sL'PQ: \sigma(L)^'.-group (P <*> Q). + by rewrite cent_joinEr // pgroupM (pi_pgroup pP) // (pi_pgroup qQ). +have sPQ_L: P <*> Q \subset L. + by rewrite (subset_trans _ sNL) // join_subG normG cents_norm. +have{sPQ_L sL'PQ} [F hallF sPQF] := Hall_superset (mmax_sol maxL) sPQ_L sL'PQ. +have{sPQF} [sPF sQF] := joing_subP sPQF. +have [A Ep2A _] := ex_tau2Elem hallF t2Lp. +have [[nsAF defA1] _ _ _] := tau2_compl_context maxL hallF t2Lp Ep2A. +have EpAP: P \in 'E_p^1(A) by rewrite -defA1; apply/pnElemP. +have{EpAP} sPA: P \subset A by case/pnElemP: EpAP. +have sCQM: 'C(Q) \subset M. + suffices: 'M('C(Q)) = [set M] by case/mem_uniq_mmax. + have [t1Mp | t3Mp] := orP t13Mp. + have [E1 hallE1 sPE1] := Hall_superset solE sPE (pi_pgroup pP t1Mp). + by have [] := cent_cent_Msigma_tau1_uniq maxM hallE hallE1 sPE1 ntP EqQ. + have [E3 hallE3 sPE3] := Hall_superset solE sPE (pi_pgroup pP t3Mp). + have [[E1 hallE1] _] := ex_tau13_compl hallE; have [sE1E _] := andP hallE1. + have [E2 _ complEi] := ex_tau2_compl hallE hallE1 hallE3. + have [regE3 | ntE1 _ prE _] := tau13_nonregular maxM complEi. + by rewrite (cent_semiregular regE3 sPE3 ntP) eqxx in ntCMsP. + rewrite /= (cent_semiprime prE) // -(cent_semiprime prE sE1E ntE1) in EqQ. + by have [] := cent_cent_Msigma_tau1_uniq maxM hallE hallE1 _ ntE1 EqQ. +have not_cQA: ~~ (A \subset 'C(Q)). + have [_ abelA dimA] := pnElemP Ep2A; apply: contraFN (ltnn 1) => cQA. + by rewrite -dimA -p_rank_abelem // -rpM p_rankS ?(subset_trans cQA sCQM). +have t1Lq: q \in \tau1(L). + have [_ nsCF t1Fb] := tau1_cent_tau2Elem_factor maxL hallF t2Lp Ep2A. + rewrite (pnatPpi (pgroupS (quotientS _ sQF) t1Fb)) //. + rewrite -p_rank_gt0 -rank_pgroup ?quotient_pgroup // rank_gt0. + rewrite -subG1 quotient_sub1 ?(subset_trans _ (normal_norm nsCF)) //. + by rewrite subsetI sQF centsC. +have defP: 'C_A(Q) = P. + apply/eqP; rewrite eq_sym eqEcard subsetI sPA centsC cPQ /=. + have [_ abelA dimA] := pnElemP Ep2A; have [pA _] := andP abelA. + rewrite (card_pgroup (pgroupS _ pA)) ?subsetIl // (card_pgroup pP) dimP. + rewrite leq_exp2l ?prime_gt1 ?(pnElem_prime EpP) //. + by rewrite -ltnS -dimA properG_ltn_log // /proper subsetIl subsetIidl. +have EqFQ: Q \in 'E_q^1(F) by exact/pnElemP. +have regQLs: 'C_(L`_\sigma)(Q) = 1. + by rewrite (tau12_regular maxL hallF t1Lq EqFQ t2Lp Ep2A) // defP. +have ntAQ: [~: A, Q] != 1 by rewrite (sameP eqP commG1P). +have [_ _ [_]] := tau1_act_tau2 maxL hallF t2Lp Ep2A t1Lq EqFQ regQLs ntAQ. +by case/negP; rewrite /= defP (subset_trans (cent_sub P)). +Qed. + +End Section13. + diff --git a/mathcomp/odd_order/BGsection14.v b/mathcomp/odd_order/BGsection14.v new file mode 100644 index 0000000..493f634 --- /dev/null +++ b/mathcomp/odd_order/BGsection14.v @@ -0,0 +1,2513 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div path fintype. +Require Import bigop finset prime fingroup morphism perm automorphism quotient. +Require Import action gproduct gfunctor pgroup cyclic center commutator. +Require Import gseries nilpotent sylow abelian maximal hall frobenius. +Require Import ssralg ssrnum ssrint rat. +Require Import BGsection1 BGsection3 BGsection4 BGsection5 BGsection6. +Require Import BGsection7 BGsection9 BGsection10 BGsection12 BGsection13. + +(******************************************************************************) +(* This file covers B & G, section 14, starting with the definition of the *) +(* sigma-decomposition of elements, sigma-supergroups, and basic categories *) +(* of maximal subgroups: *) +(* sigma_decomposition x == the set of nontrivial constituents x.`_\sigma(M), *) +(* with M ranging over maximal sugroups of G. *) +(* (x is the product of these). *) +(* \ell_\sigma[x] == #|sigma_decomposition x|. *) +(* 'M_\sigma(X) == the set of maximal subgroups M such that X is a *) +(* a subset of M`_\sigma. *) +(* 'M_\sigma[x] := 'M_\sigma(<[x]>) *) +(* \kappa(M) == the set of primes p in \tau1(M) or \tau3(M), such *) +(* that 'C_(M`_\sigma)(P) != 1 for some subgroup of *) +(* M of order p, i.e., the primes for which M fails *) +(* to be a Frobenius group. *) +(* kappa_complement M U K <-> U and K are respectively {kappa, sigma}'- and *) +(* kappa-Hall subgroups of M, whose product is a *) +(* sigma-complement of M. This corresponds to the *) +(* notation introduced at the start of section 15 in *) +(* B & G, but is needed here to capture the use of *) +(* bound variables of 14.2(a) in the statement of *) +(* Lemma 14.12. *) +(* 'M_'F == the set of maximal groups M for which \kappa(M) *) +(* is empty, i.e., the maximal groups of Frobenius *) +(* type (in the final classification, this becomes *) +(* Type I). *) +(* 'M_'P == the complement to 'M_'F in 'M, i.e., the set of M *) +(* for which at least E1 has a proper prime action *) +(* on M`_\sigma. *) +(* 'M_'P1 == the set of maximal subgroups M such that \pi(M) *) +(* is the disjoint union of \sigma(M) and \kappa(M), *) +(* i.e., for which the entire complement acts in a *) +(* prime manner (this troublesome subset of 'M_'P is *) +(* ultimately refined into Types III-V in the final *) +(* classification). *) +(* 'M_'P2 == the complement to 'M_'P1 in 'M_'P; this becomes *) +(* Type II in the final classification. *) +(* 'N[x] == if x != 1 and 'M_\sigma[x] > 1, the unique group *) +(* in 'M('C[x]) (see B & G, Theorem 14.4), and the *) +(* trivial group otherwise. *) +(* 'R[x] := 'C_('N[x]`_\sigma)[x]; if \ell_\sigma[x] == 1, *) +(* this is the normal Hall subgroup of 'C[x] that *) +(* acts sharply transitively by conjugagtion on *) +(* 'M`_\sigma[x] (again, by Theorem 14.4). *) +(* M^~~ == the union of all the cosets x *: 'R[x], with x *) +(* ranging over (M`_\sigma)^#. This will become the *) +(* support set for the Dade isometry for M in the *) +(* character theory part of the proof. *) +(* It seems 'R[x] and 'N[x]`_\sigma play a somewhat the role of a signalizer *) +(* functor in the FT proof; in particular 'R[x] will be used to construct the *) +(* Dade isometry in the character theory part of the proof. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope ring_scope. +Local Open Scope nat_scope. +Import GRing.Theory Num.Theory GroupScope. + +Section Definitons. + +Variable gT : minSimpleOddGroupType. +Implicit Type x : gT. +Implicit Type M X : {set gT}. + +Definition sigma_decomposition x := + [set x.`_\sigma(M) | M : {group gT} in 'M]^#. +Definition sigma_length x := #|sigma_decomposition x|. + +Definition sigma_mmax_of X := [set M in 'M | X \subset M`_\sigma]. + +Definition FT_signalizer_base x := + if #|sigma_mmax_of <[x]>| > 1 then odflt 1%G (pick (mem 'M('C[x]))) else 1%G. + +Definition FT_signalizer x := 'C_((FT_signalizer_base x)`_\sigma)[x]. + +Definition sigma_cover M := \bigcup_(x in (M`_\sigma)^#) x *: FT_signalizer x. + +Definition tau13 M := [predU \tau1(M) & \tau3(M)]. + +Fact kappa_key : unit. Proof. by []. Qed. +Definition kappa_def M : nat_pred := + [pred p in tau13 M | [exists P in 'E_p^1(M), 'C_(M`_\sigma)(P) != 1]]. +Definition kappa := locked_with kappa_key kappa_def. +Canonical kappa_unlockable := [unlockable fun kappa]. + +Definition sigma_kappa M := [predU \sigma(M) & kappa M]. + +Definition kappa_complement (M U K : {set gT}) := + [/\ (sigma_kappa M)^'.-Hall(M) U, (kappa M).-Hall(M) K & group_set (U * K)]. + +Definition TypeF_maxgroups := [set M in 'M | (kappa M)^'.-group M]. + +Definition TypeP_maxgroups := 'M :\: TypeF_maxgroups. + +Definition TypeP1_maxgroups := + [set M in TypeP_maxgroups | (sigma_kappa M).-group M]. + +Definition TypeP2_maxgroups := TypeP_maxgroups :\: TypeP1_maxgroups. + +End Definitons. + +Notation "\ell_ \sigma ( x )" := (sigma_length x) + (at level 8, format "\ell_ \sigma ( x )") : group_scope. + +Notation "''M_' \sigma ( X )" := (sigma_mmax_of X) + (at level 8, format "''M_' \sigma ( X )") : group_scope. + +Notation "''M_' \sigma [ x ]" := (sigma_mmax_of <[x]>) + (at level 8, format "''M_' \sigma [ x ]") : group_scope. + +Notation "''N' [ x ]" := (FT_signalizer_base x) + (at level 8, format "''N' [ x ]") : group_scope. + +Notation "''R' [ x ]" := (FT_signalizer x) + (at level 8, format "''R' [ x ]") : group_scope. + +Notation "M ^~~" := (sigma_cover M) + (at level 2, format "M ^~~") : group_scope. + +Notation "\tau13 ( M )" := (tau13 M) + (at level 8, format "\tau13 ( M )") : group_scope. + +Notation "\kappa ( M )" := (kappa M) + (at level 8, format "\kappa ( M )") : group_scope. + +Notation "\sigma_kappa ( M )" := (sigma_kappa M) + (at level 8, format "\sigma_kappa ( M )") : group_scope. + +Notation "''M_' ''F'" := (TypeF_maxgroups _) + (at level 2, format "''M_' ''F'") : group_scope. + +Notation "''M_' ''P'" := (TypeP_maxgroups _) + (at level 2, format "''M_' ''P'") : group_scope. + +Notation "''M_' ''P1'" := (TypeP1_maxgroups _) + (at level 2, format "''M_' ''P1'") : group_scope. + +Notation "''M_' ''P2'" := (TypeP2_maxgroups _) + (at level 2, format "''M_' ''P2'") : group_scope. + +Section Section14. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). +Implicit Types p q q_star r : nat. +Implicit Types x y z : gT. +Implicit Types A E H K L M Mstar N P Q Qstar R S T U V W X Y Z : {group gT}. + +(* Basic properties of the sigma decomposition. *) +Lemma mem_sigma_decomposition x M (xM := x.`_\sigma(M)) : + M \in 'M -> xM != 1 -> xM \in sigma_decomposition x. +Proof. by move=> maxM nt_xM; rewrite !inE nt_xM; apply: mem_imset. Qed. + +Lemma sigma_decompositionJ x z : + sigma_decomposition (x ^ z) = sigma_decomposition x :^ z. +Proof. +rewrite conjD1g -[_ :^ z]imset_comp; congr _^#. +by apply: eq_in_imset => M maxM; rewrite /= consttJ. +Qed. + +Lemma ell_sigmaJ x z : \ell_\sigma(x ^ z) = \ell_\sigma(x). +Proof. by rewrite /sigma_length sigma_decompositionJ cardJg. Qed. + +Lemma sigma_mmaxJ M (X : {set gT}) z : + ((M :^ z)%G \in 'M_\sigma(X :^ z)) = (M \in 'M_\sigma(X)). +Proof. by rewrite inE mmaxJ MsigmaJ conjSg !inE. Qed. + +Lemma card_sigma_mmaxJ (X : {set gT}) z : + #|'M_\sigma(X :^ z)| = #|'M_\sigma(X)|. +Proof. +rewrite -(card_setact 'JG _ z^-1) setactVin ?inE //. +by apply: eq_card => M; rewrite inE sigma_mmaxJ. +Qed. + +Lemma sigma_decomposition_constt' x M (sM := \sigma(M)) : + M \in 'M -> sigma_decomposition x.`_sM^' = sigma_decomposition x :\ x.`_sM. +Proof. +move=> maxM; apply/setP=> y; rewrite !inE andbCA; apply: andb_id2l => nty. +apply/imsetP/andP=> [ | [neq_y_xM /imsetP]] [L maxL def_y]. + have not_sMy: ~~ sM.-elt y. + apply: contra nty => sMy; rewrite -order_eq1 (pnat_1 sMy) // def_y. + by apply: p_eltX; apply: p_elt_constt. + split; first by apply: contraNneq not_sMy => ->; apply: p_elt_constt. + have notMGL: gval L \notin M :^: G. + apply: contra not_sMy; rewrite def_y; case/imsetP=> z _ ->. + by rewrite (eq_constt _ (sigmaJ M z)) p_elt_constt. + apply/imsetP; exists L; rewrite // def_y sub_in_constt // => p _ sLp. + by apply: contraFN (sigma_partition maxM maxL notMGL p) => sMp; apply/andP. +exists L; rewrite ?sub_in_constt // => p _ sLp. +suffices notMGL: gval L \notin M :^: G. + by apply: contraFN (sigma_partition maxM maxL notMGL p) => sMp; apply/andP. +apply: contra neq_y_xM; rewrite def_y => /imsetP[z _ ->]. +by rewrite (eq_constt _ (sigmaJ M z)). +Qed. + +(* General remarks about the sigma-decomposition, p. 105 of B & G. *) +Remark sigma_mmax_exists p : + p \in \pi(G) -> {M : {group gT} | M \in 'M & p \in \sigma(M)}. +Proof. +move=> piGp; have [P sylP] := Sylow_exists p [set: gT]. +have ntP: P :!=: 1 by rewrite -rank_gt0 (rank_Sylow sylP) p_rank_gt0. +have ltPG: P \proper G := mFT_pgroup_proper (pHall_pgroup sylP). +have [M maxNM] := mmax_exists (mFT_norm_proper ntP ltPG). +have{maxNM} [maxM sNM] := setIdP maxNM; have sPM := subset_trans (normG P) sNM. +have{sylP} sylP := pHall_subl sPM (subsetT M) sylP. +by exists M => //; apply/exists_inP; exists P. +Qed. + +Lemma ell_sigma0P x : reflect (x = 1) (\ell_\sigma(x) == 0). +Proof. +rewrite cards_eq0 setD_eq0. +apply: (iffP idP) => [x1 | ->]; last first. + by apply/subsetP=> _ /imsetP[M _ ->]; rewrite constt1 inE. +rewrite -(prod_constt x) big1_seq //= => p _; apply: contraTeq x1 => nt_xp. +have piXp: p \in \pi(#[x]) by rewrite -p_part_gt1 -order_constt order_gt1. +have [M maxM sMp] := sigma_mmax_exists (piSg (subsetT _) piXp). +apply/subsetPn; exists (x.`_(\sigma(M))); first exact: mem_imset. +by rewrite (sameP set1P constt1P); apply: contraL sMp => /pnatPpi; apply. +Qed. + +Remark sigma_decomposition_subG x H : + x \in H -> sigma_decomposition x \subset H. +Proof. +by move=> Hx; apply/subsetP=> _ /setD1P[_ /imsetP[M _ ->]]; apply: groupX. +Qed. + +Remark prod_sigma_decomposition x : + \prod_(x_sM in sigma_decomposition x) x_sM = x. +Proof. +rewrite -big_filter filter_index_enum; set e := enum _. +have: uniq e := enum_uniq _; have: e =i sigma_decomposition x := mem_enum _. +elim: {x}e (x) => [|y e IHe] x def_e /= Ue. + by rewrite big_nil (ell_sigma0P x _) //; apply/pred0P; apply: fsym. +have{Ue} [not_e_y Ue] := andP Ue. +have [nty] := setD1P (etrans (fsym def_e y) (mem_head _ _)). +case/imsetP=> M maxM def_y; rewrite big_cons -(consttC \sigma(M) x) -def_y. +congr (y * _); apply: IHe Ue => z; rewrite sigma_decomposition_constt' //. +rewrite -def_y inE -def_e !inE andb_orr andNb andb_idl //. +by apply: contraTneq => ->. +Qed. + +Lemma ell1_decomposition x : + \ell_\sigma(x) == 1%N -> sigma_decomposition x = [set x]. +Proof. +case/cards1P=> y sdx_y. +by rewrite -{2}[x]prod_sigma_decomposition sdx_y big_set1. +Qed. + +Lemma Msigma_ell1 M x : + M \in 'M -> x \in (M`_\sigma)^# -> \ell_\sigma(x) == 1%N. +Proof. +move=> maxM /setD1P[ntx Ms_x]; apply/cards1P. +have sMx: \sigma(M).-elt x := mem_p_elt (pcore_pgroup _ _) Ms_x. +have def_xM: x.`_(\sigma(M)) = x := constt_p_elt sMx. +exists x; apply/eqP; rewrite eqEsubset sub1set !inE ntx -setD_eq0 /=. +rewrite -{2 3}def_xM -sigma_decomposition_constt' // (constt1P _) ?p_eltNK //. +by rewrite -cards_eq0 (sameP (ell_sigma0P 1) eqP) eqxx; apply: mem_imset. +Qed. + +Remark ell_sigma1P x : + reflect (x != 1 /\ 'M_\sigma[x] != set0) (\ell_\sigma(x) == 1%N). +Proof. +apply: (iffP idP) => [ell1x | [ntx]]; last first. + case/set0Pn=> M /setIdP[maxM]; rewrite cycle_subG => Ms_x. + by rewrite (Msigma_ell1 maxM) // in_setD1 ntx. +have sdx_x: x \in sigma_decomposition x by rewrite ell1_decomposition ?set11. +have{sdx_x} [ntx sdx_x] := setD1P sdx_x; split=> //; apply/set0Pn. +have{sdx_x} [M maxM def_x] := imsetP sdx_x; rewrite // -cycle_eq1 in ntx. +have sMx: \sigma(M).-elt x by rewrite def_x p_elt_constt. +have [[z sXzMs] _] := sigma_Jsub maxM sMx ntx. +by exists (M :^ z^-1)%G; rewrite inE mmaxJ maxM MsigmaJ -sub_conjg. +Qed. + +Remark ell_sigma_le1 x :(\ell_\sigma(x) <= 1) = ('M_\sigma[x] != set0). +Proof. +rewrite -[_ <= 1](mem_iota 0 2) !inE (sameP (ell_sigma0P x) eqP). +rewrite (sameP (ell_sigma1P x) andP); case: eqP => //= ->; symmetry. +have [M max1M] := mmax_exists (mFT_pgroup_proper (@pgroup1 gT 2)). +have [maxM _] := setIdP max1M; apply/set0Pn; exists M. +by rewrite inE maxM cycle1 sub1G. +Qed. + +(* Basic properties of \kappa and the maximal group subclasses. *) +Lemma kappaJ M x : \kappa(M :^ x) =i \kappa(M). +Proof. +move=> p; rewrite unlock 3!{1}inE /= tau1J tau3J; apply: andb_id2l => _. +apply/exists_inP/exists_inP=> [] [P EpP ntCMsP]. + rewrite -(conjsgK x M); exists (P :^ x^-1)%G; first by rewrite pnElemJ. + by rewrite MsigmaJ centJ -conjIg -subG1 sub_conjg conjs1g subG1. +exists (P :^ x)%G; first by rewrite pnElemJ. +by rewrite MsigmaJ centJ -conjIg -subG1 sub_conjg conjs1g subG1. +Qed. + +Lemma kappa_tau13 M p : p \in \kappa(M) -> (p \in \tau1(M)) || (p \in \tau3(M)). +Proof. by rewrite unlock => /andP[]. Qed. + +Lemma kappa_sigma' M : {subset \kappa(M) <= \sigma(M)^'}. +Proof. by move=> p /kappa_tau13/orP[] /andP[]. Qed. + +Remark rank_kappa M p : p \in \kappa(M) -> 'r_p(M) = 1%N. +Proof. by case/kappa_tau13/orP=> /and3P[_ /eqP]. Qed. + +Lemma kappa_pi M : {subset \kappa(M) <= \pi(M)}. +Proof. by move=> p kMp; rewrite -p_rank_gt0 rank_kappa. Qed. + +Remark kappa_nonregular M p P : + p \in \kappa(M) -> P \in 'E_p^1(M) -> 'C_(M`_\sigma)(P) != 1. +Proof. +move=> kMp EpP; have rpM := rank_kappa kMp. +have [sPM abelP oP] := pnElemPcard EpP; have [pP _] := andP abelP. +have [Q EpQ nregQ]: exists2 Q, Q \in 'E_p^1(M) & 'C_(M`_\sigma)(Q) != 1. + by apply/exists_inP; rewrite unlock in kMp; case/andP: kMp. +have [sQM abelQ oQ] := pnElemPcard EpQ; have [pQ _] := andP abelQ. +have [S sylS sQS] := Sylow_superset sQM pQ; have [_ pS _] := and3P sylS. +have [x Mx sPxS] := Sylow_Jsub sylS sPM pP. +rewrite -(inj_eq (@conjsg_inj _ x)) conjs1g conjIg -centJ. +rewrite (normsP (normal_norm (pcore_normal _ _))) // (subG1_contra _ nregQ) //. +rewrite setIS ?centS // -(cardSg_cyclic _ sPxS sQS) ?cardJg ?oP ?oQ //. +by rewrite (odd_pgroup_rank1_cyclic pS) ?mFT_odd // (p_rank_Sylow sylS) rpM. +Qed. + +Lemma ex_kappa_compl M K : + M \in 'M -> \kappa(M).-Hall(M) K -> + exists U : {group gT}, kappa_complement M U K. +Proof. +move=> maxM hallK; have [sKM kK _] := and3P hallK. +have s'K: \sigma(M)^'.-group K := sub_pgroup (@kappa_sigma' M) kK. +have [E hallE sKE] := Hall_superset (mmax_sol maxM) sKM s'K. +pose sk' := \sigma_kappa(M)^'. +have [U hallU] := Hall_exists sk' (sigma_compl_sol hallE). +exists U; split=> //. + by apply: subHall_Hall hallE _ hallU => p; case/norP. +suffices ->: U * K = E by apply: groupP. +have [[sUE sk'U _] [sEM s'E _]] := (and3P hallU, and3P hallE). +apply/eqP; rewrite eqEcard mulG_subG sUE sKE /= coprime_cardMg; last first. + by apply: p'nat_coprime (sub_pgroup _ sk'U) kK => p; case/norP. +rewrite -(partnC \kappa(M) (cardG_gt0 E)) -{2}(part_pnat_id s'E) mulnC. +rewrite -(card_Hall (pHall_subl sKE sEM hallK)) leq_mul // -partnI. +by rewrite -(@eq_partn sk') -?(card_Hall hallU) // => p; apply: negb_or. +Qed. + +Lemma FtypeP M : reflect (M \in 'M /\ \kappa(M) =i pred0) (M \in 'M_'F). +Proof. +do [apply: (iffP setIdP) => [] [maxM k'M]; split] => // [p|]. + by apply/idP=> /= kMp; case/negP: (pnatPpi k'M (kappa_pi kMp)). +by apply/pgroupP=> p _ _; rewrite inE /= k'M. +Qed. + +Lemma PtypeP M : reflect (M \in 'M /\ exists p, p \in \kappa(M)) (M \in 'M_'P). +Proof. +apply: (iffP setDP) => [[maxM kM] | [maxM [p kMp]]]; split => //. + rewrite inE maxM !negb_and cardG_gt0 /= all_predC negbK in kM. + by have [p _ kMp] := hasP kM; exists p. +by apply/FtypeP=> [[_ kM0]]; rewrite kM0 in kMp. +Qed. + +Lemma trivg_kappa M K : + M \in 'M -> \kappa(M).-Hall(M) K -> (K :==: 1) = (M \in 'M_'F). +Proof. +by move=> maxM hallK; rewrite inE maxM trivg_card1 (card_Hall hallK) partG_eq1. +Qed. + +(* Could go in Section 10. *) +Lemma not_sigma_mmax M : M \in 'M -> ~~ \sigma(M).-group M. +Proof. +move=> maxM; apply: contraL (mmax_sol maxM); rewrite negb_forall_in => sM. +apply/existsP; exists M; rewrite mmax_neq1 // subsetIidl andbT. +apply: subset_trans (Msigma_der1 maxM). +by rewrite (sub_Hall_pcore (Msigma_Hall maxM)). +Qed. + +Lemma trivg_kappa_compl M U K : + M \in 'M -> kappa_complement M U K -> (U :==: 1) = (M \in 'M_'P1). +Proof. +move=> maxM [hallU _ _]; symmetry. +rewrite 3!inE maxM /= trivg_card1 (card_Hall hallU) partG_eq1 pgroupNK andbT. +apply: andb_idl => skM; apply: contra (not_sigma_mmax maxM). +by apply: sub_in_pnat => p /(pnatPpi skM)/orP[] // kMp /negP. +Qed. + +Lemma FtypeJ M x : ((M :^ x)%G \in 'M_'F) = (M \in 'M_'F). +Proof. by rewrite inE mmaxJ pgroupJ (eq_p'group _ (kappaJ M x)) !inE. Qed. + +Lemma PtypeJ M x : ((M :^ x)%G \in 'M_'P) = (M \in 'M_'P). +Proof. by rewrite !in_setD mmaxJ FtypeJ. Qed. + +Lemma P1typeJ M x : ((M :^ x)%G \in 'M_'P1) = (M \in 'M_'P1). +Proof. +rewrite inE PtypeJ pgroupJ [M \in 'M_'P1]inE; congr (_ && _). +by apply: eq_pgroup => p; rewrite inE /= kappaJ sigmaJ. +Qed. + +Lemma P2typeJ M x : ((M :^ x)%G \in 'M_'P2) = (M \in 'M_'P2). +Proof. by rewrite in_setD PtypeJ P1typeJ -in_setD. Qed. + +(* This is B & G, Lemma 14.1. *) +Lemma sigma'_kappa'_facts M p S (A := 'Ohm_1(S)) (Ms := M`_\sigma) : + M \in 'M -> p.-Sylow(M) S -> + [&& p \in \pi(M), p \notin \sigma(M) & p \notin \kappa(M)] -> + [/\ M \in 'M_'F :|: 'M_'P2, logn p #|A| <= 2, 'C_Ms(A) = 1 & nilpotent Ms]. +Proof. +move=> maxM sylS /and3P[piMp sM'p kM'p]; have [sSM pS _] := and3P sylS. +rewrite 8!(maxM, inE) /= !andbT negb_and orb_andr orbN andbT negbK. +rewrite (contra (fun skM => pnatPpi skM piMp)) ?orbT; last exact/norP. +rewrite partition_pi_mmax // (negPf sM'p) orbF orbCA in piMp. +have{piMp} [t2p | t13p] := orP piMp. + rewrite (tau2_Msigma_nil maxM t2p); have [_ rpM] := andP t2p. + have{rpM} rS: 2 <= 'r_p(S) by rewrite (p_rank_Sylow sylS) (eqP rpM). + have [B EpB] := p_rank_geP rS; have{EpB} [sBS abelB dimB] := pnElemP EpB. + have EpB: B \in 'E_p^2(M) by rewrite !inE abelB dimB (subset_trans sBS). + have [defB _ regB _ _] := tau2_context maxM t2p EpB. + by rewrite /A -dimB; have [_ [|->]] := defB S sylS. +have [ntS cycS]: S :!=: 1 /\ cyclic S. + rewrite (odd_pgroup_rank1_cyclic pS) ?mFT_odd // (p_rank_Sylow sylS). + apply/andP; rewrite -rank_gt0 (rank_Sylow sylS) -eqn_leq eq_sym. + by rewrite -2!andb_orr orNb andbT inE /= sM'p in t13p. +have [p_pr _ _] := pgroup_pdiv pS ntS. +have oA: #|A| = p by rewrite (Ohm1_cyclic_pgroup_prime cycS pS). +have sAM: A \subset M := subset_trans (Ohm_sub 1 S) sSM. +have regA: 'C_Ms(A) = 1. + apply: contraNeq kM'p => nregA; rewrite unlock; apply/andP; split=> //. + by apply/exists_inP; exists [group of A]; rewrite ?p1ElemE // !inE sAM oA /=. +have defMsA: Ms ><| A = Ms <*> A. + rewrite sdprodEY ?coprime_TIg ?(subset_trans sAM) ?gFnorm // oA. + by rewrite (pnat_coprime (pcore_pgroup _ _)) ?pnatE. +rewrite (prime_Frobenius_sol_kernel_nil defMsA) ?oA ?(pfactorK 1) //. +by rewrite (solvableS _ (mmax_sol maxM)) // join_subG pcore_sub. +Qed. + +Lemma notP1type_Msigma_nil M : + (M \in 'M_'F) || (M \in 'M_'P2) -> nilpotent M`_\sigma. +Proof. +move=> notP1maxM; suffices [maxM]: M \in 'M /\ ~~ \sigma_kappa(M).-group M. + rewrite negb_and cardG_gt0 => /allPn[p piMp /norP[s'p k'p]]. + by have [S /sigma'_kappa'_facts[] //] := Sylow_exists p M; apply/and3P. +have [/setIdP[maxM k'M] | /setDP[PmaxM]] := orP notP1maxM; last first. + by rewrite inE PmaxM; case/setDP: PmaxM. +split=> //; apply: contra (not_sigma_mmax maxM). +by apply: sub_in_pnat => p piMp /orP[] // /idPn[]; exact: (pnatPpi k'M). +Qed. + +(* This is B & G, Proposition 14.2. *) +Proposition Ptype_structure M K (Ms := M`_\sigma) (Kstar := 'C_Ms(K)) : + M \in 'M_'P -> \kappa(M).-Hall(M) K -> + [/\ (*a*) exists2 U : {group gT}, + kappa_complement M U K /\ Ms ><| (U ><| K) = M + & [/\ abelian U, semiprime Ms K & semiregular U K], + (*b*) (*1.2*) K \x Kstar = 'N_M(K) + /\ {in 'E^1(K), forall X, + (*1.1*) 'N_M(X) = 'N_M(K) + /\ (*2*) {in 'M('N(X)), forall Mstar, X \subset Mstar`_\sigma}}, + (*c*) Kstar != 1 /\ {in 'E^1(Kstar), forall X, 'M('C(X)) = [set M]}, + [/\ (*d*) {in ~: M, forall g, Kstar :&: M :^ g = 1} + /\ {in M :\: 'N_M(K), forall g, K :&: K :^ g = 1}, + (*e*) {in \pi(Kstar), forall p S, + p.-Sylow(M) S -> 'M(S) = [set M] /\ ~~ (S \subset Kstar)} + & (*f*) forall Y, \sigma(M).-group Y -> Y :&: Kstar != 1 -> Y \subset Ms] + & (*g*) M \in 'M_'P2 -> + [/\ \sigma(M) =i \beta(M), prime #|K|, nilpotent Ms + & normedTI Ms^# G M]]. +Proof. +move: @Kstar => Ks PmaxM hallK; have [maxM notFmaxM] := setDP PmaxM. +have sMs: \sigma(M).-group M`_\sigma := pcore_pgroup _ M. +have{notFmaxM} ntK: K :!=: 1 by rewrite (trivg_kappa maxM). +have [sKM kK _] := and3P hallK; have s'K := sub_pgroup (@kappa_sigma' M) kK. +have solM := mmax_sol maxM; have [E hallE sKE] := Hall_superset solM sKM s'K. +have [[sEM s'E _] [_ [E3 hallE3]]] := (and3P hallE, ex_tau13_compl hallE). +have [F1 hallF1] := Hall_exists \tau1(M) (solvableS sKM solM). +have [[sF1K t1F1 _] solE] := (and3P hallF1, sigma_compl_sol hallE). +have [E1 hallE1 sFE1] := Hall_superset solE (subset_trans sF1K sKE) t1F1. +have [E2 hallE2 complEi] := ex_tau2_compl hallE hallE1 hallE3. +have [[_ nsE3E] _ [cycE1 _] [defEl defE] _] := sigma_compl_context maxM complEi. +have [sE1E t1E1 _] := and3P hallE1; have sE1M := subset_trans sE1E sEM. +have [sE3E t3E3 _] := and3P hallE3; have sE3M := subset_trans sE3E sEM. +set part_a := exists2 U, _ & _; pose b1_hyp := {in 'E^1(K), forall X, X <| K}. +have [have_a nK1K ntE1 sE1K]: [/\ part_a, b1_hyp, E1 :!=: 1 & E1 \subset K]. + have [t1K | not_t1K] := boolP (\tau1(M).-group K). + have sKE1: K \subset E1 by rewrite (sub_pHall hallF1 t1K). + have prE1 := tau1_primact_Msigma maxM hallE hallE1. + have st1k: {subset \tau1(M) <= \kappa(M)}. + move=> p t1p; rewrite unlock 3!inE /= t1p /=. + have [X]: exists X, X \in 'E_p^1(E1). + apply/p_rank_geP; rewrite p_rank_gt0 /= (card_Hall hallE1). + by rewrite pi_of_part // inE /= (partition_pi_sigma_compl maxM) ?t1p. + rewrite -(setIidPr sE1M) pnElemI -setIdE => /setIdP[EpX sXE1]. + pose q := pdiv #|K|; have piKq: q \in \pi(K) by rewrite pi_pdiv cardG_gt1. + have /p_rank_geP[Y]: 0 < 'r_q(K) by rewrite p_rank_gt0. + rewrite -(setIidPr sKM) pnElemI -setIdE => /setIdP[EqY sYK]. + have ntCMsY := kappa_nonregular (pnatPpi kK piKq) EqY. + have [ntY sYE1] := (nt_pnElem EqY isT, subset_trans sYK sKE1). + apply/exists_inP; exists X; rewrite ?(subG1_contra _ ntCMsY) //=. + by rewrite (cent_semiprime prE1 sYE1 ntY) ?setIS ?centS. + have defK := sub_pHall hallK (sub_pgroup st1k t1E1) sKE1 sE1M. + split=> [|X||]; rewrite ?defK //; last first. + rewrite -defK; case/nElemP=> p /pnElemP[sXE1 _ _]. + by rewrite char_normal // sub_cyclic_char. + have [[U _ defU _] _ _ _] := sdprodP defE; rewrite defU in defE. + have [nsUE _ mulUE1 nUE1 _] := sdprod_context defE. + have [[_ V _ defV] _] := sdprodP defEl; rewrite defV. + have [_ <- nE21 _] := sdprodP defV => /mulGsubP[nE32 nE31] _. + have regUK: semiregular U K. + move=> y /setD1P[]; rewrite -cycle_subG -cent_cycle -order_gt1. + rewrite -pi_pdiv; move: (pdiv _) => p pi_y_p Ky. + have piKp := piSg Ky pi_y_p; have t1p := pnatPpi t1K piKp. + move: pi_y_p; rewrite -p_rank_gt0 => /p_rank_geP[Y] /=. + rewrite -{1}(setIidPr (subset_trans Ky sKE)) pnElemI -setIdE. + case/setIdP=> EpY sYy; have EpMY := subsetP (pnElemS _ _ sEM) Y EpY. + apply: contraNeq (kappa_nonregular (pnatPpi kK piKp) EpMY). + move/(subG1_contra (setIS U (centS sYy))). + have{y sYy Ky} sYE1 := subset_trans sYy (subset_trans Ky sKE1). + have ntY: Y :!=: 1 by apply: (nt_pnElem EpY). + rewrite -subG1 /=; have [_ <- _ tiE32] := sdprodP defU. + rewrite -subcent_TImulg ?subsetI ?(subset_trans sYE1) // mulG_subG. + rewrite !subG1 /= => /nandP[nregE3Y | nregE2Y]. + have pr13 := cent_semiprime (tau13_primact_Msigma maxM complEi _). + rewrite pr13 ?(subset_trans sYE1) ?joing_subr //; last first. + by move/cent_semiregular=> regE31; rewrite regE31 ?eqxx in nregE3Y. + pose q := pdiv #|'C_E3(Y)|. + have piE3q: q \in \pi(E3). + by rewrite (piSg (subsetIl E3 'C(Y))) // pi_pdiv cardG_gt1. + have /p_rank_geP[X]: 0 < 'r_q(M :&: E3). + by rewrite (setIidPr sE3M) p_rank_gt0. + rewrite pnElemI -setIdE => /setIdP[EqX sXE3]. + rewrite -subG1 -(_ : 'C_Ms(X) = 1) ?setIS ?centS //. + by rewrite (subset_trans sXE3) ?joing_subl. + apply: contraTeq (pnatPpi t3E3 piE3q) => nregMsX; apply: tau3'1. + suffices kq: q \in \kappa(M). + rewrite (pnatPpi t1K) //= (card_Hall hallK) pi_of_part //. + by rewrite inE /= kappa_pi. + rewrite unlock 3!inE /= (pnatPpi t3E3 piE3q) orbT /=. + by apply/exists_inP; exists X. + pose q := pdiv #|'C_E2(Y)|; have [sE2E t2E2 _] := and3P hallE2. + have piCE2Yq: q \in \pi('C_E2(Y)) by rewrite pi_pdiv cardG_gt1. + have [X]: exists X, X \in 'E_q^1(E :&: 'C_E2(Y)). + by apply/p_rank_geP; rewrite /= setIA (setIidPr sE2E) p_rank_gt0. + rewrite pnElemI -setIdE => /setIdP[EqX sXcE2Y]. + have t2q:= pnatPpi t2E2 (piSg (subsetIl _ _) piCE2Yq). + have [A Eq2A _] := ex_tau2Elem hallE t2q. + have [[_ defEq1] _ _ _] := tau2_compl_context maxM hallE t2q Eq2A. + rewrite (tau12_regular maxM hallE t1p EpY t2q Eq2A) //. + rewrite (subG1_contra _ (nt_pnElem EqX _)) // subsetI. + rewrite defEq1 in EqX; case/pnElemP: EqX => -> _ _. + by rewrite (subset_trans sXcE2Y) ?subsetIr. + have [defM [sUE _]] := (sdprod_sigma maxM hallE, andP nsUE). + have hallU: \sigma_kappa(M)^'.-Hall(M) U. + suffices: [predI \sigma(M)^' & \kappa(M)^'].-Hall(M) U. + by apply: etrans; apply: eq_pHall=> p; rewrite inE /= negb_or. + apply: subHall_Hall hallE _ _ => [p|]; first by case/andP. + rewrite pHallE partnI (part_pnat_id s'E) -pHallE. + have hallK_E: \kappa(M).-Hall(E) K := pHall_subl sKE sEM hallK. + by apply/(sdprod_normal_pHallP nsUE hallK_E); rewrite -defK. + exists U; [rewrite -{2}defK defE | rewrite -{1}defK]; split=> //. + by split; rewrite // -defK mulUE1 groupP. + apply: abelianS (der_mmax_compl_abelian maxM hallE). + rewrite -(coprime_cent_prod nUE1) ?(solvableS sUE) //. + by rewrite {2}defK (cent_semiregular regUK) // mulg1 commgSS. + by rewrite (coprime_sdprod_Hall_r defE); apply: pHall_Hall hallE1. + move: not_t1K; rewrite negb_and cardG_gt0 => /allPn[p piKp t1'p]. + have kp := pnatPpi kK piKp; have t3p := kappa_tau13 kp. + rewrite [p \in _](negPf t1'p) /= in t3p. + have [X]: exists X, X \in 'E_p^1(K) by apply/p_rank_geP; rewrite p_rank_gt0. + rewrite -{1}(setIidPr sKM) pnElemI -setIdE => /setIdP[EpX sXK]. + have sXE3: X \subset E3. + rewrite (sub_normal_Hall hallE3) ?(subset_trans sXK) ?(pi_pgroup _ t3p) //. + by case/pnElemP: EpX => _ /andP[]. + have [nregX ntX] := (kappa_nonregular kp EpX, nt_pnElem EpX isT). + have [regE3|ntE1 {defE}defE prE nE1_E] := tau13_nonregular maxM complEi. + by case/eqP: nregX; rewrite (cent_semiregular regE3). + have defK: E :=: K. + apply: (sub_pHall hallK _ sKE sEM); apply/pgroupP=> q q_pr q_dv_E. + have{q_dv_E} piEq: q \in \pi(E) by rewrite mem_primes q_pr cardG_gt0. + rewrite unlock; apply/andP; split=> /=. + apply: pnatPpi piEq; rewrite -pgroupE -(sdprodW defE). + rewrite pgroupM (sub_pgroup _ t3E3) => [|r t3r]; last by apply/orP; right. + by rewrite (sub_pgroup _ t1E1) // => r t1r; apply/orP; left. + have:= piEq; rewrite -p_rank_gt0 => /p_rank_geP[Y]. + rewrite -{1}(setIidPr sEM) pnElemI -setIdE => /setIdP[EqY sYE]. + rewrite (cent_semiprime prE) ?(subset_trans sXK) // in nregX. + apply/exists_inP; exists Y => //; apply: subG1_contra nregX. + by rewrite setIS ?centS. + have defM := sdprod_sigma maxM hallE. + rewrite /b1_hyp -defK; split=> //; exists 1%G; last first. + by split; [exact: abelian1 | rewrite -defK | exact: semiregular1l]. + rewrite sdprod1g; do 2?split=> //; rewrite ?mul1g ?groupP -?defK //. + rewrite pHallE sub1G cards1 eq_sym partG_eq1 pgroupNK /=. + have{defM} [_ defM _ _] := sdprodP defM; rewrite -{2}defM defK pgroupM. + rewrite (sub_pgroup _ sMs) => [|r sr]; last by apply/orP; left. + by rewrite (sub_pgroup _ kK) // => r kr; apply/orP; right. +set part_b := _ /\ _; set part_c := _ /\ _; set part_d := _ /\ _. +have [U [complUK defM] [cUU prMsK regUK]] := have_a. +have [hallU _ _] := complUK; have [sUM sk'U _] := and3P hallU. +have have_b: part_b. + have coMsU: coprime #|Ms| #|U|. + by rewrite (pnat_coprime sMs (sub_pgroup _ sk'U)) // => p; case/norP. + have{defM} [[_ F _ defF]] := sdprodP defM; rewrite defF. + have [_ <- nUK _] := sdprodP defF; rewrite mulgA mulG_subG => defM. + case/andP=> nMsU nMsK _. + have coMsU_K: coprime #|Ms <*> U| #|K|. + rewrite norm_joinEr // (p'nat_coprime _ kK) // -pgroupE. + rewrite pgroupM // (sub_pgroup _ sMs) => [|r]; last first. + by apply: contraL; apply: kappa_sigma'. + by apply: sub_pgroup _ sk'U => r /norP[]. + have defNK X: X <| K -> X :!=: 1 -> 'N_M(X) = Ks * K. + case/andP=> sXK nXK ntX; rewrite -defM -(norm_joinEr nMsU). + rewrite setIC -group_modr // setIC. + rewrite coprime_norm_cent ?(subset_trans sXK) ?normsY //; last first. + by rewrite (coprimegS sXK). + rewrite /= norm_joinEr -?subcent_TImulg ?(coprime_TIg coMsU) //; last first. + by rewrite subsetI !(subset_trans sXK). + by rewrite (cent_semiregular regUK) // mulg1 (cent_semiprime prMsK). + rewrite /part_b dprodE ?subsetIr //; last first. + rewrite setICA setIA (coprime_TIg (coprimeSg _ coMsU_K)) ?setI1g //. + by rewrite joing_subl. + rewrite -centC ?subsetIr // defNK //; split=> // X Eq1X. + have [q EqX] := nElemP Eq1X; have ntX := nt_pnElem EqX isT. + have:= EqX; rewrite -{1}(setIidPr sKE) pnElemI -setIdE. + case/setIdP=> EqEX sXK; split; first by rewrite defNK ?nK1K. + have [_ abelX dimX] := pnElemP EqX; have [qX _] := andP abelX. + have kq: q \in \kappa(M). + by rewrite (pnatPpi kK (piSg sXK _)) // -p_rank_gt0 p_rank_abelem ?dimX. + have nregX := kappa_nonregular kq (subsetP (pnElemS _ _ sEM) _ EqEX). + have sq := tau13_nonregular_sigma maxM hallE EqEX (kappa_tau13 kq) nregX. + move=> H maxNH; have [maxH sNXH] := setIdP maxNH. + rewrite (sub_Hall_pcore (Msigma_Hall maxH)) ?(subset_trans (normG X)) //. + exact: pi_pgroup qX (sq H maxNH). +have have_c: part_c. + pose p := pdiv #|E1|; have piE1p: p \in \pi(E1) by rewrite pi_pdiv cardG_gt1. + have:= piE1p; rewrite -p_rank_gt0 => /p_rank_geP[Y]. + rewrite -(setIidPr sE1M) pnElemI -setIdE => /setIdP[EpY sYE1]. + have [sYK ntY] := (subset_trans sYE1 sE1K, nt_pnElem EpY isT). + split=> [|X /nElemP[q]]. + rewrite /Ks -(cent_semiprime prMsK sYK) //. + exact: kappa_nonregular (pnatPpi kK (piSg sE1K piE1p)) EpY. + rewrite /= -(cent_semiprime prMsK sYK) // => EqX. + by have [] := cent_cent_Msigma_tau1_uniq maxM hallE hallE1 sYE1 ntY EqX. +have [[defNK defK1] [_ uniqKs]] := (have_b, have_c). +have have_d: part_d. + split=> g. + rewrite inE; apply: contraNeq; rewrite -rank_gt0. + case/rank_geP=> X; rewrite nElemI -setIdE -groupV => /setIdP[EpX sXMg]. + have [_ sCXMs] := mem_uniq_mmax (uniqKs _ EpX). + case/nElemP: EpX => p /pnElemP[/subsetIP[sXMs _] abelX dimX]. + have [[pX _] sXM] := (andP abelX, subset_trans sXMs (pcore_sub _ _)). + have piXp: p \in \pi(X) by rewrite -p_rank_gt0 p_rank_abelem ?dimX. + have sp := pnatPpi sMs (piSg sXMs piXp). + have [def_g _ _] := sigma_group_trans maxM sp pX. + have [|c cXc [m Mm ->]] := def_g g^-1 sXM; first by rewrite sub_conjgV. + by rewrite groupM // (subsetP sCXMs). + case/setDP=> Mg; apply: contraNeq; rewrite -rank_gt0 /=. + case/rank_geP=> X; rewrite nElemI -setIdE => /setIdP[EpX sXKg]. + have [<- _] := defK1 X EpX; rewrite 2!inE Mg /=. + have{EpX} [p EpX] := nElemP EpX; have [_ abelX dimX] := pnElemP EpX. + have defKp1: {in 'E_p^1(K), forall Y, 'Ohm_1('O_p(K)) = Y}. + move=> Y EpY; have E1K_Y: Y \in 'E^1(K) by apply/nElemP; exists p. + have piKp: p \in \pi(K) by rewrite -p_rank_gt0; apply/p_rank_geP; exists Y. + have [pKp sKpK] := (pcore_pgroup p K, pcore_sub p K). + have cycKp: cyclic 'O_p(K). + rewrite (odd_pgroup_rank1_cyclic pKp) ?mFT_odd //. + by rewrite -(rank_kappa (pnatPpi kK piKp)) p_rankS ?(subset_trans sKpK). + have [sYK abelY oY] := pnElemPcard EpY; have [pY _] := andP abelY. + have sYKp: Y \subset 'O_p(K) by rewrite pcore_max ?nK1K. + apply/eqP; rewrite eq_sym eqEcard -{1}(Ohm1_id abelY) OhmS //= oY. + rewrite (Ohm1_cyclic_pgroup_prime cycKp pKp) ?(subG1_contra sYKp) //=. + exact: nt_pnElem EpY _. + rewrite sub_conjg -[X :^ _]defKp1 ?(defKp1 X) //. + by rewrite !inE sub_conjgV sXKg abelemJ abelX cardJg dimX. +split=> {part_a part_b part_c have_a have_b have_c}//; first split=> //. +- move=> q; rewrite /Ks -(cent_semiprime prMsK sE1K ntE1) => picMsE1q. + have sq := pnatPpi (pcore_pgroup _ M) (piSg (subsetIl _ _) picMsE1q). + move: picMsE1q; rewrite -p_rank_gt0; case/p_rank_geP=> y EqY S sylS. + have [sSM qS _] := and3P sylS. + have sSMs: S \subset M`_\sigma. + by rewrite (sub_Hall_pcore (Msigma_Hall maxM)) ?(pi_pgroup qS). + have sylS_Ms: q.-Sylow(M`_\sigma) S := pHall_subl sSMs (pcore_sub _ M) sylS. + have [_]:= cent_cent_Msigma_tau1_uniq maxM hallE hallE1 (subxx _) ntE1 EqY. + move/(_ S sylS_Ms) => uniqS; split=> //; rewrite subsetI sSMs /=. + pose p := pdiv #|E1|; have piE1p: p \in \pi(E1) by rewrite pi_pdiv cardG_gt1. + have [s'p _] := andP (pnatPpi t1E1 piE1p). + have [P sylP] := Sylow_exists p E1; have [sPE1 pP _] := and3P sylP. + apply: contra (s'p) => cE1S; apply/exists_inP; exists P. + exact: subHall_Sylow s'p (subHall_Sylow hallE1 (pnatPpi t1E1 piE1p) sylP). + apply: (sub_uniq_mmax uniqS); first by rewrite cents_norm // (centsS sPE1). + apply: mFT_norm_proper (mFT_pgroup_proper pP). + by rewrite -rank_gt0 (rank_Sylow sylP) p_rank_gt0. +- move=> Y sY ntYKs; have ntY: Y :!=:1 := subG1_contra (subsetIl _ _) ntYKs. + have [[x sYxMs] _] := sigma_Jsub maxM sY ntY; rewrite sub_conjg in sYxMs. + suffices Mx': x^-1 \in M by rewrite (normsP _ _ Mx') ?gFnorm in sYxMs. + rewrite -(setCK M) inE; apply: contra ntYKs => M'x'. + rewrite setIC -(setIidPr sYxMs) -/Ms -[Ms](setIidPr (pcore_sub _ _)). + by rewrite conjIg !setIA; have [-> // _] := have_d; rewrite !setI1g. +rewrite inE PmaxM andbT -(trivg_kappa_compl maxM complUK) => ntU. +have [regMsU nilMs]: 'C_Ms(U) = 1 /\ nilpotent Ms. + pose p := pdiv #|U|; have piUp: p \in \pi(U) by rewrite pi_pdiv cardG_gt1. + have sk'p := pnatPpi sk'U piUp. + have [S sylS] := Sylow_exists p U; have [sSU _] := andP sylS. + have sylS_M := subHall_Sylow hallU sk'p sylS. + rewrite -(setIidPr (centS (subset_trans (Ohm_sub 1 S) sSU))) setIA. + have [|_ _ -> ->] := sigma'_kappa'_facts maxM sylS_M; last by rewrite setI1g. + by rewrite -negb_or (piSg sUM). +have [[_ F _ defF] _ _ _] := sdprodP defM; rewrite defF in defM. +have hallMs: \sigma(M).-Hall(M) Ms by apply: Msigma_Hall. +have hallF: \sigma(M)^'.-Hall(M) F by apply/(sdprod_Hall_pcoreP hallMs). +have frF: [Frobenius F = U ><| K] by apply/Frobenius_semiregularP. +have ntMs: Ms != 1 by apply: Msigma_neq1. +have prK: prime #|K|. + have [solF [_ _ nMsF _]] := (sigma_compl_sol hallF, sdprodP defM). + have solMs: solvable Ms := solvableS (pcore_sub _ _) (mmax_sol maxM). + have coMsF: coprime #|Ms| #|F|. + by rewrite (coprime_sdprod_Hall_r defM) (pHall_Hall hallF). + by have [] := Frobenius_primact frF solF nMsF solMs ntMs coMsF prMsK. +have eq_sb: \sigma(M) =i \beta(M). + suffices bMs: \beta(M).-group Ms. + move=> p; apply/idP/idP=> [sp|]; last exact: beta_sub_sigma. + rewrite (pnatPpi bMs) //= (card_Hall (Msigma_Hall maxM)) pi_of_part //. + by rewrite inE /= sigma_sub_pi. + have [H hallH cHF'] := der_compl_cent_beta' maxM hallF. + rewrite -pgroupNK -partG_eq1 -(card_Hall hallH) -trivg_card1 -subG1. + rewrite -regMsU subsetI (pHall_sub hallH) centsC (subset_trans _ cHF') //. + have [solU [_ mulUK nUK _]] := (abelian_sol cUU, sdprodP defF). + have coUK: coprime #|U| #|K|. + rewrite (p'nat_coprime (sub_pgroup _ (pHall_pgroup hallU)) kK) // => p. + by case/norP. + rewrite -(coprime_cent_prod nUK) // (cent_semiregular regUK) // mulg1. + by rewrite -mulUK commgSS ?mulG_subl ?mulG_subr. +split=> //; apply/normedTI_P; rewrite setD_eq0 subG1 setTI normD1 gFnorm. +split=> // g _; rewrite -setI_eq0 conjD1g -setDIl setD_eq0 subG1 /= -/Ms. +have [_ _ b'MsMg] := sigma_compl_embedding maxM hallE. +apply: contraR => notMg; have{b'MsMg notMg} [_ b'MsMg _] := b'MsMg g notMg. +rewrite -{2}(setIidPr (pHall_sub hallMs)) conjIg setIA coprime_TIg // cardJg. +by apply: p'nat_coprime b'MsMg _; rewrite -(eq_pnat _ eq_sb). +Qed. + +(* This is essentially the skolemized form of 14.2(a). *) +Lemma kappa_compl_context M U K : + M \in 'M -> kappa_complement M U K -> + [/\ \sigma(M)^'.-Hall(M) (U <*> K), + M`_\sigma ><| (U ><| K) = M, + semiprime M`_\sigma K, + semiregular U K + & K :!=: 1 -> abelian U]. +Proof. +move=> maxM [hallU hallK gsetUK]; set E := U <*> K. +have mulUK: U * K = E by rewrite -(gen_set_id gsetUK) genM_join. +have [[sKM kK _] [sUM sk'U _]] := (and3P hallK, and3P hallU). +have tiUK: U :&: K = 1. + by apply: coprime_TIg (p'nat_coprime (sub_pgroup _ sk'U) kK) => p; case/norP. +have hallE: \sigma(M)^'.-Hall(M) E. + rewrite pHallE /= -/E -mulUK mul_subG //= TI_cardMg //. + rewrite -(partnC \kappa(M) (part_gt0 _ _)) (partn_part _ (@kappa_sigma' M)). + apply/eqP; rewrite -partnI -(card_Hall hallK) mulnC; congr (_ * _)%N. + by rewrite (card_Hall hallU); apply: eq_partn => p; apply: negb_or. +have [K1 | ntK] := altP (K :=P: 1). + rewrite K1 sdprodg1 -{1}(mulg1 U) -{1}K1 mulUK sdprod_sigma //. + by split=> //; first apply: semiregular_prime; apply: semiregular1r. +have PmaxM: M \in 'M_'P by rewrite inE maxM -(trivg_kappa maxM hallK) andbT. +have [[V [complV defM] [cVV prK regK]] _ _ _ _] := Ptype_structure PmaxM hallK. +have [[_ F _ defF] _ _ _] := sdprodP defM; rewrite defF in defM. +have hallF: \sigma(M)^'.-Hall(M) F. + exact/(sdprod_Hall_pcoreP (Msigma_Hall maxM)). +have [a Ma /= defFa] := Hall_trans (mmax_sol maxM) hallE hallF. +have [hallV _ _] := complV; set sk' := \sigma_kappa(M)^' in hallU hallV sk'U. +have [nsVF sKF _ _ _] := sdprod_context defF. +have [[[sVF _] [sFM _]] [sEM _]] := (andP nsVF, andP hallF, andP hallE). +have hallV_F: sk'.-Hall(F) V := pHall_subl sVF sFM hallV. +have hallU_E: sk'.-Hall(E) U := pHall_subl (joing_subl _ _) sEM hallU. +have defV: 'O_sk'(F) = V := normal_Hall_pcore hallV_F nsVF. +have hallEsk': sk'.-Hall(E) 'O_sk'(E). + by rewrite [E]defFa pcoreJ pHallJ2 /= defV. +have defU: 'O_sk'(E) = U by rewrite (eq_Hall_pcore hallEsk' hallU_E). +have nUE: E \subset 'N(U) by rewrite -defU gFnorm. +have hallK_E: \kappa(M).-Hall(E) K := pHall_subl (joing_subr _ _) sEM hallK. +have hallK_F: \kappa(M).-Hall(F) K := pHall_subl sKF sFM hallK. +have hallKa_E: \kappa(M).-Hall(E) (K :^ a) by rewrite [E]defFa pHallJ2. +have [b Eb /= defKab] := Hall_trans (sigma_compl_sol hallE) hallK_E hallKa_E. +have defVa: V :^ a = U by rewrite -defV -pcoreJ -defFa defU. +split=> // [| x Kx | _]; last by rewrite -defVa abelianJ. + by rewrite [U ><| K]sdprodEY ?sdprod_sigma //; case/joing_subP: nUE. +rewrite -(conjgKV (a * b) x) -(normsP nUE b Eb) -defVa -conjsgM. +rewrite -cent_cycle cycleJ centJ -conjIg cent_cycle regK ?conjs1g //. +by rewrite -mem_conjg conjD1g conjsgM -defKab. +Qed. + +(* This is B & G, Corollary 14.3. *) +Corollary pi_of_cent_sigma M x x' : + M \in 'M -> x \in (M`_\sigma)^# -> + x' \in ('C_M[x])^# -> \sigma(M)^'.-elt x' -> + (*1*) \kappa(M).-elt x' /\ 'C[x] \subset M + \/ (*2*) [/\ \tau2(M).-elt x', \ell_\sigma(x') == 1%N & 'M('C[x']) = [set M]]. +Proof. +move: x' => y maxM /setD1P[ntx Ms_x] /setD1P[nty cMxy] s'y. +have [My cxy] := setIP cMxy. +have [t2y | not_t2y] := boolP (\tau2(M).-elt y); [right | left]. + have uniqCy: 'M('C[y]) = [set M]; last split=> //. + apply: cent1_nreg_sigma_uniq; rewrite // ?inE ?nty //. + by apply/trivgPn; exists x; rewrite // inE Ms_x cent1C. + pose p := pdiv #[y]; have piYp: p \in \pi(#[y]) by rewrite pi_pdiv order_gt1. + have t2p := pnatPpi t2y piYp; have [E hallE] := ex_sigma_compl maxM. + have [A Ep2A _] := ex_tau2Elem hallE t2p. + have pA: p.-group A by case/pnElemP: Ep2A => _ /andP[]. + have ntA: A :!=: 1 by rewrite (nt_pnElem Ep2A). + have [H maxNH] := mmax_exists (mFT_norm_proper ntA (mFT_pgroup_proper pA)). + have [st2MsH _ _] := primes_norm_tau2Elem maxM hallE t2p Ep2A maxNH. + have [maxH _] := setIdP maxNH. + have sHy: \sigma(H).-elt y by apply: sub_p_elt t2y => q /st2MsH/andP[]. + rewrite /sigma_length (cardsD1 y.`_(\sigma(H))). + rewrite mem_sigma_decomposition //; last by rewrite constt_p_elt. + rewrite eqSS -sigma_decomposition_constt' //. + by apply/ell_sigma0P; rewrite (constt1P _) ?p_eltNK. +have{not_t2y} [p piYp t2'p]: exists2 p, p \in \pi(#[y]) & p \notin \tau2(M). + by apply/allPn; rewrite negb_and cardG_gt0 in not_t2y. +have sYM: <[y]> \subset M by rewrite cycle_subG. +have piMp: p \in \pi(M) := piSg sYM piYp. +have t13p: p \in [predU \tau1(M) & \tau3(M)]. + move: piMp; rewrite partition_pi_mmax // (negPf t2'p) /= orbA. + by case/orP=> // sMy; case/negP: (pnatPpi s'y piYp). +have [X]: exists X, X \in 'E_p^1(<[y]>) by apply/p_rank_geP; rewrite p_rank_gt0. +rewrite -(setIidPr sYM) pnElemI -setIdE => /setIdP[EpX sXy]. +have kp: p \in \kappa(M). + rewrite unlock; apply/andP; split=> //; apply/exists_inP; exists X => //. + apply/trivgPn; exists x; rewrite // inE Ms_x (subsetP (centS sXy)) //. + by rewrite cent_cycle cent1C. +have [sXM abelX dimX] := pnElemP EpX; have [pX _] := andP abelX. +have [K hallK sXK] := Hall_superset (mmax_sol maxM) sXM (pi_pgroup pX kp). +have PmaxM: M \in 'M_'P. + by rewrite 2!inE maxM andbT; apply: contraL kp => k'M; exact: (pnatPpi k'M). +have [_ [defNK defNX] [_ uniqCKs] _ _] := Ptype_structure PmaxM hallK. +have{defNX} sCMy_nMK: 'C_M[y] \subset 'N_M(K). + have [|<- _] := defNX X. + by apply/nElemP; exists p; rewrite !inE sXK abelX dimX. + by rewrite setIS // cents_norm // -cent_cycle centS. +have [[sMK kK _] [_ mulKKs cKKs _]] := (and3P hallK, dprodP defNK). +have s'K: \sigma(M)^'.-group K := sub_pgroup (@kappa_sigma' M) kK. +have sMs: \sigma(M).-group M`_\sigma := pcore_pgroup _ M. +have sKs: \sigma(M).-group 'C_(M`_\sigma)(K) := pgroupS (subsetIl _ _) sMs. +have{s'K sKs} [hallK_N hallKs] := coprime_mulGp_Hall mulKKs s'K sKs. +split. + rewrite (mem_p_elt kK) // (mem_normal_Hall hallK_N) ?normal_subnorm //. + by rewrite (subsetP sCMy_nMK) // inE My cent1id. +have Mx: x \in M := subsetP (pcore_sub _ _) x Ms_x. +have sxKs: <[x]> \subset 'C_(M`_\sigma)(K). + rewrite cycle_subG (mem_normal_Hall hallKs) ?(mem_p_elt sMs) //=. + by rewrite -mulKKs /normal mulG_subr mulG_subG normG cents_norm // centsC. + by rewrite (subsetP sCMy_nMK) // inE Mx cent1C. +have /rank_geP[Z]: 0 < 'r(<[x]>) by rewrite rank_gt0 cycle_eq1. +rewrite /= -(setIidPr sxKs) nElemI -setIdE => /setIdP[E1KsZ sZx]. +have [_ sCZM] := mem_uniq_mmax (uniqCKs Z E1KsZ). +by rewrite (subset_trans _ sCZM) // -cent_cycle centS. +Qed. + +(* This is B & G, Theorem 14.4. *) +(* We are omitting the first half of part (a), since we have taken it as our *) +(* definition of 'R[x]. *) +Theorem FT_signalizer_context x (N := 'N[x]) (R := 'R[x]) : + \ell_\sigma(x) == 1%N -> + [/\ [/\ [transitive R, on 'M_\sigma[x] | 'JG], + #|R| = #|'M_\sigma[x]|, + R <| 'C[x] + & Hall 'C[x] R] + & #|'M_\sigma[x]| > 1 -> + [/\ 'M('C[x]) = [set N], + (*a*) R :!=: 1, + (*c1*) \tau2(N).-elt x, + (*f*) N \in 'M_'F :|: 'M_'P2 + & {in 'M_\sigma[x], forall M, + [/\ (*b*) R ><| 'C_(M :&: N)[x] = 'C[x], + (*c2*) {subset \tau2(N) <= \sigma(M)}, + (*d*) {subset [predI \pi(M) & \sigma(N)] <= \beta(N)} + & (*e*) \sigma(N)^'.-Hall(N) (M :&: N)]}]]. +Proof. +rewrite {}/N {}/R => ell1x; have [ntx ntMSx] := ell_sigma1P x ell1x. +have [M MSxM] := set0Pn _ ntMSx; have [maxM Ms_x] := setIdP MSxM. +rewrite cycle_subG in Ms_x; have sMx := mem_p_elt (pcore_pgroup _ M) Ms_x. +have Mx: x \in M := subsetP (pcore_sub _ _) x Ms_x. +have [MSx_le1 | MSx_gt1] := leqP _ 1. + rewrite /'R[x] /'N[x] ltnNge MSx_le1 (trivgP (pcore_sub _ _)) setI1g normal1. + have <-: [set M] = 'M_\sigma[x]. + by apply/eqP; rewrite eqEcard sub1set MSxM cards1. + by rewrite /Hall atrans_acts_card ?imset_set1 ?cards1 ?sub1G ?coprime1n. +have [q pi_x_q]: exists q, q \in \pi(#[x]). + by exists (pdiv #[x]); rewrite pi_pdiv order_gt1. +have{sMx} sMq: q \in \sigma(M) := pnatPpi sMx pi_x_q. +have [X EqX]: exists X, X \in 'E_q^1(<[x]>). + by apply/p_rank_geP; rewrite p_rank_gt0. +have [sXx abelX dimX] := pnElemP EqX; have [qX cXX _] := and3P abelX. +have ntX: X :!=: 1 := nt_pnElem EqX isT. +have sXM: X \subset M by rewrite (subset_trans sXx) ?cycle_subG. +have [N maxNX_N] := mmax_exists (mFT_norm_proper ntX (mFT_pgroup_proper qX)). +have [maxN sNX_N] := setIdP maxNX_N; pose R := 'C_(N`_\sigma)[x]%G. +have sCX_N: 'C(X) \subset N := subset_trans (cent_sub X) sNX_N. +have sCx_N: 'C[x] \subset N by rewrite -cent_cycle (subset_trans (centS sXx)). +have sMSx_MSX: 'M_\sigma[x] \subset 'M_\sigma(X). + apply/subsetP=> M1 /setIdP[maxM1 sxM1]. + by rewrite inE maxM1 (subset_trans sXx). +have nsRCx: R <| 'C[x] by rewrite /= setIC (normalGI sCx_N) ?pcore_normal. +have hallR: \sigma(N).-Hall('C[x]) R. + exact: setI_normal_Hall (pcore_normal _ _) (Msigma_Hall maxN) sCx_N. +have transCX: [transitive 'C(X), on 'M_\sigma(X) | 'JG]. + have [_ trCX _ ] := sigma_group_trans maxM sMq qX. + case/imsetP: trCX => _ /setIdP[/imsetP[y _ ->] sXMy] trCX. + have maxMy: (M :^ y)%G \in 'M by rewrite mmaxJ. + have sXMys: X \subset (M :^ y)`_\sigma. + by rewrite (sub_Hall_pcore (Msigma_Hall _)) // (pi_pgroup qX) ?sigmaJ. + apply/imsetP; exists (M :^ y)%G; first exact/setIdP. + apply/setP=> Mz; apply/setIdP/imsetP=> [[maxMz sXMzs] | [z cXz -> /=]]. + suffices: gval Mz \in orbit 'Js 'C(X) (M :^ y). + by case/imsetP=> z CXz /group_inj->; exists z. + rewrite -trCX inE andbC (subset_trans sXMzs) ?pcore_sub //=. + apply/idPn => /(sigma_partition maxM maxMz)/=/(_ q)/idP[]. + rewrite inE /= sMq (pnatPpi (pgroupS sXMzs (pcore_pgroup _ _))) //. + by rewrite -p_rank_gt0 p_rank_abelem ?dimX. + by rewrite mmaxJ -(normP (subsetP (cent_sub X) z cXz)) MsigmaJ conjSg. +have MSX_M: M \in 'M_\sigma(X) := subsetP sMSx_MSX M MSxM. +have not_sCX_M: ~~ ('C(X) \subset M). + apply: contraL MSx_gt1 => sCX_M. + rewrite -leqNgt (leq_trans (subset_leq_card sMSx_MSX)) //. + rewrite -(atransP transCX _ MSX_M) card_orbit astab1JG. + by rewrite (setIidPl (normsG sCX_M)) indexgg. +have neqNM: N :!=: M by apply: contraNneq not_sCX_M => <-. +have maxNX'_N: N \in 'M('N(X)) :\ M by rewrite 2!inE neqNM. +have [notMGN _] := sigma_subgroup_embedding maxM sMq sXM qX ntX maxNX'_N. +have sN'q: q \notin \sigma(N). + by apply: contraFN (sigma_partition maxM maxN notMGN q) => sNq; exact/andP. +rewrite (negPf sN'q) => [[t2Nq s_piM_bN hallMN]]. +have defN: N`_\sigma ><| (M :&: N) = N. + exact/(sdprod_Hall_pcoreP (Msigma_Hall maxN)). +have Nx: x \in N by rewrite (subsetP sCx_N) ?cent1id. +have MNx: x \in M :&: N by rewrite inE Mx. +have sN'x: \sigma(N)^'.-elt x by rewrite (mem_p_elt (pHall_pgroup hallMN)). +have /andP[sNsN nNsN]: N`_\sigma <| N := pcore_normal _ _. +have nNs_x: x \in 'N(N`_\sigma) := subsetP nNsN x Nx. +have defCx: R ><| 'C_(M :&: N)[x] = 'C[x]. + rewrite -{2}(setIidPr sCx_N) /= -cent_cycle (subcent_sdprod defN) //. + by rewrite subsetI andbC normsG ?cycle_subG. +have transR: [transitive R, on 'M_\sigma[x] | 'JG]. + apply/imsetP; exists M => //; apply/setP=> L. + apply/idP/imsetP=> [MSxL | [u Ru ->{L}]]; last first. + have [_ cxu] := setIP Ru; rewrite /= -cent_cycle in cxu. + by rewrite -(normsP (cent_sub _) u cxu) sigma_mmaxJ. + have [u cXu defL] := atransP2 transCX MSX_M (subsetP sMSx_MSX _ MSxL). + have [_ mulMN nNsMN tiNsMN] := sdprodP defN. + have:= subsetP sCX_N u cXu; rewrite -mulMN -normC //. + case/imset2P=> v w /setIP[Mv _] Ns_w def_u; exists w => /=; last first. + by apply: group_inj; rewrite defL /= def_u conjsgM (conjGid Mv). + rewrite inE Ns_w -groupV (sameP cent1P commgP) -in_set1 -set1gE -tiNsMN. + rewrite setICA setIC (setIidPl sNsN) inE groupMl ?groupV //. + rewrite memJ_norm // groupV Ns_w /= -(norm_mmax maxM) inE sub_conjg. + rewrite invg_comm -(conjSg _ _ w) -{2}(conjGid Mx) -!conjsgM -conjg_Rmul. + rewrite -conjgC conjsgM -(conjGid Mv) -(conjsgM M) -def_u. + rewrite -[M :^ u](congr_group defL) conjGid // -cycle_subG. + by have [_ Ls_x] := setIdP MSxL; rewrite (subset_trans Ls_x) ?pcore_sub. +have oR: #|R| = #|'M_\sigma[x]|. + rewrite -(atransP transR _ MSxM) card_orbit astab1JG (norm_mmax maxM). + rewrite -setIAC /= -{3}(setIidPl sNsN) -(setIA _ N) -(setIC M). + by have [_ _ _ ->] := sdprodP defN; rewrite setI1g indexg1. +have ntR: R :!=: 1 by rewrite -cardG_gt1 oR. +have [y Ns_y CNy_x]: exists2 y, y \in (N`_\sigma)^# & x \in ('C_N[y])^#. + have [y Ry nty] := trivgPn _ ntR; have [Ns_y cxy] := setIP Ry. + by exists y; rewrite 2!inE ?nty // inE Nx cent1C ntx. +have kN'q: q \notin \kappa(N). + rewrite (contra (@kappa_tau13 N q)) // negb_or (contraL (@tau2'1 _ _ _)) //. + exact: tau3'2. +have [[kNx _] | [t2Nx _ uniqN]] := pi_of_cent_sigma maxN Ns_y CNy_x sN'x. + by case/idPn: (pnatPpi kNx pi_x_q). +have defNx: 'N[x] = N. + apply/set1P; rewrite -uniqN /'N[x] MSx_gt1. + by case: pickP => // /(_ N); rewrite uniqN /= set11. +rewrite /'R[x] {}defNx -(erefl (gval R)) (pHall_Hall hallR). +split=> // _; split=> // [|L MSxL]. + rewrite !(maxN, inE) /=; case: (pgroup _ _) => //=; rewrite andbT. + apply: contra kN'q => skN_N; have:= pnatPpi (mem_p_elt skN_N Nx) pi_x_q. + by case/orP=> //=; rewrite (negPf sN'q). +have [u Ru ->{L MSxL}] := atransP2 transR MSxM MSxL; rewrite /= cardJg. +have [Ns_u cxu] := setIP Ru; have Nu := subsetP sNsN u Ns_u. +rewrite -{1}(conjGid Ru) -(conjGid cxu) -{1 6 7}(conjGid Nu) -!conjIg pHallJ2. +split=> // [|p t2Np]. + rewrite /= -(setTI 'C[x]) -!(setICA setT) -!morphim_conj. + exact: injm_sdprod (subsetT _) (injm_conj _ _) defCx. +have [A Ep2A _] := ex_tau2Elem hallMN t2Np. +have [[nsAMN _] _ _ _] := tau2_compl_context maxN hallMN t2Np Ep2A. +have{Ep2A} Ep2A: A \in 'E_p^2(M) by move: Ep2A; rewrite pnElemI; case/setIP. +have rpM: 'r_p(M) > 1 by apply/p_rank_geP; exists A. +have: p \in \pi(M) by rewrite -p_rank_gt0 ltnW. +rewrite sigmaJ partition_pi_mmax // !orbA; case/orP=> //. +rewrite orbAC -2!andb_orr -(subnKC rpM) andbF /= => t2Mp. +case/negP: ntX; rewrite -subG1 (subset_trans sXx) //. +have [_ _ <- _ _] := tau2_context maxM t2Mp Ep2A. +have [[sAM abelA _] [_ nAMN]] := (pnElemP Ep2A, andP nsAMN). +rewrite -coprime_norm_cent ?(subset_trans sAM) ?gFnorm //. + by rewrite cycle_subG inE Ms_x (subsetP nAMN). +have [[sM'p _] [pA _]] := (andP t2Mp, andP abelA). +exact: pnat_coprime (pcore_pgroup _ _) (pi_pgroup pA sM'p). +Qed. + +(* A useful supplement to Theorem 14.4. *) +Lemma cent1_sub_uniq_sigma_mmax x M : + #|'M_\sigma[x]| == 1%N -> M \in 'M_\sigma[x] -> 'C[x] \subset M. +Proof. +move: M => M0 /cards1P[M defMSx] MS_M0; move: MS_M0 (MS_M0). +rewrite {1}defMSx => /set1P->{M0} MSxM; have [maxM _] := setIdP MSxM. +rewrite -(norm_mmax maxM); apply/normsP=> y cxy; apply: congr_group. +by apply/set1P; rewrite -defMSx -(mulKg y x) (cent1P cxy) cycleJ sigma_mmaxJ. +Qed. + +Remark cent_FT_signalizer x : x \in 'C('R[x]). +Proof. by rewrite -sub_cent1 subsetIr. Qed. + +(* Because the definition of 'N[x] uses choice, we can only prove it commutes *) +(* with conjugation now that we have established that the choice is unique. *) +Lemma FT_signalizer_baseJ x z : 'N[x ^ z] :=: 'N[x] :^ z. +Proof. +case MSx_gt1: (#|'M_\sigma[x]| > 1); last first. + by rewrite /'N[x] /'N[_] cycleJ card_sigma_mmaxJ MSx_gt1 conjs1g. +have [x1 | ntx] := eqVneq x 1. + rewrite x1 conj1g /'N[1] /= norm1. + case: pickP => [M maxTM | _]; last by rewrite if_same conjs1g. + by have [maxM] := setIdP maxTM; case/idPn; rewrite proper_subn ?mmax_proper. +apply: congr_group; apply/eqP; rewrite eq_sym -in_set1. +have ell1xz: \ell_\sigma(x ^ z) == 1%N. + by rewrite ell_sigmaJ; apply/ell_sigma1P; rewrite -cards_eq0 -lt0n ltnW. +have [_ [|<- _ _ _ _]] := FT_signalizer_context ell1xz. + by rewrite cycleJ card_sigma_mmaxJ. +rewrite -conjg_set1 normJ mmax_ofJ; rewrite ell_sigmaJ in ell1xz. +by have [_ [//|-> _ _ _ _]] := FT_signalizer_context ell1xz; apply: set11. +Qed. + +Lemma FT_signalizerJ x z : 'R[x ^ z] :=: 'R[x] :^ z. +Proof. +by rewrite /'R[x] /'R[_] FT_signalizer_baseJ MsigmaJ -conjg_set1 normJ conjIg. +Qed. + +Lemma sigma_coverJ x z : x ^ z *: 'R[x ^ z] = (x *: 'R[x]) :^ z. +Proof. by rewrite FT_signalizerJ conjsMg conjg_set1. Qed. + +Lemma sigma_supportJ M z : (M :^ z)^~~ = M^~~ :^ z. +Proof. +rewrite -bigcupJ /_^~~ MsigmaJ -conjD1g (big_imset _ (in2W (act_inj 'J z))) /=. +by apply: eq_bigr => x _; rewrite sigma_coverJ. +Qed. + +(* This is the remark imediately above B & G, Lemma 14.5; note the adjustment *) +(* allowing for the case x' = 1. *) +Remark sigma_cover_decomposition x x' : + \ell_\sigma(x) == 1%N -> x' \in 'R[x] -> + sigma_decomposition (x * x') = x |: [set x']^#. +Proof. +move=> ell1x Rx'; have [-> | ntx'] := eqVneq x' 1. + by rewrite mulg1 setDv setU0 ell1_decomposition. +rewrite setDE (setIidPl _) ?sub1set ?inE // setUC. +have ntR: #|'R[x]| > 1 by rewrite cardG_gt1; apply/trivgPn; exists x'. +have [Ns_x' cxx'] := setIP Rx'; move/cent1P in cxx'. +have [[_ <- _ _] [//| maxN _ t2Nx _ _]] := FT_signalizer_context ell1x. +have{maxN} [maxN _] := mem_uniq_mmax maxN. +have sNx' := mem_p_elt (pcore_pgroup _ _) Ns_x'. +have sN'x: \sigma('N[x])^'.-elt x by apply: sub_p_elt t2Nx => p /andP[]. +have defx': (x * x').`_\sigma('N[x]) = x'. + by rewrite consttM // (constt1P sN'x) mul1g constt_p_elt. +have sd_xx'_x': x' \in sigma_decomposition (x * x'). + by rewrite 2!inE ntx' -{1}defx'; apply: mem_imset. +rewrite -(setD1K sd_xx'_x') -{3}defx' -sigma_decomposition_constt' ?consttM //. +by rewrite constt_p_elt // (constt1P _) ?p_eltNK ?mulg1 // ell1_decomposition. +Qed. + +(* This is the simplified form of remark imediately above B & G, Lemma 14.5. *) +Remark nt_sigma_cover_decomposition x x' : + \ell_\sigma(x) == 1%N -> x' \in 'R[x]^# -> + sigma_decomposition (x * x') = [set x; x']. +Proof. +move=> ell1x /setD1P[ntx' Rx']; rewrite sigma_cover_decomposition //. +by rewrite setDE (setIidPl _) ?sub1set ?inE // setUC. +Qed. + +Remark mem_sigma_cover_decomposition x g : + \ell_\sigma(x) == 1%N -> g \in x *: 'R[x] -> x \in sigma_decomposition g. +Proof. +by move=> ell1x /lcosetP[x' Rx' ->]; rewrite sigma_cover_decomposition ?setU11. +Qed. + +Remark ell_sigma_cover x g : + \ell_\sigma(x) == 1%N -> g \in x *: 'R[x] -> \ell_\sigma(g) <= 2. +Proof. +move=> ell1x /lcosetP[x' Rx' ->]. +rewrite /(\ell_\sigma(_)) sigma_cover_decomposition // cardsU1. +by rewrite (leq_add (leq_b1 _)) // -(cards1 x') subset_leq_card ?subsetDl. +Qed. + +Remark ell_sigma_support M g : M \in 'M -> g \in M^~~ -> \ell_\sigma(g) <= 2. +Proof. +by move=> maxM /bigcupP[x Msx]; apply: ell_sigma_cover; apply: Msigma_ell1 Msx. +Qed. + +(* This is B & G, Lemma 14.5(a). *) +Lemma sigma_cover_disjoint x y : + \ell_\sigma(x) == 1%N -> \ell_\sigma(y) == 1%N -> x != y -> + [disjoint x *: 'R[x] & y *: 'R[y]]. +Proof. +move=> ell1x ell1y neq_xy; apply/pred0P=> g /=. +have [[ntx _] [nty _]] := (ell_sigma1P x ell1x, ell_sigma1P y ell1y). +apply: contraNF (ntx) => /andP[/lcosetP[x' Rxx' ->{g}] /= yRy_xx']. +have def_y: y = x'. + apply: contraTeq (mem_sigma_cover_decomposition ell1y yRy_xx') => neq_yx'. + by rewrite sigma_cover_decomposition // !inE negb_or nty eq_sym neq_xy. +have [[_ <- _ _] [|uniqCx _ _ _ _]] := FT_signalizer_context ell1x. + by rewrite cardG_gt1; apply/trivgPn; exists x'; rewrite // -def_y. +have{uniqCx} [maxNx sCxNx] := mem_uniq_mmax uniqCx. +have Rx_y: y \in 'R[x] by [rewrite def_y]; have [Nxs_y cxy] := setIP Rx_y. +have Ry_x: x \in 'R[y]. + by rewrite -def_y -(cent1P cxy) mem_lcoset mulKg in yRy_xx'. +have MSyNx: 'N[x] \in 'M_\sigma[y] by rewrite inE maxNx cycle_subG. +have [[_ <- _ _] [|uniqCy _ _ _]] := FT_signalizer_context ell1y. + by rewrite cardG_gt1; apply/trivgPn; exists x. +have{uniqCy} [_ sCyNy] := mem_uniq_mmax uniqCy. +case/(_ 'N[x] MSyNx)=> /sdprodP[_ _ _ tiRyNx] _ _ _. +rewrite -in_set1 -set1gE -tiRyNx -setIA (setIidPr sCyNy) inE Ry_x /=. +by rewrite inE cent1C cxy (subsetP sCxNx) ?cent1id. +Qed. + +(* This is B & G, Lemma 14.5(b). *) +Lemma sigma_support_disjoint M1 M2 : + M1 \in 'M -> M2 \in 'M -> gval M2 \notin M1 :^: G -> [disjoint M1^~~ & M2^~~]. +Proof. +move=> maxM1 maxM2 notM1GM2; rewrite -setI_eq0 -subset0 big_distrl. +apply/bigcupsP=> x M1s_x; rewrite big_distrr; apply/bigcupsP=> y M2s_y /=. +have [ell1x ell1y] := (Msigma_ell1 maxM1 M1s_x, Msigma_ell1 maxM2 M2s_y). +rewrite subset0 setI_eq0 sigma_cover_disjoint //. +have{M1s_x M2s_y}[[ntx M1s_x] [_ M2s_y]] := (setD1P M1s_x, setD1P M2s_y). +pose p := pdiv #[x]; have pixp: p \in \pi(#[x]) by rewrite pi_pdiv order_gt1. +apply: contraFN (sigma_partition maxM1 maxM2 notM1GM2 p) => eq_xy. +rewrite inE /= (pnatPpi (mem_p_elt (pcore_pgroup _ _) M1s_x)) //=. +by rewrite (pnatPpi (mem_p_elt (pcore_pgroup _ _) M2s_y)) -?(eqP eq_xy). +Qed. + +(* This is B & G, Lemma 14.5(c). *) +Lemma card_class_support_sigma M : + M \in 'M -> #|class_support M^~~ G| = (#|M`_\sigma|.-1 * #|G : M|)%N. +Proof. +move=> maxM; rewrite [#|M`_\sigma|](cardsD1 1) group1 /=. +set MsG := class_support (M`_\sigma)^# G; pose P := [set x *: 'R[x] | x in MsG]. +have ellMsG x: x \in MsG -> \ell_\sigma(x) == 1%N. + by case/imset2P=> y z My _ ->; rewrite ell_sigmaJ (Msigma_ell1 maxM). +have tiP: trivIset P. + apply/trivIsetP=> _ _ /imsetP[x MsGx ->] /imsetP[y MsGy ->] neq_xRyR. + by rewrite sigma_cover_disjoint ?ellMsG //; apply: contraNneq neq_xRyR => ->. +have->: class_support M^~~ G = cover P. + apply/setP=> az; apply/imset2P/bigcupP=> [[a z] | [xRz]]. + case/bigcupP=> x Ms_x xRa Gz ->; exists (x ^ z *: 'R[x ^ z]). + by apply: mem_imset; exact: mem_imset2. + by rewrite sigma_coverJ memJ_conjg. + case/imsetP=> _ /imset2P[x z Ms_x Gz ->] ->; rewrite sigma_coverJ. + by case/imsetP=> a xRa ->; exists a z => //; apply/bigcupP; exists x. +rewrite -(eqnP tiP) big_imset /= => [|x y MsGx MsGy eq_xyR]; last first. + have: x *: 'R[x] != set0 by rewrite -cards_eq0 -lt0n card_lcoset cardG_gt0. + rewrite -[x *: _]setIid {2}eq_xyR setI_eq0. + by apply: contraNeq => neq_xy; rewrite sigma_cover_disjoint ?ellMsG. +rewrite -{2}(norm_mmax maxM) -astab1JG -indexgI -card_orbit. +set MG := orbit _ G M; rewrite mulnC -sum_nat_const. +transitivity (\sum_(Mz in MG) \sum_(x in (Mz`_\sigma)^#) 1); last first. + apply: eq_bigr => _ /imsetP[z _ ->]; rewrite sum1_card MsigmaJ. + by rewrite -conjD1g cardJg. +rewrite (exchange_big_dep (mem MsG)) /= => [|Mz xz]; last first. + case/imsetP=> z Gz ->; rewrite MsigmaJ -conjD1g => /imsetP[x Ms_x ->{xz}]. + exact: mem_imset2. +apply: eq_bigr => x MsGx; rewrite card_lcoset sum1dep_card. +have ell1x := ellMsG x MsGx; have [ntx _] := ell_sigma1P x ell1x. +have [[transRx -> _ _] _] := FT_signalizer_context ell1x. +apply: eq_card => Mz; rewrite 2!inE cycle_subG in_setD1 ntx /=. +apply: andb_id2r => Mzs_x. +apply/idP/imsetP=> [maxMz | [z _ ->]]; last by rewrite mmaxJ. +have [y t Ms_y _ def_x] := imset2P MsGx; have{Ms_y} [_ Ms_y] := setD1P Ms_y. +have [MSxMz MSxMt]: Mz \in 'M_\sigma[x] /\ (M :^ t)%G \in 'M_\sigma[x]. + by rewrite {2}def_x cycleJ sigma_mmaxJ inE maxMz inE maxM !cycle_subG. +have [z _ ->] := atransP2 transRx MSxMt MSxMz. +by exists (t * z); rewrite ?inE ?actM. +Qed. + +(* This is B & G, Lemma 14.6. *) +Lemma sigma_decomposition_dichotomy (g : gT) : + g != 1 -> + [exists (x | \ell_\sigma(x) == 1%N), x^-1 * g \in 'R[x]] + (+) [exists (y | \ell_\sigma(y) == 1%N), + let y' := y^-1 * g in + [exists M in 'M_\sigma[y], (y' \in ('C_M[y])^#) && \kappa(M).-elt y']]. +Proof. +move=> ntg; have [[x ell1x Rx'] | ] := altP exists_inP. + rewrite /= negb_exists_in; apply/forall_inP=> y ell1y. + set y' := y^-1 * g; set x' := x^-1 * g in Rx'. + apply/existsP=> -[M /and3P[MSyM CMy_y' kMy']]. + have [maxM Ms_y] := setIdP MSyM; rewrite cycle_subG in Ms_y. + have [nty'] := setD1P CMy_y'; case/setIP=> My'; move/cent1P=> cyy'. + have [[nty _] sMy]:= (ell_sigma1P y ell1y, mem_p_elt (pcore_pgroup _ _) Ms_y). + have sM'y': \sigma(M)^'.-elt y' := sub_p_elt (@kappa_sigma' M) kMy'. + have t2M'y': \tau2(M)^'.-elt y'. + apply: sub_p_elt kMy' => p; move/kappa_tau13. + by case/orP; [apply: tau2'1 | apply: contraL; apply: tau3'2]. + have xx'_y: y \in pred2 x x'. + suffices: y \in x |: [set x']^# by rewrite !inE nty. + rewrite -sigma_cover_decomposition // mulKVg 2!inE nty /=. + apply/imsetP; exists M => //; rewrite -(mulKVg y g) -/y' consttM //. + by rewrite (constt_p_elt sMy) (constt1P sM'y') mulg1. + have nt_x': x' != 1 by case/pred2P: xx'_y; rewrite /x' => <-. + have maxCY_M: M \in 'M('C[y]). + have Ms1_y: y \in (M`_\sigma)^# by apply/setD1P. + rewrite inE maxM; case/pi_of_cent_sigma: CMy_y' => // [[//] | [t2y']]. + by rewrite -order_eq1 (pnat_1 t2y' t2M'y') in nty'. + have [[_ <- _ _] [|uniqNx _ t2Nx _ _]] := FT_signalizer_context ell1x. + by rewrite cardG_gt1; apply/trivgPn; exists x'. + rewrite -order_gt1 (pnat_1 sMy _) // -/(_.-elt _) in nty. + have{xx'_y} [eq_yx | eq_yx']: y = x \/ y = x' := pred2P xx'_y. + rewrite eq_yx uniqNx in maxCY_M *; rewrite (set1P maxCY_M). + by apply: sub_p_elt t2Nx => p; case/andP. + have eq_xy': x = y' by apply: (mulIg y); rewrite cyy' {1}eq_yx' !mulKVg. + have [[z _ defM] | notMGNx] := altP (@orbitP _ _ _ 'Js G 'N[x] M). + rewrite -order_eq1 (pnat_1 _ t2M'y') // in nty'. + by rewrite -defM (eq_pnat _ (tau2J _ _)) -eq_xy'. + have Ns_y: y \in 'N[x]`_\sigma by rewrite eq_yx'; case/setIP: Rx'. + apply: sub_p_elt (mem_p_elt (pcore_pgroup _ _) Ns_y) => p sNp. + have [maxN _] := mem_uniq_mmax uniqNx. + by apply: contraFN (sigma_partition _ _ notMGNx p) => // sMp; apply/andP. +rewrite negb_exists_in => /forall_inP not_sign_g. +apply: wlog_neg; rewrite negb_exists_in => /forall_inP not_kappa_g. +have s'g M: M \in 'M -> g \in M -> g.`_\sigma(M) = 1. + move=> maxM; set x := g.`_\sigma(M); pose x' := g.`_(\sigma(M))^'. + have def_x': x^-1 * g = x' by rewrite -(consttC \sigma(M) g) mulKg. + apply: contraTeq => ntx. + have ell1x: \ell_\sigma(x) == 1%N. + rewrite /sigma_length (cardsD1 x.`_\sigma(M)). + rewrite -sigma_decomposition_constt' // mem_sigma_decomposition //. + by apply/ell_sigma0P; apply/constt1P; rewrite p_eltNK p_elt_constt. + by rewrite sub_in_constt // => ?. + apply: contra (not_sign_g _ ell1x) => Mg; rewrite def_x'. + have [-> | ntx'] := eqVneq x' 1; first exact: group1. + have cxx': x \in 'C[x'] by apply/cent1P; apply: commuteX2. + have cMx_x': x' \in ('C_M[x])^# by rewrite 3!inE ntx' cent1C cxx' groupX. + have Ms_x: x \in M`_\sigma. + by rewrite (mem_Hall_pcore (Msigma_Hall maxM)) ?p_elt_constt ?groupX. + have Ms1x: x \in (M`_\sigma)^# by apply/setD1P. + have sM'x': (\sigma(M))^'.-elt x' := p_elt_constt _ _. + have [[kMx' _] | [_ ell1x' uniqM]] := pi_of_cent_sigma maxM Ms1x cMx_x' sM'x'. + case/existsP: (not_kappa_g _ ell1x); exists M; rewrite def_x' cMx_x' /=. + by rewrite inE maxM cycle_subG Ms_x. + have MSx'_gt1: #|'M_\sigma[x']| > 1. + have [_ ntMSx'] := ell_sigma1P _ ell1x'. + rewrite ltn_neqAle lt0n cards_eq0 ntMSx' andbT eq_sym. + apply: contra ntx' => MSx'_eq1; rewrite -order_eq1 (pnat_1 _ sM'x') //. + have [N MSx'N] := set0Pn _ ntMSx'; have [maxN Ns_x'] := setIdP MSx'N. + rewrite -(eq_uniq_mmax uniqM maxN) ?cent1_sub_uniq_sigma_mmax //. + exact: pgroupS Ns_x' (pcore_pgroup _ _). + have defNx': 'N[x'] = M. + by apply: set1_inj; case/FT_signalizer_context: ell1x' => _ [|<-]. + case/negP: (not_sign_g _ ell1x'). + by rewrite -(consttC \sigma(M)^' g) mulKg consttNK inE defNx' Ms_x. +have [x sg_x]: exists x, x \in sigma_decomposition g. + by apply/set0Pn; rewrite -cards_eq0 (sameP (ell_sigma0P g) eqP). +have{sg_x} [ntx /imsetP[M maxM def_x]] := setD1P sg_x. +wlog MSxM: M maxM def_x / M \in 'M_\sigma[x]. + have sMx: \sigma(M).-elt x by rewrite def_x p_elt_constt. + have [|[z Ms_xz] _] := sigma_Jsub maxM sMx; first by rewrite cycle_eq1. + move/(_ (M :^ z^-1)%G)->; rewrite ?mmaxJ ?(eq_constt _ (sigmaJ M _)) //. + by rewrite inE mmaxJ maxM MsigmaJ -sub_conjg. +have ell1x: \ell_\sigma(x) == 1%N. + by apply/ell_sigma1P; split=> //; apply/set0Pn; exists M. +have notMg: g \notin M by apply: contra ntx; rewrite def_x; move/s'g->. +have cxg: g \in 'C[x] by rewrite cent1C def_x groupX ?cent1id. +have MSx_gt1: #|'M_\sigma[x]| > 1. + rewrite ltnNge; apply: contra notMg => MSx_le1; apply: subsetP cxg. + have [_ ntMSx] := ell_sigma1P _ ell1x. + by rewrite cent1_sub_uniq_sigma_mmax // eqn_leq MSx_le1 lt0n cards_eq0. +have [_ [//|defNx _ _ _]] := FT_signalizer_context ell1x. +case/(_ M)=> // _ _ _ hallMN; have [maxN sCxN] := mem_uniq_mmax defNx. +have Ng: <[g]> \subset 'N[x] by rewrite cycle_subG (subsetP sCxN). +have sN'g: \sigma('N[x])^'.-elt g by apply/constt1P; rewrite s'g // -cycle_subG. +have [z _ MNgz] := Hall_subJ (mmax_sol maxN) hallMN Ng sN'g. +case/eqP: ntx; rewrite def_x -(eq_constt _ (sigmaJ M z)) s'g ?mmaxJ //. +by move: MNgz; rewrite conjIg cycle_subG => /setIP[]. +Qed. + +Section PTypeEmbedding. +Implicit Types Mi Mj : {group gT}. +Implicit Type Ks : {set gT}. + +(* This is B & G, Theorem 14.7. *) +(* This theorem provides the basis for the maximal subgroup classification, *) +(* the main output of the local analysis. Note that we handle differently the *) +(* two separate instances of non-structural proof (by analogy) that occur in *) +(* the textbook, p. 112, l. 7 and p. 113, l. 22. For the latter we simply use *) +(* global induction on the size of the class support of the TI-set \hat{Z} *) +(* (for this reason we have kept the assertion that this is greater than half *) +(* of the size of G, even though this is not used later in the proof; we did *) +(* drop the more precise lower bound). For the former we prove a preliminary *) +(* lemma that summarizes the four results of the beginning of the proof that *) +(* used after p. 112, l. 7 -- note that this also gets rid of a third non *) +(* structural argument (on p. 112, l. 5). *) +(* Also, note that the direct product decomposition of Z and the K_i, and *) +(* its direct relation with the sigma-decomposition of elements of Z (p. 112, *) +(* l. 13-19) is NOT materially used in the rest of the argument, though it *) +(* does obviously help a human reader forge a mental picture of the situation *) +(* at hand. Only the first remark, l. 13, is used to prove the alternative *) +(* definition of T implicit in the remarks l. 22-23. Accordingly, we have *) +(* suppressed most of these intermediate results: we have only kept the proof *) +(* that Z is the direct product of the K_i^*, though we discard this result *) +(* immediately (its 24-line proof just nudges the whole proof size slightyly *) +(* over the 600-line bar). *) +Theorem Ptype_embedding M K : + M \in 'M_'P -> \kappa(M).-Hall(M) K -> + exists2 Mstar, Mstar \in 'M_'P /\ gval Mstar \notin M :^: G + & let Kstar := 'C_(M`_\sigma)(K) in + let Z := K <*> Kstar in let Zhat := Z :\: (K :|: Kstar) in + [/\ (*a*) {in 'E^1(K), forall X, 'M('C(X)) = [set Mstar]}, + (*b*) \kappa(Mstar).-Hall(Mstar) Kstar /\ \sigma(M).-Hall(Mstar) Kstar, + (*c*) 'C_(Mstar`_\sigma)(Kstar) = K /\ \kappa(M) =i \tau1(M), + (*d*) [/\ cyclic Z, M :&: Mstar = Z, + {in K^#, forall x, 'C_M[x] = Z}, + {in Kstar^#, forall y, 'C_Mstar[y] = Z} + & {in K^# & Kstar^#, forall x y, 'C[x * y] = Z}] +& [/\ (*e*) [/\ normedTI Zhat G Z, {in ~: M, forall g, [disjoint Zhat & M :^ g]} + & (#|G|%:R / 2%:R < #|class_support Zhat G|%:R :> rat)%R ], + (*f*) M \in 'M_'P2 /\ prime #|K| \/ Mstar \in 'M_'P2 /\ prime #|Kstar|, + (*g*) {in 'M_'P, forall H, gval H \in M :^: G :|: Mstar :^: G} + & (*h*) M^`(1) ><| K = M]]. +Proof. +pose isKi Ks M K := [&& M \in 'M_'P, \kappa(M).-Hall(M) K & Ks \subset K]. +move: M K; have Pmax_sym M K X (Ks := 'C_(M`_\sigma)(K)) (Z := K <*> Ks) Mi : + M \in 'M_'P -> \kappa(M).-Hall(M) K -> X \in 'E^1(K) -> Mi \in 'M('N(X)) -> + [/\ Z \subset Mi, gval Mi \notin M :^: G, exists Ki, isKi Ks Mi Ki + & {in 'E^1(Ks), forall Xs, Z \subset 'N_Mi(gval Xs)}]. +- move=> PmaxM hallK E1X maxNMi. + have [[_ maxM] [maxMi sNXMi]] := (setIdP PmaxM, setIdP maxNMi). + have [_ [defNK defNX] [ntKs uniqCKs] _ _] := Ptype_structure PmaxM hallK. + rewrite -/Ks in defNK ntKs uniqCKs; have [_ mulKKs cKKs _] := dprodP defNK. + have{mulKKs} defZ: 'N_M(K) = Z by rewrite -mulKKs -cent_joinEr. + have sZMi: Z \subset Mi. + by rewrite -defZ; have [<- _] := defNX X E1X; rewrite setIC subIset ?sNXMi. + have [sKMi sKsMi] := joing_subP sZMi. + have sXMis: X \subset Mi`_\sigma by have [_ ->] := defNX X E1X. + have sMiX: \sigma(Mi).-group X := pgroupS sXMis (pcore_pgroup _ _). + have [q EqX] := nElemP E1X; have [sXK abelX dimX] := pnElemP EqX. + have piXq: q \in \pi(X) by rewrite -p_rank_gt0 p_rank_abelem ?dimX. + have notMGMi: gval Mi \notin M :^: G. + apply: contraL (pnatPpi sMiX piXq); case/imsetP=> a _ ->; rewrite sigmaJ. + exact: kappa_sigma' (pnatPpi (pHall_pgroup hallK) (piSg sXK piXq)). + have kMiKs: \kappa(Mi).-group Ks. + apply/pgroupP=> p p_pr /Cauchy[] // xs Ks_xs oxs. + pose Xs := <[xs]>%G; have sXsKs: Xs \subset Ks by rewrite cycle_subG. + have EpXs: Xs \in 'E_p^1(Ks) by rewrite p1ElemE // !inE sXsKs -oxs /=. + have sMi'Xs: \sigma(Mi)^'.-group Xs. + rewrite /pgroup /= -orderE oxs pnatE //=. + apply: contraFN (sigma_partition maxM maxMi notMGMi p) => /= sMi_p. + rewrite inE /= sMi_p -pnatE // -oxs andbT. + exact: pgroupS sXsKs (pgroupS (subsetIl _ _) (pcore_pgroup _ _)). + have uniqM: 'M('C(Xs)) = [set M] by apply: uniqCKs; apply/nElemP; exists p. + have [x Xx ntx] := trivgPn _ (nt_pnElem EqX isT). + have Mis_x: x \in (Mi`_\sigma)^# by rewrite !inE ntx (subsetP sXMis). + have CMix_xs: xs \in ('C_Mi[x])^#. + rewrite 2!inE -order_gt1 oxs prime_gt1 // inE -!cycle_subG. + rewrite (subset_trans sXsKs) //= sub_cent1 (subsetP _ x Xx) //. + by rewrite centsC (centSS sXsKs sXK). + have{sMi'Xs} [|[_ _]] := pi_of_cent_sigma maxMi Mis_x CMix_xs sMi'Xs. + by case; rewrite /p_elt oxs pnatE. + case/mem_uniq_mmax=> _ sCxsMi; case/negP: notMGMi. + by rewrite -(eq_uniq_mmax uniqM maxMi) ?orbit_refl //= cent_cycle. + have{kMiKs} [Ki hallKi sKsKi] := Hall_superset (mmax_sol maxMi) sKsMi kMiKs. + have{ntKs} PmaxMi: Mi \in 'M_'P. + rewrite !(maxMi, inE) andbT /= -partG_eq1 -(card_Hall hallKi) -trivg_card1. + exact: subG1_contra sKsKi ntKs. + have [_ [defNKi defNXs] _ _ _] := Ptype_structure PmaxMi hallKi. + split=> //= [|Xs]; first by exists Ki; apply/and3P. + rewrite -{1}[Ks](setIidPr sKsKi) nElemI -setIdE => /setIdP[E1Xs sXsKs]. + have{defNXs} [defNXs _] := defNXs _ E1Xs; rewrite join_subG /= {2}defNXs. + by rewrite !subsetI sKMi sKsMi cents_norm ?normsG ?(centsS sXsKs) // centsC. +move=> M K PmaxM hallK /=; set Ks := 'C_(M`_\sigma)(K); set Z := K <*> Ks. +move: {2}_.+1 (ltnSn #|class_support (Z :\: (K :|: Ks)) G|) => nTG. +elim: nTG => // nTG IHn in M K PmaxM hallK Ks Z *; rewrite ltnS => leTGn. +have [maxM notFmaxM]: M \in 'M /\ M \notin 'M_'F := setDP PmaxM. +have{notFmaxM} ntK: K :!=: 1 by rewrite (trivg_kappa maxM). +have [_ [defNK defNX] [ntKs uniqCKs] _ _] := Ptype_structure PmaxM hallK. +rewrite -/Ks in defNK ntKs uniqCKs; have [_ mulKKs cKKs _] := dprodP defNK. +have{mulKKs} defZ: 'N_M(K) = Z by rewrite -mulKKs -cent_joinEr. +pose MNX := \bigcup_(X in 'E^1(K)) 'M('N(X)); pose MX := M |: MNX. +have notMG_MNX: {in MNX, forall Mi, gval Mi \notin M :^: G}. + by move=> Mi /bigcupP[X E1X /(Pmax_sym M K)[]]. +have MX0: M \in MX := setU11 M MNX. +have notMNX0: M \notin MNX by apply/negP=> /notMG_MNX; rewrite orbit_refl. +pose K_ Mi := odflt K [pick Ki | isKi Ks Mi Ki]. +pose Ks_ Mi := 'C_(Mi`_\sigma)(K_ Mi). +have K0: K_ M = K. + rewrite /K_; case: pickP => // K1 /and3P[_ /and3P[_ kK1 _] sKsK1]. + have sM_Ks: \sigma(M).-group Ks := pgroupS (subsetIl _ _) (pcore_pgroup _ _). + rewrite -(setIid Ks) coprime_TIg ?eqxx ?(pnat_coprime sM_Ks) // in ntKs. + exact: sub_pgroup (@kappa_sigma' M) (pgroupS sKsK1 kK1). +have Ks0: Ks_ M = Ks by rewrite /Ks_ K0. +have K_spec: {in MNX, forall Mi, isKi Ks Mi (K_ Mi)}. + move=> Mi /bigcupP[X _ /(Pmax_sym M K)[] // _ _ [Ki Ki_ok] _]. + by rewrite /K_; case: pickP => // /(_ Ki)/idP. +have PmaxMX: {in MX, forall Mi, Mi \in 'M_'P /\ \kappa(Mi).-Hall(Mi)(K_ Mi)}. + by move=> Mi /setU1P[-> | /K_spec/and3P[]//]; rewrite K0. +have ntKsX: {in MX, forall Mi, Ks_ Mi != 1}. + by move=> Mi /PmaxMX[MX_Mi /Ptype_structure[] // _ _ []]. +pose co_sHallK Mi Zi := + let sMi := \sigma(Mi) in sMi^'.-Hall(Zi) (K_ Mi) /\ sMi.-Hall(Zi) (Ks_ Mi). +have hallK_Zi: {in MX, forall Mi, co_sHallK Mi (K_ Mi \x Ks_ Mi)}. + move=> Mi MXi; have [PmaxMi hallKi] := PmaxMX _ MXi. + have [_ [defNKs _] _ _ _] := Ptype_structure PmaxMi hallKi. + have [_ mulKKs _ _] := dprodP defNKs; rewrite defNKs. + have sMi_Kis: _.-group (Ks_ Mi) := pgroupS (subsetIl _ _) (pcore_pgroup _ _). + have sMi'Ki := sub_pgroup (@kappa_sigma' _) (pHall_pgroup hallKi). + exact: coprime_mulGp_Hall mulKKs sMi'Ki sMi_Kis. +have{K_spec} defZX: {in MX, forall Mi, K_ Mi \x Ks_ Mi = Z}. + move=> Mi MXi; have [-> | MNXi] := setU1P MXi; first by rewrite K0 Ks0 defNK. + have /and3P[PmaxMi hallKi sKsKi] := K_spec _ MNXi. + have [X E1X maxNMi] := bigcupP MNXi. + have{defNX} [defNX /(_ Mi maxNMi) sXMis] := defNX X E1X. + have /rank_geP[Xs E1Xs]: 0 < 'r(Ks) by rewrite rank_gt0. + have [_ [defNi defNXi] _ _ _] := Ptype_structure PmaxMi hallKi. + have [defNXs _] := defNXi _ (subsetP (nElemS 1 sKsKi) _ E1Xs). + have [_ hallKis] := hallK_Zi _ MXi; rewrite defNi in hallKis. + have sZNXs: Z \subset 'N_Mi(Xs) by case/(Pmax_sym M K): maxNMi => // _ _ _ ->. + apply/eqP; rewrite eqEsubset andbC {1}defNi -defNXs sZNXs. + have [_ _ cKiKis tiKiKis] := dprodP defNi; rewrite dprodEY // -defZ -defNX. + have E1KiXs: Xs \in 'E^1(K_ Mi) := subsetP (nElemS 1 sKsKi) Xs E1Xs. + have [|_ _ _ -> //] := Pmax_sym Mi _ Xs M PmaxMi hallKi E1KiXs. + have [p EpXs] := nElemP E1Xs; have [_] := pnElemP EpXs; case/andP=> pXs _ _. + rewrite inE maxM (sub_uniq_mmax (uniqCKs _ E1Xs)) ?cent_sub //=. + exact: mFT_norm_proper (nt_pnElem EpXs isT) (mFT_pgroup_proper pXs). + have [q /pnElemP[sXK abelX dimX]] := nElemP E1X. + apply/nElemP; exists q; apply/pnElemP; split=> //. + have nKisZi: Ks_ Mi <| 'N_Mi(K_ Mi) by case/dprod_normal2: defNi. + rewrite (sub_normal_Hall hallKis) ?(pgroupS sXMis (pcore_pgroup _ _)) //=. + by rewrite -defNXs (subset_trans sXK) // (subset_trans (joing_subl _ Ks)). +have{hallK_Zi} hallK_Z: {in MX, forall Mi, co_sHallK Mi Z}. + by move=> Mi MXi; rewrite -(defZX _ MXi); apply: hallK_Zi. +have nsK_Z: {in MX, forall Mi, K_ Mi <| Z /\ Ks_ Mi <| Z}. + by move=> Mi /defZX; apply: dprod_normal2. +have tiKs: {in MX &, forall Mi Mj, gval Mi != gval Mj -> Ks_ Mi :&: Ks_ Mj = 1}. + move=> Mi Mj MXi MXj; apply: contraNeq; rewrite -rank_gt0. + case/rank_geP=> X E1X; move: E1X (E1X); rewrite /= {1}setIC {1}nElemI. + case/setIP=> E1jX _; rewrite nElemI => /setIP[E1iX _]. + have [[maxKi hallKi] [maxKj hallKj]] := (PmaxMX _ MXi, PmaxMX _ MXj). + have [_ _ [_ uniqMi] _ _] := Ptype_structure maxKi hallKi. + have [_ _ [_ uniqMj] _ _] := Ptype_structure maxKj hallKj. + by rewrite val_eqE -in_set1 -(uniqMj _ E1jX) (uniqMi _ E1iX) set11. +have sKsKX: {in MX &, forall Mi Mj, Mj != Mi -> Ks_ Mj \subset K_ Mi}. + move=> Mi Mj MXi MXj /= neqMji; have [hallKi hallKsi] := hallK_Z _ MXi. + have [[_ nsKsjZ] [nsKiZ _]] := (nsK_Z _ MXj, nsK_Z _ MXi). + rewrite (sub_normal_Hall hallKi) ?(normal_sub nsKsjZ) // -partG_eq1. + by rewrite -(card_Hall (Hall_setI_normal _ hallKsi)) //= setIC tiKs ?cards1. +have exMNX X: X \in 'E^1(K) -> exists2 Mi, Mi \in MNX & X \subset Mi`_\sigma. + move=> E1X; have [p EpX] := nElemP E1X; have [_ abelX _] := pnElemP EpX. + have ltXG: X \proper G := mFT_pgroup_proper (abelem_pgroup abelX). + have [Mi maxNMi] := mmax_exists (mFT_norm_proper (nt_pnElem EpX isT) ltXG). + have MNXi: Mi \in MNX by apply/bigcupP; exists X. + by exists Mi => //; have [_ ->] := defNX X E1X. +have dprodKs_eqZ: \big[dprod/1]_(Mi in MX) Ks_ Mi = Z; last clear dprodKs_eqZ. + have sYKs_KX Mi: + Mi \in MX -> <<\bigcup_(Mj in MX | Mj != Mi) Ks_ Mj>> \subset K_ Mi. + - move=> MXi; rewrite gen_subG. + by apply/bigcupsP=> Mj /= /andP[]; apply: sKsKX. + transitivity <<\bigcup_(Mi in MX) Ks_ Mi>>; apply/eqP. + rewrite -bigprodGE; apply/bigdprodYP => Mi MXi; rewrite bigprodGE. + apply: subset_trans (sYKs_KX _ MXi) _; apply/dprodYP. + have [_ defZi cKiKs tiKiKs] := dprodP (defZX _ MXi). + by rewrite dprodC joingC dprodEY. + rewrite eqEsubset {1}(bigD1 M) //= Ks0 setUC -joingE -joing_idl. + rewrite genS ?setSU ?big_setU1 //=; last by rewrite -K0 sYKs_KX. + rewrite setUC -joingE -joing_idl Ks0 genS ?setSU // -(Sylow_gen K) gen_subG. + apply/bigcupsP=> P; case/SylowP=> p p_pr /=; case/and3P=> sPK pP _. + have [-> | ] := eqsVneq P 1; first exact: sub1G. + rewrite -rank_gt0 (rank_pgroup pP); case/p_rank_geP=> X EpX. + have EpKX: X \in 'E_p^1(K) := subsetP (pnElemS p 1 sPK) X EpX. + have{EpKX} E1X: X \in 'E^1(K) by apply/nElemP; exists p. + have [Mi MNXi sXMis] := exMNX X E1X; have MXi: Mi \in MX by rewrite setU1r. + have [[_ nsKsi] [_ hallKsi]] := (nsK_Z _ MXi, hallK_Z _ MXi). + have sPZ: P \subset Z := subset_trans sPK (joing_subl _ _). + rewrite sub_gen ?(bigcup_max Mi) // (sub_normal_Hall hallKsi) //. + rewrite (pi_pgroup pP) // (pnatPpi (pcore_pgroup _ _) (piSg sXMis _)) //. + by have [_ ? dimX] := pnElemP EpX; rewrite -p_rank_gt0 p_rank_abelem ?dimX. +pose PZ := [set (Ks_ Mi)^# | Mi in MX]; pose T := Z^# :\: cover PZ. +have defT: \bigcup_(Mi in MX) (Ks_ Mi)^# * (K_ Mi)^# = T. + apply/setP=> x; apply/bigcupP/setDP=> [[Mi MXi] | [Zx notZXx]]. + case/mulsgP=> y y' /setD1P[nty Ks_y] /setD1P[nty' Ky'] defx. + have [_ defZi cKsKi tiKsKi] := dprodP (defZX _ MXi). + rewrite 2!inE -[Z]defZi -(centC cKsKi) andbC {1}defx mem_mulg //=. + have notKx: x \notin K_ Mi. + by rewrite -in_set1 -set1gE -tiKsKi inE Ks_y andbT defx groupMr in nty *. + split; first exact: group1_contra notKx. + rewrite cover_imset; apply/bigcupP=> [[Mj MXj /setD1P[_ Ksj_x]]]. + rewrite (subsetP (sKsKX Mi Mj _ _ _)) // in notKx. + apply: contraNneq nty' => eqMji; rewrite -in_set1 -set1gE -tiKsKi inE Ky'. + by rewrite -(groupMl _ Ks_y) -defx -eqMji. + have{Zx} [ntx Zx] := setD1P Zx. + have [Mi MXi notKi_x]: exists2 Mi, Mi \in MX & x \notin K_ Mi. + have [Kx | notKx] := boolP (x \in K); last by exists M; rewrite ?K0. + pose p := pdiv #[x]; have xp: p \in \pi(#[x]) by rewrite pi_pdiv order_gt1. + have /p_rank_geP[X EpX]: 0 < 'r_p(<[x]>) by rewrite p_rank_gt0. + have [sXx abelX dimX] := pnElemP EpX. + have piXp: p \in \pi(X) by rewrite -p_rank_gt0 p_rank_abelem ?dimX. + have sXK: X \subset K by rewrite (subset_trans sXx) ?cycle_subG. + have E1X: X \in 'E^1(K) by apply/nElemP; exists p; apply/pnElemP. + have [Mi MNXi sXMis] := exMNX X E1X; have MXi: Mi \in MX := setU1r M MNXi. + have sXZ: X \subset Z := subset_trans sXK (joing_subl _ _). + have sMip: p \in \sigma(Mi) := pnatPpi (pcore_pgroup _ _) (piSg sXMis piXp). + have [hallKi _] := hallK_Z _ MXi. + exists Mi => //; apply: contraL sMip => Ki_x. + exact: pnatPpi (mem_p_elt (pHall_pgroup hallKi) Ki_x) xp. + have [_ defZi cKisKi _] := dprodP (defZX _ MXi). + rewrite -[Z]defZi -(centC cKisKi) in Zx. + have [y y' Kis_y Ki_y' defx] := mulsgP Zx. + have Kis1y: y \in (Ks_ Mi)^#. + rewrite 2!inE Kis_y andbT; apply: contraNneq notKi_x => y1. + by rewrite defx y1 mul1g. + exists Mi; rewrite // defx mem_mulg // 2!inE Ki_y' andbT. + apply: contraNneq notZXx => y'1; rewrite cover_imset. + by apply/bigcupP; exists Mi; rewrite // defx y'1 mulg1. +have oT: #|T| = #|Z| + #|MNX| - (\sum_(Mi in MX) #|Ks_ Mi|). + have tiTPZ Kis: Kis \in PZ -> [disjoint T & Kis]. + move=> Z_Kis; rewrite -setI_eq0 setIDAC setD_eq0. + by rewrite (bigcup_max Kis) ?subsetIr. + have notPZset0: set0 \notin PZ. + apply/imsetP=> [[Mi MXi]]; apply/eqP; rewrite /= eq_sym setD_eq0 subG1. + exact: ntKsX. + have [| tiPZ injKs] := trivIimset _ notPZset0. + move=> Mi Mj MXi MXj /= neqMji. + by rewrite -setI_eq0 -setDIl setD_eq0 setIC tiKs. + have{tiPZ} [tiPZ notPZ_T] := trivIsetU1 tiTPZ tiPZ notPZset0. + rewrite (eq_bigr (fun Mi : {group gT} => 1 + #|(Ks_ Mi)^#|)%N); last first. + by move=> Mi _; rewrite (cardsD1 1) group1. + rewrite big_split sum1_card cardsU1 notMNX0 (cardsD1 1 Z) group1 /=. + have ->: Z^# = cover (T |: PZ). + rewrite -(setID Z^# (cover PZ)) setUC (setIidPr _) /cover ?big_setU1 //=. + apply/bigcupsP=> _ /imsetP[Mi MXi ->]; apply: setSD. + by case/nsK_Z: MXi => _ /andP[]. + by rewrite addnAC subnDl -(eqnP tiPZ) big_setU1 // big_imset //= addnK. +have tiTscov: {in 'M, forall H, [disjoint T & H^~~]}. + move=> H maxH; apply/pred0P=> t; apply/andP=> [[/= Tt scovHt]]. + have ntt: t != 1 by have [/setD1P[]] := setDP Tt. + have [x Hs_x xR_y] := bigcupP scovHt; have ell1x := Msigma_ell1 maxH Hs_x. + have:= sigma_decomposition_dichotomy ntt. + rewrite (introT existsP) /=; last by exists x; rewrite ell1x -mem_lcoset. + rewrite -defT in Tt; have [Mi MXi Zi_t] := bigcupP Tt. + case/mulsgP: Zi_t => y y' /setD1P[nty Ks_y] /setD1P[nty' Ky'] ->. + case/existsP; exists y; rewrite mulKg. + have [[Mis_y cKy] [PmaxMi hallKi]] := (setIP Ks_y, PmaxMX _ MXi). + have [[maxMi _] [sKiMi kMiKi _]] := (setDP PmaxMi, and3P hallKi). + rewrite (Msigma_ell1 maxMi) ?inE ?nty //=; apply/existsP; exists Mi. + rewrite inE maxMi cycle_subG Mis_y 3!inE nty' (subsetP sKiMi) //=. + by rewrite (subsetP _ _ Ky') ?sub_cent1 // (mem_p_elt kMiKi). +have nzT: T != set0. + have [[y Ksy nty] [y' Ky' nty']] := (trivgPn _ ntKs, trivgPn _ ntK). + apply/set0Pn; exists (y * y'); rewrite -defT; apply/bigcupP. + by exists M; rewrite ?MX0 // K0 Ks0 mem_mulg 2?inE ?nty ?nty'. +have ntiT: normedTI T G Z. + have sTZ: {subset T <= Z} by apply/subsetP; rewrite 2!subDset setUA subsetUr. + have nTZ: Z \subset 'N(T). + rewrite normsD ?norms_bigcup ?normD1 ?normG //. + apply/bigcapsP=> _ /imsetP[Mi MXi ->]; rewrite normD1. + by case/nsK_Z: MXi => _ /andP[]. + apply/normedTI_P; rewrite setTI /= -/Z. + split=> // a _ /pred0Pn[t /andP[/= Tt]]; rewrite mem_conjg => Tta. + have{Tta} [Zt Zta] := (sTZ t Tt, sTZ _ Tta). + move: Tt; rewrite -defT => /bigcupP[Mi MXi]. + case/mulsgP=> y y' /setD1P[nty Kisy] /setD1P[nty' Kiy'] def_yy'. + have [[hallKi hallKis] [nsKiZ _]] := (hallK_Z _ MXi, nsK_Z _ MXi). + have [[PmaxMi hallKiMi] defZi] := (PmaxMX _ MXi, defZX _ MXi). + have [_ [defNKi _] _ [[]]] := Ptype_structure PmaxMi hallKiMi. + rewrite -defNKi defZi -/(Ks_ _) => tiKsi tiKi _ _ _. + have [defy defy']: y = t.`_\sigma(Mi) /\ y' = t.`_\sigma(Mi)^'. + have [_ cKiy] := setIP Kisy; have cy'y := centP cKiy _ Kiy'. + have sMi_y := mem_p_elt (pHall_pgroup hallKis) Kisy. + have sMi'y' := mem_p_elt (pHall_pgroup hallKi) Kiy'. + rewrite def_yy' !consttM // constt_p_elt // 2?(constt1P _) ?p_eltNK //. + by rewrite mulg1 mul1g constt_p_elt. + have: a \in Mi. + apply: contraR nty; rewrite -in_setC -in_set1 -set1gE; move/tiKsi <-. + rewrite inE Kisy mem_conjg defy -consttJ groupX ?(subsetP _ _ Zta) //. + by rewrite -defZi defNKi subsetIl. + apply/implyP; apply: contraR nty'; rewrite negb_imply andbC -in_setD. + rewrite -in_set1 -set1gE => /tiKi <-; rewrite inE Kiy' defy' mem_conjg. + by rewrite -consttJ (mem_normal_Hall hallKi nsKiZ) ?p_elt_constt ?groupX. +have [_ tiT /eqP defNT] := and3P ntiT; rewrite setTI in defNT. +pose n : rat := #|MNX|%:R; pose g : rat := #|G|%:R. +pose z : rat := #|Z|%:R; have nz_z: z != 0%R := natrG_neq0 _ _. +pose k_ Mi : rat := #|K_ Mi|%:R. +have nz_ks: #|Ks_ _|%:R != 0%R :> rat := natrG_neq0 _ _. +pose TG := class_support T G. +have oTG: (#|TG|%:R = (1 + n / z - \sum_(Mi in MX) (k_ Mi)^-1) * g)%R. + rewrite /TG class_supportEr -cover_imset -(eqnP tiT). + rewrite (eq_bigr (fun _ => #|T|)) => [|_ /imsetP[x _ ->]]; last first. + by rewrite cardJg. + rewrite sum_nat_const card_conjugates setTI defNT. + rewrite natrM natf_indexg ?subsetT //= -/z -mulrA mulrC; congr (_ * _)%R. + rewrite oT natrB; last by rewrite ltnW // -subn_gt0 lt0n -oT cards_eq0. + rewrite mulrC natrD -/n -/z natr_sum /=. + rewrite mulrBl mulrDl big_distrl divff //=; congr (_ - _)%R. + apply: eq_bigr => Mi MXi; have defZi := defZX _ MXi. + by rewrite /z -(dprod_card defZi) natrM invfM mulrC divfK. +have neMNX: MNX != set0. + move: ntK; rewrite -rank_gt0 => /rank_geP[X /exMNX[Mi MNXi _]]. + by apply/set0Pn; exists Mi. +have [Mi MXi P2maxMi]: exists2 Mi, Mi \in MX & Mi \in 'M_'P2. + apply/exists_inP; apply: negbNE; rewrite negb_exists_in. + apply/forall_inP=> allP1; pose ssup Mi := class_support (gval Mi)^~~ G. + have{allP1} min_ssupMX Mi: + Mi \in MX -> (#|ssup Mi|%:R >= ((k_ Mi)^-1 - (z *+ 2)^-1) * g)%R. + - move=> MXi; have [PmaxMi hallKi] := PmaxMX _ MXi. + have [[U [complU defMi] _]] := Ptype_structure PmaxMi hallKi. + case=> defZi _ _ _ _; have [maxMi _] := setDP PmaxMi. + have{complU} U1: U :==: 1; last rewrite {U U1}(eqP U1) sdprod1g in defMi. + rewrite (trivg_kappa_compl maxMi complU). + by apply: contraR (allP1 _ MXi) => ?; apply/setDP. + rewrite card_class_support_sigma // natrM natf_indexg ?subsetT // -/g. + rewrite mulrCA mulrC ler_wpmul2r ?ler0n // -subn1 natrB ?cardG_gt0 //. + rewrite mulr1n mulrBl -{1}(sdprod_card defMi) natrM invfM. + rewrite mulVKf ?natrG_neq0 // ler_add2l ler_opp2 -(mulr_natr _ 2) invfM. + rewrite ler_pdivr_mulr ?natrG_gt0 // mulrC mulrA. + have sZM: Z \subset M by rewrite -defZ subsetIl. + have sZMi: Z \subset Mi by rewrite -(defZX _ MXi) defZi subsetIl. + rewrite -natf_indexg //= -/Z ler_pdivl_mulr ?(ltr0Sn _ 1) // mul1r ler_nat. + rewrite indexg_gt1 /= -/Z subEproper /proper sZMi andbF orbF. + apply: contraNneq notMNX0 => defMiZ; have [Mj MNXj] := set0Pn _ neMNX. + have maxZ: [group of Z] \in 'M by rewrite !inE defMiZ in maxMi *. + have eqZ := group_inj (eq_mmax maxZ _ _); rewrite -(eqZ M) //. + have [Xj E1Xj maxNMj] := bigcupP MNXj; have [maxMj _] := setIdP maxNMj. + by rewrite (eqZ Mj) //; case/(Pmax_sym M K): maxNMj. + pose MXsup := [set ssup Mi | Mi in MX]. + have notMXsup0: set0 \notin MXsup. + apply/imsetP=> [[Mi /PmaxMX[/setDP[maxMi _] _] /esym/eqP/set0Pn[]]]. + have [x Mis_x ntx] := trivgPn _ (Msigma_neq1 maxMi). + exists (x ^ 1); apply: mem_imset2; rewrite ?inE //. + by apply/bigcupP; exists x; rewrite ?inE ?ntx // lcoset_refl. + have [Mi Mj MXi MXj /= neqMij | tiMXsup inj_ssup] := trivIimset _ notMXsup0. + apply/pred0Pn=> [[_ /andP[/imset2P[x y1 signMi_x _ ->]]]] /=. + rewrite /ssup class_supportEr /= => /bigcupP[y2 _]. + rewrite -mem_conjgV -conjsgM -sigma_supportJ; set H := Mj :^ _ => Hx. + suffices: [disjoint Mi^~~ & H^~~]. + by case/pred0Pn; exists x; rewrite /= {1}signMi_x Hx. + have [[PmaxMi _] [PmaxMj _]] := (PmaxMX _ MXi, PmaxMX _ MXj). + have [[maxMi _] [maxMj _]] := (setDP PmaxMi, setDP PmaxMj). + apply: sigma_support_disjoint; rewrite ?mmaxJ //. + rewrite (orbit_transr _ (mem_orbit _ _ _)) ?inE //=. + apply: contra (ntKsX _ MXi); case/imsetP=> y _ /= defMj; rewrite -/(Ks_ _). + have sKisKj: Ks_ Mi \subset K_ Mj by rewrite sKsKX // eq_sym. + rewrite -(setIidPl sKisKj) coprime_TIg //. + have [[_ hallKis] [hallKj _]] := (hallK_Z _ MXi, hallK_Z _ MXj). + apply: pnat_coprime (pHall_pgroup hallKj). + by rewrite defMj -pgroupE (eq_pgroup _ (sigmaJ _ _)) (pHall_pgroup hallKis). + have [|tiPG notMXsupTG]: _ /\ TG \notin _ := trivIsetU1 _ tiMXsup notMXsup0. + move=> _ /imsetP[Mi /PmaxMX[/setDP[maxMi _] _] ->]. + apply/pred0Pn=> [[_ /andP[/imset2P[x y1 Tx _ ->]]]] /=. + rewrite /ssup class_supportEr => /bigcupP[y2 _]. + rewrite -mem_conjgV -conjsgM -sigma_supportJ; set H := Mi :^ _ => Hx. + have maxH: [group of H] \in 'M by rewrite mmaxJ. + by case/andP: (pred0P (tiTscov _ maxH) x). + suffices: (g <= #|cover (TG |: MXsup)|%:R)%R. + rewrite ler_nat (cardsD1 1 G) group1 ltnNge subset_leq_card //. + apply/bigcupsP=> _ /setU1P[|/imsetP[Mi /PmaxMX[/setDP[maxMi _] _]]] ->. + rewrite /TG class_supportEr; apply/bigcupsP=> x _. + rewrite sub_conjg (normP _) ?normD1 ?(subsetP (normG _)) ?inE //. + by rewrite subDset setUC subsetU // setSD ?subsetT. + rewrite /ssup class_supportEr; apply/bigcupsP=> x _. + rewrite subsetD1 subsetT mem_conjg conj1g {x}/=. + move/ell_sigma0P: (@erefl gT 1); rewrite cards_eq0. + apply: contraL => /bigcupP[x Mis_x xR1]; apply/set0Pn; exists x. + exact: mem_sigma_cover_decomposition (Msigma_ell1 maxMi Mis_x) xR1. + rewrite -(eqnP tiPG) big_setU1 ?big_imset //= natrD natr_sum. + suffices: (g <= #|TG|%:R + \sum_(i in MX) ((k_ i)^-1 - (z *+ 2)^-1) * g)%R. + by move/ler_trans->; rewrite // ler_add2l ler_sum. + rewrite -big_distrl /= oTG -/g -mulrDl big_split /= sumr_const. + rewrite addrA subrK -(mulr_natl _ 2) -[_ *+ _]mulr_natl invfM mulrN. + rewrite mulrA -addrA -mulrBl -{1}(mul1r g) ler_wpmul2r ?ler0n //. + rewrite ler_addl -(mul0r z^-1)%R ler_wpmul2r ?invr_ge0 ?ler0n //. + rewrite subr_ge0 ler_pdivr_mulr ?(ltr0Sn _ 1) // -natrM ler_nat. + by rewrite muln2 -addnn cardsU1 leq_add2r notMNX0 lt0n cards_eq0. +have [prKi nilMis]: prime #|K_ Mi| /\ nilpotent Mi`_\sigma. + by have [PmaxMi /Ptype_structure[] // _ _ _ _ []] := PmaxMX _ MXi. +have [Mj MXj neqMji]: exists2 Mj, Mj \in MX & Mj :!=: Mi. + have [Mj |] := pickP (mem ((MX) :\ Mi)); first by case/setD1P; exists Mj. + move/eq_card0/eqP; rewrite -(eqn_add2l true) -{1}MXi -cardsD1 cardsU1. + by rewrite notMNX0 eqSS cards_eq0 (negPf neMNX). +have defKjs: Ks_ Mj = K_ Mi. + have sKjsKi: Ks_ Mj \subset K_ Mi by rewrite sKsKX. + apply/eqP; rewrite eqEcard sKjsKi (prime_nt_dvdP _ _ (cardSg sKjsKi)) //=. + by rewrite -trivg_card1 ntKsX. +have defMXij: MX = [set Mi; Mj]. + symmetry; rewrite -(setD1K MXi); congr (_ |: _); apply/eqP. + rewrite eqEcard sub1set cards1 (cardsD1 Mj) 2!inE neqMji MXj /= ltnS leqn0. + apply/pred0Pn=> [[Mk /setD1P[neMkj /setD1P[neMki MXk]]]]. + have sKskKsj: Ks_ Mk \subset Ks_ Mj by rewrite defKjs sKsKX. + by case/negP: (ntKsX _ MXk); rewrite -(setIidPl sKskKsj) tiKs. +have defKsi: Ks_ Mi = K_ Mj. + apply/eqP; rewrite eqEcard sKsKX 1?eq_sym //=. + rewrite -(@leq_pmul2r #|Ks_ Mj|) ?cardG_gt0 // (dprod_card (defZX _ MXj)). + by rewrite defKjs mulnC (dprod_card (defZX _ MXi)). +have{nilMis} cycZ: cyclic Z. + have cycKi := prime_cyclic prKi. + apply: nil_Zgroup_cyclic. + apply/forall_inP=> S /SylowP[p _ /and3P[sSZ pS _]]. + have [[hallKi hallKis] [nsKi nsKis]] := (hallK_Z _ MXi, nsK_Z _ MXi). + have [sMi_p | sMi'p] := boolP (p \in \sigma(Mi)); last first. + by rewrite (cyclicS _ cycKi) // (sub_normal_Hall hallKi) ?(pi_pgroup pS). + have sSKj: S \subset K_ Mj. + by rewrite -defKsi (sub_normal_Hall hallKis) ?(pi_pgroup pS). + rewrite (odd_pgroup_rank1_cyclic pS) ?mFT_odd //. + apply: wlog_neg; rewrite -ltnNge ltn_neqAle p_rank_gt0 => /andP[_ piSp]. + have [_ /and3P[sKjMj kKj _]] := PmaxMX _ MXj. + rewrite -(rank_kappa (pnatPpi kKj (piSg sSKj piSp))) p_rankS //. + exact: subset_trans sSKj sKjMj. + rewrite (dprod_nil (defZX _ MXi)) abelian_nil ?cyclic_abelian //=. + exact: (nilpotentS (subsetIl _ _)) nilMis. +have cycK: cyclic K := cyclicS (joing_subl _ _) cycZ. +have defM: M^`(1) ><| K = M. + have [U complU] := ex_kappa_compl maxM hallK; have [hallU _ _] := complU. + have [_ defM _ regUK _] := kappa_compl_context maxM complU. + have{hallU} [[sUM _] [sKM kK _]] := (andP hallU, and3P hallK). + case/sdprodP: defM => [[_ E _ defE]]; rewrite defE. + case/sdprodP: defE => _ <-{E} nUK _ defM /mulGsubP[nMsU nMsK] tiMsUK. + pose MsU := M`_\sigma <*> U; have nMsUK: K \subset 'N(MsU) by rewrite normsY. + have defMl: MsU * K = M by rewrite [MsU]norm_joinEr // -mulgA. + have coUK := regular_norm_coprime nUK regUK. + have ->: M^`(1) = MsU. + apply/eqP; rewrite eqEsubset; apply/andP; split; last first. + have solU := solvableS sUM (mmax_sol maxM). + rewrite join_subG Msigma_der1 //= -(coprime_cent_prod nUK coUK solU). + by rewrite (cent_semiregular regUK) // mulg1 commgSS. + apply: der1_min; first by rewrite -{1}defMl mulG_subG normG. + by rewrite -{2}defMl quotientMidl quotient_abelian ?cyclic_abelian. + rewrite sdprodE ?coprime_TIg //= norm_joinEr //. + rewrite (coprime_dvdl (dvdn_cardMg _ _)) // coprime_mull coUK. + rewrite (pnat_coprime (pcore_pgroup _ _) (sub_pgroup _ kK)) //. + exact: kappa_sigma'. +have{neMNX} [Mstar MNX'star] := set0Pn _ neMNX. +have defMNX: MNX = [set Mstar]. + apply/eqP; rewrite eq_sym eqEcard sub1set MNX'star /= -(leq_add2l true). + by rewrite -{1}notMNX0 -cardsU1 -/MX defMXij setUC cards2 neqMji !cards1. +have MXstar: Mstar \in MX by rewrite setU1r. +have [[PmaxMstar hallKstar] defZstar] := (PmaxMX _ MXstar, defZX _ MXstar). +have [maxMstar _] := setDP PmaxMstar. +have notMGMstar := notMG_MNX _ MNX'star; exists Mstar => //. +have [defKs defKs_star]: Ks = K_ Mstar /\ Ks_ Mstar = K. + rewrite /Ks /Ks_ -K0; rewrite /MX defMNX 3!inE val_eqE in neqMji MXj MXi. + by case/set2P: MXi (negPf neqMji) MXj => <- ->; rewrite ?orbF /= => /eqP <-. +have hallKs: \sigma(M).-Hall(Mstar) Ks. + have sKsMstar: Ks \subset Mstar by rewrite defKs (pHall_sub hallKstar). + have sM_Ks: \sigma(M).-group Ks := pgroupS (subsetIl _ _) (pcore_pgroup _ _). + have [Y hallY sKsY] := Hall_superset (mmax_sol maxMstar) sKsMstar sM_Ks. + have [sYMstar sM_Y _] := and3P hallY; apply: etrans hallY; congr pHall. + have sYMs: Y \subset M`_\sigma. + case/Ptype_structure: hallK => // _ _ _ [_ _ -> //]. + by rewrite (setIidPr sKsY). + apply/eqP; rewrite eqEsubset sKsY subsetI sYMs (sameP commG1P trivgP) /=. + have <-: M`_\sigma :&: Mstar`_\sigma = 1. + rewrite coprime_TIg // (pnat_coprime (pcore_pgroup _ _)) //. + apply: sub_pgroup (pcore_pgroup _ _) => q sM1q. + apply: contraFN (sigma_partition maxM maxMstar notMGMstar q) => sMq. + exact/andP. + rewrite commg_subI //. + by rewrite subsetI sYMs (subset_trans sYMstar) ?gFnorm. + rewrite subsetI -{1}defKs_star subsetIl. + by rewrite (subset_trans (pHall_sub hallK)) ?gFnorm. +have oTGgt_g2: (g / 2%:R < #|TG|%:R)%R. + rewrite oTG big_setU1 //= /n defMNX big_set1 cards1 mulrC mul1r. + rewrite ltr_pmul2r ?(ltr_nat _ 0) ?cardG_gt0 // /k_ K0 -defKs. + rewrite /z -defZ -(dprod_card defNK) natrM invfM opprD. + pose hm u : rat := (1 - u%:R^-1)%R; set lhs := (_^-1)%R. + suffices: (lhs < hm #|K| * hm #|Ks|)%R. + by rewrite mulrBl !mulrBr !mul1r mulr1 opprB addrAC !addrA. + have hm_inc u v: 0 < u <= v -> (hm u <= hm v)%R. + case/andP=> u_gt0 le_uv; rewrite ler_add2l ler_opp2. + have v_gt0 := leq_trans u_gt0 le_uv. + rewrite -(mul1r _^-1)%R ler_pdivr_mulr ?ltr0n //. + by rewrite ler_pdivl_mull ?ltr0n // mulr1 ler_nat. + have le_pdiv H: 0 < pdiv #|H| <= #|H| by rewrite pdiv_gt0 dvdn_leq ?pdiv_dvd. + have{le_pdiv} hm_pdiv := hm_inc _ _ (le_pdiv _). + have hm_ge0 u: (0 <= hm u)%R. + by case: u => // u; rewrite subr_ge0 invf_le1 ?ltr0Sn ?(ler_nat _ 1). + do 2![rewrite mulrC (ltr_le_trans _ (ler_wpmul2r (hm_ge0 _) (hm_pdiv _))) //]. + set p := pdiv #|K|; set q := pdiv #|Ks|. + have [odd_p odd_q]: odd p /\ odd q. + by split; apply: dvdn_odd (pdiv_dvd _) (mFT_odd _). + without loss [lt1p ltpq]: p q odd_p odd_q / 1 < p /\ p < q. + have [p_pr q_pr]: prime p /\ prime q by rewrite !pdiv_prime ?cardG_gt1. + have [ltpq | ltqp | eqpq] := ltngtP p q. + - by apply; rewrite ?prime_gt1. + - by rewrite mulrC; apply; rewrite ?prime_gt1. + have [] := hallK_Z _ MX0. + rewrite K0 Ks0 => /and3P[_ sM'K _] /and3P[_ sMKs _]. + case/negP: (pgroupP sM'K _ p_pr (pdiv_dvd _)); rewrite eqpq. + exact: pgroupP sMKs _ q_pr (pdiv_dvd _). + have p_gt2: 2 < p by rewrite odd_geq. + apply: ltr_le_trans (isT : lhs < hm 3 * hm 5)%R _. + by rewrite ler_pmul ?hm_inc ?hm_ge0 //= odd_geq ?(leq_trans _ ltpq). +have defZhat: Z :\: (K :|: Ks) = T. + rewrite /T cover_imset big_setU1 //= defMNX big_set1 defKs_star Ks0. + by rewrite -setDUl setDDl setUC setD1K // inE group1. +rewrite defZhat {1}defKs; split; first 2 [by split]. +- by rewrite -defKs_star; case/Ptype_structure: hallKstar => // _ _ []. +- split=> [|p]; first by rewrite -defKs_star defKs. + apply/idP/idP=> [kMp | t1p]. + have /orP[// | /and3P[_ _ p_dv_M']] := kappa_tau13 kMp. + have hallM': \kappa(M)^'.-Hall(M) M^`(1). + exact/(sdprod_normal_pHallP (der_normal 1 M) hallK). + have piMp: p \in \pi(M) by rewrite kappa_pi. + case/idPn: kMp; apply: (pnatPpi (pHall_pgroup hallM')). + by move: piMp; rewrite !mem_primes !cardG_gt0 /= => /andP[->]. + apply: (pnatPpi (pHall_pgroup hallK)); have [_ _ not_p_dv_M'] := and3P t1p. + have: p \in \pi(M) by rewrite (partition_pi_mmax maxM) t1p ?orbT. + rewrite !mem_primes !cardG_gt0 /= => /andP[p_pr]. + by rewrite p_pr -(sdprod_card defM) Euclid_dvdM // (negPf not_p_dv_M'). +- split=> // [| x | y | x y K1_x Ks1_y]. + + have defMsMstar: M`_\sigma :&: Mstar = Ks. + apply: sub_pHall hallKs _ _ (subsetIr _ _). + exact: pgroupS (subsetIl _ _) (pcore_pgroup _ _). + by rewrite subsetI subsetIl /= -/Ks defKs (pHall_sub hallKstar). + have nKsMMstar: M :&: Mstar \subset 'N(Ks). + by rewrite -defMsMstar normsIG ?gFnorm. + have [_ [defNKs _] _ _ _] := Ptype_structure PmaxMstar hallKstar. + rewrite -(setIidPl nKsMMstar) -setIA defKs -defNKs defZstar. + by rewrite -defZ setIA setIid. + + case/setD1P; rewrite -cycle_eq1 -cycle_subG -cent_cycle => ntx sxK. + apply/eqP; rewrite eqEsubset andbC subsetI -{1}defZ subsetIl. + rewrite sub_abelian_cent ?cyclic_abelian //=; last first. + by rewrite (subset_trans sxK) ?joing_subl. + move: ntx; rewrite -rank_gt0 /= -{1}(setIidPr sxK) => /rank_geP[X]. + rewrite nElemI -setIdE -defZ => /setIdP[E1X sXx]. + by have [<- _] := defNX _ E1X; rewrite setIS ?cents_norm ?centS. + + case/setD1P; rewrite -cycle_eq1 -cycle_subG -cent_cycle => nty syKs. + have [_ [defNKs defNY] _ _ _] := Ptype_structure PmaxMstar hallKstar. + rewrite defZstar -defKs in defNKs defNY. + apply/eqP; rewrite eqEsubset andbC subsetI {1}defNKs subsetIl. + rewrite sub_abelian_cent ?cyclic_abelian //=; last first. + by rewrite (subset_trans syKs) ?joing_subr. + move: nty; rewrite -rank_gt0 /= -{1}(setIidPr syKs) => /rank_geP[Y]. + rewrite nElemI -setIdE defNKs => /setIdP[E1Y sYy]. + by have [<- _] := defNY _ E1Y; rewrite setIS ?cents_norm ?centS. + have [[_ K_x] [_ Ks_y]] := (setD1P K1_x, setD1P Ks1_y). + apply/eqP; rewrite eqEsubset sub_cent1 -(centsP cKKs) //. + have Tyx: y * x \in T by rewrite -defT big_setU1 //= inE Ks0 K0 mem_mulg. + rewrite (subset_trans _ (cent1_normedTI ntiT Tyx)) ?setTI //. + rewrite (subsetP _ _ Tyx) // -defZhat setDE subIset //. + by rewrite -abelianE cyclic_abelian. +split=> // [||H PmaxH]. +- split=> // a notMa. + have{tiKs} [_ _ _ [[tiKs _] _ _] _] := Ptype_structure PmaxM hallK. + rewrite -defT big_setU1 //= defMNX big_set1 -defKs defKs_star Ks0 K0. + rewrite centC ?(centSS _ _ cKKs) ?subsetDl // setUid. + apply/pred0Pn=> [[_ /andP[/mulsgP[x y K1_x Ks1_y ->] /= Ma_xy]]]. + have [[_ K_x] [nty Ks_y]] := (setD1P K1_x, setD1P Ks1_y); case/negP: nty. + rewrite -in_set1 -set1gE -(tiKs a notMa) inE Ks_y. + suffices ->: y = (x * y).`_\sigma(M) by rewrite groupX. + rewrite consttM; last by red; rewrite -(centsP cKKs). + have sM'K := sub_pgroup (@kappa_sigma' M) (pHall_pgroup hallK). + rewrite (constt1P (mem_p_elt sM'K K_x)) mul1g constt_p_elt //. + exact: mem_p_elt (pHall_pgroup hallKs) Ks_y. +- have:= set21 Mi Mj; rewrite -defMXij /MX defMNX defKs -K0. + by case/set2P=> <-; [left | right]. +have [maxH _] := setDP PmaxH. +have{maxH}[L hallL] := Hall_exists \kappa(H) (mmax_sol maxH). +pose Ls := 'C_(H`_\sigma)(L); pose S := (L <*> Ls) :\: (L :|: Ls). +have{IHn} oSGgt_g2: (g / 2%:R < #|class_support S G|%:R)%R. + have [|nTG_leS] := ltnP #|class_support S G| nTG. + by case/IHn=> // Sstar _ [_ _ _ _ [[_ _ -> //]]]. + apply: ltr_le_trans oTGgt_g2 _; rewrite ler_nat /TG -defZhat. + exact: leq_trans leTGn nTG_leS. +have{oSGgt_g2 oTGgt_g2} meetST: ~~ [disjoint TG & class_support S G]. + rewrite -leq_card_setU; apply: contraTneq (leqnn #|G|) => tiTGS. + rewrite -ltnNge -(ltr_nat [realFieldType of rat]) -/g. + rewrite -{1}[g](@divfK _ 2%:R) // mulr_natr. + apply: ltr_le_trans (ltr_add oTGgt_g2 oSGgt_g2) _. + by rewrite -natrD -tiTGS ler_nat cardsT max_card. +have{meetST} [x Tx [a Sx]]: exists2 x, x \in T & exists a, x \in S :^ a. + have [_ /andP[/imset2P[x a1 Tx _ ->]]] := pred0Pn meetST. + rewrite class_supportEr => /bigcupP[a2 _ Sa2_xa1]. + by exists x => //; exists (a2 * a1^-1); rewrite conjsgM mem_conjgV. +rewrite {}/S {}/Ls in Sx; without loss a1: a H L PmaxH hallL Sx / a = 1. + move/(_ 1 (H :^ a)%G (L :^ a)%G); rewrite conjsg1 PtypeJ PmaxH pHallJ2. + rewrite (eq_pHall _ _ (kappaJ H a)) hallL MsigmaJ centJ. + rewrite -conjIg -conjYg -conjUg -conjDg Sx !inE. + by rewrite !(orbit_transr _ (mem_orbit _ _ _)) ?inE //; exact. +have [_ [defNL _] [_ uniqH] _ _] := Ptype_structure PmaxH hallL. +do [rewrite {a}a1 conjsg1; set Ls := 'C_(_)(L)] in Sx defNL. +have{x Sx Tx} [Mk MXk ntLsMks]: exists2 Mk, Mk \in MX & Ls :&: Ks_ Mk != 1. + have [_ _ cLLs tiLLs] := dprodP defNL. + pose W := L <*> Ls; pose y := x.`_\sigma(H); pose ys := y.`_\sigma(Mi). + have Zy: y \in Z by apply: groupX; case/setDP: Tx; case/setD1P=> _ ->. + have{hallL} [hallL hallLs]: \sigma(H)^'.-Hall(W) L /\ \sigma(H).-Hall(W) Ls. + apply: coprime_mulGp_Hall; first by rewrite /= cent_joinEr. + exact: sub_pgroup (@kappa_sigma' H) (pHall_pgroup hallL). + exact: pgroupS (subsetIl _ _) (pcore_pgroup _ _). + have [nsLW nsLsW]: L <| W /\ Ls <| W := cprod_normal2 (cprodEY cLLs). + have{Sx} [Ls_y nty]: y \in Ls /\ y != 1. + move: Sx; rewrite 2!inE negb_or -andbA -/W; case/and3P=> notLx _ Wx. + split; first by rewrite (mem_normal_Hall hallLs) ?p_elt_constt ?groupX. + by rewrite (sameP eqP constt1P) -(mem_normal_Hall hallL). + have [[hallKi hallKis] [nsKi nsKis]] := (hallK_Z _ MXi, nsK_Z _ MXi). + have [/constt1P sM'y | ntys] := altP (ys =P 1). + exists Mj; rewrite // defKjs. + by apply/trivgPn; exists y; rewrite // inE Ls_y (mem_normal_Hall hallKi). + exists Mi => //; apply/trivgPn; exists ys; rewrite // inE groupX //=. + by rewrite (mem_normal_Hall hallKis) ?p_elt_constt // groupX. +suffices ->: H = Mk. + by move: MXk; rewrite /MX defMNX => /set2P[]->; rewrite inE orbit_refl ?orbT. +move: ntLsMks; rewrite -rank_gt0 => /rank_geP[Y E1Y]. +have:= E1Y; rewrite nElemI => /setIP[E1LsY _]. +apply: set1_inj; rewrite -(uniqH _ E1LsY). +have [PmaxMk hallKk] := PmaxMX _ MXk. +have [_ _ [_ -> //]] := Ptype_structure PmaxMk hallKk. +by rewrite /= setIC nElemI in E1Y; case/setIP: E1Y. +Qed. + +End PTypeEmbedding. + +(* This is the first part of B & G, Corollary 14.8. *) +Corollary P1type_trans : {in 'M_'P1 &, forall M H, gval H \in M :^: G}. +Proof. +move=> M H P1maxM P1maxH; have [PmaxM _] := setIdP P1maxM. +have [[maxM _] [PmaxH _]] := (setDP PmaxM, setIdP P1maxH). +have [K hallK] := Hall_exists \kappa(M) (mmax_sol maxM). +have [Mstar _ [_ _ _ _ [_ [|]]]] := Ptype_embedding PmaxM hallK. + by case; rewrite inE P1maxM. +case=> /setDP[_ /negP notP1maxMstar] _. +case/(_ H PmaxH)/setUP=> // /imsetP[a _ /group_inj defH]. +by rewrite defH P1typeJ in P1maxH. +Qed. + +(* This is the second part of B & G, Corollary 14.8. *) +Corollary Ptype_trans : {in 'M_'P, forall M, + exists2 Mstar, Mstar \in 'M_'P /\ gval Mstar \notin M :^: G + & {in 'M_'P, forall H, gval H \in M :^: G :|: Mstar :^: G}}. +Proof. +move=> M PmaxM; have [maxM _] := setDP PmaxM. +have [K hallK] := Hall_exists \kappa(M) (mmax_sol maxM). +have [Mstar PmaxMstar [_ _ _ _ [_ _ inMMs _]]] := Ptype_embedding PmaxM hallK. +by exists Mstar. +Qed. + +(* This is B & G, Corollary 14.9. *) +Corollary mFT_partition : + let Pcover := [set class_support M^~~ G | M : {group gT} in 'M] in + [/\ (*1*) 'M_'P == set0 :> {set {group gT}} -> partition Pcover G^# + & (*2*) forall M K, M \in 'M_'P -> \kappa(M).-Hall(M) K -> + let Ks := 'C_(M `_\sigma)(K) in let Z := K <*> Ks in + let Zhat := Z :\: (K :|: Ks) in + let ClZhat := class_support Zhat G in + partition (ClZhat |: Pcover) G^# /\ ClZhat \notin Pcover]. +Proof. +move=> Pcover; have notPcover0: set0 \notin Pcover. + apply/imsetP=> [[M maxM]]; apply/eqP; rewrite eq_sym; apply/set0Pn. + have [x Ms_x ntx] := trivgPn _ (Msigma_neq1 maxM); exists x. + rewrite class_supportEl; apply/bigcupP; exists x; last exact: class_refl. + by apply/bigcupP; exists x; [apply/setD1P | apply: lcoset_refl]. +have tiPcover: trivIset Pcover. + apply/trivIsetP=> _ _ /imsetP[M maxM ->] /imsetP[H maxH ->] notMGH. + rewrite -setI_eq0 !{1}class_supportEr big_distrr big1 //= => a Ga. + rewrite big_distrl big1 //= => b Gb; apply/eqP. + rewrite -!{1}sigma_supportJ setI_eq0 sigma_support_disjoint ?mmaxJ //. + apply: contra notMGH; rewrite {a Ga}(orbit_transr _ (mem_orbit _ _ Ga)). + rewrite {b Gb}(orbit_transl (mem_orbit _ _ Gb))=> /imsetP[c Gc ->] /=. + by rewrite sigma_supportJ class_supportGidl. +have ntPcover: cover Pcover \subset G^#. + apply/bigcupsP=> _ /imsetP[M maxM ->]; rewrite class_supportEr. + apply/bigcupsP=> a _; rewrite subsetD1 subsetT mem_conjg conj1g {a}//=. + move/ell_sigma0P: (@erefl gT 1); rewrite cards_eq0; apply: contraL. + case/bigcupP=> x Ms_x xR1; apply/set0Pn; exists x. + exact: mem_sigma_cover_decomposition (Msigma_ell1 maxM Ms_x) xR1. +split=> [MP0 | M K PmaxM hallK Ks Z Zhat ClZhat]. + rewrite /partition eqEsubset ntPcover tiPcover notPcover0 !andbT /=. + apply/subsetP=> x; rewrite !inE andbT => ntx. + have:= sigma_decomposition_dichotomy ntx. + have [[y ell1y yRx] _ | _] := exists_inP. + have [nty /set0Pn[M /setIdP[maxM Ms_y]]] := ell_sigma1P _ ell1y. + apply/bigcupP; exists (class_support M^~~ G); first exact: mem_imset. + rewrite -(conjg1 x) mem_imset2 ?inE //. + apply/bigcupP; exists y; last by rewrite mem_lcoset. + by rewrite !inE nty -cycle_subG. + case/exists_inP=> y _; move: (_ * x) => y' /existsP[M]. + case/and3P => /setIdP[maxM _] /setD1P[nty' /setIP[My' _]] kMy' {y}. + case/set0Pn: MP0; exists M; rewrite 2!inE maxM andbT. + apply: contra nty' => kM'M; rewrite -order_eq1 (pnat_1 kMy') //. + exact: mem_p_elt kM'M My'. +have [_ [defNK _] [ntKs _] _ _] := Ptype_structure PmaxM hallK. +have [Mst [PmaxMst _] [_ [hallKst _] [defK _]]] := Ptype_embedding PmaxM hallK. +rewrite -/Ks -/Z -/Zhat in ntKs hallKst * => _ [_ _ conjMMst _]. +have [_ _ [ntK _] _ _] := Ptype_structure PmaxMst hallKst. +have [maxM _] := setDP PmaxM; rewrite defK in ntK. +have [|//|tiZPcover notPcovZ]: _ /\ ClZhat \notin _ := trivIsetU1 _ tiPcover _. + move=> HcovG; case/imsetP=> H maxH ->{HcovG}. + rewrite -setI_eq0 /ClZhat !class_supportEr big_distrr big1 //= => a _. + rewrite big_distrl big1 //= => b _; apply/eqP; rewrite -cards_eq0. + rewrite -(cardJg _ b^-1) conjIg conjsgK -conjsgM -sigma_supportJ cards_eq0. + wlog ->: a b H maxH / H :^ (a * b^-1) = H. + by move/(_ a a (H :^ (a * b^-1))%G); rewrite mmaxJ mulgV act1 => ->. + rewrite setIC big_distrl big1 //= => y Hs_y; apply/setP=> x; rewrite in_set0. + rewrite 3!inE mem_lcoset negb_or -andbA; apply/and4P=> [[yRx notKx notKs_x]]. + rewrite /Z cent_joinEr ?subsetIr //; case/mulsgP=> z z' Kz Ks_z' defx. + have:= sigma_decomposition_dichotomy (group1_contra notKx). + rewrite (introT exists_inP) /=; last first. + by exists y; rewrite // (Msigma_ell1 maxH). + have [Ms_z' cKz'] := setIP Ks_z'; case/exists_inP; exists z'. + rewrite (Msigma_ell1 maxM) ?inE // Ms_z' andbT. + by apply: contraNneq notKx => z'1; rewrite defx z'1 mulg1. + apply/existsP; exists M; rewrite inE maxM cycle_subG Ms_z'. + rewrite defx -(centP cKz') // mulKg (mem_p_elt (pHall_pgroup hallK)) //=. + rewrite 3!inE (subsetP (pHall_sub hallK)) //= cent1C !andbT. + rewrite andbC cent1C (subsetP _ _ Kz) ?sub_cent1 //=. + by apply: contraNneq notKs_x => z1; rewrite defx z1 mul1g. +split=> //; rewrite /partition eqEsubset 2!inE {}tiZPcover negb_or notPcover0. +rewrite /cover big_setU1 {notPcovZ}//= subUset ntPcover subsetD1 subsetT. +rewrite {}/ClZhat {}/Zhat !andbT /= andbC; apply/and3P; split. +- have [[y Ks_y nty] [y' Ky' nty']] := (trivgPn _ ntKs, trivgPn _ ntK). + rewrite eq_sym; apply/set0Pn; exists ((y' * y) ^ 1). + apply: mem_imset2; rewrite 2?inE // groupMl // groupMr // -/Ks negb_or. + have [_ _ _ tiKKs] := dprodP defNK. + rewrite -[Z]genM_join ?mem_gen ?mem_mulg //= andbT; apply/andP; split. + by apply: contra nty => Ky; rewrite -in_set1 -set1gE -tiKKs inE Ky. + by apply: contra nty' => Ks_y'; rewrite -in_set1 -set1gE -tiKKs inE Ky'. +- rewrite class_supportEr; apply/bigcupP=> [[a _]]. + by rewrite mem_conjg conj1g 2!inE !group1. +apply/subsetP=> x; case/setD1P=> ntx _; apply/setUP. +case: exists_inP (sigma_decomposition_dichotomy ntx) => [[y ell1y yRx] _ | _]. + have [nty] := ell_sigma1P _ ell1y; case/set0Pn=> H; case/setIdP=> maxH Hs_y. + right; apply/bigcupP; exists (class_support H^~~ G); first exact: mem_imset. + rewrite -[x]conjg1 mem_imset2 ?inE //; apply/bigcupP. + by exists y; rewrite ?mem_lcoset // !inE nty -cycle_subG. +case/exists_inP=> y ell1y /existsP[H]; set y' := y^-1 * x. +case/and3P=> /setIdP[maxH Hs_y] /setD1P[nty' /setIP[Hy' cyy']] kHy'. +rewrite {ntK ntKs maxM defNK}/Z /Ks; left. +wlog{Ks Mst PmaxMst hallKst conjMMst defK maxH} defH: M K PmaxM hallK / H :=: M. + move=> IH; have PmaxH: H \in 'M_'P. + apply/PtypeP; split=> //; exists (pdiv #[y']). + by rewrite (pnatPpi kHy') // pi_pdiv order_gt1. + have [|] := setUP (conjMMst H PmaxH); case/imsetP=> a Ga defH. + have:= IH _ (K :^ a)%G _ _ defH. + rewrite (eq_pHall _ _ (kappaJ _ _)) pHallJ2 PtypeJ MsigmaJ centJ. + by rewrite -conjIg -conjUg -conjYg -conjDg class_supportGidl //; apply. + have:= IH _ [group of Ks :^ a] _ _ defH. + rewrite (eq_pHall _ _ (kappaJ _ _)) pHallJ2 PtypeJ MsigmaJ centJ. + rewrite -conjIg -conjUg -conjYg -conjDg setUC joingC defK. + by rewrite class_supportGidl //; apply. +have /andP[sMsM nMsM]: M`_\sigma <| M := pcore_normal _ M. +have{Hs_y} Ms_y: y \in M`_\sigma by rewrite -defH -cycle_subG. +wlog{H defH Hy' kHy'} Ky': K hallK / y' \in K. + have [maxM _] := setDP PmaxM; rewrite -cycle_subG defH in Hy' kHy'. + have [a Ma Ka_y'] := Hall_subJ (mmax_sol maxM) hallK Hy' kHy'. + move/(_ (K :^ a)%G); rewrite pHallJ // -cycle_subG. + rewrite -{1 2}(normsP nMsM a Ma) centJ -conjIg -conjYg -conjUg -conjDg. + by rewrite class_supportGidl ?inE //; apply. +rewrite -[x]conjg1 mem_imset2 ?group1 //. +have [Mst _ [_ _ _ [cycZ _ defZ _ _] _]] := Ptype_embedding PmaxM hallK. +rewrite -(mulKVg y x) -/y' 2!inE negb_or andbC. +do [set Ks := 'C_(_)(K); set Z := K <*> _] in cycZ defZ *. +have Ks_y: y \in Ks. + have cKZ := sub_abelian_cent (cyclic_abelian cycZ) (joing_subl K Ks). + rewrite inE Ms_y (subsetP cKZ) // -(defZ y'); last by rewrite !inE nty'. + by rewrite inE cent1C (subsetP sMsM). +have [_ [defNK _] _ _ _] := Ptype_structure PmaxM hallK. +have{defNK} [_ _ cKKs tiKKs] := dprodP defNK. +rewrite [Z]joingC cent_joinEl // mem_mulg // groupMr // groupMl //= -/Ks. +apply/andP; split. + have [nty _] := ell_sigma1P _ ell1y. + by apply: contra nty => Ky; rewrite -in_set1 -set1gE -tiKKs inE Ky. +by apply: contra nty' => Ks_y'; rewrite -in_set1 -set1gE -tiKKs inE Ky'. +Qed. + +(* This is B & G, Corollary 14.10. *) +Corollary ell_sigma_leq_2 x : \ell_\sigma(x) <= 2. +Proof. +have [/ell_sigma0P/eqP-> // | ntx] := eqVneq x 1. +case sigma_x: (x \in cover [set class_support M^~~ G | M : {group gT} in 'M]). + case/bigcupP: sigma_x => _ /imsetP[M maxM ->]. + case/imset2P=> x0 a /bigcupP[y Ms_y yRx0] _ ->; rewrite ell_sigmaJ. + exact: ell_sigma_cover (Msigma_ell1 maxM Ms_y) yRx0. +have G1x: x \in G^# by rewrite !inE andbT. +have [FpartG1 PpartG1] := mFT_partition. +have [/eqP/FpartG1 partG1 | [M PmaxM]] := set_0Vmem ('M_'P : {set {group gT}}). + by rewrite -(cover_partition partG1) sigma_x in G1x. +have [maxM _] := setDP PmaxM. +have [K hallK] := Hall_exists \kappa(M) (mmax_sol maxM). +have{PpartG1} [/cover_partition defG1 notZsigma] := PpartG1 M K PmaxM hallK. +rewrite -{}defG1 /cover big_setU1 {notZsigma}// inE {}sigma_x orbF in G1x. +case/imset2P: G1x => x0 a /setDP[]. +have [Mst [PmaxMst _] [_ _ [defK _] _ _]] := Ptype_embedding PmaxM hallK. +rewrite cent_joinEr ?subsetIr // => /mulsgP[y' y Ky' /= Ks_y ->]. +rewrite inE; have [-> | nty] := eqVneq y 1; first by rewrite mulg1 Ky'. +have [-> | nty' _ _ ->] := eqVneq y' 1; first by rewrite mul1g Ks_y orbT. +have [Ms_y cKy] := setIP Ks_y; set Ks := 'C_(_)(_) in Ks_y defK. +have Msts_y': y' \in Mst`_\sigma by move: Ky'; rewrite -defK => /setIP[]. +have kMy': \kappa(M).-elt y' := mem_p_elt (pHall_pgroup hallK) Ky'. +have{kMy'} sM'y': \sigma(M)^'.-elt y' := sub_pgroup (@kappa_sigma' _) kMy'. +rewrite ell_sigmaJ /sigma_length (cardsD1 (y' * y).`_\sigma(M)). +rewrite (leq_add (leq_b1 _)) // -sigma_decomposition_constt' //. +rewrite consttM /commute ?(centP cKy) // constt_p_elt //. +rewrite (constt1P _) ?p_eltNK ?(mem_p_elt (pcore_pgroup _ _) Ms_y) // mulg1. +have [maxMst _] := setDP PmaxMst; rewrite leq_eqVlt (Msigma_ell1 maxMst) //. +by rewrite !inE nty' Msts_y'. +Qed. + +(* This is B & G, Lemma 14.11. *) +Lemma primes_non_Fitting_Ftype M E q Q : + M \in 'M_'F -> \sigma(M)^'.-Hall(M) E -> + Q \in 'E_q^1(E) -> ~~ (Q \subset 'F(E)) -> + exists2 Mstar, Mstar \in 'M & + [\/ (*1*) q \in \tau2(Mstar) /\ 'M('C(Q)) = [set Mstar] + | (*2*) q \in \kappa(Mstar) /\ Mstar \in 'M_'P1 ]. +Proof. +move=> FmaxM hallE EqQ notsFE_Q; have [maxM k'M] := FtypeP _ FmaxM. +have [sQE abelQ dimQ] := pnElemP EqQ; have [qQ _] := andP abelQ. +have [q_pr oQ] := (pnElem_prime EqQ, card_pnElem EqQ : #|Q| = q). +have t1Mq: q \in \tau1(M). + have: q \in \pi(E) by rewrite -p_rank_gt0; apply/p_rank_geP; exists Q. + rewrite (partition_pi_sigma_compl maxM hallE) => /or3P[// | t2q | t3q]. + have [A EqA _] := ex_tau2Elem hallE t2q. + have [[nsAE defA1] _ _ _] := tau2_compl_context maxM hallE t2q EqA. + have sQA: Q \subset A by move: EqQ; rewrite defA1 => /pnElemP[]. + rewrite (subset_trans sQA) ?Fitting_max // ?abelian_nil // in notsFE_Q. + by have [_ abelA _] := pnElemP EqA; apply: abelem_abelian abelA. + have [[E1 hallE1] [E3 hallE3]] := ex_tau13_compl hallE. + have [E2 _ complEi] := ex_tau2_compl hallE hallE1 hallE3. + have [[_ nsE3E] _ [_ cycE3] _ _] := sigma_compl_context maxM complEi. + have sQE3: Q \subset E3 by rewrite (sub_normal_Hall hallE3) ?(pi_pgroup qQ). + rewrite (subset_trans sQE3) ?Fitting_max ?abelian_nil // in notsFE_Q. + exact: cyclic_abelian cycE3. +have q'FE: q^'.-group 'F(E). + have [R sylR sQR] := Sylow_superset sQE qQ; have [sRE qR _] := and3P sylR. + have cycR: cyclic R. + rewrite (odd_pgroup_rank1_cyclic qR) ?mFT_odd // (p_rank_Sylow sylR) //. + by move: t1Mq; rewrite (tau1E maxM hallE) eqn_leq; case/and4P. + rewrite -partG_eq1 -(card_Hall (Hall_setI_normal (Fitting_normal E) sylR)). + have sRFER: R :&: 'F(E) \subset R := subsetIl _ _. + apply: contraR notsFE_Q; rewrite -trivg_card1 => ntRFE. + rewrite (subset_trans _ (subsetIr R _)) // -(cardSg_cyclic cycR) // oQ. + by have [] := pgroup_pdiv (pgroupS sRFER qR) ntRFE. +have cE'E': abelian E^`(1) := der_mmax_compl_abelian maxM hallE. +pose K := [~: E, Q]; have cKK: abelian K by rewrite (abelianS (commgS E sQE)). +have nsKE: K <| E by rewrite /normal commg_norml comm_subG. +have q'K: q^'.-group K by rewrite (pgroupS _ q'FE) // Fitting_max ?abelian_nil. +have [sKE nKE] := andP nsKE; have nKQ := subset_trans sQE nKE. +have defKQ: [~: K, Q] = K. + have nsKQ_E: K <*> Q <| E. + rewrite -(quotientGK nsKE) -(quotientYK nKQ) cosetpre_normal /= -/K. + by rewrite /normal quotientS // cents_norm // quotient_cents2r. + have [_ sylQ] := coprime_mulGp_Hall (esym (norm_joinEr nKQ)) q'K qQ. + have defE: K * 'N_E(Q) = E. + rewrite -{2}(Frattini_arg nsKQ_E sylQ) /= norm_joinEr //= -/K -mulgA. + by congr (K * _); rewrite mulSGid // subsetI sQE normG. + have cQ_NEQ: [~: 'N_E(Q), Q] = 1. + apply/trivgP; rewrite -(coprime_TIg (pnat_coprime qQ q'K)) subsetI. + by rewrite commg_subr subsetIr commSg ?subsetIl. + by rewrite {2}/K -defE commMG ?cQ_NEQ ?mulg1 1?normsR ?subsetIr ?subIset ?nKE. +have [sEM s'E _] := and3P hallE; have sQM := subset_trans sQE sEM. +have [sKM s'K] := (subset_trans sKE sEM, pgroupS sKE s'E). +have regQ: 'C_(M`_\sigma)(Q) = 1. + apply/eqP; apply: contraFT (k'M q) => nregQ. + have EqQ_M: Q \in 'E_q^1(M) by apply/pnElemP. + by rewrite unlock 3!inE /= t1Mq; apply/exists_inP; exists Q. +have nsKM: K <| M. + have [s'q _] := andP t1Mq. + have EqQ_NK: Q \in 'E_q^1('N_M(K)) by apply/pnElemP; rewrite subsetI sQM. + have:= commG_sigma'_1Elem_cyclic maxM sKM s'K s'q EqQ_NK regQ q'K cKK. + by rewrite defKQ; case. +have ntK: K != 1. + apply: contraNneq notsFE_Q => /commG1P cQE. + by rewrite Fitting_max ?(pgroup_nil qQ) // /normal sQE cents_norm. +pose p := pdiv #|K|; have p_pr: prime p by rewrite pdiv_prime ?cardG_gt1. +have piKp: p \in \pi(K) by rewrite pi_pdiv cardG_gt1. +have t2Mp: p \in \tau2(M). + have s'p := pnatPpi s'K piKp. + have sylKp: p.-Sylow(K) 'O_p(K) := nilpotent_pcore_Hall p (abelian_nil cKK). + rewrite inE /= s'p ?(sigma'_norm_mmax_rank2 maxM s'p (pHall_pgroup sylKp)) //. + rewrite (mmax_normal maxM) ?(char_normal_trans (pcore_char _ _)) //. + by rewrite -rank_gt0 (rank_Sylow sylKp) p_rank_gt0. +have [A EpA _] := ex_tau2Elem hallE t2Mp. +have [sAE] := pnElemP EpA; case/andP=> pA _ dimA. +have [[nsAE _] _ _ _] := tau2_compl_context maxM hallE t2Mp EpA. +have nAQ := subset_trans sQE (normal_norm nsAE). +have [S sylS sAS]:= Sylow_superset (subsetT A) pA. +have not_cSS: ~~ abelian S. + apply: contra notsFE_Q => cSS; rewrite Fitting_max ?(pgroup_nil qQ) //. + have solE := sigma_compl_sol hallE. + have [E1 hallE1 sQE1] := Hall_superset solE sQE (pi_pgroup qQ t1Mq). + have [_ [E3 hallE3]] := ex_tau13_compl hallE. + have [E2 _ complEi] := ex_tau2_compl hallE hallE1 hallE3. + have [_ _ _ sQZ] := abelian_tau2 maxM complEi t2Mp EpA sylS sAS cSS. + by rewrite sub_center_normal ?{}sQZ //; apply/nElemP; exists q; apply/pnElemP. +have [] := nonabelian_tau2 maxM hallE t2Mp EpA (pHall_pgroup sylS) not_cSS. +set A0 := 'C_A(M`_\sigma)%G => _ [oA0 defFM] _ _. +have defA0: A0 :=: K. + have sA0E: A0 \subset E by rewrite subIset ?sAE. + have sKA0: K \subset A0. + have [_ _ _ tiMsE] := sdprodP (sdprod_sigma maxM hallE). + rewrite -(mul1g A0) -tiMsE setIC group_modr // subsetI sKE. + by have [_ -> _ _] := dprodP defFM; rewrite Fitting_max ?abelian_nil. + by apply/eqP; rewrite eqEsubset prime_meetG ?(setIidPr sKA0) ?oA0. +have ntA: A :!=: 1 := nt_pnElem EpA isT. +have [H maxNH] := mmax_exists (mFT_norm_proper ntA (mFT_pgroup_proper pA)). +have [maxH sNH] := setIdP maxNH; have sQH := subset_trans nAQ sNH. +exists H => //. +have: p \in [predD \sigma(H) & \beta(H)] /\ q \in [predU \tau1(H) & \tau2(H)]. + have [-> // piAb _] := primes_norm_tau2Elem maxM hallE t2Mp EpA maxNH. + rewrite (pnatPpi piAb) // (piSg (quotientS _ sQE)) //=. + have piQq: q \in \pi(Q) by rewrite -p_rank_gt0 p_rank_abelem ?dimQ. + rewrite /= card_quotient ?normsI ?norms_cent // ?normsG //. + rewrite -indexgI setIA (setIidPl sQE) prime_TIg ?indexg1 // ?oQ //. + rewrite (sameP commG1P eqP) (subG1_contra _ ntK) //= -/K -defKQ commGC. + by rewrite -defA0 commgS ?subsetIl. +case=> /andP[/= b'Hp sHP] t12Hq. +have nregQHs: 'C_(H`_\sigma)(Q) != 1. + apply: subG1_contra (setSI _ _) (_ : 'C_A(Q) != 1). + rewrite (sub_Hall_pcore (Msigma_Hall maxH)) ?(pi_pgroup pA) //. + exact: subset_trans (normG A) sNH. + apply: contraTneq (leqnn 1) => regQA; rewrite -ltnNge -dimA. + rewrite -(leq_exp2l _ _ (prime_gt1 p_pr)) -card_pgroup // -oA0 defA0. + have coAQ := pnat_coprime (pi_pnat pA t2Mp) (pi_pnat qQ (tau2'1 t1Mq)). + rewrite subset_leq_card // -(coprime_cent_prod nAQ) ?(pgroup_sol pA) //. + by rewrite regQA mulg1 commSg. +have{t12Hq} [/= t1Hq | /= t2Hq] := orP t12Hq. + have EqQ_H: Q \in 'E_q^1(H) by apply/pnElemP. + have kHq: q \in \kappa(H). + by rewrite unlock 3!inE /= t1Hq; apply/exists_inP; exists Q. + right; split=> //; apply: contraR b'Hp => notP1maxH. + have PmaxH: H \in 'M_'P by apply/PtypeP; split=> //; exists q. + have [L hallL] := Hall_exists \kappa(H) (mmax_sol maxH). + by have [_ _ _ _ [|<- //]] := Ptype_structure PmaxH hallL; apply/setDP. +left; split=> //. +have [x defQ]: exists x, Q :=: <[x]> by apply/cyclicP; rewrite prime_cyclic ?oQ. +rewrite defQ cent_cycle in nregQHs *; rewrite (cent1_nreg_sigma_uniq maxH) //. + by rewrite 2!inE -cycle_eq1 -cycle_subG -defQ (nt_pnElem EqQ). +by rewrite /p_elt /order -defQ oQ pnatE. +Qed. + +(* This is B & G, Lemma 14.12. *) +(* Note that the assumption M \in 'M_'P2 could be weakened to M \in 'M_'P, *) +(* since the assumption H \in 'M('N(R)) implies H != 1, and hence U != 1. *) +Lemma P2type_signalizer M Mstar U K r R H : + M \in 'M_'P2 -> kappa_complement M U K -> Mstar \in 'M('C(K)) -> + r.-Sylow(U) R -> H \in 'M('N(R)) -> + [/\ H \in 'M_'F, U \subset H`_\sigma, U <*> K = M :&: H + & [/\ ~~ ('N_H(U) \subset M), K \subset 'F(H :&: Mstar) + & \sigma(H)^'.-Hall(H) (H :&: Mstar)]]. +Proof. +move=> P2maxM complU maxCMstar sylR maxNH; have [hallU hallK _] := complU. +have [PmaxM notP1maxM] := setDP P2maxM; have [maxM notFmaxM] := setDP PmaxM. +have [[sUM sk'M_U _] [sKM kK _]] := (and3P hallU, and3P hallK). +have{notFmaxM} ntK: K :!=: 1 by rewrite (trivg_kappa maxM). +have [hallE defM _ regK /(_ ntK)cUU] := kappa_compl_context maxM complU. +case/sdprodP: defM => [[_ E _ defE] _ _ _]. +have [nsUE sKE mulUK nUK tiUK] := sdprod_context defE. +rewrite (norm_joinEr nUK) mulUK in hallE *. +have [Mst [PmaxMst notMGMst] [uniqMst []]] := Ptype_embedding PmaxM hallK. +set Ks := 'C_(_)(K) => hallKs; case/and3P=> sKsMst sM_Ks _ [defK _]. +case=> cycZ ziMMst _ _ _ [_ _ defPmax _]. +have [_ [defNK _] [ntKs _] _ [//|_ q_pr _ _]] := Ptype_structure PmaxM hallK. +set q := #|K| in q_pr. +have{uniqMst} uniqMst: 'M('C(K)) = [set Mst]. + by apply: uniqMst; apply/nElemP; exists q; rewrite p1ElemE // !inE subxx /=. +have{maxCMstar} ->: Mstar = Mst by [apply/set1P; rewrite -uniqMst] => {Mstar}. +have [maxH sNRH] := setIdP maxNH. +have ntR: R :!=: 1. + by apply: contraTneq sNRH => ->; rewrite norm1 proper_subn ?mmax_proper. +have piUr: r \in \pi(U) by rewrite -p_rank_gt0 -(rank_Sylow sylR) rank_gt0. +have r_pr: prime r by move: piUr; rewrite mem_primes; case/andP. +have sylR_M := subHall_Sylow hallU (pnatPpi sk'M_U piUr) sylR. +have [/= s'Mr k'Mr] := norP (pnatPpi sk'M_U piUr). +have [sRH [sRM rR _]] := (subset_trans (normG R) sNRH, and3P sylR_M). +have notMGH: gval H \notin M :^: G. + apply: contra s'Mr; case/imsetP=> a _ defH. + rewrite -(sigmaJ _ a) -defH; apply/exists_inP; exists R => //. + by rewrite pHallE sRH /= (card_Hall sylR_M) defH cardJg. +have sK_uniqMst a: K \subset Mst :^ a -> a \in Mst. + move=> sKMa; apply: contraR ntK; rewrite -in_setC => Mst'a. + have [_ _ _ [[tiK_MstG _] _ _] _] := Ptype_structure PmaxMst hallKs. + by rewrite -(tiK_MstG a) // defK (setIidPl sKMa). +have [_ _] := dprodP defNK; rewrite -/Ks => cKKs tiKKs. +have snK_sMst L: K <|<| L -> L \subset Mst. + elim: {L}_.+1 {-2}L (ltnSn #|L|) => // n IHn A leAn. + case/subnormalEr=> [<- | [L [snKL nsLA ltLA]]]. + by rewrite -defK subIset // pcore_sub. + have [sKL sLMst]: K \subset L /\ L \subset Mst. + by rewrite subnormal_sub // IHn // (leq_trans (proper_card ltLA)). + apply/subsetP=> a Aa; rewrite -groupV sK_uniqMst // (subset_trans sKL) //. + by rewrite -sub_conjg (normsP (normal_norm nsLA)). +have sEH: E \subset H. + apply: subset_trans (char_norm_trans _ (normal_norm nsUE)) sNRH. + by rewrite (nilpotent_Hall_pcore (abelian_nil cUU) sylR) pcore_char. +have [sUH sKH]: U \subset H /\ K \subset H by apply/mulGsubP; rewrite mulUK. +have notMstGH: gval H \notin Mst :^: G. + apply: contra ntR => /imsetP[a _ defH]. + have{a defH} defH: H :=: Mst by rewrite -(conjGid (sK_uniqMst a _)) -?defH. + rewrite -(setIidPl sRH) -(setIidPl sRM) -setIA defH ziMMst coprime_TIg //=. + rewrite cent_joinEr // TI_cardMg //= coprime_mulr -/Ks. + rewrite (p'nat_coprime (pi_pnat rR _) kK) //=. + exact: p'nat_coprime (pi_pnat rR _) sM_Ks. +have FmaxH: H \in 'M_'F. + suffices: H \notin 'M_'P by rewrite inE maxH andbT negbK. + by apply: (contra (defPmax H)); rewrite inE; apply/norP. +have sKMsts: K \subset Mst`_\sigma by rewrite -defK subsetIl. +have s'H_K: \sigma(H)^'.-group K. + apply/pgroupP=> p p_pr p_dv_K; have [maxMst _] := setDP PmaxMst. + apply: contraFN (sigma_partition maxMst maxH notMstGH p) => /= sHp. + by rewrite inE /= (pgroupP (pgroupS sKMsts _)) ?pcore_pgroup. +have [D hallD sKD] := Hall_superset (mmax_sol maxH) sKH s'H_K. +have piKq: q \in \pi(K) by rewrite pi_of_prime ?inE. +have sK_FD: K \subset 'F(D). + have EqK: K \in 'E_q^1(D) by rewrite p1ElemE // !inE sKD /=. + have sMst_q: q \in \sigma(Mst). + by rewrite (pnatPpi (pcore_pgroup _ _) (piSg sKMsts _)). + apply: contraR notP1maxM => not_sKFD. + have [L _ ] := primes_non_Fitting_Ftype FmaxH hallD EqK not_sKFD. + case=> [[t2Lq ]|[kLq P1maxL]]. + rewrite uniqMst => /set1_inj defL. + by rewrite -defL 3!inE sMst_q in t2Lq. + have [PmaxL _] := setIdP P1maxL. + case/setUP: (defPmax L PmaxL) => /imsetP[a _ defL]. + by rewrite (group_inj defL) P1typeJ in P1maxL. + move: kLq; rewrite defL kappaJ unlock 3!inE /=. + by rewrite -andb_orr inE /= sMst_q. +have sDMst: D \subset Mst. + apply: snK_sMst (subnormal_trans _ (normal_subnormal (Fitting_normal D))). + exact: nilpotent_subnormal (Fitting_nil D) sK_FD. +have defUK: [~: U, K] = U. + rewrite -{2}(coprime_cent_prod nUK) ?abelian_sol //; last first. + by apply: p'nat_coprime (sub_pgroup _ sk'M_U) kK => ? /norP[]. + by rewrite (cent_semiregular regK) ?mulg1. +have qK: q.-group K := pnat_id q_pr. +have sUHs: U \subset H`_\sigma. + have [nsHsH _ mulHsD nHsD _] := sdprod_context (sdprod_sigma maxH hallD). + have nHsDq := subset_trans (pcore_sub q D) nHsD. + pose HsDq := H`_\sigma <*> 'O_q(D). + have defHsDq: H`_\sigma * 'O_q(D) = HsDq by rewrite -norm_joinEr. + have hallHs_HsDq: q^'.-Hall(HsDq) H`_\sigma. + have [|//] := coprime_mulGp_Hall defHsDq _ (pcore_pgroup _ _). + rewrite p'groupEpi; apply: (contra (pnatPpi (pcore_pgroup _ _))). + exact: pnatPpi s'H_K piKq. + have sK_HsDq: K \subset HsDq. + rewrite sub_gen ?subsetU // orbC -p_core_Fitting. + by rewrite (sub_Hall_pcore (nilpotent_pcore_Hall _ (Fitting_nil _))) ?qK. + have [|sHsDq_H nHsDq_H] := andP (_ : HsDq <| H). + rewrite -(quotientGK nsHsH) -[HsDq]quotientYK //= cosetpre_normal //. + by rewrite -{3}mulHsD quotientMidl quotient_normal // pcore_normal. + have sU_HsDq: U \subset HsDq. + by rewrite -defUK (subset_trans (commgSS sUH sK_HsDq)) // commg_subr. + rewrite (sub_normal_Hall hallHs_HsDq) //. + rewrite p'groupEpi; apply: (contraL (pnatPpi sk'M_U)) => /=. + by rewrite inE /= orbC (pnatPpi kK). + exact: normalS (joing_subl _ _) _ (pcore_normal _ _). +have defNMU: 'N_M(U) = E. + have [_ mulHsE nHsE _] := sdprodP (sdprod_sigma maxM hallE). + have [sUE nUE] := andP nsUE; rewrite -mulHsE -normC // -group_modl //=. + rewrite coprime_norm_cent ?(subset_trans sUE) //; last first. + exact: coprimegS sUE (coprime_sigma_compl hallE). + have sR1U: 'Ohm_1(R) \subset U := subset_trans (Ohm_sub 1 R) (pHall_sub sylR). + rewrite (trivgP (subset_trans (setIS _ (centS sR1U)) _)) ?mulg1 //. + have [|_ _ -> //] := sigma'_kappa'_facts maxM sylR_M. + by rewrite s'Mr (piSg sUM). +have sHsFH: H`_\sigma \subset 'F(H). + rewrite Fitting_max ?pcore_normal //. + have [S] := Sylow_exists q H; case/sigma'_kappa'_facts=> {S}//. + have [_ k'H] := setIdP FmaxH. + rewrite [~~ _](pnatPpi (pHall_pgroup hallD) (piSg sKD _)) //=. + by rewrite [~~ _](pnatPpi k'H) (piSg sKH). +suffices ->: H :&: Mst = D. + set sk' := _^' in sk'M_U hallU; pose Fu := 'O_sk'('F(H)). + have [sUFH nilFH] := (subset_trans sUHs sHsFH, Fitting_nil H). + have hallFu: sk'.-Hall('F(H)) Fu := nilpotent_pcore_Hall sk' nilFH. + have sUFu: U \subset Fu by rewrite (sub_Hall_pcore hallFu). + have nsFuH: Fu <| H := char_normal_trans (pcore_char _ _) (Fitting_normal _). + have [[sFuFH sk'Fu _] [sFuH nFuH]] := (and3P hallFu, andP nsFuH). + have defU: M :&: Fu = U. + have sk'MFu: sk'.-group(M :&: Fu) := pgroupS (subsetIr M _) sk'Fu. + by rewrite (sub_pHall hallU sk'MFu) ?subsetIl // subsetI sUM. + do 2?split=> //. + apply/eqP; rewrite eqEsubset subsetI (pHall_sub hallE) sEH /=. + by rewrite -defNMU subsetI subsetIl -defU normsGI. + apply: contra (contra_orbit _ _ notMGH) => sNHU_M. + rewrite (eq_mmax maxH maxM (subset_trans _ sNHU_M)) // subsetIidl. + rewrite -(nilpotent_sub_norm (nilpotentS sFuFH nilFH) sUFu) //= -/Fu. + by rewrite -{2}defU subsetI subsetIl (subset_trans (setSI _ sFuH)). +have [maxMst _] := setDP PmaxMst. +have [_ <- _ _] := sdprodP (sdprod_sigma maxH hallD). +rewrite -{2}(mul1g D) setIC -group_modr // setIC; congr (_ * _). +apply/eqP; apply: wlog_neg => ntHsMst. +have nregHsK: 'C_(H`_\sigma)(K) != 1. + rewrite (subG1_contra _ ntHsMst) // subsetI subsetIl (sameP commG1P trivgP). + have <-: H`_\sigma :&: Mst`_\sigma = 1. + apply: card_le1_trivg; rewrite leqNgt -pi_pdiv; set p := pdiv _. + apply: contraFN (sigma_partition maxMst maxH notMstGH p) => piIp. + rewrite inE /= (pnatPpi (pcore_pgroup _ _) (piSg (subsetIl _ _) piIp)). + by rewrite (pnatPpi (pcore_pgroup _ _) (piSg (subsetIr _ _) piIp)). + rewrite commg_subI ?setIS ?gFnorm // subsetI sKMsts. + by rewrite (subset_trans sKH) ?gFnorm. +have t2Hq: q \in \tau2(H). + have: q \in \pi(D) := piSg sKD piKq. + rewrite (partition_pi_sigma_compl maxH hallD) orbCA; case/orP=> // t13Hq. + case/FtypeP: FmaxH => _ /(_ q)/idP[]; rewrite unlock 3!inE /= t13Hq. + by apply/exists_inP; exists K => //; rewrite p1ElemE // !inE sKH /=. +have [A EqA_D EqA] := ex_tau2Elem hallD t2Hq. +have [_ _ _ -> //] := tau2_context maxH t2Hq EqA. +rewrite 3!inE -val_eqE /= eq_sym (contra_orbit _ _ notMstGH) maxMst. +by have [sAD _ _] := pnElemP EqA_D; apply: subset_trans sAD sDMst. +Qed. + +(* This is B & G, Lemma 14.13(a). *) +(* Part (b) is not needed for the Peterfalvi revision of the character theory *) +(* part of the proof. *) +Lemma non_disjoint_signalizer_Frobenius x M : + \ell_\sigma(x) == 1%N -> #|'M_\sigma[x]| > 1 -> + M \in 'M_\sigma[x] -> ~~ (\sigma('N[x])^'.-group M) -> + M \in 'M_'F /\ \tau2(M)^'.-group M. +Proof. +move=> ell1x ntR SMxM; have [maxM Ms_x] := setIdP SMxM. +rewrite negb_and cardG_gt0 all_predC negbK => /hasP[q /= piMq sNq]. +have [Q EqQ]: exists Q, Q \in 'E_q^1(M) by apply/p_rank_geP; rewrite p_rank_gt0. +have [ntQ [sQM abelQ dimQ]] := (nt_pnElem EqQ isT, pnElemP EqQ). +have [[qQ _] q_pr] := (andP abelQ, pnElem_prime EqQ). +have [_ [//| uniqN _ t2Nx _]] := FT_signalizer_context ell1x. +case/(_ M SMxM)=> _ st2NsM spM_sbN _; have [maxN sCxN] := mem_uniq_mmax uniqN. +have bNq: q \in \beta('N[x]) by rewrite spM_sbN //= 4!inE /= piMq. +have bGq: q \in \beta(G) by move: bNq; rewrite -predI_sigma_beta // inE /= sNq. +set p := pdiv #[x]; have pi_p: p \in \pi(#[x]). + by rewrite pi_pdiv order_gt1 (sameP eqP (ell_sigma0P _)) (eqP ell1x). +have sMp: p \in \sigma(M) := pnatPpi (pcore_pgroup _ _) (piSg Ms_x pi_p). +have t2Np: p \in \tau2('N[x]) := pnatPpi t2Nx pi_p. +have notMGN: gval 'N[x] \notin M :^: G. + apply: contraL t2Np => /imsetP[a _ ->]. + by rewrite negb_and negbK /= sigmaJ sMp. +have sM'q: q \in \sigma(M)^'. + by apply: contraFN (sigma_partition maxM maxN notMGN q) => sMq; apply/andP. +have [g sQNg]: exists g, Q \subset 'N[x] :^ g. + have [Q1 sylQ1] := Sylow_exists q 'N[x]. + have [g _ sQQ1g] := Sylow_subJ (sigma_Sylow_G maxN sNq sylQ1) (subsetT Q) qQ. + by exists g; rewrite (subset_trans sQQ1g) // conjSg (pHall_sub sylQ1). +have EqNQ: Q \in 'E_q^1('N[x] :^ g) by apply/pnElemP. +have uniqNg: 'M('C(Q)) = [set 'N[x] :^ g]%G. + by case/cent_der_sigma_uniq: EqNQ; rewrite ?mmaxJ 1?betaJ ?bNq. +have b'Mp: p \notin \beta(M). + by rewrite -predI_sigma_beta // inE /= sMp /=; case/tau2_not_beta: t2Np. +have{p pi_p sMp t2Np b'Mp} FmaxM: M \in 'M_'F. + have [P1maxM | notP1maxM] := boolP (M \in 'M_'P1); last first. + have [K hallK] := Hall_exists \kappa(M) (mmax_sol maxM). + apply: contraR b'Mp => notFmaxM; have PmaxM: M \in 'M_'P by apply/setDP. + by have [_ _ _ _ [|<- //]] := Ptype_structure PmaxM hallK; apply/setDP. + have [PmaxM skM] := setIdP P1maxM. + have kMq: q \in \kappa(M). + by case/orP: (pnatPpi skM piMq) => //= sMq; case/negP: sM'q. + have [K hallK sQK] := Hall_superset (mmax_sol maxM) sQM (pi_pnat qQ kMq). + have EqKQ: Q \in 'E_q^1(K) by apply/pnElemP. + have [L _ [uniqL [kLhallKs sMhallKs] _ _ _]] := Ptype_embedding PmaxM hallK. + set Ks := 'C_(_)(K) in kLhallKs sMhallKs. + have{uniqL} defL: 'N[x] :^ g = L. + apply: congr_group; apply: set1_inj; rewrite -uniqNg uniqL //. + by apply/nElemP; exists q. + have rpL: 'r_p(L) = 2. + by apply/eqP; case/andP: t2Np => _; rewrite -defL p_rankJ. + suffices piKs_p: p \in \pi(Ks). + by rewrite rank_kappa // (pnatPpi (pHall_pgroup kLhallKs)) in rpL. + have [P sylP] := Sylow_exists p [group of Ks]. + have sylP_L: p.-Sylow(L) P := subHall_Sylow sMhallKs sMp sylP. + by rewrite -p_rank_gt0 -(rank_Sylow sylP) (rank_Sylow sylP_L) ?rpL. +split=> //; apply: sub_pgroup (pgroup_pi _) => p piMp; apply/negP=> /= t2Mp. +have rpN: 'r_p('N[x]) <= 1. + have: p \notin \beta('N[x]). + rewrite -(predI_sigma_beta maxN) negb_and /= orbC. + by have [-> _] := tau2_not_beta maxM t2Mp. + apply: contraR; rewrite -ltnNge => rpN; rewrite spM_sbN // inE /= piMp. + have: p \in \pi('N[x]) by rewrite -p_rank_gt0 ltnW. + rewrite (partition_pi_mmax maxN) orbCA => /orP[t2Np | ]. + by case/andP: t2Mp => /negP[]; apply: st2NsM. + by rewrite orbA -!andb_orr eqn_leq leqNgt rpN andbF. +have [E hallE sQE] := Hall_superset (mmax_sol maxM) sQM (pi_pgroup qQ sM'q). +have [A Ep2A _] := ex_tau2Elem hallE t2Mp; have [_ abelA dimA] := pnElemP Ep2A. +pose A0 := [~: A, Q]%G; pose A1 := 'C_A(Q)%G. +have sCQNg: 'C(Q) \subset 'N[x] :^ g by have [] := mem_uniq_mmax uniqNg. +have ntA0: A0 :!=: 1. + rewrite (sameP eqP commG1P); apply: contraL rpN => cQA. + rewrite -ltnNge -(p_rankJ p _ g); apply/p_rank_geP. + by exists A; apply/pnElemP; rewrite (subset_trans cQA). +have t1Mq: q \in \tau1(M). + have [_ nsCEA_E t1Eb] := tau1_cent_tau2Elem_factor maxM hallE t2Mp Ep2A. + rewrite (pnatPpi t1Eb) // (piSg (quotientS _ sQE)) // -p_rank_gt0. + rewrite -rank_pgroup ?quotient_pgroup // rank_gt0 -subG1. + rewrite quotient_sub1 ?(subset_trans _ (normal_norm nsCEA_E)) //. + by rewrite subsetI sQE centsC (sameP commG1P eqP). +have EqEQ: Q \in 'E_q^1(E) by apply/pnElemP. +have regMsQ: 'C_(M`_\sigma)(Q) = 1. + apply: contraTeq FmaxM => nregMsQ; apply/FtypeP=> [[_]]; move/(_ q). + by rewrite unlock 3!inE /= t1Mq; case/exists_inP; exists Q. +have [[]] := tau1_act_tau2 maxM hallE t2Mp Ep2A t1Mq EqEQ regMsQ ntA0. +rewrite -/A0 -/A1 => EpA0 cMsA0 _ notA1GA0 [EpA1 _]. +have [sA0A abelA0 oA0] := pnElemPcard EpA0; have [pA0 _] := andP abelA0. +have [sA1A abelA1 oA1] := pnElemPcard EpA1; have [pA1 _] := andP abelA1. +have sA0N: A0 \subset 'N[x]. + rewrite -cMsA0 (subset_trans _ sCxN) //= -cent_cycle (centsS Ms_x) //. + exact: subsetIr. +have [P sylP sA0P] := Sylow_superset sA0N pA0; have [_ pP _] := and3P sylP. +have cycP: cyclic P. + by rewrite (odd_pgroup_rank1_cyclic pP) ?mFT_odd ?(p_rank_Sylow sylP). +have sA1gN: A1 :^ g^-1 \subset 'N[x] by rewrite sub_conjgV subIset ?sCQNg ?orbT. +have [|z _ sA1gzP] := Sylow_Jsub sylP sA1gN; first by rewrite pgroupJ. +case/imsetP: notA1GA0; exists (g^-1 * z); rewrite ?inE // conjsgM. +by apply/eqP; rewrite (eq_subG_cyclic cycP) // !cardJg oA0 oA1. +Qed. + +End Section14. + + diff --git a/mathcomp/odd_order/BGsection15.v b/mathcomp/odd_order/BGsection15.v new file mode 100644 index 0000000..2238534 --- /dev/null +++ b/mathcomp/odd_order/BGsection15.v @@ -0,0 +1,1509 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice div fintype. +Require Import path bigop finset prime fingroup morphism perm automorphism. +Require Import quotient action gproduct gfunctor pgroup cyclic commutator. +Require Import center gseries nilpotent sylow abelian maximal hall frobenius. +Require Import BGsection1 BGsection2 BGsection3 BGsection4 BGsection5. +Require Import BGsection6 BGsection7 BGsection9 BGsection10 BGsection12. +Require Import BGsection13 BGsection14. + +(******************************************************************************) +(* This file covers B & G, section 15; it fills in the picture of maximal *) +(* subgroups that was sketched out in section14, providing an intrinsic *) +(* characterization of M`_\sigma and establishing the TI property for the *) +(* "kernels" of maximal groups. We introduce only one new definition: *) +(* M`_\F == the (direct) product of all the normal Sylow subgroups of M; *) +(* equivalently, the largest normal nilpotent Hall subgroup of M *) +(* We will refer to M`_\F as the Fitting core or F-core of M. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section Definitions. + +Variables (gT : finGroupType) (M : {set gT}). + +Definition Fitting_core := + <<\bigcup_(P : {group gT} | Sylow M P && (P <| M)) P>>. +Canonical Structure Fitting_core_group := [group of Fitting_core]. + +End Definitions. + +Notation "M `_ \F" := (Fitting_core M) + (at level 3, format "M `_ \F") : group_scope. +Notation "M `_ \F" := (Fitting_core_group M) : Group_scope. + +Section FittingCore. + +Variable (gT : finGroupType) (M : {group gT}). +Implicit Types H P : {group gT}. +Implicit Type p : nat. + +Lemma Fcore_normal : M`_\F <| M. +Proof. +rewrite -[M`_\F]bigprodGE. +elim/big_ind: _ => [|P Q nsP nsG|P /andP[] //]; first exact: normal1. +by rewrite /normal normsY ?normal_norm // join_subG ?normal_sub. +Qed. +Hint Resolve Fcore_normal. + +Lemma Fcore_sub : M`_\F \subset M. +Proof. by case/andP: Fcore_normal. Qed. + +Lemma Fcore_sub_Fitting : M`_\F \subset 'F(M). +Proof. +rewrite gen_subG; apply/bigcupsP=> P /andP[/SylowP[p _ /and3P[_ pP _]] nsP]. +by rewrite Fitting_max // (pgroup_nil pP). +Qed. + +Lemma Fcore_nil : nilpotent M`_\F. +Proof. exact: nilpotentS Fcore_sub_Fitting (Fitting_nil M). Qed. + +Lemma Fcore_max pi H : + pi.-Hall(M) H -> H <| M -> nilpotent H -> H \subset M`_\F. +Proof. +move=> hallH nsHM nilH; have [sHM pi_H _] := and3P hallH. +rewrite -(nilpotent_Fitting nilH) FittingEgen genS //. +apply/bigcupsP=> [[p /= _] piHp]; rewrite (bigcup_max 'O_p(H)%G) //. +have sylHp := nilpotent_pcore_Hall p nilH. +have sylHp_M := subHall_Sylow hallH (pnatPpi pi_H piHp) sylHp. +by rewrite (p_Sylow sylHp_M) (char_normal_trans (pcore_char _ _)). +Qed. + +Lemma Fcore_dprod : \big[dprod/1]_(P | Sylow M (gval P) && (P <| M)) P = M`_\F. +Proof. +rewrite -[M`_\F]bigprodGE. +apply/eqP/bigdprodYP=> P /andP[/SylowP[p p_pr sylP] nsPM]. +have defP := normal_Hall_pcore sylP nsPM. +have /dprodP[_ _ cFpFp' tiFpFp'] := nilpotent_pcoreC p (Fitting_nil M). +have /dprodYP := dprodEY cFpFp' tiFpFp'; rewrite /= p_core_Fitting defP. +apply: subset_trans; rewrite bigprodGE gen_subG. +apply/bigcupsP=> Q => /andP[/andP[/SylowP[q _ sylQ] nsQM] neqQP]. +have defQ := normal_Hall_pcore sylQ nsQM; rewrite -defQ -p_core_Fitting. +apply: sub_pcore => q' /eqnP->; apply: contraNneq neqQP => eq_qp. +by rewrite -val_eqE /= -defP -defQ eq_qp. +Qed. + +Lemma Fcore_pcore_Sylow p : p \in \pi(M`_\F) -> p.-Sylow(M) 'O_p(M). +Proof. +rewrite /= -(bigdprod_card Fcore_dprod) mem_primes => /and3P[p_pr _]. +have not_p_dv_1: ~ p %| 1 by rewrite gtnNdvd ?prime_gt1. +elim/big_ind: _ => // [p1 p2 IH1 IH2|P /andP[/SylowP[q q_pr sylP] nsPM p_dv_P]]. + by rewrite Euclid_dvdM // => /orP[/IH1 | /IH2]. +have qP := pHall_pgroup sylP. +by rewrite (eqnP (pgroupP qP p p_pr p_dv_P)) (normal_Hall_pcore sylP). +Qed. + +Lemma p_core_Fcore p : p \in \pi(M`_\F) -> 'O_p(M`_\F) = 'O_p(M). +Proof. +move=> piMFp /=; rewrite -(pcore_setI_normal p Fcore_normal). +apply/setIidPl; rewrite sub_gen // (bigcup_max 'O_p(M)%G) //= pcore_normal. +by rewrite (p_Sylow (Fcore_pcore_Sylow piMFp)). +Qed. + +Lemma Fcore_Hall : \pi(M`_\F).-Hall(M) M`_\F. +Proof. +rewrite Hall_pi // /Hall Fcore_sub coprime_pi' ?cardG_gt0 //=. +apply/pnatP=> // p p_pr; apply: contraL => /= piMFp; rewrite -p'natE //. +rewrite -partn_eq1 // -(eqn_pmul2l (part_gt0 p #|M`_\F|)) muln1. +rewrite -partnM ?cardG_gt0 // Lagrange ?Fcore_sub //. +rewrite -(card_Hall (nilpotent_pcore_Hall p Fcore_nil)) /=. +by rewrite p_core_Fcore // (card_Hall (Fcore_pcore_Sylow piMFp)). +Qed. + +Lemma pcore_Fcore pi : {subset pi <= \pi(M`_\F)} -> 'O_pi(M`_\F) = 'O_pi(M). +Proof. +move=> s_pi_MF; rewrite -(pcore_setI_normal pi Fcore_normal). +apply/setIidPl; rewrite (sub_normal_Hall Fcore_Hall) ?pcore_sub //. +exact: sub_pgroup s_pi_MF (pcore_pgroup pi M). +Qed. + +Lemma Fcore_pcore_Hall pi : {subset pi <= \pi(M`_\F)} -> pi.-Hall(M) 'O_pi(M). +Proof. +move=> s_pi_MF; apply: (subHall_Hall Fcore_Hall s_pi_MF). +by rewrite /= -pcore_Fcore // (nilpotent_pcore_Hall pi Fcore_nil). +Qed. + +End FittingCore. + +Lemma morphim_Fcore : GFunctor.pcontinuous Fitting_core. +Proof. +move=> gT rT G D f; have nsGF_G := Fcore_normal G. +suffices hall_fGF: \pi(G`_\F).-Hall(f @* (D :&: G)) (f @* (D :&: G`_\F)). + rewrite !morphimIdom in hall_fGF. + by rewrite (Fcore_max hall_fGF) ?morphim_normal // morphim_nil ?Fcore_nil. +rewrite morphim_pHall ?subsetIl //= -{2}(setIidPr (Fcore_sub G)) setIA. +by rewrite !(setIC (D :&: G)) (setI_normal_Hall nsGF_G) ?subsetIr ?Fcore_Hall. +Qed. + +Canonical Structure Fcore_igFun := [igFun by Fcore_sub & morphim_Fcore]. +Canonical Structure Fcore_gFun := [gFun by morphim_Fcore]. +Canonical Structure Fcore_pgFun := [pgFun by morphim_Fcore]. + +Section MoreFittingCore. + +Variables (gT rT : finGroupType) (D : {group gT}) (f : {morphism D >-> rT}). +Implicit Types (M H : {group gT}) (R : {group rT}). + +Lemma Fcore_char M : M`_\F \char M. Proof. exact: gFchar. Qed. + +Lemma FcoreJ M x : (M :^ x)`_\F = M`_\F :^ x. +Proof. +rewrite -{1}(setTI M) -morphim_conj. +by rewrite -injmF ?injm_conj ?subsetT // morphim_conj setTI. +Qed. + +Lemma injm_Fcore M : 'injm f -> M \subset D -> f @* M`_\F = (f @* M)`_\F. +Proof. by move=> injf sMD; rewrite injmF. Qed. + +Lemma isom_Fcore M R : isom M R f -> M \subset D -> isom M`_\F R`_\F f. +Proof. by move=> isoMR sMD; apply: gFisom. Qed. + +Lemma isog_Fcore M R : M \isog R -> M`_\F \isog R`_\F. +Proof. by move=> isoMR; apply: gFisog. Qed. + +End MoreFittingCore. + +Section Section15. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). +Implicit Types p q q_star r : nat. +Implicit Types x y z : gT. +Implicit Types A E H K L M Mstar N P Q Qstar R S T U V W X Y Z : {group gT}. + +Lemma Fcore_sub_Msigma M : M \in 'M -> M`_\F \subset M`_\sigma. +Proof. +move=> maxM; rewrite gen_subG. +apply/bigcupsP=> P /andP[/SylowP[p _ sylP] nsPM]; have [sPM pP _] := and3P sylP. +have [-> | ntP] := eqsVneq P 1; first exact: sub1G. +rewrite (sub_Hall_pcore (Msigma_Hall maxM)) // (pi_pgroup pP) //. +by apply/exists_inP; exists P; rewrite ?(mmax_normal maxM). +Qed. + +Lemma Fcore_eq_Msigma M : + M \in 'M -> reflect (M`_\F = M`_\sigma) (nilpotent M`_\sigma). +Proof. +move=> maxM; apply: (iffP idP) => [nilMs | <-]; last exact: Fcore_nil. +apply/eqP; rewrite eqEsubset Fcore_sub_Msigma //. +by rewrite (Fcore_max (Msigma_Hall maxM)) ?pcore_normal. +Qed. + +(* This is B & G, Lemma 15.1. *) +(* We have made all semidirect products explicits, and omitted the assertion *) +(* M`_\sigma \subset M^`(1), which is exactly covered by Msigma_der1. *) +(* Some refactoring is definitely needed here, to avoid the mindless cut *) +(* and paste of a large fragment of the proof of Lemma 12.12. *) +Lemma kappa_structure M U K (Ms := M`_\sigma) : + M \in 'M -> kappa_complement M U K -> + [/\ (*a*) [/\ (Ms ><| U) ><| K = M, cyclic K & abelian (M^`(1) / Ms)], + (*b*) K :!=: 1 -> Ms ><| U = M^`(1) /\ abelian U, + (*c*) forall X, X \subset U -> X :!=: 1 -> 'C_Ms(X) != 1 -> + [/\ 'M('C(X)) = [set M], cyclic X & \tau2(M).-group X], + (*d*) abelian <<\bigcup_(x in Ms^#) 'C_U[x]>> + & (*e*) U :!=: 1 -> exists U0, + [/\ gval U0 \subset U, exponent (gval U0) = exponent U + & [Frobenius Ms <*> U0 = Ms ><| U0]]]. +Proof. +move=> maxM complU; have [hallU hallK _] := complU. +have [hallE defM _ regUK cUU] := kappa_compl_context maxM complU. +have [[_ E _ defE]] := sdprodP defM. +have [nsUE sKE mulUK nUK tiUK] := sdprod_context defE. +rewrite defE -{1 2}mulUK mulgA => defMl /mulGsubP[nMsU nMsK] tiMsE. +have [/andP[sMsM nMsM] [sUE nUE]] := (pcore_normal _ M : Ms <| M, andP nsUE). +rewrite norm_joinEr // mulUK in hallE. +have [[sEM s'M_E _] [sUM sk'U _]] := (and3P hallE, and3P hallU). +have defMsU: Ms ><| U = Ms <*> U. + by apply: sdprodEY nMsU (trivgP _); rewrite -tiMsE -mulUK setIS ?mulG_subl. +have{defM} defM: Ms <*> U ><| K = M. + rewrite sdprodE ?normsY ?coprime_TIg //=; first by rewrite norm_joinEr. + rewrite -(sdprod_card defMsU) coprime_mull andbC regular_norm_coprime //=. + by rewrite (coprimegS sKE) ?(pnat_coprime (pcore_pgroup _ _)). +rewrite defMsU quotient_der //= -/Ms -{2}defMl -mulgA mulUK. +rewrite quotientMidl -quotient_der ?(subset_trans sEM) //. +rewrite quotient_abelian ?(der_mmax_compl_abelian maxM hallE) //. +set part_c := forall U, _; have c_holds: part_c. + move=> X sXU ntX nregMsX; have sXE := subset_trans sXU sUE. + have [x /setIP[Ms_x cXx] ntx] := trivgPn _ nregMsX. + have Ms1x: x \in Ms^# by apply/setD1P. + have piCx_hyp: {in X^#, forall x', x' \in ('C_M[x])^# /\ \sigma(M)^'.-elt x'}. + move=> x' /setD1P[ntx' Xx']; have Ex' := subsetP sXE x' Xx'. + rewrite 3!inE ntx' (subsetP sEM) ?(mem_p_elt s'M_E) //=. + by rewrite (subsetP _ _ Xx') ?sub_cent1. + have piCx x' X1x' := (* GG -- ssreflect evar generalization fails in trunk *) + let: conj c e := piCx_hyp x' X1x' in pi_of_cent_sigma maxM Ms1x c e. + have t2X: \tau2(M).-group X. + apply/pgroupP=> p p_pr /Cauchy[] // x' Xx' ox'. + have X1x': x' \in X^# by rewrite !inE Xx' -order_gt1 ox' prime_gt1. + have [[]|[]] := piCx _ X1x'; last by rewrite /p_elt ox' pnatE. + case/idPn; have:= mem_p_elt (pgroupS sXU sk'U) Xx'. + by rewrite /p_elt ox' !pnatE // => /norP[]. + suffices cycX: cyclic X. + split=> //; have [x' defX] := cyclicP cycX. + have X1x': x' \in X^# by rewrite !inE -cycle_eq1 -cycle_subG -defX ntX /=. + have [[kX _]|[_ _]] := piCx _ X1x'; last by rewrite defX cent_cycle. + rewrite -(setIid X) coprime_TIg ?eqxx // {2}defX in ntX. + rewrite (pnat_coprime t2X (sub_pgroup _ kX)) // => p kp. + by rewrite inE /= negb_and rank_kappa ?orbT. + have [E2 hallE2 sXE2] := Hall_superset (sigma_compl_sol hallE) sXE t2X. + rewrite abelian_rank1_cyclic; last first. + exact: abelianS sXE2 (tau2_compl_abelian maxM hallE hallE2). + have [p _ ->] := rank_witness X; rewrite leqNgt; apply: contra nregMsX => rpX. + have t2p: p \in \tau2(M) by rewrite (pnatPpi t2X) // -p_rank_gt0 ltnW. + rewrite -(setIidPr (subset_trans sXE sEM)) in rpX. + case/p_rank_geP: rpX => A; rewrite pnElemI -setIdE; case/setIdP=> Ep2A sAX. + rewrite -subG1; have [_ _ <- _ _] := tau2_context maxM t2p Ep2A. + by rewrite setIS ?centS. +have hallU_E: Hall E U := pHall_Hall (pHall_subl sUE sEM hallU). +have UtypeF := FTtypeF_complement maxM hallE hallU_E nsUE. +set k'U13 := ({in _, _}) in UtypeF. +have/UtypeF{UtypeF k'U13}UtypeF: k'U13. + move=> x /setD1P[]; rewrite -order_gt1 -pi_pdiv. + set p := pdiv _ => pi_x_p Ux t13x. + apply: contraNeq (pnatPpi (mem_p_elt sk'U Ux) pi_x_p) => nreg_x. + apply/orP; right; rewrite unlock /= inE /= (pnatPpi t13x) //=. + have sxM: <[x]> \subset M by rewrite cycle_subG (subsetP sUM). + move: pi_x_p; rewrite -p_rank_gt0 /= -(setIidPr sxM) => /p_rank_geP[P]. + rewrite pnElemI -setIdE => /setIdP[EpP sPx]; apply/exists_inP; exists P => //. + by rewrite (subG1_contra _ nreg_x) //= -cent_cycle setIS ?centS. +have [K1 | ntK] := altP (K :=P: 1). + rewrite {2}K1 cyclic1; rewrite K1 mulg1 in mulUK; rewrite -mulUK in hallE. + have ltM'M := sol_der1_proper (mmax_sol maxM) (subxx _) (mmax_neq1 maxM). + suffices /UtypeF[[A0 [_ abA0 genA0]] frobM]: U :!=: 1. + by split => //; apply: abelianS abA0; rewrite gen_subG; apply/bigcupsP. + apply: contraNneq (proper_subn ltM'M); rewrite -{1}defMl => ->. + by rewrite K1 !mulg1 Msigma_der1. +have PmaxM: M \in 'M_'P by rewrite inE maxM -(trivg_kappa maxM hallK) andbT. +have [_ _ [_ _ _ [cycZ _ _ _ _] [_ _ _ defM']]] := Ptype_embedding PmaxM hallK. +have{cycZ cUU} [cycK cUU] := (cyclicS (joing_subl _ _) cycZ, cUU ntK). +split=> // [_||/UtypeF[] //]; first split=> //. + apply/eqP; rewrite eq_sym eqEcard -(leq_pmul2r (cardG_gt0 K)). + have [nsMsU_M _ mulMsU _ _] := sdprod_context defM. + rewrite (sdprod_card defM) (sdprod_card defM') der1_min ?normal_norm //=. + by rewrite -(isog_abelian (sdprod_isog defM)) cyclic_abelian. +by apply: abelianS cUU; rewrite gen_subG -big_distrr subsetIl. +Qed. + +(* This is B & G, Theorem 15.2. *) +(* It is this theorem that implies that the non-functorial definition of *) +(* M`_\sigma used in B & G is equivalent to the original definition in FT *) +(* (also used in Peterfalvi). *) +(* Proof notes: this proof contained two non-structural arguments: taking D *) +(* to be K-invariant, and reusing the nilpotent Frobenius kernel argument for *) +(* Q1 (bottom of p. 118). We handled the first with a "without loss", but for *) +(* the second we had to spell out explicitly the assumptions and conclusions *) +(* of the nilpotent kernel argument that were spread throughout the last *) +(* paragraph p. 118. *) +(* We also had to make a few additions to the argument at the top of p. 119; *) +(* while the statement of the Theorem states that F(M) = C_M(Qbar), the text *) +(* only shows that F(M) = C_Msigma(Qbar), and we need to show that K acts *) +(* regularly on Qbar to complete the proof; this follows from the values of *) +(* orders of K, Kstar and Qbar. In addition we need to show much earlier *) +(* that K acts faithfully on Q, to show that C_M(Q) is included in Ms, and *) +(* this requires a use of 14.2(e) not mentioned in the text; in addition, the *) +(* reference to coprime action (Proposition 1.5) on p. 119 l. 1 is somewhat *) +(* misleading, since we actually need to use the coprime stabilizer Lemma 1.9 *) +(* to show that C_D(Qbar) = C_D(Q) = 1 (unless we splice in the proof of that *) +(* lemma). *) +Theorem Fcore_structure M (Ms := M`_\sigma) : + M \in 'M -> + [/\ M`_\F != 1, M`_\F \subset Ms, Ms \subset M^`(1) & M^`(1) \proper M] + /\ (forall K D : {group gT}, + \kappa(M).-Hall(M) K -> M`_\F != M`_\sigma -> + let p := #|K| in let Ks := 'C_Ms(K) in + let q := #|Ks| in let Q := 'O_q(M) in + let Q0 := 'C_Q(D) in let Qbar := Q / Q0 in + q^'.-Hall(M`_\sigma) D -> + [/\ (*a*) [/\ M \in 'M_'P1, Ms ><| K = M & Ms = M ^`(1)], + (*b*) [/\ prime p, prime q, q \in \pi(M`_\F) & q \in \beta(M)], + [/\ (*c*) q.-Sylow(M) Q, + (*d*) nilpotent D + & (*e*) Q0 <| M], + (*f*) [/\ minnormal Qbar (M / Q0), q.-abelem Qbar & #|Qbar| = (q ^ p)%N] + & (*g*) [/\ Ms^`(1) = M^`(2), + M^`(2) \subset 'F(M), + [/\ Q <*> 'C_M(Q) = 'F(M), + 'C_M(Qbar | 'Q) = 'F(M) + & 'C_Ms (Ks / Q0 | 'Q) = 'F(M)] + & 'F(M) \proper Ms]]). +Proof. +move=> maxM; set M' := M^`(1); set M'' := M^`(2). +have nsMsM: Ms <| M := pcore_normal _ M; have [sMsM nMsM] := andP nsMsM. +have solM := mmax_sol maxM; have solMs: solvable Ms := solvableS sMsM solM. +have sMF_Ms: M`_\F \subset Ms := Fcore_sub_Msigma maxM. +have ltM'M: M' \proper M by rewrite (sol_der1_proper solM) ?mmax_neq1. +have sMsM': Ms \subset M' := Msigma_der1 maxM. +have [-> | ltMF_Ms] := eqVproper sMF_Ms; first by rewrite eqxx Msigma_neq1. +set KDpart := (X in _ /\ X); suffices KD_holds: KDpart. + do 2!split=> //; have [K hallK] := Hall_exists \kappa(M) solM. + pose q := #|'C_(M`_\sigma)(K)|; have [D hallD] := Hall_exists q^' solMs. + have [_ [_ _ piMFq _] _ _ _] := KD_holds K D hallK (proper_neq ltMF_Ms) hallD. + by rewrite -rank_gt0 (leq_trans _ (p_rank_le_rank q _)) ?p_rank_gt0. +move=> {KDpart} K D hallK neMF_Ms p Ks q Q /= hallD. +have not_nilMs: ~~ nilpotent Ms by rewrite (sameP (Fcore_eq_Msigma maxM) eqP). +have P1maxM: M \in 'M_'P1; last have [PmaxM _] := setIdP P1maxM. + apply: contraR not_nilMs => notP1maxM; apply: notP1type_Msigma_nil. + by rewrite orbC inE notP1maxM inE maxM andbT orNb. +have ntK: K :!=: 1 by rewrite inE maxM andbT -(trivg_kappa maxM hallK) in PmaxM. +have [defMs defM]: Ms = M' /\ Ms ><| K = M. + have [U complU] := ex_kappa_compl maxM hallK. + have U1: U :=: 1 by apply/eqP; rewrite (trivg_kappa_compl maxM complU). + have [[defM _ _] [//| defM' _] _ _ _] := kappa_structure maxM complU. + by rewrite U1 sdprodg1 in defM defM'. +have [_ mulMsK nMsK _] := sdprodP defM; rewrite /= -/Ms in mulMsK nMsK. +have [sKM kK _] := and3P hallK; have s'K := sub_pgroup (@kappa_sigma' _ _) kK. +have coMsK: coprime #|Ms| #|K| := pnat_coprime (pcore_pgroup _ _) s'K. +have q_pr: prime q. + have [L _ [_ _ _ _ [_]]] := Ptype_embedding PmaxM hallK. + by rewrite inE P1maxM => [[] []]. +have hallMs: \sigma(M).-Hall(M) Ms := Msigma_Hall maxM. +have sMq: q \in \sigma(M). + by rewrite -pnatE // -pgroupE (pgroupS (subsetIl _ _) (pcore_pgroup _ _)). +have{s'K kK} q'K: q^'.-group K := pi'_p'group s'K sMq. +have nsQM: Q <| M := pcore_normal q M; have [sQM nQM] := andP nsQM. +have qQ: q.-group Q := pcore_pgroup _ _. +have sQMs: Q \subset Ms by rewrite (sub_Hall_pcore hallMs) ?(pi_pgroup qQ). +have [K1 prK1 sK1K]: exists2 K1, prime #|gval K1| & K1 \subset K. + have:= ntK; rewrite -rank_gt0; have [r r_pr ->] := rank_witness K. + by case/p_rank_geP=> K1 /pnElemPcard[? _ oK1]; exists K1; rewrite ?oK1. +have coMsK1 := coprimegS sK1K coMsK; have coQK1 := coprimeSg sQMs coMsK1. +have prMsK: semiprime Ms K by have [[? _ []] ] := Ptype_structure PmaxM hallK. +have defCMsK1: 'C_Ms(K1) = Ks. + by rewrite (cent_semiprime prMsK) // -cardG_gt1 prime_gt1. +have sK1M := subset_trans sK1K sKM; have nQK1 := subset_trans sK1M nQM. +have{sMsM'} sKsQ: Ks \subset Q. + have defMsK: [~: Ms, K] = Ms by case/coprime_der1_sdprod: defM. + have hallQ := nilpotent_pcore_Hall q (Fitting_nil M). + rewrite -[Q]p_core_Fitting (sub_Hall_pcore hallQ) //; first exact: pnat_id. + apply: prime_meetG => //; apply: contraNneq not_nilMs => tiKsFM. + suffices <-: 'F(Ms) = Ms by apply: Fitting_nil. + apply/eqP; rewrite eqEsubset Fitting_sub /= -{1}defMsK. + rewrite (odd_sdprod_primact_commg_sub_Fitting defM) ?mFT_odd //. + apply/trivgP; rewrite -tiKsFM setIAC setSI //= -/Ms subsetI Fitting_sub /=. + by rewrite Fitting_max ?Fitting_nil // (char_normal_trans (Fitting_char _)). +have nilMs_Q: nilpotent (Ms / Q). + have [nMsK1 tiQK1] := (subset_trans sK1K nMsK, coprime_TIg coQK1). + have prK1b: prime #|K1 / Q| by rewrite -(card_isog (quotient_isog _ _)). + have defMsK1: (Ms / Q) ><| (K1 / Q) = (Ms / Q) <*> (K1 / Q). + by rewrite sdprodEY ?quotient_norms // coprime_TIg ?coprime_morph. + apply: (prime_Frobenius_sol_kernel_nil defMsK1) => //. + by rewrite (solvableS _ (quotient_sol _ solM)) ?join_subG ?quotientS. + by rewrite -coprime_quotient_cent ?quotientS1 /= ?defCMsK1. +have defQ: 'O_q(Ms) = Q by rewrite -(setIidPl sQMs) pcore_setI_normal. +have sylQ: q.-Sylow(Ms) Q. + have nsQMs: Q <| Ms by rewrite -defQ pcore_normal. + rewrite -(pquotient_pHall qQ) // /= -/Q -{3}defQ. + by rewrite -(pquotient_pcore _ qQ) ?nilpotent_pcore_Hall. +have{sMq hallMs} sylQ_M := subHall_Sylow hallMs sMq sylQ. +have sQ_MF: Q \subset M`_\F. + by rewrite sub_gen ?(bigcup_max [group of Q]) ?(p_Sylow sylQ_M) ?pcore_normal. +have{sQ_MF} piMFq: q \in \pi(M`_\F). + by rewrite (piSg sQ_MF) // (piSg sKsQ) // pi_of_prime ?inE /=. +without loss nDK: D hallD / K \subset 'N(D). + have [E hallE nEK] := coprime_Hall_exists q^' nMsK coMsK solMs. + have [x Ms_x ->] := Hall_trans solMs hallD hallE. + set Q0 := 'C__(_)%G; rewrite -(isog_nil (conj_isog _ _)) -['C_Q(_)]/(gval Q0). + move/(_ E hallE nEK)=> IH; suffices ->: Q0 = [group of 'C_Q(E)] by []. + apply: group_inj => /=; have Mx: x \in M := subsetP (pcore_sub _ _) x Ms_x. + rewrite /= -/Q -{1}(normsP nQM x Mx) centJ -conjIg (normsP _ x Mx) //. + by case: IH => _ _ [_ _]; case/andP. +set Q0 := 'C_Q(D); set Qb := Q / Q0. +have defQD: Q ><| D = Ms by rewrite -defQ in sylQ *; apply/sdprod_Hall_pcoreP. +have [_ mulQD nQD tiQD] := sdprodP defQD; rewrite /= -/Q -/Ms in mulQD nQD tiQD. +have nilD: nilpotent D. + by rewrite (isog_nil (quotient_isog nQD tiQD)) /= -quotientMidl mulQD. +have [sDMs q'D _] := and3P hallD; have sDM := subset_trans sDMs sMsM. +have sDKM: D <*> K \subset M by rewrite join_subG sDM. +have q'DK: q^'.-group (D <*> K) by rewrite norm_joinEr // pgroupM q'D. +have{K1 sK1M sK1K coMsK1 coQK1 prK1 defCMsK1 nQK1 solMs} Qi_rec Qi: + Qi \in |/|_Q(D <*> K; q) -> Q0 \subset Qi -> Qi \proper Q -> + exists L, [/\ L \in |/|_Q(D <*> K; q), Qi <| L, minnormal (L / Qi) (M / Qi) + & ~~ ((Ks \subset L) ==> (Ks \subset Qi))]. +- case/setIdP=> /andP[sQiQ qQi] nQiDK sQ0i ltQiQ. + have ltQiN := nilpotent_proper_norm (pgroup_nil qQ) ltQiQ. + have [Lb minLb sLbQ]: {Lb | minnormal (gval Lb) (M / Qi) & Lb \subset Q / Qi}. + apply: mingroup_exists; rewrite quotient_norms //= andbT -quotientInorm. + by rewrite -subG1 quotient_sub1 ?subsetIr // proper_subn. + have [ntLb nLbM] := andP (mingroupp minLb). + have nsQiN: Qi <| 'N_M(Qi) by rewrite normal_subnorm (subset_trans sQiQ). + have: Lb <| 'N_M(Qi) / Qi. + by rewrite quotientInorm /normal (subset_trans sLbQ) ?quotientS. + case/(inv_quotientN nsQiN) => L defLb sQij /=; case/andP. + case/subsetIP=> sLM nQij nLN; exists L. + have{sLbQ} sLQ: L \subset Q by rewrite -(quotientSGK nQij sQiQ) -defLb. + rewrite inE /psubgroup /normal sLQ sQij nQij (pgroupS sLQ qQ) -defLb. + have nLDK: D <*> K \subset 'N(L) by apply: subset_trans nLN; exact/subsetIP. + have sLD_Ms: L <*> D \subset Ms by rewrite join_subG (subset_trans sLQ). + have coLD_K1: coprime #|L <*> D| #|K1| := coprimeSg sLD_Ms coMsK1. + have [[nQiD nQiK] [nLD nLK]] := (joing_subP nQiDK, joing_subP nLDK). + have [nQiK1 nLK1] := (subset_trans sK1K nQiK, subset_trans sK1K nLK). + split=> //; apply: contra ntLb => regLK. + have [sLLD sDLD] := joing_subP (subxx (L <*> D)). + suffices nilLDbar: nilpotent (L <*> D / Qi). + rewrite defLb -subG1 -(quotientS1 sQ0i) /= -/Q. + rewrite coprime_quotient_cent ?(pgroup_sol qQ) ?(pnat_coprime qQ) //=. + rewrite subsetI quotientS //= (sub_nilpotent_cent2 nilLDbar) ?quotientS //. + by rewrite coprime_morph ?(p'nat_coprime q'D (pgroupS sLQ qQ)). + have defLK1b: (L <*> D / Qi) ><| (K1 / Qi) = (L <*> D / Qi) <*> (K1 / Qi). + rewrite sdprodEY ?coprime_TIg ?quotient_norms //=. + by rewrite (subset_trans sK1K) // normsY. + by rewrite coprime_morph // (coprimeSg sLD_Ms). + have [sQiLD sLD_M] := (subset_trans sQij sLLD, subset_trans sLD_Ms sMsM). + have{regLK}: 'C_(L <*> D / Qi)(K1 / Qi) = 1. + rewrite -coprime_quotient_cent ?(subset_trans sK1K) ?(solvableS sLD_M) //=. + rewrite -(setIidPr sLD_Ms) setIAC defCMsK1 quotientS1 //= -/Ks joingC. + rewrite norm_joinEl // -(setIidPl sKsQ) -setIA -group_modr // tiQD mul1g. + have [-> | ntLKs] := eqVneq (Ks :&: L) 1; first exact: sub1G. + by rewrite subIset ?(implyP regLK) // prime_meetG. + apply: (prime_Frobenius_sol_kernel_nil defLK1b). + by apply: solvableS (quotient_sol _ solM); rewrite join_subG !quotientS. + by rewrite -(card_isog (quotient_isog _ _)) ?coprime_TIg // (coprimeSg sQiQ). +have ltQ0Q: Q0 \proper Q. + rewrite properEneq subsetIl andbT; apply: contraNneq not_nilMs => defQ0. + rewrite -dprodEsd // in defQD; last by rewrite centsC -defQ0 subsetIr. + by rewrite (dprod_nil defQD) (pgroup_nil qQ). +have [nQK coQK] := (subset_trans sKM nQM, pnat_coprime qQ q'K). +have solQ := pgroup_sol qQ. (* must come late: Coq diverges on solQ <> solMs *) +have [coDK coQD] := (coprimeSg sDMs coMsK, pnat_coprime qQ q'D). +have nQ0K: K \subset 'N(Q0) by rewrite normsI ?norms_cent. +have nQ0D: D \subset 'N(Q0) by rewrite cents_norm // centsC subsetIr. +have nQ0DK: D <*> K \subset 'N(Q0) by apply/joing_subP. +have [|Q1 [DKinvQ1 nsQ01 minQ1b nregQ1b]] := Qi_rec _ _ (subxx _) ltQ0Q. + by rewrite inE /psubgroup (pgroupS _ qQ) ?subsetIl. +have{Qi_rec nregQ1b DKinvQ1} [tiQ0Ks defQ1]: Q0 :&: Ks = 1 /\ Q1 :=: Q. + move: nregQ1b; rewrite negb_imply; case/andP=> sKsQ1 not_sKsQ0. + split=> //; first by rewrite setIC prime_TIg. + have [] := setIdP DKinvQ1; case/andP; case/eqVproper=> // ltQ1Q _ _. + have [Q2 [_ _ _]] := Qi_rec Q1 DKinvQ1 (normal_sub nsQ01) ltQ1Q. + by rewrite sKsQ1 implybT. +have [nsQ0Q minQb]: Q0 <| Q /\ minnormal Qb (M / Q0) by rewrite /Qb -defQ1. +have{Q1 defQ1 minQ1b nsQ01} abelQb: q.-abelem Qb. + have qQb: q.-group Qb := quotient_pgroup _ qQ; have solQb := pgroup_sol qQb. + by rewrite -is_abelem_pgroup // (minnormal_solvable_abelem minQb). +have [cQbQb [sQ0Q nQ0Q]] := (abelem_abelian abelQb, andP nsQ0Q). +have nQ0M: M \subset 'N(Q0) by rewrite -mulMsK -mulQD -mulgA !mul_subG. +have nsQ0M: Q0 <| M by rewrite /normal subIset ?sQM. +have sFM_QCQ: 'F(M) \subset Q <*> 'C_M(Q). + have [_ /= mulQQ' cQQ' _] := dprodP (nilpotent_pcoreC q (Fitting_nil M)). + rewrite -{3}mulQQ' p_core_Fitting cent_joinEr ?subsetIr //= -/Q in cQQ' *. + by rewrite mulgS // subsetI (subset_trans (pcore_sub _ _) (Fitting_sub M)). +have sQCQ_CMsQb: Q <*> 'C_M(Q) \subset 'C_Ms(Qb | 'Q). + rewrite join_subG !(subsetI _ Ms) sQMs /= !sub_astabQ nQ0Q /= -/Q0 -/Qb. + rewrite -abelianE cQbQb quotient_cents ?subsetIr //= andbC subIset ?nQ0M //=. + rewrite -(coprime_mulG_setI_norm mulMsK) ?norms_cent //= -/Ms. + suffices ->: 'C_K(Q) = 1 by rewrite mulg1 subsetIl. + have: ~~ (Q \subset Ks); last apply: contraNeq => ntCKQ. + have [_ _ _ [_]] := Ptype_structure PmaxM hallK. + by move/(_ q); rewrite pi_of_prime //; case/(_ (eqxx q) _ sylQ_M). + rewrite -[Ks](cent_semiprime prMsK _ ntCKQ) ?subsetIl //. + by rewrite subsetI sQMs centsC subsetIr. +have nCQb: M \subset 'N('C(Qb | 'Q)). + by rewrite (subset_trans _ (astab_norm _ _)) ?actsQ. +have defFM: 'C_Ms(Qb | 'Q) = 'F(M). + apply/eqP; rewrite eqEsubset andbC (subset_trans sFM_QCQ) //=. + rewrite Fitting_max //=; first by rewrite /normal subIset ?sMsM //= normsI. + rewrite -(coprime_mulG_setI_norm mulQD) ?(subset_trans sMsM) //= -/Q. + rewrite mulg_nil ?(nilpotentS (subsetIl _ _)) ?(pgroup_nil qQ) //= -/Q. + rewrite (centsS (subsetIl _ _)) //= -/Q. + have cDQ0: 'C_D(Qb | 'Q) \subset 'C(Q0) by rewrite subIset // centsC subsetIr. + rewrite (stable_factor_cent cDQ0) ?(coprimegS (subsetIl _ _) coQD) //. + by rewrite /stable_factor commGC -sub_astabQR ?subsetIr // subIset ?nQ0D. +have{sFM_QCQ sQCQ_CMsQb} ->: Q <*> 'C_M(Q) = 'F(M). + by apply/eqP; rewrite eqEsubset sFM_QCQ andbT -defFM. +have ltFM_Ms: 'F(M) \proper Ms. + rewrite properEneq -{2}defFM subsetIl andbT. + by apply: contraNneq not_nilMs => <-; apply: Fitting_nil. +have sQFM: Q \subset 'F(M) by rewrite -[Q]p_core_Fitting pcore_sub. +have not_cDQb: ~~ (D / Q0 \subset 'C(Qb)). + apply: contra (proper_subn ltFM_Ms) => cDQb; rewrite -mulQD mulG_subG sQFM /=. + by rewrite -defFM subsetI sDMs sub_astabQ nQ0D. +have [_ minQbP] := mingroupP minQb. +have regQbDb: 'C_Qb(D / Q0) = 1. + apply: contraNeq not_cDQb => ntCQDb; rewrite centsC; apply/setIidPl. + apply: minQbP (subsetIl _ _); rewrite ntCQDb /= -/Qb -(setIidPl cQbQb) -setIA. + by rewrite -centM -quotientMl //= mulQD normsI ?norms_cent ?quotient_norms. +have tiQ0 R: q^'.-group R -> Q0 :&: R = 1. + by move/(pnat_coprime (pgroupS sQ0Q qQ))/coprime_TIg. +have oKb: #|K / Q0| = p by rewrite -(card_isog (quotient_isog _ (tiQ0 _ _))). +have oKsb: #|Ks / Q0| = q. + by rewrite -(card_isog (quotient_isog _ tiQ0Ks)) ?(subset_trans sKsQ). +have regDK: 'C_D(K) = 1. + by rewrite -(setIidPl sDMs) -setIA setIC coprime_TIg ?(coprimeSg sKsQ). +have{tiQ0} frobDKb: [Frobenius D <*> K / Q0 = (D / Q0) ><| (K / Q0)]. + have ntDb: D / Q0 != 1 by apply: contraNneq not_cDQb => ->; apply: sub1G. + have ntKb: K / Q0 != 1 by rewrite -(isog_eq1 (quotient_isog _ (tiQ0 _ _))). + apply/Frobenius_semiregularP => // [|xb]. + by apply: quotient_coprime_sdprod; rewrite ?sdprodEY ?coprime_TIg. + have [f [_ ker_f _ im_f]] := restrmP (coset_morphism Q0) nQ0DK. + have{ker_f} inj_f: 'injm f by rewrite ker_f ker_coset setIC tiQ0. + rewrite /= /quotient -!im_f ?joing_subl ?joing_subr //. + rewrite 2!inE andbC => /andP[/morphimP[x DKx Kx ->{xb}]]. + rewrite morph_injm_eq1 // -injm_subcent1 ?joing_subl // => ntx. + rewrite -{3}(setIidPl sDMs) -setIA prMsK ?inE ?ntx //. + by rewrite setICA regDK setIg1 morphim1. +have defKsb: 'C_Qb(K / Q0) = Ks / Q0. + rewrite /Ks -mulQD coprime_cent_mulG // regDK mulg1. + by rewrite coprime_quotient_cent ?subsetIl. +have{frobDKb regQbDb} [p_pr oQb cQbD']: + [/\ prime p, #|Qb| = (q ^ p)%N & (D / Q0)^`(1) \subset 'C(Qb)]. +- have ntQb: Qb != 1 by rewrite -subG1 quotient_sub1 ?proper_subn. + have prQbK: semiprime Qb (K / Q0). + move=> xb; rewrite 2!inE andbC; case/andP; case/morphimP=> x nQ0x Kx -> ntx. + have{ntx} ntx: x != 1 by apply: contraNneq ntx => ->; rewrite morph1. + transitivity ('C_Q[x] / Q0); last first. + rewrite -(coprime_quotient_cent (subsetIl Q _) nQ0K coQK solQ) /= -/Q0. + by rewrite -/Q -(setIidPl sQMs) -!setIA prMsK // !inE ntx. + rewrite -!cent_cycle -quotient_cycle //; rewrite -!cycle_subG in Kx nQ0x. + by rewrite coprime_quotient_cent ?(coprimegS Kx). + have:= Frobenius_primact frobDKb _ _ _ ntQb _ prQbK regQbDb. + have [nQDK solDK] := (subset_trans sDKM nQM, solvableS sDKM solM). + rewrite !quotient_sol ?quotient_norms // coprime_morph ?(pnat_coprime qQ) //=. + rewrite -/Qb oKb defKsb prime_cyclic oKsb // subsetI der_sub /=. + by case=> //= -> -> ->. +have{cQbD'} sM''FM: M'' \subset 'F(M). + have nQMs := subset_trans sMsM nQM. + rewrite [M'']dergSn -/M' -defMs -(quotientSGK _ sQFM) ?comm_subG //. + rewrite (quotient_der 1) //= -/Ms -mulQD quotientMidl -quotient_der //= -/Q. + by rewrite quotientS // -defFM subsetI sub_astabQ !comm_subG ?quotient_der. +have sQ0Ms := subset_trans sQ0Q sQMs. +have ->: 'C_Ms(Ks / Q0 | 'Q) = 'F(M). + have sFMcKsb: 'F(M) \subset 'C_Ms(Ks / Q0 | 'Q). + by rewrite -defFM setIS ?astabS ?quotientS. + have nCMsKsbM: M \subset 'N('C_Ms(Ks / Q0 | 'Q)). + rewrite -{1}mulMsK mulG_subG sub_der1_norm ?subsetIl //= -/Ms; last first. + by rewrite {1}defMs (subset_trans sM''FM sFMcKsb). + rewrite normsI // (subset_trans _ (astab_norm _ _)) ?actsQ //. + by rewrite cents_norm // centsC subsetIr. + apply/eqP; rewrite eqEsubset sFMcKsb -defFM subsetI subsetIl. + rewrite sub_astabQ /= -/Q0 subIset ?(subset_trans sMsM) //= andbT centsC. + apply/setIidPl; apply: minQbP (subsetIl _ _). + rewrite andbC normsI ?norms_cent ?quotient_norms //= -/Qb. + have: Ks / Q0 != 1 by rewrite -cardG_gt1 oKsb prime_gt1. + apply: subG1_contra; rewrite (quotientGI _ sQ0Ms) quotient_astabQ /= -/Q0. + by rewrite subsetI quotientS // centsC subsetIr. +have ->: 'C_M(Qb | 'Q) = 'F(M). + apply/eqP; rewrite eqEsubset -{2}defFM setSI //= andbT. + rewrite -(coprime_mulG_setI_norm mulMsK) //= -defFM mulG_subG subxx /=. + rewrite subsetI subsetIr -(quotientSGK _ sQ0Ms) 1?subIset ?nQ0K //= -/Q0. + rewrite quotientIG; last by rewrite sub_astabQ normG trivg_quotient sub1G. + rewrite quotient_astabQ /= -/Q0 prime_TIg ?sub1G ?oKb //. + rewrite centsC -subsetIidl defKsb; apply: contra (@subset_leq_card _ _ _) _. + by rewrite -ltnNge oQb oKsb (ltn_exp2l 1) prime_gt1. +suffices ->: q \in \beta(M) by do 2!split=> //; last rewrite {1}defMs. +apply: contraR not_cDQb; rewrite negb_forall_in; case/exists_inP=> Q1 sylQ1. +rewrite negbK {Q1 sylQ1}(eq_Hall_pcore sylQ_M sylQ1) -/Q => nnQ. +have sD_DK': D \subset (D <*> K)^`(1). + rewrite -{1}(coprime_cent_prod nDK) ?nilpotent_sol // regDK mulg1. + by rewrite commgSS ?joing_subl ?joing_subr. +rewrite quotient_cents // (subset_trans sD_DK') //. +have nQDK := subset_trans sDKM nQM; have nCQDK := norms_cent nQDK. +rewrite der1_min // -(isog_abelian (second_isog nCQDK)) setIC /=. +rewrite -ker_conj_aut (isog_abelian (first_isog_loc _ _)) //=; set A := _ @* _. +have norm_q := normal_norm (pcore_normal q _). +rewrite {norm_q}(isog_abelian (quotient_isog (norm_q _ _) _)) /=; last first. + by rewrite coprime_TIg ?coprime_morphr //= (pnat_coprime (pcore_pgroup q _)). +have AutA: A \subset [Aut Q] := Aut_conj_aut _ _. +have [|//] := Aut_narrow qQ (mFT_odd _) nnQ _ AutA (morphim_odd _ (mFT_odd _)). +exact: morphim_sol (solvableS sDKM solM). +Qed. + +(* This is B & G, Corollary 15.3(a). *) +Corollary cent_Hall_sigma_sdprod M H pi : + M \in 'M -> pi.-Hall(M`_\sigma) H -> H :!=: 1 -> + exists X, [/\ gval X \subset M, cyclic X, \tau2(M).-group X + & 'C_(M`_\sigma)(H) ><| X = 'C_M(H)]. +Proof. +move=> maxM hallH ntH; have hallMs := Msigma_Hall maxM. +have nsMsM: M`_\sigma <| M := pcore_normal _ M; have [sMsM nMsM] := andP nsMsM. +have sMs := pHall_pgroup hallMs; have [sHMs piH _] := and3P hallH. +have k'CH: \kappa(M)^'.-group 'C_M(H). + apply/idPn; rewrite negb_and cardG_gt0 all_predC negbK => /hasP[p piCHp kMp]. + have PmaxM: M \in 'M_'P by apply/PtypeP; split; last exists p. + have [X]: exists X, X \in 'E_p^1('C_M(H)). + by apply/p_rank_geP; rewrite p_rank_gt0. + case/pnElemP; case/subsetIP=> sXM cHX abelX dimX; have [pX _] := andP abelX. + have [K hallK sXK] := Hall_superset (mmax_sol maxM) sXM (pi_pgroup pX kMp). + have E1X: X \in 'E^1(K) by apply/nElemP; exists p; apply/pnElemP. + have [q q_pr rqH] := rank_witness H; have [S sylS] := Sylow_exists q H. + have piSq: q \in \pi(S). + by rewrite -p_rank_gt0 (p_rank_Sylow sylS) -rqH rank_gt0. + have [_ [defNK defNX] _ [_ not_sylCP _] _] := Ptype_structure PmaxM hallK. + have{defNX} [defNX _] := defNX X E1X. + have [[_ nsKs] [_ mulKKs _ _]] := (dprod_normal2 defNK, dprodP defNK). + have s'K := sub_pgroup (@kappa_sigma' _ _) (pHall_pgroup hallK). + have [_ hallKs] := coprime_mulGp_Hall mulKKs s'K (pgroupS (subsetIl _ _) sMs). + have [sSH _] := andP sylS. + have sylS_Ms := subHall_Sylow hallH (pnatPpi piH (piSg sSH piSq)) sylS. + have [sSMs _] := andP sylS_Ms; have sS := pgroupS sSMs sMs. + have sylS_M := subHall_Sylow hallMs (pnatPpi sS piSq) sylS_Ms. + have sSKs: S \subset 'C_(M`_\sigma)(K). + rewrite (sub_normal_Hall hallKs) //= -defNX subsetI (pHall_sub sylS_M) /=. + by rewrite cents_norm // centsC (centsS sSH). + by have [_ /negP] := not_sylCP q (piSg sSKs piSq) S sylS_M. +have solCH := solvableS (subsetIl M 'C(H)) (mmax_sol maxM). +have [X hallX] := Hall_exists \sigma(M)^' solCH; exists X. +have nsCsH: 'C_(M`_\sigma)(H) <| 'C_M(H) by rewrite /normal setSI // normsIG. +have hallCs: \sigma(M).-Hall('C_M(H)) 'C_(M`_\sigma)(H). + by rewrite -(setIidPl sMsM) -setIA (setI_normal_Hall nsMsM) ?subsetIl. +rewrite (sdprod_normal_p'HallP nsCsH hallX hallCs). +have [-> | ntX] := eqsVneq X 1; first by rewrite sub1G cyclic1 pgroup1. +have [sXCH s'X _] := and3P hallX; have [sXM cHX] := subsetIP sXCH. +have sk'X: \sigma_kappa(M)^'.-group X. + apply/pgroupP=> p p_pr p_dv_X; apply/norP=> /=. + by split; [apply: (pgroupP s'X) | apply: (pgroupP (pgroupS sXCH k'CH))]. +have [K hallK] := Hall_exists \kappa(M) (mmax_sol maxM). +have [U complU] := ex_kappa_compl maxM hallK; have [hallU _ _] := complU. +have [a Ma sXaU] := Hall_Jsub (mmax_sol maxM) hallU sXM sk'X. +have [_ _ cycX _ _] := kappa_structure maxM complU. +rewrite -(cyclicJ _ a) -(pgroupJ _ _ a); have [||//] := cycX _ sXaU. + by rewrite -(isog_eq1 (conj_isog X a)). +rewrite -(normsP nMsM a Ma) centJ -conjIg -(isog_eq1 (conj_isog _ a)). +by rewrite (subG1_contra _ ntH) // subsetI sHMs centsC. +Qed. + +(* This is B & G, Corollary 15.3(b). *) +Corollary sigma_Hall_tame M H pi x a : + M \in 'M -> pi.-Hall(M`_\sigma) H -> x \in H -> x ^ a \in H -> + exists2 b, b \in 'N_M(H) & x ^ a = x ^ b. +Proof. +move=> maxM hallH Hx Hxa; have [sHMs piH _] := and3P hallH. +have SMxM: M \in 'M_\sigma[x] by rewrite inE maxM cycle_subG (subsetP sHMs). +have SMxMa: (M :^ a^-1)%G \in 'M_\sigma[x]. + by rewrite inE mmaxJ maxM cycle_subG /= MsigmaJ mem_conjgV (subsetP sHMs). +have [-> | ntx] := eqVneq x 1; first by exists 1; rewrite ?group1 ?conj1g. +have ell1x: \ell_\sigma(x) == 1%N. + by apply/ell_sigma1P; split=> //; apply/set0Pn; exists M. +have ntH: H :!=: 1 by apply/trivgPn; exists x. +have [[transR _ _ _] _] := FT_signalizer_context ell1x. +have [c Rc defMc] := atransP2 transR SMxM SMxMa. +pose b := c * a; have def_xa: x ^ a = x ^ b. + by have [_ cxc] := setIP Rc; rewrite conjgM {3}/conjg -(cent1P cxc) mulKg. +have Mb: b \in M. + by rewrite -(norm_mmax maxM) inE conjsgM -(congr_group defMc) actKV. +have nsMsM: M`_\sigma <| M := pcore_normal _ _; have [sMsM _] := andP nsMsM. +have [nsHM | not_nsHM] := boolP (H <| M). + by exists b; rewrite // (mmax_normal maxM) ?setIid. +have neqMFs: M`_\F != M`_\sigma. + apply: contraNneq not_nsHM => eq_MF_Ms. + have nilMs: nilpotent M`_\sigma by apply/Fcore_eq_Msigma. + rewrite (eq_Hall_pcore (nilpotent_pcore_Hall _ nilMs) hallH). + exact: char_normal_trans (pcore_char _ _) nsMsM. +have [K hallK] := Hall_exists \kappa(M) (mmax_sol maxM). +pose q := #|'C_(M`_\sigma)(K)|. +have [D hallD] := Hall_exists q^' (solvableS sMsM (mmax_sol maxM)). +have [[_ sMFs _ _]] := Fcore_structure maxM; case/(_ K D) => //; rewrite -/q. +set Q := 'O_q(M) => _ [_ q_pr piMFq _] [sylQ nilD _] _ _. +have sQMs: Q \subset M`_\sigma. + by apply: subset_trans sMFs; rewrite -[Q](p_core_Fcore piMFq) pcore_sub. +have sylQ_Ms: q.-Hall(M`_\sigma) Q := pHall_subl sQMs sMsM sylQ. +have nsQM: Q <| M := pcore_normal q M; have [_ qQ _] := and3P sylQ. +have nsQ_Ms: Q <| M`_\sigma := normalS sQMs sMsM nsQM. +have defMs: Q ><| D = M`_\sigma := sdprod_normal_p'HallP nsQ_Ms hallD sylQ_Ms. +have [_ mulQD nQD tiQD] := sdprodP defMs; rewrite -/Q in mulQD nQD tiQD. +have nQH := subset_trans sHMs (normal_norm nsQ_Ms). +have nsQHM: Q <*> H <| M. + rewrite -(quotientGK nsQM) -quotientYK // cosetpre_normal //= -/Q. + have nilMsQ: nilpotent (M`_\sigma / Q). + by rewrite -mulQD quotientMidl -(isog_nil (quotient_isog _ _)). + have hallMsQpi := nilpotent_pcore_Hall pi nilMsQ. + rewrite (eq_Hall_pcore hallMsQpi (quotient_pHall nQH hallH)). + by rewrite (char_normal_trans (pcore_char _ _)) ?quotient_normal. +have tiQH: Q :&: H = 1. + apply: coprime_TIg (p'nat_coprime (pi_pgroup qQ _) piH). + apply: contra not_nsHM => pi_q; rewrite (joing_idPr _) // in nsQHM. + by rewrite (normal_sub_max_pgroup (Hall_max hallH)) ?(pi_pgroup qQ). +have defM: Q * 'N_M(H) = M. + have hallH_QH: pi.-Hall(Q <*> H) H. + by rewrite (pHall_subl (joing_subr _ _) _ hallH) // join_subG sQMs. + have solQH := solvableS (normal_sub nsQHM) (mmax_sol maxM). + rewrite -{2}(Hall_Frattini_arg solQH nsQHM hallH_QH) /= norm_joinEr //. + by rewrite -mulgA [H * _]mulSGid // subsetI (subset_trans sHMs sMsM) normG. +move: Mb; rewrite -{1}defM; case/mulsgP=> z n Qz Nn defb; exists n => //. +rewrite def_xa defb conjgM [x ^ z](conjg_fixP _) // -in_set1 -set1gE -tiQH. +rewrite inE {1}commgEr groupMr // -mem_conjgV groupV /=. +rewrite (normsP (normal_norm nsQM)) ?Qz; last first. + by rewrite groupV (subsetP sMsM) // (subsetP sHMs). +rewrite commgEl groupMl ?groupV //= -(conjsgK n H) mem_conjgV -conjgM -defb. +by have [_ nHn] := setIP Nn; rewrite (normP nHn) -def_xa. +Qed. + +(* This is B & G, Corollary 15.4. *) +(* This result does not appear to be needed for the actual proof. *) +Corollary nilpotent_Hall_sigma H : + nilpotent H -> Hall G H -> exists2 M, M \in 'M & H \subset M`_\sigma. +Proof. +move=> nilH /Hall_pi/=hallH; have [_ piH _] := and3P hallH. +have [-> | ntH] := eqsVneq H 1. + by have [M maxM] := any_mmax gT; exists M; rewrite ?sub1G. +pose p := pdiv #|H|; have piHp: p \in \pi(H) by rewrite pi_pdiv cardG_gt1. +pose S := 'O_p(H)%G; have sylS: p.-Sylow(H) S := nilpotent_pcore_Hall p nilH. +have [sSH pS _] := and3P sylS. +have ntS: S :!=: 1 by rewrite -rank_gt0 (rank_Sylow sylS) p_rank_gt0. +have [M maxNM] := mmax_exists (mFT_norm_proper ntS (mFT_pgroup_proper pS)). +have [maxM sNM] := setIdP maxNM; exists M => //. +have sSM: S \subset M := subset_trans (normG _) sNM. +have sylS_G := subHall_Sylow hallH (pnatPpi piH piHp) sylS. +have sylS_M := pHall_subl sSM (subsetT M) sylS_G. +have sMp: p \in \sigma(M) by apply/exists_inP; exists S. +have sSMs: S \subset M`_\sigma. + by rewrite (sub_Hall_pcore (Msigma_Hall maxM)) ?(pi_pgroup pS). +rewrite -(nilpotent_Fitting nilH) FittingEgen gen_subG. +apply/bigcupsP=> [[q /= _] piHq]; have [-> // | p'q] := eqVneq q p. +have sylS_Ms := pHall_subl sSMs (pcore_sub _ _) sylS_M. +have [X [_ cycX t2X defCS]] := cent_Hall_sigma_sdprod maxM sylS_Ms ntS. +have{defCS} [nCMsCS _ defCS _ _] := sdprod_context defCS. +have t2'CMs: \tau2(M)^'.-group 'C_(M`_\sigma)(S). + apply: pgroupS (subsetIl _ _) (sub_pgroup _ (pcore_pgroup _ _)) => r. + by apply: contraL => /andP[]. +have [hallCMs hallX] := coprime_mulGp_Hall defCS t2'CMs t2X. +have sHqCS: 'O_q(H) \subset 'C_M(S). + rewrite (setIidPr (subset_trans (cent_sub _) sNM)). + rewrite (sub_nilpotent_cent2 nilH) ?pcore_sub //. + exact: pnat_coprime pS (pi_pgroup (pcore_pgroup _ _) _). +have [t2q | t2'q] := boolP (q \in \tau2(M)); last first. + apply: subset_trans (subsetIl _ 'C(S)). + by rewrite (sub_normal_Hall hallCMs) // (pi_pgroup (pcore_pgroup _ _)). +have sylHq := nilpotent_pcore_Hall q nilH. +have sylHq_G := subHall_Sylow hallH (pnatPpi piH piHq) sylHq. +have sylHq_CS := pHall_subl sHqCS (subsetT _) sylHq_G. +have [Q sylQ] := Sylow_exists q X; have [sQX _] := andP sylQ. +have sylQ_CS := subHall_Sylow hallX t2q sylQ. +case/andP: t2q => _. +rewrite eqn_leq andbC ltnNge (leq_trans (p_rankS q (subsetT _))) //. +rewrite -(rank_Sylow sylHq_G) (rank_Sylow sylHq_CS) -(rank_Sylow sylQ_CS). +by rewrite (leq_trans (rankS sQX)) // -abelian_rank1_cyclic ?cyclic_abelian. +Qed. + +(* This is B & G, Corollary 15.5. *) +(* We have changed the condition K != 1 to the equivalent M \in 'M_'P, as *) +(* avoids a spurrious quantification on K. *) +(* The text is quite misleading here, since Corollary 15.3(a) is needed for *) +(* bith the nilpotent and the non-nilpotent case -- indeed, it is not really *) +(* needed in the non-nilpotent case! *) +Corollary Fitting_structure M (H := M`_\F) (Y := 'O_\sigma(M)^'('F(M))) : + M \in 'M -> + [/\ (*a*) cyclic Y /\ \tau2(M).-group Y, + (*b*) [/\ M^`(2) \subset 'F(M), + H \* 'C_M(H) = 'F(M) + & 'F(M`_\sigma) \x Y = 'F(M)], + (*c*) H \subset M^`(1) /\ nilpotent (M^`(1) / H) + & (*d*) M \in 'M_'P -> 'F(M) \subset M^`(1)]. +Proof. +move=> maxM; have nilF := Fitting_nil M. +have sHF: H \subset 'F(M) := Fcore_sub_Fitting M. +have nsMsM: M`_\sigma <| M := pcore_normal _ _; have [sMsM nMsM] := andP nsMsM. +have sMs: \sigma(M).-group M`_\sigma := pcore_pgroup _ _. +have nsFM: 'F(M) <| M := Fitting_normal M; have [sFM nFM] := andP nsFM. +have sYF: Y \subset 'F(M) := pcore_sub _ _; have sYM := subset_trans sYF sFM. +have defF: 'F(M`_\sigma) \x Y = 'F(M). + rewrite -(nilpotent_pcoreC \sigma(M) nilF); congr (_ \x _). + apply/eqP; rewrite eqEsubset pcore_max ?(pgroupS (Fitting_sub _)) //=. + rewrite Fitting_max ?(nilpotentS (pcore_sub _ _)) //=. + by rewrite -(pcore_setI_normal _ nsFM) norm_normalI ?(subset_trans sMsM). + rewrite /normal (char_norm_trans (Fitting_char _)) ?(subset_trans sFM) //. + by rewrite Fitting_max ?Fitting_nil // (char_normal_trans (Fitting_char _)). +have [[ntH sHMs sMsM' _] nnil_struct] := Fcore_structure maxM. +have hallH: \pi(H).-Hall(M`_\sigma) H := pHall_subl sHMs sMsM (Fcore_Hall M). +have [X [_ cycX t2X defCH]] := cent_Hall_sigma_sdprod maxM hallH ntH. +have hallX: \sigma(M)^'.-Hall('C_M(H)) X. + have [_ mulCsH_X _ _] := sdprodP defCH. + have [|//] := coprime_mulpG_Hall mulCsH_X (pgroupS (subsetIl _ _) sMs). + by apply: sub_pgroup t2X => p /andP[]. +have sYX: Y \subset X. + rewrite (normal_sub_max_pgroup (Hall_max hallX)) ?pcore_pgroup //. + rewrite /normal (char_norm_trans (pcore_char _ _)) ?subIset ?nFM //= -/Y. + have [_ _ cFsY _] := dprodP defF. + rewrite subsetI sYM (sub_nilpotent_cent2 nilF) //= -/Y -/H. + exact: pnat_coprime (pgroupS sHMs sMs) (pcore_pgroup _ _). +have [cycY t2Y]: cyclic Y /\ \tau2(M).-group Y. + by rewrite (cyclicS sYX cycX) (pgroupS sYX t2X). +have [K hallK] := Hall_exists \kappa(M) (mmax_sol maxM). +have [U complU] := ex_kappa_compl maxM hallK. +have [[defM _ cM'M'b] defM' _ _ _] := kappa_structure maxM complU. +have d_holds: M \in 'M_'P -> 'F(M) \subset M^`(1). + rewrite inE maxM andbT -(trivg_kappa maxM hallK) => ntK. + rewrite -(dprodW defF) mulG_subG (subset_trans (Fitting_sub _)) //= -/Y. + have{defM'} [[defM' _] nsM'M] := (defM' ntK, der_normal 1 M). + have hallM': \kappa(M)^'.-Hall(M) M^`(1). + by apply/(sdprod_normal_pHallP nsM'M hallK); rewrite /= -defM'. + rewrite (sub_normal_Hall hallM') ?(sub_pgroup _ t2Y) // => p. + by case/andP=> _; apply: contraL => /rank_kappa->. +have defF_H: 'C_M(H) \subset 'F(M) -> H \* 'C_M(H) = 'F(M). + move=> sCHF; apply/eqP; rewrite cprodE ?subsetIr // eqEsubset ?mul_subG //=. + have hallH_F := pHall_subl sHF sFM (Fcore_Hall M). + have nsHF := normalS sHF sFM (Fcore_normal M). + have /dprodP[_] := nilpotent_pcoreC \pi(H) nilF. + rewrite (normal_Hall_pcore hallH_F nsHF) /= -/H => defF_H cHFH' _. + by rewrite -defF_H mulgS // subsetI (subset_trans (pcore_sub _ _)). +have [eqHMs | neqHMs] := eqVneq H M`_\sigma. + split=> //; [split=> // | by rewrite eqHMs abelian_nil]. + by rewrite (subset_trans _ sHF) //= eqHMs der1_min ?comm_subG. + rewrite defF_H // -(sdprodW defCH) -eqHMs mulG_subG subIset ?sHF //=. + rewrite Fitting_max ?abelian_nil ?cyclic_abelian //. + rewrite -(normal_Hall_pcore hallX) ?(char_normal_trans (pcore_char _ _)) //. + by rewrite norm_normalI // eqHMs norms_cent. + move: defCH; rewrite -dprodEsd; first by case/dprod_normal2. + by rewrite -eqHMs (centsS (subsetIl _ _)); case/subsetIP: (pHall_sub hallX). +pose q := #|'C_(M`_\sigma)(K)|; pose Q := 'O_q(M). +have [D hallD] := Hall_exists q^' (solvableS sMsM (mmax_sol maxM)). +case/(_ K D): nnil_struct => //=; rewrite -/H -/q -/Q. +move=> [_ _ defMs] [_ _ piHq _] [sylQ nilD _] _ [_ -> [defF_Q _ _] _]. +have sQH: Q \subset H by rewrite -[Q](p_core_Fcore piHq) pcore_sub. +split=> //; rewrite -?{}defMs; split=> //. + by rewrite defF_H // -defF_Q joingC sub_gen // subsetU ?setIS ?centS. +have sQMs := subset_trans sQH sHMs; have sylQ_Ms := pHall_subl sQMs sMsM sylQ. +have nsQ_Ms: Q <| M`_\sigma := normalS sQMs sMsM (pcore_normal _ _). +have defMs: Q ><| D = M`_\sigma := sdprod_normal_p'HallP nsQ_Ms hallD sylQ_Ms. +have [_ <- _ _] := sdprodP defMs; rewrite -quotientMidl mulgA (mulGSid sQH). +by rewrite quotientMidl quotient_nil. +Qed. + +(* This is B & G, Corollary 15.6. *) +(* Note that the proof of the F-core noncyclicity given in the text only *) +(* applies to the nilpotent case, and we need to use a different assertion of *) +(* 15.2 if Msigma is not nilpotent. *) +Corollary Ptype_cyclics M K (Ks := 'C_(M`_\sigma)(K)) : + M \in 'M_'P -> \kappa(M).-Hall(M) K -> + [/\ Ks != 1, cyclic Ks, Ks \subset M^`(2), Ks \subset M`_\F + & ~~ cyclic M`_\F]. +Proof. +move=> PmaxM hallK; have [ntK maxM] := setIdP PmaxM. +rewrite -(trivg_kappa maxM hallK) in ntK. +have [_ _ [ntKs _] _ _] := Ptype_structure PmaxM hallK. +have [_ _ [_ _ _ [cycZ _ _ _ _] [_ _ _ defM]]] := Ptype_embedding PmaxM hallK. +have{cycZ} cycKs: cyclic Ks := cyclicS (joing_subr _ _) cycZ. +have solM': solvable M^`(1) := solvableS (der_sub 1 M) (mmax_sol maxM). +have sMsM' := Msigma_der1 maxM. +have{defM} sKsM'': Ks \subset M^`(2). + have coM'K: coprime #|M^`(1)| #|K|. + by rewrite (coprime_sdprod_Hall_r defM) (pHall_Hall hallK). + have [_] := coprime_der1_sdprod defM coM'K solM' (subxx _). + exact: subset_trans (setSI _ sMsM'). +have [eqMFs | neqMFs] := eqVneq M`_\F M`_\sigma. + split=> //; rewrite eqMFs ?subsetIl //; apply: contra ntKs => cycMs. + rewrite -subG1 (subset_trans sKsM'') // (sameP trivgP derG1P) /= -derg1. + have cycF: cyclic 'F(M). + have [[cycY _] [_ _ defF] _ _] := Fitting_structure maxM. + have [[x defMs] [y defY]] := (cyclicP cycMs, cyclicP cycY). + rewrite defMs (nilpotent_Fitting (abelian_nil (cycle_abelian _))) in defF. + have [_ mulXY cxy _] := dprodP defF. + rewrite -mulXY defY -cycleM ?cycle_cyclic //. + by apply/cent1P; rewrite -cycle_subG sub_cent1 -cycle_subG -defY. + by rewrite /order -defMs -defY coprime_pcoreC. + apply: abelianS (cyclic_abelian cycF). + apply: subset_trans (cent_sub_Fitting (mmax_sol maxM)). + rewrite der1_min ?normsI ?normG ?norms_cent ?gFnorm //=. + rewrite -ker_conj_aut (isog_abelian (first_isog_loc _ _)) ?gFnorm //=. + exact: abelianS (Aut_conj_aut _ _) (Aut_cyclic_abelian cycF). +have [D hallD] := Hall_exists #|Ks|^' (solvableS sMsM' solM'). +have [_ /(_ K D)[]//=] := Fcore_structure maxM; rewrite -/Ks. +set q := #|Ks|; set Q := 'O_q(M) => _ [_ q_pr piMFq bMq] [sylQ _ _] _ _. +have sQMF: Q \subset M`_\F by rewrite -[Q]p_core_Fcore ?pcore_sub. +have qKs: q.-group Ks := pnat_id q_pr. +have sKsM := subset_trans sKsM'' (der_sub 2 M). +split=> //; first by apply: subset_trans sQMF; rewrite (sub_Hall_pcore sylQ). +apply: contraL (beta_sub_alpha bMq) => /(cyclicS sQMF)cycQ; rewrite -leqNgt. +by rewrite leqW // -(rank_Sylow sylQ) -abelian_rank1_cyclic ?cyclic_abelian. +Qed. + +(* This is B & G, Theorem 15.7. *) +(* We had to change the statement of the Theorem, because the first equality *) +(* of part (c) does not appear to be valid: if M is of type F, we know very *) +(* little of the action E1 on the Sylow subgroups of E2, and so E2 might have *) +(* a Sylow subgroup that meets F(M) but is also centralised by E1 and hence *) +(* intesects M' trivially; luckily, only the inclusion M' \subset F(M) seems *) +(* to be needed in the sequel. *) +(* We have also restricted the quantification on the Ei to part (c), and *) +(* factored and simplified some of the assertions of parts (e2) and (e3); it *) +(* appears they could perhaps be simplified futher, since the assertions on *) +(* Op(H) and Op'(H) do not appear to be used in the Peterfalvi revision of *) +(* the character theory part of the proof. *) +(* Proof notes: we had to correct/complete several arguments of the B & G *) +(* text. The use of 12.6(d) for parts (c) and (d), p. 120, l. 5 from the *) +(* bottom, is inapropriate as tau2 could be empty. The assertion X1 != Z0 on *) +(* l. 5, p. 121 needs to be strengthened to ~~ (X1 \subset Z0) in order to *) +(* prove that #|Z0| is prime -- only then are the assertions equivalent. The *) +(* use of Lemma 10.13(b), l. 7, p. 121, requires that B be maximal in G, not *) +(* only in P as is stated l. 6; proving the stronger assertion requires using *) +(* Corollary 15.3(b), which the text does not mention. The regularity *) +(* property stated l. 11-13 is too weak to be used in the type P1 case -- the *) +(* regularity assumption need to be restricted to a subgroup of prime order. *) +(* Finally, the cyclicity of Z(H) is not actually needed in the proof. *) +Theorem nonTI_Fitting_structure M g (H := (M`_\F)%G) : + let X := ('F(M) :&: 'F(M) :^ g)%G in + M \in 'M -> g \notin M -> X :!=: 1 -> + [/\ (*a*) M \in 'M_'F :|: 'M_'P1 /\ H :=: M`_\sigma, + (*b*) X \subset H /\ cyclic X, + (*c*) M^`(1) \subset 'F(M) /\ M`_\sigma \x 'O_\sigma(M)^'('F(M)) = 'F(M), + (*d*) forall E E1 E2 E3, sigma_complement M E E1 E2 E3 -> + [/\ E3 :=: 1, E2 <| E, E / E2 \isog E1 & cyclic (E / E2)] + & (*e*) (*1*) [/\ M \in 'M_'F, abelian H & 'r(H) = 2] + \/ let p := #|X| in [/\ prime p, ~~ abelian 'O_p(H), cyclic 'O_p^'(H) + & (*2*) {in \pi(H), forall q, exponent (M / H) %| q.-1} + \/ (*3*) [/\ #|'O_p(H)| = (p ^ 3)%N, M \in 'M_'P1 & #|M / H| %| p.+1] + ]]. +Proof. +move=> X maxM notMg ntX; have nilH: nilpotent H := Fcore_nil M. +have /andP[sHM nHM]: H <| M := Fcore_normal M. +have [[cycY t2Y] [_ _ defF] _ _] := Fitting_structure maxM. +set Y := 'O_\sigma(M)^'('F(M)) in cycY t2Y defF *. +have not_cycMp: {in \pi(X), forall p, ~~ cyclic 'O_p(M)}. + move=> p; rewrite mem_primes => /and3P[p_pr _ p_dv_X]. + apply: contra notMg => cycMp. + have hallMp := nilpotent_pcore_Hall p (Fitting_nil M). + have{cycMp} defNx1: {in 'F(M), forall x1, #[x1] = p -> 'N(<[x1]>) = M}. + move=> x1; rewrite /order -cycle_subG => sX1F oX1. + rewrite (mmax_normal maxM) //; last by rewrite -cardG_gt1 oX1 prime_gt1. + rewrite (char_normal_trans _ (pcore_normal p M)) ?sub_cyclic_char //=. + by rewrite -p_core_Fitting (sub_Hall_pcore hallMp) // /pgroup oX1 pnat_id. + have [x1 Xx1 ox1] := Cauchy p_pr p_dv_X; have [Fx1 Fgx1] := setIP Xx1. + rewrite -(norm_mmax maxM) inE -{1}(defNx1 (x1 ^ g^-1)) -?mem_conjg ?orderJ //. + by rewrite cycleJ normJ actKV -(defNx1 x1). +have{cycY} sX: \sigma(M).-group X. + apply: sub_pgroup (pgroup_pi X) => p piXp. + apply: contraR (not_cycMp p piXp) => s'p; rewrite -p_core_Fitting. + by apply: cyclicS (sub_pcore _ _) cycY => p1; move/eqnP->. +have sXMs: X \subset M`_\sigma. + by rewrite (sub_Hall_pcore (Msigma_Hall maxM)) // subIset ?Fitting_sub. +have E1X_facts p X1 (C1 := 'C_H(X1)%G): + X1 \in 'E_p^1(X) -> [/\ C1 \notin 'U, 'r(C1) <= 2 & abelian C1]. +- move=> EpX1; have [sX1X /andP[pX1 _] _] := pnElemP EpX1. + have piXp: p \in \pi(X) by rewrite -p_rank_gt0; apply/p_rank_geP; exists X1. + have not_sCX1M: ~~ ('C(X1) \subset M). + have [[sX1F sX1Fg] sFM] := (subsetIP sX1X, Fitting_sub M). + apply: contra notMg => sCX1M; rewrite -groupV. + have [trCX1 _ _] := sigma_group_trans maxM (pnatPpi sX piXp) pX1. + have [||c cX1c] := trCX1 g^-1; rewrite ?(subset_trans _ sFM) ?sub_conjgV //. + by case=> m Mm ->; rewrite groupM // (subsetP sCX1M). + have ltCX1_G: 'C(X1) \proper G := mFT_cent_proper (nt_pnElem EpX1 isT). + have ltC1G: C1 \proper G := sub_proper_trans (subsetIr H _) ltCX1_G. + have{ltCX1_G} nonuniqC1: C1 \notin 'U. + have sC1M: C1 \subset M by rewrite subIset ?Fcore_sub. + apply: contra not_sCX1M => uniqC1. + by rewrite (sub_uniq_mmax (def_uniq_mmax uniqC1 maxM sC1M)) ?subsetIr. + split=> //; first by rewrite leqNgt (contra (rank3_Uniqueness _)). + have sC1H: C1 \subset H := subsetIl _ _. + have dprodC1: 'F(C1) = C1 := nilpotent_Fitting (nilpotentS sC1H nilH). + apply/center_idP; rewrite -{2}dprodC1 -(center_bigdprod dprodC1). + apply: eq_bigr => r _; apply/center_idP; apply: contraR nonuniqC1. + move/(nonabelian_Uniqueness (pcore_pgroup _ _)). + exact: uniq_mmaxS (pcore_sub _ _) ltC1G. +pose p := pdiv #|X|; have piXp: p \in \pi(X) by rewrite pi_pdiv cardG_gt1. +have /p_rank_geP[X1 EpX1]: 0 < 'r_p(X) by rewrite p_rank_gt0. +have [sMp ntX1] := (pnatPpi sX piXp, nt_pnElem EpX1 isT). +have [p_pr oX1] := (pnElem_prime EpX1, card_pnElem EpX1 : #|X1| = p). +have [sX1X abelX1 dimX1] := pnElemP EpX1; have [pX1 _] := andP abelX1. +have [nonuniqC1 rC1 cC1C1] := E1X_facts p X1 EpX1. +have [cycX b'p]: cyclic X /\ p \in \beta(M)^'. + have [E hallE] := ex_sigma_compl maxM. + have [_ _] := sigma_compl_embedding maxM hallE. + case/(_ g notMg); set X2 := _ :&: _ => cycX2 b'X2 _. + have sXMg: X \subset M :^ g by rewrite subIset // conjSg Fitting_sub orbT. + have{sXMg} sXX2: X \subset X2 by rewrite subsetI sXMs. + by rewrite (pnatPpi b'X2 (piSg sXX2 piXp)) (cyclicS sXX2). +have b'H: \beta(M)^'.-group H. + apply: sub_pgroup (pgroup_pi _) => r piHr; have [-> // | p'r] := eqVneq r p. + apply/existsP; exists 'O_r(M)%G; rewrite /= Fcore_pcore_Sylow // negbK. + apply/implyP; rewrite ltnNge -rank_pgroup ?pcore_pgroup ?(leq_trans _ rC1) //. + rewrite rankS // subsetI /= -{1}(p_core_Fcore piHr) pcore_sub //. + rewrite -p_core_Fitting (sub_nilpotent_cent2 (Fitting_nil M)) ?pcore_sub //. + exact: subset_trans sX1X (subsetIl _ _). + exact: pnat_coprime pX1 (pi_pgroup (pcore_pgroup r _) _). +have [K hallK] := Hall_exists \kappa(M) (mmax_sol maxM). +have [sKM kK _] := and3P hallK; have s'K := sub_pgroup (@kappa_sigma' _ M) kK. +have [U complU] := ex_kappa_compl maxM hallK. +have [[defM cycK _] defM' _ _ exU0] := kappa_structure maxM complU. +have{b'p} FP1maxM: M \in 'M_'F :|: 'M_'P1. + apply: contraR b'p; rewrite inE /=; case/norP=> notFmaxF notP1maxF. + have PmaxM: M \in 'M_'P by apply/setDP. + by have [_ _ _ _ [| <- //]] := Ptype_structure PmaxM hallK; apply/setDP. +have defH: H :=: M`_\sigma. + apply/eqP; apply/idPn=> neqHMs; pose q := #|'C_(M`_\sigma)(K)|. + have solMs: solvable M`_\sigma := solvableS (pcore_sub _ _) (mmax_sol maxM). + have [D hallD] := Hall_exists q^' solMs. + have [_ /(_ K D)[] // _ [_ _ piHq /idPn[]]] := Fcore_structure maxM. + exact: pnatPpi b'H piHq. +have{sXMs} sXH: X \subset H by rewrite defH. +have{b'H} sM'F: M^`(1) \subset 'F(M). + rewrite Fitting_max ?der_normal // (isog_nil (quotient1_isog _)). + suffices <-: M`_\beta = 1 by apply: Mbeta_quo_nil. + apply/eqP; rewrite trivg_card1 (card_Hall (Mbeta_Hall maxM)). + rewrite -(partn_part _ (beta_sub_sigma maxM)) -(card_Hall (Msigma_Hall maxM)). + by rewrite /= -defH partG_eq1. +have{defF} defF: M`_\sigma \x Y = 'F(M). + by rewrite -defF -defH nilpotent_Fitting. +split=> // [E E1 E2 E3 complEi | {Y t2Y defF sM'F}]. + have [[sE3E' _] _ [cycE1 _] [_ defE] _]:= sigma_compl_context maxM complEi. + have [hallE _ _ hallE3 _] := complEi; have [sE3E t3E3 _] := and3P hallE3. + have E3_1: E3 :=: 1. + have [sEM s'E _] := and3P hallE; have sE'M' := dergS 1 sEM. + have sE3F: E3 \subset 'F(M) := subset_trans sE3E' (subset_trans sE'M' sM'F). + rewrite -(setIidPr sE3F) coprime_TIg // -(dprod_card defF) coprime_mull. + rewrite (pnat_coprime (pcore_pgroup _ _) (pgroupS sE3E s'E)). + exact: p'nat_coprime (sub_pgroup (@tau3'2 _ M) t2Y) t3E3. + have{defE} defE: E2 ><| E1 = E by rewrite -defE E3_1 sdprod1g. + have [-> _ mulE21 nE21 tiE21] := sdprod_context defE. + by rewrite -mulE21 quotientMidl quotient_cyclic // isog_sym quotient_isog. +have{defM'} defM_P1: M \in 'M_'P1 -> H ><| K = M /\ M^`(1) = H. + move=> P1maxM; have [PmaxM _] := setIdP P1maxM. + have U1: U :=: 1 by apply/eqP; rewrite (trivg_kappa_compl maxM complU). + have ntK: K :!=: 1 by rewrite (trivg_kappa maxM hallK); case/setDP: PmaxM. + by have [<- _] := defM' ntK; rewrite -{1}defM U1 sdprodg1 -defH. +pose P := 'O_p(H); have sylP: p.-Sylow(H) P := nilpotent_pcore_Hall p nilH. +have [sPH pP _] := and3P sylP. +have [cHH | {not_cycMp} not_cHH] := boolP (abelian H); [left | right]. + have [-> | P1maxM] := setUP FP1maxM; last first. + have [PmaxM _] := setIdP P1maxM. + have [ntKs _ sKsM'' _ _] := Ptype_cyclics PmaxM hallK. + case/eqP: (subG1_contra sKsM'' ntKs); apply/derG1P. + by rewrite /= -derg1; have [_ ->] := defM_P1 P1maxM. + split=> //; apply/eqP; rewrite eqn_leq (leq_trans _ rC1) //=; last first. + by rewrite rankS // subsetIidl (centsS sX1X) // (sub_abelian_cent cHH). + apply: leq_trans (rankS (pcore_sub p _)). + rewrite ltnNge -abelian_rank1_cyclic ?(abelianS sPH) //=. + by rewrite p_core_Fcore ?(piSg sXH) ?not_cycMp. +have sX1P: X1 \subset P by rewrite (sub_Hall_pcore sylP) ?(subset_trans sX1X). +have [_ mulPHp' cPHp' _] := dprodP (nilpotent_pcoreC p nilH : P \x _ = H). +have cHp'Hp': abelian 'O_p^'(H). + by rewrite (abelianS _ cC1C1) // subsetI pcore_sub (centsS sX1P). +have not_cPP: ~~ abelian P. + by apply: contra not_cHH => cPP; rewrite -mulPHp' abelianM cPP cHp'Hp'. +have{E1X_facts} pX: p.-group X. + apply: sub_pgroup (pgroup_pi _) => q; rewrite -p_rank_gt0. + case/p_rank_geP=> X2 EqX2; have [_ _ cC2C2] := E1X_facts _ _ EqX2. + case/pnElemP: EqX2 => sX2X /andP[qX2 _] _; have sX2H := subset_trans sX2X sXH. + apply: contraR not_cPP => q'p; rewrite (abelianS _ cC2C2) // subsetI sPH. + by rewrite (sub_nilpotent_cent2 nilH) ?(p'nat_coprime (pi_pgroup qX2 _) pP). +have sXP: X \subset P by rewrite (sub_Hall_pcore sylP). +pose Z0 := 'Ohm_1('Z(P)); have sZ0ZP: Z0 \subset 'Z(P) := Ohm_sub 1 _. +have{sZ0ZP} [sZ0P cPZ0] := subsetIP sZ0ZP. +have not_sX1Z0: ~~ (X1 \subset Z0). + apply: contra not_cPP => sX1Z0; apply: abelianS cC1C1. + by rewrite subsetI sPH (centsS sX1Z0) // centsC. +pose B := X1 <*> Z0; have sBP: B \subset P by rewrite join_subG sX1P. +have defB: X1 \x Z0 = B by rewrite dprodEY ?prime_TIg ?oX1 ?(centsS sX1P). +have pZP: p.-group 'Z(P) := pgroupS (center_sub _) pP. +have abelZ0: p.-abelem Z0 by rewrite Ohm1_abelem ?center_abelian. +have{abelZ0} abelB: p.-abelem B by rewrite (dprod_abelem _ defB) abelX1. +have sylP_Ms: p.-Sylow(M`_\sigma) P by rewrite -defH. +have sylP_G: p.-Sylow(G) P := subHall_Sylow (Msigma_Hall_G maxM) sMp sylP_Ms. +have max_rB A: p.-abelem A -> B \subset A -> 'r_p(A) <= 2. + move=> abelA /joing_subP[sX1A _]; have [pA cAA _] := and3P abelA. + suffices [a [nX1a sAaP]]: exists a, a \in 'N(X1) /\ A :^ a \subset P. + rewrite -rank_pgroup // -(rankJ _ a) (leq_trans _ rC1) ?rankS //= subsetI. + by rewrite -(normP nX1a) centJ conjSg (subset_trans sAaP) ?(centsS sX1A). + have [a _ sAaP] := Sylow_Jsub sylP_G (subsetT A) pA. + have [x1 defX1]: exists x1, X1 :=: <[x1]>. + by apply/cyclicP; rewrite prime_cyclic ?oX1. + have Px1: x1 \in P by rewrite -cycle_subG -defX1. + have Px1a: x1 ^ a \in P. + by rewrite (subsetP sAaP) // memJ_conjg -cycle_subG -defX1. + have [b nPb def_xb] := sigma_Hall_tame maxM sylP_Ms Px1 Px1a. + exists (a * b^-1); rewrite !inE !actM !sub_conjgV defX1 /= -!cycleJ def_xb. + by have{nPb} [_ nPb] := setIP nPb; rewrite (normP nPb). +have rpB: 'r_p(B) = 2. + apply/eqP; rewrite eqn_leq max_rB // -(p_rank_dprod p defB). + rewrite p_rank_abelem ?dimX1 // ltnS p_rank_Ohm1 -rank_pgroup // rank_gt0. + by rewrite center_nil_eq1 ?(pgroup_nil pP) ?(subG1_contra sXP). +have oZ0: #|Z0| = p. + apply/eqP; rewrite -(eqn_pmul2l (cardG_gt0 X1)) (dprod_card defB) oX1. + by rewrite (card_pgroup (abelem_pgroup abelB)) -p_rank_abelem ?rpB. +have p2maxElemB: [group of B] \in 'E_p^2(G) :&: 'E*_p(G). + rewrite !inE subsetT abelB -p_rank_abelem // rpB /=. + apply/maxgroupP; rewrite !inE subsetT /= -/B; split=> // A. + case/pElemP=> _ abelA sBA; have [pA _] := andP abelA. + apply/eqP; rewrite eq_sym eqEcard sBA (card_pgroup pA). + rewrite (card_pgroup (abelem_pgroup abelB)) -!p_rank_abelem // rpB. + by rewrite leq_exp2l ?prime_gt1 ?max_rB. +have{not_sX1Z0} defX: X :=: X1. + have sX_CPB: X \subset 'C_P(B). + rewrite centY !subsetI sXP sub_abelian_cent ?cyclic_abelian //=. + by rewrite centsC (centsS sXP). + have [C defCPB]: exists C, X1 \x C = 'C_P(B). + have [_ [C]] := basic_p2maxElem_structure p2maxElemB pP sBP not_cPP. + case=> _ _ defCPB _; exists C; rewrite defCPB // !inE joing_subl abelX1. + by rewrite -val_eqE eqEsubset negb_and not_sX1Z0 /= dimX1. + have defX: X1 \x (C :&: X) = X by rewrite (dprod_modl defCPB) // (setIidPr _). + by move/eqP: ntX1; case/(cyclic_pgroup_dprod_trivg pX cycX): defX; case. +have cycHp': cyclic 'O_p^'(H). + rewrite abelian_rank1_cyclic // leqNgt; apply: contra nonuniqC1 => rHp'. + apply: (uniq_mmaxS (setIS H (centS sX1P))). + by rewrite mFT_sol_proper nilpotent_sol // (nilpotentS (subsetIl _ _)). + apply: cent_uniq_Uniqueness (subsetIr _ _) (leq_trans rHp' (rankS _)). + exact: nonabelian_Uniqueness pP not_cPP. + by rewrite subsetI pcore_sub. +rewrite {1}defX oX1 /= -[M`_\F]/(gval H) -/P; split=> //. +pose Z q := 'Ohm_1('Z('O_q(H)))%G. +have charZ q: Z q \char H. + have:= char_trans (center_char _) (pcore_char q H). + exact: char_trans (Ohm_char 1 _). +have{cycHp'} oZ: {in \pi(H), forall q, #|Z q| = q}. + move=> q piHp; have [-> // | p'q] := eqVneq q p. + have qHq: q.-group 'O_q(H) := pcore_pgroup q H. + have sHqHp': 'O_q(H) \subset 'O_p^'(H) by apply: sub_pcore => r /eqnP->. + rewrite /= (center_idP (abelianS sHqHp' cHp'Hp')). + apply: Ohm1_cyclic_pgroup_prime (cyclicS sHqHp' cycHp') qHq _. + by rewrite -rank_gt0 (rank_Sylow (nilpotent_pcore_Hall q nilH)) p_rank_gt0. +have regZq_dv_q1 A q: + A \subset 'N(H) -> q \in \pi(H) -> semiregular (Z q) A -> #|A| %| q.-1. +- move=> nHA piHq regA. + by rewrite -(oZ q piHq) regular_norm_dvd_pred // (char_norm_trans (charZ q)). +have [FmaxM | {U complU defM exU0}P1maxM] := setUP FP1maxM. + left=> q piHq; have K1: K :=: 1 by apply/eqP; rewrite (trivg_kappa maxM). + have ntU: U :!=: 1 by rewrite (trivg_kappa_compl maxM complU) 2!inE FmaxM. + rewrite K1 sdprodg1 -defH in defM; have [_ mulHU nHU tiHU] := sdprodP defM. + rewrite -mulHU quotientMidl -(exponent_isog (quotient_isog nHU tiHU)). + have [U0 [sU0U <- frobMsU0]] := exU0 ntU; have nHU0 := subset_trans sU0U nHU. + apply: dvdn_trans (exponent_dvdn U0) _; apply: regZq_dv_q1 => // x U0x. + apply/trivgP; rewrite -(Frobenius_reg_ker frobMsU0 U0x) setSI //= -defH. + exact: (char_sub (charZ _)). +have{defM_P1} [[defM defM'] [PmaxM _]] := (defM_P1 P1maxM, setIdP P1maxM). +have [_ mulHK nHK tiHK] := sdprodP defM; have p'K := pi'_p'group s'K sMp. +have coHK: coprime #|H| #|K| by rewrite defH (pnat_coprime (pcore_pgroup _ _)). +have{coHK} coPK: coprime #|P| #|K| := coprimeSg sPH coHK. +have oMH: #|M / H| = #|K|. + by rewrite -mulHK quotientMidl -(card_isog (quotient_isog nHK tiHK)). +pose Ks := 'C_H(K); have prKs: prime #|Ks|. + have [Ms _ [_ _ _ _ [_]]] := Ptype_embedding PmaxM hallK. + by rewrite inE P1maxM -defH; do 2!case. +have sKsP: Ks \subset P. + have sKsM'': Ks \subset M^`(2) by rewrite /Ks defH; case/Ptype_cyclics: hallK. + rewrite (subset_trans sKsM'') 1?der1_min //= -derg1 defM' ?gFnorm //. + by rewrite -mulPHp' quotientMidl quotient_abelian. +have oKs: #|Ks| = p. + apply/eqP; apply: pnatPpi pP (piSg sKsP _). + by rewrite mem_primes prKs cardG_gt0 dvdnn. +have [prHK ntKs]: semiprime H K /\ Ks != 1. + by rewrite /Ks defH; case/Ptype_structure: hallK => // [[_ _ [_ ? _]] _ []]. +have [K_dv_p1 | {regZq_dv_q1}] := altP (@implyP (Ks :==: Z0) (#|K| %| p.-1)). + left=> q piHq; rewrite (dvdn_trans (exponent_dvdn _)) // oMH. + have [eqZqKs | neqZqKs] := eqVneq Ks (Z q). + have def_q: q = p by rewrite -(oZ q piHq) -eqZqKs. + by rewrite def_q K_dv_p1 // eqZqKs def_q. + apply: regZq_dv_q1 => // x Kx; rewrite -(setIidPl (char_sub (charZ q))). + rewrite -setIA prHK {x Kx}// setIC (prime_TIg prKs) //. + have q_pr: prime q by rewrite mem_primes in piHq; case/and3P: piHq. + apply: contra neqZqKs => sKsZq; rewrite eqEsubset sKsZq /=. + by rewrite prime_meetG ?oZ // (setIidPr sKsZq). +rewrite {Z oZ charZ}negb_imply; case/andP; move/eqP=> defKs not_K_dv_p1. +have nPK: K \subset 'N(P) := char_norm_trans (pcore_char p H) nHK. +have defZP: 'Z(P) = Ks. + apply/eqP; rewrite eqEsubset andbC {1}defKs Ohm_sub subsetI subIset ?sPH //. + have nZPK: K \subset 'N('Z(P)) := char_norm_trans (center_char _) nPK. + have coZPK: coprime #|'Z(P)| #|K| := coprimeSg (center_sub _) coPK. + rewrite centsC (coprime_odd_faithful_Ohm1 pZP) ?mFT_odd //. + by rewrite /= -/Z0 -defKs centsC subsetIr. +have rPle2: 'r(P) <= 2. + case/setIP: p2maxElemB; case/pnElemP=> _ _ dimB pmaxB. + have Ep2B: [group of B] \in 'E_p^2(P) by apply/pnElemP. + rewrite leqNgt; apply: contra not_K_dv_p1 => rPgt2. + have tiKcP: 'C_K(P) = 1. + apply/trivgP/subsetP=> x => /setIP[Kx cPx]. + apply: contraR ntX1 => ntx; rewrite -subG1. + have [_ _ _ <-] := dprodP defB; rewrite subsetIidl -defKs. + rewrite -[Ks](prHK x) 1?inE ?ntx // (subset_trans sX1P) //=. + by rewrite subsetI sPH sub_cent1. + rewrite (card_isog (quotient1_isog _)) -tiKcP -ker_conj_aut. + rewrite (card_isog (first_isog_loc _ nPK)) /=. + set A := _ @* _; have AutA: A \subset Aut P := Aut_conj_aut _ _. + have solA: solvable A by rewrite morphim_sol ?abelian_sol ?cyclic_abelian. + have oddA: odd #|A| by rewrite morphim_odd ?mFT_odd. + have nnP: p.-narrow P. + apply/implyP=> _; apply/set0Pn; exists [group of B]. + by rewrite inE Ep2B (subsetP (pmaxElemS p (subsetT P))) // inE pmaxB inE. + have [x defK] := cyclicP cycK; have Kx: x \in K by rewrite defK cycle_id. + have nPx := subsetP nPK x Kx; rewrite /A defK morphim_cycle //. + have Axj: conj_aut [group of P] x \in A by exact: mem_morphim. + have [_ _ -> //] := Aut_narrow pP (mFT_odd _) nnP solA AutA oddA. + by rewrite morph_p_elt // (mem_p_elt p'K). +have{rPle2} dimP: logn p #|P| = 3. + have [S [_ <- _] [C cycC]] := mFT_rank2_Sylow_cprod sylP_G rPle2 not_cPP. + case=> defP defZS; congr (logn p #|(_ : {set _})|). + suffices defC: 'Ohm_1(C) = C by rewrite -defC defZS cprod_center_id in defP. + suffices <-: 'Z(P) = C by rewrite defZP (@Ohm1_id _ p) // prime_abelem. + have [_ <- _] := cprodP (center_cprod defP). + by rewrite -defZS (center_idP (cyclic_abelian cycC)) mulSGid ?Ohm_sub. +have oP: #|P| = (p ^ 1.*2.+1)%N by rewrite (card_pgroup pP) dimP. +right; split; rewrite // {}oMH. +have esP: extraspecial P by apply: (p3group_extraspecial pP); rewrite ?dimP. +have defPK: P ><| K = P <*> K by rewrite sdprodEY // coprime_TIg. +have copK: coprime p #|K| by rewrite -oX1 (coprimeSg sX1P). +have [x|] := repr_extraspecial_prime_sdprod_cycle pP esP defPK cycK oP copK. + move/prHK=> defCHx /=; rewrite /= -/P -{1}(setIidPl sPH) -setIA defCHx -/Ks. + by rewrite -defZP setIA setIid. +by rewrite addn1 subn1 (negPf not_K_dv_p1) orbF. +Qed. + +(* A subset of the above, that does not require the non-TI witness. *) +Lemma nonTI_Fitting_facts M : + M \in 'M -> ~~ normedTI 'F(M)^# G M -> + [/\ M \in 'M_'F :|: 'M_'P1, M`_\F = M`_\sigma & M^`(1) \subset 'F(M)]. +Proof. +move=> maxM nonTI; suff: [exists (y | y \notin M), 'F(M) :&: 'F(M) :^ y != 1]. + by case/exists_inP=> y notMy /nonTI_Fitting_structure[] // [[-> ?] _ []]. +rewrite -negb_forall_in; apply: contra nonTI => /forall_inP tiF. +apply/normedTI_P; rewrite normD1 setTI gFnorm setD_eq0 subG1. +split=> // [|g _]; first by rewrite (trivg_Fitting (mmax_sol maxM)) mmax_neq1. +by apply: contraR => /tiF; rewrite -setI_eq0 conjD1g -setDIl setD_eq0 subG1. +Qed. + +(* This is B & G, Theorem 15.8, due to Feit and Thompson (1991). *) +(* We handle the non-structural step on l. 5, p. 122 by choosing A not to be *) +(* a q-group, if possible, so that when it turns out to be we know q is the *) +(* only prime in tau2(H). Since this uniqueness does not appear to be used *) +(* later we could also eliminate this complication. *) +(* We also avoid the circularity in proving that A is a q-group and that Q *) +(* is non-abelian by deriving that Q is in U from 14.2(e) rather than 12.13. *) +Theorem tau2_P2type_signalizer M Mstar U K r R H (q := #|K|) : + M \in 'M_'P2 -> kappa_complement M U K -> Mstar \in 'M('C(K)) -> + r.-Sylow(U) R -> H \in 'M('N(R)) -> ~~ \tau2(H)^'.-group H -> + [/\ prime q, \tau2(H) =i (q : nat_pred) & \tau2(M)^'.-group M]. +Proof. +move: Mstar => L P2maxM complU maxCK_L sylR maxNR_H not_t2'H. +have [[PmaxM notP1maxM] [hallU hallK _]] := (setDP P2maxM, complU). +have q_pr: prime q by have [_ _ _ _ []] := Ptype_structure PmaxM hallK. +have [[maxH _] [maxM _]] := (setIdP maxNR_H, setDP PmaxM). +have [maxL sCKL] := setIdP maxCK_L; have hallLs := Msigma_Hall maxL. +have [_ sUHs] := P2type_signalizer P2maxM complU maxCK_L sylR maxNR_H. +set D := H :&: L => defUK [_ sKFD hallD] {r R sylR maxNR_H}. +set uniq_q := _ =i _. +have{not_t2'H} [q1 t2Hq neq_q]: exists2 q1, q1 \in \tau2(H) & q1 = q -> uniq_q. + move: not_t2'H; rewrite negb_and cardG_gt0 all_predC negbK /= has_filter. + set s := filter _ _ => nts. + have mem_s: s =i \tau2(H). + move=> q1; rewrite mem_filter; apply: andb_idr => /= t2q1. + by rewrite (partition_pi_mmax maxH) t2q1 !orbT. + have [all_q | ] := altP (@allP _ (pred1 q) s); last first. + by case/allPn=> q1; rewrite mem_s=> t2q1; move/eqnP=> ne_q1q; exists q1. + have s_q1: head q s \in s by case: (s) nts => // q1 s' _; exact: predU1l. + exists (head q s) => [|def_q q1]; rewrite -mem_s //. + by apply/idP/idP; [exact: all_q | move/eqnP->; rewrite -def_q]. +have [A /= Eq2A Eq2A_H] := ex_tau2Elem hallD t2Hq; rewrite -/D in Eq2A. +have [b'q qmaxA]: q1 \notin \beta(G) /\ A \in 'E*_q1(G). + by have [-> ->] := tau2_not_beta maxH t2Hq. +have [sDH s'HD _] := and3P hallD. +have [sAH abelA dimA] := pnElemP Eq2A_H; have [qA _] := andP abelA. +have [[nsAD _] _ _ _] := tau2_compl_context maxH hallD t2Hq Eq2A. +have cKA: A \subset 'C(K). + have sFD: 'F(D) \subset D := Fitting_sub _; have sFH := subset_trans sFD sDH. + have cFF: abelian 'F(D). + exact: sigma'_nil_abelian maxH sFH (pgroupS sFD s'HD) (Fitting_nil _). + exact: sub_abelian_cent2 cFF (Fitting_max nsAD (pgroup_nil qA)) sKFD. +have sAL: A \subset L := subset_trans cKA sCKL. +pose Ks := 'C_(M`_\sigma)(K). +have [PmaxL hallKs defK]: + [/\ L \in 'M_'P, \kappa(L).-Hall(L) Ks & 'C_(L`_\sigma)(Ks) = K]. +- have [L1 [? _] [defL1 [? _] [? _] _ _]] := Ptype_embedding PmaxM hallK. + suffices ->: L = L1 by []; apply/set1P; rewrite defL1 // in maxCK_L. + by apply/nElemP; exists q; rewrite p1ElemE // !inE subxx eqxx. +have sKLs: K \subset L`_\sigma by rewrite -defK subsetIl. +have sLq: q \in \sigma(L). + by rewrite -pnatE // -pgroupE (pgroupS sKLs) ?pcore_pgroup. +have sLq1: q1 \in \sigma(L). + apply: contraLR sLq => s'Lq1; rewrite -negnK negbK /= -pnatE // -pgroupE. + have s'LA: \sigma(L)^'.-group A by exact: pi_pgroup qA _. + have [E hallE sAE] := Hall_superset (mmax_sol maxL) sAL s'LA. + have EqA_E: A \in 'E_q1^2(E) by exact/pnElemP. + have [[sEL s'E _] t2Lq1] := (and3P hallE, sigma'2Elem_tau2 maxL hallE EqA_E). + have [_ [sCAE _ _] _ _] := tau2_compl_context maxL hallE t2Lq1 EqA_E. + by apply: pgroupS (subset_trans _ sCAE) s'E; rewrite centsC. +have sALs: A \subset L`_\sigma by rewrite sub_Hall_pcore ?(pi_pgroup qA). +have solL: solvable L`_\sigma := solvableS (pcore_sub _ _) (mmax_sol maxL). +pose Q := 'O_q(L)%G; have{solL} [Ds hallDs] := Hall_exists q^' solL. +have sQFL: Q \subset 'F(L) by rewrite -[gval Q]p_core_Fitting pcore_sub. +have [sAFL sylQ]: A \subset 'F(L) /\ q.-Sylow(L) Q. + have [defLF | neqLF] := eqVneq L`_\F L`_\sigma. + split; first by rewrite (subset_trans sALs) // -defLF Fcore_sub_Fitting. + by rewrite Fcore_pcore_Sylow // defLF mem_primes q_pr cardG_gt0 cardSg. + have [_ /(_ _ Ds hallKs neqLF)] := Fcore_structure maxL. + rewrite /= defK -/q -/Q; case=> // _ _ [-> _ nsQ0L] _ [_ _ [_ _ <-] _]. + rewrite subsetI sALs sub_astabQ quotient_cents // (subset_trans sAL) //. + exact: normal_norm nsQ0L. +have{sLq1} neqHL: H :!=: L. + by apply: contraTneq t2Hq => ->; rewrite negb_and negbK /= sLq1. +have def_q1: q1 = q. + have uniqQ: Q \in 'U. + have [_ _ _ [_ uniqQ _] _] := Ptype_structure PmaxL hallKs. + apply/uniq_mmaxP; exists L; case/uniqQ: sylQ => //=; rewrite defK. + by rewrite pi_of_prime ?inE. + apply: contraNeq neqHL => q'q1. + rewrite (eq_uniq_mmax (def_uniq_mmax _ maxL sAL) maxH sAH) //. + rewrite (cent_uniq_Uniqueness uniqQ) ?(rank_abelem abelA) ?dimA //. + rewrite (sub_nilpotent_cent2 (Fitting_nil L)) //. + exact: pnat_coprime (pcore_pgroup _ _) (pi_pgroup qA _). +split=> //; first exact: neq_q. +rewrite {q1 neq_q}def_q1 in qA Eq2A Eq2A_H t2Hq abelA dimA qmaxA b'q. +have{b'q} b'q: q \notin \beta(L) by rewrite -predI_sigma_beta // inE /= sLq. +have P1maxL: L \in 'M_'P1. + apply: contraR b'q => notP1maxL. + by have [_ _ _ _ [|<- //]] := Ptype_structure PmaxL hallKs; apply/setDP. +have nilLs: nilpotent L`_\sigma. + rewrite (sameP (Fcore_eq_Msigma maxL) eqP); apply: contraR b'q => neqLF. + have [_ /(_ _ Ds hallKs neqLF)] := Fcore_structure maxL. + by rewrite /= defK -/q -/Q; case=> // _ [_ _ _ ->] _ _ _. +have defL': L^`(1) = L`_\sigma. + have [Us complUs] := ex_kappa_compl maxL hallKs. + have [_ [|<- _ _ _ _]] := kappa_structure maxL complUs. + by rewrite (trivg_kappa maxL hallKs) //; case/setDP: PmaxL. + suffices ->: Us :=: 1 by rewrite sdprodg1. + by apply/eqP; rewrite (trivg_kappa_compl maxL complUs). +have [ntK sKLs']: K :!=: 1 /\ K \subset L`_\sigma^`(1). + by rewrite -defL' -defK; case/Ptype_cyclics: hallKs. +have [sQL qQ _] := and3P sylQ. +have not_cQQ: ~~ abelian Q. + have sKL: K \subset L := subset_trans sKLs (pcore_sub _ _). + have sKQ: K \subset Q by rewrite (sub_Hall_pcore sylQ) /pgroup ?pnat_id. + have sQLs: Q \subset L`_\sigma by rewrite sub_Hall_pcore ?(pi_pgroup qQ). + have defLs: 'O_q^'(L`_\sigma) * Q = L`_\sigma. + rewrite -(setIidPl sQLs) pcore_setI_normal ?pcore_normal //. + by have [_] := dprodP (nilpotent_pcoreC q^' nilLs); rewrite pcoreNK. + apply: contra ntK => cQQ; rewrite -subG1 /= -(derG1P cQQ) -subsetIidl. + rewrite -(pprod_focal_coprime defLs) ?subsetIidl ?pcore_normal //. + by rewrite coprime_sym (coprimeSg sKQ) ?coprime_pcoreC. +pose X := 'C_A(H`_\sigma)%G. +have [sXA cHsX]: X \subset A /\ X \subset 'C(H`_\sigma) by apply/subsetIP. +have{not_cQQ} oX: #|X| = q. + by have [_ []] := nonabelian_tau2 maxH hallD t2Hq Eq2A qQ not_cQQ. +have neqXK: X :!=: K. + apply: contraNneq neqHL => defX; rewrite (eq_mmax maxH maxL) //. + have [_ <- _ _] := sdprodP (sdprod_sigma maxH hallD). + by rewrite mulG_subG subsetIr (subset_trans _ sCKL) // centsC -defX. +have{neqXK sXA} not_sXM: ~~ (X \subset M). + apply: contra neqXK => sXM; rewrite eqEcard oX leqnn andbT; apply/joing_idPl. + have [[sKM kK _] cKX] := (and3P hallK, subset_trans sXA cKA). + apply: sub_pHall hallK _ (joing_subl _ _) _; last by rewrite join_subG sKM. + by rewrite /= (cent_joinEr cKX) pgroupM {2}/pgroup oX andbb. +have{not_sXM} not_sCUM: ~~ ('C(U) \subset M). + exact: contra (subset_trans (centsS sUHs cHsX)) not_sXM. +apply/pgroupP=> r r_pr _; apply: contra not_sCUM => /= t2Mr. +have [hallUK _ _ _ _] := kappa_compl_context maxM complU. +have [[B Er2B _] [sUKM _]] := (ex_tau2Elem hallUK t2Mr, andP hallUK). +have [[nsBUK _] [sCBUK _ _] _ _ ] := tau2_compl_context maxM hallUK t2Mr Er2B. +apply: subset_trans (centS _) (subset_trans sCBUK sUKM). +have [sBUK /andP[rB _] _] := pnElemP Er2B. +have maxU_UK := Hall_max (pHall_subl (joing_subl _ _) sUKM hallU). +rewrite (normal_sub_max_pgroup maxU_UK) // (pi_pgroup rB) //. +apply: contraL t2Mr; rewrite negb_and negbK /= inE /=. +by case: (r \in _) => //=; move/rank_kappa->. +Qed. + +(* This is B & G, Theorem 15.9, parts (a) and (b), due to D. Sibley and Feit *) +(* and Thompson, respectively. *) +(* We have dropped part (c) because it is not used later, and localizing the *) +(* quantification on r would complicate the proof needlessly. *) +Theorem nonFtype_signalizer_base M x : + M \in 'M -> x \in M`_\sigma^# -> + ~~ ('C[x] \subset M) -> 'N[x] \notin 'M_'F -> + [/\ (*a*) M \in 'M_'F, 'N[x] \in 'M_'P2 + & (*b*) exists2 E : {group gT}, \sigma(M)^'.-Hall(M) E + & cyclic (gval E) /\ [Frobenius M = M`_\sigma ><| E]]. +Proof. +move=> maxM Ms1x not_sCxM notFmaxN; have ell1x := Msigma_ell1 maxM Ms1x. +have [[ntx Ms_x] [y cxy notMy]] := (setD1P Ms1x, subsetPn not_sCxM). +have SMxM: M \in 'M_\sigma[x] by rewrite inE maxM cycle_subG. +have SMxMy: (M :^ y)%G \in 'M_\sigma[x]. + by rewrite inE mmaxJ maxM gen_subG -(normP cxy) /= MsigmaJ conjSg sub1set. +have neq_MyM: M :^ y != M by rewrite (sameP eqP normP) norm_mmax. +have SMx_gt1: #|'M_\sigma[x]| > 1. + by rewrite (cardD1 M) SMxM (cardD1 (M :^ y)%G) inE /= SMxMy neq_MyM. +have [_ [//|uniqN _ t2Nx]] := FT_signalizer_context ell1x. +rewrite inE (negPf notFmaxN) /= => P2maxN /(_ M SMxM)[_ st2NsM _ hallMN]. +pose r := pdiv #[x]; have pixr: r \in \pi(#[x]) by rewrite pi_pdiv order_gt1. +have t2Nr := pnatPpi t2Nx pixr; have sMr := st2NsM r t2Nr. +have [[PmaxN _] [_ s'N_MN _]] := (setDP P2maxN, and3P hallMN). +have [K hallK] := Hall_exists \kappa('N[x]) (sigma_compl_sol hallMN). +have [U hallU] := Hall_exists \kappa('N[x])^' (sigma_compl_sol hallMN). +have hallK_N := subHall_Hall hallMN (@kappa_sigma' _ _) hallK. +have [[sKMN kK _] [sUMN k'U _]] := (and3P hallK, and3P hallU). +have mulUK: U * K = M :&: 'N[x]. + apply/eqP; rewrite eqEcard mulG_subG sUMN sKMN. + rewrite coprime_cardMg ?(p'nat_coprime k'U) //= mulnC. + by rewrite (card_Hall hallU) (card_Hall hallK) partnC ?cardG_gt0. +have complU: kappa_complement 'N[x] U K. + split=> //; last by rewrite mulUK groupP. + apply: (subHall_Hall hallMN) => [p|]; first by case/norP. + rewrite pHallE sUMN /= (card_Hall hallU) eq_sym; apply/eqP. + apply: eq_in_partn => p piMNp; rewrite inE /= negb_or /=. + by rewrite [~~ _](pnatPpi s'N_MN). +have prK: prime #|K| by case/Ptype_structure: hallK_N => // _ _ _ _ []. +have ntK: K :!=: 1 by rewrite -cardG_gt1 prime_gt1. +have [maxN _] := setDP PmaxN. +have [defUK cUU regUK]: [/\ U ><| K = M :&: 'N[x], abelian U & 'C_U(K) = 1]. + have [_ defM _ regUK -> //] := kappa_compl_context maxN complU. + have [[_ UK _ defUK] _ _ _] := sdprodP defM. + by rewrite (cent_semiregular regUK) // defUK; case/sdprodP: defUK => _ <-. +have [[R sylR] [s'Nr rrN]] := (Sylow_exists r (M :&: 'N[x]), andP t2Nr). +have [[sRMN rR _] sylR_N] := (and3P sylR, subHall_Sylow hallMN s'Nr sylR). +have [nsUMN _ _ nUK _] := sdprod_context defUK. +have [[sRM sRN] [sKM _]] := (subsetIP sRMN, subsetIP sKMN). +have sRU: R \subset U. + rewrite (sub_normal_Hall hallU nsUMN sRMN) (pi_pgroup rR) //. + by apply: contraL rrN; move/rank_kappa->. +have sNRM: 'N(R) \subset M. + apply: (norm_noncyclic_sigma maxM sMr rR sRM). + rewrite (odd_pgroup_rank1_cyclic rR) ?mFT_odd //. + by rewrite (p_rank_Sylow sylR_N) (eqnP rrN). +have sylR_U := pHall_subl sRU sUMN sylR. +have maxNRM: M \in 'M('N(R)) by rewrite inE maxM. +have [L maxCK_L] := mmax_exists (mFT_cent_proper ntK). +have FmaxM: M \in 'M_'F; last split=> //. + by have [] := P2type_signalizer P2maxN complU maxCK_L sylR_U maxNRM. +have nilMs: nilpotent M`_\sigma by rewrite notP1type_Msigma_nil ?FmaxM. +have sMsF: M`_\sigma \subset 'F(M) by rewrite Fitting_max ?pcore_normal. +have defR: R :=: 'O_r(U) := nilpotent_Hall_pcore (abelian_nil cUU) sylR_U. +have nRK: K \subset 'N(R) by rewrite defR (char_norm_trans (pcore_char r U)). +have ntR: R :!=: 1. + rewrite -rank_gt0 (rank_Sylow sylR_N) p_rank_gt0. + by rewrite (partition_pi_mmax maxN) t2Nr !orbT. +have not_nilRK: ~~ nilpotent (R <*> K). + apply: contra ntR => nilRK; rewrite -subG1 -regUK subsetI sRU. + rewrite (sub_nilpotent_cent2 nilRK) ?joing_subl ?joing_subr //. + by rewrite (coprimegS sRU) ?(pnat_coprime kK). +have{not_nilRK} not_sKMs: ~~ (K \subset M`_\sigma). + apply: contra not_nilRK => sKMs; apply: nilpotentS nilMs. + by rewrite join_subG (sub_Hall_pcore (Msigma_Hall maxM)) // (pi_pgroup rR). +have s'MK: \sigma(M)^'.-group K. + rewrite /pgroup pnatE //; apply: contra not_sKMs; rewrite /= -pnatE // => sK. + by rewrite (sub_Hall_pcore (Msigma_Hall maxM)). +have [E hallE sKE] := Hall_superset (mmax_sol maxM) sKM s'MK. +have [[E1 hallE1] [E3 hallE3]] := ex_tau13_compl hallE. +have [E2 hallE2 complEi] := ex_tau2_compl hallE hallE1 hallE3. +have [[_ t1E1 _] [sEM _]] := (and3P hallE1, andP hallE). +have E2_1: E2 :=: 1. + have [sE2E t2E2 _] := and3P hallE2. + rewrite -(setIidPl sE2E) coprime_TIg ?(pnat_coprime t2E2 (pgroupS sEM _)) //. + apply: contraR ntR => not_t2'M. + have:= tau2_P2type_signalizer P2maxN complU maxCK_L sylR_U maxNRM not_t2'M. + case=> _ _ t2'N; rewrite -(setIidPl sRN) coprime_TIg //. + by rewrite (pnat_coprime (pi_pgroup rR t2Nr)). +have E3_1: E3 :=: 1. + have ntX: 'F(M) :&: 'F(M) :^ y != 1. + apply/trivgPn; exists x; rewrite // inE mem_conjg !(subsetP sMsF) //. + by rewrite /conjg invgK mulgA (cent1P cxy) mulgK. + have [_ _ _ defE _] := nonTI_Fitting_structure maxM notMy ntX. + by case/defE: complEi. +have [cycE defE]: cyclic E /\ E :=: E1. + have [_ _ [cycE1 _] [<- _] _] := sigma_compl_context maxM complEi. + by rewrite E2_1 E3_1 !sdprod1g. +have [ntMs ntE] := (Msigma_neq1 maxM, subG1_contra sKE ntK). +have defM := sdprod_sigma maxM hallE. +exists E => //; split=> //; apply/Frobenius_semiregularP=> // z Ez. +have{Ez} [ntz szE1] := setD1P Ez; rewrite defE -cycle_subG in szE1. +pose q := pdiv #[z]; have pizq: q \in \pi(#[z]) by rewrite pi_pdiv order_gt1. +have szM: <[z]> \subset M by rewrite (subset_trans _ sEM) ?defE. +have [_ k'M] := setIdP FmaxM; have k'q := pnatPpi k'M (piSg szM pizq). +have t1q := pnatPpi t1E1 (piSg szE1 pizq). +move: pizq; rewrite -p_rank_gt0 => /p_rank_geP[Z]. +rewrite /= -(setIidPr szM) pnElemI -setIdE => /setIdP[EqZ sZz]. +apply: contraNeq k'q => ntCMsx /=. +rewrite unlock 3!inE /= t1q; apply/exists_inP; exists Z => //. +by rewrite (subG1_contra _ ntCMsx) ?setIS //= -cent_cycle centS. +Qed. + +End Section15. + + diff --git a/mathcomp/odd_order/BGsection16.v b/mathcomp/odd_order/BGsection16.v new file mode 100644 index 0000000..a37edba --- /dev/null +++ b/mathcomp/odd_order/BGsection16.v @@ -0,0 +1,1359 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div path fintype. +Require Import bigop finset prime fingroup morphism perm automorphism quotient. +Require Import action gproduct gfunctor pgroup cyclic center commutator. +Require Import gseries nilpotent sylow abelian maximal hall frobenius. +Require Import BGsection1 BGsection2 BGsection3 BGsection4 BGsection5. +Require Import BGsection6 BGsection7 BGsection9 BGsection10 BGsection12. +Require Import BGsection13 BGsection14 BGsection15. + +(******************************************************************************) +(* This file covers B & G, section 16; it summarises all the results of the *) +(* local analysis. Some of the definitions of B & G have been adapted to fit *) +(* in beter with Peterfalvi, section 8, dropping unused properties and adding *) +(* a few missing ones. This file also defines the following: *) +(* of_typeF M U <-> M = M`_\F ><| U is of type F, in the sense of *) +(* Petervalvi (8.1) rather than B & G section 14. *) +(* is_typeF_complement M U U0 <-> U0 is a subgroup of U with the same *) +(* exponent as U, such that M`_\F ><| U0 is a Frobenius *) +(* group; this corresponds to Peterfalvi (8.1)(c). *) +(* is_typeF_inertia M U U1 <-> U1 <| U is abelian and contains 'C_U[x] for *) +(* all x in M`_\F^#, and thus the inertia groups of all *) +(* nonprincipal irreducible characters of M`_\F; this *) +(* corresponds to Peterfalvi (8.1)(b). *) +(* of_typeI M U <-> M = M`_\F ><| U is of type I, in the sense of *) +(* Peterfalvi (8.3); this definition is almost identical *) +(* to B & G conditions (Ii) - (Iv), except that (Iiv) is *) +(* dropped, as is the condition p \in \pi* in (Iv)(c). *) +(* Also, the condition 'O_p^'(M) cyclic, present in both *) +(* B & G and Peterfalvi, is weakened to 'O_p^'(M`_\F) *) +(* cyclic, because B & G, Theorem 15.7 only proves the *) +(* weaker statement, and we did not manage to improve it. *) +(* This appears to be a typo in B & G that was copied *) +(* over to Petrfalvi (8.3). It is probably no consequence *) +(* because (8.3) is only used in (12.6) and (12.10) and *) +(* neither use the assumption that 'O_p^'(M) is cyclic. *) +(* For defW : W1 \x W2 = W we also define: *) +(* of_typeP M U defW <-> M = M`_\F ><| U ><| W1 is of type P, in the sense of *) +(* Peterfalvi (8.4) rather than B & G section 14, where *) +(* (8.4)(d,e) hold for W and W2 (i.e., W2 = C_M^(1)(W1)). *) +(* of_typeII_IV M U defW <-> M = M`_\F ><| U ><| W1 is of type II, III, or IV *) +(* in the sense of Peterfalvi (8.6)(a). This is almost *) +(* exactly the contents of B & G, (T1)-(T7), except that *) +(* (T6) is dropped, and 'C_(M`_\F)(W1) \subset M^`(2) is *) +(* added (PF, (8.4)(d) and B & G, Theorem C(3)). *) +(* of_typeII M U defW <-> M = M`_\F ><| U ><| W1 is of type II in the sense *) +(* of Peterfalvi (8.6); this differs from B & G by *) +(* dropping the rank 2 clause in IIiii and replacing IIv *) +(* by B(2)(3) (note that IIv is stated incorrectly: M' *) +(* should be M'^#). *) +(* of_typeIII M U defW <-> M = M`_\F ><| U ><| W1 is of type III in the sense *) +(* of Peterfalvi (8.6). *) +(* of_typeIV M U defW <-> M = M`_\F ><| U ><| W1 is of type IV in the sense *) +(* of Peterfalvi (8.6). *) +(* of_typeV M U defW <-> U = 1 and M = M`_\F ><| W1 is of type V in the *) +(* sense of Peterfalvi (8.7); this differs from B & G (V) *) +(* dropping the p \in \pi* condition in clauses (V)(b) *) +(* and (V)(c). *) +(* exists_typeP spec <-> spec U defW holds for some groups U, W, W1 and W2 *) +(* such that defW : W1 \x W2 = W; spec will be one of *) +(* (of_typeP M), (of_typeII_IV M), (of_typeII M), etc. *) +(* FTtype_spec i M <-> M is of type i, for 0 < i <= 5, in the sense of the *) +(* predicates above, for the appropriate complements to *) +(* M`_\F and M^`(1). *) +(* FTtype M == the type of M, in the sense above, when M is a maximal *) +(* subgroup of G (this is an integer i between 1 and 5). *) +(* M`_\s == an alternative, combinatorial definition of M`_\sigma *) +(* := M`_\F if M is of type I or II, else M^`(1) *) +(* 'A1(M) == the "inner Dade support" of a maximal group M, as *) +(* defined in Peterfalvi (8.10). *) +(* := (M`_\s)^# *) +(* 'A(M) == the "Dade support" of M as defined in Peterfalvi (8.10) *) +(* (this differs from B & G by excluding 1). *) +(* 'A0(M) == the "outer Dade support" of M as defined in Peterfalvi *) +(* (8.10) (this differs from B & G by excluding 1). *) +(* 'M^G == a transversal of the conjugacy classes of 'M. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section GeneralDefinitions. + +Variable gT : finGroupType. +Implicit Types V W X : {set gT}. + +End GeneralDefinitions. + +Section Definitions. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). + +Implicit Types M U V W X : {set gT}. + +Definition is_typeF_inertia M U (H := M`_\F) U1 := + [/\ U1 <| U, abelian U1 & {in H^#, forall x, 'C_U[x] \subset U1}]. + +Definition is_typeF_complement M U (H := M`_\F) U0 := + [/\ U0 \subset U, exponent U0 = exponent U & [Frobenius H <*> U0 = H ><| U0]]. + +Definition of_typeF M U (H := M`_\F) := + [/\ (*a*) [/\ H != 1, U :!=: 1 & H ><| U = M], + (*b*) exists U1 : {group gT}, is_typeF_inertia M U U1 + & (*c*) exists U0 : {group gT}, is_typeF_complement M U U0]. + +Definition of_typeI M (H := M`_\F) U := + of_typeF M U + /\ [\/ (*a*) normedTI H^# G M, + (*b*) abelian H /\ 'r(H) = 2 + | (*c*) {in \pi(H), forall p, exponent U %| p.-1} + /\ (exists2 p, p \in \pi(H) & cyclic 'O_p^'(H))]. + +Section Ptypes. + +Variables M U W W1 W2 : {set gT}. +Let H := M`_\F. +Let M' := M^`(1). +Implicit Type defW : W1 \x W2 = W. + +Definition of_typeP defW := + [/\ (*a*) [/\ cyclic W1, Hall M W1, W1 != 1 & M' ><| W1 = M], + (*b*) [/\ nilpotent U, U \subset M', W1 \subset 'N(U) & H ><| U = M'], + (*c*) [/\ ~~ cyclic H, M^`(2) \subset 'F(M), H * 'C_M(H) = 'F(M) + & 'F(M) \subset M'], + (*d*) [/\ cyclic W2, W2 != 1, W2 \subset H, W2 \subset M^`(2) + & {in W1^#, forall x, 'C_M'[x] = W2}] + & (*e*) normedTI (W :\: (W1 :|: W2)) G W]. + +Definition of_typeII_IV defW := + [/\ of_typeP defW, U != 1, prime #|W1| & normedTI 'F(M)^# G M]. + +Definition of_typeII defW := + [/\ of_typeII_IV defW, abelian U, ~~ ('N(U) \subset M), + of_typeF M' U & M'`_\F = H]. + +Definition of_typeIII defW := + [/\ of_typeII_IV defW, abelian U & 'N(U) \subset M]. + +Definition of_typeIV defW := + [/\ of_typeII_IV defW, ~~ abelian U & 'N(U) \subset M]. + +Definition of_typeV defW := + [/\ of_typeP defW /\ U = 1 + & [\/ (*a*) normedTI H^# G M, + (*b*) exists2 p, p \in \pi(H) & #|W1| %| p.-1 /\ cyclic 'O_p^'(H) + | (*c*) exists2 p, p \in \pi(H) + & [/\ #|'O_p(H)| = (p ^ 3)%N, #|W1| %| p.+1 & cyclic 'O_p^'(H)]]]. + +End Ptypes. + +CoInductive exists_typeP (spec : forall U W W1 W2, W1 \x W2 = W -> Prop) : Prop + := FTtypeP_Spec (U W W1 W2 : {group gT}) defW of spec U W W1 W2 defW. + +Definition FTtype_spec i M := + match i with + | 1%N => exists U : {group gT}, of_typeI M U + | 2 => exists_typeP (of_typeII M) + | 3 => exists_typeP (of_typeIII M) + | 4 => exists_typeP (of_typeIV M) + | 5 => exists_typeP (of_typeV M) + | _ => False + end. + +Definition FTtype M := + if \kappa(M)^'.-group M then 1%N else + if M`_\sigma != M^`(1) then 2 else + if M`_\F == M`_\sigma then 5 else + if abelian (M`_\sigma / M`_\F) then 3 else 4. + +Lemma FTtype_range M : 0 < FTtype M <= 5. +Proof. by rewrite /FTtype; do 4!case: ifP => // _. Qed. + +Definition FTcore M := if 0 < FTtype M <= 2 then M`_\F else M^`(1). +Fact FTcore_is_group M : group_set (FTcore M). +Proof. rewrite /FTcore; case: ifP => _; exact: groupP. Qed. +Canonical Structure FTcore_group M := Group (FTcore_is_group M). + +Definition FTsupport1 M := (FTcore M)^#. + +Let FTder M := M^`(FTtype M != 1%N). + +Definition FTsupport M := \bigcup_(x in FTsupport1 M) 'C_(FTder M)[x]^#. + +Definition FTsupport0 M (pi := \pi(FTder M)) := + FTsupport M :|: [set x in M | ~~ pi.-elt x & ~~ pi^'.-elt x]. + +Definition mmax_transversal U := orbit_transversal 'JG U 'M. + +End Definitions. + +Notation "M `_ \s" := (FTcore M) (at level 3, format "M `_ \s") : group_scope. +Notation "M `_ \s" := (FTcore_group M) : Group_scope. + +Notation "''A1' ( M )" := (FTsupport1 M) + (at level 8, format "''A1' ( M )") : group_scope. + +Notation "''A' ( M )" := (FTsupport M) + (at level 8, format "''A' ( M )") : group_scope. + +Notation "''A0' ( M )" := (FTsupport0 M) + (at level 8, format "''A0' ( M )") : group_scope. + +Notation "''M^' G" := (mmax_transversal G) + (at level 3, format "''M^' G") : group_scope. + +Section Section16. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). +Implicit Types p q q_star r : nat. +Implicit Types x y z : gT. +Implicit Types A E H K L M Mstar N P Q Qstar R S T U V W X Y Z : {group gT}. + +(* Structural properties of the M`_\s definition. *) +Lemma FTcore_char M : M`_\s \char M. +Proof. by rewrite /FTcore; case: ifP; rewrite gFchar. Qed. + +Lemma FTcore_normal M : M`_\s <| M. +Proof. by rewrite char_normal ?FTcore_char. Qed. + +Lemma FTcore_norm M : M \subset 'N(M`_\s). +Proof. by rewrite char_norm ?FTcore_char. Qed. + +Lemma FTcore_sub M : M`_\s \subset M. +Proof. by rewrite char_sub ?FTcore_char. Qed. + +Lemma FTcore_type1 M : FTtype M == 1%N -> M`_\s = M`_\F. +Proof. by rewrite /M`_\s => /eqP->. Qed. + +Lemma FTcore_type2 M : FTtype M == 2 -> M`_\s = M`_\F. +Proof. by rewrite /M`_\s => /eqP->. Qed. + +Lemma FTcore_type_gt2 M : FTtype M > 2 -> M`_\s = M^`(1). +Proof. by rewrite /M`_\s => /subnKC <-. Qed. + +Lemma FTsupp1_type1 M : FTtype M == 1%N -> 'A1(M) = M`_\F^#. +Proof. by move/FTcore_type1 <-. Qed. + +Lemma FTsupp1_type2 M : FTtype M == 2 -> 'A1(M) = M`_\F^#. +Proof. by move/FTcore_type2 <-. Qed. + +Lemma FTsupp1_type_gt2 M : FTtype M > 2 -> 'A1(M) = M^`(1)^#. +Proof. by move/FTcore_type_gt2 <-. Qed. + +(* This section covers the characterization of the F, P, P1 and P2 types of *) +(* maximal subgroups summarized at the top of p. 125. in B & G. *) +Section KappaClassification. + +Variables M U K : {group gT}. +Hypotheses (maxM : M \in 'M) (complU : kappa_complement M U K). + +Remark trivgFmax : (M \in 'M_'F) = (K :==: 1). +Proof. by rewrite (trivg_kappa maxM); case: complU. Qed. + +Remark trivgPmax : (M \in 'M_'P) = (K :!=: 1). +Proof. by rewrite inE trivgFmax maxM andbT. Qed. + +Remark FmaxP : reflect (K :==: 1 /\ U :!=: 1) (M \in 'M_'F). +Proof. +rewrite (trivg_kappa_compl maxM complU) 2!inE. +have [_ hallK _] := complU; rewrite (trivg_kappa maxM hallK). +by apply: (iffP idP) => [-> | []]. +Qed. + +Remark P1maxP : reflect (K :!=: 1 /\ U :==: 1) (M \in 'M_'P1). +Proof. +rewrite (trivg_kappa_compl maxM complU) inE -trivgPmax. +by apply: (iffP idP) => [|[] //]; case/andP=> ->. +Qed. + +Remark P2maxP : reflect (K :!=: 1 /\ U :!=: 1) (M \in 'M_'P2). +Proof. +rewrite (trivg_kappa_compl maxM complU) -trivgPmax. +by apply: (iffP setDP) => [] []. +Qed. + +End KappaClassification. + +(* This section covers the combinatorial statements of B & G, Lemma 16.1. It *) +(* needs to appear before summary theorems A-E because we are following *) +(* Peterfalvi in anticipating the classification in the definition of the *) +(* kernel sets A1(M), A(M) and A0(M). The actual correspondence between the *) +(* combinatorial classification and the mathematical description, i.e., the *) +(* of_typeXX predicates, will be given later. *) +Section FTtypeClassification. + +Variable M : {group gT}. +Hypothesis maxM : M \in 'M. + +Lemma kappa_witness : + exists UK : {group gT} * {group gT}, kappa_complement M UK.1 UK.2. +Proof. +have [K hallK] := Hall_exists \kappa(M) (mmax_sol maxM). +by have [U complU] := ex_kappa_compl maxM hallK; exists (U, K). +Qed. + +(* This is B & G, Lemma 16.1(a). *) +Lemma FTtype_Fmax : (M \in 'M_'F) = (FTtype M == 1%N). +Proof. +by rewrite inE maxM /FTtype; case: (_.-group M) => //; do 3!case: ifP => // _. +Qed. + +Lemma FTtype_Pmax : (M \in 'M_'P) = (FTtype M != 1%N). +Proof. by rewrite inE maxM andbT FTtype_Fmax. Qed. + +(* This is B & G, Lemma 16.1(b). *) +Lemma FTtype_P2max : (M \in 'M_'P2) = (FTtype M == 2). +Proof. +have [[U K] /= complU] := kappa_witness. +rewrite (sameP (P2maxP maxM complU) andP) -(trivgFmax maxM complU) FTtype_Fmax. +have [-> // | notMtype1] := altP eqP. +have ntK: K :!=: 1 by rewrite -(trivgFmax maxM complU) FTtype_Fmax. +have [_ [//|defM' _] _ _ _] := kappa_structure maxM complU. +do [rewrite /FTtype; case: ifP => // _] in notMtype1 *. +rewrite -cardG_gt1 eqEcard Msigma_der1 //= -(sdprod_card defM') -ltnNge. +rewrite -(@ltn_pmul2l #|M`_\sigma|) ?cardG_gt0 //= muln1. +by case: leqP => // _; do 2!case: ifP=> //. +Qed. + +(* This covers the P1 part of B & G, Lemma 16.1 (c) and (d). *) +Lemma FTtype_P1max : (M \in 'M_'P1) = (2 < FTtype M <= 5). +Proof. +rewrite 2!ltn_neqAle -!andbA FTtype_range andbT eq_sym -FTtype_P2max. +rewrite eq_sym -FTtype_Pmax in_setD inE. +by case: (M \in _); rewrite ?andbT ?andbF ?negbK. +Qed. + +Lemma Msigma_eq_der1 : M \in 'M_'P1 -> M`_\sigma = M^`(1). +Proof. +have [[U K] /= complU] := kappa_witness. +case/(P1maxP maxM complU)=> ntK; move/eqP=> U1. +by have [_ [//|<- _] _ _ _] := kappa_structure maxM complU; rewrite U1 sdprodg1. +Qed. + +Lemma def_FTcore : M`_\s = M`_\sigma. +Proof. +rewrite /FTcore -mem_iota 2!inE -FTtype_Fmax -FTtype_P2max. +have [notP1maxM |] := ifPn. + by apply/Fcore_eq_Msigma; rewrite ?notP1type_Msigma_nil. +case/norP=> notFmaxM; rewrite inE andbC inE maxM notFmaxM negbK => P1maxM. +by rewrite Msigma_eq_der1. +Qed. + +(* Other relations between the 'core' groups. *) + +Lemma FTcore_sub_der1 : M`_\s \subset M^`(1)%g. +Proof. by rewrite def_FTcore Msigma_der1. Qed. + +Lemma Fcore_sub_FTcore : M`_\F \subset M`_\s. +Proof. by rewrite def_FTcore Fcore_sub_Msigma. Qed. + +Lemma mmax_Fcore_neq1 : M`_\F != 1. +Proof. by have [[]] := Fcore_structure maxM. Qed. + +Lemma mmax_Fitting_neq1 : 'F(M) != 1. +Proof. exact: subG1_contra (Fcore_sub_Fitting M) mmax_Fcore_neq1. Qed. + +Lemma FTcore_neq1 : M`_\s != 1. +Proof. exact: subG1_contra Fcore_sub_FTcore mmax_Fcore_neq1. Qed. + +Lemma norm_mmax_Fcore : 'N(M`_\F) = M. +Proof. exact: mmax_normal (gFnormal _ _) mmax_Fcore_neq1. Qed. + +Lemma norm_FTcore : 'N(M`_\s) = M. +Proof. exact: mmax_normal (FTcore_normal _) FTcore_neq1. Qed. + +Lemma norm_mmax_Fitting : 'N('F(M)) = M. +Proof. exact: mmax_normal (gFnormal _ _) mmax_Fitting_neq1. Qed. + +(* This is B & G, Lemma 16.1(f). *) +Lemma Fcore_eq_FTcore : reflect (M`_\F = M`_\s) (FTtype M \in pred3 1%N 2 5). +Proof. +rewrite /FTcore -mem_iota 3!inE orbA; case type12M: (_ || _); first by left. +move: type12M FTtype_P1max; rewrite /FTtype; do 2![case: ifP => // _] => _. +rewrite !(fun_if (leq^~ 5)) !(fun_if (leq 3)) !if_same /= => P1maxM. +rewrite Msigma_eq_der1 // !(fun_if (eq_op^~ 5)) if_same. +by rewrite [if _ then _ else _]andbT; apply: eqP. +Qed. + +(* This is the second part of B & G, Lemma 16.1(c). *) +Lemma Fcore_neq_FTcore : (M`_\F != M`_\s) = (FTtype M \in pred2 3 4). +Proof. +have:= FTtype_range M; rewrite -mem_iota (sameP eqP Fcore_eq_FTcore). +by do 5!case/predU1P=> [-> //|]. +Qed. + +Lemma FTcore_eq_der1 : FTtype M > 2 -> M`_\s = M^`(1). +Proof. +move=> FTtype_gt2; rewrite def_FTcore Msigma_eq_der1 // FTtype_P1max. +by rewrite FTtype_gt2; case/andP: (FTtype_range M). +Qed. + +End FTtypeClassification. + +(* Internal automorphism. *) +Lemma FTtypeJ M x : FTtype (M :^ x) = FTtype M. +Proof. +rewrite /FTtype (eq_p'group _ (kappaJ _ _)) pgroupJ MsigmaJ FcoreJ derJ. +rewrite !(can_eq (conjsgK x)); do 4!congr (if _ then _ else _). +rewrite -quotientInorm normJ -conjIg /= setIC -{1 3}(setIidPr (normG M`_\F)). +rewrite -!morphim_conj -morphim_quotm ?normalG //= => nsMFN. +by rewrite injm_abelian /= ?im_quotient // injm_quotm ?injm_conj. +Qed. + +Lemma FTcoreJ M x : (M :^ x)`_\s = M`_\s :^ x. +Proof. by rewrite /FTcore FTtypeJ FcoreJ derJ; case: ifP. Qed. + +Lemma FTsupp1J M x : 'A1(M :^ x) = 'A1(M) :^ x. +Proof. by rewrite conjD1g -FTcoreJ. Qed. + +Lemma FTsuppJ M x : 'A(M :^ x) = 'A(M) :^ x. +Proof. +rewrite -bigcupJ /'A(_) FTsupp1J big_imset /=; last exact: in2W (conjg_inj x). +by apply: eq_bigr => y _; rewrite FTtypeJ derJ cent1J -conjIg conjD1g. +Qed. + +Lemma FTsupp0J M x : 'A0(M :^ x) = 'A0(M) :^ x. +Proof. +apply/setP=> y; rewrite mem_conjg !inE FTsuppJ !mem_conjg; congr (_ || _ && _). +by rewrite FTtypeJ !p_eltJ derJ /= cardJg. +Qed. + +(* Inclusion/normality of class function supports. *) + +Lemma FTsupp_sub0 M : 'A(M) \subset 'A0(M). +Proof. exact: subsetUl. Qed. + +Lemma FTsupp0_sub M : 'A0(M) \subset M^#. +Proof. +rewrite subUset andbC subsetD1 setIdE subsetIl !inE p_elt1 andbF /=. +by apply/bigcupsP=> x _; rewrite setSD ?subIset ?der_sub. +Qed. + +Lemma FTsupp_sub M : 'A(M) \subset M^#. +Proof. exact: subset_trans (FTsupp_sub0 M) (FTsupp0_sub M). Qed. + +Lemma FTsupp1_norm M : M \subset 'N('A1(M)). +Proof. by rewrite normD1 (normal_norm (FTcore_normal M)). Qed. + +Lemma FTsupp_norm M : M \subset 'N('A(M)). +Proof. +apply/subsetP=> y My; rewrite inE -bigcupJ; apply/bigcupsP=> x A1x. +rewrite (bigcup_max (x ^ y)) ?memJ_norm ?(subsetP (FTsupp1_norm M)) //. +by rewrite conjD1g conjIg cent1J (normsP _ y My) ?gFnorm. +Qed. + +Lemma FTsupp0_norm M : M \subset 'N('A0(M)). +Proof. +rewrite normsU ?FTsupp_norm // setIdE normsI //. +by apply/normsP=> x _; apply/setP=> y; rewrite mem_conjg !inE !p_eltJ. +Qed. + +Section MmaxFTsupp. +(* Support inclusions that depend on the maximality of M. *) + +Variable M : {group gT}. +Hypothesis maxM : M \in 'M. + +Lemma FTsupp1_sub : 'A1(M) \subset 'A(M). +Proof. +apply/subsetP=> x A1x; apply/bigcupP; exists x => //. +have [ntx Ms_x] := setD1P A1x; rewrite 3!inE ntx cent1id (subsetP _ x Ms_x) //. +by case: (~~ _); rewrite ?FTcore_sub_der1 ?FTcore_sub. +Qed. + +Lemma FTsupp1_sub0 : 'A1(M) \subset 'A0(M). +Proof. exact: subset_trans FTsupp1_sub (FTsupp_sub0 M). Qed. + +Lemma FTsupp1_neq0 : 'A1(M) != set0. +Proof. by rewrite setD_eq0 subG1 FTcore_neq1. Qed. + +Lemma FTsupp_neq0 : 'A(M) != set0. +Proof. +by apply: contraNneq FTsupp1_neq0 => AM_0; rewrite -subset0 -AM_0 FTsupp1_sub. +Qed. + +Lemma FTsupp0_neq0 : 'A0(M) != set0. +Proof. +by apply: contraNneq FTsupp_neq0 => A0M_0; rewrite -subset0 -A0M_0 FTsupp_sub0. +Qed. + +Lemma Fcore_sub_FTsupp1 : M`_\F^# \subset 'A1(M). +Proof. exact: setSD (Fcore_sub_FTcore maxM). Qed. + +Lemma Fcore_sub_FTsupp : M`_\F^# \subset 'A(M). +Proof. exact: subset_trans Fcore_sub_FTsupp1 FTsupp1_sub. Qed. + +Lemma Fcore_sub_FTsupp0 : M`_\F^# \subset 'A0(M). +Proof. exact: subset_trans Fcore_sub_FTsupp1 FTsupp1_sub0. Qed. + +Lemma Fitting_sub_FTsupp : 'F(M)^# \subset 'A(M). +Proof. +pose pi := \pi(M`_\F); have nilF := Fitting_nil M. +have [U defF]: {U : {group gT} | M`_\F \x U = 'F(M)}. + have hallH := pHall_subl (Fcore_sub_Fitting M) (gFsub _ _) (Fcore_Hall M). + exists 'O_pi^'('F(M))%G; rewrite (nilpotent_Hall_pcore nilF hallH). + exact: nilpotent_pcoreC. +apply/subsetP=> xy /setD1P[ntxy Fxy]; apply/bigcupP. +have [x [y [Hx Vy Dxy _]]] := mem_dprod defF Fxy. +have [z [ntz Hz czxy]]: exists z, [/\ z != 1%g, z \in M`_\F & x \in 'C[z]]. + have [-> | ntx] := eqVneq x 1%g; last by exists x; rewrite ?cent1id. + by have /trivgPn[z ntz] := mmax_Fcore_neq1 maxM; exists z; rewrite ?group1. +exists z; first by rewrite !inE ntz (subsetP (Fcore_sub_FTcore maxM)). +rewrite 3!inE ntxy {2}Dxy groupMl //= andbC (subsetP _ y Vy) //=; last first. + by rewrite sub_cent1 (subsetP _ _ Hz) // centsC; have [] := dprodP defF. +rewrite -FTtype_Pmax // (subsetP _ xy Fxy) //. +case MtypeP: (M \in _); last exact: gFsub. +by have [_ _ _ ->] := Fitting_structure maxM. +Qed. + +Lemma Fitting_sub_FTsupp0 : 'F(M)^# \subset 'A0(M). +Proof. exact: subset_trans Fitting_sub_FTsupp (FTsupp_sub0 M). Qed. + +Lemma FTsupp_eq1 : (2 < FTtype M)%N -> 'A(M) = 'A1(M). +Proof. +move=> typeMgt2; rewrite /'A(M) -(subnKC typeMgt2) /= -FTcore_eq_der1 //. +apply/setP=> y; apply/bigcupP/idP=> [[x A1x /setD1P[nty /setIP[Ms_y _]]] | A1y]. + exact/setD1P. +by exists y; rewrite // inE in_setI cent1id andbT -in_setD. +Qed. + +End MmaxFTsupp. + +Section SingleGroupSummaries. + +Variables M U K : {group gT}. +Hypotheses (maxM : M \in 'M) (complU : kappa_complement M U K). + +Let Kstar := 'C_(M`_\sigma)(K). + +Theorem BGsummaryA : + [/\ (*1*) [/\ M`_\sigma <| M, \sigma(M).-Hall(M) M`_\sigma & + \sigma(M).-Hall(G) M`_\sigma], + (*2*) \kappa(M).-Hall(M) K /\ cyclic K, + (*3*) [/\ U \in [complements to M`_\sigma <*> K in M], + K \subset 'N(U), + M`_\sigma <*> U <| M, + U <| U <*> K + & M`_\sigma * U * K = M], + (*4*) {in K^#, forall k, 'C_U[k] = 1} + & + [/\ (*5*) Kstar != 1 /\ {in K^#, forall k, K \x Kstar = 'C_M[k]}, + (*6*) [/\ M`_\F != 1, M`_\F \subset M`_\sigma, M`_\sigma \subset M^`(1), + M^`(1) \proper M & nilpotent (M^`(1) / M`_\F)], + (*7*) [/\ M^`(2) \subset 'F(M), M`_\F * 'C_M(M`_\F) = 'F(M) + & K :!=: 1 -> 'F(M) \subset M^`(1)] + & (*8*) M`_\F != M`_\sigma -> + [/\ U :=: 1, normedTI 'F(M)^# G M & prime #|K| ]]]. +Proof. +have [hallU hallK _] := complU; split. +- by rewrite pcore_normal Msigma_Hall // Msigma_Hall_G. +- by have [[]] := kappa_structure maxM complU. +- have [_ defM _ _ _] := kappa_compl_context maxM complU. + have [[_ UK _ defUK]] := sdprodP defM; rewrite defUK. + have [nsKUK _ mulUK nUK _] := sdprod_context defUK. + rewrite -mulUK mulG_subG mulgA => mulMsUK /andP[nMsU nMsK] _. + rewrite (norm_joinEr nUK) mulUK; split=> //. + rewrite inE coprime_TIg /= norm_joinEr //=. + by rewrite -mulgA (normC nUK) mulgA mulMsUK !eqxx. + rewrite (pnat_coprime _ (pHall_pgroup hallU)) // -pgroupE pgroupM. + rewrite (sub_pgroup _ (pHall_pgroup hallK)) => [|p k_p]; last first. + by apply/orP; right. + by rewrite (sub_pgroup _ (pcore_pgroup _ _)) => // p s_p; apply/orP; left. + have{defM} [[defM _ _] _ _ _ _] := kappa_structure maxM complU. + have [[MsU _ defMsU] _ _ _ _] := sdprodP defM; rewrite defMsU in defM. + have [_ mulMsU _ _] := sdprodP defMsU. + by rewrite norm_joinEr // mulMsU; case/sdprod_context: defM. +- by have [] := kappa_compl_context maxM complU. +split. +- have [K1 | ntK] := eqsVneq K 1. + rewrite /Kstar K1 cent1T setIT Msigma_neq1 // setDv. + by split=> // k; rewrite inE. + have PmaxM: M \in 'M_'P by rewrite inE -(trivg_kappa maxM hallK) ntK. + have [_ [defNK _] [-> _] _ _] := Ptype_structure PmaxM hallK. + have [_ _ cKKs tiKKs] := dprodP defNK; rewrite dprodEY //; split=> // k Kk. + by have [_ _ [_ _ _ [_ _ -> // _ _] _]] := Ptype_embedding PmaxM hallK. +- have [_ _ [_ ->] _] := Fitting_structure maxM. + by have [[]] := Fcore_structure maxM. +- have [_ [-> defF _] _ sFM'] := Fitting_structure maxM. + have [_ -> _] := cprodP defF; split=> // ntK. + by rewrite sFM' // inE -(trivg_kappa maxM hallK) ntK. +move=> not_nilMs; pose q := #|Kstar|. +have solMs: solvable M`_\sigma := solvableS (pcore_sub _ _) (mmax_sol maxM). +have [D hallD] := Hall_exists q^' solMs. +have [_] := Fcore_structure maxM; case/(_ K D)=> //. +case=> P1maxM _ _ [-> _ _ _] _ _ _; split=> //. + by apply/eqP; rewrite (trivg_kappa_compl maxM complU). +by apply: contraR not_nilMs; case/nonTI_Fitting_facts=> // _ -> _. +Qed. + +(* This is a variant of B & G, Lemma 16.1(e) that better fits the Peterfalvi *) +(* definitions. *) +Lemma sdprod_FTder : M`_\sigma ><| U = M^`(FTtype M != 1%N). +Proof. +rewrite -FTtype_Fmax // (trivgFmax maxM complU). +have [[defM _ _] defM' _ _ _] := kappa_structure maxM complU. +by case: (altP eqP) defM' defM => [-> _ | _ [] //]; rewrite sdprodg1. +Qed. + +Theorem BGsummaryB : + [/\ (*1*) forall p S, p.-Sylow(U) S -> abelian S /\ 'r(S) <= 2, + (*2*) abelian <>, + (*3*) exists U0 : {group gT}, + [/\ U0 \subset U, exponent U0 = exponent U & [disjoint U0 & 'A(M)]] + & (*4*) (forall X, X \subset U -> X :!=: 1 -> 'C_(M`_\sigma)(X) != 1 -> + 'M('C(X)) = [set M]) + /\ (*5*) ('A(M) != 'A1(M) -> normedTI ('A(M) :\: 'A1(M)) G M)]. +Proof. +split. +- move=> p S sylS; have [hallU _ _] := complU; have [sUM sk'U _] := and3P hallU. + have [-> | ntS] := eqsVneq S 1; first by rewrite abelian1 rank1. + have sk'p: p \in \sigma_kappa(M)^'. + by rewrite (pnatPpi sk'U) // -p_rank_gt0 -(rank_Sylow sylS) rank_gt0. + have{sylS} sylS := subHall_Sylow hallU sk'p sylS. + have [[sSM pS _] [/= s'p _]] := (and3P sylS, norP sk'p). + rewrite (sigma'_nil_abelian maxM) ?(pi_pgroup pS) ?(pgroup_nil pS) //. + rewrite (rank_Sylow sylS) leqNgt (contra _ s'p) //; exact: alpha_sub_sigma. +- have [_ _ _ cUA_UA _] := kappa_structure maxM complU. + apply: abelianS cUA_UA; rewrite genS // -big_distrr ?setIS -?def_FTcore //=. + by apply/bigcupsP=> x A1x; rewrite (bigcup_max x) // setDE setIAC subsetIr. +- have [-> | ntU] := eqsVneq U 1. + exists 1%G; split; rewrite // disjoint_sym disjoints_subset. + by apply/bigcupsP=> x _; rewrite setDE subsetIr. + have [_ _ _ _ [// | U0 [sU0U expU0 frobU0]]] := kappa_structure maxM complU. + exists U0; split; rewrite // -setI_eq0 big_distrr /= /'A1(M) def_FTcore //. + rewrite big1 // => x A1x; apply/eqP; rewrite setIDA setD_eq0 setICA. + by rewrite (Frobenius_reg_compl frobU0) ?subsetIr. +set part4 := forall X, _; have part4holds: part4. + move=> X sXU ntX nregX. + by have [_ _] := kappa_structure maxM complU; case/(_ X). +have [[nsMsM _ _] _ [_ _ nsMsUM _ _] _ _] := BGsummaryA. +have{nsMsM nsMsUM}[[_ nMsM] [_ nMsUM]] := (andP nsMsM, andP nsMsUM). +rewrite eqEsubset FTsupp1_sub // -setD_eq0 andbT; set B := _ :\: _. +have nBM: M \subset 'N(B) by rewrite normsD ?FTsupp_norm ?FTsupp1_norm. +have uniqB y (u := y.`_\sigma(M)^'): y \in B -> 'M('C[u]) = [set M]. + case/setDP=> /bigcupP[x /setD1P[ntx Ms_x] /setD1P[nty /setIP[M'y cxy]]]. + rewrite !inE nty def_FTcore //= in Ms_x * => notMs_y; set M' := M^`(_) in M'y. + have [nsMsM' _ _ _ _] := sdprod_context sdprod_FTder. + have [[sMsM' nMsM'] sM'M]:= (andP nsMsM', der_sub _ M : M' \subset M). + have hallMs := pHall_subl sMsM' sM'M (Msigma_Hall maxM). + have hallU: \sigma(M)^'.-Hall(M') U. + by rewrite -(compl_pHall _ hallMs) sdprod_compl ?sdprod_FTder. + have suM': <[u]> \subset M' by rewrite cycle_subG groupX. + have solM': solvable M' := solvableS sM'M (mmax_sol maxM). + have [z M'z suzU] := Hall_Jsub solM' hallU suM' (p_elt_constt _ _). + have Mz': z^-1 \in M by rewrite groupV (subsetP sM'M). + rewrite -(conjgK z u) -(group_inj (conjGid Mz')) -cent_cycle. + rewrite !cycleJ centJ; apply: def_uniq_mmaxJ (part4holds _ suzU _ _). + rewrite /= -cycleJ cycle_eq1 -consttJ; apply: contraNneq notMs_y. + move/constt1P; rewrite p_eltNK p_eltJ => sMy. + by rewrite (mem_normal_Hall hallMs). + rewrite -(normsP nMsM' z M'z) centJ -conjIg -(isog_eq1 (conj_isog _ _)). + by apply/trivgPn; exists x; rewrite //= inE Ms_x cent_cycle cent1C groupX. +split=> // nzB; apply/normedTI_P; rewrite setTI; split=> // a _. +case/pred0Pn=> x /andP[/= Bx]; rewrite mem_conjg => /uniqB/(def_uniq_mmaxJ a). +rewrite consttJ -normJ conjg_set1 conjgKV uniqB // => /set1_inj defM. +by rewrite -(norm_mmax maxM) inE {2}defM. +Qed. + +Let Z := K <*> Kstar. +Let Zhat := Z :\: (K :|: Kstar). + +(* We strengthened the uniqueness condition in part (4) to *) +(* 'M_\sigma(K) = [set Mstar]. *) +Theorem BGsummaryC : K :!=: 1 -> + [/\ + [/\ (*1*) abelian U /\ ~~ ('N(U) \subset M), + (*2*) [/\ cyclic Kstar, Kstar != 1, Kstar \subset M`_\F & ~~ cyclic M`_\F] + & (*3*) M`_\sigma ><| U = M^`(1) /\ Kstar \subset M^`(2)], + exists Mstar, + [/\ (*4*) [/\ Mstar \in 'M_'P, 'C_(Mstar`_\sigma)(Kstar) = K, + \kappa(Mstar).-Hall(Mstar) Kstar + & 'M_\sigma(K) = [set Mstar]], (* uniqueness *) + (*5*) {in 'E^1(Kstar), forall X, 'M('C(X)) = [set M]} + /\ {in 'E^1(K), forall Y, 'M('C(Y)) = [set Mstar]}, + (*6*) [/\ M :&: Mstar = Z, K \x Kstar = Z & cyclic Z] + & (*7*) (M \in 'M_'P2 \/ Mstar \in 'M_'P2) + /\ {in 'M_'P, forall H, gval H \in M :^: G :|: Mstar :^: G}] +& [/\ (*8*) normedTI Zhat G Z, + (*9*) let B := 'A0(M) :\: 'A(M) in + B = class_support Zhat M /\ normedTI B G M, + (*10*) U :!=: 1 -> + [/\ prime #|K|, normedTI 'F(M)^# G M & M`_\sigma \subset 'F(M)] + & (*11*) U :==: 1 -> prime #|Kstar| ]]. +Proof. +move=> ntK; have [_ hallK _] := complU. +have PmaxM: M \in 'M_'P by rewrite inE -(trivg_kappa maxM hallK) ntK. +split. +- have [_ [//|-> ->] _ _ _] := kappa_structure maxM complU. + have [-> -> -> -> ->] := Ptype_cyclics PmaxM hallK; do 2!split=> //. + have [L maxCK_L] := mmax_exists (mFT_cent_proper ntK). + have [-> | ntU] := eqsVneq U 1. + by rewrite norm1 proper_subn // mmax_proper. + have P2maxM: M \in 'M_'P2 by rewrite inE -(trivg_kappa_compl maxM complU) ntU. + have [r _ rU] := rank_witness U; have [R sylR] := Sylow_exists r U. + have ntR: R :!=: 1 by rewrite -rank_gt0 (rank_Sylow sylR) -rU rank_gt0. + have ltRG: R \proper G := mFT_pgroup_proper (pHall_pgroup sylR). + have [H maxNR_H] := mmax_exists (mFT_norm_proper ntR ltRG). + apply: contra (subset_trans (subsetIr H _)) _. + by have [_ _ _ [->]] := P2type_signalizer P2maxM complU maxCK_L sylR maxNR_H. +- have [L [PmaxL _] [uniqL []]] := Ptype_embedding PmaxM hallK. + rewrite -/Kstar -/Z -/Zhat => hallKstar _ [defK _] [cycZ defML _ _ _]. + case=> _ P2_MorL Pmax_conjMorL _; exists L. + suffices uniqMSK: 'M_\sigma(K) = [set L]. + have [_ [defNK _] [_ uniqM] _ _] := Ptype_structure PmaxM hallK. + do 2!split=> //; last by case: P2_MorL => [] [-> _]; [left | right]. + by have [_ _ cKKs tiKKs] := dprodP defNK; rewrite dprodEY. + have sKLs: K \subset L`_\sigma by rewrite -defK subsetIl. + have [X E1X]: exists X, X \in 'E^1(K) by apply/rank_geP; rewrite rank_gt0. + have sXK: X \subset K by case/nElemP: E1X => ? /pnElemP[]. + have [maxL sCXL] := mem_uniq_mmax (uniqL X E1X). + have [x defKx] := cyclicP (cyclicS (joing_subl _ _) cycZ). + have SMxL: L \in 'M_\sigma[x] by rewrite -defKx inE maxL. + have ell1x: \ell_\sigma(x) == 1%N. + by rewrite (Msigma_ell1 maxL) // !inE -cycle_eq1 -cycle_subG -defKx ntK. + apply/eqP; rewrite eq_sym eqEcard defKx sub1set SMxL cards1 leqNgt. + apply/negP=> ntSMx; have [_ [//|_ ntR _ _]] := FT_signalizer_context ell1x. + case/(_ L)=> // /sdprodP[_ _ _ tiRL]; case/negP: ntR. + rewrite -subG1 -tiRL subsetIidl -setIA setICA setISS ?pcore_sub //. + by rewrite subsetIidr /= -cent_cycle -defKx (subset_trans (centS sXK) sCXL). +split; last 1 first. +- rewrite (trivg_kappa_compl maxM complU) => P1maxM. + have [L _ [_ _ _ _ [_ [] [] //]]] := Ptype_embedding PmaxM hallK. + by rewrite inE P1maxM. +- by have [L _ [_ _ _ _ [[]]]] := Ptype_embedding PmaxM hallK. +- have [L _ [_ _ _]] := Ptype_embedding PmaxM hallK; rewrite -/Zhat -/Z. + case=> cycZ defML defCK defCKs defCZhat [[tiZhat tiZhatM _] _ _ defM] B. + have sZM: Z \subset M by rewrite -[Z]defML subsetIl. + have sZhM: Zhat \subset M by rewrite subDset setUC subsetU ?sZM. + suffices defB: B = class_support Zhat M. + split=> //; apply/normedTI_P. + rewrite setTI normsD ?FTsupp_norm ?FTsupp0_norm //; split=> // [|g _]. + case/andP: tiZhat => /set0Pn[z Zz] _; apply/set0Pn; exists z. + by rewrite defB mem_class_support. + rewrite defB => /pred0Pn[_ /andP[/imset2P[z x Zz Mx ->] /= Bg_zx]]. + apply/idPn; rewrite -(groupMr g (groupVr Mx)) -in_setC. + case/tiZhatM/pred0Pn; exists z; rewrite /= Zz conjsgM mem_conjgV. + by apply: subsetP Bg_zx; rewrite conjSg class_support_subG. + rewrite /B /'A0(M); set M' := M^`(_); set su := \pi(M'). + have defM': M' = M^`(1) by rewrite /M' -FTtype_Pmax ?PmaxM. + have{hallK} hallM': su.-Hall(M) M'. + by rewrite Hall_pi //= -/M' defM' (sdprod_Hall defM) (pHall_Hall hallK). + have{hallM'} hallK: su^'.-Hall(M) K. + by rewrite -(compl_pHall _ hallM') /= -/M' defM' sdprod_compl. + have su'K: su^'.-group K := pHall_pgroup hallK. + have suKs: su.-group Kstar. + by rewrite (pgroupS _ (pgroup_pi _)) ///= -/M' defM' subIset ?Msigma_der1. + apply/setP=> x; rewrite !inE; apply/andP/imset2P=> [[]| [y a]]; last first. + case/setDP=> Zy; rewrite inE => /norP[not_Ky notKs_y] Ma ->. + have My := subsetP sZM y Zy; have Mya := groupJ My Ma. + have [not_suy not_su'y]: ~~ su.-elt y /\ ~~ su^'.-elt y. + have defZ: K * Kstar = Z by rewrite -cent_joinEr ?subsetIr. + have [hallK_Z hallKs] := coprime_mulGp_Hall defZ su'K suKs. + have ns_Z := sub_abelian_normal _ (cyclic_abelian cycZ). + rewrite -(mem_normal_Hall hallKs) -?ns_Z ?joing_subr // notKs_y. + by rewrite -(mem_normal_Hall hallK_Z) -?ns_Z ?joing_subl. + rewrite Mya !p_eltJ not_suy not_su'y orbT; split=> //. + apply: contra not_suy => /bigcupP[_ _ /setD1P[_ /setIP[M'ya _]]]. + by rewrite -(p_eltJ _ y a) (mem_p_elt (pgroup_pi _)). + move/negPf=> -> /and3P[Mx not_sux not_su'x]; set y := x.`_su^'. + have syM: <[y]> \subset M by rewrite cycle_subG groupX. + have [a Ma Kya] := Hall_Jsub (mmax_sol maxM) hallK syM (p_elt_constt _ _). + have{Kya} K1ya: y ^ a \in K^#. + rewrite !inE -cycle_subG cycleJ Kya andbT -consttJ. + by apply: contraNneq not_sux; move/constt1P; rewrite p_eltNK p_eltJ. + exists (x ^ a) a^-1; rewrite ?groupV ?conjgK // 2!inE andbC negb_or. + rewrite -[Z](defCK _ K1ya) inE groupJ // cent1C -consttJ groupX ?cent1id //. + by rewrite (contra (mem_p_elt su'K)) ?(contra (mem_p_elt suKs)) ?p_eltJ. +rewrite (trivg_kappa_compl maxM complU) => notP1maxM. +have P2maxM: M \in 'M_'P2 by exact/setDP. +split; first by have [_ _ _ _ []] := Ptype_structure PmaxM hallK. + apply: contraR notP1maxM; case/nonTI_Fitting_facts=> //. + by case/setUP=> //; case/idPn; case/setDP: PmaxM. +have [<- | neqMF_Ms] := eqVneq M`_\F M`_\sigma; first exact: Fcore_sub_Fitting. +have solMs: solvable M`_\sigma := solvableS (pcore_sub _ _) (mmax_sol maxM). +have [D hallD] := Hall_exists #|Kstar|^' solMs. +by case: (Fcore_structure maxM) notP1maxM => _ /(_ K D)[] // [[->]]. +Qed. + +End SingleGroupSummaries. + +Theorem BGsummaryD M : M \in 'M -> + [/\ (*1*) {in M`_\sigma &, forall x y, y \in x ^: G -> y \in x ^: M}, + (*2*) forall g (Ms := M`_\sigma), g \notin M -> + Ms:&: M :^ g = Ms :&: Ms :^ g /\ cyclic (Ms :&: M :^ g), + (*3*) {in M`_\sigma^#, forall x, + [/\ Hall 'C[x] 'C_M[x], 'R[x] ><| 'C_M[x] = 'C[x] + & let MGx := [set Mg in M :^: G | x \in Mg] in + [transitive 'R[x], on MGx | 'Js] /\ #|'R[x]| = #|MGx| ]} + & (*4*) {in M`_\sigma^#, forall x (N := 'N[x]), ~~ ('C[x] \subset M) -> + [/\ 'M('C[x]) = [set N] /\ N`_\F = N`_\sigma, + x \in 'A(N) :\: 'A1(N) /\ N \in 'M_'F :|: 'M_'P2, + \sigma(N)^'.-Hall(N) (M :&: N) + & N \in 'M_'P2 -> + [/\ M \in 'M_'F, + exists2 E, [Frobenius M = M`_\sigma ><| gval E] & cyclic E + & ~~ normedTI (M`_\F)^# G M]]}]. +Proof. +move=> maxM; have [[U K] /= complU] := kappa_witness maxM. +have defSM: {in M`_\sigma^#, + forall x, [set Mg in M :^: G | x \in Mg] = val @: 'M_\sigma[x]}. +- move=> x /setD1P[ntx Ms_x]. + have SMxM: M \in 'M_\sigma[x] by rewrite inE maxM cycle_subG. + apply/setP=> /= Mg; apply/setIdP/imsetP=> [[] | [H]]. + case/imsetP=> g _ -> Mg_x; exists (M :^ g)%G => //=. + rewrite inE cycle_subG (mem_Hall_pcore (Msigma_Hall _)) ?mmaxJ // maxM. + by rewrite (eq_p_elt _ (sigmaJ _ _)) (mem_p_elt (pcore_pgroup _ M)). + case/setIdP=> maxH; rewrite cycle_subG => Hs_x ->. + split; last exact: subsetP (pcore_sub _ _) x Hs_x. + pose p := pdiv #[x]; have pixp: p \in \pi(#[x]) by rewrite pi_pdiv order_gt1. + apply/idPn=> /(sigma_partition maxM maxH)/(_ p). + rewrite inE /= (pnatPpi (mem_p_elt (pcore_pgroup _ _) Ms_x)) //. + by rewrite (pnatPpi (mem_p_elt (pcore_pgroup _ _) Hs_x)). +split. +- have hallMs := pHall_subl (subxx _) (subsetT _) (Msigma_Hall_G maxM). + move=> x y Ms_x Ms_y /=/imsetP[a _ def_y]; rewrite def_y in Ms_y *. + have [b /setIP[Mb _ ->]] := sigma_Hall_tame maxM hallMs Ms_x Ms_y. + exact: mem_imset. +- move=> g notMg; split. + apply/eqP; rewrite eqEsubset andbC setIS ?conjSg ?pcore_sub //=. + rewrite subsetI subsetIl -MsigmaJ. + rewrite (sub_Hall_pcore (Msigma_Hall _)) ?mmaxJ ?subsetIr //. + rewrite (eq_pgroup _ (sigmaJ _ _)). + exact: pgroupS (subsetIl _ _) (pcore_pgroup _ _). + have [E hallE] := ex_sigma_compl maxM. + by have [_ _] := sigma_compl_embedding maxM hallE; case/(_ g). +- move=> x Ms1x /=. + have [[ntx Ms_x] ell1x] := (setD1P Ms1x, Msigma_ell1 maxM Ms1x). + have [[trR oR nsRC hallR] defC] := FT_signalizer_context ell1x. + have SMxM: M \in 'M_\sigma[x] by rewrite inE maxM cycle_subG. + suffices defCx: 'R[x] ><| 'C_M[x] = 'C[x]. + split=> //; first by rewrite -(sdprod_Hall defCx). + rewrite defSM //; split; last by rewrite (card_imset _ val_inj). + apply/imsetP; exists (gval M); first exact: mem_imset. + by rewrite -(atransP trR _ SMxM) -imset_comp. + have [| SMgt1] := leqP #|'M_\sigma[x]| 1. + rewrite leq_eqVlt {2}(cardD1 M) SMxM orbF => eqSMxM. + have ->: 'R[x] = 1 by apply/eqP; rewrite trivg_card1 oR. + by rewrite sdprod1g (setIidPr _) ?cent1_sub_uniq_sigma_mmax. + have [uniqN _ _ _ defCx] := defC SMgt1. + have{defCx} [[defCx _ _ _] [_ sCxN]] := (defCx M SMxM, mem_uniq_mmax uniqN). + by rewrite -setIA (setIidPr sCxN) in defCx. +move=> x Ms1x /= not_sCM. +have [[ntx Ms_x] ell1x] := (setD1P Ms1x, Msigma_ell1 maxM Ms1x). +have SMxM: M \in 'M_\sigma[x] by rewrite inE maxM cycle_subG. +have SMgt1: #|'M_\sigma[x]| > 1. + apply: contraR not_sCM; rewrite -leqNgt leq_eqVlt {2}(cardD1 M) SMxM orbF. + by move/cent1_sub_uniq_sigma_mmax->. +have [_ [//|uniqN ntR t2Nx notP1maxN]] := FT_signalizer_context ell1x. +have [maxN sCxN] := mem_uniq_mmax uniqN. +case/(_ M SMxM)=> _ st2NsM _ ->; split=> //. +- by rewrite (Fcore_eq_Msigma maxN (notP1type_Msigma_nil _)) // -in_setU. +- split=> //; apply/setDP; split. + have [y Ry nty] := trivgPn _ ntR; have [Nsy cxy] := setIP Ry. + apply/bigcupP; exists y; first by rewrite 2!inE def_FTcore ?nty. + rewrite 3!inE ntx cent1C cxy -FTtype_Pmax //= andbT. + have Nx: x \in 'N[x] by rewrite (subsetP sCxN) ?cent1id. + case PmaxN: ('N[x] \in 'M_'P) => //. + have [KN hallKN] := Hall_exists \kappa('N[x]) (mmax_sol maxN). + have [_ _ [_ _ _ _ [_ _ _ defN]]] := Ptype_embedding PmaxN hallKN. + have hallN': \kappa('N[x])^'.-Hall('N[x]) 'N[x]^`(1). + exact/(sdprod_normal_pHallP (der_normal 1 _) hallKN). + rewrite (mem_normal_Hall hallN') ?der_normal // (sub_p_elt _ t2Nx) // => p. + by case/andP=> _; apply: contraL => /rank_kappa->. + rewrite 2!inE ntx def_FTcore //=; apply: contra ntx => Ns_x. + rewrite -(constt_p_elt (mem_p_elt (pcore_pgroup _ _) Ns_x)). + by rewrite (constt1P (sub_p_elt _ t2Nx)) // => p; case/andP. +move=> P2maxN; have [PmaxN _] := setDP P2maxN; have [_ notFmaxN] := setDP PmaxN. +have [FmaxM _ [E _]] := nonFtype_signalizer_base maxM Ms1x not_sCM notFmaxN. +case=> cycE frobM; split=> //; first by exists E. +move: SMgt1; rewrite (cardsD1 M) SMxM ltnS lt0n => /pred0Pn[My /setD1P[neqMyM]]. +move/(mem_imset val); rewrite -defSM //= => /setIdP[/imsetP[y _ defMy] My_x]. +rewrite (Fcore_eq_Msigma maxM (notP1type_Msigma_nil _)) ?FmaxM //. +apply/normedTI_P=> [[_ _ /(_ y (in_setT y))/contraR/implyP/idPn[]]]. +rewrite -{1}(norm_mmax maxM) (sameP normP eqP) -defMy neqMyM. +apply/pred0Pn; exists x; rewrite /= conjD1g !inE ntx Ms_x /= -MsigmaJ. +rewrite (mem_Hall_pcore (Msigma_Hall _)) ?mmaxJ /= -?defMy //. +by rewrite defMy (eq_p_elt _ (sigmaJ _ _)) (mem_p_elt (pcore_pgroup _ _) Ms_x). +Qed. + +Lemma mmax_transversalP : + [/\ 'M^G \subset 'M, is_transversal 'M^G (orbit 'JG G @: 'M) 'M, + {in 'M^G &, injective (fun M => M :^: G)} + & {in 'M, forall M, exists x, (M :^ x)%G \in 'M^G}]. +Proof. +have: [acts G, on 'M | 'JG] by apply/actsP=> x _ M; rewrite mmaxJ. +case/orbit_transversalP; rewrite -/mmax_transversal => -> -> injMX memMX. +split=> // [M H MX_M MX_H /= eqMH | M /memMX[x _]]; last by exists x. +have /orbitP[x Gx defH]: val H \in M :^: G by rewrite eqMH orbit_refl. +by apply/eqP; rewrite -injMX // -(group_inj defH) (mem_orbit 'JG). +Qed. + +(* We are conforming to the statement of B & G, but we defer the introduction *) +(* of 'M^G to Peterfalvi (8.17), which requires several other changes. *) +Theorem BGsummaryE : + [/\ (*1*) forall M, M \in 'M -> + #|class_support M^~~ G| = (#|M`_\sigma|.-1 * #|G : M|)%N, + (*2*) {in \pi(G), forall p, + exists2 M : {group gT}, M \in 'M & p \in \sigma(M)} + /\ {in 'M &, forall M H, + gval H \notin M :^: G -> [predI \sigma(M) & \sigma(H)] =i pred0} + & (*3*) let PG := [set class_support M^~~ G | M : {group gT} in 'M] in + [/\ partition PG (cover PG), + 'M_'P = set0 :> {set {group gT}} -> cover PG = G^# + & forall M K, M \in 'M_'P -> \kappa(M).-Hall(M) K -> + let Kstar := 'C_(M`_\sigma)(K) in + let Zhat := (K <*> Kstar) :\: (K :|: Kstar) in + partition [set class_support Zhat G; cover PG] G^#]]. +Proof. +split=> [||PG]; first exact: card_class_support_sigma. + by split=> [p /sigma_mmax_exists[M]|]; [exists M | apply: sigma_partition]. +have [noPmax | ntPmax] := eqVneq 'M_'P (set0 : {set {group gT}}). + rewrite noPmax; move/eqP in noPmax; have [partPG _] := mFT_partition gT. + have /and3P[/eqP-> _ _] := partPG noPmax; rewrite partPG //. + by split=> // M K; rewrite inE. +have [_ partZPG] := mFT_partition gT. +have partPG: partition PG (cover PG). + have [M PmaxM] := set0Pn _ ntPmax; have [maxM _] := setDP PmaxM. + have [K hallK] := Hall_exists \kappa(M) (mmax_sol maxM). + have{partZPG} [/and3P[_ tiPG]] := partZPG M K PmaxM hallK. + rewrite inE => /norP[_ notPGset0] _; apply/and3P; split=> //; apply/trivIsetP. + by apply: sub_in2 (trivIsetP tiPG) => C; apply: setU1r. +split=> // [noPmax | M K PmaxM hallK]; first by case/eqP: ntPmax. +have [/=] := partZPG M K PmaxM hallK; rewrite -/PG; set Z := class_support _ G. +case/and3P=> /eqP defG1 tiZPG; rewrite 2!inE => /norP[nzZ _] notPGZ. +have [_ tiPG nzPG] := and3P partPG; have [maxM _] := setDP PmaxM. +rewrite /cover big_setU1 //= -/(cover PG) in defG1. +rewrite /trivIset /cover !big_setU1 //= (eqnP tiPG) -/(cover PG) in tiZPG. +have tiZ_PG: Z :&: cover PG = set0. + by apply/eqP; rewrite setI_eq0 -leq_card_setU eq_sym. +have notUPGZ: Z \notin [set cover PG]. + by rewrite inE; apply: contraNneq nzZ => defZ; rewrite -tiZ_PG -defZ setIid. +rewrite /partition /trivIset /(cover _) !big_setU1 // !big_set1 /= -defG1. +rewrite eqxx tiZPG !inE negb_or nzZ /= eq_sym; apply: contraNneq nzPG => PG0. +apply/imsetP; exists M => //; apply/eqP; rewrite eq_sym -subset0 -PG0. +by rewrite (bigcup_max (class_support M^~~ G)) //; apply: mem_imset. +Qed. + +Let typePfacts M (H := M`_\F) U W1 W2 W (defW : W1 \x W2 = W) : + M \in 'M -> of_typeP M U defW -> + [/\ M \in 'M_'P, \kappa(M).-Hall(M) W1, 'C_H(W1) = W2, + (M \in 'M_'P1) = (U :==: 1) || ('N(U) \subset M) + & let Ms := M`_\sigma in + Ms = M^`(1) -> (H == Ms) = (U :==: 1) /\ abelian (Ms / H) = abelian U]. +Proof. +move=> maxM []{defW}; move: W1 W2 => K Ks [cycK hallK ntK defM] /=. +have [[_ /= sHMs sMsM' _] _] := Fcore_structure maxM. +rewrite -/H in sHMs * => [] [nilU sUM' nUK defM'] _ [_ ntKs sKsH _ prKsK _]. +have [_ sKM mulM'K _ tiM'K] := sdprod_context defM. +have defKs: 'C_H(K) = Ks. + have [[x defK] sHM'] := (cyclicP cycK, subset_trans sHMs sMsM'). + have K1x: x \in K^# by rewrite !inE -cycle_eq1 -cycle_subG -defK subxx andbT. + by rewrite -(setIidPl sHM') -setIA defK cent_cycle prKsK // (setIidPr _). +have{hallK} kK: \kappa(M).-group K. + apply: sub_pgroup (pgroup_pi K) => p piKp. + rewrite unlock 4!inE -!andb_orr orNb andbT -andbA. + have [X EpX]: exists X, X \in 'E_p^1(K). + by apply/p_rank_geP; rewrite p_rank_gt0. + have [sXK abelX dimX] := pnElemP EpX; have [pX _] := andP abelX. + have sXM := subset_trans sXK sKM. + have ->: p \in \sigma(M)^'. + apply: contra (nt_pnElem EpX isT) => sp. + rewrite -subG1 -tiM'K subsetI (subset_trans _ sMsM') //. + by rewrite (sub_Hall_pcore (Msigma_Hall maxM)) ?(pi_pgroup pX). + have ->: 'r_p(M) == 1%N. + rewrite -(p_rank_Hall (Hall_pi hallK)) // eqn_leq p_rank_gt0 piKp andbT. + apply: leq_trans (p_rank_le_rank p K) _. + by rewrite -abelian_rank1_cyclic ?cyclic_abelian. + apply/existsP; exists X; rewrite 2!inE sXM abelX dimX /=. + by rewrite (subG1_contra _ ntKs) // -defKs setISS ?centS. +have PmaxM : M \in 'M_'P. + apply/PtypeP; split=> //; exists (pdiv #|K|). + by rewrite (pnatPpi kK) // pi_pdiv cardG_gt1. +have hallK: \kappa(M).-Hall(M) K. + rewrite pHallE sKM -(eqn_pmul2l (cardG_gt0 M^`(1))) (sdprod_card defM). + have [K1 hallK1] := Hall_exists \kappa(M) (mmax_sol maxM). + have [_ _ [_ _ _ _ [_ _ _ defM1]]] := Ptype_embedding PmaxM hallK1. + by rewrite -(card_Hall hallK1) /= (sdprod_card defM1). +split=> // [|->]; first set Ms := M`_\sigma; last first. + rewrite trivg_card_le1 -(@leq_pmul2l #|H|) ?cardG_gt0 // muln1. + split; first by rewrite (sdprod_card defM') eqEcard (subset_trans sHMs). + have [_ mulHU nHU tiHU] := sdprodP defM'. + by rewrite -mulHU quotientMidl (isog_abelian (quotient_isog nHU tiHU)). +have [U1 | /= ntU] := altP eqP. + rewrite inE PmaxM -{2}mulM'K /= -defM' U1 sdprodg1 pgroupM. + have sH: \sigma(M).-group H := pgroupS sHMs (pcore_pgroup _ _). + rewrite (sub_pgroup _ sH) => [|p sMp]; last by rewrite inE /= sMp. + by rewrite (sub_pgroup _ kK) // => p kMp; rewrite inE /= kMp orbT. +have [P1maxM | notP1maxM] := boolP (M \in _). + have defMs: Ms = M^`(1). + have [U1 complU1] := ex_kappa_compl maxM hallK. + have [_ [//|<- _] _ _ _] := kappa_structure maxM complU1. + by case: (P1maxP maxM complU1 P1maxM) => _; move/eqP->; rewrite sdprodg1. + pose p := pdiv #|U|; have piUp: p \in \pi(U) by rewrite pi_pdiv cardG_gt1. + have hallU: \pi(H)^'.-Hall(M^`(1)) U. + have sHM': H \subset M^`(1) by rewrite -defMs. + have hallH := pHall_subl sHM' (der_sub 1 M) (Fcore_Hall M). + by rewrite -(compl_pHall _ hallH) ?sdprod_compl. + have piMs_p: p \in \pi(Ms) by rewrite defMs (piSg sUM'). + have{piMs_p} sMp: p \in \sigma(M) := pnatPpi (pcore_pgroup _ _) piMs_p. + have sylP: p.-Sylow(M^`(1)) 'O_p(U). + apply: (subHall_Sylow hallU (pnatPpi (pHall_pgroup hallU) piUp)). + exact: nilpotent_pcore_Hall nilU. + rewrite (subset_trans (char_norms (pcore_char p U))) //. + rewrite (norm_sigma_Sylow sMp) //. + by rewrite (subHall_Sylow (Msigma_Hall maxM)) //= -/Ms defMs. +suffices complU: kappa_complement M U K. + by symmetry; apply/idPn; have [[[]]] := BGsummaryC maxM complU ntK. +split=> //; last by rewrite -norm_joinEr ?groupP. +rewrite pHallE (subset_trans _ (der_sub 1 M)) //=. +rewrite -(@eqn_pmul2l #|H|) ?cardG_gt0 // (sdprod_card defM'). +have [U1 complU1] := ex_kappa_compl maxM hallK. +have [hallU1 _ _] := complU1; rewrite -(card_Hall hallU1). +have [_ [// | defM'1 _] _ _ _] := kappa_structure maxM complU1. +rewrite [H](Fcore_eq_Msigma maxM _) ?(sdprod_card defM'1) //. +by rewrite notP1type_Msigma_nil // in_setD notP1maxM PmaxM orbT. +Qed. + +(* This is B & G, Lemma 16.1. *) +Lemma FTtypeP i M : M \in 'M -> reflect (FTtype_spec i M) (FTtype M == i). +Proof. +move=> maxM; pose Ms := M`_\sigma; pose M' := M^`(1); pose H := M`_\F. +have [[ntH sHMs sMsM' _] _] := Fcore_structure maxM. +apply: (iffP eqP) => [<- | ]; last first. + case: i => [// | [[U [[[_ _ defM] _ [U0 [sU0U expU0 frobM]]] _]] | ]]. + apply/eqP; rewrite -FTtype_Fmax //; apply: wlog_neg => notFmaxM. + have PmaxM: M \in 'M_'P by apply/setDP. + apply/FtypeP; split=> // p; apply/idP=> kp. + have [X EpX]: exists X, X \in 'E_p^1(U0). + apply/p_rank_geP; rewrite p_rank_gt0 -pi_of_exponent expU0 pi_of_exponent. + have: p \in \pi(M) by rewrite kappa_pi. + rewrite /= -(sdprod_card defM) pi_ofM ?cardG_gt0 //; case/orP=> // Fk. + have [[_ sMFMs _ _] _] := Fcore_structure maxM. + case/negP: (kappa_sigma' kp). + exact: pnatPpi (pcore_pgroup _ _) (piSg sMFMs Fk). + have [[sXU0 abelX _] ntX] := (pnElemP EpX, nt_pnElem EpX isT). + have kX := pi_pgroup (abelem_pgroup abelX) kp. + have [_ sUM _ _ _] := sdprod_context defM. + have sXM := subset_trans sXU0 (subset_trans sU0U sUM). + have [K hallK sXK] := Hall_superset (mmax_sol maxM) sXM kX. + have [ntKs _ _ sKsMF _] := Ptype_cyclics PmaxM hallK; case/negP: ntKs. + rewrite -subG1 -(cent_semiregular (Frobenius_reg_ker frobM) sXU0 ntX). + by rewrite subsetI sKsMF subIset // centS ?orbT. + case=> [[U W K Ks defW [[PtypeM ntU _ _] _ not_sNUM _ _]] | ]. + apply/eqP; rewrite -FTtype_P2max // inE andbC. + by have [-> _ _ -> _] := typePfacts maxM PtypeM; rewrite negb_or ntU. + case=> [[U W K Ks defW [[PtypeM ntU _ _] cUU sNUM]] | ]. + have [_ _ _] := typePfacts maxM PtypeM. + rewrite (negPf ntU) sNUM FTtype_P1max // cUU /FTtype -/Ms -/M' -/H. + by case: ifP => // _; case: (Ms =P M') => // -> _ [//|-> ->]. + case=> [[U W K Ks defW [[PtypeM ntU _ _] not_cUU sNUM]] | ]. + have [_ _ _] := typePfacts maxM PtypeM. + rewrite (negPf ntU) (negPf not_cUU) sNUM FTtype_P1max // /FTtype -/Ms -/M'. + by case: ifP => // _; case: (Ms =P M') => // -> _ [//|-> ->]. + case=> // [[U K Ks W defW [[PtypeM U_1] _]]]. + have [_ _ _] := typePfacts maxM PtypeM. + rewrite U_1 eqxx FTtype_P1max //= /FTtype -/Ms -/M' -/H. + by case: ifP => // _; case: (Ms =P M') => // -> _ [//|-> _]. +have [[U K] /= complU] := kappa_witness maxM; have [hallU hallK _] := complU. +have [K1 | ntK] := eqsVneq K 1. + have FmaxM: M \in 'M_'F by rewrite -(trivg_kappa maxM hallK) K1. + have ->: FTtype M = 1%N by apply/eqP; rewrite -FTtype_Fmax. + have ntU: U :!=: 1 by case/(FmaxP maxM complU): FmaxM. + have defH: H = Ms. + by apply/Fcore_eq_Msigma; rewrite // notP1type_Msigma_nil ?FmaxM. + have defM: H ><| U = M. + by have [_] := kappa_compl_context maxM complU; rewrite defH K1 sdprodg1. + exists U; split. + have [_ _ _ cU1U1 exU0] := kappa_structure maxM complU. + split=> //; last by rewrite -/Ms -defH in exU0; exact: exU0. + exists [group of <<\bigcup_(x in (M`_\sigma)^#) 'C_U[x]>>]. + split=> //= [|x Hx]; last by rewrite sub_gen //= -/Ms -defH (bigcup_max x). + rewrite -big_distrr /= /normal gen_subG subsetIl. + rewrite norms_gen ?normsI ?normG //; apply/subsetP=> u Uu. + rewrite inE sub_conjg; apply/bigcupsP=> x Msx. + rewrite -sub_conjg -normJ conjg_set1 (bigcup_max (x ^ u)) ?memJ_norm //. + by rewrite normD1 (subsetP (gFnorm _ _)) // (subsetP (pHall_sub hallU)). + have [|] := boolP [forall (y | y \notin M), 'F(M) :&: 'F(M) :^ y == 1]. + move/forall_inP=> TI_F; constructor 1; apply/normedTI_P. + rewrite setD_eq0 subG1 mmax_Fcore_neq1 // setTI normD1 gFnorm. + split=> // x _; apply: contraR => /TI_F/eqP tiFx. + rewrite -setI_eq0 conjD1g -setDIl setD_eq0 -set1gE -tiFx. + by rewrite setISS ?conjSg ?Fcore_sub_Fitting. + rewrite negb_forall_in => /exists_inP[y notMy ntX]. + have [_ _ _ _] := nonTI_Fitting_structure maxM notMy ntX. + case=> [[] | [_]]; first by constructor 2. + move: #|_| => p; set P := 'O_p(H); rewrite /= -/H => not_cPP cycHp'. + case=> [expU | [_]]; [constructor 3 | by rewrite 2!inE FmaxM]. + split=> [q /expU | ]. + have [_ <- nHU tiHU] := sdprodP defM. + by rewrite quotientMidl -(exponent_isog (quotient_isog _ _)). + have sylP: p.-Sylow(H) P := nilpotent_pcore_Hall _ (Fcore_nil M). + have ntP: P != 1 by apply: contraNneq not_cPP => ->; exact: abelian1. + by exists p; rewrite // -p_rank_gt0 -(rank_Sylow sylP) rank_gt0. +have PmaxM: M \in 'M_'P by rewrite inE -(trivg_kappa maxM hallK) ntK. +have [Mstar _ [_ _ _ [cycW _ _ _ _]]] := Ptype_embedding PmaxM hallK. +case=> [[tiV _ _] _ _ defM {Mstar}]. +have [_ [_ cycK] [_ nUK _ _ _] _] := BGsummaryA maxM complU; rewrite -/H. +case=> [[ntKs defCMK] [_ _ _ _ nilM'H] [sM''F defF /(_ ntK)sFM'] types34]. +have hallK_M := pHall_Hall hallK. +have [/= [[cUU not_sNUM]]] := BGsummaryC maxM complU ntK; rewrite -/H -/M' -/Ms. +case=> cycKs _ sKsH not_cycH [defM' sKsM''] _ [_ _ type2 _]. +pose Ks := 'C_H(K); pose W := K <*> Ks; pose V := W :\: (K :|: Ks). +have defKs: 'C_Ms(K) = Ks by rewrite -(setIidPr sKsH) setIA (setIidPl sHMs). +rewrite {}defKs -/W -/V in ntKs tiV cycW cycKs sKsM'' sKsH defCMK. +have{defCMK} prM'K: {in K^#, forall k, 'C_M'[k] = Ks}. + have sKsM': Ks \subset M' := subset_trans sKsM'' (der_sub 1 _). + move=> k; move/defCMK=> defW; have:= dprod_modr defW sKsM'. + have [_ _ _ ->] := sdprodP defM; rewrite dprod1g. + by rewrite setIA (setIidPl (der_sub 1 M)). +have [sHM' nsM'M] := (subset_trans sHMs sMsM', der_normal 1 M : M' <| M). +have hallM': \kappa(M)^'.-Hall(M) M' by apply/(sdprod_normal_pHallP _ hallK). +have [sM'M k'M' _] := and3P hallM'. +have hallH_M': \pi(H).-Hall(M') H := pHall_subl sHM' sM'M (Fcore_Hall M). +have nsHM' := normalS sHM' sM'M (Fcore_normal M). +have defW: K \x Ks = W. + rewrite dprodEY ?subsetIr //= setIC; apply/trivgP. + by have [_ _ _ <-] := sdprodP defM; rewrite setSI ?subIset ?sHM'. +have [Ueq1 | ntU] := eqsVneq U 1; last first. + have P2maxM: M \in 'M_'P2 by rewrite inE -(trivg_kappa_compl maxM complU) ntU. + have ->: FTtype M = 2 by apply/eqP; rewrite -FTtype_P2max. + have defH: H = Ms. + by apply/Fcore_eq_Msigma; rewrite // notP1type_Msigma_nil ?P2maxM ?orbT. + have [//|pr_K tiFM _] := type2; rewrite -defH in defM'. + have [_ sUM' _ _ _] := sdprod_context defM'. + have MtypeP: of_typeP M U defW by split; rewrite // abelian_nil. + have defM'F: M'`_\F = H. + apply/eqP; rewrite eqEsubset (Fcore_max hallH_M') ?Fcore_nil // andbT. + rewrite (Fcore_max (subHall_Hall hallM' _ (Fcore_Hall _))) ?Fcore_nil //. + by move=> p piM'Fp; apply: pnatPpi k'M' (piSg (Fcore_sub _) piM'Fp). + exact: char_normal_trans (Fcore_char _) nsM'M. + exists U _ K _ defW; split=> //; split; first by rewrite defM'F. + by exists U; split=> // x _; apply: subsetIl. + have [_ _ _ _ /(_ ntU)] := kappa_structure maxM complU. + by rewrite -/Ms -defH -defM'F. +have P1maxM: M \in 'M_'P1 by rewrite -(trivg_kappa_compl maxM complU) Ueq1. +have: 2 < FTtype M <= 5 by rewrite -FTtype_P1max. +rewrite /FTtype -/H -/Ms; case: ifP => // _; case: eqP => //= defMs _. +have [Y hallY nYK]: exists2 Y, \pi(H)^'.-Hall(M') (gval Y) & K \subset 'N(Y). + apply: coprime_Hall_exists; first by case/sdprodP: defM. + by rewrite (coprime_sdprod_Hall_l defM) (pHall_Hall hallM'). + exact: solvableS sM'M (mmax_sol maxM). +have{defM'} defM': H ><| Y = M' by apply/(sdprod_normal_p'HallP _ hallY). +have MtypeP: of_typeP M Y defW. + have [_ sYM' mulHY nHY tiHY] := sdprod_context defM'. + do 2!split=> //; rewrite (isog_nil (quotient_isog nHY tiHY)). + by rewrite /= -quotientMidl mulHY. +have [_ _ _ sNYG [//| defY1 ->]] := typePfacts maxM MtypeP. +rewrite defY1; have [Y1 | ntY] := altP (Y :=P: 1); last first. + move/esym: sNYG; rewrite (negPf ntY) P1maxM /= => sNYG. + have [|_ tiFM prK] := types34; first by rewrite defY1. + by case: ifPn; exists Y _ K _ defW. +exists Y _ K _ defW; split=> //=. +have [|] := boolP [forall (y | y \notin M), 'F(M) :&: 'F(M) :^ y == 1]. + move/forall_inP=> TI_F; constructor 1; apply/normedTI_P. + rewrite setD_eq0 subG1 mmax_Fcore_neq1 // setTI normD1 gFnorm. + split=> // x _; apply: contraR => /TI_F/eqP tiFx. + rewrite -setI_eq0 conjD1g -setDIl setD_eq0 -set1gE -tiFx. + by rewrite setISS ?conjSg ?Fcore_sub_Fitting. +rewrite negb_forall_in => /exists_inP[y notMy ntX]. +have [_ _ _ _] := nonTI_Fitting_structure maxM notMy ntX. +case=> [[] | [_]]; first by case/idPn; case/setDP: PmaxM. +move: #|_| => p; set P := 'O_p(H); rewrite /= -/H => not_cPP cycHp'. +have sylP: p.-Sylow(H) P := nilpotent_pcore_Hall _ (Fcore_nil M). +have ntP: P != 1 by apply: contraNneq not_cPP => ->; exact: abelian1. +have piHp: p \in \pi(H) by rewrite -p_rank_gt0 -(rank_Sylow sylP) rank_gt0. +have defH: H = Ms by apply/eqP; rewrite defY1 Y1. +rewrite -defMs -defH in defM; have [_ <- nHU tiHU] := sdprodP defM. +rewrite quotientMidl -(card_isog (quotient_isog _ _)) //. +rewrite -(exponent_isog (quotient_isog _ _)) // exponent_cyclic //=. +case=> [K_dv_H1 | []]; [constructor 2 | constructor 3]; exists p => //. +by rewrite K_dv_H1. +Qed. + +(* This is B & G, Theorem I. *) +(* Note that the first assertion is not used in the Perterfalvi revision of *) +(* the character theory part of the proof. *) +Theorem BGsummaryI : + [/\ forall H x a, Hall G H -> nilpotent H -> x \in H -> x ^ a \in H -> + exists2 y, y \in 'N(H) & x ^ a = x ^ y + & {in 'M, forall M, FTtype M == 1%N} + \/ exists ST : {group gT} * {group gT}, let (S, T) := ST in + [/\ S \in 'M /\ T \in 'M, + exists Wi : {group gT} * {group gT}, let (W1, W2) := Wi in + let W := W1 <*> W2 in let V := W :\: (W1 :|: W2) in + (*a*) [/\ cyclic W, normedTI V G W & W1 :!=: 1 /\ W2 :!=: 1] /\ + (*b*) [/\ S^`(1) ><| W1 = S, T^`(1) ><| W2 = T & S :&: T = W], + (*c*) {in 'M, forall M, FTtype M != 1%N -> + exists x, S :^ x = M \/ T :^ x = M}, + (*d*) FTtype S == 2 \/ FTtype T == 2 + & (*e*) 1 < FTtype S <= 5 /\ 1 < FTtype T <= 5]]. +Proof. +split=> [H x a hallH nilH Hx|]. + have [M maxM sHMs] := nilpotent_Hall_sigma nilH hallH. + have{hallH} hallH := pHall_subl sHMs (subsetT _) (Hall_pi hallH). + by case/(sigma_Hall_tame maxM hallH Hx) => // y; case/setIP; exists y. +have [allFM | ] := boolP (('M : {set {group gT}}) \subset 'M_'F). + by left=> M maxM; rewrite -FTtype_Fmax // (subsetP allFM). +case/subsetPn=> S maxS notFmaxS; right. +have PmaxS: S \in 'M_'P by exact/setDP. +have [[U W1] /= complU] := kappa_witness maxS; have [_ hallW1 _] := complU. +have ntW1: W1 :!=: 1 by rewrite (trivg_kappa maxS). +have [[_ [_]]] := BGsummaryC maxS complU ntW1; set W2 := 'C_(_)(W1) => ntW2 _. +set W := W1 <*> W2; set V := W :\: _ => _ _ [T [[PmaxT defW1 hallW2 _] _]]. +case=> defST _ cycW [P2maxST PmaxST] [tiV _ _] _. +have [maxT _] := setDP PmaxT. +have [_ _ [_ _ _ _ [_ _ _ defS]]] := Ptype_embedding PmaxS hallW1. +have [_ _ [_ _ _ _ [_ _ _ defT]]] := Ptype_embedding PmaxT hallW2. +exists (S, T); split=> //; first by exists (W1, [group of W2]). +- move=> M maxM; rewrite /= -FTtype_Pmax //. + by case/PmaxST/setUP => /imsetP[x _ ->]; exists x; by [left | right]. +- by rewrite -!{1}FTtype_P2max. +rewrite !{1}(ltn_neqAle 1) -!{1}andbA !{1}FTtype_range // !{1}andbT. +by rewrite !{1}(eq_sym 1%N) -!{1}FTtype_Pmax. +Qed. + +Lemma FTsupp0_type1 M : FTtype M == 1%N -> 'A0(M) = 'A(M). +Proof. +move=> typeM; apply/setUidPl/subsetP=> x; rewrite typeM !inE => /and3P[Mx]. +by rewrite (mem_p_elt (pgroup_pi M)). +Qed. + +Lemma FTsupp0_typeP M (H := M`_\F) U W1 W2 W (defW : W1 \x W2 = W) : + M \in 'M -> of_typeP M U defW -> + let V := W :\: (W1 :|: W2) in 'A0(M) :\: 'A(M) = class_support V M. +Proof. +move: W1 W2 => K Ks in defW * => maxM MtypeP /=. +have [[_ _ ntK _] _ _ _ _] := MtypeP. +have [PmaxM hallK defKs _ _] := typePfacts maxM MtypeP. +have [[_ sHMs _ _] _] := Fcore_structure maxM. +have [V complV] := ex_kappa_compl maxM hallK. +have [[_ [_ _ sKsH _] _] _ [_ [-> _] _ _]] := BGsummaryC maxM complV ntK. +by rewrite -(setIidPr sKsH) setIA (setIidPl sHMs) defKs -(dprodWY defW). +Qed. + +(* This is the part of B & G, Theorem II that is relevant to the proof of *) +(* Peterfalvi (8.7). We drop the considerations on the set of supporting *) +(* groups, in particular (Tii)(a), but do include additional information on D *) +(* namely the fact that D is included in 'A1(M), not just 'A(M). *) +Theorem BGsummaryII M (X : {set gT}) : + M \in 'M -> X \in pred2 'A(M) 'A0(M) -> + let D := [set x in X | ~~ ('C[x] \subset M)] in + [/\ D \subset 'A1(M), (* was 'A(M) in B & G *) + (*i*) {in X, forall x a, x ^ a \in X -> exists2 y, y \in M & x ^ a = x ^ y} + & {in D, forall x (L := 'N[x]), + [/\ (*ii*) 'M('C[x]) = [set L], FTtype L \in pred2 1%N 2, + [/\ (*b*) L`_\F ><| (M :&: L) = L, + (*c*) {in X, forall y, coprime #|L`_\F| #|'C_M[y]| }, + (*d*) x \in 'A(L) :\: 'A1(L) + & (*e*) 'C_(L`_\F)[x] ><| 'C_M[x] = 'C[x]] + & (*iii*) FTtype L == 2 -> + exists2 E, [Frobenius M = M`_\F ><| gval E] & cyclic E]}]. +Proof. +move=> maxM defX. +have sA0M: 'A0(M) \subset M := subset_trans (FTsupp0_sub M) (subsetDl M 1). +have sAA0: 'A(M) \subset 'A0(M) := FTsupp_sub0 M. +have sAM: 'A(M) \subset M := subset_trans sAA0 sA0M. +without loss {defX} ->: X / X = 'A0(M). + case/pred2P: defX => ->; move/(_ _ (erefl _))=> //. + set D0 := finset _ => [[sD0A1 tameA0 signD0]] D. + have sDD0: D \subset D0 by rewrite /D /D0 !setIdE setSI. + split=> [|x Ax a Axa|x Dx]; first exact: subset_trans sDD0 sD0A1. + by apply: tameA0; exact: (subsetP sAA0). + have [/= -> -> [-> coA0L -> -> frobL]] := signD0 x (subsetP sDD0 x Dx). + by do 2![split=> //] => y Ay; rewrite coA0L // (subsetP sAA0). +move=> {X} D; pose Ms := M`_\sigma. +have tiA0A x a: x \in 'A0(M) :\: 'A(M) -> x ^ a \notin 'A(M). + rewrite 3!inE; case: (x \in _) => //= /and3P[_ notM'x _]. + apply: contra notM'x => /bigcupP[y _ /setD1P[_ /setIP[Mx _]]]. + by rewrite -(p_eltJ _ _ a) (mem_p_elt (pgroup_pi _)). +have tiA0 x a: x \in 'A0(M) :\: 'A1(M) -> x ^ a \in 'A0(M) -> a \in M. + case/setDP=> A0x notA1x A0xa. + have [Mx Mxa] := (subsetP sA0M x A0x, subsetP sA0M _ A0xa). + have [[U K] /= complU] := kappa_witness maxM. + have [Ax | notAx] := boolP (x \in 'A(M)). + have [_ _ _ [_]] := BGsummaryB maxM complU; set B := _ :\: _ => tiB. + have Bx: x \in B by apply/setDP. + have /tiB/normedTI_memJ_P: 'A(M) != 'A1(M) by apply: contraTneq Ax => ->. + case=> _ _ /(_ x) <- //; rewrite 3?inE // conjg_eq1; apply/andP; split. + apply: contra notA1x; rewrite !inE def_FTcore // => /andP[->]. + by rewrite !(mem_Hall_pcore (Msigma_Hall maxM)) // p_eltJ. + by apply: contraLR Ax => notAxa; rewrite -(conjgK a x) tiA0A // inE notAxa. + have ntK: K :!=: 1. + rewrite -(trivgFmax maxM complU) FTtype_Fmax //. + by apply: contra notAx => /FTsupp0_type1 <-. + have [_ _ [_ [_ /normedTI_memJ_P[_ _ tiB]] _ _]]:= BGsummaryC maxM complU ntK. + by rewrite -(tiB x) inE ?tiA0A ?notAx // inE notAx. +have sDA1: D \subset 'A1(M). + apply/subsetPn=> [[x /setIdP[A0x not_sCxM] notA1x]]. + case/subsetP: not_sCxM => a cxa. + by apply: (tiA0 x); [exact/setDP | rewrite /conjg -(cent1P cxa) mulKg]. +have sDMs1: D \subset Ms^# by rewrite /Ms -def_FTcore. +have [tameMs _ signM PsignM] := BGsummaryD maxM. +split=> // [x A0x a A0xa|x Dx]. + have [A1x | notA1x] := boolP (x \in 'A1(M)); last first. + by exists a; rewrite // (tiA0 x) // inE notA1x. + case/setD1P: A1x => _; rewrite def_FTcore // => Ms_x. + apply/imsetP; rewrite tameMs ?mem_imset ?inE //. + rewrite (mem_Hall_pcore (Msigma_Hall maxM)) ?(subsetP sA0M) //. + by rewrite p_eltJ (mem_p_elt (pcore_pgroup _ _) Ms_x). +have [Ms1x [_ not_sCxM]] := (subsetP sDMs1 x Dx, setIdP Dx). +have [[uniqN defNF] [ANx typeN hallMN] type2] := PsignM x Ms1x not_sCxM. +have [maxN _] := mem_uniq_mmax uniqN. +split=> //; last 1 first. +- rewrite -FTtype_P2max // => /type2[FmaxM]. + by rewrite (Fcore_eq_Msigma maxM _) // notP1type_Msigma_nil ?FmaxM. +- by rewrite !inE -FTtype_Fmax // -FTtype_P2max // -in_setU. +split=> // [|y A0y|]; rewrite defNF ?sdprod_sigma //=; last by case/signM: Ms1x. +rewrite coprime_pi' ?cardG_gt0 // -pgroupE. +rewrite (eq_p'group _ (pi_Msigma maxN)); apply: wlog_neg => not_sNx'CMy. +have ell1x := Msigma_ell1 maxM Ms1x. +have SMxM: M \in 'M_\sigma[x] by rewrite inE maxM cycle_subG; case/setD1P: Ms1x. +have MSx_gt1: #|'M_\sigma[x]| > 1. + rewrite ltn_neqAle lt0n {2}(cardD1 M) SMxM andbT eq_sym. + by apply: contra not_sCxM; move/cent1_sub_uniq_sigma_mmax->. +have [FmaxM t2'M]: M \in 'M_'F /\ \tau2(M)^'.-group M. + apply: (non_disjoint_signalizer_Frobenius ell1x MSx_gt1 SMxM). + by apply: contra not_sNx'CMy; exact: pgroupS (subsetIl _ _). +have defA0: 'A0(M) = Ms^#. + rewrite FTsupp0_type1; last by rewrite -FTtype_Fmax. + rewrite /'A(M) /'A1(M) -FTtype_Fmax // FmaxM def_FTcore //= -/Ms. + apply/setP => z; apply/bigcupP/idP=> [[t Ms1t] | Ms1z]; last first. + have [ntz Ms_z] := setD1P Ms1z. + by exists z; rewrite // 3!inE ntz cent1id (subsetP (pcore_sub _ _) z Ms_z). + case/setD1P=> ntz; case/setIP=> Mz ctz. + rewrite 2!inE ntz (mem_Hall_pcore (Msigma_Hall maxM)) //. + apply: sub_in_pnat (pnat_pi (order_gt0 z)) => p _ pi_z_p. + have szM: <[z]> \subset M by rewrite cycle_subG. + have [piMp [_ k'M]] := (piSg szM pi_z_p, setIdP FmaxM). + apply: contraR (pnatPpi k'M piMp) => s'p /=. + rewrite unlock; apply/andP; split. + have:= piMp; rewrite (partition_pi_mmax maxM) (negPf s'p) orbF. + by rewrite orbCA [p \in _](negPf (pnatPpi t2'M piMp)). + move: pi_z_p; rewrite -p_rank_gt0 /= -(setIidPr szM). + case/p_rank_geP=> P; rewrite pnElemI -setIdE => /setIdP[EpP sPz]. + apply/exists_inP; exists P => //; apply/trivgPn. + have [ntt Ms_t] := setD1P Ms1t; exists t => //. + by rewrite inE Ms_t (subsetP (centS sPz)) // cent_cycle cent1C. +move: A0y; rewrite defA0 => /setD1P[nty Ms_y]. +have sCyMs: 'C_M[y] \subset Ms. + rewrite -[Ms](setD1K (group1 _)) -subDset /= -defA0 subsetU //. + rewrite (bigcup_max y) //; first by rewrite 2!inE nty def_FTcore. + by rewrite -FTtype_Fmax ?FmaxM. +have notMGN: gval 'N[x] \notin M :^: G. + have [_ [//|_ _ t2Nx _ _]] := FT_signalizer_context ell1x. + have [ntx Ms_x] := setD1P Ms1x; have sMx := mem_p_elt (pcore_pgroup _ _) Ms_x. + apply: contra ntx => /imsetP[a _ defN]. + rewrite -order_eq1 (pnat_1 sMx (sub_p_elt _ t2Nx)) // => p. + by rewrite defN tau2J // => /andP[]. +apply: sub_pgroup (pgroupS sCyMs (pcore_pgroup _ _)) => p sMp. +by apply: contraFN (sigma_partition maxM maxN notMGN p) => sNp; apply/andP. +Qed. + +End Section16. + + diff --git a/mathcomp/odd_order/BGsection2.v b/mathcomp/odd_order/BGsection2.v new file mode 100644 index 0000000..fc5f489 --- /dev/null +++ b/mathcomp/odd_order/BGsection2.v @@ -0,0 +1,1153 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div fintype. +Require Import bigop prime binomial finset fingroup morphism perm automorphism. +Require Import quotient action gfunctor commutator gproduct. +Require Import ssralg finalg zmodp cyclic center pgroup gseries nilpotent. +Require Import sylow abelian maximal hall. +Require poly ssrint. +Require Import matrix mxalgebra mxrepresentation mxabelem. +Require Import BGsection1. + +(******************************************************************************) +(* This file covers the useful material in B & G, Section 2. This excludes *) +(* part (c) of Proposition 2.1 and part (b) of Proposition 2.2, which are not *) +(* actually used in the rest of the proof; also the rest of Proposition 2.1 *) +(* is already covered by material in file mxrepresentation.v. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section BGsection2. + +Import GroupScope GRing.Theory FinRing.Theory poly.UnityRootTheory ssrint.IntDist. +Local Open Scope ring_scope. + +Implicit Types (F : fieldType) (gT : finGroupType) (p : nat). + +(* File mxrepresentation.v covers B & G, Proposition 2.1 as follows: *) +(* - Proposition 2.1 (a) is covered by Lemmas mx_abs_irr_cent_scalar and *) +(* cent_mx_scalar_abs_irr. *) +(* - Proposition 2.2 (b) is our definition of "absolutely irreducible", and *) +(* is thus covered by cent_mx_scalar_abs_irr and mx_abs_irrP. *) +(* - Proposition 2.2 (c) is partly covered by the construction in submodule *) +(* MatrixGenField, which extends the base field with a single element a of *) +(* K = Hom_FG(M, M), rather than all of K, thus avoiding the use of the *) +(* Wedderburn theorem on finite division rings (by the primitive element *) +(* theorem this is actually equivalent). The corresponding representation *) +(* is built by MatrixGenField.gen_repr. In B & G, Proposition 2.1(c) is *) +(* only used in case II of the proof of Theorem 3.10, which we greatly *) +(* simplify by making use of the Wielandt fixpoint formula, following *) +(* Peterfalvi (Theorem 9.1). In this formalization the limited form of *) +(* 2.1(c) is used to streamline the proof that groups of odd order are *) +(* p-stable (B & G, Appendix A.5(c)). *) + +(* This is B & G, Proposition 2.2(a), using internal isomorphims (mx_iso). *) +Proposition mx_irr_prime_index F gT (G H : {group gT}) n M (nsHG : H <| G) + (rG : mx_representation F G n) (rH := subg_repr rG (normal_sub nsHG)) : + group_closure_field F gT -> mx_irreducible rG -> cyclic (G / H)%g -> + mxsimple rH M -> {in G, forall x, mx_iso rH M (M *m rG x)} -> + mx_irreducible rH. +Proof. +move=> closedF irrG /cyclicP[Hx defGH] simM isoM; have [sHG nHG] := andP nsHG. +have [modM nzM _] := simM; pose E_H := enveloping_algebra_mx rH. +have absM f: (M *m f <= M)%MS -> {a | (a \in E_H)%MS & M *m a = M *m f}. + move=> sMf; set rM := submod_repr modM; set E_M := enveloping_algebra_mx rM. + pose u := mxvec (in_submod M (val_submod 1%:M *m f)) *m pinvmx E_M. + have EHu: (gring_mx rH u \in E_H)%MS := gring_mxP rH u. + exists (gring_mx rH u) => //; rewrite -(in_submodK sMf). + rewrite -(in_submodK (mxmodule_envelop modM EHu _)) //; congr (val_submod _). + transitivity (in_submod M M *m gring_mx rM u). + rewrite /gring_mx /= !mulmx_sum_row !linear_sum; apply: eq_bigr => i /= _. + by rewrite !linearZ /= !rowK !mxvecK -in_submodJ. + rewrite /gring_mx /= mulmxKpV ?submx_full ?mxvecK //; last first. + suffices: mx_absolutely_irreducible rM by case/andP. + by apply: closedF; exact/submod_mx_irr. + rewrite {1}[in_submod]lock in_submodE -mulmxA mulmxA -val_submodE -lock. + by rewrite mulmxA -in_submodE in_submodK. +have /morphimP[x nHx Gx defHx]: Hx \in (G / H)%g by rewrite defGH cycle_id. +have{Hx defGH defHx} defG : G :=: <[x]> <*> H. + rewrite -(quotientGK nsHG) defGH defHx -quotient_cycle //. + by rewrite joingC quotientK ?norm_joinEr // cycle_subG. +have [e def1]: exists e, 1%:M = \sum_(z in G) e z *m (M *m rG z). + apply/sub_sumsmxP; have [X sXG [<- _]] := Clifford_basis irrG simM. + by apply/sumsmx_subP=> z Xz; rewrite (sumsmx_sup z) ?(subsetP sXG). +have [phi inj_phi hom_phi defMx] := isoM x Gx. +have Mtau: (M *m (phi *m rG x^-1%g) <= M)%MS. + by rewrite mulmxA (eqmxMr _ defMx) repr_mxK. +have Mtau': (M *m (rG x *m invmx phi) <= M)%MS. + by rewrite mulmxA -(eqmxMr _ defMx) mulmxK. +have [[tau Htau defMtau] [tau' Htau' defMtau']] := (absM _ Mtau, absM _ Mtau'). +have tau'K: tau' *m tau = 1%:M. + rewrite -[tau']mul1mx def1 !mulmx_suml; apply: eq_bigr => z Gz. + have [f _ hom_f] := isoM z Gz; move/eqmxP; case/andP=> _; case/submxP=> v ->. + rewrite (mulmxA _ v) -2!mulmxA; congr (_ *m _). + rewrite -(hom_envelop_mxC hom_f) ?envelop_mxM //; congr (_ *m _). + rewrite mulmxA defMtau' -(mulmxKpV Mtau') -mulmxA defMtau (mulmxA _ M). + by rewrite mulmxKpV // !mulmxA mulmxKV // repr_mxK. +have cHtau_x: centgmx rH (tau *m rG x). + apply/centgmxP=> y Hy; have [u defMy] := submxP (mxmoduleP modM y Hy). + have Gy := subsetP sHG y Hy. + rewrite mulmxA; apply: (canRL (repr_mxKV rG Gx)). + rewrite -!mulmxA /= -!repr_mxM ?groupM ?groupV // (conjgC y) mulKVg. + rewrite -[rG y]mul1mx -{1}[tau]mul1mx def1 !mulmx_suml. + apply: eq_bigr => z Gz; have [f _ hom_f] := isoM z Gz. + move/eqmxP; case/andP=> _; case/submxP=> v ->; rewrite -!mulmxA. + congr (_ *m (_ *m _)); rewrite {v} !(mulmxA M). + rewrite -!(hom_envelop_mxC hom_f) ?envelop_mxM ?(envelop_mx_id rH) //. + congr (_ *m f); rewrite !mulmxA defMy -(mulmxA u) defMtau (mulmxA u) -defMy. + rewrite !mulmxA (hom_mxP hom_phi) // -!mulmxA; congr (M *m (_ *m _)). + by rewrite /= -!repr_mxM ?groupM ?groupV // -conjgC. + by rewrite -mem_conjg (normsP nHG). +have{cHtau_x} cGtau_x: centgmx rG (tau *m rG x). + rewrite /centgmx {1}defG join_subG cycle_subG !inE Gx /= andbC. + rewrite (subset_trans cHtau_x); last by rewrite rcent_subg subsetIr. + apply/eqP; rewrite -{2 3}[rG x]mul1mx -tau'K !mulmxA; congr (_ *m _ *m _). + case/envelop_mxP: Htau' => u ->. + rewrite !(mulmx_suml, mulmx_sumr); apply: eq_bigr => y Hy. + by rewrite -!(scalemxAl, scalemxAr) (centgmxP cHtau_x) ?mulmxA. +have{cGtau_x} [a def_tau_x]: exists a, tau *m rG x = a%:M. + by apply/is_scalar_mxP; apply: mx_abs_irr_cent_scalar cGtau_x; exact: closedF. +apply: mx_iso_simple (eqmx_iso _ _) simM; apply/eqmxP; rewrite submx1 sub1mx. +case/mx_irrP: (irrG) => _ -> //; rewrite /mxmodule {1}defG join_subG /=. +rewrite cycle_subG inE Gx andbC (subset_trans modM) ?rstabs_subg ?subsetIr //=. +rewrite -{1}[M]mulmx1 -tau'K mulmxA -mulmxA def_tau_x mul_mx_scalar. +by rewrite scalemx_sub ?(mxmodule_envelop modM Htau'). +Qed. + +(* This is B & G, Lemma 2.3. Note that this is not used in the FT proof. *) +Lemma rank_abs_irr_dvd_solvable F gT (G : {group gT}) n rG : + @mx_absolutely_irreducible F _ G n rG -> solvable G -> n %| #|G|. +Proof. +move=> absG solG. +without loss closF: F rG absG / group_closure_field F gT. + move=> IH; apply: (@group_closure_field_exists gT F) => [[F' f closF']]. + by apply: IH (map_repr f rG) _ closF'; rewrite map_mx_abs_irr. +elim: {G}_.+1 {-2}G (ltnSn #|G|) => // m IHm G leGm in n rG absG solG *. +have [G1 | ntG] := eqsVneq G 1%g. + by rewrite abelian_abs_irr ?G1 ?abelian1 // in absG; rewrite (eqP absG) dvd1n. +have [H nsHG p_pr] := sol_prime_factor_exists solG ntG. +set p := #|G : H| in p_pr. +pose sHG := normal_sub nsHG; pose rH := subg_repr rG sHG. +have irrG := mx_abs_irrW absG. +wlog [L simL _]: / exists2 L, mxsimple rH L & (L <= 1%:M)%MS. + by apply: mxsimple_exists; rewrite ?mxmodule1 //; case: irrG. +have ltHG: H \proper G. + by rewrite properEcard sHG -(Lagrange sHG) ltn_Pmulr // prime_gt1. +have dvLH: \rank L %| #|H|. + have absL: mx_absolutely_irreducible (submod_repr (mxsimple_module simL)). + by apply: closF; exact/submod_mx_irr. + apply: IHm absL (solvableS (normal_sub nsHG) solG). + by rewrite (leq_trans (proper_card ltHG)). +have [_ [x Gx H'x]] := properP ltHG. +have prGH: prime #|G / H|%g by rewrite card_quotient ?normal_norm. +wlog sH: / socleType rH by exact: socle_exists. +pose W := PackSocle (component_socle sH simL). +have card_sH: #|sH| = #|G : 'C_G[W | 'Cl]|. + rewrite -cardsT; have ->: setT = orbit 'Cl G W. + apply/eqP; rewrite eqEsubset subsetT. + have /imsetP[W' _ defW'] := Clifford_atrans irrG sH. + have WW': W' \in orbit 'Cl G W by rewrite orbit_in_sym // -defW' inE. + by rewrite defW' andbT; apply/subsetP=> W''; exact: orbit_in_trans. + rewrite orbit_stabilizer // card_in_imset //. + exact: can_in_inj (act_reprK _). +have sHcW: H \subset 'C_G[W | 'Cl]. + apply: subset_trans (subset_trans (joing_subl _ _) (Clifford_astab sH)) _. + apply/subsetP=> z; rewrite !inE => /andP[->]; apply: subset_trans. + exact: subsetT. +have [|] := prime_subgroupVti ('C_G[W | 'Cl] / H)%G prGH. + rewrite quotientSGK ?normal_norm // => cClG. + have def_sH: setT = [set W]. + apply/eqP; rewrite eq_sym eqEcard subsetT cards1 cardsT card_sH. + by rewrite -indexgI (setIidPl cClG) indexgg. + suffices L1: (L :=: 1%:M)%MS. + by rewrite L1 mxrank1 in dvLH; exact: dvdn_trans (cardSg sHG). + apply/eqmxP; rewrite submx1. + have cycH: cyclic (G / H)%g by rewrite prime_cyclic. + have [y Gy|_ _] := mx_irr_prime_index closF irrG cycH simL; last first. + by apply; rewrite ?submx1 //; case simL. + have simLy: mxsimple rH (L *m rG y) by exact: Clifford_simple. + pose Wy := PackSocle (component_socle sH simLy). + have: (L *m rG y <= Wy)%MS by rewrite PackSocleK component_mx_id. + have ->: Wy = W by apply/set1P; rewrite -def_sH inE. + by rewrite PackSocleK; exact: component_mx_iso. +rewrite (setIidPl _) ?quotientS ?subsetIl // => /trivgP. +rewrite quotient_sub1 //; last by rewrite subIset // normal_norm. +move/setIidPl; rewrite (setIidPr sHcW) /= => defH. +rewrite -(Lagrange sHG) -(Clifford_rank_components irrG W) card_sH -defH. +rewrite mulnC dvdn_pmul2r // (_ : W :=: L)%MS //; apply/eqmxP. +have sLW: (L <= W)%MS by rewrite PackSocleK component_mx_id. +rewrite andbC sLW; have [modL nzL _] := simL. +have [_ _] := (Clifford_rstabs_simple irrG W); apply=> //. +rewrite /mxmodule rstabs_subg /= -Clifford_astab1 -astabIdom -defH. +by rewrite -(rstabs_subg rG sHG). +Qed. + +(* This section covers the many parts B & G, Proposition 2.4; only the last *) +(* part (k) in used in the rest of the proof, and then only for Theorem 2.5. *) +Section QuasiRegularCyclic. + +Variables (F : fieldType) (q' h : nat). + +Local Notation q := q'.+1. +Local Notation V := 'rV[F]_q. +Local Notation E := 'M[F]_q. + +Variables (g : E) (eps : F). + +Hypothesis gh1 : g ^+ h = 1. +Hypothesis prim_eps : h.-primitive_root eps. + +Let h_gt0 := prim_order_gt0 prim_eps. +Let eps_h := prim_expr_order prim_eps. +Let eps_mod_h m := expr_mod m eps_h. +Let inj_eps : injective (fun i : 'I_h => eps ^+ i). +Proof. +move=> i j eq_ij; apply/eqP; move/eqP: eq_ij. +by rewrite (eq_prim_root_expr prim_eps) !modn_small. +Qed. + +Let inhP m : m %% h < h. Proof. by rewrite ltn_mod. Qed. +Let inh m := Ordinal (inhP m). + +Let V_ i := eigenspace g (eps ^+ i). +Let n_ i := \rank (V_ i). +Let E_ i := eigenspace (lin_mx (mulmx g^-1 \o mulmxr g)) (eps ^+ i). +Let E2_ i t := + (kermx (lin_mx (mulmxr (cokermx (V_ t)) \o mulmx (V_ i))) + :&: kermx (lin_mx (mulmx (\sum_(j < h | j != i %[mod h]) V_ j)%MS)))%MS. + +Local Notation "''V_' i" := (V_ i) (at level 8, i at level 2, format "''V_' i"). +Local Notation "''n_' i" := (n_ i) (at level 8, i at level 2, format "''n_' i"). +Local Notation "''E_' i" := (E_ i) (at level 8, i at level 2, format "''E_' i"). +Local Notation "'E_ ( i )" := (E_ i) (at level 8, only parsing). +Local Notation "e ^g" := (g^-1 *m (e *m g)) + (at level 8, format "e ^g") : ring_scope. +Local Notation "'E_ ( i , t )" := (E2_ i t) + (at level 8, format "''E_' ( i , t )"). + +Let inj_g : g \in GRing.unit. +Proof. by rewrite -(unitrX_pos _ h_gt0) gh1 unitr1. Qed. + +Let Vi_mod i : 'V_(i %% h) = 'V_i. +Proof. by rewrite /V_ eps_mod_h. Qed. + +Let g_mod i := expr_mod i gh1. + +Let EiP i e : reflect (e^g = eps ^+ i *: e) (e \in 'E_i)%MS. +Proof. +rewrite (sameP eigenspaceP eqP) mul_vec_lin -linearZ /=. +by rewrite (can_eq mxvecK); exact: eqP. +Qed. + +Let E2iP i t e : + reflect ('V_i *m e <= 'V_t /\ forall j, j != i %[mod h] -> 'V_j *m e = 0)%MS + (e \in 'E_(i, t))%MS. +Proof. +rewrite sub_capmx submxE !(sameP sub_kermxP eqP) /=. +rewrite !mul_vec_lin !mxvec_eq0 /= -submxE -submx0 sumsmxMr. +apply: (iffP andP) => [[->] | [-> Ve0]]; last first. + by split=> //; apply/sumsmx_subP=> j ne_ji; rewrite Ve0. +move/sumsmx_subP=> Ve0; split=> // j ne_ji; apply/eqP. +by rewrite -submx0 -Vi_mod (Ve0 (inh j)) //= modn_mod. +Qed. + +Let sumV := (\sum_(i < h) 'V_i)%MS. + +(* This is B & G, Proposition 2.4(a). *) +Proposition mxdirect_sum_eigenspace_cycle : (sumV :=: 1%:M)%MS /\ mxdirect sumV. +Proof. +have splitF: group_splitting_field F (Zp_group h). + move: prim_eps (abelianS (subsetT (Zp h)) (Zp_abelian _)). + by rewrite -{1}(card_Zp h_gt0); exact: primitive_root_splitting_abelian. +have F'Zh: [char F]^'.-group (Zp h). + apply/pgroupP=> p p_pr; rewrite card_Zp // => /dvdnP[d def_h]. + apply/negP=> /= charFp. + have d_gt0: d > 0 by move: h_gt0; rewrite def_h; case d. + have: eps ^+ d == 1. + rewrite -(inj_eq (fmorph_inj [rmorphism of Frobenius_aut charFp])). + by rewrite rmorph1 /= Frobenius_autE -exprM -def_h eps_h. + by rewrite -(prim_order_dvd prim_eps) gtnNdvd // def_h ltn_Pmulr // prime_gt1. +case: (ltngtP h 1) => [|h_gt1|h1]; last first; last by rewrite ltnNge h_gt0. + rewrite /sumV mxdirectE /= h1 !big_ord1; split=> //. + apply/eqmxP; rewrite submx1; apply/eigenspaceP. + by rewrite mul1mx scale1r idmxE -gh1 h1. +pose mxZ (i : 'Z_h) := g ^+ i. +have mxZ_repr: mx_repr (Zp h) mxZ. + by split=> // i j _ _; rewrite /mxZ /= {3}Zp_cast // expr_mod // exprD. +pose rZ := MxRepresentation mxZ_repr. +have ZhT: Zp h = setT by rewrite /Zp h_gt1. +have memZh: _ \in Zp h by move=> i; rewrite ZhT inE. +have def_g: g = rZ Zp1 by []. +have lin_rZ m (U : 'M_(m, q)) a: + U *m g = a *: U -> forall i, U *m rZ i%:R = (a ^+ i) *: U. +- move=> defUg i; rewrite repr_mxX //. + elim: i => [|i IHi]; first by rewrite mulmx1 scale1r. + by rewrite !exprS -scalerA mulmxA defUg -IHi scalemxAl. +rewrite mxdirect_sum_eigenspace => [|j k _ _]; last exact: inj_eps. +split=> //; apply/eqmxP; rewrite submx1. +wlog [I M /= simM <- _]: / mxsemisimple rZ 1. + exact: mx_reducible_semisimple (mxmodule1 _) (mx_Maschke rZ F'Zh) _. +apply/sumsmx_subP=> i _; have simMi := simM i; have [modMi _ _] := simMi. +set v := nz_row (M i); have nz_v: v != 0 by exact: nz_row_mxsimple simMi. +have rankMi: \rank (M i) = 1%N. + by rewrite (mxsimple_abelian_linear splitF _ simMi) //= ZhT Zp_abelian. +have defMi: (M i :=: v)%MS. + apply/eqmxP; rewrite andbC -(geq_leqif (mxrank_leqif_eq _)) ?nz_row_sub //. + by rewrite rankMi lt0n mxrank_eq0. +have [a defvg]: exists a, v *m rZ 1%R = a *: v. + by apply/sub_rVP; rewrite -defMi mxmodule_trans ?socle_module ?defMi. +have: a ^+ h - 1 == 0. + apply: contraR nz_v => nz_pZa; rewrite -(eqmx_eq0 (eqmx_scale _ nz_pZa)). + by rewrite scalerBl scale1r -lin_rZ // subr_eq0 char_Zp ?mulmx1. +rewrite subr_eq0; move/eqP; case/(prim_rootP prim_eps) => k def_a. +by rewrite defMi (sumsmx_sup k) // /V_ -def_a; exact/eigenspaceP. +Qed. + +(* This is B & G, Proposition 2.4(b). *) +Proposition rank_step_eigenspace_cycle i : 'n_ (i + h) = 'n_ i. +Proof. by rewrite /n_ -Vi_mod modnDr Vi_mod. Qed. + +Let sumE := (\sum_(it : 'I_h * 'I_h) 'E_(it.1, it.2))%MS. + +(* This is B & G, Proposition 2.4(c). *) +Proposition mxdirect_sum_proj_eigenspace_cycle : + (sumE :=: 1%:M)%MS /\ mxdirect sumE. +Proof. +have [def1V] := mxdirect_sum_eigenspace_cycle; move/mxdirect_sumsP=> dxV. +pose p (i : 'I_h) := proj_mx 'V_i (\sum_(j | j != i) 'V_j)%MS. +have def1p: 1%:M = \sum_i p i. + rewrite -[\sum_i _]mul1mx; move/eqmxP: def1V; rewrite submx1. + case/sub_sumsmxP=> u ->; rewrite mulmx_sumr; apply: eq_bigr => i _. + rewrite (bigD1 i) //= mulmxDl proj_mx_id ?submxMl ?dxV //. + rewrite proj_mx_0 ?dxV ?addr0 ?summx_sub // => j ne_ji. + by rewrite (sumsmx_sup j) ?submxMl. +split; first do [apply/eqmxP; rewrite submx1]. + apply/(@memmx_subP F _ _ q)=> A _; apply/memmx_sumsP. + pose B i t := p i *m A *m p t. + exists (fun it => B it.1 it.2) => [|[i t] /=]. + rewrite -(pair_bigA _ B) /= -[A]mul1mx def1p mulmx_suml. + by apply: eq_bigr => i _; rewrite -mulmx_sumr -def1p mulmx1. + apply/E2iP; split=> [|j ne_ji]; first by rewrite mulmxA proj_mx_sub. + rewrite 2!mulmxA -mulmxA proj_mx_0 ?dxV ?mul0mx //. + rewrite (sumsmx_sup (inh j)) ?Vi_mod //. + by rewrite (modn_small (valP i)) in ne_ji. +apply/mxdirect_sumsP=> [[i t] _] /=. +apply/eqP; rewrite -submx0; apply/(@memmx_subP F _ _ q)=> A. +rewrite sub_capmx submx0 mxvec_eq0 -submx0. +case/andP=> /E2iP[ViA Vi'A] /memmx_sumsP[B /= defA sBE]. +rewrite -[A]mul1mx -(eqmxMr A def1V) sumsmxMr (bigD1 i) //=. +rewrite big1 ?addsmx0 => [|j ne_ij]; last by rewrite Vi'A ?modn_small. +rewrite -[_ *m A]mulmx1 def1p mulmx_sumr (bigD1 t) //=. +rewrite big1 ?addr0 => [|u ne_ut]; last first. + by rewrite proj_mx_0 ?dxV ?(sumsmx_sup t) // eq_sym. +rewrite {A ViA Vi'A}defA mulmx_sumr mulmx_suml summx_sub // => [[j u]]. +case/E2iP: (sBE (j, u)); rewrite eqE /=; case: eqP => [-> sBu _ ne_ut|]. + by rewrite proj_mx_0 ?dxV ?(sumsmx_sup u). +by move/eqP=> ne_ji _ ->; rewrite ?mul0mx // eq_sym !modn_small. +Qed. + +(* This is B & G, Proposition 2.4(d). *) +Proposition rank_proj_eigenspace_cycle i t : \rank 'E_(i, t) = ('n_i * 'n_t)%N. +Proof. +have [def1V] := mxdirect_sum_eigenspace_cycle; move/mxdirect_sumsP=> dxV. +pose p (i : 'I_h) := proj_mx 'V_i (\sum_(j | j != i) 'V_j)%MS. +have def1p: 1%:M = \sum_i p i. + rewrite -[\sum_i _]mul1mx; move/eqmxP: def1V; rewrite submx1. + case/sub_sumsmxP=> u ->; rewrite mulmx_sumr; apply: eq_bigr => j _. + rewrite (bigD1 j) //= mulmxDl proj_mx_id ?submxMl ?dxV //. + rewrite proj_mx_0 ?dxV ?addr0 ?summx_sub // => k ne_kj. + by rewrite (sumsmx_sup k) ?submxMl. +move: i t => i0 t0; pose i := inh i0; pose t := inh t0. +transitivity (\rank 'E_(i, t)); first by rewrite /E2_ !Vi_mod modn_mod. +transitivity ('n_i * 'n_t)%N; last by rewrite /n_ !Vi_mod. +move: {i0 t0}i t => i t; pose Bi := row_base 'V_i; pose Bt := row_base 'V_t. +pose B := lin_mx (mulmx (p i *m pinvmx Bi) \o mulmxr Bt). +pose B' := lin_mx (mulmx Bi \o mulmxr (pinvmx Bt)). +have Bk : B *m B' = 1%:M. + have frVpK m (C : 'M[F]_(m, q)) : row_free C -> C *m pinvmx C = 1%:M. + by move/row_free_inj; apply; rewrite mul1mx mulmxKpV. + apply/row_matrixP=> k; rewrite row_mul mul_rV_lin /= rowE mx_rV_lin /= -row1. + rewrite (mulmxA _ _ Bt) -(mulmxA _ Bt) [Bt *m _]frVpK ?row_base_free //. + rewrite mulmx1 2!mulmxA proj_mx_id ?dxV ?eq_row_base //. + by rewrite frVpK ?row_base_free // mul1mx vec_mxK. +have <-: \rank B = ('n_i * 'n_t)%N by apply/eqP; apply/row_freeP; exists B'. +apply/eqP; rewrite eqn_leq !mxrankS //. + apply/row_subP=> k; rewrite rowE mul_rV_lin /=. + apply/E2iP; split=> [|j ne_ji]. + rewrite 3!mulmxA mulmx_sub ?eq_row_base //. + rewrite 2!(mulmxA 'V_j) proj_mx_0 ?dxV ?mul0mx //. + rewrite (sumsmx_sup (inh j)) ?Vi_mod //. + by rewrite (modn_small (valP i)) in ne_ji. +apply/(@memmx_subP F _ _ q) => A /E2iP[ViA Vi'A]. +apply/submxP; exists (mxvec (Bi *m A *m pinvmx Bt)); rewrite mul_vec_lin /=. +rewrite mulmxKpV; last by rewrite eq_row_base (eqmxMr _ (eq_row_base _)). +rewrite mulmxA -[p i]mul1mx mulmxKpV ?eq_row_base ?proj_mx_sub // mul1mx. +rewrite -{1}[A]mul1mx def1p mulmx_suml (bigD1 i) //= big1 ?addr0 // => j neji. +rewrite -[p j]mul1mx -(mulmxKpV (proj_mx_sub _ _ _)) -mulmxA Vi'A ?mulmx0 //. +by rewrite !modn_small. +Qed. + +(* This is B & G, Proposition 2.4(e). *) +Proposition proj_eigenspace_cycle_sub_quasi_cent i j : + ('E_(i, i + j) <= 'E_j)%MS. +Proof. +apply/(@memmx_subP F _ _ q)=> A /E2iP[ViA Vi'A]. +apply/EiP; apply: canLR (mulKmx inj_g) _; rewrite -{1}[A]mul1mx -{2}[g]mul1mx. +have: (1%:M <= sumV)%MS by have [->] := mxdirect_sum_eigenspace_cycle. +case/sub_sumsmxP=> p ->; rewrite -!mulmxA !mulmx_suml. +apply: eq_bigr=> k _; have [-> | ne_ki] := eqVneq (k : nat) (i %% h)%N. + rewrite Vi_mod -mulmxA (mulmxA _ A) (eigenspaceP ViA). + rewrite (mulmxA _ g) (eigenspaceP (submxMl _ _)). + by rewrite -!(scalemxAl, scalemxAr) scalerA mulmxA exprD. +rewrite 2!mulmxA (eigenspaceP (submxMl _ _)) -!(scalemxAr, scalemxAl). +by rewrite -(mulmxA _ 'V_k A) Vi'A ?linear0 ?mul0mx ?scaler0 // modn_small. +Qed. + +Let diagE m := + (\sum_(it : 'I_h * 'I_h | it.1 + m == it.2 %[mod h]) 'E_(it.1, it.2))%MS. + +(* This is B & G, Proposition 2.4(f). *) +Proposition diag_sum_proj_eigenspace_cycle m : + (diagE m :=: 'E_m)%MS /\ mxdirect (diagE m). +Proof. +have sub_diagE n: (diagE n <= 'E_n)%MS. + apply/sumsmx_subP=> [[i t] /= def_t]. + apply: submx_trans (proj_eigenspace_cycle_sub_quasi_cent i n). + by rewrite /E2_ -(Vi_mod (i + n)) (eqP def_t) Vi_mod. +pose sum_diagE := (\sum_(n < h) diagE n)%MS. +pose p (it : 'I_h * 'I_h) := inh (h - it.1 + it.2). +have def_diag: sum_diagE = sumE. + rewrite /sumE (partition_big p xpredT) //. + apply: eq_bigr => n _; apply: eq_bigl => [[i t]] /=. + rewrite /p -val_eqE /= -(eqn_modDl (h - i)). + by rewrite addnA subnK 1?ltnW // modnDl modn_small. +have [Efull dxE] := mxdirect_sum_proj_eigenspace_cycle. +have /mxdirect_sumsE[/= dx_diag rank_diag]: mxdirect sum_diagE. + apply/mxdirectP; rewrite /= -/sum_diagE def_diag (mxdirectP dxE) /=. + rewrite (partition_big p xpredT) //. + apply: eq_bigr => n _; apply: eq_bigl => [[i t]] /=. + symmetry; rewrite /p -val_eqE /= -(eqn_modDl (h - i)). + by rewrite addnA subnK 1?ltnW // modnDl modn_small. +have dx_sumE1: mxdirect (\sum_(i < h) 'E_i). + by apply: mxdirect_sum_eigenspace => i j _ _; exact: inj_eps. +have diag_mod n: diagE (n %% h) = diagE n. + by apply: eq_bigl=> it; rewrite modnDmr. +split; last first. + apply/mxdirectP; rewrite /= -/(diagE m) -diag_mod. + rewrite (mxdirectP (dx_diag (inh m) _)) //=. + by apply: eq_bigl=> it; rewrite modnDmr. +apply/eqmxP; rewrite sub_diagE /=. +rewrite -(capmx_idPl (_ : _ <= sumE))%MS ?Efull ?submx1 //. +rewrite -def_diag /sum_diagE (bigD1 (inh m)) //= addsmxC. +rewrite diag_mod -matrix_modr ?sub_diagE //. +rewrite ((_ :&: _ =P 0)%MS _) ?adds0mx // -submx0. +rewrite -{2}(mxdirect_sumsP dx_sumE1 (inh m)) ?capmxS //. + by rewrite /E_ eps_mod_h. +by apply/sumsmx_subP=> i ne_i_m; rewrite (sumsmx_sup i) ?sub_diagE. +Qed. + +(* This is B & G, Proposition 2.4(g). *) +Proposition rank_quasi_cent_cycle m : + \rank 'E_m = (\sum_(i < h) 'n_i * 'n_(i + m))%N. +Proof. +have [<- dx_diag] := diag_sum_proj_eigenspace_cycle m. +rewrite (mxdirectP dx_diag) /= (reindex (fun i : 'I_h => (i, inh (i + m)))) /=. + apply: eq_big => [i | i _]; first by rewrite modn_mod eqxx. + by rewrite rank_proj_eigenspace_cycle /n_ Vi_mod. +exists (@fst _ _) => // [] [i t] /=. +by rewrite !inE /= (modn_small (valP t)) => def_t; exact/eqP/andP. +Qed. + +(* This is B & G, Proposition 2.4(h). *) +Proposition diff_rank_quasi_cent_cycle m : + (2 * \rank 'E_0 = 2 * \rank 'E_m + \sum_(i < h) `|'n_i - 'n_(i + m)| ^ 2)%N. +Proof. +rewrite !rank_quasi_cent_cycle !{1}mul2n -addnn. +rewrite {1}(reindex (fun i : 'I_h => inh (i + m))) /=; last first. + exists (fun i : 'I_h => inh (i + (h - m %% h))%N) => i _. + apply: val_inj; rewrite /= modnDml -addnA addnCA -modnDml addnCA. + by rewrite subnKC 1?ltnW ?ltn_mod // modnDr modn_small. + apply: val_inj; rewrite /= modnDml -modnDmr -addnA. + by rewrite subnK 1?ltnW ?ltn_mod // modnDr modn_small. +rewrite -mul2n big_distrr -!big_split /=; apply: eq_bigr => i _. +by rewrite !addn0 (addnC (2 * _)%N) sqrn_dist addnC /n_ Vi_mod. +Qed. + +Hypothesis rankEm : forall m, m != 0 %[mod h] -> \rank 'E_0 = (\rank 'E_m).+1. + +(* This is B & G, Proposition 2.4(j). *) +Proposition rank_eigenspaces_quasi_homocyclic : + exists2 n, `|q - h * n| = 1%N & + exists i : 'I_h, [/\ `|'n_i - n| = 1%N, (q < h * n) = ('n_i < n) + & forall j, j != i -> 'n_j = n]. +Proof. +have [defV dxV] := mxdirect_sum_eigenspace_cycle. +have sum_n: (\sum_(i < h) 'n_i)%N = q by rewrite -(mxdirectP dxV) defV mxrank1. +suffices [n [i]]: exists n : nat, exists2 i : 'I_h, + `|'n_i - n| == 1%N & forall i', i' != i -> 'n_i' = n. +- move/eqP=> n_i n_i'; rewrite -{1 5}(prednK h_gt0). + rewrite -sum_n (bigD1 i) //= (eq_bigr _ n_i') sum_nat_const cardC1 card_ord. + by exists n; last exists i; rewrite ?distnDr ?ltn_add2r. +case: (leqP h 1) sum_n {defV dxV} => [|h_gt1 _]. + rewrite leq_eqVlt ltnNge h_gt0 orbF; move/eqP->; rewrite big_ord1 => n_0. + by exists q', 0 => [|i']; rewrite ?(ord1 i') // n_0 distSn. +pose dn1 i := `|'n_i - 'n_(i + 1)|. +have sum_dn1: (\sum_(0 <= i < h) dn1 i ^ 2 == 2)%N. + rewrite big_mkord -(eqn_add2l (2 * \rank 'E_1)) -diff_rank_quasi_cent_cycle. + by rewrite -mulnSr -rankEm ?modn_small. +pose diff_n := [seq i <- index_iota 0 h | dn1 i != 0%N]. +have diff_n_1: all (fun i => dn1 i == 1%N) diff_n. + apply: contraLR sum_dn1; case/allPn=> i; rewrite mem_filter. + case def_i: (dn1 i) => [|[|ni]] //=; case/splitPr=> e e' _. + by rewrite big_cat big_cons /= addnCA def_i -add2n sqrnD. +have: sorted ltn diff_n. + by rewrite (sorted_filter ltn_trans) // /index_iota subn0 iota_ltn_sorted. +have: all (ltn^~ h) diff_n. + by apply/allP=> i; rewrite mem_filter mem_index_iota; case/andP. +have: size diff_n = 2%N. + move: diff_n_1; rewrite size_filter -(eqnP sum_dn1) /diff_n. + elim: (index_iota 0 h) => [|i e IHe]; rewrite (big_nil, big_cons) //=. + by case def_i: (dn1 i) => [|[]] //=; rewrite def_i //; move/IHe->. +case def_jk: diff_n diff_n_1 => [|j [|k []]] //=; case/and3P=> dn1j dn1k _ _. +case/and3P=> lt_jh lt_kh _ /andP[lt_jk _]. +have def_n i: + i <= h -> 'n_i = if i <= j then 'n_0 else if i <= k then 'n_j.+1 else 'n_k.+1. +- elim: i => // i IHi lt_ik; have:= IHi (ltnW lt_ik); rewrite !(leq_eqVlt i). + have:= erefl (i \in diff_n); rewrite {2}def_jk !inE mem_filter mem_index_iota. + case: (i =P j) => [-> _ _ | _]; first by rewrite ltnn lt_jk. + case: (i =P k) => [-> _ _ | _]; first by rewrite ltnNge ltnW // ltnn. + by rewrite distn_eq0 lt_ik addn1; case: eqP => [->|]. +have n_j1: 'n_j.+1 = 'n_k by rewrite (def_n k (ltnW lt_kh)) leqnn leqNgt lt_jk. +have n_k1: 'n_k.+1 = 'n_0. + rewrite -(rank_step_eigenspace_cycle 0) (def_n h (leqnn h)). + by rewrite leqNgt lt_jh leqNgt lt_kh; split. +case: (leqP k j.+1) => [ | lt_j1_k]. + rewrite leq_eqVlt ltnNge lt_jk orbF; move/eqP=> def_k. + exists 'n_(k + 1); exists (Ordinal lt_kh) => [|i' ne_i'k]; first exact: dn1k. + rewrite addn1 {1}(def_n _ (ltnW (valP i'))) n_k1. + by rewrite -ltnS -def_k ltn_neqAle ne_i'k /=; case: leqP; split. +case: (leqP h.-1 (k - j)) => [le_h1_kj | lt_kj_h1]. + have k_h1: k = h.-1. + apply/eqP; rewrite eqn_leq -ltnS (prednK h_gt0) lt_kh. + exact: leq_trans (leq_subr j k). + have j0: j = 0%N. + apply/eqP; rewrite -leqn0 -(leq_add2l k) -{2}(subnK (ltnW lt_jk)). + by rewrite addn0 leq_add2r {1}k_h1. + exists 'n_(j + 1); exists (Ordinal lt_jh) => [|i' ne_i'j]; first exact: dn1j. + rewrite addn1 {1}(def_n _ (ltnW (valP i'))) j0 leqNgt lt0n -j0. + by rewrite ne_i'j -ltnS k_h1 (prednK h_gt0) (valP i'); split. +suffices: \sum_(i < h) `|'n_i - 'n_(i + 2)| ^ 2 > 2. + rewrite -(ltn_add2l (2 * \rank 'E_2)) -diff_rank_quasi_cent_cycle. + rewrite -mulnSr -rankEm ?ltnn ?modn_small //. + by rewrite -(prednK h_gt0) ltnS (leq_trans _ lt_kj_h1) // ltnS subn_gt0. +have lt_k1h: k.-1 < h by rewrite ltnW // (ltn_predK lt_jk). +rewrite (bigD1 (Ordinal lt_jh)) // (bigD1 (Ordinal lt_k1h)) /=; last first. + by rewrite -val_eqE neq_ltn /= orbC -subn1 ltn_subRL lt_j1_k. +rewrite (bigD1 (Ordinal lt_kh)) /=; last first. + by rewrite -!val_eqE !neq_ltn /= lt_jk (ltn_predK lt_jk) leqnn !orbT. +rewrite !addnA ltn_addr // !addn2 (ltn_predK lt_jk) n_k1. +rewrite (def_n j (ltnW lt_jh)) leqnn (def_n _ (ltn_trans lt_j1_k lt_kh)). +rewrite lt_j1_k -if_neg -leqNgt leqnSn n_j1. +rewrite (def_n _ (ltnW lt_k1h)) leq_pred -if_neg -ltnNge. +rewrite -subn1 ltn_subRL lt_j1_k n_j1. +suffices ->: 'n_k.+2 = 'n_k.+1. + by rewrite distnC -n_k1 -(addn1 k) -/(dn1 k) (eqP dn1k). +case: (leqP k.+2 h) => [le_k2h | ]. + by rewrite (def_n _ le_k2h) (leqNgt _ k) leqnSn n_k1 if_same. +rewrite ltnS leq_eqVlt ltnNge lt_kh orbF; move/eqP=> def_h. +rewrite -{1}def_h -add1n rank_step_eigenspace_cycle (def_n _ h_gt0). +rewrite -(subSn (ltnW lt_jk)) def_h leq_subLR in lt_kj_h1. +by rewrite -(leq_add2r k) lt_kj_h1 n_k1. +Qed. + +(* This is B & G, Proposition 2.4(k). *) +Proposition rank_eigenspaces_free_quasi_homocyclic : + q > 1 -> 'n_0 = 0%N -> h = q.+1 /\ (forall j, j != 0 %[mod h] -> 'n_j = 1%N). +Proof. +move=> q_gt1 n_0; rewrite mod0n. +have [n d_q_hn [i [n_i lt_q_hn n_i']]] := rank_eigenspaces_quasi_homocyclic. +move/eqP: d_q_hn; rewrite distn_eq1 {}lt_q_hn. +case: (eqVneq (Ordinal h_gt0) i) n_i n_i' => [<- | ne0i _ n_i']; last first. + by rewrite -(n_i' _ ne0i) n_0 /= muln0 -(subnKC q_gt1). +rewrite n_0 dist0n => -> n_i'; rewrite muln1 => /eqP->; split=> // i'. +by move/(n_i' (inh i')); rewrite /n_ Vi_mod. +Qed. + +End QuasiRegularCyclic. + +(* This is B & G, Theorem 2.5, used for Theorems 3.4 and 15.7. *) +Theorem repr_extraspecial_prime_sdprod_cycle p n gT (G P H : {group gT}) : + p.-group P -> extraspecial P -> P ><| H = G -> cyclic H -> + let h := #|H| in #|P| = (p ^ n.*2.+1)%N -> coprime p h -> + {in H^#, forall x, 'C_P[x] = 'Z(P)} -> + (h %| p ^ n + 1) || (h %| p ^ n - 1) + /\ ((h != p ^ n + 1)%N -> forall F q (rG : mx_representation F G q), + [char F]^'.-group G -> mx_faithful rG -> rfix_mx rG H != 0). +Proof. +move=> pP esP sdPH_G cycH h oPpn co_p_h primeHP. +set dvd_h_pn := _ || _; set neq_h_pn := h != _. +suffices IH F q (rG : mx_representation F G q): + [char F]^'.-group G -> mx_faithful rG -> + dvd_h_pn && (neq_h_pn ==> (rfix_mx rG H != 0)). +- split=> [|ne_h F q rG F'G ffulG]; last first. + by case/andP: (IH F q rG F'G ffulG) => _; rewrite ne_h. + pose r := pdiv #|G|.+1. + have r_pr: prime r by rewrite pdiv_prime // ltnS cardG_gt0. + have F'G: [char 'F_r]^'.-group G. + rewrite /pgroup (eq_pnat _ (eq_negn (charf_eq (char_Fp r_pr)))). + rewrite p'natE // -prime_coprime // (coprime_dvdl (pdiv_dvd _)) //. + by rewrite /coprime -addn1 gcdnC gcdnDl gcdn1. + by case/andP: (IH _ _ _ F'G (regular_mx_faithful _ _)). +move=> F'G ffulG. +without loss closF: F rG F'G ffulG / group_closure_field F gT. + move=> IH; apply: (@group_closure_field_exists gT F) => [[Fs f clFs]]. + rewrite -(map_mx_eq0 f) map_rfix_mx {}IH ?map_mx_faithful //. + by rewrite (eq_p'group _ (fmorph_char f)). +have p_pr := extraspecial_prime pP esP; have p_gt1 := prime_gt1 p_pr. +have oZp := card_center_extraspecial pP esP; have[_ prZ] := esP. +have{sdPH_G} [nsPG sHG defG nPH tiPH] := sdprod_context sdPH_G. +have sPG := normal_sub nsPG. +have coPH: coprime #|P| #|H| by rewrite oPpn coprime_pexpl. +have nsZG: 'Z(P) <| G := char_normal_trans (center_char _) nsPG. +have defCP: 'C_G(P) = 'Z(P). + apply/eqP; rewrite eqEsubset andbC setSI //=. + rewrite -(coprime_mulG_setI_norm defG) ?norms_cent ?normal_norm //=. + rewrite mul_subG // -(setD1K (group1 H)). + apply/subsetP=> x; case/setIP; case/setU1P=> [-> // | H'x]. + rewrite -sub_cent1; move/setIidPl; rewrite primeHP // => defP. + by have:= min_card_extraspecial pP esP; rewrite -defP oZp (leq_exp2l 3 1). +have F'P: [char F]^'.-group P by exact: pgroupS sPG F'G. +have F'H: [char F]^'.-group H by exact: pgroupS sHG F'G. +wlog{ffulG F'G} [irrG regZ]: q rG / mx_irreducible rG /\ rfix_mx rG 'Z(P) = 0. + move=> IH; wlog [I W /= simW defV _]: / mxsemisimple rG 1%:M. + exact: (mx_reducible_semisimple (mxmodule1 _) (mx_Maschke rG F'G)). + have [z Zz ntz]: exists2 z, z \in 'Z(P) & z != 1%g. + by apply/trivgPn; rewrite -cardG_gt1 oZp prime_gt1. + have Gz := subsetP sPG z (subsetP (center_sub P) z Zz). + case: (pickP (fun i => z \notin rstab rG (W i))) => [i ffZ | z1]; last first. + case/negP: ntz; rewrite -in_set1 (subsetP ffulG) // inE Gz /=. + apply/eqP; move/eqmxP: defV; case/andP=> _; case/sub_sumsmxP=> w ->. + rewrite mulmx_suml; apply: eq_bigr => i _. + by move/negbFE: (z1 i) => /rstab_act-> //; rewrite submxMl. + have [modW _ _] := simW i; pose rW := submod_repr modW. + rewrite -(eqmx_rstab _ (val_submod1 (W i))) -(rstab_submod modW) in ffZ. + have irrW: mx_irreducible rW by exact/submod_mx_irr. + have regZ: rfix_mx rW 'Z(P)%g = 0. + apply/eqP; apply: contraR ffZ; case/mx_irrP: irrW => _ minW /minW. + by rewrite normal_rfix_mx_module // -sub1mx inE Gz /= => /implyP/rfix_mxP->. + have ffulP: P :&: rker rW = 1%g. + apply: (TI_center_nil (pgroup_nil pP)). + by rewrite /normal subsetIl normsI ?normG ?(subset_trans _ (rker_norm _)). + rewrite /= setIC setIA (setIidPl (center_sub _)); apply: prime_TIg=> //. + by apply: contra ffZ => /subsetP->. + have cPker: rker rW \subset 'C_G(P). + rewrite subsetI rstab_sub (sameP commG1P trivgP) /= -ffulP subsetI. + rewrite commg_subl commg_subr (subset_trans sPG) ?rker_norm //. + by rewrite (subset_trans (rstab_sub _ _)) ?normal_norm. + have [->] := andP (IH _ _ (conj irrW regZ)); case: (neq_h_pn) => //. + apply: contra; rewrite (eqmx_eq0 (rfix_submod modW sHG)) => /eqP->. + by rewrite capmx0 linear0. +pose rP := subg_repr rG sPG; pose rH := subg_repr rG sHG. +wlog [M simM _]: / exists2 M, mxsimple rP M & (M <= 1%:M)%MS. + by apply: (mxsimple_exists (mxmodule1 _)); last case irrG. +have{M simM irrG regZ F'P} [irrP def_q]: mx_irreducible rP /\ q = (p ^ n)%N. + have [modM nzM _]:= simM. + have [] := faithful_repr_extraspecial _ _ oPpn _ _ simM => // [|<- isoM]. + apply/eqP; apply: (TI_center_nil (pgroup_nil pP)). + rewrite /= -(eqmx_rstab _ (val_submod1 M)) -(rstab_submod modM). + exact: rker_normal. + rewrite setIC prime_TIg //=; apply: contra nzM => cMZ. + rewrite -submx0 -regZ; apply/rfix_mxP=> z; move/(subsetP cMZ)=> cMz. + by rewrite (rstab_act cMz). + suffices irrP: mx_irreducible rP. + by split=> //; apply/eqP; rewrite eq_sym; case/mx_irrP: irrP => _; exact. + apply: (@mx_irr_prime_index F _ G P _ M nsPG) => // [|x Gx]. + by rewrite -defG quotientMidl quotient_cyclic. + rewrite (bool_irrelevance (normal_sub nsPG) sPG). + apply: isoM; first exact: (@Clifford_simple _ _ _ _ nsPG). + have cZx: x \in 'C_G('Z(P)). + rewrite (setIidPl _) // -defG mulG_subG centsC subsetIr. + rewrite -(setD1K (group1 H)) subUset sub1G /=. + by apply/subsetP=> y H'y; rewrite -sub_cent1 -(primeHP y H'y) subsetIr. + by have [f] := Clifford_iso nsZG rG M cZx; exists f. +pose E_P := enveloping_algebra_mx rP; have{irrP} absP := closF P _ _ irrP. +have [q_gt0 EPfull]: q > 0 /\ (1%:M <= E_P)%MS by apply/andP; rewrite sub1mx. +pose Z := 'Z(P); have [sZP nZP] := andP (center_normal P : Z <| P). +have nHZ: H \subset 'N(Z) := subset_trans sHG (normal_norm nsZG). +pose clPqH := [set Zx ^: (H / Z) | Zx in P / Z]%g. +pose b (ZxH : {set coset_of Z}) := repr (repr ZxH). +have Pb ZxH: ZxH \in clPqH -> b ZxH \in P. + case/imsetP=> Zx P_Zx ->{ZxH}. + rewrite -(quotientGK (center_normal P)) /= -/Z inE repr_coset_norm /=. + rewrite inE coset_reprK; apply: subsetP (mem_repr _ (class_refl _ _)). + rewrite -class_support_set1l class_support_sub_norm ?sub1set //. + by rewrite quotient_norms. +have{primeHP coPH} card_clPqH ZxH: ZxH \in clPqH^# -> #|ZxH| = #|H|. + case/setD1P=> ntZxH P_ZxH. + case/imsetP: P_ZxH ntZxH => Zx P_Zx ->{ZxH}; rewrite classG_eq1 => ntZx. + rewrite -index_cent1 ['C__[_]](trivgP _). + rewrite indexg1 card_quotient // -indexgI setICA setIA tiPH. + by rewrite (setIidPl (sub1G _)) indexg1. + apply/subsetP=> Zy => /setIP[/morphimP[y Ny]]; rewrite -(setD1K (group1 H)). + case/setU1P=> [-> | Hy] ->{Zy} cZxy; first by rewrite morph1 set11. + have: Zx \in 'C_(P / Z)(<[y]> / Z). + by rewrite inE P_Zx quotient_cycle // cent_cycle cent1C. + case/idPn; rewrite -coprime_quotient_cent ?cycle_subG ?(pgroup_sol pP) //. + by rewrite /= cent_cycle primeHP // trivg_quotient inE. + by apply: coprimegS coPH; rewrite cycle_subG; case/setD1P: Hy. +pose B x := \matrix_(i < #|H|) mxvec (rP (x ^ enum_val i)%g). +have{E_P EPfull absP} sumB: (\sum_(ZxH in clPqH) <> :=: 1%:M)%MS. + apply/eqmxP; rewrite submx1 (submx_trans EPfull) //. + apply/row_subP=> ix; set x := enum_val ix; pose ZxH := coset Z x ^: (H / Z)%g. + have Px: x \in P by [rewrite enum_valP]; have nZx := subsetP nZP _ Px. + have P_ZxH: ZxH \in clPqH by apply: mem_imset; rewrite mem_quotient. + have Pbx := Pb _ P_ZxH; have nZbx := subsetP nZP _ Pbx. + rewrite rowK (sumsmx_sup ZxH) {P_ZxH}// genmxE -/x. + have: coset Z x \in coset Z (b ZxH) ^: (H / Z)%g. + by rewrite class_sym coset_reprK (mem_repr _ (class_refl _ _)). + case/imsetP=> _ /morphimP[y Ny Hy ->]. + rewrite -morphJ //; case/kercoset_rcoset; rewrite ?groupJ // => z Zz ->. + have [Pz cPz] := setIP Zz; rewrite repr_mxM ?memJ_norm ?(subsetP nPH) //. + have [a ->]: exists a, rP z = a%:M. + apply/is_scalar_mxP; apply: (mx_abs_irr_cent_scalar absP). + by apply/centgmxP=> t Pt; rewrite -!repr_mxM ?(centP cPz). + rewrite mul_scalar_mx linearZ scalemx_sub //. + by rewrite (eq_row_sub (gring_index H y)) // rowK gring_indexK. +have{card_clPqH} Bfree_if ZxH: + ZxH \in clPqH^# -> \rank <> <= #|ZxH| ?= iff row_free (B (b ZxH)). +- by move=> P_ZxH; rewrite genmxE card_clPqH // /leqif rank_leq_row. +have B1_if: \rank <> <= 1 ?= iff (<> == mxvec 1%:M)%MS. + have r1: \rank (mxvec 1%:M : 'rV[F]_(q ^ 2)) = 1%N. + by rewrite rank_rV mxvec_eq0 -mxrank_eq0 mxrank1 -lt0n q_gt0. + rewrite -{1}r1; apply: mxrank_leqif_eq; rewrite genmxE. + have ->: b 1%g = 1%g by rewrite /b repr_set1 repr_coset1. + by apply/row_subP=> i; rewrite rowK conj1g repr_mx1. +have rankEP: \rank (1%:M : 'A[F]_q) = (\sum_(ZxH in clPqH) #|ZxH|)%N. + rewrite acts_sum_card_orbit ?astabsJ ?quotient_norms // card_quotient //. + rewrite mxrank1 -divgS // -mulnn oPpn oZp expnS -muln2 expnM -def_q. + by rewrite mulKn // ltnW. +have cl1: 1%g \in clPqH by apply/imsetP; exists 1%g; rewrite ?group1 ?class1G. +have{B1_if Bfree_if}:= leqif_add B1_if (leqif_sum Bfree_if). +case/(leqif_trans (mxrank_sum_leqif _)) => _ /=. +rewrite -{1}(big_setD1 _ cl1) sumB {}rankEP (big_setD1 1%g) // cards1 eqxx. +case/esym/and3P=> dxB /eqmxP defB1 /forall_inP/= Bfree. +have [yg defH] := cyclicP cycH; pose g := rG yg. +have Hxg: yg \in H by [rewrite defH cycle_id]; have Gyg := subsetP sHG _ Hxg. +pose gE : 'A_q := lin_mx (mulmx (invmx g) \o mulmxr g). +pose yr := regular_repr F H yg. +have mulBg x: x \in P -> B x *m gE = yr *m B x. + move/(subsetP sPG)=> Gx. + apply/row_matrixP=> i; have Hi := enum_valP i; have Gi := subsetP sHG _ Hi. + rewrite 2!row_mul !rowK mul_vec_lin /= -rowE rowK gring_indexK ?groupM //. + by rewrite conjgM -repr_mxV // -!repr_mxM // ?(groupJ, groupM, groupV). +wlog sH: / irrType F H by exact: socle_exists. +have{cycH} linH: irr_degree (_ : sH) = 1%N. + exact: irr_degree_abelian (cyclic_abelian cycH). +have baseH := linear_irr_comp F'H (closF H) (linH _). +have{linH} linH (W : sH): \rank W = 1%N by rewrite baseH; exact: linH. +have [w] := cycle_repr_structure sH defH F'H (closF H). +rewrite -/h => prim_w [Wi [bijWi _ _ Wi_yg]]. +have{Wi_yg baseH} Wi_yr i: Wi i *m yr = w ^+ i *: (Wi i : 'M_h). + have /submxP[u ->]: (Wi i <= val_submod (irr_repr (Wi i) 1%g))%MS. + by rewrite repr_mx1 val_submod1 -baseH. + rewrite repr_mx1 -mulmxA -2!linearZ; congr (u *m _). + by rewrite -mul_mx_scalar -Wi_yg /= val_submodJ. +pose E_ m := eigenspace gE (w ^+ m). +have dxE: mxdirect (\sum_(m < h) E_ m)%MS. + apply: mxdirect_sum_eigenspace => m1 m2 _ _ eq_m12; apply/eqP. + by move/eqP: eq_m12; rewrite (eq_prim_root_expr prim_w) !modn_small. +pose B2 ZxH i : 'A_q := <>%MS. +pose B1 i : 'A_q := (\sum_(ZxH in clPqH^#) B2 ZxH i)%MS. +pose SB := (<> + \sum_i B1 i)%MS. +have{yr Wi_yr Pb mulBg} sB1E i: (B1 i <= E_ i)%MS. + apply/sumsmx_subP=> ZxH /setIdP[_]; rewrite genmxE => P_ZxH. + by apply/eigenspaceP; rewrite -mulmxA mulBg ?Pb // mulmxA Wi_yr scalemxAl. +have{bijWi sumB cl1 F'H} defSB: (SB :=: 1%:M)%MS. + apply/eqmxP; rewrite submx1 -sumB (big_setD1 _ cl1) addsmxS //=. + rewrite exchange_big sumsmxS // => ZxH _; rewrite genmxE /= -sumsmxMr_gen. + rewrite -((reindex Wi) xpredT val) /=; last by exact: onW_bij. + by rewrite -/(Socle _) (reducible_Socle1 sH (mx_Maschke _ F'H)) mul1mx. +rewrite mxdirect_addsE /= in dxB; case/and3P: dxB => _ dxB dxB1. +have{linH Bfree dxB} rankB1 i: \rank (B1 i) = #|clPqH^#|. + rewrite -sum1_card (mxdirectP _) /=. + by apply: eq_bigr => ZxH P_ZxH; rewrite genmxE mxrankMfree ?Bfree. + apply/mxdirect_sumsP=> ZxH P_ZxH. + apply/eqP; rewrite -submx0 -{2}(mxdirect_sumsP dxB _ P_ZxH) capmxS //. + by rewrite !genmxE submxMl. + by rewrite sumsmxS // => ZyH _; rewrite !genmxE submxMl. +have rankEi (i : 'I_h) : i != 0%N :> nat -> \rank (E_ i) = #|clPqH^#|. + move=> i_gt0; apply/eqP; rewrite -(rankB1 i) (mxrank_leqif_sup _) ?sB1E //. + rewrite -[E_ i]cap1mx -(cap_eqmx defSB (eqmx_refl _)) /SB. + rewrite (bigD1 i) //= (addsmxC (B1 i)) addsmxA addsmxC -matrix_modl //. + rewrite -(addsmx0 (q ^ 2) (B1 i)) addsmxS //. + rewrite capmxC -{2}(mxdirect_sumsP dxE i) // capmxS // addsmx_sub // . + rewrite (sumsmx_sup (Ordinal (cardG_gt0 H))) ?sumsmxS 1?eq_sym //. + rewrite defB1; apply/eigenspaceP; rewrite mul_vec_lin scale1r /=. + by rewrite mul1mx mulVmx ?repr_mx_unit. +have{b B defB1 rP rH sH Wi rankB1 dxB1 defSB sB1E B1 B2 dxE SB} rankE0 i: + (i : 'I_h) == 0%N :> nat -> \rank (E_ i) = #|clPqH^#|.+1. +- move=> i_eq0; rewrite -[E_ i]cap1mx -(cap_eqmx defSB (eqmx_refl _)) /SB. + rewrite (bigD1 i) // addsmxA -matrix_modl; last first. + rewrite addsmx_sub // sB1E andbT defB1; apply/eigenspaceP. + by rewrite mul_vec_lin (eqP i_eq0) scale1r /= mul1mx mulVmx ?repr_mx_unit. + rewrite (((_ :&: _)%MS =P 0) _). + rewrite addsmx0 mxrank_disjoint_sum /=. + by rewrite defB1 rank_rV rankB1 mxvec_eq0 -mxrank_eq0 mxrank1 -lt0n q_gt0. + apply/eqP; rewrite -submx0 -(eqP dxB1) capmxS // sumsmxS // => ZxH _. + by rewrite !genmxE ?submxMl. + by rewrite -submx0 capmxC /= -{2}(mxdirect_sumsP dxE i) // capmxS ?sumsmxS. +have{clPqH rankE0 rankEi} (m): + m != 0 %[mod h] -> \rank (E_ 0%N) = (\rank (E_ m)).+1. +- move=> nz_m; rewrite (rankE0 (Ordinal (cardG_gt0 H))) //. + rewrite /E_ -(prim_expr_mod prim_w); rewrite mod0n in nz_m. + have lt_m: m %% h < h by rewrite ltn_mod ?cardG_gt0. + by rewrite (rankEi (Ordinal lt_m)). +have: q > 1. + rewrite def_q (ltn_exp2l 0) // lt0n. + apply: contraL (min_card_extraspecial pP esP). + by rewrite oPpn; move/eqP->; rewrite leq_exp2l. +rewrite {}/E_ {}/gE {}/dvd_h_pn {}/neq_h_pn -{n oPpn}def_q subn1 addn1 /=. +case: q q_gt0 => // q' _ in rG g * => q_gt1 rankE. +have gh1: g ^+ h = 1 by rewrite -repr_mxX // /h defH expg_order repr_mx1. +apply/andP; split. + have [n' def_q _]:= rank_eigenspaces_quasi_homocyclic gh1 prim_w rankE. + move/eqP: def_q; rewrite distn_eq1 eqSS. + by case: ifP => _ /eqP->; rewrite dvdn_mulr ?orbT. +apply/implyP; apply: contra => regH. +have [|-> //]:= rank_eigenspaces_free_quasi_homocyclic gh1 prim_w rankE q_gt1. +apply/eqP; rewrite mxrank_eq0 -submx0 -(eqP regH). +apply/rV_subP=> v /eigenspaceP; rewrite scale1r => cvg. +apply/rfix_mxP=> y Hy; apply: rstab_act (submx_refl v); apply: subsetP y Hy. +by rewrite defH cycle_subG !inE Gyg /= cvg. +Qed. + +(* This is the main part of B & G, Theorem 2.6; it implies 2.6(a) and most of *) +(* 2.6(b). *) +Theorem der1_odd_GL2_charf F gT (G : {group gT}) + (rG : mx_representation F G 2) : + odd #|G| -> mx_faithful rG -> [char F].-group G^`(1)%g. +Proof. +move=> oddG ffulG. +without loss closF: F rG ffulG / group_closure_field F gT. + move=> IH; apply: (@group_closure_field_exists gT F) => [[Fc f closFc]]. + rewrite -(eq_pgroup _ (fmorph_char f)). + by rewrite -(map_mx_faithful f) in ffulG; exact: IH ffulG closFc. +elim: {G}_.+1 {-2}G (ltnSn #|G|) => // m IHm G le_g_m in rG oddG ffulG *. +apply/pgroupP=> p p_pr pG'; rewrite !inE p_pr /=; apply: wlog_neg => p_nz. +have [P sylP] := Sylow_exists p G. +have nPG: G \subset 'N(P). + apply/idPn=> ltNG; pose N := 'N_G(P); have sNG: N \subset G := subsetIl _ _. + have{IHm ltNG} p'N': [char F].-group N^`(1)%g. + apply: IHm (subg_mx_faithful sNG ffulG); last exact: oddSg oddG. + rewrite -ltnS (leq_trans _ le_g_m) // ltnS proper_card //. + by rewrite /proper sNG subsetI subxx. + have{p'N'} tiPN': P :&: N^`(1)%g = 1%g. + rewrite coprime_TIg ?(pnat_coprime (pHall_pgroup sylP)) //= -/N. + apply: sub_in_pnat p'N' => q _; apply: contraL; move/eqnP->. + by rewrite !inE p_pr. + have sPN: P \subset N by rewrite subsetI normG (pHall_sub sylP). + have{tiPN'} cPN: N \subset 'C(P). + rewrite (sameP commG1P trivgP) -tiPN' subsetI commgS //. + by rewrite commg_subr subsetIr. + have /sdprodP[_ /= defG nKP _] := Burnside_normal_complement sylP cPN. + set K := 'O_p^'(G) in defG nKP; have nKG: G \subset 'N(K) by exact: gFnorm. + suffices p'G': p^'.-group G^`(1)%g by case/eqnP: (pgroupP p'G' p p_pr pG'). + apply: pgroupS (pcore_pgroup p^' G); rewrite -quotient_cents2 //= -/K. + by rewrite -defG quotientMidl /= -/K quotient_cents ?(subset_trans sPN). +pose Q := G^`(1)%g :&: P; have sQG: Q \subset G by rewrite subIset ?der_subS. +have nQG: G \subset 'N(Q) by rewrite normsI // normal_norm ?der_normalS. +have pQ: (p %| #|Q|)%N. + have sylQ: p.-Sylow(G^`(1)%g) Q. + by apply: Sylow_setI_normal (der_normalS _ _) _. + apply: contraLR pG'; rewrite -!p'natE // (card_Hall sylQ) -!partn_eq1 //. + by rewrite part_pnat_id ?part_pnat. +have{IHm} abelQ: abelian Q. + apply/commG1P/eqP/idPn => ntQ'. + have{IHm} p'Q': [char F].-group Q^`(1)%g. + apply: IHm (subg_mx_faithful sQG ffulG); last exact: oddSg oddG. + rewrite -ltnS (leq_trans _ le_g_m) // ltnS proper_card //. + rewrite /proper sQG subsetI //= andbC subEproper. + case: eqP => [-> /= | _]; last by rewrite /proper (pHall_sub sylP) andbF. + have: nilpotent P by rewrite (pgroup_nil (pHall_pgroup sylP)). + move/forallP/(_ P); apply: contraL; rewrite subsetI subxx => -> /=. + apply: contra ntQ'; rewrite /Q => /eqP->. + by rewrite (setIidPr _) ?sub1G // commG1. + case/eqP: ntQ'; have{p'Q'}: P :&: Q^`(1)%g = 1%g. + rewrite coprime_TIg ?(pnat_coprime (pHall_pgroup sylP)) //= -/Q. + by rewrite (pi_p'nat p'Q') // !inE p_pr. + by rewrite (setIidPr _) // comm_subG ?subsetIr. +pose rQ := subg_repr rG sQG. +wlog [U simU sU1]: / exists2 U, mxsimple rQ U & (U <= 1%:M)%MS. + by apply: mxsimple_exists; rewrite ?mxmodule1 ?oner_eq0. +have Uscal: \rank U = 1%N by exact: (mxsimple_abelian_linear (closF _)) simU. +have{simU} [Umod _ _] := simU. +have{sU1} [|V Vmod sumUV dxUV] := mx_Maschke _ _ Umod sU1. + have: p.-group Q by apply: pgroupS (pHall_pgroup sylP); rewrite subsetIr. + by apply: sub_in_pnat=> q _; move/eqnP->; rewrite !inE p_pr. +have [u defU]: exists u : 'rV_2, (u :=: U)%MS. + by move: (row_base U) (eq_row_base U); rewrite Uscal => u; exists u. +have{dxUV Uscal} [v defV]: exists v : 'rV_2, (v :=: V)%MS. + move/mxdirectP: dxUV; rewrite /= Uscal sumUV mxrank1 => [[Vscal]]. + by move: (row_base V) (eq_row_base V); rewrite -Vscal => v; exists v. +pose B : 'M_(1 + 1) := col_mx u v; have{sumUV} uB: B \in unitmx. + rewrite -row_full_unit /row_full eqn_leq rank_leq_row {1}addn1. + by rewrite -addsmxE -(mxrank1 F 2) -sumUV mxrankS // addsmxS ?defU ?defV. +pose Qfix (w : 'rV_2) := {in Q, forall y, w *m rG y <= w}%MS. +have{U defU Umod} u_fix: Qfix u. + by move=> y Qy; rewrite /= (eqmxMr _ defU) defU (mxmoduleP Umod). +have{V defV Vmod} v_fix: Qfix v. + by move=> y Qy; rewrite /= (eqmxMr _ defV) defV (mxmoduleP Vmod). +case/Cauchy: pQ => // x Qx oxp; have Gx := subsetP sQG x Qx. +case/submxP: (u_fix x Qx) => a def_ux. +case/submxP: (v_fix x Qx) => b def_vx. +have def_x: rG x = B^-1 *m block_mx a 0 0 b *m B. + rewrite -mulmxA -[2]/(1 + 1)%N mul_block_col !mul0mx addr0 add0r. + by rewrite -def_ux -def_vx -mul_col_mx mulKmx. +have ap1: a ^+ p = 1. + suff: B^-1 *m block_mx (a ^+ p) 0 0 (b ^+ p) *m B = 1. + move/(canRL (mulmxK uB))/(canRL (mulKVmx uB)); rewrite mul1mx. + by rewrite mulmxV // scalar_mx_block; case/eq_block_mx. + transitivity (rG x ^+ p); last first. + by rewrite -(repr_mxX (subg_repr rG sQG)) // -oxp expg_order repr_mx1. + elim: (p) => [|k IHk]; first by rewrite -scalar_mx_block mulmx1 mulVmx. + rewrite !exprS -IHk def_x -!mulmxE !mulmxA mulmxK // -2!(mulmxA B^-1). + by rewrite -[2]/(1 + 1)%N mulmx_block !mulmx0 !mul0mx !addr0 mulmxA add0r. +have ab1: a * b = 1. + have: Q \subset <<[set y in G | \det (rG y) == 1]>>. + rewrite subIset // genS //; apply/subsetP=> yz; case/imset2P=> y z Gy Gz ->. + rewrite inE !repr_mxM ?groupM ?groupV //= !detM (mulrCA _ (\det (rG y))). + rewrite -!det_mulmx -!repr_mxM ?groupM ?groupV //. + by rewrite mulKg mulVg repr_mx1 det1. + rewrite gen_set_id; last first. + apply/group_setP; split=> [|y z /setIdP[Gy /eqP y1] /setIdP[Gz /eqP z1]]. + by rewrite inE group1 /= repr_mx1 det1. + by rewrite inE groupM ?repr_mxM //= detM y1 z1 mulr1. + case/subsetP/(_ x Qx)/setIdP=> _. + rewrite def_x !detM mulrAC -!detM -mulrA mulKr // -!mulmxE. + rewrite -[2]/(1 + 1)%N det_lblock // [a]mx11_scalar [b]mx11_scalar. + by rewrite !det_scalar1 -scalar_mxM => /eqP->. +have{ab1 ap1 def_x} ne_ab: a != b. + apply/eqP=> defa; have defb: b = 1. + rewrite -ap1 (divn_eq p 2) modn2. + have ->: odd p by rewrite -oxp (oddSg _ oddG) // cycle_subG. + by rewrite addn1 exprS mulnC exprM exprS {1 3}defa ab1 expr1n mulr1. + suff x1: x \in [1] by rewrite -oxp (set1P x1) order1 in p_pr. + rewrite (subsetP ffulG) // inE Gx def_x defa defb -scalar_mx_block mulmx1. + by rewrite mul1mx mulVmx ?eqxx. +have{a b ne_ab def_ux def_vx} nx_uv (w : 'rV_2): + (w *m rG x <= w -> w <= u \/ w <= v)%MS. +- case/submxP=> c; have:= mulmxKV uB w. + rewrite -[_ *m invmx B]hsubmxK [lsubmx _]mx11_scalar [rsubmx _]mx11_scalar. + move: (_ 0) (_ 0) => dv du; rewrite mul_row_col !mul_scalar_mx => <-{w}. + rewrite mulmxDl -!scalemxAl def_ux def_vx mulmxDr -!scalemxAr. + rewrite !scalemxAl -!mul_row_col; move/(can_inj (mulmxK uB)). + case/eq_row_mx => eqac eqbc; apply/orP. + have [-> | nz_dv] := eqVneq dv 0; first by rewrite scale0r addr0 scalemx_sub. + have [-> | nz_du] := eqVneq du 0. + by rewrite orbC scale0r add0r scalemx_sub. + case/eqP: ne_ab; rewrite -[b]scale1r -(mulVf nz_dv) -[a]scale1r. + by rewrite -(mulVf nz_du) -!scalerA eqac eqbc !scalerA !mulVf. +have{x Gx Qx oxp nx_uv} redG y (A := rG y): + y \in G -> (u *m A <= u /\ v *m A <= v)%MS. +- move=> Gy; have uA: row_free A by rewrite row_free_unit repr_mx_unit. + have Ainj (w t : 'rV_2): (w *m A <= w -> t *m A <= w -> t *m A <= t)%MS. + case/sub_rVP=> [c ryww] /sub_rVP[d rytw]. + rewrite -(submxMfree _ _ uA) rytw -scalemxAl ryww scalerA mulrC. + by rewrite -scalerA scalemx_sub. + have{Qx nx_uv} nAx w: Qfix w -> (w *m A <= u \/ w *m A <= v)%MS. + move=> nwQ; apply: nx_uv; rewrite -mulmxA -repr_mxM // conjgCV. + rewrite repr_mxM ?groupJ ?groupV // mulmxA submxMr // nwQ // -mem_conjg. + by rewrite (normsP nQG). + have [uAu | uAv] := nAx _ u_fix; have [vAu | vAv] := nAx _ v_fix; eauto. + have [k ->]: exists k, A = A ^+ k.*2. + exists #[y].+1./2; rewrite -mul2n -divn2 mulnC divnK. + by rewrite -repr_mxX // expgS expg_order mulg1. + by rewrite dvdn2 negbK; apply: oddSg oddG; rewrite cycle_subG. + elim: k => [|k [IHu IHv]]; first by rewrite !mulmx1. + case/sub_rVP: uAv => c uAc; case/sub_rVP: vAu => d vAd. + rewrite doubleS !exprS !mulmxA; do 2!rewrite uAc vAd -!scalemxAl. + by rewrite !scalemx_sub. +suffices trivG': G^`(1)%g = 1%g. + by rewrite /= trivG' cards1 gtnNdvd ?prime_gt1 in pG'. +apply/trivgP; apply: subset_trans ffulG; rewrite gen_subG. +apply/subsetP=> _ /imset2P[y z Gy Gz ->]; rewrite inE groupR //=. +rewrite -(inj_eq (can_inj (mulKmx (repr_mx_unit rG (groupM Gz Gy))))). +rewrite mul1mx mulmx1 -repr_mxM ?(groupR, groupM) // -commgC !repr_mxM //. +rewrite -(inj_eq (can_inj (mulKmx uB))) !mulmxA !mul_col_mx. +case/redG: Gy => /sub_rVP[a uya] /sub_rVP[b vyb]. +case/redG: Gz => /sub_rVP[c uzc] /sub_rVP[d vzd]. +by do 2!rewrite uya vyb uzc vzd -?scalemxAl; rewrite !scalerA mulrC (mulrC d). +Qed. + +(* This is B & G, Theorem 2.6(a) *) +Theorem charf'_GL2_abelian F gT (G : {group gT}) + (rG : mx_representation F G 2) : + odd #|G| -> mx_faithful rG -> [char F]^'.-group G -> abelian G. +Proof. +move=> oddG ffG char'G; apply/commG1P/eqP. +rewrite trivg_card1 (pnat_1 _ (pgroupS _ char'G)) ?comm_subG //=. +exact: der1_odd_GL2_charf ffG. +Qed. + +(* This is B & G, Theorem 2.6(b) *) +Theorem charf_GL2_der_subS_abelian_Sylow p F gT (G : {group gT}) + (rG : mx_representation F G 2) : + odd #|G| -> mx_faithful rG -> p \in [char F] -> + exists P : {group gT}, [/\ p.-Sylow(G) P, abelian P & G^`(1)%g \subset P]. +Proof. +move=> oddG ffG charFp. +have{oddG} pG': p.-group G^`(1)%g. + rewrite /pgroup -(eq_pnat _ (charf_eq charFp)). + exact: der1_odd_GL2_charf ffG. +have{pG'} [P SylP sG'P]:= Sylow_superset (der_sub _ _) pG'. +exists P; split=> {sG'P}//; case/and3P: SylP => sPG pP _. +apply/commG1P/trivgP; apply: subset_trans ffG; rewrite gen_subG. +apply/subsetP=> _ /imset2P[y z Py Pz ->]; rewrite inE (subsetP sPG) ?groupR //=. +pose rP := subg_repr rG sPG; pose U := rfix_mx rP P. +rewrite -(inj_eq (can_inj (mulKmx (repr_mx_unit rP (groupM Pz Py))))). +rewrite mul1mx mulmx1 -repr_mxM ?(groupR, groupM) // -commgC !repr_mxM //. +have: U != 0 by apply: (rfix_pgroup_char charFp). +rewrite -mxrank_eq0 -lt0n 2!leq_eqVlt ltnNge rank_leq_row orbF orbC eq_sym. +case/orP=> [Ufull | Uscal]. + suffices{y z Py Pz} rP1 y: y \in P -> rP y = 1%:M by rewrite !rP1 ?mulmx1. + move=> Py; apply/row_matrixP=> i. + by rewrite rowE -row1 (rfix_mxP P _) ?submx_full. +have [u defU]: exists u : 'rV_2, (u :=: U)%MS. + by move: (row_base U) (eq_row_base U); rewrite -(eqP Uscal) => u; exists u. +have fix_u: {in P, forall x, u *m rP x = u}. + by move/eqmxP: defU; case/andP; move/rfix_mxP. +have [v defUc]: exists u : 'rV_2, (u :=: U^C)%MS. + have UCscal: \rank U^C = 1%N by rewrite mxrank_compl -(eqP Uscal). + by move: (row_base _)%MS (eq_row_base U^C)%MS; rewrite UCscal => v; exists v. +pose B := col_mx u v; have uB: B \in unitmx. + rewrite -row_full_unit -sub1mx -(eqmxMfull _ (addsmx_compl_full U)). + by rewrite mulmx1 -addsmxE addsmxS ?defU ?defUc. +have Umod: mxmodule rP U by exact: rfix_mx_module. +pose W := rfix_mx (factmod_repr Umod) P. +have ntW: W != 0. + apply: (rfix_pgroup_char charFp) => //. + rewrite eqmxMfull ?row_full_unit ?unitmx_inv ?row_ebase_unit //. + by rewrite rank_copid_mx -(eqP Uscal). +have{ntW} Wfull: row_full W. + by rewrite -col_leq_rank {1}mxrank_coker -(eqP Uscal) lt0n mxrank_eq0. +have svW: (in_factmod U v <= W)%MS by rewrite submx_full. +have fix_v: {in P, forall x, v *m rG x - v <= u}%MS. + move=> x Px /=; rewrite -[v *m _](add_sub_fact_mod U) (in_factmodJ Umod) //. + move/rfix_mxP: svW => -> //; rewrite in_factmodK ?defUc // addrK. + by rewrite defU val_submodP. +have fixB: {in P, forall x, exists2 a, u *m rG x = u & v *m rG x = v + a *: u}. + move=> x Px; case/submxP: (fix_v x Px) => a def_vx. + exists (a 0 0); first exact: fix_u. + by rewrite addrC -mul_scalar_mx -mx11_scalar -def_vx subrK. +rewrite -(inj_eq (can_inj (mulKmx uB))) // !mulmxA !mul_col_mx. +case/fixB: Py => a uy vy; case/fixB: Pz => b uz vz. +by rewrite uy uz vy vz !mulmxDl -!scalemxAl uy uz vy vz addrAC. +Qed. + +(* This is B & G, Lemma 2.7. *) +Lemma regular_abelem2_on_abelem2 p q gT (P Q : {group gT}) : + p.-abelem P -> q.-abelem Q -> 'r_p(P) = 2 ->'r_q(Q) = 2 -> + Q \subset 'N(P) -> 'C_Q(P) = 1%g -> + (q %| p.-1)%N + /\ (exists2 a, a \in Q^# & exists r, + [/\ {in P, forall x, x ^ a = x ^+ r}%g, + r ^ q = 1 %[mod p] & r != 1 %[mod p]]). +Proof. +move=> abelP abelQ; rewrite !p_rank_abelem // => logP logQ nPQ regQ. +have ntP: P :!=: 1%g by case: eqP logP => // ->; rewrite cards1 logn1. +have [p_pr _ _]:= pgroup_pdiv (abelem_pgroup abelP) ntP. +have ntQ: Q :!=: 1%g by case: eqP logQ => // ->; rewrite cards1 logn1. +have [q_pr _ _]:= pgroup_pdiv (abelem_pgroup abelQ) ntQ. +pose rQ := abelem_repr abelP ntP nPQ. +have [|P1 simP1 _] := dec_mxsimple_exists (mxmodule1 rQ). + by rewrite oner_eq0. +have [modP1 nzP1 _] := simP1. +have ffulQ: mx_faithful rQ by exact: abelem_mx_faithful. +have linP1: \rank P1 = 1%N. + apply/eqP; have:= abelem_cyclic abelQ; rewrite logQ; apply: contraFT. + rewrite neq_ltn ltnNge lt0n mxrank_eq0 nzP1 => P1full. + have irrQ: mx_irreducible rQ. + apply: mx_iso_simple simP1; apply: eqmx_iso; apply/eqmxP. + by rewrite submx1 sub1mx -col_leq_rank {1}(dim_abelemE abelP ntP) logP. + exact: mx_faithful_irr_abelian_cyclic irrQ (abelem_abelian abelQ). +have ne_qp: q != p. + move/implyP: (logn_quotient_cent_abelem nPQ abelP). + by rewrite logP regQ indexg1 /=; case: eqP => // <-; rewrite logQ. +have redQ: mx_completely_reducible rQ 1%:M. + apply: mx_Maschke; apply: pi_pnat (abelem_pgroup abelQ) _. + by rewrite inE /= (charf_eq (char_Fp p_pr)). +have [P2 modP2 sumP12 dxP12] := redQ _ modP1 (submx1 _). +have{dxP12} linP2: \rank P2 = 1%N. + apply: (@addnI 1%N); rewrite -{1}linP1 -(mxdirectP dxP12) /= sumP12. + by rewrite mxrank1 (dim_abelemE abelP ntP) logP. +have{sumP12} [u def1]: exists u, 1%:M = u.1 *m P1 + u.2 *m P2. + by apply/sub_addsmxP; rewrite sumP12. +pose lam (Pi : 'M(P)) b := (nz_row Pi *m rQ b *m pinvmx (nz_row Pi)) 0 0. +have rQ_lam Pi b: + mxmodule rQ Pi -> \rank Pi = 1%N -> b \in Q -> Pi *m rQ b = lam Pi b *: Pi. +- rewrite /lam => modPi linPi Qb; set v := nz_row Pi; set a := _ 0. + have nz_v: v != 0 by rewrite nz_row_eq0 -mxrank_eq0 linPi. + have sPi_v: (Pi <= v)%MS. + by rewrite -mxrank_leqif_sup ?nz_row_sub // rank_rV nz_v linPi. + have [v' defPi] := submxP sPi_v; rewrite {2}defPi scalemxAr -mul_scalar_mx. + rewrite -mx11_scalar !(mulmxA v') -defPi mulmxKpV ?(submx_trans _ sPi_v) //. + exact: (mxmoduleP modPi). +have lam_q Pi b: + mxmodule rQ Pi -> \rank Pi = 1%N -> b \in Q -> lam Pi b ^+ q = 1. +- move=> modPi linPi Qb; apply/eqP; rewrite eq_sym -subr_eq0. + have: \rank Pi != 0%N by rewrite linPi. + apply: contraR; move/eqmx_scale=> <-. + rewrite mxrank_eq0 scalerBl subr_eq0 -mul_mx_scalar -(repr_mx1 rQ). + have <-: (b ^+ q = 1)%g by case/and3P: abelQ => _ _; move/exponentP->. + apply/eqP; rewrite repr_mxX //. + elim: (q) => [|k IHk]; first by rewrite scale1r mulmx1. + by rewrite !exprS mulmxA rQ_lam // -scalemxAl IHk scalerA. +pose f b := (lam P1 b, lam P2 b). +have inj_f: {in Q &, injective f}. + move=> b c Qb Qc /= [eq_bc1 eq_bc2]; apply: (mx_faithful_inj ffulQ) => //. + rewrite -[rQ b]mul1mx -[rQ c]mul1mx {}def1 !mulmxDl -!mulmxA. + by rewrite !{1}rQ_lam ?eq_bc1 ?eq_bc2. +pose rs := [set x : 'F_p | x ^+ q == 1]. +have s_fQ_rs: f @: Q \subset setX rs rs. + apply/subsetP=> _ /imsetP[b Qb ->]. + by rewrite !{1}inE /= !{1}lam_q ?eqxx. +have le_rs_q: #|rs| <= q ?= iff (#|rs| == q). + split; rewrite // cardE max_unity_roots ?enum_uniq ?prime_gt0 //. + by apply/allP=> x; rewrite mem_enum inE unity_rootE. +have:= subset_leqif_card s_fQ_rs. +rewrite card_in_imset // (card_pgroup (abelem_pgroup abelQ)) logQ. +case/(leqif_trans (leqif_mul le_rs_q le_rs_q))=> _; move/esym. +rewrite cardsX eqxx andbb muln_eq0 orbb eqn0Ngt prime_gt0 //= => /andP[rs_q]. +rewrite subEproper /proper {}s_fQ_rs andbF orbF => /eqP rs2_Q. +have: ~~ (rs \subset [set 1 : 'F_p]). + apply: contraL (prime_gt1 q_pr); move/subset_leq_card. + by rewrite cards1 (eqnP rs_q) leqNgt. +case/subsetPn => r rs_r; rewrite inE => ne_r_1. +have rq1: r ^+ q = 1 by apply/eqP; rewrite inE in rs_r. +split. + have Ur: r \in GRing.unit. + by rewrite -(unitrX_pos _ (prime_gt0 q_pr)) rq1 unitr1. + pose u_r : {unit 'F_p} := Sub r Ur; have:= order_dvdG (in_setT u_r). + rewrite card_units_Zp ?pdiv_gt0 // {2}/pdiv primes_prime //=. + rewrite (@totient_pfactor p 1) // muln1; apply: dvdn_trans. + have: (u_r ^+ q == 1)%g. + by rewrite -val_eqE unit_Zp_expg -Zp_nat natrX natr_Zp rq1. + case/primeP: q_pr => _ q_min; rewrite -order_dvdn; move/q_min. + by rewrite order_eq1 -val_eqE (negPf ne_r_1) /=; move/eqnP->. +have /imsetP[a Qa [def_a1 def_a2]]: (r, r) \in f @: Q. + by rewrite -rs2_Q inE andbb. +have rQa: rQ a = r%:M. + rewrite -[rQ a]mul1mx def1 mulmxDl -!mulmxA !rQ_lam //. + by rewrite -def_a1 -def_a2 !linearZ -scalerDr -def1 /= scalemx1. +exists a. + rewrite !inE Qa andbT; apply: contra ne_r_1 => a1. + by rewrite (eqP a1) repr_mx1 in rQa; rewrite (fmorph_inj _ rQa). +exists r; rewrite -!val_Fp_nat // natrX natr_Zp rq1. +split=> // x Px; apply: (@abelem_rV_inj _ _ _ abelP ntP); rewrite ?groupX //. + by rewrite memJ_norm ?(subsetP nPQ). +by rewrite abelem_rV_X // -mul_mx_scalar natr_Zp -rQa -abelem_rV_J. +Qed. + +End BGsection2. diff --git a/mathcomp/odd_order/BGsection3.v b/mathcomp/odd_order/BGsection3.v new file mode 100644 index 0000000..25879a6 --- /dev/null +++ b/mathcomp/odd_order/BGsection3.v @@ -0,0 +1,1831 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div. +Require Import fintype tuple bigop prime binomial finset ssralg fingroup finalg. +Require Import morphism perm automorphism quotient action commutator gproduct. +Require Import zmodp cyclic gfunctor center pgroup gseries nilpotent sylow. +Require Import finmodule abelian frobenius maximal extremal hall. +Require Import matrix mxalgebra mxrepresentation mxabelem wielandt_fixpoint. +Require Import BGsection1 BGsection2. + +(******************************************************************************) +(* This file covers the material in B & G, Section 3. *) +(* Note that in spite of the use of Gorenstein 2.7.6, the material in all *) +(* of Section 3, and in all likelyhood the whole of B & G, does NOT depend on *) +(* the general proof of existence of Frobenius kernels, because results on *) +(* Frobenius groups are only used when the semidirect product decomposition *) +(* is already known, and (see file frobenius.v) in this case the kernel is *) +(* equal to the normal complement of the Frobenius complement. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope ring_scope. +Import GroupScope GRing.Theory. + +Section BGsection3. + +Implicit Type F : fieldType. +Implicit Type gT : finGroupType. +Implicit Type p : nat. + +(* B & G, Lemma 3.1 is covered by frobenius.Frobenius_semiregularP. *) + +(* This is B & G, Lemma 3.2. *) +Section FrobeniusQuotient. + +Variables (gT : finGroupType) (G K R : {group gT}). +Implicit Type N : {group gT}. + +(* This is a special case of B & G, Lemma 3.2 (b). *) +Lemma Frobenius_proper_quotient N : + [Frobenius G = K ><| R] -> solvable K -> N <| G -> N \proper K -> + [Frobenius G / N = (K / N) ><| (R / N)]. +Proof. +move=> frobG solK nsNG /andP[sNK ltNK]. +have [defG _ ntR _ _] := Frobenius_context frobG. +have [nsKG sRG defKR nKR tiKR] := sdprod_context defG; have [sKG _]:= andP nsKG. +have nsNK := normalS sNK sKG nsNG. +apply/Frobenius_semiregularP=> [|||Nx]. +- rewrite sdprodE ?quotient_norms //. + by rewrite -quotientMl ?defKR ?normal_norm. + by rewrite -quotientGI // tiKR quotient1. +- by rewrite -subG1 quotient_sub1 ?normal_norm. +- rewrite -subG1 quotient_sub1; last by rewrite (subset_trans sRG) ?normal_norm. + apply: contra ntR => sRN. + by rewrite -subG1 -tiKR subsetI (subset_trans sRN) /=. +rewrite !inE andbC => /andP[/morphimP[x nNx Rx ->{Nx}] notNx]. +apply/trivgP; rewrite /= -cent_cycle -quotient_cycle //. +rewrite -coprime_quotient_cent ?cycle_subG //; last first. + by apply: coprimegS (Frobenius_coprime frobG); rewrite cycle_subG. +rewrite cent_cycle (Frobenius_reg_ker frobG) ?quotient1 // !inE Rx andbT. +by apply: contraNneq notNx => ->; rewrite morph1. +Qed. + +(* This is B & G, Lemma 3.2 (a). *) +Lemma Frobenius_normal_proper_ker N : + [Frobenius G = K ><| R] -> solvable K -> N <| G -> ~~ (K \subset N) -> + N \proper K. +Proof. +move=> frobG solK nsNG ltNK; have [sNG nNG] := andP nsNG; pose H := N :&: K. +have [defG _ ntR _ _] := Frobenius_context frobG. +have [nsKG _ /mulG_sub[sKG _] nKR tiKR] := sdprod_context defG. +have nsHG: H <| G := normalI nsNG nsKG; have [_ nHG] := andP nsHG. +have ltHK: H \proper K by rewrite /proper subsetIr subsetI subxx andbT. +suffices /eqP tiNR: N :&: R == 1. + rewrite /proper ltNK andbT -(setIidPl sNG). + rewrite -(cover_partition (Frobenius_partition frobG)) big_distrr /=. + apply/bigcupsP=> _ /setU1P[->| /imsetP[x Kx ->]]; first exact: subsetIr. + rewrite conjD1g setIDA subDset -(normsP (subset_trans sKG nNG) x) //. + by rewrite -conjIg tiNR conjs1g subsetUl. +suffices: (N :&: R) / H \subset [1]. + by rewrite -subG1 quotient_sub1 ?normsGI // -subsetIidr setIACA tiKR setIg1. +have frobGq := Frobenius_proper_quotient frobG solK nsHG ltHK. +have [_ ntKq _ _ _] := Frobenius_context frobGq. +rewrite -(cent_semiregular (Frobenius_reg_compl frobGq) _ ntKq) //. +rewrite subsetI quotientS ?subsetIr // quotient_cents2r //. +by rewrite commg_subI ?setIS // subsetIidl (subset_trans sKG). +Qed. + +(* This is B & G, Lemma 3.2 (b). *) +Lemma Frobenius_quotient N : + [Frobenius G = K ><| R] -> solvable K -> N <| G -> ~~ (K \subset N) -> + [Frobenius G / N = (K / N) ><| (R / N)]. +Proof. +move=> frobG solK nsNG ltKN; apply: Frobenius_proper_quotient => //. +exact: (Frobenius_normal_proper_ker frobG). +Qed. + +End FrobeniusQuotient. + +(* This is B & G, Lemma 3.3. *) +Lemma Frobenius_rfix_compl F gT (G K R : {group gT}) n + (rG : mx_representation F G n) : + [Frobenius G = K ><| R] -> [char F]^'.-group K -> + ~~ (K \subset rker rG) -> rfix_mx rG R != 0. +Proof. +rewrite /pgroup charf'_nat => frobG nzK. +have [defG _ _ ltKG ltRG]:= Frobenius_context frobG. +have{ltKG ltRG} [sKG sRG]: K \subset G /\ R \subset G by rewrite !proper_sub. +apply: contraNneq => fixR0; rewrite rfix_mx_rstabC // -(eqmx_scale _ nzK). +pose gsum H := gring_op rG (gset_mx F G H). +have fixsum (H : {group gT}): H \subset G -> (gsum H <= rfix_mx rG H)%MS. + move/subsetP=> sHG; apply/rfix_mxP=> x Hx; have Gx := sHG x Hx. + rewrite -gring_opG // -gring_opM ?envelop_mx_id //; congr (gring_op _ _). + rewrite {2}/gset_mx (reindex_acts 'R _ Hx) ?astabsR //= mulmx_suml. + by apply:eq_bigr=> y; move/sHG=> Gy; rewrite repr_mxM. +have: gsum G + rG 1 *+ #|K| = gsum K + \sum_(x in K) gsum (R :^ x). + rewrite -gring_opG // -sumr_const -!linear_sum -!linearD; congr gring_op. + rewrite {1}/gset_mx (set_partition_big _ (Frobenius_partition frobG)) /=. + rewrite big_setU1 -?addrA /=; last first. + by apply: contraL (group1 K) => /imsetP[x _ ->]; rewrite conjD1g !inE eqxx. + congr (_ + _); rewrite big_imset /= => [|x y Kx Ky /= eqRxy]; last first. + have [/eqP/sdprodP[_ _ _ tiKR] _ _ _ /eqP snRG] := and5P frobG. + apply/eqP; rewrite eq_mulgV1 -in_set1 -set1gE -tiKR -snRG setIA. + by rewrite (setIidPl sKG) !inE conjsgM eqRxy actK groupM /= ?groupV. + rewrite -big_split; apply: eq_bigr => x Kx /=. + by rewrite addrC conjD1g -big_setD1 ?group1. +have ->: gsum G = 0. + apply/eqP; rewrite -submx0 -fixR0; apply: submx_trans (rfix_mxS rG sRG). + exact: fixsum. +rewrite repr_mx1 -scaler_nat add0r => ->. +rewrite big1 ?addr0 ?fixsum // => x Kx; have Gx := subsetP sKG x Kx. +apply/eqP; rewrite -submx0 (submx_trans (fixsum _ _)) ?conj_subG //. +by rewrite -(mul0mx _ (rG x)) -fixR0 rfix_mx_conjsg. +Qed. + +(* This is Aschbacher (40.6)(3), or G. (3.14)(iii). *) +Lemma regular_pq_group_cyclic gT p q (H R : {group gT}) : + [/\ prime p, prime q & p != q] -> #|R| = (p * q)%N -> + H :!=: 1 -> R \subset 'N(H) -> semiregular H R -> + cyclic R. +Proof. +case=> pr_p pr_q q'p oR ntH nHR regHR. +without loss{q'p} ltpq: p q pr_p pr_q oR / p < q. + by move=> IH; case: ltngtP q'p => // /IH-> //; rewrite mulnC. +have [p_gt0 q_gt0]: 0 < p /\ 0 < q by rewrite !prime_gt0. +have [[P sylP] [Q sylQ]] := (Sylow_exists p R, Sylow_exists q R). +have [sPR sQR] := (pHall_sub sylP, pHall_sub sylQ). +have [oP oQ]: #|P| = p /\ #|Q| = q. + rewrite (card_Hall sylQ) (card_Hall sylP) oR !p_part !lognM ?logn_prime //. + by rewrite !eqxx eq_sym gtn_eqF. +have [ntP ntQ]: P :!=: 1 /\ Q :!=: 1 by rewrite -!cardG_gt1 oP oQ !prime_gt1. +have nQR: R \subset 'N(Q). + rewrite -subsetIidl -indexg_eq1 -(card_Syl_mod R pr_q) (card_Syl sylQ) /=. + rewrite modn_small // -divgS ?subsetIl ?ltn_divLR // mulnC oR ltn_pmul2r //. + by rewrite (leq_trans ltpq) // -oQ subset_leq_card // subsetI sQR normG. +have coQP: coprime #|Q| #|P|. + by rewrite oP oQ prime_coprime ?dvdn_prime2 ?gtn_eqF. +have defR: Q ><| P = R. + rewrite sdprodE ?coprime_TIg ?(subset_trans sPR) //. + by apply/eqP; rewrite eqEcard mul_subG //= oR coprime_cardMg // oP oQ mulnC. +have [cycP cycQ]: cyclic P /\ cyclic Q by rewrite !prime_cyclic ?oP ?oQ. +suffices cQP: P \subset 'C(Q) by rewrite (@cyclic_dprod _ Q P) ?dprodEsd. +without loss /is_abelemP[r pr_r abelH]: H ntH nHR regHR / is_abelem H. + move=> IH; have [r _ rH] := rank_witness H. + have solR: solvable R. + apply/metacyclic_sol/metacyclicP; exists Q. + by rewrite /(Q <| R) sQR -(isog_cyclic (sdprod_isog defR)). + have coHR: coprime #|H| #|R| := regular_norm_coprime nHR regHR. + have [H1 sylH1 nH1R] := sol_coprime_Sylow_exists r solR nHR coHR. + have ntH1: H1 :!=: 1 by rewrite -rank_gt0 (rank_Sylow sylH1) -rH rank_gt0. + have [H2 minH2 sH21] := minnormal_exists ntH1 nH1R. + have [sH1H rH1 _] := and3P sylH1; have sH2H := subset_trans sH21 sH1H. + have [nH2R ntH2 abelH2] := minnormal_solvable minH2 sH21 (pgroup_sol rH1). + by apply: IH abelH2 => //; apply: semiregularS regHR. +have: rfix_mx (abelem_repr abelH ntH nHR) P == 0. + rewrite -mxrank_eq0 rfix_abelem // mxrank_eq0 rowg_mx_eq0 /=. + by rewrite (cent_semiregular regHR) ?morphim1. +apply: contraLR => not_cQP; have{not_cQP} frobR: [Frobenius R = Q ><| P]. + by apply/prime_FrobeniusP; rewrite ?prime_TIg ?oP ?oQ // centsC. +apply: (Frobenius_rfix_compl frobR). + rewrite (eq_p'group _ (charf_eq (char_Fp pr_r))). + rewrite (coprime_p'group _ (abelem_pgroup abelH)) //. + by rewrite coprime_sym (coprimegS sQR) ?regular_norm_coprime. +rewrite rker_abelem subsetI sQR centsC. +by rewrite -subsetIidl (cent_semiregular regHR) ?subG1. +Qed. + +(* This is B & G, Theorem 3.4. *) +Theorem odd_prime_sdprod_rfix0 F gT (G K R : {group gT}) n + (rG : mx_representation F G n) : + K ><| R = G -> solvable G -> odd #|G| -> coprime #|K| #|R| -> prime #|R| -> + [char F]^'.-group G -> rfix_mx rG R = 0 -> + [~: R, K] \subset rker rG. +Proof. +move: {2}_.+1 (ltnSn #|G|) => m; elim: m => // m IHm in gT G K R n rG *. +rewrite ltnS; set p := #|R| => leGm defG solG oddG coKR p_pr F'G regR. +have [nsKG sRG defKR nKR tiKR] := sdprod_context defG. +have [sKG nKG] := andP nsKG; have solK := solvableS sKG solG. +have [-> | ntK] := eqsVneq K 1; first by rewrite commG1 sub1G. +have ker_ltK (H : {group gT}): + H \proper K -> R \subset 'N(H) -> [~: R, H] \subset rker rG. +- move=> ltKH nHR; have sHK := proper_sub ltKH; set G1 := H <*> R. + have sG1G: G1 \subset G by rewrite join_subG (subset_trans sHK). + have coHR := coprimeSg sHK coKR. + have defG1: H ><| R = G1 by rewrite sdprodEY // coprime_TIg. + apply: subset_trans (subsetIr G1 _); rewrite -(rker_subg _ sG1G). + apply: IHm; rewrite ?(solvableS sG1G) ?(oddSg sG1G) ?(pgroupS sG1G) //. + apply: leq_trans leGm; rewrite /= norm_joinEr // -defKR !coprime_cardMg //. + by rewrite ltn_pmul2r ?proper_card. +without loss [q q_pr qK]: / exists2 q, prime q & q.-group K. + move=> IH; set q := pdiv #|K|. + have q_pr: prime q by rewrite pdiv_prime ?cardG_gt1. + have exHall := coprime_Hall_exists _ nKR coKR solK. + have [Q sylQ nQR] := exHall q; have [Q' hallQ' nQ'R] := exHall q^'. + have [sQK qQ _] := and3P sylQ; have [sQ'K q'Q' _] := and3P hallQ'. + without loss{IH} ltQK: / Q \proper K. + by rewrite properEneq; case: eqP IH => [<- -> | _ _ ->] //; exists q. + have ltQ'K: Q' \proper K. + rewrite properEneq; case: eqP (pgroupP q'Q' q q_pr) => //= ->. + by rewrite !inE pdiv_dvd eqxx; apply. + have nkerG := subset_trans _ (rker_norm rG). + rewrite -quotient_cents2 ?nkerG //. + have <-: Q * Q' = K. + apply/eqP; rewrite eqEcard mulG_subG sQK sQ'K. + rewrite coprime_cardMg ?(pnat_coprime qQ) //=. + by rewrite (card_Hall sylQ) (card_Hall hallQ') partnC. + rewrite quotientMl ?nkerG ?(subset_trans sQK) // centM subsetI. + by rewrite !quotient_cents2r ?ker_ltK. +without loss{m IHm leGm} [ffulG cycZ]: / rker rG = 1 /\ cyclic 'Z(G). + move=> IH; wlog [I M /= simM sumM _]: / mxsemisimple rG 1%:M. + exact: (mx_reducible_semisimple (mxmodule1 _) (mx_Maschke _ F'G)). + pose not_cRK_M i := ~~ ([~: R, K] \subset rstab rG (M i)). + case: (pickP not_cRK_M) => [i | cRK_M]; last first. + rewrite rfix_mx_rstabC ?comm_subG // -sumM. + apply/sumsmx_subP=> i _; move/negbFE: (cRK_M i). + by rewrite rfix_mx_rstabC ?comm_subG. + have [modM ntM _] := simM i; pose rM := kquo_repr (submod_repr modM). + do [rewrite {+}/not_cRK_M -(rker_submod modM) /=; set N := rker _] in rM *. + have [N1 _ | ntN] := eqVneq N 1. + apply: IH; split. + by apply/trivgP; rewrite -N1 /N rker_submod rstabS ?submx1. + have: mx_irreducible (submod_repr modM) by exact/submod_mx_irr. + by apply: mx_faithful_irr_center_cyclic; exact/trivgP. + have tiRN: R :&: N = 1. + by apply: prime_TIg; rewrite //= rker_submod rfix_mx_rstabC // regR submx0. + have nsNG: N <| G := rker_normal _; have [sNG nNG] := andP nsNG. + have nNR := subset_trans sRG nNG. + have sNK: N \subset K. + have [pi hallK]: exists pi, pi.-Hall(G) K. + by apply: HallP; rewrite -(coprime_sdprod_Hall_l defG). + rewrite (sub_normal_Hall hallK) //=. + apply: pnat_dvd (pHall_pgroup hallK). + rewrite -(dvdn_pmul2r (prime_gt0 p_pr)) -!TI_cardMg // 1?setIC // defKR. + by rewrite -norm_joinEr // cardSg // join_subG sNG. + have defGq: (K / N) ><| (R / N) = G / N. + rewrite sdprodE ?quotient_norms -?quotientMr ?defKR //. + by rewrite -quotientGI // tiKR quotient1. + case/negP; rewrite -quotient_cents2 ?(subset_trans _ nNG) //= -/N. + rewrite (sameP commG1P trivgP). + apply: subset_trans (kquo_mx_faithful (submod_repr modM)). + rewrite IHm ?quotient_sol ?coprime_morph ?morphim_odd ?quotient_pgroup //. + - apply: leq_trans leGm; exact: ltn_quotient. + - by rewrite card_quotient // -indexgI tiRN indexg1. + apply/eqP; rewrite -submx0 rfix_quo // rfix_submod //. + by rewrite regR capmx0 linear0 sub0mx. +without loss perfectK: / [~: K, R] = K. + move=> IH; have: [~: K, R] \subset K by rewrite commg_subl. + rewrite subEproper; case/predU1P=> //; move/ker_ltK. + by rewrite commGC commg_normr coprime_commGid // commGC => ->. +have primeR: {in R^#, forall x, 'C_K[x] = 'C_K(R)}. + move=> x; case/setD1P=> nt_x Rx; rewrite -cent_cycle ((<[x]> =P R) _) //. + rewrite eqEsubset cycle_subG Rx; apply: contraR nt_x; move/prime_TIg. + by rewrite -cycle_eq1 (setIidPr _) ?cycle_subG // => ->. +case cKK: (abelian K). + rewrite commGC perfectK; move/eqP: regR; apply: contraLR. + apply: Frobenius_rfix_compl => //; last exact: pgroupS F'G. + rewrite -{2 4}perfectK coprime_abel_cent_TI // in primeR. + by apply/Frobenius_semiregularP; rewrite // -cardG_gt1 prime_gt1. +have [spK defZK]: special K /\ 'C_K(R) = 'Z(K). + apply: (abelian_charsimple_special qK) => //. + apply/bigcupsP=> H; case/andP=> chHK cHH. + have:= char_sub chHK; rewrite subEproper. + case/predU1P=> [eqHK | ltHK]; first by rewrite eqHK cKK in cHH. + have nHR: R \subset 'N(H) := char_norm_trans chHK nKR. + by rewrite (sameP commG1P trivgP) /= commGC -ffulG ker_ltK. +have{spK} esK: extraspecial K. + have abelZK := center_special_abelem qK spK; have [qZK _] := andP abelZK. + have /(pgroup_pdiv qZK)[_ _ []]: 'Z(K) != 1. + by case: spK => _ <-; rewrite (sameP eqP commG1P) -abelianE cKK. + case=> [|e] oK; first by split; rewrite ?oK. + suffices: cyclic 'Z(K) by rewrite (abelem_cyclic abelZK) oK pfactorK. + rewrite (cyclicS _ cycZ) // subsetI subIset ?sKG //=. + by rewrite -defKR centM subsetI -{2}defZK !subsetIr. +have [e e_gt0 oKqe] := card_extraspecial qK esK. +have cycR: cyclic R := prime_cyclic p_pr. +have co_q_p: coprime q p by rewrite oKqe coprime_pexpl in coKR. +move/eqP: regR; case/idPn. +rewrite defZK in primeR. +case: (repr_extraspecial_prime_sdprod_cycle _ _ defG _ oKqe) => // _. +apply=> //; last exact/trivgP. +apply: contraL (oddSg sRG oddG); move/eqP->; have:= oddSg sKG oddG. +by rewrite oKqe addn1 /= !odd_exp /= orbC => ->. +Qed. + +(* Internal action version of B & G, Theorem 3.4. *) +Theorem odd_prime_sdprod_abelem_cent1 k gT (G K R V : {group gT}) : + solvable G -> odd #|G| -> K ><| R = G -> coprime #|K| #|R| -> prime #|R| -> + k.-abelem V -> G \subset 'N(V) -> k^'.-group G -> 'C_V(R) = 1 -> + [~: R, K] \subset 'C_K(V). +Proof. +move=> solG oddG defG coKR prR abelV nVG k'G regR. +have [_ sRG _ nKR _] := sdprod_context defG; rewrite subsetI commg_subr nKR. +case: (eqsVneq V 1) => [-> | ntV]; first exact: cents1. +pose rV := abelem_repr abelV ntV nVG. +apply: subset_trans (_ : rker rV \subset _); last first. + by rewrite rker_abelem subsetIr. +apply: odd_prime_sdprod_rfix0 => //. + have k_pr: prime k by case/pgroup_pdiv: (abelem_pgroup abelV). + by rewrite (eq_pgroup G (eq_negn (charf_eq (char_Fp k_pr)))). +by apply/eqP; rewrite -submx0 rfix_abelem //= regR morphim1 rowg_mx1. +Qed. + +(* This is B & G, Theorem 3.5. *) +Theorem Frobenius_prime_rfix1 F gT (G K R : {group gT}) n + (rG : mx_representation F G n) : + K ><| R = G -> solvable G -> prime #|R| -> 'C_K(R) = 1 -> + [char F]^'.-group G -> \rank (rfix_mx rG R) = 1%N -> + K^`(1) \subset rker rG. +Proof. +move=> defG solG p_pr regR F'G fixRlin. +wlog closF: F rG F'G fixRlin / group_closure_field F gT. + move=> IH; apply: (@group_closure_field_exists gT F) => [[Fc f closFc]]. + rewrite -(rker_map f) IH //; last by rewrite -map_rfix_mx mxrank_map. + by rewrite (eq_p'group _ (fmorph_char f)). +move: {2}_.+1 (ltnSn #|K|) => m. +elim: m => // m IHm in gT G K R rG solG p_pr regR F'G closF fixRlin defG *. +rewrite ltnS => leKm. +have [nsKG sRG defKR nKR tiKR] := sdprod_context defG. +have [sKG nKG] := andP nsKG; have solK := solvableS sKG solG. +have cycR := prime_cyclic p_pr. +case: (eqsVneq K 1) => [-> | ntK]; first by rewrite derg1 commG1 sub1G. +have defR x: x \in R^# -> <[x]> = R. + case/setD1P; rewrite -cycle_subG -cycle_eq1 => ntX sXR. + apply/eqP; rewrite eqEsubset sXR; apply: contraR ntX => /(prime_TIg p_pr). + by rewrite /= (setIidPr sXR) => ->. +have ntR: R :!=: 1 by rewrite -cardG_gt1 prime_gt1. +have frobG: [Frobenius G = K ><| R]. + by apply/Frobenius_semiregularP=> // x Rx; rewrite -cent_cycle defR. +case: (eqVneq (rker rG) 1) => [ffulG | ntC]; last first. + set C := rker rG in ntC *; have nsCG: C <| G := rker_normal rG. + have [sCG nCG] := andP nsCG. + have nCK := subset_trans sKG nCG; have nCR := subset_trans sRG nCG. + case sKC: (K \subset C); first exact: subset_trans (der_sub _ _) _. + have sCK: C \subset K. + by rewrite proper_sub // (Frobenius_normal_proper_ker frobG) ?sKC. + have frobGq: [Frobenius G / C = (K / C) ><| (R / C)]. + by apply: Frobenius_quotient; rewrite ?sKC. + have [defGq _ ntRq _ _] := Frobenius_context frobGq. + rewrite -quotient_sub1 ?comm_subG ?quotient_der //= -/C. + apply: subset_trans (kquo_mx_faithful rG). + apply: IHm defGq _; rewrite 1?(quotient_sol, quotient_pgroup, rfix_quo) //. + - rewrite card_quotient // -indexgI /= -/C setIC. + by rewrite -(setIidPl sCK) -setIA tiKR (setIidPr (sub1G _)) indexg1. + - have: cyclic (R / C) by [rewrite quotient_cyclic]; case/cyclicP=> Cx defRq. + rewrite /= defRq cent_cycle (Frobenius_reg_ker frobGq) //= !inE defRq. + by rewrite cycle_id -cycle_eq1 -defRq ntRq. + - move=> Hq; rewrite -(group_inj (cosetpreK Hq)). + by apply: quotient_splitting_field; rewrite ?subsetIl. + by apply: leq_trans leKm; exact: ltn_quotient. +have ltK_abelian (N : {group gT}): R \subset 'N(N) -> N \proper K -> abelian N. + move=> nNR ltNK; have [sNK _] := andP ltNK; apply/commG1P/trivgP. + rewrite -(setIidPr (sub1G (N <*> R))) /= -ffulG; set G1 := N <*> R. + have sG1: G1 \subset G by rewrite join_subG (subset_trans sNK). + have defG1: N ><| R = G1. + by rewrite sdprodEY //; apply/trivgP; rewrite -tiKR setSI. + rewrite -(rker_subg _ sG1). + apply: IHm defG1 _; rewrite ?(solvableS sG1) ?(pgroupS sG1) //. + by apply/trivgP; rewrite -regR setSI. + by apply: leq_trans leKm; exact: proper_card. +have cK'K': abelian K^`(1). + apply: ltK_abelian; first exact: char_norm_trans (der_char _ _) nKR. + exact: (sol_der1_proper solK). +pose fixG := rfix_mx rG; pose NRmod N (U : 'M_n) := N <*> R \subset rstabs rG U. +have dx_modK_rfix (N : {group gT}) U V: + N \subset K -> R \subset 'N(N) -> NRmod N U -> NRmod N V -> + mxdirect (U + V) -> (U <= fixG N)%MS || (V <= fixG N)%MS. +- move=> sNK nNR nUNR nVNR dxUV. + have [-> | ntN] := eqsVneq N 1; first by rewrite -rfix_mx_rstabC sub1G. + have sNRG: N <*> R \subset G by rewrite join_subG (subset_trans sNK). + pose rNR := subg_repr rG sNRG. + have nfixU W: NRmod N W -> ~~ (W <= fixG N)%MS -> (fixG R <= W)%MS. + move=> nWN not_cWN; rewrite (sameP capmx_idPr eqmxP). + rewrite -(geq_leqif (mxrank_leqif_eq (capmxSr _ _))) fixRlin lt0n. + rewrite mxrank_eq0 -(in_submodK (capmxSl _ _)) val_submod_eq0. + have modW: mxmodule rNR W by rewrite /mxmodule rstabs_subg subsetI subxx. + rewrite -(eqmx_eq0 (rfix_submod modW _)) ?joing_subr //. + apply: Frobenius_rfix_compl (pgroupS (subset_trans sNK sKG) F'G) _. + apply/Frobenius_semiregularP=> // [|x Rx]. + by rewrite sdprodEY //; apply/trivgP; rewrite -tiKR setSI. + by apply/trivgP; rewrite -regR /= -cent_cycle defR ?setSI. + by rewrite rker_submod rfix_mx_rstabC ?joing_subl. + have: fixG R != 0 by rewrite -mxrank_eq0 fixRlin. + apply: contraR; case/norP=> not_fixU not_fixW. + by rewrite -submx0 -(mxdirect_addsP dxUV) sub_capmx !nfixU. +have redG := mx_Maschke rG F'G. +wlog [U simU nfixU]: / exists2 U, mxsimple rG U & ~~ (U <= fixG K)%MS. + move=> IH; wlog [I U /= simU sumU _]: / mxsemisimple rG 1%:M. + exact: (mx_reducible_semisimple (mxmodule1 _) redG). + case: (pickP (fun i => ~~ (U i <= fixG K))%MS) => [i nfixU | fixK]. + by apply: IH; exists (U i). + apply: (subset_trans (der_sub _ _)); rewrite rfix_mx_rstabC // -sumU. + by apply/sumsmx_subP=> i _; apply/idPn; rewrite fixK. +have [modU ntU minU] := simU; pose rU := submod_repr modU. +have irrU: mx_irreducible rU by exact/submod_mx_irr. +have [W modW sumUW dxUW] := redG U modU (submx1 U). +have cWK: (W <= fixG K)%MS. + have:= dx_modK_rfix _ _ _ (subxx _) nKR _ _ dxUW. + by rewrite /NRmod /= norm_joinEr // defKR (negPf nfixU); exact. +have nsK'G: K^`(1) <| G by exact: char_normal_trans (der_char _ _) nsKG. +have [sK'G nK'G] := andP nsK'G. +suffices nregK'U: (rfix_mx rU K^`(1))%MS != 0. + rewrite rfix_mx_rstabC ?normal_sub // -sumUW addsmx_sub andbC. + rewrite (submx_trans cWK) ?rfix_mxS ?der_sub //= (sameP capmx_idPl eqmxP). + rewrite minU ?capmxSl ?capmx_module ?normal_rfix_mx_module //. + apply: contra nregK'U => cUK'; rewrite (eqmx_eq0 (rfix_submod _ _)) //. + by rewrite (eqP cUK') linear0. +pose rK := subg_repr rU (normal_sub nsKG); set p := #|R| in p_pr. +wlog sK: / socleType rK by exact: socle_exists. +have [i _ def_sK]: exists2 i, i \in setT & [set: sK] = orbit 'Cl G i. + by apply/imsetP; exact: Clifford_atrans. +have card_sK: #|[set: sK]| = #|G : 'C[i | 'Cl]|. + by rewrite def_sK card_orbit_in ?indexgI. +have ciK: K \subset 'C[i | 'Cl]. + apply: subset_trans (astabS _ (subsetT _)). + by apply: subset_trans (Clifford_astab _); exact: joing_subl. +pose M := socle_base i; have simM: mxsimple rK M := socle_simple i. +have [sKp | sK1 {ciK card_sK}]: #|[set: sK]| = p \/ #|[set: sK]| = 1%N. +- apply/pred2P; rewrite orbC card_sK; case/primeP: p_pr => _; apply. + by rewrite (_ : p = #|G : K|) ?indexgS // -divgS // -(sdprod_card defG) mulKn. +- have{def_sK} def_sK: [set: sK] = orbit 'Cl R i. + apply/eqP; rewrite eq_sym -subTset def_sK. + apply/subsetP=> i_yz; case/imsetP=> yz; rewrite -{1}defKR. + case/imset2P=> y z; move/(subsetP ciK); rewrite !inE sub1set inE. + case/andP=> Gy; move/eqP=> ciy Rz -> ->{yz i_yz}. + by rewrite actMin ?(subsetP sRG z Rz) // ciy mem_orbit. + have inj_i: {in R &, injective ('Cl%act i)}. + apply/dinjectiveP; apply/card_uniqP; rewrite size_map -cardE -/p. + by rewrite -sKp def_sK /orbit Imset.imsetE cardsE. + pose sM := (\sum_(y in R) M *m rU y)%MS. + have dxM: mxdirect sM. + apply/mxdirect_sumsP=> y Ry; have Gy := subsetP sRG y Ry. + pose j := 'Cl%act i y. + apply/eqP; rewrite -submx0 -{2}(mxdirect_sumsP (Socle_direct sK) j) //. + rewrite capmxS ?val_Clifford_act // ?submxMr ?component_mx_id //. + apply/sumsmx_subP => z; case/andP=> Rz ne_z_y; have Gz := subsetP sRG z Rz. + rewrite (sumsmx_sup ('Cl%act i z)) ?(inj_in_eq inj_i) //. + by rewrite val_Clifford_act // ?submxMr // ?component_mx_id. + pose inCR := \sum_(x in R) rU x. + have im_inCR: (inCR <= rfix_mx rU R)%MS. + apply/rfix_mxP=> x Rx; have Gx := subsetP sRG x Rx. + rewrite {2}[inCR](reindex_astabs 'R x) ?astabsR //= mulmx_suml. + by apply: eq_bigr => y; move/(subsetP sRG)=> Gy; rewrite repr_mxM. + pose inM := proj_mx M (\sum_(x in R | x != 1) M *m rU x)%MS. + have dxM1 := mxdirect_sumsP dxM _ (group1 R). + rewrite repr_mx1 mulmx1 in dxM1. + have inCR_K: M *m inCR *m inM = M. + rewrite mulmx_sumr (bigD1 1) //= repr_mx1 mulmx1 mulmxDl proj_mx_id //. + by rewrite proj_mx_0 ?addr0 // summx_sub_sums. + have [modM ntM _] := simM. + have linM: \rank M = 1%N. + apply/eqP; rewrite eqn_leq lt0n mxrank_eq0 ntM andbT. + rewrite -inCR_K; apply: leq_trans (mxrankM_maxl _ _) _. + apply: leq_trans (mxrankS (mulmx_sub _ im_inCR)) _. + rewrite rfix_submod //; apply: leq_trans (mxrankM_maxl _ _) _. + by rewrite -fixRlin mxrankS ?capmxSr. + apply: contra (ntM); move/eqP; rewrite -submx0 => <-. + by rewrite -(rfix_mx_rstabC rK) ?der_sub // -(rker_submod modM) rker_linear. +have{sK i M simM sK1 def_sK} irrK: mx_irreducible rK. + have cycGq: cyclic (G / K) by rewrite -defKR quotientMidl quotient_cyclic. + apply: (mx_irr_prime_index closF irrU cycGq simM) => x Gx /=. + apply: (component_mx_iso simM); first exact: Clifford_simple. + have jP: component_mx rK (M *m rU x) \in socle_enum sK. + by apply: component_socle; exact: Clifford_simple. + pose j := PackSocle jP; apply: submx_trans (_ : j <= _)%MS. + by rewrite PackSocleK component_mx_id //; exact: Clifford_simple. + have def_i: [set i] == [set: sK] by rewrite eqEcard subsetT cards1 sK1. + by rewrite ((j =P i) _) // -in_set1 (eqP def_i) inE. +pose G' := K^`(1) <*> R. +have sG'G: G' \subset G by rewrite join_subG sK'G. +pose rG' := subg_repr rU sG'G. +wlog irrG': / mx_irreducible rG'. + move=> IH; wlog [M simM sM1]: / exists2 M, mxsimple rG' M & (M <= 1%:M)%MS. + by apply: mxsimple_exists; rewrite ?mxmodule1; case: irrK. + have [modM ntM _] := simM. + have [M' modM' sumM dxM] := mx_Maschke rG' (pgroupS sG'G F'G) modM sM1. + wlog{IH} ntM': / M' != 0. + case: eqP sumM => [-> M1 _ | _ _ -> //]; apply: IH. + by apply: mx_iso_simple simM; apply: eqmx_iso; rewrite addsmx0_id in M1. + suffices: (K^`(1) \subset rstab rG' M) || (K^`(1) \subset rstab rG' M'). + rewrite !rfix_mx_rstabC ?joing_subl //; rewrite -!submx0 in ntM ntM' *. + by case/orP; move/submx_trans=> sM; apply: (contra (sM _ _)). + rewrite !rstab_subg !rstab_submod !subsetI joing_subl !rfix_mx_rstabC //. + rewrite /mxmodule !rstabs_subg !rstabs_submod !subsetI !subxx in modM modM'. + do 2!rewrite orbC -genmxE. + rewrite dx_modK_rfix // /NRmod ?(eqmx_rstabs _ (genmxE _)) ?der_sub //. + exact: subset_trans sRG nK'G. + apply/mxdirect_addsP; apply/eqP; rewrite -genmx_cap (eqmx_eq0 (genmxE _)). + rewrite -(in_submodK (submx_trans (capmxSl _ _) (val_submodP _))). + rewrite val_submod_eq0 in_submodE -submx0 (submx_trans (capmxMr _ _ _)) //. + by rewrite -!in_submodE !val_submodK (mxdirect_addsP dxM). +have nsK'K: K^`(1) <| K by apply: der_normal. +pose rK'K := subg_repr rK (normal_sub nsK'K). +have irrK'K: mx_absolutely_irreducible rK'K. + wlog sK'K: / socleType rK'K by apply: socle_exists. + have sK'_dv_K: #|[set: sK'K]| %| #|K|. + exact: atrans_dvd_in (Clifford_atrans _ _). + have nsK'G': K^`(1) <| G' := normalS (joing_subl _ _) sG'G nsK'G. + pose rK'G' := subg_repr rG' (normal_sub nsK'G'). + wlog sK'G': / socleType rK'G' by exact: socle_exists. + have coKp: coprime #|K| p := Frobenius_coprime frobG. + have nK'R := subset_trans sRG nK'G. + have sK'_dv_p: #|[set: sK'G']| %| p. + suffices: #|G' : 'C([set: sK'G'] | 'Cl)| %| #|G' : K^`(1)|. + rewrite -(divgS (joing_subl _ _)) /= {2}norm_joinEr //. + rewrite coprime_cardMg ?(coprimeSg (normal_sub nsK'K)) //. + rewrite mulKn ?cardG_gt0 // -indexgI; apply: dvdn_trans. + exact: atrans_dvd_index_in (Clifford_atrans _ _). + rewrite indexgS //; apply: subset_trans (Clifford_astab sK'G'). + exact: joing_subl. + have eq_sK': #|[set: sK'K]| = #|[set: sK'G']|. + rewrite !cardsT !cardE -!(size_map (fun i => socle_val i)). + apply: perm_eq_size. + rewrite uniq_perm_eq 1?(map_inj_uniq val_inj) 1?enum_uniq // => V. + apply/mapP/mapP=> [] [i _ ->{V}]. + exists (PackSocle (component_socle sK'G' (socle_simple i))). + by rewrite mem_enum. + by rewrite PackSocleK. + exists (PackSocle (component_socle sK'K (socle_simple i))). + by rewrite mem_enum. + by rewrite PackSocleK. + have [i def_i]: exists i, [set: sK'G'] = [set i]. + apply/cards1P; rewrite -dvdn1 -{7}(eqnP coKp) dvdn_gcd. + by rewrite -{1}eq_sK' sK'_dv_K sK'_dv_p. + pose M := socle_base i; have simM : mxsimple rK'G' M := socle_simple i. + have cycGq: cyclic (G' / K^`(1)). + by rewrite /G' joingC quotientYidr ?quotient_cyclic. + apply closF; apply: (mx_irr_prime_index closF irrG' cycGq simM) => x K'x /=. + apply: (component_mx_iso simM); first exact: Clifford_simple. + have jP: component_mx rK'G' (M *m rG' x) \in socle_enum sK'G'. + by apply: component_socle; exact: Clifford_simple. + pose j := PackSocle jP; apply: submx_trans (_ : j <= _)%MS. + by rewrite PackSocleK component_mx_id //; exact: Clifford_simple. + by rewrite ((j =P i) _) // -in_set1 -def_i inE. +have linU: \rank U = 1%N by apply/eqP; rewrite abelian_abs_irr in irrK'K. +case: irrU => _ nz1 _; apply: contra nz1; move/eqP=> fix0. +by rewrite -submx0 -fix0 -(rfix_mx_rstabC rK) ?der_sub // rker_linear. +Qed. + +(* Internal action version of B & G, Theorem 3.5. *) +Theorem Frobenius_prime_cent_prime k gT (G K R V : {group gT}) : + solvable G -> K ><| R = G -> prime #|R| -> 'C_K(R) = 1 -> + k.-abelem V -> G \subset 'N(V) -> k^'.-group G -> #|'C_V(R)| = k -> + K^`(1) \subset 'C_K(V). +Proof. +move=> solG defG prR regRK abelV nVG k'G primeRV. +have [_ sRG _ nKR _] := sdprod_context defG; rewrite subsetI der_sub. +have [-> | ntV] := eqsVneq V 1; first exact: cents1. +pose rV := abelem_repr abelV ntV nVG. +apply: subset_trans (_ : rker rV \subset _); last first. + by rewrite rker_abelem subsetIr. +have k_pr: prime k by case/pgroup_pdiv: (abelem_pgroup abelV). +apply: (Frobenius_prime_rfix1 defG) => //. + by rewrite (eq_pgroup G (eq_negn (charf_eq (char_Fp k_pr)))). +apply/eqP; rewrite rfix_abelem // -(eqn_exp2l _ _ (prime_gt1 k_pr)). +rewrite -{1}(card_Fp k_pr) -card_rowg rowg_mxK. +by rewrite card_injm ?abelem_rV_injm ?subsetIl ?primeRV. +Qed. + +Section Theorem_3_6. +(* Limit the scope of the FiniteModule notations *) +Import FiniteModule. + +(* This is B & G, Theorem 3.6. *) +Theorem odd_sdprod_Zgroup_cent_prime_plength1 p gT (G H R R0 : {group gT}) : + solvable G -> odd #|G| -> H ><| R = G -> coprime #|H| #|R| -> + R0 \subset R -> prime #|R0| -> Zgroup 'C_H(R0) -> + p.-length_1 [~: H, R]. +Proof. +move: {2}_.+1 (ltnSn #|G|) => n; elim: n => // n IHn in gT G H R R0 *. +rewrite ltnS; move oR0: #|R0| => r leGn solG oddG defG coHR sR0R r_pr ZgrCHR0. +have rR0: r.-group R0 by rewrite /pgroup oR0 pnat_id. +have [nsHG sRG mulHR nHR tiHR]:= sdprod_context defG. +have [sHG nHG] := andP nsHG; have solH := solvableS sHG solG. +have IHsub (H1 R1 : {group gT}): + H1 \subset H -> H1 * R1 \subset 'N(H1) -> R0 \subset R1 -> R1 \subset R -> + (#|H1| < #|H|) || (#|R1| < #|R|) -> p.-length_1 [~: H1, R1]. +- move=> sH1 nH1 sR01 sR1 ltG1; set G1 := H1 <*> R1. + have coHR1: coprime #|H1| #|R1| by rewrite (coprimeSg sH1) // (coprimegS sR1). + have defG1: H1 ><| R1 = G1. + by rewrite sdprodEY ?coprime_TIg ?(subset_trans (mulG_subr H1 R1)). + have sG1: G1 \subset G by rewrite join_subG -mulG_subG -mulHR mulgSS. + have{ltG1} ltG1n: #|G1| < n. + rewrite (leq_trans _ leGn) // -(sdprod_card defG1) -(sdprod_card defG). + have leqifS := leqif_geq (subset_leq_card _). + rewrite ltn_neqAle !(leqif_mul (leqifS _ _ _ sH1) (leqifS _ _ _ sR1)). + by rewrite muln_eq0 !negb_or negb_and -!ltnNge ltG1 -!lt0n !cardG_gt0. + apply: IHn defG1 _ sR01 _ _; rewrite ?oR0 ?(solvableS sG1) ?(oddSg sG1) //. + exact: ZgroupS (setSI _ sH1) ZgrCHR0. +without loss defHR: / [~: H, R] = H; last rewrite defHR. + have sHR_H: [~: H, R] \subset H by rewrite commg_subl. + have:= sHR_H; rewrite subEproper; case/predU1P=> [-> -> //|ltHR_H _]. + rewrite -coprime_commGid // IHsub 1?proper_card //. + by apply: subset_trans (commg_norm H R); rewrite norm_joinEr ?mulSg. +have{n leGn IHn tiHR} IHquo (X : {group gT}): + X :!=: 1 -> X \subset H -> G \subset 'N(X) -> p.-length_1 (H / X). +- move=> ntX sXH nXG; have nXH := subset_trans sHG nXG. + have nXR := subset_trans sRG nXG; have nXR0 := subset_trans sR0R nXR. + rewrite -defHR quotientE morphimR // -!quotientE. + have ltGbn: #|G / X| < n. + exact: leq_trans (ltn_quotient ntX (subset_trans sXH sHG)) _. + have defGb: (H / X) ><| (R / X) = G / X by exact: quotient_coprime_sdprod. + have pr_R0b: prime #|R0 / X|. + have tiXR0: X :&: R0 = 1 by apply/trivgP; rewrite -tiHR setISS. + by rewrite card_quotient // -indexgI setIC tiXR0 indexg1 oR0. + have solGb: solvable (G / X) by exact: quotient_sol. + have coHRb: coprime #|H / X| #|R / X| by exact: coprime_morph. + apply: IHn defGb coHRb _ pr_R0b _; rewrite ?quotientS ?quotient_odd //. + by rewrite -coprime_quotient_cent ?(coprimegS sR0R) // morphim_Zgroup. +without loss Op'H: / 'O_p^'(H) = 1. + have [_ -> // | ntO _] := eqVneq 'O_p^'(H) 1. + suffices: p.-length_1 (H / 'O_p^'(H)). + by rewrite p'quo_plength1 ?pcore_normal ?pcore_pgroup. + apply: IHquo => //; first by rewrite normal_sub ?pcore_normal. + by rewrite normal_norm // (char_normal_trans (pcore_char _ _)). +move defV: 'F(H)%G => V. +have charV: V \char H by rewrite -defV Fitting_char. +have [sVH nVH]: V \subset H /\ H \subset 'N(V) := andP (char_normal charV). +have nsVG: V <| G := char_normal_trans charV nsHG. +have [_ nVG] := andP nsVG; have nVR: R \subset 'N(V) := subset_trans sRG nVG. +without loss ntV: / V :!=: 1. + by rewrite -defV trivg_Fitting //; case: eqP => [|_] ->; rewrite ?plength1_1. +have scVHV: 'C_H(V) \subset V by rewrite -defV cent_sub_Fitting. +have{defV Op'H} defV: 'O_p(H) = V by rewrite -(Fitting_eq_pcore Op'H) -defV. +have pV: p.-group V by rewrite -defV pcore_pgroup. +have [p_pr p_dv_V _] := pgroup_pdiv pV ntV. +have p'r: r != p. + rewrite eq_sym -dvdn_prime2 // -prime_coprime // (coprime_dvdl p_dv_V) //. + by rewrite -oR0 (coprimegS sR0R) // (coprimeSg sVH). +without loss{charV} abelV: / p.-abelem V; last have [_ cVV eV] := and3P abelV. + move/implyP; rewrite implybE -trivg_Phi //; case/orP=> // ntPhi. + have charPhi: 'Phi(V) \char H := char_trans (Phi_char _) charV. + have nsPhiH := char_normal charPhi; have [sPhiH nPhiH] := andP nsPhiH. + have{charPhi} nPhiG: G \subset 'N('Phi(V)):= char_norm_trans charPhi nHG. + rewrite -(pquo_plength1 nsPhiH) 1?IHquo ?(pgroupS (Phi_sub _)) //. + have [/= W defW sPhiW nsWH] := inv_quotientN nsPhiH (pcore_normal p^' _). + have p'Wb: p^'.-group (W / 'Phi(V)) by rewrite -defW pcore_pgroup. + have{p'Wb} tiWb := coprime_TIg (pnat_coprime (quotient_pgroup _ _) p'Wb). + suffices pW: p.-group W by rewrite -(tiWb W pW) setIid. + apply/pgroupP=> q q_pr; case/Cauchy=> // x Wx ox; apply: wlog_neg => q'p. + suffices Vx: x \in V by rewrite (pgroupP pV) // -ox order_dvdG. + have [sWH nWH] := andP nsWH; rewrite (subsetP scVHV) // inE (subsetP sWH) //=. + have coVx: coprime #|V| #[x] by rewrite ox (pnat_coprime pV) // pnatE. + rewrite -cycle_subG (coprime_cent_Phi pV coVx) //. + have: V :&: W \subset 'Phi(V); last apply: subset_trans. + rewrite -quotient_sub1; last by rewrite subIset ?(subset_trans sWH) ?orbT. + by rewrite quotientIG ?tiWb. + rewrite commg_subI //; first by rewrite subsetI subxx (subset_trans sVH). + by rewrite cycle_subG inE Wx (subsetP nVH) // (subsetP sWH). +have{scVHV} scVH: 'C_H(V) = V by apply/eqP; rewrite eqEsubset scVHV subsetI sVH. +without loss{IHquo} indecomposableV: / forall U W, + U \x W = V -> G \subset 'N(U) :&: 'N(W) -> U = 1 \/ U = V. +- pose decV UW := let: (U, W) := UW in + [&& U \x W == V, G \subset 'N(U) :&: 'N(W), U != 1 & W != 1]. + case: (pickP decV) => [[A B /=] | indecV]; last first. + apply=> U W defUW nUW_G; have:= indecV (U, W); rewrite /= -defUW nUW_G eqxx. + by rewrite -negb_or; case/pred2P=> ->; [left | right; rewrite dprodg1]. + rewrite subsetI -!andbA => /and5P[/eqP/dprodP[[U W -> ->{A B}]]]. + move=> defUW _ tiUW nUG nWG ntU ntW _. + have [sUH sWH]: U \subset H /\ W \subset H. + by apply/andP; rewrite -mulG_subG defUW. + have [nsUH nsWH]: U <| H /\ W <| H. + by rewrite /normal !(subset_trans sHG) ?andbT. + by rewrite -(quo2_plength1 _ nsUH nsWH) ?tiUW ?IHquo. +have nsFb: 'F(H / V) <| G / V. + exact: char_normal_trans (Fitting_char _) (morphim_normal _ _). +have{nsVG nsFb} [/= U defU sVU nsUG] := inv_quotientN nsVG nsFb. +have{nsUG} [sUG nUG] := andP nsUG. +have [solU nVU] := (solvableS sUG solG, subset_trans sUG nVG). +have sUH: U \subset H by rewrite -(quotientSGK nVU sVH) -defU Fitting_sub. +have [K hallK nKR]: exists2 K : {group gT}, p^'.-Hall(U) K & R \subset 'N(K). + by apply: coprime_Hall_exists; rewrite ?(coprimeSg sUH) ?(subset_trans sRG). +have [sKU p'K _] := and3P hallK; have{sUG} sKG := subset_trans sKU sUG. +have coVK: coprime #|V| #|K| := pnat_coprime pV p'K. +have [sKH nVK] := (subset_trans sKU sUH, subset_trans sKU nVU). +have{defV} p'Ub: p^'.-group (U / V). + rewrite -defU -['F(H / V)](nilpotent_pcoreC p (Fitting_nil _)) /=. + by rewrite p_core_Fitting -defV trivg_pcore_quotient dprod1g pcore_pgroup. +have{p'Ub} sylV: p.-Sylow(U) V by rewrite /pHall sVU pV -card_quotient. +have{sKU} mulVK: V * K = U. + apply/eqP; rewrite eqEcard mul_subG //= coprime_cardMg //. + by rewrite (card_Hall sylV) (card_Hall hallK) partnC. +have [sKN sNH]: K \subset 'N_H(K) /\ 'N_H(K) \subset H. + by rewrite subsetIl subsetI sKH normG. +have [solN nVN] := (solvableS sNH solH, subset_trans sNH nVH). +have{solU hallK sUH nUG} defH: V * 'N_H(K) = H. + have nsUH: U <| H by apply/andP; rewrite (subset_trans sHG). + by rewrite -(mulSGid sKN) mulgA mulVK (Hall_Frattini_arg solU nsUH hallK). +have [P sylP nPR]: exists2 P : {group _}, p.-Sylow('N_H(K)) P & R \subset 'N(P). + apply: coprime_Hall_exists (coprimeSg sNH coHR) solN. + by rewrite normsI ?norms_norm. +have [sPN pP _]: [/\ P \subset 'N_H(K), p.-group P & _] := and3P sylP. +have [sPH nKP]: P \subset H /\ P \subset 'N(K) by apply/andP; rewrite -subsetI. +have nVP := subset_trans sPH nVH. +have coKP: coprime #|K| #|P| by rewrite coprime_sym (pnat_coprime pP). +have{sylP} sylVP: p.-Sylow(H) (V <*> P). + rewrite pHallE /= norm_joinEr ?mul_subG //= -defH -!LagrangeMl. + rewrite partnM // part_pnat_id // -!card_quotient //. + by apply/eqP; congr (_ * _)%N; apply: card_Hall; exact: quotient_pHall. +have [trKP | {sylV sVU nVU}ntKP] := eqVneq [~: K, P] 1. + suffices sylVH: p.-Sylow(H) V. + rewrite p_elt_gen_length1 // (_ : p_elt_gen p H = V). + rewrite /pHall pcore_sub pcore_pgroup /= pnatNK. + by apply: pnat_dvd pV; exact: dvdn_indexg. + rewrite -(genGid V) -(setIidPr sVH); congr <<_>>; apply/setP=> x. + rewrite !inE; apply: andb_id2l => Hx. + by rewrite (mem_normal_Hall sylVH) /normal ?sVH. + suffices sPV: P \subset V by rewrite -(joing_idPl sPV). + suffices sPU: P \subset U by rewrite (sub_normal_Hall sylV) //; exact/andP. + have cUPb: P / V \subset 'C_(H / V)(U / V). + rewrite subsetI morphimS // -mulVK quotientMidl quotient_cents2r //. + by rewrite commGC trKP sub1G. + rewrite -(quotientSGK nVP sVU) (subset_trans cUPb) //. + by rewrite -defU cent_sub_Fitting ?quotient_sol. +have{sylVP} dxV: [~: V, K] \x 'C_V(K) = V by exact: coprime_abelian_cent_dprod. +have tiVsub_VcK: 'C_V(K) = 1 \/ 'C_V(K) = V. + apply: (indecomposableV _ [~: V, K]); first by rewrite dprodC. + rewrite -mulHR -defH -mulgA mul_subG // subsetI. + by rewrite commg_norml cents_norm // centsC subIset // -abelianE cVV. + have nK_NR: 'N_H(K) * R \subset 'N(K) by rewrite mul_subG ?subsetIr. + have nV_NR: 'N_H(K) * R \subset 'N(V) by rewrite mul_subG. + by rewrite normsR // normsI ?norms_cent. +have{tiVsub_VcK dxV} [defVK tiVcK]: [~: V, K] = V /\ 'C_V(K) = 1. + have [tiVcK | eqC] := tiVsub_VcK; first by rewrite -{2}dxV // tiVcK dprodg1. + rewrite (card1_trivg (pnat_1 (pgroupS _ pV) p'K)) ?comm1G ?eqxx // in ntKP. + by rewrite -scVH subsetI sKH centsC -eqC subsetIr. +have eqVncK: 'N_V(K) = 'C_V(K) := coprime_norm_cent nVK (pnat_coprime pV p'K). +have{eqVncK} tiVN: V :&: 'N_H(K) = 1 by rewrite setIA (setIidPl sVH) eqVncK. +have{sPN} tiVP: V :&: P = 1 by apply/trivgP; rewrite -tiVN setIS. +have{U defU mulVK} defK: 'F('N_H(K)) = K. + have [injV imV] := isomP (quotient_isom nVN tiVN). + rewrite -(im_invm injV) -injm_Fitting ?injm_invm //= {2}imV /=. + rewrite -quotientMidl defH defU -mulVK quotientMidl morphim_invmE. + by rewrite morphpre_restrm quotientK // -group_modr // setIC tiVN mul1g. +have scKH: 'C_H(K) \subset K. + rewrite -{2}defK; apply: subset_trans (cent_sub_Fitting _) => //. + by rewrite defK subsetI subsetIr setIS // cent_sub. +have{nVN} ntKR0: [~: K, R0] != 1. + rewrite (sameP eqP commG1P); apply: contra ntKP => cR0K. + have ZgrK: Zgroup K by apply: ZgroupS ZgrCHR0; rewrite subsetI sKH. + have{ZgrK} cycK: cyclic K by rewrite nil_Zgroup_cyclic // -defK Fitting_nil. + have{cycK} sNR_K: [~: 'N_H(K), R] \subset K. + apply: subset_trans scKH; rewrite subsetI; apply/andP; split. + by rewrite (subset_trans (commSg R sNH)) // commGC commg_subr. + suffices: 'N(K)^`(1) \subset 'C(K). + by apply: subset_trans; rewrite commgSS ?subsetIr. + rewrite der1_min ?cent_norm //= -ker_conj_aut (isog_abelian (first_isog _)). + exact: abelianS (Aut_conj_aut K 'N(K)) (Aut_cyclic_abelian cycK). + suffices sPV: P \subset V by rewrite -(setIidPr sPV) tiVP commG1. + have pPV: p.-group (P / V) := quotient_pgroup V pP. + rewrite -quotient_sub1 // subG1 (card1_trivg (pnat_1 pPV _)) //. + apply: pgroupS (quotient_pgroup V p'K). + apply: subset_trans (quotientS V sNR_K). + by rewrite quotientR // -quotientMidl defH -quotientR ?defHR ?quotientS. +have nKR0: R0 \subset 'N(K) := subset_trans sR0R nKR. +have mulKR0: K * R0 = K <*> R0 by rewrite norm_joinEr. +have sKR0_G : K <*> R0 \subset G by rewrite -mulKR0 -mulHR mulgSS. +have nV_KR0: K <*> R0 \subset 'N(V) := subset_trans sKR0_G nVG. +have solKR0: solvable (K <*> R0) by exact: solvableS solG. +have coKR0: coprime #|K| #|R0| by rewrite (coprimeSg sKH) ?(coprimegS sR0R). +have r'K: r^'.-group K. + by rewrite /pgroup p'natE -?prime_coprime // coprime_sym -oR0. +have tiKcV: 'C_K(V) = 1. + by apply/trivgP; rewrite -tiVN -{2}scVH -setIIr setICA setIC setSI. +have tiKR0cV: 'C_(K <*> R0)(V) = 1. + set C := 'C_(K <*> R0)(V); apply/eqP; apply: contraR ntKR0 => ntC. + have nC_KR0: K <*> R0 \subset 'N(C) by rewrite normsI ?normG ?norms_cent. + rewrite -subG1 -(coprime_TIg coKR0) commg_subI ?subsetI ?subxx //=. + suff defC: C == R0 by rewrite -(eqP defC) (subset_trans (joing_subl K R0)). + have sC_R0: C \subset R0. + rewrite -[C](coprime_mulG_setI_norm mulKR0) ?norms_cent //= tiKcV mul1g. + exact: subsetIl. + rewrite eqEsubset sC_R0; apply: contraR ntC => not_sR0C. + by rewrite -(setIidPr sC_R0) prime_TIg ?oR0. +have{nKR0 mulKR0 sKR0_G solKR0 nV_KR0} oCVR0: #|'C_V(R0)| = p. + case: (eqVneq 'C_V(R0) 1) => [tiVcR0 | ntCVR0]. + case/negP: ntKR0; rewrite -subG1/= commGC -tiKcV. + have defKR0: K ><| R0 = K <*> R0 by rewrite sdprodE ?coprime_TIg. + have odd_KR0: odd #|K <*> R0| := oddSg sKR0_G oddG. + apply: odd_prime_sdprod_abelem_cent1 abelV nV_KR0 _ _; rewrite // ?oR0 //=. + by rewrite -mulKR0 pgroupM p'K /pgroup oR0 pnatE. + have [x defC]: exists x, 'C_V(R0) = <[x]>. + have ZgrC: Zgroup 'C_V(R0) by apply: ZgroupS ZgrCHR0; exact: setSI. + apply/cyclicP; apply: (forall_inP ZgrC); apply/SylowP; exists p => //. + by rewrite /pHall subxx indexgg (pgroupS (subsetIl V _)). + rewrite defC; apply: nt_prime_order => //; last by rewrite -cycle_eq1 -defC. + by rewrite (exponentP eV) // -cycle_subG -defC subsetIl. +have tiPcR0: 'C_P(R0) = 1. + rewrite -(setIidPl (joing_subl P V)) setIIl TI_Ohm1 //=. + set C := 'C_(P <*> V)(R0); suffices <-: 'C_V(R0) = 'Ohm_1(C). + by rewrite setIC -setIIl tiVP (setIidPl (sub1G _)). + have pPV: p.-group (P <*> V) by rewrite norm_joinEl // pgroupM pP. + have pC: p.-group C := pgroupS (subsetIl _ _) pPV. + have abelCVR0: p.-abelem 'C_V(R0) by rewrite prime_abelem ?oCVR0. + have sCV_C: 'C_V(R0) \subset C by rewrite setSI ?joing_subr. + apply/eqP; rewrite eqEcard -(Ohm1_id abelCVR0) OhmS //=. + have [-> | ntC] := eqVneq C 1; first by rewrite subset_leq_card ?OhmS ?sub1G. + rewrite (Ohm1_id abelCVR0) oCVR0 (Ohm1_cyclic_pgroup_prime _ pC) //=. + have ZgrC: Zgroup C by rewrite (ZgroupS _ ZgrCHR0) ?setSI // join_subG sPH. + apply: (forall_inP ZgrC); apply/SylowP; exists p => //. + by apply/pHallP; rewrite part_pnat_id. +have defP: [~: P, R0] = P. + have solvP := pgroup_sol pP; have nPR0 := subset_trans sR0R nPR. + have coPR0: coprime #|P| #|R0| by rewrite (coprimeSg sPH) ?(coprimegS sR0R). + by rewrite -{2}(coprime_cent_prod nPR0) // tiPcR0 mulg1. +have{IHsub nVH} IHsub: forall X : {group gT}, + P <*> R0 \subset 'N(X) -> X \subset K -> + (#|V <*> X <*> P| < #|H|) || (#|R0| < #|R|) -> [~: X, P] = 1. +- move=> X; rewrite join_subG; case/andP=> nXP nXR0 sXK. + set H0 := V <*> X <*> P => ltG0G; have sXH := subset_trans sXK sKH. + have sXH0: X \subset H0 by rewrite /H0 joingC joingA joing_subr. + have sH0H: H0 \subset H by rewrite !join_subG sVH sXH. + have nH0R0: R0 \subset 'N(H0). + by rewrite 2?normsY ?nXR0 ?(subset_trans sR0R) // (subset_trans sRG). + have Op'H0: 'O_p^'(H0) = 1. + have [sOp' nOp'] := andP (pcore_normal _ _ : 'O_p^'(H0) <| H0). + have p'Op': p^'.-group 'O_p^'(H0) by exact: pcore_pgroup. + apply: card1_trivg (pnat_1 (pgroupS _ pV) p'Op'). + rewrite -scVH subsetI (subset_trans sOp') //= centsC; apply/setIidPl. + rewrite -coprime_norm_cent ?(pnat_coprime pV p'Op') //. + by rewrite (setIidPl (subset_trans _ nOp')) // /H0 -joingA joing_subl. + exact: subset_trans (subset_trans sH0H nVH). + have Op'HR0: 'O_p^'([~: H0, R0]) = 1. + apply/trivgP; rewrite -Op'H0 pcore_max ?pcore_pgroup //. + apply: char_normal_trans (pcore_char _ _) _. + by rewrite /(_ <| _) commg_norml andbT commg_subl. + have{ltG0G IHsub} p1_HR0: p.-length_1 [~: H0, R0]. + by apply: IHsub ltG0G => //=; rewrite mul_subG ?normG. + have{p1_HR0} sPOpHR0: P \subset 'O_p([~: H0, R0]). + rewrite sub_Hall_pcore //; last by rewrite -defP commSg ?joing_subr. + rewrite /pHall pcore_sub pcore_pgroup /= -(pseries_pop2 _ Op'HR0). + rewrite -card_quotient ?normal_norm ?pseries_normal // -/(pgroup _ _). + by rewrite -{1}((_ :=P: _) p1_HR0) (quotient_pseries [::_;_]) pcore_pgroup. + apply/trivgP; have <-: K :&: 'O_p([~: H0, R0]) = 1. + by rewrite setIC coprime_TIg // (pnat_coprime (pcore_pgroup p _)). + rewrite commg_subI // subsetI ?sPOpHR0 ?sXK //=. + by rewrite (char_norm_trans (pcore_char _ _)) // normsRl. +have{defH sR0R} [defH defR0]: V * K * P = H /\ R0 :=: R. + suffices: (V * K * P == H) && (R0 :==: R) by do 2!case: eqP => // ->. + apply: contraR ntKP; rewrite -subG1 !eqEcard sR0R ?mul_subG //= negb_and. + rewrite -!ltnNge -!norm_joinEr // 1?normsY //; move/IHsub=> -> //. + by rewrite join_subG nKP (subset_trans sR0R). +move: IHsub defP oR0 rR0 ZgrCHR0 coKR0 ntKR0 tiKR0cV oCVR0 tiPcR0. +rewrite {R0}defR0 ltnn => IHsub defP oR rR ZgrCHR coKR ntKR tiKRcV oCVR tiPcR. +have mulVK: V * K = V <*> K by rewrite norm_joinEr. +have oVK: #|V <*> K| = (#|V| * #|K|)%N by rewrite -mulVK coprime_cardMg. +have tiVK_P: V <*> K :&: P = 1. + have sylV: p.-Sylow(V <*> K) V. + by rewrite /pHall pV -divgS joing_subl //= oVK mulKn. + apply/trivgP; rewrite -tiVP subsetI subsetIr. + rewrite (sub_normal_Hall sylV) ?subsetIl ?(pgroupS (subsetIr _ P)) //=. + by rewrite /normal joing_subl join_subG normG. +have{mulVK oVK} oH: (#|H| = #|V| * #|K| * #|P|)%N. + by rewrite -defH mulVK -oVK (TI_cardMg tiVK_P). +have{oH tiVK_P IHsub} IHsub: forall X : {group gT}, + P <*> R \subset 'N(X) -> X \subset K -> X :=: K \/ X \subset 'C(P). +- move=> X nX_PR sXK; have p'X: p^'.-group X := pgroupS sXK p'K. + have nXP: P \subset 'N(X) := subset_trans (joing_subl P R) nX_PR. + apply/predU1P; rewrite eqEcard sXK; case: leqP => //= ltXK. + apply/commG1P; rewrite {}IHsub // orbF (norm_joinEr (normsY _ _)) //=. + rewrite TI_cardMg /=; last first. + by apply/trivgP; rewrite -tiVK_P setSI ?genS ?setUS. + rewrite oH ltn_pmul2r ?cardG_gt0 // norm_joinEr ?(subset_trans sXK) //. + by rewrite coprime_cardMg ?ltn_pmul2l ?(pnat_coprime pV). +have defKP: [~: K, P] = K. + have sKP_K: [~: K, P] \subset K by rewrite commg_subl. + have{sKP_K} [|//|cP_KP] := IHsub _ _ sKP_K. + by rewrite join_subG /= commg_normr normsR. + by case/eqP: ntKP; rewrite -coprime_commGid ?(commG1P cP_KP) ?(solvableS sKH). +have nKPR: P <*> R \subset 'N(K) by rewrite join_subG nKP. +have coPR: coprime #|P| #|R| by rewrite (coprimeSg sPH). +have{scKH} tiPRcK: 'C_(P <*> R)(K) = 1. + have tiPK: P :&: K = 1 by rewrite setIC coprime_TIg. + have tiPcK: 'C_P(K) = 1. + by apply/trivgP; rewrite /= -{1}(setIidPl sPH) -setIA -tiPK setIS. + have tiRcK: 'C_R(K) = 1. + by rewrite prime_TIg ?oR // centsC (sameP commG1P eqP). + have mulPR: P * R = P <*> R by rewrite norm_joinEr. + by rewrite -(coprime_mulG_setI_norm mulPR) ?tiPcK ?mul1g ?norms_cent. +have [K1 | ntK]:= eqsVneq K 1; first by rewrite K1 comm1G eqxx in ntKR. +have [K1 | [q q_pr q_dv_K]] := trivgVpdiv K; first by case/eqP: ntK. +have q_gt1 := prime_gt1 q_pr. +have p'q: q != p by exact: (pgroupP p'K). +have{r'K} q'r: r != q by rewrite eq_sym; exact: (pgroupP r'K). +have{defK} qK: q.-group K. + have{defK} nilK: nilpotent K by rewrite -defK Fitting_nil. + have{nilK} [_ defK _ _] := dprodP (nilpotent_pcoreC q nilK). + have{IHsub} IHpi: forall pi, 'O_pi(K) = K \/ 'O_pi(K) \subset 'C(P). + move=> pi; apply: IHsub (pcore_sub _ _). + by apply: char_norm_trans (pcore_char _ _) _; rewrite join_subG nKP. + case: (IHpi q) => [<-| cPKq]; first exact: pcore_pgroup. + case/eqP: ntKP; apply/commG1P; rewrite -{}defK mul_subG //. + case: (IHpi q^') => // defK; case/idPn: q_dv_K. + rewrite -p'natE // -defK; exact: pcore_pgroup. +pose K' := K^`(1); have charK': K' \char K := der_char 1 K. +have nsK'K: K' <| K := der_normal 1 K; have [sK'K nK'K] := andP nsK'K. +have nK'PR: P <*> R \subset 'N(K') := char_norm_trans charK' nKPR. +have iK'K: 'C_(P <*> R / K')(K / K') = 1 -> #|K / K'| > q ^ 2. + have qKb: q.-group (K / K') by exact: morphim_pgroup qK. + rewrite ltnNge => trCK'; apply: contra ntKP => Kq_le_q2. + suffices sPR_K': [~: P, R] \subset K'. + rewrite -defP -(setIidPl sPR_K') coprime_TIg ?commG1 //. + by rewrite (pnat_coprime (pgroupS _ pP) (pgroupS sK'K p'K)) ?commg_subl. + rewrite -quotient_cents2 ?(char_norm_trans charK') //. + suffices cPRbPrb: abelian (P <*> R / K'). + by rewrite (sub_abelian_cent2 cPRbPrb) ?quotientS ?joing_subl ?joing_subr. + have nKbPR: P <*> R / K' \subset 'N(K / K') by exact: quotient_norms. + case cycK: (cyclic (K / K')). + rewrite (isog_abelian (quotient1_isog _)) -trCK' -ker_conj_aut. + rewrite (isog_abelian (first_isog_loc _ _)) //. + by rewrite (abelianS (Aut_conj_aut _ _)) ?Aut_cyclic_abelian. + have{cycK} [oKb abelKb]: #|K / K'| = (q ^ 2)%N /\ q.-abelem (K / K'). + have sKb1: 'Ohm_1(K / K') \subset K / K' by exact: Ohm_sub. + have cKbKb: abelian (K / K') by rewrite sub_der1_abelian. + have: #|'Ohm_1(K / K')| >= q ^ 2. + rewrite (card_pgroup (pgroupS sKb1 qKb)) leq_exp2l // ltnNge. + by rewrite -p_rank_abelian -?rank_pgroup // -abelian_rank1_cyclic ?cycK. + rewrite (geq_leqif (leqif_trans (subset_leqif_card sKb1) (leqif_eq _))) //. + by case/andP=> sKbKb1; move/eqP->; rewrite (abelemS sKbKb1) ?Ohm1_abelem. + have ntKb: K / K' != 1 by rewrite -cardG_gt1 oKb (ltn_exp2l 0). + pose rPR := abelem_repr abelKb ntKb nKbPR. + have: mx_faithful rPR by rewrite abelem_mx_faithful. + move: rPR; rewrite (dim_abelemE abelKb ntKb) oKb pfactorK // => rPR ffPR. + apply: charf'_GL2_abelian ffPR _. + by rewrite quotient_odd ?(oddSg _ oddG) // join_subG (subset_trans sPH). + rewrite (eq_pgroup _ (eq_negn (charf_eq (char_Fp q_pr)))). + rewrite quotient_pgroup //= norm_joinEr // pgroupM. + by rewrite /pgroup (pi_pnat rR) // (pi_pnat pP) // !inE eq_sym. +case cKK: (abelian K); last first. + have [|[dPhiK dK'] dCKP] := abelian_charsimple_special qK coKP defKP. + apply/bigcupsP=> L; case/andP=> charL; have sLK := char_sub charL. + by case/IHsub: sLK cKK => // [|-> -> //]; exact: (char_norm_trans charL). + have eK: exponent K %| q. + have oddK: odd #|K| := oddSg sKG oddG. + have [Q [charQ _ _ eQ qCKQ]] := critical_odd qK oddK ntK; rewrite -eQ. + have sQK: Q \subset K := char_sub charQ. + have [<- // | cQP] := IHsub Q (char_norm_trans charQ nKPR) sQK. + case/negP: ntKP; rewrite (sameP eqP commG1P) centsC. + rewrite -ker_conj_aut -sub_morphim_pre // subG1 trivg_card1. + rewrite (pnat_1 (morphim_pgroup _ pP) (pi_pnat (pgroupS _ qCKQ) _)) //. + apply/subsetP=> a; case/morphimP=> x nKx Px ->{a}. + rewrite /= astab_ract inE /= Aut_aut; apply/astabP=> y Qy. + rewrite [_ y _]norm_conj_autE ?(subsetP sQK) //. + by rewrite /conjg (centsP cQP y) ?mulKg. + have tiPRcKb: 'C_(P <*> R / K')(K / K') = 1. + rewrite -quotient_astabQ -quotientIG /=; last first. + by rewrite sub_astabQ normG trivg_quotient sub1G. + apply/trivgP; rewrite -quotient1 quotientS // -tiPRcK subsetI subsetIl /=. + rewrite (coprime_cent_Phi qK) ?(coprimegS (subsetIl _ _)) //=. + by rewrite norm_joinEr // coprime_cardMg // coprime_mulr coKP. + rewrite dPhiK -dK' -/K' (subset_trans (commgS _ (subsetIr _ _))) //. + by rewrite astabQ -quotient_cents2 ?subsetIl // cosetpreK centsC /=. + have [nK'P nK'R] := (char_norm_trans charK' nKP, char_norm_trans charK' nKR). + have solK: solvable K := pgroup_sol qK. + have dCKRb: 'C_K(R) / K' = 'C_(K / K')(R / K'). + by rewrite coprime_quotient_cent. + have abelKb: q.-abelem (K / K') by rewrite [K']dK' -dPhiK Phi_quotient_abelem. + have [qKb cKbKb _] := and3P abelKb. + have [tiKcRb | ntCKRb]:= eqVneq 'C_(K / K')(R / K') 1. + have coK'P: coprime #|K'| #|P| by rewrite (coprimeSg sK'K). + suffices sPK': P \subset K'. + by case/negP: ntKP; rewrite -(setIidPr sPK') coprime_TIg ?commG1. + rewrite -quotient_sub1 // -defP commGC quotientR //= -/K'. + have <-: 'C_(P / K')(K / K') = 1. + by apply/trivgP; rewrite -tiPRcKb setSI ?morphimS ?joing_subl. + have q'P: q^'.-group P by rewrite /pgroup (pi_pnat pP) // !inE eq_sym. + move: tiKcRb; have: q^'.-group (P <*> R / K'). + rewrite quotient_pgroup //= norm_joinEr //. + by rewrite pgroupM q'P /pgroup oR pnatE. + have sPRG: P <*> R \subset G by rewrite join_subG sRG (subset_trans sPH). + have coPRb: coprime #|P / K'| #|R / K'| by rewrite coprime_morph. + apply: odd_prime_sdprod_abelem_cent1 abelKb _; rewrite ?quotient_norms //. + - by rewrite quotient_sol // (solvableS sPRG). + - by rewrite quotient_odd // (oddSg sPRG). + - by rewrite /= quotientY // sdprodEY ?quotient_norms ?coprime_TIg. + rewrite -(card_isog (quotient_isog nK'R _)) ?oR //. + by rewrite coprime_TIg // (coprimeSg sK'K). + have{ntCKRb} not_sCKR_K': ~~ ('C_K(R) \subset K'). + by rewrite -quotient_sub1 ?subIset ?nK'K // dCKRb subG1. + have oCKR: #|'C_K(R)| = q. + have [x defCKR]: exists x, 'C_K(R) = <[x]>. + have ZgrCKR: Zgroup 'C_K(R) := ZgroupS (setSI _ sKH) ZgrCHR. + have qCKR: q.-group 'C_K(R) by rewrite (pgroupS (subsetIl K _)). + by apply/cyclicP; exact: nil_Zgroup_cyclic (pgroup_nil qCKR). + have Kx: x \in K by rewrite -cycle_subG -defCKR subsetIl. + rewrite defCKR cycle_subG in not_sCKR_K' *. + exact: nt_prime_order (exponentP eK x Kx) (group1_contra not_sCKR_K'). + have tiCKR_K': 'C_K(R) :&: K' = 1 by rewrite prime_TIg ?oCKR. + have sKR_K: [~: K, R] \subset K by rewrite commg_subl nKR. + have ziKRcR: 'C_K(R) :&: [~: K, R] \subset K'. + rewrite -quotient_sub1 ?subIset ?nK'K // setIC. + rewrite (subset_trans (quotientI _ _ _)) // dCKRb setIA. + rewrite (setIidPl (quotientS _ sKR_K)) // ?quotientR //= -/K'. + by rewrite coprime_abel_cent_TI ?quotient_norms ?coprime_morph. + have not_sK_KR: ~~ (K \subset [~: K, R]). + by apply: contra not_sCKR_K' => sK_KR; rewrite -{1}(setIidPl sK_KR) setIAC. + have tiKRcR: 'C_[~: K, R](R) = 1. + rewrite -(setIidPr sKR_K) setIAC -(setIidPl ziKRcR) setIAC tiCKR_K'. + by rewrite (setIidPl (sub1G _)). + have cKR_KR: abelian [~: K, R]. + have: 'C_[~: K, R](V) \subset [1]. + rewrite -tiVN -{2}scVH -setIIr setICA setIC setIS //. + exact: subset_trans sKR_K sKN. + rewrite /abelian (sameP commG1P trivgP) /= -derg1; apply: subset_trans. + have nKR_R: R \subset 'N([~: K, R]) by rewrite commg_normr. + have sKRR_G: [~: K, R] <*> R \subset G by rewrite join_subG comm_subG. + move: oCVR; have: p^'.-group ([~: K, R] <*> R). + by rewrite norm_joinEr // pgroupM (pgroupS sKR_K p'K) /pgroup oR pnatE. + have solKR_R := solvableS sKRR_G solG. + apply: Frobenius_prime_cent_prime; rewrite ?oR ?(subset_trans _ nVG) //. + by rewrite sdprodEY // coprime_TIg // (coprimeSg sKR_K). + case nKR_P: (P \subset 'N([~: K, R])). + have{nKR_P} nKR_PR: P <*> R \subset 'N([~: K, R]). + by rewrite join_subG nKR_P commg_normr. + have{nKR_PR} [dKR | cP_KR] := IHsub _ nKR_PR sKR_K. + by rewrite dKR subxx in not_sK_KR. + have{cP_KR} cKRb: R / K' \subset 'C(K / K'). + by rewrite quotient_cents2r //= dK' -dCKP commGC subsetI sKR_K. + case/negP: ntKR; rewrite (sameP eqP commG1P) centsC. + by rewrite (coprime_cent_Phi qK) // dPhiK -dK' commGC -quotient_cents2. + have{nKR_P} [x Px not_nKRx] := subsetPn (negbT nKR_P). + have iKR: #|K : [~: K, R]| = q. + rewrite -divgS // -{1}(coprime_cent_prod nKR) // TI_cardMg ?mulKn //. + by rewrite setIA (setIidPl sKR_K). + have sKRx_K: [~: K, R] :^ x \subset K by rewrite -{2}(normsP nKP x Px) conjSg. + have nKR_K: K \subset 'N([~: K, R]) by exact: commg_norml. + have mulKR_Krx: [~: K, R] * [~: K, R] :^ x = K. + have maxKR: maximal [~: K, R] K by rewrite p_index_maximal ?iKR. + apply: mulg_normal_maximal; rewrite ?(p_maximal_normal qK) //. + by rewrite inE in not_nKRx. + have ziKR_KRx: [~: K, R] :&: [~: K, R] :^ x \subset K'. + rewrite /K' dK' subsetI subIset ?sKR_K // -{3}mulKR_Krx centM centJ. + by rewrite setISS ?conjSg. + suffices: q ^ 2 >= #|K / K'| by rewrite leqNgt iK'K. + rewrite -divg_normal // leq_divLR ?cardSg //. + rewrite -(@leq_pmul2l (#|[~: K, R]| ^ 2)) ?expn_gt0 ?cardG_gt0 // mulnA. + rewrite -expnMn -iKR Lagrange // -mulnn -{2}(cardJg _ x) mul_cardG. + by rewrite mulKR_Krx mulnAC leq_pmul2l ?muln_gt0 ?cardG_gt0 ?subset_leq_card. +have tiKcP: 'C_K(P) = 1 by rewrite -defKP coprime_abel_cent_TI. +have{IHsub} abelK: q.-abelem K. + have [|cPK1] := IHsub _ (char_norm_trans (Ohm_char 1 K) nKPR) (Ohm_sub 1 K). + by move/abelem_Ohm1P->. + rewrite -(setIid K) TI_Ohm1 ?eqxx // in ntK. + by apply/eqP; rewrite -subG1 -tiKcP setIS. +have{K' iK'K charK' nsK'K sK'K nK'K nK'PR} oKq2: q ^ 2 < #|K|. + have K'1: K' :=: 1 by exact/commG1P. + rewrite -indexg1 -K'1 -card_quotient ?normal_norm // iK'K // K'1. + by rewrite -injm_subcent ?coset1_injm ?norms1 //= tiPRcK morphim1. +pose S := [set Vi : {group gT} | 'C_V('C_K(Vi)) == Vi & maximal 'C_K(Vi) K]. +have defSV Vi: Vi \in S -> 'C_V('C_K(Vi)) = Vi by rewrite inE; case: eqP. +have maxSK Vi: Vi \in S -> maximal 'C_K(Vi) K by case/setIdP. +have sSV Vi: Vi \in S -> Vi \subset V by move/defSV <-; rewrite subsetIl. +have ntSV Vi: Vi \in S -> Vi :!=: 1. + move=> Si; apply: contraTneq (maxgroupp (maxSK _ Si)) => ->. + by rewrite /= cent1T setIT proper_irrefl. +have nSK Vi: Vi \in S -> K \subset 'N(Vi). + by move/defSV <-; rewrite normsI ?norms_cent // sub_abelian_norm ?subsetIl. +have defV: <<\bigcup_(Vi in S) Vi>> = V. + apply/eqP; rewrite eqEsubset gen_subG. + apply/andP; split; first by apply/bigcupsP; apply: sSV. + rewrite -(coprime_abelian_gen_cent cKK nVK) ?(pnat_coprime pV) // gen_subG. + apply/bigcupsP=> Kj /= /and3P[cycKbj sKjK nKjK]. + have [xb defKbj] := cyclicP cycKbj. + have Kxb: xb \in K / Kj by rewrite defKbj cycle_id. + set Vj := 'C_V(Kj); have [-> | ntVj] := eqsVneq Vj 1; first exact: sub1G. + have nt_xb: xb != 1. + apply: contra ntVj; rewrite -cycle_eq1 -defKbj -!subG1 -tiVcK. + by rewrite quotient_sub1 // => sKKj; rewrite setIS ?centS. + have maxKj: maximal Kj K. + rewrite p_index_maximal // -card_quotient // defKbj -orderE. + by rewrite (abelem_order_p (quotient_abelem Kj abelK) Kxb nt_xb). + suffices defKj: 'C_K(Vj) = Kj. + by rewrite sub_gen // (bigcup_max 'C_V(Kj))%G // inE defKj eqxx. + have{maxKj} [_ maxKj] := maxgroupP maxKj. + rewrite ['C_K(Vj)]maxKj //; last by rewrite subsetI sKjK centsC subsetIr. + rewrite properEneq subsetIl andbT (sameP eqP setIidPl) centsC. + by apply: contra ntVj; rewrite -subG1 -tiVcK subsetI subsetIl. +pose dxp := [fun D : {set {group gT}} => \big[dprod/1]_(Vi in D) Vi]. +have{defV} defV: \big[dprod/1]_(Vi in S) Vi = V. + have [D maxD]: {D | maxset [pred E | group_set (dxp E) & E \subset S] D}. + by apply: ex_maxset; exists set0; rewrite /= sub0set big_set0 groupP. + have [gW sDS] := andP (maxsetp maxD); have{maxD} [_ maxD] := maxsetP maxD. + have{gW} [W /= defW]: {W : {group gT} | dxp D = W} by exists (Group gW). + have [eqDS | ltDS] := eqVproper sDS. + by rewrite eqDS in defW; rewrite defW -(bigdprodWY defW). + have{ltDS} [_ [Vi Si notDi]] := properP ltDS. + have sWV: W \subset V. + rewrite -(bigdprodWY defW) gen_subG. + by apply/bigcupsP=> Vj Dj; rewrite sSV ?(subsetP sDS). + suffices{maxD sWV defV} tiWcKi: 'C_W('C_K(Vi)) = 1. + have:= notDi; rewrite -(maxD (Vi |: D)) ?setU11 ?subsetUr //= subUset sDS. + rewrite sub1set Si big_setU1 //= defW dprodEY ?groupP //. + by rewrite (sub_abelian_cent2 cVV) // sSV. + by rewrite -(defSV Vi Si) setIAC (setIidPr sWV). + apply/trivgP/subsetP=> w /setIP[Ww cKi_w]. + have [v [Vv def_w v_uniq]] := mem_bigdprod defW Ww. + rewrite def_w big1 ?inE // => Vj Dj; have Sj := subsetP sDS Vj Dj. + have cKi_vj: v Vj \in 'C('C_K(Vi)). + apply/centP=> x Ki_x; apply/commgP/conjg_fixP. + apply: (v_uniq (fun Vk => v Vk ^ x)) => // [Vk Dk|]. + have [[Kx _] Sk]:= (setIP Ki_x, subsetP sDS Vk Dk). + by rewrite memJ_norm ?Vv // (subsetP (nSK Vk Sk)). + rewrite -(mulKg x w) -(centP cKi_w) // -conjgE def_w. + by apply: (big_morph (conjg^~ x)) => [y z|]; rewrite ?conj1g ?conjMg. + suffices mulKji: 'C_K(Vj) * 'C_K(Vi) = K. + by apply/set1gP; rewrite -tiVcK -mulKji centM setIA defSV // inE Vv. + have maxKj := maxSK Vj Sj; have [_ maxKi] := maxgroupP (maxSK Vi Si). + rewrite (mulg_normal_maximal _ maxKj) -?sub_abelian_normal ?subsetIl //. + have [eqVji|] := eqVneq Vj Vi; first by rewrite -eqVji Dj in notDi. + apply: contra => /= sKiKj; rewrite -val_eqE /= -(defSV Vj Sj). + by rewrite (maxKi _ (maxgroupp maxKj) sKiKj) defSV. +have nVPR: P <*> R \subset 'N(V) by rewrite join_subG nVP. +have actsPR: [acts P <*> R, on S | 'JG]. + apply/subsetP=> x PRx; rewrite !inE; apply/subsetP=> Vi. + rewrite !inE /= => Si; rewrite -(normsP nKPR x PRx) !centJ -!conjIg centJ . + by rewrite -(normsP nVPR x PRx) -conjIg (inj_eq (@conjsg_inj _ _)) maximalJ. +have transPR: [transitive P <*> R, on S | 'JG]. + pose ndxp D (U A B : {group gT}) := dxp (S :&: D) = U -> A * B \subset 'N(U). + have nV_VK D U: ndxp D U V K. + move/bigdprodWY <-; rewrite norms_gen ?norms_bigcup //. + apply/bigcapsP=> Vi /setIP[Si _]. + by rewrite mulG_subG nSK // sub_abelian_norm // sSV. + have nV_PR D U: [acts P <*> R, on S :&: D | 'JG] -> ndxp D U P R. + move=> actsU /bigdprodWY<-; rewrite -norm_joinEr ?norms_gen //. + apply/subsetP=> x PRx; rewrite inE sub_conjg; apply/bigcupsP=> Vi Di. + by rewrite -sub_conjg (bigcup_max (Vi :^ x)%G) //= (acts_act actsU). + have [S0 | [V1 S1]] := set_0Vmem S. + by case/eqP: ntV; rewrite -defV S0 big_set0. + apply/imsetP; exists V1 => //; set D := orbit _ _ _. + rewrite (big_setID D) /= setDE in defV. + have [[U W defU defW] _ _ tiUW] := dprodP defV. + rewrite defU defW in defV tiUW. + have [|U1|eqUV]:= indecomposableV _ _ defV. + - rewrite -mulHR -defH -mulgA mul_subG //. + by rewrite subsetI (nV_VK _ _ defU) (nV_VK _ _ defW). + rewrite subsetI (nV_PR _ _ _ defU) ?actsI ?acts_orbit ?subsetT //=. + by rewrite (nV_PR _ _ _ defW) // actsI ?astabsC ?acts_orbit ?subsetT /=. + - case/negP: (ntSV V1 S1); rewrite -subG1 -U1 -(bigdprodWY defU) sub_gen //. + by rewrite (bigcup_max V1) // inE S1 orbit_refl. + apply/eqP; rewrite eqEsubset (acts_sub_orbit _ actsPR) S1 andbT. + apply/subsetP=> Vi Si; apply: contraR (ntSV Vi Si) => D'i; rewrite -subG1. + rewrite -tiUW eqUV subsetI sSV // -(bigdprodWY defW). + by rewrite (bigD1 Vi) ?joing_subl // inE Si inE. +have [cSR | not_cSR] := boolP (R \subset 'C(S | 'JG)). + have{cSR} sRnSV: R \subset \bigcap_(Vi in S) 'N(Vi). + apply/bigcapsP=> Vi Si. + by rewrite -astab1JG (subset_trans cSR) ?astabS ?sub1set. + have sPRnSV: P <*> R \subset 'N(\bigcap_(Vi in S) 'N(Vi)). + apply/subsetP=> x PRx; rewrite inE; apply/bigcapsP=> Vi Si. + by rewrite sub_conjg -normJ bigcap_inf ?(acts_act actsPR) ?groupV. + have [V1 S1] := imsetP transPR. + have: P <*> R \subset 'N(V1). + rewrite join_subG (subset_trans sRnSV) /= ?bigcap_inf // andbT -defP. + apply: (subset_trans (commgS P sRnSV)). + have:= subset_trans (joing_subl P R) sPRnSV; rewrite -commg_subr /=. + move/subset_trans; apply; exact: bigcap_inf. + rewrite -afixJG; move/orbit1P => -> allV1. + have defV1: V1 = V by apply: group_inj; rewrite /= -defV allV1 big_set1. + case/idPn: oKq2; rewrite -(Lagrange (subsetIl K 'C(V1))). + rewrite (p_maximal_index qK (maxSK V1 S1)) defV1 /= tiKcV cards1 mul1n. + by rewrite (ltn_exp2l 2 1). +have actsR: [acts R, on S | 'JG] := subset_trans (joing_subr P R) actsPR. +have ntSRcR Vi: + Vi \in S -> ~~ (R \subset 'N(Vi)) -> + #|Vi| = p /\ 'C_V(R) \subset <>. +- move=> Si not_nViR; have [sVi nV] := (subsetP (sSV Vi Si), subsetP nVR). + pose f v := fmval (\sum_(x in R) fmod cVV v ^@ x). + have fM: {in Vi &, {morph f: u v / u * v}}. + move=> u v /sVi Vu /sVi Vv; rewrite -fmvalA -big_split. + by congr (fmval _); apply: eq_bigr => x Rx; rewrite /= -actAr fmodM. + have injf: 'injm (Morphism fM). + apply/subsetP=> v /morphpreP[Vi_v]; have Vv := sVi v Vi_v. + rewrite (bigD1 Vi) //= in defV; have [[_ W _ dW] _ _ _] := dprodP defV. + have [u [w [_ _ uw Uuw]]] := mem_dprod defV (group1 V). + case: (Uuw 1 1) => // [||u1 w1]; rewrite ?dW ?mulg1 // !inE eq_sym /f /=. + move/eqP; rewrite (big_setD1 1) // actr1 ?fmodK // fmvalA //= fmval_sum. + do [case/Uuw; rewrite ?dW ?fmodK -?u1 ?group_prod //] => [x R'x | ->] //. + rewrite (nt_gen_prime _ R'x) ?cycle_subG ?oR // inE in not_nViR nVR actsR. + rewrite fmvalJ ?fmodK // -(bigdprodWY dW) ?mem_gen //; apply/bigcupP. + exists (Vi :^ x)%G; rewrite ?memJ_conjg // (astabs_act _ actsR) Si. + by apply: contraNneq not_nViR => /congr_group->. + have im_f: Morphism fM @* Vi \subset 'C_V(R). + apply/subsetP=> _ /morphimP[v _ Vi_v ->]; rewrite inE fmodP. + apply/centP=> x Rx; red; rewrite conjgC -fmvalJ ?nV //; congr (x * fmval _). + rewrite {2}(reindex_acts 'R _ Rx) ?astabsR //= actr_sum. + by apply: eq_bigr => y Ry; rewrite actrM ?nV. + have defCVR: Morphism fM @* Vi = 'C_V(R). + apply/eqP; rewrite eqEcard im_f (prime_nt_dvdP _ _ (cardSg im_f)) ?oCVR //=. + by rewrite -trivg_card1 morphim_injm_eq1 ?ntSV. + rewrite -oCVR -defCVR; split; first by rewrite card_injm. + apply/subsetP=> _ /morphimP[v _ Vi_v ->] /=; rewrite /f fmval_sum. + have Vv := sVi v Vi_v; apply: group_prod => x Rx. + by rewrite fmvalJ ?fmodK ?nV // mem_gen // mem_imset2. +have{not_cSR} [V1 S1 not_nV1R]: exists2 V1, V1 \in S & ~~ (R \subset 'N(V1)). + by move: not_cSR; rewrite astabC; case/subsetPn=> v; rewrite afixJG; exists v. +set D := orbit 'JG%act R V1. +have oD: #|D| = r by rewrite card_orbit astab1JG prime_TIg ?indexg1 ?oR. +have oSV Vi: Vi \in S -> #|Vi| = p. + move=> Si; have [z _ ->]:= atransP2 transPR S1 Si. + by rewrite cardJg; case/ntSRcR: not_nV1R. +have cSnS' Vi: Vi \in S -> 'N(Vi)^`(1) \subset 'C(Vi). + move=> Si; rewrite der1_min ?cent_norm //= -ker_conj_aut. + rewrite (isog_abelian (first_isog _)) (abelianS (Aut_conj_aut _ _)) //. + by rewrite Aut_cyclic_abelian // prime_cyclic // oSV. +have nVjR Vj: Vj \in S :\: D -> 'C_K(Vj) = [~: K, R]. + case/setDP=> Sj notDj; set Kj := 'C_K(Vj). + have [nVjR|] := boolP (R \subset 'N(Vj)). + have{nVjR} sKRVj: [~: K, R] \subset Kj. + rewrite subsetI {1}commGC commg_subr nKR. + by rewrite (subset_trans _ (cSnS' Vj Sj)) // commgSS ?nSK. + have iKj: #|K : Kj| = q by rewrite (p_maximal_index qK (maxSK Vj Sj)). + have dxKR: [~: K, R] \x 'C_K(R) = K by rewrite coprime_abelian_cent_dprod. + have{dxKR} [_ defKR _ tiKRcR] := dprodP dxKR. + have Z_CK: Zgroup 'C_K(R) by apply: ZgroupS ZgrCHR; exact: setSI. + have abelCKR: q.-abelem 'C_K(R) := abelemS (subsetIl _ _) abelK. + have [qCKR _] := andP abelCKR. + apply/eqP; rewrite eq_sym eqEcard sKRVj -(leq_pmul2r (ltnW q_gt1)). + rewrite -{1}iKj Lagrange ?subsetIl // -{1}defKR (TI_cardMg tiKRcR). + rewrite leq_pmul2l ?cardG_gt0 //= (card_pgroup qCKR). + rewrite (leq_exp2l _ 1) // -abelem_cyclic // (forall_inP Z_CK) //. + by rewrite (@p_Sylow _ q) // /pHall subxx indexgg qCKR. + case/ntSRcR=> // _ sCVj; case/ntSRcR: not_nV1R => // _ sCV1. + suffices trCVR: 'C_V(R) = 1 by rewrite -oCVR trCVR cards1 in p_pr. + apply/trivgP; rewrite (big_setID D) in defV. + have{defV} [[W U /= defW defU] _ _ <-] := dprodP defV. + rewrite defW defU subsetI (subset_trans sCV1) /=; last first. + rewrite class_supportEr -(bigdprodWY defW) genS //. + apply/bigcupsP=> x Rx; rewrite (bigcup_max (V1 :^ x)%G) // inE. + by rewrite (actsP actsR) //= S1 mem_imset. + rewrite (subset_trans sCVj) // class_supportEr -(bigdprodWY defU) genS //. + apply/bigcupsP=> x Rx; rewrite (bigcup_max (Vj :^ x)%G) // inE. + by rewrite (actsP actsR) // Sj andbT (orbit_transr _ (mem_orbit 'JG Vj Rx)). +have sDS: D \subset S. + by rewrite acts_sub_orbit //; apply: subset_trans actsPR; exact: joing_subr. +have [eqDS | ltDS] := eqVproper sDS. + have [fix0 | [Vj cVjP]] := set_0Vmem 'Fix_(S | 'JG)(P). + case/negP: p'r; rewrite eq_sym -dvdn_prime2 // -oD eqDS /dvdn. + rewrite (pgroup_fix_mod pP (subset_trans (joing_subl P R) actsPR)). + by rewrite fix0 cards0 mod0n. + have{cVjP} [Sj nVjP] := setIP cVjP; rewrite afixJG in nVjP. + case/negP: (ntSV Vj Sj); rewrite -subG1 -tiVcK subsetI sSV // centsC -defKP. + by rewrite (subset_trans _ (cSnS' Vj Sj)) // commgSS ?nSK. +have [_ [Vj Sj notDj]] := properP ltDS. +have defS: S = Vj |: D. + apply/eqP; rewrite eqEsubset andbC subUset sub1set Sj sDS. + apply/subsetP=> Vi Si; rewrite !inE orbC /= -val_eqE /= -(defSV Vi Si). + have [//|notDi] := boolP (Vi \in _); rewrite -(defSV Vj Sj) /=. + by rewrite !nVjR // inE ?notDi ?notDj. +suffices: odd #|S| by rewrite defS cardsU1 (negPf notDj) /= oD -oR (oddSg sRG). +rewrite (dvdn_odd (atrans_dvd transPR)) // (oddSg _ oddG) //. +by rewrite join_subG (subset_trans sPH). +Qed. + +End Theorem_3_6. + +(* This is B & G, Theorem 3.7. *) +Theorem prime_Frobenius_sol_kernel_nil gT (G K R : {group gT}) : + K ><| R = G -> solvable G -> prime #|R| -> 'C_K(R) = 1 -> nilpotent K. +Proof. +move=> defG solG R_pr regR. +elim: {K}_.+1 {-2}K (ltnSn #|K|) => // m IHm K leKm in G defG solG regR *. +have [nsKG sRG defKR nKR tiKR] := sdprod_context defG. +have [sKG nKG] := andP nsKG. +wlog ntK: / K :!=: 1 by case: eqP => [-> _ | _ ->] //; exact: nilpotent1. +have [L maxL _]: {L : {group gT} | maxnormal L K G & [1] \subset L}. + by apply: maxgroup_exists; rewrite proper1G ntK norms1. +have [ltLK nLG]:= andP (maxgroupp maxL); have [sLK not_sKL]:= andP ltLK. +have{m leKm IHm}nilL: nilpotent L. + pose G1 := L <*> R; have nLR := subset_trans sRG nLG. + have sG1G: G1 \subset G by rewrite join_subG (subset_trans sLK). + have defG1: L ><| R = G1. + by rewrite sdprodEY //; apply/eqP; rewrite -subG1 -tiKR setSI. + apply: (IHm _ _ _ defG1); rewrite ?(solvableS sG1G) ?(oddSg sG1G) //. + exact: leq_trans (proper_card ltLK) _. + by apply/eqP; rewrite -subG1 -regR setSI. +have sLG := subset_trans sLK sKG; have nsLG: L <| G by apply/andP. +have sLF: L \subset 'F(G) by apply: Fitting_max. +have frobG: [Frobenius G = K ><| R] by apply/prime_FrobeniusP. +have solK := solvableS sKG solG. +have frobGq := Frobenius_quotient frobG solK nsLG not_sKL. +suffices sKF: K \subset 'F(K) by apply: nilpotentS sKF (Fitting_nil K). +apply: subset_trans (chief_stab_sub_Fitting solG nsKG). +rewrite subsetI subxx; apply/bigcapsP=> [[X Y] /= /andP[chiefXY sXF]]. +set V := X / Y; have [maxY nsXG] := andP chiefXY. +have [ltYX nYG] := andP (maxgroupp maxY); have [sYX _]:= andP ltYX. +have [sXG nXG] := andP nsXG; have sXK := subset_trans sXF (Fitting_sub K). +have minV := chief_factor_minnormal chiefXY. +have cVL: L \subset 'C(V | 'Q). + apply: subset_trans (subset_trans sLF (Fitting_stab_chief solG _)) _ => //. + exact: (bigcap_inf (X, Y)). +have nVG: {acts G, on group V | 'Q}. + by split; rewrite ?quotientS ?subsetT // actsQ // normal_norm. +pose V1 := sdpair1 <[nVG]> @* V. +have [p p_pr abelV]: exists2 p, prime p & p.-abelem V. + apply/is_abelemP; apply: charsimple_solvable (quotient_sol _ _). + exact: minnormal_charsimple minV. + exact: nilpotent_sol (nilpotentS sXF (Fitting_nil _)). +have abelV1: p.-abelem V1 by rewrite morphim_abelem. +have injV1 := injm_sdpair1 <[nVG]>. +have ntV1: V1 :!=: 1. + by rewrite -cardG_gt1 card_injm // cardG_gt1; case/andP: (mingroupp minV). +have nV1_G1 := im_sdpair_norm <[nVG]>. +pose rV := morphim_repr (abelem_repr abelV1 ntV1 nV1_G1) (subxx G). +have def_kerV: rker rV = 'C_G(V | 'Q). + rewrite rker_morphim rker_abelem morphpreIdom morphpreIim -astabEsd //. + by rewrite astab_actby setIid. +have kerL: L \subset rker rV by rewrite def_kerV subsetI sLG. +pose rVq := quo_repr kerL nLG. +suffices: K / L \subset rker rVq. + rewrite rker_quo def_kerV quotientSGK //= 1?subsetI 1?(subset_trans sKG) //. + by rewrite sLG. +have irrVq: mx_irreducible rVq. + apply/quo_mx_irr; apply/morphim_mx_irr; apply/abelem_mx_irrP. + apply/mingroupP; rewrite ntV1; split=> // U1; case/andP=> ntU1 nU1G sU1V. + rewrite -(morphpreK sU1V); congr (_ @* _). + case/mingroupP: minV => _; apply; last by rewrite sub_morphpre_injm. + rewrite -subG1 sub_morphpre_injm ?sub1G // morphim1 subG1 ntU1 /=. + set U := _ @*^-1 U1; rewrite -(cosetpreK U) quotient_norms //. + have: [acts G, on U | <[nVG]>] by rewrite actsEsd ?subsetIl // morphpreK. + rewrite astabs_actby subsetI subxx (setIidPr _) ?subsetIl //=. + by rewrite -{1}(cosetpreK U) astabsQ ?normal_cosetpre //= -/U subsetI nYG. +have [q q_pr abelKq]: exists2 q, prime q & q.-abelem (K / L). + apply/is_abelemP; apply: charsimple_solvable (quotient_sol _ solK). + exact: maxnormal_charsimple maxL. +case (eqVneq q p) => [def_q | neq_qp]. + have sKGq: K / L \subset G / L by apply: quotientS. + rewrite rfix_mx_rstabC //; have [_ _]:= irrVq; apply; rewrite ?submx1 //. + by rewrite normal_rfix_mx_module ?quotient_normal. + rewrite -(rfix_subg _ sKGq) (@rfix_pgroup_char _ p) ?char_Fp -?def_q //. + exact: (abelem_pgroup abelKq). +suffices: rfix_mx rVq (R / L) == 0. + apply: contraLR; apply: (Frobenius_rfix_compl frobGq). + apply: pi_pnat (abelem_pgroup abelKq) _. + by rewrite inE /= (charf_eq (char_Fp p_pr)). +rewrite -mxrank_eq0 (rfix_quo _ _ sRG) (rfix_morphim _ _ sRG). +rewrite (rfix_abelem _ _ _ (morphimS _ sRG)) mxrank_eq0 rowg_mx_eq0 -subG1. +rewrite (sub_abelem_rV_im _ _ _ (subsetIl _ _)) -(morphpreSK _ (subsetIl _ _)). +rewrite morphpreIim -gacentEsd gacent_actby gacentQ (setIidPr sRG) /=. +rewrite -coprime_quotient_cent ?(solvableS sXG) ?(subset_trans sRG) //. + by rewrite {1}['C_X(R)](trivgP _) ?quotient1 ?sub1G // -regR setSI. +by apply: coprimeSg sXK _; apply: Frobenius_coprime frobG. +Qed. + +Corollary Frobenius_sol_kernel_nil gT (G K H : {group gT}) : + [Frobenius G = K ><| H] -> solvable G -> nilpotent K. +Proof. +move=> frobG solG; have [defG ntK ntH _ _] := Frobenius_context frobG. +have{defG} /sdprodP[_ defG nKH tiKH] := defG. +have[H1 | [p p_pr]] := trivgVpdiv H; first by case/eqP: ntH. +case/Cauchy=> // x Hx ox; rewrite -ox in p_pr. +have nKx: <[x]> \subset 'N(K) by rewrite cycle_subG (subsetP nKH). +have tiKx: K :&: <[x]> = 1 by apply/trivgP; rewrite -tiKH setIS ?cycle_subG. +apply: (prime_Frobenius_sol_kernel_nil (sdprodEY nKx tiKx)) => //. + by rewrite (solvableS _ solG) // join_subG -mulG_subG -defG mulgS ?cycle_subG. +by rewrite cent_cycle (Frobenius_reg_ker frobG) // !inE -order_gt1 prime_gt1. +Qed. + +(* This is B & G, Theorem 3.8. *) +Theorem odd_sdprod_primact_commg_sub_Fitting gT (G K R : {group gT}) : + K ><| R = G -> odd #|G| -> solvable G -> + (*1*) coprime #|K| #|R| -> + (*2*) semiprime K R -> + (*3*) 'C_('F(K))(R) = 1 -> + [~: K, R] \subset 'F(K). +Proof. +elim: {G}_.+1 {-2}G (ltnSn #|G|) K R => // n IHn G. +rewrite ltnS => leGn K R defG oddG solG coKR primR regR_F. +have [nsKG sRG defKR nKR tiKR] := sdprod_context defG. +have [sKG nKG] := andP nsKG. +have chF: 'F(K) \char K := Fitting_char K; have nFR := char_norm_trans chF nKR. +have nsFK := char_normal chF; have [sFK nFK] := andP nsFK. +pose KqF := K / 'F(K); have solK := solvableS sKG solG. +without loss [p p_pr pKqF]: / exists2 p, prime p & p.-group KqF. + move=> IHp; apply: wlog_neg => IH_KR; rewrite -quotient_cents2 //= -/KqF. + set Rq := R / 'F(K); have nKRq: Rq \subset 'N(KqF) by exact: quotient_norms. + rewrite centsC. + apply: subset_trans (coprime_cent_Fitting nKRq _ _); last first. + - exact: quotient_sol. + - exact: coprime_morph. + rewrite subsetI subxx centsC -['F(KqF)]Sylow_gen gen_subG. + apply/bigcupsP=> Pq /SylowP[p p_pr /= sylPq]; rewrite -/KqF in sylPq. + have chPq: Pq \char KqF. + apply: char_trans (Fitting_char _); rewrite /= -/KqF. + by rewrite (nilpotent_Hall_pcore (Fitting_nil _) sylPq) ?pcore_char. + have [P defPq sFP sPK] := inv_quotientS nsFK (char_sub chPq). + have nsFP: 'F(K) <| P by rewrite /normal sFP (subset_trans sPK). + have{chPq} chP: P \char K. + by apply: char_from_quotient nsFP (Fitting_char _) _; rewrite -defPq. + have defFP: 'F(P) = 'F(K). + apply/eqP; rewrite eqEsubset !Fitting_max ?Fitting_nil //. + by rewrite char_normal ?(char_trans (Fitting_char _)). + have coPR := coprimeSg sPK coKR. + have nPR: R \subset 'N(P) := char_norm_trans chP nKR. + pose G1 := P <*> R. + have sG1G: G1 \subset G by rewrite /G1 -defKR norm_joinEr ?mulSg. + have defG1: P ><| R = G1 by rewrite sdprodEY ?coprime_TIg. + rewrite defPq quotient_cents2r //= -defFP. + have:= sPK; rewrite subEproper; case/predU1P=> [defP | ltPK]. + rewrite IHp // in IH_KR; exists p => //. + by rewrite /KqF -{2}defP -defPq (pHall_pgroup sylPq). + move/IHn: defG1 => ->; rewrite ?(oddSg sG1G) ?(solvableS sG1G) ?defFP //. + apply: leq_trans leGn; rewrite /= norm_joinEr //. + by rewrite -defKR !coprime_cardMg // ltn_pmul2r ?proper_card. + by move=> x Rx; rewrite -(setIidPl sPK) -!setIA primR. +without loss r_pr: / prime #|R|; last set r := #|R| in r_pr. + have [-> _ | [r r_pr]] := trivgVpdiv R; first by rewrite commG1 sub1G. + case/Cauchy=> // x; rewrite -cycle_subG subEproper orderE; set X := <[x]>. + case/predU1P=> [-> -> -> // | ltXR rX _]; have sXR := proper_sub ltXR. + have defCX: 'C_K(X) = 'C_K(R). + rewrite cent_cycle primR // !inE -order_gt1 orderE rX prime_gt1 //=. + by rewrite -cycle_subG. + have primX: semiprime K X. + by move=> y; case/setD1P=> nty Xy; rewrite primR // !inE nty (subsetP sXR). + have nKX := subset_trans sXR nKR; have coKX := coprimegS sXR coKR. + pose H := K <*> X; have defH: K ><| X = H by rewrite sdprodEY ?coprime_TIg. + have sHG: H \subset G by rewrite /H -defKR norm_joinEr ?mulgSS. + have ltHn: #|H| < n. + rewrite (leq_trans _ leGn) /H ?norm_joinEr // -defKR !coprime_cardMg //. + by rewrite ltn_pmul2l ?proper_card. + have oddH := oddSg sHG oddG; have solH := solvableS sHG solG. + have regX_F: 'C_('F(K))(X) = 1. + by rewrite -regR_F -(setIidPl sFK) -!setIA defCX. + have:= IHn _ ltHn _ _ defH oddH solH coKX primX regX_F. + rewrite -!quotient_cents2 ?(subset_trans sXR) //; move/setIidPl <-. + rewrite -coprime_quotient_cent ?(subset_trans sXR) // defCX. + by rewrite coprime_quotient_cent ?subsetIr. +apply: subset_trans (chief_stab_sub_Fitting solG nsKG) => //. +rewrite subsetI commg_subl nKR; apply/bigcapsP => [[U V]] /=. +case/andP=> chiefUV sUF; set W := U / V. +have minW := chief_factor_minnormal chiefUV. +have [ntW nWG] := andP (mingroupp minW). +have /andP[/maxgroupp/andP[/andP[sVU _] nVG] nsUG] := chiefUV. +have sUK := subset_trans sUF sFK; have sVK := subset_trans sVU sUK. +have nVK := subset_trans sKG nVG; have nVR := subset_trans sRG nVG. +have [q q_pr abelW]: exists2 q, prime q & q.-abelem W. + apply/is_abelemP; apply: charsimple_solvable (minnormal_charsimple minW) _. + by rewrite quotient_sol // (solvableS sUK). +have regR_W: 'C_(W)(R / V) = 1. + rewrite -coprime_quotient_cent ?(coprimeSg sUK) ?(solvableS sUK) //. + by rewrite -(setIidPl sUF) -setIA regR_F (setIidPr _) ?quotient1 ?sub1G. +rewrite sub_astabQ comm_subG ?quotientR //=. +have defGv: (K / V) * (R / V) = G / V by rewrite -defKR quotientMl. +have oRv: #|R / V| = r. + rewrite card_quotient // -indexgI -(setIidPr sVK) setICA setIA tiKR. + by rewrite (setIidPl (sub1G _)) indexg1. +have defCW: 'C_(G / V)(W) = 'C_(K / V)(W). + apply/eqP; rewrite eqEsubset andbC setSI ?quotientS //=. + rewrite subsetI subsetIr /= andbT. + rewrite -(coprime_mulG_setI_norm defGv) ?coprime_morph ?norms_cent //=. + suffices ->: 'C_(R / V)(W) = 1 by rewrite mulg1 subsetIl. + apply/trivgP; apply/subsetP=> x; case/setIP=> Rx cWx. + apply: contraR ntW => ntx; rewrite -subG1 -regR_W subsetI subxx centsC /= -/W. + by apply: contraR ntx; move/prime_TIg <-; rewrite ?oRv // inE Rx. +have [P sylP nPR] := coprime_Hall_exists p nKR coKR solK. +have [sPK pP _] := and3P sylP. +have nVP := subset_trans sPK nVK; have nFP := subset_trans sPK nFK. +have sylPv: p.-Sylow(K / V) (P / V) by rewrite quotient_pHall. +have defKv: (P / V) * 'C_(G / V)(W) = (K / V). + rewrite defCW; apply/eqP; rewrite eqEsubset mulG_subG subsetIl quotientS //=. + have sK_PF: K \subset P * 'F(K). + rewrite (normC nFP) -quotientSK // subEproper eq_sym eqEcard quotientS //=. + by rewrite (card_Hall (quotient_pHall nFP sylP)) part_pnat_id ?leqnn. + rewrite (subset_trans (quotientS _ sK_PF)) // quotientMl // mulgS //. + rewrite subsetI -quotient_astabQ !quotientS //. + by rewrite (subset_trans (Fitting_stab_chief solG nsKG)) ?(bigcap_inf (U, V)). +have nW_ := subset_trans (quotientS _ _) nWG; have nWK := nW_ _ sKG. +rewrite -quotient_cents2 ?norms_cent ?(nW_ _ sRG) //. +have [eq_qp | p'q] := eqVneq q p. + apply: subset_trans (sub1G _); rewrite -trivg_quotient quotientS // centsC. + apply/setIidPl; case/mingroupP: minW => _; apply; last exact: subsetIl. + rewrite andbC normsI ?norms_cent // ?quotient_norms //=. + have nsWK: W <| K / V by rewrite /normal quotientS. + have sWP: W \subset P / V. + by rewrite (normal_sub_max_pgroup (Hall_max sylPv)) -?eq_qp ?abelem_pgroup. + rewrite -defKv centM setIA setIAC /=. + rewrite ['C_W(_)](setIidPl _); last by rewrite centsC subsetIr. + have nilPv: nilpotent (P / V) := pgroup_nil (pHall_pgroup sylPv). + rewrite -/W -(setIidPl sWP) -setIA meet_center_nil //. + exact: normalS (quotientS V sPK) nsWK. +rewrite -defKv -quotientMidr -mulgA mulSGid ?subsetIr // quotientMidr. +have sPG := subset_trans sPK sKG. +rewrite quotient_cents2 ?norms_cent ?nW_ //= commGC. +pose Hv := (P / V) <*> (R / V). +have sHGv: Hv \subset G / V by rewrite join_subG !quotientS. +have solHv: solvable Hv := solvableS sHGv (quotient_sol V solG). +have sPHv: P / V \subset Hv by exact: joing_subl. +have nPRv: R / V \subset 'N(P / V) := quotient_norms _ nPR. +have coPRv: coprime #|P / V| #|R / V| := coprime_morph _ (coprimeSg sPK coKR). +apply: subset_trans (subsetIr (P / V) _). +have oHv: #|Hv| = (#|P / V| * #|R / V|)%N. + by rewrite /Hv norm_joinEr // coprime_cardMg // oRv. +move/(odd_prime_sdprod_abelem_cent1 solHv): (abelW); apply=> //. +- exact: oddSg sHGv (quotient_odd _ _). +- by rewrite sdprodEY ?quotient_norms // coprime_TIg. +- by rewrite oRv. +- by rewrite (subset_trans _ nWG) ?join_subG ?quotientS. +rewrite /= norm_joinEr // pgroupM /pgroup. +rewrite (pi_pnat (quotient_pgroup _ pP)) ?inE 1?eq_sym //=. +apply: coprime_p'group (abelem_pgroup abelW) ntW. +by rewrite coprime_sym coprime_morph // (coprimeSg sUK). +Qed. + +(* This is B & G, Proposition 3.9 (for external action), with the incorrectly *) +(* omitted nontriviality assumption reinstated. *) +Proposition ext_odd_regular_pgroup_cyclic (aT rT : finGroupType) p + (D R : {group aT}) (K H : {group rT}) (to : groupAction D K) : + p.-group R -> odd #|R| -> H :!=: 1 -> + {acts R, on group H | to} -> {in R^#, forall x, 'C_(H | to)[x] = 1} -> + cyclic R. +Proof. +move: R H => R0 H0 pR0 oddR0 ntH0 actsR0 regR0. +pose gT := sdprod_groupType <[actsR0]>. +pose H : {group gT} := (sdpair1 <[actsR0]> @* H0)%G. +pose R : {group gT} := (sdpair2 <[actsR0]> @* R0)%G. +pose G : {group gT} := [set: gT]%G. +have{pR0} pR: p.-group R by rewrite morphim_pgroup. +have{oddR0} oddR: odd #|R| by rewrite morphim_odd. +have [R1 | ntR] := eqsVneq R 1. + by rewrite -(im_invm (injm_sdpair2 <[actsR0]>)) {2}R1 morphim1 cyclic1. +have{ntH0} ntH: H :!=: 1. + apply: contraNneq ntH0 => H1. + by rewrite -(im_invm (injm_sdpair1 <[actsR0]>)) {2}H1 morphim1. +have{regR0 ntR} frobG: [Frobenius G = H ><| R]. + apply/Frobenius_semiregularP => // [|x]; first exact: sdprod_sdpair. + case/setD1P=> nt_x; case/morphimP=> x2 _ Rx2 def_x. + apply/trivgP; rewrite -(morphpreSK _ (subsetIl _ _)) morphpreI. + rewrite /= -cent_cycle def_x -morphim_cycle // -gacentEsd. + rewrite injmK ?injm_sdpair1 // (trivgP (injm_sdpair1 _)). + rewrite -(regR0 x2) ?inE ?Rx2 ?andbT; last first. + by apply: contra nt_x; rewrite def_x; move/eqP->; rewrite morph1. + have [sRD sHK]: R0 \subset D /\ H0 \subset K by case actsR0; move/acts_dom. + have sx2R: <[x2]> \subset R0 by rewrite cycle_subG. + rewrite gacent_actby setIA setIid (setIidPr sx2R). + rewrite !gacentE ?cycle_subG ?sub1set ?(subsetP sRD) //. + by rewrite !setIS ?afixS ?sub_gen. +suffices: cyclic R by rewrite (injm_cyclic (injm_sdpair2 _)). +move: gT H R G => {aT rT to D K H0 R0 actsR0} gT H R G in ntH pR oddR frobG *. +have [defG _ _ _ _] := Frobenius_context frobG; case/sdprodP: defG => _ _ nHR _. +have coHR := Frobenius_coprime frobG. +rewrite (odd_pgroup_rank1_cyclic pR oddR) leqNgt. +apply: contra ntH => /p_rank_geP[E /pnElemP[sER abelE dimE2]]. +have ncycE: ~~ cyclic E by rewrite (abelem_cyclic abelE) dimE2. +have nHE := subset_trans sER nHR; have coHE := coprimegS sER coHR. +rewrite -subG1 -(coprime_abelian_gen_cent1 _ _ nHE) ?(abelem_abelian abelE) //. +rewrite -bigprodGE big1 // => x /setD1P[nt_x Ex]; apply: val_inj => /=. +by apply: (Frobenius_reg_ker frobG); rewrite !inE nt_x (subsetP sER). +Qed. + +(* Internal action version of B & G, Proposition 3.9 (possibly, the only one *) +(* we should keep). *) +Proposition odd_regular_pgroup_cyclic gT p (H R : {group gT}) : + p.-group R -> odd #|R| -> H :!=: 1 -> R \subset 'N(H) -> semiregular H R -> + cyclic R. +Proof. +move=> pR oddR ntH nHR regR. +have actsR: {acts R, on group H | 'J} by split; rewrite ?subsetT ?astabsJ. +apply: ext_odd_regular_pgroup_cyclic pR oddR ntH actsR _ => // x Rx. +by rewrite gacentJ cent_set1 regR. +Qed. + +(* Another proof of Proposition 3.9, which avoids Frobenius groups entirely. *) +Proposition simple_odd_regular_pgroup_cyclic gT p (H R : {group gT}) : + p.-group R -> odd #|R| -> H :!=: 1 -> R \subset 'N(H) -> semiregular H R -> + cyclic R. +Proof. +move=> pR oddR ntH nHR regR; rewrite (odd_pgroup_rank1_cyclic pR oddR) leqNgt. +apply: contra ntH => /p_rank_geP[E /pnElemP[sER abelE dimE2]]. +have ncycE: ~~ cyclic E by rewrite (abelem_cyclic abelE) dimE2. +have nHE := subset_trans sER nHR. +have coHE := coprimegS sER (regular_norm_coprime nHR regR). +rewrite -subG1 -(coprime_abelian_gen_cent1 _ _ nHE) ?(abelem_abelian abelE) //. +rewrite -bigprodGE big1 // => x; case/setD1P=> nt_x Ex; apply: val_inj => /=. +by rewrite regR // !inE nt_x (subsetP sER). +Qed. + +(* This is Aschbacher (40.6)(4). *) +Lemma odd_regular_metacyclic gT (H R : {group gT}) : + odd #|R| -> H :!=: 1 -> R \subset 'N(H) -> semiregular H R -> + metacyclic R. +Proof. +move=> oddR ntH nHR regHR. +apply/Zgroup_metacyclic/forall_inP=> P /SylowP[p pr_p /and3P[sPR pP _]]. +have [oddP nHP] := (oddSg sPR oddR, subset_trans sPR nHR). +exact: odd_regular_pgroup_cyclic pP oddP ntH nHP (semiregularS _ sPR regHR). +Qed. + +(* This is Huppert, Kapitel V, Satz 18.8 b (used in Peterfalvi, Section 13). *) +Lemma prime_odd_regular_normal gT (H R P : {group gT}) : + prime #|P| -> odd #|R| -> P \subset R -> + H :!=: 1 -> R \subset 'N(H) -> semiregular H R -> + P <| R. +Proof. +set p := #|P| => pr_p oddR sPR ntH nHR regHR. +have pP: p.-group P := pnat_id pr_p. +have cycQ (q : nat) (Q : {group gT}) : q.-group Q -> Q \subset R -> cyclic Q. + move=> qQ sQR; have [oddQ nHQ] := (oddSg sQR oddR, subset_trans sQR nHR). + exact: odd_regular_pgroup_cyclic qQ oddQ ntH nHQ (semiregularS _ sQR regHR). +have cycRq (q : nat): cyclic 'O_q(R) by rewrite (cycQ q) ?pcore_pgroup ?gFsub. +suffices cFP: P \subset 'C('F(R)). + have nilF: nilpotent 'F(R) := Fitting_nil R. + have hallRp: p.-Hall('F(R)) 'O_p('F(R)) := nilpotent_pcore_Hall p nilF. + apply: char_normal_trans (pcore_normal p R); rewrite sub_cyclic_char //=. + rewrite -p_core_Fitting (sub_normal_Hall hallRp) ?gFnormal //. + have solR: solvable R. + by apply: metacyclic_sol; apply: odd_regular_metacyclic regHR. + by apply: subset_trans (cent_sub_Fitting solR); rewrite subsetI sPR. +rewrite centsC -(bigdprodWY (erefl 'F(R))) gen_subG big_tnth. +apply/bigcupsP=> i _; move: {i}(tuple.tnth _ i) => q. +have [<- | q'p] := eqVneq p q. + have [Q sylQ sPQ] := Sylow_superset sPR pP; have [sQR pQ _] := and3P sylQ. + rewrite (sub_abelian_cent2 (cyclic_abelian (cycQ _ _ pQ sQR))) //. + by rewrite pcore_sub_Hall. +have [-> | ntRq] := eqVneq 'O_q(R) 1%g; first exact: sub1G. +have /andP[sRqR qRq]: q.-subgroup(R) 'O_q(R) by apply: pcore_psubgroup. +have [pr_q _ _] := pgroup_pdiv qRq ntRq. +have coRqP: coprime #|'O_q(R)| p by rewrite (pnat_coprime qRq) // pnatE. +have nRqP: P \subset 'N('O_q(R)) by rewrite (subset_trans sPR) ?gFnorm. +rewrite centsC (coprime_odd_faithful_Ohm1 qRq) ?(oddSg sRqR) //. +apply: sub_abelian_cent2 (joing_subl _ _) (joing_subr _ _) => /=. +set PQ := P <*> _; have oPQ: #|PQ| = (p * q)%N. + rewrite /PQ norm_joinEl ?(char_norm_trans (Ohm_char 1 _)) //. + rewrite coprime_cardMg 1?coprime_sym ?(coprimeSg (Ohm_sub 1 _)) // -/p. + by congr (p * _)%N; apply: Ohm1_cyclic_pgroup_prime => /=. +have sPQ_R: PQ \subset R by rewrite join_subG sPR (subset_trans (Ohm_sub 1 _)). +have nH_PQ := subset_trans sPQ_R nHR. +apply: cyclic_abelian; apply: regular_pq_group_cyclic oPQ ntH nH_PQ _ => //. +exact: semiregularS regHR. +Qed. + +Section Wielandt_Frobenius. + +Variables (gT : finGroupType) (G K R : {group gT}). +Implicit Type A : {group gT}. + +(* This is Peterfalvi (9.1). *) +Lemma Frobenius_Wielandt_fixpoint (M : {group gT}) : + [Frobenius G = K ><| R] -> + G \subset 'N(M) -> coprime #|M| #|G| -> solvable M -> + [/\ (#|'C_M(G)| ^ #|R| * #|M| = #|'C_M(R)| ^ #|R| * #|'C_M(K)|)%N, + 'C_M(R) = 1 -> K \subset 'C(M) + & 'C_M(K) = 1 -> (#|M| = #|'C_M(R)| ^ #|R|)%N]. +Proof. +move=> frobG nMG coMG solM; have [defG _ ntR _ _] := Frobenius_context frobG. +have [_ _ _ _ /eqP snRG] := and5P frobG. +have [nsKG sRG _ _ tiKR] := sdprod_context defG; have [sKG _] := andP nsKG. +pose m0 (_ : {group gT}) := 0%N. +pose Dm := [set 1%G; G]; pose Dn := K |: orbit 'JG K R. +pose m := [fun A => 0%N with 1%G |-> #|K|, G |-> 1%N]. +pose n A : nat := A \in Dn. +have out_m: {in [predC Dm], m =1 m0}. + by move=> A; rewrite !inE /=; case/norP; do 2!move/negbTE->. +have out_n: {in [predC Dn], n =1 m0}. + by rewrite /n => A /=; move/negbTE=> /= ->. +have ntG: G != 1%G by case: eqP sRG => // -> <-; rewrite subG1. +have neqKR: K \notin orbit 'JG K R. + apply/imsetP=> [[x _ defK]]; have:= Frobenius_dvd_ker1 frobG. + by rewrite defK cardJg gtnNdvd // ?prednK // -subn1 subn_gt0 cardG_gt1. +have Gmn A: m A + n A > 0 -> A \subset G. + rewrite /=; case: eqP => [-> | ] _; first by rewrite sub1G. + rewrite /n 2!inE; do 2!case: eqP => [-> // | ] _. + case R_A: (A \in _) => // _; case/imsetP: R_A => x Kx ->{A}. + by rewrite conj_subG ?(subsetP sKG). +have partG: {in G, forall a, + \sum_(A | a \in gval A) m A = \sum_(A | a \in gval A) n A}%N. +- move=> a Ga; have [-> | nt_a] := eqVneq a 1. + rewrite (bigD1 1%G) ?inE ?eqxx //= (bigD1 G) ?inE ?group1 //=. + rewrite (negbTE ntG) !eqxx big1 ?addn1 => [|A]; last first. + by rewrite group1 -negb_or -in_set2; apply: out_m. + rewrite (bigID (mem Dn)) /= addnC big1 => [|A]; last first. + by rewrite group1; apply: out_n. + transitivity #|Dn|. + rewrite cardsU1 neqKR card_orbit astab1JG. + by rewrite -{3}(setIidPl sKG) -setIA -normD1 snRG tiKR indexg1. + by rewrite -sum1_card /n; apply: eq_big => [A | A ->]; rewrite ?group1. + rewrite (bigD1 G) //= (negbTE ntG) eqxx big1 => [|A]; last first. + case/andP=> Aa neAG; apply: out_m; rewrite !inE; case: eqP => // A1. + by rewrite A1 inE (negbTE nt_a) in Aa. + have [partG tiG _] := and3P (Frobenius_partition frobG). + do [rewrite -(eqP partG); set pG := _ |: _] in Ga tiG. + rewrite (bigD1 <>%G) /=; last by rewrite mem_gen // mem_pblock. + rewrite big1 => [|B]; last first. + case/andP=> Ba neqBA; rewrite -/(false : nat); congr (nat_of_bool _). + apply: contraTF neqBA; rewrite negbK -val_eqE /=. + case/setU1P=> [BK | /imsetP[x Kx defB]]. + by rewrite (def_pblock tiG _ Ba) BK ?setU11 ?genGid. + have Rxa: a \in R^# :^ x by rewrite conjD1g !inE nt_a -(congr_group defB). + rewrite (def_pblock tiG _ Rxa) ?setU1r ?mem_imset // conjD1g. + by rewrite genD1 ?group1 // genGid defB. + rewrite /n !inE -val_eqE /= -/(true : nat); congr ((_ : bool) + _)%N. + case/setU1P: (pblock_mem Ga) => [-> |]; first by rewrite genGid eqxx. + case/imsetP=> x Kx ->; symmetry; apply/orP; right. + apply/imsetP; exists x => //. + by apply: val_inj; rewrite conjD1g /= genD1 ?group1 // genGid. +move/eqP: (solvable_Wielandt_fixpoint Gmn nMG coMG solM partG). +rewrite (bigD1 1%G) // (bigD1 G) //= eqxx (setIidPl (cents1 _)) cards1 muln1. +rewrite (negbTE ntG) eqxx mul1n -(sdprod_card defG) (mulnC #|K|) expnM. +rewrite mulnA -expnMn big1 ?muln1 => [|A]; last first. + by rewrite -negb_or -in_set2; move/out_m; rewrite /m => /= ->. +rewrite mulnC eq_sym (bigID (mem Dn)) /= mulnC. +rewrite big1 ?mul1n => [|A]; last by move/out_n->. +rewrite big_setU1 //= /n setU11 mul1n. +rewrite (eq_bigr (fun _ => #|'C_M(R)| ^ #|R|)%N) => [|A R_A]; last first. + rewrite inE R_A orbT mul1n; case/imsetP: R_A => x Kx ->. + suffices nMx: x \in 'N(M) by rewrite -{1}(normP nMx) centJ -conjIg !cardJg. + exact: subsetP (subsetP sKG x Kx). +rewrite mulnC prod_nat_const card_orbit astab1JG. +have ->: 'N_K(R) = 1 by rewrite -(setIidPl sKG) -setIA -normD1 snRG tiKR. +rewrite indexg1 -expnMn eq_sym eqn_exp2r ?cardG_gt0 //; move/eqP=> eq_fix. +split=> // [regR | regK]. + rewrite centsC (sameP setIidPl eqP) eqEcard subsetIl /=. + move: eq_fix; rewrite regR cards1 exp1n mul1n => <-. + suffices ->: 'C_M(G) = 1 by rewrite cards1 exp1n mul1n. + by apply/trivgP; rewrite -regR setIS ?centS //; case/sdprod_context: defG. +move: eq_fix; rewrite regK cards1 muln1 => <-. +suffices ->: 'C_M(G) = 1 by rewrite cards1 exp1n mul1n. +by apply/trivgP; rewrite -regK setIS ?centS. +Qed. + +End Wielandt_Frobenius. + +(* This is B & G, Theorem 3.10. *) +Theorem Frobenius_primact gT (G K R M : {group gT}) : + [Frobenius G = K ><| R] -> solvable G -> + G \subset 'N(M) -> solvable M -> M :!=: 1 -> + (*1*) coprime #|M| #|G| -> + (*2*) semiprime M R -> + (*3*) 'C_M(K) = 1 -> + [/\ prime #|R|, + #|M| = (#|'C_M(R)| ^ #|R|)%N + & cyclic 'C_M(R) -> K^`(1) \subset 'C_K(M)]. +Proof. +move: {2}_.+1 (ltnSn #|M|) => n; elim: n => // n IHn in gT G K R M *. +rewrite ltnS => leMn frobG solG nMG solM ntM coMG primRM tcKM. +case: (Frobenius_Wielandt_fixpoint frobG nMG) => // _ _ /(_ tcKM) oM. +have [defG ntK ntR ltKG _]:= Frobenius_context frobG. +have Rpr: prime #|R|. + have [R1 | [r r_pr]] := trivgVpdiv R; first by case/eqP: ntR. + case/Cauchy=> // x Rx ox; pose R0 := <[x]>; pose G0 := K <*> R0. + have [_ defKR nKR tiKR] := sdprodP defG. + have sR0R: R0 \subset R by rewrite cycle_subG. + have sG0G: G0 \subset G by rewrite /G0 -genM_join gen_subG -defKR mulgS. + have nKR0 := subset_trans sR0R nKR; have nMG0 := subset_trans sG0G nMG. + have ntx: <[x]> != 1 by rewrite cycle_eq1 -order_gt1 ox prime_gt1. + have [tcRM | ntcRM] := eqVneq 'C_M(R) 1. + by rewrite -cardG_gt1 oM tcRM cards1 exp1n in ntM. + have frobG0: [Frobenius G0 = K ><| R0]. + apply/Frobenius_semiregularP=> // [|y /setD1P[nty x_y]]. + by apply: sdprodEY nKR0 (trivgP _); rewrite -tiKR setIS. + by apply: (Frobenius_reg_ker frobG); rewrite !inE nty (subsetP sR0R). + case: (Frobenius_Wielandt_fixpoint frobG0 nMG0 (coprimegS _ coMG)) => // _ _. + move/(_ tcKM)/eqP; rewrite oM cent_cycle. + rewrite primRM; last by rewrite !inE Rx andbT -cycle_eq1. + by rewrite eqn_exp2l ?cardG_gt1 // -orderE ox => /eqP->. +split=> // cyc_cMR. +have nM_MG: M <*> G \subset 'N(M) by rewrite join_subG normG. +have [V minV sVM] := minnormal_exists ntM nM_MG. +have [] := minnormal_solvable minV sVM solM. +rewrite join_subG; case/andP=> nVM nVG ntV; case/is_abelemP=> [q q_pr abelV]. +have coVG := coprimeSg sVM coMG; have solV := solvableS sVM solM. +have cVK': K^`(1) \subset 'C_K(V). + case: (eqVneq 'C_V(R) 1) => [tcVR | ntcRV]. + case: (Frobenius_Wielandt_fixpoint frobG nVG) => // _. + by move/(_ tcVR)=> cVK _; rewrite (setIidPl cVK) der_sub. + have ocVR: #|'C_V(R)| = q. + have [u def_u]: exists u, 'C_V(R) = <[u]>. + by apply/cyclicP; apply: cyclicS (setSI _ sVM) cyc_cMR. + rewrite def_u -orderE (abelem_order_p abelV) -?cycle_eq1 -?def_u //. + by rewrite -cycle_subG -def_u subsetIl. + apply: (Frobenius_prime_cent_prime _ defG _ _ abelV) => //. + by case/prime_FrobeniusP: frobG. + by rewrite (coprime_p'group _ (abelem_pgroup abelV) ntV) // coprime_sym. +have cMK': K^`(1) / V \subset 'C_(K / V)(M / V). + have [-> | ntMV] := eqVneq (M / V) 1. + by rewrite subsetI cents1 quotientS ?der_sub. + have coKR := Frobenius_coprime frobG. + case/prime_FrobeniusP: frobG => //. + case/sdprod_context=> nsKG sRG defKR nKR tiKR regR; have [sKG _] := andP nsKG. + have nVK := subset_trans sKG nVG; have nVR := subset_trans sRG nVG. + have RVpr: prime #|R / V|. + rewrite card_quotient // -indexgI setIC coprime_TIg ?(coprimegS sRG) //. + by rewrite indexg1. + have frobGV: [Frobenius G / V = (K / V) ><| (R / V)]. + apply/prime_FrobeniusP; rewrite // -?cardG_gt1 ?card_quotient //. + rewrite -indexgI setIC coprime_TIg ?(coprimegS sKG) //. + by rewrite indexg1 cardG_gt1. + rewrite -coprime_norm_quotient_cent ?(coprimegS sRG) //= regR quotient1. + rewrite -defKR quotientMl // sdprodE ?quotient_norms //. + by rewrite coprime_TIg ?coprime_morph. + have ltMVn: #|M / V| < n by apply: leq_trans leMn; rewrite ltn_quotient. + rewrite quotient_der //; move/IHn: frobGV. + case/(_ _ ltMVn); rewrite ?quotient_sol ?quotient_norms ?coprime_morph //. + - move=> Vx; case/setD1P=> ntVx; case/morphimP=> x nVx Rx defVx. + rewrite defVx /= -cent_cycle -quotient_cycle //; congr 'C__(_ / V). + apply/eqP; rewrite eqEsubset cycle_subG Rx /=. + apply: contraR ntVx; move/(prime_TIg Rpr); move/trivgP. + rewrite defVx /= (setIidPr _) cycle_subG //; move/set1P->. + by rewrite morph1. + - rewrite -coprime_norm_quotient_cent ?(coprimegS sKG) ?(subset_trans sKG) //. + by rewrite tcKM quotient1. + move=> _ _ -> //; rewrite -coprime_quotient_cent ?quotient_cyclic //. + by rewrite (coprimegS sRG). +rewrite !subsetI in cVK' cMK' *. +case/andP: cVK' => sK'K cVK'; case/andP: cMK' => _ cMVK'; rewrite sK'K. +have sK'G: K^`(1) \subset G by rewrite (subset_trans sK'K) ?proper_sub. +have coMK': coprime #|M| #|K^`(1)| := coprimegS sK'G coMG. +rewrite (stable_factor_cent cVK') // /stable_factor /normal sVM nVM !andbT. +by rewrite commGC -quotient_cents2 // (subset_trans sK'G). +Qed. + +End BGsection3. diff --git a/mathcomp/odd_order/BGsection4.v b/mathcomp/odd_order/BGsection4.v new file mode 100644 index 0000000..c33bd2f --- /dev/null +++ b/mathcomp/odd_order/BGsection4.v @@ -0,0 +1,1413 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div. +Require Import fintype finfun bigop ssralg finset prime binomial. +Require Import fingroup morphism automorphism perm quotient action gproduct. +Require Import gfunctor commutator zmodp cyclic center pgroup gseries nilpotent. +Require Import sylow abelian maximal extremal hall. +Require Import matrix mxalgebra mxrepresentation mxabelem. +Require Import BGsection1 BGsection2. + +(******************************************************************************) +(* This file covers B & G, Section 4, i.e., the proof of structure theorems *) +(* for solvable groups with a small (of rank at most 2) Fitting subgroup. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section Section4. + +Implicit Type gT : finGroupType. +Implicit Type p : nat. + +(* B & G, Lemma 4.1 (also, Gorenstein, 1.3.4, and Aschbacher, ex. 2.4) is *) +(* covered by Lemma center_cyclic_abelian, in center.v. *) + +(* B & G, Lemma 4.2 is covered by Lemmas commXg, commgX, commXXg (for 4.2(a)) *) +(* and expMg_Rmul (for 4.2(b)) in commutators.v. *) + +(* This is B & G, Proposition 4.3. *) +Proposition exponent_odd_nil23 gT (R : {group gT}) p : + p.-group R -> odd #|R| -> nil_class R <= 2 + (p > 3) -> + [/\ (*a*) exponent 'Ohm_1(R) %| p + & (*b*) R^`(1) \subset 'Ohm_1(R) -> + {in R &, {morph expgn^~ p : x y / x * y}}]. +Proof. +move=> pR oddR classR. +pose f n := 'C(n, 3); pose g n := 'C(n, 3).*2 + 'C(n, 2). +have fS n: f n.+1 = 'C(n, 2) + f n by rewrite /f binS addnC. +have gS n: g n.+1 = 'C(n, 2).*2 + 'C(n, 1) + g n. + by rewrite /g !binS doubleD -!addnA; do 3!nat_congr. +have [-> | ntR] := eqsVneq R 1. + rewrite Ohm1 exponent1 der_sub dvd1n; split=> // _ _ _ /set1P-> /set1P->. + by rewrite !(mulg1, expg1n). +have{ntR} [p_pr p_dv_R _] := pgroup_pdiv pR ntR. +have pdivbin2: p %| 'C(p, 2). + by rewrite prime_dvd_bin //= odd_prime_gt2 // (dvdn_odd p_dv_R). +have p_dv_fp: p > 3 -> p %| f p by move=> pgt3; apply: prime_dvd_bin. +have p_dv_gp: p > 3 -> p %| g p. + by move=> pgt3; rewrite dvdn_add // -muln2 dvdn_mulr // p_dv_fp. +have exp_dv_p x m (S : {group gT}): + exponent S %| p -> p %| m -> x \in S -> x ^+ m = 1. +- move=> expSp p_dv_m Sx; apply/eqP; rewrite -order_dvdn. + by apply: dvdn_trans (dvdn_trans expSp p_dv_m); apply: dvdn_exponent. +have p3_L21: p <= 3 -> {in R & &, forall u v w, [~ u, v, w] = 1}. + move=> lep3 u v w Ru Rv Rw; rewrite (ltnNge 3) lep3 nil_class2 in classR. + by apply/eqP/commgP; red; rewrite (centerC Rw) // (subsetP classR) ?mem_commg. +have{fS gS} expMR_fg: {in R &, forall u v n (r := [~ v, u]), + (u * v) ^+ n = u ^+ n * v ^+ n * r ^+ 'C(n, 2) + * [~ r, u] ^+ f n * [~ r, v] ^+ g n}. +- move=> u v Ru Rv n r; have Rr: r \in R by exact: groupR. + have cRr: {in R &, forall x y, commute x [~ r, y]}. + move=> x y Rx Ry /=; red; rewrite (centerC Rx) //. + have: [~ r, y] \in 'L_3(R) by rewrite !mem_commg. + by apply: subsetP; rewrite -nil_class3 (leq_trans classR) // !ltnS leq_b1. + elim: n => [|n IHn]; first by rewrite !mulg1. + rewrite 3!expgSr {}IHn -!mulgA (mulgA (_ ^+ f n)); congr (_ * _). + rewrite -commuteM; try by apply: commuteX; red; rewrite cRr ?groupM. + rewrite -mulgA; do 2!rewrite (mulgA _ u) (commgC _ u) -2!mulgA. + congr (_ * (_ * _)); rewrite (mulgA _ v). + have ->: [~ v ^+ n, u] = r ^+ n * [~ r, v] ^+ 'C(n, 2). + elim: n => [|n IHn]; first by rewrite comm1g mulg1. + rewrite !expgS commMgR -/r {}IHn commgX; last exact: cRr. + rewrite binS bin1 addnC expgD -2!mulgA; congr (_ * _); rewrite 2!mulgA. + by rewrite commuteX2 // /commute cRr. + rewrite commXg 1?commuteX2 -?[_ * v]commuteX; try exact: cRr. + rewrite mulgA {1}[mulg]lock mulgA -mulgA -(mulgA v) -!expgD -fS -lock. + rewrite -{2}(bin1 n) addnC -binS -2!mulgA (mulgA _ v) (commgC _ v). + rewrite -commuteX; last by red; rewrite cRr ?(Rr, groupR, groupX, groupM). + rewrite -3!mulgA; congr (_ * (_ * _)); rewrite 2!mulgA. + rewrite commXg 1?commuteX2; try by red; rewrite cRr 1?groupR. + by rewrite -!mulgA -!expgD addnCA binS addnAC addnn addnC -gS. +have expR1p: exponent 'Ohm_1(R) %| p. + elim: _.+1 {-2 4}R (ltnSn #|R|) (subxx R) => // n IHn Q leQn sQR. + rewrite (OhmE 1 (pgroupS sQR pR)) expn1 -sub_LdivT. + rewrite gen_set_id ?subsetIr //. + apply/group_setP; rewrite !inE group1 expg1n /=. + split=> // x y /LdivP[Qx xp1] /LdivP[Qy yp1]; rewrite !inE groupM //=. + have sxQ: <[x]> \subset Q by rewrite cycle_subG. + have [{sxQ}defQ|[S maxS /= sxS]] := maximal_exists sxQ. + rewrite expgMn; first by rewrite xp1 yp1 mulg1. + by apply: (centsP (cycle_abelian x)); rewrite ?defQ. + have:= maxgroupp maxS; rewrite properEcard => /andP[sSQ ltSQ]. + have pQ := pgroupS sQR pR; have pS := pgroupS sSQ pQ. + have{ltSQ leQn} ltSn: #|S| < n by exact: leq_trans ltSQ _. + have expS1p := IHn _ ltSn (subset_trans sSQ sQR). + have defS1 := Ohm1Eexponent p_pr expS1p; move/exp_dv_p: expS1p => expS1p. + have nS1Q: [~: Q, 'Ohm_1(S)] \subset 'Ohm_1(S). + rewrite commg_subr (char_norm_trans (Ohm_char 1 S)) ?normal_norm //. + exact: p_maximal_normal pQ maxS. + have S1x : x \in 'Ohm_1(S) by rewrite defS1 !inE -cycle_subG sxS xp1 /=. + have S1yx : [~ y, x] \in 'Ohm_1(S) by rewrite (subsetP nS1Q) ?mem_commg. + have S1yxx : [~ y, x, x] \in 'Ohm_1(S) by rewrite groupR. + have S1yxy : [~ y, x, y] \in 'Ohm_1(S). + by rewrite -invg_comm groupV (subsetP nS1Q) 1?mem_commg. + rewrite expMR_fg ?(subsetP sQR) //= xp1 yp1 expS1p ?mul1g //. + case: (leqP p 3) => [p_le3 | p_gt3]; last by rewrite ?expS1p ?mul1g; auto. + by rewrite !p3_L21 // ?(subsetP sQR) // !expg1n mulg1. +split=> // sR'R1 x y Rx Ry; rewrite -[x ^+ p * _]mulg1 expMR_fg // -2!mulgA //. +have expR'p := exp_dv_p _ _ _ (dvdn_trans (exponentS sR'R1) expR1p). +congr (_ * _); rewrite expR'p ?mem_commg // mul1g. +case: (leqP p 3) => [p_le3 | p_gt3]. + by rewrite !p3_L21 // ?(subsetP sQR) // !expg1n mulg1. +by rewrite !expR'p 1?mem_commg ?groupR ?mulg1; auto. +Qed. + +(* Part (a) of B & G, Proposition 4.4 is covered in file maximal.v by lemmas *) +(* max_SCN and SCN_max. *) + +(* This is B & G, Proposition 4.4(b), or Gorenstein 7.6.5. *) +Proposition SCN_Sylow_cent_dprod gT (R G A : {group gT}) p : + p.-Sylow(G) R -> A \in 'SCN(R) -> 'O_p^'('C_G(A)) \x A = 'C_G(A). +Proof. +move=> sylR scnA; have [[sRG _] [nAR CRA_A]] := (andP sylR, SCN_P scnA). +set C := 'C_G(A); have /maxgroupP[/andP[nAG abelA] maxA] := SCN_max scnA. +have CiP_eq : C :&: R = A by rewrite -CRA_A setIC setIA (setIidPl sRG). +have sylA: p.-Sylow(C) A. + rewrite -CiP_eq; apply: (Sylow_setI_normal (subcent_normal _ _)). + by apply: pHall_subl sylR; rewrite ?subsetIl // subsetI sRG normal_norm. +rewrite dprodEsd; last first. + by rewrite centsC (subset_trans (pcore_sub _ _)) ?subsetIr. +by apply: Burnside_normal_complement; rewrite // subIset ?subsetIr. +Qed. + +(* This is B & G, Lemma 4.5(b), or Gorenstein, 5.4.4 and 5.5.5. *) +Lemma Ohm1_extremal_odd gT (R : {group gT}) p x : + p.-group R -> odd #|R| -> ~~ cyclic R -> x \in R -> #|R : <[x]>| = p -> + ('Ohm_1(R))%G \in 'E_p^2(R). +Proof. +move=> pR oddR ncycR Rx ixR; rewrite -cycle_subG in Rx. +have ntR: R :!=: 1 by apply: contra ncycR; move/eqP->; exact: cyclic1. +have [p_pr _ [e oR]]:= pgroup_pdiv pR ntR. +case p2: (p == 2); first by rewrite oR odd_exp (eqP p2) in oddR. +have [cRR | not_cRR] := orP (orbN (abelian R)). + rewrite 2!inE Ohm_sub Ohm1_abelem // -p_rank_abelian //= eqn_leq. + rewrite -rank_pgroup // ltnNge -abelian_rank1_cyclic // ncycR andbT. + have maxX: maximal <[x]> R by rewrite (p_index_maximal Rx) ?ixR. + have nsXR: <[x]> <| R := p_maximal_normal pR maxX. + have [_ [y Ry notXy]] := properP (maxgroupp maxX). + have defR: <[x]> * <[y]> = R. + by apply: mulg_normal_maximal; rewrite ?cycle_subG. + rewrite -grank_abelian // -(genGid R) -defR genM_join joing_idl joing_idr. + by rewrite (leq_trans (grank_min _)) // cards2 ltnS leq_b1. +have{x Rx ixR} [e_gt1 isoR]: 2 < e.+1 /\ R \isog 'Mod_(p ^ e.+1). + have:= maximal_cycle_extremal pR not_cRR (cycle_cyclic x) Rx ixR. + rewrite p2 orbF /extremal_class oR pfactorKpdiv // pdiv_pfactor //. + by do 4!case: andP => //. +have [[x y] genR modR] := generators_modular_group p_pr e_gt1 isoR. +have [_ _ _ _] := modular_group_structure p_pr e_gt1 genR isoR modR. +rewrite xpair_eqE p2; case/(_ 1%N) => // _ oR1. +by rewrite 2!inE Ohm_sub oR1 pfactorK ?abelem_Ohm1 ?(card_p2group_abelian p_pr). +Qed. + +Section OddNonCyclic. + +Variables (gT : finGroupType) (p : nat) (R : {group gT}). +Hypotheses (pR : p.-group R) (oddR : odd #|R|) (ncycR : ~~ cyclic R). + +(* This is B & G, Lemma 4.5(a), or Gorenstein 5.4.10. *) +Lemma ex_odd_normal_p2Elem : {S : {group gT} | S <| R & S \in 'E_p^2(R)}. +Proof. +have [M minM]: {M | [min M | M <| R & ~~ cyclic M]}. + by apply: ex_mingroup; exists R; rewrite normal_refl. +have{minM} [[nsMR ncycM] [_ minM]] := (andP (mingroupp minM), mingroupP minM). +have [sMR _] := andP nsMR; have pM := pgroupS sMR pR. +exists ('Ohm_1(M))%G; first exact: char_normal_trans (Ohm_char 1 M) nsMR. +apply: (subsetP (pnElemS _ _ sMR)). +have [M1 | ntM] := eqsVneq M 1; first by rewrite M1 cyclic1 in ncycM. +have{ntM} [p_pr _ [e oM]] := pgroup_pdiv pM ntM. +have le_e_M: e <= logn p #|M| by rewrite ltnW // oM pfactorK. +have{le_e_M} [N [sNM nsNR] oN] := normal_pgroup pR nsMR le_e_M. +have ltNM: ~~ (#|N| >= #|M|) by rewrite -ltnNge oM oN ltn_exp2l ?prime_gt1. +have cycN : cyclic N by apply: contraR ltNM => ncycN; rewrite minM //= nsNR. +case/cyclicP: cycN => x defN; have Mx : x \in M by rewrite -cycle_subG -defN. +apply: Ohm1_extremal_odd Mx _; rewrite ?(oddSg sMR) //. +by rewrite -divgS /= -defN // oM oN expnS mulnK // expn_gt0 prime_gt0. +Qed. + +(* This is B & G, Lemma 4.5(c). *) +Lemma Ohm1_odd_ucn2 (Z := 'Ohm_1('Z_2(R))) : ~~ cyclic Z /\ exponent Z %| p. +Proof. +have [S nsSR Ep2S] := ex_odd_normal_p2Elem; have p_pr := pnElem_prime Ep2S. +have [sSR abelS dimS] := pnElemP Ep2S; have [pS cSS expSp]:= and3P abelS. +pose SR := [~: S, R]; pose SRR := [~: SR, R]. +have nilR := pgroup_nil pR. +have ntS: S :!=: 1 by rewrite -rank_gt0 (rank_abelem abelS) dimS. +have sSR_S: SR \subset S by rewrite commg_subl normal_norm. +have sSRR_SR: SRR \subset SR by rewrite commSg. +have sSR_R := subset_trans sSR_S sSR. +have{ntS} prSR: SR \proper S. + by rewrite (nil_comm_properl nilR) // subsetI subxx -commg_subl. +have SRR1: SRR = 1. + have [SR1 | ntSR] := eqVneq SR 1; first by rewrite /SRR SR1 comm1G. + have prSRR: SRR \proper SR. + rewrite /proper sSRR_SR; apply: contra ntSR => sSR_SRR. + by rewrite (forall_inP nilR) // subsetI sSR_R. + have pSR := pgroupS sSR_R pR; have pSRR := pgroupS sSRR_SR pSR. + have [_ _ [e oSR]] := pgroup_pdiv pSR ntSR; have [f oSRR] := p_natP pSRR. + have e0: e = 0. + have:= proper_card prSR; rewrite oSR (card_pnElem Ep2S). + by rewrite ltn_exp2l ?prime_gt1 // !ltnS leqn0; move/eqP. + apply/eqP; have:= proper_card prSRR; rewrite trivg_card1 oSR oSRR e0. + by rewrite ltn_exp2l ?prime_gt1 // ltnS; case f. +have sSR_ZR: [~: S, R] \subset 'Z(R). + by rewrite subsetI sSR_R /=; apply/commG1P. +have sS_Z2R: S \subset 'Z_2(R). + rewrite ucnSnR; apply/subsetP=> s Ss; rewrite inE (subsetP sSR) //= ucn1. + by rewrite (subset_trans _ sSR_ZR) ?commSg ?sub1set. +have sZ2R_R := ucn_sub 2 R; have pZ2R := pgroupS sZ2R_R pR. +have pZ: p.-group Z. + apply: pgroupS pR; apply: subset_trans (Ohm_sub _ _) (ucn_sub 2 R). +have sSZ: S \subset Z. + by rewrite /Z (OhmE 1 pZ2R) sub_gen // subsetI sS_Z2R sub_LdivT. +have ncycX: ~~ cyclic S by rewrite (abelem_cyclic abelS) dimS. +split; first by apply: contra ncycX; exact: cyclicS. +have nclZ2R : nil_class 'Z_2(R) <= 2 + _ := leq_trans (nil_class_ucn _ _) _. +by have [] := exponent_odd_nil23 pZ2R (oddSg sZ2R_R oddR) (nclZ2R _ _). +Qed. + +End OddNonCyclic. + +(* Some "obvious" consequences of the above, which are used casually and *) +(* pervasively throughout B & G. *) +Definition odd_pgroup_rank1_cyclic := odd_pgroup_rank1_cyclic. (* in extremal *) + +Lemma odd_rank1_Zgroup gT (G : {group gT}) : + odd #|G| -> Zgroup G = ('r(G) <= 1). +Proof. +move=> oddG; apply/forallP/idP=> [ZgG | rG_1 P]. + have [p p_pr ->]:= rank_witness G; have [P sylP]:= Sylow_exists p G. + have [sPG pP _] := and3P sylP; have oddP := oddSg sPG oddG. + rewrite -(p_rank_Sylow sylP) -(odd_pgroup_rank1_cyclic pP) //. + by apply: (implyP (ZgG P)); apply: (p_Sylow sylP). +apply/implyP=> /SylowP[p p_pr /and3P[sPG pP _]]. +rewrite (odd_pgroup_rank1_cyclic pP (oddSg sPG oddG)). +by apply: leq_trans (leq_trans (p_rank_le_rank p G) rG_1); apply: p_rankS. +Qed. + +(* This is B & G, Proposition 4.6 (a stronger version of Lemma 4.5(a)). *) +Proposition odd_normal_p2Elem_exists gT p (R S : {group gT}) : + p.-group R -> odd #|R| -> S <| R -> ~~ cyclic S -> + exists E : {group gT}, [/\ E \subset S, E <| R & E \in 'E_p^2(R)]. +Proof. +move=> pR oddR nsSR ncycS; have sSR := normal_sub nsSR. +have{sSR ncycS} []:= Ohm1_odd_ucn2 (pgroupS sSR pR) (oddSg sSR oddR) ncycS. +set Z := 'Ohm_1(_) => ncycZ expZp. +have chZS: Z \char S := char_trans (Ohm_char 1 _) (ucn_char 2 S). +have{nsSR} nsZR: Z <| R := char_normal_trans chZS nsSR. +have [sZR _] := andP nsZR; have pZ: p.-group Z := pgroupS sZR pR. +have geZ2: 2 <= logn p #|Z|. + rewrite (odd_pgroup_rank1_cyclic pZ (oddSg sZR oddR)) -ltnNge /= -/Z in ncycZ. + by case/p_rank_geP: ncycZ => E; case/pnElemP=> sEZ _ <-; rewrite lognSg. +have [E [sEZ nsER oE]] := normal_pgroup pR nsZR geZ2. +have [sER _] := andP nsER; have{pR} pE := pgroupS sER pR. +have{geZ2} p_pr: prime p by move: geZ2; rewrite lognE; case: (prime p). +have{oE p_pr} dimE2: logn p #|E| = 2 by rewrite oE pfactorK. +exists E; split; rewrite ?(subset_trans _ (char_sub chZS)) {chZS nsZR}//. +rewrite !inE /abelem sER pE (p2group_abelian pE) dimE2 //= andbT. +by apply: (dvdn_trans _ expZp); apply: exponentS. +Qed. + +(* This is B & G, Lemma 4.7, and (except for the trivial converse) Gorenstein *) +(* 5.4.15 and Aschbacher 23.17. *) +Lemma rank2_SCN3_empty gT p (R : {group gT}) : + p.-group R -> odd #|R| -> ('r(R) <= 2) = ('SCN_3(R) == set0). +Proof. +move=> pR oddR; apply/idP/idP=> [leR2 | SCN_3_empty]. + apply/set0Pn=> [[A /setIdP[/SCN_P[/andP[sAR _] _]]]]. + by rewrite ltnNge (leq_trans (rankS sAR)). +rewrite (rank_pgroup pR) leqNgt; apply/negP=> gtR2. +have ncycR: ~~ cyclic R by rewrite (odd_pgroup_rank1_cyclic pR) // -ltnNge ltnW. +have{ncycR} [Z nsZR] := ex_odd_normal_p2Elem pR oddR ncycR. +case/pnElemP=> sZR abelZ dimZ2; have [pZ cZZ _] := and3P abelZ. +have{SCN_3_empty} defZ: 'Ohm_1('C_R(Z)) = Z. + apply: (Ohm1_cent_max_normal_abelem _ pR). + by have:= oddSg sZR oddR; rewrite (card_pgroup pZ) dimZ2 odd_exp. + apply/maxgroupP; split=> [|H /andP[nsHR abelH] sZH]; first exact/andP. + have [pH cHH _] := and3P abelH; apply/eqP; rewrite eq_sym eqEproper sZH /=. + pose normal_abelian := [pred K : {group gT} | K <| R & abelian K]. + have [|K maxK sHK] := @maxgroup_exists _ normal_abelian H; first exact/andP. + apply: contraL SCN_3_empty => ltZR; apply/set0Pn; exists K. + rewrite inE (max_SCN pR) {maxK}//= -dimZ2 (leq_trans _ (rankS sHK)) //. + by rewrite (rank_abelem abelH) properG_ltn_log. +have{gtR2} [A] := p_rank_geP gtR2; pose H := 'C_A(Z); pose K := H <*> Z. +case/pnElemP=> sAR abelA dimA3; have [pA cAA _] := and3P abelA. +have{nsZR} nZA := subset_trans sAR (normal_norm nsZR). +have sHA: H \subset A := subsetIl A _; have abelH := abelemS sHA abelA. +have geH2: logn p #|H| >= 2. + rewrite -ltnS -dimA3 -(Lagrange sHA) lognM // -addn1 leq_add2l /= -/H. + by rewrite logn_quotient_cent_abelem ?dimZ2. +have{abelH} abelK : p.-abelem K. + by rewrite (cprod_abelem _ (cprodEY _)) 1?centsC ?subsetIr ?abelH. +suffices{sZR cZZ defZ}: 'r(Z) < 'r(K). + by rewrite ltnNge -defZ rank_Ohm1 rankS // join_subG setSI // subsetI sZR. +rewrite !(@rank_abelem _ p) // properG_ltn_log ?abelem_pgroup //= -/K properE. +rewrite joing_subr join_subG subxx andbT subEproper; apply: contraL geH2. +case/predU1P=> [defH | ltHZ]; last by rewrite -ltnNge -dimZ2 properG_ltn_log. +rewrite -defH [H](setIidPl _) ?dimA3 // in dimZ2. +by rewrite centsC -defH subIset // -abelianE cAA. +Qed. + +(* This is B & G, Proposition 4.8(a). *) +Proposition rank2_exponent_p_p3group gT (R : {group gT}) p : + p.-group R -> rank R <= 2 -> exponent R %| p -> logn p #|R| <= 3. +Proof. +move=> pR rankR expR. +have [A max_na_A]: {A | [max A | A <| R & abelian A]}. + by apply: ex_maxgroup; exists 1%G; rewrite normal1 abelian1. +have {max_na_A} SCN_A := max_SCN pR max_na_A. +have cAA := SCN_abelian SCN_A; case/SCN_P: SCN_A => nAR cRAA. +have sAR := normal_sub nAR; have pA := pgroupS sAR pR. +have abelA : p.-abelem A. + by rewrite /abelem pA cAA /= (dvdn_trans (exponentS sAR) expR). +have cardA : logn p #|A| <= 2. + by rewrite -rank_abelem // (leq_trans (rankS sAR) rankR). +have cardRA : logn p #|R : A| <= 1. + by rewrite -cRAA logn_quotient_cent_abelem // (normal_norm nAR). +rewrite -(Lagrange sAR) lognM ?cardG_gt0 //. +by apply: (leq_trans (leq_add cardA cardRA)). +Qed. + +(* This is B & G, Proposition 4.8(b). *) +Proposition exponent_Ohm1_rank2 gT p (R : {group gT}) : + p.-group R -> 'r(R) <= 2 -> p > 3 -> exponent 'Ohm_1(R) %| p. +Proof. +move=> pR rR p_gt3; wlog p_pr: / prime p. + have [-> | ntR] := eqsVneq R 1; first by rewrite Ohm1 exponent1 dvd1n. + by apply; have [->] := pgroup_pdiv pR ntR. +wlog minR: R pR rR / forall S, gval S \proper R -> exponent 'Ohm_1(S) %| p. + elim: {R}_.+1 {-2}R (ltnSn #|R|) => // m IHm R leRm in pR rR * => IH. + apply: (IH) => // S; rewrite properEcard; case/andP=> sSR ltSR. + exact: IHm (leq_trans ltSR _) (pgroupS sSR pR) (leq_trans (rankS sSR) rR) IH. +wlog not_clR_le3: / ~~ (nil_class R <= 3). + case: leqP => [clR_le3 _ | _ -> //]. + have [||-> //] := exponent_odd_nil23 pR; last by rewrite p_gt3. + by apply: odd_pgroup_odd pR; case/even_prime: p_pr p_gt3 => ->. +rewrite -sub_LdivT (OhmE 1 pR) gen_set_id ?subsetIr //. +apply/group_setP; rewrite !inE group1 expg1n. +split=> //= x y; case/LdivP=> Rx xp1; case/LdivP=> Ry yp1. +rewrite !inE groupM //=; apply: contraR not_clR_le3 => nt_xyp. +pose XY := <[x]> <*> <[y]>. +have [XYx XYy]: x \in XY /\ y \in XY by rewrite -!cycle_subG; exact/joing_subP. +have{nt_xyp} defR: XY = R. + have sXY_R : XY \subset R by rewrite join_subG !cycle_subG Rx Ry. + have pXY := pgroupS sXY_R pR; have [// | ltXY_R] := eqVproper sXY_R. + rewrite (exponentP (minR _ ltXY_R)) ?eqxx // in nt_xyp. + by rewrite (OhmE 1 pXY) groupM ?mem_gen ?inE ?XYx ?XYy /= ?xp1 ?yp1. +have sXR: <[x]> \subset R by rewrite cycle_subG. +have [<- | ltXR] := eqVproper sXR. + by rewrite 2?leqW // nil_class1 cycle_abelian. +have [S maxS sXS]: {S : {group gT} | maximal S R & <[x]> \subset S}. + exact: maxgroup_exists. +have nsSR: S <| R := p_maximal_normal pR maxS; have [sSR _] := andP nsSR. +have{nsSR} nsS1R: 'Ohm_1(S) <| R := char_normal_trans (Ohm_char 1 S) nsSR. +have [sS1R nS1R] := andP nsS1R; have pS1 := pgroupS sS1R pR. +have expS1p: exponent 'Ohm_1(S) %| p := minR S (maxgroupp maxS). +have{expS1p} dimS1: logn p #|'Ohm_1(S)| <= 3. + exact: rank2_exponent_p_p3group pS1 (leq_trans (rankS sS1R) rR) expS1p. +have sXS1: <[x]> \subset 'Ohm_1(S). + rewrite cycle_subG /= (OhmE 1 (pgroupS sSR pR)) mem_gen //. + by rewrite !inE -cycle_subG sXS xp1 /=. +have dimS1b: logn p #|R / 'Ohm_1(S)| <= 1. + rewrite -quotientYidl // -defR joingA (joing_idPl sXS1). + rewrite quotientYidl ?cycle_subG ?(subsetP nS1R) //. + rewrite (leq_trans (logn_quotient _ _ _)) // -(pfactorK 1 p_pr). + by rewrite dvdn_leq_log ?prime_gt0 // order_dvdn yp1. +rewrite (leq_trans (nil_class_pgroup pR)) // geq_max /= -subn1 leq_subLR. +by rewrite -(Lagrange sS1R) lognM // -card_quotient // addnC leq_add. +Qed. + +(* This is B & G, Lemma 4.9. *) +Lemma quotient_p2_Ohm1 gT p (R : {group gT}) : + p.-group R -> p > 3 -> logn p #|'Ohm_1(R)| <= 2 -> + forall T : {group gT}, T <| R -> logn p #|'Ohm_1(R / T)| <= 2. +Proof. +move=> pR p_gt3 dimR1; move: {2}_.+1 (ltnSn #|R|) => n. +elim: n => // n IHn in gT R pR dimR1 *; rewrite ltnS => leRn. +apply/forall_inP/idPn; rewrite negb_forall_in. +case/existsP/ex_mingroup=> T /mingroupP[/andP[nsTR dimRb1] minT]. +have [sTR nTR] := andP nsTR; have pT: p.-group T := pgroupS sTR pR. +pose card_iso_Ohm := card_isog (gFisog [igFun of Ohm 1] _). +have ntT: T :!=: 1; last have p_pr: prime p by have [] := pgroup_pdiv pT ntT. + apply: contraNneq dimRb1 => ->. + by rewrite -(card_iso_Ohm _ _ _ _ (quotient1_isog R)). +have{minT} dimT: logn p #|T| = 1%N. + have [Z EpZ]: exists Z, Z \in 'E_p^1(T :&: 'Z(R)). + apply/p_rank_geP; rewrite -rank_pgroup ?(pgroupS (subsetIl T _)) //. + by rewrite rank_gt0 (meet_center_nil (pgroup_nil pR)). + have [sZ_ZT _ dimZ] := pnElemP EpZ; have [sZT sZZ] := subsetIP sZ_ZT. + have{sZZ} nsZR: Z <| R := sub_center_normal sZZ. + rewrite -(minT Z) // nsZR; apply: contra dimRb1 => dimRz1. + rewrite -(card_iso_Ohm _ _ _ _ (third_isog sZT nsZR nsTR)) /=. + rewrite IHn ?quotient_pgroup ?quotient_normal ?(leq_trans _ leRn) //. + by rewrite ltn_quotient ?(subset_trans sZT) // (nt_pnElem EpZ). +have pRb: p.-group (R / T) by apply: quotient_pgroup. +have{IHn} minR (Ub : {group coset_of T}): + Ub \subset R / T -> ~~ (logn p #|'Ohm_1(Ub)| <= 2) -> R / T = Ub. +- case/inv_quotientS=> // U -> sTU sUR dimUb; congr (_ / T). + apply/eqP; rewrite eq_sym eqEcard sUR leqNgt; apply: contra dimUb => ltUR. + rewrite IHn ?(pgroupS sUR) ?(normalS _ sUR) ?(leq_trans ltUR) //. + by rewrite (leq_trans _ dimR1) ?lognSg ?OhmS. +have [dimRb eRb]: logn p #|R / T| = 3 /\ exponent (R / T) %| p. + have [Rb_gt2 | Rb_le2] := ltnP 2 'r_p(R / T). + have [Ub Ep3Ub] := p_rank_geP Rb_gt2. + have [sUbR abelUb dimUb] := pnElemP Ep3Ub; have [_ _ eUb] := and3P abelUb. + by rewrite (minR Ub) // (Ohm1_id abelUb) dimUb. + rewrite -rank_pgroup // in Rb_le2. + have eRb: exponent (R / T) %| p. + by rewrite (minR _ (Ohm_sub 1 _)) ?exponent_Ohm1_rank2 ?Ohm_id. + split=> //; apply/eqP; rewrite eqn_leq rank2_exponent_p_p3group // ltnNge. + by apply: contra (leq_trans _) dimRb1; rewrite lognSg ?Ohm_sub. +have ntRb: (R / T) != 1. + by rewrite -cardG_gt1 (card_pgroup pRb) dimRb (ltn_exp2l 0) ?prime_gt1. +have{dimRb} dimR: logn p #|R| = 4. + by rewrite -(Lagrange sTR) lognM ?cardG_gt0 // dimT -card_quotient ?dimRb. +have nsR1R: 'Ohm_1(R) <| R := Ohm_normal 1 R; have [sR1R nR1R] := andP nsR1R. +have pR1: p.-group 'Ohm_1(R) := pgroupS sR1R pR. +have p_odd: odd p by case/even_prime: p_pr p_gt3 => ->. +have{p_odd} oddR: odd #|R| := odd_pgroup_odd p_odd pR. +have{dimR1} dimR1: logn p #|'Ohm_1(R)| = 2. + apply/eqP; rewrite eqn_leq dimR1 -p_rank_abelem; last first. + by rewrite abelem_Ohm1 // (p2group_abelian pR1). + rewrite ltnNge p_rank_Ohm1 -odd_pgroup_rank1_cyclic //. + apply: contra dimRb1 => cycR; have cycRb := quotient_cyclic T cycR. + by rewrite (Ohm1_cyclic_pgroup_prime cycRb pRb ntRb) (pfactorK 1). +have pRs: p.-group (R / 'Ohm_1(R)) by rewrite quotient_pgroup. +have dimRs: logn p #|R / 'Ohm_1(R)| = 2. + by rewrite -divg_normal // logn_div ?cardSg // dimR1 dimR. +have sR'R1: R^`(1) \subset 'Ohm_1(R). + by rewrite der1_min // (p2group_abelian pRs) ?dimRs. +have [|_ phiM] := exponent_odd_nil23 pR oddR. + by rewrite (leq_trans (nil_class_pgroup pR)) // dimR p_gt3. +pose phi := Morphism (phiM sR'R1). +suffices: logn p #|R / 'Ohm_1(R)| <= logn p #|T| by rewrite dimT dimRs. +have ->: 'Ohm_1(R) = 'ker phi. + rewrite -['ker phi]genGid (OhmE 1 pR); congr <<_>>. + by apply/setP=> x; rewrite !inE. +rewrite (card_isog (first_isog phi)) lognSg //=. +apply/subsetP=> _ /morphimP[x _ Rx ->] /=. +apply: coset_idr; first by rewrite groupX ?(subsetP nTR). +by rewrite morphX ?(subsetP nTR) // (exponentP eRb) // mem_quotient. +Qed. + +(* This is B & G, Lemma 4.10. *) +Lemma Ohm1_metacyclic_p2Elem gT p (R : {group gT}) : + metacyclic R -> p.-group R -> odd #|R| -> ~~ cyclic R -> + 'Ohm_1(R)%G \in 'E_p^2(R). +Proof. +case/metacyclicP=> S [cycS nsSR cycRb] pR oddR ncycR. +have [[sSR nSR] [s defS]] := (andP nsSR, cyclicP cycS). +have [T defTb sST sTR] := inv_quotientS nsSR (Ohm_sub 1 (R / S)). +have [pT oddT] := (pgroupS sTR pR, oddSg sTR oddR). +have Ts: s \in T by rewrite -cycle_subG -defS. +have iTs: #|T : <[s]>| = p. + rewrite -defS -card_quotient ?(subset_trans sTR) // -defTb. + rewrite (Ohm1_cyclic_pgroup_prime cycRb (quotient_pgroup _ pR)) // -subG1. + by rewrite quotient_sub1 ?(contra (fun sRS => cyclicS sRS cycS)). +have defR1: 'Ohm_1(R) = 'Ohm_1(T). + apply/eqP; rewrite eqEsubset (OhmS _ sTR) andbT -Ohm_id OhmS //. + rewrite -(quotientSGK _ sST); last by rewrite (subset_trans _ nSR) ?Ohm_sub. + by rewrite -defTb morphim_Ohm. +rewrite (subsetP (pnElemS _ _ sTR)) // (group_inj defR1). +apply: Ohm1_extremal_odd iTs => //; apply: contra ncycR. +by rewrite !(@odd_pgroup_rank1_cyclic _ p) // -p_rank_Ohm1 -defR1 p_rank_Ohm1. +Qed. + +(* This is B & G, Proposition 4.11 (due to Huppert). *) +Proposition p2_Ohm1_metacyclic gT p (R : {group gT}) : + p.-group R -> p > 3 -> logn p #|'Ohm_1(R)| <= 2 -> metacyclic R. +Proof. +move=> pR p_gt3 dimR1; move: {2}_.+1 (ltnSn #|R|) => n. +elim: n => // n IHn in gT R pR dimR1 *; rewrite ltnS => leRn. +have pR1: p.-group 'Ohm_1(R) := pgroupS (Ohm_sub 1 R) pR. +have [cRR | not_cRR] := boolP (abelian R). + have [b defR typeR] := abelian_structure cRR; move: dimR1 defR. + rewrite -(rank_abelian_pgroup pR cRR) -(size_abelian_type cRR) -{}typeR. + case: b => [|a [|b []]] //= _; first by move <-; rewrite big_nil metacyclic1. + by rewrite big_seq1 => <-; rewrite cyclic_metacyclic ?cycle_cyclic. + rewrite big_cons big_seq1; case/dprodP=> _ <- cAB _. + apply/existsP; exists <[a]>%G; rewrite cycle_cyclic /=. + rewrite /normal mulG_subl mulG_subG normG cents_norm //= quotientMidl. + by rewrite quotient_cycle ?cycle_cyclic // -cycle_subG cents_norm. +pose R' := R^`(1); pose e := 'Mho^1(R') != 1. +have nsR'R: R' <| R := der_normal 1 R; have [sR'R nR'R] := andP nsR'R. +have [T EpT]: exists T, T \in 'E_p^1('Mho^e(R') :&: 'Z(R)). + apply/p_rank_geP; rewrite -rank_pgroup; last first. + by rewrite (pgroupS _ pR) //= setIC subIset ?center_sub. + rewrite rank_gt0 (meet_center_nil (pgroup_nil pR)) //. + exact: char_normal_trans (Mho_char e _) nsR'R. + by case ntR'1: e; rewrite //= Mho0 (sameP eqP derG1P). +have [p_gt1 p_pr] := (ltnW (ltnW p_gt3), pnElem_prime EpT). +have p_odd: odd p by case/even_prime: p_pr p_gt3 => ->. +have{p_odd} oddR: odd #|R| := odd_pgroup_odd p_odd pR. +have [sTR'eZ abelT oT] := pnElemPcard EpT; rewrite expn1 in oT. +have{sTR'eZ abelT} [[sTR'e sTZ] [pT cTT eT]] := (subsetIP sTR'eZ, and3P abelT). +have sTR': T \subset R' := subset_trans sTR'e (Mho_sub e _). +have nsTR := sub_center_normal sTZ; have [sTR cRT] := subsetIP sTZ. +have cTR: R \subset 'C(T) by rewrite centsC. +have{n IHn leRn EpT} metaRb: metacyclic (R / T). + have pRb: p.-group (R / T) := quotient_pgroup T pR. + have dimRb: logn p #|'Ohm_1(R / T)| <= 2 by apply: quotient_p2_Ohm1. + by rewrite IHn ?(leq_trans (ltn_quotient _ _)) ?(nt_pnElem EpT). +have{metaRb} [Xb [cycXb nsXbR cycRs]] := metacyclicP metaRb. +have{cycRs} [yb defRb]: exists yb, R / T = Xb <*> <[yb]>. + have [ys defRs] := cyclicP cycRs; have [yb nXyb def_ys] := cosetP ys. + exists yb; rewrite -quotientYK ?cycle_subG ?quotient_cycle // -def_ys -defRs. + by rewrite quotientGK. +have{sTZ} ntXb: Xb :!=: 1. + apply: contraNneq not_cRR => Xb1. + by rewrite (cyclic_factor_abelian sTZ) // defRb Xb1 joing1G cycle_cyclic. +have [TX defTXb sTTX nsTXR] := inv_quotientN nsTR nsXbR. +have{cycXb} [[sTXR nTXR] [xb defXb]] := (andP nsTXR, cyclicP cycXb). +have [[x nTx def_xb] [y nTy def_yb]] := (cosetP xb, cosetP yb). +have{defTXb} defTX: T <*> <[x]> = TX. + rewrite -quotientYK ?cycle_subG ?quotient_cycle // -def_xb -defXb defTXb. + by rewrite quotientGK // (normalS _ sTXR). +have{yb defRb def_yb} defR: TX <*> <[y]> = R. + rewrite -defTX -joingA -quotientYK ?join_subG ?quotientY ?cycle_subG ?nTx //. + by rewrite !quotient_cycle // -def_xb -def_yb -defXb -defRb quotientGK. +have sXYR: <[x]> <*> <[y]> \subset R by rewrite -defR -defTX -joingA joing_subr. +have [Rx Ry]: x \in R /\ y \in R by rewrite -!cycle_subG; exact/joing_subP. +have cTXY := subset_trans sXYR cTR; have [cTX cTY] := joing_subP cTXY. +have [R'1_1 {e sTR'e} | ntR'1] := eqVneq 'Mho^1(R') 1; last first. + have sR'TX: R' \subset TX. + rewrite der1_min // -defR quotientYidl ?cycle_subG ?(subsetP nTXR) //. + by rewrite quotient_abelian // cycle_abelian. + have sTX : T \subset <[x]>. + rewrite (subset_trans (subset_trans sTR'e (MhoS e sR'TX))) // /e ntR'1. + have{defTX} defTX: T \* <[x]> = TX by rewrite cprodEY // centsC. + rewrite -(Mho_cprod 1 defTX) ['Mho^1(_)](trivgP _) ?cprod1g ?Mho_sub //=. + rewrite (MhoE 1 pT) gen_subG; apply/subsetP=> tp; case/imsetP=> t Tt ->{tp}. + by rewrite inE (exponentP eT). + apply/metacyclicP; exists TX; split=> //. + by rewrite -defTX (joing_idPr sTX) cycle_cyclic. + rewrite -defR quotientYidl ?cycle_subG ?(subsetP nTXR) //. + by rewrite quotient_cyclic ?cycle_cyclic. +have{R'1_1} eR': exponent R' %| p. + have <-: 'Ohm_1(R') = R' by apply/eqP; rewrite trivg_Mho ?R'1_1. + rewrite -sub_LdivT (OhmEabelian (pgroupS sR'R pR)) ?subsetIr //. + by rewrite (abelianS (OhmS 1 sR'R)) // (p2group_abelian pR1). +pose r := [~ x, y]; have Rr: r \in R by exact: groupR. +have{defXb ntXb nsXbR} [i def_rb]: exists i, coset T r = (xb ^+ p) ^+ i. + have p_xb: p.-elt xb by rewrite def_xb morph_p_elt ?(mem_p_elt pR). + have pRbb: p.-group (R / T / 'Mho^1(Xb)) by rewrite !quotient_pgroup. + have [_ nXb1R] := andP (char_normal_trans (Mho_char 1 Xb) nsXbR). + apply/cycleP; rewrite -(Mho_p_cycle 1 p_xb) -defXb. + apply: coset_idr; first by rewrite (subsetP nXb1R) ?mem_quotient. + apply/eqP; rewrite !morphR ?(subsetP nXb1R) ?mem_quotient //=; apply/commgP. + red; rewrite -(@centerC _ (R / T / _)) ?mem_quotient // -cycle_subG. + rewrite -quotient_cycle ?(subsetP nXb1R) ?mem_quotient // -def_xb -defXb. + suffices oXbb: #|Xb / 'Mho^1(Xb)| = p. + apply: prime_meetG; first by rewrite oXbb. + rewrite (meet_center_nil (pgroup_nil pRbb)) ?quotient_normal //. + by rewrite -cardG_gt1 oXbb. + rewrite -divg_normal ?Mho_normal //= defXb. + rewrite -(mul_card_Ohm_Mho_abelian 1) ?cycle_abelian ?mulnK ?cardG_gt0 //. + by rewrite (Ohm1_cyclic_pgroup_prime _ p_xb) ?cycle_cyclic //= -defXb. +have{xb def_xb def_rb} [t Tt def_r]: exists2 t, t \in T & r = t * x ^+ (p * i). + apply/rcosetP; rewrite -val_coset ?groupX ?morphX //= -def_xb. + by rewrite expgM -def_rb val_coset ?groupR // rcoset_refl. +have{eR' def_r cTT} defR': R' = <[r]>. + have R'r : r \in R' by exact: mem_commg. + have cxt: t \in 'C[x] by apply/cent1P; exact: (centsP cRT). + have crx: x \in 'C[r] by rewrite cent1C def_r groupM ?groupX ?cent1id. + have def_xy: x ^ y = t * x ^+ (p * i).+1. + by rewrite conjg_mulR -/r def_r expgS !mulgA (cent1P cxt). + have crR : R \subset 'C[r]. + rewrite -defR -defTX !join_subG sub_cent1 (subsetP cTR) //= !cycle_subG. + rewrite crx cent1C (sameP cent1P commgP); apply/conjg_fixP. + rewrite def_r conjMg conjXg conjgE (centsP cRT t) // mulKg conjg_mulR -/r. + by rewrite (expgMn _ (cent1P crx)) (expgM r) (exponentP eR') ?expg1n ?mulg1. + apply/eqP; rewrite eqEsubset cycle_subG R'r andbT. + have nrR : R \subset 'N(<[r]>) by rewrite cents_norm ?cent_cycle. + rewrite der1_min // -defR -defTX -joingA. + rewrite norm_joinEr ?(subset_trans sXYR) ?normal_norm //. + rewrite quotientMl ?(subset_trans sTR) // abelianM quotient_abelian //=. + rewrite quotient_cents //= -der1_joing_cycles ?der_abelian //. + by rewrite -sub_cent1 (subset_trans sXYR). +have [S maxS sR'S] : {S | [max S | S \subset R & cyclic S] & R' \subset S}. + by apply: maxgroup_exists; rewrite sR'R /= -/R' defR' cycle_cyclic. +case/maxgroupP: maxS; case/andP=> sSR cycS maxS. +have nsSR: S <| R := sub_der1_normal sR'S sSR; have [_ nSR] := andP nsSR. +apply/existsP; exists S; rewrite cycS nsSR //=. +suffices uniqRs1 Us: Us \in 'E_p^1(R / S) -> 'Ohm_1(R) / S = Us. + have pRs: p.-group (R / S) := quotient_pgroup S pR. + rewrite abelian_rank1_cyclic ?sub_der1_abelian ?(rank_pgroup pRs) // leqNgt. + apply: contraFN (ltnn 1) => rRs; have [Us EpUs] := p_rank_geP (ltnW rRs). + have [Vs EpVs] := p_rank_geP rRs; have [sVsR abelVs <-] := pnElemP EpVs. + have [_ _ <-] := pnElemP EpUs; apply: lognSg; apply/subsetP=> vs Vvs. + apply: wlog_neg => notUvs; rewrite -cycle_subG -(uniqRs1 _ EpUs). + rewrite (uniqRs1 <[vs]>%G) ?p1ElemE // !inE cycle_subG (subsetP sVsR) //=. + by rewrite -orderE (abelem_order_p abelVs Vvs (group1_contra notUvs)). +case/pnElemPcard; rewrite expn1 => sUsR _ oUs. +have [U defUs sSU sUR] := inv_quotientS nsSR sUsR. +have [cycU | {maxS} ncycU] := boolP (cyclic U). + by rewrite -[p]oUs defUs (maxS U) ?sUR // trivg_quotient cards1 in p_gt1. +have EpU1: 'Ohm_1(U)%G \in 'E_p^2(U). + have [u defS] := cyclicP cycS; rewrite defS cycle_subG in sSU. + rewrite (Ohm1_extremal_odd (pgroupS sUR pR) (oddSg sUR oddR) _ sSU) //. + by rewrite -defS -card_quotient -?defUs // (subset_trans sUR). +have defU1: 'Ohm_1(U) = 'Ohm_1(R). + apply/eqP; rewrite eqEcard OhmS // (card_pnElem EpU1). + by rewrite (card_pgroup pR1) leq_exp2l. +apply/eqP; rewrite eqEcard oUs defUs -{1}defU1 quotientS ?Ohm_sub //. +rewrite dvdn_leq ?cardG_gt0 //; case/pgroup_pdiv: (quotient_pgroup S pR1) => //. +rewrite -subG1 quotient_sub1 ?(subset_trans (Ohm_sub 1 R) nSR) //. +apply: contraL (cycS) => sR1S; rewrite abelian_rank1_cyclic ?cyclic_abelian //. +rewrite -ltnNge (rank_pgroup (pgroupS sSR pR)); apply/p_rank_geP. +by exists 'Ohm_1(U)%G; rewrite -(setIidPr sSU) pnElemI inE EpU1 inE /= defU1. +Qed. + +(* This is B & G, Theorem 4.12 (also due to Huppert), for internal action. *) +Theorem coprime_metacyclic_cent_sdprod gT p (R A : {group gT}) : + p.-group R -> odd #|R| -> metacyclic R -> p^'.-group A -> A \subset 'N(R) -> + let T := [~: R, A] in let C := 'C_R(A) in + [/\ (*a*) abelian T, + (*b*) T ><| C = R + & (*c*) ~~ abelian R -> T != 1 -> + [/\ C != 1, cyclic T, cyclic C & R^`(1) \subset T]]. +Proof. +move=> pR oddR metaR p'A nRA T C. +suffices{C T} cTT: abelian [~: R, A]. + have sTR: T \subset R by rewrite commg_subl. + have nTR: R \subset 'N(T) by rewrite commg_norml. + have coRA: coprime #|R| #|A| := pnat_coprime pR p'A. + have solR: solvable R := pgroup_sol pR. + have defR: T * C = R by rewrite coprime_cent_prod. + have sCR: C \subset R := subsetIl _ _; have nTC := subset_trans sCR nTR. + have tiTC: T :&: C = 1. + have defTA: [~: T, A] = T by rewrite coprime_commGid. + have coTA: coprime #|T| #|A| := coprimeSg sTR coRA. + by rewrite setIA (setIidPl sTR) -defTA coprime_abel_cent_TI ?commg_normr. + split=> // [|not_cRR ntT]; first by rewrite sdprodE. + have ntC: C != 1 by apply: contraNneq not_cRR => C1; rewrite -defR C1 mulg1. + suffices [cycT cycC]: cyclic T /\ cyclic C. + split=> //; rewrite der1_min //= -/T -defR quotientMidl. + by rewrite cyclic_abelian ?quotient_cyclic. + have [pT pC]: p.-group T /\ p.-group C by rewrite !(pgroupS _ pR). + apply/andP; rewrite (odd_pgroup_rank1_cyclic pC (oddSg sCR oddR)). + rewrite abelian_rank1_cyclic // -rank_pgroup //. + rewrite -(geq_leqif (leqif_add (leqif_geq _) (leqif_geq _))) ?rank_gt0 //. + have le_rTC_dimTC1: 'r(T) + 'r(C) <= logn p #|'Ohm_1(T) * 'Ohm_1(C)|. + rewrite (rank_pgroup pC) -p_rank_Ohm1 (rank_abelian_pgroup pT cTT). + rewrite TI_cardMg; last by apply/trivgP; rewrite -tiTC setISS ?Ohm_sub. + by rewrite lognM ?cardG_gt0 // leq_add2l p_rank_le_logn. + apply: leq_trans le_rTC_dimTC1 _; rewrite add1n. + have ncycR: ~~ cyclic R by apply: contra not_cRR; apply: cyclic_abelian. + have: 'Ohm_1(R)%G \in 'E_p^2(R) by apply: Ohm1_metacyclic_p2Elem. + have nT1C1: 'Ohm_1(C) \subset 'N('Ohm_1(T)). + by rewrite (subset_trans (Ohm_sub 1 _)) ?(char_norm_trans (Ohm_char 1 _)). + by case/pnElemP=> _ _ <-; rewrite -norm_joinEr ?lognSg // join_subG !OhmS. +without loss defR: R pR oddR metaR nRA / [~: R, A] = R. + set T := [~: R, A] => IH; have sTR: T \subset R by rewrite commg_subl. + have defTA: [~: T, A] = T. + by rewrite coprime_commGid ?(pgroup_sol pR) ?(pnat_coprime pR). + rewrite -defTA IH ?(pgroupS sTR) ?(oddSg sTR) ?(metacyclicS sTR) //. + exact: commg_normr. +rewrite defR; apply: wlog_neg => not_cRR. +have ncycR: ~~ cyclic R := contra (@cyclic_abelian _ R) not_cRR. +pose cycR_nA S := [&& cyclic S, S \subset R & A \subset 'N(S)]. +have [S maxS sR'S] : {S | [max S | cycR_nA S] & R^`(1) \subset S}. + apply: maxgroup_exists; rewrite {}/cycR_nA der_sub /=. + rewrite (char_norm_trans (der_char 1 _)) // andbT. + have [K [cycK nsKR cycKR]] := metacyclicP metaR. + by rewrite (cyclicS _ cycK) // der1_min ?normal_norm // cyclic_abelian. +case/maxgroupP: maxS; case/and3P=> cycS sSR nSA maxS. +have ntS: S :!=: 1 by rewrite (subG1_contra sR'S) // (sameP eqP derG1P). +have nSR: R \subset 'N(S) := sub_der1_norm sR'S sSR. +have nsSR: S <| R by exact/andP. +have sSZ: S \subset 'Z(R). + have sR_NS': R \subset 'N(S)^`(1) by rewrite -{1}defR commgSS. + rewrite subsetI sSR centsC (subset_trans sR_NS') // der1_min ?cent_norm //=. + rewrite -ker_conj_aut (isog_abelian (first_isog _)). + by rewrite (abelianS (Aut_conj_aut _ _)) ?Aut_cyclic_abelian. +have cRbRb: abelian (R / S) by rewrite sub_der1_abelian. +have pRb: p.-group (R / S) := quotient_pgroup S pR. +pose R1 := 'Ohm_1(R); pose Rb1 := 'Ohm_1(R / S). +have [Xb]: exists2 Xb, R1 / S \x gval Xb = Rb1 & A / S \subset 'N(Xb). + have MaschkeRb1 := Maschke_abelem (Ohm1_abelem pRb cRbRb). + pose normOhm1 := (char_norm_trans (Ohm_char 1 _), quotient_norms S). + by apply: MaschkeRb1; rewrite ?quotient_pgroup ?morphim_Ohm ?normOhm1. +case/dprodP=> _ defRb1 _ tiR1bX nXbA. +have sXbR: Xb \subset R / S. + by apply: subset_trans (Ohm_sub 1 _); rewrite -defRb1 mulG_subr. +have{sXbR} [X defXb sSX sXR] := inv_quotientS nsSR sXbR. +have{nXbA nsSR} nXA: A \subset 'N(X). + rewrite (subset_trans (mulG_subr S A)) // -quotientK //. + by rewrite -(quotientGK (normalS sSX sXR nsSR)) -defXb morphpre_norms. +have{tiR1bX} cycX: cyclic X. + have sX1_XR1: 'Ohm_1(X) \subset X :&: R1 by rewrite subsetI Ohm_sub OhmS. + have cyc_sR := odd_pgroup_rank1_cyclic (pgroupS _ pR) (oddSg _ oddR). + have:= cycS; rewrite !{}cyc_sR //; apply: leq_trans. + rewrite -p_rank_Ohm1 p_rankS // (subset_trans sX1_XR1) //. + rewrite -quotient_sub1 ?subIset ?(subset_trans sXR) //. + by rewrite quotientGI // setIC -defXb tiR1bX. +rewrite (cyclic_factor_abelian sSZ) // abelian_rank1_cyclic //. +rewrite (rank_abelian_pgroup pRb cRbRb) -defRb1 defXb. +rewrite (maxS X) ?trivg_quotient ?mulg1 //; last exact/and3P. +have EpR1: 'Ohm_1(R)%G \in 'E_p^2(R) by exact: Ohm1_metacyclic_p2Elem. +have [sR1R _ dimR1] := pnElemP EpR1; have pR1 := pgroupS sR1R pR. +rewrite -(card_isog (second_isog _)) ?(subset_trans sR1R) // -ltnS -dimR1. +by rewrite (ltn_log_quotient pR1) ?subsetIr //= meet_Ohm1 // (setIidPl sSR). +Qed. + +(* This covers B & G, Lemmas 4.13 and 4.14. *) +Lemma pi_Aut_rank2_pgroup gT p q (R : {group gT}) : + p.-group R -> odd #|R| -> 'r(R) <= 2 -> q \in \pi(Aut R) -> q != p -> + [/\ q %| (p ^ 2).-1, q < p & q %| p.+1./2 \/ q %| p.-1./2]. +Proof. +move=> pR oddR rR q_Ar p'q; rewrite /= in q_Ar. +have [R1 | ntR] := eqsVneq R 1; first by rewrite R1 Aut1 cards1 in q_Ar. +have{ntR} [p_pr p_dv_R _] := pgroup_pdiv pR ntR. +have{oddR p_dv_R} [p_odd p_gt1] := (dvdn_odd p_dv_R oddR, prime_gt1 p_pr). +have{q_Ar} [q_pr q_dv_Ar]: prime q /\ q %| #|Aut R|. + by move: q_Ar; rewrite mem_primes; case/and3P. +suffices q_dv_p2: q %| (p ^ 2).-1. + have q_dv_p1: q %| p.+1./2 \/ q %| p.-1./2. + apply/orP; have:= q_dv_p2; rewrite -subn1 (subn_sqr p 1). + rewrite -[p]odd_double_half p_odd /= !doubleK addKn addn1 -doubleS -!mul2n. + rewrite mulnC !Euclid_dvdM // dvdn_prime2 // -orbA; case: eqP => // -> _. + by rewrite -Euclid_dvdM // /dvdn modn2 mulnC odd_mul andbN. + have p_gt2: p > 2 by rewrite ltn_neqAle; case: eqP p_odd => // <-. + have p1_ltp: p.+1./2 < p. + by rewrite -divn2 ltn_divLR // muln2 -addnn -addn2 leq_add2l. + split=> //; apply: leq_ltn_trans p1_ltp. + move/orP: q_dv_p1; rewrite -(subnKC p_gt2) leqNgt. + by apply: contraL => lt_p1q; rewrite negb_or !gtnNdvd // ltnW. +wlog{q_dv_Ar} [a oa nRa]: gT R pR rR / {a | #[a] = q & a \in 'N(R) :\: 'C(R)}. + have [a Ar_a oa] := Cauchy q_pr q_dv_Ar. + rewrite -(injm_rank (injm_sdpair1 [Aut R])) // in rR. + move=> IH; apply: IH rR _; rewrite ?morphim_pgroup ?morphim_odd //. + exists (sdpair2 [Aut R] a); rewrite ?(order_injm (injm_sdpair2 _)) //. + rewrite inE (subsetP (im_sdpair_norm _)) ?mem_morphim //= andbT. + apply: contraL (prime_gt1 q_pr) => cRa; rewrite -oa order_gt1 negbK. + apply/eqP; apply: (eq_Aut Ar_a (group1 _)) => x Rx. + by rewrite perm1 [a x](@astab_act _ _ _ [Aut R] R) ?astabEsd ?mem_morphpre. +move: {2}_.+1 (ltnSn #|R|) => n. +elim: n => // n IHn in gT a R pR rR nRa oa *; rewrite ltnS => leRn. +case recR: [exists (S : {group gT} | S \proper R), a \in 'N(S) :\: 'C(S)]. + have [S ltSR nSa] := exists_inP recR; rewrite properEcard in ltSR. + have{ltSR} [sSR ltSR] := andP ltSR; have rS := leq_trans (rankS sSR) rR. + by apply: IHn nSa oa _; rewrite ?(pgroupS sSR) ?(leq_trans ltSR). +do [rewrite inE -!cycle_subG orderE; set A := <[a]>] in nRa oa. +have{nRa oa} [[not_cRA nRA] oA] := (andP nRa, oa). +have coRA : coprime #|R| #|A| by rewrite oA (pnat_coprime pR) ?pnatE. +have{recR} IH: forall S, gval S \proper R -> A \subset 'N(S) -> A \subset 'C(S). + move=> S ltSR; rewrite !cycle_subG => nSa; apply: contraFT recR => not_cSa. + by apply/exists_inP; exists S; rewrite // inE not_cSa nSa. +have defR1: 'Ohm_1(R) = R. +apply: contraNeq not_cRA; rewrite eqEproper Ohm_sub negbK => ltR1R. + rewrite (coprime_odd_faithful_Ohm1 pR) ?IH ?(odd_pgroup_odd p_odd) //. + by rewrite (char_norm_trans (Ohm_char 1 R)). +have defRA: [~: R, A] = R. + apply: contraNeq not_cRA; rewrite eqEproper commg_subl nRA negbK => ltRAR. + rewrite centsC; apply/setIidPl. + rewrite -{2}(coprime_cent_prod nRA) ?(pgroup_sol pR) //. + by rewrite mulSGid // subsetI commg_subl nRA centsC IH ?commg_normr. +have [cRR | not_cRR] := boolP (abelian R). + rewrite -subn1 (subn_sqr p 1) Euclid_dvdM //. + have abelR: p.-abelem R by rewrite -defR1 Ohm1_abelem. + have ntR: R :!=: 1 by apply: contraNneq not_cRA => ->; apply: cents1. + pose rAR := reprGLm (abelem_repr abelR ntR nRA). + have:= cardSg (subsetT (rAR @* A)); rewrite card_GL ?card_Fp //. + rewrite card_injm ?ker_reprGLm ?rker_abelem ?prime_TIg ?oA // unlock. + rewrite Gauss_dvdr; last by rewrite coprime_expr ?prime_coprime ?dvdn_prime2. + move: rR; rewrite -ltnS -[_ < _](mem_iota 0) !inE eqn0Ngt rank_gt0 ntR. + rewrite (dim_abelemE abelR ntR) (rank_abelem abelR). + do [case/pred2P=> ->; rewrite /= muln1] => [-> // | ]. + by rewrite (subn_sqr p 1) mulnA !Euclid_dvdM ?orbb. +have [[defPhi defR'] _]: special R /\ 'C_R(A) = 'Z(R). + apply: (abelian_charsimple_special pR) => //. + apply/bigcupsP=> S; case/andP=> charS cSS. + rewrite centsC IH ?(char_norm_trans charS) // properEneq char_sub // andbT. + by apply: contraNneq not_cRR => <-. +have ntZ: 'Z(R) != 1 by rewrite -defR' (sameP eqP derG1P). +have ltRbR: #|R / 'Z(R)| < #|R| by rewrite ltn_quotient ?center_sub. +have pRb: p.-group (R / 'Z(R)) by apply: quotient_pgroup. +have nAZ: A \subset 'N('Z(R)) by rewrite (char_norm_trans (center_char R)). +have defAb: A / 'Z(R) = <[coset _ a]> by rewrite quotient_cycle -?cycle_subG. +have oab: #[coset 'Z(R) a] = q. + rewrite orderE -defAb -(card_isog (quotient_isog _ _)) //. + by rewrite coprime_TIg ?(coprimeSg (center_sub R)). +have rRb: 'r(R / 'Z(R)) <= 2. + rewrite (rank_pgroup pRb) (leq_trans (p_rank_le_logn _ _)) // -ltnS. + apply: leq_trans (rank2_exponent_p_p3group pR rR _). + by rewrite -(ltn_exp2l _ _ p_gt1) -!card_pgroup. + by rewrite -defR1 (exponent_Ohm1_class2 p_odd) // nil_class2 defR'. +apply: IHn oab (leq_trans ltRbR leRn) => //. +rewrite inE -!cycle_subG -defAb quotient_norms ?andbT //. +apply: contra not_cRA => cRAb; rewrite (coprime_cent_Phi pR coRA) // defPhi. +by rewrite commGC -quotient_cents2 ?gFnorm. +Qed. + +(* B & G, Lemma 4.15 is covered by maximal/critical_extraspecial. *) + +(* This is B & G, Theorem 4.16 (due to Blackburn). *) +Theorem rank2_coprime_comm_cprod gT p (R A : {group gT}) : + p.-group R -> odd #|R| -> R :!=: 1 -> 'r(R) <= 2 -> + [~: R, A] = R -> p^'.-group A -> odd #|A| -> + [/\ p > 3 + & [\/ abelian R + | exists2 S : {group gT}, + [/\ ~~ abelian S, logn p #|S| = 3 & exponent S %| p] + & exists C : {group gT}, + [/\ S \* C = R, cyclic C & 'Ohm_1(C) = S^`(1)]]]. +Proof. +move=> pR oddR ntR rR defRA p'A oddA. +have [p_pr _ _] := pgroup_pdiv pR ntR; have p_gt1 := prime_gt1 p_pr. +have nilR: nilpotent R := pgroup_nil pR. +have nRA: A \subset 'N(R) by rewrite -commg_subl defRA. +have p_gt3: p > 3; last split => //. + have [Ab1 | [q q_pr q_dv_Ab]] := trivgVpdiv (A / 'C_A(R)). + case/eqP: ntR; rewrite -defRA commGC; apply/commG1P. + by rewrite -subsetIidl -quotient_sub1 ?Ab1 ?normsI ?norms_cent ?normG. + have odd_q := dvdn_odd q_dv_Ab (quotient_odd _ oddA). + have p'q := pgroupP (quotient_pgroup _ p'A) q q_pr q_dv_Ab. + have q_gt1: q > 1 := prime_gt1 q_pr. + have q_gt2: q > 2 by rewrite ltn_neqAle; case: eqP odd_q => // <-. + apply: leq_ltn_trans q_gt2 _. + rewrite /= -ker_conj_aut (card_isog (first_isog_loc _ _)) // in q_dv_Ab. + have q_dv_A := dvdn_trans q_dv_Ab (cardSg (Aut_conj_aut _ _)). + by case/(pi_Aut_rank2_pgroup pR): (pgroupP (pgroup_pi _) q q_pr q_dv_A). +pose S := 'Ohm_1(R); pose S' := S^`(1); pose C := 'C_R(S). +have pS: p.-group S := pgroupS (Ohm_sub 1 _) pR. +have nsSR: S <| R := Ohm_normal 1 R. +have nsS'R: S' <| R := char_normal_trans (der_char 1 _) nsSR. +have [sSR nSR] := andP nsSR; have [_ nS'R] := andP nsS'R. +have [Sle2 | Sgt2] := leqP (logn p #|S|) 2. + have metaR: metacyclic R := p2_Ohm1_metacyclic pR p_gt3 Sle2. + have [cRR _ _] := coprime_metacyclic_cent_sdprod pR oddR metaR p'A nRA. + by left; rewrite -defRA. +have{p_gt3} eS: exponent S %| p by apply: exponent_Ohm1_rank2. +have{rR} rS: 'r(S) <= 2 by rewrite rank_Ohm1. +have{Sgt2} dimS: logn p #|S| = 3. + by apply/eqP; rewrite eqn_leq rank2_exponent_p_p3group. +have{rS} not_cSS: ~~ abelian S. + by apply: contraL rS => cSS; rewrite -ltnNge -dimS -rank_abelem ?abelem_Ohm1. +have esS: extraspecial S by apply: (p3group_extraspecial pS); rewrite ?dimS. +have defS': S' = 'Z(S) by case: esS; case. +have oS': #|S'| = p by rewrite defS' (card_center_extraspecial pS esS). +have dimS': logn p #|S'| = 1%N by rewrite oS' (pfactorK 1). +have nsCR: C <| R := normalGI nSR (cent_normal _); have [sCR nCR] := andP nsCR. +have [pC oddC]: p.-group C * odd #|C| := (pgroupS sCR pR, oddSg sCR oddR). +have defC1: 'Ohm_1(C) = S'. + apply/eqP; rewrite eqEsubset defS' subsetI OhmS ?(OhmE 1 pC) //= -/C. + by rewrite gen_subG setIAC subsetIr sub_gen ?setSI // subsetI sSR sub_LdivT. +have{pC oddC} cycC: cyclic C. + rewrite (odd_pgroup_rank1_cyclic pC) //. + by rewrite -p_rank_Ohm1 defC1 -dimS' p_rank_le_logn. +pose T := [~: S, R]; have nsTR: T <| R by rewrite /normal commg_normr comm_subG. +have [sTR nTR] := andP nsTR; have pT: p.-group T := pgroupS sTR pR. +have [sTS' | not_sTS' {esS}] := boolP (T \subset S'). + right; exists [group of S] => //; exists [group of C]. + by rewrite (critical_extraspecial pR sSR esS sTS'). +have ltTS: T \proper S by rewrite (nil_comm_properl nilR) ?Ohm1_eq1 ?subsetIidl. +have sTS: T \subset S := proper_sub ltTS. +have [sS'T ltS'T]: S' \subset T /\ S' \proper T by rewrite /proper commgS. +have{ltS'T ltTS} dimT: logn p #|T| = 2. + by apply/eqP; rewrite eqn_leq -ltnS -dimS -dimS' !properG_ltn_log. +have{eS} eT: exponent T %| p := dvdn_trans (exponentS sTS) eS. +have cTT: abelian T by rewrite (p2group_abelian pT) ?dimT. +have abelT: p.-abelem T by apply/and3P. +pose B := 'C_R(T); have sTB: T \subset B by rewrite subsetI sTR. +have nsBR: B <| R := normalGI nTR (cent_normal _); have [sBR nBR] := andP nsBR. +have not_sSB: ~~ (S \subset B). + by rewrite defS' !subsetI sTS sSR centsC in not_sTS' *. +have maxB: maximal B R. + rewrite p_index_maximal // (_ : #|R : B| = p) //; apply/prime_nt_dvdP=> //. + by apply: contra not_sSB; rewrite indexg_eq1; apply: subset_trans. + rewrite -(part_pnat_id (pnat_dvd (dvdn_indexg _ _) pR)) p_part. + by rewrite (@dvdn_exp2l _ _ 1) // logn_quotient_cent_abelem ?dimT //. +have{maxB nsBR} defR: B * S = R := mulg_normal_maximal nsBR maxB sSR not_sSB. +have cBbBb: abelian (B / C). + rewrite sub_der1_abelian // subsetI comm_subG ?subsetIl //=; apply/commG1P. + suff cB_SB: [~: S, B, B] = 1 by rewrite three_subgroup // [[~: _, S]]commGC. + by apply/commG1P; rewrite centsC subIset // centS ?orbT // commgS. +have{cBbBb} abelBb: p.-abelem (B / C). + apply/abelemP=> //; split=> // Cg; case/morphimP=> x Nx Bx /= ->. + have [Rx cTx] := setIP Bx; rewrite -morphX //= coset_id // inE groupX //=. + apply/centP=> y Sy; symmetry; have Tyx : [~ y, x] \in T by apply: mem_commg. + by apply/commgP; rewrite commgX ?(exponentP eT) //; apply: (centP cTx). +have nsCB: C <| B by rewrite (normalS _ _ nsCR) ?setIS ?subsetIl // centS. +have p'Ab: p^'.-group (A / C) by apply: quotient_pgroup. +have sTbB: T / C \subset B / C by rewrite quotientS. +have nSA: A \subset 'N(S) := char_norm_trans (Ohm_char 1 _) nRA. +have nTA: A \subset 'N(T) := normsR nSA nRA. +have nTbA: A / C \subset 'N(T / C) := quotient_norms _ nTA. +have nBbA: A / C \subset 'N(B / C). + by rewrite quotient_norms ?normsI ?norms_cent. +have{p'Ab sTbB nBbA abelBb nTbA} + [Xb defBb nXbA] := Maschke_abelem abelBb p'Ab sTbB nBbA nTbA. +have{defBb} [_] := dprodP defBb; rewrite /= -/T -/B => defBb _ tiTbX. +have sXbB: Xb \subset B / C by rewrite -defBb mulG_subr. +have{sXbB} [X] := inv_quotientS nsCB sXbB; rewrite /= -/C -/B => defXb sCX sXB. +have sXR: X \subset R := subset_trans sXB sBR; have pX := pgroupS sXR pR. +have nsCX: C <| X := normalS sCX sXR nsCR. +have{tiTbX} ziTX: T :&: X \subset C. + rewrite -quotient_sub1 ?subIset ?(subset_trans sTR) ?normal_norm //= -/C. + by rewrite quotientIG -?defXb ?tiTbX. +have{nXbA} nXA: A \subset 'N(X). + have nCA: A \subset 'N(C) by rewrite normsI ?norms_cent. + by rewrite -(quotientSGK nCA) ?normsG // quotient_normG -?defXb. +have{abelT} defB1: 'Ohm_1(B) = T. + apply/eqP; rewrite eq_sym eqEcard -{1}[T](Ohm1_id abelT) OhmS //. + have pB1: p.-group 'Ohm_1(B) := pgroupS (subset_trans (Ohm_sub 1 _) sBR) pR. + rewrite (card_pgroup pT) (card_pgroup pB1) leq_exp2l //= -/T -/B. + rewrite dimT -ltnS -dimS properG_ltn_log // properEneq OhmS ?subsetIl //= -/S. + by case: eqP not_sSB => // <-; rewrite Ohm_sub. +have{ziTX defB1} cycX: cyclic X; last have [x defX]:= cyclicP cycX. + rewrite (odd_pgroup_rank1_cyclic pX (oddSg sXR oddR)) -p_rank_Ohm1. + have:= cycC; rewrite abelian_rank1_cyclic ?cyclic_abelian //= -/C. + apply: leq_trans (leq_trans (p_rank_le_rank p _) (rankS _)). + by apply: subset_trans ziTX; rewrite subsetI Ohm_sub -defB1 OhmS. +have{Xb defXb defBb nsCX} mulSX: S * X = R. + have nCT: T \subset 'N(C) := subset_trans sTR nCR. + rewrite -defR -(normC (subset_trans sSR nBR)) -[B](quotientGK nsCB) -defBb. + rewrite cosetpreM quotientK // defXb quotientGK // -(normC nCT). + by rewrite -mulgA (mulSGid sCX) mulgA (mulGSid sTS). +have{mulSX} not_sXS_S': ~~ ([~: X, S] \subset S'). + apply: contra not_sTS' => sXS_S'; rewrite /T -mulSX. + by rewrite commGC commMG ?(subset_trans sXR) // mul_subG. +have [oSb oTb] : #|S / T| = p /\ #|T / S'| = p. + rewrite (card_pgroup (quotient_pgroup _ pS)) -divg_normal ?(normalS _ sSR) //. + rewrite (card_pgroup (quotient_pgroup _ pT)) -divg_normal ?(normalS _ sTR) //. + by rewrite !logn_div ?cardSg // dimS dimT dimS'. +have [Ty defSb]: exists Ty, S / T = <[Ty]>. + by apply/cyclicP; rewrite prime_cyclic ?oSb. +have SbTy: Ty \in S / T by rewrite defSb cycle_id. +have{SbTy} [y nTy Sy defTy] := morphimP SbTy. +have [S'z defTb]: exists S'z, T / S' = <[S'z]>. + apply/cyclicP; rewrite prime_cyclic ?oTb //. +have TbS'z: S'z \in T / S' by rewrite defTb cycle_id. +have{TbS'z} [z nS'z Tz defS'z] := morphimP TbS'z. +have [Ta AbTa not_cSbTa]: exists2 Ta, Ta \in A / T & Ta \notin 'C(S / T). + apply: subsetPn; rewrite quotient_cents2 ?commg_norml //= -/T commGC. + apply: contra not_sSB => sSA_T; rewrite (subset_trans sSR) // -defRA -defR. + rewrite -(normC (subset_trans sSR nBR)) commMG /= -/S -/B; last first. + by rewrite cents_norm ?subIset ?centS ?orbT. + by rewrite mul_subG ?commg_subl ?normsI ?norms_cent // (subset_trans sSA_T). +have [a nTa Aa defTa] := morphimP AbTa. +have nS'a: a \in 'N(S') := subsetP (char_norm_trans (der_char 1 _) nSA) a Aa. +have [i xa]: exists i, x ^ a = x ^+ i. + by apply/cycleP; rewrite -cycle_subG cycleJ /= -defX (normsP nXA). +have [j Tya]: exists j, Ty ^ Ta = Ty ^+ j. + apply/cycleP; rewrite -cycle_subG cycleJ /= -defSb. + by rewrite (normsP (quotient_norms _ nSA)). +suffices {oSb oddA not_cSbTa} j2_1: j ^ 2 == 1 %[mod p]. + have Tya2: Ty ^ coset T (a ^+ 2) = Ty ^+ (j ^ 2). + by rewrite morphX // conjgM -defTa Tya conjXg Tya expgM. + have coA2: coprime #|A| 2 by rewrite coprime_sym prime_coprime // dvdn2 oddA. + case/negP: not_cSbTa; rewrite defTa -(expgK coA2 Aa) morphX groupX //=. + rewrite defSb cent_cycle inE conjg_set1 Tya2 sub1set inE. + by rewrite (eq_expg_mod_order _ _ 1) orderE -defSb oSb. +have {Tya Ta defTa AbTa} [u Tu yj]: exists2 u, u \in T & y ^+ j = u * y ^ a. + apply: rcosetP; apply/rcoset_kercosetP; rewrite ?groupX ?groupJ //. + by rewrite morphX ?morphJ -?defTy // -defTa. +have{Ty defTy defSb} defS: T * <[y]> = S. + rewrite -quotientK ?cycle_subG ?quotient_cycle // -defTy -defSb /= -/T. + by rewrite quotientGK // /normal sTS /= commg_norml. +have{nTA} [k S'zk]: exists k, S'z ^ coset S' a = S'z ^+ k. + apply/cycleP; rewrite -cycle_subG cycleJ /= -defTb. + by rewrite (normsP (quotient_norms _ nTA)) ?mem_quotient. +have S'yz: [~ y, z] \in S' by rewrite mem_commg // (subsetP sTS). +have [v Zv zk]: exists2 v, v \in 'Z(S) & z ^+ k = v * z ^ a. + apply: rcosetP; rewrite -defS'. + by apply/rcoset_kercosetP; rewrite ?groupX ?groupJ ?morphX ?morphJ -?defS'z. +have defT: S' * <[z]> = T. + rewrite -quotientK ?cycle_subG ?quotient_cycle // -defS'z -defTb /= -/S'. + by rewrite quotientGK // (normalS _ sTR) // proper_sub. +have nt_yz: [~ y, z] != 1. + apply: contra not_cSS; rewrite (sameP commgP cent1P) => cyz. + rewrite -defS abelianM cTT cycle_abelian /= -/T -defT centM /= -/S' defS'. + by rewrite cent_cycle subsetI centsC subIset ?centS ?cycle_subG ?orbT. +have sS'X1: S' \subset 'Ohm_1(X) by rewrite -defC1 OhmS. +have i_neq0: i != 0 %[mod p]. + have: 'Ohm_1(X) != 1 by rewrite (subG1_contra sS'X1) //= -cardG_gt1 oS'. + rewrite defX in pX *; rewrite (Ohm_p_cycle 1 pX) subn1 trivg_card1 -orderE. + rewrite -(orderJ _ a) conjXg xa order_eq1 -expgM -order_dvdn mod0n. + apply: contra; case/dvdnP=> m ->; rewrite -mulnA -expnS dvdn_mull //. + by rewrite {1}[#[x]](card_pgroup pX) dvdn_exp2l ?leqSpred. +have Txy: [~ x, y] \in T by rewrite [T]commGC mem_commg // -cycle_subG -defX. +have [Rx Ry]: x \in R /\ y \in R by rewrite -cycle_subG -defX (subsetP sSR). +have [nS'x nS'y] := (subsetP nS'R x Rx, subsetP nS'R y Ry). +have{not_sXS_S'} not_S'xy: [~ x, y] \notin S'. + apply: contra not_sXS_S' => S'xy. + rewrite -quotient_cents2 ?(subset_trans _ nS'R) //= -/S'. + rewrite -defS quotientMl ?(subset_trans _ nS'R) // centM /= -/S' -/T. + rewrite subsetI quotient_cents; last by rewrite (subset_trans sXB) ?subsetIr. + rewrite defX !quotient_cycle // cent_cycle cycle_subG /= -/S'. + by rewrite (sameP cent1P commgP) -morphR /= ?coset_id. +have jk_eq_i: j * k = i %[mod p]. + have Zyz: [~ y, z] \in 'Z(S) by rewrite -defS'. + have Sz: z \in S := subsetP sTS z Tz. + have yz_p: [~ y, z] ^+ p == 1 by rewrite -order_dvdn -oS' order_dvdG. + have <-: #[[~ y, z]] = p by apply: nt_prime_order => //; apply: eqP. + apply: eqP; rewrite -eq_expg_mod_order -commXXg; try exact: centerC Zyz. + have cyv: [~ y ^+ j, v] = 1 by apply/eqP/commgP/(centerC (groupX j Sy) Zv). + have cuz: [~ u, z ^ a] = 1. + by apply/eqP/commgP/(centsP cTT); rewrite ?memJ_norm. + rewrite zk commgMJ cyv yj commMgJ cuz !conj1g mulg1 mul1g -conjRg. + suffices [m ->]: exists m, [~ y, z] = x ^+ m by rewrite conjXg xa expgAC. + by apply/cycleP; rewrite -defX (subsetP (Ohm_sub 1 X)) ?(subsetP sS'X1). +have ij_eq_k: i * j = k %[mod p]. + have <-: #[coset S' [~ x, y]] = p. + apply: nt_prime_order => //. + by apply: eqP; rewrite -order_dvdn -oTb order_dvdG 1?mem_quotient. + by apply: contraNneq not_S'xy; apply: coset_idr; rewrite groupR. + have sTbZ: T / S' \subset 'Z(R / S'). + rewrite prime_meetG ?oTb // (meet_center_nil (quotient_nil _ nilR)) //. + by rewrite quotient_normal //; apply/andP. + by rewrite -cardG_gt1 oTb. + have ZRxyb: [~ coset S' x, coset S' y] \in 'Z(R / S'). + by rewrite -morphR // (subsetP sTbZ) ?mem_quotient. + apply: eqP; rewrite -eq_expg_mod_order {1}morphR //. + rewrite -commXXg; try by apply: centerC ZRxyb; apply: mem_quotient. + have [Ru nRa] := (subsetP sTR u Tu, subsetP nRA a Aa). + rewrite -2?morphX // yj morphM ?(subsetP nS'R) ?memJ_norm //. + have cxu_b: [~ coset S' (x ^+ i), coset S' u] = 1. + apply: eqP; apply/commgP. + by apply: centerC (subsetP sTbZ _ _); rewrite mem_quotient ?groupX. + rewrite commgMJ cxu_b conj1g mulg1 -xa !morphJ // -conjRg -morphR //=. + have: coset S' [~ x, y] \in <[S'z]> by rewrite -defTb mem_quotient. + by case/cycleP=> m ->; rewrite conjXg S'zk expgAC. +have j2_gt0: j ^ 2 > 0. + rewrite expn_gt0 orbF lt0n; apply: contraNneq i_neq0 => j0. + by rewrite -jk_eq_i j0. +have{i_neq0} co_p_i: coprime p i by rewrite mod0n prime_coprime in i_neq0 *. +rewrite eqn_mod_dvd // -(Gauss_dvdr _ co_p_i) mulnBr -eqn_mod_dvd ?leq_mul //. +by rewrite muln1 mulnCA -modnMmr ij_eq_k modnMmr jk_eq_i. +Qed. + +(* This is B & G, Theorem 4.17. *) +Theorem der1_Aut_rank2_pgroup gT p (R : {group gT}) (A : {group {perm gT}}) : + p.-group R -> odd #|R| -> 'r(R) <= 2 -> + A \subset Aut R -> solvable A -> odd #|A| -> + p.-group A^`(1). +Proof. +move=> pR oddR rR AutA solA oddA. +without loss ntR: / R :!=: 1. + case: eqP AutA => [-> | ntR _ -> //]; rewrite Aut1. + by move/trivgP=> ->; rewrite derg1 commG1 pgroup1. +have [p_pr _ _] := pgroup_pdiv pR ntR; have p_gt1 := prime_gt1 p_pr. +have{ntR oddR} [H [charH _] _ eH pCH] := critical_odd pR oddR ntR. +have sHR := char_sub charH; have pH := pgroupS sHR pR. +have{rR} rH: 'r(H) <= 2 := leq_trans (rankS (char_sub charH)) rR. +have dimH: logn p #|H| <= 3 by rewrite rank2_exponent_p_p3group ?eH. +have{eH} ntH: H :!=: 1 by rewrite trivg_exponent eH gtnNdvd. +have charP := Phi_char H; have [sPH nPH] := andP (Phi_normal H : 'Phi(H) <| H). +have nHA: {acts A, on group H | [Aut R]} := gacts_char _ AutA charH. +pose B := 'C(H | <[nHA]>); pose V := H / 'Phi(H); pose C := 'C(V | <[nHA]> / _). +have{pCH} pB: p.-group B. + by rewrite (pgroupS _ pCH) //= astab_actby setIid subsetIr. +have s_p'C_B X: gval X \subset C -> p^'.-group X -> X \subset B. + move=> sXC p'X; have [sDX _] := subsetIP sXC; have [sXA _] := subsetIP sDX. + rewrite -gacentC //; apply/setIidPl; rewrite -[H :&: _]genGid //. + apply: Phi_nongen; apply/eqP; rewrite eqEsubset join_subG sPH subsetIl. + rewrite -quotientYK 1?subIset ?nPH //= -sub_quotient_pre //= -/V gacentIim. + have pP := pgroupS sPH pH; have coPX := pnat_coprime pP p'X. + rewrite -(setIid X) -(gacent_ract _ sXA). + rewrite ext_coprime_quotient_cent ?(pgroup_sol pP) ?acts_char //. + have domXb: X \subset qact_dom (<[nHA]> \ sXA) 'Phi(H). + by rewrite qact_domE ?acts_char. + rewrite gacentE // subsetIidl -/V; apply/subsetP=> v Vv; apply/afixP=> a Xa. + have [cVa dom_a] := (subsetP sXC a Xa, subsetP domXb a Xa). + have [x Nx Hx def_v] := morphimP Vv; rewrite {1}def_v qactE //=. + by rewrite -qactE ?(astab_dom cVa) ?(astab_act cVa) -?def_v. +have{B pB s_p'C_B} pC : p.-group C. + apply/pgroupP=> q q_pr; case/Cauchy=> // a Ca oa; apply: wlog_neg => p'q. + apply: (pgroupP pB) => //; rewrite -oa cardSg // s_p'C_B ?cycle_subG //. + by rewrite /pgroup -orderE oa pnatE. +have nVA: A \subset qact_dom <[nHA]> 'Phi(H) by rewrite qact_domE // acts_char. +have nCA: A \subset 'N(C). + by rewrite (subset_trans _ (astab_norm _ _)) // astabs_range. +suffices{pC nCA}: p.-group (A / C)^`(1). + by rewrite -quotient_der ?pquotient_pgroup // (subset_trans (der_sub 1 A)). +pose toAV := ((<[nHA]> / 'Phi(H)) \ nVA)%gact. +have defC: C = 'C(V | toAV). + by symmetry; rewrite astab_ract; apply/setIidPr; rewrite subIset ?subsetIl. +have abelV: p.-abelem V := Phi_quotient_abelem pH. +have ntV: V != 1 by rewrite -subG1 quotient_sub1 // proper_subn ?Phi_proper. +have: 'r(V) \in iota 1 2. + rewrite mem_iota rank_gt0 ntV (rank_abelem abelV). + have [abelH | not_abelH] := boolP (p.-abelem H). + by rewrite ltnS (leq_trans _ rH) // (rank_abelem abelH) logn_quotient. + by rewrite (leq_trans _ dimH) // ltn_log_quotient // (trivg_Phi pH). +rewrite !inE; case/pred2P=> dimV. + have isoAb: A / C \isog actperm toAV @* A. + by rewrite defC astab_range -ker_actperm first_isog. + rewrite (derG1P _) ?pgroup1 // (isog_abelian isoAb). + apply: abelianS (im_actperm_Aut _) (Aut_cyclic_abelian _). + by rewrite (abelem_cyclic abelV) -rank_abelem ?dimV. +pose Vb := sdpair1 toAV @* V; pose Ab := sdpair2 toAV @* A. +have [injV injA] := (injm_sdpair1 toAV, injm_sdpair2 toAV). +have abelVb: p.-abelem Vb := morphim_abelem _ abelV. +have ntVb: Vb != 1 by rewrite morphim_injm_eq1. +have nVbA: Ab \subset 'N(Vb) := im_sdpair_norm toAV. +pose rV := morphim_repr (abelem_repr abelVb ntVb nVbA) (subxx A). +have{defC} <-: rker rV = C; last move: rV. + rewrite rker_morphim rker_abelem morphpreI morphimK //=. + by rewrite (trivgP injA) mul1g -astabEsd // defC astab_ract 2!setIA !setIid. +have ->: 'dim Vb = 2 by rewrite (dim_abelemE abelVb) // card_injm -?rank_abelem. +move=> rV; rewrite -(eq_pgroup _ (GRing.charf_eq (char_Fp p_pr))). +by apply: der1_odd_GL2_charf (kquo_mx_faithful rV); rewrite !morphim_odd. +Qed. + +(* This is B & G, Theorem 4.18(a). *) +Theorem rank2_max_pdiv gT p q (G : {group gT}) : + solvable G -> odd #|G| -> 'r_p(G) <= 2 -> q \in \pi(G / 'O_p^'(G)) -> q <= p. +Proof. +rewrite mem_primes => solG oddG rG /and3P[pr_q _ /= q_dv_G]. +without loss Gp'1: gT G solG oddG rG q_dv_G / 'O_p^'(G) = 1. + move/(_ _ (G / 'O_p^'(G))%G); rewrite quotient_odd ?quotient_sol //. + rewrite trivg_pcore_quotient -(card_isog (quotient1_isog _)). + by rewrite p_rank_p'quotient ?pcore_pgroup ?gFnorm //; apply. +set R := 'O_p(G); have pR: p.-group R := pcore_pgroup p G. +have [sRG nRG] := andP (pcore_normal p G : R <| G). +have oddR: odd #|R| := oddSg sRG oddG. +have rR: 'r(R) <= 2 by rewrite (rank_pgroup pR) (leq_trans _ rG) ?p_rankS. +rewrite leq_eqVlt -implyNb; apply/implyP=> p'q. +have [|//] := pi_Aut_rank2_pgroup pR oddR rR _ p'q; rewrite eq_sym in p'q. +apply: (piSg (Aut_conj_aut _ G)); apply: contraLR q_dv_G. +rewrite -p'groupEpi -p'natE // Gp'1 -(card_isog (quotient1_isog _)) /pgroup. +rewrite -(card_isog (first_isog_loc _ _)) // -!pgroupE ker_conj_aut /= -/R. +set C := 'C_G(R); rewrite pquotient_pgroup ?normsI ?norms_cent ?normG //= -/C. +suffices sCR: C \subset R by rewrite (pgroupS sCR (pi_pnat pR _)). +by rewrite /C /R -(Fitting_eq_pcore _) ?cent_sub_Fitting. +Qed. + +(* This is B & G, Theorem 4.18(c,e) *) +Theorem rank2_der1_complement gT p (G : {group gT}) : + solvable G -> odd #|G| -> 'r_p(G) <= 2 -> + [/\ (*c*) p^'.-Hall(G^`(1)) 'O_p^'(G^`(1)), + (*e1*) abelian (G / 'O_{p^',p}(G)) + & (*e2*) p^'.-group (G / 'O_{p^',p}(G))]. +Proof. +move=> solG oddG rG; rewrite /pHall pcore_sub pcore_pgroup /= pnatNK. +rewrite -(pcore_setI_normal _ (der_normal 1 G)) // setIC indexgI /=. +without loss Gp'1: gT G solG oddG rG / 'O_p^'(G) = 1. + have nsGp': 'O_p^'(G) <| G := pcore_normal p^' G; have [_ nGp'] := andP nsGp'. + move/(_ _ (G / 'O_p^'(G))%G); rewrite quotient_sol // quotient_odd //=. + have Gp'1 := trivg_pcore_quotient p^' G. + rewrite p_rank_p'quotient ?pcore_pgroup // Gp'1 indexg1; case=> //=. + rewrite -quotient_der // card_quotient ?(subset_trans (der_sub 1 G)) // => ->. + rewrite (pseries_pop2 _ Gp'1) /= -pseries1 -quotient_pseries /= /pgroup. + pose isos := (isog_abelian (third_isog _ _ _), card_isog (third_isog _ _ _)). + by rewrite !{}isos ?pseries_normal ?pseries_sub_catl. +rewrite pseries_pop2 // Gp'1 indexg1 -pgroupE /=. +set R := 'O_p(G); pose C := 'C_G(R). +have [sRG nRG] := andP (pcore_normal p G : R <| G). +have sCR: C \subset R by rewrite /C /R -(Fitting_eq_pcore _) ?cent_sub_Fitting. +have pR: p.-group R := pcore_pgroup p G; have pC: p.-group C := pgroupS sCR pR. +have nCG: G \subset 'N(C) by rewrite normsI ?normG ?norms_cent. +have nsG'G: G^`(1) <| G := der_normal 1 G; have [sG'G nG'G] := andP nsG'G. +suffices sG'R: G^`(1) \subset R. + have cGbGb: abelian (G / R) := sub_der1_abelian sG'R. + rewrite -{2}(nilpotent_pcoreC p (abelian_nil cGbGb)) trivg_pcore_quotient. + by rewrite dprod1g pcore_pgroup (pgroupS sG'R pR). +rewrite pcore_max // -(pquotient_pgroup pC (subset_trans sG'G nCG)) /= -/C. +pose A := conj_aut 'O_p(G) @* G; have AutA: A \subset Aut R := Aut_conj_aut _ G. +have isoGbA: G / C \isog A by rewrite /C -ker_conj_aut first_isog_loc. +have{isoGbA} [f injf defA] := isogP isoGbA; rewrite /= -/A in defA. +rewrite quotient_der // /pgroup -(card_injm injf) ?der_sub ?morphim_der //. +have [? ?]: odd #|A| /\ solvable A by rewrite -defA !morphim_odd ?morphim_sol. +have rR: 'r(R) <= 2 by rewrite (rank_pgroup pR) (leq_trans (p_rankS p sRG)). +by rewrite defA -pgroupE (der1_Aut_rank2_pgroup pR) ?(oddSg sRG). +Qed. + +(* This is B & G, Theorem 4.18(b) *) +Theorem rank2_min_p_complement gT (G : {group gT}) (p := pdiv #|G|) : + solvable G -> odd #|G| -> 'r_p(G) <= 2 -> p^'.-Hall(G) 'O_p^'(G). +Proof. +move=> solG oddG rG; rewrite /pHall pcore_pgroup pcore_sub pnatNK /=. +rewrite -card_quotient ?gFnorm //; apply/pgroupP=> q q_pr q_dv_Gb. +rewrite inE /= eqn_leq (rank2_max_pdiv _ _ rG) ?mem_primes ?q_pr ?cardG_gt0 //. +by rewrite pdiv_min_dvd ?prime_gt1 ?(dvdn_trans q_dv_Gb) ?dvdn_quotient. +Qed. + +(* This is B & G, Theorem 4.18(d) *) +Theorem rank2_sub_p'core_der1 gT (G A : {group gT}) p : + solvable G -> odd #|G| -> 'r_p(G) <= 2 -> p^'.-subgroup(G^`(1)) A -> + A \subset 'O_p^'(G^`(1)). +Proof. +move=> solG oddG rG /andP[sAG' p'A]; rewrite sub_Hall_pcore //. +by have [-> _ _] := rank2_der1_complement solG oddG rG. +Qed. + +(* This is B & G, Corollary 4.19 *) +Corollary rank2_der1_cent_chief gT p (G Gs U V : {group gT}) : + odd #|G| -> solvable G -> Gs <| G -> 'r_p(Gs) <= 2 -> + chief_factor G V U -> p.-group (U / V) -> U \subset Gs -> + G^`(1) \subset 'C(U / V | 'Q). +Proof. +move=> oddG solG nsGsG rGs chiefUf pUf sUGs. +wlog Gs_p'_1: gT G Gs U V oddG solG nsGsG rGs chiefUf pUf sUGs / 'O_p^'(Gs) = 1. + pose K := 'O_p^'(Gs)%G; move/(_ _ (G / K) (Gs / K) (U / K) (V / K))%G. + rewrite trivg_pcore_quotient quotient_odd ?quotient_sol ?quotientS //. + have p'K: p^'.-group K := pcore_pgroup p^' Gs. + have tiUfK := coprime_TIg (pnat_coprime pUf (quotient_pgroup V p'K)). + have nsKG: K <| G := char_normal_trans (pcore_char p^' Gs) nsGsG. + have [[sG'G sGsG] nKG] := (der_sub 1 G, normal_sub nsGsG, normal_norm nsKG). + have{sGsG} [nKG' nKGs] := (subset_trans sG'G nKG, subset_trans sGsG nKG). + case/andP: chiefUf; case/maxgroupP; case/andP=> ltVU nVG maxV nsUG. + have [sUG nUG] := andP nsUG; have [sVU not_sUV] := andP ltVU. + have [nUG' nVG'] := (subset_trans sG'G nUG, subset_trans sG'G nVG). + have [sVG nVU] := (subset_trans sVU sUG, subset_trans sUG nVG). + have [nKU nKV] := (subset_trans sUG nKG, subset_trans sVG nKG). + have nsVU: V <| U by apply/andP. + rewrite p_rank_p'quotient // /chief_factor -quotient_der ?quotient_normal //. + rewrite andbT !sub_astabQR ?quotient_norms // -quotientR // => IH. + rewrite -quotient_sub1 ?comm_subG // -tiUfK subsetI quotientS ?commg_subr //. + rewrite quotientSK ?(comm_subG nVG') // (normC nKV) -quotientSK ?comm_subG //. + apply: IH => //=; last first. + rewrite -(setIid U) -(setIidPr sVU) -![_ / K](morphim_restrm nKU). + by rewrite -(morphim_quotm _ nsVU) morphim_pgroup. + apply/maxgroupP; rewrite /proper quotientS ?quotient_norms //= andbT. + rewrite quotientSK // -(normC nKV) -quotientSK // -subsetIidl tiUfK. + split=> [|Wb]; first by rewrite quotient_sub1. + do 2![case/andP]=> sWbU not_sUWb nWbG sVWb; apply/eqP; rewrite eqEsubset sVWb. + have nsWbG: Wb <| G / K by rewrite /normal (subset_trans sWbU) ?quotientS. + have [W defWb sKW] := inv_quotientN nsKG nsWbG; case/andP=> sWG nWG. + rewrite -(setIidPl sWbU) defWb -quotientGI // quotientS //. + rewrite (maxV (W :&: U))%G ?normsI //; last first. + by rewrite subsetI sVU andbT -(quotientSGK nKV sKW) -defWb. + by rewrite andbT /proper subsetIr subsetIidr -(quotientSGK nKU sKW) -defWb. +pose R := 'O_p(Gs); have pR: p.-group R := pcore_pgroup p Gs. +have nsRG: R <| G := char_normal_trans (pcore_char p Gs) nsGsG. +have [[sGsG nGsG] [sRG nRG]] := (andP nsGsG, andP nsRG). +have nsRGs: R <| Gs := pcore_normal p Gs; have [sRGs nRGs] := andP nsRGs. +have sylR: p.-Sylow(Gs) R. + have [solGs oddGs] := (solvableS sGsG solG, oddSg sGsG oddG). + have [_ _ p'Gsb] := rank2_der1_complement solGs oddGs rGs. + by rewrite /pHall pcore_sub pR -card_quotient //= -(pseries_pop2 p Gs_p'_1). +case/andP: (chiefUf); case/maxgroupP; case/andP=> ltVU nVG maxV nsUG. +have [sUG nUG] := andP nsUG; have [sVU not_sUV] := andP ltVU. +have [sVG nVU] := (subset_trans sVU sUG, subset_trans sUG nVG). +have nsVU: V <| U by apply/andP. +have nVGs := subset_trans sGsG nVG; have nVR := subset_trans sRGs nVGs. +have{sylR} sUfR: U / V \subset R / V. + have sylRb: p.-Sylow(Gs / V) (R / V) by rewrite quotient_pHall. + by rewrite (sub_normal_Hall sylRb) ?quotientS ?quotient_normal. +have pGb: p.-group((G / 'C_G(R))^`(1)). + pose A := conj_aut 'O_p(Gs) @* G. + have AA: A \subset Aut R := Aut_conj_aut _ G. + have isoGbA: G / 'C_G(R) \isog A by rewrite -ker_conj_aut first_isog_loc. + have{isoGbA} [f injf defA] := isogP isoGbA; rewrite /= -/A in defA. + rewrite /pgroup -(card_injm injf) ?der_sub ?morphim_der //. + have [? ?]: odd #|A| /\ solvable A by rewrite -defA !morphim_odd ?morphim_sol. + have rR: 'r(R) <= 2 by rewrite (rank_pgroup pR) (leq_trans (p_rankS p sRGs)). + by rewrite defA -pgroupE (der1_Aut_rank2_pgroup pR) ?(oddSg sRG). +set C := 'C_G(U / V | 'Q). +have nUfG: [acts G, on U / V | 'Q] by rewrite actsQ. +have nCG: G \subset 'N(C) by rewrite -(setIidPl nUfG) normsGI ?astab_norm. +have{pGb sUfR} pGa': p.-group (G / C)^`(1). + have nCRG : G \subset 'N('C_G(R)) by rewrite normsI ?normG ?norms_cent. + have sCR_C: 'C_G(R) \subset C. + rewrite subsetI subsetIl sub_astabQ ?subIset ?nVG ?(centsS sUfR) //=. + by rewrite quotient_cents ?subsetIr. + have [f /= <-]:= homgP (homg_quotientS nCRG nCG sCR_C). + by rewrite -morphim_der //= morphim_pgroup. +have irrG: acts_irreducibly (G / C) (U / V) ('Q %% _). + by rewrite acts_irr_mod_astab // acts_irrQ // chief_factor_minnormal. +have Ga_p_1: 'O_p(G / C) = 1. + rewrite (pcore_faithful_irr_act pUf _ irrG) ?modact_faithful //. + by rewrite gacentC ?quotientS ?subsetT ?subsetIr //= setICA subsetIl. +have sG'G := der_sub 1 G; have nCG' := subset_trans sG'G nCG. +rewrite -subsetIidl -{2}(setIidPl sG'G) -setIA subsetIidl -/C. +by rewrite -quotient_sub1 /= ?quotient_der //= -Ga_p_1 pcore_max ?der_normal. +Qed. + +(* This is B & G, Theorem 4.20(a) *) +Theorem rank2_der1_sub_Fitting gT (G : {group gT}) : + odd #|G| -> solvable G -> 'r('F(G)) <= 2 -> G^`(1) \subset 'F(G). +Proof. +move=> oddG solG Fle2; have nsFG := Fitting_normal G. +apply: subset_trans (chief_stab_sub_Fitting solG _) => //. +rewrite subsetI der_sub; apply/bigcapsP=> [[U V] /= /andP[chiefUV sUF]]. +have [p p_pr /andP[pUV _]] := is_abelemP (sol_chief_abelem solG chiefUV). +apply: rank2_der1_cent_chief nsFG _ _ pUV sUF => //. +exact: leq_trans (p_rank_le_rank p _) Fle2. +Qed. + +(* This is B & G, Theorem 4.20(b) *) +Theorem rank2_char_Sylow_normal gT (G S T : {group gT}) : + odd #|G| -> solvable G -> 'r('F(G)) <= 2 -> + Sylow G S -> T \char S -> T \subset S^`(1) -> T <| G. +Proof. +set F := 'F(G) => oddG solG Fle2 /SylowP[p p_pr sylS] charT sTS'. +have [sSG pS _] := and3P sylS. +have nsFG: F <| G := Fitting_normal G; have [sFG nFG] := andP nsFG. +have nFS := subset_trans sSG nFG; have nilF: nilpotent F := Fitting_nil _. +have cGGq: abelian (G / F). + by rewrite sub_der1_abelian ?rank2_der1_sub_Fitting. +have nsFS_G: F <*> S <| G. + rewrite -(quotientGK nsFG) norm_joinEr // -(quotientK nFS) cosetpre_normal. + by rewrite -sub_abelian_normal ?quotientS. +have sylSF: p.-Sylow(F <*> S) S. + by rewrite (pHall_subl _ _ sylS) ?joing_subr // join_subG sFG. +have defG: G :=: F * 'N_G(S). + rewrite -{1}(Frattini_arg nsFS_G sylSF) /= norm_joinEr // -mulgA. + by congr (_ * _); rewrite mulSGid // subsetI sSG normG. +rewrite /normal (subset_trans (char_sub charT)) //= defG mulG_subG /= -/F. +rewrite setIC andbC subIset /=; last by rewrite (char_norm_trans charT). +case/dprodP: (nilpotent_pcoreC p nilF); rewrite /= -/F => _ defF cFpFp' _. +have defFp: 'O_p(F) = F :&: S. + rewrite -{2}defF -group_modl ?coprime_TIg ?mulg1 //. + by rewrite coprime_sym (pnat_coprime pS (pcore_pgroup _ _)). + by rewrite p_core_Fitting pcore_sub_Hall. +rewrite -defF mulG_subG /= -/F defFp setIC subIset ?(char_norm charT) //=. +rewrite cents_norm // (subset_trans cFpFp') // defFp centS // subsetI. +rewrite (char_sub charT) (subset_trans (subset_trans sTS' (dergS 1 sSG))) //. +exact: rank2_der1_sub_Fitting. +Qed. + +(* This is B & G, Theorem 4.20(c), for the last factor of the series. *) +Theorem rank2_min_p'core_Hall gT (G : {group gT}) (p := pdiv #|G|) : + odd #|G| -> solvable G -> 'r('F(G)) <= 2 -> p^'.-Hall(G) 'O_p^'(G). +Proof. +set F := 'F(G) => oddG solG Fle2. +have nsFG: F <| G := Fitting_normal G; have [sFG nFG] := andP nsFG. +have [H] := inv_quotientN nsFG (pcore_normal p^' _). +rewrite /= -/F => defH sFH nsHG; have [sHG nHG] := andP nsHG. +have [P sylP] := Sylow_exists p H; have [sPH pP _] := and3P sylP. +have sPF: P \subset F. + rewrite -quotient_sub1 ?(subset_trans (subset_trans sPH sHG)) //. + rewrite -(setIidPl (quotientS _ sPH)) -defH coprime_TIg //. + by rewrite coprime_morphl // (pnat_coprime pP (pcore_pgroup _ _)). +have nilGq: nilpotent (G / F). + by rewrite abelian_nil ?sub_der1_abelian ?rank2_der1_sub_Fitting. +have pGq: p.-group (G / H). + rewrite /pgroup -(card_isog (third_isog sFH nsFG nsHG)) /= -/F -/(pgroup _ _). + rewrite -(dprodW (nilpotent_pcoreC p nilGq)) defH quotientMidr. + by rewrite quotient_pgroup ?pcore_pgroup. +rewrite pHallE pcore_sub -(Lagrange sHG) partnM // -card_quotient //=. +have hallHp': p^'.-Hall(H) 'O_p^'(H). + case p'H: (p^'.-group H). + by rewrite pHallE /= pcore_pgroup_id ?subxx //= part_pnat_id. + have def_p: p = pdiv #|H|. + have [p_pr pH]: prime p /\ p %| #|H|. + apply/andP; apply: contraFT p'H => p'H; apply/pgroupP=> q q_pr qH. + by apply: contraNneq p'H => <-; rewrite q_pr qH. + apply/eqP; rewrite eqn_leq ?pdiv_min_dvd ?prime_gt1 //. + rewrite pdiv_prime // cardG_gt1. + by case: eqP p'H => // ->; rewrite pgroup1. + exact: dvdn_trans (pdiv_dvd _) (cardSg (normal_sub nsHG)). + rewrite def_p rank2_min_p_complement ?(oddSg sHG) ?(solvableS sHG) -?def_p //. + rewrite -(p_rank_Sylow sylP) (leq_trans (p_rank_le_rank _ _)) //. + exact: leq_trans (rankS sPF) Fle2. +rewrite -(card_Hall hallHp') part_p'nat ?pnatNK ?muln1 // subset_leqif_card. + by rewrite pcore_max ?pcore_pgroup ?(char_normal_trans (pcore_char _ _)). +rewrite pcore_max ?pcore_pgroup // (normalS _ _ (pcore_normal _ _)) //. +rewrite -quotient_sub1 ?(subset_trans (pcore_sub _ _)) //. +rewrite -(setIidPr (quotientS _ (pcore_sub _ _))) coprime_TIg //. +by rewrite coprime_morphr // (pnat_coprime pGq (pcore_pgroup _ _)). +Qed. + +(* This is B & G, Theorem 4.20(c), for intermediate factors. *) +Theorem rank2_ge_pcore_Hall gT m (G : {group gT}) (pi := [pred p | p >= m]) : + odd #|G| -> solvable G -> 'r('F(G)) <= 2 -> pi.-Hall(G) 'O_pi(G). +Proof. +elim: {G}_.+1 {-2}G (ltnSn #|G|) => // n IHn G. +rewrite ltnS => leGn oddG solG Fle2; pose p := pdiv #|G|. +have [defGpi | not_pi_G] := eqVneq 'O_pi(G) G. + by rewrite /pHall pcore_sub pcore_pgroup defGpi indexgg. +have pi'_p: (p \in pi^'). + apply: contra not_pi_G => pi_p; rewrite eqEsubset pcore_sub pcore_max //. + apply/pgroupP=> q q_pr qG; apply: leq_trans pi_p _. + by rewrite pdiv_min_dvd ?prime_gt1. +pose Gp' := 'O_p^'(G); have sGp'G: Gp' \subset G := pcore_sub _ _. +have hallGp'pi: pi.-Hall(Gp') 'O_pi(Gp'). + apply: IHn; rewrite ?(oddSg sGp'G) ?(solvableS sGp'G) //; last first. + by apply: leq_trans (rankS _) Fle2; rewrite /= Fitting_pcore pcore_sub. + apply: leq_trans (proper_card _) leGn. + rewrite properEneq pcore_sub andbT; apply/eqP=> defG. + suff: p \in p^' by case/eqnP. + have p'G: p^'.-group G by rewrite -defG pcore_pgroup. + rewrite (pgroupP p'G) ?pdiv_dvd ?pdiv_prime // cardG_gt1. + by apply: contra not_pi_G; move/eqP->; rewrite (trivgP (pcore_sub _ _)). +have defGp'pi: 'O_pi(Gp') = 'O_pi(G). + rewrite -pcoreI; apply: eq_pcore => q; apply: andb_idr. + by apply: contraL => /=; move/eqnP->. +have hallGp': p^'.-Hall(G) Gp' by rewrite rank2_min_p'core_Hall. +rewrite pHallE pcore_sub /= -defGp'pi (card_Hall hallGp'pi) (card_Hall hallGp'). +by rewrite partn_part // => q; apply: contraL => /=; move/eqnP->. +Qed. + +(* This is B & G, Theorem 4.20(c), for the first factor of the series. *) +Theorem rank2_max_pcore_Sylow gT (G : {group gT}) (p := max_pdiv #|G|) : + odd #|G| -> solvable G -> 'r('F(G)) <= 2 -> p.-Sylow(G) 'O_p(G). +Proof. +move=> oddG solG Fle2; pose pi := [pred q | p <= q]. +rewrite pHallE pcore_sub eqn_leq -{1}(part_pnat_id (pcore_pgroup _ _)). +rewrite dvdn_leq ?partn_dvd ?cardSg ?pcore_sub // /=. +rewrite (@eq_in_partn _ pi) => [|q piGq]; last first. + by rewrite !inE eqn_leq; apply: andb_idl => le_q_p; exact: max_pdiv_max. +rewrite -(card_Hall (rank2_ge_pcore_Hall p oddG solG Fle2)) -/pi. +rewrite subset_leq_card // pcore_max ?pcore_normal //. +apply: sub_in_pnat (pcore_pgroup _ _) => q; move/(piSg (pcore_sub _ _)) => piGq. +by rewrite !inE eqn_leq max_pdiv_max. +Qed. + +End Section4. diff --git a/mathcomp/odd_order/BGsection5.v b/mathcomp/odd_order/BGsection5.v new file mode 100644 index 0000000..ab5a14a --- /dev/null +++ b/mathcomp/odd_order/BGsection5.v @@ -0,0 +1,536 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div. +Require Import fintype finset prime fingroup morphism perm automorphism action. +Require Import quotient cyclic gfunctor pgroup gproduct center commutator. +Require Import gseries nilpotent sylow abelian maximal hall. +Require Import BGsection1 BGsection4. + +(******************************************************************************) +(* This file covers Section 5 of B & G, except for some technical results *) +(* that are not actually used in the proof of the Odd Order Theorem, namely *) +(* part (c) of Theorem 5.5, parts (b), (d) and (e) of Theorem 5.5, and all of *) +(* Theorem 5.7. We also make the following change: in B & G, narrow p-groups *) +(* of rank at least 3 are defined by the structure of the centralisers of *) +(* their prime subgroups, then characterized by their rank 2 elementary *) +(* abelian subgroups in Theorem 5.3. We exchange the two, because the latter *) +(* condition is easier to check, and is the only one used later in the proof. *) +(* *) +(* p.-narrow G == G has a maximal elementary abelian p-subgroup of *) +(* p-rank at most 2. *) +(* := ('r_p(G) > 2) ==> ('E_p^2(G) :&: 'E*_p(G) != set0) *) +(* *) +(* narrow_structure p G <-> G has a subgroup S of order p whose centraliser *) +(* is the direct product of S and a cyclic group C, *) +(* i.e., S \x C = 'C_G(S). This is the condition used *) +(* in the definition of "narrow" in B & G, p. 2. *) +(* Theorem 5.3 states that for odd p this definition *) +(* is equivalent to ours, and this property is not *) +(* used outside of Section 5. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Reserved Notation "p .-narrow" (at level 2, format "p .-narrow"). + +Section Definitions. + +Variables (gT : finGroupType) (p : nat) (A : {set gT}). + +Definition narrow := ('r_p(A) > 2) ==> ('E_p^2(A) :&: 'E*_p(A) != set0). + +Inductive narrow_structure : Prop := + NarrowStructure (S C : {group gT}) of + S \subset A & C \subset A & #|S| = p & cyclic C & S \x C = 'C_A(S). + +End Definitions. + +Notation "p .-narrow" := (narrow p) : group_scope. + +Section IsoDef. + +Variables (gT rT : finGroupType) (p : nat). +Implicit Types G H : {group gT}. +Implicit Type R : {group rT}. + +Lemma injm_narrow G H (f : {morphism G >-> rT}) : + 'injm f -> H \subset G -> p.-narrow (f @* H) = p.-narrow H. +Proof. +move=> injf sHG; rewrite /narrow injm_p_rank //; congr (_ ==> _). +apply/set0Pn/set0Pn=> [] [E /setIP[Ep2E maxE]]. + exists (invm injf @* E)%G; rewrite -[H](group_inj (morphim_invm injf _)) //. + have sEfG: E \subset f @* G. + by rewrite (subset_trans _ (morphimS _ sHG)) //; case/pnElemP: Ep2E. + by rewrite inE injm_pnElem ?injm_pmaxElem ?injm_invm ?morphimS // Ep2E. +have sEG: E \subset G by rewrite (subset_trans _ sHG) //; case/pnElemP: Ep2E. +by exists (f @* E)%G; rewrite inE injm_pnElem ?injm_pmaxElem // Ep2E. +Qed. + +Lemma isog_narrow G R : G \isog R -> p.-narrow G = p.-narrow R. +Proof. by case/isogP=> f injf <-; rewrite injm_narrow. Qed. + +(* No isomorphism theorems for narrow_structure, which is not used outside of *) +(* this file. *) + +End IsoDef. + +Section Five. + +Implicit Type gT : finGroupType. +Implicit Type p : nat. + +Section OneGroup. + +Variables (gT : finGroupType) (p : nat) (R : {group gT}). +Implicit Types B E S : {group gT}. + +Lemma narrowJ x : p.-narrow (R :^ x) = p.-narrow R. +Proof. by apply: isog_narrow (isog_symr (conj_isog R x)). Qed. + +Hypotheses (pR : p.-group R) (oddR : odd #|R|). + +Section Rank3. + +Hypothesis rR : 2 < 'r_p(R). + +(* This lemma uses only the rR hypothesis. *) +Lemma narrow_pmaxElem : p.-narrow R -> exists E, E \in 'E_p^2(R) :&: 'E*_p(R). +Proof. by move=> nnP; apply: set0Pn; apply: implyP rR. Qed. + +Let ntR : R :!=: 1. Proof. by case: eqP rR => // ->; rewrite p_rank1. Qed. +Let p_pr : prime p. Proof. by case: (pgroup_pdiv pR ntR). Qed. +Let p_gt1 : p > 1. Proof. exact: prime_gt1. Qed. + +(* This is B & G, Lemma 5.1(a). *) +Lemma rank3_SCN3 : exists B, B \in 'SCN_3(R). +Proof. +by apply/set0Pn; rewrite -(rank2_SCN3_empty pR oddR) leqNgt (rank_pgroup pR) rR. +Qed. + +(* This is B & G, Lemma 5.1(b). *) +Lemma normal_p2Elem_SCN3 E : + E \in 'E_p^2(R) -> E <| R -> exists2 B, B \in 'SCN_3(R) & E \subset B. +Proof. +move=> Ep2E /andP[sER nER]; have [_ abelE dimE] := pnElemP Ep2E. +have [B Ep3B nBR]: exists2 B, B \in 'E_p^3(R) & R \subset 'N(B). + have [C] := rank3_SCN3; case/setIdP=> SCN_C rC. + have [nsCR cCC] := andP (maxgroupp (SCN_max SCN_C)). + have [sCR _] := andP nsCR; have pC: p.-group C := pgroupS sCR pR. + have{pC cCC} abelC1: p.-abelem 'Ohm_1(C) := Ohm1_abelem pC cCC. + have dimC1: 3 <= logn p #|'Ohm_1(C)| by rewrite -rank_abelem // rank_Ohm1. + have nsC1R: 'Ohm_1(C) <| R := char_normal_trans (Ohm_char 1 _) nsCR. + have [B [sBC1 nsBR oB]] := normal_pgroup pR nsC1R dimC1. + have [sBR nBR] := andP nsBR; exists B => //; apply/pnElemP. + by rewrite oB pfactorK // (abelemS sBC1). +have [sBR abelB dimB] := pnElemP Ep3B; have [pB cBB _] := and3P abelB. +have [oB oE] := (card_pnElem Ep3B, card_pnElem Ep2E). +pose Bs := (E <*> 'C_B(E))%G; have sCB: 'C_B(E) \subset B := subsetIl B _. +have sBsR: Bs \subset R by rewrite join_subG sER subIset ?sBR. +suffices Bs_gt2: 2 < logn p #|Bs|. + have nBsR: Bs <| R by rewrite /normal sBsR // normsY ?normsI ?norms_cent. + have abelBs: p.-abelem Bs. + by rewrite (cprod_abelem p (cprodEY _)) ?subsetIr // abelE (abelemS sCB). + have [C maxC sBsC] : {H | [max H | H <| R & abelian H ] & Bs \subset H}. + by apply: maxgroup_exists; rewrite nBsR (abelem_abelian abelBs). + exists C; last by rewrite (subset_trans _ sBsC) ?joing_subl. + by rewrite inE (max_SCN pR) ?(leq_trans Bs_gt2) // -rank_abelem ?rankS. +apply: contraFT (ltnn 2); rewrite -leqNgt => Bs_le2. +have{Bs_le2} sCE: 'C_B(E) \subset E. + rewrite (sameP joing_idPl eqP) eq_sym eqEcard joing_subl /=. + by rewrite (card_pgroup (pgroupS sBsR pR)) oE leq_exp2l. +have dimCBE: 2 <= logn p #|'C_B(E)|. + rewrite -ltnS -dimB -addn1 -leq_subLR -logn_div ?divgS ?cardSg //. + by rewrite logn_quotient_cent_abelem ?dimE ?(subset_trans sBR nER). +have defE: 'C_B(E) = E. + apply/eqP; rewrite eqEcard sCE oE /=. + by rewrite (card_pgroup (pgroupS sCB pB)) leq_exp2l. +by rewrite -dimB -dimE -defE lognSg // subsetIidl sub_abelian_cent // -defE. +Qed. + +Let Z := 'Ohm_1('Z(R)). +Let W := 'Ohm_1('Z_2(R)). +Let T := 'C_R(W). + +Let ntZ : Z != 1. +Proof. by rewrite Ohm1_eq1 (center_nil_eq1 (pgroup_nil pR)). Qed. + +Let sZR : Z \subset R. +Proof. exact: subset_trans (Ohm_sub 1 _) (center_sub R). Qed. + +Let abelZ : p.-abelem (Z). +Proof. by rewrite (Ohm1_abelem (pgroupS _ pR)) ?center_sub ?center_abelian. Qed. + +Let pZ : p.-group Z. +Proof. exact: abelem_pgroup abelZ. Qed. + +Let defCRZ : 'C_R(Z) = R. +Proof. +apply/eqP; rewrite eqEsubset subsetIl subsetIidl centsC. +by rewrite (subset_trans (Ohm_sub 1 _)) ?subsetIr. +Qed. + +Let sWR : W \subset R. +Proof. exact: subset_trans (Ohm_sub 1 _) (ucn_sub 2 R). Qed. + +Let nWR : R \subset 'N(W). +Proof. exact: char_norm_trans (Ohm_char 1 _) (char_norm (ucn_char 2 R)). Qed. + +(* This is B & G, Lemma 5.2. *) +Lemma Ohm1_ucn_p2maxElem E : + E \in 'E_p^2(R) :&: 'E*_p(R) -> + [/\ (*a*) ~~ (E \subset T), + (*b*) #|Z| = p /\ [group of W] \in 'E_p^2(R) + & (*c*) T \char R /\ #|R : T| = p ]. +Proof. +case/setIP=> Ep2E maxE; have defCRE1 := Ohm1_cent_max maxE pR. +have [[sER abelE dimE] oE] := (pnElemP Ep2E, card_pnElem Ep2E). +have [[sZR_R nZR_R] [pE _ eE]] := (andP (center_normal R), and3P abelE). +have{nZR_R} nZR: R \subset 'N(Z) := char_norm_trans (Ohm_char 1 _) nZR_R. +have{sZR_R} [pZR pW] := (pgroupS sZR_R pR, pgroupS sWR pR). +have sZE: Z \subset E by rewrite -defCRE1 OhmS ?setIS // centS. +have rCRE : 'r_p('C_R(E)) = 2 by rewrite -p_rank_Ohm1 defCRE1 p_rank_abelem. +have oZ: #|Z| = p. + apply/prime_nt_dvdP; rewrite -?trivg_card1 // (card_pgroup pZ) /= -/Z. + rewrite (@dvdn_exp2l _ _ 1) // -ltnS -dimE properG_ltn_log //= -/Z. + by case/eqVproper: sZE rR => // defZ; rewrite -defCRZ defZ rCRE ltnn. +have ncycR: ~~ cyclic R by rewrite (odd_pgroup_rank1_cyclic pR) // -(subnKC rR). +have [ncycW eW] := Ohm1_odd_ucn2 pR oddR ncycR; rewrite -/W in ncycW eW. +have sWRZ: [~: W, R] \subset Z. + rewrite [Z](OhmE 1 pZR) sub_gen //= -ucn1 subsetI. + rewrite (subset_trans _ (ucn_comm 1 _)) ?commSg ?Ohm_sub //. + by move: nWR eW; rewrite -commg_subl -sub_LdivT; apply: subset_trans. +have sZW: Z \subset W by rewrite OhmS /= -?ucn1 ?ucn_subS //. +have ltZW: Z \proper W. + by rewrite properEneq; case: eqP ncycW => // <-; rewrite prime_cyclic ?oZ. +have sWRE := subset_trans sWRZ sZE. +have nEW: W \subset 'N(E) by rewrite -commg_subr (subset_trans _ sWRE) ?commgSS. +have defZ: 'C_W(E) = Z. + have sCE: 'C_W(E) \subset E. + rewrite -{2}defCRE1 (OhmE 1 (pgroupS (subsetIl R _) pR)) sub_gen //. + by rewrite subsetI setSI // subIset // sub_LdivT eW. + have [defC | ltCE] := eqVproper sCE. + have sEW: E \subset W by rewrite -defC subsetIl. + have nsER: E <| R. + by rewrite /normal sER -commg_subl (subset_trans (commSg R sEW)). + have [B scn3B sEB] := normal_p2Elem_SCN3 Ep2E nsER. + have [scnB dimB] := setIdP scn3B; have [_ scBR] := SCN_P scnB. + rewrite ltnNge -rank_Ohm1 -dimE -rank_abelem ?rankS // in dimB. + by rewrite -scBR -defCRE1 OhmS // setIS ?centS. + apply/eqP; rewrite eq_sym eqEcard oZ (card_pgroup (pgroupS sCE pE)) /= -/W. + rewrite subsetI sZW (centsS sER); last by rewrite centsC -subsetIidl defCRZ. + by rewrite (leq_exp2l _ 1) // -ltnS -dimE properG_ltn_log. +have dimW: logn p #|W| = 2. + apply/eqP; rewrite -(Lagrange sZW) lognM ?cardG_gt0 // oZ (pfactorK 1) //=. + rewrite -/Z eqSS eqn_leq -{1}defZ logn_quotient_cent_abelem ?dimE // -/W. + by rewrite -divgS // logn_div ?cardSg // subn_gt0 properG_ltn_log. +have abelW: p.-abelem W. + by rewrite (abelem_Ohm1 (pgroupS _ pR)) ?(p2group_abelian pW) ?dimW ?ucn_sub. +have charT: T \char R. + by rewrite subcent_char ?char_refl //= (char_trans (Ohm_char 1 _)) ?ucn_char. +rewrite 2!inE sWR abelW dimW; do 2?split => //. + by apply: contra (proper_subn ltZW); rewrite -defZ !subsetI subxx sER centsC. +apply/prime_nt_dvdP=> //. + rewrite indexg_eq1 subsetIidl centsC; apply: contraFN (ltnn 1) => cRW. + by rewrite -dimW -(setIidPl (centsS sER cRW)) defZ oZ (pfactorK 1). +rewrite -(part_pnat_id (pnat_dvd (dvdn_indexg _ _) pR)) p_part. +by rewrite (@dvdn_exp2l p _ 1) ?logn_quotient_cent_abelem ?dimW. +Qed. + +(* This is B & G, Theorem 5.3(d); we omit parts (a)-(c) as they are mostly *) +(* redundant with Lemma 5.2, given our definition of "narrow". *) +Theorem narrow_cent_dprod S : + p.-narrow R -> #|S| = p -> S \subset R -> 'r_p('C_R(S)) <= 2 -> + [/\ cyclic 'C_T(S), S :&: R^`(1) = 1, S :&: T = 1 & S \x 'C_T(S) = 'C_R(S)]. +Proof. +move=> nnR oS sSR rS; have pS : p.-group S := pgroupS sSR pR. +have [E maxEp2E] := narrow_pmaxElem nnR; have [Ep2E maxE] := setIP maxEp2E. +have [not_sET [oZ Ep2W] [charT maxT]] := Ohm1_ucn_p2maxElem maxEp2E. +have cZS : S \subset 'C(Z) by rewrite (subset_trans sSR) // -defCRZ subsetIr. +have nZS : S \subset 'N(Z) by rewrite cents_norm. +have cSS : abelian S by rewrite cyclic_abelian ?prime_cyclic // oS. +pose SZ := (S <*> [group of Z])%G; have sSSZ: S \subset SZ := joing_subl _ _. +have sSZ_R: SZ \subset R by rewrite join_subG sSR sZR. +have abelSZ : p.-abelem SZ. + by rewrite /= joingC (cprod_abelem p (cprodEY cZS)) abelZ prime_abelem. +have tiSZ: S :&: Z = 1. + rewrite prime_TIg ?oS //= -/Z; apply: contraL rR => sZS. + by rewrite -leqNgt (leq_trans _ rS) ?p_rankS // -{1}defCRZ setIS ?centS. +have{tiSZ} oSZ: #|SZ| = (p ^ 2)%N by rewrite /= norm_joinEl ?TI_cardMg ?oS ?oZ. +have Ep2SZ: SZ \in 'E_p^2(R) by rewrite pnElemE // !inE sSZ_R abelSZ oSZ eqxx. +have{oSZ Ep2SZ abelSZ sSZ_R} maxSZ: SZ \in 'E_p^2(R) :&: 'E*_p(R). + rewrite inE Ep2SZ; apply/pmaxElemP; rewrite inE sSZ_R abelSZ. + split=> // H /setIdP[sHR abelH] sSZH. + have [[_ _ dimSZ] [cHH pH _]] := (pnElemP Ep2SZ, and3P abelH). + have sSH: S \subset H := subset_trans sSSZ sSZH. + have{sSH} sH_CRS: H \subset 'C_R(S) by rewrite subsetI sHR (centsS sSH). + have{sH_CRS}: 'r_p(H) <= 2 by rewrite (leq_trans _ rS) ?p_rankS. + apply: contraTeq; rewrite eq_sym eqEproper sSZH negbK => lSZH. + by rewrite -ltnNge p_rank_abelem // -dimSZ properG_ltn_log. +have sZT: Z \subset T. + by rewrite subsetI sZR (centsS sWR) // centsC -defCRZ subsetIr. +have{SZ sSSZ maxSZ} not_sST: ~~ (S \subset T). + have: ~~ (SZ \subset T) by case/Ohm1_ucn_p2maxElem: maxSZ. + by rewrite join_subG sZT andbT. +have tiST: S :&: T :=: 1 by rewrite prime_TIg ?oS. +have defST: S * T = R. + apply/eqP; rewrite eqEcard TI_cardMg ?mul_subG ?subsetIl //=. + by rewrite mulnC oS -maxT Lagrange ?subsetIl. +have cRRb: abelian (R / T) by rewrite -defST quotientMidr quotient_abelian. +have sR'T: R^`(1) \subset T by rewrite der1_min ?char_norm. +have TI_SR': S :&: R^`(1) :=: 1. + by rewrite prime_TIg ?oS // (contra _ not_sST) //; move/subset_trans->. +have defCRS : S \x 'C_T(S) = 'C_R(S). + rewrite (dprodE _ _) ?subsetIr //= -/T; last by rewrite setIA tiST setI1g. + rewrite -{1}(center_idP cSS) subcent_TImulg ?defST //. + by rewrite subsetI normG (subset_trans sSR) ?char_norm. +have sCTSR: 'C_T(S) \subset R by rewrite subIset ?subsetIl. +split; rewrite ?(odd_pgroup_rank1_cyclic (pgroupS _ pR) (oddSg _ oddR)) //= -/T. +rewrite -ltnS (leq_trans _ rS) //= -(p_rank_dprod p defCRS) -add1n leq_add2r. +by rewrite -rank_pgroup // rank_gt0 -cardG_gt1 oS. +Qed. + +(* This is B & G, Corollary 5.4. Given our definition of narrow, this is used *) +(* directly in the proof of the main part of Theorem 5.3. *) +Corollary narrow_centP : + reflect (exists S, [/\ gval S \subset R, #|S| = p & 'r_p('C_R(S)) <= 2]) + (p.-narrow R). +Proof. +rewrite /narrow rR; apply: (iffP (set0Pn _)) => [[E maxEp2E]|[S [sSR oS rCRS]]]. + have [Ep2E maxE] := setIP maxEp2E. + have{maxEp2E} [_ [oZ _] _] := Ohm1_ucn_p2maxElem maxEp2E. + have [sER abelE dimE] := pnElemP Ep2E; have oE := card_pnElem Ep2E. + have sZE: Z \subset E by rewrite -(Ohm1_cent_max maxE pR) OhmS ?setIS ?centS. + have [S defE] := abelem_split_dprod abelE sZE; exists S. + have{defE} [[_ defZS _ _] oZS] := (dprodP defE, dprod_card defE). + split; first by rewrite (subset_trans _ sER) // -defZS mulG_subr. + by apply/eqP; rewrite -(eqn_pmul2l (ltnW p_gt1)) -{1}oZ oZS oE. + rewrite -dimE -p_rank_abelem // -(Ohm1_cent_max maxE pR) p_rank_Ohm1. + by rewrite -defZS /= centM setIA defCRZ. +have abelS := prime_abelem p_pr oS. +have cSZ: Z \subset 'C(S) by rewrite (centsS sSR) // centsC -defCRZ subsetIr. +have sSZR: S <*> Z \subset R by rewrite join_subG sSR. +have defSZ: S \x Z = S <*> Z. + rewrite dprodEY ?prime_TIg ?oS //= -/Z; apply: contraL rR => sSZ. + by rewrite -leqNgt (leq_trans _ rCRS) ?p_rankS // -{1}defCRZ setIS ?centS. +have abelSZ: p.-abelem (S <*> Z) by rewrite (dprod_abelem p defSZ) abelS. +have [pSZ cSZSZ _] := and3P abelSZ. +have dimSZ: logn p #|S <*> Z| = 2. + apply/eqP; rewrite -p_rank_abelem // eqn_leq (leq_trans (p_rankS _ _) rCRS). + rewrite -(p_rank_dprod p defSZ) p_rank_abelem // oS (pfactorK 1) // ltnS. + by rewrite -rank_pgroup // rank_gt0. + by rewrite subsetI sSZR sub_abelian_cent ?joing_subl. +exists [group of S <*> Z]; rewrite 3!inE sSZR abelSZ dimSZ /=. +apply/pmaxElemP; rewrite inE sSZR; split=> // E; case/pElemP=> sER abelE sSZE. +apply: contraTeq rCRS; rewrite eq_sym -ltnNge -dimSZ => neqSZE. +have [[pE cEE _] sSE] := (and3P abelE, subset_trans (joing_subl S Z) sSZE). +rewrite (leq_trans (properG_ltn_log pE _)) ?properEneq ?neqSZE //. +by rewrite -p_rank_abelem ?p_rankS // subsetI sER sub_abelian_cent. +Qed. + +(* This is the main statement of B & G, Theorem 5.3, stating the equivalence *) +(* of the structural and rank characterizations of the "narrow" property. Due *) +(* to our definition of "narrow", the equivalence is the converse of that in *) +(* B & G (we define narrow in terms of maximal elementary abelian subgroups). *) +Lemma narrow_structureP : reflect (narrow_structure p R) (p.-narrow R). +Proof. +apply: (iffP idP) => [nnR | [S C sSR sCR oS cycC defSC]]. + have [S [sSR oS rCRS]] := narrow_centP nnR. + have [cycC _ _ defCRS] := narrow_cent_dprod nnR oS sSR rCRS. + by exists S [group of 'C_T(S)]; rewrite //= -setIA subsetIl. +apply/narrow_centP; exists S; split=> //. +have cycS: cyclic S by rewrite prime_cyclic ?oS. +rewrite -(p_rank_dprod p defSC) -!(rank_pgroup (pgroupS _ pR)) // -addn1. +rewrite leq_add -?abelian_rank1_cyclic ?cyclic_abelian //. +Qed. + +End Rank3. + +(* This is B & G, Theoren 5.5 (a) and (b). Part (c), which is not used in the *) +(* proof of the Odd Order Theorem, is omitted. *) +Theorem Aut_narrow (A : {group {perm gT}}) : + p.-narrow R -> solvable A -> A \subset Aut R -> odd #|A| -> + [/\ (*a*) p^'.-group (A / 'O_p(A)), abelian (A / 'O_p(A)) + & (*b*) 2 < 'r(R) -> forall x, x \in A -> p^'.-elt x -> #[x] %| p.-1]. +Proof. +move=> nnR solA AutA oddA; have nilR := pgroup_nil pR. +have [rR | rR] := leqP 'r(R) 2. + have pA' := der1_Aut_rank2_pgroup pR oddR rR AutA solA oddA. + have sA'Ap: A^`(1) \subset 'O_p(A) by rewrite pcore_max ?der_normal. + have cAbAb: abelian (A / 'O_p(A)) by rewrite sub_der1_abelian. + split; rewrite // -(nilpotent_pcoreC p (abelian_nil cAbAb)). + by rewrite trivg_pcore_quotient dprod1g pcore_pgroup. +have ntR: R :!=: 1 by rewrite -rank_gt0 2?ltnW. +rewrite (rank_pgroup pR) in rR. +have [H [charH sHRZ] _ eH pCH] := critical_odd pR oddR ntR. +have{ntR} [[p_pr _ _] sHR] := (pgroup_pdiv pR ntR, char_sub charH). +have ntH: H :!=: 1 by rewrite trivg_exponent eH -prime_coprime ?coprimen1. +have{nnR} [S C sSR sCR oS cycC defSC] := narrow_structureP rR nnR. +have [_ mulSC cSC tiSC] := dprodP defSC. +have abelS: p.-abelem S := prime_abelem p_pr oS; have [pS cSS _] := and3P abelS. +have cycS: cyclic S by rewrite prime_cyclic ?oS. +have tiHS: H :&: S = 1. + have rCRS: 'r_p('C_R(S)) <= 2. + rewrite -(p_rank_dprod p defSC) -addn1 -!rank_pgroup ?(pgroupS _ pR) //. + by rewrite leq_add -?abelian_rank1_cyclic ?cyclic_abelian. + rewrite setIC prime_TIg ?oS //; apply: contraL (rCRS) => sSH; rewrite -ltnNge. + have cZHS: S \subset 'C('Z(H)) by rewrite centsC (centsS sSH) ?subsetIr. + pose U := S <*> 'Z(H). + have sUH: U \subset H by rewrite join_subG sSH subsetIl. + have cUU: abelian U by rewrite abelianY cSS center_abelian centsC. + have abelU: p.-abelem U by rewrite abelemE // cUU -eH exponentS. + have sUR: U \subset R := subset_trans sUH sHR. + have rU: 'r_p(U) <= 'r_p('C_R(S)). + by rewrite p_rankS //= subsetI sUR (centsS (joing_subl S 'Z(H))). + have nsUR: U <| R. + rewrite /normal sUR -commg_subl (subset_trans (commSg _ sUH)) //= -/U. + by rewrite (subset_trans sHRZ) // joing_subr. + have{rU}:= leq_trans rU rCRS; rewrite leq_eqVlt => /predU1P[] rU. + have Ep2U: [group of U] \in 'E_p^2(R). + by rewrite !inE /= sUR abelU -(p_rank_abelem abelU) rU. + have [F scn3F sUF] := normal_p2Elem_SCN3 rR Ep2U nsUR. + have [scnF rF] := setIdP scn3F; have [_ scF] := SCN_P scnF. + rewrite (leq_trans rF) // -scF -rank_pgroup ?(pgroupS (subsetIl _ _)) //. + by rewrite rankS ?setIS ?centS // (subset_trans _ sUF) ?joing_subl. + have defU: S :=: U. + apply/eqP; rewrite eqEcard oS joing_subl (card_pgroup (pgroupS sUR pR)). + by rewrite -p_rank_abelem // (leq_exp2l _ 1) // prime_gt1. + have ntS: S :!=: 1 by rewrite -cardG_gt1 oS prime_gt1. + have sSZ: S \subset 'Z(R) by rewrite prime_meetG ?oS ?meet_center_nil // defU. + by rewrite (setIidPl _) // centsC (subset_trans sSZ) ?subsetIr. +have{tiHS eH} oCHS: #|'C_H(S)| = p. + have ntCHS: 'C_H(S) != 1. + have: H :&: 'Z(R) != 1 by rewrite meet_center_nil ?char_normal. + by apply: subG1_contra; rewrite setIS // (centsS sSR) ?subsetIr. + have cycCHS: cyclic 'C_H(S). + have tiS_CHS: S :&: 'C_H(S) = 1 by rewrite setICA setIA tiHS setI1g. + rewrite (isog_cyclic (quotient_isog _ tiS_CHS)) ?subIset ?cent_sub ?orbT //. + rewrite (cyclicS _ (quotient_cyclic S cycC)) //= -(quotientMidl S C). + by rewrite mulSC quotientS // setSI // char_sub. + have abelCHS: p.-abelem 'C_H(S). + by rewrite abelemE ?cyclic_abelian // -eH exponentS ?subsetIl. + rewrite -(Ohm1_id abelCHS). + by rewrite (Ohm1_cyclic_pgroup_prime _ (abelem_pgroup abelCHS)). +pose B := A^`(1) <*> [set a ^+ p.-1 | a in A]. +have sBA: B \subset A. + rewrite join_subG (der_sub 1 A) /=. + by apply/subsetP=> _ /imsetP[a Aa ->]; rewrite groupX. +have AutB: B \subset Aut R := subset_trans sBA AutA. +suffices pB (X : {group {perm gT}}): X \subset B -> p^'.-group X -> X :=: 1. + have cAbAb: abelian (A / 'O_p(A)). + rewrite sub_der1_abelian // pcore_max ?der_normal //. + apply/pgroupP=> q q_pr; apply: contraLR => p'q; rewrite -p'natE //. + have [X sylX] := Sylow_exists q A^`(1); have [sXA' qX _] := and3P sylX. + rewrite -partn_eq1 ?cardG_gt0 // -(card_Hall sylX). + by rewrite (pB X) ?cards1 ?(pi_pgroup qX) ?(subset_trans sXA') ?joing_subl. + rewrite cAbAb -(nilpotent_pcoreC p (abelian_nil cAbAb)) trivg_pcore_quotient. + rewrite dprod1g pcore_pgroup; split=> //_ a Aa p'a. + rewrite order_dvdn -cycle_eq1 [<[_]>]pB ?(pgroupS (cycleX _ _) p'a) //. + by rewrite genS // sub1set inE orbC (mem_imset (expgn^~ _)). +move=> sXB p'X; have AutX := subset_trans sXB AutB. +pose toX := ([Aut R] \ AutX)%gact; pose CX := 'C_(H | toX)(X). +suffices sHCX: H \subset CX. + rewrite -(setIid X) coprime_TIg ?(pnat_coprime (pgroupS _ pCH)) //. + by rewrite subsetIidl gacent_ract setIid gacentC in sHCX. +elim: _.+1 {1 2 4 6}H (charH) (subxx H) (ltnSn #|H|) => // n IHn L charL sLH. +rewrite ltnS => leLn; have sLR := char_sub charL; pose K := [~: L, R]. +wlog ntL: / L :!=: 1 by case: eqP => [-> | _ -> //]; rewrite sub1G. +have charK: K \char R by rewrite charR ?char_refl. +have ltKL: K \proper L. + have nLR: R \subset 'N_R(L) by rewrite subsetIidl char_norm. + exact: nil_comm_properl nilR sLR ntL nLR. +have [sKL sKR] := (proper_sub ltKL, char_sub charK). +have [sKH pK] := (subset_trans sKL sLH, pgroupS sKR pR : p.-group K). +have nsKH: K <| H := normalS sKH sHR (char_normal charK). +have sKCX: K \subset CX by rewrite IHn ?(leq_trans (proper_card ltKL)) ?leLn. +have pL := pgroupS sLR pR; have nKL: L \subset 'N(K) := commg_norml _ _. +have{pS cSS} oLb: #|L / K| = p. + have [v defS] := cyclicP cycS; rewrite defS cycle_subG in sSR. + have ntLb: L / K != 1 by rewrite -subG1 quotient_sub1 ?proper_subn. + have [_ p_dv_Lb _] := pgroup_pdiv (quotient_pgroup _ pL) ntLb. + apply/eqP; rewrite eqn_leq {p_dv_Lb}(dvdn_leq _ p_dv_Lb) // andbT. + rewrite -divg_normal ?(normalS sKL sLH nsKH) // leq_divLR ?cardSg //= -/K. + rewrite -(card_lcoset K v) -(LagrangeI L 'C(S)) -indexgI /= -oCHS /K commGC. + rewrite {2}defS cent_cycle index_cent1 leq_mul ?subset_leq_card ?setSI //. + by apply/subsetP=> vx; case/imsetP=> x Lx ->; rewrite mem_lcoset mem_commg. +have cycLb: cyclic (L / K) by rewrite prime_cyclic ?oLb. +rewrite -(quotientSGK _ sKCX) // quotientGI // subsetI quotientS //= -/K. +have actsXK: [acts X, on K | toX] by rewrite acts_ract subxx acts_char. +rewrite ext_coprime_quotient_cent ?(pnat_coprime pK p'X) ?(pgroup_sol pK) //. +have actsAL : {acts A, on group L | [Aut R]} by exact: gacts_char. +have sAD: A \subset qact_dom <[actsAL]> [~: L, R]. + by rewrite qact_domE // acts_actby subxx (setIidPr sKL) acts_char. +suffices cLbX: X \subset 'C(L / K | <[actsAL]> / _). + rewrite gacentE ?qact_domE // subsetI quotientS //=. + apply/subsetP=> Ku LbKu; rewrite inE; apply/subsetP=> x Xx; rewrite inE. + have [Dx cLx] := setIdP (subsetP cLbX x Xx); have [Ax _] := setIdP Dx. + rewrite inE in cLx; have:= subsetP cLx Ku LbKu; rewrite inE /=. + have [u Nu Lu ->] := morphimP LbKu. + by rewrite !{1}qactE // ?actbyE // qact_domE ?(subsetP actsXK). +rewrite (subset_trans sXB) // astab_range -ker_actperm gen_subG. +rewrite -sub_morphim_pre; last by rewrite -gen_subG ?(subset_trans sBA). +rewrite morphimU subUset morphim_der // (sameP trivgP derG1P). +rewrite (abelianS _ (Aut_cyclic_abelian cycLb)); last first. + exact: subset_trans (morphim_sub _ _) (im_actperm_Aut _). +apply/subsetP=> _ /morphimP[_ _ /imsetP[x Ax ->] ->]. +have Dx := subsetP sAD x Ax; rewrite inE morphX //= -order_dvdn. +apply: dvdn_trans (order_dvdG (actperm_Aut _ Dx)) _. +by rewrite card_Aut_cyclic // oLb (@totient_pfactor p 1) ?muln1. +Qed. + +End OneGroup. + +(* This is B & G, Theorem 5.6, parts (a) and (c). We do not prove parts (b), *) +(* (d) and (e), as they are not used in the proof of the Odd Order Theorem. *) +Theorem narrow_der1_complement_max_pdiv gT p (G S : {group gT}) : + odd #|G| -> solvable G -> p.-Sylow(G) S -> p.-narrow S -> + (2 < 'r(S)) ==> p.-length_1 G -> + [/\ (*a*) p^'.-Hall(G^`(1)) 'O_p^'(G^`(1)) + & (*c*) forall q, q \in \pi(G / 'O_p^'(G)) -> q <= p]. +Proof. +move=> oddG solG sylS nnS; case: (leqP 'r(S) 2) => /= rS pl1G. + have rG: 'r_p(G) <= 2 by rewrite -(rank_Sylow sylS). + split=> [|q]; first by have [-> _ _] := rank2_der1_complement solG oddG rG. + exact: rank2_max_pdiv solG oddG rG. +rewrite /pHall pcore_sub pcore_pgroup pnatNK /=. +rewrite -(pcore_setI_normal p^' (der_normal 1 G)) // setIC indexgI /=. +wlog Gp'1: gT G S oddG nnS solG sylS rS pl1G / 'O_p^'(G) = 1. + set K := 'O_p^'(G); have [_ nKG] := andP (pcore_normal _ G : K <| G). + move/(_ _ (G / K) (S / K))%G; rewrite quotient_sol ?quotient_odd //. + have [[sSG pS _] p'K] := (and3P sylS, pcore_pgroup _ G : p^'.-group K). + have [nKS nKG'] := (subset_trans sSG nKG, subset_trans (der_sub 1 G) nKG). + have tiKS: K :&: S = 1 := coprime_TIg (p'nat_coprime p'K pS). + have isoS := isog_symr (quotient_isog nKS tiKS). + rewrite (isog_narrow p isoS) {isoS}(isog_rank isoS) quotient_pHall //. + rewrite plength1_quo // trivg_pcore_quotient indexg1 /= -quotient_der //. + by rewrite card_quotient //= -/K -(card_isog (quotient1_isog _)); exact. +rewrite Gp'1 indexg1 -(card_isog (quotient1_isog _)) -pgroupE. +have [sSG pS _] := and3P sylS; have oddS: odd #|S| := oddSg sSG oddG. +have ntS: S :!=: 1 by rewrite -rank_gt0 (leq_trans _ rS). +have [p_pr _ _] := pgroup_pdiv pS ntS; have p_gt1 := prime_gt1 p_pr. +have{pl1G} defS: 'O_p(G) = S. + by rewrite (eq_Hall_pcore _ sylS) -?plength1_pcore_Sylow. +have nSG: G \subset 'N(S) by rewrite -defS gFnorm. +pose fA := restrm nSG (conj_aut S); pose A := fA @* G. +have AutA: A \subset Aut S by rewrite [A]im_restrm Aut_conj_aut. +have [solA oddA]: solvable A /\ odd #|A| by rewrite morphim_sol ?morphim_odd. +have [/= _ cAbAb p'A_dv_p1] := Aut_narrow pS oddS nnS solA AutA oddA. +have{defS} pKfA: p.-group ('ker fA). + rewrite (pgroupS _ pS) //= ker_restrm ker_conj_aut. + by rewrite -defS -Fitting_eq_pcore ?cent_sub_Fitting. +split=> [|q]. + rewrite -(pmorphim_pgroup pKfA) ?der_sub // morphim_der //. + by rewrite (pgroupS (der1_min (char_norm _) cAbAb)) ?pcore_pgroup ?pcore_char. +rewrite mem_primes; case/and3P=> q_pr _; case/Cauchy=> // x Gx ox. +rewrite leq_eqVlt -implyNb; apply/implyP=> p'q; rewrite -(ltn_predK p_gt1) ltnS. +have ofAx: #[fA x] = q. + apply/prime_nt_dvdP=> //; last by rewrite -ox morph_order. + rewrite order_eq1; apply: contraNneq p'q => fAx1. + by apply: (pgroupP pKfA); rewrite // -ox order_dvdG //; exact/kerP. +have p'fAx: p^'.-elt (fA x) by rewrite /p_elt ofAx pnatE. +by rewrite -ofAx dvdn_leq ?p'A_dv_p1 ?mem_morphim // -(subnKC p_gt1). +Qed. + +End Five. diff --git a/mathcomp/odd_order/BGsection6.v b/mathcomp/odd_order/BGsection6.v new file mode 100644 index 0000000..234313c --- /dev/null +++ b/mathcomp/odd_order/BGsection6.v @@ -0,0 +1,315 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div fintype finset. +Require Import prime fingroup morphism automorphism quotient gproduct gfunctor. +Require Import cyclic center commutator pgroup nilpotent sylow abelian hall. +Require Import maximal. +Require Import BGsection1 BGappendixAB. + +(******************************************************************************) +(* This file covers most of B & G section 6. *) +(* Theorem 6.4 is not proved, since it is not needed for the revised proof of *) +(* the odd order theorem. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section Six. + +Implicit Type gT : finGroupType. +Implicit Type p : nat. + +Section OneType. + +Variable gT : finGroupType. +Implicit Types G H K S U : {group gT}. + +(* This is B & G, Theorem A.4(b) and 6.1, or Gorenstein 6.5.2, the main Hall- *) +(* Higman style p-stability result used in the proof of the Odd Order Theorem *) +Theorem odd_p_abelian_constrained p G : + odd #|G| -> solvable G -> p.-abelian_constrained G. +Proof. +move/odd_p_stable=> stabG /solvable_p_constrained constrG. +exact: p_stable_abelian_constrained. +Qed. + +(* Auxiliary results from AppendixAB, necessary to exploit the results below. *) +Definition center_Puig_char := BGappendixAB.center_Puig_char. +Definition trivg_center_Puig_pgroup := BGappendixAB.trivg_center_Puig_pgroup. + +(* The two parts of B & G, Theorem 6.2 are established in BGappendixAB. *) +Theorem Puig_factorisation p G S : + odd #|G| -> solvable G -> p.-Sylow(G) S -> 'O_p^'(G) * 'N_G('Z('L(S))) = G. +Proof. exact: BGappendixAB.Puig_factorization. Qed. + +(* This is the main statement of B & G, Theorem 6.2. It is not used in the *) +(* actual proof. *) +Theorem Puig_center_p'core_normal p G S : + odd #|G| -> solvable G -> p.-Sylow(G) S -> 'O_p^'(G) * 'Z('L(S)) <| G. +Proof. +move=> oddG solG sylS; rewrite -{2}(Puig_factorisation _ _ sylS) //. +have sZL_G := subset_trans (char_sub (center_Puig_char S)) (pHall_sub sylS). +rewrite -!quotientK ?(subset_trans _ (gFnorm _ _)) ?subsetIl //. +by rewrite cosetpre_normal quotient_normal // normalSG. +Qed. + +(* This is the second part (special case) of B & G, Theorem 6.2. *) +Theorem Puig_center_normal p G S : + odd #|G| -> solvable G -> p.-Sylow(G) S -> 'O_p^'(G) = 1 -> 'Z('L(S)) <| G. +Proof. exact: BGappendixAB.Puig_center_normal. Qed. + +(* This is B & G, Lemma 6.3(a). *) +Lemma coprime_der1_sdprod K H G : + K ><| H = G -> coprime #|K| #|H| -> solvable K -> K \subset G^`(1) -> + [~: K, H] = K /\ 'C_K(H) \subset K^`(1). +Proof. +case/sdprodP=> _ defG nKH tiKH coKH solK sKG'. +set K' := K^`(1); have [sK'K nK'K] := andP (der_normal 1 K : K' <| K). +have nK'H: H \subset 'N(K') := char_norm_trans (der_char 1 K) nKH. +set R := [~: K, H]; have sRK: R \subset K by rewrite commg_subl. +have [nRK nRH] := joing_subP (commg_norm K H : K <*> H \subset 'N(R)). +have sKbK'H': K / R \subset (K / R)^`(1) * (H / R)^`(1). + have defGb: (K / R) \* (H / R) = G / R. + by rewrite -defG quotientMl ?cprodE // centsC quotient_cents2r. + have [_ -> _ /=] := cprodP (der_cprod 1 defGb). + by rewrite -quotient_der ?quotientS // -defG mul_subG. +have tiKbHb': K / R :&: (H / R)^`(1) = 1. + by rewrite coprime_TIg // (coprimegS (der_sub 1 _)) ?coprime_morph. +have{sKbK'H' tiKbHb'} derKb: (K / R)^`(1) = K / R. + by rewrite -{2}(setIidPr sKbK'H') -group_modl ?der_sub // setIC tiKbHb' mulg1. +have{derKb} Kb1: K / R = 1. + rewrite (contraNeq (sol_der1_proper _ (subxx (K / R)))) ?quotient_sol //. + by rewrite derKb properxx. +have{Kb1 sRK} defKH: [~: K, H] = K. + by apply/eqP; rewrite eqEsubset sRK -quotient_sub1 ?Kb1 //=. +split=> //; rewrite -quotient_sub1 ?subIset ?nK'K //= -/K'. +have cKaKa: abelian (K / K') := der_abelian 0 K. +rewrite coprime_quotient_cent ?quotient_norms ?coprime_morph //= -/K' -defKH. +by rewrite quotientR // coprime_abel_cent_TI ?quotient_norms ?coprime_morph. +Qed. + +(* This is B & G, Lemma 6.3(b). It is apparently not used later. *) +Lemma prime_nil_der1_factor G : + nilpotent G^`(1) -> prime #|G / G^`(1)| -> + Hall G G^`(1) /\ (forall H, G^`(1) ><| H = G -> G^`(1) = [~: G, H]). +Proof. +move=> nilG' /=; set G' := G^`(1); set p := #|G / G'| => p_pr. +have nsG'G: G' <| G := der_normal 1 G; have [sG'G nG'G] := andP nsG'G. +have nsG'p'G: 'O_p^'(G') <| G := char_normal_trans (pcore_char _ _) nsG'G. +have nG'p'G := normal_norm nsG'p'G; have solG' := nilpotent_sol nilG'. +have{nilG'} pGb: p.-group (G / 'O_p^'(G')). + rewrite /pgroup card_quotient -?(Lagrange_index sG'G (pcore_sub _ _)) //=. + rewrite pnat_mul // -card_quotient // pnat_id //= -pnatNK. + by case/and3P: (nilpotent_pcore_Hall p^' nilG'). +have{pGb} cycGb: cyclic (G / 'O_p^'(G')). + apply: (cyclic_nilpotent_quo_der1_cyclic (pgroup_nil pGb)). + rewrite -quotient_der // (isog_cyclic (third_isog _ _ _)) ?pcore_sub //. + by apply: prime_cyclic. +have defG': G' = 'O_p^'(G'). + by apply/eqP; rewrite eqEsubset pcore_sub der1_min ?cyclic_abelian. +have hallG': Hall G G'. + rewrite /Hall sG'G -?card_quotient // defG' //= -/p. + by rewrite (p'nat_coprime (pcore_pgroup _ _)) ?pnat_id. +split=> // H defG; have [_ mulG'H nG'H tiG'H] := sdprodP defG. +rewrite -mulG'H commMG ?commg_normr // -derg1 (derG1P _) ?mulg1 //. + by case/coprime_der1_sdprod: (defG); rewrite ?(coprime_sdprod_Hall_l defG). +rewrite (isog_abelian (quotient_isog nG'H tiG'H)) /= -/G'. +by rewrite -quotientMidl mulG'H der_abelian. +Qed. + +Section PprodSubCoprime. + +Variables K U H G : {group gT}. +Hypotheses (defG : K * U = G) (nsKG : K <| G). +Hypotheses (sHU : H \subset U) (coKH : coprime #|K| #|H|). +Let nKG : G \subset 'N(K). Proof. by case/andP: nsKG. Qed. +Let sKG : K \subset G. Proof. by case/mulG_sub: defG. Qed. +Let sUG : U \subset G. Proof. by case/mulG_sub: defG. Qed. +Let nKU : U \subset 'N(K). Proof. exact: subset_trans sUG nKG. Qed. +Let nKH : H \subset 'N(K). Proof. exact: subset_trans sHU nKU. Qed. + +(* This is B & G, Lemma 6.5(a); note that we do not assume solvability. *) +Lemma pprod_focal_coprime : H :&: G^`(1) = H :&: U^`(1). +Proof. +set G' := G^`(1); set U' := U^`(1). +have [sU'U nU'U] := andP (der_normal 1 U : U' <| U). +have{nU'U} nU_U': U :&: _ \subset 'N(U') by move=> A; rewrite subIset ?nU'U. +suffices sHG'U': H :&: G' \subset U'. + by rewrite -(setIidPl sHG'U') -setIA (setIidPr (dergS 1 sUG)). +rewrite -(setIidPr sHU) -setIA -quotient_sub1 // setICA setIC. +rewrite quotientGI ?subsetI ?sU'U ?dergS ?coprime_TIg //= -/G' -/U'. +have sUG'_UKb: (U :&: G') / U' \subset (U :&: K) / U'. + rewrite quotientSK // -normC ?group_modr ?setIS //. + by rewrite -quotientSK ?comm_subG ?quotient_der // -defG quotientMidl. +rewrite (coprimeSg sUG'_UKb) // -(card_isog (second_isog _)) //=. +rewrite setIA (setIidPl sU'U) coprime_morphl ?coprime_morphr //. +exact: coprimeSg (subsetIr U K) coKH. +Qed. + +Hypothesis solG : solvable G. + +(* This is B & G, Lemma 6.5(c). *) +Lemma pprod_trans_coprime g : + g \in G -> H :^ g \subset U -> + exists2 c, c \in 'C_K(H) & exists2 u, u \in U & g = c * u. +Proof. +rewrite -{1}defG => /mulsgP[k u Kk Uu defg] sHgU. +have [sK_KH sH_KH] := joing_sub (erefl (K <*> H)). +have hallH: \pi(H).-Hall(K <*> H :&: U) H. + rewrite (pHall_subl _ (subsetIl _ _)) ?subsetI ?sH_KH //. + rewrite /pHall sH_KH pgroup_pi /= joingC norm_joinEl // indexMg -indexgI. + by rewrite -coprime_pi' ?cardG_gt0 //= coprime_sym coprime_TIg ?indexg1. +have{sHgU} hallHk: \pi(H).-Hall(K <*> H :&: U) (H :^ k). + rewrite pHallE cardJg (card_Hall hallH) eqxx andbT subsetI andbC. + rewrite -(conjSg _ _ u) (conjGid Uu) -conjsgM -defg sHgU. + by rewrite sub_conjg conjGid // groupV (subsetP sK_KH). +have{hallH hallHk} [w KUw defHk]: exists2 w, w \in K :&: U & H :^ k = H :^ w. + have sKHU_G: K <*> H :&: U \subset G by rewrite setIC subIset ?sUG. + have [hw KHUhw ->] := Hall_trans (solvableS sKHU_G solG) hallHk hallH. + have: hw \in H * (K :&: U) by rewrite group_modl // -norm_joinEl // joingC. + by case/mulsgP=> h w Hh KUw ->; exists w; rewrite // conjsgM (conjGid Hh). +have{KUw} [Kw Uw] := setIP KUw. +exists (k * w^-1); last by exists (w * u); rewrite ?groupM // -mulgA mulKg. +by rewrite -coprime_norm_cent // !inE groupM ?groupV //= conjsgM defHk conjsgK. +Qed. + +(* This is B & G, Lemma 6.5(b). *) +Lemma pprod_norm_coprime_prod : 'C_K(H) * 'N_U(H) = 'N_G(H). +Proof. +apply/eqP; rewrite eqEsubset mul_subG ?setISS ?cent_sub //=. +apply/subsetP=> g /setIP[Gg /normP nHg]. +have [|c Cc [u Uu defg]] := pprod_trans_coprime Gg; first by rewrite nHg. +rewrite defg mem_mulg // !inE Uu -{2}nHg defg conjsgM conjSg (normP _) //=. +by case/setIP: Cc => _; exact: (subsetP (cent_sub H)). +Qed. + +End PprodSubCoprime. + +Section Plength1Prod. + +Variables (p : nat) (G S : {group gT}). +Hypotheses (sylS : p.-Sylow(G) S) (pl1G : p.-length_1 G). +Let K := 'O_p^'(G). +Let sSG : S \subset G. Proof. by case/andP: sylS. Qed. +Let nsKG : K <| G. Proof. exact: pcore_normal. Qed. +Let sKG : K \subset G. Proof. by case/andP: nsKG. Qed. +Let nKG : G \subset 'N(K). Proof. by case/andP: nsKG. Qed. +Let nKS : S \subset 'N(K). Proof. exact: subset_trans sSG nKG. Qed. +Let coKS : coprime #|K| #|S|. +Proof. exact: p'nat_coprime (pcore_pgroup _ G) (pHall_pgroup sylS). Qed. +Let sSN : S \subset 'N_G(S). Proof. by rewrite subsetI sSG normG. Qed. + +Let sylGbp : p.-Sylow(G / K) 'O_p(G / K). +Proof. by rewrite -plength1_pcore_quo_Sylow. Qed. + +(* This is B & G, Lemma 6.6(a1); note that we do not assume solvability. *) +Lemma plength1_Sylow_prod : K * S = 'O_{p^',p}(G). +Proof. +by rewrite -quotientK 1?(eq_Hall_pcore sylGbp) ?quotient_pHall //= /K -pseries1. +Qed. + +Let sylS_Gp'p : p.-Sylow('O_{p^',p}(G)) S. +Proof. +have [_ sSGp'p] := mulG_sub plength1_Sylow_prod. +exact: pHall_subl sSGp'p (pseries_sub _ _) sylS. +Qed. + +(* This is B & G, Lemma 6.6(a2); note that we do not assume solvability. *) +Lemma plength1_Frattini : K * 'N_G(S) = G. +Proof. +rewrite -{2}(Frattini_arg _ sylS_Gp'p) ?pseries_normal //= -plength1_Sylow_prod. +by rewrite -mulgA [S * _]mulSGid // subsetI sSG normG. +Qed. +Local Notation defG := plength1_Frattini. + +(* This is B & G, Lemma 6.6(b); note that we do not assume solvability. *) +Lemma plength1_Sylow_sub_der1 : S \subset G^`(1) -> S \subset ('N_G(S))^`(1). +Proof. +by move/setIidPl=> sSG'; apply/setIidPl; rewrite -(pprod_focal_coprime defG). +Qed. + +Hypothesis solG : solvable G. + +(* This is B & G, Lemma 6.6(c). *) +Lemma plength1_Sylow_trans (Y : {set gT}) g : + Y \subset S -> g \in G -> Y :^ g \subset S -> + exists2 c, c \in 'C_G(Y) & exists2 u, u \in 'N_G(S) & g = c * u. +Proof. +rewrite -gen_subG -(gen_subG (Y :^ g)) genJ => sYS Gg sYgS. +have coKY := coprimegS sYS coKS. +have [sYN sYgN] := (subset_trans sYS sSN, subset_trans sYgS sSN). +have [c Cc defg] := pprod_trans_coprime defG nsKG sYN coKY solG Gg sYgN. +by exists c => //; apply: subsetP Cc; rewrite cent_gen setSI. +Qed. + +(* This is B & G, Lemma 6.6(d). *) +Lemma plength1_Sylow_Jsub (Q : {group gT}) : + Q \subset G -> p.-group Q -> + exists2 x, x \in 'C_G(Q :&: S) & Q :^ x \subset S. +Proof. +move=> sQG pQ; have sQ_Gp'p: Q \subset 'O_{p^',p}(G). + rewrite -sub_quotient_pre /= pcore_mod1 ?(subset_trans sQG) //. + by rewrite (sub_Hall_pcore sylGbp) ?quotientS ?quotient_pgroup. +have [xy /= KSxy sQxyS] := Sylow_Jsub sylS_Gp'p sQ_Gp'p pQ. +rewrite -plength1_Sylow_prod in KSxy; have [x y Kx Sy def_xy] := mulsgP KSxy. +have{sQxyS} sQxS: Q :^ x \subset S. + by rewrite -(conjSg _ _ y) (conjGid Sy) -conjsgM -def_xy. +exists x; rewrite // inE (subsetP sKG) //; apply/centP=> z; case/setIP=> Qz Sz. +apply/commgP; rewrite -in_set1 -set1gE -(coprime_TIg coKS) inE. +rewrite groupMl ?groupV ?memJ_norm ?(subsetP nKS) ?Kx //=. +by rewrite commgEr groupMr // (subsetP sQxS) ?memJ_conjg ?groupV. +Qed. + +End Plength1Prod. + +End OneType. + +(* This is B & G, Theorem 6.7 *) +Theorem plength1_norm_pmaxElem gT p (G E L : {group gT}) : + E \in 'E*_p(G) -> odd p -> solvable G -> p.-length_1 G -> + L \subset G -> E \subset 'N(L) -> p^'.-group L -> + L \subset 'O_p^'(G). +Proof. +move=> maxE p_odd solG pl1G sLG nEL p'L. +case p_pr: (prime p); last first. + by rewrite pcore_pgroup_id // p'groupEpi mem_primes p_pr. +wlog Gp'1: gT G E L maxE solG pl1G sLG nEL p'L / 'O_p^'(G) = 1. + set K := 'O_p^'(G); have [sKG nKG] := andP (pcore_normal _ G : K <| G). + move/(_ _ (G / K) (E / K) (L / K))%G; rewrite morphim_sol ?plength1_quo //. + rewrite morphimS ?morphim_norms ?quotient_pgroup // trivg_pcore_quotient. + rewrite (quotient_sub1 (subset_trans sLG nKG)) => -> //. + have [EpE _] := pmaxElemP maxE; have{EpE} [sEG abelE] := pElemP EpE. + apply/pmaxElemP; rewrite inE quotient_abelem ?quotientS //. + split=> // Fb; case/pElemP=> sFbG abelFb; have [pFb _ _] := and3P abelFb. + have [S sylS sES] := Sylow_superset sEG (abelem_pgroup abelE). + have [sSG pS _] := and3P sylS; have nKS := subset_trans sSG nKG. + have: (E / K)%G \in 'E*_p(S / K). + have: E \in 'E*_p(S) by rewrite (subsetP (pmaxElemS p sSG)) // inE maxE inE. + have coKS: coprime #|K| #|S| := p'nat_coprime (pcore_pgroup _ _) pS. + have [injK imK] := isomP (quotient_isom nKS (coprime_TIg coKS)). + by rewrite -(injm_pmaxElem injK) ?imK ?inE //= morphim_restrm (setIidPr _). + case/pmaxElemP=> _; apply; rewrite inE abelFb andbT. + rewrite (sub_normal_Hall (quotient_pHall _ sylS)) //= -quotientMidl /= -/K. + by rewrite plength1_Sylow_prod // quotient_pseries2 pcore_normal. +have [EpE _] := pmaxElemP maxE; have{EpE} [sEG abelE] := pElemP EpE. +have [S sylS sES] := Sylow_superset sEG (abelem_pgroup abelE). +have [sSG pS _] := and3P sylS; have oddS: odd #|S| := odd_pgroup_odd p_odd pS. +have defS: S :=: 'O_p(G) by apply eq_Hall_pcore; rewrite -?plength1_pcore_Sylow. +have coSL: coprime #|S| #|L| := pnat_coprime pS p'L. +have tiSL: S :&: L = 1 := coprime_TIg coSL. +have{solG} scSG: 'C_G(S) \subset S. + by rewrite defS -Fitting_eq_pcore ?cent_sub_Fitting. +rewrite Gp'1 -tiSL subsetIidr (subset_trans _ scSG) // subsetI sLG /=. +have nSL: L \subset 'N(S) by rewrite (subset_trans sLG) // defS gFnorm. +have cLE: L \subset 'C(E). + by rewrite (sameP commG1P trivgP) -tiSL setIC commg_subI ?(introT subsetIP). +have maxES: E \in 'E*_p(S) by rewrite (subsetP (pmaxElemS p sSG)) ?(maxE, inE). +have EpE: E \in 'E_p(S) by apply/setIdP. +by rewrite (coprime_odd_faithful_cent_abelem EpE) ?(pmaxElem_LdivP p_pr maxES). +Qed. + +End Six. + diff --git a/mathcomp/odd_order/BGsection7.v b/mathcomp/odd_order/BGsection7.v new file mode 100644 index 0000000..9982283 --- /dev/null +++ b/mathcomp/odd_order/BGsection7.v @@ -0,0 +1,979 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div fintype bigop. +Require Import finset prime fingroup morphism automorphism action quotient. +Require Import gfunctor cyclic pgroup center commutator gseries nilpotent. +Require Import sylow abelian maximal hall. +Require Import BGsection1 BGsection6. + +(******************************************************************************) +(* This file covers B & G, section 7, i.e., the proof of the Thompson *) +(* Transitivity Theorem, as well as some generalisations used later in the *) +(* proof. *) +(* This is the first section of the proof that applies to a (hypothetical) *) +(* minimally simple odd group, so we also introduce at this point some *) +(* infrastructure to carry over this assumption into the rest of the proof. *) +(* minSimpleOddGroupType == a finGroupType that ranges exactly over the *) +(* elements of a minimal counter-example to the *) +(* Odd Order Theorem. *) +(* G == the group of all the elements in a *) +(* minSimpleOddGroupType (this is a local notation *) +(* that must be reestablished for each such Type). *) +(* 'M == the set of all (proper) maximal subgroups of G *) +(* 'M(H) == the set of all elements of 'M that contain H *) +(* 'U == the set of all H such that 'M(H) contains a *) +(* single (unique) maximal subgroup of G. *) +(* 'SCN_n[p] == the set of all SCN subgroups of rank at least n *) +(* of all the Sylow p-subgroups of G. *) +(* |/|_H(A, pi) == the set of all pi-subgroups of H that are *) +(* normalised by A. *) +(* |/|*(A, pi) == the set of pi-subgroups of G, normalised by A, *) +(* and maximal subject to this condition. *) +(* normed_constrained A == A is a nontrivial proper subgroup of G, such *) +(* that for any proper subgroup X containing A, *) +(* all Y in |/|_X(A, pi') lie in the pi'-core of X *) +(* (here pi is the set of prime divisors of #|A|). *) +(* This is Hypothesis 7.1 in B & G. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Reserved Notation "''M'" (at level 8, format "''M'"). +Reserved Notation "''M' ( H )" (at level 8, format "''M' ( H )"). +Reserved Notation "''U'" (at level 8). +Reserved Notation "''SCN_' n [ p ]" + (at level 8, n at level 2, format "''SCN_' n [ p ]"). +Reserved Notation "|/|_ X ( A ; pi )" + (at level 8, X at level 2, format "|/|_ X ( A ; pi )"). +Reserved Notation "|/|* ( A ; pi )" + (at level 8, format "|/|* ( A ; pi )"). + +(* The generic setup for the whole Odd Order Theorem proof. *) +Section InitialReduction. + +Implicit Type gT : finGroupType. + +Record minSimpleOddGroupMixin gT : Prop := MinSimpleOddGroupMixin { + _ : odd #|[set: gT]|; + _ : simple [set: gT]; + _ : ~~ solvable [set: gT]; + _ : forall M : {group gT}, M \proper [set: gT] -> solvable M +}. + +Structure minSimpleOddGroupType := MinSimpleOddGroupType { + minSimpleOddGroupType_base :> finGroupType; + _ : minSimpleOddGroupMixin minSimpleOddGroupType_base +}. + +Hypothesis IH_FT : minSimpleOddGroupType -> False. + +Lemma minSimpleOdd_ind gT (G : {group gT}) : odd #|G| -> solvable G. +Proof. +move: {2}_.+1 (ltnSn #|G|) => n. +elim: n => // n IHn in gT G *; rewrite ltnS => leGn oddG. +have oG: #|[subg G]| = #|G| by rewrite (card_isog (isog_subg G)). +apply/idPn=> nsolG; case: IH_FT; exists [finGroupType of subg_of G]. +do [split; rewrite ?oG //=] => [||M]. +- rewrite -(isog_simple (isog_subg _)); apply/simpleP; split=> [|H nsHG]. + by apply: contra nsolG; move/eqP->; rewrite abelian_sol ?abelian1. + have [sHG _]:= andP nsHG; apply/pred2P; apply: contraR nsolG; case/norP=> ntH. + rewrite eqEcard sHG -ltnNge (series_sol nsHG) => ltHG. + by rewrite !IHn ?(oddSg sHG) ?quotient_odd ?(leq_trans _ leGn) ?ltn_quotient. +- by apply: contra nsolG => solG; rewrite -(im_sgval G) morphim_sol. +rewrite properEcard oG; case/andP=> sMG ltMG. +by apply: IHn (leq_trans ltMG leGn) (oddSg sMG _); rewrite oG. +Qed. + +Lemma minSimpleOdd_prime gT (G : {group gT}) : + odd #|G| -> simple G -> prime #|G|. +Proof. by move/minSimpleOdd_ind; apply: simple_sol_prime. Qed. + +End InitialReduction. + +Notation TheMinSimpleOddGroup gT := + [set: FinGroup.arg_sort (FinGroup.base (minSimpleOddGroupType_base gT))] + (only parsing). + +(* Elementary properties of the minimal counter example. *) +Section MinSimpleOdd. + +Variable gT : minSimpleOddGroupType. +Notation G := (TheMinSimpleOddGroup gT). +Implicit Types H K D M P U V X : {group gT}. +Local Notation sT := {set gT}. +Implicit Type p : nat. + +Lemma mFT_odd H : odd #|H|. +Proof. by apply: (oddSg (subsetT H)); case: gT => ? []. Qed. + +Lemma mFT_simple : simple G. +Proof. by case: gT => ? []. Qed. + +Lemma mFT_nonSolvable : ~~ solvable G. +Proof. by case: gT => ? []. Qed. + +Lemma mFT_sol M : M \proper G -> solvable M. +Proof. by case: gT M => ? []. Qed. + +Lemma mFT_nonAbelian : ~~ abelian G. +Proof. apply: contra mFT_nonSolvable; exact: abelian_sol. Qed. + +Lemma mFT_neq1 : G != 1. +Proof. by apply: contraNneq mFT_nonAbelian => ->; exact: abelian1. Qed. + +Lemma mFT_gt1 : [1] \proper G. Proof. by rewrite proper1G mFT_neq1. Qed. + +Lemma mFT_quo_odd M H : odd #|M / H|. +Proof. by rewrite quotient_odd ?mFT_odd. Qed. + +Lemma mFT_sol_proper M : (M \proper G) = solvable M. +Proof. +apply/idP/idP; first exact: mFT_sol. +by rewrite properT; apply: contraL; move/eqP->; exact: mFT_nonSolvable. +Qed. + +Lemma mFT_pgroup_proper p P : p.-group P -> P \proper G. +Proof. by move/pgroup_sol; rewrite mFT_sol_proper. Qed. + +Lemma mFT_norm_proper H : H :!=: 1 -> H \proper G -> 'N(H) \proper G. +Proof. +move=> ntH; rewrite !properT; apply: contra; move/eqP=> nHG; apply/eqP. +move/eqP: ntH; case/simpleP: mFT_simple => _; case/(_ H) => //=. +by rewrite -nHG normalG. +Qed. + +Lemma cent_mFT_trivial : 'C(G) = 1. +Proof. +apply/eqP; apply: contraR mFT_nonAbelian => ntC. +rewrite /abelian subTset /= eqEproper subsetT /=; apply/negP=> prC. +have:= mFT_norm_proper ntC prC. +by rewrite /proper subsetT norms_cent ?normG. +Qed. + +Lemma mFT_cent_proper H : H :!=: 1 -> 'C(H) \proper G. +Proof. +case: (eqsVneq H G) => [-> | ]. + by rewrite cent_mFT_trivial properT eq_sym. +rewrite -properT => prH ntH; apply: sub_proper_trans (cent_sub H) _. +exact: mFT_norm_proper. +Qed. + +Lemma mFT_cent1_proper x : x != 1 -> 'C[x] \proper G. +Proof. by rewrite -cycle_eq1 -cent_cycle; exact: mFT_cent_proper. Qed. + +Lemma mFT_quo_sol M H : H :!=: 1 -> solvable (M / H). +Proof. +move=> ntH; case: (eqsVneq H G) => [-> |]. + rewrite [_ / _](trivgP _) ?abelian_sol ?abelian1 //. + by rewrite quotient_sub1 ?normsG ?subsetT. +rewrite -properT => prH; rewrite -quotientInorm morphim_sol //. +by apply: solvableS (subsetIr _ _) (mFT_sol _); rewrite mFT_norm_proper. +Qed. + +(* Maximal groups of the minimal FT counterexample, as defined at the start *) +(* of B & G, section 7. *) +Definition minSimple_max_groups := [set M : {group gT} | maximal M G]. +Local Notation "'M" := minSimple_max_groups : group_scope. + +Definition minSimple_max_groups_of (H : sT) := [set M in 'M | H \subset M]. +Local Notation "''M' ( H )" := (minSimple_max_groups_of H) : group_scope. + +Definition minSimple_uniq_max_groups := [set U : {group gT} | #|'M(U)| == 1%N]. +Local Notation "'U" := minSimple_uniq_max_groups : group_scope. + +Definition minSimple_SCN_at n p := \bigcup_(P in 'Syl_p(G)) 'SCN_n(P). + +Lemma mmax_exists H : H \proper G -> {M | M \in 'M(H)}. +Proof. +case/(@maxgroup_exists _ (fun M => M \proper G)) => M maxM sHM. +by exists M; rewrite !inE sHM andbT. +Qed. + +Lemma any_mmax : {M : {group gT} | M \in 'M}. +Proof. by have [M] := mmax_exists mFT_gt1; case/setIdP; exists M. Qed. + +Lemma mmax_proper M : M \in 'M -> M \proper G. +Proof. by rewrite inE; apply: maxgroupp. Qed. + +Lemma mmax_sol M : M \in 'M -> solvable M. +Proof. by move/mmax_proper/mFT_sol. Qed. + +Lemma mmax_max M H : M \in 'M -> H \proper G -> M \subset H -> H :=: M. +Proof. by rewrite inE; case/maxgroupP=> _; apply. Qed. + +Lemma eq_mmax : {in 'M &, forall M H, M \subset H -> M :=: H}. +Proof. by move=> M H Mmax; move/mmax_proper=> prH; move/mmax_max->. Qed. + +Lemma sub_mmax_proper M H : M \in 'M -> H \subset M -> H \proper G. +Proof. by move=> maxM sHM; apply: sub_proper_trans (mmax_proper maxM). Qed. + +Lemma mmax_norm X M : + M \in 'M -> X :!=: 1 -> X \proper G -> M \subset 'N(X) -> 'N(X) = M. +Proof. by move=> maxM ntX prX; exact: mmax_max (mFT_norm_proper _ _). Qed. + +Lemma mmax_normal_subset A M : + M \in 'M -> A <| M -> ~~ (A \subset [1]) -> 'N(A) = M. +Proof. +rewrite -gen_subG subG1 => maxM /andP[sAM nAM] ntGA. +rewrite (mmax_max maxM) // (sub_proper_trans (norm_gen _)) ?mFT_norm_proper //. +by rewrite (sub_mmax_proper maxM) // gen_subG. +Qed. + +Lemma mmax_normal M H : M \in 'M -> H <| M -> H :!=: 1 -> 'N(H) = M. +Proof. by rewrite -subG1; apply: mmax_normal_subset. Qed. + +Lemma mmax_sigma_Sylow p P M : + M \in 'M -> p.-Sylow(M) P -> 'N(P) \subset M -> p.-Sylow(G) P. +Proof. +by move=> maxM sylP sNM; rewrite -Sylow_subnorm setTI (pHall_subl _ sNM) ?normG. +Qed. + +Lemma mmax_neq1 M : M \in 'M -> M :!=: 1. +Proof. +move=> maxM; apply: contra mFT_nonAbelian; move/eqP=> M1. +case: (eqVneq G 1) => [-> | ]; first exact: abelian1. +case/trivgPn=> x; rewrite -cycle_subG -cycle_eq1 subEproper /=. +case/predU1P=> [<- | ]; first by rewrite cycle_abelian. +by move/(mmax_max maxM)=> ->; rewrite M1 ?sub1G ?eqxx. +Qed. + +Lemma norm_mmax M : M \in 'M -> 'N(M) = M. +Proof. +move=> maxM; apply: mmax_max (normG M) => //. +exact: (mFT_norm_proper (mmax_neq1 maxM) (mmax_proper maxM)). +Qed. + +Lemma mmaxJ M x : (M :^ x \in 'M)%G = (M \in 'M). +Proof. by rewrite !inE /= -{1}[G](@conjGid _ _ x) ?maximalJ ?inE. Qed. + +Lemma mmax_ofS H K : H \subset K -> 'M(K) \subset 'M(H). +Proof. +move=> sHK; apply/subsetP=> M; rewrite !inE => /andP[->]. +exact: subset_trans. +Qed. + +Lemma mmax_ofJ K x M : ((M :^ x)%G \in 'M(K :^ x)) = (M \in 'M(K)). +Proof. by rewrite inE mmaxJ conjSg !inE. Qed. + +Lemma uniq_mmaxP U : reflect (exists M, 'M(U) = [set M]) (U \in 'U). +Proof. by rewrite inE; apply: cards1P. Qed. +Implicit Arguments uniq_mmaxP [U]. + +Lemma mem_uniq_mmax U M : 'M(U) = [set M] -> M \in 'M /\ U \subset M. +Proof. by move/setP/(_ M); rewrite set11 => /setIdP. Qed. + +Lemma eq_uniq_mmax U M H : + 'M(U) = [set M] -> H \in 'M -> U \subset H -> H :=: M. +Proof. +by move=> uU_M maxH sUH; apply/congr_group/set1P; rewrite -uU_M inE maxH. +Qed. + +Lemma def_uniq_mmax U M : + U \in 'U -> M \in 'M -> U \subset M -> 'M(U) = [set M]. +Proof. +case/uniq_mmaxP=> D uU_D maxM sUM. +by rewrite (group_inj (eq_uniq_mmax uU_D maxM sUM)). +Qed. + +Lemma uniq_mmax_subset1 U M : + M \in 'M -> U \subset M -> (U \in 'U) = ('M(U) \subset [set M]). +Proof. +move=> maxM sUM; apply/idP/idP=> uU; first by rewrite -(def_uniq_mmax uU). +by apply/uniq_mmaxP; exists M; apply/eqP; rewrite eqEsubset uU sub1set inE maxM. +Qed. + +Lemma sub_uniq_mmax U M H : + 'M(U) = [set M] -> U \subset H -> H \proper G -> H \subset M. +Proof. +move=> uU_M sUH; case/mmax_exists=> D; case/setIdP=> maxD sHD. +by rewrite -(eq_uniq_mmax uU_M maxD) ?(subset_trans sUH). +Qed. + +Lemma mmax_sup_id M : M \in 'M -> 'M(M) = [set M]. +Proof. +move=> maxM; apply/eqP; rewrite eqEsubset sub1set inE maxM subxx !andbT. +apply/subsetP=> H; case/setIdP=> maxH; rewrite inE -val_eqE /=. +by move/eq_mmax=> ->. +Qed. + +Lemma mmax_uniq_id : {subset 'M <= 'U}. +Proof. by move=> M maxM; apply/uniq_mmaxP; exists M; exact: mmax_sup_id. Qed. + +Lemma def_uniq_mmaxJ M K x : 'M(K) = [set M] -> 'M(K :^ x) = [set M :^ x]%G. +Proof. +move=> uK_M; apply/setP=> L; rewrite -(actKV 'JG x L) mmax_ofJ uK_M. +by rewrite !inE (inj_eq (act_inj 'JG x)). +Qed. + +Lemma uniq_mmaxJ K x :((K :^ x)%G \in 'U) = (K \in 'U). +Proof. +apply/uniq_mmaxP/uniq_mmaxP=> [] [M uK_M]. + exists (M :^ x^-1)%G; rewrite -(conjsgK x K); exact: def_uniq_mmaxJ. +by exists (M :^ x)%G; exact: def_uniq_mmaxJ. +Qed. + +Lemma uniq_mmax_norm_sub (M U : {group gT}) : + 'M(U) = [set M] -> 'N(U) \subset M. +Proof. +move=> uU_M; have [maxM _] := mem_uniq_mmax uU_M. +apply/subsetP=> x nUx; rewrite -(norm_mmax maxM) inE. +have:= set11 M; rewrite -uU_M -(mmax_ofJ _ x) (normP nUx) uU_M. +by move/set1P/congr_group->. +Qed. + +Lemma uniq_mmax_neq1 (U : {group gT}) : U \in 'U -> U :!=: 1. +Proof. +case/uniq_mmaxP=> M uU_M; have [maxM _] := mem_uniq_mmax uU_M. +apply: contraL (uniq_mmax_norm_sub uU_M); move/eqP->. +by rewrite norm1 subTset -properT mmax_proper. +Qed. + +Lemma def_uniq_mmaxS M U V : + U \subset V -> V \proper G -> 'M(U) = [set M] -> 'M(V) = [set M]. +Proof. +move=> sUV prV uU_M; apply/eqP; rewrite eqEsubset sub1set -uU_M. +rewrite mmax_ofS //= inE (sub_uniq_mmax uU_M) //. +by case/mem_uniq_mmax: uU_M => ->. +Qed. + +Lemma uniq_mmaxS U V : U \subset V -> V \proper G -> U \in 'U -> V \in 'U. +Proof. +move=> sUV prV /uniq_mmaxP[M uU_M]; apply/uniq_mmaxP; exists M. +exact: def_uniq_mmaxS uU_M. +Qed. + +End MinSimpleOdd. + +Implicit Arguments uniq_mmaxP [gT U]. +Prenex Implicits uniq_mmaxP. + +Notation "''M'" := (minSimple_max_groups _) : group_scope. +Notation "''M' ( H )" := (minSimple_max_groups_of H) : group_scope. +Notation "''U'" := (minSimple_uniq_max_groups _) : group_scope. +Notation "''SCN_' n [ p ]" := (minSimple_SCN_at _ n p) : group_scope. + +Section Hypothesis7_1. + +Variable gT : finGroupType. +Implicit Types X Y A P Q : {group gT}. +Local Notation G := [set: gT]. + +Definition normed_pgroups (X A : {set gT}) pi := + [set Y : {group gT} | pi.-subgroup(X) Y & A \subset 'N(Y)]. +Local Notation "|/|_ X ( A ; pi )" := (normed_pgroups X A pi) : group_scope. + +Definition max_normed_pgroups (A : {set gT}) pi := + [set Y : {group gT} | [max Y | pi.-group Y & A \subset 'N(Y)]]. +Local Notation "|/|* ( A ; pi )" := (max_normed_pgroups A pi) : group_scope. + +(* This is the statement for B & G, Hypothesis 7.1. *) +Inductive normed_constrained (A : {set gT}) := + NormedConstrained (pi := \pi(A)) of A != 1 & A \proper G + & forall X Y : {group gT}, + A \subset X -> X \proper G -> Y \in |/|_X(A; pi^') -> Y \subset 'O_pi^'(X). + +Variable pi : nat_pred. + +Lemma max_normed_exists A X : + pi.-group X -> A \subset 'N(X) -> {Y | Y \in |/|*(A; pi) & X \subset Y}. +Proof. +move=> piX nXA; pose piAn Y := pi.-group(Y) && (A \subset 'N(Y)). +have [|Y] := @maxgroup_exists _ piAn X; first by rewrite /piAn piX. +by exists Y; rewrite // inE. +Qed. + +Lemma mem_max_normed A X : X \in |/|*(A; pi) -> pi.-group X /\ A \subset 'N(X). +Proof. by rewrite inE; move/maxgroupp; move/andP. Qed. + +Lemma norm_acts_max_norm P : [acts 'N(P), on |/|*(P; pi) | 'JG]. +Proof. +apply/subsetP=> z Nz; rewrite !inE; apply/subsetP=> Q; rewrite !inE. +case/maxgroupP=> qQ maxQ; apply/maxgroupP; rewrite pgroupJ norm_conj_norm //. +split=> // Y; rewrite sub_conjg /= => qY; move/maxQ=> <-; rewrite ?conjsgKV //. +by rewrite pgroupJ norm_conj_norm ?groupV. +Qed. + +Lemma trivg_max_norm P : 1%G \in |/|*(P; pi) -> |/|*(P; pi) = [set 1%G]. +Proof. +move=> max1; apply/eqP; rewrite eqEsubset sub1set max1 andbT. +apply/subsetP=> Q; rewrite !inE -val_eqE /= in max1 *. +by case/maxgroupP: max1 => _ max1; move/maxgroupp; move/max1->; rewrite ?sub1G. +Qed. + +Lemma max_normed_uniq A P Q : + |/|*(A; pi) = [set Q] -> A \subset P -> P \subset 'N(Q) -> + |/|*(P; pi) = [set Q]. +Proof. +move=> defAmax sAP nQP; have: Q \in |/|*(A; pi) by rewrite defAmax set11. +rewrite inE; case/maxgroupP; case/andP=> piQ _ maxQ. +apply/setP=> X; rewrite !inE -val_eqE /=; apply/maxgroupP/eqP=> [[]|->{X}]. + case/andP=> piX nXP maxX; have nXA := subset_trans sAP nXP. + have [Y] := max_normed_exists piX nXA. + by rewrite defAmax; move/set1P->; move/maxX=> -> //; rewrite piQ. +rewrite piQ; split=> // X; case/andP=> piX nXP sQX. +by rewrite (maxQ X) // piX (subset_trans sAP). +Qed. + +End Hypothesis7_1. + +Notation "|/|_ X ( A ; pi )" := (normed_pgroups X A pi) : group_scope. +Notation "|/|* ( A ; pi )" := (max_normed_pgroups A pi) : group_scope. + +Section Seven. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). +Local Notation grT := {group gT}. +Implicit Types H P Q R K M A B : grT. +Implicit Type p q : nat. + +Section NormedConstrained. + +Variables (q : nat) (A : grT). +Let pi := Eval simpl in \pi(A). +Let K := 'O_pi^'('C(A)). +Let nsKC : K <| 'C(A) := pcore_normal _ _. + +Lemma cent_core_acts_max_norm : [acts K, on |/|*(A; q) | 'JG]. +Proof. +by rewrite (subset_trans _ (norm_acts_max_norm _ _)) ?cents_norm ?pcore_sub. +Qed. +Let actsKmax := actsP cent_core_acts_max_norm. + +Hypotheses (cstrA : normed_constrained A) (pi'q : q \notin pi). + +Let hyp71 H R : + A \subset H -> H \proper G -> R \in |/|_H(A; pi^') -> R \subset 'O_pi^'(H). +Proof. by case: cstrA H R. Qed. + +(* This is the observation between B & G, Hypothesis 7.1 and Lemma 7.1. *) +Remark normed_constrained_Hall : pi^'.-Hall('C(A)) K. +Proof. +have [_ ntA prA _] := cstrA; rewrite -[setT]/G in prA. +rewrite /pHall pcore_pgroup pcore_sub pnatNK /=. +rewrite -card_quotient ?gFnorm //= -/K. +apply/pgroupP=> p p_pr; case/Cauchy=> // Kx; case/morphimP=> x Nx Cx ->{Kx}. +rewrite /order -quotient_cycle //= -/K => def_p; apply/idPn=> pi'p. +have [P sylP] := Sylow_exists p <[x]>; have [sPx pP _]:= and3P sylP. +suffices: P \subset K. + have nKP: P \subset 'N(K) by rewrite (subset_trans sPx) ?cycle_subG. + rewrite -quotient_sub1 //= -/K (sameP trivgP eqP) trivg_card1. + rewrite (card_Hall (morphim_pHall _ nKP sylP)) def_p part_pnat_id ?pnat_id //. + by case: eqP p_pr => // ->. +suffices sP_pAC: P \subset 'O_pi^'(A <*> 'C(A)). + rewrite (subset_trans sP_pAC) ?pcore_max ?pcore_pgroup //. + rewrite /normal (char_norm_trans (pcore_char _ _)) ?normsG ?joing_subr //. + rewrite andbT -quotient_sub1; last first. + rewrite (subset_trans (pcore_sub _ _)) // join_subG normG cents_norm //. + by rewrite centsC. + rewrite /= -(setIidPr (pcore_sub _ _)) quotientGI ?joing_subr //=. + rewrite {1}cent_joinEr // quotientMidr coprime_TIg // coprime_morph //. + by rewrite coprime_pi' ?cardG_gt0 //= -/pi [pnat _ _]pcore_pgroup. +apply: hyp71; first exact: joing_subl. + apply: sub_proper_trans (mFT_norm_proper ntA prA). + by rewrite join_subG normG cent_sub. +have sPC: P \subset 'C(A) by rewrite (subset_trans sPx) ?cycle_subG. +rewrite inE /psubgroup cents_norm 1?centsC // andbT. +rewrite (subset_trans sPC) ?joing_subr //=. +by apply: sub_in_pnat pP => p' _; move/eqnP->. +Qed. +Let hallK := normed_constrained_Hall. + +(* This is B & G, Lemma 7.1. *) +Lemma normed_constrained_meet_trans Q1 Q2 H : + A \subset H -> H \proper G -> Q1 \in |/|*(A; q) -> Q2 \in |/|*(A; q) -> + Q1 :&: H != 1 -> Q2 :&: H != 1 -> + exists2 k, k \in K & Q2 :=: Q1 :^ k. +Proof. +move: {2}_.+1 (ltnSn (#|G| - #|Q1 :&: Q2|)) => m. +elim: m => // m IHm in H Q1 Q2 * => geQ12m sAH prHG maxQ1 maxQ2 ntHQ1 ntHQ2. +have:= maxQ1; rewrite inE => /maxgroupP[/andP[qQ1 nQ1A] maxQ1P]. +have:= maxQ2; rewrite inE => /maxgroupP[/andP[qQ2 nQ2A] maxQ2P]. +have prQ12: Q1 :&: Q2 \proper G. + rewrite properT; apply: contraNneq (mFT_nonSolvable gT) => <-. + by apply: pgroup_sol (pgroupS _ qQ1); rewrite subsetIl. +wlog defH: H prHG sAH ntHQ1 ntHQ2 / Q1 :&: Q2 != 1 -> H :=: 'N(Q1 :&: Q2). + case: (eqVneq (Q1 :&: Q2) 1) => [-> | ntQ12] IH. + by apply: (IH H) => //; case/eqP. + apply: (IH 'N(Q1 :&: Q2)%G); rewrite ?normsI ?mFT_norm_proper //; + apply: contra ntQ12; rewrite -!subG1; apply: subset_trans; + by rewrite subsetI normG (subsetIl, subsetIr). +pose L := 'O_pi^'(H); have sLH: L \subset H := pcore_sub _ _. +have [nLA coLA solL]: [/\ A \subset 'N(L), coprime #|L| #|A| & solvable L]. +- rewrite (char_norm_trans (pcore_char _ _)) ?normsG //. + rewrite coprime_sym coprime_pi' ?cardG_gt0 ?[pnat _ _]pcore_pgroup //. + by rewrite (solvableS sLH) ?mFT_sol. +have Qsyl Q: Q \in |/|*(A; q) -> Q :&: H != 1 -> + exists R : {group _}, [/\ q.-Sylow(L) R, A \subset 'N(R) & Q :&: H \subset R]. +- case/mem_max_normed=> qQ nQA ntQH. + have qQH: q.-group (Q :&: H) by rewrite (pgroupS _ qQ) ?subsetIl. + have nQHA: A \subset 'N(Q :&: H) by rewrite normsI // normsG. + apply: coprime_Hall_subset => //; apply: (hyp71) => //. + rewrite inE nQHA /psubgroup subsetIr andbT. + by apply: sub_in_pnat qQH => p _; move/eqnP->. +have [R1 [sylR1 nR1A sQR1]] := Qsyl _ maxQ1 ntHQ1. +have [R2 [sylR2 nR2A sQR2]] := Qsyl _ maxQ2 ntHQ2. +have [h Ch defR2] := coprime_Hall_trans nLA coLA solL sylR2 nR2A sylR1 nR1A. +have{Ch} [Hh Kh]: h \in H /\ h \in K. + case/setIP: Ch => Lh Ch; rewrite (subsetP sLH) //. + rewrite (mem_normal_Hall hallK (pcore_normal _ _)) //. + by rewrite (mem_p_elt _ Lh) ?pcore_pgroup. +have [Q3 maxQ3 sR2Q3] := max_normed_exists (pHall_pgroup sylR2) nR2A. +have maxQ1h: (Q1 :^ h)%G \in |/|*(A; q) by rewrite actsKmax. +case: (eqsVneq Q1 Q2) => [| neQ12]; first by exists 1; rewrite ?group1 ?conjsg1. +have ntHQ3: Q3 :&: H != 1. + apply: contra ntHQ2; rewrite -!subG1; apply: subset_trans. + by rewrite subsetI subsetIr (subset_trans sQR2). +have ntHQ1h: (Q1 :^ h) :&: H != 1. + by move: ntHQ1; rewrite !trivg_card1 -(cardJg _ h) conjIg (conjGid Hh). +suff [prI1 prI2]: Q1 :&: Q2 \proper Q1 :&: R1 /\ Q1 :&: Q2 \proper Q2 :&: R2. + have: #|G| - #|(Q1 :^ h) :&: Q3| < m. + rewrite ltnS in geQ12m; apply: leq_trans geQ12m. + rewrite ltn_sub2l ?(proper_card prQ12) // -(cardJg _ h) proper_card //. + by rewrite (proper_sub_trans _ (setIS _ sR2Q3)) // defR2 -conjIg properJ. + have: #|G| - #|Q3 :&: Q2| < m. + rewrite ltnS in geQ12m; apply: leq_trans geQ12m. + rewrite ltn_sub2l ?proper_card // (proper_sub_trans prI2) //. + by rewrite setIC setISS. + case/(IHm H) => // k2 Kk2 defQ2; case/(IHm H) => // k3 Kk3 defQ3. + by exists (h * k3 * k2); rewrite ?groupM ?conjsgM // -defQ3. +case: (eqVneq (Q1 :&: Q2) 1) => [-> | ntQ12]. + rewrite !proper1G; split; [apply: contra ntHQ1 | apply: contra ntHQ2]; + by rewrite -!subG1; apply: subset_trans; rewrite subsetI subsetIl. +rewrite -(setIidPr (subset_trans (pHall_sub sylR1) sLH)) setIA. +rewrite -(setIidPr (subset_trans (pHall_sub sylR2) sLH)) setIA. +rewrite (setIidPl sQR1) (setIidPl sQR2) {}defH //. +have nilQ1 := pgroup_nil qQ1; have nilQ2 := pgroup_nil qQ2. +rewrite !nilpotent_proper_norm /proper ?subsetIl ?subsetIr ?subsetI ?subxx //=. + by rewrite andbT; apply: contra neQ12 => sQ21; rewrite (maxQ2P Q1) ?qQ1. +by apply: contra neQ12 => sQ12; rewrite (maxQ1P Q2) ?qQ2. +Qed. + +(* This is B & G, Theorem 7.2. *) +Theorem normed_constrained_rank3_trans : + 'r('Z(A)) >= 3 -> [transitive K, on |/|*(A; q) | 'JG]. +Proof. +case/rank_geP=> B /nElemP[p]; rewrite !inE subsetI -2!andbA. +case/and4P=> sBA cAB abelB mB3; have [_ cBB _] := and3P abelB. +have q'B: forall Q, q.-group Q -> coprime #|Q| #|B|. + move=> Q qQ; rewrite coprime_sym (coprimeSg sBA) ?coprime_pi' //. + exact: pi_pnat qQ _. +have [Q1 maxQ1 _] := max_normed_exists (pgroup1 _ q) (norms1 A). +apply/imsetP; exists Q1 => //; apply/setP=> Q2. +apply/idP/imsetP=> [maxQ2|[k Kk] ->]; last by rewrite actsKmax. +have [qQ1 nQ1A]:= mem_max_normed maxQ1; have [qQ2 nQ2A]:= mem_max_normed maxQ2. +case: (eqVneq Q1 1%G) => [trQ1 | ntQ1]. + exists 1; rewrite ?group1 // act1; apply/eqP. + by rewrite trivg_max_norm -trQ1 // inE in maxQ2. +case: (eqVneq Q2 1%G) => [trQ2 | ntQ2]. + by case/negP: ntQ1; rewrite trivg_max_norm -trQ2 // inE in maxQ1 *. +have: [exists (C : grT | 'C_Q1(C) != 1), cyclic (B / C) && (C <| B)]. + apply: contraR ntQ1 => trQ1; have: B \subset 'N(Q1) := subset_trans sBA nQ1A. + rewrite -val_eqE -subG1 /=; move/coprime_abelian_gen_cent <-; rewrite ?q'B //. + rewrite gen_subG; apply/bigcupsP=> C cocyC; rewrite subG1. + by apply: contraR trQ1 => ntCC; apply/existsP; exists C; rewrite ntCC. +case/existsP=> C /and3P[ntCQ1 cycBC nsCB]; have [sCB nCB]:= andP nsCB. +have{mB3} ncycC: ~~ cyclic C. + rewrite (abelem_cyclic (quotient_abelem _ abelB)) ?card_quotient // in cycBC. + rewrite -divgS // logn_div ?cardSg // leq_subLR addn1 (eqP mB3) in cycBC. + by rewrite (abelem_cyclic (abelemS sCB abelB)) -ltnNge. +have: [exists (z | 'C_Q2[z] != 1), z \in C^#]. + apply: contraR ntQ2 => trQ2; have:= subset_trans sCB (subset_trans sBA nQ2A). + rewrite -[_ == _]subG1 /=. + move/coprime_abelian_gen_cent1 <-; rewrite ?(abelianS sCB) //; last first. + by rewrite (coprimegS sCB) ?q'B. + rewrite gen_subG; apply/bigcupsP=> z Cz. + by apply: contraR trQ2 => ntCz; apply/existsP; exists z; rewrite -subG1 ntCz. +case/existsP=> z; rewrite !inE => /and3P[ntzQ2 ntz Cz]. +have prCz: 'C[z] \proper G by rewrite -cent_cycle mFT_cent_proper ?cycle_eq1. +have sACz: A \subset 'C[z] by rewrite sub_cent1 (subsetP cAB) ?(subsetP sCB). +have [|//|k Kk defQ2]:= normed_constrained_meet_trans sACz prCz maxQ1 maxQ2. + apply: contra ntCQ1; rewrite -!subG1; apply: subset_trans. + by rewrite setIS //= -cent_cycle centS ?cycle_subG. +exists k => //; exact: val_inj. +Qed. + +(* This is B & G, Theorem 7.3. *) +Theorem normed_constrained_rank2_trans : + q %| #|'C(A)| -> 'r('Z(A)) >= 2 -> [transitive K, on |/|*(A; q) | 'JG]. +Proof. +move=> qC; case/rank_geP=> B; case/nElemP=> p; do 2![case/setIdP]. +rewrite subsetI; case/andP=> sBA cAB abelB mB2; have [_ cBB _] := and3P abelB. +have{abelB mB2} ncycB: ~~ cyclic B by rewrite (abelem_cyclic abelB) (eqP mB2). +have [R0 sylR0] := Sylow_exists q 'C(A); have [cAR0 qR0 _] := and3P sylR0. +have nR0A: A \subset 'N(R0) by rewrite cents_norm // centsC. +have{nR0A} [R maxR sR0R] := max_normed_exists qR0 nR0A. +apply/imsetP; exists R => //; apply/setP=> Q. +apply/idP/imsetP=> [maxQ|[k Kk] ->]; last by rewrite actsKmax. +have [qR nRA]:= mem_max_normed maxR; have [qQ nQA]:= mem_max_normed maxQ. +have [R1 | ntR] := eqVneq R 1%G. + rewrite trivg_max_norm -R1 // in maxQ. + by exists 1; rewrite ?group1 ?act1 ?(set1P maxQ). +have ntQ: Q != 1%G. + by apply: contra ntR => Q1; rewrite trivg_max_norm -(eqP Q1) // inE in maxR *. +have ntRC: 'C_R(A) != 1. + have sR0CR: R0 \subset 'C_R(A) by rewrite subsetI sR0R. + suffices: R0 :!=: 1 by rewrite -!proper1G; move/proper_sub_trans->. + move: ntR; rewrite -!cardG_gt1 -(part_pnat_id qR) (card_Hall sylR0). + by rewrite !p_part_gt1 !mem_primes !cardG_gt0 qC; case/and3P=> ->. +have: [exists (z | 'C_Q[z] != 1), z \in B^#]. + apply: contraR ntQ => trQ; have:= subset_trans sBA nQA. + rewrite -[_ == _]subG1; move/coprime_abelian_gen_cent1 <- => //; last first. + by rewrite coprime_sym (coprimeSg sBA) ?coprime_pi' /pgroup ?(pi_pnat qQ). + rewrite gen_subG; apply/bigcupsP=> z Cz; rewrite subG1. + by apply: contraR trQ => ntCz; apply/existsP; exists z; rewrite ntCz. +case/existsP=> z; rewrite 2!inE => /and3P[ntzQ ntz Bz]. +have prCz: 'C[z] \proper G by rewrite -cent_cycle mFT_cent_proper ?cycle_eq1. +have sACz: A \subset 'C[z] by rewrite sub_cent1 (subsetP cAB). +have [|//|k Kk defQ2]:= normed_constrained_meet_trans sACz prCz maxR maxQ. + apply: contra ntRC; rewrite -!subG1; apply: subset_trans. + by rewrite setIS //= -cent_cycle centS // cycle_subG (subsetP sBA). +exists k => //; exact: val_inj. +Qed. + +(* This is B & G, Theorem 7.4. *) +Theorem normed_trans_superset P : + A <|<| P -> pi.-group P -> [transitive K, on |/|*(A; q) | 'JG] -> + [/\ 'C_K(P) = 'O_pi^'('C(P)), + [transitive 'O_pi^'('C(P)), on |/|*(P; q) | 'JG], + |/|*(P; q) \subset |/|*(A; q) + & {in |/|*(P; q), forall Q, P :&: 'N(P)^`(1) \subset 'N(Q)^`(1) + /\ 'N(P) = 'C_K(P) * 'N_('N(P))(Q)}]. +Proof. +move=> snAP piP trnK; set KP := 'O_pi^'('C(P)). +have defK: forall B, A \subset B -> 'C_K(B) = 'O_pi^'('C(B)). + move=> B sAB; apply/eqP; rewrite eqEsubset {1}setIC pcoreS ?centS //. + rewrite subsetI pcore_sub (sub_Hall_pcore hallK) ?pcore_pgroup //. + by rewrite (subset_trans (pcore_sub _ _)) ?centS. +suffices: [transitive KP, on |/|*(P; q) | 'JG] /\ |/|*(P; q) \subset |/|*(A; q). + have nsKPN: KP <| 'N(P) := char_normal_trans (pcore_char _ _) (cent_normal _). + case=> trKP smnPA; rewrite (defK _ (subnormal_sub snAP)); split=> // Q maxQ. + have defNP: KP * 'N_('N(P))(Q) = 'N(P). + rewrite -(astab1JG Q) -normC; last by rewrite subIset 1?normal_norm. + apply/(subgroup_transitiveP maxQ); rewrite ?normal_sub //=. + by rewrite (atrans_supgroup _ trKP) ?norm_acts_max_norm ?normal_sub. + split=> //; move/pprod_focal_coprime: defNP => -> //. + - by rewrite subIset // orbC commgSS ?subsetIr. + - by rewrite subsetI normG; case/mem_max_normed: maxQ. + by rewrite (p'nat_coprime (pcore_pgroup _ _)). +elim: {P}_.+1 {-2}P (ltnSn #|P|) => // m IHm P lePm in KP piP snAP *. +wlog{snAP} [B maxnB snAB]: / {B : grT | maxnormal B P P & A <|<| B}. + case/subnormalEr: snAP => [|[D [snAD nDP prDP]]]; first by rewrite /KP => <-. + have [B maxnB sDB]: {B : grT | maxnormal B P P & D \subset B}. + by apply: maxgroup_exists; rewrite prDP normal_norm. + apply; exists B => //; apply: subnormal_trans snAD (normal_subnormal _). + by apply: normalS sDB _ nDP; case/andP: (maxgroupp maxnB); case/andP. +have [prBP nBP] := andP (maxgroupp maxnB); have sBP := proper_sub prBP. +have{lePm}: #|B| < m by exact: leq_trans (proper_card prBP) _. +case/IHm=> {IHm}// [|trnB smnBA]; first by rewrite (pgroupS sBP). +have{maxnB} abelPB: is_abelem (P / B). + apply: charsimple_solvable (maxnormal_charsimple _ maxnB) _ => //. + have [_ ntA _ _] := cstrA; have sAB := subnormal_sub snAB. + by apply: mFT_quo_sol; apply: contraL sAB; move/eqP->; rewrite subG1. +have{abelPB} [p p_pr pPB]: exists2 p, prime p & p.-group (P / B). + by case/is_abelemP: abelPB => p p_pr; case/andP; exists p. +have{prBP} pi_p: p \in pi. + case/pgroup_pdiv: pPB => [|_ pPB _]. + by rewrite -subG1 quotient_sub1 // proper_subn. + by apply: pgroupP p_pr pPB; exact: quotient_pgroup. +pose S := |/|*(B; q); have p'S: #|S| %% p != 0. + have pi'S: pi^'.-nat #|S| := pnat_dvd (atrans_dvd trnB) (pcore_pgroup _ _). + by rewrite -prime_coprime // (pnat_coprime _ pi'S) ?pnatE. +have{p'S} [Q S_Q nQP]: exists2 Q, Q \in S & P \subset 'N(Q). + have sTSB: setT \subset G / B by rewrite -im_quotient quotientS ?subsetT. + have modBE: {in P & S, forall x Q, ('JG %% B) Q (coset B x) = 'JG Q x}%act. + move=> x Q Px; rewrite inE; move/maxgroupp; case/andP=> _ nQB. + by rewrite /= modactE ?(subsetP nBP) ?afixJG ?setTI ?inE. + have actsPB: [acts P / B, on S | 'JG %% B \ sTSB]. + apply/subsetP=> _ /morphimP[x Nx Px ->]. + rewrite !inE; apply/subsetP=> Q S_Q; rewrite inE /= modBE //. + by rewrite (actsP (norm_acts_max_norm q B)). + move: p'S; rewrite (pgroup_fix_mod pPB actsPB); set nQ := #|_|. + case: (posnP nQ) => [->|]; first by rewrite mod0n. + rewrite lt0n; case/existsP=> Q /setIP[Q_S fixQ]; exists Q => //. + apply/normsP=> x Px; apply: congr_group; have Nx := subsetP nBP x Px. + by have:= afixP fixQ (coset B x); rewrite /= modBE ?mem_morphim //= => ->. +have [qQ _]:= mem_max_normed S_Q. +have{qQ nQP} [Q0 maxQ0 sQQ0] := max_normed_exists qQ nQP. +have [_ nQ0P]:= mem_max_normed maxQ0. +have actsKmnP: [acts 'O_pi^'('C(P)), on |/|*(P; q) | 'JG]. + by rewrite (subset_trans _ (norm_acts_max_norm q P)) // cents_norm ?pcore_sub. +case nt_mnP: (1%G \in |/|*(P; q)) => [|{Q S_Q sQQ0}]. + rewrite atrans_acts_card actsKmnP trivg_max_norm // imset_set1 in maxQ0 *. + have <-: Q = 1%G by apply/trivGP; rewrite -(congr_group (set1P maxQ0)). + by rewrite cards1 sub1set (subsetP smnBA). +have sAB := subnormal_sub snAB; have sAP := subset_trans sAB sBP. +have smnP_S: |/|*(P; q) \subset S. + apply/subsetP=> Q1 maxQ1; have [qQ1 nQ1P] := mem_max_normed maxQ1. + have ntQ1: Q1 != 1%G by case: eqP nt_mnP maxQ1 => // -> ->. + have prNQ1: 'N(Q1) \proper G := mFT_norm_proper ntQ1 (mFT_pgroup_proper qQ1). + have nQ1A: A \subset 'N(Q1) := subset_trans sAP nQ1P. + have [Q2 maxQ2 sQ12] := max_normed_exists qQ1 (subset_trans sBP nQ1P). + have [qQ2 nQ2B] := mem_max_normed maxQ2; apply: etrans maxQ2; congr in_mem. + apply: val_inj; suffices: q.-Sylow(Q2) Q1 by move/pHall_id=> /= ->. + have qNQ2: q.-group 'N_Q2(Q1) by rewrite (pgroupS _ qQ2) ?subsetIl. + pose KN := 'O_pi^'('N(Q1)); have sNQ2_KN: 'N_Q2(Q1) \subset KN. + rewrite hyp71 // inE normsI ?norms_norm ?(subset_trans sAB nQ2B) //=. + by rewrite /psubgroup subsetIr andbT; exact: pi_pnat qNQ2 _. + rewrite -Sylow_subnorm (pHall_subl _ sNQ2_KN) ?subsetI ?sQ12 ?normG //= -/KN. + suff: exists Q3 : grT, [/\ q.-Sylow(KN) Q3, P \subset 'N(Q3) & Q1 \subset Q3]. + move: maxQ1; rewrite inE; case/maxgroupP=> _ maxQ1 [Q3 [sylQ3 nQ3P sQ13]]. + by rewrite -(maxQ1 Q3) // (pHall_pgroup sylQ3). + apply: coprime_Hall_subset; rewrite //= -/KN. + - by rewrite (char_norm_trans (pcore_char _ _)) ?norms_norm. + - by rewrite coprime_sym (pnat_coprime piP (pcore_pgroup _ _)). + - by rewrite (solvableS (pcore_sub _ _)) ?mFT_sol. + by rewrite pcore_max ?normalG // /pgroup (pi_pnat qQ1). +split; last exact: subset_trans smnP_S smnBA. +apply/imsetP; exists Q0 => //; apply/setP=> Q2. +apply/idP/imsetP=> [maxQ2 | [k Pk ->]]; last by rewrite (actsP actsKmnP). +have [S_Q0 S_Q2]: Q0 \in S /\ Q2 \in S by rewrite !(subsetP smnP_S). +pose KB := 'O_pi^'('C(B)); pose KBP := KB <*> P. +have pi'KB: pi^'.-group KB by exact: pcore_pgroup. +have nKB_P: P \subset 'N(KB). + by rewrite (char_norm_trans (pcore_char _ _)) ?norms_cent. +have [k KBk defQ2]:= atransP2 trnB S_Q0 S_Q2. +have [qQ2 nQ2P] := mem_max_normed maxQ2. +have hallP: pi.-Hall('N_KBP(Q2)) P. + have sPN: P \subset 'N_KBP(Q2) by rewrite subsetI joing_subr. + rewrite pHallE eqn_leq -{1}(part_pnat_id piP) dvdn_leq ?partn_dvd ?cardSg //. + have ->: #|P| = #|KBP|`_pi. + rewrite /KBP joingC norm_joinEl // coprime_cardMg ?(pnat_coprime piP) //. + by rewrite partnM // part_pnat_id // part_p'nat // muln1. + by rewrite sPN dvdn_leq ?partn_dvd ?cardSg ?cardG_gt0 ?subsetIl. +have hallPk: pi.-Hall('N_KBP(Q2)) (P :^ k). + rewrite pHallE -(card_Hall hallP) cardJg eqxx andbT subsetI /=. + by rewrite defQ2 normJ conjSg conj_subG ?joing_subr // mem_gen // inE KBk. +have [gz]: exists2 gz, gz \in 'N_KBP(Q2) & P :=: (P :^ k) :^ gz. + apply: Hall_trans (solvableS (subsetIr _ _) _) hallP hallPk. + have ntQ2: Q2 != 1%G by case: eqP nt_mnP maxQ2 => // -> ->. + exact: mFT_sol (mFT_norm_proper ntQ2 (mFT_pgroup_proper qQ2)). +rewrite [KBP]norm_joinEr //= setIC -group_modr //= setIC -/KB. +case/imset2P=> g z; case/setIP=> KBg nQ2g Pz ->{gz} defP. +exists (k * g); last first. + by apply: val_inj; rewrite /= conjsgM -(normP nQ2g) defQ2. +rewrite /KP -defK // (subsetP (subsetIl _ 'C(B))) //= setIAC defK // -/KB. +rewrite -coprime_norm_cent 1?coprime_sym ?(pnat_coprime piP) //= -/KB. +rewrite inE groupM //; apply/normP. +by rewrite -{2}(conjsgK z P) (conjGid Pz) {2}defP /= !conjsgM conjsgK. +Qed. + +End NormedConstrained. + +(* This is B & G, Proposition 7.5(a). As this is only used in Proposition *) +(* 10.10, under the assumption A \in E*_p(G), we avoid the in_pmaxElemE *) +(* detour A = [set x in 'C_G(A) | x ^+ p == 1], and just use A \in E*_p(G). *) +Proposition plength_1_normed_constrained p A : + A :!=: 1 -> A \in 'E*_p(G) -> (forall M, M \proper G -> p.-length_1 M) -> + normed_constrained A. +Proof. +move=> ntA EpA pl1subG. +case/pmaxElemP: (EpA); case/pElemP=> sAG; case/and3P=> pA cAA _ _. +have prA: A \proper G := sub_proper_trans cAA (mFT_cent_proper ntA). +split=> // X Y sAX prX; case/setIdP; case/andP=> sYX p'Y nYA. +have pl1X := pl1subG _ prX; have solX := mFT_sol prX. +have [p_pr _ [r oApr]] := pgroup_pdiv pA ntA. +have oddp: odd p by move: (mFT_odd A); rewrite oApr odd_exp. +have def_pi: \pi(A)^' =i p^'. + by move=> q; rewrite inE /= oApr pi_of_exp // pi_of_prime. +have{p'Y} p'Y : p^'.-group Y by rewrite -(eq_pgroup _ def_pi). +rewrite (eq_pcore _ def_pi) (@plength1_norm_pmaxElem _ p X A) //. +by rewrite (subsetP (pmaxElemS p (subsetT _))) // setIC 2!inE sAX. +Qed. + +(* This is B & G, Proposition 7.5(b). *) +Proposition SCN_normed_constrained p P A : + p.-Sylow(G) P -> A \in 'SCN_2(P) -> normed_constrained A. +Proof. +move=> sylP; rewrite 2!inE -andbA => /and3P[nsAP /eqP defCA lt1mA]. +have [sAP nAP]:= andP nsAP. +have pP := pHall_pgroup sylP; have pA := pgroupS sAP pP. +have abA: abelian A by rewrite /abelian -{1}defCA subsetIr. +have prP: P \proper G := mFT_pgroup_proper pP. +have ntA: A :!=: 1 by rewrite -rank_gt0 ltnW. +pose pi := \pi(A); simpl in pi. +have [p_pr pdvA [r oApr]] := pgroup_pdiv pA ntA. +have{r oApr} def_pi: pi =i (p : nat_pred). + by move=> p'; rewrite !inE oApr primes_exp // primes_prime ?inE. +have def_pi' := eq_negn def_pi; have defK := eq_pcore _ def_pi'. +pose Z := 'Ohm_1('Z(P)); have sZ_ZP: Z \subset 'Z(P) by exact: Ohm_sub. +have sZP_A: 'Z(P) \subset A by rewrite -defCA setIS ?centS. +have sZA := subset_trans sZ_ZP sZP_A. +have nsA1: 'Ohm_1(A) <| P by exact: (char_normal_trans (Ohm_char _ _)). +pose inZor1 B := B \subset Z \/ #|Z| = p /\ Z \subset B. +have [B [E2_B nsBP sBZ]]: exists B, [/\ B \in 'E_p^2(A), B <| P & inZor1 B]. + have pZP: p.-group 'Z(P) by exact: pgroupS (center_sub _) pP. + have pZ: p.-group Z by exact: pgroupS sZ_ZP pZP. + have abelZ: p.-abelem Z by rewrite Ohm1_abelem ?center_abelian. + have nsZP: Z <| P := sub_center_normal sZ_ZP; have [sZP nZP] := andP nsZP. + case: (eqVneq Z 1). + rewrite -(setIidPr sZ_ZP); move/TI_Ohm1; rewrite setIid. + by move/(trivg_center_pgroup pP)=> P1; rewrite -subG1 -P1 sAP in ntA. + case/(pgroup_pdiv pZ)=> _ _ [[|k] /=]; rewrite -/Z => oZ; last first. + have: 2 <= 'r_p(Z) by rewrite p_rank_abelem // oZ pfactorK. + case/p_rank_geP=> B; rewrite /= -/Z => Ep2Z_B; exists B. + rewrite (subsetP (pnElemS _ _ sZA)) //. + case/setIdP: Ep2Z_B; case/setIdP=> sBZ _ _; split=> //; last by left. + by rewrite sub_center_normal ?(subset_trans sBZ). + pose BZ := ('Ohm_1(A) / Z) :&: 'Z(P / Z). + have ntBz: BZ != 1. + rewrite meet_center_nil ?quotient_nil ?(pgroup_nil pP) ?quotient_normal //. + rewrite -subG1 quotient_sub1 ?(subset_trans (normal_sub nsA1) nZP) //= -/Z. + apply: contraL lt1mA => sA1Z; rewrite -(pfactorK 1 p_pr) -oZ -rank_Ohm1. + by rewrite -(rank_abelem abelZ) -leqNgt rankS. + have lt1A1: 1 < logn p #|'Ohm_1(A)| by rewrite -p_rank_abelian -?rank_pgroup. + have [B [sBA1 nsBP oB]] := normal_pgroup pP nsA1 lt1A1. + exists B; split=> //; last do [right; split=> //]. + rewrite 2!inE (subset_trans sBA1) ?Ohm_sub // oB pfactorK //. + by rewrite (abelemS sBA1) ?Ohm1_abelem. + apply/idPn=> s'BZ; have: B :&: Z = 1 by rewrite setIC prime_TIg ?oZ. + move/TI_Ohm1; apply/eqP; rewrite meet_center_nil ?(pgroup_nil pP) //. + by rewrite -cardG_gt1 oB (ltn_exp2l 0 _ (prime_gt1 p_pr)). +split; rewrite ?(sub_proper_trans sAP) // => X Y sAX prX. +rewrite inE defK -andbA (eq_pgroup _ def_pi'); case/and3P=> sYX p'Y nYA. +move: E2_B; rewrite 2!inE -andbA; case/and3P=> sBA abelB dimB2. +have [pB cBB _] := and3P abelB. +have ntB: B :!=: 1 by case: (eqsVneq B 1) dimB2 => // ->; rewrite cards1 logn1. +have cBA b: b \in B -> A \subset 'C[b]. + by move=> Bb; rewrite -cent_set1 centsC sub1set (subsetP abA) ?(subsetP sBA). +have solCB (b : gT): b != 1 -> solvable 'C[b]. + by move=> ntb; rewrite mFT_sol ?mFT_cent1_proper. +wlog{sAX prX} [b B'b defX]: X Y p'Y nYA sYX / exists2 b, b \in B^# & 'C[b] = X. + move=> IH; have nYB := subset_trans sBA nYA. + rewrite -(coprime_abelian_gen_cent1 cBB _ nYB); last first. + - by rewrite coprime_sym (pnat_coprime pB). + - apply: contraL dimB2 => /cyclicP[x defB]. + have Bx: x \in B by rewrite defB cycle_id. + rewrite defB -orderE (abelem_order_p abelB Bx) ?(pfactorK 1) //. + by rewrite -cycle_eq1 -defB. + rewrite gen_subG; apply/bigcupsP=> b B'b. + have [ntb Bb]:= setD1P B'b; have sYbY: 'C_Y[b] \subset Y := subsetIl _ _. + have{IH} sYbKb: 'C_Y[b] \subset 'O_p^'('C[b]). + rewrite IH ?(pgroupS sYbY) ?subsetIr //; last by exists b. + by rewrite normsI // ?normsG ?cBA. + have{sYbKb} sYbKXb: 'C_Y[b] \subset 'O_p^'('C_X(<[b]>)). + apply: subset_trans (pcoreS _ (subsetIr _ _)). + by rewrite /= cent_gen cent_set1 subsetI setSI. + rewrite (subset_trans sYbKXb) // p'core_cent_pgroup ?mFT_sol //. + rewrite /psubgroup ?(pgroupS _ pB) cycle_subG //. + by rewrite (subsetP sAX) ?(subsetP sBA). +wlog Zb: b X Y defX B'b p'Y nYA sYX / b \in Z. + move=> IH; case Zb: (b \in Z); first exact: IH Zb. + case/setD1P: B'b => ntb Bb; have solX := solCB b ntb; rewrite defX in solX. + case: sBZ => [sBZ | [oZ sZB]]; first by rewrite (subsetP sBZ) in Zb. + have defB: Z * <[b]> = B. + apply/eqP; rewrite eqEcard mulG_subG sZB cycle_subG Bb. + have obp := abelem_order_p abelB Bb ntb. + rewrite (card_pgroup pB) /= (eqP dimB2) TI_cardMg -/#[_] ?oZ ?obp //. + rewrite -obp in p_pr; case: (prime_subgroupVti [group of Z] p_pr) => //. + by rewrite cycle_subG Zb. + pose P1 := P :&: X; have sP1P: P1 \subset P := subsetIl _ _. + have pP1 := pgroupS sP1P pP. + have [P2 sylP2 sP12] := Sylow_superset (subsetIr _ _) pP1. + have defP1: P1 = 'C_P(B). + rewrite -defB centM /= -/Z setIA /cycle cent_gen cent_set1 defX. + by rewrite [P :&: _](setIidPl _) // centsC (subset_trans sZ_ZP) ?subsetIr. + have dimPP1: logn p #|P : P1| <= 1. + by rewrite defP1 logn_quotient_cent_abelem ?normal_norm ?(eqP dimB2). + have{dimPP1} nsP12: P1 <| P2. + have pP2 := pHall_pgroup sylP2. + have: logn p #|P2 : P1| <= 1. + apply: leq_trans dimPP1; rewrite dvdn_leq_log //. + rewrite -(dvdn_pmul2l (cardG_gt0 [group of P1])) !Lagrange ?subsetIl //. + rewrite -(part_pnat_id pP2) (card_Hall sylP). + by rewrite partn_dvd ?cardSg ?subsetT. + rewrite -(pfactorK 1 p_pr) -pfactor_dvdn ?prime_gt0 // -p_part. + rewrite part_pnat_id ?(pnat_dvd (dvdn_indexg _ _)) //=. + case: (primeP p_pr) => _ dv_p; move/dv_p=> {dv_p}. + case/pred2P=> oP21; first by rewrite -(index1g sP12 oP21) normal_refl. + by rewrite (p_maximal_normal pP2) ?p_index_maximal ?oP21. + have nsZP1_2: 'Z(P1) <| P2 by rewrite (char_normal_trans (center_char _)). + have sZKp: Z \subset 'O_{p^', p}(X). + suff: 'Z(P1) \subset 'O_{p^', p}(X). + apply: subset_trans; rewrite subsetI {1}defP1 (subset_trans sZB). + by rewrite (subset_trans sZ_ZP) ?subIset // orbC centS. + by rewrite subsetI normal_sub. + apply: odd_p_abelian_constrained sylP2 (center_abelian _) nsZP1_2 => //. + exact: mFT_odd. + have coYZ: coprime #|Y| #|Z|. + by rewrite oZ coprime_sym (pnat_coprime _ p'Y) ?pnatE ?inE. + have nYZ := subset_trans sZA nYA. + have <-: [~: Y, Z] * 'C_Y(Z) = Y. + exact: coprime_cent_prod (solvableS sYX solX). + set K := 'O_p^'(X); have [nKY nKZ]: Y \subset 'N(K) /\ Z \subset 'N(K). + rewrite !(char_norm_trans (pcore_char _ _)) ?(subset_trans sZA) ?normsG //. + by rewrite -defX cBA. + rewrite mul_subG //. + have coYZK: coprime #|Y / K| #|'O_p(X / K)|. + by rewrite coprime_sym coprime_morphr ?(pnat_coprime (pcore_pgroup _ _)). + rewrite -quotient_sub1 ?comm_subG // -(coprime_TIg coYZK) subsetI. + rewrite /= -quotient_pseries2 !quotientS ?commg_subl //. + by rewrite (subset_trans (commgSS sYX sZKp)) ?commg_subr //= gFnorm. + have: 'O_p^'('C_X(Z)) \subset K. + rewrite p'core_cent_pgroup // /psubgroup /pgroup oZ pnat_id //. + by rewrite -defX (subset_trans sZA) ?cBA. + apply: subset_trans; apply: subset_trans (pcoreS _ (subsetIr _ _)). + have: cyclic Z by rewrite prime_cyclic ?oZ. + case/cyclicP=> z defZ; have Zz: z \in Z by rewrite defZ cycle_id. + rewrite subsetI setSI //= (IH z) ?subsetIr ?(pgroupS (subsetIl _ _)) //. + - by rewrite defZ /= cent_gen cent_set1. + - rewrite !inE -cycle_eq1 -defZ trivg_card_le1 oZ -ltnNge prime_gt1 //=. + by rewrite (subsetP sZB). + by rewrite normsI // norms_cent // cents_norm // centsC (subset_trans sZA). +set K := 'O_p^'(X); have nsKX: K <| X by exact: pcore_normal. +case/setD1P: B'b => ntb Bb. +have [sAX solX]: A \subset X /\ solvable X by rewrite -defX cBA ?solCB. +have sPX: P \subset X. + by rewrite -defX -cent_set1 centsC sub1set; case/setIP: (subsetP sZ_ZP b Zb). +have [nKA nKY nKP]: [/\ A \subset 'N(K), Y \subset 'N(K) & P \subset 'N(K)]. + by rewrite !(subset_trans _ (normal_norm nsKX)). +have sylPX: p.-Sylow(X) P by exact: pHall_subl (subsetT _) sylP. +have sAKb: A \subset 'O_{p^', p}(X). + exact: (odd_p_abelian_constrained (mFT_odd _)) abA nsAP. +have coYZK: coprime #|Y / K| #|'O_p(X / K)|. + by rewrite coprime_sym coprime_morphr ?(pnat_coprime (pcore_pgroup _ _)). +have cYAq: A / K \subset 'C_('O_p(X / K))(Y / K). + rewrite subsetI -quotient_pseries2 quotientS //= (sameP commG1P trivgP). + rewrite /= -quotientR // -(coprime_TIg coYZK) subsetI /= -quotient_pseries2. + rewrite !quotientS ?commg_subr // (subset_trans (commgSS sAKb sYX)) //. + by rewrite commg_subl /= gFnorm. +have cYKq: Y / K \subset 'C('O_p(X / K)). + apply: coprime_nil_faithful_cent_stab => /=. + - by rewrite (char_norm_trans (pcore_char _ _)) ?normsG ?quotientS. + - by rewrite coprime_morphr ?(pnat_coprime (pcore_pgroup _ _)). + - exact: pgroup_nil (pcore_pgroup _ _). + apply: subset_trans (cYAq); rewrite -defCA -['C_P(A) / K](morphim_restrm nKP). + rewrite injm_cent ?ker_restrm ?ker_coset ?morphim_restrm -?quotientE //. + rewrite setIid (setIidPr sAP) setISS ?centS //. + by rewrite pcore_sub_Hall ?morphim_pHall. + by rewrite coprime_TIg ?(pnat_coprime _ (pcore_pgroup _ _)). +rewrite -quotient_sub1 //= -/K -(coprime_TIg coYZK) subsetI subxx /=. +rewrite -Fitting_eq_pcore ?trivg_pcore_quotient // in cYKq *. +apply: subset_trans (cent_sub_Fitting (quotient_sol _ solX)). +by rewrite subsetI quotientS. +Qed. + +(* This is B & G, Theorem 7.6 (the Thompson Transitivity Theorem). *) +Theorem Thompson_transitivity p q A : + A \in 'SCN_3[p] -> q \in p^' -> + [transitive 'O_p^'('C(A)), on |/|*(A; q) | 'JG]. +Proof. +case/bigcupP=> P; rewrite 2!inE => sylP /andP[SCN_A mA3]. +have [defZ def_pi']: 'Z(A) = A /\ \pi(A)^' =i p^'. + rewrite inE -andbA in SCN_A; case/and3P: SCN_A => sAP _ /eqP defCA. + case: (eqsVneq A 1) mA3 => /= [-> | ntA _]. + rewrite /rank big1_seq // => p1 _; rewrite /p_rank big1 // => E. + by rewrite inE; case/andP; move/trivgP->; rewrite cards1 logn1. + have [p_pr _ [k ->]] := pgroup_pdiv (pgroupS sAP (pHall_pgroup sylP)) ntA. + split=> [|p1]; last by rewrite !inE primes_exp // primes_prime ?inE. + by apply/eqP; rewrite eqEsubset subsetIl subsetI subxx -{1}defCA subsetIr. +rewrite -(eq_pcore _ def_pi') -def_pi' => pi'q. +apply: normed_constrained_rank3_trans; rewrite ?defZ //. +by apply: SCN_normed_constrained sylP _; rewrite inE SCN_A ltnW. +Qed. + +End Seven. + diff --git a/mathcomp/odd_order/BGsection8.v b/mathcomp/odd_order/BGsection8.v new file mode 100644 index 0000000..8e306fa --- /dev/null +++ b/mathcomp/odd_order/BGsection8.v @@ -0,0 +1,404 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div fintype path. +Require Import finset prime fingroup automorphism action gproduct gfunctor. +Require Import center commutator pgroup gseries nilpotent sylow abelian maximal. +Require Import BGsection1 BGsection5 BGsection6 BGsection7. + +(******************************************************************************) +(* This file covers B & G, section 8, i.e., the proof of two special cases *) +(* of the Uniqueness Theorem, for maximal groups with Fitting subgroups of *) +(* rank at least 3. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section Eight. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). +Implicit Types H M A X P : {group gT}. +Implicit Types p q r : nat. + +Local Notation "K ` p" := 'O_(nat_pred_of_nat p)(K) + (at level 8, p at level 2, format "K ` p") : group_scope. +Local Notation "K ` p" := 'O_(nat_pred_of_nat p)(K)%G : Group_scope. + +(* This is B & G, Theorem 8.1(a). *) +Theorem non_pcore_Fitting_Uniqueness p M A0 : + M \in 'M -> ~~ p.-group ('F(M)) -> A0 \in 'E*_p('F(M)) -> 'r_p(A0) >= 3 -> + 'C_('F(M))(A0)%G \in 'U. +Proof. +set F := 'F(M) => maxM p'F /pmaxElemP[/=/setIdP[sA0F abelA0] maxA0]. +have [pA0 cA0A0 _] := and3P abelA0; rewrite (p_rank_abelem abelA0) => dimA0_3. +rewrite (uniq_mmax_subset1 maxM) //= -/F; last by rewrite subIset ?Fitting_sub. +set A := 'C_F(A0); pose pi := \pi(A). +have [sZA sAF]: 'Z(F) \subset A /\ A \subset F by rewrite subsetIl setIS ?centS. +have nilF: nilpotent F := Fitting_nil _. +have nilZ := nilpotentS (center_sub _) nilF. +have piZ: \pi('Z(F)) = \pi(F) by rewrite pi_center_nilpotent. +have def_pi: pi = \pi(F). + by apply/eq_piP=> q; apply/idP/idP; last rewrite -piZ; exact: piSg. +have def_nZq: forall q, q \in pi -> 'N('Z(F)`q) = M. + move=> q; rewrite def_pi -piZ -p_part_gt1. + rewrite -(card_Hall (nilpotent_pcore_Hall _ nilZ)) cardG_gt1 /= -/F => ntZ. + apply: mmax_normal => //=; apply: char_normal_trans (Fitting_normal _). + exact: char_trans (pcore_char _ _) (center_char _). +have sCqM: forall q, q \in pi -> 'C(A`q) \subset M. + move=> q; move/def_nZq <-; rewrite cents_norm // centS //. + rewrite (sub_Hall_pcore (nilpotent_pcore_Hall _ _)) ?pcore_pgroup //. + by apply: nilpotentS (Fitting_nil M); exact: subsetIl. + exact: subset_trans (pcore_sub _ _) _. +have sA0A: A0 \subset A by rewrite subsetI sA0F. +have pi_p: p \in pi. + by apply: (piSg sA0A); rewrite -[p \in _]logn_gt0 (leq_trans _ dimA0_3). +have sCAM: 'C(A) \subset M. + by rewrite (subset_trans (centS (pcore_sub p _))) ?sCqM. +have prM: M \proper G := mmax_proper maxM; have solM := mFT_sol prM. +have piCA: pi.-group('C(A)). + apply/pgroupP=> q q_pr; case/Cauchy=> // x cAx oxq; apply/idPn=> pi'q. + have Mx := subsetP sCAM x cAx; pose C := 'C_F(<[x]>). + have sAC: A \subset C by rewrite subsetI sAF centsC cycle_subG. + have sCFC_C: 'C_F(C) \subset C. + by rewrite (subset_trans _ sAC) ?setIS // centS ?(subset_trans _ sAC). + have cFx: x \in 'C_M(F). + rewrite inE Mx -cycle_subG coprime_nil_faithful_cent_stab //=. + by rewrite cycle_subG (subsetP (gFnorm _ _)). + by rewrite -orderE coprime_pi' ?cardG_gt0 // -def_pi oxq pnatE. + case/negP: pi'q; rewrite def_pi mem_primes q_pr cardG_gt0 -oxq cardSg //. + by rewrite cycle_subG (subsetP (cent_sub_Fitting _)). +have{p'F} pi_alt q: exists2 r, r \in pi & r != q. + have [<-{q} | ] := eqVneq p q; last by exists p. + rewrite def_pi; apply/allPn; apply: contra p'F => /allP/=pF. + by apply/pgroupP=> q q_pr qF; rewrite !inE pF // mem_primes q_pr cardG_gt0. +have sNZqXq' q X: + A \subset X -> X \proper G -> 'O_q^'('N_X('Z(F)`q)) \subset 'O_q^'(X). +- move=> sAX prX; have sZqX: 'Z(F)`q \subset X. + exact: subset_trans (pcore_sub _ _) (subset_trans sZA sAX). + have cZqNXZ: 'O_q^'('N_X('Z(F)`q)) \subset 'C('Z(F)`q). + have coNq'Zq: coprime #|'O_q^'('N_X('Z(F)`q))| #|'Z(F)`q|. + by rewrite coprime_sym coprime_pcoreC. + rewrite (sameP commG1P trivgP) -(coprime_TIg coNq'Zq) subsetI commg_subl /=. + rewrite commg_subr /= andbC (subset_trans (pcore_sub _ _)) ?subsetIr //=. + by rewrite (char_norm_trans (pcore_char _ _)) ?normsG // subsetI sZqX normG. + have: 'O_q^'('C_X(('Z(F))`q)) \subset 'O_q^'(X). + by rewrite p'core_cent_pgroup ?mFT_sol // /psubgroup sZqX pcore_pgroup. + apply: subset_trans; apply: subset_trans (pcoreS _ (subcent_sub _ _)). + by rewrite !subsetI subxx cZqNXZ (subset_trans (pcore_sub _ _)) ?subsetIl. +have sArXq' q r X: + q \in pi -> q != r -> A \subset X -> X \proper G -> A`r \subset 'O_q^'(X). +- move=> pi_q r'q sAX prX; apply: subset_trans (sNZqXq' q X sAX prX). + apply: subset_trans (pcoreS _ (subsetIr _ _)). + rewrite -setIA (setIidPr (pcore_sub _ _)) subsetI. + rewrite (subset_trans (pcore_sub _ _)) //= def_nZq //. + apply: subset_trans (pcore_Fitting _ _); rewrite -/F. + rewrite (sub_Hall_pcore (nilpotent_pcore_Hall _ nilF)) //; last first. + exact: subset_trans (pcore_sub _ _) sAF. + by apply: (pi_pnat (pcore_pgroup _ _)); rewrite !inE eq_sym. +have cstrA: normed_constrained A. + split=> [||X Y sAX prX]. + - by apply/eqP=> A1; rewrite /pi /= A1 cards1 in pi_p. + - exact: sub_proper_trans (subset_trans sAF (Fitting_sub _)) prM. + rewrite !inE -/pi -andbA; case/and3P=> sYX pi'Y nYA. + rewrite -bigcap_p'core subsetI sYX; apply/bigcapsP=> [[q /= _] pi_q]. + have [r pi_r q'r] := pi_alt q. + have{sArXq'} sArXq': A`r \subset 'O_q^'(X) by apply: sArXq'; rewrite 1?eq_sym. + have cA_CYr: 'C_Y(A`r) \subset 'C(A). + have coYF: coprime #|Y| #|F|. + by rewrite coprime_sym coprime_pi' ?cardG_gt0 // -def_pi. + rewrite (sameP commG1P trivgP) -(coprime_TIg coYF) commg_subI //. + by rewrite setIS // (subset_trans (sCqM r pi_r)) // gFnorm. + by rewrite subsetI subsetIl. + have{cA_CYr} CYr1: 'C_Y(A`r) = 1. + rewrite -(setIid Y) setIAC coprime_TIg // (coprimeSg cA_CYr) //. + by rewrite (pnat_coprime piCA). + have{CYr1} ->: Y :=: [~: Y, A`r]. + rewrite -(mulg1 [~: Y, _]) -CYr1 coprime_cent_prod //. + - by rewrite (subset_trans (pcore_sub _ _)). + - rewrite coprime_sym (coprimeSg (pcore_sub _ _)) //= -/A. + by rewrite coprime_pi' ?cardG_gt0. + by rewrite mFT_sol // (sub_proper_trans sYX). + rewrite (subset_trans (commgS _ sArXq')) // commg_subr. + by rewrite (char_norm_trans (pcore_char _ _)) ?normsG. +have{cstrA} nbyApi'1 q: q \in pi^' -> |/|*(A; q) = [set 1%G]. + move=> pi'q; have trA: [transitive 'O_pi^'('C(A)), on |/|*(A; q) | 'JG]. + apply: normed_constrained_rank3_trans; rewrite //= -/A. + rewrite -rank_abelem // in dimA0_3; apply: leq_trans dimA0_3 (rankS _). + by rewrite /= -/A subsetI sA0A centsC subsetIr. + have [Q maxQ defAmax]: exists2 Q, Q \in |/|*(A; q) & |/|*(A; q) = [set Q]. + case/imsetP: trA => Q maxQ defAmax; exists Q; rewrite // {maxQ}defAmax. + suffices ->: 'O_pi^'('C(A)) = 1 by rewrite /orbit imset_set1 act1. + rewrite -(setIidPr (pcore_sub _ _)) coprime_TIg //. + exact: pnat_coprime piCA (pcore_pgroup _ _). + have{maxQ} qQ: q.-group Q by move: maxQ; rewrite inE => /maxgroupp/andP[]. + have [<- // |] := eqVneq Q 1%G; rewrite -val_eqE /= => ntQ. + have{defAmax trA} defFmax: |/|*(F; q) = [set Q]. + apply/eqP; rewrite eqEcard cards1 -defAmax. + have snAF: A <|<| F by rewrite nilpotent_subnormal ?Fitting_nil. + have piF: pi.-group F by rewrite def_pi /pgroup pnat_pi ?cardG_gt0. + case/(normed_trans_superset _ _ snAF): trA => //= _ /imsetP[R maxR _] -> _. + by rewrite (cardsD1 R) maxR. + have nQM: M \subset 'N(Q). + apply/normsP=> x Mx; apply: congr_group; apply/set1P. + rewrite -defFmax (acts_act (norm_acts_max_norm _ _)) ?defFmax ?set11 //. + by apply: subsetP Mx; exact: gFnorm. + have{nQM} nsQM: Q <| M. + rewrite inE in maxM; case/maxgroupP: maxM => _ maxM. + rewrite -(maxM 'N(Q)%G) ?normalG ?mFT_norm_proper //. + exact: mFT_pgroup_proper qQ. + have sQF: Q \subset F by rewrite Fitting_max ?(pgroup_nil qQ). + rewrite -(setIidPr sQF) coprime_TIg ?eqxx // in ntQ. + by rewrite coprime_pi' ?cardG_gt0 // -def_pi (pi_pnat qQ). +apply/subsetP=> H /setIdP[maxH sAH]; rewrite inE -val_eqE /=. +have prH: H \proper G := mmax_proper maxH; have solH := mFT_sol prH. +pose D := 'F(H); have nilD: nilpotent D := Fitting_nil H. +have card_pcore_nil := card_Hall (nilpotent_pcore_Hall _ _). +have piD: \pi(D) = pi. + set sigma := \pi(_); have pi_sig: {subset sigma <= pi}. + move=> q; rewrite -p_part_gt1 -card_pcore_nil // cardG_gt1 /= -/D. + apply: contraR => /nbyApi'1 defAmax. + have nDqA: A \subset 'N(D`q). + rewrite (char_norm_trans (pcore_char _ _)) //. + by rewrite (subset_trans sAH) ?gFnorm. + have [Q]:= max_normed_exists (pcore_pgroup _ _) nDqA. + by rewrite defAmax -subG1; move/set1P->. + apply/eq_piP=> q; apply/idP/idP=> [|pi_q]; first exact: pi_sig. + apply: contraLR (pi_q) => sig'q; have nilA := nilpotentS sAF nilF. + rewrite -p_part_eq1 -card_pcore_nil // -trivg_card1 -subG1 /= -/A. + have <-: 'O_sigma^'(H) = 1. + apply/eqP; rewrite -trivg_Fitting ?(solvableS (pcore_sub _ _)) //. + rewrite Fitting_pcore -(setIidPr (pcore_sub _ _)) coprime_TIg //. + by rewrite coprime_pi' ?cardG_gt0 //; exact: pcore_pgroup. + rewrite -bigcap_p'core subsetI (subset_trans (pcore_sub _ _)) //=. + apply/bigcapsP=> [[r /= _] sig_r]; apply: sArXq' => //; first exact: pi_sig. + by apply: contra sig'q; move/eqP <-. +have cAD q r: q != r -> D`q \subset 'C(A`r). + move=> r'q; have [-> |] := eqVneq D`q 1; first by rewrite sub1G. + rewrite -cardG_gt1 card_pcore_nil // p_part_gt1 piD => pi_q. + have sArHq': A`r \subset 'O_q^'(H) by rewrite sArXq'. + have coHqHq': coprime #|D`q| #|'O_q^'(H)| by rewrite coprime_pcoreC. + rewrite (sameP commG1P trivgP) -(coprime_TIg coHqHq') commg_subI //. + rewrite subsetI subxx /= p_core_Fitting (subset_trans (pcore_sub _ _)) //. + exact: gFnorm. + rewrite subsetI sArHq' (subset_trans (subset_trans (pcore_sub _ _) sAH)) //. + by rewrite /= p_core_Fitting gFnorm. +have sDM: D \subset M. + rewrite [D]FittingEgen gen_subG; apply/bigcupsP=> [[q /= _] _]. + rewrite -p_core_Fitting -/D; have [r pi_r r'q] := pi_alt q. + by apply: subset_trans (sCqM r pi_r); apply: cAD; rewrite eq_sym. +have cApHp': A`p \subset 'C('O_p^'(H)). + have coApHp': coprime #|'O_p^'(H)| #|A`p|. + by rewrite coprime_sym coprime_pcoreC. + have solHp': solvable 'O_p^'(H) by rewrite (solvableS (pcore_sub _ _)). + have nHp'Ap: A`p \subset 'N('O_p^'(H)). + by rewrite (subset_trans (subset_trans (pcore_sub _ _) sAH)) ?gFnorm. + apply: subset_trans (coprime_cent_Fitting nHp'Ap coApHp' solHp'). + rewrite subsetI subxx centsC /= FittingEgen gen_subG. + apply/bigcupsP=> [[q /= _] _]; have [-> | /cAD] := eqVneq q p. + by rewrite -(setIidPl (pcore_sub p _)) TI_pcoreC sub1G. + apply: subset_trans; rewrite p_core_Fitting -pcoreI. + by apply: sub_pcore => r /andP[]. +have sHp'M: 'O_p^'(H) \subset M. + by apply: subset_trans (sCqM p pi_p); rewrite centsC. +have ntDp: D`p != 1 by rewrite -cardG_gt1 card_pcore_nil // p_part_gt1 piD. +have sHp'_NMDp': 'O_p^'(H) \subset 'O_p^'('N_M(D`p)). + apply: subset_trans (pcoreS _ (subsetIr _ _)). + rewrite -setIA (setIidPr (pcore_sub _ _)) /= (mmax_normal maxH) //. + by rewrite subsetI sHp'M subxx. + by rewrite /= p_core_Fitting pcore_normal. +have{sHp'_NMDp'} sHp'Mp': 'O_p^'(H) \subset 'O_p^'(M). + have pM_D: p.-subgroup(M) D`p. + by rewrite /psubgroup pcore_pgroup (subset_trans (pcore_sub _ _)). + apply: subset_trans (p'core_cent_pgroup pM_D (mFT_sol prM)). + apply: subset_trans (pcoreS _ (subcent_sub _ _)). + rewrite !subsetI sHp'_NMDp' sHp'M andbT /= (sameP commG1P trivgP). + have coHp'Dp: coprime #|'O_p^'(H)| #|D`p|. + by rewrite coprime_sym coprime_pcoreC. + rewrite -(coprime_TIg coHp'Dp) subsetI commg_subl commg_subr /=. + by rewrite p_core_Fitting !(subset_trans (pcore_sub _ _)) ?gFnorm. +have sMp'H: 'O_p^'(M) \subset H. + rewrite -(mmax_normal maxH (pcore_normal p H)) /= -p_core_Fitting //. + rewrite -/D (subset_trans _ (cent_sub _)) // centsC. + have solMp' := solvableS (pcore_sub p^' _) (mFT_sol prM). + have coMp'Dp: coprime #|'O_p^'(M)| #|D`p|. + by rewrite coprime_sym coprime_pcoreC. + have nMp'Dp: D`p \subset 'N('O_p^'(M)). + by rewrite (subset_trans (subset_trans (pcore_sub _ _) sDM)) ?gFnorm. + apply: subset_trans (coprime_cent_Fitting nMp'Dp coMp'Dp solMp'). + rewrite subsetI subxx centsC /= FittingEgen gen_subG. + apply/bigcupsP=> [[q /= _] _]; have [<- | /cAD] := eqVneq p q. + by rewrite -(setIidPl (pcore_sub p _)) TI_pcoreC sub1G. + rewrite centsC; apply: subset_trans. + rewrite -p_core_Fitting Fitting_pcore pcore_max ?pcore_pgroup //=. + rewrite /normal subsetI -pcoreI pcore_sub subIset ?gFnorm //=. + rewrite pcoreI (subset_trans (pcore_sub _ _)) //= -/F centsC. + case/dprodP: (nilpotent_pcoreC p nilF) => _ _ /= cFpp' _. + rewrite centsC (subset_trans cFpp' (centS _)) //. + have hallFp := nilpotent_pcore_Hall p nilF. + by rewrite (sub_Hall_pcore hallFp). +have{sHp'Mp' sMp'H} eqHp'Mp': 'O_p^'(H) = 'O_p^'(M). + apply/eqP; rewrite eqEsubset sHp'Mp'. + apply: subset_trans (sNZqXq' p H sAH prH). + apply: subset_trans (pcoreS _ (subsetIr _ _)). + rewrite -setIA (setIidPr (pcore_sub _ _)) subsetI sMp'H /=. + rewrite (mmax_normal maxM (char_normal_trans (pcore_char _ _) _)) //. + by rewrite (char_normal_trans (center_char _)) ?Fitting_normal. + by rewrite -cardG_gt1 card_pcore_nil // p_part_gt1 piZ -def_pi. +have ntHp': 'O_p^'(H) != 1. + have [q pi_q p'q] := pi_alt p; have: D`q \subset 'O_p^'(H). + by rewrite p_core_Fitting sub_pcore // => r; move/eqnP->. + rewrite -proper1G; apply: proper_sub_trans; rewrite proper1G. + by rewrite -cardG_gt1 card_pcore_nil // p_part_gt1 piD. +rewrite -(mmax_normal maxH (pcore_normal p^' H)) //= eqHp'Mp'. +by rewrite (mmax_normal maxM (pcore_normal _ _)) //= -eqHp'Mp'. +Qed. + +(* This is B & G, Theorem 8.1(b). *) +Theorem SCN_Fitting_Uniqueness p M P A : + M \in 'M -> p.-group ('F(M)) -> p.-Sylow(M) P -> + 'r_p('F(M)) >= 3 -> A \in 'SCN_3(P) -> + [/\ p.-Sylow(G) P, A \subset 'F(M) & A \in 'U]. +Proof. +set F := 'F(M) => maxM pF sylP dimFp3 scn3_A. +have [scnA dimA3] := setIdP scn3_A; have [nsAP defCA] := SCN_P scnA. +have cAA := SCN_abelian scnA; have sAP := normal_sub nsAP. +have [sPM pP _] := and3P sylP; have sAM := subset_trans sAP sPM. +have{dimA3} ntA: A :!=: 1 by case: eqP dimA3 => // ->; rewrite rank1. +have prM := mmax_proper maxM; have solM := mFT_sol prM. +have{pF} Mp'1: 'O_p^'(M) = 1. + apply/eqP; rewrite -trivg_Fitting ?(solvableS (pcore_sub _ _)) //. + rewrite Fitting_pcore -(setIidPr (pcore_sub _ _)) coprime_TIg //. + exact: pnat_coprime (pcore_pgroup _ _). +have defF: F = M`p := Fitting_eq_pcore Mp'1. +have sFP: F \subset P by rewrite defF (pcore_sub_Hall sylP). +have sAF: A \subset F. + rewrite defF -(pseries_pop2 _ Mp'1). + exact: (odd_p_abelian_constrained (mFT_odd _) solM sylP cAA nsAP). +have sZA: 'Z(F) \subset A. + by rewrite -defCA setISS ?centS // defF pcore_sub_Hall. +have sCAM: 'C(A) \subset M. + have nsZM: 'Z(F) <| M := char_normal_trans (center_char _) (Fitting_normal _). + rewrite -(mmax_normal maxM nsZM); last first. + rewrite /= -(setIidPr (center_sub _)) meet_center_nil ?Fitting_nil //. + by rewrite -proper1G (proper_sub_trans _ sAF) ?proper1G. + by rewrite (subset_trans _ (cent_sub _)) ?centS. +have nsZL_M: 'Z('L(P)) <| M. + by rewrite (Puig_center_normal (mFT_odd _) solM sylP). +have sNPM: 'N(P) \subset M. + rewrite -(mmax_normal maxM nsZL_M). + by rewrite (char_norm_trans (center_Puig_char P)). + apply/eqP; move/(trivg_center_Puig_pgroup (pHall_pgroup sylP))=> P1. + by rewrite -subG1 -P1 sAP in ntA. +have sylPG: p.-Sylow(G) P := mmax_sigma_Sylow maxM sylP sNPM. +split; rewrite // (uniq_mmax_subset1 maxM sAM). +have{scn3_A} scn3_A: A \in 'SCN_3[p] by apply/bigcupP; exists P; rewrite // inE. +pose K := 'O_p^'('C(A)); have sKF: K \subset F. + have sKM: K \subset M := subset_trans (pcore_sub _ _) sCAM. + apply: subset_trans (cent_sub_Fitting solM). + rewrite subsetI sKM coprime_nil_faithful_cent_stab ?Fitting_nil //. + - by rewrite (subset_trans (subset_trans (pcore_sub _ _) sCAM)) ?gFnorm. + - by rewrite /= -/F defF coprime_pcoreC. + have sACK: A \subset 'C_F(K) by rewrite subsetI sAF centsC pcore_sub. + by rewrite /= -/F -/K (subset_trans _ sACK) //= -defCA setISS ?centS. +have{sKF} K1: K = 1 by rewrite -(setIidPr sKF) defF TI_pcoreC. +have p'nbyA_1 q: q != p -> |/|*(A; q) = [set 1%G]. + move=> p'q. + have: [transitive K, on |/|*(A; q) | 'JG] by apply: Thompson_transitivity. + case/imsetP=> Q maxQ; rewrite K1 /orbit imset_set1 act1 => defAmax. + have nQNA: 'N(A) \subset 'N(Q). + apply/normsP=> x Nx; apply: congr_group; apply/set1P; rewrite -defAmax. + by rewrite (acts_act (norm_acts_max_norm _ _)). + have{nQNA} nQF: F \subset 'N(Q). + exact: subset_trans (subset_trans (normal_norm nsAP) nQNA). + have defFmax: |/|*(F; q) = [set Q] := max_normed_uniq defAmax sAF nQF. + have nQM: M \subset 'N(Q). + apply/normsP=> x Mx; apply: congr_group; apply/set1P; rewrite -defFmax. + rewrite (acts_act (norm_acts_max_norm _ _)) ?defFmax ?set11 //. + by rewrite (subsetP (gFnorm _ _)). + have [<- // | ntQ] := eqVneq Q 1%G. + rewrite inE in maxQ; have [qQ _] := andP (maxgroupp maxQ). + have{nQM} defNQ: 'N(Q) = M. + by rewrite (mmax_norm maxM) // (mFT_pgroup_proper qQ). + case/negP: ntQ; rewrite -[_ == _]subG1 -Mp'1 -defNQ pcore_max ?normalG //. + exact: pi_pnat qQ _. +have{p'nbyA_1} p'nbyA_1 X: + X \proper G -> p^'.-group X -> A \subset 'N(X) -> X :=: 1. +- move=> prX p'X nXA; have solX := mFT_sol prX. + apply/eqP; rewrite -trivg_Fitting // -subG1 /= FittingEgen gen_subG. + apply/bigcupsP=> [[q /= _] _]; have [-> | p'q] := eqVneq q p. + rewrite -(setIidPl (pcore_sub _ _)) coprime_TIg //. + by rewrite (pnat_coprime (pcore_pgroup _ _)). + have [|R] := max_normed_exists (pcore_pgroup q X) (char_norm_trans _ nXA). + exact: pcore_char. + by rewrite p'nbyA_1 // => /set1P->. +apply/subsetPn=> [[H0 MA_H0 neH0M]]. +have:= erefl [arg max_(H > H0 | (H \in 'M(A)) && (H != M)) #|H :&: M|`_p]. +case: arg_maxP => [|H {H0 MA_H0 neH0M}]; first by rewrite MA_H0 -in_set1. +rewrite /= inE -andbA; case/and3P=> maxH sAH neHM maxHM _. +have prH: H \proper G by rewrite inE in maxH; exact: maxgroupp maxH. +have sAHM: A \subset H :&: M by rewrite subsetI sAH. +have [R sylR_HM sAR]:= Sylow_superset sAHM (pgroupS sAP pP). +have [/subsetIP[sRH sRM] pR _] := and3P sylR_HM. +have{sylR_HM} sylR_H: p.-Sylow(H) R. + have [Q sylQ] := Sylow_superset sRM pR; have [sQM pQ _] := and3P sylQ. + case/eqVproper=> [defR | /(nilpotent_proper_norm (pgroup_nil pQ)) sRN]. + apply: (pHall_subl sRH (subsetT _)); rewrite pHallE subsetT /=. + by rewrite -(card_Hall sylPG) (card_Hall sylP) defR (card_Hall sylQ). + case/maximal_exists: (subsetT 'N(R)) => [nRG | [D maxD sND]]. + case/negP: (proper_irrefl (mem G)); rewrite -{1}nRG. + rewrite mFT_norm_proper ?(mFT_pgroup_proper pR) //. + by rewrite -proper1G (proper_sub_trans _ sAR) ?proper1G. + move/implyP: (maxHM D); rewrite 2!inE {}maxD leqNgt. + case: eqP sND => [->{D} sNM _ | _ sND]. + rewrite -Sylow_subnorm (pHall_subl _ _ sylR_HM) ?setIS //. + by rewrite subsetI sRH normG. + rewrite (subset_trans (subset_trans sAR (normG R)) sND); case/negP. + rewrite -(card_Hall sylR_HM) (leq_trans (proper_card sRN)) //. + rewrite -(part_pnat_id (pgroupS (subsetIl _ _) pQ)) dvdn_leq //. + by rewrite partn_dvd ?cardG_gt0 // cardSg //= setIC setISS. +have Hp'1: 'O_p^'(H) = 1. + apply: p'nbyA_1 (pcore_pgroup _ _) (subset_trans sAH (gFnorm _ _)). + exact: sub_proper_trans (pcore_sub _ _) prH. +have nsZLR_H: 'Z('L(R)) <| H. + exact: Puig_center_normal (mFT_odd _) (mFT_sol prH) sylR_H _. +have ntZLR: 'Z('L(R)) != 1. + apply/eqP=> /(trivg_center_Puig_pgroup pR) R1. + by rewrite -subG1 -R1 sAR in ntA. +have defH: 'N('Z('L(R))) = H := mmax_normal maxH nsZLR_H ntZLR. +have{sylR_H} sylR: p.-Sylow(G) R. + rewrite -Sylow_subnorm setTI (pHall_subl _ _ sylR_H) ?normG //=. + by rewrite -defH (char_norm_trans (center_Puig_char R)). +have nsZLR_M: 'Z('L(R)) <| M. + have sylR_M := pHall_subl sRM (subsetT _) sylR. + exact: Puig_center_normal (mFT_odd _) solM sylR_M _. +case/eqP: neHM; apply: group_inj. +by rewrite -defH (mmax_normal maxM nsZLR_M). +Qed. + +(* This summarizes the two branches of B & G, Theorem 8.1. *) +Theorem Fitting_Uniqueness M : M \in 'M -> 'r('F(M)) >= 3 -> 'F(M)%G \in 'U. +Proof. +move=> maxM; have [p _ -> dimF3] := rank_witness 'F(M). +have prF: 'F(M) \proper G := sub_mmax_proper maxM (Fitting_sub M). +have [pF | npF] := boolP (p.-group 'F(M)). + have [P sylP] := Sylow_exists p M; have [sPM pP _] := and3P sylP. + have dimP3: 'r_p(P) >= 3. + rewrite (p_rank_Sylow sylP) (leq_trans dimF3) //. + by rewrite p_rankS ?Fitting_sub. + have [A] := rank3_SCN3 pP (mFT_odd _) dimP3. + by case/(SCN_Fitting_Uniqueness maxM pF)=> // _ sAF; exact: uniq_mmaxS. +case/p_rank_geP: dimF3 => A /setIdP[EpA dimA3]. +have [A0 maxA0 sAA0] := @maxgroup_exists _ [pred X in 'E_p('F(M))] _ EpA. +have [_ abelA] := pElemP EpA; have pmaxA0: A0 \in 'E*_p('F(M)) by rewrite inE. +case/pElemP: (maxgroupp maxA0) => sA0F; case/and3P=> _ cA0A0 _. +have dimA0_3: 'r_p(A0) >= 3. + by rewrite -(eqP dimA3) -(p_rank_abelem abelA) p_rankS. +have:= non_pcore_Fitting_Uniqueness maxM npF pmaxA0 dimA0_3. +exact: uniq_mmaxS (subsetIl _ _) prF. +Qed. + +End Eight. + diff --git a/mathcomp/odd_order/BGsection9.v b/mathcomp/odd_order/BGsection9.v new file mode 100644 index 0000000..dba9344 --- /dev/null +++ b/mathcomp/odd_order/BGsection9.v @@ -0,0 +1,470 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div fintype path. +Require Import finset prime fingroup action automorphism quotient cyclic. +Require Import gproduct gfunctor pgroup center commutator gseries nilpotent. +Require Import sylow abelian maximal hall. +Require Import BGsection1 BGsection4 BGsection5 BGsection6. +Require Import BGsection7 BGsection8. + +(******************************************************************************) +(* This file covers B & G, section 9, i.e., the proof the Uniqueness *) +(* Theorem, along with the several variants and auxiliary results. Note that *) +(* this is the only file to import BGsection8. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section Nine. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). +Implicit Types H K L M A B P Q R : {group gT}. +Implicit Types p q r : nat. + +(* This is B & G, Theorem 9.1(b). *) +Theorem noncyclic_normed_sub_Uniqueness p M B : + M \in 'M -> B \in 'E_p(M) -> ~~ cyclic B -> + \bigcup_(K in |/|_G(B; p^')) K \subset M -> + B \in 'U. +Proof. +move=> maxM /pElemP[sBM abelB] ncycB snbBp'_M; have [pB cBB _] := and3P abelB. +have prM := mmax_proper maxM; have solM := mFT_sol prM. +apply/uniq_mmaxP; exists M; symmetry; apply/eqP. +rewrite eqEsubset sub1set inE maxM sBM; apply/subsetPn=> [[H0 MB_H0 neH0M]]. +have:= erefl [arg max_(H > H0 | (H \in 'M(B)) && (H :!=: M)) #|H :&: M|`_p]. +have [|H] := arg_maxP; first by rewrite MB_H0; rewrite inE in neH0M. +rewrite inE -andbA => /and3P[maxH sBH neHM] maxHM _ {H0 MB_H0 neH0M}. +have sB_HM: B \subset H :&: M by rewrite subsetI sBH. +have{sB_HM} [R sylR sBR] := Sylow_superset sB_HM pB. +have [/subsetIP[sRH sRM] pR _] := and3P sylR. +have [P sylP sRP] := Sylow_superset sRM pR; have [sPM pP _] := and3P sylP. +have sHp'M: 'O_p^'(H) \subset M. + apply: subset_trans snbBp'_M; rewrite (bigcup_max 'O_p^'(H)%G) // inE -andbA. + by rewrite subsetT pcore_pgroup (subset_trans sBH) ?gFnorm. +have{snbBp'_M} defMp': <<\bigcup_(K in |/|_G(P; p^')) K>> = 'O_p^'(M). + have nMp'M: M \subset 'N('O_p^'(M)) by exact: gFnorm. + have nMp'P := subset_trans sPM nMp'M. + apply/eqP; rewrite eqEsubset gen_subG sub_gen ?andbT; last first. + by rewrite (bigcup_max 'O_p^'(M)%G) // inE -andbA subsetT pcore_pgroup. + apply/bigcupsP=> K; rewrite inE -andbA => /and3P[_ p'K nKP]. + have sKM: K \subset M. + apply: subset_trans snbBp'_M; rewrite (bigcup_max K) // inE -andbA subsetT. + by rewrite p'K (subset_trans (subset_trans sBR sRP)). + rewrite -quotient_sub1 ?(subset_trans sKM) //=; set Mp' := 'O__(M). + have tiKp: 'O_p(M / Mp') :&: (K / _) = 1. + exact: coprime_TIg (pnat_coprime (pcore_pgroup _ _) (quotient_pgroup _ _)). + suffices sKMp: K / _ \subset 'O_p(M / Mp') by rewrite -(setIidPr sKMp) tiKp. + rewrite -Fitting_eq_pcore ?trivg_pcore_quotient //. + apply: subset_trans (cent_sub_Fitting (quotient_sol _ solM)). + rewrite subsetI quotientS //= (Fitting_eq_pcore (trivg_pcore_quotient _ _)). + rewrite (sameP commG1P trivgP) /= -/Mp' -tiKp subsetI commg_subl commg_subr. + rewrite (subset_trans (quotientS _ sKM)) ?gFnorm //=. + apply: subset_trans (pcore_sub_Hall (quotient_pHall nMp'P sylP)) _. + by rewrite quotient_norms. +have ntR: R :!=: 1 by case: eqP sBR ncycB => // -> /trivgP->; rewrite cyclic1. +have{defMp'} sNPM: 'N(P) \subset M. + have [Mp'1 | ntMp'] := eqVneq 'O_p^'(M) 1. + have nsZLP: 'Z('L(P)) <| M. + by apply: Puig_center_normal Mp'1 => //; apply: mFT_odd. + rewrite -(mmax_normal maxM nsZLP). + exact: char_norm_trans (center_Puig_char P) _. + apply: contraNneq ntR => /(trivg_center_Puig_pgroup pP) P1. + by rewrite -subG1 -P1. + rewrite -(mmax_normal maxM (pcore_normal _ _) ntMp') /= -defMp' norms_gen //. + apply/subsetP=> x nPx; rewrite inE sub_conjg; apply/bigcupsP=> K. + rewrite inE -andbA -sub_conjg => /and3P[_ p'K nKP]. + rewrite (bigcup_max (K :^ x)%G) // inE -andbA subsetT pgroupJ p'K /=. + by rewrite -(normP nPx) normJ conjSg. +have sylPG := mmax_sigma_Sylow maxM sylP sNPM. +have{sNPM} [sNRM sylRH]: 'N(R) \subset M /\ p.-Sylow(H) R. + have [defR | ltRP] := eqVproper sRP. + by split; rewrite defR // (pHall_subl _ (subsetT _)) // -defR. + have [| D /setIdP[maxD sND]]:= @mmax_exists _ 'N(R). + by rewrite mFT_norm_proper // (mFT_pgroup_proper pR). + have/implyP := maxHM D; rewrite inE {}maxD /= leqNgt. + rewrite (subset_trans (subset_trans sBR (normG R))) //= implybNN. + have ltRN := nilpotent_proper_norm (pgroup_nil pP) ltRP. + rewrite -(card_Hall sylR) (leq_trans (proper_card ltRN)) /=; last first. + rewrite setIC -(part_pnat_id (pgroupS (subsetIr _ _) pP)) dvdn_leq //. + by rewrite partn_dvd ?cardG_gt0 // cardSg // setISS. + move/eqP=> defD; rewrite defD in sND; split; rewrite // -Sylow_subnorm. + by rewrite (pHall_subl _ _ sylR) ?setIS // subsetI sRH normG. +have sFH_RHp': 'F(H) \subset R * 'O_p^'(H). + case/dprodP: (nilpotent_pcoreC p (Fitting_nil H)) => _ /= <- _ _. + by rewrite p_core_Fitting mulgSS ?(pcore_sub_Hall sylRH) ?pcore_Fitting. +have sFH_M: 'F(H) \subset M by rewrite (subset_trans sFH_RHp') ?mul_subG. +case/(H :=P: M): neHM; have [le3r | ge2r] := ltnP 2 'r('F(H)). + have [D uF_D] := uniq_mmaxP (Fitting_Uniqueness maxH le3r). + by rewrite (eq_uniq_mmax uF_D maxM) // (eq_uniq_mmax uF_D maxH) ?Fitting_sub. +have nHp'R: R \subset 'N('O_p^'(H)) by rewrite (subset_trans sRH) ?gFnorm. +have nsRHp'H: R <*> 'O_p^'(H) <| H. + rewrite sub_der1_normal //= ?join_subG ?sRH ?pcore_sub //. + rewrite norm_joinEl // (subset_trans _ sFH_RHp') //. + by rewrite rank2_der1_sub_Fitting ?mFT_odd // mFT_sol ?mmax_proper. +have sylR_RHp': p.-Sylow(R <*> 'O_p^'(H)) R. + by apply: (pHall_subl _ _ sylRH); rewrite ?joing_subl // normal_sub. +rewrite (mmax_max maxH) // -(Frattini_arg nsRHp'H sylR_RHp') /=. +by rewrite mulG_subG join_subG sRM sHp'M /= setIC subIset ?sNRM. +Qed. + +(* This is B & G, Theorem 9.1(a). *) +Theorem noncyclic_cent1_sub_Uniqueness p M B : + M \in 'M -> B \in 'E_p(M) -> ~~ cyclic B -> + \bigcup_(b in B^#) 'C[b] \subset M -> + B \in 'U. +Proof. +move=> maxM EpB ncycB sCB_M. +apply: (noncyclic_normed_sub_Uniqueness maxM EpB) => //. +apply/bigcupsP=> K; rewrite inE -andbA => /and3P[_ p'K nKB]. +case/pElemP: EpB => _ /and3P[pB cBB _]. +rewrite -(coprime_abelian_gen_cent1 cBB ncycB nKB); last first. + by rewrite coprime_sym (pnat_coprime pB). +rewrite gen_subG (subset_trans _ sCB_M) //. +by apply/bigcupsP=> b Bb; rewrite (bigcup_max b) // subsetIr. +Qed. + +(* This is B & G, Corollary 9.2. *) +Corollary cent_uniq_Uniqueness K L : + L \in 'U -> K \subset 'C(L) -> 'r(K) >= 2 -> K \in 'U. +Proof. +move=> uL; have ntL := uniq_mmax_neq1 uL. +case/uniq_mmaxP: uL => H uL_H cLK; have [maxH sLH] := mem_uniq_mmax uL_H. +case/rank_geP=> B /nElemP[p /pnElemP[sBK abelB /eqP dimB2]]. +have scBH: \bigcup_(b in B^#) 'C[b] \subset H. + apply/bigcupsP=> b /setIdP[]; rewrite inE -cycle_eq1 => ntb Bb. + apply: (sub_uniq_mmax uL_H); last by rewrite /= -cent_cycle mFT_cent_proper. + by rewrite sub_cent1 (subsetP cLK) ?(subsetP sBK). +have EpB: B \in 'E_p(H). + apply/pElemP; split=> //; rewrite -(setD1K (group1 B)) subUset sub1G /=. + apply/subsetP=> b Bb; apply: (subsetP scBH). + by apply/bigcupP; exists b => //; apply/cent1P. +have prK: K \proper G by rewrite (sub_proper_trans cLK) ?mFT_cent_proper. +apply: uniq_mmaxS prK (noncyclic_cent1_sub_Uniqueness _ EpB _ _) => //. +by rewrite (abelem_cyclic abelB) (eqP dimB2). +Qed. + +(* This is B & G, Corollary 9.3. *) +Corollary any_cent_rank3_Uniquness p A B : + abelian A -> p.-group A -> 'r(A) >= 3 -> A \in 'U -> + p.-group B -> ~~ cyclic B -> 'r_p('C(B)) >= 3 -> + B \in 'U. +Proof. +move=> cAA pA rA3 uA pB ncycB /p_rank_geP[C /= Ep3C]. +have [cBC abelC dimC3] := pnElemP Ep3C; have [pC cCC _] := and3P abelC. +have [P /= sylP sCP] := Sylow_superset (subsetT _) pC. +wlog sAP: A pA cAA rA3 uA / A \subset P. + move=> IHA; have [x _] := Sylow_Jsub sylP (subsetT _) pA. + by apply: IHA; rewrite ?pgroupJ ?abelianJ ?rankJ ?uniq_mmaxJ. +have ncycC: ~~ cyclic C by rewrite (abelem_cyclic abelC) dimC3. +have ncycP: ~~ cyclic P := contra (cyclicS sCP) ncycC. +have [D] := ex_odd_normal_p2Elem (pHall_pgroup sylP) (mFT_odd _) ncycP. +case/andP=> sDP nDP /pnElemP[_ abelD dimD2]. +have CADge2: 'r('C_A(D)) >= 2. + move: rA3; rewrite (rank_pgroup pA) => /p_rank_geP[E]. + case/pnElemP=> sEA abelE dimE3; apply: leq_trans (rankS (setSI _ sEA)). + rewrite (rank_abelem (abelemS (subsetIl _ _) abelE)) -(leq_add2r 1) addn1. + rewrite -dimE3 -leq_subLR -logn_div ?cardSg ?divgS ?subsetIl //. + rewrite logn_quotient_cent_abelem ?dimD2 //. + exact: subset_trans (subset_trans sAP nDP). +have CCDge2: 'r('C_C(D)) >= 2. + rewrite (rank_abelem (abelemS (subsetIl _ _) abelC)) -(leq_add2r 1) addn1. + rewrite -dimC3 -leq_subLR -logn_div ?cardSg ?divgS ?subsetIl //. + by rewrite logn_quotient_cent_abelem ?dimD2 //; apply: subset_trans nDP. +rewrite centsC in cBC; apply: cent_uniq_Uniqueness cBC _; last first. + by rewrite ltnNge (rank_pgroup pB) -odd_pgroup_rank1_cyclic ?mFT_odd. +have cCDC: C \subset 'C('C_C(D)) + by rewrite (sub_abelian_cent (abelem_abelian abelC)) ?subsetIl. +apply: cent_uniq_Uniqueness cCDC _; last by rewrite (rank_abelem abelC) dimC3. +apply: cent_uniq_Uniqueness (subsetIr _ _) CCDge2. +have cDCA: D \subset 'C('C_A(D)) by rewrite centsC subsetIr. +apply: cent_uniq_Uniqueness cDCA _; last by rewrite (rank_abelem abelD) dimD2. +by apply: cent_uniq_Uniqueness uA _ CADge2; rewrite subIset // -abelianE cAA. +Qed. + +(* This is B & G, Lemma 9.4. *) +Lemma any_rank3_Fitting_Uniqueness p M P : + M \in 'M -> 'r_p('F(M)) >= 3 -> p.-group P -> 'r(P) >= 3 -> P \in 'U. +Proof. +move=> maxM FMge3 pP; rewrite (rank_pgroup pP) => /p_rank_geP[B]. +case/pnElemP=> sBP abelB dimB3; have [pB cBB _] := and3P abelB. +have CBge3: 'r_p('C(B)) >= 3 by rewrite -dimB3 -(p_rank_abelem abelB) p_rankS. +have ncycB: ~~ cyclic B by rewrite (abelem_cyclic abelB) dimB3. +apply: {P pP}uniq_mmaxS sBP (mFT_pgroup_proper pP) _. +case/orP: (orbN (p.-group 'F(M))) => [pFM | pFM']. + have [P sylP sFP] := Sylow_superset (Fitting_sub _) pFM. + have pP := pHall_pgroup sylP. + have [|A SCN_A]:= rank3_SCN3 pP (mFT_odd _). + by rewrite (leq_trans FMge3) ?p_rankS. + have [_ _ uA] := SCN_Fitting_Uniqueness maxM pFM sylP FMge3 SCN_A. + case/setIdP: SCN_A => SCN_A dimA3; case: (setIdP SCN_A); case/andP=> sAP _ _. + have cAA := SCN_abelian SCN_A; have pA := pgroupS sAP pP. + exact: (any_cent_rank3_Uniquness cAA pA). +have [A0 EpA0 A0ge3] := p_rank_pmaxElem_exists FMge3. +have uA := non_pcore_Fitting_Uniqueness maxM pFM' EpA0 A0ge3. +case/pmaxElemP: EpA0; case/setIdP=> _ abelA0 _. +have [pA0 cA0A0 _] := and3P abelA0; rewrite -rank_pgroup // in A0ge3. +rewrite (any_cent_rank3_Uniquness _ pA0) // (cent_uniq_Uniqueness uA) 1?ltnW //. +by rewrite centsC subsetIr. +Qed. + +(* This is B & G, Lemma 9.5. *) +Lemma SCN_3_Uniqueness p A : A \in 'SCN_3[p] -> A \in 'U. +Proof. +move=> SCN3_A; apply/idPn=> uA'. +have [P] := bigcupP SCN3_A; rewrite inE => sylP /setIdP[SCN_A Age3]. +have [nsAP _] := setIdP SCN_A; have [sAP nAP] := andP nsAP. +have cAA := SCN_abelian SCN_A. +have pP := pHall_pgroup sylP; have pA := pgroupS sAP pP. +have ntA: A :!=: 1 by rewrite -rank_gt0 -(subnKC Age3). +have [p_pr _ [e oA]] := pgroup_pdiv pA ntA. +have{e oA} def_piA: \pi(A) =i (p : nat_pred). + by rewrite /= oA pi_of_exp //; exact: pi_of_prime. +have FmCAp_le2 M: M \in 'M('C(A)) -> 'r_p('F(M)) <= 2. + case/setIdP=> maxM cCAM; rewrite leqNgt; apply: contra uA' => Fge3. + exact: (any_rank3_Fitting_Uniqueness maxM Fge3). +have sNP_mCA M: M \in 'M('C(A)) -> 'N(P) \subset M. + move=> mCA_M; have Fple2 := FmCAp_le2 M mCA_M. + case/setIdP: mCA_M => maxM sCAM; set F := 'F(M) in Fple2. + have sNR_M R: A \subset R -> R \subset P :&: M -> 'N(R) \subset M. + move=> sAR /subsetIP[sRP sRM]. + pose q := if 'r(F) <= 2 then max_pdiv #|M| else s2val (rank_witness 'F(M)). + have nMqR: R \subset 'N('O_q(M)) := subset_trans sRM (gFnorm _ _). + have{nMqR} [Q maxQ sMqQ] := max_normed_exists (pcore_pgroup _ _) nMqR. + have [p'q sNQ_M]: q != p /\ 'N(Q) \subset M. + case/mem_max_normed: maxQ sMqQ; rewrite {}/q. + case: leqP => [Fle2 | ]; last first. + case: rank_witness => q /= q_pr -> Fge3 qQ _ sMqQ; split=> //. + by case: eqP Fge3 => // ->; rewrite ltnNge Fple2. + have Mqge3: 'r('O_q(M)) >= 3. + rewrite (rank_pgroup (pcore_pgroup _ _)) /= -p_core_Fitting. + by rewrite (p_rank_Sylow (nilpotent_pcore_Hall _ (Fitting_nil _))). + have uMq: 'O_q(M)%G \in 'U. + exact: (any_rank3_Fitting_Uniqueness _ Fge3 (pcore_pgroup _ _)). + have uMqM := def_uniq_mmax uMq maxM (pcore_sub _ _). + apply: sub_uniq_mmax (subset_trans sMqQ (normG _)) _ => //. + apply: mFT_norm_proper (mFT_pgroup_proper qQ). + by rewrite -rank_gt0 2?ltnW ?(leq_trans Mqge3) ?rankS. + set q := max_pdiv _ => qQ _ sMqQ. + have sylMq: q.-Sylow(M) 'O_q(M). + by rewrite [pHall _ _ _]rank2_max_pcore_Sylow ?mFT_odd ?mmax_sol. + have defNMq: 'N('O_q(M)) = M. + rewrite (mmax_normal maxM (pcore_normal _ _)) // -rank_gt0. + rewrite (rank_pgroup (pcore_pgroup _ _)) (p_rank_Sylow sylMq). + by rewrite p_rank_gt0 pi_max_pdiv cardG_gt1 mmax_neq1. + have sylMqG: q.-Sylow(G) 'O_q(M). + by rewrite (mmax_sigma_Sylow maxM) ?defNMq. + rewrite (sub_pHall sylMqG qQ) ?subsetT // defNMq; split=> //. + have: 'r_p(G) > 2. + by rewrite (leq_trans Age3) // (rank_pgroup pA) p_rankS ?subsetT. + apply: contraTneq => <-; rewrite -(p_rank_Sylow sylMqG). + rewrite -leqNgt -(rank_pgroup (pcore_pgroup _ _)) /=. + by rewrite -p_core_Fitting (leq_trans _ Fle2) // rankS ?pcore_sub. + have trCRq': [transitive 'O_p^'('C(R)), on |/|*(R; q) | 'JG]. + have cstrA: normed_constrained A. + by apply: SCN_normed_constrained sylP _; rewrite inE SCN_A ltnW. + have pR: p.-group R := pgroupS sRP pP. + have snAR: A <|<| R by rewrite (nilpotent_subnormal (pgroup_nil pR)). + have A'q: q \notin \pi(A) by rewrite def_piA. + rewrite -(eq_pgroup _ def_piA) in pR. + have [|?] := normed_trans_superset cstrA A'q snAR pR. + by rewrite (eq_pcore _ (eq_negn def_piA)) Thompson_transitivity. + by rewrite (eq_pcore _ (eq_negn def_piA)). + apply/subsetP=> x nRx; have maxQx: (Q :^ x)%G \in |/|*(R; q). + by rewrite (actsP (norm_acts_max_norm _ _)). + have [y cRy [defQx]] := atransP2 trCRq' maxQ maxQx. + rewrite -(mulgKV y x) groupMr. + by rewrite (subsetP sNQ_M) // inE conjsgM defQx conjsgK. + apply: subsetP cRy; apply: (subset_trans (pcore_sub _ _)). + exact: subset_trans (centS _) sCAM. + have sNA_M: 'N(A) \subset M. + by rewrite sNR_M // subsetI sAP (subset_trans cAA). + by rewrite sNR_M // subsetI subxx (subset_trans nAP). +pose P0 := [~: P, 'N(P)]. +have ntP0: P0 != 1. + apply/eqP=> /commG1P; rewrite centsC -(setIidPr (subsetT 'N(P))) /=. + case/(Burnside_normal_complement sylP)/sdprodP=> _ /= defG nGp'P _. + have prGp': 'O_p^'(G) \proper G. + rewrite properT; apply: contra ntA; move/eqP=> defG'. + rewrite -(setIidPl (subsetT A)) /= -defG'. + by rewrite coprime_TIg // (pnat_coprime pA (pcore_pgroup _ _)). + have ntGp': 'O_p^'(G) != 1. + apply: contraTneq (mFT_pgroup_proper pP); rewrite -{2}defG => ->. + by rewrite mul1g proper_irrefl. + by have:= mFT_norm_proper ntGp' prGp'; rewrite properE gFnorm andbF. +have sP0P: P0 \subset P by rewrite commg_subl. +have pP0: p.-group P0 := pgroupS sP0P pP. +have uNP0_mCA M: M \in 'M('C(A)) -> 'M('N(P0)) = [set M]. + move=> mCA_M; have [maxM sCAM] := setIdP mCA_M. + have sAM := subset_trans cAA sCAM. + pose F := 'F(M); pose D := 'O_p^'(F). + have cDP0: P0 \subset 'C(D). + have sA1A := Ohm_sub 1 A. + have nDA1: 'Ohm_1(A) \subset 'N(D). + apply: subset_trans sA1A (subset_trans sAM (char_norm _)). + exact: char_trans (pcore_char _ _) (Fitting_char _). + have abelA1: p.-abelem 'Ohm_1(A) by rewrite Ohm1_abelem. + have dimA1ge3: logn p #|'Ohm_1(A)| >= 3. + by rewrite -(rank_abelem abelA1) rank_Ohm1. + have coDA1: coprime #|D| #|'Ohm_1(A)|. + rewrite coprime_sym (coprimeSg sA1A) //. + exact: pnat_coprime pA (pcore_pgroup _ _). + rewrite centsC -[D](coprime_abelian_gen_cent (abelianS sA1A cAA) nDA1) //=. + rewrite gen_subG /= -/D; apply/bigcupsP=> B /and3P[cycqB sBA1 nBA1]. + have abelB := abelemS sBA1 abelA1; have sBA := subset_trans sBA1 sA1A. + have{cycqB} ncycB: ~~ cyclic B. + move: cycqB; rewrite (abelem_cyclic (quotient_abelem _ abelA1)). + rewrite card_quotient // -divgS // logn_div ?cardSg // leq_subLR addn1. + by move/(leq_trans dimA1ge3); rewrite ltnS ltnNge -(abelem_cyclic abelB). + have [x Bx sCxM']: exists2 x, x \in B^# & ~~ ('C[x] \subset M). + suff: ~~ (\bigcup_(x in B^#) 'C[x] \subset M). + case/subsetPn=> y /bigcupP[x Bx cxy] My'. + by exists x; last by apply/subsetPn; exists y. + have EpB: B \in 'E_p(M) by rewrite inE (subset_trans sBA sAM). + apply: contra uA' => sCB_M. + apply: uniq_mmaxS sBA (mFT_pgroup_proper pA) _. + exact: noncyclic_cent1_sub_Uniqueness maxM EpB ncycB sCB_M. + case/setD1P: Bx; rewrite -cycle_eq1 => ntx Bx. + have{ntx} [L /setIdP[maxL /=]] := mmax_exists (mFT_cent_proper ntx). + rewrite cent_cycle => sCxL. + have{sCxM'} neLM : L != M by case: eqP sCxL sCxM' => // -> ->. + have sNP_LM: 'N(P) \subset L :&: M. + rewrite subsetI !sNP_mCA // inE maxL (subset_trans _ sCxL) // -cent_set1. + by rewrite centS // sub1set (subsetP sBA). + have sP0_LM': P0 \subset (L :&: M)^`(1). + exact: subset_trans (commSg _ (normG _)) (dergS 1 sNP_LM). + have DLle2: 'r(D :&: L) <= 2. + apply: contraR neLM; rewrite -ltnNge -in_set1 => /rank_geP[E /nElemP[q]]. + rewrite /= -/D => /pnElemP[/subsetIP[sED sEL] abelE dimE3]. + have sEF: E \subset F := subset_trans sED (pcore_sub _ _). + have Fge3: 'r_q(F) >= 3 by rewrite -dimE3 -p_rank_abelem // p_rankS. + have qE := abelem_pgroup abelE. + have uE: E \in 'U. + apply: any_rank3_Fitting_Uniqueness Fge3 _ _ => //. + by rewrite (rank_pgroup qE) p_rank_abelem ?dimE3. + rewrite -(def_uniq_mmax uE maxM (subset_trans sEF (Fitting_sub _))). + by rewrite inE maxL. + have cDL_P0: P0 \subset 'C(D :&: L). + have nsDM: D <| M:= char_normal_trans (pcore_char _ _) (Fitting_normal M). + have{nsDM} [sDM nDM] := andP nsDM. + have sDL: D :&: L \subset L :&: M by rewrite setIC setIS. + have nsDL: D :&: L <| L :&: M by rewrite /normal sDL setIC normsIG. + have [s ch_s last_s_DL] := chief_series_exists nsDL. + have solLM := solvableS (subsetIl L M) (mmax_sol maxL). + have solDL := solvableS sDL solLM. + apply: (stable_series_cent (congr_group last_s_DL)) => //; first 1 last. + rewrite coprime_sym (coprimegS (subsetIl _ _)) //. + exact: pnat_coprime (pcore_pgroup _ _). + have{last_s_DL}: last 1%G s \subset D :&: L by rewrite last_s_DL. + rewrite /= -/P0; elim/last_ind: s ch_s => //= s U IHs. + rewrite !rcons_path last_rcons /=; set V := last _ s. + case/andP=> ch_s chUV sUDL; have [maxU _ nU_LM] := and3P chUV. + have{maxU} /andP[/andP[sVU _] nV_LM] := maxgroupp maxU. + have nVU := subset_trans sUDL (subset_trans sDL nV_LM). + rewrite IHs ?(subset_trans sVU) // /stable_factor /normal sVU nVU !andbT. + have nVP0 := subset_trans (subset_trans sP0_LM' (der_sub _ _)) nV_LM. + rewrite commGC -sub_astabQR // (subset_trans sP0_LM') //. + have /is_abelemP[q _ /andP[qUV _]]: is_abelem (U / V). + exact: sol_chief_abelem solLM chUV. + apply: rank2_der1_cent_chief qUV sUDL; rewrite ?mFT_odd //. + exact: leq_trans (p_rank_le_rank _ _) DLle2. + rewrite centsC (subset_trans cDL_P0) ?centS ?setIS //. + by rewrite (subset_trans _ sCxL) // -cent_set1 centS ?sub1set. + case: (ltnP 2 'r(F)) => [| Fle2]. + have [q q_pr -> /= Fq3] := rank_witness [group of F]. + have Mq3: 'r('O_q(M)) >= 3. + rewrite (rank_pgroup (pcore_pgroup _ _)) /= -p_core_Fitting. + by rewrite (p_rank_Sylow (nilpotent_pcore_Hall _ (Fitting_nil _))). + have uMq: 'O_q(M)%G \in 'U. + exact: any_rank3_Fitting_Uniqueness Fq3 (pcore_pgroup _ _) Mq3. + apply: def_uniq_mmaxS (def_uniq_mmax uMq maxM (pcore_sub q _)); last first. + exact: mFT_norm_proper ntP0 (mFT_pgroup_proper pP0). + rewrite cents_norm // centsC (subset_trans cDP0) ?centS //=. + rewrite -p_core_Fitting sub_pcore // => q1; move/eqnP=> ->{q1}. + by apply/eqnP=> def_q; rewrite ltnNge def_q FmCAp_le2 in Fq3. + rewrite (mmax_normal maxM) ?mmax_sup_id //. + have sNP_M := sNP_mCA M mCA_M; have sPM := subset_trans (normG P) sNP_M. + rewrite /normal comm_subG //= -/P0. + have nFP: P \subset 'N(F) by rewrite (subset_trans _ (gFnorm _ _)). + have <-: F <*> P * 'N_M(P) = M. + apply: Frattini_arg (pHall_subl (joing_subr _ _) (subsetT _) sylP). + rewrite -(quotientGK (Fitting_normal M)) /= norm_joinEr //= -/F. + rewrite -quotientK // cosetpre_normal -sub_abelian_normal ?quotientS //. + by rewrite sub_der1_abelian ?rank2_der1_sub_Fitting ?mFT_odd ?mmax_sol. + case/dprodP: (nilpotent_pcoreC p (Fitting_nil M)) => _ /= defF cDFp _. + rewrite norm_joinEr //= -{}defF -(centC cDFp) -/D p_core_Fitting /= -/F. + rewrite -!mulgA mul_subG //; first by rewrite cents_norm // centsC. + rewrite mulgA [_ * P]mulSGid ?pcore_sub_Hall 1?(pHall_subl _ (subsetT _)) //. + by rewrite mulSGid ?subsetI ?sPM ?normG // subIset // orbC normsRr. +have [M mCA_M] := mmax_exists (mFT_cent_proper ntA). +have [maxM sCAM] := setIdP mCA_M; have sAM := subset_trans cAA sCAM. +have abelA1: p.-abelem 'Ohm_1(A) by rewrite Ohm1_abelem. +have sA1A := Ohm_sub 1 A. +have EpA1: 'Ohm_1(A)%G \in 'E_p(M) by rewrite inE (subset_trans sA1A). +have ncycA1: ~~ cyclic 'Ohm_1(A). + rewrite (abelem_cyclic abelA1) -(rank_abelem abelA1) rank_Ohm1. + by rewrite -(subnKC Age3). +have [x A1x sCxM']: exists2 x, x \in 'Ohm_1(A)^# & ~~ ('C[x] \subset M). + suff: ~~ (\bigcup_(x in 'Ohm_1(A)^#) 'C[x] \subset M). + case/subsetPn=> y /bigcupP[x A1 cxy] My'. + by exists x; last by apply/subsetPn; exists y. + apply: contra uA' => sCA1_M. + apply: uniq_mmaxS sA1A (mFT_pgroup_proper pA) _. + exact: noncyclic_cent1_sub_Uniqueness maxM EpA1 ncycA1 sCA1_M. +case/setD1P: A1x; rewrite -cycle_eq1 => ntx A1x. +have: 'C[x] \proper G by rewrite -cent_cycle mFT_cent_proper. +case/mmax_exists=> L /setIdP[maxL sCxL]. +have mCA_L: L \in 'M('C(A)). + rewrite inE maxL (subset_trans _ sCxL) //= -cent_set1 centS // sub1set. + by rewrite (subsetP sA1A). +case/negP: sCxM'; have/uNP0_mCA := mCA_L. +by rewrite (uNP0_mCA M) // => /set1_inj->. +Qed. + +(* This is B & G, Theorem 9.6, first assertion; note that B & G omit the *) +(* (necessary!) condition K \proper G. *) +Theorem rank3_Uniqueness K : K \proper G -> 'r(K) >= 3 -> K \in 'U. +Proof. +move=> prK /rank_geP[B /nElemP[p /pnElemP[sBK abelB dimB3]]]. +have [pB cBB _] := and3P abelB. +suffices: B \in 'U by apply: uniq_mmaxS. +have [P sylP sBP] := Sylow_superset (subsetT _) pB. +have pP := pHall_pgroup sylP. +have [|A SCN3_A] := rank3_SCN3 pP (mFT_odd _). + by rewrite -dimB3 -(rank_abelem abelB) (rank_pgroup pB) p_rankS. +have [SCN_A Age3] := setIdP SCN3_A. +have: A \in 'SCN_3[p] by apply/bigcupP; exists P; rewrite // inE. +move/SCN_3_Uniqueness=> uA; have cAA := SCN_abelian SCN_A. +case/setIdP: SCN_A; case/andP=> sAP _ _; have pA := pgroupS sAP pP. +apply: any_cent_rank3_Uniquness uA pB _ _ => //. + by rewrite (abelem_cyclic abelB) dimB3. +by rewrite -dimB3 -p_rank_abelem ?p_rankS. +Qed. + +(* This is B & G, Theorem 9.6, second assertion *) +Theorem cent_rank3_Uniqueness K : 'r(K) >= 2 -> 'r('C(K)) >= 3 -> K \in 'U. +Proof. +move=> Kge2 CKge3; have cCK_K: K \subset 'C('C(K)) by rewrite centsC. +apply: cent_uniq_Uniqueness cCK_K _ => //. +apply: rank3_Uniqueness (mFT_cent_proper _) CKge3. +by rewrite -rank_gt0 ltnW. +Qed. + +(* This is B & G, Theorem 9.6, final observation *) +Theorem nonmaxElem2_Uniqueness p A : A \in 'E_p^2(G) :\: 'E*_p(G) -> A \in 'U. +Proof. +case/setDP=> EpA nmaxA; have [_ abelA dimA2]:= pnElemP EpA. +case/setIdP: EpA => EpA _; have [pA _] := andP abelA. +apply: cent_rank3_Uniqueness; first by rewrite -dimA2 -(rank_abelem abelA). +have [E maxE sAE] := pmaxElem_exists EpA. +have [/pElemP[_ abelE _]] := pmaxElemP maxE; have [pE cEE _] := and3P abelE. +have: 'r(E) <= 'r('C(A)) by rewrite rankS // (subset_trans cEE) ?centS. +apply: leq_trans; rewrite (rank_abelem abelE) -dimA2 properG_ltn_log //. +by rewrite properEneq; case: eqP maxE nmaxA => // => /group_inj-> ->. +Qed. + +End Nine. + diff --git a/mathcomp/odd_order/PFsection1.v b/mathcomp/odd_order/PFsection1.v new file mode 100644 index 0000000..dc5ce95 --- /dev/null +++ b/mathcomp/odd_order/PFsection1.v @@ -0,0 +1,809 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg finset fingroup morphism. +Require Import perm automorphism quotient action zmodp center commutator. +Require Import poly cyclic pgroup nilpotent matrix mxalgebra mxrepresentation. +Require Import vector falgebra fieldext ssrnum algC rat algnum galois. +Require Import classfun character inertia integral_char vcharacter. +Require ssrint. + +(******************************************************************************) +(* This file covers Peterfalvi, Section 1: Preliminary results. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory Num.Theory. +Local Open Scope ring_scope. + +Local Notation algCF := [fieldType of algC]. + +Section Main. + +Variable gT : finGroupType. + +(* This is Peterfalvi (1.1). *) +Lemma odd_eq_conj_irr1 (G : {group gT}) t : + odd #|G| -> (('chi[G]_t)^*%CF == 'chi_t) = ('chi_t == 1). +Proof. +move=> OG; apply/eqP/eqP=> [Ht | ->]; last exact: cfConjC_cfun1. +pose a := (@Zp1 1). +have Aito: + is_action <[a]> (fun (t : Iirr G) v => if v == a then conjC_Iirr t else t). + split=> [[[|[]]] //= _ t1 t2 Hj |j [[|[]]] // HH1 [[|[]]] // HH2 ] //=. + by apply: (inv_inj (@conjC_IirrK _ _)). + by rewrite conjC_IirrK. +pose ito := Action Aito. +have Acto: + is_action <[a]> (fun (c : {set gT}) v => if v == a then c^-1%g else c). + split=> [[[|[]]] //= _ t1 t2 Hj |j [[|[]]] // HH1 [[|[]]] // HH2 ] //=. + by rewrite -[t1]invgK Hj invgK. + by rewrite invgK. +pose cto := Action Acto. +have F1: [acts <[a]>, on (classes G) | cto]. + apply/subsetP=> j Hj. + rewrite !inE Hj; apply/subsetP=> u. + case/imsetP=> g GiG ->. + by rewrite inE /=; case: (_ == _) => //; + rewrite -?classVg mem_classes // ?groupV. +have F2 u x y: x \in G -> y \in cto (x ^: G) a -> 'chi_u x = 'chi_(ito u a) y. + rewrite mem_invg -{2}[y]invgK => Gx {y}/imsetP[y Gy ->]. + by rewrite -conjVg cfunJ {y Gy}//= conjC_IirrE cfunE -irr_inv invgK. +have F3: forall c, c \in classes G -> c^-1%g = c -> c = 1%g. + move=> c; case/imsetP => g GiG ->; rewrite -classVg => Hg. + move: (class_refl G g^-1); rewrite Hg; case/imsetP=> x XiG Hx. + have F4: (x ^+ 2)%g \in 'C_G[g]. + apply/subcent1P; split; rewrite ?groupM //. + apply: (mulgI (x * x * g)^-1)%g. + rewrite mulVg !invMg Hx conjgE !mulgA mulgK. + rewrite -[(_ * g * x)%g]mulgA -[(_ * (g * _))%g]mulgA -conjgE. + by rewrite -Hx mulgK mulVg. + have F5 : x \in 'C_G[g]. + suff->: (x = (x ^+ 2) ^+ (#|G| %/2).+1)%g by apply: groupX. + rewrite -expgM -[(_%/_).+1]addn1 mulnDr muln1 -{3}addn1 addnA. + move: (modn2 #|G|); rewrite {1}OG /= => HH; rewrite -{3}HH. + rewrite [(2 * _)%N]mulnC -divn_eq expgD expg1. + by move: (order_dvdG XiG); rewrite order_dvdn; move/eqP->; rewrite mul1g. + move: Hx; rewrite conjgE; case/subcent1P: F5=> _ ->. + rewrite mulgA mulVg mul1g => HH. + have F6: (g ^+ 2 == 1)%g by rewrite expgS -{1}HH expg1 mulVg. + suff: #[g] == 1%N by rewrite order_eq1; move/eqP->; apply: class1G. + move: F6 (order_gt0 g) (order_dvdG GiG); rewrite -order_dvdn. + move/(dvdn_leq (isT : (0 < 2)%N)); case: #[_]=> // [[|[]]] //. + by rewrite dvdn2 OG. +apply/eqP; case: (boolP (t == 0))=> // Hd. + by move/eqP: Hd->; rewrite irr0. +have:= card_afix_irr_classes (cycle_id a) F1 F2. +have->: #|'Fix_(classes G | cto)[a]| = 1%N. + apply: (@eq_card1 _ 1%g)=> c; apply/idP/idP; rewrite !inE. + case/andP=> GiG HH; apply/eqP; apply: F3=> //; apply/eqP. + by move/subsetP: HH; move/(_ a); rewrite !inE eqxx; apply. + move/eqP->; rewrite classes1. + apply/subsetP=> b; rewrite !inE; move/eqP=> -> /=. + by rewrite invg1. +rewrite (cardD1 (0 : Iirr _)). +have->: 0 \in 'Fix_ito[a]. + apply/afixP=> b; rewrite !inE; move/eqP->; rewrite /=. + apply: irr_inj; apply/cfunP=> g. + by rewrite conjC_IirrE cfConjCE irr0 cfun1E conjC_nat. +rewrite (cardD1 t) //. +suff->: t \in [predD1 'Fix_ito[a] & 0] by []. +rewrite inE /= Hd. +apply/afixP=> b; rewrite !inE; move/eqP->; rewrite /=. +apply: irr_inj; apply/cfunP=> g. +by rewrite conjC_IirrE Ht. +Qed. + +Variables G H : {group gT}. + +(* This is Peterfalvi (1.2). *) +Lemma not_in_ker_char0 t g : g \in G -> + H <| G -> ~~ (H \subset cfker 'chi[G]_t) -> 'C_H[g] = 1%g -> 'chi_t g = 0. +Proof. +move=> GiG HnG nHsC CH1. +have: (#|'C_G[g]| <= #|'C_(G/H)[coset H g]|)%N. + suff->: #|'C_G[g]| = #|'C_G[g] / H|%G. + by apply: (subset_leq_card (quotient_subcent1 H G g)). + apply: card_isog. + apply: isog_trans (second_isog _); last first. + apply: subset_trans (normal_norm HnG). + by apply: subcent1_sub. + suff->: H :&: 'C_G[g] = 1%g by exact: quotient1_isog. + rewrite -CH1. + apply/setP=> h; rewrite inE. + apply/andP/subcent1P; case=> H1 H2; split=> //. + by move/subcent1P: H2; case. + apply/subcent1P; split=> //. + by apply: (subsetP (normal_sub HnG)). +have F1: coset H g \in (G / H)%g by exact: mem_quotient. +rewrite -leC_nat. +have:= second_orthogonality_relation g GiG. +rewrite mulrb class_refl => <-. +have:= second_orthogonality_relation (coset H g) F1. +rewrite mulrb class_refl => <-; rewrite -!(eq_bigr _ (fun _ _ => normCK _)). +rewrite sum_norm_irr_quo // (bigID (fun i => H \subset cfker 'chi_i)) //=. +set S := \sum_(i | ~~ _) _; set S' := \sum_(i | _) _ => HH. +have /eqP F2: S == 0. + rewrite eqr_le -(ler_add2l S') addr0 HH /=. + by apply: sumr_ge0 => j _; rewrite mulr_ge0 ?normr_ge0. +apply/eqP; have: `|'chi_t g| ^+ 2 == 0. + apply/eqP; apply: (psumr_eq0P _ F2) nHsC => j _. + by rewrite mulr_ge0 ?normr_ge0. +by rewrite mulf_eq0 orbb normr_eq0. +Qed. + +(* This is Peterfalvi (1.3)(a). *) +Lemma equiv_restrict_compl A m (Phi : m.-tuple 'CF(H)) (mu : 'CF(G)) d : + H \subset G -> A <| H -> basis_of 'CF(H, A) Phi -> + ({in A, mu =1 \sum_i d i *: 'chi_i} <-> + (forall j : 'I_m, + \sum_i '[Phi`_j, 'chi_i] * (d i)^* = '['Ind[G] Phi`_j, mu])). +Proof. +move=> sHG nsAH BPhi; have [sAH nAH] := andP nsAH. +have APhi (i : 'I_m) : Phi`_i \in 'CF(H, A). + by apply: (basis_mem BPhi _); apply: mem_nth; rewrite size_tuple. +pose D := 'Res[H] mu - \sum_i d i *: 'chi_i. +transitivity (D \in 'CF(H, H :\: A)). + split=> [A'D | /cfun_onP A'D x Ax]. + apply/cfun_onP=> x; rewrite inE negb_and negbK. + case/orP=> [Ax | /cfun0-> //]; rewrite !cfunE -A'D //. + by rewrite cfResE ?subrr ?(subsetP sAH). + have:= A'D x; rewrite !cfunE !inE Ax => /(_ isT)/(canRL (subrK _)). + by rewrite add0r cfResE // ?(subsetP sAH). +have F0 (j : 'I_m) : + (\sum_i '[Phi`_j, 'chi_i] * (d i)^* == '['Ind Phi`_j, mu]) + = ('[Phi`_j, D] == 0). + rewrite raddfB raddf_sum /= Frobenius_reciprocity subr_eq0 eq_sym. + by congr (_ == _); apply: eq_bigr=> i _; rewrite cfdotZr mulrC. +split=> [HH j | HH]. + by apply/eqP; rewrite F0; apply/eqP; apply: cfdot_complement. +have{F0} F1 (j : 'I_m) : '[Phi`_j, D]_H = 0. + by have/eqP := HH j; rewrite F0 => /eqP. +have: (D \in 'CF(H))%VS by rewrite memvf. +rewrite -(cfun_complement nsAH) => /memv_addP[f Cf [g Cg defD]]. +have: '[f, f + g] = 0. + rewrite -defD (coord_basis BPhi Cf) cfdot_suml. + by rewrite big1 // => i _; rewrite cfdotZl F1 mulr0. +rewrite raddfD /= {1}(cfdot_complement Cf Cg) addr0 => /eqP. +by rewrite cfnorm_eq0 defD => /eqP->; rewrite add0r. +Qed. + +(* This is Peterfalvi (1.3)(b). *) +Lemma equiv_restrict_compl_ortho A m (Phi : m.-tuple 'CF(H)) mu_ : + H \subset G -> A <| H -> basis_of 'CF(H, A) Phi -> + (forall i j, '[mu_ i, mu_ j] = (i == j)%:R) -> + (forall j : 'I_m, 'Ind[G] Phi`_j = \sum_i '[Phi`_j, 'chi_i] *: mu_ i) -> + [/\ forall i, {in A, mu_ i =1 'chi_i} + & forall mu, (forall i, '[mu, mu_ i] = 0) -> {in A, forall x, mu x = 0}]. +Proof. +move=> HsG nsAH /equiv_restrict_compl Phi_A Mo IP; split=> [/= i | mu Cmu x Ax]. + have->: 'chi[H]_i = \sum_j (j == i)%:R *: 'chi_j. + rewrite (bigD1 i) //= eqxx scale1r big1 ?addr0 // => j /negPf->. + by rewrite scale0r. + apply/Phi_A=> // j; rewrite IP cfdot_suml. + by apply: eq_bigr=> k _; rewrite cfdotZl rmorph_nat Mo. +transitivity ((\sum_j 0 *: 'chi[H]_j) x); last first. + by rewrite sum_cfunE big1 // => j _; rewrite cfunE mul0r. +move: x Ax; apply/Phi_A=> // j. +rewrite -mulr_suml rmorph0 mulr0 IP cfdot_suml big1 // => k _. +by rewrite cfdotZl [d in _ * d]cfdotC Cmu rmorph0 mulr0. +Qed. + +Let vchar_isometry_base3 f f' : + f \in 'Z[irr G, G^#] -> '[f]_G = 2%:R -> + f' \in 'Z[irr G, G^#] -> '[f']_G = 2%:R -> + '[f, f'] = 1 -> + exists es : _ * bool, let: (i, j, k, epsilon) := es in + [/\ f = (-1) ^+ epsilon *: ('chi_j - 'chi_i), + f' = (-1) ^+ epsilon *: ('chi_j - 'chi_k) + & uniq [:: i; j; k]]. +Proof. +move=> Hf H2f Hf1 H2f1. +have [j [i neq_ij ->]] := vchar_norm2 Hf H2f. +have [j' [k neq_kj' ->]] := vchar_norm2 Hf1 H2f1. +rewrite cfdotBl !cfdotBr !cfdot_irr opprB addrAC !addrA. +do 2!move/(canRL (subrK _)); rewrite -(natrD _ 1) -!natrD => /eqP. +rewrite eqr_nat; have [eq_jj' | neq_jj'] := altP (j =P j'). + rewrite (eq_sym j) -eq_jj' {1}eq_jj' (negbTE neq_ij) (negbTE neq_kj'). + rewrite eqSS (can_eq oddb) => /eqP neq_ik; exists (i, j, k, false). + by rewrite !scaler_sign /= !inE neq_ik orbF neq_ij eq_sym eq_jj' neq_kj'. +case: (i =P k) => // eq_ik; exists (j, i, j', true). +rewrite !scaler_sign !opprB /= !inE eq_sym negb_or neq_ij neq_jj'. +by rewrite eq_ik neq_kj'. +Qed. + +Let vchar_isometry_base4 (eps : bool) i j k n m : + let f1 := 'chi_j - 'chi_i in + let f2 := 'chi_k - 'chi_i in + let f3 := 'chi_n - 'chi_m in + j != k -> '[f3, f1]_G = (-1) ^+ eps -> '[f3, f2] = (-1) ^+ eps -> + if eps then n == i else m == i. +Proof. +move=> /= Hjk; wlog ->: eps n m / eps = false. + case: eps; last exact; move/(_ false m n)=> IH nm_ji nm_ki. + by apply: IH; rewrite // -opprB cfdotNl (nm_ji, nm_ki) opprK. +rewrite !cfdotBl !cfdotBr !cfdot_irr !opprB addrAC addrA. +do 2!move/(canRL (subrK _)); rewrite -(natrD _ 1) -!natrD. +move/(can_inj natCK); case: (m == i) => //. +case: eqP => // ->; case: (j == i) => // _. +rewrite subr0 add0r => /(canRL (subrK _)); rewrite -(natrD _ 1). +by move/(can_inj natCK); rewrite (negbTE Hjk). +Qed. + +(* This is Peterfalvi (1.4). *) +Lemma vchar_isometry_base m L (Chi : m.-tuple 'CF(H)) + (tau : {linear 'CF(H) -> 'CF(G)}) : + (1 < m)%N -> {subset Chi <= irr H} -> free Chi -> + (forall chi, chi \in Chi -> chi 1%g = Chi`_0 1%g) -> + (forall i : 'I_m, (Chi`_i - Chi`_0) \in 'CF(H, L)) -> + {in 'Z[Chi, L], isometry tau, to 'Z[irr G, G^#]} -> + exists2 mu : m.-tuple (Iirr G), + uniq mu + & exists epsilon : bool, forall i : 'I_m, + tau (Chi`_i - Chi`_0) = (-1) ^+ epsilon *: ('chi_(mu`_i) - 'chi_(mu`_0)). +Proof. +case: m Chi => [|[|m]] // Chi _ irrChi Chifree Chi1 ChiCF [iso_tau Ztau]. +rewrite -(tnth_nth 0 _ 0); set chi := tnth Chi. +have chiE i: chi i = Chi`_i by rewrite -tnth_nth. +have inChi i: chi i \in Chi by exact: mem_tnth. +have{irrChi} irrChi i: chi i \in irr H by exact: irrChi. +have eq_chi i j: (chi i == chi j) = (i == j). + by rewrite /chi !(tnth_nth 0) nth_uniq ?size_tuple ?free_uniq. +have dot_chi i j: '[chi i, chi j] = (i == j)%:R. + rewrite -eq_chi; have [/irrP[{i}i ->] /irrP[{j}j ->]] := (irrChi i,irrChi j). + by rewrite cfdot_irr inj_eq //; exact: irr_inj. +pose F i j := chi i - chi j. +have DF i j : F i j = F i 0 - F j 0 by rewrite /F opprB addrA subrK. +have ZF i j: F i j \in 'Z[Chi, L]. + by rewrite zchar_split rpredB ?mem_zchar // DF memvB // /F !chiE. +have htau2 i j: i != j -> '[tau (F i j)] = 2%:R. + rewrite iso_tau // cfnormB -cfdotC !dot_chi !eqxx eq_sym => /negbTE->. + by rewrite -!natrD subr0. +have htau1 i j: j != 0 -> j != i -> i != 0 -> '[tau (F i 0), tau (F j 0)] = 1. + rewrite iso_tau // cfdotBl !cfdotBr opprB !dot_chi !(eq_sym j). + by do 3!move/negbTE->; rewrite !subr0 add0r. +have [m0 | nz_m] := boolP (m == 0%N). + rewrite -2!eqSS eq_sym in m0; move: (htau2 1 0 isT). + case/(vchar_norm2 (Ztau _ (ZF 1 0))) => [k1 [k0 neq_k01 eq_mu]]. + pose mu := @Tuple _ _ [:: k0; k1] m0. + exists mu; first by rewrite /= andbT inE. + exists false => i; rewrite scale1r chiE. + have: (i : nat) \in iota 0 2 by rewrite mem_iota (eqP m0) (valP i). + rewrite !inE; case/pred2P=> ->; first by rewrite !subrr linear0. + by rewrite -eq_mu /F !chiE. +have m_gt2: (2 < m.+2)%N by rewrite !ltnS lt0n. +pose i2 := Ordinal m_gt2. +case: (@vchar_isometry_base3 (tau (F 1 0)) (tau (F i2 0))); auto. +case=> [[[k1 k0] k2] e] []; set d := (-1) ^+ e => eq10 eq20. +rewrite /= !inE => /and3P[/norP[nek10 nek12]]; rewrite eq_sym => nek20 _. +have muP i: + {k | (i == 0) ==> (k == k0) & tau (F i 0) == d *: ('chi_k0 - 'chi_k)}. +- apply: sig2W; have [-> | nei0] := altP (i =P 0). + by exists k0; rewrite ?eqxx // /F !subrr !linear0. + have /(vchar_norm2 (Ztau _ (ZF i 0)))[k [k' nekk' eqFkk']] := htau2 i 0 nei0. + have [-> | neq_i1] := eqVneq i 1; first by exists k1; rewrite // -eq10. + have [-> | neq_i2] := eqVneq i i2; first by exists k2; rewrite // -eq20. + have:= @vchar_isometry_base4 (~~ e) k0 k1 k2 k k' nek12. + have ZdK u v w: '[u, v - w]_G = (-1) ^+ (~~ e) * '[u, d *: (w - v)]. + rewrite cfdotZr rmorph_sign mulrA -signr_addb addNb addbb mulN1r. + by rewrite -cfdotNr opprB. + rewrite -eqFkk' ZdK -eq10 {}ZdK -eq20 !htau1 //; try by rewrite eq_sym. + move/(_ (mulr1 _) (mulr1 _)); rewrite /d eqFkk'. + by case e => /eqP <-; [exists k | exists k']; rewrite ?scaler_sign ?opprB. +pose mu := [tuple of [seq s2val (muP i) | i <- ord_tuple m.+2]]; exists mu. + rewrite map_inj_uniq ?enum_uniq // => i j. + case: (muP i) (muP j) => /= ki _ /eqP eq_i0 [/= kj _ /eqP eq_j0] eq_kij. + apply/eqP; rewrite -eq_chi -subr_eq0 -cfnorm_eq0 -iso_tau ?ZF //. + rewrite -[chi i](subrK (chi 0)) -addrA linearD eq_i0 eq_kij -eq_j0. + by rewrite -linearD -opprB subrr !raddf0. +exists (~~ e) => i; rewrite -addbT signr_addb -/d -scalerA scaleN1r opprB. +rewrite -!tnth_nth -/(F i 0) tnth_map tnth_ord_tuple. +suffices /= ->: mu`_0 = k0 by case: (muP i) => /= k _ /eqP. +rewrite -(tnth_nth 0 _ 0) tnth_map tnth_ord_tuple. +by case: (muP 0) => /= k /(k =P k0). +Qed. + +(* This is Peterfalvi (1.5)(a). *) +Lemma cfResInd_sum_cfclass t : H <| G -> + 'Res[H] ('Ind[G] 'chi_t) + = #|'I_G['chi_t] : H|%:R *: \sum_(xi <- ('chi_t ^: G)%CF) xi. +Proof. +set T := 'I_G['chi_t] => nsHG; have [sHG nHG] := andP nsHG. +apply/cfun_inP=> h Hh; rewrite cfResE ?cfIndE // cfunE sum_cfunE. +apply: (canLR (mulKf (neq0CG H))). +rewrite mulrA -natrM Lagrange ?sub_Inertia //= -/T reindex_cfclass //=. +rewrite mulr_sumr [s in _ = s]big_mkcond /= (reindex_inj invg_inj). +rewrite (partition_big (conjg_Iirr t) xpredT) //=; apply: eq_bigr => i _. +have [[y Gy chi_i] | not_i_t] := cfclassP _ _ _; last first. + apply: big1 => z; rewrite groupV => /andP[Gz /eqP def_i]. + by case: not_i_t; exists z; rewrite // -def_i conjg_IirrE. +rewrite -(card_rcoset _ y) mulr_natl -sumr_const; apply: eq_big => z. + rewrite -(inj_eq irr_inj) conjg_IirrE chi_i mem_rcoset inE groupMr ?groupV //. + apply: andb_id2l => Gz; rewrite eq_sym (cfConjg_eqE _ nsHG) //. + by rewrite mem_rcoset inE groupM ?groupV. +rewrite groupV => /andP[Gz /eqP <-]. +by rewrite conjg_IirrE cfConjgE ?(subsetP nHG). +Qed. + +(* This is Peterfalvi (1.5)(b), main formula. *) +Lemma cfnorm_Ind_irr t : + H <| G -> '['Ind[G] 'chi[H]_t] = #|'I_G['chi_t] : H|%:R. +Proof. +set r := _%:R => HnG; have HsG := normal_sub HnG. +rewrite -Frobenius_reciprocity cfResInd_sum_cfclass //= cfdotZr rmorph_nat -/r. +rewrite reindex_cfclass // cfdot_sumr (bigD1 t) ?cfclass_refl //= cfnorm_irr. +rewrite big1 ?addr0 ?mulr1 // => j /andP[_ /negbTE]. +by rewrite eq_sym cfdot_irr => ->. +Qed. + +(* This is Peterfalvi (1.5)(b), irreducibility remark. *) +Lemma inertia_Ind_irr t : + H <| G -> 'I_G['chi[H]_t] \subset H -> 'Ind[G] 'chi_t \in irr G. +Proof. +rewrite -indexg_eq1 => nsHG /eqP r1. +by rewrite irrEchar cfInd_char ?irr_char //= cfnorm_Ind_irr ?r1. +Qed. + +(* This is Peterfalvi (1.5)(c). *) +Lemma cfclass_Ind_cases t1 t2 : H <| G -> + if 'chi_t2 \in ('chi[H]_t1 ^: G)%CF + then 'Ind[G] 'chi_t1 = 'Ind[G] 'chi_t2 + else '['Ind[G] 'chi_t1, 'Ind[G] 'chi_t2] = 0. +Proof. +move=> nsHG; have [/cfclass_Ind-> // | not_ch1Gt2] := ifPn. +rewrite -Frobenius_reciprocity cfResInd_sum_cfclass // cfdotZr rmorph_nat. +rewrite cfdot_sumr reindex_cfclass // big1 ?mulr0 // => j; rewrite cfdot_irr. +case: eqP => // <- /idPn[]; apply: contra not_ch1Gt2 => /cfclassP[y Gy ->]. +by apply/cfclassP; exists y^-1%g; rewrite ?groupV ?cfConjgK. +Qed. + +(* Useful consequences of (1.5)(c) *) +Lemma not_cfclass_Ind_ortho i j : + H <| G -> ('chi_i \notin 'chi_j ^: G)%CF -> + '['Ind[G, H] 'chi_i, 'Ind[G, H] 'chi_j] = 0. +Proof. by move/(cfclass_Ind_cases i j); rewrite cfclass_sym; case: ifP. Qed. + +Lemma cfclass_Ind_irrP i j : + H <| G -> + reflect ('Ind[G, H] 'chi_i = 'Ind[G, H] 'chi_j) ('chi_i \in 'chi_j ^: G)%CF. +Proof. +move=> nsHG; have [sHG _] := andP nsHG. +case: ifP (cfclass_Ind_cases j i nsHG) => [|_ Oji]; first by left. +right=> eq_chijG; have /negP[]: 'Ind[G] 'chi_i != 0 by exact: Ind_irr_neq0. +by rewrite -cfnorm_eq0 {1}eq_chijG Oji. +Qed. + +Lemma card_imset_Ind_irr (calX : {set Iirr H}) : + H <| G -> {in calX, forall i, 'Ind 'chi_i \in irr G} -> + {in calX & G, forall i y, conjg_Iirr i y \in calX} -> + #|calX| = (#|G : H| * #|[set cfIirr ('Ind[G] 'chi_i) | i in calX]|)%N. +Proof. +move=> nsHG irrIndX sXGX; have [sHG _] := andP nsHG; set f := fun i => cfIirr _. +rewrite -sum1_card (partition_big_imset f) /= mulnC -sum_nat_const. +apply: eq_bigr => _ /imsetP[i Xi ->]; transitivity (size (cfclass 'chi_i G)). + rewrite -sum1_size reindex_cfclass //; apply: eq_bigl => j. + case Xj: (j \in calX). + rewrite -(inj_eq irr_inj) !(cfIirrPE irrIndX) //. + exact/eqP/cfclass_Ind_irrP. + apply/esym/(contraFF _ Xj)=> /cfclassP[y Gy Dj]. + by rewrite -conjg_IirrE in Dj; rewrite (irr_inj Dj) sXGX. +rewrite -(Lagrange_index (Inertia_sub G 'chi_i)) ?sub_Inertia //. +rewrite -size_cfclass ((#|_ : _| =P 1)%N _) ?muln1 // -eqC_nat. +by rewrite -cfnorm_Ind_irr // -(cfIirrPE irrIndX) ?cfnorm_irr. +Qed. + +(* This is Peterfalvi (1.5)(d). *) +Lemma scaled_cfResInd_sum_cfclass t : H <| G -> + let chiG := 'Ind[G] 'chi_t in + (chiG 1%g / '[chiG]) *: 'Res[H] chiG + = #|G : H|%:R *: (\sum_(xi <- ('chi_t ^: G)%CF) xi 1%g *: xi). +Proof. +move=> nsHG chiG; have [sHG _] := andP nsHG. +rewrite cfResInd_sum_cfclass // cfnorm_Ind_irr // scalerA cfInd1 //. +rewrite divfK ?pnatr_eq0 -?lt0n // -scalerA linear_sum !reindex_cfclass //=. +congr (_ *: _); apply: eq_bigr => _ /cfclassP[y _ ->]. +by rewrite cfConjg1. +Qed. + +(* This is Peterfalvi (1.5)(e). *) +Lemma odd_induced_orthogonal t : + H <| G -> odd #|G| -> t != 0 -> + '['Ind[G, H] 'chi_t, ('Ind[G] 'chi_t)^*] = 0. +Proof. +move=> nsHG oddG nz_t; have [sHG _] := andP nsHG. +have:= cfclass_Ind_cases t (conjC_Iirr t) nsHG. +rewrite conjC_IirrE conj_cfInd; case: cfclassP => // [[g Gg id_cht]]. +have oddH: odd #|H| := pgroup.oddSg sHG oddG. +case/eqP: nz_t; apply: irr_inj; rewrite irr0. +apply/eqP; rewrite -odd_eq_conj_irr1 // id_cht; apply/eqP. +have F1: ('chi_t ^ (g ^+ 2))%CF = 'chi_t. + rewrite (cfConjgM _ nsHG) // -id_cht -conj_cfConjg -id_cht. + exact: cfConjCK. +suffices /eqP->: g == ((g ^+ 2) ^+ #|G|./2.+1)%g. + elim: _./2.+1 => [|n IHn]; first exact: cfConjgJ1. + by rewrite expgS (cfConjgM _ nsHG) ?groupX // F1. +rewrite eq_mulVg1 expgS -expgM mul2n -mulgA mulKg -expgS -order_dvdn. +by rewrite -add1n -[1%N](congr1 nat_of_bool oddG) odd_double_half order_dvdG. +Qed. + +(* This is Peterfalvi (1.6)(a). *) +Lemma sub_cfker_Ind_irr A i : + H \subset G -> G \subset 'N(A) -> + (A \subset cfker ('Ind[G, H] 'chi_i)) = (A \subset cfker 'chi_i). +Proof. by move=> sHG nAG; rewrite cfker_Ind_irr ?sub_gcore. Qed. + +(* Some consequences and related results. *) +Lemma sub_cfker_Ind (A : {set gT}) chi : + A \subset H -> H \subset G -> G \subset 'N(A) -> chi \is a character -> + (A \subset cfker ('Ind[G, H] chi)) = (A \subset cfker chi). +Proof. +move=> sAH sHG nAG Nchi; have [-> | nz_chi] := eqVneq chi 0. + by rewrite raddf0 !cfker_cfun0 !(subset_trans sAH). +by rewrite cfker_Ind ?sub_gcore. +Qed. + +Lemma cfInd_irr_eq1 i : + H <| G -> ('Ind[G, H] 'chi_i == 'Ind[G, H] 1) = (i == 0). +Proof. +case/andP=> sHG nHG; apply/eqP/idP=> [chi1 | /eqP->]; last by rewrite irr0. +rewrite -subGcfker -(sub_cfker_Ind_irr _ sHG nHG) chi1 -irr0. +by rewrite sub_cfker_Ind_irr ?cfker_irr0. +Qed. + +Lemma sub_cfker_constt_Res_irr (A : {set gT}) i j : + j \in irr_constt ('Res[H, G] 'chi_i) -> + A \subset H -> H \subset G -> G \subset 'N(A) -> + (A \subset cfker 'chi_j) = (A \subset cfker 'chi_i). +Proof. +move=> iHj sAH sHG nAG; apply/idP/idP=> kerA. + have jGi: i \in irr_constt ('Ind 'chi_j) by rewrite constt_Ind_Res. + rewrite (subset_trans _ (cfker_constt _ jGi)) ?cfInd_char ?irr_char //=. + by rewrite sub_cfker_Ind_irr. +rewrite (subset_trans _ (cfker_constt _ iHj)) ?cfRes_char ?irr_char //=. +by rewrite cfker_Res ?irr_char // subsetI sAH. +Qed. + +Lemma sub_cfker_constt_Ind_irr (A : {set gT}) i j : + i \in irr_constt ('Ind[G, H] 'chi_j) -> + A \subset H -> H \subset G -> G \subset 'N(A) -> + (A \subset cfker 'chi_j) = (A \subset cfker 'chi_i). +Proof. by rewrite constt_Ind_Res; apply: sub_cfker_constt_Res_irr. Qed. + +(* This is a stronger version of Peterfalvi (1.6)(b). *) +Lemma cfIndMod (K : {group gT}) (phi : 'CF(H / K)) : + K \subset H -> H \subset G -> K <| G -> + 'Ind[G] (phi %% K)%CF = ('Ind[G / K] phi %% K)%CF. +Proof. by move=> sKH sHG /andP[_ nKG]; rewrite cfIndMorph ?ker_coset. Qed. + +Lemma cfIndQuo (K : {group gT}) (phi : 'CF(H)) : + K \subset cfker phi -> H \subset G -> K <| G -> + 'Ind[G / K] (phi / K)%CF = ('Ind[G] phi / K)%CF. +Proof. +move=> kerK sHG nsKG; have sKH := subset_trans kerK (cfker_sub phi). +have nsKH := normalS sKH sHG nsKG. +by apply: canRL (cfModK nsKG) _; rewrite -cfIndMod // cfQuoK. +Qed. + +Section IndSumInertia. + +Variable s : Iirr H. + +Let theta := 'chi_s. +Let T := 'I_G[theta]. +Let calA := irr_constt ('Ind[T] theta). +Let calB := irr_constt ('Ind[G] theta). +Let AtoB (t : Iirr T) := Ind_Iirr G t. +Let e_ t := '['Ind theta, 'chi[T]_t]. + +Hypothesis nsHG: H <| G. +(* begin hide *) +Let sHG : H \subset G. Proof. exact: normal_sub. Qed. +Let nHG : G \subset 'N(H). Proof. exact: normal_norm. Qed. +Let nsHT : H <| T. Proof. exact: normal_Inertia. Qed. +Let sHT : H \subset T. Proof. exact: normal_sub. Qed. +Let nHT : T \subset 'N(H). Proof. exact: normal_norm. Qed. +Let sTG : T \subset G. Proof. exact: subsetIl. Qed. +(* end hide *) + +(* This is Peterfalvi (1.7)(a). *) +Lemma cfInd_sum_Inertia : + [/\ {in calA, forall t, 'Ind 'chi_t \in irr G}, + {in calA, forall t, 'chi_(AtoB t) = 'Ind 'chi_t}, + {in calA &, injective AtoB}, + AtoB @: calA =i calB + & 'Ind[G] theta = \sum_(t in calA) e_ t *: 'Ind 'chi_t]. +Proof. +have [AtoBirr AtoBinj defB _ _] := constt_Inertia_bijection s nsHG. +split=> // [i Ai|]; first exact/cfIirrE/AtoBirr. +rewrite -(cfIndInd _ sTG sHT) {1}['Ind theta]cfun_sum_constt linear_sum. +by apply: eq_bigr => i _; rewrite linearZ. +Qed. + +Hypothesis abTbar : abelian (T / H). + +(* This is Peterfalvi (1.7)(b). *) +Lemma cfInd_central_Inertia : + exists2 e, [/\ e \in Cnat, e != 0 & {in calA, forall t, e_ t = e}] + & [/\ 'Ind[G] theta = e *: \sum_(j in calB) 'chi_j, + #|calB|%:R = #|T : H|%:R / e ^+ 2 + & {in calB, forall i, 'chi_i 1%g = #|G : T|%:R * e * theta 1%g}]. +Proof. +have [t1 At1] := constt_cfInd_irr s sHT; pose psi1 := 'chi_t1. +pose e := '['Ind theta, psi1]. +have NthT: 'Ind[T] theta \is a character by rewrite cfInd_char ?irr_char. +have Ne: e \in Cnat by rewrite Cnat_cfdot_char_irr. +have Dpsi1H: 'Res[H] psi1 = e *: theta. + have psi1Hs: s \in irr_constt ('Res psi1) by rewrite -constt_Ind_Res. + rewrite (Clifford_Res_sum_cfclass nsHT psi1Hs) cfclass_invariant ?subsetIr //. + by rewrite big_seq1 cfdot_Res_l cfdotC conj_Cnat. +have linL j: 'chi[T / H]_j \is a linear_char by apply/char_abelianP. +have linLH j: ('chi_j %% H)%CF \is a linear_char := cfMod_lin_char (linL j). +pose LtoT (j : Iirr (T / H)) := mul_mod_Iirr t1 j. +have LtoTE j: 'chi_(LtoT j) = ('chi_j %% H)%CF * psi1. + by rewrite !(mod_IirrE, cfIirrE) // mul_lin_irr ?mem_irr ?cfMod_lin_char. +have psiHG: 'Ind ('Res[H] psi1) = \sum_j 'chi_(LtoT j). + transitivity ((cfReg (T / H) %% H)%CF * psi1); last first. + rewrite cfReg_sum linear_sum /= mulr_suml; apply: eq_bigr => i _. + by rewrite LtoTE // lin_char1 ?scale1r. + apply/cfun_inP=> x Tx; rewrite cfunE cfModE // cfRegE mulrnAl mulrb. + rewrite (sameP eqP (kerP _ (subsetP nHT x Tx))) ker_coset. + case: ifPn => [Hx | H'x]; last by rewrite (cfun_on0 (cfInd_normal _ _)). + rewrite card_quotient // -!(cfResE _ sHT) // cfRes_Ind_invariant ?cfunE //. + by rewrite -subsetIidl (subset_trans _ (sub_inertia_Res _ _)) ?sub_Inertia. +have imLtoT: {subset calA <= codom LtoT}. + move=> t At; apply/codomP/exists_eqP. + have{At}: t \in irr_constt ('Ind ('Res[H] 'chi_t1)). + by rewrite Dpsi1H linearZ irr_consttE cfdotZl mulf_neq0. + apply: contraR; rewrite negb_exists => /forallP imL't. + by rewrite psiHG cfdot_suml big1 // => j _; rewrite cfdot_irr mulrb ifN_eqC. +have De_ t: t \in calA -> e_ t = e. + case/imLtoT/codomP=> j ->; rewrite /e_ LtoTE /e -!cfdot_Res_r rmorphM /=. + by rewrite cfRes_sub_ker ?cfker_mod // mulr_algl lin_char1 ?scale1r. +have{imLtoT} A_1 t: t \in calA -> 'chi_t 1%g = e * theta 1%g. + case/imLtoT/codomP=> j ->; rewrite LtoTE //= cfunE. + by rewrite (lin_char1 (linLH j)) mul1r -(cfRes1 H) Dpsi1H cfunE. +exists e => //; have [_ defAtoB injAtoB imAtoB ->] := cfInd_sum_Inertia. +rewrite -(eq_bigl _ _ imAtoB) -(eq_card imAtoB) big_imset //= scaler_sumr. +split=> [||i]; first by apply: eq_bigr => t2 At2; rewrite De_ ?defAtoB. + apply: (mulIf (irr1_neq0 s)); rewrite mulrAC -cfInd1 // mulr_natl mulrC invfM. + rewrite ['Ind _]cfun_sum_constt sum_cfunE mulr_sumr card_in_imset //. + rewrite -sumr_const; apply: eq_bigr => t At. + by rewrite -mulrA -/(e_ t) De_ // cfunE A_1 ?mulKf. +by rewrite -imAtoB => /imsetP[t At ->]; rewrite defAtoB ?cfInd1 ?A_1 ?mulrA. +Qed. + +(* This is Peterfalvi (1.7)(c). *) +Lemma cfInd_Hall_central_Inertia : + Hall T H -> + [/\ 'Ind[G] theta = \sum_(i in calB) 'chi_i, #|calB| = #|T : H| + & {in calB, forall i, 'chi_i 1%g = #|G : T|%:R * theta 1%g}]. +Proof. +case/andP=> _ hallH; have [e [_ _ De]] := cfInd_central_Inertia. +suffices ->: e = 1. + by case=> -> /eqP; rewrite scale1r expr1n divr1 mulr1 eqC_nat => /eqP. +suffices{De} [t Dtheta]: exists i, 'Res[H, T] 'chi_i = theta. + have e_t_1: e_ t = 1 by rewrite /e_ -cfdot_Res_r Dtheta cfnorm_irr. + by rewrite -(De t) // irr_consttE -/(e_ t) e_t_1 oner_eq0. +have ITtheta: T \subset 'I[theta] := subsetIr _ _. +have solT: solvable (T / H) := abelian_sol abTbar. +have [|t []] := extend_solvable_coprime_irr nsHT solT ITtheta; last by exists t. +rewrite coprime_sym coprime_mull !(coprime_dvdl _ hallH) ?cfDet_order_dvdG //. +by rewrite -dvdC_nat !CdivE truncCK ?Cnat_irr1 // dvd_irr1_cardG. +Qed. + +End IndSumInertia. + +(* This is Peterfalvi (1.8). *) +Lemma irr1_bound_quo (B C D : {group gT}) i : + B <| C -> B \subset cfker 'chi[G]_i -> + B \subset D -> D \subset C -> C \subset G -> (D / B \subset 'Z(C / B))%g -> + 'chi_i 1%g <= #|G : C|%:R * sqrtC #|C : D|%:R. +Proof. +move=> BnC BsK BsD DsC CsG QsZ. +case: (boolP ('Res[C] 'chi_i == 0))=> [HH|]. + have: ('Res[C] 'chi_i) 1%g = 0 by rewrite (eqP HH) cfunE. + by rewrite cfResE // => HH1; case/eqP: (irr1_neq0 i). +have IC := cfRes_char C (irr_char i). +case/neq0_has_constt=> i1 Hi1. +have CIr: i \in irr_constt ('Ind[G] 'chi_i1). + by rewrite inE /= -Frobenius_reciprocity /= cfdotC conjC_eq0. +have BsKi : B \subset cfker 'chi_i1. + suff BsKri: B \subset cfker ('Res[C] 'chi_i). + by apply: (subset_trans BsKri); exact: (cfker_constt _ Hi1). + apply/subsetP=> g GiG. + have F: g \in C by rewrite (subsetP (subset_trans BsD _)). + rewrite cfkerEchar // inE F !cfResE //. + by move: (subsetP BsK _ GiG); rewrite cfkerEirr inE. +pose i2 := quo_Iirr B i1. +have ZsC: 'Z(C / B)%g \subset 'Z('chi_i2)%CF. + by rewrite -(cap_cfcenter_irr (C / B)); apply: bigcap_inf. +have CBsH: C :&: B \subset D. + apply/subsetP=> g; rewrite inE; case/andP=> _ HH. + by apply: (subsetP (BsD)). +have I1B: 'chi_i1 1%g ^+ 2 <= #|C : D|%:R. + case: (irr1_bound i2)=> HH _; move: HH. + have ->: 'chi_i2 1%g = 'chi_i1 1%g. + by rewrite quo_IirrE // -(coset_id (group1 B)) cfQuoE. + move/ler_trans; apply. + rewrite ler_nat // -(index_quotient_eq CBsH) ?normal_norm //. + rewrite -(@leq_pmul2l #|'Z('chi_i2)%CF|) ?cardG_gt0 ?cfcenter_sub //. + rewrite Lagrange ?quotientS ?cfcenter_sub //. + rewrite -(@leq_pmul2l #|(D / B)%g|) ?cardG_gt0 //. + rewrite mulnA mulnAC Lagrange ?quotientS //. + rewrite mulnC leq_pmul2l ?cardG_gt0 // subset_leq_card //. + exact: subset_trans QsZ ZsC. +have IC': 'Ind[G] 'chi_i1 \is a character := cfInd_char G (irr_char i1). +move: (char1_ge_constt IC' CIr); rewrite cfInd1 //= => /ler_trans-> //. +have chi1_1_ge0: 0 <= 'chi_i1 1%g by rewrite ltrW ?irr1_gt0. +rewrite ler_pmul2l ?gt0CiG //. +by rewrite -(@ler_pexpn2r _ 2) -?topredE /= ?sqrtC_ge0 ?ler0n ?sqrtCK. +Qed. + +(* This is Peterfalvi (1.9)(a). *) +Lemma extend_coprime_Qn_aut a b (Qa Qb : fieldExtType rat) w_a w_b + (QaC : {rmorphism Qa -> algC}) (QbC : {rmorphism Qb -> algC}) + (mu : {rmorphism algC -> algC}) : + coprime a b -> + a.-primitive_root w_a /\ <<1; w_a>>%VS = {:Qa}%VS -> + b.-primitive_root w_b /\ <<1; w_b>>%VS = {:Qb}%VS -> + {nu : {rmorphism algC -> algC} | forall x, nu (QaC x) = mu (QaC x) + & forall y, nu (QbC y) = QbC y}. +Proof. +move=> coab [pr_w_a genQa] [pr_w_b genQb]. +have [k co_k_a Dmu]: {k | coprime k a & mu (QaC w_a) = QaC (w_a ^+ k)}. + have prCw: a.-primitive_root (QaC w_a) by rewrite fmorph_primitive_root. + by have [k coka ->] := aut_prim_rootP mu prCw; rewrite -rmorphX; exists k. +pose k1 := chinese a b k 1; have /Qn_aut_exists[nu Dnu]: coprime k1 (a * b). + rewrite coprime_mulr -!(coprime_modl k1) chinese_modl ?chinese_modr //. + by rewrite !coprime_modl co_k_a coprime1n. +exists nu => [x | y]. + have /Fadjoin_polyP[p Qp ->]: x \in <<1; w_a>>%VS by rewrite genQa memvf. + rewrite -!horner_map -!map_poly_comp !map_Qnum_poly // Dmu Dnu -rmorphX /=. + by rewrite -(prim_expr_mod pr_w_a) chinese_modl // prim_expr_mod. + by rewrite exprM (prim_expr_order pr_w_a) expr1n rmorph1. +have /Fadjoin_polyP[p Qp ->]: y \in <<1; w_b>>%VS by rewrite genQb memvf. +rewrite -!horner_map -!map_poly_comp !map_Qnum_poly // Dnu -rmorphX /=. + by rewrite -(prim_expr_mod pr_w_b) chinese_modr // prim_expr_mod. +by rewrite mulnC exprM (prim_expr_order pr_w_b) expr1n rmorph1. +Qed. + +(* This intermediate result in the proof of Peterfalvi (1.9)(b) is used in *) +(* he proof of (3.9)(c). *) +Lemma dvd_restrict_cfAut a (v : {rmorphism algC -> algC}) : + exists2 u : {rmorphism algC -> algC}, + forall gT0 G0 chi x, + chi \in 'Z[irr (@gval gT0 G0)] -> #[x] %| a -> u (chi x) = v (chi x) + & forall chi x, chi \in 'Z[irr G] -> coprime #[x] a -> u (chi x) = chi x. +Proof. +have [-> | a_gt0] := posnP a. + exists v => // chi x Zchi; rewrite /coprime gcdn0 order_eq1 => /eqP->. + by rewrite aut_Cint ?Cint_vchar1. +pose b := (#|G|`_(\pi(a)^'))%N. +have co_a_b: coprime a b := pnat_coprime (pnat_pi a_gt0) (part_pnat _ _). +have [Qa _ [QaC _ [w_a genQa memQa]]] := group_num_field_exists [group of Zp a]. +have [Qb _ [QbC _ [w_b genQb memQb]]] := group_num_field_exists [group of Zp b]. +rewrite !card_Zp ?part_gt0 // in Qa QaC w_a genQa memQa Qb QbC w_b genQb memQb. +have [nu nuQa nuQb] := extend_coprime_Qn_aut QaC QbC v co_a_b genQa genQb. +exists nu => [gt0 G0 chi x Zchi x_dv_a | chi x Zchi co_x_a]. + without loss{Zchi} Nchi: chi / chi \is a character. + move=> IH; case/vcharP: Zchi => [chi1 Nchi1 [chi2 Nchi2 ->]]. + by rewrite !cfunE !rmorphB !IH. + by have [xa <-] := memQa _ _ _ Nchi x x_dv_a; rewrite nuQa. +without loss{Zchi} Nchi: chi / chi \is a character. + move=> IH; case/vcharP: Zchi => [chi1 Nchi1 [chi2 Nchi2 ->]]. + by rewrite !cfunE rmorphB !IH. +have [Gx | /cfun0->] := boolP (x \in G); last by rewrite rmorph0. +have{Gx} x_dv_b: (#[x] %| b)%N. + rewrite coprime_sym coprime_pi' // in co_x_a. + by rewrite -(part_pnat_id co_x_a) partn_dvd ?order_dvdG. +by have [xb <-] := memQb _ _ _ Nchi x x_dv_b; rewrite nuQb. +Qed. + +(* This is Peterfalvi (1.9)(b). *) +(* We have strengthened the statement of this lemma so that it can be used *) +(* rather than reproved for Peterfalvi (3.9). In particular we corrected a *) +(* quantifier inversion in the original statement: the automorphism is *) +(* constructed uniformly for all (virtual) characters. We have also removed *) +(* the spurrious condition that a be a \pi(a) part of #|G| -- the proof works *) +(* for all a, and indeed the first part holds uniformaly for all groups! *) +Lemma make_pi_cfAut a k : + coprime k a -> + exists2 u : {rmorphism algC -> algC}, + forall (gT0 : finGroupType) (G0 : {group gT0}) chi x, + chi \in 'Z[irr G0] -> #[x] %| a -> cfAut u chi x = chi (x ^+ k)%g + & forall chi x, chi \in 'Z[irr G] -> coprime #[x] a -> cfAut u chi x = chi x. +Proof. +move=> co_k_a; have [v Dv] := Qn_aut_exists co_k_a. +have [u Du_a Du_a'] := dvd_restrict_cfAut a v. +exists u => [gt0 G0 | ] chi x Zchi a_x; last by rewrite cfunE Du_a'. +rewrite cfunE {u Du_a'}Du_a //. +without loss{Zchi} Nchi: chi / chi \is a character. + move=> IH; case/vcharP: Zchi => [chi1 Nchi1 [chi2 Nchi2 ->]]. + by rewrite !cfunE rmorphB !IH. +have [sXG0 | G0'x] := boolP (<[x]> \subset G0); last first. + have /(<[x]> =P _) gen_xk: generator <[x]> (x ^+ k). + by rewrite generator_coprime coprime_sym (coprime_dvdr a_x). + by rewrite !cfun0 ?rmorph0 -?cycle_subG -?gen_xk. +rewrite -!(cfResE chi sXG0) ?cycle_id ?mem_cycle //. +rewrite ['Res _]cfun_sum_cfdot !sum_cfunE rmorph_sum; apply: eq_bigr => i _. +have chiX := lin_charX (char_abelianP _ (cycle_abelian x) i) _ (cycle_id x). +rewrite !cfunE rmorphM aut_Cnat ?Cnat_cfdot_char_irr ?cfRes_char //. +by congr (_ * _); rewrite Dv -chiX // -expg_mod_order (eqnP a_x) chiX. +Qed. + +Section ANT. +Import ssrint. + +(* This section covers Peterfalvi (1.10). *) +(* We have simplified the statement somewhat by substituting the global ring *) +(* of algebraic integers for the specific ring Z[eta]. Formally this amounts *) +(* to strengthening (b) and weakening (a) accordingly, but since actually the *) +(* Z[eta] is equal to the ring of integers of Q[eta] (cf. Theorem 6.4 in J.S. *) +(* Milne's course notes on Algebraic Number Theory), the simplified statement *) +(* is actually equivalent to the textbook one. *) +Variable (p : nat) (eps : algC). +Hypothesis (pr_eps : p.-primitive_root eps). +Local Notation e := (1 - eps). + +(* This is Peterfalvi (1.10) (a). *) +Lemma vchar_ker_mod_prim : {in G & G & 'Z[irr G], forall x y (chi : 'CF(G)), + #[x] = p -> y \in 'C[x] -> chi (x * y)%g == chi y %[mod e]}%A. +Proof. +move=> x y chi Gx Gy Zchi ox cxy; pose X := <<[set x; y]>>%G. +have [Xx Xy]: x \in X /\ y \in X by apply/andP; rewrite -!sub1set -join_subG. +have sXG: X \subset G by rewrite join_subG !sub1set Gx. +suffices{chi Zchi} IHiX i: ('chi[X]_i (x * y)%g == 'chi_i y %[mod e])%A. + rewrite -!(cfResE _ sXG) ?groupM //. + have irr_free := (free_uniq (basis_free (irr_basis X))). + have [c Zc ->] := (zchar_expansion irr_free (cfRes_vchar X Zchi)). + rewrite !sum_cfunE /eqAmod -sumrB big_seq rpred_sum // => _ /irrP[i ->]. + by rewrite !cfunE [(_ %| _)%A]eqAmodMl // rpred_Cint. +have lin_chi: 'chi_i \is a linear_char. + apply/char_abelianP; rewrite -[gval X]joing_idl -joing_idr abelianY. + by rewrite !cycle_abelian cycle_subG /= cent_cycle. +rewrite lin_charM // -{2}['chi_i y]mul1r eqAmodMr ?Aint_irr //. +have [|k ->] := (prim_rootP pr_eps) ('chi_i x). + by rewrite -lin_charX // -ox expg_order lin_char1. +rewrite -[_ ^+ k](subrK 1) subrX1 -[_ - 1]opprB mulNr -mulrN mulrC. +rewrite eqAmod_addl_mul // rpredN rpred_sum // => n _. +by rewrite rpredX ?(Aint_prim_root pr_eps). +Qed. + +(* This is Peterfalvi (1.10)(b); the primality condition is only needed here. *) +Lemma int_eqAmod_prime_prim n : + prime p -> n \in Cint -> (n == 0 %[mod e])%A -> (p %| n)%C. +Proof. +move=> p_pr Zn; rewrite /eqAmod unfold_in subr0. +have p_gt0 := prime_gt0 p_pr. +case: ifPn => [_ /eqP->// | nz_e e_dv_n]. +suffices: (n ^+ p.-1 == 0 %[mod p])%A. + rewrite eqAmod0_rat ?rpredX ?rpred_nat 1?rpred_Cint // !dvdC_int ?rpredX //. + by rewrite floorCX // abszX Euclid_dvdX // => /andP[]. +rewrite /eqAmod subr0 unfold_in pnatr_eq0 eqn0Ngt p_gt0 /=. +pose F := \prod_(1 <= i < p) ('X - (eps ^+ i)%:P). +have defF: F = \sum_(i < p) 'X^i. + apply: (mulfI (monic_neq0 (monicXsubC 1))); rewrite -subrX1. + by rewrite -(factor_Xn_sub_1 pr_eps) big_ltn. +have{defF} <-: F.[1] = p :> Algebraics.divisor. + rewrite -[p]card_ord -[rhs in _ = rhs]sumr_const defF horner_sum. + by apply: eq_bigr => i _; rewrite hornerXn expr1n. +rewrite -[p.-1]card_ord {F}horner_prod big_add1 big_mkord -prodfV. +rewrite -prodr_const -big_split rpred_prod //= => k _; rewrite !hornerE. +rewrite -[n](divfK nz_e) -[_ * _ / _]mulrA rpredM {e_dv_n}//. +have p'k: ~~ (p %| k.+1)%N by rewrite gtnNdvd // -{2}(prednK p_gt0) ltnS. +have [r {1}->]: exists r, eps = eps ^+ k.+1 ^+ r. + have [q _ /dvdnP[r Dr]] := Bezoutl p (ltn0Sn k); exists r; apply/esym/eqP. + rewrite -exprM (eq_prim_root_expr pr_eps _ 1) mulnC -Dr addnC gcdnC. + by rewrite -prime_coprime // in p'k; rewrite (eqnP p'k) modnMDl. +rewrite -[1 - _]opprB subrX1 -mulNr opprB mulrC. +rewrite mulKf; last by rewrite subr_eq0 eq_sym -(prim_order_dvd pr_eps). +by apply: rpred_sum => // i _; rewrite !rpredX ?(Aint_prim_root pr_eps). +Qed. + +End ANT. + +End Main. + + diff --git a/mathcomp/odd_order/PFsection10.v b/mathcomp/odd_order/PFsection10.v new file mode 100644 index 0000000..d380e47 --- /dev/null +++ b/mathcomp/odd_order/PFsection10.v @@ -0,0 +1,1215 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg poly finset center. +Require Import fingroup morphism perm automorphism quotient action finalg zmodp. +Require Import gfunctor gproduct cyclic commutator gseries nilpotent pgroup. +Require Import sylow hall abelian maximal frobenius. +Require Import matrix mxalgebra mxrepresentation mxabelem vector. +Require Import BGsection1 BGsection3 BGsection7 BGsection15 BGsection16. +Require Import ssrnum algC classfun character integral_char inertia vcharacter. +Require Import PFsection1 PFsection2 PFsection3 PFsection4. +Require Import PFsection5 PFsection6 PFsection7 PFsection8 PFsection9. + +(******************************************************************************) +(* This file covers Peterfalvi, Section 10: Maximal subgroups of Types III, *) +(* IV and V. For defW : W1 \x W2 = W and MtypeP : of_typeP M U defW, and *) +(* setting ptiW := FT_primeTI_hyp MtypeP, mu2_ i j := primeTIirr ptiW i j and *) +(* delta_ j := primeTIsign j, we define here, for M of type III-V: *) +(* FTtype345_TIirr_degree MtypeP == the common degree of the components of *) +(* (locally) d the images of characters of irr W that don't have *) +(* W2 in their kernel by the cyclicTI isometry to M. *) +(* Thus mu2_ i j 1%g = d%:R for all j != 0. *) +(* FTtype345_TIsign MtypeP == the common sign of the images of characters *) +(* (locally) delta of characters of irr W that don't have W2 in *) +(* their kernel by the cyclicTI isometry to M. *) +(* Thus delta_ j = delta for all j != 0. *) +(* FTtype345_ratio MtypeP == the ratio (d - delta) / #|W1|. Even though it *) +(* (locally) n is always a positive integer we take n : algC. *) +(* FTtype345_bridge MtypeP s i j == a virtual character that can be used to *) +(* (locally) alpha_ i j bridge coherence between the mu2_ i j and other *) +(* irreducibles of M; here s should be the index of *) +(* an irreducible character of M induced from M^(1). *) +(* := mu2_ i j - delta *: mu2_ i 0 -n *: 'chi_s. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory Num.Theory. + +Section Ten. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). +Implicit Types (p q : nat) (x y z : gT). +Implicit Types H K L N P Q R S T U W : {group gT}. + +Local Notation "#1" := (inord 1) (at level 0). + +Section OneMaximal. + +(* These assumptions correspond to Peterfalvi, Hypothesis (10.1). *) +(* We also declare the group U_M, even though it is not used in this section, *) +(* because it is a parameter to the theorems and definitions of PFsection8 *) +(* and PFsection9. *) +Variables M U_M W W1 W2 : {group gT}. +Hypotheses (maxM : M \in 'M) (defW : W1 \x W2 = W). +Hypotheses (MtypeP : of_typeP M U_M defW) (notMtype2: FTtype M != 2). + +Local Notation "` 'M'" := (gval M) (at level 0, only parsing) : group_scope. +Local Notation "` 'W1'" := (gval W1) (at level 0, only parsing) : group_scope. +Local Notation "` 'W2'" := (gval W2) (at level 0, only parsing) : group_scope. +Local Notation "` 'W'" := (gval W) (at level 0, only parsing) : group_scope. +Local Notation V := (cyclicTIset defW). +Local Notation M' := M^`(1)%G. +Local Notation "` 'M''" := `M^`(1) (at level 0) : group_scope. +Local Notation M'' := M^`(2)%G. +Local Notation "` 'M'''" := `M^`(2) (at level 0) : group_scope. + +Let defM : M' ><| W1 = M. Proof. by have [[]] := MtypeP. Qed. +Let nsM''M' : M'' <| M'. Proof. exact: (der_normal 1 M'). Qed. +Let nsM'M : M' <| M. Proof. exact: (der_normal 1 M). Qed. +Let sM'M : M' \subset M. Proof. exact: der_sub. Qed. +Let nsM''M : M'' <| M. Proof. exact: der_normal 2 M. Qed. + +Let notMtype1 : FTtype M != 1%N. Proof. exact: FTtypeP_neq1 MtypeP. Qed. +Let typeMgt2 : FTtype M > 2. +Proof. by move: (FTtype M) (FTtype_range M) notMtype1 notMtype2=> [|[|[]]]. Qed. + +Let defA1 : 'A1(M) = M'^#. Proof. by rewrite /= -FTcore_eq_der1. Qed. +Let defA : 'A(M) = M'^#. Proof. by rewrite FTsupp_eq1 ?defA1. Qed. +Let defA0 : 'A0(M) = M'^# :|: class_support V M. +Proof. by rewrite -defA (FTtypeP_supp0_def _ MtypeP). Qed. +Let defMs : M`_\s :=: M'. Proof. exact: FTcore_type_gt2. Qed. + +Let pddM := FT_prDade_hyp maxM MtypeP. +Let ptiWM : primeTI_hypothesis M M' defW := FT_primeTI_hyp MtypeP. +Let ctiWG : cyclicTI_hypothesis G defW := pddM. +Let ctiWM : cyclicTI_hypothesis M defW := prime_cycTIhyp ptiWM. + +Let ntW1 : W1 :!=: 1. Proof. by have [[]] := MtypeP. Qed. +Let ntW2 : W2 :!=: 1. Proof. by have [_ _ _ []] := MtypeP. Qed. +Let cycW1 : cyclic W1. Proof. by have [[]] := MtypeP. Qed. +Let cycW2 : cyclic W2. Proof. by have [_ _ _ []] := MtypeP. Qed. + +Let w1 := #|W1|. +Let w2 := #|W2|. +Let nirrW1 : #|Iirr W1| = w1. Proof. by rewrite card_Iirr_cyclic. Qed. +Let nirrW2 : #|Iirr W2| = w2. Proof. by rewrite card_Iirr_cyclic. Qed. +Let NirrW1 : Nirr W1 = w1. Proof. by rewrite -nirrW1 card_ord. Qed. +Let NirrW2 : Nirr W2 = w2. Proof. by rewrite -nirrW2 card_ord. Qed. + +Let w1gt2 : w1 > 2. Proof. by rewrite odd_gt2 ?mFT_odd ?cardG_gt1. Qed. +Let w2gt2 : w2 > 2. Proof. by rewrite odd_gt2 ?mFT_odd ?cardG_gt1. Qed. + +Let coM'w1 : coprime #|M'| w1. +Proof. by rewrite (coprime_sdprod_Hall_r defM); have [[]] := MtypeP. Qed. + +(* This is used both in (10.2) and (10.8). *) +Let frobMbar : [Frobenius M / M'' = (M' / M'') ><| (W1 / M'')]. +Proof. +have [[_ hallW1 _ _] _ _ [_ _ _ sW2M'' regM'W1 ] _] := MtypeP. +apply: Frobenius_coprime_quotient => //. +split=> [|w /regM'W1-> //]; apply: (sol_der1_proper (mmax_sol maxM)) => //. +by apply: subG1_contra ntW2; apply: subset_trans sW2M'' (der_sub 1 M'). +Qed. + +Local Open Scope ring_scope. + +Let sigma := (cyclicTIiso ctiWG). +Let w_ i j := (cyclicTIirr defW i j). +Local Notation eta_ i j := (sigma (w_ i j)). + +Local Notation Imu2 := (primeTI_Iirr ptiWM). +Let mu2_ i j := primeTIirr ptiWM i j. +Let mu_ := primeTIred ptiWM. +Local Notation chi_ j := (primeTIres ptiWM j). + +Local Notation Idelta := (primeTI_Isign ptiWM). +Local Notation delta_ j := (primeTIsign ptiWM j). + +Local Notation tau := (FT_Dade0 maxM). +Local Notation "chi ^\tau" := (tau chi). + +Let calS0 := seqIndD M' M M`_\s 1. +Let rmR := FTtypeP_coh_base maxM MtypeP. +Let scohS0 : subcoherent calS0 tau rmR. +Proof. exact: FTtypeP_subcoherent MtypeP. Qed. + +Let calS := seqIndD M' M M' 1. +Let sSS0 : cfConjC_subset calS calS0. +Proof. by apply: seqInd_conjC_subset1; rewrite /= ?defMs. Qed. + +Let mem_calS s : ('Ind 'chi[M']_s \in calS) = (s != 0). +Proof. +rewrite mem_seqInd ?normal1 ?FTcore_normal //=. +by rewrite !inE sub1G subGcfker andbT. +Qed. + +Let calSmu j : j != 0 -> mu_ j \in calS. +Proof. +move=> nz_j; rewrite -[mu_ j]cfInd_prTIres mem_calS -irr_eq1. +by rewrite -(prTIres0 ptiWM) (inj_eq irr_inj) (inj_eq (prTIres_inj _)). +Qed. + +Let tauM' : {subset 'Z[calS, M'^#] <= 'CF(M, 'A0(M))}. +Proof. by rewrite defA0 => phi /zchar_on/(cfun_onS (subsetUl _ _))->. Qed. + +(* This is Peterfalvi (10.2). *) +(* Note that this result is also valid for type II groups. *) +Lemma FTtypeP_ref_irr : + {zeta | [/\ zeta \in irr M, zeta \in calS & zeta 1%g = w1%:R]}. +Proof. +have [_ /has_nonprincipal_irr[s nz_s] _ _ _] := Frobenius_context frobMbar. +exists ('Ind 'chi_s %% M'')%CF; split. +- exact/cfMod_irr/(irr_induced_Frobenius_ker (FrobeniusWker frobMbar)). +- by rewrite -cfIndMod ?normal_sub // -mod_IirrE // mem_calS mod_Iirr_eq0. +rewrite -cfIndMod ?cfInd1 ?normal_sub // -(index_sdprod defM) cfMod1. +by rewrite lin_char1 ?mulr1 //; apply/char_abelianP/sub_der1_abelian. +Qed. + +(* This is Peterfalvi (10.3), first assertion. *) +Lemma FTtype345_core_prime : prime w2. +Proof. +have [S pairMS [xdefW [U StypeP]]] := FTtypeP_pair_witness maxM MtypeP. +have [[_ _ maxS] _] := pairMS; rewrite {1}(negPf notMtype2) /= => Stype2 _ _. +by have [[]] := compl_of_typeII maxS StypeP Stype2. +Qed. +Let w2_pr := FTtype345_core_prime. + +Definition FTtype345_TIirr_degree := truncC (mu2_ 0 #1 1%g). +Definition FTtype345_TIsign := delta_ #1. +Local Notation d := FTtype345_TIirr_degree. +Local Notation delta := FTtype345_TIsign. +Definition FTtype345_ratio := (d%:R - delta) / w1%:R. +Local Notation n := FTtype345_ratio. + +(* This is the remainder of Peterfalvi (10.3). *) +Lemma FTtype345_constants : + [/\ forall i j, j != 0 -> mu2_ i j 1%g = d%:R, + forall j, j != 0 -> delta_ j = delta, + (d > 1)%N + & n \in Cnat]. +Proof. +have nz_j1 : #1 != 0 :> Iirr W2 by rewrite Iirr1_neq0. +have invj j: j != 0 -> mu2_ 0 j 1%g = d%:R /\ delta_ j = delta. + move=> nz_j; have [k co_k_j1 Dj] := cfExp_prime_transitive w2_pr nz_j1 nz_j. + rewrite -(cforder_dprodr defW) -dprod_IirrEr in co_k_j1. + have{co_k_j1} [[u Dj1u] _] := cycTIiso_aut_exists ctiWM co_k_j1. + rewrite dprod_IirrEr -rmorphX -Dj /= -!dprod_IirrEr -!/(w_ _ _) in Dj1u. + rewrite truncCK ?Cnat_irr1 //. + have: delta_ j *: mu2_ 0 j == cfAut u (delta_ #1 *: mu2_ 0 #1). + by rewrite -!(cycTIiso_prTIirr pddM) -/ctiWM -Dj1u. + rewrite raddfZsign /= -prTIirr_aut eq_scaled_irr signr_eq0 /= /mu2_. + by case/andP=> /eqP-> /eqP->; rewrite prTIirr_aut cfunE aut_Cnat ?Cnat_irr1. +have d_gt1: (d > 1)%N. + rewrite ltn_neqAle andbC -eqC_nat -ltC_nat truncCK ?Cnat_irr1 //. + rewrite irr1_gt0 /= eq_sym; apply: contraNneq nz_j1 => mu2_lin. + have: mu2_ 0 #1 \is a linear_char by rewrite qualifE irr_char /= mu2_lin. + by rewrite lin_irr_der1 => /(prTIirr0P ptiWM)[i /irr_inj/prTIirr_inj[_ ->]]. +split=> // [i j /invj[<- _] | _ /invj[//] | ]; first by rewrite prTIirr_1. +have: (d%:R == delta %[mod w1])%C by rewrite truncCK ?Cnat_irr1 ?prTIirr1_mod. +rewrite /eqCmod unfold_in -/n (negPf (neq0CG W1)) CnatEint => ->. +rewrite divr_ge0 ?ler0n // [delta]signrE opprB addrA -natrD subr_ge0 ler1n. +by rewrite -(subnKC d_gt1). +Qed. + +Let o_mu2_irr zeta i j : + zeta \in calS -> zeta \in irr M -> '[mu2_ i j, zeta] = 0. +Proof. +case/seqIndP=> s _ -> irr_sM; rewrite -cfdot_Res_l cfRes_prTIirr cfdot_irr. +rewrite (negPf (contraNneq _ (prTIred_not_irr ptiWM j))) // => Ds. +by rewrite -cfInd_prTIres Ds. +Qed. + +Let ZmuBzeta zeta j : + zeta \in calS -> zeta 1%g = w1%:R -> j != 0 -> + mu_ j - d%:R *: zeta \in 'Z[calS, M'^#]. +Proof. +move=> Szeta zeta1w1 nz_j; have [mu1 _ _ _] := FTtype345_constants. +rewrite -[d%:R](mulKf (neq0CiG M M')) mulrC -(mu1 0 j nz_j). +rewrite -(cfResE _ sM'M) // cfRes_prTIirr -cfInd1 // cfInd_prTIres. +by rewrite (seqInd_sub_lin_vchar _ Szeta) ?calSmu // -(index_sdprod defM). +Qed. + +Let mu0Bzeta_on zeta : + zeta \in calS -> zeta 1%g = w1%:R -> mu_ 0 - zeta \in 'CF(M, 'A(M)). +Proof. +move/seqInd_on=> M'zeta zeta1w1; rewrite [mu_ 0]prTIred0 defA cfun_onD1. +rewrite !cfunE zeta1w1 cfuniE // group1 mulr1 subrr rpredB ?M'zeta //=. +by rewrite rpredZ ?cfuni_on. +Qed. + +(* We need to prove (10.5) - (10.7) for an arbitrary choice of zeta, to allow *) +(* part of the proof of (10.5) to be reused in that of (11.8). *) +Variable zeta : 'CF(M). +Hypotheses (irr_zeta : zeta \in irr M) (Szeta : zeta \in calS). +Hypothesis (zeta1w1 : zeta 1%g = w1%:R). + +Let o_mu2_zeta i j : '[mu2_ i j, zeta] = 0. Proof. exact: o_mu2_irr. Qed. + +Let o_mu_zeta j : '[mu_ j, zeta] = 0. +Proof. by rewrite cfdot_suml big1 // => i _; apply: o_mu2_zeta. Qed. + +Definition FTtype345_bridge i j := mu2_ i j - delta *: mu2_ i 0 - n *: zeta. +Local Notation alpha_ := FTtype345_bridge. + +(* This is the first part of Peterfalvi (10.5), which does not depend on the *) +(* coherence assumption that will ultimately be refuted by (10.8). *) +Lemma supp_FTtype345_bridge i j : j != 0 -> alpha_ i j \in 'CF(M, 'A0(M)). +Proof. +move=> nz_j; have [Dd Ddelta _ _] := FTtype345_constants. +have Dmu2 := prTIirr_id pddM. +have W1a0 x: x \in W1 -> alpha_ i j x = 0. + move=> W1x; rewrite !cfunE; have [-> | ntx] := eqVneq x 1%g. + by rewrite Dd // prTIirr0_1 mulr1 zeta1w1 divfK ?neq0CG ?subrr. + have notM'x: x \notin M'. + apply: contra ntx => M'x; have: x \in M' :&: W1 by apply/setIP. + by rewrite coprime_TIg ?inE. + have /sdprod_context[_ sW1W _ _ tiW21] := dprodWsdC defW. + have abW2: abelian W2 := cyclic_abelian cycW2. + have Wx: x \in W :\: W2. + rewrite inE (contra _ ntx) ?(subsetP sW1W) // => W2x. + by rewrite -in_set1 -set1gE -tiW21 inE W2x. + rewrite !Dmu2 {Wx}// Ddelta // prTIsign0 scale1r !dprod_IirrE cfunE. + rewrite -!(cfResE _ sW1W) ?cfDprodKl_abelian // subrr. + have [s _ ->] := seqIndP Szeta. + by rewrite (cfun_on0 (cfInd_normal _ _)) ?mulr0 ?subrr. +apply/cfun_onP=> x; rewrite !inE defA notMtype1 /= => /norP[notM'x]. +set pi := \pi(M'); have [Mx /= pi_x | /cfun0->//] := boolP (x \in M). +have hallM': pi.-Hall(M) M' by rewrite Hall_pi -?(coprime_sdprod_Hall_l defM). +have hallW1: pi^'.-Hall(M) W1 by rewrite -(compl_pHall _ hallM') sdprod_compl. +have{pi_x} pi'x: pi^'.-elt x. + apply: contraR notM'x => not_pi'x; rewrite !inE (mem_normal_Hall hallM') //. + rewrite not_pi'x andbT negbK in pi_x. + by rewrite (contraNneq _ not_pi'x) // => ->; apply: p_elt1. +have [|y My] := Hall_subJ (mmax_sol maxM) hallW1 _ pi'x; rewrite cycle_subG //. +by case/imsetP=> z Wz ->; rewrite cfunJ ?W1a0. +Qed. +Local Notation alpha_on := supp_FTtype345_bridge. + +Lemma vchar_FTtype345_bridge i j : alpha_ i j \in 'Z[irr M]. +Proof. +have [_ _ _ Nn] := FTtype345_constants. +by rewrite !rpredB ?rpredZsign ?rpredZ_Cnat ?irr_vchar ?mem_zchar. +Qed. +Local Notation Zalpha := vchar_FTtype345_bridge. +Local Hint Resolve Zalpha. + +Lemma vchar_Dade_FTtype345_bridge i j : + j != 0 -> (alpha_ i j)^\tau \in 'Z[irr G]. +Proof. by move=> nz_j; rewrite Dade_vchar // zchar_split Zalpha alpha_on. Qed. +Local Notation Zalpha_tau := vchar_Dade_FTtype345_bridge. + +(* This covers the last paragraph in the proof of (10.5); it's isolated here *) +(* because it is reused in the proof of (10.10) and (11.8). *) + +Lemma norm_FTtype345_bridge i j : + j != 0 -> '[(alpha_ i j)^\tau] = 2%:R + n ^+ 2. +Proof. +move=> nz_j; rewrite Dade_isometry ?alpha_on // cfnormBd ?cfnormZ; last first. + by rewrite cfdotZr cfdotBl cfdotZl !o_mu2_zeta !(mulr0, subr0). +have [_ _ _ /Cnat_ge0 n_ge0] := FTtype345_constants. +rewrite ger0_norm // cfnormBd ?cfnorm_sign ?cfnorm_irr ?irrWnorm ?mulr1 //. +by rewrite cfdotZr (cfdot_prTIirr pddM) (negPf nz_j) andbF ?mulr0. +Qed. +Local Notation norm_alpha := norm_FTtype345_bridge. + +Implicit Type tau : {additive 'CF(M) -> 'CF(G)}. + +(* This exported version is adapted to its use in (11.8). *) +Lemma FTtype345_bridge_coherence calS1 tau1 i j X Y : + coherent_with calS1 M^# tau tau1 -> (alpha_ i j)^\tau = X + Y -> + cfConjC_subset calS1 calS0 -> {subset calS1 <= irr M} -> + j != 0 -> Y \in 'Z[map tau1 calS1] -> '[Y, X] = 0 -> '[Y] = n ^+ 2 -> + X = delta *: (eta_ i j - eta_ i 0). +Proof. +move=> cohS1 Dalpha sS10 irrS1 nz_j S1_Y oYX nY_n2. +have [[_ Ddelta _ Nn] [[Itau1 Ztau1] _]] := (FTtype345_constants, cohS1). +have [|z Zz defY] := zchar_expansion _ S1_Y. + rewrite map_inj_in_uniq; first by case: sS10. + by apply: sub_in2 (Zisometry_inj Itau1); apply: mem_zchar. +have nX_2: '[X] = 2%:R. + apply: (addrI '[Y]); rewrite -cfnormDd // addrC -Dalpha norm_alpha //. + by rewrite addrC nY_n2. +have Z_X: X \in 'Z[irr G]. + rewrite -[X](addrK Y) -Dalpha rpredB ?Zalpha_tau // defY big_map big_seq. + by apply: rpred_sum => psi S1psi; rewrite rpredZ_Cint // Ztau1 ?mem_zchar. +apply: eq_signed_sub_cTIiso => // y Vy; rewrite -[X](addrK Y) -Dalpha -/delta. +rewrite !cfunE !cycTIiso_restrict //; set rhs := delta * _. +rewrite Dade_id ?defA0 //; last by rewrite setUC inE mem_class_support. +have notM'y: y \notin M'. + by have:= subsetP (prDade_supp_disjoint pddM) y Vy; rewrite inE. +have Wy: y \in W :\: W2 by move: Vy; rewrite !inE => /andP[/norP[_ ->]]. +rewrite !cfunE 2?{1}prTIirr_id // prTIsign0 scale1r Ddelta // cfunE -mulrBr. +rewrite -/rhs (cfun_on0 (seqInd_on _ Szeta)) // mulr0 subr0. +rewrite (ortho_cycTIiso_vanish ctiWG) ?subr0 // -/sigma. +apply/orthoPl=> _ /mapP[_ /(cycTIirrP defW)[i1 [j1 ->]] ->]. +rewrite defY cfdot_suml big_map big1_seq //= => psi S1psi. +by rewrite cfdotZl (coherent_ortho_cycTIiso MtypeP sS10) ?irrS1 ?mulr0. +Qed. + +(* This is a specialization of the above, used in (10.5) and (10.10). *) +Let def_tau_alpha calS1 tau1 i j : + coherent_with calS1 M^# tau tau1 -> cfConjC_subset calS1 calS0 -> + j != 0 -> zeta \in calS1 -> '[(alpha_ i j)^\tau, tau1 zeta] = - n -> + (alpha_ i j)^\tau = delta *: (eta_ i j - eta_ i 0) - n *: tau1 zeta. +Proof. +move=> cohS1 [_ sS10 ccS1] nz_j S1zeta alpha_zeta_n. +have [[_ _ _ Nn] [[Itau1 _] _]] := (FTtype345_constants, cohS1). +set Y := - (n *: _); apply: canRL (addrK _) _; set X := _ + _. +have Dalpha: (alpha_ i j)^\tau = X + Y by rewrite addrK. +have nY_n2: '[Y] = n ^+ 2. + by rewrite cfnormN cfnormZ norm_Cnat // Itau1 ?mem_zchar // irrWnorm ?mulr1. +pose S2 := zeta :: zeta^*%CF; pose S2tau1 := map tau1 S2. +have S2_Y: Y \in 'Z[S2tau1] by rewrite rpredN rpredZ_Cnat ?mem_zchar ?mem_head. +have sS21: {subset S2 <= calS1} by apply/allP; rewrite /= ccS1 ?S1zeta. +have cohS2 : coherent_with S2 M^# tau tau1 := subset_coherent_with sS21 cohS1. +have irrS2: {subset S2 <= irr M} by apply/allP; rewrite /= cfAut_irr irr_zeta. +rewrite (FTtype345_bridge_coherence cohS2 Dalpha) //; last first. + rewrite -[X]opprK cfdotNr opprD cfdotDr nY_n2 cfdotNl cfdotNr opprK cfdotZl. + by rewrite cfdotC alpha_zeta_n rmorphN conj_Cnat // mulrN addNr oppr0. +split=> [|_ /sS21/sS10//|]; last first. + by apply/allP; rewrite /= !inE cfConjCK !eqxx orbT. +by rewrite /= inE eq_sym; have [[_ /hasPn-> //]] := scohS0; apply: sS10. +Qed. + +Section NonCoherence. + +(* We will ultimately contradict these assumptions. *) +(* Note that we do not need to export any lemma save the final contradiction. *) +Variable tau1 : {additive 'CF(M) -> 'CF(G)}. +Hypothesis cohS : coherent_with calS M^# tau tau1. + +Local Notation "mu ^\tau1" := (tau1 mu%CF) + (at level 2, format "mu ^\tau1") : ring_scope. + +Let Dtau1 : {in 'Z[calS, M'^#], tau1 =1 tau}. +Proof. by case: cohS => _; apply: sub_in1; apply: zchar_onS; apply: setSD. Qed. + +Let o_zeta_s: '[zeta, zeta^*] = 0. +Proof. by rewrite (seqInd_conjC_ortho _ _ _ Szeta) ?mFT_odd /= ?defMs. Qed. + +Import ssrint rat. + +(* This is the second part of Peterfalvi (10.5). *) +Let tau_alpha i j : j != 0 -> + (alpha_ i j)^\tau = delta *: (eta_ i j - eta_ i 0) - n *: zeta^\tau1. +Proof. +move=> nz_j; set al_ij := alpha_ i j; have [[Itau1 Ztau1] _] := cohS. +have [mu1 Ddelta d_gt1 Nn] := FTtype345_constants. +pose a := '[al_ij^\tau, zeta^\tau1] + n. +have al_ij_zeta_s: '[al_ij^\tau, zeta^*^\tau1] = a. + apply: canRL (addNKr _) _; rewrite addrC -opprB -cfdotBr -raddfB. + have M'dz: zeta - zeta^*%CF \in 'Z[calS, M'^#] by apply: seqInd_sub_aut_zchar. + rewrite Dtau1 // Dade_isometry ?alpha_on ?tauM' //. + rewrite cfdotBr opprB cfdotBl cfdot_conjCr rmorphB linearZ /=. + rewrite -!prTIirr_aut !cfdotBl !cfdotZl !o_mu2_zeta o_zeta_s !mulr0. + by rewrite opprB !(subr0, rmorph0) add0r irrWnorm ?mulr1. +have Zal_ij: al_ij^\tau \in 'Z[irr G] by apply: Zalpha_tau. +have Za: a \in Cint. + by rewrite rpredD ?(Cint_Cnat Nn) ?Cint_cfdot_vchar ?Ztau1 ?(mem_zchar Szeta). +have{al_ij_zeta_s} ub_da2: (d ^ 2)%:R * a ^+ 2 <= (2%:R + n ^+ 2) * w1%:R. + have [k nz_k j'k]: exists2 k, k != 0 & k != j. + have:= w2gt2; rewrite -nirrW2 (cardD1 0) (cardD1 j) !inE nz_j !ltnS lt0n. + by case/pred0Pn=> k /and3P[]; exists k. + have muk_1: mu_ k 1%g = (d * w1)%:R. + by rewrite (prTIred_1 pddM) mu1 // mulrC -natrM. + rewrite natrX -exprMn; have <-: '[al_ij^\tau, (mu_ k)^\tau1] = d%:R * a. + rewrite mulrDr mulr_natl -raddfMn /=; apply: canRL (addNKr _) _. + rewrite addrC -cfdotBr -raddfMn -raddfB -scaler_nat. + rewrite Dtau1 ?Dade_isometry ?alpha_on ?tauM' ?ZmuBzeta // cfdotBr cfdotZr. + rewrite rmorph_nat !cfdotBl !cfdotZl !o_mu2_zeta irrWnorm //. + rewrite !(cfdot_prTIirr_red pddM) cfdotC o_mu_zeta conjC0 !mulr0 mulr1. + by rewrite 2![_ == k](negPf _) 1?eq_sym // mulr0 -mulrN opprB !subr0 add0r. + have ZSmuk: mu_ k \in 'Z[calS] by rewrite mem_zchar ?calSmu. + have <-: '[al_ij^\tau] * '[(mu_ k)^\tau1] = (2%:R + n ^+ 2) * w1%:R. + by rewrite Itau1 // cfdot_prTIred eqxx mul1n norm_alpha. + by rewrite -Cint_normK ?cfCauchySchwarz // Cint_cfdot_vchar // Ztau1. +suffices a0 : a = 0. + by apply: (def_tau_alpha _ sSS0); rewrite // -sub0r -a0 addrK. +apply: contraTeq (d_gt1) => /(sqr_Cint_ge1 Za) a2_ge1. +suffices: n == 0. + rewrite mulf_eq0 invr_eq0 orbC -implyNb neq0CG /= subr_eq0 => /eqP Dd. + by rewrite -ltC_nat -(normr_nat _ d) Dd normr_sign ltrr. +suffices: n ^+ 2 < n + 1. + have d_dv_M: (d%:R %| #|M|)%C by rewrite -(mu1 0 j) // ?dvd_irr1_cardG. + have{d_dv_M} d_odd: odd d by apply: dvdn_odd (mFT_odd M); rewrite -dvdC_nat. + have: (2 %| n * w1%:R)%C. + rewrite divfK ?neq0CG // -signrN signrE addrA -(natrD _ d 1). + by rewrite rpredB // dvdC_nat dvdn2 ?odd_double // odd_add d_odd. + rewrite -(truncCK Nn) -mulrSr -natrM -natrX ltC_nat (dvdC_nat 2) pnatr_eq0. + rewrite dvdn2 odd_mul mFT_odd; case: (truncC n) => [|[|n1]] // _ /idPn[]. + by rewrite -leqNgt (ltn_exp2l 1). +apply: ltr_le_trans (_ : n * - delta + 1 <= _); last first. + have ->: n + 1 = n * `|- delta| + 1 by rewrite normrN normr_sign mulr1. + rewrite ler_add2r ler_wpmul2l ?Cnat_ge0 ?real_ler_norm //. + by rewrite rpredN ?rpred_sign. +rewrite -(ltr_pmul2r (ltC_nat 0 2)) mulrDl mul1r -[rhs in rhs + _]mulrA. +apply: ler_lt_trans (_ : n ^+ 2 * (w1%:R - 1) < _). + rewrite -(subnKC w1gt2) -(@natrB _ _ 1) // ler_wpmul2l ?leC_nat //. + by rewrite Cnat_ge0 ?rpredX. +rewrite -(ltr_pmul2l (gt0CG W1)) -/w1 2!mulrBr mulr1 mulrCA -exprMn. +rewrite mulrDr ltr_subl_addl addrCA -mulrDr mulrCA mulrA -ltr_subl_addl. +rewrite -mulrBr mulNr opprK divfK ?neq0CG // mulr_natr addrA subrK -subr_sqr. +rewrite sqrr_sign mulrC [_ + 2%:R]addrC (ltr_le_trans _ ub_da2) //. +apply: ltr_le_trans (ler_wpmul2l (ler0n _ _) a2_ge1). +by rewrite mulr1 ltr_subl_addl -mulrS -natrX ltC_nat. +Qed. + +(* This is the first part of Peterfalvi (10.6)(a). *) +Let tau1mu j : j != 0 -> (mu_ j)^\tau1 = delta *: \sum_i eta_ i j. +Proof. +move=> nz_j; have [[[Itau1 _] _] Smu_j] := (cohS, calSmu nz_j). +have eta_mu i: '[delta *: (eta_ i j - eta_ i 0), (mu_ j)^\tau1] = 1. + have Szeta_s: zeta^*%CF \in calS by rewrite cfAut_seqInd. + have o_zeta_s_w k: '[eta_ i k, d%:R *: zeta^*^\tau1] = 0. + have o_S_eta_ := coherent_ortho_cycTIiso MtypeP sSS0 cohS. + by rewrite cfdotZr cfdotC o_S_eta_ ?conjC0 ?mulr0 // cfAut_irr. + pose psi := mu_ j - d%:R *: zeta^*%CF; rewrite (canRL (subrK _) (erefl psi)). + rewrite (raddfD tau1) raddfZnat cfdotDr addrC cfdotZl cfdotBl !{}o_zeta_s_w. + rewrite subr0 mulr0 add0r -(canLR (subrK _) (tau_alpha i nz_j)). + have Zpsi: psi \in 'Z[calS, M'^#]. + by rewrite ZmuBzeta // cfunE zeta1w1 rmorph_nat. + rewrite cfdotDl cfdotZl Itau1 ?(zcharW Zpsi) ?mem_zchar // -cfdotZl Dtau1 //. + rewrite Dade_isometry ?alpha_on ?tauM' {Zpsi}// -cfdotDl cfdotBr cfdotZr. + rewrite subrK !cfdotBl !cfdotZl !cfdot_prTIirr_red eq_sym (negPf nz_j). + by rewrite !o_mu2_irr ?cfAut_irr // !(mulr0, subr0) eqxx. +have [_ Ddel _ _] := FTtype345_constants. +have [[d1 k] Dtau1mu] := FTtypeP_coherent_TIred sSS0 cohS irr_zeta Szeta Smu_j. +case=> [[Dd1 Dk] | [_ Dk _]]; first by rewrite Dtau1mu Dd1 Dk [_ ^+ _]Ddel. +have /esym/eqP/idPn[] := eta_mu 0; rewrite Dtau1mu Dk /= cfdotZl cfdotZr. +rewrite cfdot_sumr big1 ?mulr0 ?oner_eq0 // => i _; rewrite -/sigma -/(w_ i _). +rewrite cfdotBl !(cfdot_cycTIiso pddM) !(eq_sym 0) conjC_Iirr_eq0 -!irr_eq1. +rewrite (eq_sym j) -(inj_eq irr_inj) conjC_IirrE. +by rewrite odd_eq_conj_irr1 ?mFT_odd ?subrr. +Qed. + +(* This is the second part of Peterfalvi (10.6)(a). *) +Let tau1mu0 : (mu_ 0 - zeta)^\tau = \sum_i eta_ i 0 - zeta^\tau1. +Proof. +have [j nz_j] := has_nonprincipal_irr ntW2. +have sum_al: \sum_i alpha_ i j = mu_ j - d%:R *: zeta - delta *: (mu_ 0 - zeta). + rewrite scalerBr opprD addrACA scaler_sumr !sumrB sumr_const; congr (_ + _). + by rewrite -opprD -scalerBl nirrW1 -scaler_nat scalerA mulrC divfK ?neq0CG. +have ->: mu_ 0 - zeta = delta *: (mu_ j - d%:R *: zeta - \sum_i alpha_ i j). + by rewrite sum_al opprD addNKr opprK signrZK. +rewrite linearZ linearB; apply: canLR (signrZK _) _; rewrite -/delta /=. +rewrite linear_sum -Dtau1 ?ZmuBzeta //= raddfB raddfZnat addrAC scalerBr. +rewrite (eq_bigr _ (fun i _ => tau_alpha i nz_j)) sumrB sumr_const nirrW1 opprD. +rewrite -scaler_sumr sumrB scalerBr -tau1mu // opprD !opprK -!addrA addNKr. +congr (_ + _); rewrite -scaler_nat scalerA mulrC divfK ?neq0CG //. +by rewrite addrC -!scaleNr -scalerDl addKr. +Qed. + +(* This is Peterfalvi (10.6)(b). *) +Let zeta_tau1_coprime g : + g \notin 'A~(M) -> coprime #[g] w1 -> `|zeta^\tau1 g| >= 1. +Proof. +move=> notAg co_g_w1; have Amu0zeta := mu0Bzeta_on Szeta zeta1w1. +have mu0_zeta_g: (mu_ 0 - zeta)^\tau g = 0. + have [ | ] := boolP (g \in 'A0~(M)); rewrite -FT_Dade0_supportE; last first. + by apply: cfun_on0; apply: Dade_cfunS. + case/bigcupP=> x A0x xRg; rewrite (DadeE _ A0x) // (cfun_on0 Amu0zeta) //. + apply: contra notAg => Ax; apply/bigcupP; exists x => //. + by rewrite -def_FTsignalizer0. +have{mu0_zeta_g} zeta_g: zeta^\tau1 g = \sum_i eta_ i 0 g. + by apply/esym/eqP; rewrite -subr_eq0 -{2}mu0_zeta_g tau1mu0 !cfunE sum_cfunE. +have Zwg i: eta_ i 0 g \in Cint. + have Lchi: 'chi_i \is a linear_char by apply: irr_cyclic_lin. + rewrite Cint_cycTIiso_coprime // dprod_IirrE irr0 cfDprod_cfun1r. + rewrite (coprime_dvdr _ co_g_w1) // dvdn_cforder. + rewrite -rmorphX cfDprodl_eq1 -dvdn_cforder; apply/dvdn_cforderP=> x W1x. + by rewrite -lin_charX // -expg_mod_order (eqnP (order_dvdG W1x)) lin_char1. +have odd_zeta_g: (zeta^\tau1 g == 1 %[mod 2])%C. + rewrite zeta_g (bigD1 0) //= [w_ 0 0]cycTIirr00 cycTIiso1 cfun1E inE. + pose eW1 := [pred i : Iirr W1 | conjC_Iirr i < i]%N. + rewrite (bigID eW1) (reindex_inj (can_inj (@conjC_IirrK _ _))) /=. + set s1 := \sum_(i | _) _; set s2 := \sum_(i | _) _; suffices ->: s1 = s2. + by rewrite -mulr2n addrC -(mulr_natr _ 2) eqCmod_addl_mul ?rpred_sum. + apply/eq_big=> [i | i _]. + rewrite (canF_eq (@conjC_IirrK _ _)) conjC_Iirr0 conjC_IirrK -leqNgt. + rewrite ltn_neqAle val_eqE -irr_eq1 (eq_sym i) -(inj_eq irr_inj) andbA. + by rewrite aut_IirrE odd_eq_conj_irr1 ?mFT_odd ?andbb. + rewrite -{1}conjC_Iirr0 [w_ _ _]cycTIirr_aut -cfAut_cycTIiso. + by rewrite cfunE conj_Cint ?Zwg. +rewrite norm_Cint_ge1 //; first by rewrite zeta_g rpred_sum. +apply: contraTneq odd_zeta_g => ->. +by rewrite eqCmod_sym /eqCmod subr0 /= (dvdC_nat 2 1). +Qed. + +(* This is Peterfalvi (10.7). *) +Let Frob_der1_type2 S : + S \in 'M -> FTtype S == 2 -> [Frobenius S^`(1) with kernel S`_\F]. +Proof. +move: S => L maxL /eqP Ltype2. +have [S pairMS [xdefW [U StypeP]]] := FTtypeP_pair_witness maxM MtypeP. +have [[_ _ maxS] _] := pairMS; rewrite {1}(negPf notMtype2) /= => Stype2 _. +move/(_ L maxL)/implyP; rewrite Ltype2 /= => /setUP[] /imsetP[x0 _ defL]. + by case/eqP/idPn: Ltype2; rewrite defL FTtypeJ. +pose H := (S`_\F)%G; pose HU := (S^`(1))%G. +suffices{L Ltype2 maxL x0 defL}: [Frobenius HU = H ><| U]. + by rewrite defL derJ FcoreJ FrobeniusJker; apply: FrobeniusWker. +have sHHU: H \subset HU by have [_ [_ _ _ /sdprodW/mulG_sub[]]] := StypeP. +pose calT := seqIndD HU S H 1; pose tauS := FT_Dade0 maxS. +have DcalTs: calT = seqIndD HU S S`_\s 1. + by congr (seqIndD _ _ _ _); apply: val_inj; rewrite /= FTcore_type2. +have notFrobM: ~~ [Frobenius M with kernel M`_\F]. + by apply/existsP=> [[U1 /Frobenius_of_typeF/(typePF_exclusion MtypeP)]]. +have{notFrobM} notSsupportM: ~~ [exists x, FTsupports M (S :^ x)]. + apply: contra notFrobM => /'exists_existsP[x [y /and3P[Ay not_sCyM sCySx]]]. + have [_ [_ /(_ y)uMS] /(_ y)] := FTsupport_facts maxM. + rewrite inE (subsetP (FTsupp_sub0 _)) //= in uMS *. + rewrite -(eq_uniq_mmax (uMS not_sCyM) _ sCySx) ?mmaxJ // FTtypeJ. + by case=> // _ _ _ [_ ->]. +have{notSsupportM} tiA1M_AS: [disjoint 'A1~(M) & 'A~(S)]. + have notMG_S: gval S \notin M :^: G. + by apply: contraL Stype2 => /imsetP[x _ ->]; rewrite FTtypeJ. + by apply: negbNE; have [_ <- _] := FT_Dade_support_disjoint maxM maxS notMG_S. +pose pddS := FT_prDade_hypF maxS StypeP; pose nu := primeTIred pddS. +have{tiA1M_AS} oST phi psi: + phi \in 'Z[calS, M^#] -> psi \in 'Z[calT, S^#] -> '[phi^\tau, tauS psi] = 0. +- rewrite zcharD1_seqInd // -[seqInd _ _]/calS => Sphi. + rewrite zcharD1E => /andP[Tpsi psi1_0]. + rewrite -FT_Dade1E ?defA1 ?(zchar_on Sphi) //. + apply: cfdot_complement (Dade_cfunS _ _) _; rewrite FT_Dade1_supportE setTD. + rewrite -[tauS _]FT_DadeE ?(cfun_onS _ (Dade_cfunS _ _)) ?FT_Dade_supportE //. + by rewrite -disjoints_subset disjoint_sym. + have /subsetD1P[_ /setU1K <-] := FTsupp_sub S; rewrite cfun_onD1 {}psi1_0. + rewrite -Tpsi andbC -zchar_split {psi Tpsi}(zchar_trans_on _ Tpsi) //. + move=> psi Tpsi; rewrite zchar_split mem_zchar //=. + have [s /setDP[_ kerH's] ->] := seqIndP Tpsi. + by rewrite inE in kerH's; rewrite (prDade_Ind_irr_on pddS). +have notStype5: FTtype S != 5 by rewrite (eqP Stype2). +have [|[_ _ _ _ -> //]] := typeP_reducible_core_cases maxS StypeP notStype5. +case=> t []; set lambda := 'chi_t => T0C'lam lam_1 _. +have{T0C'lam} Tlam: lambda \in calT. + by apply: seqIndS T0C'lam; rewrite Iirr_kerDS ?sub1G. +have{lam_1} [r [nz_r Tnu_r nu_r_1]]: + exists r, [/\ r != 0, nu r \in calT & nu r 1%g = lambda 1%g]. +- have [_] := typeP_reducible_core_Ind maxS StypeP notStype5. + set H0 := Ptype_Fcore_kernel _; set nuT := filter _ _; rewrite -/nu. + case/hasP=> nu_r nuTr _ /(_ _ nuTr)/imageP[r nz_r Dr] /(_ _ nuTr)[nu_r1 _ _]. + have{nuTr} Tnu_r := mem_subseq (filter_subseq _ _) nuTr. + by exists r; rewrite -Dr nu_r1 (seqIndS _ Tnu_r) // Iirr_kerDS ?sub1G. +pose T2 := [:: lambda; lambda^*; nu r; (nu r)^*]%CF. +have [rmRS scohT]: exists rmRS, subcoherent calT tauS rmRS. + move: (FTtypeP_coh_base _ _) (FTtypeP_subcoherent maxS StypeP) => RS scohT. + by rewrite DcalTs; exists RS. +have [lam_irr nu_red]: lambda \in irr S /\ nu r \notin irr S. + by rewrite mem_irr prTIred_not_irr. +have [lam'nu lams'nu]: lambda != nu r /\ lambda^*%CF != nu r. + by rewrite -conjC_IirrE !(contraNneq _ nu_red) // => <-; apply: mem_irr. +have [[_ nRT ccT] _ _ _ _] := scohT. +have{ccT} sT2T: {subset T2 <= calT} by apply/allP; rewrite /= ?Tlam ?Tnu_r ?ccT. +have{nRT} uccT2: cfConjC_subset T2 calT. + split; last 1 [by [] | by apply/allP; rewrite /= !inE !cfConjCK !eqxx !orbT]. + rewrite /uniq /T2 !inE !negb_or -!(inv_eq (@cfConjCK _ S)) !cfConjCK. + by rewrite lam'nu lams'nu !(hasPn nRT). +have scohT2 := subset_subcoherent scohT uccT2. +have [tau2 cohT2]: coherent T2 S^# tauS. + apply: (uniform_degree_coherence scohT2); rewrite /= !cfunE nu_r_1 eqxx. + by rewrite conj_Cnat ?Cnat_irr1 ?eqxx. +have [s nz_s] := has_nonprincipal_irr ntW2; have Smu_s := calSmu nz_s. +pose alpha := mu_ s - d%:R *: zeta; pose beta := nu r - lambda. +have Salpha: alpha \in 'Z[calS, M^#] by rewrite zcharD1_seqInd ?ZmuBzeta. +have [T2lam T2nu_r]: lambda \in T2 /\ nu r \in T2 by rewrite !inE !eqxx !orbT. +have Tbeta: beta \in 'Z[T2, S^#]. + by rewrite zcharD1E rpredB ?mem_zchar //= !cfunE nu_r_1 subrr. +have /eqP/idPn[] := oST _ _ Salpha (zchar_subset sT2T Tbeta). +have [[_ <- //] [_ <- //]] := (cohS, cohT2). +rewrite !raddfB raddfZnat /= subr_eq0 !cfdotBl !cfdotZl. +have [|[dr r'] -> _] := FTtypeP_coherent_TIred _ cohT2 lam_irr T2lam T2nu_r. + by rewrite -DcalTs. +set sigS := cyclicTIiso _ => /=. +have etaC i j: sigS (cyclicTIirr xdefW j i) = eta_ i j by apply: cycTIisoC. +rewrite !cfdotZr addrC cfdot_sumr big1 => [|j _]; last first. + by rewrite etaC (coherent_ortho_cycTIiso _ sSS0) ?mem_irr. +rewrite !mulr0 oppr0 add0r rmorph_sign. +have ->: '[zeta^\tau1, tau2 lambda] = 0. + pose X1 := (zeta :: zeta^*)%CF; pose X2 := (lambda :: lambda^*)%CF. + pose Y1 := map tau1 X1; pose Y2 := map tau2 X2; have [_ _ ccS] := sSS0. + have [sX1S sX2T]: {subset X1 <= calS} /\ {subset X2 <= T2}. + by split; apply/allP; rewrite /= ?inE ?eqxx ?orbT // Szeta ccS. + have [/(sub_iso_to (zchar_subset sX1S) sub_refl)[Itau1 Ztau1] Dtau1L] := cohS. + have [/(sub_iso_to (zchar_subset sX2T) sub_refl)[Itau2 Ztau2] Dtau2] := cohT2. + have Z_Y12: {subset Y1 <= 'Z[irr G]} /\ {subset Y2 <= 'Z[irr G]}. + by rewrite /Y1 /Y2; split=> ? /mapP[xi /mem_zchar] => [/Ztau1|/Ztau2] ? ->. + have o1Y12: orthonormal Y1 && orthonormal Y2. + rewrite !map_orthonormal //. + by apply: seqInd_conjC_ortho2 Tlam; rewrite ?gFnormal ?mFT_odd. + by apply: seqInd_conjC_ortho2 Szeta; rewrite ?gFnormal ?mFT_odd ?mem_irr. + apply: orthonormal_vchar_diff_ortho Z_Y12 o1Y12 _; rewrite -2!raddfB. + have SzetaBs: zeta - zeta^*%CF \in 'Z[calS, M^#]. + by rewrite zcharD1_seqInd // seqInd_sub_aut_zchar. + have T2lamBs: lambda - lambda^*%CF \in 'Z[T2, S^#]. + rewrite sub_aut_zchar ?zchar_onG ?mem_zchar ?inE ?eqxx ?orbT //. + by move=> xi /sT2T/seqInd_vcharW. + by rewrite Dtau1L // Dtau2 // !Dade1 oST ?(zchar_subset sT2T) ?eqxx. +have [[ds s'] /= -> _] := FTtypeP_coherent_TIred sSS0 cohS irr_zeta Szeta Smu_s. +rewrite mulr0 subr0 !cfdotZl mulrA -signr_addb !cfdot_suml. +rewrite (bigD1 r') //= cfdot_sumr (bigD1 s') //=. +rewrite etaC cfdot_cycTIiso !eqxx big1 => [|j ne_s'_j]; last first. + by rewrite etaC cfdot_cycTIiso andbC eq_sym (negPf ne_s'_j). +rewrite big1 => [|i ne_i_r']; last first. + rewrite cfdot_sumr big1 // => j _. + by rewrite etaC cfdot_cycTIiso (negPf ne_i_r'). +rewrite !addr0 mulr1 big1 ?mulr0 ?signr_eq0 // => i _. +by rewrite -etaC cfdotC (coherent_ortho_cycTIiso _ _ cohT2) ?conjC0 -?DcalTs. +Qed. + +(* This is the bulk of the proof of Peterfalvi (10.8); however the result *) +(* will be restated below to avoid the quantification on zeta and tau1. *) +Lemma FTtype345_noncoherence_main : False. +Proof. +have [S pairMS [xdefW [U StypeP]]] := FTtypeP_pair_witness maxM MtypeP. +have [[_ _ maxS] _] := pairMS; rewrite {1}(negPf notMtype2) /= => Stype2 _ _. +pose H := (S`_\F)%G; pose HU := (S^`(1))%G. +have [[_ hallW2 _ defS] [_ _ nUW2 defHU] _ [_ _ sW1H _ _] _] := StypeP. +have ntU: U :!=: 1%g by have [[]] := compl_of_typeII maxS StypeP Stype2. +pose G01 := [set g : gT | coprime #[g] w1]. +pose G0 := ~: 'A~(M) :&: G01; pose G1 := ~: 'A~(M) :\: G01. +pose chi := zeta^\tau1; pose ddAM := FT_Dade_hyp maxM; pose rho := invDade ddAM. +have Suzuki: + #|G|%:R^-1 * (\sum_(g in ~: 'A~(M)) `|chi g| ^+ 2 - #|~: 'A~(M)|%:R) + + '[rho chi] - #|'A(M)|%:R / #|M|%:R <= 0. +- pose A_ (_ : 'I_1) := ddAM; pose Atau i := Dade_support (A_ i). + have tiA i j : i != j -> [disjoint Atau i & Atau j] by rewrite !ord1. + have Nchi1: '[chi] = 1 by have [[->]] := cohS; rewrite ?mem_zchar ?irrWnorm. + have:= Dade_cover_inequality tiA Nchi1; rewrite /= !big_ord1 -/rho -addrA. + by congr (_ * _ + _ <= 0); rewrite FT_Dade_supportE setTD. +have{Suzuki} ub_rho: '[rho chi] <= #|'A(M)|%:R / #|M|%:R + #|G1|%:R / #|G|%:R. + rewrite addrC -subr_le0 opprD addrCA (ler_trans _ Suzuki) // -addrA. + rewrite ler_add2r -(cardsID G01 (~: _)) (big_setID G01) -/G0 -/G1 /=. + rewrite mulrC mulrBr ler_subr_addl -mulrBr natrD addrK. + rewrite ler_wpmul2l ?invr_ge0 ?ler0n // -sumr_const ler_paddr //. + by apply: sumr_ge0 => g; rewrite exprn_ge0 ?normr_ge0. + apply: ler_sum => g; rewrite !inE => /andP[notAg] /(zeta_tau1_coprime notAg). + by rewrite expr_ge1 ?normr_ge0. +have lb_M'bar: (w1 * 2 <= #|M' / M''|%g.-1)%N. + suffices ->: w1 = #|W1 / M''|%g. + rewrite muln2 -ltnS prednK ?cardG_gt0 //. + by rewrite (ltn_odd_Frobenius_ker frobMbar) ?quotient_odd ?mFT_odd. + have [_ sW1M _ _ tiM'W1] := sdprod_context defM. + apply/card_isog/quotient_isog; first exact: subset_trans (der_norm 2 M). + by apply/trivgP; rewrite -tiM'W1 setSI ?normal_sub. +have lb_rho: 1 - w1%:R / #|M'|%:R <= '[rho chi]. + have cohS_A: coherent_with calS M^# (Dade ddAM) tau1. + have [Itau1 _] := cohS; split=> // phi; rewrite zcharD1_seqInd // => Sphi. + by rewrite Dtau1 // FT_DadeE // defA (zchar_on Sphi). + rewrite {ub_rho}/rho [w1](index_sdprod defM); rewrite defA in (ddAM) cohS_A *. + have [||_ [_ _ [] //]] := Dade_Ind1_sub_lin cohS_A _ irr_zeta Szeta. + - by apply: seqInd_nontrivial Szeta; rewrite ?mem_irr ?mFT_odd. + - by rewrite -(index_sdprod defM). + rewrite -(index_sdprod defM) ler_pdivl_mulr ?ltr0n // -natrM. + rewrite -leC_nat in lb_M'bar; apply: ler_trans lb_M'bar _. + rewrite ler_subr_addl -mulrS prednK ?cardG_gt0 // leC_nat. + by rewrite dvdn_leq ?dvdn_quotient. +have{lb_rho ub_rho}: 1 - #|G1|%:R/ #|G|%:R - w1%:R^-1 < w1%:R / #|M'|%:R :> algC. + rewrite -addrA -opprD ltr_subl_addr -ltr_subl_addl. + apply: ler_lt_trans (ler_trans lb_rho ub_rho) _; rewrite addrC ltr_add2l. + rewrite ltr_pdivr_mulr ?gt0CG // mulrC -(sdprod_card defM) natrM. + by rewrite mulfK ?neq0CG // defA ltC_nat (cardsD1 1%g M') group1. +have frobHU: [Frobenius HU with kernel H] by apply: Frob_der1_type2. +have tiH: normedTI H^# G S. + by have [_ _] := FTtypeII_ker_TI maxS Stype2; rewrite FTsupp1_type2. +have sG1_HVG: G1 \subset class_support H^# G :|: class_support V G. + apply/subsetP=> x; rewrite !inE coprime_has_primes ?cardG_gt0 // negbK. + case/andP=> /hasP[p W1p]; rewrite /= mem_primes => /and3P[p_pr _ p_dv_x] _. + have [a x_a a_p] := Cauchy p_pr p_dv_x. + have nta: a != 1%g by rewrite -order_gt1 a_p prime_gt1. + have ntx: x != 1%g by apply: contraTneq x_a => ->; rewrite /= cycle1 inE. + have cxa: a \in 'C[x] by rewrite -cent_cycle (subsetP (cycle_abelian x)). + have hallH: \pi(H).-Hall(G) H by apply: Hall_pi; have [] := FTcore_facts maxS. + have{a_p} p_a: p.-elt a by rewrite /p_elt a_p pnat_id. + have piHp: p \in \pi(H) by rewrite (piSg _ W1p). + have [y _ Hay] := Hall_pJsub hallH piHp (subsetT _) p_a. + do [rewrite -cycleJ cycle_subG; set ay := (a ^ y)%g] in Hay. + rewrite -[x](conjgK y); set xy := (x ^ y)%g. + have caxy: xy \in 'C[ay] by rewrite cent1J memJ_conjg cent1C. + have [ntxy ntay]: xy != 1%g /\ ay != 1%g by rewrite !conjg_eq1. + have Sxy: xy \in S. + have H1ay: ay \in H^# by apply/setD1P. + by rewrite (subsetP (cent1_normedTI tiH H1ay)) ?setTI. + have [HUxy | notHUxy] := boolP (xy \in HU). + rewrite memJ_class_support ?inE ?ntxy //=. + have [_ _ _ regHUH] := Frobenius_kerP frobHU. + by rewrite (subsetP (regHUH ay _)) // inE ?HUxy // inE ntay. + suffices /imset2P[xyz z Vxzy _ ->]: xy \in class_support V S. + by rewrite -conjgM orbC memJ_class_support. + rewrite /V setUC -(FTsupp0_typeP maxS StypeP) !inE Sxy. + rewrite andb_orr andNb (contra (subsetP _ _) notHUxy) /=; last first. + by apply/bigcupsP=> z _; rewrite (eqP Stype2) setDE -setIA subsetIl. + have /Hall_pi hallHU: Hall S HU by rewrite (sdprod_Hall defS). + rewrite (eqP Stype2) -(mem_normal_Hall hallHU) ?gFnormal // notHUxy. + have /mulG_sub[sHHU _] := sdprodW defHU. + rewrite (contra (fun p'xy => pi'_p'group p'xy (piSg sHHU piHp))) //. + by rewrite pgroupE p'natE // cycleJ cardJg p_dv_x. +have ub_G1: #|G1|%:R / #|G|%:R <= #|H|%:R / #|S|%:R + #|V|%:R / #|W|%:R :> algC. + rewrite ler_pdivr_mulr ?ltr0n ?cardG_gt0 // mulrC mulrDr !mulrA. + rewrite ![_ * _ / _]mulrAC -!natf_indexg ?subsetT //= -!natrM -natrD ler_nat. + apply: leq_trans (subset_leq_card sG1_HVG) _. + rewrite cardsU (leq_trans (leq_subr _ _)) //. + have unifJG B C: C \in B :^: G -> #|C| = #|B|. + by case/imsetP=> z _ ->; rewrite cardJg. + have oTI := card_uniform_partition (unifJG _) (partition_class_support _ _). + have{tiH} [ntH tiH /eqP defNH] := and3P tiH. + have [_ _ /and3P[ntV tiV /eqP defNV]] := ctiWG. + rewrite !oTI // !card_conjugates defNH defNV /= leq_add2r ?leq_mul //. + by rewrite subset_leq_card ?subsetDl. +rewrite ler_gtF // addrAC ler_subr_addl -ler_subr_addr (ler_trans ub_G1) //. +rewrite -(sdprod_card defS) -(sdprod_card defHU) addrC. +rewrite -mulnA !natrM invfM mulVKf ?natrG_neq0 // -/w1 -/w2. +have sW12_W: W1 :|: W2 \subset W by rewrite -(dprodWY defW) sub_gen. +rewrite cardsD (setIidPr sW12_W) natrB ?subset_leq_card // mulrBl. +rewrite divff ?natrG_neq0 // -!addrA ler_add2l. +rewrite cardsU -(dprod_card defW) -/w1 -/w2; have [_ _ _ ->] := dprodP defW. +rewrite cards1 natrB ?addn_gt0 ?cardG_gt0 // addnC natrD -addrA mulrDl mulrBl. +rewrite {1}mulnC !natrM !invfM !mulVKf ?natrG_neq0 // opprD -addrA ler_add2l. +rewrite mul1r -{1}[_^-1]mul1r addrC ler_oppr [- _]opprB -!mulrBl. +rewrite -addrA -opprD ler_pdivl_mulr; last by rewrite natrG_gt0. +apply: ler_trans (_ : 1 - (3%:R^-1 + 7%:R^-1) <= _); last first. + rewrite ler_add2l ler_opp2. + rewrite ler_add // lef_pinv ?qualifE ?gt0CG ?ltr0n ?ler_nat //. + have notStype5: FTtype S != 5 by rewrite (eqP Stype2). + have frobUW2 := Ptype_compl_Frobenius maxS StypeP notStype5. + apply: leq_ltn_trans (ltn_odd_Frobenius_ker frobUW2 (mFT_odd _)). + by rewrite (leq_double 3). +apply: ler_trans (_ : 2%:R^-1 <= _); last by rewrite -!CratrE; compute. +rewrite mulrAC ler_pdivr_mulr 1?gt0CG // ler_pdivl_mull ?ltr0n //. +rewrite -!natrM ler_nat mulnA -(Lagrange (normal_sub nsM''M')) mulnC leq_mul //. + by rewrite subset_leq_card //; have [_ _ _ []] := MtypeP. +by rewrite -card_quotient ?normal_norm // mulnC -(prednK (cardG_gt0 _)) leqW. +Qed. + +End NonCoherence. + +(* This is Peterfalvi (10.9). *) +Lemma FTtype345_Dade_bridge0 : + (w1 < w2)%N -> + {chi | [/\ (mu_ 0 - zeta)^\tau = \sum_i eta_ i 0 - chi, + chi \in 'Z[irr G], '[chi] = 1 + & forall i j, '[chi, eta_ i j] = 0]}. +Proof. +move=> w1_lt_w2; set psi := mu_ 0 - zeta; pose Wsig := map sigma (irr W). +have [X wsigX [chi [DpsiG _ o_chiW]]] := orthogonal_split Wsig psi^\tau. +exists (- chi); rewrite opprK rpredN cfnormN. +have o_chi_w i j: '[chi, eta_ i j] = 0. + by rewrite (orthoPl o_chiW) ?map_f ?mem_irr. +have [Isigma Zsigma] := cycTI_Zisometry ctiWG. +have o1Wsig: orthonormal Wsig by rewrite map_orthonormal ?irr_orthonormal. +have [a_ Da defX] := orthonormal_span o1Wsig wsigX. +have{Da} Da i j: a_ (eta_ i j) = '[psi^\tau, eta_ i j]. + by rewrite DpsiG cfdotDl o_chi_w addr0 Da. +have sumX: X = \sum_i \sum_j a_ (eta_ i j) *: eta_ i j. + rewrite pair_bigA defX big_map (big_nth 0) size_tuple big_mkord /=. + rewrite (reindex (dprod_Iirr defW)) /=. + by apply: eq_bigr => [[i j] /= _]; rewrite -tnth_nth. + by exists (inv_dprod_Iirr defW) => ij; rewrite (inv_dprod_IirrK, dprod_IirrK). +have Zpsi: psi \in 'Z[irr M]. + by rewrite rpredB ?irr_vchar ?(mem_zchar irr_zeta) ?char_vchar ?prTIred_char. +have{Zpsi} M'psi: psi \in 'Z[irr M, M'^#]. + by rewrite -defA zchar_split Zpsi mu0Bzeta_on. +have A0psi: psi \in 'CF(M, 'A0(M)). + by apply: cfun_onS (zchar_on M'psi); rewrite defA0 subsetUl. +have a_00: a_ (eta_ 0 0) = 1. + rewrite Da [w_ 0 0](cycTIirr00 defW) [sigma 1]cycTIiso1. + rewrite Dade_reciprocity // => [|x _ y _]; last by rewrite !cfun1E !inE. + rewrite rmorph1 /= -(prTIirr00 ptiWM) -/(mu2_ 0 0) cfdotC. + by rewrite cfdotBr o_mu2_zeta subr0 cfdot_prTIirr_red rmorph1. +have n2psiG: '[psi^\tau] = w1.+1%:R. + rewrite Dade_isometry // cfnormBd ?o_mu_zeta //. + by rewrite cfnorm_prTIred irrWnorm // -/w1 mulrSr. +have psiG_V0 x: x \in V -> psi^\tau x = 0. + move=> Vx; rewrite Dade_id ?defA0; last first. + by rewrite inE orbC mem_class_support. + rewrite (cfun_on0 (zchar_on M'psi)) // -defA. + suffices /setDP[]: x \in 'A0(M) :\: 'A(M) by []. + by rewrite (FTsupp0_typeP maxM MtypeP) // mem_class_support. +have ZpsiG: psi^\tau \in 'Z[irr G]. + by rewrite Dade_vchar // zchar_split (zcharW M'psi). +have n2psiGsum: '[psi^\tau] = \sum_i \sum_j `|a_ (eta_ i j)| ^+ 2 + '[chi]. + rewrite DpsiG addrC cfnormDd; last first. + by rewrite (span_orthogonal o_chiW) ?memv_span1. + rewrite addrC defX cfnorm_sum_orthonormal // big_map pair_bigA; congr (_ + _). + rewrite big_tuple /= (reindex (dprod_Iirr defW)) //. + by exists (inv_dprod_Iirr defW) => ij; rewrite (inv_dprod_IirrK, dprod_IirrK). +have NCpsiG: (cyclicTI_NC ctiWG psi^\tau < 2 * minn w1 w2)%N. + apply: (@leq_ltn_trans w1.+1); last first. + by rewrite /minn w1_lt_w2 mul2n -addnn (leq_add2r w1 2) cardG_gt1. + pose z_a := [pred ij | a_ (eta_ ij.1 ij.2) == 0]. + have ->: cyclicTI_NC ctiWG psi^\tau = #|[predC z_a]|. + by apply: eq_card => ij; rewrite !inE -Da. + rewrite -leC_nat -n2psiG n2psiGsum ler_paddr ?cfnorm_ge0 // pair_bigA. + rewrite (bigID z_a) big1 /= => [|ij /eqP->]; last by rewrite normCK mul0r. + rewrite add0r -sumr_const ler_sum // => [[i j] nz_ij]. + by rewrite expr_ge1 ?norm_Cint_ge1 // Da Cint_cfdot_vchar ?Zsigma ?irr_vchar. +have nz_psiG00: '[psi^\tau, eta_ 0 0] != 0 by rewrite -Da a_00 oner_eq0. +have [a_i|a_j] := small_cycTI_NC psiG_V0 NCpsiG nz_psiG00. + have psiGi: psi^\tau = \sum_i eta_ i 0 + chi. + rewrite DpsiG sumX; congr (_ + _); apply: eq_bigr => i _. + rewrite big_ord_recl /= Da a_i -Da a_00 mul1r scale1r. + by rewrite big1 ?addr0 // => j1 _; rewrite Da a_i mul0r scale0r. + split=> // [||i j]; last by rewrite cfdotNl o_chi_w oppr0. + rewrite -(canLR (addKr _) psiGi) rpredD // rpredN rpred_sum // => j _. + by rewrite Zsigma ?irr_vchar. + apply: (addrI w1%:R); rewrite -mulrSr -n2psiG n2psiGsum; congr (_ + _). + rewrite -nirrW1 // -sumr_const; apply: eq_bigr => i _. + rewrite big_ord_recl /= Da a_i -Da a_00 mul1r normr1. + by rewrite expr1n big1 ?addr0 // => j1 _; rewrite Da a_i normCK !mul0r. +suffices /idPn[]: '[psi^\tau] >= w2%:R. + rewrite odd_geq /= ?uphalf_half mFT_odd //= in w1_lt_w2. + by rewrite n2psiG leC_nat -ltnNge odd_geq ?mFT_odd. +rewrite n2psiGsum exchange_big /= ler_paddr ?cfnorm_ge0 //. +rewrite -nirrW2 -sumr_const; apply: ler_sum => i _. +rewrite big_ord_recl /= Da a_j -Da a_00 mul1r normr1. +by rewrite expr1n big1 ?addr0 // => j1 _; rewrite Da a_j normCK !mul0r. +Qed. + +Local Notation H := M'. +Local Notation "` 'H'" := `M' (at level 0) : group_scope. +Local Notation H' := M''. +Local Notation "` 'H''" := `M'' (at level 0) : group_scope. + +(* This is the bulk of the proof of Peterfalvi, Theorem (10.10); as with *) +(* (10.8), it will be restated below in order to remove dependencies on zeta, *) +(* U_M and W1. *) +Lemma FTtype5_exclusion_main : FTtype M != 5. +Proof. +apply/negP=> Mtype5. +suffices [tau1]: coherent calS M^# tau by case/FTtype345_noncoherence_main. +have [[_ U_M_1] MtypeV] := compl_of_typeV maxM MtypeP Mtype5. +have [_ [_ _ _ defH] _ [_ _ _ sW2H' _] _] := MtypeP. +have{U_M_1 defH} defMF: M`_\F = H by rewrite /= -defH U_M_1 sdprodg1. +have nilH: nilpotent `H by rewrite -defMF Fcore_nil. +have scohS := subset_subcoherent scohS0 sSS0. +have [|//|[[_]]] := (non_coherent_chief nsM'M (nilpotent_sol nilH) scohS) 1%G. + split; rewrite ?mFT_odd ?normal1 ?sub1G ?quotient_nil //. + by rewrite joingG1 (FrobeniusWker frobMbar). +rewrite /= joingG1 -(index_sdprod defM) /= -/w1 -[H^`(1)%g]/`H' => ubHbar [p[]]. +rewrite -(isog_abelian (quotient1_isog H)) -(isog_pgroup p (quotient1_isog H)). +rewrite subn1 => pH not_cHH /negP not_w1_dv_p'1. +have ntH: H :!=: 1%g by apply: contraNneq not_cHH => ->; apply: abelian1. +have [sH'H nH'H] := andP nsM''M'; have sW2H := subset_trans sW2H' sH'H. +have def_w2: w2 = p by apply/eqP; have:= pgroupS sW2H pH; rewrite pgroupE pnatE. +have [p_pr _ [e oH]] := pgroup_pdiv pH ntH. +rewrite -/w1 /= defMF oH pi_of_exp {e oH}// /pi_of primes_prime // in MtypeV. +have [tiHG | [_ /predU1P[->[]|]]// | [_ /predU1P[->|//] [oH w1p1 _]]] := MtypeV. + suffices [tau1 [Itau1 Dtau1]]: coherent (seqIndD H M H 1) M^# 'Ind[G]. + exists tau1; split=> // phi Sphi; rewrite {}Dtau1 //. + rewrite zcharD1_seqInd // -subG1 -setD_eq0 -defA in Sphi tiHG ntH. + by have Aphi := zchar_on Sphi; rewrite -FT_DadeE // Dade_Ind. + apply: (@Sibley_coherence _ [set:_] M H W1); first by rewrite mFT_odd. + right; exists W2 => //; exists 'A0(M), W, defW. + by rewrite -defA -{2}(group_inj defMs). +rewrite pcore_pgroup_id // in oH. +have esH: extraspecial H. + by apply: (p3group_extraspecial pH); rewrite // oH pfactorK. +have oH': #|H'| = p. + by rewrite -(card_center_extraspecial pH esH); have [[_ <-]] := esH. +have defW2: W2 :=: H' by apply/eqP; rewrite eqEcard sW2H' oH' -def_w2 /=. +have iH'H: #|H : H'|%g = (p ^ 2)%N by rewrite -divgS // oH oH' mulKn ?prime_gt0. +have w1_gt0: (0 < w1)%N by apply: cardG_gt0. +(* This is step (10.10.1). *) +have{ubHbar} [def_p_w1 w1_lt_w2]: (p = 2 * w1 - 1 /\ w1 < w2)%N. + have /dvdnP[k def_p]: 2 * w1 %| p.+1. + by rewrite Gauss_dvd ?coprime2n ?mFT_odd ?dvdn2 //= -{1}def_w2 mFT_odd. + suffices k1: k = 1%N. + rewrite k1 mul1n in def_p; rewrite -ltn_double -mul2n -def_p -addn1 addnK. + by rewrite -addnS -addnn def_w2 leq_add2l prime_gt1. + have [k0 | k_gt0] := posnP k; first by rewrite k0 in def_p. + apply/eqP; rewrite eqn_leq k_gt0 andbT -ltnS -ltn_double -mul2n. + rewrite -[(2 * k)%N]prednK ?muln_gt0 // ltnS -ltn_sqr 3?leqW //=. + rewrite -subn1 sqrn_sub ?muln_gt0 // expnMn muln1 mulnA ltnS leq_subLR. + rewrite addn1 addnS ltnS -mulnSr leq_pmul2l // -(leq_subLR _ 1). + rewrite (leq_trans (leq_pmulr _ w1_gt0)) // -(leq_pmul2r w1_gt0). + rewrite -mulnA mulnBl mul1n -2!leq_double -!mul2n mulnA mulnBr -!expnMn. + rewrite -(expnMn 2 _ 2) mulnCA -def_p -addn1 leq_subLR sqrnD muln1. + by rewrite (addnC p) mulnDr addnA leq_add2r addn1 addnS -iH'H. +(* This is step (10.10.2). *) +pose S1 := seqIndD H M H H'. +have sS1S: {subset S1 <= calS} by apply: seqIndS; rewrite Iirr_kerDS ?sub1G. +have irrS1: {subset S1 <= irr M}. + move=> _ /seqIndP[s /setDP[kerH' ker'H] ->]; rewrite !inE in kerH' ker'H. + rewrite -(quo_IirrK _ kerH') // mod_IirrE // cfIndMod // cfMod_irr //. + rewrite (irr_induced_Frobenius_ker (FrobeniusWker frobMbar)) //. + by rewrite quo_Iirr_eq0 // -subGcfker. +have S1w1: {in S1, forall xi : 'CF(M), xi 1%g = w1%:R}. + move=> _ /seqIndP[s /setDP[kerH' _] ->]; rewrite !inE in kerH'. + by rewrite cfInd1 // -(index_sdprod defM) lin_char1 ?mulr1 // lin_irr_der1. +have sS10: cfConjC_subset S1 calS0. + by apply: seqInd_conjC_subset1; rewrite /= defMs. +pose S2 := [seq mu_ j | j in predC1 0]. +have szS2: size S2 = p.-1. + by rewrite -def_w2 size_map -cardE cardC1 card_Iirr_abelian ?cyclic_abelian. +have uS2: uniq S2 by apply/dinjectiveP; apply: in2W (prTIred_inj pddM). +have redS2: {subset S2 <= [predC irr M]}. + by move=> _ /imageP[j _ ->]; apply: (prTIred_not_irr pddM). +have sS2S: {subset S2 <= calS} by move=> _ /imageP[j /calSmu Smu_j ->]. +have S1'2: {subset S2 <= [predC S1]}. + by move=> xi /redS2; apply: contra (irrS1 _). +have w1_dv_p21: w1 %| p ^ 2 - 1 by rewrite (subn_sqr p 1) addn1 dvdn_mull. +have [j nz_j] := has_nonprincipal_irr ntW2. +have [Dmu2_1 Ddelta_ lt1d Nn] := FTtype345_constants. +have{lt1d} [defS szS1 Dd Ddel Dn]: + [/\ perm_eq calS (S1 ++ S2), size S1 = (p ^ 2 - 1) %/ w1, + d = p, delta = -1 & n = 2%:R]. +- pose X_ (S0 : seq 'CF(M)) := [set s | 'Ind[M, H] 'chi_s \in S0]. + pose sumX_ cS0 := \sum_(s in X_ cS0) 'chi_s 1%g ^+ 2. + have defX1: X_ S1 = Iirr_kerD H H H'. + by apply/setP=> s; rewrite !inE mem_seqInd // !inE. + have defX: X_ calS = Iirr_kerD H H 1%g. + by apply/setP=> s; rewrite !inE mem_seqInd ?normal1 //= !inE. + have sumX1: sumX_ S1 = (p ^ 2)%:R - 1. + by rewrite /sumX_ defX1 sum_Iirr_kerD_square // iH'H indexgg mul1r. + have ->: size S1 = (p ^ 2 - 1) %/ w1. + apply/eqP; rewrite eqn_div // -eqC_nat mulnC [w1](index_sdprod defM). + rewrite (size_irr_subseq_seqInd _ (subseq_refl S1)) //. + rewrite natrB ?expn_gt0 ?prime_gt0 // -sumr_const -sumX1. + apply/eqP/esym/eq_bigr => s. + by rewrite defX1 !inE -lin_irr_der1 => /and3P[_ _ /eqP->]; rewrite expr1n. + have oX2: #|X_ S2| = p.-1. + by rewrite -(size_red_subseq_seqInd_typeP MtypeP uS2 sS2S). + have sumX2: (p ^ 2 * p.-1)%:R <= sumX_ S2 ?= iff (d == p). + rewrite /sumX_ (eq_bigr (fun _ => d%:R ^+ 2)) => [|s]; last first. + rewrite inE => /imageP[j1 nz_j1 Dj1]; congr (_ ^+ 2). + apply: (mulfI (neq0CiG M H)); rewrite -cfInd1 // -(index_sdprod defM). + by rewrite Dj1 (prTIred_1 pddM) Dmu2_1. + rewrite sumr_const oX2 mulrnA (mono_lerif (ler_pmuln2r _)); last first. + by rewrite -def_w2 -(subnKC w2gt2). + rewrite natrX (mono_in_lerif ler_sqr) ?rpred_nat // eq_sym lerif_nat. + apply/leqif_eq; rewrite dvdn_leq 1?ltnW //. + have: (mu2_ 0 j 1%g %| (p ^ 3)%N)%C. + by rewrite -(cfRes1 H) cfRes_prTIirr -oH dvd_irr1_cardG. + rewrite Dmu2_1 // dvdC_nat => /dvdn_pfactor[//|[_ d1|e _ ->]]. + by rewrite d1 in lt1d. + by rewrite expnS dvdn_mulr. + pose S3 := filter [predC S1 ++ S2] calS. + have sumX3: 0 <= sumX_ S3 ?= iff nilp S3. + rewrite /sumX_; apply/lerifP. + have [-> | ] := altP nilP; first by rewrite big_pred0 // => s; rewrite !inE. + rewrite -lt0n -has_predT => /hasP[xi S3xi _]. + have /seqIndP[s _ Dxi] := mem_subseq (filter_subseq _ _) S3xi. + rewrite (bigD1 s) ?inE -?Dxi //= ltr_spaddl ?sumr_ge0 // => [|s1 _]. + by rewrite exprn_gt0 ?irr1_gt0. + by rewrite ltrW ?exprn_gt0 ?irr1_gt0. + have [_ /esym] := lerif_add sumX2 sumX3. + have /(canLR (addKr _)) <-: sumX_ calS = sumX_ S1 + (sumX_ S2 + sumX_ S3). + rewrite [sumX_ _](big_setID (X_ S1)); congr (_ + _). + by apply: eq_bigl => s; rewrite !inE andb_idl // => /sS1S. + rewrite (big_setID (X_ S2)); congr (_ + _); apply: eq_bigl => s. + by rewrite !inE andb_idl // => S2s; rewrite [~~ _]S1'2 ?sS2S. + by rewrite !inE !mem_filter /= mem_cat orbC negb_or andbA. + rewrite sumX1 /sumX_ defX sum_Iirr_kerD_square ?sub1G ?normal1 // indexgg. + rewrite addr0 mul1r indexg1 oH opprD addrACA addNr addr0 addrC. + rewrite (expnSr p 2) -[p in (_ ^ 2 * p)%:R - _]prednK ?prime_gt0 // mulnSr. + rewrite natrD addrK eqxx => /andP[/eqP Dd /nilP S3nil]. + have uS12: uniq (S1 ++ S2). + by rewrite cat_uniq seqInd_uniq uS2 andbT; apply/hasPn. + rewrite uniq_perm_eq ?seqInd_uniq {uS12}// => [|xi]; last first. + apply/idP/idP; apply: allP xi; last by rewrite all_cat !(introT allP _). + by rewrite -(canLR negbK (has_predC _ _)) has_filter -/S3 S3nil. + have: (w1 %| d%:R - delta)%C. + by rewrite unfold_in pnatr_eq0 eqn0Ngt w1_gt0 rpred_Cnat. + rewrite /n Dd def_p_w1 /delta; case: (Idelta _) => [_|/idPn[] /=]. + by rewrite opprK -(natrD _ _ 1) subnK ?muln_gt0 // natrM mulfK ?neq0CG. + rewrite mul2n -addnn -{1}(subnKC (ltnW w1gt2)) !addSn mulrSr addrK dvdC_nat. + by rewrite add0n dvdn_addl // -(subnKC w1gt2) gtnNdvd // leqW. +have scohS1 := subset_subcoherent scohS0 sS10. +have o1S1: orthonormal S1. + rewrite orthonormalE andbC; have [_ _ -> _ _] := scohS1. + by apply/allP=> xi /irrS1/irrP[t ->]; rewrite /= cfnorm_irr. +have [tau1 cohS1]: coherent S1 M^# tau. + apply: uniform_degree_coherence scohS1 _; apply: all_pred1_constant w1%:R _ _. + by rewrite all_map; apply/allP=> xi /S1w1/= ->. +have [[Itau1 Ztau1] Dtau1] := cohS1. +have o1S1tau: orthonormal (map tau1 S1) by apply: map_orthonormal. +have S1zeta: zeta \in S1. + by have:= Szeta; rewrite (perm_eq_mem defS) mem_cat => /orP[//|/redS2/negP]. +(* This is the main part of step 10.10.3; as the definition of alpha_ remains *) +(* valid we do not need to reprove alpha_on. *) +have Dalpha i (al_ij := alpha_ i j) : + al_ij^\tau = delta *: (eta_ i j - eta_ i 0) - n *: tau1 zeta. +- have [Y S1_Y [X [Dal_ij _ oXY]]] := orthogonal_split (map tau1 S1) al_ij^\tau. + have [a_ Da_ defY] := orthonormal_span o1S1tau S1_Y. + have oXS1 lam : lam \in S1 -> '[X, tau1 lam] = 0. + by move=> S1lam; rewrite (orthoPl oXY) ?map_f. + have{Da_} Da_ lam : lam \in S1 -> a_ (tau1 lam) = '[al_ij^\tau, tau1 lam]. + by move=> S1lam; rewrite Dal_ij cfdotDl oXS1 // addr0 Da_. + pose a := n + a_ (tau1 zeta); have [_ oS1S1] := orthonormalP o1S1. + have Da_z: a_ (tau1 zeta) = - n + a by rewrite addKr. + have Za: a \in Cint. + rewrite rpredD ?Dn ?rpred_nat // Da_ // Cint_cfdot_vchar ?Zalpha_tau //=. + by rewrite Ztau1 ?mem_zchar. + have Da_z' lam: lam \in S1 -> lam != zeta -> a_ (tau1 lam) = a. + move=> S1lam zeta'lam; apply: canRL (subrK _) _. + rewrite !Da_ // -cfdotBr -raddfB. + have S1dlam: lam - zeta \in 'Z[S1, M^#]. + by rewrite zcharD1E rpredB ?mem_zchar //= !cfunE !S1w1 ?subrr. + rewrite Dtau1 // Dade_isometry ?alpha_on ?tauM' //; last first. + by rewrite -zcharD1_seqInd ?(zchar_subset sS1S). + have o_mu2_lam k: '[mu2_ i k, lam] = 0 by rewrite o_mu2_irr ?sS1S ?irrS1. + rewrite !cfdotBl !cfdotZl !cfdotBr !o_mu2_lam !o_mu2_zeta !(subr0, mulr0). + by rewrite irrWnorm ?oS1S1 // eq_sym (negPf zeta'lam) !add0r mulrN1 opprK. + have lb_n2alij: (a - n) ^+ 2 + (size S1 - 1)%:R * a ^+ 2 <= '[al_ij^\tau]. + rewrite Dal_ij cfnormDd; last first. + by rewrite cfdotC (span_orthogonal oXY) ?rmorph0 // memv_span1. + rewrite ler_paddr ?cfnorm_ge0 // defY cfnorm_sum_orthonormal //. + rewrite (big_rem (tau1 zeta)) ?map_f //= ler_eqVlt; apply/predU1P; left. + congr (_ + _). + by rewrite Da_z addrC Cint_normK 1?rpredD // rpredN Dn rpred_nat. + rewrite (eq_big_seq (fun _ => a ^+ 2)) => [|tau1lam]; last first. + rewrite rem_filter ?free_uniq ?orthonormal_free // filter_map. + case/mapP=> lam; rewrite mem_filter /= andbC => /andP[S1lam]. + rewrite (inj_in_eq (Zisometry_inj Itau1)) ?mem_zchar // => zeta'lam ->. + by rewrite Da_z' // Cint_normK. + rewrite big_tnth sumr_const card_ord size_rem ?map_f // size_map. + by rewrite mulr_natl subn1. + have{lb_n2alij} ub_a2: (size S1)%:R * a ^+ 2 <= 2%:R * a * n + 2%:R. + rewrite norm_alpha // addrC sqrrB !addrA ler_add2r in lb_n2alij. + rewrite mulr_natl -mulrSr ler_subl_addl subn1 in lb_n2alij. + by rewrite -mulrA !mulr_natl; case: (S1) => // in S1zeta lb_n2alij *. + have{ub_a2} ub_8a2: 8%:R * a ^+ 2 <= 4%:R * a + 2%:R. + rewrite mulrAC Dn -natrM in ub_a2; apply: ler_trans ub_a2. + rewrite -Cint_normK // ler_wpmul2r ?exprn_ge0 ?normr_ge0 // leC_nat szS1. + rewrite (subn_sqr p 1) def_p_w1 subnK ?muln_gt0 // mulnA mulnK // mulnC. + by rewrite -subnDA -(mulnBr 2 _ 1%N) mulnA (@leq_pmul2l 4 2) ?ltn_subRL. + have Z_4a1: 4%:R * a - 1%:R \in Cint by rewrite rpredB ?rpredM ?rpred_nat. + have{ub_8a2} ub_4a1: `|4%:R * a - 1| < 3%:R. + rewrite -ltr_sqr ?rpred_nat ?qualifE ?normr_ge0 // -natrX Cint_normK //. + rewrite sqrrB1 exprMn -natrX -mulrnAl -mulrnA (natrD _ 8 1) ltr_add2r. + rewrite (natrM _ 2 4) (natrM _ 2 8) -!mulrA -mulrBr ltr_pmul2l ?ltr0n //. + by rewrite ltr_subl_addl (ler_lt_trans ub_8a2) // ltr_add2l ltr_nat. + have{ub_4a1} a0: a = 0. + apply: contraTeq ub_4a1 => a_nz; have:= norm_Cint_ge1 Za a_nz. + rewrite real_ltr_norml ?real_ler_normr ?Creal_Cint //; apply: contraL. + case/andP; rewrite ltr_subl_addr -(natrD _ 3 1) gtr_pmulr ?ltr0n //. + rewrite ltr_oppl opprB -mulrN => /ltr_le_trans/=/(_ _ (leC_nat 3 5)). + by rewrite (natrD _ 1 4) ltr_add2l gtr_pmulr ?ltr0n //; do 2!move/ltr_geF->. + apply: (def_tau_alpha cohS1 sS10 nz_j S1zeta). + by rewrite -Da_ // Da_z a0 addr0. +have o_eta__zeta i j1: '[tau1 zeta, eta_ i j1] = 0. + by rewrite (coherent_ortho_cycTIiso _ sS10 cohS1) ?mem_irr. +(* This is step (10.4), the final one. *) +have Dmu0zeta: (mu_ 0 - zeta)^\tau = \sum_i eta_ i 0 - tau1 zeta. + have A0mu0tau: mu_ 0 - zeta \in 'CF(M, 'A0(M)). + rewrite /'A0(M) defA; apply: (cfun_onS (subsetUl _ _)). + rewrite cfun_onD1 [mu_ 0](prTIred0 pddM) !cfunE zeta1w1 cfuniE // group1. + by rewrite mulr1 subrr rpredB ?rpredZnat ?cfuni_on ?(seqInd_on _ Szeta) /=. + have [chi [Dmu0 Zchi n1chi o_chi_w]] := FTtype345_Dade_bridge0 w1_lt_w2. + have dirr_chi: chi \in dirr G by rewrite dirrE Zchi n1chi /=. + have dirr_zeta: tau1 zeta \in dirr G. + by rewrite dirrE Ztau1 ?Itau1 ?mem_zchar //= irrWnorm. + have: '[(alpha_ 0 j)^\tau, (mu_ 0 - zeta)^\tau] == - delta + n. + rewrite Dade_isometry ?alpha_on // !cfdotBl !cfdotZl !cfdotBr. + rewrite !o_mu2_zeta 2!cfdot_prTIirr_red (negPf nz_j) cfdotC o_mu_zeta. + by rewrite eqxx irrWnorm // conjC0 !(subr0, add0r) mulr1 mulrN1 opprK. + rewrite Dalpha // Dmu0 !{1}(cfdotBl, cfdotZl) !cfdotBr 2!{1}(cfdotC _ chi). + rewrite !o_chi_w conjC0 !cfdot_sumr big1 => [|i]; first last. + by rewrite (cfdot_cycTIiso pddM) (negPf nz_j) andbF. + rewrite (bigD1 0) //= cfdot_cycTIiso big1 => [|i nz_i]; first last. + by rewrite cfdot_cycTIiso eq_sym (negPf nz_i). + rewrite big1 // !subr0 !add0r addr0 mulrN1 mulrN opprK (can_eq (addKr _)). + rewrite {2}Dn -mulr_natl Dn (inj_eq (mulfI _)) ?pnatr_eq0 //. + by rewrite cfdot_dirr_eq1 // => /eqP->. +have [] := uniform_prTIred_coherent pddM nz_j; rewrite -/sigma. +have ->: uniform_prTIred_seq pddM j = S2. + congr (map _ _); apply: eq_enum => k; rewrite !inE -!/(mu_ _). + by rewrite andb_idr // => nz_k; rewrite 2!{1}prTIred_1 2?Dmu2_1. +case=> _ _ ccS2 _ _ [tau2 Dtau2 cohS2]. +have{cohS2} cohS2: coherent_with S2 M^# tau tau2 by apply: cohS2. +have sS20: cfConjC_subset S2 calS0. + by split=> // xi /sS2S Sxi; have [_ ->] := sSS0. +rewrite perm_eq_sym perm_catC in defS; apply: perm_eq_coherent defS _. +suffices: (mu_ j - d%:R *: zeta)^\tau = tau2 (mu_ j) - tau1 (d%:R *: zeta). + apply: (bridge_coherent scohS0 sS20 cohS2 sS10 cohS1) => [phi|]. + by apply: contraL => /S1'2. + rewrite cfunD1E !cfunE zeta1w1 prTIred_1 mulrC Dmu2_1 // subrr. + by rewrite image_f // rpredZnat ?mem_zchar. +have sumA: \sum_i alpha_ i j = mu_ j - delta *: mu_ 0 - (d%:R - delta) *: zeta. + rewrite !sumrB sumr_const /= -scaler_sumr; congr (_ - _ - _). + rewrite card_Iirr_abelian ?cyclic_abelian // -/w1 -scaler_nat. + by rewrite scalerA mulrC divfK ?neq0CG. +rewrite scalerBl opprD opprK addrACA in sumA. +rewrite -{sumA}(canLR (addrK _) sumA) opprD opprK -scalerBr. +rewrite linearD linearZ linear_sum /= Dmu0zeta scalerBr. +rewrite (eq_bigr _ (fun i _ => Dalpha i)) sumrB sumr_const nirrW1. +rewrite -!scaler_sumr sumrB addrAC !addrA scalerBr subrK -addrA -opprD. +rewrite raddfZnat Dtau2 Ddelta_ //; congr (_ - _). +by rewrite addrC -scaler_nat scalerA mulrC divfK ?neq0CG // -scalerDl subrK. +Qed. + +End OneMaximal. + +Implicit Type M : {group gT}. + +(* This is the exported version of Peterfalvi, Theorem (10.8). *) +Theorem FTtype345_noncoherence M (M' := M^`(1)%G) (maxM : M \in 'M) : + (FTtype M > 2)%N -> ~ coherent (seqIndD M' M M' 1) M^# (FT_Dade0 maxM). +Proof. +rewrite ltnNge 2!leq_eqVlt => /norP[notMtype2 /norP[notMtype1 _]] [tau1 cohS]. +have [U W W1 W2 defW MtypeP] := FTtypeP_witness maxM notMtype1. +have [zeta [irr_zeta Szeta zeta1w1]] := FTtypeP_ref_irr maxM MtypeP. +exact: (FTtype345_noncoherence_main MtypeP _ irr_zeta Szeta zeta1w1 cohS). +Qed. + +(* This is the exported version of Peterfalvi, Theorem (10.10). *) +Theorem FTtype5_exclusion M : M \in 'M -> FTtype M != 5. +Proof. +move=> maxM; apply: wlog_neg; rewrite negbK => Mtype5. +have notMtype2: FTtype M != 2 by rewrite (eqP Mtype5). +have [U W W1 W2 defW [[MtypeP _] _]] := FTtypeP 5 maxM Mtype5. +have [zeta [irr_zeta Szeta zeta1w1]] := FTtypeP_ref_irr maxM MtypeP. +exact: (FTtype5_exclusion_main _ MtypeP _ irr_zeta). +Qed. + +(* This the first assertion of Peterfalvi (10.11). *) +Lemma FTtypeP_pair_primes S T W W1 W2 (defW : W1 \x W2 = W) : + typeP_pair S T defW -> prime #|W1| /\ prime #|W2|. +Proof. +move=> pairST; have [[_ maxS maxT] _ _ _ _] := pairST. +have type24 maxM := compl_of_typeII_IV maxM _ (FTtype5_exclusion maxM). +split; first by have [U /type24[]] := typeP_pairW pairST. +have xdefW: W2 \x W1 = W by rewrite dprodC. +by have [U /type24[]] := typeP_pairW (typeP_pair_sym xdefW pairST). +Qed. + +Corollary FTtypeP_primes M U W W1 W2 (defW : W1 \x W2 = W) : + M \in 'M -> of_typeP M U defW -> prime #|W1| /\ prime #|W2|. +Proof. +move=> maxM MtypeP; have [T pairMT _] := FTtypeP_pair_witness maxM MtypeP. +exact: FTtypeP_pair_primes pairMT. +Qed. + +(* This is the remainder of Peterfalvi (10.11). *) +Lemma FTtypeII_prime_facts M U W W1 W2 (defW : W1 \x W2 = W) (maxM : M \in 'M) : + of_typeP M U defW -> FTtype M == 2 -> + let H := M`_\F%G in let HU := M^`(1)%G in + let calS := seqIndD HU M H 1 in let tau := FT_Dade0 maxM in + let p := #|W2| in let q := #|W1| in + [/\ p.-abelem H, (#|H| = p ^ q)%N & coherent calS M^# tau]. +Proof. +move=> MtypeP Mtype2 H HU calS tau p q. +have Mnot5: FTtype M != 5 by rewrite (eqP Mtype2). +have [_ cUU _ _ _] := compl_of_typeII maxM MtypeP Mtype2. +have [q_pr p_pr]: prime q /\ prime p := FTtypeP_primes maxM MtypeP. +have:= typeII_IV_core maxM MtypeP Mnot5; rewrite Mtype2 -/p -/q => [[_ oH]]. +have [] := Ptype_Fcore_kernel_exists maxM MtypeP Mnot5. +have [_ _] := Ptype_Fcore_factor_facts maxM MtypeP Mnot5. +rewrite -/H; set H0 := Ptype_Fcore_kernel _; set Hbar := (H / H0)%G. +rewrite def_Ptype_factor_prime // -/p -/q => oHbar chiefHbar _. +have trivH0: H0 :=: 1%g. + have [/maxgroupp/andP[/andP[sH0H _] nH0M] /andP[sHM _]] := andP chiefHbar. + apply: card1_trivg; rewrite -(setIidPr sH0H) -divg_index. + by rewrite -card_quotient ?(subset_trans sHM) // oHbar -oH divnn cardG_gt0. +have abelHbar: p.-abelem Hbar. + have pHbar: p.-group Hbar by rewrite /pgroup oHbar pnat_exp pnat_id. + by rewrite -is_abelem_pgroup // (sol_chief_abelem _ chiefHbar) ?mmax_sol. +rewrite /= trivH0 -(isog_abelem (quotient1_isog _)) in abelHbar. +have:= Ptype_core_coherence maxM MtypeP Mnot5; rewrite trivH0. +set C := _ MtypeP; have sCU: C \subset U by rewrite [C]unlock subsetIl. +by rewrite (derG1P (abelianS sCU cUU)) [(1 <*> 1)%G]join1G. +Qed. + +End Ten. diff --git a/mathcomp/odd_order/PFsection11.v b/mathcomp/odd_order/PFsection11.v new file mode 100644 index 0000000..3584dbe --- /dev/null +++ b/mathcomp/odd_order/PFsection11.v @@ -0,0 +1,1193 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg poly finset center. +Require Import fingroup morphism perm automorphism quotient action finalg zmodp. +Require Import gfunctor gproduct cyclic commutator gseries nilpotent pgroup. +Require Import sylow hall abelian maximal frobenius. +Require Import matrix mxalgebra mxrepresentation mxabelem vector. +Require Import BGsection1 BGsection3 BGsection7 BGsection15 BGsection16. +Require Import ssrnum ssrint algC classfun character inertia vcharacter. +Require Import PFsection1 PFsection2 PFsection3 PFsection4 PFsection5. +Require Import PFsection6 PFsection7 PFsection8 PFsection9 PFsection10. + +(******************************************************************************) +(* This file covers Peterfalvi, Section 11: Maximal subgroups of Types *) +(* III and IV. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory FinRing.Theory Num.Theory. + +Section Eleven. + +(* This is Peterfalvi (11.1). *) +Lemma lbound_expn_odd_prime p q : + odd p -> odd q -> prime p -> prime q -> p != q -> 4 * q ^ 2 + 1 < p ^ q. +Proof. +move=> odd_p odd_q pr_p pr_q p_neq_q. +have{pr_p pr_q} [pgt2 qgt2] : 2 < p /\ 2 < q by rewrite !odd_prime_gt2. +have [qlt5 | qge5 {odd_q qgt2 p_neq_q}] := ltnP q 5. + have /eqP q3: q == 3 by rewrite eqn_leq qgt2 andbT -ltnS -(odd_ltn 5). + apply: leq_trans (_ : 5 ^ q <= p ^ q); first by rewrite q3. + by rewrite leq_exp2r // odd_geq // ltn_neqAle pgt2 eq_sym -q3 p_neq_q. +apply: leq_trans (_ : 3 ^ q <= p ^ q); last by rewrite -(subnKC qge5) leq_exp2r. +elim: q qge5 => // q IHq; rewrite ltnS leq_eqVlt => /predU1P[<- // | qge5]. +rewrite (expnS 3); apply: leq_trans {IHq}(leq_mul (leqnn 3) (IHq qge5)). +rewrite -!addnS mulnDr leq_add // mulnCA leq_mul // !(mul1n, mulSnr). +by rewrite -addn1 sqrnD muln1 -(subnKC qge5) !leq_add ?leq_mul. +Qed. + +Local Open Scope ring_scope. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). +Implicit Types H K L N P Q R S T U V W : {group gT}. + +Variables M U W W1 W2 : {group gT}. +Hypotheses (maxM : M \in 'M) (defW : W1 \x W2 = W) (MtypeP : of_typeP M U defW). +Hypothesis notMtype2 : FTtype M != 2. + +Let notMtype5 : FTtype M != 5. Proof. exact: FTtype5_exclusion. Qed. +Let notMtype1 : FTtype M != 1%N. Proof. exact: FTtypeP_neq1 MtypeP. Qed. +Let Mtype34 : FTtype M \in pred2 3 4. +Proof. +by have:= FTtype_range M; rewrite -mem_iota !inE !orbA orbC 3?[_ == _](negPf _). +Qed. +Let Mtype_gt2 : (FTtype M > 2)%N. Proof. by case/pred2P: Mtype34 => ->. Qed. + +Local Notation H0 := (Ptype_Fcore_kernel MtypeP). +Local Notation "` 'H0'" := (gval H0) (at level 0, only parsing) : group_scope. +Local Notation "` 'M'" := (gval M) (at level 0, only parsing) : group_scope. +Local Notation "` 'U'" := (gval U) (at level 0, only parsing) : group_scope. +Local Notation "` 'W'" := (gval W) (at level 0, only parsing) : group_scope. +Local Notation "` 'W1'" := (gval W1) (at level 0, only parsing) : group_scope. +Local Notation "` 'W2'" := (gval W2) (at level 0, only parsing) : group_scope. +Local Notation H := `M`_\F%G. +Local Notation "` 'H'" := `M`_\F (at level 0) : group_scope. +Local Notation HU := M^`(1)%G. +Local Notation "` 'HU'" := `M^`(1)%g (at level 0) : group_scope. +Local Notation U' := U^`(1)%G. +Local Notation "` 'U''" := `U^`(1)%g (at level 0) : group_scope. +Local Notation C := 'C_U(`H)%G. +Local Notation "` 'C'" := 'C_`U(`H) (at level 0) : group_scope. +Local Notation HC := (`H <*> `C)%G. +Local Notation "` 'HC'" := (`H <*> `C) (at level 0) : group_scope. +Local Notation H0C := (`H0 <*> `C)%G. +Local Notation "` 'H0C'" := (`H0 <*> `C) (at level 0) : group_scope. +Local Notation Hbar := (`H / `H0)%g. + +Local Notation S_ := (seqIndD HU M HU). +Local Notation tau := (FT_Dade0 maxM). +Local Notation R := (FTtypeP_coh_base maxM MtypeP). +Local Notation V := (cyclicTIset defW). + +Let Mtype24 := compl_of_typeII_IV maxM MtypeP notMtype5. + +Let defMs : M`_\s = HU. Proof. exact: FTcore_type_gt2. Qed. +Let defA1 : 'A1(M) = HU^#. Proof. by rewrite /= -defMs. Qed. +Let defA : 'A(M) = HU^#. Proof. by rewrite FTsupp_eq1. Qed. +Let sHU_A0 : HU^# \subset 'A0(M). Proof. by rewrite -defA FTsupp_sub0. Qed. + +Let calS := seqIndD HU M M`_\s 1. +Let scohM : subcoherent calS tau R. Proof. exact: FTtypeP_subcoherent. Qed. +Let scoh1 : subcoherent (S_ 1) tau R. +Proof. by rewrite -{2}(group_inj defMs). Qed. + +Let p := #|W2|. +Let pr_p : prime p. Proof. by have [] := FTtypeP_primes maxM MtypeP. Qed. +Let ntW2 : W2 :!=: 1%g. Proof. by rewrite -cardG_gt1 prime_gt1. Qed. +Let cycW2 : cyclic W2. Proof. exact: prime_cyclic. Qed. +Let def_p : pdiv #|Hbar| = p. Proof. exact: typeIII_IV_core_prime. Qed. + +Let q := #|W1|. +Let pr_q : prime q. Proof. by have [] := FTtypeP_primes maxM MtypeP. Qed. +Let ntW1 : W1 :!=: 1%g. Proof. by rewrite -cardG_gt1 prime_gt1. Qed. +Let cycW1 : cyclic W1. Proof. exact: prime_cyclic. Qed. + +Let defM : HU ><| W1 = M. Proof. by have [[]] := MtypeP. Qed. +Let defHU : H ><| U = HU. Proof. by have [_ []] := MtypeP. Qed. + +Let nsHUM : HU <| M. Proof. exact: gFnormal. Qed. +Let sHUM : HU \subset M. Proof. exact: gFsub. Qed. +Let sHHU : H \subset HU. Proof. by have /mulG_sub[] := sdprodW defHU. Qed. +Let sUHU : U \subset HU. Proof. by have /mulG_sub[] := sdprodW defHU. Qed. +Let sUM : U \subset M. Proof. exact: subset_trans sUHU sHUM. Qed. + +Let coHUq : coprime #|HU| q. +Proof. by rewrite (coprime_sdprod_Hall_r defM); have [[]] := MtypeP. Qed. +Let coUq : coprime #|U| q. Proof. exact: coprimeSg coHUq. Qed. + +Let neq_pq : p != q. +Proof. +apply: contraTneq coHUq => <-; rewrite coprime_sym prime_coprime ?cardSg //. +by rewrite -(typeP_cent_compl MtypeP) subsetIl. +Qed. + +Let solHU : solvable HU. Proof. exact: solvableS sHUM (mmax_sol maxM). Qed. +Let solH : solvable H. Proof. exact: solvableS sHHU solHU. Qed. + +Let ltM''HU : M^`(2)%g \proper HU. +Proof. by rewrite (sol_der1_proper solHU) // -defMs FTcore_neq1. Qed. + +Let frobMtilde : [Frobenius M / M^`(2) = (HU / M^`(2)) ><| (W1 / M^`(2))]. +Proof. +have [[_ _ _ _] _ _ [_ _ _ sW2M'' prHUW1 ] _] := MtypeP. +by rewrite Frobenius_coprime_quotient ?gFnormal //; split=> // _ /prHUW1->. +Qed. + +Let defHC : H \x C = HC. +Proof. +by have [defHC _ _ _] := typeP_context MtypeP; rewrite /= (dprodWY defHC). +Qed. + +Let nC_UW1 : U <*> W1 \subset 'N(C). +Proof. +have /sdprodP[_ _ nHUW1 _] := Ptype_Fcore_sdprod MtypeP. +by rewrite normsI ?norms_cent // join_subG normG; have [_ []] := MtypeP. +Qed. + +Let nsCM : C <| M. +Proof. +rewrite /normal subIset ?sUM //= -{1}(sdprodW (Ptype_Fcore_sdprod MtypeP)). +by rewrite mulG_subG cents_norm // centsC subsetIr. +Qed. + +Let nsCU : C <| U. Proof. exact: normalS (subsetIl _ _) sUM nsCM. Qed. +Let nsHC_M : HC <| M. Proof. by rewrite normalY ?gFnormal. Qed. +Let sHC_HU : HC \subset HU. Proof. by rewrite join_subG sHHU subIset ?sUHU. Qed. +Let nsHC_HU : HC <| HU. Proof. exact: normalS nsHC_M. Qed. + +Let chiefH0 : chief_factor M H0 H. +Proof. by have [] := Ptype_Fcore_kernel_exists maxM MtypeP notMtype5. Qed. + +Let minHbar : minnormal Hbar (M / H0). +Proof. exact: chief_factor_minnormal. Qed. + +Let abelHbar : p.-abelem Hbar. +Proof. +have solHbar : solvable (H / H0) by rewrite quotient_sol. +have [_ _] := minnormal_solvable minHbar (subxx _) solHbar. +by rewrite /is_abelem def_Ptype_factor_prime. +Qed. + +Let sH0H : H0 \subset H. +Proof. by have/andP[/maxgroupp/andP[/proper_sub]]:= chiefH0. Qed. + +Let nH0M: M \subset 'N(H0). +Proof. by have /andP[/maxgroupp/andP[]] := chiefH0. Qed. + +Let nsH0H : H0 <| H. +Proof. by rewrite /normal sH0H (subset_trans (Fcore_sub _)). Qed. + +Let nsH0C_M : H0C <| M. +Proof. by rewrite !normalY ?gFnormal /normal ?(subset_trans sH0H) ?gFsub. Qed. + +Let defH0C : H0 \x C = H0C. +Proof. +have /dprodP[_ _ cHC tiHC] := defHC. +by rewrite dprodEY ?(centsS sH0H) //; apply/trivgP; rewrite -tiHC setSI. +Qed. + +(* Group-theoretic consequences of the coherence and non-coherence theorems *) +(* of Sections 5, 9 and 10 for maximal subgroups of type III and IV. *) + +(* This is Peterfalvi (11.3). *) +Lemma FTtype34_noncoherence : ~ coherent (S_ H0C) M^# tau. +Proof. +move=> cohH0C; suff: coherent (S_ 1) M^# tau by apply: FTtype345_noncoherence. +have /mulG_sub[_ sW1M] := sdprodW defM. +have [nsHHU _ _ nHU tiHU] := sdprod_context defHU. +have sHM: H \subset M := gFsub _ _. +have [sCM sH0C_M]: C \subset M /\ H0C \subset M by rewrite !normal_sub. +have nH0_C := subset_trans sCM nH0M. +have sH0C_HC: H0C \subset HC by apply: genS (setSU _ _). +have defF: HC :=: 'F(M) by have [/dprodWY] := typeP_context MtypeP. +have{defF} nilHC: nilpotent (HC / 1) by rewrite defF quotient_nil ?Fitting_nil. +have /bounded_seqIndD_coherent-bounded_coh1 := scoh1. +apply: bounded_coh1 nilHC cohH0C _; rewrite ?sub1G ?normal1 //. +have[_ _ /= oHbar] := Ptype_Fcore_factor_facts maxM MtypeP notMtype5. +rewrite -(index_sdprod defM) -divgS // -(dprod_card defHC) -(dprod_card defH0C). +rewrite divnMr ?cardG_gt0 // divg_normal // oHbar def_p -/q. +by rewrite lbound_expn_odd_prime ?mFT_odd. +Qed. + +(* This is Peterfalvi (11.4). *) +Lemma bounded_proper_coherent H1 : + H1 <| M -> H1 \proper HU -> coherent (S_ H1) M^# tau -> + (#|HU : H1| <= 2 * q * #|U : C| + 1)%N. +Proof. +move=> nsH1_M psH1_M' cohH1; have [nsHHU _ _ _ _] := sdprod_context defHU. +rewrite -leC_nat natrD -ler_subl_addr. +have ->: (2 * q * #|U : C|)%:R = 2%:R * #|M : HC|%:R * sqrtC #|HC : HC|%:R. + rewrite indexgg sqrtC1 mulr1 -mulnA natrM; congr (_ * _%:R). + apply/eqP; rewrite // -(eqn_pmul2l (cardG_gt0 HC)) Lagrange ?normal_sub //. + rewrite mulnCA -(dprod_card defHC) -mulnA (Lagrange (subsetIl _ _)). + by rewrite -(sdprod_card defM) -(sdprod_card defHU) mulnC. +have ns_M: [/\ H1 <| M, H0C <| M, HC <| M & HC <| M] by []. +case: (coherent_seqIndD_bound _ _ scoh1 ns_M) FTtype34_noncoherence => //. +suffices /center_idP->: abelian (HC / H0C) by rewrite genS ?setSU. +suffices /isog_abelian->: HC / H0C \isog H / H0 by apply: abelem_abelian p _ _. +by rewrite /= (joingC H0) isog_sym quotient_sdprodr_isog ?(dprodWsdC defHC). +Qed. + +(* This is Peterfalvi (11.5). *) +Lemma FTtype34_der2 : M^`(2)%g = HC. +Proof. +have [defFM [_ not_cHU] _ _] := typeP_context MtypeP. +have [_ sW1M _ _ tiHU_W1] := sdprod_context defM. +have{defFM} sM''_HC: M^`(2)%g \subset HC. + by rewrite -defHC defFM; have [_ _ []] := MtypeP. +have scohM'': subcoherent (S_ M^`(2)) tau R. + exact/(subset_subcoherent scoh1)/seqInd_conjC_subset1. +have cohM'': coherent (S_ M^`(2)) M^# tau. + apply: uniform_degree_coherence scohM'' _. + apply: all_pred1_constant #|M : HU|%:R _ _; rewrite all_map. + apply/allP=> _ /seqIndP[s /setDP[kerM'' _] ->] /=; rewrite inE in kerM''. + by rewrite cfInd1 ?gFsub // lin_char1 ?mulr1 ?lin_irr_der1. +have ubHC: (#|HC : M^`(2)| < 2 * q + 1)%N. + rewrite -(ltn_pmul2r (indexg_gt0 U C)) mulnDl mul1n. + apply: leq_ltn_trans (_ : 2 * q * #|U : C| + 1 < _)%N; last first. + by rewrite ltn_add2l indexg_gt1 subsetIidl not_cHU //; have [] := Mtype24. + have {1}->: #|U : C| = #|HU : HC| by apply: index_sdprodr (subsetIl _ _). + by rewrite mulnC (Lagrange_index sHC_HU) // bounded_proper_coherent ?gFnormal. +have regHC_W1: semiregular (HC / M^`(2)) (W1 / M^`(2)). + by apply: semiregularS (Frobenius_reg_ker frobMtilde); rewrite quotientS. +suffices /dvdnP[k Dk]: 2 * q %| #|HC : M^`(2)|.-1. + apply: contraTeq ubHC; rewrite -leqNgt eqEsubset sM''_HC -indexg_gt1 addn1. + by rewrite -[#|_:_|]prednK // {}Dk !ltnS muln_gt0 => /andP[/leq_pmull->]. +rewrite Gauss_dvd; last by rewrite coprime2n mFT_odd. +rewrite dvdn2 -subn1 odd_sub // addbT negbK subn1. +rewrite -card_quotient; last by rewrite (subset_trans sHC_HU) // (der_norm 1). +have Dq: q = #|W1 / M^`(2)|%g. + apply/card_isog/quotient_isog; first by rewrite (subset_trans sW1M) ?gFnorm. + by apply/trivgP; rewrite -tiHU_W1 setSI // (der_sub 1). +rewrite quotient_odd ?mFT_odd //= Dq regular_norm_dvd_pred ?quotient_norms //. +by rewrite (subset_trans sW1M) ?normal_norm. +Qed. +Local Notation defM'' := FTtype34_der2. + +(* This is Peterfalvi (11.6). *) +Lemma FTtype34_facts (H' := H^`(1)%g): + [/\ p.-group H, U \subset 'C(H0), H0 :=: H' & C :=: U']. +Proof. +have nilH: nilpotent H := Fcore_nil M. +have /sdprod_context[/andP[_ nHM] sUW1M _ _ _] := Ptype_Fcore_sdprod MtypeP. +have coH_UW1: coprime #|H| #|U <*> W1| := Ptype_Fcore_coprime MtypeP. +have [[_ mulHU _ tiHU] [nHU isomHU]] := (sdprodP defHU, sdprod_isom defHU). +have{sUW1M} cH0U: U \subset 'C(H0). + have frobUW1 := Ptype_compl_Frobenius maxM MtypeP notMtype5. + have nH0_UW1 := subset_trans sUW1M nH0M; have [_ nH0W1] := joing_subP nH0_UW1. + have [coH0_UW1 solH0] := (coprimeSg sH0H coH_UW1, solvableS sH0H solH). + have [_ -> //] := Frobenius_Wielandt_fixpoint frobUW1 nH0_UW1 coH0_UW1 solH0. + have ->: 'C_H0(W1) = H0 :&: 'C_H(W1) by rewrite setIA (setIidPl sH0H). + have nH0C: 'C_H(W1) \subset 'N(H0) by rewrite subIset // normal_norm. + rewrite cardMg_TI // -LagrangeMl -card_quotient {nH0C}//. + rewrite coprime_quotient_cent ?(coprimeSg sHHU) //=. + have [_ -> _] := Ptype_Fcore_factor_facts maxM MtypeP notMtype5. + by rewrite (typeP_cent_core_compl MtypeP) def_p. +have{isomHU} defC: C :=: U'. + have [injHquo defHUb] := isomP isomHU. + apply: (injm_morphim_inj injHquo); rewrite ?subsetIl ?morphim_der ?der_sub //. + rewrite defHUb morphim_restrm -quotientE setIA setIid -quotientMidl /=. + by rewrite (dprodW defHC) -defM'' -quotient_der // -mulHU mul_subG ?normG. +have{coH_UW1} defH0: H0 :=: H'. + pose Hhat := (H / H')%g; pose Uhat := (U / H')%g; pose HUhat := (HU / H')%g. + have nH'H: H \subset 'N(H') := gFnorm _ _. + have nH'U: U \subset 'N(H') := char_norm_trans (der_char _ _) nHU. + apply/eqP; rewrite eqEsubset andbC. + rewrite der1_min ?(abelem_abelian abelHbar) ?normal_norm //=. + rewrite -quotient_sub1 /= -/H'; last exact: subset_trans sH0H nH'H. + suffices <-: 'C_Hhat(Uhat) = 1%g. + by rewrite subsetI quotientS //= quotient_cents // centsC. + suffices: ~~ ('C_Hhat(Uhat)^`(1)%g \proper 'C_Hhat(Uhat)). + exact: contraNeq (sol_der1_proper (quotient_sol _ solH) (subsetIl Hhat _)). + have {2}<-: HUhat^`(1)%g :&: 'C_Hhat(Uhat) = 'C_Hhat(Uhat). + rewrite -quotient_der ?[HU^`(1)%g]defM''; last by rewrite -mulHU mul_subG. + by rewrite (setIidPr _) ?subIset // quotientS ?joing_subl. + suffices defHUhat: 'C_Hhat(Uhat) \x ([~: Hhat, Uhat] <*> Uhat) = HUhat. + rewrite -(dprod_modl (der_dprod 1 defHUhat)) ?der_sub //= -/Hhat. + rewrite [rhs in _ \x rhs](trivgP _) ?dprodg1 ?properxx //= -/Hhat. + by have [_ _ _ <-] := dprodP defHUhat; rewrite setIC setIS ?der_sub. + have coHUhat: coprime #|Hhat| #|Uhat|. + by rewrite coprime_morph ?(coprimegS _ coH_UW1) ?joing_subl. + have defHhat: 'C_Hhat(Uhat) \x [~: Hhat, Uhat] = Hhat. + by rewrite dprodC coprime_abelian_cent_dprod ?der_abelian ?quotient_norms. + rewrite /HUhat -(sdprodWY defHU) quotientY //= -(dprodWY defHhat). + have [_ _ cCRhat tiCRhat] := dprodP defHhat. + rewrite dprodEY ?joingA //; first by rewrite join_subG cCRhat centsC subsetIr. + apply/trivgP; rewrite /= joingC norm_joinEl ?commg_normr //= -/Hhat -/Uhat. + rewrite -tiCRhat !(setIAC _ 'C(_)) setSI // subsetI subsetIl /=. + by rewrite -group_modr ?commg_subl ?quotient_norms //= coprime_TIg ?mul1g. +suffices{defC defH0}: p.-group H by []. +pose R := 'O_p^'(H); have hallR: p^'.-Hall(H) R := nilpotent_pcore_Hall _ nilH. +have defRHp: R \x 'O_p(H) = H by rewrite dprodC nilpotent_pcoreC. +suffices R_1: R :=: 1%g by rewrite -defRHp R_1 dprod1g pcore_pgroup. +have /subsetIP[sRH cUR]: R \subset 'C_H(U). + have oH: #|H| = (p ^ q * #|'C_H(U)|)%N. + by have:= typeII_IV_core maxM MtypeP notMtype5 => /=; rewrite ifN => // -[]. + apply/setIidPl/eqP; rewrite eqEcard subsetIl /= (card_Hall hallR) {}oH. + rewrite (card_Hall (setI_normal_Hall _ hallR _)) ?subsetIl ?gFnormal //. + rewrite partnM ?expn_gt0 ?cardG_gt0 //= part_p'nat ?mul1n ?pnatNK //. + by rewrite pnat_exp ?pnat_id. +suffices: ~~ (R^`(1)%g \proper R) by apply: contraNeq (sol_der1_proper solH _). +have /setIidPr {2}<-: R \subset HU^`(1)%g. + by rewrite [HU^`(1)%g]defM'' -(dprodWY defHC) sub_gen ?subsetU ?sRH. +suffices defRHpU: R \x ('O_p(H) <*> U) = HU. + rewrite -(dprod_modl (der_dprod 1 defRHpU)) ?der_sub //= -/R setIC. + rewrite [rhs in _ \x rhs](trivgP _) ?dprodg1 ?properxx //= -/R. + by have /dprodP[_ _ _ <-] := defRHpU; rewrite setIS ?der_sub. +rewrite -(sdprodWY defHU) -[in RHS](dprodWY defRHp) -joingA. +have [_ _ cRHp tiRHp] := dprodP defRHp. +rewrite dprodEY //= -/R; first by rewrite join_subG cRHp centsC. +rewrite joingC (norm_joinEl (char_norm_trans (pcore_char p H) nHU)). +by rewrite -(setIidPl sRH) -setIA -group_modr ?gFsub // tiHU mul1g. +Qed. + +Let frobUW1bar : [Frobenius U <*> W1 / C = (U / C) ><| (W1 / C)]. +Proof. +have frobUW1: [Frobenius U <*> W1 = U ><| W1]. + exact: Ptype_compl_Frobenius MtypeP notMtype5. +have [defUW1 ntU _ _ _] := Frobenius_context frobUW1. +have [[_ _ _ defC] regUW1] := (FTtype34_facts, Frobenius_reg_ker frobUW1). +rewrite Frobenius_coprime_quotient // /normal ?subIset ?joing_subl //. +by split=> [|x /regUW1->]; rewrite ?sub1G //= defC (sol_der1_proper solHU). +Qed. + +(* This is Peterfalvi (11.7). *) +(* We have recast the linear algebra arguments in the original text in pure- *) +(* group-theoretic terms: the overhead of the abelem_rV correspondence is not *) +(* justifiable here, as the Ssreflect linear algebra library lacks specific *) +(* support for bilinear forms: we use D y z := [~ coset Q y, coset Q z] as *) +(* our "linear form". D is antisymmetric as D z y = (D y z)^-1, so we only *) +(* show that D is "linear" in z, that is, that D y is a group morphism with *) +(* domain H whose kernel contains H0, when y \in H, and we do not bother to *) +(* factor D to obtain a form over Hbar = H / H0. *) +(* We further rework the argument to support this change in perspective: *) +(* - We remove any reference to linear algebra in the "Galois" (9.7b) case, *) +(* where U acts irreducibly on Hbar: we revert to the proof of the *) +(* original Odd Order paper, using the fact that H / Q is extraspecial. *) +(* - In the "non-Galois" (9.7a) case, we use the W1-conjugation class of a *) +(* generator of H1 as an explicit basis of Hbar, indexed by W1, and we *) +(* use the elements xbar_ w = coset H0 (x_ w) of this basis instead of *) +(* arbitrary y in H_i, as the same argument then justifies extending *) +(* commutativity to all of Hbar. *) +(* - We construct phi as the morphism mapping ubar in Ubar to the n such *) +(* that the action of ubar on H1 is exponentiation by n. We derive a *) +(* morphism phi_ w ubar for the action of Ubar on H1 ^ w, for w in W1, by *) +(* composign with the action QV of W1 on Ubar by inverse conjugation. *) +(* - We exchange the two alternatives in the (9.7a) case; most of proof is *) +(* thus by contradiction with the C_U(Hbar) != u assertion in (9.6), *) +(* first establishing case 9.7a (as 9.7b contradicts q odd), then that D *) +(* is nontrivial for some x_ w1 and x_ w2 (as (H / Q)' = H0 / Q != 1), *) +(* whence (phi_ w1 u)(phi_ w2 u) = 1, whence (phi u)^-1 = phi u and *) +(* phi = 1, i.e., Ubar centralises Wbar. *) +(* Note finally that we simply construct U as a maximal subgroup of H0 normal *) +(* in H, as the nilpotence of H / Q implies that H0 / Q lies in its center. *) +Lemma FTtype34_Fcore_kernel_trivial : + [/\ p.-abelem H, #|H| = (p ^ q)%N & `H0 = 1%g]. +Proof. +have [[_ _ nHU tiHU] [pH cH0U defH' _]] := (sdprodP defHU, FTtype34_facts). +have [/mulG_sub[_ sW1M] nH0H] := (sdprodW defM, normal_norm nsH0H). +have nHW1: W1 \subset 'N(H) := subset_trans sW1M (gFnorm _ M). +have nUW1: W1 \subset 'N(U) by have [_ []] := MtypeP. +pose bar := coset_morphism H0; pose Hbar := (H / H0)%g; pose Ubar := (U / H0)%g. +have [Cbar_neqU _ /= oHbar] := Ptype_Fcore_factor_facts maxM MtypeP notMtype5. +rewrite -/Hbar def_p // -/q in oHbar. +have [nH0U nH0W1] := (subset_trans sUM nH0M, subset_trans sW1M nH0M). +suffices H0_1 : `H0 = 1%g. + have isoHbar: H \isog H / H0 by rewrite H0_1 quotient1_isog. + by rewrite (isog_abelem isoHbar) (card_isog isoHbar). +apply: contraNeq Cbar_neqU => ntH0; rewrite [Ptype_Fcompl_kernel _]unlock. +suffices: Hbar \subset 'C(Ubar). + by rewrite (sameP eqP setIidPl) sub_astabQ nH0U centsC. +have pH0 := pgroupS sH0H pH; have{ntH0} [_ _ [k oH0]] := pgroup_pdiv pH0 ntH0. +have{k oH0} [Q maxQ nsQH]: exists2 Q : {group gT}, maximal Q H0 & Q <| H. + have [Q [sQH0 nsQH oQ]] := normal_pgroup pH nsH0H (leq_pred _). + exists Q => //; apply: p_index_maximal => //. + by rewrite -divgS // oQ oH0 pfactorK //= expnS mulnK ?expn_gt0 ?cardG_gt0. +have nsQH0: Q <| H0 := p_maximal_normal (pgroupS sH0H pH) maxQ. +have [[sQH0 nQH0] nQH] := (andP nsQH0, normal_norm nsQH). +have nQU: U \subset 'N(Q) by rewrite cents_norm ?(centsS sQH0). +pose hat := coset_morphism Q; pose Hhat := (H / Q)%g; pose H0hat := (H0 / Q)%g. +have{maxQ} oH0hat: #|H0hat| = p by rewrite card_quotient ?(p_maximal_index pH0). +have defHhat': Hhat^`(1)%g = H0hat by rewrite -quotient_der -?defH'. +have ntH0hat: H0hat != 1%g by rewrite -cardG_gt1 oH0hat prime_gt1. +have pHhat: p.-group Hhat by apply: quotient_pgroup. +have nsH0Hhat: H0hat <| Hhat by apply: quotient_normal. +have sH0hatZ: H0hat \subset 'Z(Hhat). + by rewrite prime_meetG ?oH0hat // meet_center_nil ?(pgroup_nil pHhat). +have{pHhat} gal'M: ~~ typeP_Galois MtypeP. + have sZHhat: 'Z(Hhat) \subset Hhat := center_sub _. + have nsH0hatZ: H0hat <| 'Z(Hhat) := normalS sH0hatZ sZHhat nsH0Hhat. + have [f injf im_f] := third_isom sQH0 nsQH nsH0H. + have fHhat: f @* (Hhat / H0hat) = Hbar by rewrite im_f. + apply: contra (odd (logn p #|Hhat|)) _ _; last first. + rewrite -(divnK (cardSg (quotientS Q sH0H))) divg_normal // oH0hat. + by rewrite -(card_injm injf) // fHhat oHbar -expnSr pfactorK //= mFT_odd. + rewrite /typeP_Galois acts_irrQ // => /mingroupP[_ minUHbar]. + suffices /(card_extraspecial pHhat)[n _ ->]: extraspecial Hhat. + by rewrite pfactorK //= odd_double. + have abelH: p.-abelem (Hhat / H0hat)%g by rewrite -(injm_abelem injf) ?fHhat. + suffices{abelH} defZHhat: 'Z(Hhat) = H0hat. + do 2?split; rewrite defZHhat ?oH0hat //. + apply/eqP; rewrite eqEsubset (Phi_min pHhat) ?normal_norm //=. + by rewrite (Phi_joing pHhat) defHhat' joing_subl. + apply: contraNeq ntH0hat; rewrite eqEsubset sH0hatZ andbT => not_esHhat. + rewrite -defHhat'; apply/eqP/derG1P/center_idP/(quotient_inj nsH0hatZ)=> //. + apply: (injm_morphim_inj injf); rewrite ?quotientS //= fHhat -/Hhat -/H0hat. + rewrite minUHbar //= -/Hbar -?fHhat 1?morphim_injm_eq1 ?morphimS // -subG1. + rewrite quotient_sub1 ?(normal_norm nsH0hatZ) // not_esHhat -['Z(_)]cosetpreK. + rewrite im_f ?sub_cosetpre_quo // quotient_norms ?norm_quotient_pre //. + by rewrite (char_norm_trans (center_char _)) ?quotient_norms. +have [H1 []] := typeP_Galois_Pn maxM notMtype5 gal'M. +rewrite def_p => oH1 nH1Ubar _ /bigdprodWY-defHbar _. +have /cyclicP[xbar defH1]: cyclic H1 by rewrite prime_cyclic ?oH1. +have H1xbar: xbar \in H1 by rewrite defH1 cycle_id. +have sH1_Hbar: H1 \subset Hbar. + by rewrite -[Hbar]defHbar (bigD1 1%g) ?group1 ?conjsg1 ?joing_subl. +have{sH1_Hbar} Hxbar: xbar \in Hbar := subsetP sH1_Hbar xbar H1xbar. +have /morphimP[x nH0x Hx /= Dxbar] := Hxbar. +have{oH1} oxbar: #[xbar] = p by rewrite orderE -defH1. +have memH0: {in H &, forall y z, [~ y, z] \in H0}. + by rewrite defH'; apply: mem_commg. +have [_ /centsP-cHH0hat] := subsetIP sH0hatZ; move/subsetP in nQH. +pose D y z := [~ hat z, hat y]. +have D_H0_1 y z: y \in H -> z \in H0 -> D y z = 1%g. + by move=> Hy H0z; apply/eqP/commgP/cHH0hat; apply: mem_quotient. +have H0_D: {in H &, forall y z, D y z \in H0hat}. + by move=> y z Hy Hz; rewrite -defHhat' mem_commg ?mem_quotient. +have Dsym y z: (D y z)^-1%g = D z y by rewrite invg_comm. +have Dmul y: y \in H -> {in H &, {morph D y: z t / z * t}}%g. + move=> Hy z t Hz Ht; rewrite {1}/D morphM ?nQH // commMgR; congr (_ * _)%g. + by rewrite -{2}morphR ?nQH // -/(D t _) D_H0_1 ?memH0 // mulg1. +pose Dm y Hy : {morphism H >-> coset_of Q} := Morphism (Dmul y Hy). +have{D_H0_1} kerDmH0 y Hy: H0 \subset 'ker (Dm y Hy). + by rewrite subsetI sH0H; apply/subsetP=> z H0z; rewrite !inE /= D_H0_1. +pose x_ w := (x ^ w)%g; pose xbar_ w := (xbar ^ bar w)%g. +move/subsetP in nHW1; move/subsetP in nHU. +have Hx_ w: w \in W1 -> (x_ w \in H) * {in U, forall u, x_ w ^ u \in H}%g. + by move/nHW1=> nHw; split=> [|u /nHU-nHu]; rewrite !memJ_norm. +have Dx: {in H &, forall y z, {in W1, forall w, D (x_ w) y = 1} -> D y z = 1}%g. + move=> y z Hy Hz Dxy1; apply/(kerP (Dm y Hy) Hz); apply: subsetP z Hz. + rewrite -(quotientSGK nH0H) ?kerDmH0 // -defHbar gen_subG. + apply/bigcupsP=> _ /morphimP[w nH0w W1w ->] /=. + rewrite defH1 Dxbar -quotient_cycle -?quotientJ ?quotientS // -cycleJ. + by rewrite cycle_subG !inE /= Hx_ //= -Dsym eq_invg1 Dxy1. +pose ntrivD := [exists w in [predX W1 & W1], #[D (x_ w.1) (x_ w.2)] == p]. +have{ntrivD Dx} /exists_inP[[w1 w2] /andP/=[Ww1 Ww2] /eqP-oDx12]: ntrivD. + apply: contraR ntH0hat => Dx_1; rewrite -defHhat' -subG1 gen_subG. + apply/subsetP=> _ /imset2P[_ _ /morphimP[y ? Hy ->] /morphimP[z ? Hz ->] ->]. + apply/set1P/Dx=> // w2 Ww2; rewrite Dx ?Hx_ // => w1 Ww1. + have abelH0hat: p.-abelem H0hat by apply: prime_abelem. + apply: contraNeq Dx_1 => /(abelem_order_p abelH0hat)oDx12. + by apply/exists_inP; exists (w1, w2); rewrite ?inE ?Ww1 // oDx12 ?H0_D ?Hx_. +have /subsetP-nUW1bar: (W1 / H0)%g \subset 'N(Ubar) := quotient_norms H0 nUW1. +move/subsetP in nH0H; move/subsetP in nH0W1. +pose n (phi : {morphism Ubar >-> {unit 'F_p}}) ubar : nat := val (phi ubar). +have [phi Dphi]: {phi | {in Ubar, forall ub, xbar ^ ub =xbar ^+ n phi ub}}%g. + pose xbar_Autm := invm (injm_Zp_unitm xbar). + have /restrmP[phi [Dphi _ _ _]]: Ubar \subset 'dom (xbar_Autm \o conj_aut H1). + by rewrite -sub_morphim_pre //= im_Zp_unitm -defH1 Aut_conj_aut. + rewrite /n pdiv_id // -oxbar; exists phi => ubar /(subsetP nH1Ubar)Uubar. + transitivity (Zp_unitm (phi ubar) xbar); last by rewrite autE /= -?defH1. + by rewrite Dphi invmK ?im_Zp_unitm -?defH1 ?Aut_aut ?norm_conj_autE. +pose QV ubar w := (ubar ^ (bar w)^-1)%g. +have UbarQV: {in Ubar & W1, forall ubar w, QV ubar w \in Ubar}. + by move=> ub w Uub W1w; rewrite /= memJ_norm ?groupV ?nUW1bar ?mem_quotient. +pose phi_ w ub := phi (QV ub w); pose nphi_ w ub := n phi (QV ub w). +have xbarJ: {in W1 & Ubar, forall w ub, xbar_ w ^ ub = xbar_ w ^+ nphi_ w ub}%g. + by move=> w ubar * /=; rewrite -conjgM conjgCV conjgM Dphi ?UbarQV // conjXg. +have{oDx12} phi_w12 ubar: ubar \in Ubar -> (phi_ w1 ubar * phi_ w2 ubar = 1)%g. + pose n_u := nphi_ ^~ ubar => Uubar; have [u nH0u Uu Dubar] := morphimP Uubar. + suffices: n_u w1 * n_u w2 == 1 %[mod #[D (x_ w1) (x_ w2)]]. + by apply: contraTeq; rewrite oDx12 -!val_Fp_nat // natrM !natr_Zp. + have DXn: {in H & W1, forall y w, D y (x_ w) ^+ n_u w = D y (x_ w ^ u)}%g. + move=> y w Hy W1w; set z := x_ w; have [Hz /(_ u Uu) Hzu] := Hx_ w W1w. + rewrite -(morphX (Dm y Hy)) //; apply/rcoset_kerP; rewrite ?groupX //. + have /subsetP: H0 :* z ^ u \subset 'ker (Dm y Hy) :* z ^ u by rewrite mulSg. + apply; apply/rcoset_kercosetP; rewrite ?groupX ?nH0H //. + by rewrite morphX ?morphJ ?(nH0W1 w) // ?nH0H //= -Dubar -Dxbar xbarJ. + rewrite -eq_expg_mod_order -{1}Dsym expgM expgVn ?(DXn, Dsym) ?Hx_ //. + rewrite /D -!morphR ?nQH ?Hx_ // -conjRg (conjg_fixP _) //. + by apply/commgP/esym/(centsP cH0U); rewrite ?memH0 ?Hx_. +pose wbar := bar (w1 * w2 ^-1)%g; pose W1bar := (W1 / H0)%g. +have W1wbar: wbar \in W1bar by rewrite mem_quotient ?groupM ?groupV. +have{phi_w12} phiJ: {in Ubar, forall ubar, phi (ubar ^ wbar) = (phi ubar)^-1}%g. + move=> ubar Uubar; apply/esym/eqP; rewrite eq_invg_mul. + rewrite [wbar]morphM ?morphV ?nH0W1 ?groupV // -{1}[ubar](conjgK (bar w1)). + by rewrite conjgM phi_w12 // memJ_norm ?nUW1bar ?mem_quotient. +have coW1bar2: coprime #|W1bar| 2 by rewrite coprimen2 quotient_odd ?mFT_odd. +have coUbar2: coprime #|Ubar| 2 by rewrite coprimen2 quotient_odd ?mFT_odd. +have{wbar phiJ W1wbar} phiV: {in Ubar, forall ubar, phi ubar = (phi ubar)^-1}%g. + move=> ubar Uubar; rewrite /= -phiJ // -(expgK coW1bar2 W1wbar) -expgM mul2n. + elim: (expg_invn _ _) => [|k IHk]; first by rewrite conjg1. + by do 2!rewrite expgSr conjgM phiJ ?memJ_norm ?nUW1bar ?groupX // ?invgK. +rewrite -[Hbar]defHbar gen_subG defH1; apply/bigcupsP=> _ /morphimP[w _ Ww ->]. +rewrite -cycleJ cycle_subG -/(xbar_ _); apply/centP=> ubar Uubar; apply/commgP. +apply/conjg_fixP; rewrite xbarJ // /nphi_ -[QV _ w](expgK coUbar2) ?UbarQV //. +by rewrite /n !morphX ?groupX 1?expgS 1?{1}phiV ?UbarQV // mulVg expg1n. +Qed. + +Let defU' : C :=: U'. Proof. by have [] := FTtype34_facts. Qed. +Let H0_1 : H0 :=: 1%g. Proof. by have [] := FTtype34_Fcore_kernel_trivial. Qed. + +Lemma Ptype_Fcompl_kernel_cent : Ptype_Fcompl_kernel MtypeP :=: C. +Proof. +rewrite [Ptype_Fcompl_kernel MtypeP]unlock /= (group_inj H0_1). +by rewrite astabQ -morphpreIim -injm_cent ?injmK ?ker_coset ?norms1. +Qed. +Local Notation defC := Ptype_Fcompl_kernel_cent. + +(* Character theory proper. *) + +Let pddM := FT_prDade_hyp maxM MtypeP. +Let ptiWM : primeTI_hypothesis M HU defW := FT_primeTI_hyp MtypeP. +Let ctiWG : cyclicTI_hypothesis G defW := pddM. +Let ctiWM : cyclicTI_hypothesis M defW := prime_cycTIhyp ptiWM. + +Local Notation sigma := (cyclicTIiso ctiWG). +Local Notation w_ i j := (cyclicTIirr defW i j). +Local Notation eta_ i j := (sigma (w_ i j)). +Local Notation mu_ := (primeTIred ptiWM). +Local Notation Idelta := (primeTI_Isign ptiWM). +Local Notation delta_ j := (primeTIsign ptiWM j). +Local Notation d := (FTtype345_TIirr_degree MtypeP). +Local Notation n := (FTtype345_ratio MtypeP). +Local Notation delta := (FTtype345_TIsign MtypeP). + +Implicit Types zeta xi lambda : 'CF(M). + +Let u := #|U / C|%g. +Let mu2_ i j := primeTIirr ptiWM i j. +Let etaW := map sigma (irr W). +Let eq_proj_eta (alpha gamma : 'CF(G)) := orthogonal (alpha - gamma) etaW. +Let eta_col j := \sum_i eta_ i j. +Let bridge0 zeta := mu_ 0 - zeta. + +Let proj_col_eta j0 i j : '[eta_col j0, eta_ i j] = (j == j0)%:R. +Proof. +rewrite cfdot_suml (bigD1 i) //= cfdot_cycTIiso eqxx eq_sym. +by rewrite big1 ?addr0 // => k /negPf-i'k; rewrite cfdot_cycTIiso i'k. +Qed. + +Let nirrW1 : #|Iirr W1| = q. Proof. by rewrite card_Iirr_cyclic. Qed. +Let NirrW1 : Nirr W1 = q. Proof. by rewrite -nirrW1 card_ord. Qed. + +Let nirrW2 : #|Iirr W2| = p. Proof. by rewrite card_Iirr_cyclic. Qed. +Let NirrW2 : Nirr W2 = p. Proof. by rewrite -nirrW2 card_ord. Qed. + +Let calT := seqIndT HU M. +Let S1 := S_ HC. +Let S2 := seqIndD HU M HC C. + +Let sS10 : cfConjC_subset S1 calS. +Proof. by apply: seqInd_conjC_subset1; rewrite /= ?defMs. Qed. + +Let sS20 : cfConjC_subset S2 calS. +Proof. by apply: seqInd_conjC_subset1; rewrite /= ?defMs. Qed. + +Let scohS1 : subcoherent S1 tau R. Proof. exact: subset_subcoherent sS10. Qed. +Let scohS2 : subcoherent S2 tau R. Proof. exact: subset_subcoherent sS20. Qed. + +Let S1_1 : {in S1, forall zeta, zeta 1%g = q%:R}. +Proof. +move=> _ /seqIndP[s /setDP[kerM'' _] ->]; rewrite !inE -defM'' in kerM''. +by rewrite cfInd1 ?gFsub // -(index_sdprod defM) lin_char1 ?mulr1 ?lin_irr_der1. +Qed. + +Let cohS1 : coherent S1 M^# tau. +Proof. +apply: uniform_degree_coherence scohS1 _. +by apply/(@all_pred1_constant _ q%:R)/allP=> _ /=/mapP[zeta /S1_1<- ->]. +Qed. + +Let irrS1 : {subset S1 <= irr M}. +Proof. +move=> _ /seqIndP[s /setDP[kerHC kerHU] ->]; rewrite !inE in kerHC kerHU. +rewrite -(quo_IirrK _ kerHC) // mod_IirrE // cfIndMod // cfMod_irr //. +have /irr_induced_Frobenius_ker := FrobeniusWker frobMtilde; rewrite defM''. +by apply; rewrite quo_Iirr_eq0 // -subGcfker. +Qed. + +Let o1S1 : orthonormal S1. +Proof. exact: sub_orthonormal (seqInd_uniq _ _) (irr_orthonormal _). Qed. + +Let cfdotS1 : {in S1 &, forall zeta xi, '[zeta, xi] = (zeta == xi)%:R}. +Proof. by case/orthonormalP: o1S1. Qed. + +Let omu2S1 i j : {in S1, forall zeta, '[mu2_ i j, zeta] = 0}. +Proof. +move=> zeta S1zeta; have [s _ Dzeta] := seqIndP S1zeta. +rewrite Dzeta -cfdot_Res_l cfRes_prTIirr cfdot_irr mulrb ifN_eq //. +apply: contraNneq (prTIred_not_irr ptiWM j) => Ds. +by rewrite -cfInd_prTIres Ds -Dzeta irrS1. +Qed. + +Let Tmu j : mu_ j \in calT. Proof. by rewrite -cfInd_prTIres mem_seqIndT. Qed. + +Let omuS1 j : {in S1, forall zeta, '[mu_ j, zeta] = 0}. +Proof. +by move=> zeta S1zeta /=; rewrite cfdot_suml big1 // => i _; apply: omu2S1. +Qed. + +Let Zbridge0 : {in S1, forall zeta, bridge0 zeta \in 'Z[irr M, HU^#]}. +Proof. +have mu0_1: mu_ 0 1%g = q%:R by rewrite prTIred_1 prTIirr0_1 mulr1. +move=> zeta S1zeta; rewrite /= zcharD1 !cfunE subr_eq0 mu0_1 S1_1 // eqxx. +by rewrite rpredB ?(seqInd_vchar _ (Tmu 0)) ?(seqInd_vchar _ S1zeta). +Qed. + +Let A0bridge0 : {in S1, forall zeta, bridge0 zeta \in 'CF(M, 'A0(M))}. +Proof. by move=> zeta /Zbridge0/zchar_on/cfun_onS->. Qed. + +Let sS1S2' : {subset S1 <= [predC S2]}. +Proof. +by move=> _ /seqIndP[s /setDP[kHCs _] ->]; rewrite !inE mem_seqInd // inE kHCs. +Qed. + +Let defS2: S2 = seqIndD HU M H H0C. +Proof. by rewrite /S2 H0_1 -!joinGE join1G joinGC seqIndDY. Qed. + +Let cohS2: coherent S2 M^# tau. +Proof. +apply: subset_coherent (Ptype_core_coherence maxM MtypeP notMtype5). +by rewrite defC defS2; apply: seqIndS; rewrite Iirr_kerDS ?genS ?setUS ?der_sub. +Qed. + +Let Smu := [seq mu_ j | j in predC1 0]. +Let Sred := filter [predC irr M] (seqIndD HU M H H0). + +Let memSred : Sred =i Smu. +Proof. +have [szSred _ memSred _] := typeP_reducible_core_Ind maxM MtypeP notMtype5. +have uSred: uniq Sred by apply: filter_uniq (seqInd_uniq _ _). +suffices{uSred}: (size Smu <= size Sred)%N by case/leq_size_perm. +by rewrite szSred def_p size_map -cardE cardC1 nirrW2. +Qed. + +Let mu_1 j : j != 0 -> mu_ j 1%g = (q * u)%:R. +Proof. +move=> nzj; have Smuj: mu_ j \in Sred by rewrite memSred image_f. +have [_ _ _ /(_ _ Smuj)[]] := typeP_reducible_core_Ind maxM MtypeP notMtype5. +by rewrite defC. +Qed. + +Let memS2red : [predD S2 & irr M] =i Smu. +Proof. +move=> xi; rewrite defS2 -memSred mem_filter; apply: andb_id2l => /= red_xi. +apply/idP/idP=> [|Sxi]; first by apply: seqIndS; rewrite Iirr_kerDS ?joing_subl. +have [_ _ _ /(_ xi)] := typeP_reducible_core_Ind maxM MtypeP notMtype5. +by rewrite defC mem_filter /= red_xi; case. +Qed. + +Let i1 : Iirr W1 := inord 1. +Let nz_i1 : i1 != 0. Proof. by rewrite Iirr1_neq0. Qed. +Let j1 : Iirr W2 := inord 1. +Let nz_j1 : j1 != 0. Proof. by rewrite Iirr1_neq0. Qed. + +(* This is Peterfalvi (11.8). *) +(* We have rearranged the argument somewhat: *) +(* - Step (11.8.4) was out of sequence as it involves changing the definition *) +(* of tau2, which requires showing that (11.8.2-3) are preserved by this *) +(* change; since (11.8.4) does not use (11.8.2-3) we avoid this by proving *) +(* (11.8.4) first. *) +(* - The first part of step (11.8.3) is the last fact that needs to be proved *) +(* for an arbitrary j != 0; (11.8.1, 5-6) can all use the same fixed j != 0 *) +(* (we take j = 1), provided (11.8.3) is proved before (11.8.2), which it *) +(* doe not use. *) +(* - Steps (11.8.2) and (11.8.5) are really as combination, to provide an *) +(* expression for tau (alpha i j) for an arbitrary i. We merge their proofs *) +(* so we can use a fixed i for the whole combined step and hide some *) +(* intermediate technical facts. *) +(* - We also reorganise the contents of the superstep, proving most of *) +(* (11.8.5) between the first and last two parts of (11.8.2); this *) +(* simplifies the latter because a is then known to be even, so we can show *) +(* directly that a is 0 or 2, and then that X = eta i j - eta i 0. *) +Lemma FTtype34_not_ortho_cycTIiso zeta : + zeta \in S1 -> ~~ eq_proj_eta (tau (bridge0 zeta)) (eta_col 0). +Proof. +move=> S1zeta; set psi := tau _; apply/negP=> proj_psi_eta. +have irr_zeta: zeta \in irr M := irrS1 S1zeta. +have Szeta: zeta \in S_ 1 by apply: seqInd_sub S1zeta. +have Zzeta_S1: {in S1, forall xi, zeta - xi \in 'Z[S1, M^#]}. + by move=> * /=; rewrite zcharD1E rpredB ?mem_zchar //= !cfunE !S1_1 ?subrr. +have n1S1: {in S1, forall xi, '[xi] = 1} by move=> xi /irrS1/irrWnorm. +have Z_S1: {in S1, forall xi, xi \in 'Z[S1]} by apply: mem_zchar. +have [p_gt0 q_gt0 u_gt0]: [/\ p > 0, q > 0 & u > 0]%N by rewrite !cardG_gt0. +have q_gt2: (q > 2)%N by rewrite odd_prime_gt2 ?mFT_odd. +have mu2_1 i j: j != 0 -> mu2_ i j 1%g = d%:R. + by have [/(_ i j)] := FTtype345_constants maxM MtypeP notMtype2. +(* This is (11.8.1). *) +have [Dd delta1 Dn]: [/\ d = u, delta = 1 & n = (size S1)%:R]. + have size_S1 : (size S1 * q = u - 1)%N. + rewrite mulnC [q](index_sdprod defM). + rewrite (size_irr_subseq_seqInd _ (subseq_refl _)) //. + transitivity #|[set mod_Iirr t | t : Iirr (HU / HC) in predC1 0]|. + apply/eq_card=> s; rewrite inE mem_seqInd // !inE subGcfker. + apply/andP/imsetP=> [[nzs kHCs] | [t nzt ->]]. + by exists (quo_Iirr HC s); rewrite ?quo_IirrK // inE quo_Iirr_eq0. + by rewrite mod_Iirr_eq0 // mod_IirrE // cfker_mod. + rewrite card_imset; last exact: can_inj (mod_IirrK _). + have isoUC: U / C \isog HU / HC by apply: quotient_sdprodr_isog. + rewrite subn1 cardC1 card_Iirr_abelian -?(card_isog isoUC) //. + by rewrite -(isog_abelian isoUC) defU' der_abelian. + have Dd: d = u. + apply/eqP; rewrite -(eqn_pmul2l q_gt0) -eqC_nat -(mu_1 nz_j1). + by rewrite natrM prTIred_1 mu2_1. + suffices delta1: delta = 1. + by rewrite /n Dd delta1 -(@natrB _ _ 1) // -size_S1 natrM mulfK ?neq0CG. + have: (delta == 1 %[mod q])%C. + rewrite -(eqCmod_transl _ (prTIirr1_mod ptiWM 0 j1)) mu2_1 // -/q Dd. + by rewrite /eqCmod -(@natrB _ u 1) // dvdC_nat -size_S1 dvdn_mull. + rewrite -[1]subr0 [delta]signrE -/ptiWM eqCmodDl eqCmodN opprK. + by rewrite eqCmod0_nat; case: (Idelta j1); first rewrite gtnNdvd. +have deltaZ gamma: delta *: gamma = gamma by rewrite delta1 scale1r. +have [tau1 coh_tau1] := cohS1; pose zeta1 := tau1 zeta. +(* This is (11.8.4). *) +without loss Dpsi: tau1 coh_tau1 @zeta1 / psi = eta_col 0 - zeta1. + move=> IHtau1; have [[Itau1 Ztau1] Dtau1] := coh_tau1. + have tau1_dirr: {in S1, forall xi, tau1 xi \in dirr G}. + by move=> xi S1xi; rewrite /= dirrE Ztau1 ?Itau1 ?mem_zchar //= n1S1. + pose chi : 'CF(G) := eta_col 0 - psi. + have Dpsi: psi = eta_col 0 - chi by rewrite opprD opprK addNKr. + have chi'zeta1: chi <> zeta1. + by move=> Dchi; case: (IHtau1 tau1); rewrite -/zeta1 -?Dchi. + have dirr_chi: chi \in dirr G. + apply: dirr_norm1. + rewrite rpredB ?rpred_sum // => [i _|]; first exact: cycTIiso_vchar. + rewrite Dade_vchar // zchar_split A0bridge0 //. + by rewrite rpredB ?char_vchar ?prTIred_char ?irrWchar. + apply: (addrI q%:R); transitivity '[psi]; last first. + rewrite Dade_isometry ?A0bridge0 // (cfnormBd (omuS1 _ _)) //. + by rewrite cfnorm_prTIred n1S1. + rewrite Dpsi [RHS]cfnormDd; last first. + rewrite opprB cfdotC cfdot_sumr big1 ?conjC0 // => i _. + by rewrite (orthoPl proj_psi_eta) ?map_f ?mem_irr. + rewrite cfnormN -nirrW1 -sumr_const cfdot_sumr. + by congr (_ + _); apply: eq_bigr => i _; rewrite proj_col_eta. + have Dchi: {in S1, forall xi, xi != zeta -> chi = - tau1 xi}. + move=> xi S1xi /negPf-zeta'xi; have irr_xi := irrS1 S1xi. + suffices: '[zeta1 - tau1 xi, chi] = 1. + by case/cfdot_add_dirr_eq1; rewrite ?rpredN ?tau1_dirr. + rewrite /= cfdotBr cfdot_sumr big1 => [|i _]; last first. + have oS1eta := coherent_ortho_cycTIiso MtypeP sS10 coh_tau1. + by rewrite cfdotBl !oS1eta ?irrS1 ?subrr. + rewrite -raddfB Dtau1 ?Zzeta_S1 // Dade_isometry ?A0bridge0 //; last first. + exact: cfun_onS sHU_A0 (zcharD1_seqInd_on _ (Zzeta_S1 xi S1xi)). + rewrite cfdotBr cfdotC cfdotBr 2?omuS1 // subrr conjC0 !sub0r opprK. + by rewrite cfdotBl n1S1 // cfdotS1 // zeta'xi subr0. + have S1zetaC: zeta^*%CF \in S1 by rewrite cfAut_seqInd. + have Dchi_zetaC: chi = - tau1 zeta^*%CF. + by rewrite -Dchi ?(seqInd_conjC_neq _ _ _ S1zeta) ?mFT_odd. + suffices S1le2: (size S1 <= size [:: zeta; zeta^*%CF])%N. + case: (IHtau1 (dual_iso tau1)); last by rewrite /= -Dchi_zetaC. + exact: dual_coherence scohS1 coh_tau1 S1le2. + rewrite uniq_leq_size ?seqInd_uniq // => xi S1xi. + rewrite !inE -implyNb; apply/implyP=> zeta'xi; apply/eqP. + apply: (Zisometry_inj Itau1); rewrite ?mem_zchar ?cfAut_seqInd //. + by apply: oppr_inj; rewrite -Dchi. +have [[Itau1 Ztau1] Dtau1] := coh_tau1. +have tau1_dirr: {in S1, forall xi, tau1 xi \in dirr G}. + by move=> xi S1xi; rewrite /= dirrE Ztau1 ?Itau1 ?mem_zchar //= n1S1. +have oS1eta i j: {in S1, forall xi, '[tau1 xi, eta_ i j] = 0}. + by move=> xi S1xi /=; rewrite (coherent_ortho_cycTIiso _ _ coh_tau1) ?irrS1. +pose alpha_ := FTtype345_bridge MtypeP zeta. +have A0alpha i j : j != 0 -> alpha_ i j \in 'CF(M, 'A0(M)). + by move/supp_FTtype345_bridge->; rewrite ?S1_1. +have alpha_S1 i j: {in S1, forall xi, '[alpha_ i j, xi] = n *- (xi == zeta)}. + move=> xi S1xi; rewrite /= !cfdotBl !cfdotZl !omu2S1 // mulr0 subrr add0r. + by rewrite cfdotS1 // eq_sym mulr_natr. +pose beta_ i j := tau (alpha_ i j) - (eta_ i j - eta_ i 0) + n *: zeta1. +pose beta := beta_ 0 j1. +(* This is the first part of (11.8.3). *) +have betaE i j: j != 0 -> beta_ i j = beta. + move=> nz_j; transitivity (beta_ i j1); congr (_ + _); apply/eqP. + rewrite eq_sym -subr_eq0 [rhs in _ + rhs]opprD addrACA -opprD subr_eq0. + rewrite -linearB /= !opprB !addrA !subrK -!/(mu2_ i _). + by rewrite [Dade pddM _]prDade_sub_TIirr ?mu2_1 //= deltaZ. + rewrite -subr_eq0 !opprD addrACA -3!opprD opprK subr_eq0 addrACA addrA. + rewrite -(prDade_sub2_TIirr pddM) -!/(mu2_ _ _) !deltaZ -linearB /=. + by rewrite opprB addrA subrK !deltaZ opprD opprK addrACA addrA. +pose j := j1. (* The remainder of the proof only uses j = 1. *) +(* This is the second part of (11.8.3). *) +have Rbeta: cfReal beta. + rewrite /cfReal eq_sym -subr_eq0 rmorphD !rmorphB /= opprB 2!opprD opprB -/j. + rewrite 2![(eta_ 0 _)^*%CF]cfAut_cycTIiso -!cycTIirr_aut !aut_Iirr0 -Dade_aut. + set k := aut_Iirr conjC j; rewrite -(betaE 0 k) ?aut_Iirr_eq0 // addrACA. + rewrite addrC addr_eq0 addrCA subrK opprD opprK Dn raddfZnat -!raddfB /= -Dn. + apply/eqP; rewrite (cfConjC_Dade_coherent coh_tau1) ?mFT_odd // -raddfB. + rewrite Dtau1 ?Zzeta_S1 ?cfAut_seqInd //= -linearZ scalerBr; congr (tau _). + rewrite opprD !rmorphB !deltaZ /= -!prTIirr_aut !aut_Iirr0 addrACA subrr. + by rewrite add0r opprK addrC Dn -raddfZnat. +(* This is the consequence of Peterfalvi (11.8.2) and (11.8.5). *) +have tau_alpha i: tau (alpha_ i j) = eta_ i j - eta_ i 0 - n *: zeta1. + set phi := tau (alpha_ i j); pose sum_tau1 := \sum_(xi <- S1) tau1 xi. + have A0alpha_j k: alpha_ k j \in 'CF(M, 'A0(M)) by apply: A0alpha. + have Zphi: phi \in 'Z[irr G]. + by rewrite Dade_vchar // zchar_split vchar_FTtype345_bridge /=. + have [Y S1_Y [X [Dphi oYX oXS1]]] := orthogonal_split (map tau1 S1) phi. + (* This is the first part of 11.8.2 *) + have [a Za defY]: exists2 a, a \in Cint & Y = a *: sum_tau1 - n *: zeta1. + have [a_ Da defY] := orthonormal_span (map_orthonormal Itau1 o1S1) S1_Y. + have{Da} Da: {in S1, forall xi, a_ (tau1 xi) = '[phi, tau1 xi]}. + by move=> xi Sxi; rewrite Da Dphi cfdotDl (orthoPl oXS1) ?map_f ?addr0. + exists (a_ (tau1 zeta) + n). + by rewrite Dn rpredD ?rpred_nat // Da // Cint_cfdot_vchar ?Ztau1 ?Z_S1. + rewrite defY big_map scaler_sumr !(bigD1_seq _ S1zeta) ?seqInd_uniq //=. + rewrite addrAC scalerDl addrK !(big_seq_cond (predC1 _)) /=; congr (_ + _). + apply: eq_bigr => xi /andP[S1xi zeta'xi]; congr (_ *: _); rewrite !Da //. + apply: canRL (addNKr _) _; rewrite addrC -opprB -!raddfB Dtau1 ?Zzeta_S1//=. + rewrite Dade_isometry //; last first. + exact: cfun_onS (zcharD1_seqInd_on _ (Zzeta_S1 _ S1xi)). + by rewrite cfdotBr !alpha_S1 // !mulrb eqxx ifN_eq // !(addr0, opprK). + have psi_phi: '[psi, phi] = -1 + n. (* This is part of (11.8.5). *) + rewrite cfdotC Dade_isometry ?A0bridge0 //. + rewrite cfdotBr !cfdotBl deltaZ !cfdotZl n1S1 // mulr1. + rewrite !cfdot_prTIirr_red (negPf nz_j1) eqxx !omu2S1 //= cfdotC omuS1 //. + by rewrite conjC0 mulr0 opprB !subr0 add0r rmorphD rmorphN Dn !rmorph_nat. + have{psi_phi} col0_beta: '[eta_col 0, beta] = a. (* Also part of (11.8.5). *) + apply/(addIr (-1 + n))/(canRL (addNKr _)). + rewrite addrCA addrA addrACA -{}psi_phi Dpsi cfdotBl; congr (_ + _). + rewrite -(betaE i j) // cfdotDr !cfdotBr -/phi cfdotZr -!addrA. + apply/(canLR (addNKr _)); rewrite addNr !cfdot_suml. + rewrite big1 ?add0r ?opprK => [|k _]; last first. + by rewrite cfdot_cycTIiso andbC eq_sym (negPf nz_j1). + rewrite addrCA big1 ?mulr0 ?add0r => [|k _]; last first. + by rewrite cfdotC oS1eta ?conjC0. + rewrite addrC (bigD1 i) // cfnorm_cycTIiso /= addKr big1 // => k i'k. + by rewrite cfdot_cycTIiso (negPf i'k). + rewrite cfdotC Dphi cfdotDl (orthoPl oXS1) ?map_f // addr0. + rewrite defY cfdotBl scaler_sumr cfproj_sum_orthonormal //. + rewrite cfdotZl Itau1 ?mem_zchar ?n1S1 // mulr1 rmorphB opprD opprK. + by rewrite Dn rmorph_nat conj_Cint. + have a_even: (2 %| a)%C. (* Third internal part of (11.8.5). *) + have Zbeta: beta \in 'Z[irr G]. + rewrite -{1}(betaE i j) // rpredD ?rpredB ?Zphi ?cycTIiso_vchar //. + by rewrite Dn rpredZnat // Ztau1 ?mem_zchar. + rewrite -col0_beta cfdot_real_vchar_even ?mFT_odd //; first 1 last. + split; first by apply/rpred_sum=> k _; apply: cycTIiso_vchar. + apply/eqP; rewrite [RHS](reindex_inj (can_inj (@conjC_IirrK _ _))) /=. + rewrite rmorph_sum; apply/eq_bigr=> k _ /=. + by rewrite cfAut_cycTIiso -cycTIirr_aut aut_Iirr0. + have eta00: eta_ 0 0 = 1 by rewrite cycTIirr00 cycTIiso1. + rewrite orbC cfdotDl 2!cfdotBl cfdotZl -eta00 oS1eta // mulr0 addr0. + rewrite opprB addrC 2!{1}cfdot_cycTIiso (negPf nz_j1) subr0 /= eta00. + rewrite Dade_reciprocity // => [|x _ y _]; last by rewrite !cfun1E !inE. + rewrite cfRes_cfun1 !cfdotBl deltaZ !cfdotZl -!/(mu2_ 0 _). + rewrite -(prTIirr00 ptiWM) !cfdot_prTIirr cfdotC omu2S1 // conjC0 mulr0. + by rewrite (negPf nz_j1) add0r subr0 subrr rpred0. + have nY: '[Y] = n * a * (a - 2%:R) + n ^+ 2. (* Resuming step (11.8.2). *) + rewrite defY cfnormD cfnormN !cfnormZ cfdotNr cfdotZr. + rewrite cfnorm_map_orthonormal // -Dn Itau1 ?mem_zchar ?n1S1 // mulr1. + rewrite scaler_sumr cfproj_sum_orthonormal // rmorphN addrAC. + rewrite Dn rmorphM !Cint_normK ?rpred_nat // !rmorph_nat conj_Cint // -Dn. + by rewrite -mulr2n mulrC mulrA -mulr_natr mulNr -mulrBr. + have{a_even} Da: (a == 0) || (a == 2%:R). (* Second part of (11.8.2). *) + suffices (b := a - 1): b ^+ 2 == 1. + by rewrite -!(can_eq (subrK 1) a) add0r addrK orbC -eqf_sqr expr1n. + have S1gt0: (0 < size S1)%N by case: (S1) S1zeta. + have: n * b ^+ 2 <= n *+ 3. + have: 2%:R + n <= n *+ 3 by rewrite addrC ler_add2l ler_muln2r Dn ler1n. + apply: ler_trans; rewrite sqrrB1 -mulr_natr -mulrBr mulrDr mulrA mulr1. + rewrite ler_add2r -(ler_add2r (n ^+ 2 + '[X])) !addrA -nY -cfnormDd //. + by rewrite -Dphi norm_FTtype345_bridge ?S1_1 // ler_addl cfnorm_ge0. + have Zb: b \in Cint by rewrite rpredB ?rpred1 ?Za. + have nz_b: b != 0 by rewrite subr_eq0 (memPn _ a a_even) ?(dvdC_nat 2 1). + rewrite eqr_le sqr_Cint_ge1 {nz_b}//= andbT -Cint_normK // Dn -mulrnA. + have /CnatP[m ->] := Cnat_norm_Cint Zb; rewrite -natrX -natrM leC_nat. + by rewrite leq_pmul2l // lern1 -ltnS (ltn_sqr m 2) (leq_sqr m 1). + have{nY Da} defX: X = eta_ i j - eta_ i 0. (* Last part of (11.8.2). *) + have{nY Da} /eqP-nY: '[Y] == n ^+ 2. + by rewrite -subr_eq0 nY addrK -mulrA !mulf_eq0 !subr_eq0 Da orbT. + have coh_zeta_phi := FTtype345_bridge_coherence _ _ Szeta _ coh_tau1. + have:= Dphi; rewrite addrC => /coh_zeta_phi->; rewrite ?S1_1 ?deltaZ //. + rewrite defY scaler_sumr big_seq rpredB ?rpred_sum // => [xi Sxi|]. + by rewrite rpredZ_Cint ?mem_zchar ?map_f. + by rewrite Dn rpredZnat ?mem_zchar ?map_f. + have{col0_beta} a0: a = 0. (* This is the conclusion of (11.8.5). *) + rewrite cfdot_suml big1 // in col0_beta => k _. + rewrite -(betaE i j) // /beta_ -/phi Dphi -defX addrK defY subrK. + rewrite cfdotZr cfdot_sumr big1_seq ?mulr0 // => xi S1xi. + by rewrite cfdotC oS1eta ?conjC0. + by rewrite Dphi defY defX a0 ?inE ?eqxx // scale0r sub0r addrC. +(* This is step (11.8.6). *) +pose theta := mu_ j - d%:R *: zeta. +have /andP/=[red_muj S2muj]: mu_ j \in [predD S2 & irr M]. + by rewrite memS2red image_f. +have HUtheta: theta \in 'CF(M, HU^#). + rewrite cfun_onD1 !cfunE mu_1 ?S1_1 // Dd mulrC natrM subrr eqxx. + by rewrite rpredB ?rpredZ ?(seqInd_on _ S1zeta) ?(seqInd_on _ S2muj). +have Dtheta: theta = mu_ 0 - zeta + \sum_i alpha_ i j. + rewrite !sumrB -scaler_sumr delta1 scale1r. + rewrite [X in _ = X]addrC -!addrA -/(mu_ 0); congr (_ + _). + rewrite [X in _ = _ + X]addrC !addrA addNr add0r -opprD; congr (- _). + rewrite sumr_const nirrW1 -scaler_nat scalerA mulrC. + by rewrite divfK ?neq0CG // delta1 addrC scalerBl scale1r subrK. +have tau_theta: tau theta = eta_col j - d%:R *: zeta1. + pose psi1 i := eta_ i j1 - eta_ i 0 - n *: zeta1. + have Dpsi1 i: tau (alpha_ i j) = psi1 i by apply: tau_alpha. + rewrite Dtheta [tau _]raddfD raddf_sum (eq_bigr psi1) //= {Dpsi1}/psi1 -/psi. + rewrite Dpsi !sumrB [X in X = _]addrC -!addrA; congr (_ + _). + rewrite -opprB -opprD -opprB -/(eta_col 0) addrA addrK; congr (- _). + rewrite sumr_const nirrW1 -scaler_nat scalerA mulrC. + by rewrite divfK ?neq0CG // delta1 scalerBl scale1r subrK. +have [tau2 coh_tau2] := cohS2. +without loss tau2muj: tau2 coh_tau2 / tau2 (mu_ j) = eta_col j; last first. + case: FTtype34_noncoherence; rewrite H0_1 -joinGE join1G. + have uS12: uniq (S2 ++ S1). + by rewrite cat_uniq ?seqInd_uniq ?andbT //=; apply/hasPn. + have /perm_eq_coherent: perm_eq (S2 ++ S1) (S_ C); last apply. + apply: uniq_perm_eq; rewrite ?seqInd_uniq // => xi; rewrite mem_cat. + apply/idP/idP=> [/orP | /seqIndP[i /setDP[kCi k'HUi] ->]]. + by case; apply/seqIndS/Iirr_kerDS; rewrite ?joing_subr. + by rewrite !mem_seqInd // inE orbC inE kCi k'HUi andbT orbN. + move: tau_theta; rewrite -tau2muj // -raddfZnat. + apply: (bridge_coherent scohM) sS20 coh_tau2 sS10 coh_tau1 sS1S2' _. + by rewrite (cfun_onS _ HUtheta) ?setSD // rpredZnat ?Z_S1. +move=> IHtau2; apply: (IHtau2 tau2 coh_tau2); have [IZtau2 Dtau2] := coh_tau2. +have{IHtau2} /hasP[xi S2xi /=irr_xi]: has [mem irr M] S2. + apply/hasPn=> redS2 {tau2 coh_tau2 IZtau2 Dtau2}. + have muS2: {subset S2 <= Smu} by move=> xi S2xi; rewrite -memS2red !inE redS2. + have [_ [tau2 tau2mu coh_tau2]] := uniform_prTIred_coherent pddM nz_j1. + have S2uniform: {subset S2 <= uniform_prTIred_seq pddM j}. + move=> _ /muS2/imageP[k nz_k ->]; apply: image_f. + by rewrite !inE [_ != 0]nz_k /= !mu_1. + apply: (IHtau2 tau2); first exact: subset_coherent_with coh_tau2. + have [_ /(_ _ nz_j1) Ez _ _] := FTtype345_constants maxM MtypeP notMtype2. + by have:= tau2mu j; rewrite Ez -/delta delta1 scale1r. +suffices: '[tau2 (mu_ j), eta_col j] != 0. + have:= FTtypeP_coherent_TIred sS20 coh_tau2 irr_xi S2xi S2muj. + case=> _ -> [[-> ->] | [-> -> _] /eqP[]]; first by rewrite deltaZ. + rewrite -[cyclicTIiso _]/sigma cfdot_sumr big1 ?mulr0 // => i _. + rewrite cfdotZl proj_col_eta -(inj_eq irr_inj) conjC_IirrE eq_sym. + by rewrite odd_eq_conj_irr1 ?mFT_odd // irr_eq1 (negPf nz_j1) mulr0. +pose gamma := xi 1%g *: mu_ j - mu_ j 1%g *: xi. +have: '[tau2 gamma, tau theta] != 0. + have [Txi Tzeta] := (seqInd_subT S2xi, seqInd_subT S1zeta). + have S2gamma: gamma \in 'Z[S2, HU^#] by apply: sub_seqInd_zchar. + rewrite Dtau2 ?zcharD1_seqInd //; move/zchar_on in S2gamma. + rewrite Dade_isometry ?(cfun_onS sHU_A0) // cfdotBr cfdotZr !cfdotBl !cfdotZl. + rewrite cfnorm_prTIred omuS1 // (seqInd_ortho _ _ S2muj) ?(memPn red_muj) //. + rewrite (seqInd_ortho _ Txi) ?(memPn (sS1S2' _)) // !(mulr0, subr0) mulf_eq0. + by rewrite char1_eq0 ?irrWchar // -cfnorm_eq0 irrWnorm ?oner_eq0 ?neq0CG. +apply: contraNneq => o_muj_etaj; rewrite {}tau_theta !{gamma}raddfB subr_eq0 /=. +have /CnatP[xi1 ->]: xi 1%g \in Cnat by rewrite Cnat_char1 ?irrWchar. +rewrite mu_1 // cfdotZr !cfdotBl !raddfZnat !cfdotZl {}o_muj_etaj cfdot_sumr. +have /orthogonalP oS2_S1: orthogonal (map tau2 S2) (map tau1 S1). + exact: (coherent_ortho scohM) sS20 coh_tau2 sS10 coh_tau1 sS1S2'. +rewrite !oS2_S1 ?map_f // big1 ?(mulr0, subr0) // => k _. +exact: (coherent_ortho_cycTIiso _ _ coh_tau2). +Qed. + +(* This is Peterfalvi (11.9). *) +(* Note that in the proof of part (a), the text improperly suggests using *) +(* (5.3.b) to show then tau (zeta - zeta^alpha) is orthogonal to the eta i j. *) +(* Since alpha might not be conjugation, this is not obvious. Indeed the best *) +(* way to derive this is to use (5.5) together with the coherence of S(HC). *) +(* In part (c) we start by reducing the proof to q <= p - 1; we also don't *) +(* compute [tau (mu0 - zeta), tau2 lambda] = [chi, tau2 lambda] since this *) +(* is not needed to prove than u = a: one only needs to show that the *) +(* the left-hand side is an integer, which is in fact required to show that *) +(* the right-hand is an integer. *) +Lemma FTtype34_structure (eta0row := \sum_j eta_ 0 j) : + [/\ (*a*) {in S1, forall zeta, eq_proj_eta (tau (bridge0 zeta)) eta0row}, + (*b*) (p < q)%N + & (*c*) FTtype M == 3 /\ typeP_Galois MtypeP]. +Proof. +have sum_etaW F: \sum_(eta <- etaW) F eta = \sum_i \sum_j F (eta_ i j). + rewrite big_map big_tuple (reindex (dprod_Iirr defW)) /=. + by rewrite pair_bigA; apply: eq_bigr => -[i j]. + by exists (inv_dprod_Iirr defW) => ij; rewrite ?dprod_IirrK ?inv_dprod_IirrK. +have bridgeS1: {in S1, forall zeta, eq_proj_eta (tau (bridge0 zeta)) eta0row}. + move=> zeta S1zeta; set phi := bridge0 zeta; have irr_zeta := irrS1 S1zeta. + have [X etaX [chi [Dchi oXchi o_chi_eta]]] := orthogonal_split etaW (tau phi). + have [Isigma Zsigma] := cycTI_Zisometry ctiWG. + have{o_chi_eta} o_chi_eta i j: '[chi, eta_ i j] = 0. + by rewrite (orthoPl o_chi_eta) ?map_f ?mem_irr. + have o1etaW: orthonormal etaW by rewrite map_orthonormal ?irr_orthonormal. + have [a Da defX] := orthonormal_span o1etaW etaX; pose a_ := a (eta_ _ _). + have{Da} Da i j: a_ i j = '[tau phi, eta_ i j]. + by rewrite Dchi cfdotDl o_chi_eta addr0 /a_ Da. + have Zphi: phi \in 'Z[irr M, HU^#] by apply: Zbridge0. + have A0phi: phi \in 'CF(M, 'A0(M)) by apply: A0bridge0. + have a00_1 : a_ 0 0 = 1. + rewrite Da cycTIirr00 [sigma 1]cycTIiso1. + rewrite Dade_reciprocity // => [|x _ y _]; last by rewrite !cfun1E !inE. + rewrite rmorph1 /= -(prTIirr00 ptiWM) -/(mu2_ 0 0) cfdotC. + by rewrite cfdotBr cfdot_prTIirr_red omu2S1 // subr0 rmorph1. + have aut_phi nu: cfAut nu (tau phi) = tau phi + tau (zeta - cfAut nu zeta). + rewrite -Dade_aut !rmorphB !raddfB /= !addrA subrK. + by rewrite -prTIred_aut aut_Iirr0. + have Za i j: a_ i j \in Cint. + rewrite Da Cint_cfdot_vchar ?cycTIiso_vchar //. + by rewrite Dade_vchar ?(zchar_onS sHU_A0). + have [tau1 coh_tau1] := cohS1; have [_ Dtau1] := coh_tau1. + have o_tau1_eta := coherent_ortho_cycTIiso MtypeP sS10 coh_tau1. + have a_aut nu i j: a (cfAut nu (eta_ i j)) = a_ i j. + symmetry; transitivity '[cfAut nu (tau phi), cfAut nu (eta_ i j)]. + by rewrite cfdot_aut_vchar ?cycTIiso_vchar // -Da aut_Cint. + rewrite aut_phi cfAut_cycTIiso -cycTIirr_aut [a _]Da cfdotDl addrC. + rewrite -Dtau1 ?zcharD1_seqInd ?seqInd_sub_aut_zchar // raddfB cfdotBl. + by rewrite !o_tau1_eta ?cfAut_seqInd ?cfAut_irr // subr0 add0r. + pose a10 := a_ i1 0; pose a01 := a_ 0 j1; pose a11 := a_ i1 j1. + have Da10 i: i != 0 -> a_ i 0 = a10. + case/(cfExp_prime_transitive pr_q nz_i1) => k co_k_wi1 Dwi. + rewrite -(cforder_dprodl defW) -dprod_IirrEl in co_k_wi1. + have [[nu eta10nu] _] := cycTIiso_aut_exists ctiWG co_k_wi1. + by rewrite /a_ dprod_IirrEl Dwi rmorphX /= -dprod_IirrEl eta10nu a_aut. + have Da01 j: j != 0 -> a_ 0 j = a01. + case/(cfExp_prime_transitive pr_p nz_j1) => k co_k_wj1 Dwj. + rewrite -(cforder_dprodr defW) -dprod_IirrEr in co_k_wj1. + have [[nu eta01nu] _] := cycTIiso_aut_exists ctiWG co_k_wj1. + by rewrite /a_ dprod_IirrEr Dwj rmorphX /= -dprod_IirrEr eta01nu a_aut. + have DaB1 i j: a_ i j = a_ i 0 + a_ 0 j - a_ 0 0. + apply: (canRL (addrK _)); rewrite !Da cycTIiso_cfdot_exchange // => x Vx. + have /setDP[A0x A'x]: x \in 'A0(M) :\: 'A(M). + by rewrite (FTsupp0_typeP maxM MtypeP) // mem_class_support. + by rewrite Dade_id // (cfun_on0 (zchar_on Zphi)) // -defA. + pose p1 : algC := p.-1%:R; pose q1 : algC := q.-1%:R. + have normX: '[X] = 1 + q1 * a10 ^+ 2 + p1 * a01 ^+ 2 + p1 * q1 * a11 ^+ 2. + transitivity (\sum_i \sum_j a_ i j ^+ 2). + rewrite defX cfnorm_sum_orthonormal // sum_etaW. + by apply/eq_bigr=> i _; apply/eq_bigr=> j _; rewrite Cint_normK ?Za. + rewrite -addrA addrACA (bigD1 0) //= (bigD1 0) //= a00_1 expr1n. + rewrite -natrM !mulr_natl mulrnA -mulrnDl. + rewrite -nirrW1 -nirrW2 -!(cardC1 0) -!sumr_const. + congr (1 + _ + _); first by apply: eq_bigr => j /Da01->. + apply: eq_bigr => i /Da10-Dai0; rewrite (bigD1 0) //= Dai0; congr (_ + _). + by apply: eq_bigr => j /Da01-Da0j; rewrite DaB1 Dai0 Da0j -DaB1. + have normX_le_q: '[X] <= q%:R. + rewrite -(ler_add2r '[chi]) -cfnormDd // -Dchi -ler_subl_addl. + have ->: '[tau phi] - q%:R = 1. + rewrite Dade_isometry ?A0bridge0 // cfnormBd; last by rewrite omuS1. + by rewrite cfnorm_prTIred cfdotS1 // eqxx addrC addKr. + suffices: '[chi] != 0. + suffices /CnatP[nchi ->]: '[chi] \in Cnat by rewrite ler1n lt0n -eqC_nat. + rewrite Cnat_cfnorm_vchar // -(canLR (addKr _) Dchi) defX addrC rpredB //. + by rewrite Dade_vchar // (zchar_onS (FTsupp_sub0 M)) ?defA. + rewrite big_map big_seq rpred_sum // => _ /(cycTIirrP defW)[i [j ->]]. + by rewrite rpredZ_Cint ?Za ?cycTIiso_vchar. + pose theta := zeta - zeta^*%CF. + have Ztheta: theta \in 'Z[S1, HU^#] by apply: seqInd_sub_aut_zchar. + have: '[tau phi, tau theta] != 0. + rewrite Dade_isometry //; last by rewrite (cfun_onS _ (zchar_on Ztheta)). + rewrite cfdotBl !cfdotBr ?omuS1 ?cfAut_seqInd // subr0 add0r oppr_eq0. + rewrite irrWnorm // (seqInd_conjC_ortho _ _ _ S1zeta) ?mFT_odd //. + by rewrite subr0 oner_eq0. + rewrite cfnorm_eq0 Dchi; apply: contraNneq => ->; rewrite addr0 defX. + rewrite -Dtau1 ?zcharD1_seqInd //. + rewrite cfdot_suml big_map big1_seq // => _ /(cycTIirrP defW)[i [j ->]]. + apply/eqP; rewrite cfdotC fmorph_eq0 cfdotZr raddfB cfdotBl. + by rewrite !o_tau1_eta ?cfAut_seqInd ?irr_aut // subrr mulr0. + have a2_ge0 i j: 0 <= a_ i j ^+ 2 by rewrite -realEsqr Creal_Cint. + have a11_0: a11 = 0. + have: ('[X] < (2 * q.-1)%:R). + rewrite (ler_lt_trans normX_le_q) // ltC_nat -subn1 mulnBr ltn_subRL. + by rewrite !mul2n -!addnn ltn_add2r odd_prime_gt2 ?mFT_odd. + apply: contraTeq => nz_a11; rewrite ler_gtF // normX ler_paddl //. + by rewrite !mulr_natl ?addr_ge0 ?ler01 ?mulrn_wge0 ?a2_ge0. + rewrite -mulr_natl -natrM ?ler_pmul ?natr_ge0 ?sqr_Cint_ge1 ?Za //. + by rewrite leC_nat leq_mul // -subn1 ltn_subRL odd_prime_gt2 ?mFT_odd. + rewrite a11_0 expr0n /= mulr0 addr0 in normX. + have a10_a01: a10 + a01 = 1. + by apply/eqP; rewrite -subr_eq0 -a00_1 -DaB1 -/a11 a11_0. + have{o_chi_eta} o_chi_eta: orthogonal chi etaW. + by apply/orthoPl=> _ /mapP[_ /(cycTIirrP defW)[i [j ->]] ->]. + have a10_0: a10 = 0. + apply: contraNeq (FTtype34_not_ortho_cycTIiso S1zeta) => nz_a10. + have a01_0: a01 = 0. + apply: contraTeq normX_le_q => nz_a01; rewrite normX ltr_geF //. + rewrite ltr_spaddr 1?mulr_gt0 ?ltr0n -?subn1 ?subn_gt0 ?prime_gt1 //. + by rewrite ltr_def sqrf_eq0 nz_a01 a2_ge0. + rewrite -ler_subl_addl -(natrB _ (prime_gt0 pr_q)) subn1 -mulr_natl. + by rewrite ler_wpmul2l ?ler0n // sqr_Cint_ge1 ?Za. + suffices <-: X = eta_col 0 by rewrite Dchi /eq_proj_eta addrC addKr. + rewrite defX sum_etaW exchange_big (bigD1 0) //= addrC. + rewrite big1 ?add0r => [|j nz_j]; first apply: eq_bigr => i _; last first. + rewrite (bigD1 0) // [a _]Da01 //= a01_0 scale0r add0r big1 // => i nz_i. + by rewrite [a _]DaB1 Da10 // Da01 // a10_a01 a00_1 subrr scale0r. + have [-> | nz_i] := eqVneq i 0; first by rewrite [a _]a00_1 scale1r. + by rewrite [a _]Da10 // (canRL (addrK _) a10_a01) a01_0 subr0 scale1r. + suffices <-: X = eta0row by rewrite Dchi /eq_proj_eta addrC addKr. + rewrite defX sum_etaW (bigD1 0) //= addrC. + rewrite big1 ?add0r => [|i nz_i]; first apply: eq_bigr => j _; last first. + rewrite (bigD1 0) // [a _]Da10 //= a10_0 scale0r add0r big1 // => j nz_j. + by rewrite [a _]DaB1 Da10 // Da01 // a10_a01 a00_1 subrr scale0r. + have [-> | nz_j] := eqVneq j 0; first by rewrite [a _]a00_1 scale1r. + by rewrite [a _]Da01 // (canRL (addKr _) a10_a01) a10_0 oppr0 add0r scale1r. +have [zeta [irr_zeta Szeta zeta1]] := FTtypeP_ref_irr maxM MtypeP. +have{zeta1} [S1zeta zeta1]: zeta \in S1 /\ zeta 1%g = q%:R. + split=> //; have [k nz_k Dzeta] := seqIndC1P Szeta. + rewrite Dzeta mem_seqInd // !inE subGcfker nz_k -defM'' lin_char_der1 //. + rewrite -mulr_natl Dzeta cfInd1 //= -(index_sdprod defM) in zeta1. + by apply/andP; rewrite irr_char -(mulfI _ zeta1) ?neq0CG. +have{Szeta} ltpq: (p < q)%N. + rewrite ltn_neqAle neq_pq leqNgt /=. + apply: contra (FTtype34_not_ortho_cycTIiso S1zeta) => ltqp. + case/(FTtype345_Dade_bridge0 _ MtypeP): Szeta => // chi [-> _ _ o_chi_eta]. + rewrite /eq_proj_eta addrC addKr (orthogonal_oppl chi). + by apply/orthoPl=> _ /mapP[_ /(cycTIirrP defW)[i [j ->]] ->]. +suffices galM: typeP_Galois MtypeP. + have [_ [_ _ _ [/= cycUbar _ _]]] := typeP_Galois_P maxM notMtype5 galM. + have{cycUbar} cycUbar: cyclic (U / U') by rewrite -defU' -defC. + have nilU: nilpotent U by have [_ []] := MtypeP. + case/orP: Mtype34 => // /(compl_of_typeIV maxM MtypeP)[_ /negP[]]. + exact/cyclic_abelian/cyclic_nilpotent_quo_der1_cyclic. +apply: contraLR ltpq => gal'M; rewrite -leqNgt (leq_trans _ (leq_pred _)) //. +have [_ _ _] := typeP_nonGalois_characters maxM notMtype5 gal'M. +case: (_ gal'M) => H1 /= [_ _ nH1U _ []]; set a := #|U : _| => a_gt1. +rewrite def_p -/q -defU' -defS2 => a_dv_p1 cycUhat _. +set irr_qa := [pred lambda in irr M | lambda 1%g == (q * a)%:R] => S2_qa. +have{S2_qa}/hasP[lambda S2lambda /andP[irr_lambda /eqP-lambda1]]: has irr_qa S2. + have [a2_dv_pu] := S2_qa; rewrite has_count; apply: leq_trans. + rewrite -(@ltn_pmul2r (a ^ 2 * #|C|)); last first. + by rewrite !muln_gt0 (ltnW a_gt1) cardG_gt0. + by rewrite mul0n divnK // muln_gt0 cardG_gt0 -subn1 subn_gt0 prime_gt1. +have{nH1U cycUhat} a_dv_u: a %| u. + rewrite /u card_quotient ?normal_norm // indexgS // defU'. + rewrite der1_min ?cyclic_abelian // normsI ?normG //. + by rewrite (subset_trans nH1U) // astab_norm. +pose j := j1; pose psi := mu_ j - (u %/ a)%:R *: lambda. +have /andP/=[red_muj S2muj]: mu_ j \in [predD S2 & irr M]. + by rewrite memS2red image_f. +have S2psi: psi \in 'Z[S2, M^#]. + rewrite zcharD1E rpredB ?rpredZnat ?mem_zchar //=. + by rewrite !cfunE mu_1 // lambda1 -natrM mulnCA divnK ?subrr. +pose phi := tau (mu_ 0 - zeta). +have o_phi_psi: '[phi, tau psi] = 0. + have Apsi: psi \in 'CF(M, 'A(M)) by rewrite defA (zcharD1_seqInd_on _ S2psi). + have [Tzeta Tlambda] := (seqInd_subT S1zeta, seqInd_subT S2lambda). + rewrite Dade_isometry ?A0bridge0 ?(cfun_onS (FTsupp_sub0 M)) //. + rewrite cfdotBl !cfdotBr !cfdotZr cfdot_prTIred eq_sym (negPf nz_j1) add0r. + rewrite !(seqInd_ortho _ Tzeta) ?Tmu ?(memPnC (sS1S2' S1zeta)) // add0r. + rewrite (seqInd_ortho _ (Tmu 0)) ?(memPnC (prTIred_not_irr _ _)) // !mulr0. + by rewrite subrr. +have [tau2 coh_tau2] := cohS2; have [[_ Ztau2] Dtau2] := coh_tau2. +have ua_1: (u %/ a)%:R * `|'[phi, tau2 lambda]| == 1. + rewrite -normr_nat -normrM mulr_natl -!raddfMn -[_ *+ _](subrK (mu_ j)) /=. + rewrite -opprB addrC raddfB cfdotBr -scaler_nat (Dtau2 _ S2psi) o_phi_psi. + case: (FTtypeP_coherent_TIred _ coh_tau2 _ S2lambda S2muj) => // -[b k] -> _. + rewrite -/(eta_col k) cfdotZr rmorph_sign subr0 normrMsign. + rewrite -[phi](subrK eta0row) cfdotDl cfdot_sumr big1 => [|j' _]; last first. + by rewrite (orthoPl (bridgeS1 _ _)) ?map_f ?mem_irr. + rewrite add0r cfdotC norm_conjC cfdot_sumr (bigD1 k) //= proj_col_eta eqxx. + by rewrite big1 ?addr0 ?normr1 // => i k'i; rewrite proj_col_eta (negPf k'i). +have Du: u = a. + apply/eqP; rewrite -[a]mul1n eqn_mul ?(ltnW a_gt1) // -eqC_nat. + move: ua_1; rewrite Cnat_mul_eq1 ?rpred_nat //; first by case/andP. + rewrite Cnat_norm_Cint ?Cint_cfdot_vchar //; last by rewrite Ztau2 ?mem_zchar. + rewrite Dade_vchar // zchar_split A0bridge0 //. + by rewrite rpredB ?char_vchar ?prTIred_char ?irrWchar. +have lequ: (q <= u)%N. + have u1_gt0: (0 < u.-1)%N by rewrite -subn1 subn_gt0 Du. + rewrite (leq_trans _ (leq_pred u)) // dvdn_leq //. + suffices ->: q = #|W1 / C|%g by apply: Frobenius_dvd_ker1 frobUW1bar. + apply/card_isog/quotient_isog; first by have [] := joing_subP nC_UW1. + by rewrite setIAC (coprime_TIg coUq) setI1g. +by rewrite (leq_trans lequ) // Du dvdn_leq // -subn1 subn_gt0 prime_gt1. +Qed. + +End Eleven. diff --git a/mathcomp/odd_order/PFsection12.v b/mathcomp/odd_order/PFsection12.v new file mode 100644 index 0000000..2b3a3e1 --- /dev/null +++ b/mathcomp/odd_order/PFsection12.v @@ -0,0 +1,1371 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg finset center. +Require Import fingroup morphism perm automorphism quotient action finalg zmodp. +Require Import gfunctor gproduct cyclic commutator gseries nilpotent pgroup. +Require Import sylow hall abelian maximal frobenius. +Require Import matrix mxalgebra mxpoly mxrepresentation mxabelem vector. +Require Import falgebra fieldext finfield. +Require Import BGsection1 BGsection2 BGsection3 BGsection4 BGsection7. +Require Import BGsection14 BGsection15 BGsection16. +Require Import ssrnum ssrint algC cyclotomic algnum. +Require Import classfun character inertia vcharacter. +Require Import PFsection1 PFsection2 PFsection3 PFsection4 PFsection5. +Require Import PFsection6 PFsection7 PFsection8 PFsection9 PFsection10. +Require Import PFsection11. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory FinRing.Theory Num.Theory. +Local Open Scope ring_scope. + +Section PFTwelve. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). +Implicit Types (p q : nat) (x y z : gT). +Implicit Types H K L M N P Q R S T U V W : {group gT}. + +Section Twelve2. + +(* Hypothesis 12.1 *) +Variable L : {group gT}. + +Hypotheses (maxL : L \in 'M) (Ltype1 : FTtype L == 1%N). + +Local Notation "` 'L'" := (gval L) (at level 0, only parsing) : group_scope. +Local Notation H := `L`_\F%G. +Local Notation "` 'H'" := `L`_\F (at level 0) : group_scope. + +Let nsHL : H <| L. Proof. exact: gFnormal. Qed. +Let calS := seqIndD H L H 1%G. +Let tau := FT_Dade maxL. +Let S_ (chi : 'CF(L)) := [set i in irr_constt chi]. +Let calX : {set Iirr L} := Iirr_kerD L H 1%g. +Let calI := [seq 'chi_i | i in calX]. + +(* This does not actually use the Ltype1 assumption. *) +Lemma FTtype1_ref_irr : exists2 phi, phi \in calS & phi 1%g = #|L : H|%:R. +Proof. +have [solH ntH] := (nilpotent_sol (Fcore_nil L), mmax_Fcore_neq1 maxL). +have [s Ls nzs] := solvable_has_lin_char ntH solH. +exists ('Ind 'chi_s); last by rewrite cfInd1 ?gFsub // lin_char1 ?mulr1. +by rewrite mem_seqInd ?gFnormal ?normal1 // !inE sub1G subGcfker -irr_eq1 nzs. +Qed. + +Let mem_calI i : i \in calX -> 'chi_i \in calI. +Proof. by move=> i_Iirr; apply/imageP; exists i. Qed. + +Lemma FTtype1_irrP i : + reflect (exists2 chi, chi \in calS & i \in S_ chi) (i \in calX). +Proof. +have [sHL nHL] := andP nsHL; rewrite !inE sub1G andbT. +apply/(iffP idP) => [kerH'i | [_ /seqIndC1P[t nz_t ->]]]; last first. + by rewrite inE => /sub_cfker_constt_Ind_irr <-; rewrite ?subGcfker. +have [t] := constt_cfRes_irr H i; rewrite -constt_Ind_Res => tLi. +rewrite -(sub_cfker_constt_Ind_irr tLi) // in kerH'i. +suffices: 'Ind 'chi_t \in calS by exists ('Ind 'chi_t); rewrite // inE. +by rewrite mem_seqInd ?normal1 // !inE sub1G kerH'i. +Qed. + +Lemma FTtype1_irr_partition : + partition [set Si in [seq S_ chi | chi <- calS]] calX. +Proof. +apply/and3P; split; last 1 first. +- rewrite inE; apply/mapP=> [[chi Schi /esym/setP S_0]]. + have /eqP[] := seqInd_neq0 nsHL Schi. + rewrite [chi]cfun_sum_constt big1 // => i chi_i. + by have:= S_0 i; rewrite inE chi_i inE. +- apply/eqP/setP=> i; apply/bigcupP/FTtype1_irrP=> [[S_chi] | [chi Schi Si]]. + by rewrite inE => /mapP[chi Schi ->]; exists chi. + by exists (S_ chi); rewrite // inE map_f. +apply/trivIsetP=> S_chi1 S_chi2. +rewrite !inE => /mapP[chi1 Schi1 ->] /mapP[chi2 Schi2 ->] {S_chi1 S_chi2}chi2'1. +apply/pred0P=> i; rewrite /= !inE; apply/andP=> [[chi1_i chi2_i]]. +suffices: '['chi_i] == 0 by rewrite cfnorm_irr oner_eq0. +rewrite (constt_ortho_char (seqInd_char Schi1) (seqInd_char Schi2)) //. +by rewrite (seqInd_ortho _ Schi1 Schi2) // (contraNneq _ chi2'1) // => ->. +Qed. + +(* This is Peterfalvi (12.2)(a), first part *) +Lemma FTtype1_seqInd_facts chi : + chi \in calS -> + [/\ chi = \sum_(i in S_ chi) 'chi_i, + constant [seq 'chi_i 1%g | i in S_ chi] + & {in S_ chi, forall i, 'chi_i \in 'CF(L, 1%g |: 'A(L))}]. +Proof. +move=> calS_chi; have [t nz_t Dchi] := seqIndC1P calS_chi. +pose T := 'I_L['chi_t]%g. +have sTL: T \subset L by apply: Inertia_sub. +have sHT: H \subset T by apply/sub_Inertia/gFsub. +have sHL: H \subset L by apply: normal_sub. +have hallH: Hall T H := pHall_Hall (pHall_subl sHT sTL (Fcore_Hall L)). +have [U [LtypeF _]] := FTtypeP _ maxL Ltype1. +have [[_ _ sdHU] [U1 inertU1] _] := LtypeF. +have defT: H ><| 'I_U['chi_t] = T := sdprod_modl sdHU (sub_inertia 'chi_t). +have abTbar : abelian (T / H). + have [_ _ /(_ _ _ inertU1 nz_t)sItU1] := typeF_context LtypeF. + by rewrite -(isog_abelian (sdprod_isog defT)) (abelianS sItU1); case: inertU1. +have [DtL _ X_1] := cfInd_Hall_central_Inertia nsHL abTbar hallH. +have Dchi_sum : chi = \sum_(i in S_ chi) 'chi_i. + by rewrite {1}Dchi DtL -Dchi; apply: eq_bigl => i; rewrite !inE. +have lichi : constant [seq 'chi_i 1%g | i in S_ chi]. + pose c := #|L : T|%:R * 'chi_t 1%g; apply: (@all_pred1_constant _ c). + by apply/allP=> _ /imageP[s tLs ->] /=; rewrite inE Dchi in tLs; rewrite X_1. +split=> // j Schi_j /=; apply/cfun_onP=> y A'y. +have [Ly | /cfun0->//] := boolP (y \in L). +have CHy1: 'C_H[y] = 1%g. + apply: contraNeq A'y => /trivgPn[z /setIP[Hz cyz] ntz]. + rewrite !inE -implyNb; apply/implyP=> nty; apply/bigcupP. + rewrite FTsupp1_type1 Ltype1 //=; exists z; first by rewrite !inE ntz. + by rewrite 3!inE nty Ly cent1C. +have: j \in calX by apply/FTtype1_irrP; exists chi. +by rewrite !inE => /andP[/not_in_ker_char0->]. +Qed. + +(* This is Peterfalvi (12.2)(a), second part. *) +Lemma FPtype1_irr_isometry : + {in 'Z[calI, L^#], isometry tau, to 'Z[irr G, G^#]}. +Proof. +apply: (sub_iso_to _ _ (Dade_Zisometry _)) => // phi. +rewrite zcharD1E => /andP[S_phi phi1_0]. +have /subsetD1P[_ /setU1K <-] := FTsupp_sub L; rewrite zcharD1 {}phi1_0 andbT. +apply: zchar_trans_on phi S_phi => _ /imageP[i /FTtype1_irrP[j calSj Sj_i] ->]. +by rewrite zchar_split irr_vchar; have [_ _ ->] := FTtype1_seqInd_facts calSj. +Qed. + +Lemma FPtype1_irr_subcoherent : + {R : 'CF(L) -> seq 'CF(G) | subcoherent calI tau R}. +Proof. +apply: irr_subcoherent; last exact: FPtype1_irr_isometry. + have UcalI: uniq calI by apply/dinjectiveP; apply: in2W irr_inj. + split=> // _ /imageP[i Ii ->]; rewrite !inE in Ii; first exact: mem_irr. + by apply/imageP; exists (conjC_Iirr i); rewrite ?inE conjC_IirrE ?cfker_aut. +apply/hasPn=> psi; case/imageP => i; rewrite !inE => /andP[kerH'i _] ->. +rewrite /cfReal odd_eq_conj_irr1 ?mFT_odd // irr_eq1 -subGcfker. +by apply: contra kerH'i; apply: subset_trans; apply: gFsub. +Qed. +Local Notation R1gen := FPtype1_irr_subcoherent. + +(* This is Peterfalvi (12.2)(b). *) +Lemma FPtype1_subcoherent (R1 := sval R1gen) : + {R : 'CF(L) -> seq 'CF(G) | + [/\ subcoherent calS tau R, + {in Iirr_kerD L H 1%G, forall i (phi := 'chi_i), + [/\ orthonormal (R1 phi), + size (R1 phi) = 2 + & tau (phi - phi^*%CF) = \sum_(mu <- R1 phi) mu]} + & forall chi, R chi = flatten [seq R1 'chi_i | i in S_ chi]]}. +Proof. +have nrS: ~~ has cfReal calS by apply: seqInd_notReal; rewrite ?mFT_odd. +have U_S: uniq calS by apply: seqInd_uniq. +have ccS: conjC_closed calS by apply: cfAut_seqInd. +have conjCS: cfConjC_subset calS (seqIndD H L H 1) by split. +case: R1gen @R1 => /= R1 subc1. +have [[chi_char nrI ccI] tau_iso oI h1 hortho] := subc1. +pose R chi := flatten [seq R1 'chi_i | i in S_ chi]. +have memI phi i: phi \in calS -> i \in S_ phi -> 'chi_i \in calI. + by move=> Sphi Sphi_i; apply/image_f/FTtype1_irrP; exists phi. +have aux phi psi i j mu nu: + phi \in calS -> psi \in calS -> i \in S_ phi -> j \in S_ psi -> + mu \in R1 'chi_i -> nu \in R1 'chi_j -> + orthogonal 'chi_i ('chi_j :: ('chi_j)^*%CF) -> '[mu, nu] = 0. +- move=> Sphi Spsi Sphi_i Spsi_j R1i_mu R1i_nu o_ij. + apply: orthogonalP R1i_mu R1i_nu. + by apply: hortho o_ij; [apply: memI Spsi Spsi_j | apply: memI Sphi Sphi_i]. +exists R; split => //= => [| i Ii]; last first. + have mem_i := mem_calI Ii; have{h1} [Zirr oR1 tau_im] := h1 _ mem_i. + split=> //; apply/eqP; rewrite -eqC_nat -cfnorm_orthonormal // -{}tau_im. + have ?: 'chi_i - ('chi_i)^*%CF \in 'Z[calI, L^#]. + have hchi : 'chi_i \in 'Z[calI, L] by rewrite mem_zchar_on // cfun_onG. + rewrite sub_aut_zchar ?cfAut_zchar // => _ /mapP[j _ ->]; exact: irr_vchar. + have [-> // _] := tau_iso; rewrite cfnormBd ?cfnorm_conjC ?cfnorm_irr //. + by have [_ ->] := pairwise_orthogonalP oI; rewrite ?ccI // eq_sym (hasPn nrI). +have calS_portho : pairwise_orthogonal calS by apply: seqInd_orthogonal. +have calS_char : {subset calS <= character} by apply: seqInd_char. +have calS_chi_ortho : + {in calS &, forall phi psi i j, + i \in irr_constt phi -> j \in irr_constt psi -> + '[phi, psi] = 0 -> '['chi_i, 'chi_j] = 0}. +- by move=> phi psi Sphi Spsi /= i j; apply: constt_ortho_char; apply/calS_char. +have ZisoS_tau: {in 'Z[calS, L^#], isometry tau, to 'Z[irr G, G^#]}. + apply: (sub_iso_to _ _ (Dade_Zisometry _)) => // phi. + have /subsetD1P[_ /setU1K <-] := FTsupp_sub L. + rewrite zcharD1E zcharD1 => /andP[S_phi ->]; rewrite andbT. + apply: zchar_trans_on phi S_phi => psi calS_psi. + have [Dpsi _ hCF] := FTtype1_seqInd_facts calS_psi. + by rewrite zchar_split (seqInd_vcharW calS_psi) /= Dpsi rpred_sum. +split=> {ZisoS_tau}//= [phi calS_phi | phi psi calS_phi calS_psi]. + rewrite /R /[seq _ | i in _]; set e := enum _; have: uniq e := enum_uniq _. + have: all (mem (S_ phi)) e by apply/allP=> i; rewrite mem_enum. + have ->: phi - phi^*%CF = \sum_(i <- e) ('chi_i - ('chi_i)^*%CF). + rewrite big_filter sumrB -rmorph_sum. + by have [<-] := FTtype1_seqInd_facts calS_phi. + elim: e => /= [_ _ | i e IHe /andP[Si Se] /andP[e'i Ue]]. + by rewrite !big_nil /tau linear0. + rewrite big_cons [tau _]linearD big_cat /= -/tau orthonormal_cat. + have{IHe Ue} [/allP Ze -> ->] := IHe Se Ue. + have{h1} /h1[/allP Z_R1i -> -> /=] := memI _ _ calS_phi Si. + split=> //; first by apply/allP; rewrite all_cat Z_R1i. + apply/orthogonalP=> mu nu R1i_mu /flatten_mapP[j e_j R1j_nu]. + have /= Sj := allP Se j e_j; apply: (aux phi phi i j) => //. + rewrite /orthogonal /= !andbT !cfdot_irr mulrb ifN_eqC ?(memPn e'i) ?eqxx //=. + rewrite !inE in Si Sj; rewrite -conjC_IirrE; set k := conjC_Iirr j. + rewrite (calS_chi_ortho phi phi^*%CF) ?calS_char ?ccS //. + by rewrite irr_consttE conjC_IirrE cfdot_conjC fmorph_eq0. + by rewrite (seqInd_conjC_ortho _ _ _ calS_phi) ?mFT_odd. +case/andP=> /and3P[/eqP opsi_phi /eqP opsi_phiC _] _; apply/orthogonalP. +move=> nu mu /flatten_imageP[j Spsi_j R1j_nu] /flatten_imageP[i Sphi_i R1i_mu]. +apply: (aux psi phi j i) => //; rewrite /orthogonal /= !andbT -conjC_IirrE. +rewrite !inE in Sphi_i Spsi_j; rewrite (calS_chi_ortho psi phi) ?calS_char //. +rewrite (calS_chi_ortho psi phi^*%CF) ?calS_char ?ccS ?eqxx //. +by rewrite irr_consttE conjC_IirrE cfdot_conjC fmorph_eq0. +Qed. + +End Twelve2. + +Local Notation R1gen := FPtype1_irr_subcoherent. +Local Notation Rgen := FPtype1_subcoherent. + +(* This is Peterfalvi (12.3) *) +Lemma FTtype1_seqInd_ortho L1 L2 (maxL1 : L1 \in 'M) (maxL2 : L2 \in 'M) + (L1type1 : FTtype L1 == 1%N) (L2type1 : FTtype L2 == 1%N) + (H1 := L1`_\F%G) (H2 := L2`_\F%G) + (calS1 := seqIndD H1 L1 H1 1) (calS2 := seqIndD H2 L2 H2 1) + (R1 := sval (Rgen maxL1 L1type1)) (R2 := sval (Rgen maxL2 L2type1)) : + gval L2 \notin L1 :^: G -> + {in calS1 & calS2, forall chi1 chi2, orthogonal (R1 chi1) (R2 chi2)}. +Proof. +move=> notL1G_L2; without loss{notL1G_L2} disjointA1A: + L1 L2 maxL1 maxL2 L1type1 L2type1 @H1 @H2 @calS1 @calS2 @R1 @R2 / + [disjoint 'A1~(L2) & 'A~(L1)]. +- move=> IH_L; have [_ _] := FT_Dade_support_disjoint maxL1 maxL2 notL1G_L2. + by case=> /IH_L-oS12 chi1 chi2 *; first rewrite orthogonal_sym; apply: oS12. +case: (Rgen _ _) @R1 => /= R1; set R1' := sval _ => [[subcoh1 hR1' defR1]]. +case: (Rgen _ _) @R2 => /= R2; set R2' := sval _ => [[subcoh2 hR2' defR2]]. +pose tau1 := FT_Dade maxL1; pose tau2 := FT_Dade maxL2. +move=> chi1 chi2 calS1_chi1 calS2_chi2. +have [_ _ _ /(_ chi1 calS1_chi1)[Z_R1 o1R1 dtau1_chi1] _] := subcoh1. +have{o1R1} [uR1 oR1] := orthonormalP o1R1. +apply/orthogonalP=> a b R1a R2b; pose psi2 := tau2 (chi2 - chi2^*%CF). +have Z1a: a \in dirr G by rewrite dirrE Z_R1 //= oR1 ?eqxx. +suffices{b R2b}: '[a, psi2] == 0. + apply: contraTeq => nz_ab; rewrite /psi2 /tau2. + have [_ _ _ /(_ chi2 calS2_chi2)[Z_R2 o1R2 ->] _] := subcoh2. + suffices [e ->]: {e | a = if e then - b else b}. + rewrite -scaler_sign cfdotC cfdotZr -cfdotZl scaler_sumr. + by rewrite cfproj_sum_orthonormal // conjCK signr_eq0. + have [_ oR2] := orthonormalP o1R2. + have Z1b: b \in dirr G by rewrite dirrE Z_R2 //= oR2 ?eqxx. + move/eqP: nz_ab; rewrite cfdot_dirr //. + by do 2?[case: eqP => [-> | _]]; [exists true | exists false | ]. +have [chi1D _ Achi1] := FTtype1_seqInd_facts maxL1 L1type1 calS1_chi1. +pose S_chi1 := [set i0 in irr_constt chi1]. +pose bchi i := 'chi[_ : {set gT}]_i - ('chi_i)^*%CF. +have [t S_chi1t et]: exists2 t, t \in S_chi1 & tau1 (bchi _ t) = a - a^*%CF. + suffices: ~~ [forall i in S_chi1, '[tau1 (bchi L1 i), a] <= 0]. + rewrite negb_forall_in => /exists_inP[i Si tau1i_a]; exists i => //. + case/dIrrP: Z1a tau1i_a => ia ->. + have [k ->]: exists k, tau1 (bchi _ i) = bchi G k. + exact: Dade_irr_sub_conjC (mem_irr _) (Achi1 i Si). + have {1}->: bchi G k = dchi (false, k) + dchi (true, conjC_Iirr k). + by rewrite /dchi !scaler_sign conjC_IirrE. + rewrite cfdotDl !cfdot_dchi addrACA -opprD subr_le0 -!natrD leC_nat. + do 2?case: (_ =P ia) => [<-|] _ //; first by rewrite /dchi scale1r. + by rewrite /dchi scaleN1r conjC_IirrE rmorphN /= cfConjCK opprK addrC. + have: '[tau1 (chi1 - chi1^*%CF), a] == 1. + rewrite /tau1 dtau1_chi1 (bigD1_seq a) //= cfdotDl cfdot_suml oR1 // eqxx. + by rewrite big1_seq ?addr0 // => xi /andP[/negPf a'xi ?]; rewrite oR1 ?a'xi. + apply: contraL => /forall_inP tau1a_le0. + rewrite (ltr_eqF (ler_lt_trans _ ltr01)) // chi1D rmorph_sum /= -/S_chi1. + rewrite -sumrB [tau1 _]linear_sum /= -/tau1 cfdot_suml. + by rewrite -oppr_ge0 -sumrN sumr_ge0 // => i /tau1a_le0; rewrite oppr_ge0. +clear Achi1 dtau1_chi1 uR1 defR1. +suffices: '[a, psi2] == - '[a, psi2] by rewrite -addr_eq0 (mulrn_eq0 _ 2). +have A1bchi2: chi2 - (chi2^*)%CF \in 'Z[calS2, 'A1(L2)]. + by rewrite FTsupp1_type1 // seqInd_sub_aut_zchar ?gFnormal. +have{t S_chi1t et} /eqP{2}->: '[a, psi2] == '[a^*%CF, psi2]. + move/zchar_on in A1bchi2; rewrite -subr_eq0 -cfdotBl. + rewrite [psi2]FT_DadeE ?(cfun_onS (FTsupp1_sub _)) // -FT_Dade1E // -et. + rewrite (cfdot_complement (Dade_cfunS _ _)) ?(cfun_onS _ (Dade_cfunS _ _)) //. + by rewrite FT_Dade_supportE FT_Dade1_supportE setTD -disjoints_subset. +rewrite -2!raddfN opprB /= cfdot_conjCl -Dade_conjC rmorphB /= cfConjCK -/tau2. +rewrite conj_Cint ?Cint_cfdot_vchar ?(Z_R1 a) // Dade_vchar //. +rewrite (zchar_onS (FTsupp1_sub _)) // (zchar_sub_irr _ A1bchi2) //. +exact: seqInd_vcharW. +Qed. + +Section Twelve_4_to_6. + +Variable L : {group gT}. +Hypothesis maxL : L \in 'M . + +Local Notation "` 'L'" := (gval L) (at level 0, only parsing) : group_scope. +Local Notation H := `L`_\F%G. +Local Notation "` 'H'" := `L`_\F (at level 0) : group_scope. +Local Notation H' := H^`(1)%G. +Local Notation "` 'H''" := `H^`(1) (at level 0) : group_scope. + +Let calS := seqIndD H L H 1%G. +Let tau := FT_Dade maxL. +Let rho := invDade (FT_DadeF_hyp maxL). + +Section Twelve_4_5. + +Hypothesis Ltype1 : FTtype L == 1%N. + +Let R := sval (Rgen maxL Ltype1). +Let S_ (chi : 'CF(L)) := [set i in irr_constt chi]. + +(* This is Peterfalvi (12.4). *) +Lemma FTtype1_ortho_constant (psi : 'CF(G)) x : + {in calS, forall phi, orthogonal psi (R phi)} -> x \in L :\: H -> + {in x *: H, forall y, psi y = psi x}%g. +Proof. +move=> opsiR /setDP[Lx H'x]; pose Rpsi := 'Res[L] psi. +have nsHL: H <| L := gFnormal _ _; have [sHL _] := andP nsHL. +have [U [[[_ _ sdHU] [U1 inertU1] _] _]] := FTtypeP 1 maxL Ltype1. +have /= [_ _ TIsub]:= FTtypeI_II_facts maxL Ltype1 sdHU. +pose ddL := FT_Dade_hyp maxL. +have A1Hdef : 'A1(L) = H^# by apply: FTsupp1_type1. +have dot_irr xi j : xi \in calS -> j \in S_ xi -> '['chi_j, xi] = 1. + move=> xi_calS Sj. + have -> : xi = \sum_(i <- enum (S_ xi)) 'chi_i. + by rewrite big_filter; have [] := FTtype1_seqInd_facts maxL Ltype1 xi_calS. + rewrite (bigD1_seq j) ?mem_enum ?enum_uniq //= cfdotDr cfdot_sumr cfnorm_irr. + by rewrite big1 ?addr0 // => k i'k; rewrite cfdot_irr eq_sym (negPf i'k). +have {dot_irr} supp12B y xi j1 j2 : xi \in calS -> j1 \in S_ xi -> + j2 \in S_ xi -> y \notin ('A(L) :\: H^#) -> ('chi_j1 - 'chi_j2) y = 0. +- move=> calS_xi Sj1 Sj2 yADHn. + have [xiD xi_cst sup_xi] := FTtype1_seqInd_facts maxL Ltype1 calS_xi. + have [Hy | H'y] := boolP (y \in H); last first. + suffices /cfun_on0->: y \notin 1%g |: 'A(L) by rewrite ?rpredB ?sup_xi. + by rewrite !inE negb_or negb_and (group1_contra H'y) ?H'y in yADHn *. + have [s _ xiIndD] := seqIndP calS_xi. + pose sum_sL := \sum_(xi_z <- ('chi_s ^: L)%CF) xi_z. + suffices Dxi: {in S_ xi, forall i, 'chi_i y = sum_sL y}. + by rewrite !cfunE !Dxi ?subrr. + move=> k Sk; pose phiH := 'Res[H] 'chi_k. + transitivity (phiH y); first by rewrite cfResE ?normal_sub. + have phiH_s_1: '[phiH, 'chi_s] = 1 by rewrite cfdot_Res_l -xiIndD dot_irr. + have phiH_s: s \in irr_constt phiH by rewrite irr_consttE phiH_s_1 oner_eq0. + by rewrite [phiH](Clifford_Res_sum_cfclass _ phiH_s) // phiH_s_1 scale1r. +have {supp12B} oResD xi i1 i2 : xi \in calS -> i1 \in S_ xi -> i2 \in S_ xi -> + '['Res[L] psi, 'chi_i1 - 'chi_i2] = 0. +- move=> calS_xi Si1 Si2; rewrite cfdotC Frobenius_reciprocity -cfdotC. + case: (altP (i1 =P i2))=> [-> | d12]; first by rewrite subrr linear0 cfdot0r. + have {supp12B} supp12B y: y \notin 'A(L) :\: H^# -> ('chi_i1 - 'chi_i2) y = 0. + exact: (supp12B _ xi _ _ calS_xi). + case: (FTtype1_seqInd_facts maxL Ltype1 calS_xi) => _ cst1 supA. + move/(_ _ Si1): (supA) => /cfun_onP s1; case/(constantP 0): (cst1) => [n]. + move/all_pred1P /allP => nseqD; move/(_ _ Si2): (supA) => /cfun_onP s2. + have nchi11: 'chi_i1 1%g = n by apply/eqP/nseqD/image_f. + have{nseqD} nchi12: 'chi_i2 1%g = n by apply/eqP/nseqD/image_f. + have i12_1: 'chi_i1 1%g == 'chi_i2 1%g by rewrite nchi11 nchi12. + have sH1A: H^# \subset 'A(L) by rewrite Fcore_sub_FTsupp. + have nzAH: 'A(L) :\: H^# != set0. + apply: contra d12 => /eqP tADH; apply/eqP; apply: irr_inj; apply/cfunP=> w. + apply/eqP; rewrite -subr_eq0; have := supp12B w; rewrite !cfunE => -> //. + by rewrite tADH in_set0. + have{nzAH} tiH: normedTI ('A(L) :\: H^#) G L by rewrite -A1Hdef TIsub ?A1Hdef. + have{supp12B} supp12B : 'chi_i1 - 'chi_i2 \in 'CF(L, 'A(L) :\: H^#). + by apply/cfun_onP; apply: supp12B. + have [_ /subsetIP[_ nAHL] _] := normedTI_P tiH. + pose tau1 := restr_Dade ddL (subsetDl _ _) nAHL. + have tauInd: {in 'CF(L, 'A(L) :\: H^#), tau1 =1 'Ind} := Dade_Ind _ tiH. + rewrite -{}tauInd // [tau1 _]restr_DadeE {tau1 nAHL}//. + suffices Rtau12: Dade ddL ('chi_i1 - 'chi_i2) \in 'Z[R xi]. + by rewrite (span_orthogonal (opsiR xi _)) ?memv_span1 ?(zchar_span Rtau12). + case: (Rgen _ _) @R => rR [scohS]; case: (R1gen _ _) => /= R1 scohI ? DrR. + rewrite -/calS in scohS; set calI := image _ _ in scohI. + have [Ii1 Ii2]: 'chi_i1 \in calI /\ 'chi_i2 \in calI. + by split; apply/image_f/FTtype1_irrP; exists xi. + have [calI2 [I2i1 I2i2 sI2I] []] := pair_degree_coherence scohI Ii1 Ii2 i12_1. + move=> tau2 cohI2; have [_ <-] := cohI2; last first. + by rewrite zcharD1E rpredB ?mem_zchar // 2!cfunE subr_eq0. + suffices R_I2 j: j \in S_ xi -> 'chi_j \in calI2 -> tau2 'chi_j \in 'Z[rR xi]. + by rewrite raddfB rpredB ?R_I2. + move=> Sj /(mem_coherent_sum_subseq scohI sI2I cohI2)[e R1e ->]. + rewrite DrR big_seq rpred_sum // => phi /(mem_subseq R1e) R1phi. + by apply/mem_zchar/flatten_imageP; exists j. +suffices ResL: {in x *: H, forall y, Rpsi y = Rpsi x}%g. + move=> w xHw; case/lcosetP: xHw (ResL w xHw) => h Hh -> {w}. + by rewrite !cfResE ?subsetT ?groupM // ?(subsetP sHL). +move=> _ /lcosetP[h Hh ->] /=; rewrite (cfun_sum_cfdot Rpsi). +pose calX := Iirr_kerD L H 1%g; rewrite (bigID (mem calX) xpredT) /= !cfunE. +set sumX := \sum_(i in _) _; suffices HsumX: sumX \in 'CF(L, H). + rewrite !(cfun_on0 HsumX) ?groupMr // !sum_cfunE. + rewrite !add0r; apply: eq_bigr => i;rewrite !inE sub1G andbT negbK => kerHi. + by rewrite !cfunE cfkerMr ?(subsetP kerHi). +rewrite [sumX](set_partition_big _ (FTtype1_irr_partition L)) /=. +apply: rpred_sum => A; rewrite inE => /mapP[xi calS_xi defA]. +have [-> | [j Achij]] := set_0Vmem A; first by rewrite big_set0 rpred0. +suffices ->: \sum_(i in A) '[Rpsi, 'chi_i] *: 'chi_i = '[Rpsi, 'chi_j] *: xi. + by rewrite rpredZ // (seqInd_on _ calS_xi). +have [-> _ _] := FTtype1_seqInd_facts maxL Ltype1 calS_xi; rewrite -defA. +rewrite scaler_sumr; apply: eq_bigr => i Ai; congr (_ *: _); apply/eqP. +by rewrite -subr_eq0 -cfdotBr (oResD xi) /S_ -?defA. +Qed. + +(* This is Peterfalvi (12.5) *) +Lemma FtypeI_invDade_ortho_constant (psi : 'CF(G)) : + {in calS, forall phi, orthogonal psi (R phi)} -> + {in H :\: H' &, forall x y, rho psi x = rho psi y}. +Proof. +have [nsH'H nsHL]: H' <| H /\ H <| L by rewrite !gFnormal. +have [[sH'H _] [sHL _]] := (andP nsH'H, andP nsHL). +case: (Rgen _ _) @R => /= rR [scohS _ _] opsiR; set rpsi := rho psi. +have{rR scohS opsiR} o_rpsi_S xi1 xi2: + xi1 \in calS -> xi2 \in calS -> xi1 1%g = xi2 1%g -> '[rpsi, xi1 - xi2] = 0. +- move=> Sxi1 Sxi2 /eqP deg12. + have [calS2 [S2xi1 S2xi2]] := pair_degree_coherence scohS Sxi1 Sxi2 deg12. + move=> ccsS2S [tau2 cohS2]; have [[_ Dtau2] [_ sS2S _]] := (cohS2, ccsS2S). + have{deg12} L1xi12: (xi1 - xi2) 1%g == 0 by rewrite !cfunE subr_eq0. + have{ccsS2S cohS2} tau2E := mem_coherent_sum_subseq scohS ccsS2S cohS2. + have o_psi_tau2 xi: xi \in calS2 -> '[psi, tau2 xi] = 0. + move=> S2xi; have [e /mem_subseq Re ->] := tau2E xi S2xi. + by rewrite cfdot_sumr big1_seq // => _ /Re/orthoPl->; rewrite ?opsiR ?sS2S. + have A1xi12: xi1 - xi2 \in 'CF(L, H^#). + by rewrite (@zchar_on _ _ calS) ?zcharD1 ?rpredB ?seqInd_zchar. + rewrite cfdotC -invDade_reciprocity // -cfdotC. + rewrite FT_DadeF_E -?FT_DadeE ?(cfun_onS (Fcore_sub_FTsupp maxL)) //. + rewrite -Dtau2; last by rewrite zcharD1E rpredB ?mem_zchar. + by rewrite !raddfB /= !o_psi_tau2 ?subrr. +pose P_ i : {set Iirr H} := [set j in irr_constt ('Ind[H, H'] 'chi_i)]. +pose P : {set {set Iirr H}} := [set P_ i | i : Iirr H']. +have tiP: trivIset P. + apply/trivIsetP=> _ _ /imsetP[i1 _ ->] /imsetP[i2 _ ->] chi2'1. + apply/pred0P=> j; rewrite !inE; apply: contraNF chi2'1 => /andP[i1Hj i2Hj]. + case: ifP (cfclass_Ind_cases i1 i2 nsH'H) => _; first by rewrite /P_ => ->. + have NiH i: 'Ind[H,H'] 'chi_i \is a character by rewrite cfInd_char ?irr_char. + case/(constt_ortho_char (NiH i1) (NiH i2) i1Hj i2Hj)/eqP/idPn. + by rewrite cfnorm_irr oner_eq0. +have coverP: cover P =i predT. + move=> j; apply/bigcupP; have [i jH'i] := constt_cfRes_irr H' j. + by exists (P_ i); [apply: mem_imset | rewrite inE constt_Ind_Res]. +have /(all_sig_cond 0)[lambda lambdaP] A: A \in P -> {i | A = P_ i}. + by case/imsetP/sig2_eqW=> i; exists i. +pose theta A : Iirr H := odflt 0 [pick j in A :\ 0]; pose psiH := 'Res[H] rpsi. +pose a_ A := '[psiH, 'chi_(theta A)] / '['Ind 'chi_(lambda A), 'chi_(theta A)]. +pose a := '[psiH, 1 - 'chi_(theta (pblock P 0))]. +suffices Da: {in H :\: H', rpsi =1 (fun=> a)} by move=> /= *; rewrite !Da. +suffices DpsiH: psiH = \sum_(A in P) a_ A *: 'Ind 'chi_(lambda A) + a%:A. + move=> x /setDP[Hx notH'x]; transitivity (psiH x); first by rewrite cfResE. + rewrite DpsiH !cfunE sum_cfunE cfun1E Hx mulr1 big1 ?add0r // => A _. + by rewrite cfunE (cfun_onP (cfInd_normal _ _)) ?mulr0. +apply: canRL (subrK _) _; rewrite [_ - _]cfun_sum_cfdot. +rewrite -(eq_bigl _ _ coverP) big_trivIset //=; apply: eq_bigr => A P_A. +rewrite {}/a_; set i := lambda A; set k := theta A; pose Ii := 'I_H['chi_i]%G. +have /cfInd_central_Inertia[//|e _ [DiH _ DiH_1]]: abelian (Ii / H'). + by rewrite (abelianS _ (der_abelian 0 H)) ?quotientS ?subsetIl. +have defA: A = P_ i := lambdaP A P_A. +have Ak: k \in A; last 1 [have iHk := Ak; rewrite defA inE in Ak]. + have [j iHj] := constt_cfInd_irr i sH'H. + rewrite {}/k /theta; case: pickP => [k /setDP[]//| /(_ j)/=]. + by rewrite defA !in_set iHj andbT => /negbFE/eqP <-. +have{DiH} DiH: 'Ind 'chi_i = e *: \sum_(j in A) 'chi_j. + by congr (_ = _ *: _): DiH; apply: eq_bigl => j; rewrite [in RHS]defA !inE. +rewrite {2}DiH; have{DiH} ->: e = '['Ind 'chi_i, 'chi_k]. + rewrite DiH cfdotZl cfdot_suml (bigD1 k) //= cfnorm_irr big1 ?addr0 ?mulr1 //. + by move=> j /andP[_ k'j]; rewrite cfdot_irr (negPf k'j). +rewrite scalerA scaler_sumr divfK //; apply: eq_bigr => j Aj; congr (_ *: _). +rewrite cfdotBl cfdotZl -irr0 cfdot_irr mulr_natr mulrb eq_sym. +apply/(canLR (addrK _))/(canRL (addNKr _)); rewrite addrC -cfdotBr. +have [j0 | nzj] := altP eqP; first by rewrite j0 irr0 /a -j0 (def_pblock _ P_A). +have iHj := Aj; rewrite defA inE in iHj; rewrite cfdot_Res_l linearB /=. +do [rewrite o_rpsi_S ?cfInd1 ?DiH_1 //=; apply/seqIndC1P]; first by exists j. +by exists k; rewrite // /k /theta; case: pickP => [? | /(_ j)] /setD1P[]. +Qed. + +End Twelve_4_5. + +Hypothesis frobL : [Frobenius L with kernel H]. + +Lemma FT_Frobenius_type1 : FTtype L == 1%N. +Proof. +have [E /Frobenius_of_typeF LtypeF] := existsP frobL. +by apply/idPn=> /FTtypeP_witness[]// _ _ _ _ _ /typePF_exclusion/(_ E). +Qed. +Let Ltype1 := FT_Frobenius_type1. + +Lemma FTsupp_Frobenius : 'A(L) = H^#. +Proof. +apply/eqP; rewrite eqEsubset Fcore_sub_FTsupp // andbT. +apply/bigcupsP=> y; rewrite Ltype1 FTsupp1_type1 //= => H1y. +by rewrite setSD //; have [_ _ _ ->] := Frobenius_kerP frobL. +Qed. + +(* This is Peterfalvi (12.6). *) +Lemma FT_Frobenius_coherence : {subset calS <= irr L} /\ coherent calS L^# tau. +Proof. +have irrS: {subset calS <= irr L}. + by move=> _ /seqIndC1P[s nz_s ->]; apply: irr_induced_Frobenius_ker. +split=> //; have [U [MtypeF MtypeI]] := FTtypeP 1 maxL Ltype1. +have [[ntH ntU defL] _ _] := MtypeF; have nsHL: H <| L := gFnormal _ L. +have nilH: nilpotent H := Fcore_nil L; have solH := nilpotent_sol nilH. +have frobHU: [Frobenius L = H ><| U] := set_Frobenius_compl defL frobL. +pose R := sval (Rgen maxL Ltype1). +have scohS: subcoherent calS tau R by case: (svalP (Rgen maxL Ltype1)). +have [tiH | [cHH _] | [expUdvH1 _]] := MtypeI. +- have /Sibley_coherence := And3 (mFT_odd L) nilH tiH. + case/(_ U)=> [|tau1 [IZtau1 Dtau1]]; first by left. + exists tau1; split=> // chi Schi; rewrite Dtau1 //. + by rewrite /tau Dade_Ind ?FTsupp_Frobenius ?(zcharD1_seqInd_on _ Schi). +- apply/(uniform_degree_coherence scohS)/(@all_pred1_constant _ #|L : H|%:R). + apply/allP=> _ /mapP[_ /seqIndP[s _ ->] ->] /=. + by rewrite cfInd1 ?gFsub // lin_char1 ?mulr1 //; apply/char_abelianP. +have isoHbar := quotient1_isog H. +have /(_ 1%G)[|//|[_ [p [pH _] /negP[]]]] := non_coherent_chief nsHL solH scohS. + split; rewrite ?mFT_odd ?normal1 ?sub1G -?(isog_nil isoHbar) //= joingG1. + apply/existsP; exists (U / H')%G. + rewrite Frobenius_proper_quotient ?(sol_der1_proper solH) //. + exact: char_normal_trans (der_char 1 H) nsHL. +rewrite -(isog_pgroup p isoHbar) in pH. +have [pr_p p_dv_H _] := pgroup_pdiv pH ntH. +rewrite subn1 -(index_sdprod defL). +have [-> *] := typeF_context MtypeF; last by split; rewrite ?(sdprodWY defL). +by rewrite expUdvH1 // mem_primes pr_p cardG_gt0. +Qed. + +End Twelve_4_to_6. + +Section Twelve_8_to_16. + +Variable p : nat. + +(* Equivalent reformultaion of Hypothesis (12.8), avoiding quotients. *) +Hypothesis IHp : + forall q M, (q < p)%N -> M \in 'M -> FTtype M == 1%N -> ('r_q(M) > 1)%N -> + q \in \pi(M`_\F). + +Variables M P0 : {group gT}. + +Let K := M`_\F%G. +Let K' := K^`(1)%G. +Let nsKM : K <| M. Proof. exact: gFnormal. Qed. + +Hypothesis maxM : M \in 'M. +Hypothesis Mtype1 : FTtype M == 1%N. +Hypothesis prankM : ('r_p(M) > 1)%N. +Hypothesis p'K : p^'.-group K. + +Hypothesis sylP0 : p.-Sylow(M) P0. + +(* This is Peterfalvi (12.9). *) +Lemma non_Frobenius_FTtype1_witness : + [/\ abelian P0, 'r_p(P0) = 2 + & exists2 L, L \in 'M /\ P0 \subset L`_\s + & exists2 x, x \in 'Ohm_1(P0)^# + & [/\ ~~ ('C_K[x] \subset K'), 'N(<[x]>) \subset M & ~~ ('C[x] \subset L)]]. +Proof. +have ntK: K :!=: 1%g := mmax_Fcore_neq1 maxM; have [sP0M pP0 _] := and3P sylP0. +have hallK: \pi(K).-Hall(M) K := Fcore_Hall M. +have K'p: p \notin \pi(K) by rewrite -p'groupEpi. +have K'P0: \pi(K)^'.-group P0 by rewrite (pi_pgroup pP0). +have [U hallU sP0U] := Hall_superset (mmax_sol maxM) sP0M K'P0. +have sylP0_U: p.-Sylow(U) P0 := pHall_subl sP0U (pHall_sub hallU) sylP0. +have{hallU} defM: K ><| U = M by apply/(sdprod_normal_p'HallP nsKM hallU). +have{K'P0} coKP0: coprime #|K| #|P0| by rewrite coprime_pi'. +have [/(_ _ _ sylP0_U)[abP0 rankP0] uCK _] := FTtypeI_II_facts maxM Mtype1 defM. +have{rankP0} /eqP prankP0: 'r_p(P0) == 2. + by rewrite eqn_leq -{1}rank_pgroup // rankP0 (p_rank_Sylow sylP0). +have piP0p: p \in \pi(P0) by rewrite -p_rank_gt0 prankP0. +have [L maxL sP0Ls]: exists2 L, L \in 'M & P0 \subset L`_\s. + have [DpiG _ _ _] := FT_Dade_support_partition gT. + have:= piSg (subsetT P0) piP0p; rewrite DpiG => /exists_inP[L maxL piLs_p]. + have [_ /Hall_pi hallLs _] := FTcore_facts maxL. + have [P sylP] := Sylow_exists p L`_\s; have [sPLs _] := andP sylP. + have sylP_G: p.-Sylow(G) P := subHall_Sylow hallLs piLs_p sylP. + have [y _ sP0_Py] := Sylow_subJ sylP_G (subsetT P0) pP0. + by exists (L :^ y)%G; rewrite ?mmaxJ // FTcoreJ (subset_trans sP0_Py) ?conjSg. +split=> //; exists L => //; set P1 := 'Ohm_1(P0). +have abelP1: p.-abelem P1 := Ohm1_abelem pP0 abP0. +have [pP1 abP1 _] := and3P abelP1. +have sP10: P1 \subset P0 := Ohm_sub 1 P0; have sP1M := subset_trans sP10 sP0M. +have nKP1: P1 \subset 'N(K) by rewrite (subset_trans sP1M) ?gFnorm. +have nK'P1: P1 \subset 'N(K') := char_norm_trans (der_char 1 K) nKP1. +have{coKP0} coKP1: coprime #|K| #|P1| := coprimegS sP10 coKP0. +have solK: solvable K := nilpotent_sol (Fcore_nil M). +have isoP1: P1 \isog P1 / K'. + by rewrite quotient_isog // coprime_TIg ?(coprimeSg (der_sub 1 K)). +have{ntK} ntKK': (K / K' != 1)%g. + by rewrite -subG1 quotient_sub1 ?gFnorm ?proper_subn ?(sol_der1_proper solK). +have defKK': (<<\bigcup_(xbar in (P1 / K')^#) 'C_(K / K')[xbar]>> = K / K')%g. + rewrite coprime_abelian_gen_cent1 ?coprime_morph ?quotient_norms //. + by rewrite quotient_abelian. + rewrite -(isog_cyclic isoP1) (abelem_cyclic abelP1). + by rewrite -(p_rank_abelem abelP1) p_rank_Ohm1 prankP0. +have [xb P1xb ntCKxb]: {xb | xb \in (P1 / K')^# & 'C_(K / K')[xb] != 1}%g. + apply/sig2W/exists_inP; rewrite -negb_forall_in. + apply: contra ntKK' => /eqfun_inP regKP1bar. + by rewrite -subG1 /= -defKK' gen_subG; apply/bigcupsP=> xb /regKP1bar->. +have [ntxb /morphimP[x nK'x P1x Dxb]] := setD1P P1xb. +have ntx: x != 1%g by apply: contraNneq ntxb => x1; rewrite Dxb x1 morph1. +have ntCKx: ~~ ('C_K[x] \subset K'). + rewrite -quotient_sub1 ?subIset ?gFnorm // -cent_cycle subG1 /=. + have sXP1: <[x]> \subset P1 by rewrite cycle_subG. + rewrite coprime_quotient_cent ?(coprimegS sXP1) ?(subset_trans sXP1) ?gFsub//. + by rewrite quotient_cycle ?(subsetP nK'P1) // -Dxb cent_cycle. +have{uCK} UCx: 'M('C[x]) = [set M]. + rewrite -cent_set1 uCK -?card_gt0 ?cards1 // ?sub1set ?cent_set1. + by rewrite !inE ntx (subsetP sP0U) ?(subsetP sP10). + by apply: contraNneq ntCKx => ->; rewrite sub1G. +exists x; [by rewrite !inE ntx | split=> //]. + rewrite (sub_uniq_mmax UCx) /= -?cent_cycle ?cent_sub //. + rewrite mFT_norm_proper ?cycle_eq1 //. + by rewrite mFT_sol_proper abelian_sol ?cycle_abelian. +apply: contraL (leqW (p_rankS p sP0Ls)) => /(eq_uniq_mmax UCx)-> //. +by rewrite prankP0 FTcore_type1 //= ltnS p_rank_gt0. +Qed. + +Variables (L : {group gT}) (x : gT). +Hypotheses (abP0 : abelian P0) (prankP0 : 'r_p(P0) = 2). +Hypotheses (maxL : L \in 'M) (sP0_Ls : P0 \subset L`_\s). +Hypotheses (P0_1s_x : x \in 'Ohm_1(P0)^#) (not_sCxK' : ~~ ('C_K[x] \subset K')). +Hypotheses (sNxM : 'N(<[x]>) \subset M) (not_sCxL : ~~ ('C[x] \subset L)). + +Let H := L`_\F%G. +Let nsHL : H <| L. Proof. exact: gFnormal. Qed. + +(* This is Peterfalvi (12.10). *) +Let frobL : [Frobenius L with kernel H]. +Proof. +have [sP0M pP0 _] := and3P sylP0. +have [ntx /(subsetP (Ohm_sub 1 _))P0x] := setD1P P0_1s_x. +have [Ltype1 | notLtype1] := boolP (FTtype L == 1)%N; last first. + have [U W W1 W2 defW LtypeP] := FTtypeP_witness maxL notLtype1. + suffices sP0H: P0 \subset H. + have [Hx notLtype5] := (subsetP sP0H x P0x, FTtype5_exclusion maxL). + have [_ _ _ tiFL] := compl_of_typeII_IV maxL LtypeP notLtype5. + have Fx: x \in 'F(L)^# by rewrite !inE ntx (subsetP (Fcore_sub_Fitting L)). + by have /idPn[] := cent1_normedTI tiFL Fx; rewrite setTI. + have [/=/FTcore_type2<- // | notLtype2] := boolP (FTtype L == 2). + have [_ _ [Ltype3 galL]] := FTtype34_structure maxL LtypeP notLtype2. + have cycU: cyclic U. + suffices regHU: Ptype_Fcompl_kernel LtypeP :=: 1%g. + rewrite (isog_cyclic (quotient1_isog U)) -regHU. + by have [|_ _ [//]] := typeP_Galois_P maxL _ galL; rewrite (eqP Ltype3). + rewrite /Ptype_Fcompl_kernel unlock /= astabQ /=. + have [_ _ ->] := FTtype34_Fcore_kernel_trivial maxL LtypeP notLtype2. + rewrite -morphpreIim -injm_cent ?injmK ?ker_coset ?norms1 //. + have [_ _ _ ->] := FTtype34_facts maxL LtypeP notLtype2. + by apply/derG1P; have [] := compl_of_typeIII maxL LtypeP Ltype3. + have sP0L': P0 \subset L^`(1) by rewrite -FTcore_type_gt2 ?(eqP Ltype3). + have [_ [_ _ _ defL'] _ _ _] := LtypeP. + have [nsHL' _ /mulG_sub[sHL' _] _ _] := sdprod_context defL'. + have hallH := pHall_subl sHL' (der_sub 1 L) (Fcore_Hall L). + have hallU: \pi(H)^'.-Hall(L^`(1)) U. + by rewrite -(compl_pHall U hallH) sdprod_compl. + rewrite (sub_normal_Hall hallH) // (pi_pgroup pP0) //. + have: ~~ cyclic P0; last apply: contraR => piK'p. + by rewrite abelian_rank1_cyclic // (rank_pgroup pP0) prankP0. + by have [|y _ /cyclicS->] := Hall_psubJ hallU piK'p _ pP0; rewrite ?cyclicJ. +have sP0H: P0 \subset H by rewrite /= -FTcore_type1. +have [U [LtypeF /= LtypeI]] := FTtypeP 1 maxL Ltype1. +have [[_ _ defL] _ _] := LtypeF; have [_ sUL _ nHU _] := sdprod_context defL. +have not_tiH: ~ normedTI H^# G L. + have H1x: x \in H^# by rewrite !inE ntx (subsetP sP0H). + by case/cent1_normedTI/(_ x H1x)/idPn; rewrite setTI. +apply/existsP; exists U; have [_ -> _] := typeF_context LtypeF. +apply/forall_inP=> Q /SylowP[q pr_q sylQ]; have [sQU qQ _] := and3P sylQ. +rewrite (odd_pgroup_rank1_cyclic qQ) ?mFT_odd //. +apply: wlog_neg; rewrite -ltnNge => /ltnW; rewrite p_rank_gt0 => piQq. +have hallU: \pi(H)^'.-Hall(L) U. + by rewrite -(compl_pHall U (Fcore_Hall L)) sdprod_compl. +have H'q := pnatPpi (pHall_pgroup hallU) (piSg sQU piQq). +rewrite leqNgt; apply: contra (H'q) => qrankQ; apply: IHp => //; last first. + by rewrite (leq_trans qrankQ) ?p_rankS ?(subset_trans sQU). +have piHp: p \in \pi(H) by rewrite (piSg sP0H) // -p_rank_gt0 prankP0. +have pr_p: prime p by have:= piHp; rewrite mem_primes => /andP[]. +have piUq: q \in \pi(exponent U) by rewrite pi_of_exponent (piSg sQU). +have [odd_p odd_q]: odd p /\ odd q. + rewrite !odd_2'nat !pnatE //. + by rewrite (pnatPpi _ piHp) ?(pnatPpi _ piQq) -?odd_2'nat ?mFT_odd. +have pgt2 := odd_prime_gt2 odd_p pr_p. +suffices [b dv_q_bp]: exists b : bool, q %| (b.*2 + p).-1. + rewrite -ltn_double (@leq_ltn_trans (p + b.*2).-1) //; last first. + by rewrite -!addnn -(subnKC pgt2) prednK // leq_add2l; case: (b). + rewrite -(subnKC pgt2) dvdn_leq // -mul2n Gauss_dvd ?coprime2n // -{1}subn1. + by rewrite dvdn2 odd_sub // subnKC // odd_add odd_p odd_double addnC. +have [// | [cHH rankH] | [/(_ p piHp)Udvp1 _]] := LtypeI; last first. + exists false; apply: dvdn_trans Udvp1. + by have:= piUq; rewrite mem_primes => /and3P[]. +suffices: q %| p ^ 2 - 1 ^ 2. + rewrite subn_sqr addn1 subn1 Euclid_dvdM //. + by case/orP; [exists false | exists true]. +pose P := 'O_p(H); pose P1 := 'Ohm_1(P). +have chP1H: P1 \char H := char_trans (Ohm_char 1 _) (pcore_char p H). +have sylP: p.-Sylow(H) P := nilpotent_pcore_Hall p (Fcore_nil L). +have [sPH pP _] := and3P sylP. +have abelP1: p.-abelem P1 by rewrite Ohm1_abelem ?(abelianS sPH). +have [pP1 _] := andP abelP1. +have prankP1: 'r_p(P1) = 2. + apply/eqP; rewrite p_rank_Ohm1 eqn_leq -{1}rank_pgroup // -{1}rankH rankS //=. + by rewrite -prankP0 (p_rank_Sylow sylP) p_rankS. +have ntP1: P1 != 1%g by rewrite -rank_gt0 (rank_pgroup pP1) prankP1. +have [_ _ [U0 [sU0U expU0 frobHU0]]] := LtypeF. +have nP1U0: U0 \subset 'N(P1). + by rewrite (char_norm_trans chP1H) ?(subset_trans sU0U). +rewrite subn1 -prankP1 p_rank_abelem // -card_pgroup //. +have frobP1U0 := Frobenius_subl ntP1 (char_sub chP1H) nP1U0 frobHU0. +apply: dvdn_trans (Frobenius_dvd_ker1 frobP1U0). +by have:= piUq; rewrite -expU0 pi_of_exponent mem_primes => /and3P[]. +Qed. + +Let Ltype1 : FTtype L == 1%N. Proof. exact: FT_Frobenius_type1 frobL. Qed. +Let defAL : 'A(L) = H^#. Proof. exact: FTsupp_Frobenius frobL. Qed. +Let sP0H : P0 \subset H. Proof. by rewrite /= -FTcore_type1. Qed. + +(* This is the first part of Peterfalvi (12.11). *) +Let defM : K ><| (M :&: L) = M. +Proof. +have [ntx /(subsetP (Ohm_sub 1 _))P0x] := setD1P P0_1s_x. +have Dx: x \in [set y in 'A0(L) | ~~ ('C[y] \subset L)]. + by rewrite inE FTsupp0_type1 // defAL !inE ntx (subsetP sP0H). +have [_ [_ /(_ x Dx)uCx] /(_ x Dx)[[defM _] _ _ _]] := FTsupport_facts maxL. +rewrite /K /= setIC (eq_uniq_mmax uCx maxM) //= -cent_cycle. +exact: subset_trans (cent_sub <[x]>) sNxM. +Qed. + +(* This is the second part of Peterfalvi (12.11). *) +Let sML_H : M :&: L \subset H. +Proof. +have [sP0M pP0 _] := and3P sylP0. +rewrite (sub_normal_Hall (Fcore_Hall L)) ?subsetIr //. +apply/pgroupP=> q pr_q /Cauchy[]// z /setIP[Mz Lz] oz; pose A := <[z]>%G. +have z_gt1: (#[z] > 1)%N by rewrite oz prime_gt1. +have sylP0_HM: p.-Sylow(H :&: M) P0. + by rewrite (pHall_subl _ _ sylP0) ?subsetIr // subsetI sP0H. +have nP0A: A \subset 'N(P0). + have sylHp: p.-Sylow(H) 'O_p(H) := nilpotent_pcore_Hall p (Fcore_nil L). + have sP0Hp: P0 \subset 'O_p(H) by rewrite sub_Hall_pcore. + have <-: 'O_p(H) :&: M = P0. + rewrite [_ :&: _](sub_pHall sylP0_HM) ?setSI ?pcore_sub //. + by rewrite (pgroupS (subsetIl _ _)) ?pcore_pgroup. + by rewrite subsetI sP0Hp. + have chHpL: 'O_p(H) \char L := char_trans (pcore_char p H) (Fcore_char L). + by rewrite normsI ?(char_norm_trans chHpL) ?normsG // cycle_subG. +apply: wlog_neg => piH'q. +have coHQ: coprime #|H| #|A| by rewrite -orderE coprime_pi' // oz pnatE. +have frobP0A: [Frobenius P0 <*> A = P0 ><| A]. + have defHA: H ><| A = H <*> A. + by rewrite sdprodEY ?coprime_TIg // cycle_subG (subsetP (gFnorm _ _)). + have ltH_HA: H \proper H <*> A. + by rewrite /proper joing_subl -indexg_gt1 -(index_sdprod defHA). + have: [Frobenius H <*> A = H ><| A]. + apply: set_Frobenius_compl defHA _. + by apply: Frobenius_kerS frobL; rewrite // join_subG gFsub cycle_subG. + by apply: Frobenius_subl => //; rewrite -rank_gt0 (rank_pgroup pP0) prankP0. +have sP0A_M: P0 <*> A \subset M by rewrite join_subG sP0M cycle_subG. +have nKP0a: P0 <*> A \subset 'N(K) := subset_trans sP0A_M (gFnorm _ _). +have solK: solvable K := nilpotent_sol (Fcore_nil M). +have [_ [/(compl_of_typeF defM) MtypeF _]] := FTtypeP 1 maxM Mtype1. +have nreg_KA: 'C_K(A) != 1%g. + have [Kq | K'q] := boolP (q \in \pi(K)). + apply/trivgPn; exists z; rewrite -?order_gt1 //= cent_cycle inE cent1id. + by rewrite andbT (mem_normal_Hall (Fcore_Hall M)) // /p_elt oz pnatE. + have [defP0A ntP0 _ _ _] := Frobenius_context frobP0A. + have coK_P0A: coprime #|K| #|P0 <*> A|. + rewrite -(sdprod_card defP0A) coprime_mulr (p'nat_coprime p'K) //=. + by rewrite -orderE coprime_pi' // oz pnatE. + have: ~~ (P0 \subset 'C(K)); last apply: contraNneq. + have [[ntK _ _] _ [U0 [sU0ML expU0 frobKU0]]] := MtypeF. + have [P1 /pnElemP[sP1U0 abelP1 dimP1]] := p_rank_witness p U0. + have ntP1: P1 :!=: 1%g. + rewrite -rank_gt0 (rank_abelem abelP1) dimP1 p_rank_gt0 -pi_of_exponent. + rewrite expU0 pi_of_exponent (piSg (setIS M (Fcore_sub L))) //=. + by rewrite setIC -p_rank_gt0 -(p_rank_Sylow sylP0_HM) prankP0. + have frobKP1: [Frobenius K <*> P1 = K ><| P1]. + exact: Frobenius_subr ntP1 sP1U0 frobKU0. + have sP1M: P1 \subset M. + by rewrite (subset_trans (subset_trans sP1U0 sU0ML)) ?subsetIl. + have [y My sP1yP0] := Sylow_Jsub sylP0 sP1M (abelem_pgroup abelP1). + apply: contra ntK => cP0K; rewrite -(Frobenius_trivg_cent frobKP1). + rewrite (setIidPl _) // -(conjSg _ _ y) (normsP _ y My) ?gFnorm //. + by rewrite -centJ centsC (subset_trans sP1yP0). + by have [] := Frobenius_Wielandt_fixpoint frobP0A nKP0a coK_P0A solK. +have [_ [U1 [_ abU1 sCK_U1]] _] := MtypeF. +have [ntx /(subsetP (Ohm_sub 1 _))P0x] := setD1P P0_1s_x. +have cAx: A \subset 'C[x]. + rewrite -cent_set1 (sub_abelian_cent2 abU1) //. + have [y /setIP[Ky cAy] nty] := trivgPn _ nreg_KA. + apply: subset_trans (sCK_U1 y _); last by rewrite !inE nty. + by rewrite subsetI sub_cent1 cAy cycle_subG !inE Mz Lz. + have [y /setIP[Ky cxy] notK'y] := subsetPn not_sCxK'. + apply: subset_trans (sCK_U1 y _); last by rewrite !inE (group1_contra notK'y). + rewrite sub1set inE cent1C cxy (subsetP _ x P0x) //. + by rewrite subsetI sP0M (subset_trans sP0H) ?gFsub. +have [_ _ _ regHL] := Frobenius_kerP frobL. +rewrite (piSg (regHL x _)) //; first by rewrite !inE ntx (subsetP sP0H). +by rewrite mem_primes pr_q cardG_gt0 -oz cardSg // subsetI cycle_subG Lz. +Qed. + +Let E := sval (sigW (existsP frobL)). +Let e := #|E|. + +Let defL : H ><| E = L. +Proof. by rewrite /E; case: (sigW _) => E0 /=/Frobenius_context[]. Qed. + +Let Ecyclic_le_p : cyclic E /\ (e %| p.-1) || (e %| p.+1). +Proof. +pose P := 'O_p(H)%G; pose T := 'Ohm_1('Z(P))%G. +have sylP: p.-Sylow(H) P := nilpotent_pcore_Hall p (Fcore_nil L). +have [[sPH pP _] [sP0M pP0 _]] := (and3P sylP, and3P sylP0). +have sP0P: P0 \subset P by rewrite (sub_normal_Hall sylP) ?pcore_normal. +have defP0: P :&: M = P0. + rewrite [P :&: M](sub_pHall sylP0 (pgroupS _ pP)) ?subsetIl ?subsetIr //. + by rewrite subsetI sP0P. +have [ntx P01x] := setD1P P0_1s_x; have P0x := subsetP (Ohm_sub 1 P0) x P01x. +have sZP0: 'Z(P) \subset P0. + apply: subset_trans (_ : 'C_P[x] \subset P0). + by rewrite -cent_set1 setIS ?centS // sub1set (subsetP sP0P). + by rewrite -defP0 setIS // (subset_trans _ sNxM) // cents_norm ?cent_cycle. +have ntT: T :!=: 1%g. + rewrite Ohm1_eq1 center_nil_eq1 ?(pgroup_nil pP) // (subG1_contra sP0P) //. + by apply/trivgPn; exists x. +have [_ sEL _ nHE tiHE] := sdprod_context defL. +have charTP: T \char P := char_trans (Ohm_char 1 _) (center_char P). +have{ntT} [V minV sVT]: {V : {group gT} | minnormal V E & V \subset T}. + apply: mingroup_exists; rewrite ntT (char_norm_trans charTP) //. + exact: char_norm_trans (pcore_char p H) nHE. +have abelT: p.-abelem T by rewrite Ohm1_abelem ?center_abelian ?(pgroupS sZP0). +have sTP := subset_trans (Ohm_sub 1 _) sZP0. +have rankT: ('r_p(T) <= 2)%N by rewrite -prankP0 p_rankS. +have [abelV /andP[ntV nVE]] := (abelemS sVT abelT, mingroupp minV). +have pV := abelem_pgroup abelV; have [pr_p _ [n oV]] := pgroup_pdiv pV ntV. +have frobHE: [Frobenius L = H ><| E] by rewrite /E; case: (sigW _). +have: ('r_p(V) <= 2)%N by rewrite (leq_trans (p_rankS p sVT)). +rewrite (p_rank_abelem abelV) // oV pfactorK // ltnS leq_eqVlt ltnS leqn0 orbC. +have sVH := subset_trans sVT (subset_trans (char_sub charTP) sPH). +have regVE: 'C_E(V) = 1%g. + exact: cent_semiregular (Frobenius_reg_compl frobHE) sVH ntV. +case/pred2P=> dimV; rewrite {n}dimV in oV. + pose f := [morphism of restrm nVE (conj_aut V)]. + have injf: 'injm f by rewrite ker_restrm ker_conj_aut regVE. + rewrite /e -(injm_cyclic injf) // -(card_injm injf) //. + have AutE: f @* E \subset Aut V by rewrite im_restrm Aut_conj_aut. + rewrite (cyclicS AutE) ?Aut_prime_cyclic ?oV // (dvdn_trans (cardSg AutE)) //. + by rewrite card_Aut_cyclic ?prime_cyclic ?oV // totient_pfactor ?muln1. +have defV: V :=: 'Ohm_1(P0). + apply/eqP; rewrite eqEcard (subset_trans sVT) ?OhmS //= oV -prankP0. + by rewrite p_rank_abelian // -card_pgroup ?(pgroupS (Ohm_sub 1 _)). +pose rE := abelem_repr abelV ntV nVE. +have ffulE: mx_faithful rE by apply: abelem_mx_faithful. +have p'E: [char 'F_p]^'.-group E. + rewrite (eq_p'group _ (charf_eq (char_Fp pr_p))) (coprime_p'group _ pV) //. + by rewrite coprime_sym (coprimeSg sVH) ?(Frobenius_coprime frobHE). +have dimV: 'dim V = 2 by rewrite (dim_abelemE abelV) // oV pfactorK. +have cEE: abelian E. + by rewrite dimV in (rE) ffulE; apply: charf'_GL2_abelian (mFT_odd E) ffulE _. +have Enonscalar y: y \in E -> y != 1%g -> ~~ is_scalar_mx (rE y). + move=> Ey; apply: contra => /is_scalar_mxP[a rEy]; simpl in a. + have nXy: y \in 'N(<[x]>). + rewrite !inE -cycleJ cycle_subG; apply/cycleP; exists a. + have [Vx nVy]: x \in V /\ y \in 'N(V) by rewrite (subsetP nVE) ?defV. + apply: (@abelem_rV_inj p _ V); rewrite ?groupX ?memJ_norm ?morphX //=. + by rewrite zmodXgE -scaler_nat natr_Zp -mul_mx_scalar -rEy -abelem_rV_J. + rewrite -in_set1 -set1gE -tiHE inE (subsetP sML_H) //. + by rewrite inE (subsetP sEL) // (subsetP sNxM). +have /trivgPn[y nty Ey]: E != 1%G by have [] := Frobenius_context frobHE. +have cErEy: centgmx rE (rE y). + by apply/centgmxP=> z Ez; rewrite -!repr_mxM // (centsP cEE). +have irrE: mx_irreducible rE by apply/abelem_mx_irrP. +have charFp2: p \in [char MatrixGenField.gen_finFieldType irrE cErEy]. + apply: (rmorph_char (MatrixGenField.gen_rmorphism irrE cErEy)). + exact: char_Fp. +pose Fp2 := primeChar_finFieldType charFp2. +pose n1 := MatrixGenField.gen_dim (rE y). +pose rEp2 : mx_representation Fp2 E n1 := MatrixGenField.gen_repr irrE cErEy. +have n1_gt0: (0 < n1)%N := MatrixGenField.gen_dim_gt0 irrE cErEy. +have n1_eq1: n1 = 1%N. + pose d := degree_mxminpoly (rE y). + have dgt0: (0 < d)%N := mxminpoly_nonconstant _. + apply/eqP; rewrite eqn_leq n1_gt0 andbT -(leq_pmul2r dgt0). + rewrite (MatrixGenField.gen_dim_factor irrE cErEy) mul1n dimV. + by rewrite ltnNge mxminpoly_linear_is_scalar Enonscalar. +have oFp2: #|Fp2| = (p ^ 2)%N. + rewrite card_sub card_matrix card_Fp // -{1}n1_eq1. + by rewrite (MatrixGenField.gen_dim_factor irrE cErEy) dimV. +have [f rfK fK]: bijective (@scalar_mx Fp2 n1). + rewrite n1_eq1. + by exists (fun A : 'M_1 => A 0 0) => ?; rewrite ?mxE -?mx11_scalar. +pose g z : {unit Fp2} := insubd (1%g : {unit Fp2}) (f (rEp2 z)). +have val_g z : z \in E -> (val (g z))%:M = rEp2 z. + move=> Ez; rewrite insubdK ?fK //; have:= repr_mx_unit rEp2 Ez. + by rewrite -{1}[rEp2 z]fK unitmxE det_scalar !unitfE expf_eq0 n1_gt0. +have ffulEp2: mx_faithful rEp2 by rewrite MatrixGenField.gen_mx_faithful. +have gM: {in E &, {morph g: z1 z2 / z1 * z2}}%g. + move=> z1 z2 Ez1 Ez2 /=; apply/val_inj/(can_inj rfK). + rewrite {1}(val_g _ (groupM Ez1 Ez2)) scalar_mxM. + by rewrite {1}(val_g _ Ez1) (val_g _ Ez2) repr_mxM. +have inj_g: 'injm (Morphism gM). + apply/injmP=> z1 z2 Ez1 Ez2 /(congr1 (@scalar_mx _ n1 \o val)). + by rewrite /= {1}(val_g _ Ez1) (val_g _ Ez2); apply: mx_faithful_inj. +split; first by rewrite -(injm_cyclic inj_g) ?field_unit_group_cyclic. +have: e %| #|[set: {unit Fp2}]|. + by rewrite /e -(card_injm inj_g) ?cardSg ?subsetT. +rewrite card_finField_unit oFp2 -!subn1 (subn_sqr p 1) addn1. +rewrite orbC Gauss_dvdr; first by move->. +rewrite coprime_sym coprime_has_primes ?subn_gt0 ?prime_gt1 ?cardG_gt0 //. +apply/hasPn=> r; rewrite /= !mem_primes subn_gt0 prime_gt1 ?cardG_gt0 //=. +case/andP=> pr_r /Cauchy[//|z Ez oz]; rewrite pr_r /= subn1. +apply: contra (Enonscalar z Ez _); last by rewrite -order_gt1 oz prime_gt1. +rewrite -oz -(order_injm inj_g) // order_dvdn -val_eqE => /eqP gz_p1_eq1. +have /vlineP[a Dgz]: val (g z) \in 1%VS. + rewrite Fermat's_little_theorem dimv1 card_Fp //=. + by rewrite -[(p ^ 1)%N]prednK ?prime_gt0 // exprS -val_unitX gz_p1_eq1 mulr1. +apply/is_scalar_mxP; exists a; apply/row_matrixP=> i. +apply: (can_inj ((MatrixGenField.in_genK irrE cErEy) _)). +rewrite !rowE mul_mx_scalar MatrixGenField.in_genZ MatrixGenField.in_genJ //. +rewrite -val_g // Dgz mul_mx_scalar; congr (_ *: _). +rewrite -(natr_Zp a) scaler_nat. +by rewrite -(rmorph_nat (MatrixGenField.gen_rmorphism irrE cErEy)). +Qed. + +Let calS := seqIndD H L H 1. +Notation tauL := (FT_Dade maxL). +Notation tauL_H := (FT_DadeF maxL). +Notation rhoL := (invDade (FT_DadeF_hyp maxL)). + +Section Twelve_13_to_16. + +Variables (tau1 : {additive 'CF(L) -> 'CF(G)}) (chi : 'CF(L)). +Hypothesis cohS : coherent_with calS L^# tauL tau1. +Hypotheses (Schi : chi \in calS) (chi1 : chi 1%g = e%:R). +Let psi := tau1 chi. + +Let cohS_H : coherent_with calS L^# tauL_H tau1. +Proof. +have [? Dtau] := cohS; split=> // xi Sxi; have /zcharD1_seqInd_on Hxi := Sxi. +by rewrite Dtau // FT_DadeF_E ?FT_DadeE ?(cfun_onS (Fcore_sub_FTsupp _)) ?Hxi. +Qed. + +(* This is Peterfalvi (12.14). *) +Let rhoL_psi : {in K, forall g, psi (x * g)%g = chi x} /\ rhoL psi x = chi x. +Proof. +have not_LGM: gval M \notin L :^: G. + apply: contraL p'K => /= /imsetP[z _ ->]; rewrite FcoreJ pgroupJ. + by rewrite p'groupEpi (piSg sP0H) // -p_rank_gt0 prankP0. +pose rmR := sval (Rgen maxL Ltype1). +have Zpsi: psi \in 'Z[rmR chi]. + case: (Rgen _ _) @rmR => /= rmR []; rewrite -/calS => scohS _ _. + have sSS: cfConjC_subset calS calS by apply: seqInd_conjC_subset1. + have [B /mem_subseq sBR Dpsi] := mem_coherent_sum_subseq scohS sSS cohS Schi. + by rewrite [psi]Dpsi big_seq rpred_sum // => xi /sBR/mem_zchar->. +have [ntx /(subsetP (Ohm_sub 1 P0))P0x] := setD1P P0_1s_x. +have Mx: x \in M by rewrite (subsetP sNxM) // -cycle_subG normG. +have psi_xK: {in K, forall g, psi (x * g)%g = psi x}. + move=> g Kg; have{Kg}: (x * g \in x *: K)%g by rewrite mem_lcoset mulKg. + apply: FTtype1_ortho_constant => [phi calMphi|]. + apply/orthoPl=> nu /memv_span; apply: {nu}span_orthogonal (zchar_span Zpsi). + exact: FTtype1_seqInd_ortho. + rewrite inE -/K (contra _ ntx) // => Kx. + rewrite -(consttC p x) !(constt1P _) ?mulg1 ?(mem_p_elt p'K) //. + by rewrite p_eltNK (mem_p_elt (pHall_pgroup sylP0)). +have H1x: x \in H^# by rewrite !inE ntx (subsetP sP0H). +have rhoL_psi_x: rhoL psi x = psi x. + rewrite cfunElock mulrb def_FTsignalizerF H1x //=. + apply: canLR (mulKf (neq0CG _)) _; rewrite mulr_natl -sumr_const /=. + apply: eq_bigr => g; rewrite /'R_L (negPf not_sCxL) /= setIC => /setIP[cxz]. + have Dx: x \in [set y in 'A0(L) | ~~ ('C[y] \subset L)]. + by rewrite inE (subsetP (Fcore_sub_FTsupp0 _)). + have [_ [_ /(_ x Dx)defNx] _] := FTsupport_facts maxL. + rewrite (cent1P cxz) -(eq_uniq_mmax defNx maxM) => [/psi_xK//|]. + by rewrite /= -cent_cycle (subset_trans (cent_sub _)). +suffices <-: rhoL psi x = chi x by split=> // g /psi_xK->. +have irrS: {subset calS <= irr L} by have [] := FT_Frobenius_coherence maxL. +have irr_chi := irrS _ Schi. +have Sgt1: (1 < size calS)%N by apply: seqInd_nontrivial Schi; rewrite ?mFT_odd. +have De: #|L : H| = e by rewrite -(index_sdprod defL). +have [] := Dade_Ind1_sub_lin cohS_H Sgt1 irr_chi Schi; rewrite ?De //. +rewrite -/tauL_H -/calS -/psi /=; set alpha := 'Ind 1 - chi. +case=> o_tau_1 tau_alpha_1 _ [Gamma [o_tau1_Ga _ [a Za tau_alpha] _] _]. +have [[Itau1 _] Dtau1] := cohS_H. +have o1calS: orthonormal calS. + by rewrite (sub_orthonormal irrS) ?seqInd_uniq ?irr_orthonormal. +have norm_alpha: '[tauL_H alpha] = e%:R + 1. + rewrite Dade_isometry ?(cfInd1_sub_lin_on _ Schi) ?De //. + rewrite cfnormBd; last by rewrite cfdotC (seqInd_ortho_Ind1 _ _ Schi) ?conjC0. + by rewrite cfnorm_Ind_cfun1 // De irrWnorm. +pose h := #|H|; have ub_a: a ^+ 2 * ((h%:R - 1) / e%:R) - 2%:R * a <= e%:R - 1. + rewrite -[h%:R - 1](mulKf (neq0CiG L H)) -sum_seqIndC1_square // De -/calS. + rewrite -[lhs in lhs - 1](addrK 1) -norm_alpha -[tauL_H _](subrK 1). + rewrite cfnormDd; last by rewrite cfdotBl tau_alpha_1 cfnorm1 subrr. + rewrite cfnorm1 addrK [in '[_]]addrC {}tau_alpha -!addrA addKr addrCA addrA. + rewrite ler_subr_addr cfnormDd ?ler_paddr ?cfnorm_ge0 //; last first. + rewrite cfdotBl cfdotZl cfdot_suml (orthoPr o_tau1_Ga) ?map_f // subr0. + rewrite big1_seq ?mulr0 // => xi Sxi; rewrite cfdotZl. + by rewrite (orthoPr o_tau1_Ga) ?map_f ?mulr0. + rewrite cfnormB cfnormZ Cint_normK // cfdotZl cfproj_sum_orthonormal //. + rewrite cfnorm_sum_orthonormal // Itau1 ?mem_zchar // irrWnorm ?irrS // divr1. + rewrite chi1 divff ?neq0CG // mulr1 conj_Cint // addrAC mulr_natl. + rewrite !ler_add2r !(mulr_suml, mulr_sumr) !big_seq ler_sum // => xi Sxi. + rewrite irrWnorm ?irrS // !divr1 (mulrAC _^-1) -expr2 -!exprMn (mulrC _^-1). + by rewrite normf_div normr_nat norm_Cnat // (Cnat_seqInd1 Sxi). +have [pr_p p_dv_M]: prime p /\ p %| #|M|. + have: p \in \pi(M) by rewrite -p_rank_gt0 ltnW. + by rewrite mem_primes => /and3P[]. +have odd_p: odd p by rewrite (dvdn_odd p_dv_M) ?mFT_odd. +have pgt2: (2 < p)%N := odd_prime_gt2 odd_p pr_p. +have ub_e: e%:R <= (p%:R + 1) / 2%:R :> algC. + rewrite ler_pdivl_mulr ?ltr0n // -natrM -mulrSr leC_nat muln2. + have [b e_dv_pb]: exists b : bool, e %| (b.*2 + p).-1. + by have [_ /orP[]] := Ecyclic_le_p; [exists false | exists true]. + rewrite -ltnS (@leq_trans (b.*2 + p)) //; last first. + by rewrite (leq_add2r p _ 2) (leq_double _ 1) leq_b1. + rewrite dvdn_double_ltn ?mFT_odd //; first by rewrite odd_add odd_double. + by rewrite -(subnKC pgt2) !addnS. +have lb_h: p%:R ^+ 2 <= h%:R :> algC. + rewrite -natrX leC_nat dvdn_leq ?pfactor_dvdn ?cardG_gt0 //. + by rewrite -prankP0 (leq_trans (p_rankS p sP0H)) ?p_rank_le_logn. +have{ub_a ub_e} ub_a: p.-1.*2%:R * a ^+ 2 - 2%:R * a <= p.-1%:R / 2%:R :> algC. + apply: ler_trans (ler_trans ub_a _); last first. + rewrite -subn1 -subSS natrB ?ltnS ?prime_gt0 // mulrSr mulrBl. + by rewrite divff ?pnatr_eq0 ?ler_add2r. + rewrite ler_add2r mulrC -Cint_normK // -!mulrA !ler_wpmul2l ?normr_ge0 //. + rewrite ler_pdivl_mulr ?gt0CG // ler_subr_addr (ler_trans _ lb_h) //. + rewrite -muln2 natrM -mulrA -ler_subr_addr subr_sqr_1. + rewrite -(natrB _ (prime_gt0 pr_p)) subn1 ler_wpmul2l ?ler0n //. + by rewrite mulrC -ler_pdivl_mulr ?ltr0n. +have a0: a = 0. + apply: contraTeq ub_a => nz_a; rewrite ltr_geF // ltr_pdivr_mulr ?ltr0n //. + rewrite mulrC -{1}mulr_natl -muln2 natrM -mulrA mulrBr mulrCA ltr_subr_addl. + rewrite -ltr_subr_addr -mulrBr mulr_natl mulrA -expr2 -exprMn. + apply: ltr_le_trans (_ : 2%:R * ((a *+ 2) ^+ 2 - 1) <= _); last first. + rewrite (mulr_natl a 2) ler_wpmul2r // ?subr_ge0. + by rewrite sqr_Cint_ge1 ?rpredMn // mulrn_eq0. + by rewrite leC_nat -subn1 ltn_subRL. + rewrite -(@ltr_pmul2l _ 2%:R) ?ltr0n // !mulrA -expr2 mulrBr -exprMn mulr1. + rewrite -natrX 2!mulrnAr -[in rhs in _ < rhs]mulrnAl -mulrnA. + rewrite ltr_subr_addl -ltr_subr_addr -(ltr_add2r 1) -mulrSr -sqrrB1. + rewrite -Cint_normK ?rpredB ?rpredM ?rpred_nat ?rpred1 //. + rewrite (@ltr_le_trans _ (3 ^ 2)%:R) ?ltC_nat // natrX. + rewrite ler_sqr ?qualifE ?ler0n ?normr_ge0 //. + rewrite (ler_trans _ (ler_sub_dist _ _)) // normr1 normrM normr_nat. + by rewrite ler_subr_addl -mulrS mulr_natl ler_pmuln2r ?norm_Cint_ge1. +pose chi0 := 'Ind[L, H] 1. +have defS1: perm_eq (seqIndT H L) (chi0 :: calS). + by rewrite [calS]seqIndC1_rem // perm_to_rem ?seqIndT_Ind1. +have [c _ -> // _] := invDade_seqInd_sum (FT_DadeF_hyp maxL) psi defS1. +have psi_alpha_1: '[psi, tauL_H alpha] = -1. + rewrite tau_alpha a0 scale0r addr0 addrC addrA cfdotBr cfdotDr. + rewrite (orthoPr o_tau_1) ?(orthoPr o_tau1_Ga) ?map_f // !add0r. + by rewrite Itau1 ?mem_zchar ?map_f // irrWnorm ?irrS. +rewrite (bigD1_seq chi) ?seqInd_uniq //= big1_seq => [|xi /andP[chi'xi Sxi]]. + rewrite addr0 -cfdotC chi1 cfInd1 ?gFsub // cfun11 mulr1 De divff ?neq0CG //. + rewrite scale1r -opprB linearN cfdotNr psi_alpha_1 opprK. + by rewrite irrWnorm ?irrS // divr1 mul1r. +rewrite -cfdotC cfInd1 ?gFsub // cfun11 mulr1. +rewrite /chi0 -(canLR (subrK _) (erefl alpha)) scalerDr opprD addrCA -scaleNr. +rewrite linearD linearZ /= cfdotDr cfdotZr psi_alpha_1 mulrN1 rmorphN opprK. +rewrite -/tauL_H -Dtau1 ?zcharD1_seqInd ?(seqInd_sub_lin_vchar _ Schi) ?De //. +have [_ ooS] := orthonormalP o1calS. +rewrite raddfB cfdotBr Itau1 ?mem_zchar // ooS // mulrb ifN_eqC // add0r. +rewrite -De raddfZ_Cnat ?(dvd_index_seqInd1 _ Sxi) // De cfdotZr. +by rewrite Itau1 ?mem_zchar ?ooS // eqxx mulr1 subrr !mul0r. +Qed. + +Let rhoM := invDade (FT_DadeF_hyp maxM). + +Let rhoM_psi : + [/\ {in K^#, rhoM psi =1 psi}, + {in K :\: K' &, forall g1 g2, psi g1 = psi g2} + & {in K :\: K', forall g, psi g \in Cint}]. +Proof. +have pr_p: prime p. + by have:= ltnW prankM; rewrite p_rank_gt0 mem_primes => /andP[]. +have [sP0M pP0 _] := and3P sylP0; have abelP01 := Ohm1_abelem pP0 abP0. +have not_frobM: ~~ [Frobenius M with kernel K]. + apply: contraL prankM => /(set_Frobenius_compl defM)frobM. + rewrite -leqNgt -(p_rank_Sylow sylP0) -p_rank_Ohm1 p_rank_abelem //. + rewrite -abelem_cyclic // (cyclicS (Ohm_sub _ _)) //. + have sP0ML: P0 \subset M :&: L. + by rewrite subsetI sP0M (subset_trans sP0H) ?gFsub. + rewrite nil_Zgroup_cyclic ?(pgroup_nil pP0) // (ZgroupS sP0ML) //. + have [U [MtypeF _]] := FTtypeP 1 maxM Mtype1. + by have{MtypeF} /typeF_context[_ <- _] := compl_of_typeF defM MtypeF. +pose rmR := sval (Rgen maxL Ltype1). +have Zpsi: psi \in 'Z[rmR chi]. + case: (Rgen _ _) @rmR => /= rmR []; rewrite -/calS => scohS _ _. + have sSS: cfConjC_subset calS calS by apply: seqInd_conjC_subset1. + have [B /mem_subseq sBR Dpsi] := mem_coherent_sum_subseq scohS sSS cohS Schi. + by rewrite [psi]Dpsi big_seq rpred_sum // => xi /sBR/mem_zchar->. +have part1: {in K^#, rhoM psi =1 psi}. + move=> g K1g; rewrite /= cfunElock mulrb def_FTsignalizerF K1g //= /'R_M. + have [_ | sCg'M] := ifPn; first by rewrite cards1 big_set1 invr1 mul1r mul1g. + have Dg: g \in [set z in 'A0(M) | ~~ ('C[z] \subset M)]. + by rewrite inE (subsetP (Fcore_sub_FTsupp0 _)). + have [_ [_ /(_ g Dg)maxN] /(_ g Dg)[_ _ ANg Ntype12]] := FTsupport_facts maxM. + have{maxN} [maxN sCgN] := mem_uniq_mmax maxN. + have{Ntype12} Ntype1: FTtype 'N[g] == 1%N. + have [] := Ntype12; rewrite -(mem_iota 1 2) !inE => /orP[// | Ntype2] frobM. + by have /negP[] := not_frobM; apply/frobM/Ntype2. + have not_frobN: ~~ [Frobenius 'N[g] with kernel 'N[g]`_\F]. + apply/Frobenius_kerP=> [[_ _ _ regFN]]. + have [/bigcupP[y]] := setDP ANg; rewrite FTsupp1_type1 Ntype1 //. + by move=> /regFN sCyF /setD1P[ntg cNy_g]; rewrite 2!inE ntg (subsetP sCyF). + have LG'N: gval 'N[g] \notin L :^: G. + by apply: contra not_frobN => /imsetP[y _ ->]; rewrite FcoreJ FrobeniusJker. + suff /(eq_bigr _)->: {in 'C_('N[g]`_\F)[g], forall z, psi (z * g)%g = psi g}. + by rewrite sumr_const -[psi g *+ _]mulr_natl mulKf ?neq0CG. + move=> z /setIP[Fz /cent1P cgz]. + have{Fz cgz}: (z * g \in g *: 'N[g]`_\F)%g by rewrite cgz mem_lcoset mulKg. + apply: FTtype1_ortho_constant => [phi calMphi|]. + apply/orthoPl=> nu /memv_span; apply: span_orthogonal (zchar_span Zpsi). + exact: FTtype1_seqInd_ortho. + have [/(subsetP (FTsupp_sub _))/setD1P[ntg Ng]] := setDP ANg. + by rewrite FTsupp1_type1 //= !inE ntg Ng andbT. +have part2: {in K :\: K' &, forall g1 g2, psi g1 = psi g2}. + have /subsetP sK1_K: K :\: K' \subset K^# by rewrite setDS ?sub1G. + have LG'M: gval M \notin L :^: G. + apply: contra not_frobM => /imsetP[y _ /= ->]. + by rewrite FcoreJ FrobeniusJker. + move=> g1 g2 Kg1 Kg2; rewrite /= -!part1 ?sK1_K //. + apply: FtypeI_invDade_ortho_constant => // phi calMphi. + apply/orthoPl=> nu /memv_span; apply: span_orthogonal (zchar_span Zpsi). + exact: FTtype1_seqInd_ortho. +split=> // g KK'g; pose nKK' : algC := #|K :\: K'|%:R. +pose nK : algC := #|K|%:R; pose nK' : algC := #|K'|%:R. +have nzKK': nKK' != 0 by rewrite pnatr_eq0 cards_eq0; apply/set0Pn; exists g. +have Dpsi_g: nK * '['Res[K] psi, 1] = nK' * '['Res[K'] psi, 1] + nKK' * psi g. + rewrite !mulVKf ?neq0CG // (big_setID K') (setIidPr (gFsub _ _)) /=. + rewrite mulr_natl -sumr_const; congr (_ + _); apply: eq_bigr => z K'z. + by rewrite !cfun1E !cfResE ?subsetT ?(subsetP (der_sub 1 K)) ?K'z. + have [Kz _] := setDP K'z; rewrite cfun1E Kz conjC1 mulr1 cfResE ?subsetT //. + exact: part2. +have{Zpsi} Zpsi: psi \in 'Z[irr G] by have [[_ ->//]] := cohS; apply: mem_zchar. +have Qpsi1 R: '['Res[R] psi, 1] \in Crat. + by rewrite rpred_Cint ?Cint_cfdot_vchar ?rpred1 ?cfRes_vchar. +apply: Cint_rat_Aint (Aint_vchar g Zpsi). +rewrite -[psi g](mulKf nzKK') -(canLR (addKr _) Dpsi_g) addrC mulrC. +by rewrite rpred_div ?rpredB 1?rpredM ?rpred_nat ?Qpsi1. +Qed. + +(* This is the main part of Peterfalvi (12.16). *) +Lemma FTtype1_nonFrobenius_witness_contradiction : False. +Proof. +have pr_p: prime p. + by have:= ltnW prankM; rewrite p_rank_gt0 mem_primes => /andP[]. +have [sP0M pP0 _] := and3P sylP0; have abelP01 := Ohm1_abelem pP0 abP0. +have [ntx P01x] := setD1P P0_1s_x. +have ox: #[x] = p := abelem_order_p abelP01 P01x ntx. +have odd_p: odd p by rewrite -ox mFT_odd. +have pgt2 := odd_prime_gt2 odd_p pr_p. +have Zpsi: psi \in 'Z[irr G] by have [[_ ->//]] := cohS; apply: mem_zchar. +have lb_psiM: '[rhoM psi] >= #|K :\: K'|%:R / #|M|%:R * e.-1%:R ^+ 2. + have [g /setIP[Kg cxg] notK'g] := subsetPn not_sCxK'. + have KK'g: g \in K :\: K' by rewrite !inE notK'g. + have [rhoMid /(_ _ g _ KK'g)psiKK'_id /(_ g KK'g)Zpsig] := rhoM_psi. + rewrite -mulrA mulrCA ler_pmul2l ?invr_gt0 ?gt0CG // mulr_natl. + rewrite (big_setID (K :\: K')) (setIidPr _) ?subDset ?subsetU ?gFsub ?orbT //. + rewrite ler_paddr ?sumr_ge0 // => [z _|]; first exact: mul_conjC_ge0. + rewrite -sumr_const ler_sum // => z KK'z. + rewrite {}rhoMid ?(subsetP _ z KK'z) ?setDS ?sub1G // {}psiKK'_id {z KK'z}//. + rewrite -normCK ler_sqr ?qualifE ?ler0n ?normr_ge0 //. + have [eps prim_eps] := C_prim_root_exists (prime_gt0 pr_p). + have psi_xg: (psi (x * g)%g == e%:R %[mod 1 - eps])%A. + have [-> // _] := rhoL_psi; rewrite -[x]mulg1 -chi1. + rewrite (vchar_ker_mod_prim prim_eps) ?group1 ?(seqInd_vcharW Schi) //. + rewrite (subsetP _ _ P01x) // (subset_trans (Ohm_sub 1 _)) //. + by rewrite (subset_trans sP0H) ?gFsub. + have{psi_xg} /dvdCP[a Za /(canRL (subrK _))->]: (p %| psi g - e%:R)%C. + rewrite (int_eqAmod_prime_prim prim_eps) ?rpredB ?rpred_nat // eqAmod0. + apply: eqAmod_trans psi_xg; rewrite eqAmod_sym. + by rewrite (vchar_ker_mod_prim prim_eps) ?in_setT. + have [-> | nz_a] := eqVneq a 0. + by rewrite mul0r add0r normr_nat leC_nat leq_pred. + rewrite -[e%:R]opprK (ler_trans _ (ler_sub_dist _ _)) // normrN normrM. + rewrite ler_subr_addl !normr_nat -natrD. + apply: ler_trans (_ : 1 * p%:R <= _); last first. + by rewrite ler_wpmul2r ?ler0n ?norm_Cint_ge1. + rewrite mul1r leC_nat -subn1 addnBA ?cardG_gt0 // leq_subLR addnn -ltnS. + have [b e_dv_pb]: exists b : bool, e %| (b.*2 + p).-1. + by have [_ /orP[]] := Ecyclic_le_p; [exists false | exists true]. + apply: (@leq_trans (b.*2 + p)); last first. + by rewrite (leq_add2r p _ 2) (leq_double b 1) leq_b1. + rewrite dvdn_double_ltn ?odd_add ?mFT_odd ?odd_double //. + by rewrite addnC -(subnKC pgt2). +have irrS: {subset calS <= irr L} by have [] := FT_Frobenius_coherence maxL. +have lb_psiL: '[rhoL psi] >= 1 - e%:R / #|H|%:R. + have irr_chi := irrS _ Schi. + have Sgt1: (1 < size calS)%N by apply: seqInd_nontrivial (mFT_odd _) _ _ Schi. + have De: #|L : H| = e by rewrite -(index_sdprod defL). + have [|_] := Dade_Ind1_sub_lin cohS_H Sgt1 irr_chi Schi; rewrite De //=. + by rewrite -De odd_Frobenius_index_ler ?mFT_odd // => -[_ _ []//]. +have tiA1_LM: [disjoint 'A1~(L) & 'A1~(M)]. + apply: FT_Dade1_support_disjoint => //. + apply: contraL p'K => /= /imsetP[z _ ->]; rewrite FcoreJ pgroupJ. + by rewrite p'groupEpi (piSg sP0H) // -p_rank_gt0 prankP0. +have{tiA1_LM} ub_rhoML: '[rhoM psi] + '[rhoL psi] < 1. + have [[Itau1 Ztau1] _] := cohS. + have n1psi: '[psi] = 1 by rewrite Itau1 ?mem_zchar ?irrWnorm ?irrS. + rewrite -n1psi (cfnormE (cfun_onG psi)) (big_setD1 1%g) ?group1 //=. + rewrite mulrDr ltr_spaddl 1?mulr_gt0 ?invr_gt0 ?gt0CG ?exprn_gt0 //. + have /dirrP[s [i ->]]: psi \in dirr G. + by rewrite dirrE Ztau1 ?mem_zchar ?n1psi /=. + by rewrite cfunE normrMsign normr_gt0 irr1_neq0. + rewrite (big_setID 'A1~(M)) mulrDr ler_add //=. + rewrite FTsupp1_type1 // -FT_DadeF_supportE. + by rewrite (setIidPr _) ?Dade_support_subD1 ?leC_cfnorm_invDade_support. + rewrite (big_setID 'A1~(L)) mulrDr ler_paddr //=. + rewrite mulr_ge0 ?invr_ge0 ?ler0n ?sumr_ge0 // => z _. + by rewrite exprn_ge0 ?normr_ge0. + rewrite (setIidPr _); last first. + by rewrite subsetD tiA1_LM -FT_Dade1_supportE Dade_support_subD1. + by rewrite FTsupp1_type1 // -FT_DadeF_supportE leC_cfnorm_invDade_support. +have ubM: (#|M| <= #|K| * #|H|)%N. + by rewrite -(sdprod_card defM) leq_mul // subset_leq_card. +have{lb_psiM lb_psiL ub_rhoML ubM} ubK: (#|K / K'|%g < 4)%N. + rewrite card_quotient ?gFnorm -?ltC_nat //. + rewrite -ltf_pinv ?qualifE ?gt0CiG ?ltr0n // natf_indexg ?gFsub //. + rewrite invfM invrK mulrC -(subrK #|K|%:R #|K'|%:R) mulrDl divff ?neq0CG //. + rewrite -opprB mulNr addrC ltr_subr_addl -ltr_subr_addr. + have /Frobenius_context[_ _ ntE _ _] := set_Frobenius_compl defL frobL. + have egt2: (2 < e)%N by rewrite odd_geq ?mFT_odd ?cardG_gt1. + have e1_gt0: 0 < e.-1%:R :> algC by rewrite ltr0n -(subnKC egt2). + apply: ltr_le_trans (_ : e%:R / e.-1%:R ^+ 2 <= _). + rewrite ltr_pdivl_mulr ?exprn_gt0 //. + rewrite -(@ltr_pmul2r _ #|H|%:R^-1) ?invr_gt0 ?gt0CG // mulrAC. + rewrite -(ltr_add2r 1) -ltr_subl_addl -addrA. + apply: ler_lt_trans ub_rhoML; rewrite ler_add //. + apply: ler_trans lb_psiM; rewrite -natrX ler_wpmul2r ?ler0n //. + rewrite cardsD (setIidPr _) ?gFsub // -natrB ?subset_leq_card ?gFsub //. + rewrite -mulrA ler_wpmul2l ?ler0n //. + rewrite ler_pdivr_mulr ?gt0CG // ler_pdivl_mull ?gt0CG //. + by rewrite ler_pdivr_mulr ?gt0CG // mulrC -natrM leC_nat. + rewrite -(ler_pmul2l (gt0CG E)) -/e mulrA -expr2 invfM -exprMn. + apply: ler_trans (_ : (1 + 2%:R^-1) ^+ 2 <= _). + rewrite ler_sqr ?rpred_div ?rpredD ?rpred1 ?rpredV ?rpred_nat //. + rewrite -{1}(ltn_predK egt2) mulrSr mulrDl divff ?gtr_eqF // ler_add2l. + rewrite ler_pdivr_mulr // ler_pdivl_mull ?ltr0n //. + by rewrite mulr1 leC_nat -(subnKC egt2). + rewrite -(@ler_pmul2r _ (2 ^ 2)%:R) ?ltr0n // {1}natrX -exprMn -mulrA. + rewrite mulrDl mulrBl !mul1r !mulVf ?pnatr_eq0 // (mulrSr _ 3) addrK. + by rewrite -mulrSr ler_wpmul2r ?ler0n ?ler_nat. +have [U [MtypeF _]] := FTtypeP 1 maxM Mtype1. +have{U MtypeF} [_ _ [U0 [sU0ML expU0 frobU0]]] := compl_of_typeF defM MtypeF. +have [/sdprodP[_ _ nKU0 tiKU0] ntK _ _ _] := Frobenius_context frobU0. +have nK'U0: U0 \subset 'N(K') := char_norm_trans (der_char 1 K) nKU0. +have frobU0K': [Frobenius K <*> U0 / K' = (K / K') ><| (U0 / K')]%g. + have solK: solvable K by rewrite ?nilpotent_sol ?Fcore_nil. + rewrite Frobenius_proper_quotient ?(sol_der1_proper solK) // /(_ <| _). + by rewrite (subset_trans (der_sub 1 _)) ?joing_subl // join_subG gFnorm. +have isoU0: U0 \isog U0 / K'. + by rewrite quotient_isog //; apply/trivgP; rewrite -tiKU0 setSI ?gFsub. +have piU0p: p \in \pi(U0 / K')%g. + rewrite /= -(card_isog isoU0) -pi_of_exponent expU0 pi_of_exponent. + rewrite mem_primes pr_p cardG_gt0 /= -ox order_dvdG // (subsetP _ _ P01x) //. + rewrite (subset_trans (Ohm_sub 1 _)) // subsetI sP0M. + by rewrite (subset_trans sP0H) ?gFsub. +have /(Cauchy pr_p)[z U0z oz]: p %| #|U0 / K'|%g. + by rewrite mem_primes in piU0p; case/and3P: piU0p. +have frobKz: [Frobenius (K / K') <*> <[z]> = (K / K') ><| <[z]>]%g. + rewrite (Frobenius_subr _ _ frobU0K') ?cycle_subG //. + by rewrite cycle_eq1 -order_gt1 oz ltnW. +have: p %| #|K / K'|%g.-1 by rewrite -oz (Frobenius_dvd_ker1 frobKz) //. +have [_ ntKK' _ _ _] := Frobenius_context frobKz. +rewrite -subn1 gtnNdvd ?subn_gt0 ?cardG_gt1 // subn1 prednK ?cardG_gt0 //. +by rewrite -ltnS (leq_trans ubK). +Qed. + +End Twelve_13_to_16. + +Lemma FTtype1_nonFrobenius_contradiction : False. +Proof. +have [_ [tau1 cohS]] := FT_Frobenius_coherence maxL frobL. +have [chi] := FTtype1_ref_irr maxL; rewrite -(index_sdprod defL). +exact: FTtype1_nonFrobenius_witness_contradiction cohS. +Qed. + +End Twelve_8_to_16. + +(* This is Peterfalvi, Theorem (12.7). *) +Theorem FTtype1_Frobenius M : + M \in 'M -> FTtype M == 1%N -> [Frobenius M with kernel M`_\F]. +Proof. +set K := M`_\F => maxM Mtype1; have [U [MtypeF _]] := FTtypeP 1 maxM Mtype1. +have hallU: \pi(K)^'.-Hall(M) U. + by rewrite -(compl_pHall U (Fcore_Hall M)) sdprod_compl; have [[]] := MtypeF. +apply: FrobeniusWker (U) _ _; have{MtypeF} [_ -> _] := typeF_context MtypeF. +apply/forall_inP=> P0 /SylowP[p _ sylP0]. +rewrite (odd_pgroup_rank1_cyclic (pHall_pgroup sylP0)) ?mFT_odd // leqNgt. +apply/negP=> prankP0. +have piUp: p \in \pi(U) by rewrite -p_rank_gt0 -(p_rank_Sylow sylP0) ltnW. +have{piUp} K'p: p \in \pi(K)^' := pnatPpi (pHall_pgroup hallU) piUp. +have{U hallU sylP0} sylP0: p.-Sylow(M) P0 := subHall_Sylow hallU K'p sylP0. +have{P0 sylP0 prankP0} prankM: (1 < 'r_p(M))%N by rewrite -(p_rank_Sylow sylP0). +case/negP: K'p => /=. +elim: {p}_.+1 {-2}p M @K (ltnSn p) maxM Mtype1 prankM => // p IHp q M K. +rewrite ltnS leq_eqVlt => /predU1P[->{q} | /(IHp q M)//] maxM Mtype1 prankM. +apply/idPn; rewrite -p'groupEpi /= -/K => p'K. +have [P0 sylP0] := Sylow_exists p M. +have [] := non_Frobenius_FTtype1_witness maxM Mtype1 prankM p'K sylP0. +move=> abP0 prankP0 [L [maxL sP0_Ls [x P01s_x []]]]. +exact: (FTtype1_nonFrobenius_contradiction IHp) P01s_x. +Qed. + +(* This is Peterfalvi, Theorem (12.17). *) +Theorem not_all_FTtype1 : ~~ all_FTtype1 gT. +Proof. +apply/negP=> allT1; pose k := #|'M^G|. +have [partGpi coA1 _ [injA1 /(_ allT1)partG _]] := FT_Dade_support_partition gT. +move/forall_inP in allT1. +have [/subsetP maxMG _ injMG exMG] := mmax_transversalP gT. +have{partGpi exMG} kge2: (k >= 2)%N. + have [L MG_L]: exists L, L \in 'M^G. + by have [L maxL] := any_mmax gT; have [x] := exMG L maxL; exists (L :^ x)%G. + have maxL := maxMG L MG_L; have Ltype1 := allT1 L maxL. + have /Frobenius_kerP[_ ltHL nsHL _] := FTtype1_Frobenius maxL Ltype1. + rewrite ltnNge; apply: contra (proper_subn ltHL) => leK1. + rewrite (sub_normal_Hall (Fcore_Hall L)) // (pgroupS (subsetT L)) //=. + apply: sub_pgroup (pgroup_pi _) => p; rewrite partGpi => /exists_inP[M maxM]. + have /eqP defMG: [set L] == 'M^G by rewrite eqEcard sub1set MG_L cards1. + have [x] := exMG M maxM; rewrite -defMG => /set1P/(canRL (actK 'JG _))-> /=. + by rewrite FTcoreJ cardJg FTcore_type1. +pose L (i : 'I_k) : {group gT} := enum_val i; pose H i := (L i)`_\F%G. +have MG_L i: L i \in 'M^G by apply: enum_valP. +have maxL i: L i \in 'M by apply: maxMG. +have defH i: (L i)`_\s = H i by rewrite FTcore_type1 ?allT1. +pose frobL_P i E := [Frobenius L i = H i ><| gval E]. +have /fin_all_exists[E frobHE] i: exists E, frobL_P i E. + by apply/existsP/FTtype1_Frobenius; rewrite ?allT1. +have frobL i: [/\ L i \subset G, solvable (L i) & frobL_P i (E i)]. + by rewrite subsetT mmax_sol. +have{coA1} coH_ i j: i != j -> coprime #|H i| #|H j|. + move=> j'i; rewrite -!defH coA1 //; apply: contra j'i => /imsetP[x Gx defLj]. + apply/eqP/enum_val_inj; rewrite -/(L i) -/(L j); apply: injMG => //. + by rewrite defLj; apply/esym/orbit_act. +have tiH i: normedTI (H i)^# G (L i). + have ntA: (H i)^# != set0 by rewrite setD_eq0 subG1 mmax_Fcore_neq1. + apply/normedTI_memJ_P=> //=; rewrite subsetT; split=> // x z H1x Gz. + apply/idP/idP=> [H1xz | Lz]; last first. + by rewrite memJ_norm // (subsetP _ z Lz) // normD1 gFnorm. + have /subsetP sH1A0: (H i)^# \subset 'A0(L i) by apply: Fcore_sub_FTsupp0. + have [/(sub_in2 sH1A0)wccH1 [_ maxN] Nfacts] := FTsupport_facts (maxL i). + suffices{z Gz H1xz wccH1} sCxLi: 'C[x] \subset L i. + have /imsetP[y Ly defxz] := wccH1 _ _ H1x H1xz (mem_imset _ Gz). + rewrite -[z](mulgKV y) groupMr // (subsetP sCxLi) // !inE conjg_set1. + by rewrite conjgM defxz conjgK. + apply/idPn=> not_sCxM; pose D := [set y in 'A0(L i) | ~~ ('C[y] \subset L i)]. + have Dx: x \in D by rewrite inE sH1A0. + have{maxN} /mem_uniq_mmax[maxN sCxN] := maxN x Dx. + have Ntype1 := allT1 _ maxN. + have [_ _ /setDP[/bigcupP[y NFy /setD1P[ntx cxy]] /negP[]]] := Nfacts x Dx. + rewrite FTsupp1_type1 Ntype1 // in NFy cxy *. + have /Frobenius_kerP[_ _ _ regFN] := FTtype1_Frobenius maxN Ntype1. + by rewrite 2!inE ntx (subsetP (regFN y NFy)). +have /negP[] := no_coherent_Frobenius_partition (mFT_odd _) kge2 frobL tiH coH_. +rewrite eqEsubset sub1set !inE andbT; apply/andP; split; last first. + apply/bigcupP=> [[i _ /imset2P[x y /setD1P[ntx _] _ Dxy]]]. + by rewrite -(conjg_eq1 x y) -Dxy eqxx in ntx. +rewrite subDset setUC -subDset -(cover_partition partG). +apply/bigcupsP=> _ /imsetP[Li MG_Li ->]; pose i := enum_rank_in MG_Li Li. +rewrite (bigcup_max i) //=; have ->: Li = L i by rewrite /L enum_rankK_in. +rewrite -FT_Dade1_supportE //; apply/bigcupsP=> x A1x; apply: imset2S => //. +move: (FT_Dade1_hyp _) (tiH i); rewrite -defH => _ /Dade_normedTI_P[_ -> //]. +by rewrite mul1g sub1set -/(H i) -defH. +Qed. + +End PFTwelve. diff --git a/mathcomp/odd_order/PFsection13.v b/mathcomp/odd_order/PFsection13.v new file mode 100644 index 0000000..58e0142 --- /dev/null +++ b/mathcomp/odd_order/PFsection13.v @@ -0,0 +1,2185 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime binomial ssralg poly finset. +Require Import fingroup morphism perm automorphism quotient action finalg zmodp. +Require Import gfunctor gproduct center cyclic commutator gseries nilpotent. +Require Import pgroup sylow hall abelian maximal frobenius. +Require Import matrix mxalgebra mxrepresentation mxabelem vector. +Require Import BGsection1 BGsection3 BGsection7. +Require Import BGsection14 BGsection15 BGsection16. +Require Import ssrnum rat algC cyclotomic algnum. +Require Import classfun character integral_char inertia vcharacter. +Require Import PFsection1 PFsection2 PFsection3 PFsection4. +Require Import PFsection5 PFsection6 PFsection7 PFsection8 PFsection9. +Require Import PFsection10 PFsection11 PFsection12. + +(******************************************************************************) +(* This file covers Peterfalvi, Section 13: The Subgroups S and T. *) +(* The following definitions will be used in PFsection14: *) +(* FTtypeP_bridge StypeP j == a virtual character of S that mixes characters *) +(* (locally) beta_ j, betaS that do and do not contain P = S`_\F in their *) +(* kernels, for StypeP : of_typeP S U defW. *) +(* := 'Ind[S, P <*> W1] 1 - mu2_ 0 j. *) +(* FTtypeP_bridge_gap StypeP == the difference between the image of beta_ j *) +(* (locally) Gamma, GammaS under the Dade isometry for S, and its natural *) +(* value, 1 - eta_ 0 j (this does not actually *) +(* depend on j != 0). *) +(* The following definitions are only used locally across sections: *) +(* #1 == the irreducible index 1 (i.e., inord 1). *) +(* irr_Ind_Fittinq S chi <=> chi is an irreducible character of S induced *) +(* (locally) irrIndH from an irreducible character of 'F(S) (which *) +(* will be linear here, as 'F(S) is abelian). *) +(* typeP_TIred_coherent StypeP tau1 <=> tau1 maps the reducible induced *) +(* characters mu_ j of a type P group S, which are *) +(* the image under the cyclic TI isometry to S of *) +(* row sums of irreducibles of W = W1 x W2, to *) +(* the image of that sum under the cyclic TI *) +(* isometry to G (except maybe for a sign change *) +(* if p = #|W2| = 3). *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory FinRing.Theory Num.Theory. + +Section Thirteen. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). +Implicit Types (p q : nat) (x y z : gT). +Implicit Types H K L N P Q R S T U W : {group gT}. + +Definition irr_Ind_Fitting S := [predI irr S & seqIndT 'F(S) S]. + +Local Notation irrIndH := (irr_Ind_Fitting _). +Local Notation "#1" := (inord 1) (at level 0). + +Section Thirteen_2_3_5_to_9. + +(* These assumptions correspond to the part of Peterfalvi, Hypothesis (13.1) *) +(* that is used to prove (13.2-3) and (13.5-9). Because of the shortcomings *) +(* of Coq's Section and Module features we will need to repeat most of these *) +(* assumptions twice down this file to exploit the symmetry between S and T. *) +(* We anticipate the use of the letter 'H' to designate the Fitting group *) +(* of S, which Peterfalvi does only locally in (13.5-9), in order not to *) +(* conflict with (13.17-19), where H denotes the F-core of a Frobenius group. *) +(* This is not a problem for us, since these lemmas will only appear in the *) +(* last section of this file, and we will have no use for H at that point *) +(* since we will have shown in (13.12) that H coincides with P = S`_\F. *) + +Variables S U W W1 W2 : {group gT}. +Hypotheses (maxS : S \in 'M) (defW : W1 \x W2 = W). +Hypotheses (StypeP : of_typeP S U defW). + +Local Notation "` 'W1'" := (gval W1) (at level 0, only parsing) : group_scope. +Local Notation "` 'W2'" := (gval W2) (at level 0, only parsing) : group_scope. +Local Notation "` 'W'" := (gval W) (at level 0, only parsing) : group_scope. +Local Notation V := (cyclicTIset defW). + +Local Notation "` 'S'" := (gval S) (at level 0, only parsing) : group_scope. +Local Notation P := `S`_\F%G. +Local Notation "` 'P'" := `S`_\F (at level 0) : group_scope. +Local Notation PU := S^`(1)%G. +Local Notation "` 'PU'" := `S^`(1) (at level 0) : group_scope. +Local Notation "` 'U'" := (gval U) (at level 0, only parsing) : group_scope. +Local Notation C := 'C_U(`P)%G. +Local Notation "` 'C'" := 'C_`U(`P) (at level 0) : group_scope. +Local Notation H := 'F(S)%G. +Local Notation "` 'H'" := 'F(`S) (at level 0) : group_scope. + +Let defS : PU ><| W1 = S. Proof. by have [[]] := StypeP. Qed. +Let defPU : P ><| U = PU. Proof. by have [_ []] := StypeP. Qed. +Let defH : P \x C = H. Proof. by have [] := typeP_context StypeP. Qed. + +Let notStype1 : FTtype S != 1%N. Proof. exact: FTtypeP_neq1 StypeP. Qed. +Let notStype5 : FTtype S != 5%N. Proof. exact: FTtype5_exclusion maxS. Qed. + +Let pddS := FT_prDade_hypF maxS StypeP. +Let ptiWS : primeTI_hypothesis S PU defW := FT_primeTI_hyp StypeP. +Let ctiWG : cyclicTI_hypothesis G defW := pddS. + +Let ntW1 : W1 :!=: 1. Proof. by have [[]] := StypeP. Qed. +Let ntW2 : W2 :!=: 1. Proof. by have [_ _ _ []] := StypeP. Qed. +Let cycW1 : cyclic W1. Proof. by have [[]] := StypeP. Qed. +Let cycW2 : cyclic W2. Proof. by have [_ _ _ []] := StypeP. Qed. + +Let p := #|W2|. +Let q := #|W1|. +Let c := #|C|. +Let u := #|U : C|. + +Let oU : #|U| = (u * c)%N. Proof. by rewrite mulnC Lagrange ?subsetIl. Qed. + +Let pr_p : prime p. Proof. by have [] := FTtypeP_primes maxS StypeP. Qed. +Let pr_q : prime q. Proof. by have [] := FTtypeP_primes maxS StypeP. Qed. + +Let qgt2 : q > 2. Proof. by rewrite odd_gt2 ?mFT_odd ?cardG_gt1. Qed. +Let pgt2 : p > 2. Proof. by rewrite odd_gt2 ?mFT_odd ?cardG_gt1. Qed. + +Let coPUq : coprime #|PU| q. +Proof. by rewrite (coprime_sdprod_Hall_r defS); have [[]] := StypeP. Qed. + +Let nirrW1 : #|Iirr W1| = q. Proof. by rewrite card_Iirr_cyclic. Qed. +Let nirrW2 : #|Iirr W2| = p. Proof. by rewrite card_Iirr_cyclic. Qed. +Let NirrW1 : Nirr W1 = q. Proof. by rewrite -nirrW1 card_ord. Qed. +Let NirrW2 : Nirr W2 = p. Proof. by rewrite -nirrW2 card_ord. Qed. + +Local Open Scope ring_scope. + +Let sigma := (cyclicTIiso ctiWG). +Let w_ i j := (cyclicTIirr defW i j). +Local Notation eta_ i j := (sigma (w_ i j)). + +Local Notation Imu2 := (primeTI_Iirr ptiWS). +Let mu2_ i j := primeTIirr ptiWS i j. +Let mu_ := primeTIred ptiWS. +Local Notation chi_ j := (primeTIres ptiWS j). + +Local Notation Idelta := (primeTI_Isign ptiWS). +Local Notation delta_ j := (primeTIsign ptiWS j). + +Local Notation tau := (FT_Dade0 maxS). +Local Notation "chi ^\tau" := (tau chi). + +Let calS0 := seqIndD PU S S`_\s 1. +Let rmR := FTtypeP_coh_base maxS StypeP. +Let scohS0 : subcoherent calS0 tau rmR. +Proof. exact: FTtypeP_subcoherent StypeP. Qed. + +Let calS := seqIndD PU S P 1. +Let sSS0 : cfConjC_subset calS calS0. +Proof. exact/seqInd_conjC_subset1/Fcore_sub_FTcore. Qed. + +Local Notation type34ker1 := (FTtype34_Fcore_kernel_trivial maxS StypeP). +Local Notation type34facts := (FTtype34_structure maxS StypeP). +Local Notation type2facts := (FTtypeII_prime_facts maxS StypeP). +Local Notation compl2facts := (compl_of_typeII maxS StypeP). +Local Notation compl3facts := (compl_of_typeIII maxS StypeP). + +Local Notation H0 := (Ptype_Fcore_kernel StypeP). + +Lemma Ptype_factor_prime : pdiv #|P / H0|%g = p. +Proof. exact: def_Ptype_factor_prime. Qed. +Local Notation pHbar_p := Ptype_factor_prime. + +Lemma Ptype_Fcore_kernel_trivial : H0 :=: 1%g. +Proof. +have [/type2facts[_ oP _]| /type34ker1[]//] := boolP (FTtype S == 2). +have [/and3P[]] := Ptype_Fcore_kernel_exists maxS StypeP notStype5. +case/maxgroupp/andP=> /proper_sub sH0P nH0S /subset_trans/(_ nH0S)nH0P _ _. +apply: card1_trivg; rewrite -(divg_indexS sH0P) -card_quotient //. +have [_ _ ->] := Ptype_Fcore_factor_facts maxS StypeP notStype5. +by rewrite pHbar_p -{}oP divnn ?cardG_gt0. +Qed. +Local Notation H0_1 := Ptype_Fcore_kernel_trivial. + +Lemma Ptype_Fcompl_kernel_cent : Ptype_Fcompl_kernel StypeP :=: C. +Proof. +rewrite [Ptype_Fcompl_kernel StypeP]unlock /= (group_inj H0_1). +by rewrite astabQ -morphpreIim -injm_cent ?injmK ?ker_coset ?norms1. +Qed. +Local Notation CHbar_C := Ptype_Fcompl_kernel_cent. + +(* This is Peterfalvi (13.2). *) +Lemma FTtypeP_facts : + [/\ (*a*) [/\ pred2 2 3 (FTtype S), q < p -> FTtype S == 2, + [Frobenius U <*> W1 = U ><| W1] & abelian U], + (*b*) p.-abelem P /\ #|P| = p ^ q, + (*c*) u <= (p ^ q).-1 %/ p.-1, + (*d*) coherent calS S^# tau + & (*e*) normedTI 'A0(S) G S /\ {in 'CF(S, 'A0(S)), tau =1 'Ind}]%N. +Proof. +have type23: pred2 2 3 (FTtype S). + by rewrite /= -implyNb; apply/implyP=> /type34facts[_ _ [->]]. +have [_ ntU _ tiFS] := compl_of_typeII_IV maxS StypeP notStype5. +have [_ /mulG_sub[_ sUPU] nPU tiPU] := sdprodP defPU. +have cUU: abelian U by case/orP: type23 => [/compl2facts | /compl3facts] [_ ->]. +split. +- split=> //; last exact: Ptype_compl_Frobenius StypeP _. + by rewrite ltnNge; apply: contraR => /type34facts[_ /ltnW]. +- by have [/type2facts[] | /type34ker1[]] := boolP (FTtype S == 2). +- have ->: u = #|U / C|%g by rewrite card_quotient ?normsI ?normG ?norms_cent. + have p1gt0: (0 < p.-1)%N by rewrite -(subnKC pgt2). + have [/typeP_Galois_P[]| /typeP_Galois_Pn[]]// := boolP (typeP_Galois StypeP). + move=> _ _ [_ _]; rewrite pHbar_p CHbar_C // -/u -/q; apply: dvdn_leq. + by rewrite divn_gt0 // -!subn1 leq_sub2r // (leq_exp2l 1) ltnW // ltnW. + rewrite -/q CHbar_C pHbar_p => H1 [_ _ _ _ [agt1 a_dv_p1 _ [V /card_isog->]]]. + apply: leq_trans (_ : p.-1 ^ q.-1 <= _)%N; last first. + have ltp1q: (p.-1 ^ q < p ^ q)%N by rewrite ltn_exp2r ?prednK // 2?ltnW. + by rewrite leq_divRL // -expnSr (ltn_predK qgt2) -ltnS (ltn_predK ltp1q). + rewrite dvdn_leq ?expn_gt0 ?p1gt0 // (dvdn_trans (cardSg (subsetT V))) //. + by rewrite cardsT card_matrix mul1n dvdn_exp2r //= card_ord Zp_cast. +- have:= Ptype_core_coherence maxS StypeP notStype5; rewrite H0_1 CHbar_C. + by rewrite (derG1P (abelianS _ cUU)) ?subsetIl ?(group_inj (joing1G _)). +have ntA0: 'A0(S) != set0 := FTsupp0_neq0 maxS. +suffices tiA0: normedTI 'A0(S) G S by split=> //; apply: Dade_Ind. +apply/normedTI_memJ_P=> //; rewrite subsetT; split=> // x g A0x Gg. +apply/idP/idP=> [A0xg | /(subsetP (FTsupp0_norm S))/memJ_norm->//]. +apply/idPn=> S'g; have Dx: x \in [set y in 'A0(S) | ~~ ('C[y] \subset S)]. + rewrite inE A0x; have [_ _ [_ _ _ wccA0 _] _] := pddS. + have /imsetP[y Sy Dxy]: x ^ g \in x ^: S by rewrite wccA0 // mem_orbit. + apply/subsetPn; exists (g * y^-1)%g; last by rewrite groupMr ?groupV. + by rewrite !inE conjg_set1 conjgM Dxy conjgK. +have [_ [_ /(_ x Dx) defL] /(_ x Dx)[_ _]] := FTsupport_facts maxS. +have{defL} [maxL _] := mem_uniq_mmax defL; set L := 'N[x] in maxL *. +rewrite -mem_iota !inE => ALx [/orP[Ltype1 _ | Ltype2]]; last first. + by case/(_ _)/existsP=> // ? /Frobenius_of_typeF/(typePF_exclusion StypeP). +have /Frobenius_kerP[_ _ _ regLF_L] := FTtype1_Frobenius maxL Ltype1. +case/andP: ALx => A1'x /bigcupP[z A1z /setD1P[ntx cLz_z]]; case/negP: A1'x. +rewrite ntx /'A1(L) -(Fcore_eq_FTcore _ _) ?(eqP Ltype1) //= in cLz_z A1z *. +exact: subsetP (regLF_L z A1z) _ cLz_z. +Qed. + +Lemma FTseqInd_TIred j : j != 0 -> mu_ j \in calS. +Proof. +move=> nz_j; rewrite -[mu_ j]cfInd_prTIres mem_seqInd ?gFnormal ?normal1 //=. +by rewrite !inE sub1G (cfker_prTIres pddS). +Qed. + +Lemma FTtypeP_Fitting_abelian : abelian H. +Proof. +rewrite -(dprodW defH) abelianM subsetIr. +have [[_ _ _ cUU] [/abelem_abelian-> _] _ _ _] := FTtypeP_facts. +by rewrite (abelianS _ cUU) ?subsetIl. +Qed. +Hint Resolve FTtypeP_Fitting_abelian. + +Local Notation calH := (seqIndT H S). + +Lemma FTtypeP_Ind_Fitting_1 lambda : lambda \in calH -> lambda 1%g = (u * q)%:R. +Proof. +case/seqIndP=> i _ ->; rewrite cfInd1 -?divgS ?gFsub //; set theta := 'chi_i. +have Ltheta: theta \is a linear_char by apply/char_abelianP. +rewrite -(sdprod_card defS) -(sdprod_card defPU) -/q -(dprod_card defH) oU. +by rewrite -mulnA divnMl // mulnAC mulnK ?cardG_gt0 // lin_char1 ?mulr1. +Qed. +Local Notation calHuq := FTtypeP_Ind_Fitting_1. + +(* This is Peterfalvi (13.3)(a). *) +Lemma FTprTIred_Ind_Fitting j : j != 0 -> mu_ j \in calH. +Proof. +move=> nz_j; have [//|_ _ _] := typeP_reducible_core_Ind maxS StypeP. +rewrite (group_inj H0_1) CHbar_C -/q /= (dprodWY defH) -/calS => /(_ (mu_ j)). +case=> [|_ _ [_ /lin_char_irr/irrP[r ->] ->]]; last exact: mem_seqIndT. +by rewrite mem_filter /= prTIred_not_irr FTseqInd_TIred. +Qed. +Local Notation Hmu := FTprTIred_Ind_Fitting. + +Lemma FTprTIred1 j : j != 0 -> mu_ j 1%g = (u * q)%:R. +Proof. by move/Hmu/calHuq. Qed. +Local Notation mu1uq := FTprTIred1. + +(* This is the first assertion of Peterfalvi (13.3)(c). *) +Lemma FTprTIsign j : delta_ j = 1. +Proof. +have [[_ _ frobUW1 cUU] _ _ cohS _] := FTtypeP_facts. +have [-> | nz_j] := eqVneq j 0; first exact: prTIsign0. +suffices: (1 == delta_ j %[mod q])%C. + rewrite signrE /eqCmod addrC opprB subrK dvdC_nat. + by case: (Idelta j); rewrite ?subr0 // gtnNdvd. +apply: eqCmod_trans (prTIirr1_mod ptiWS 0 j); rewrite -/(mu2_ 0 j) -/q. +have ->: mu2_ 0 j 1%g = u%:R. + by apply: (mulfI (neq0CG W1)); rewrite -prTIred_1 -/mu_ mu1uq // mulnC natrM. +rewrite eqCmod_sym /eqCmod -(@natrB _ u 1) ?indexg_gt0 // subn1 dvdC_nat. +have nC_UW1: U <*> W1 \subset 'N(C). + have /sdprodP[_ _ nPUW1 _] := Ptype_Fcore_sdprod StypeP. + by rewrite normsI ?norms_cent // join_subG normG; have [_ []] := StypeP. +have coUq: coprime #|U| q by have /sdprod_context[_ /coprimeSg->] := defPU. +have /Frobenius_dvd_ker1: [Frobenius U <*> W1 / C = (U / C) ><| (W1 / C)]. + have [defUW1 _ _ _ _] := Frobenius_context frobUW1. + rewrite Frobenius_coprime_quotient // /normal ?subIset ?joing_subl //. + split=> [|x /(Frobenius_reg_ker frobUW1)->]; last exact: sub1G. + rewrite properEneq subsetIl -CHbar_C andbT. + by have [] := Ptype_Fcore_factor_facts maxS StypeP notStype5. +have [nCU nCW1] := joing_subP nC_UW1; rewrite !card_quotient // -/u. +by rewrite -indexgI setIC setIAC (coprime_TIg coUq) setI1g indexg1. +Qed. +Local Notation delta1 := FTprTIsign. + +(* This is Peterfalvi (13.3)(b). *) +Lemma FTtypeP_no_Ind_Fitting_facts : + ~~ has irrIndH calS -> + [/\ typeP_Galois StypeP, `C = 1%g & u = (p ^ q).-1 %/ p.-1]. +Proof. +move=> noIndH; have [[_ _ _ cUU] _ _ _ _] := FTtypeP_facts. +have [[t []] | [->]] := typeP_reducible_core_cases maxS StypeP notStype5. + rewrite CHbar_C H0_1 (derG1P (abelianS _ cUU)) ?subsetIl //=. + rewrite (group_inj (joing1G 1)) -/calS /= (dprodWY defH) => calSt _. + case=> _ /lin_char_irr/irrP[r ->] Dt; case/hasP: noIndH. + by exists 'chi_t; rewrite //= mem_irr; apply/seqIndP; exists r; rewrite ?inE. +rewrite /= pHbar_p H0_1 oU /c => frobPU _ <- _ /=. +suffices /eqP->: C :==: 1%g by rewrite cards1 muln1. +suffices: 'C_(U / 1)(P / 1) == 1%g. + by rewrite -injm_subcent ?morphim_injm_eq1 ?norms1 ?ker_coset. +have [_ ntP _ _ _] := Frobenius_context frobPU. +by rewrite (cent_semiregular (Frobenius_reg_compl frobPU)). +Qed. + +(* Helper function for (13.3)(c). *) +Let signW2 (b : bool) := iter b (@conjC_Iirr _ W2). + +Let signW2K b : involutive (signW2 b). +Proof. by case: b => //; apply: conjC_IirrK. Qed. + +Let signW2_eq0 b : {mono signW2 b: j / j == 0}. +Proof. by case: b => //; apply: conjC_Iirr_eq0. Qed. + +(* This is a reformulation of the definition condition part of (13.3)(c) that *) +(* better fits its actual use in (13.7), (13.8) and (13.9) (note however that *) +(* the p = 3 part will in fact not be used). *) +Definition typeP_TIred_coherent tau1 := + exists2 b : bool, b -> p = 3 + & forall j, j != 0 -> tau1 (mu_ j) = (-1) ^+ b *: \sum_i eta_ i (signW2 b j). + +(* This is the main part of Peterfalvi (13.3)(c), using the definition above. *) +(* Note that the text glosses over the quantifier inversion in the second use *) +(* of (5.8) in the p = 3 case. We must rule out tau1 (mu_ k) = - tau1 (mu_ j) *) +(* by using the isometry property of tau1 (alternatively, we could use (4.8) *) +(* to compute tau1 (mu_ k) = tau (mu_ k - mu_ j) + tau1 (mu_ j) directly). *) +Lemma FTtypeP_coherence : + exists2 tau1 : {additive 'CF(S) -> 'CF(G)}, + coherent_with calS S^# tau tau1 & typeP_TIred_coherent tau1. +Proof. +have [redS|] := altP (@allP _ [predC irr S] calS). + have [k nz_k] := has_nonprincipal_irr ntW2. + have [_ [tau1 Dtau1]] := uniform_prTIred_coherent pddS nz_k. + set calT := uniform_prTIred_seq pddS k => cohT. + exists tau1; last by exists false => // j _; rewrite /= Dtau1 delta1. + apply: subset_coherent_with cohT => xi Sxi. + have [_ _ /(_ xi)] := typeP_reducible_core_Ind maxS StypeP notStype5. + rewrite (group_inj H0_1) mem_filter redS // => /(_ Sxi)/imageP[j nz_j ->] _. + by rewrite image_f // inE -/mu_ [~~ _]nz_j /= !mu1uq. +rewrite all_predC negbK => /hasP[xi Sxi irr_xi]. +have [_ _ _ [tau1 cohS] _] := FTtypeP_facts; exists tau1 => //. +have [|] := boolP [forall (j | j != 0), tau1 (mu_ j) == \sum_i eta_ i j]. + by move/eqfun_inP=> Dtau1; exists false => // j /Dtau1; rewrite scale1r. +rewrite negb_forall_in => /exists_inP[j nz_j /eqP tau1muj_neq_etaj]. +have:= FTtypeP_coherent_TIred sSS0 cohS irr_xi Sxi (FTseqInd_TIred _). +rewrite -/mu_ -/sigma -/ptiWS => tau1mu; have [dk tau1muj Ddk] := tau1mu j nz_j. +case: Ddk tau1muj => [][-> ->]{dk}; rewrite ?signrN delta1 ?scaleNr scale1r //. +set k := conjC_Iirr j => Dmu tau1muj. +have{Dmu} defIW2 l: l != 0 -> pred2 j k l. + by move=> nz_l; rewrite Dmu ?FTseqInd_TIred ?mu1uq. +have [nz_k j'k]: k != 0 /\ k != j. + rewrite conjC_Iirr_eq0 nz_j -(inj_eq irr_inj) conjC_IirrE. + by rewrite odd_eq_conj_irr1 ?mFT_odd ?irr_eq1. +have /eqP p3: p == 3. + rewrite -nirrW2 (cardD1 0) (cardD1 j) (cardD1 k) !inE nz_j nz_k j'k !eqSS. + by apply/pred0Pn=> [[l /and4P[k'l j'l /defIW2/norP[]]]]. +exists true => // _ /defIW2/pred2P[]->; first by rewrite scaler_sign. +have [[[Itau1 _] _] [d t1muk Dd]] := (cohS, tau1mu k nz_k); move: Dd t1muk. +case=> [][-> ->] => [|_]; rewrite ?signrN delta1 // scale1r. +case/(congr1 (cfdotr (tau1 (mu_ j)) \o -%R))/eqP/idPn => /=. +rewrite -tau1muj cfdotNl eq_sym !Itau1 ?mem_zchar ?FTseqInd_TIred //. +by rewrite !cfdot_prTIred (negPf j'k) eqxx mul1n oppr0 neq0CG. +Qed. + +(* We skip over (13.4), whose proof uses (13.2) and (13.3) for both groups of *) +(* a type P pair. *) + +Let calS1 := seqIndD H S P 1. + +(* Some facts about calS1 used implicitly throughout (13.5-8). *) +Let S1mu j : j != 0 -> mu_ j \in calS1. +Proof. +move=> nz_j; have /seqIndP[s _ Ds] := Hmu nz_j. +rewrite Ds mem_seqInd ?gFnormal ?normal1 // !inE sub1G andbT. +rewrite -(sub_cfker_Ind_irr s (gFsub _ _) (gFnorm _ _)) -Ds /=. +rewrite -[mu_ j](cfInd_prTIres (FT_prDade_hypF maxS StypeP)). +by rewrite sub_cfker_Ind_irr ?cfker_prTIres ?gFsub ?gFnorm. +Qed. + +Let calSirr := [seq phi <- calS | phi \in irr S]. +Let S1cases zeta : + zeta \in calS1 -> {j | j != 0 & zeta = mu_ j} + (zeta \in 'Z[calSirr]). +Proof. +move=> S1zeta; have /sig2_eqW[t /setDP[_ kerP't] Dzeta] := seqIndP S1zeta. +rewrite inE in kerP't; have /mulG_sub[sPH _] := dprodW defH. +have [/andP[sPPU nPPU] sUPU _ _ _] := sdprod_context defPU. +have sHPU: H \subset PU by rewrite /= -(dprodWC defH) mulG_subG subIset ?sUPU. +have [/eqfunP mu'zeta|] := boolP [forall j, '['Ind 'chi_t, chi_ j] == 0]. + right; rewrite Dzeta -(cfIndInd _ _ sHPU) ?gFsub //. + rewrite ['Ind 'chi_t]cfun_sum_constt linear_sum /= rpred_sum // => s tPUs. + rewrite linearZ rpredZ_Cnat ?Cnat_cfdot_char ?cfInd_char ?irr_char //=. + have [[j Ds] | [irr_zeta _]] := prTIres_irr_cases ptiWS s. + by case/eqP: tPUs; rewrite Ds mu'zeta. + rewrite mem_zchar // mem_filter irr_zeta mem_seqInd ?gFnormal ?normal1 //=. + by rewrite !inE sub1G andbT -(sub_cfker_constt_Ind_irr tPUs). +rewrite negb_forall => /existsP/sigW[j]. +rewrite -irr_consttE constt_Ind_Res => jHt. +have nz_j: j != 0; last do [left; exists j => //]. + apply: contraTneq jHt => ->; rewrite prTIres0 rmorph1 -irr0 constt_irr. + by apply: contraNneq kerP't => ->; rewrite irr0 cfker_cfun1. +have /pairwise_orthogonalP[_ ooS1]: pairwise_orthogonal calS1. + by rewrite seqInd_orthogonal ?gFnormal. +rewrite -(cfRes_prTIirr _ 0) cfResRes ?gFsub //= in jHt. +have muj_mu0j: Imu2 (0, j) \in irr_constt (mu_ j). + by rewrite irr_consttE cfdotC cfdot_prTIirr_red eqxx conjC1 oner_eq0. +apply: contraNeq (constt_Res_trans (prTIred_char _ _) muj_mu0j jHt). +by rewrite cfdot_Res_l /= -Dzeta eq_sym => /ooS1-> //; rewrite S1mu. +Qed. + +Let sS1S : {subset calS1 <= 'Z[calS]}. +Proof. +move=> zeta /S1cases[[j nz_j ->]|]; first by rewrite mem_zchar ?FTseqInd_TIred. +by apply: zchar_subset; apply: mem_subseq (filter_subseq _ _). +Qed. + +(* This is Peterfalvi (13.5). *) +(* We have adapted the statement to its actual use by replacing the Dade *) +(* (partial) isometry by a (total) coherent isometry, and strengthening the *) +(* orthogonality condition. This simplifies the assumptions as zeta0 is no *) +(* longer needed. Note that this lemma is only used to establish various *) +(* inequalities (13.6-8) that contribute to (13.10), so it does not need to *) +(* be exported from this section. *) +Let calS1_split1 (tau1 : {additive _}) zeta1 chi : + coherent_with calS S^# tau tau1 -> zeta1 \in calS1 -> chi \in 'Z[irr G] -> + {in calS1, forall zeta, zeta != zeta1 -> '[tau1 zeta, chi] = 0} -> + let a := '[tau1 zeta1, chi] in + exists2 alpha, + alpha \in 'Z[irr H] /\ {subset irr_constt alpha <= Iirr_ker H P} & + [/\ (*a*) {in H^#, forall x, chi x = a / '[zeta1] * zeta1 x + alpha x}, + (*b*) + \sum_(x in H^#) `|chi x| ^+ 2 = + a ^+ 2 / '[zeta1] * (#|S|%:R - zeta1 1%g ^+ 2 / '[zeta1]) + - 2%:R * a * (zeta1 1%g * alpha 1%g / '[zeta1]) + + (\sum_(x in H^#) `|alpha x| ^+ 2) + & (*c*) + \sum_(x in H^#) `|alpha x| ^+ 2 >= #|P|.-1%:R * alpha 1%g ^+ 2]. +Proof. +case=> _ Dtau1 S1zeta1 Zchi o_tau1S_chi a. +have sW2P: W2 \subset P by have [_ _ _ []] := StypeP. +have /mulG_sub[sPH _] := dprodW defH. +have ntH: H :!=: 1%g by apply: subG1_contra ntW2; apply: subset_trans sPH. +have sH1S: H^# \subset G^# by rewrite setSD ?subsetT. +have[nsHS nsPS ns1S]: [/\ H <| S, P <| S & 1 <| S] by rewrite !gFnormal normal1. +have [[sHS nHS] [sPS nPS]] := (andP nsHS, andP nsPS). +have tiH: normedTI H^# G S by have [] := compl_of_typeII_IV maxS StypeP. +have ddH := normedTI_Dade tiH sH1S; have [_ ddH_1] := Dade_normedTI_P ddH tiH. +pose tauH := Dade ddH. +have DtauH: {in 'CF(S, H^#), tauH =1 'Ind} := Dade_Ind ddH tiH. +have sS1H: {subset calS1 <= calH} by apply: seqInd_subT. +pose zeta0 := zeta1^*%CF. +have S1zeta0: zeta0 \in calS1 by rewrite cfAut_seqInd. +have zeta1'0: zeta0 != zeta1. + by rewrite (hasPn (seqInd_notReal _ _ _ _) _ S1zeta1) ?gFnormal ?mFT_odd. +have Hzeta0 := sS1H _ S1zeta0. +have dH_1 zeta: zeta \in calH -> (zeta - zeta0) 1%g == 0. + by move=> Tzeta; rewrite 2!cfunE !calHuq // subrr eqxx. +have H1dzeta zeta: zeta \in calH -> zeta - zeta0 \in 'CF(S, H^#). + have HonH: {subset calH <= 'CF(S, H)} by exact: seqInd_on. + by move=> Hzeta; rewrite cfun_onD1 rpredB ?HonH ?dH_1. +pose calH1 := rem zeta1 (rem zeta0 (filter [mem calS1] calH)). +pose calH2 := filter [predC calS1] calH. +have DcalH: perm_eq calH (zeta0 :: zeta1 :: calH1 ++ calH2). + rewrite -(perm_filterC [mem calS1]) -!cat_cons perm_cat2r. + rewrite (perm_eqlP (@perm_to_rem _ zeta0 _ _)) ?mem_filter /= ?S1zeta0 //. + rewrite perm_cons perm_to_rem // mem_rem_uniq ?filter_uniq ?seqInd_uniq //. + by rewrite !inE mem_filter /= eq_sym zeta1'0 S1zeta1 sS1H. +have{DcalH} [a_ _ Dchi _] := invDade_seqInd_sum ddH chi DcalH. +have Da_ zeta: zeta \in calH -> a_ zeta = '['Ind (zeta - zeta0), chi]. + move=> Tzeta; rewrite /a_ !calHuq // divff ?scale1r; last first. + by rewrite pnatr_eq0 -lt0n muln_gt0 indexg_gt0 cardG_gt0. + by rewrite [Dade _ _]DtauH ?H1dzeta. +have Za_ zeta: zeta \in calH -> a_ zeta \in Cint. + move=> Hzeta; rewrite Da_ // Cint_cfdot_vchar ?cfInd_vchar //. + by rewrite rpredB ?char_vchar ?(seqInd_char Hzeta) ?(seqInd_char Hzeta0). +have{Da_} Da_ zeta: zeta \in calS1 -> a_ zeta = '[tau1 zeta, chi]. + move=> S1zeta; have Hzeta := sS1H _ S1zeta. + rewrite Da_ //; have [_ _ _ _ [_ <-]] := FTtypeP_facts. + rewrite -Dtau1; last by rewrite zcharD1E rpredB ?sS1S ?dH_1. + by rewrite raddfB cfdotBl (o_tau1S_chi zeta0) ?subr0. + by rewrite (cfun_onS (Fitting_sub_FTsupp0 maxS)) ?H1dzeta. +pose alpha := 'Res[H] (\sum_(zeta <- calH2) (a_ zeta)^* / '[zeta] *: zeta). +have{Dchi} Dchi: {in H^#, forall x, chi x = a / '[zeta1] * zeta1 x + alpha x}. + move=> x H1x; have [_ Hx] := setD1P H1x. + transitivity (invDade ddH chi x). + by rewrite cfunElock ddH_1 // big_set1 H1x mul1g cards1 invr1 mul1r. + rewrite cfResE ?gFsub ?Dchi // big_cons conj_Cint ?Za_ ?Da_ ?sS1H //= -/a. + congr (_ + _); rewrite big_cat /= sum_cfunE big1_seq ?add0r //= => [|zeta]. + by apply: eq_bigr => zeta; rewrite cfunE. + rewrite ?(mem_rem_uniq, inE) ?rem_uniq ?filter_uniq ?seqInd_uniq //=. + rewrite mem_filter => /and4P[/= zeta1'z _ S1zeta _]. + by rewrite Da_ ?o_tau1S_chi // conjC0 !mul0r. +have kerHalpha: {subset irr_constt alpha <= Iirr_ker H P}. + move=> s; apply: contraR => kerP's; rewrite [alpha]rmorph_sum cfdot_suml. + rewrite big1_seq // => psi; rewrite mem_filter /= andbC => /andP[]. + case/seqIndP=> r _ ->; rewrite mem_seqInd // !inE sub1G andbT negbK => kerPr. + rewrite cfdot_Res_l cfdotZl mulrC cfdot_sum_irr big1 ?mul0r // => t _. + apply: contraNeq kerP's; rewrite mulf_eq0 fmorph_eq0 inE => /norP[rSt sSt]. + by rewrite (sub_cfker_constt_Ind_irr sSt) -?(sub_cfker_constt_Ind_irr rSt). +have Zalpha: alpha \in 'Z[irr H]. + rewrite [alpha]rmorph_sum big_seq rpred_sum // => zeta; rewrite mem_filter /=. + case/andP=> S1'zeta Tzeta; rewrite linearZ /= -scalerA. + rewrite rpredZ_Cint ?conj_Cint ?Za_ //; have [s _ ->] := seqIndP Tzeta. + rewrite cfResInd_sum_cfclass ?reindex_cfclass -?cfnorm_Ind_irr //=. + rewrite scalerK ?cfnorm_eq0 ?cfInd_eq0 ?irr_neq0 ?irr_char ?gFsub //. + by apply: rpred_sum => i _; apply: irr_vchar. +have{Da_ Za_} Za: a \in Cint by rewrite -[a]Da_ ?Za_ ?sS1H. +exists alpha => //; split=> //. + set a1 := a / _ in Dchi; pose phi := a1 *: 'Res zeta1 + alpha. + transitivity (#|H|%:R * '[phi] - `|phi 1%g| ^+ 2). + rewrite (cfnormE (cfun_onG phi)) mulVKf ?neq0CG // addrC. + rewrite (big_setD1 _ (group1 H)) addKr; apply: eq_bigr => x H1x. + by have [_ Hx] := setD1P H1x; rewrite !cfunE cfResE // Dchi. + have Qa1: a1 \in Creal. + apply: rpred_div; first by rewrite rpred_Cint. + by rewrite rpred_Cnat // Cnat_cfdot_char ?(seqInd_char S1zeta1). + rewrite cfnormDd; last first. + rewrite [alpha]cfun_sum_constt cfdotZl cfdot_sumr big1 ?mulr0 // => s. + move/kerHalpha; rewrite inE cfdotZr mulrC cfdot_Res_l => kerPs. + have [r kerP'r ->] := seqIndP S1zeta1; rewrite cfdot_sum_irr big1 ?mul0r //. + move=> t _; apply: contraTeq kerP'r; rewrite !inE sub1G andbT negbK. + rewrite mulf_eq0 fmorph_eq0 => /norP[]; rewrite -!irr_consttE. + by move=> /sub_cfker_constt_Ind_irr-> // /sub_cfker_constt_Ind_irr <-. + rewrite cfnormZ 2!cfunE cfRes1 2?real_normK //; last first. + rewrite rpredD 1?rpredM // Creal_Cint ?Cint_vchar1 // ?char_vchar //. + by rewrite (seqInd_char S1zeta1). + rewrite mulrDr mulrCA sqrrD opprD addrACA; congr (_ + _); last first. + rewrite (cfnormE (cfun_onG _)) mulVKf ?neq0CG //. + by rewrite (big_setD1 1%g) // Cint_normK ?Cint_vchar1 // addrC addKr. + rewrite opprD addrA; congr (_ - _); last first. + rewrite -[_ * a * _]mulrA -mulr_natl; congr (_ * _). + by rewrite -[a1 * _]mulrA -(mulrA a); congr (_ * _); rewrite -mulrA mulrC. + rewrite mulrBr; congr (_ - _); last first. + by rewrite mulrACA -expr2 -!exprMn mulrAC. + rewrite -mulrA exprMn -mulrA; congr (_ * _); rewrite expr2 -mulrA. + congr (_ * _); apply: canLR (mulKf (cfnorm_seqInd_neq0 nsHS S1zeta1)) _. + rewrite (cfnormE (cfun_onG _)) mulVKf ?neq0CG // mulrC. + rewrite (cfnormE (seqInd_on nsHS S1zeta1)) mulVKf ?neq0CG //. + by apply: eq_bigr => x Hx; rewrite cfResE. +rewrite -subn1 natrB // -Cint_normK ?Cint_vchar1 // mulrBl mul1r ler_subl_addl. +apply: ler_trans (_ : \sum_(x in H) `|alpha x| ^+ 2 <= _); last first. + by rewrite (big_setD1 1%g). +rewrite (big_setID P) /= (setIidPr sPH) ler_paddr ?sumr_ge0 // => [x _|]. + by rewrite mulr_ge0 ?normr_ge0. +rewrite mulr_natl -sumr_const ler_sum // => y Py. +suffices ->: alpha y = alpha 1%g by apply: lerr. +rewrite [alpha]cfun_sum_constt !sum_cfunE; apply: eq_bigr => i. +by rewrite !cfunE => /kerHalpha; rewrite inE => /subsetP/(_ y Py)/cfker1->. +Qed. + +Local Notation eta10 := (eta_ #1 0). +Local Notation eta01 := (eta_ 0 #1). + +Let o_tau1_eta (tau1 : {additive _}) i j: + coherent_with calS S^# tau tau1 -> + {in 'Z[calSirr], forall zeta, '[tau1 zeta, eta_ i j] = 0}. +Proof. +move=> cohS _ /zchar_expansion[|z Zz ->]. + by rewrite filter_uniq ?seqInd_uniq. +rewrite raddf_sum cfdot_suml big1_seq //= => phi; rewrite mem_filter. +case/andP=> irr_phi /(coherent_ortho_cycTIiso StypeP sSS0 cohS) o_phi_eta. +by rewrite raddfZ_Cint {Zz}//= cfdotZl o_phi_eta ?mulr0. +Qed. + +Let P1_int2_lb b : b \in Cint -> 2%:R * u%:R * b <= #|P|.-1%:R * b ^+ 2. +Proof. +move=> Zb; rewrite -natrM; apply: ler_trans (_ : (2 * u)%:R * b ^+ 2 <= _). + by rewrite ler_wpmul2l ?ler0n ?Cint_ler_sqr. +rewrite ler_wpmul2r -?realEsqr ?Creal_Cint // leC_nat mulnC -leq_divRL //. +have [_ [_ ->] /leq_trans-> //] := FTtypeP_facts. +by rewrite leq_div2l // -subn1 ltn_subRL. +Qed. + +(* This is Peterfalvi (13.6). *) +Lemma FTtypeP_sum_Ind_Fitting_lb (tau1 : {additive _}) lambda : + coherent_with calS S^# tau tau1 -> lambda \in irrIndH -> lambda \in calS -> + \sum_(x in H^#) `|tau1 lambda x| ^+ 2 >= #|S|%:R - lambda 1%g ^+ 2. +Proof. +move=> cohS /andP[Ilam Hlam] Slam; have [[Itau1 Ztau1] _] := cohS. +have Zlam1: tau1 lambda \in 'Z[irr G] by rewrite Ztau1 ?mem_zchar. +have S1lam: lambda \in calS1. + have [[s kerP's Ds] [r _ Dr]] := (seqIndP Slam, seqIndP Hlam). + rewrite Dr mem_seqInd ?gFnormal ?normal1 // !inE !sub1G !andbT in kerP's *. + rewrite -(sub_cfker_Ind_irr r (gFsub _ _) (gFnorm _ _)) /= -Dr. + by rewrite Ds sub_cfker_Ind_irr ?gFsub ?gFnorm. +have [|alpha [Zalpha kerPalpha]] := calS1_split1 cohS S1lam Zlam1. + move=> zeta S1zeta lam'zeta; rewrite Itau1 ?sS1S //. + suffices: pairwise_orthogonal calS1 by case/pairwise_orthogonalP=> _ ->. + by rewrite seqInd_orthogonal ?gFnormal. +rewrite Itau1 ?mem_zchar // irrWnorm // expr1n !divr1 mul1r => [[Dlam ->]]. +rewrite mulr1 -ler_subl_addl addrC opprB subrK calHuq //; apply: ler_trans. +have [[x W2x ntx] [y W1y nty]] := (trivgPn _ ntW2, trivgPn _ ntW1). +have [_ _ _ [_ _ sW2P _ _] _] := StypeP; have Px := subsetP sW2P x W2x. +have [eps pr_eps] := C_prim_root_exists (prime_gt0 pr_q). +have{y W1y W2x nty} lamAmod: (tau1 lambda x == lambda x %[mod 1 - eps])%A. + have [_ /mulG_sub[_ sW1S] _ tiPUW1] := sdprodP defS. + have [_ /mulG_sub[sW1W sW2W] cW12 _] := dprodP defW. + have /mulG_sub[sPPU _] := sdprodW defPU. + have [o_y cxy]: #[y] = q /\ x \in 'C[y]. + split; last by apply/cent1P; red; rewrite (centsP cW12). + by apply: nt_prime_order => //; apply/eqP; rewrite -order_dvdn order_dvdG. + have lam1yx: (tau1 lambda (y * x)%g == tau1 lambda x %[mod 1 - eps])%A. + by rewrite (vchar_ker_mod_prim pr_eps) ?in_setT. + have [Sx Sy] := (subsetP (gFsub _ _) x Px, subsetP sW1S y W1y). + have PUx := subsetP sPPU x Px. + have lam_yx: (lambda (y * x)%g == lambda x %[mod 1 - eps])%A. + by rewrite (vchar_ker_mod_prim pr_eps) ?char_vchar ?(seqInd_char Slam). + apply: eqAmod_trans lam_yx; rewrite eqAmod_sym; apply: eqAmod_trans lam1yx. + have PUlam: lambda \in 'CF(S, PU) by rewrite (seqInd_on _ Slam) ?gFnormal. + have PU'yx: (y * x)%g \notin PU. + by rewrite groupMr //= -[y \in PU]andbT -W1y -in_setI tiPUW1 !inE. + rewrite (cfun_on0 PUlam PU'yx) (ortho_cycTIiso_vanish pddS) //. + apply/orthoPl=> _ /mapP[_ /(cycTIirrP defW)[i [j ->]] ->]. + by rewrite (coherent_ortho_cycTIiso StypeP sSS0). + rewrite !inE (groupMl x (subsetP sW1W y _)) // (subsetP sW2W) // andbT. + rewrite groupMl // -[x \in _]andTb -PUx -in_setI tiPUW1 !inE negb_or ntx /=. + by rewrite (contra _ PU'yx) // => /(subsetP sW2P)/(subsetP sPPU). +have{x ntx Px lamAmod} alphaAmod: (alpha 1%g == 0 %[mod 1 - eps])%A. + have Hx: x \in H by have/mulG_sub[/subsetP->] := dprodW defH. + have:= lamAmod; rewrite -[lambda x]addr0 Dlam ?inE ?ntx // mul1r eqAmodDl. + rewrite cfker1 // [alpha]cfun_sum_constt (subsetP (cfker_sum _ _ _)) //. + rewrite !inE Hx (subsetP _ x Px) //; apply/bigcapsP=> i /kerPalpha. + by rewrite !inE => /subset_trans-> //; apply: cfker_scale. +have /dvdCP[b Zb ->]: (q %| alpha 1%g)%C. + by rewrite (int_eqAmod_prime_prim pr_eps) // Cint_vchar1. +rewrite natrM mulrACA exprMn !mulrA 2?ler_pmul2r ?gt0CG //. +by rewrite -[_ * b * b]mulrA P1_int2_lb. +Qed. + +(* This is Peterfalvi (13.7). *) +Lemma FTtypeP_sum_cycTIiso10_lb : \sum_(x in H^#) `|eta10 x| ^+ 2 >= #|H^#|%:R. +Proof. +pose mu1 := mu_ #1; have S1mu1: mu1 \in calS1 by rewrite S1mu ?Iirr1_neq0. +have Zeta10: eta10 \in 'Z[irr G] by rewrite cycTIiso_vchar. +have [tau1 cohS [b _ Dtau1]] := FTtypeP_coherence. +have{b Dtau1} oS1eta10: {in calS1, forall zeta, '[tau1 zeta, eta10] = 0}. + move=> zeta /S1cases[[j nz_j ->] | /o_tau1_eta-> //]. + rewrite Dtau1 // cfdotZl cfdot_suml big1 ?mulr0 // => i _. + by rewrite cfdot_cycTIiso signW2_eq0 (negPf nz_j) andbF. +have [_ /oS1eta10//|alpha [Zalpha kerPalpha]] := calS1_split1 cohS S1mu1 Zeta10. +rewrite {}oS1eta10 // expr0n mulr0 !mul0r subrr add0r => [[Deta10 -> ub_alpha]]. +have{Deta10} Deta10: {in H^#, eta10 =1 alpha}. + by move=> x /Deta10; rewrite !mul0r add0r. +set a1_2 := alpha 1%g ^+ 2 in ub_alpha. +have Dsum_alpha: \sum_(x in H^#) `|alpha x| ^+ 2 = #|H|%:R * '[alpha] - a1_2. + rewrite (cfnormE (cfun_onG _)) mulVKf ?neq0CG // (big_setD1 _ (group1 H)) /=. + by rewrite addrC Cint_normK ?addKr ?Cint_vchar1. +have [/mulG_sub[sPH _] [_ _ _ [_ _ sW2P _ _] _]] := (dprodW defH, StypeP). +have nz_alpha: alpha != 0. + have [[x W2x ntx] [y W1y nty]] := (trivgPn _ ntW2, trivgPn _ ntW1). + have [eps pr_eps] := C_prim_root_exists (prime_gt0 pr_q). + have [_ mulW12 cW12 tiW12] := dprodP defW. + have [sW1W sW2W] := mulG_sub mulW12. + have [o_y cxy]: #[y] = q /\ x \in 'C[y]. + split; last by apply/cent1P; red; rewrite (centsP cW12). + by apply: nt_prime_order => //; apply/eqP; rewrite -order_dvdn order_dvdG. + have eta10x: (eta10 x == eta10 (y * x)%g %[mod 1 - eps])%A. + by rewrite eqAmod_sym (vchar_ker_mod_prim pr_eps) ?in_setT. + have eta10xy: (eta10 (y * x)%g == 1 %[mod 1 - eps])%A. + rewrite cycTIiso_restrict; last first. + rewrite !inE -mulW12 mem_mulg // andbT groupMl ?groupMr // -[_ || _]andTb. + by rewrite andb_orr -{1}W2x -W1y andbC -!in_setI tiW12 !inE (negPf ntx). + have {2}<-: w_ #1 0 x = 1. + rewrite -[x]mul1g /w_ dprod_IirrE cfDprodE // irr0 cfun1E W2x mulr1. + by rewrite lin_char1 ?irr_cyclic_lin. + rewrite (vchar_ker_mod_prim pr_eps) ?(subsetP sW1W y) ?(subsetP sW2W) //. + by rewrite irr_vchar. + have: (alpha x == 1 %[mod 1 - eps])%A. + rewrite -Deta10; last by rewrite !inE ntx (subsetP sPH) ?(subsetP sW2P). + exact: eqAmod_trans eta10x eta10xy. + apply: contraTneq => ->; rewrite cfunE eqAmod_sym. + apply/negP=> /(int_eqAmod_prime_prim pr_eps pr_q (rpred1 _))/idPn[]. + by rewrite (dvdC_nat q 1) -(subnKC qgt2). +apply: wlog_neg => suma_lt_H. +suffices{ub_alpha} lb_a1_2: a1_2 >= #|H^#|%:R. + have Pgt2: (2 < #|P|)%N by apply: leq_trans (subset_leq_card sW2P). + apply: ler_trans (ler_trans lb_a1_2 _) ub_alpha. + rewrite ler_pmull ?(ltr_le_trans _ lb_a1_2) ?ler1n ?ltr0n //. + by rewrite -(subnKC Pgt2). + have:= leq_trans (ltnW Pgt2) (subset_leq_card sPH). + by rewrite (cardsD1 1%g) group1. +have /CnatP[n Dn]: '[alpha] \in Cnat by rewrite Cnat_cfnorm_vchar. +have /CnatP[m Dm]: a1_2 \in Cnat by rewrite Cnat_exp_even ?Cint_vchar1. +rewrite Dm leC_nat leqNgt; apply: contra suma_lt_H => a1_2_lt_H. +rewrite {1}Dsum_alpha Dn Dm -natrM ler_subr_addl (cardsD1 1%g H) group1 /=. +case Dn1: n => [|[|n1]]; first by rewrite -cfnorm_eq0 Dn Dn1 eqxx in nz_alpha. + have /dirrP[b [i Dalpha]]: alpha \in dirr H by rewrite dirrE Zalpha Dn Dn1 /=. + rewrite -Dm /a1_2 Dalpha cfunE exprMn sqrr_sign mul1r muln1 mulrS ler_add2r. + by rewrite lin_char1 ?expr1n //; apply/char_abelianP. +rewrite -natrD leC_nat -add2n mulnDr (addnC 1%N) mulnDl -addnA. +by apply: leq_trans (leq_addr _ _); rewrite muln2 -addnn leq_add2r ltnW. +Qed. + +(* This is Peterfalvi (13.8). *) +(* We have filled a logical gap in the textbook, which quotes (13.3.c) to get *) +(* a j such that eta_01 is a component of mu_j^tau1, then asserts that the *) +(* (orthogonality) assumptions of (13.5) have been checked, apparently *) +(* implying that because for zeta in calS1 \ mu_j, zeta^tau1 is orthogonal to *) +(* mu_j^tau1, as per the proof of (13.6), zeta^tau1 must be orthogonal to *) +(* eta_01. This is wrong, because zeta^tau1, mu_j^tau1 and eta_01 are not *) +(* characters, but virtual characters. We need to use a more careful line of *) +(* reasoning, using the more precise characterization of calS1 in the lemma *) +(* S1cases above (which does use the orthogonal-constituent argument, but *) +(* for chi_j and Res_H zeta), and the decomposition given in (13.3.c) for all *) +(* the mu_k. *) +Lemma FTtypeP_sum_cycTIiso01_lb : + \sum_(x in H^#) `|eta01 x| ^+ 2 >= #|PU|%:R - (u ^ 2)%:R. +Proof. +have [tau1 cohS [b _ Dtau1]] := FTtypeP_coherence. +have Zeta01: eta01 \in 'Z[irr G] by rewrite cycTIiso_vchar. +pose j1 := signW2 b #1; pose d : algC := (-1) ^+ b; pose mu1 := mu_ j1. +have nzj1: j1 != 0 by [rewrite signW2_eq0 ?Iirr1_neq0]; have S1mu1 := S1mu nzj1. +have o_mu_eta01 j: j != 0 -> '[tau1 (mu_ j), eta01] = d *+ (j == j1). + move/Dtau1->; rewrite -/d cfdotZl cfdot_suml big_ord_recl /=. + rewrite cfdot_cycTIiso andTb (inv_eq (signW2K b)). + by rewrite big1 ?addr0 ?mulr_natr // => i _; rewrite cfdot_cycTIiso. +have [zeta | alpha [Zalpha kerPalpha [_]]] := calS1_split1 cohS S1mu1 Zeta01. + case/S1cases=> [[j nz_j ->] | /o_tau1_eta-> //]. + by rewrite o_mu_eta01 // (inj_eq (prTIred_inj _)) => /negPf->. +rewrite o_mu_eta01 // eqxx mulrb => -> lb_alpha. +rewrite -ler_subl_addl cfnorm_prTIred -/q mulrAC sqrr_sign mul1r. +rewrite mu1uq // natrM exprMn (mulrAC _ q%:R) (mulrA _ q%:R) !mulfK ?neq0CG //. +rewrite natrX -(sdprod_card defS) natrM -mulrBl mulfK ?neq0CG //. +rewrite addrC opprB subrK mulrACA; apply: ler_trans lb_alpha. +apply: ler_trans (P1_int2_lb _) _; first by rewrite rpredMsign Cint_vchar1. +by rewrite exprMn sqrr_sign mul1r lerr. +Qed. + +(* These are the assumptions for (13.9); K will be set to 'F(T) in the only *) +(* application of this lemma, in the proof of (13.10). *) + +Variable K : {group gT}. +Let G0 := ~: (class_support H G :|: class_support K G). + +Variables (tau1 : {additive 'CF(S) -> 'CF(G)}) (lambda : 'CF(S)). + +Hypothesis cohS : coherent_with calS S^# tau tau1. +Hypothesis cohSmu : typeP_TIred_coherent tau1. + +Hypotheses (Slam : lambda \in calS) (irrHlam : irrIndH lambda). + +(* This is Peterfalvi (13.9)(a). *) +(* As this part is only used to establish (13.9.b) it can be Section-local. *) +Let cover_G0 : {in G0, forall x, tau1 lambda x != 0 \/ eta_ #1 0 x != 0}. +Proof. +have [[b _ Dtau1_mu] [/= Ilam Hlam]] := (cohSmu, andP irrHlam). +pose sum_eta1 := (-1) ^+ b *: \sum_i eta_ i #1. +have{Dtau1_mu} [j nz_j tau1muj]: exists2 j, j != 0 & tau1 (mu_ j) = sum_eta1. + pose j := signW2 b #1; have nz: j != 0 by rewrite signW2_eq0 Iirr1_neq0. + by exists j; rewrite // Dtau1_mu // signW2K. +move=> x; rewrite !inE => /norP[H'x _]. +have{tau1muj} ->: tau1 lambda x = sum_eta1 x. + rewrite -[lambda](subrK (mu_ j)) raddfD cfunE tau1muj. + rewrite [tau1 _ x](cfun_on0 _ H'x) ?add0r {x H'x}//=. + have Hmuj: mu_ j \in calH := Hmu nz_j. + have dmu1: (lambda - mu_ j) 1%g == 0 by rewrite !cfunE !calHuq ?subrr. + have H1dmu: lambda - mu_ j \in 'CF(S, H^#). + by rewrite cfun_onD1 rpredB ?((seqInd_on (gFnormal _ _)) setT). + have [_ ->] := cohS; last first. + by rewrite zcharD1E ?rpredB ?mem_zchar ?FTseqInd_TIred /=. + have A0dmu := cfun_onS (Fitting_sub_FTsupp0 maxS) H1dmu. + have [_ _ _ _ [_ -> //]] := FTtypeP_facts. + by rewrite cfInd_on ?subsetT // (cfun_onS _ H1dmu) ?imset2Sl ?subsetDl. +apply/nandP/andP=> [[/eqP sum_eta1x_0 /eqP eta1x_0]]. +have cycW: cyclic W by have [] := ctiWG. +have W'x: x \notin class_support (cyclicTIset defW) G. + apply: contra_eqN eta1x_0 => /imset2P[{x H'x sum_eta1x_0}x g Wx Gg ->]. + rewrite cfunJ {g Gg}// cycTIiso_restrict //. + by rewrite lin_char_neq0 ?irr_cyclic_lin //; case/setDP: Wx. +have nz_i1 : #1 != 0 :> Iirr W1 by rewrite Iirr1_neq0. +have eta_x_0 i: i != 0 -> eta_ i 0 x = 0. + rewrite /w_ dprod_IirrEl => /(cfExp_prime_transitive pr_q nz_i1)[k co_k_p ->]. + have: coprime k #[w_ #1 0]%CF by rewrite /w_ dprod_IirrEl cforder_sdprod. + rewrite rmorphX /= -dprod_IirrEl => /(cycTIiso_aut_exists ctiWG)[[uu ->] _]. + by rewrite cfunE /= -/sigma eta1x_0 rmorph0. +have eta_i1 i: i != 0 -> eta_ i #1 x = eta_ 0 #1 x - 1. + move=> nz_i; apply/eqP; pose alpha := cfCyclicTIset defW i #1. + have Walpha: alpha \in 'CF(W, cyclicTIset defW). + by rewrite (cfCycTI_on ctiWG) ?Iirr1_neq0. + have: sigma alpha x == 0. + by rewrite cycTIiso_Ind // (cfun_on0 _ W'x) ?cfInd_on ?subsetT. + rewrite [alpha]cfCycTI_E linearD !linearB /= !cfunE cycTIiso1 cfun1E inE. + by rewrite {1}eta_x_0 //= subr0 addrC addr_eq0 opprB. +have eta11x: eta_ #1 #1 x = - (q%:R)^-1. + rewrite -mulN1r; apply: canRL (mulfK (neq0CG W1)) _. + transitivity ((-1) ^+ b * sum_eta1 x - 1); last first. + by rewrite sum_eta1x_0 mulr0 add0r. + rewrite cfunE signrMK mulr_natr -/q -nirrW1 -sumr_const sum_cfunE. + by rewrite !(bigD1 0 isT) /= addrAC eta_i1 // (eq_bigr _ eta_i1). +have: - eta_ #1 #1 x \in Cint. + rewrite rpredN Cint_rat_Aint ?Aint_vchar ?cycTIiso_vchar //. + by rewrite eta11x rpredN rpredV rpred_nat. +case/norm_Cint_ge1/implyP/idPn; rewrite eta11x opprK invr_eq0 neq0CG /=. +by rewrite normfV normr_nat invf_ge1 ?gt0CG // lern1 -ltnNge ltnW. +Qed. + +(* This is Peterfalvi (13.9)(b). *) +Lemma FTtypeP_sum_nonFitting_lb : + \sum_(x in G0) (`|tau1 lambda x| ^+ 2 + `|eta_ #1 0 x| ^+ 2) >= #|G0|%:R. +Proof. +pose A (xi : 'CF(G)) := [set x in G0 | xi x != 0]. +suffices A_ub xi: xi \in dirr G -> #|A xi|%:R <= \sum_(x in G0) `|xi x| ^+ 2. + apply: ler_trans (_ : (#|A (tau1 lambda)| + #|A (eta_ #1 0)|)%:R <= _). + rewrite leC_nat -cardsUI /A !setIdE -setIUr (leq_trans _ (leq_addr _ _)) //. + rewrite subset_leq_card // subsetIidl. + by apply/subsetP=> x /cover_G0/orP; rewrite !inE. + rewrite natrD big_split ler_add ?A_ub ?cycTIiso_dirr //. + have [[[Itau1 Ztau1] _] [Ilam _]] := (cohS, andP irrHlam). + by rewrite dirrE Ztau1 ?Itau1 ?mem_zchar //= irrWnorm. +case/dirrP=> d [t Dxi]; rewrite (big_setID [set x | xi x != 0]) /= addrC. +rewrite -setIdE -/(A _) big1 ?add0r => [|x]; last first. + by rewrite !inE negbK => /andP[/eqP-> _]; rewrite normr0 expr0n. +rewrite -sum1_card !(partition_big_imset (@cycle _)) /= natr_sum. +apply: ler_sum => _ /imsetP[x Ax ->]. +pose B := [pred y | generator <[x]> y]; pose phi := 'Res[<[x]>] 'chi_t. +have defA: [pred y in A xi | <[y]> == <[x]>] =i B. + move=> y; rewrite inE /= eq_sym andb_idl // !inE => eq_xy. + have LGxy L (LG := class_support L G): x \notin LG -> y \notin LG. + rewrite /LG class_supportEr; apply: contra => /bigcupP[g Gg Lg_y]. + apply/bigcupP; exists g => //; move: Lg_y. + by rewrite -!cycle_subG (eqP eq_xy). + move: Ax; rewrite !inE !negb_or -andbA => /and3P[/LGxy-> /LGxy->]. + apply: contraNneq => chi_y_0. + have [k co_k_y ->]: exists2 k, coprime k #[y] & x = (y ^+ k)%g. + have Yx: generator <[y]> x by rewrite [generator _ _]eq_sym. + have /cycleP[k Dx] := cycle_generator Yx; exists k => //. + by rewrite coprime_sym -generator_coprime -Dx. + have Zxi: xi \in 'Z[irr G] by rewrite Dxi rpredZsign irr_vchar. + have [uu <- // _] := make_pi_cfAut [group of G] co_k_y. + by rewrite cfunE chi_y_0 rmorph0. +have resB: {in B, forall y, `|xi y| ^+ 2 = `|phi y| ^+ 2}. + move=> y /cycle_generator Xy. + by rewrite Dxi cfunE normrMsign cfResE ?subsetT. +rewrite !(eq_bigl _ _ defA) sum1_card (eq_bigr _ resB). +apply: sum_norm2_char_generators => [|y By]. + by rewrite cfRes_char ?irr_char. +rewrite -normr_eq0 -sqrf_eq0 -resB // sqrf_eq0 normr_eq0. +by move: By; rewrite -defA !inE -andbA => /and3P[]. +Qed. + +End Thirteen_2_3_5_to_9. + +Section Thirteen_4_10_to_16. + +(* These assumptions correspond to Peterfalvi, Hypothesis (13.1), most of *) +(* which gets used to prove (13.4) and (13.9-13). *) + +Variables S U W W1 W2 : {group gT}. +Hypotheses (maxS : S \in 'M) (defW : W1 \x W2 = W). +Hypotheses (StypeP : of_typeP S U defW). + +Local Notation "` 'W1'" := (gval W1) (at level 0, only parsing) : group_scope. +Local Notation "` 'W2'" := (gval W2) (at level 0, only parsing) : group_scope. +Local Notation "` 'W'" := (gval W) (at level 0, only parsing) : group_scope. +Local Notation V := (cyclicTIset defW). + +Local Notation "` 'S'" := (gval S) (at level 0, only parsing) : group_scope. +Local Notation P := `S`_\F%G. +Local Notation "` 'P'" := `S`_\F (at level 0) : group_scope. +Local Notation PU := S^`(1)%G. +Local Notation "` 'PU'" := `S^`(1) (at level 0) : group_scope. +Local Notation "` 'U'" := (gval U) (at level 0, only parsing) : group_scope. +Local Notation C := 'C_U(`P)%G. +Local Notation "` 'C'" := 'C_`U(`P) (at level 0) : group_scope. +Local Notation H := 'F(S)%G. +Local Notation "` 'H'" := 'F(`S) (at level 0) : group_scope. + +Let defS : PU ><| W1 = S. Proof. by have [[]] := StypeP. Qed. +Let defPU : P ><| U = PU. Proof. by have [_ []] := StypeP. Qed. +Let defH : P \x C = H. Proof. by have [] := typeP_context StypeP. Qed. + +Let notStype1 : FTtype S != 1%N. Proof. exact: FTtypeP_neq1 StypeP. Qed. +Let notStype5 : FTtype S != 5%N. Proof. exact: FTtype5_exclusion maxS. Qed. + +Let pddS := FT_prDade_hypF maxS StypeP. +Let ptiWS : primeTI_hypothesis S PU defW := FT_primeTI_hyp StypeP. +Let ctiWG : cyclicTI_hypothesis G defW := pddS. +Local Notation Sfacts := (FTtypeP_facts maxS StypeP). + +Let ntW1 : W1 :!=: 1. Proof. by have [[]] := StypeP. Qed. +Let ntW2 : W2 :!=: 1. Proof. by have [_ _ _ []] := StypeP. Qed. +Let cycW1 : cyclic W1. Proof. by have [[]] := StypeP. Qed. +Let cycW2 : cyclic W2. Proof. by have [_ _ _ []] := StypeP. Qed. + +Let p := #|W2|. +Let q := #|W1|. + +Let pr_p : prime p. Proof. by have [] := FTtypeP_primes maxS StypeP. Qed. +Let pr_q : prime q. Proof. by have [] := FTtypeP_primes maxS StypeP. Qed. + +Let qgt2 : q > 2. Proof. by rewrite odd_gt2 ?mFT_odd ?cardG_gt1. Qed. +Let pgt2 : p > 2. Proof. by rewrite odd_gt2 ?mFT_odd ?cardG_gt1. Qed. + +Let coPUq : coprime #|PU| q. +Proof. by rewrite (coprime_sdprod_Hall_r defS); have [[]] := StypeP. Qed. + +Let sW2P: W2 \subset P. Proof. by have [_ _ _ []] := StypeP. Qed. + +Let p'q : q != p. +Proof. +by rewrite -dvdn_prime2 -?prime_coprime -?(cyclic_dprod defW) //; case: ctiWG. +Qed. + +Let nirrW1 : #|Iirr W1| = q. Proof. by rewrite card_Iirr_cyclic. Qed. +Let nirrW2 : #|Iirr W2| = p. Proof. by rewrite card_Iirr_cyclic. Qed. +Let NirrW1 : Nirr W1 = q. Proof. by rewrite -nirrW1 card_ord. Qed. +Let NirrW2 : Nirr W2 = p. Proof. by rewrite -nirrW2 card_ord. Qed. + +Local Open Scope ring_scope. + +Let sigma := (cyclicTIiso ctiWG). +Let w_ i j := (cyclicTIirr defW i j). +Local Notation eta_ i j := (sigma (w_ i j)). + +Let mu_ := primeTIred ptiWS. +Local Notation tau := (FT_Dade0 maxS). + +Let calS0 := seqIndD PU S S`_\s 1. +Let rmR := FTtypeP_coh_base maxS StypeP. +Let scohS0 : subcoherent calS0 tau rmR. +Proof. exact: FTtypeP_subcoherent StypeP. Qed. + +Let calS := seqIndD PU S P 1. +Let sSS0 : cfConjC_subset calS calS0. +Proof. exact/seqInd_conjC_subset1/Fcore_sub_FTcore. Qed. + +Local Notation calH := (seqIndT H S). +Local Notation calHuq := (FTtypeP_Ind_Fitting_1 maxS StypeP). + +Section Thirteen_10_to_13_15. + +(* This section factors the assumption that S contains an irreducible induced *) +(* from a linear character of H. It does not actually export (13.4) and *) +(* and (4.11) but instead uses them to carry out the bulk of the proofs of *) +(* (4.12), (4.13) and (4.15). The combinatorial bound m is also local to this *) +(* Section, but (4.10) has to be exported from an inner Section that factors *) +(* facts about T, the typeP pair associate of S. *) +(* Note that u and c are bound locally to this section; we will set u = #|U| *) +(* after this section. *) + +Variable lambda : 'CF(S). +Hypotheses (Slam : lambda \in calS) (irrHlam : irrIndH lambda). +Let Hlam : lambda \in calH. Proof. by have [] := andP irrHlam. Qed. +Let Ilam : lambda \in irr S. Proof. by have [] := andP irrHlam. Qed. + +Let c := #|C|. +Let u := #|U : C|. +Let oU : #|U| = (u * c)%N. Proof. by rewrite mulnC Lagrange ?subsetIl. Qed. + +Let m : algC := 1 - q.-1%:R^-1 - q.-1%:R / (q ^ p)%:R + (q.-1 * q ^ p)%:R^-1. + +Section Thirteen_4_10. + +(* This Section factors assumptions and facts about T, including Lemma (13.4) *) +(* is local to this Section. *) + +Variables T V : {group gT}. +Hypotheses (maxT : T \in 'M) (xdefW : W2 \x W1 = W). +Hypothesis TtypeP : of_typeP T V xdefW. + +Local Notation Q := (gval T)`_\F. +Local Notation D := 'C_(gval V)(Q). +Local Notation K := 'F(gval T). +Let v := #|V : D|. + +Local Notation calT := (seqIndD T^`(1) T (gval T)`_\F 1). + +(* This part of the proof of (13.4) is reused in (13.10). *) +Let tiHK: class_support H^# G :&: class_support K^# G = set0. +Proof. +apply/eqP/set0Pn => [[_ /setIP[/imset2P[x g1 H1x _ ->] /imset2P[xg g2]]]]. +pose g := (g2 * g1^-1)%g => /setD1P[_ Kxg] _ Dxg. +have{Kxg Dxg} Kgx: x \in K :^ g by rewrite conjsgM mem_conjgV Dxg memJ_conjg. +have{Kgx} cxQg: Q :^ g \subset 'C[x]. + rewrite sub_cent1 (subsetP _ _ Kgx) // centJ conjSg centsC. + have [/dprodW/mulG_sub[/subset_trans-> //=]] := typeP_context TtypeP. + exact: FTtypeP_Fitting_abelian TtypeP. +have{cxQg} sQgS: Q :^ g \subset S. + have sH1A0 := subset_trans (Fitting_sub_FTsupp maxS) (FTsupp_sub0 S). + have{sH1A0} A0x: x \in 'A0(S) := subsetP sH1A0 x H1x. + have [_ _ _ _ [tiA0 _]] := Sfacts. + by have:= cent1_normedTI tiA0 A0x; rewrite setTI; apply: subset_trans. +have /pHallP[_ eq_Sq_q]: q.-Hall(S) W1. + have qW1: q.-group W1 by rewrite /pgroup pnat_id. + have [|//] := coprime_mulGp_Hall (sdprodW defS) _ qW1. + by rewrite /pgroup p'natE // -prime_coprime // coprime_sym. +have:= partn_dvd q (cardG_gt0 _) (cardSg sQgS). +rewrite cardJg /= -eq_Sq_q => /(dvdn_leq_log q (cardG_gt0 _))/idPn[]. +have [_ [_ ->] _ _ _] := FTtypeP_facts maxT TtypeP. +by rewrite -ltnNge p_part !pfactorK // logn_prime // eqxx ltnW. +Qed. + +(* This is Peterfalvi (13.4). *) +Let T_Galois : [/\ typeP_Galois TtypeP, D = 1%g & v = (q ^ p).-1 %/ q.-1]. +Proof. +apply: FTtypeP_no_Ind_Fitting_facts => //; apply/hasPn=> theta Ttheta. +apply/andP=> [[/= irr_theta Ktheta]]; set calK := seqIndT _ T in Ktheta. +have [tau1S cohS [bS _ Dtau1Smu]] := FTtypeP_coherence maxS StypeP. +have [tau1T cohT [bT _ Dtau1Tnu]] := FTtypeP_coherence maxT TtypeP. +have [[[Itau1S Ztau1S] Dtau1S] [[Itau1T Ztau1T] Dtau1T]] := (cohS, cohT). +have onF0 := cfun_onS (Fitting_sub_FTsupp0 _). +pose HG := class_support H^# G; pose KG := class_support K^# G. +have Hdlambda xi: + xi \in calH -> xi \in calS -> tau1S (lambda - xi) \in 'CF(G, HG). +- move=> Hxi Sxi; have H1dxi: lambda - xi \in 'CF(S, H^#). + rewrite cfun_onD1 rpredB ?((seqInd_on (gFnormal _ _)) setT) //=. + by rewrite !cfunE !calHuq ?subrr. + rewrite Dtau1S ?zcharD1E ?rpredB ?mem_zchar ?(cfun_on0 H1dxi) ?inE ?eqxx //=. + by have [_ _ _ _ [_ ->]] := Sfacts; rewrite ?onF0 // cfInd_on ?subsetT. +have Kdtheta xi: + xi \in calK -> xi \in calT -> tau1T (theta - xi) \in 'CF(G, KG). +- move=> Kxi Txi; have K1dxi: theta - xi \in 'CF(T, K^#). + rewrite cfun_onD1 rpredB ?((seqInd_on (gFnormal _ _)) setT) //=. + by rewrite !cfunE !(FTtypeP_Ind_Fitting_1 _ TtypeP) ?subrr. + rewrite Dtau1T ?zcharD1E ?rpredB ?mem_zchar ?(cfun_on0 K1dxi) ?inE ?eqxx //=. + have [_ _ _ _ [_ ->]] := FTtypeP_facts maxT TtypeP; last exact: onF0. + by rewrite cfInd_on ?subsetT. +have oHK alpha beta: + alpha \in 'CF(G, HG) -> beta \in 'CF(G, KG) -> '[alpha, beta] = 0. +- by move=> Halpha Kbeta; rewrite (cfdotElr Halpha Kbeta) tiHK big_set0 mulr0. +have o_lambda_theta: '[tau1S lambda, tau1T theta] = 0. + pose S1 := lambda :: lambda^*%CF; pose T1 := theta :: theta^*%CF. + have sS1S: {subset S1 <= calS} by apply/allP; rewrite /= Slam cfAut_seqInd. + have sT1T: {subset T1 <= calT} by apply/allP; rewrite /= Ttheta cfAut_seqInd. + have ooS1: orthonormal (map tau1S S1). + rewrite map_orthonormal //; first exact: (sub_in2 (zchar_subset sS1S)). + apply: seqInd_conjC_ortho2 Slam; rewrite ?gFnormal ?mFT_odd //. + by have /mulG_sub[] := sdprodW defPU. + have ooT1: orthonormal (map tau1T T1). + rewrite map_orthonormal //; first exact: (sub_in2 (zchar_subset sT1T)). + apply: seqInd_conjC_ortho2 Ttheta; rewrite ?gFnormal ?mFT_odd //. + by have [_ [_ _ _ /sdprodW/mulG_sub[]]] := TtypeP. + have /andP/orthonormal_vchar_diff_ortho := conj ooS1 ooT1; apply. + by split; apply/allP; rewrite /= ?Ztau1S ?Ztau1T ?mem_zchar ?cfAut_seqInd. + have on1'G M beta: beta \in 'CF(G, class_support M^# G) -> beta 1%g = 0. + move/cfun_on0->; rewrite // class_supportEr -cover_imset -class_supportD1. + by rewrite !inE eqxx. + rewrite -!raddfB; set alpha := tau1S _; set beta := tau1T _. + have [Halpha Kbeta]: alpha \in 'CF(G, HG) /\ beta \in 'CF(G, KG). + by rewrite Hdlambda ?Kdtheta ?cfAut_seqInd ?cfAut_seqIndT. + by rewrite oHK // {1}(on1'G _ _ Halpha) (on1'G _ _ Kbeta) !eqxx. +pose ptiWT := FT_primeTI_hyp TtypeP; pose nu_ := primeTIred ptiWT. +have etaC := cycTIisoC (FT_cyclicTI_hyp StypeP) (FT_cyclicTI_hyp TtypeP). +have /idPn[]: '[tau1S (lambda - mu_ #1), tau1T (theta - nu_ #1)] == 0. + rewrite oHK //. + by rewrite Hdlambda ?FTseqInd_TIred ?FTprTIred_Ind_Fitting ?Iirr1_neq0. + by rewrite Kdtheta ?FTseqInd_TIred ?FTprTIred_Ind_Fitting ?Iirr1_neq0. +rewrite !raddfB /= !cfdotBl o_lambda_theta Dtau1Smu ?Dtau1Tnu ?Iirr1_neq0 //. +rewrite !cfdotZl !cfdotZr rmorph_sign !cfdot_suml big1 => [|i _]; last first. + rewrite cfdotC etaC (coherent_ortho_cycTIiso TtypeP _ cohT) ?conjC0 //. + by apply: seqInd_conjC_subset1; apply: Fcore_sub_FTcore. +rewrite cfdot_sumr big1 ?mulr0 ?subr0 ?add0r ?opprK => [|j _]; last first. + by rewrite -etaC (coherent_ortho_cycTIiso StypeP _ cohS). +set i1 := iter bT _ #1; set j1 := iter bS _ #1. +rewrite !mulf_eq0 !signr_eq0 (bigD1 i1) //= addrC big1 => [|i i1'i]; last first. + rewrite etaC cfdot_sumr big1 // => j _; rewrite cfdot_cycTIiso. + by rewrite (negPf i1'i) andbF. +rewrite etaC cfdot_sumr (bigD1 j1) //= cfdot_cycTIiso !eqxx addrCA. +rewrite big1 ?addr0 ?oner_eq0 // => j j1'j; rewrite cfdot_cycTIiso. +by rewrite eq_sym (negPf j1'j). +Qed. + +(* This is Peterfalvi (13.10). *) +Lemma FTtypeP_compl_ker_ratio_lb : m * (p ^ q.-1)%:R / q%:R < u%:R / c%:R. +Proof. +have [tau1 cohS cohSmu] := FTtypeP_coherence maxS StypeP. +pose lam1 := tau1 lambda; pose eta10 := eta_ #1 0. +pose H1G := class_support H^# G; pose K1G := class_support K^# G. +pose G0 := ~: (class_support H G :|: class_support K G). +pose invJ (f : gT -> algC) := forall y x, f (x ^ y) = f x. +pose nm2 (chi : 'CF(G)) x := `|chi x| ^+ 2; pose g : algC := #|G|%:R. +have injJnm2 chi: invJ (nm2 chi) by move=> y x; rewrite /nm2 cfunJ ?inE. +have nm2_dirr chi: chi \in dirr G -> g^-1 <= nm2 chi 1%g / g. + case/dIrrP=> d ->; rewrite -{1}[g^-1]mul1r ler_pmul2r ?invr_gt0 ?gt0CG //. + rewrite expr_ge1 ?normr_ge0 // cfunE normrMsign. + by rewrite irr1_degree normr_nat ler1n irr_degree_gt0. +pose mean (F M : {set gT}) (f : gT -> algC) := (\sum_(x in F) f x) / #|M|%:R. +have meanTI M (F := 'F(gval M)^#) (FG := class_support F G) f: + M \in 'M -> normedTI F G M -> invJ f -> mean FG G f = mean F M f. +- move=> maxM /and3P[ntF tiF /eqP defN] fJ; apply: canLR (mulfK (neq0CG _)) _. + rewrite (set_partition_big _ (partition_class_support ntF tiF)) /=. + rewrite mulrAC -mulrA -natf_indexg ?subsetT //=. + have ->: #|G : M| = #|F :^: G| by rewrite card_conjugates defN. + rewrite mulr_natr -sumr_const; apply: eq_bigr => _ /imsetP[y _ ->]. + by rewrite (big_imset _ (in2W (conjg_inj _))) (eq_bigr _ (in1W (fJ y))). +have{meanTI} meanG f : + invJ f -> mean G G f = f 1%g / g + mean H^# S f + mean K^# T f + mean G0 G f. +- have type24 maxM := compl_of_typeII_IV maxM _ (FTtype5_exclusion maxM). + have tiH: normedTI H^# G S by have/type24[] := StypeP. + have{type24} tiK: normedTI K^# G T by have/type24[] := TtypeP. + move=> fJ; rewrite -!meanTI // {1}/mean (big_setD1 1%g) // (big_setID H1G) /=. + rewrite [in rhs in _ + (_ + rhs)](big_setID K1G) /= -/g -!mulrDl !addrA. + congr ((_ + _ + _ + _) / g); rewrite ?(setIidPr _) // /H1G /K1G. + + by rewrite class_supportEr -cover_imset -class_supportD1 setSD ?subsetT. + + rewrite subsetD -setI_eq0 setIC tiHK eqxx andbT. + by rewrite class_supportEr -cover_imset -class_supportD1 setSD ?subsetT. + rewrite !class_supportEr -!cover_imset -!class_supportD1. + apply: eq_bigl => x; rewrite !inE andbT -!negb_or orbCA orbA orbC. + by case: (x =P 1%g) => //= ->; rewrite mem_class_support ?group1. +have lam1_ub: mean G0 G (nm2 lam1) <= lambda 1%g ^+ 2 / #|S|%:R - g^-1. + have [[Itau1 Ztau1] _] := cohS. + have{Itau1} n1lam1: '[lam1] = 1 by rewrite Itau1 ?mem_zchar ?irrWnorm. + have{Ztau1} Zlam1: lam1 \in 'Z[irr G] by rewrite Ztau1 ?mem_zchar. + rewrite -ler_opp2 opprB -(ler_add2l '[lam1]) {1}n1lam1 addrCA. + rewrite (cfnormE (cfun_onG _)) (mulrC g^-1) [_ / g](meanG (nm2 _)) // addrK. + rewrite -addrA ler_add ?nm2_dirr //; first by rewrite dirrE Zlam1 n1lam1 /=. + rewrite ler_paddr ?divr_ge0 ?ler0n //. + by apply: sumr_ge0 => x _; rewrite exprn_ge0 ?normr_ge0. + rewrite ler_pdivl_mulr ?gt0CG // mulrBl mul1r divfK ?neq0CG //. + by rewrite (FTtypeP_sum_Ind_Fitting_lb StypeP). +pose ub_lam1 : algC := (#|T^`(1)%g|%:R - (v ^ 2)%:R - #|Q|.-1%:R) / #|T|%:R. +have [_ D_1 Dv] := T_Galois. +have defK : K = Q by have [<-] := typeP_context TtypeP; rewrite D_1 dprodg1. +have eta10_ub: mean G0 G (nm2 (eta_ #1 0)) <= #|G0|%:R / g - ub_lam1. + rewrite -ler_opp2 opprB -(ler_add2l '[eta_ #1 0]) {2}(cfnormE (cfun_onG _)). + rewrite (mulrC g^-1) [_ / g in rhs in _ <= rhs](meanG (nm2 _)) // addrK. + have ->: '[eta_ #1 0] = mean G G (fun _ => 1). + by rewrite /mean sumr_const cfdot_cycTIiso eqxx divff ?neq0CG. + rewrite meanG // [in lhs in lhs <= _]/mean !sumr_const addrACA subrr addr0. + rewrite [lhs in lhs <= _]addrAC -addrA -mulrDl (cardsD1 1%g Q) group1 -defK. + rewrite mul1r subrK ?ler_add ?ler_pmul2r ?invr_gt0 ?gt0CG //. + - by rewrite nm2_dirr ?cycTIiso_dirr. + - exact: (FTtypeP_sum_cycTIiso10_lb _ StypeP). + congr (_ <= _): (FTtypeP_sum_cycTIiso01_lb maxT TtypeP). + by apply: eq_bigr => x _; congr (nm2 _ x); apply: cycTIisoC. +have: ub_lam1 < lambda 1%g ^+ 2 / #|S|%:R. + rewrite -[_ / _](subrK g^-1) ltr_spaddr ?invr_gt0 ?gt0CG //. + rewrite -(ler_add2r (#|G0|%:R / g)) -ler_subr_addl -addrA. + apply: ler_trans (ler_add lam1_ub eta10_ub). + rewrite -mulrDl -big_split /= ler_pmul2r ?invr_gt0 ?gt0CG //. + exact: FTtypeP_sum_nonFitting_lb. +rewrite calHuq // -/u -(sdprod_card defS) -/q -(sdprod_card defPU) oU mulnC. +rewrite mulnCA mulnAC !natrM !invfM expr2 !mulrA !mulfK ?neq0CG ?neq0CiG //. +rewrite mulrAC ltr_pdivl_mulr ?ltr_pdivr_mulr ?gt0CG //. +congr (_ < _); last by rewrite -mulrA mulrC. +have [_ [_ ->] _ _ _] := Sfacts; rewrite -/p -/q. +rewrite -{1}(ltn_predK qgt2) expnS natrM mulrA; congr (_ * _). +have /sdprod_card oT: T^`(1) ><| W2 = T by have [[]] := TtypeP. +rewrite /ub_lam1 -{}oT natrM invfM mulrA divfK ?mulrBl ?divff ?neq0CG //. +have /sdprod_card <-: Q ><| V = T^`(1)%g by have [_ []] := TtypeP. +have ->: #|V| = v by rewrite /v D_1 indexg1. +rewrite mulnC !natrM invfM mulrA mulfK ?neq0CiG //. +have [_ [_ oQ] _ _ _] := FTtypeP_facts maxT TtypeP; rewrite -/p -/q /= in oQ. +rewrite Dv natf_div ?dvdn_pred_predX // oQ. +rewrite invfM invrK -mulrA -subn1 mulVKf ?gtr_eqF ?ltr0n //; last first. + by rewrite subn_gt0 -(exp1n p) ltn_exp2r ltnW // ltnW. +rewrite -oQ natrB ?cardG_gt0 // !mulrBl mul1r mulrC mulKf ?neq0CG // -invfM. +by rewrite -natrM oQ opprD opprK addrA addrAC. +Qed. + +End Thirteen_4_10. + +(* This is (13.10) without the dependency on T. *) +Let gen_lb_uc : m * (p ^ q.-1)%:R / q%:R < u%:R / c%:R. +Proof. +have [T pairST [xdefW [V TtypeP]]] := FTtypeP_pair_witness maxS StypeP. +by apply: FTtypeP_compl_ker_ratio_lb TtypeP; have [[]] := pairST. +Qed. + +Import ssrint. +(* This is Peterfalvi (13.11). *) +Let lb_m_cases : + [/\ (*a*) (q >= 7)%N -> m > 8%:R / 10%:R, + (*b*) (q >= 5)%N -> m > 7%:R / 10%:R + & (*c*) q = 3 -> + m > 49%:R / 100 %:R /\ u%:R / c%:R > (p ^ 2).-1%:R / 6%:R :> algC]. +Proof. +pose mkrat b d := fracq (b, d%:Z). +pose test r b d := 1 - mkrat 1 r.-1 - mkrat 1 (r ^ 2)%N > mkrat b%:Z d. +have lb_m r b d: test r.+2 b d -> (q >= r.+2)%N -> m > b%:R / d%:R. + rewrite /test /mkrat !fracqE !CratrE /= => ub_bd le_r_q. + apply: ltr_le_trans ub_bd _; rewrite ler_paddr ?invr_ge0 ?ler0n //. + rewrite -!addrA ler_add2l -!opprD ler_opp2 ler_add //. + rewrite mul1r lef_pinv ?qualifE ?ltr0n //; last by rewrite -(subnKC qgt2). + by rewrite leC_nat -ltnS (ltn_predK qgt2). + rewrite -(ltn_predK pgt2) expnSr natrM invfM mulrA. + rewrite ler_pdivr_mulr ?gt0CG // mulrAC mul1r -subn1. + rewrite ler_pmul ?invr_ge0 ?ler0n ?leC_nat ?leq_subr //. + rewrite lef_pinv ?qualifE ?ltr0n ?leC_nat ?expn_gt0 ?(prime_gt0 pr_q) //. + apply: leq_trans (_ : q ^ 2 <= _)%N; first by rewrite leq_exp2r. + by rewrite -(subnKC qgt2) leq_pexp2l // -subn1 ltn_subRL. +split=> [||q3]; try by apply: lb_m; compute. +pose d r : algC := (3 ^ r.-1)%:R^-1; pose f r := (r ^ 2)%:R * d r. +have Dm: m = (1 - d p) / 2%:R. + rewrite mulrBl mul1r -mulrN mulrC /m q3 /= addrAC -addrA natrM invfM -mulrBl. + rewrite -{1}(ltn_predK pgt2) expnS natrM invfM mulrA. + by congr (_ + _ / _); apply/eqP; rewrite -!CratrE; compute. +split; last apply: ler_lt_trans gen_lb_uc. + apply: ltr_le_trans (_ : (1 - d 5) / 2%:R <= _). + by rewrite /d -!CratrE; compute. + rewrite Dm ler_pmul2r ?invr_gt0 ?ltr0n // ler_add2l ler_opp2. + rewrite lef_pinv ?qualifE ?ltr0n ?expn_gt0 // leC_nat leq_pexp2l //=. + by rewrite -subn1 ltn_subRL odd_geq ?mFT_odd //= ltn_neqAle pgt2 andbT -q3. +rewrite -mulrA mulrCA Dm -mulrA -invfM -natrM mulrA q3 mulrBr mulr1. +rewrite ler_pmul2r ?invr_gt0 ?ltr0n //= -subn1 natrB ?expn_gt0 ?prime_gt0 //. +rewrite ler_add2l ler_opp2 -/(f p) -(subnKC pgt2). +elim: (p - 3)%N => [|r]; first by rewrite /f /d -!CratrE; compute. +apply: ler_trans; rewrite addnS /f /d; set x := (3 + r)%N. +rewrite ler_pdivr_mulr ?ltr0n ?expn_gt0 // mulrAC (expnS 3) (natrM _ 3). +rewrite mulrA mulfK ?gtr_eqF ?ltr0n ?expn_gt0 //. +rewrite -ler_pdivr_mull ?ltr0n // !natrX -exprVn -exprMn. +rewrite mulrS mulrDr mulr1 mulVf ?pnatr_eq0 //. +apply: ler_trans (_ : (3%:R^-1 + 1) ^+ 2 <= _); last by rewrite -!CratrE. +rewrite ler_sqr ?rpredD ?rpred1 ?rpredV ?rpred_nat // ler_add2r. +by rewrite lef_pinv ?qualifE ?ltr0n ?leC_nat. +Qed. + +(* This corollary of (13.11) is used in both (13.12) and (13.15). *) +Let small_m_q3 : m < (q * p)%:R / (q.*2.+1 * p.-1)%:R -> q = 3 /\ (p >= 5)%N. +Proof. +move=> ub_m; have [lb7_m lb5_m _] := lb_m_cases. +have [p3 | p_neq3] := eqVneq p 3. + have ub7_m: ~~ (8%:R / 10%:R < m). + rewrite ltr_gtF // (ltr_le_trans ub_m) // p3 /=. + apply: ler_trans (_ : 3%:R / 4%:R <= _); last first. + by rewrite -!CratrE; compute. + rewrite ler_pdivl_mulr ?ltr0n // mulrAC ler_pdivr_mulr ?ltr0n ?muln_gt0 //. + by rewrite -!natrM leC_nat mulnCA mulSn -muln2 -!mulnA leq_addl. + have{ub7_m} q5: q = 5. + apply: contraNeq ub7_m; rewrite neq_ltn odd_ltn ?mFT_odd //= ltnS leqNgt. + by rewrite ltn_neqAle qgt2 -{1}p3 eq_sym p'q -(odd_geq 7) ?mFT_odd. + have /implyP := ltr_trans (lb5_m _) ub_m. + by rewrite q5 p3 -!CratrE; compute. +have pge5: (5 <= p)%N by rewrite odd_geq ?mFT_odd // ltn_neqAle eq_sym p_neq3. +have ub5_m: ~~ (7%:R / 10%:R < m). + rewrite ltr_gtF // (ltr_le_trans ub_m) //. + apply: ler_trans (_ : 2%:R^-1 * (1 + 4%:R^-1) <= _); last first. + by rewrite -!CratrE; compute. + rewrite !natrM invfM mulrACA ler_pmul ?divr_ge0 ?ler0n //. + rewrite ler_pdivr_mulr ?ler_pdivl_mull ?ltr0n // -natrM mul2n leC_nat. + by rewrite ltnW. + rewrite -(subnKC pge5) [_%:R]mulrSr mulrDl divff ?pnatr_eq0 // ler_add2l. + by rewrite mul1r lef_pinv ?qualifE ?ltr0n // leC_nat. +split=> //; apply: contraNeq ub5_m. +by rewrite neq_ltn ltnNge qgt2 -(odd_geq 5) ?mFT_odd. +Qed. + +(* A more usable form for (13.10). *) +Let gen_ub_m : m < (q * u)%:R / (c * p ^ q.-1)%:R. +Proof. +rewrite !natrM invfM mulrA ltr_pdivl_mulr ?ltr0n ?expn_gt0 ?cardG_gt0 //. +by rewrite -mulrA -ltr_pdivr_mull ?gt0CG // mulrC. +Qed. + +(* This is the bulk of the proof of Peterfalvi (13.12). *) +Lemma FTtypeP_Ind_Fitting_reg_Fcore : c = 1%N. +Proof. +apply/eqP/wlog_neg; rewrite eqn_leq cardG_gt0 andbT -ltnNge => c_gt1. +have ub_m: m < (q * (p ^ q).-1)%:R / (c * p ^ q.-1 * p.-1)%:R. + rewrite 2!natrM invfM mulrACA mulrAC -natf_div ?dvdn_pred_predX // -natrM. + rewrite (ltr_le_trans gen_ub_m) // ler_pmul ?invr_ge0 ?ler0n // leC_nat. + by rewrite leq_mul //; case: Sfacts. +have regCW1: semiregular C W1. + have [[_ _ /Frobenius_reg_ker regUW1 _] _ _ _] := FTtypeP_facts maxS StypeP. + by move=> _ y /regUW1 regUx; rewrite setIAC regUx setI1g. +have{regCW1} dv_2q_c1: q.*2 %| c.-1. + rewrite -(subnKC c_gt1) -mul2n Gauss_dvd ?coprime2n ?dvdn2 ?mFT_odd //=. + rewrite odd_sub ?mFT_odd -?subSn // subn2 regular_norm_dvd_pred //. + have /mulG_sub[_ sW1S] := sdprodW defS. + apply: normsI; first by have [_ []] := StypeP. + by rewrite (subset_trans sW1S) ?norms_cent ?gFnorm. +have [q3 pge5]: q = 3 /\ (p >= 5)%N. + apply: small_m_q3; apply: (ltr_le_trans ub_m). + rewrite !natrM -!mulrA ler_pmul2l ?gt0CG //. + rewrite !invfM !mulrA -(subnKC pgt2) ler_pmul2r ?invr_gt0 ?ltr0n //. + rewrite ler_pdivr_mulr ?ltr0n ?expn_gt0 // mulrAC -natrM -expnS. + rewrite prednK ?cardG_gt0 // ler_pmul ?invr_ge0 ?ler0n ?leC_nat ?leq_pred //. + rewrite lef_pinv ?qualifE ?gt0CG ?ltr0n // leC_nat. + by rewrite -(subnKC c_gt1) ltnS dvdn_leq //= -subSn ?subn2. +have [_ _ [//|lb_m lb_uc]] := lb_m_cases. +pose sum3 r : algC := (r.+1 ^ 2)%:R^-1 + r.+1%:R^-1 + 1. +have [b Dc1] := dvdnP dv_2q_c1; rewrite q3 in Dc1. +have [b0 | b_gt0] := posnP b; first by rewrite b0 -(subnKC c_gt1) in Dc1. +have ub3_m r a: (r < p)%N -> (a <= b)%N -> m < 3%:R / (a * 6).+1%:R * sum3 r. + move=> lb_p lb_b; apply: ltr_le_trans ub_m _. + rewrite !natrM !invfM mulrACA -!mulrA q3 ler_pmul2l ?ltr0n //. + rewrite -(ltn_predK c_gt1) Dc1 ler_pmul ?mulr_ge0 ?invr_ge0 ?ler0n //. + by rewrite lef_pinv ?qualifE ?ltr0n // leC_nat ltnS leq_mul. + rewrite predn_exp mulnC natrM 2!big_ord_recl big_ord1 /= /bump /= expn1. + rewrite -(subnKC (ltnW pgt2)) add2n in lb_p *. + rewrite mulfK ?pnatr_eq0 // addnA 2!natrD 2!mulrDr mulr1 {-1}natrM invfM. + rewrite mulrA divfK ?mulVf ?pnatr_eq0 // ler_add2r. + by rewrite ler_add ?lef_pinv ?qualifE ?ltr0n ?leC_nat ?leq_sqr. +have beq1: b = 1%N. + apply: contraTeq lb_m; rewrite neq_ltn ltnNge b_gt0 => /(ub3_m 4) ub41. + by rewrite ltr_gtF // (ltr_trans (ub41 _)) // /sum3 -!CratrE; compute. +have c7: c = 7 by rewrite -(ltn_predK c_gt1) Dc1 beq1. +have plt11: (p < 11)%N. + rewrite ltnNge; apply: contraL lb_m => /ub3_m/(_ b_gt0) ub100. + by rewrite ltr_gtF // (ltr_trans ub100) // /sum3 -!CratrE; compute. +have{plt11} p5: p = 5. + suffices: p \in [seq r <- iota q.+1 7 | prime r & coprime r c]. + by rewrite c7 q3 inE => /eqP. + rewrite mem_filter mem_iota ltn_neqAle p'q q3 pgt2 pr_p (coprimeSg sW2P) //. + by rewrite (coprimegS _ (Ptype_Fcore_coprime StypeP)) ?subIset ?joing_subl. +have [galS | gal'S] := boolP (typeP_Galois StypeP); last first. + have [H1 [_ _ _ _ []]] := typeP_Galois_Pn maxS notStype5 gal'S. + case/pdivP=> r pr_r r_dv_a /(dvdn_trans r_dv_a)/idPn[]. + rewrite Ptype_factor_prime // -/p p5 (Euclid_dvdM 2 2) // gtnNdvd //. + rewrite odd_prime_gt2 ?(dvdn_odd (dvdn_trans r_dv_a (dvdn_indexg _ _))) //. + by rewrite mFT_odd. +have{galS} u_dv_31: u %| 31. + have [_ _ [_ _]] := typeP_Galois_P maxS notStype5 galS. + rewrite Ptype_factor_prime ?Ptype_Fcompl_kernel_cent // -/p -/q p5 q3. + rewrite card_quotient // normsI ?normG ?norms_cent //. + by have [] := sdprodP defPU. +have hallH: Hall S H. + rewrite /Hall -divgS ?gFsub //= -(sdprod_card defS) -(sdprod_card defPU). + rewrite -(dprod_card defH) -mulnA divnMl ?cardG_gt0 // -/c oU mulnAC c7. + have [_ [_ ->] _ _ _] := FTtypeP_facts maxS StypeP. + by rewrite mulnK // -/q -/p q3 p5 coprime_mulr (coprime_dvdr u_dv_31). +rewrite -(leq_pmul2l (cardG_gt0 P)) muln1 (dprod_card defH) subset_leq_card //. +by rewrite (Fcore_max (Hall_pi hallH)) ?gFnormal ?Fitting_nil. +Qed. +Local Notation c1 := FTtypeP_Ind_Fitting_reg_Fcore. + +(* This is the main part of the proof of Peterfalvi (13.13). *) +Lemma FTtypeP_Ind_Fitting_nonGalois_facts : + ~~ typeP_Galois StypeP -> q = 3 /\ #|U| = (p.-1./2 ^ 2)%N. +Proof. +have even_p1: 2 %| p.-1 by rewrite -subn1 -subSS dvdn_sub ?dvdn2 //= mFT_odd. +move=> gal'S; have{gal'S} u_dv_p2q: u %| p.-1./2 ^ q.-1. + have [H1 [_ _ _ _ []]] := typeP_Galois_Pn maxS notStype5 gal'S. + rewrite Ptype_factor_prime ?Ptype_Fcompl_kernel_cent // -/p -/q. + set a := #|U : _| => a_gt1 a_dv_p1 _ [Uhat isoUhat]. + have a_odd: odd a by rewrite (dvdn_odd (dvdn_indexg _ _)) ?mFT_odd. + have [_ _ nPU _] := sdprodP defPU. + rewrite /u -card_quotient ?normsI ?normG ?norms_cent // (card_isog isoUhat). + apply: dvdn_trans (cardSg (subsetT _)) _; rewrite cardsT card_matrix mul1n. + rewrite card_ord Zp_cast ?dvdn_exp2r // -(@Gauss_dvdl a _ 2) ?coprimen2 //. + by rewrite -divn2 divnK. +have [_ lb5_m lb3_m] := lb_m_cases. +pose f r : algC := r%:R / (2 ^ r.-1)%:R. +have ub_m: m < f q. + apply: ltr_le_trans gen_ub_m _; rewrite c1 mul1n. + rewrite natrM ler_pdivr_mulr ?ltr0n ?expn_gt0 ?cardG_gt0 // -mulrA. + rewrite ler_wpmul2l ?ler0n // mulrC !natrX -expr_div_n. + apply: ler_trans (_ : (p.-1 %/ 2)%:R ^+ q.-1 <= _). + by rewrite -natrX leC_nat divn2 dvdn_leq // expn_gt0 -(subnKC pgt2). + rewrite -(subnKC qgt2) ler_pexpn2r ?rpred_div ?rpred_nat // natf_div //. + by rewrite ler_wpmul2r ?invr_ge0 ?ler0n // leC_nat leq_pred. +have{ub_m} q3: q = 3. + apply: contraTeq ub_m; rewrite neq_ltn ltnNge qgt2 -(odd_geq 5) ?mFT_odd //=. + move=> qge5; rewrite ltr_gtF // -(subnKC qge5). + elim: (q - 5)%N => [|r]; last apply: ler_lt_trans. + by apply: ltr_trans (lb5_m qge5); rewrite /f -!CratrE; compute. + rewrite addnS ler_pdivr_mulr ?ltr0n ?expn_gt0 // natrM mulrACA mulrA. + by rewrite divfK ?pnatr_eq0 ?expn_eq0 // mulr_natr mulrS ler_add2r ler1n. +have [[]] := dvdnP u_dv_p2q; rewrite q3; first by rewrite -(subnKC pgt2). +case=> [|b] Du; first by rewrite oU c1 Du muln1 mul1n. +have [_ /idPn[]] := lb3_m q3; rewrite c1 divr1 ler_gtF //. +apply: ler_trans (_ : (p.-1 ^ 2)%:R / 8%:R <= _). + rewrite (natrX _ 2 3) exprSr invfM mulrA natrX -expr_div_n -natf_div // divn2. + by rewrite -natrX Du ler_pdivl_mulr ?ltr0n // mulrC -natrM leC_nat leq_mul. +rewrite -!subn1 (subn_sqr p 1) !natrM -!mulrA ler_wpmul2l ?ler0n //. +rewrite ler_pdivr_mulr 1?mulrAC ?ler_pdivl_mulr ?ltr0n // -!natrM leC_nat. +rewrite (mulnA _ 3 2) (mulnA _ 4 2) leq_mul // mulnBl mulnDl leq_subLR. +by rewrite addnCA (mulnSr p 3) -addnA leq_addr. +Qed. + +(* This is the bulk of the proof of Peterfalvi (13.15). *) +(* We improve slightly on the end of the argument by maing better use of the *) +(* bound on u to get p = 5 directly. *) +Lemma FTtypeP_Ind_Fitting_Galois_ub b : + (p ^ q).-1 %/ p.-1 = (b * u)%N -> (b <= q.*2)%N. +Proof. +move=> Dbu; have: U :!=: 1%g by have [[_ _ /Frobenius_context[]]] := Sfacts. +rewrite trivg_card1 oU c1 muln1 leqNgt; apply: contra => bgt2q. +have [|q3 pge5] := small_m_q3. + apply: ltr_le_trans gen_ub_m _; rewrite c1 mul1n !natrM -!mulrA. + rewrite ler_wpmul2l ?ler0n // ler_pdivr_mulr ?ltr0n ?expn_gt0 ?cardG_gt0 //. + rewrite mulrAC invfM -natrM -expnS prednK ?cardG_gt0 // mulrCA. + rewrite ler_pdivl_mull ?ltr0n // -natrM. + apply: ler_trans (_ : (b * u)%:R <= _); first by rewrite leC_nat leq_mul. + rewrite -Dbu natf_div ?dvdn_pred_predX // ler_wpmul2r ?invr_ge0 ?ler0n //. + by rewrite leC_nat leq_pred. +have ub_p: ((p - 3) ^ 2 < 4 ^ 2)%N. + have [_ _ [] // _] := lb_m_cases; rewrite c1 divr1 ltr_pdivr_mulr ?ltr0n //. + rewrite -natrM ltC_nat prednK ?expn_gt0 ?cardG_gt0 // => /(leq_mul bgt2q). + rewrite mulnC mulnA -Dbu q3 predn_exp mulKn; last by rewrite -(subnKC pgt2). + rewrite 2!big_ord_recl big_ord1 /= /bump /= !mulnDl expn0 expn1. + rewrite addnA mulnS leq_add2r -(leq_add2r 9) (mulnCA p 2 3) -addnA addnCA. + by rewrite -leq_subLR -(sqrn_sub pgt2). +have{ub_p pge5} p5: p = 5. + apply/eqP; rewrite eqn_leq pge5 andbT. + by rewrite ltn_sqr ltnS leq_subLR -ltnS odd_ltn ?mFT_odd in ub_p. +have bgt1: (1 < b)%N by rewrite -(subnKC bgt2q) q3. +rewrite -(eqn_pmul2l (ltnW bgt1)) muln1 eq_sym. +by apply/eqP/prime_nt_dvdP; rewrite ?dvdn_mulr ?gtn_eqF // -Dbu q3 p5. +Qed. + +End Thirteen_10_to_13_15. + +(* This is Peterfalvi (13.12). *) +Lemma FTtypeP_reg_Fcore : C :=: 1%g. +Proof. +have [] := boolP (has irrIndH calS); last first. + by case/(FTtypeP_no_Ind_Fitting_facts maxS StypeP). +by case/hasP=> lambda Slam /FTtypeP_Ind_Fitting_reg_Fcore/card1_trivg->. +Qed. + +Lemma Ptype_Fcompl_kernel_trivial : Ptype_Fcompl_kernel StypeP :=: 1%g. +Proof. by rewrite Ptype_Fcompl_kernel_cent ?FTtypeP_reg_Fcore. Qed. + +(* Since C is trivial, from here on u will denote #|U|. *) +Let u := #|U|. +Let ustar := (p ^ q).-1 %/ p.-1. + +(* This is Peterfalvi (13.13). *) +Lemma FTtypeP_nonGalois_facts : + ~~ typeP_Galois StypeP -> q = 3 /\ u = (p.-1./2 ^ 2)%N. +Proof. +move=> gal'S; have: has irrIndH calS. + by apply: contraR gal'S => /(FTtypeP_no_Ind_Fitting_facts maxS StypeP)[]. +by case/hasP=> lambda Slam /FTtypeP_Ind_Fitting_nonGalois_facts; apply. +Qed. + +Import FinRing.Theory. + +(* This is Peterfalvi (13.14). *) +Lemma FTtypeP_primes_mod_cases : + [/\ odd ustar, + p == 1 %[mod q] -> q %| ustar + & p != 1 %[mod q] -> + [/\ coprime ustar p.-1, ustar == 1 %[mod q] + & forall b, b %| ustar -> b == 1 %[mod q]]]. +Proof. +have ustar_mod r: p = 1 %[mod r] -> ustar = q %[mod r]. + move=> pr1; rewrite -[q]card_ord -sum1_card /ustar predn_exp //. + rewrite -(subnKC pgt2) mulKn // subnKC //. + elim/big_rec2: _ => // i s1 s2 _ eq_s12. + by rewrite -modnDm -modnXm pr1 eq_s12 modnXm modnDm exp1n. +have ustar_odd: odd ustar. + by apply: (can_inj oddb); rewrite -modn2 ustar_mod ?modn2 ?mFT_odd. +split=> // [p1_q|p'1_q]; first by rewrite /dvdn ustar_mod ?modnn //; apply/eqP. +have ustar_gt0: (ustar > 0)%N by rewrite odd_geq. +have [p1_gt0 p_gt0]: (p.-1 > 0 /\ p > 0)%N by rewrite -(subnKC pgt2). +have co_ustar_p1: coprime ustar p.-1. + rewrite coprime_pi' //; apply/pnatP=> //= r pr_r. + rewrite inE -subn1 -eqn_mod_dvd //= mem_primes pr_r ustar_gt0 => /eqP rp1. + rewrite /dvdn ustar_mod // [_ == _]dvdn_prime2 //. + by apply: contraNneq p'1_q => <-; apply/eqP. +suffices ustar_mod_q b: b %| ustar -> b == 1 %[mod q]. + by split; rewrite // ustar_mod_q. +move=> b_dv_ustar; have b_gt0 := dvdn_gt0 ustar_gt0 b_dv_ustar. +rewrite (prod_prime_decomp b_gt0) prime_decompE big_map /= big_seq. +elim/big_rec: _ => // r s /(pi_of_dvd b_dv_ustar ustar_gt0). +rewrite mem_primes -modnMml -modnXm => /and3P[pr_r _ r_dv_ustar]. +suffices{s} ->: r = 1 %[mod q] by rewrite modnXm modnMml exp1n mul1n. +apply/eqP; rewrite eqn_mod_dvd ?prime_gt0 // subn1. +have ->: r.-1 = #|[set: {unit 'F_r}]|. + rewrite card_units_Zp ?prime_gt0 ?pdiv_id //. + by rewrite -[r]expn1 totient_pfactor ?muln1. +have pq_r: p%:R ^+ q == 1 :> 'F_r. + rewrite -subr_eq0 -natrX -(@natrB _ _ 1) ?expn_gt0 ?cardG_gt0 // subn1. + rewrite -(divnK (dvdn_pred_predX p q)) -Fp_nat_mod //. + by rewrite -modnMml (eqnP r_dv_ustar) mod0n. +have Up_r: (p%:R : 'F_r) \is a GRing.unit. + by rewrite -(unitrX_pos _ (prime_gt0 pr_q)) (eqP pq_r) unitr1. +congr (_ %| _): (order_dvdG (in_setT (FinRing.unit 'F_r Up_r))). +apply/prime_nt_dvdP=> //; last by rewrite order_dvdn -val_eqE val_unitX. +rewrite -dvdn1 order_dvdn -val_eqE /= -subr_eq0 -val_eqE -(@natrB _ p 1) //=. +rewrite subn1 val_Fp_nat //; apply: contraFN (esym (mem_primes r 1)). +by rewrite pr_r /= -(eqnP co_ustar_p1) dvdn_gcd r_dv_ustar. +Qed. + +(* This is Peterfalvi (13.15). *) +Lemma card_FTtypeP_Galois_compl : + typeP_Galois StypeP -> u = (if p == 1 %[mod q] then ustar %/ q else ustar). +Proof. +case/typeP_Galois_P=> //= _ _ [_ _ /dvdnP[b]]; rewrite Ptype_factor_prime //. +rewrite -/ustar Ptype_Fcompl_kernel_trivial -(card_isog (quotient1_isog _)) -/u. +move=> Dbu; have ub_b: (b <= q.*2)%N. + have [[lambda Slam irrHlam]| ] := altP (@hasP _ irrIndH calS). + apply: (FTtypeP_Ind_Fitting_Galois_ub Slam irrHlam). + by rewrite FTtypeP_reg_Fcore indexg1. + case/(FTtypeP_no_Ind_Fitting_facts maxS StypeP) => _ /= ->. + rewrite indexg1 -/ustar -(leq_pmul2r (cardG_gt0 U)) -/u => Du. + by rewrite -Dbu -Du -(subnKC qgt2) leq_pmull. +have [ustar_odd p1_q p'1_q] := FTtypeP_primes_mod_cases. +have b_odd: odd b by rewrite Dbu odd_mul mFT_odd andbT in ustar_odd. +case: ifPn => [/p1_q q_dv_ustar | /p'1_q[_ _ /(_ b)]]. + have /dvdnP[c Db]: q %| b. + rewrite Dbu Gauss_dvdl // coprime_sym in q_dv_ustar. + by apply: coprimeSg coPUq; have /mulG_sub[_ sUPU] := sdprodW defPU. + have c_odd: odd c by rewrite Db odd_mul mFT_odd andbT in b_odd. + suffices /eqP c1: c == 1%N by rewrite Dbu Db c1 mul1n mulKn ?prime_gt0. + rewrite eqn_leq odd_gt0 // andbT -ltnS -(odd_ltn 3) // ltnS. + by rewrite -(leq_pmul2r (ltnW (ltnW qgt2))) -Db mul2n. +have Db: b = (b - 1).+1 by rewrite subn1 prednK ?odd_gt0. +rewrite Dbu dvdn_mulr // eqn_mod_dvd Db // -Db => /(_ isT)/dvdnP[c Db1]. +have c_even: ~~ odd c by rewrite Db Db1 /= odd_mul mFT_odd andbT in b_odd. +suffices /eqP->: b == 1%N by rewrite mul1n. +have:= ub_b; rewrite Db Db1 -mul2n ltn_pmul2r ?cardG_gt0 //. +by rewrite -ltnS odd_ltn //= !ltnS leqn0 => /eqP->. +Qed. + +(* This is Peterfalvi (13.16). *) +(* We have transposed T and Q here so that the lemma does not require *) +(* assumptions on the associate group. *) +Lemma FTtypeP_norm_cent_compl : P ><| W1 = 'N(W2) /\ P ><| W1 = 'C(W2). +Proof. +have [/mulG_sub[_ sW1S] /mulG_sub[sPPU sUPU]] := (sdprodW defS, sdprodW defPU). +have nPW1: W1 \subset 'N(P) by rewrite (subset_trans sW1S) ?gFnorm. +have [[_ _ frobUW1 cUU] [abelP _] _ _ _] := Sfacts. +have [pP cPP _] := and3P abelP; have [_ _ cW12 tiW12] := dprodP defW. +have cW2P: P \subset 'C(W2) by rewrite sub_abelian_cent. +suffices sNPW2: 'N(W2) \subset P <*> W1. + have cW2PW1: P <*> W1 \subset 'C(W2) by rewrite join_subG cW2P centsC. + rewrite sdprodEY ?coprime_TIg ?(coprimeSg sPPU) //. + split; apply/eqP; rewrite eqEsubset ?(subset_trans cW2PW1) ?cent_sub //. + by rewrite (subset_trans (cent_sub _)). +have tiP: normedTI P^# G S. + have [_ _ _] := compl_of_typeII_IV maxS StypeP notStype5. + by rewrite -defH FTtypeP_reg_Fcore dprodg1. +have ->: 'N(W2) = 'N_S(W2). + apply/esym/setIidPr/subsetP=> y nW2y; have [x W2x ntx] := trivgPn _ ntW2. + have [_ _ tiP_J] := normedTI_memJ_P tiP. + by rewrite -(tiP_J x) ?inE ?conjg_eq1 // ntx (subsetP sW2P) ?memJ_norm. +rewrite -{1}(sdprodW defS) setIC -group_modr ?cents_norm 1?centsC //=. +rewrite mulG_subG joing_subr /= -(sdprodW defPU) setIC. +rewrite -group_modl ?cents_norm //= mulG_subG joing_subl /= andbT. +set K := 'N_U(W2). +have nPKW1: K <*> W1 \subset 'N(P). + rewrite (subset_trans _ (gFnorm _ _)) // -(sdprodWY defS) genS ?setSU //. + by rewrite subIset ?sUPU. +have nW2KW1: K <*> W1 \subset 'N(W2). + by rewrite join_subG subsetIr cents_norm // centsC. +have coPKW1: coprime #|P| #|K <*> W1|. + by rewrite (coprimegS _ (Ptype_Fcore_coprime StypeP)) ?genS ?setSU ?subsetIl. +have p'KW1: p^'.-group (K <*> W1). + by rewrite /pgroup p'natE // -prime_coprime ?(coprimeSg sW2P). +have [Q1 defP nQ1KW1] := Maschke_abelem abelP p'KW1 sW2P nPKW1 nW2KW1. +have [-> | ntK] := eqVneq K 1%g; first by rewrite sub1G. +have frobKW1: [Frobenius K <*> W1 = K ><| W1]. + apply: Frobenius_subl frobUW1; rewrite ?subsetIl //. + rewrite normsI ?norms_norm //; first by have [_ []] := StypeP. + by rewrite cents_norm // centsC. +have regQ1W1: 'C_Q1(W1) = 1%g. + have [_ /mulG_sub[_ /setIidPl defQ1] _ tiW2Q1] := dprodP defP. + by rewrite -defQ1 -setIA (typeP_cent_core_compl StypeP) setIC. +have cQ1K: K \subset 'C(Q1). + have /mulG_sub[_ sQ1P] := dprodW defP; have coQ1KW1 := coprimeSg sQ1P coPKW1. + have solQ1 := solvableS sQ1P (abelian_sol cPP). + by have [_ ->] := Frobenius_Wielandt_fixpoint frobKW1 nQ1KW1 coQ1KW1 solQ1. +have /subsetIP[_ cW1K]: K \subset 'C_(K <*> W1)(W2). + have cCW1: W1 \subset 'C_(K <*> W1)(W2) by rewrite subsetI joing_subr centsC. + apply: contraR ntW1 => /(Frobenius_normal_proper_ker frobKW1) ltCK. + rewrite -subG1; have [/eqP/sdprodP[_ _ _ <-] _] := andP frobKW1. + rewrite subsetIidr (subset_trans cCW1) // proper_sub //. + rewrite ltCK //; last by rewrite norm_normalI ?norms_cent. + by rewrite (solvableS _ (abelian_sol cUU)) ?subsetIl. +case/negP: ntK; rewrite -subG1 -FTtypeP_reg_Fcore subsetI subsetIl /=. +by rewrite -(dprodW defP) centM subsetI cW1K. +Qed. + +End Thirteen_4_10_to_16. + +Section Thirteen_17_to_19. + +(* These assumptions repeat the part of Peterfalvi, Hypothesis (13.1) used *) +(* to prove (13.17-19). *) + +Variables S U W W1 W2 : {group gT}. +Hypotheses (maxS : S \in 'M) (defW : W1 \x W2 = W). +Hypotheses (StypeP : of_typeP S U defW). + +Local Notation "` 'W1'" := (gval W1) (at level 0, only parsing) : group_scope. +Local Notation "` 'W2'" := (gval W2) (at level 0, only parsing) : group_scope. +Local Notation "` 'W'" := (gval W) (at level 0, only parsing) : group_scope. +Local Notation V := (cyclicTIset defW). + +Local Notation "` 'S'" := (gval S) (at level 0, only parsing) : group_scope. +Local Notation P := `S`_\F%G. +Local Notation "` 'P'" := `S`_\F (at level 0) : group_scope. +Local Notation PU := S^`(1)%G. +Local Notation "` 'PU'" := `S^`(1) (at level 0) : group_scope. +Local Notation "` 'U'" := (gval U) (at level 0, only parsing) : group_scope. + +Let defS : PU ><| W1 = S. Proof. by have [[]] := StypeP. Qed. +Let defPU : P ><| U = PU. Proof. by have [_ []] := StypeP. Qed. + +Let notStype1 : FTtype S != 1%N. Proof. exact: FTtypeP_neq1 StypeP. Qed. +Let notStype5 : FTtype S != 5%N. Proof. exact: FTtype5_exclusion maxS. Qed. + +Let pddS := FT_prDade_hypF maxS StypeP. +Let ptiWS : primeTI_hypothesis S PU defW := FT_primeTI_hyp StypeP. +Let ctiWG : cyclicTI_hypothesis G defW := pddS. +Local Notation Sfacts := (FTtypeP_facts maxS StypeP). + +Let ntW1 : W1 :!=: 1. Proof. by have [[]] := StypeP. Qed. +Let ntW2 : W2 :!=: 1. Proof. by have [_ _ _ []] := StypeP. Qed. +Let cycW1 : cyclic W1. Proof. by have [[]] := StypeP. Qed. +Let cycW2 : cyclic W2. Proof. by have [_ _ _ []] := StypeP. Qed. + +Let p := #|W2|. +Let q := #|W1|. + +Let pr_p : prime p. Proof. by have [] := FTtypeP_primes maxS StypeP. Qed. +Let pr_q : prime q. Proof. by have [] := FTtypeP_primes maxS StypeP. Qed. + +Let qgt2 : q > 2. Proof. by rewrite odd_gt2 ?mFT_odd ?cardG_gt1. Qed. +Let pgt2 : p > 2. Proof. by rewrite odd_gt2 ?mFT_odd ?cardG_gt1. Qed. + +Let coPUq : coprime #|PU| q. +Proof. by rewrite (coprime_sdprod_Hall_r defS); have [[]] := StypeP. Qed. + +Let sW2P: W2 \subset P. Proof. by have [_ _ _ []] := StypeP. Qed. + +Let p'q : q != p. +Proof. +by rewrite -dvdn_prime2 -?prime_coprime -?(cyclic_dprod defW) //; case: ctiWG. +Qed. + +Let nirrW1 : #|Iirr W1| = q. Proof. by rewrite card_Iirr_cyclic. Qed. +Let nirrW2 : #|Iirr W2| = p. Proof. by rewrite card_Iirr_cyclic. Qed. +Let NirrW1 : Nirr W1 = q. Proof. by rewrite -nirrW1 card_ord. Qed. +Let NirrW2 : Nirr W2 = p. Proof. by rewrite -nirrW2 card_ord. Qed. + +Local Open Scope ring_scope. + +Let sigma := (cyclicTIiso ctiWG). +Let w_ i j := (cyclicTIirr defW i j). +Local Notation eta_ i j := (sigma (w_ i j)). + +Let mu_ := primeTIred ptiWS. +Local Notation tau := (FT_Dade0 maxS). + +Let calS0 := seqIndD PU S S`_\s 1. +Let rmR := FTtypeP_coh_base maxS StypeP. +Let scohS0 : subcoherent calS0 tau rmR. +Proof. exact: FTtypeP_subcoherent StypeP. Qed. + +Let calS := seqIndD PU S P 1. +Let sSS0 : cfConjC_subset calS calS0. +Proof. exact/seqInd_conjC_subset1/Fcore_sub_FTcore. Qed. + +(* This is Peterfalvi (13.17). *) +Lemma FTtypeII_support_facts T L (Q := T`_\F) (H := L`_\F) : + FTtype S == 2 -> typeP_pair S T defW -> L \in 'M('N(U)) -> + [/\ (*a*) [Frobenius L with kernel H], + (*b*) U \subset H + & (*c*) H ><| W1 = L \/ (exists2 y, y \in Q & H ><| (W1 <*> W2 :^ y) = L)]. +Proof. +move=> Stype2 pairST /setIdP[maxL sNU_L]. +have [pgt0 qgt0] := (ltnW (ltnW pgt2), ltnW (ltnW qgt2)). +have [[_ _ maxT] _ _ _ allST] := pairST. +have [[_ ntU _ _] _ not_sNU_S _ _] := compl_of_typeII maxS StypeP Stype2. +have [[_ _ frobUW1 cUU] _ _ _ _] := Sfacts. +have xdefW: W2 \x W1 = W by rewrite dprodC. +have [V TtypeP] := typeP_pairW (typeP_pair_sym xdefW pairST). +have [abelQ oQ]: q.-abelem Q /\ #|Q| = (q ^ p)%N. + by have [] := FTtypeP_facts maxT TtypeP. +have sUL: U \subset L := subset_trans (normG U) sNU_L. +have [/mulG_sub[sPPU sUPU] sPUS] := (sdprodW defPU, der_sub 1 S). +have nUW1: W1 \subset 'N(U) by have [_ []] := StypeP. +have sW1L := subset_trans nUW1 sNU_L. +have Ltype1: FTtype L == 1%N. + apply: contraR not_sNU_S => /allST/setUP[]// /imsetP[y _ defL]. + have hallU: \pi(U).-Hall(S) U. + have /Hall_pi/(subHall_Hall _ (piSg sUPU)): Hall PU U. + have /pHall_Hall:= pHall_subl sPPU sPUS (Fcore_Hall S). + by rewrite (sdprod_Hall defPU). + by apply; rewrite Hall_pi // -(coprime_sdprod_Hall_l defS). + have hallUy: \pi(U).-Hall(S) (U :^ y^-1). + by rewrite pHallE sub_conjgV -defL sUL /= cardJg -(card_Hall hallU). + have [x /conjGid <- ->] := Hall_trans (mmax_sol maxS) hallU hallUy. + by rewrite !normJ conjSg sub_conjgV -defL. + have oH: #|H| = (q ^ p)%N by rewrite /H defL FcoreJ cardJg. + have sW1H: W1 \subset H. + rewrite (sub_normal_Hall (Fcore_Hall L)) ?gFnormal //=. + by rewrite oH pi_of_exp ?prime_gt0 // pgroup_pi. + have regUW1: 'C_U(W1) = 1%g := Frobenius_trivg_cent frobUW1. + have /negP[] := ntU; rewrite -subG1 -regUW1 subsetIidl (sameP commG1P trivgP). + have /coprime_TIg <-: coprime #|U| #|H|. + by rewrite oH coprime_pexpr ?(coprimeSg sUPU). + rewrite commg_subI //; last by rewrite subsetI sW1H. + by rewrite subsetIidl (subset_trans sUL) ?gFnorm. +have frobL := FTtype1_Frobenius maxL Ltype1. +have solH: solvable H by rewrite nilpotent_sol ?Fcore_nil. +have coHW1: coprime #|H| #|W1|. + rewrite -(coprime_pexpr _ _ pgt0) -oQ. + apply/(coprimegS (Fcore_sub_FTcore maxT))/(coprimeSg (Fcore_sub_FTcore maxL)). + have [_ -> //] := FT_Dade_support_partition gT. + have: FTtype T != 1%N := FTtypeP_neq1 maxT TtypeP. + by apply: contra => /imsetP[y _ ->] /=; rewrite FTtypeJ. +have tiHW1: H :&: W1 = 1%g := coprime_TIg coHW1. +have sUH: U \subset H; last split=> //. + have [ntH _ /andP[sHL nHL] regHL] := Frobenius_kerP frobL. + have regHE E: gval E != 1%g -> E \subset L -> H :&: E = 1%g -> 'C_H(E) = 1%g. + move=> ntE sEL tiHE; apply: contraNeq ntE => /trivgPn[x /setIP[Hx cEx] ntx]. + rewrite -subG1 -tiHE subsetIidr (subset_trans _ (regHL x _)) ?inE ?ntx //. + by rewrite subsetI sEL sub_cent1. + suffices /trivgPn[x /setIP[Hx Ux] ntx]: H :&: U != 1%g. + apply: subset_trans (regHL x _); last by rewrite !inE ntx. + by rewrite subsetI sUL sub_cent1 (subsetP cUU). + apply: contraNneq (ntH) => tiHU; rewrite trivg_card1. + have [nHU nHW1] := (subset_trans sUL nHL, subset_trans sW1L nHL). + have nHUW1: U <*> W1 \subset 'N(H) by rewrite join_subG nHU. + have coHUW1: coprime #|H| #|U <*> W1|. + have [/eqP defUW1 _] := andP frobUW1. + rewrite (sdprodWY defUW1) -(sdprod_card defUW1) coprime_mulr coHW1 andbT. + have defHU: H ><| U = H <*> U by rewrite sdprodEY. + rewrite (coprime_sdprod_Hall_l defHU). + apply: pHall_Hall (pHall_subl (joing_subl _ _) _ (Fcore_Hall L)). + by rewrite join_subG sHL. + have [_ _] := Frobenius_Wielandt_fixpoint frobUW1 nHUW1 coHUW1 solH. + by move->; rewrite regHE // cards1 exp1n. +have [E sW1E frobHE]: exists2 E, W1 \subset gval E & [Frobenius L = H ><| E]. + have [E frobHE] := existsP frobL; have [/eqP defL _] := andP frobHE. + have hallE: \pi(H)^'.-Hall(L) E. + by rewrite -(compl_pHall E (Fcore_Hall L)) sdprod_compl. + have [|x Lx sW1Ex] := Hall_subJ (mmax_sol maxL) hallE sW1L. + by rewrite /pgroup -coprime_pi' ?cardG_gt0. + rewrite -(FrobeniusJ x) conjGid // (normsP (gFnorm _ _)) // in frobHE. + by exists (E :^ x)%G. +have [defL ntH ntE _ _] := Frobenius_context frobHE. +have [_ sEL _ nHE _] := sdprod_context defL. +have solE := solvableS sEL (mmax_sol maxL). +have [regHE regEH] := (Frobenius_reg_ker frobHE, Frobenius_reg_compl frobHE). +have qW1: q.-group W1 by apply: pnat_id. +have cycEr (r : nat) R: r.-group R -> R \subset E -> cyclic R. + move=> rR sRE; have nHR := subset_trans sRE nHE. + apply: odd_regular_pgroup_cyclic rR (mFT_odd _) ntH nHR _. + by move=> y /setD1P[nty Ry]; rewrite regHE // !inE nty (subsetP sRE). +have /normal_norm nW1E: W1 <| E. + exact: prime_odd_regular_normal (mFT_odd E) _ _ _ (Frobenius_reg_ker frobHE). +have defNW1: Q ><| W2 = 'N(W1). + by have [] := FTtypeP_norm_cent_compl maxT TtypeP. +have [nsQN sW2N _ _ _] := sdprod_context defNW1. +have sylQ: q.-Sylow('N(W1)) Q. + rewrite /pHall normal_sub // abelem_pgroup //=. + by rewrite -(index_sdprod defNW1) pnatE //= !inE eq_sym. +have hallW2: q^'.-Hall('N(W1)) W2 by rewrite -(compl_pHall _ sylQ) sdprod_compl. +pose Q1 := Q :&: E; have sylQ1: q.-Sylow(E) Q1 by apply: setI_normal_Hall nW1E. +have defQ1: Q1 = W1. + have abelQ1: q.-abelem Q1 := abelemS (subsetIl Q E) abelQ. + have sW1Q: W1 \subset Q by have [_ _ _ []] := TtypeP. + have sW1Q1: W1 \subset Q1 by apply/subsetIP. + have ntQ1: Q1 != 1%g by apply: subG1_contra ntW1. + apply/esym/eqP; rewrite eqEcard sW1Q1 (cyclic_abelem_prime abelQ1) //=. + by rewrite (cycEr q) ?(pHall_pgroup sylQ1) ?subsetIr. +have [P2 hallP2] := Hall_exists q^' solE; have [sP2E q'P2 _] := and3P hallP2. +have defE: W1 ><| P2 = E. + apply/(sdprod_normal_p'HallP _ hallP2); rewrite /= -defQ1 //. + by rewrite /Q1 setIC norm_normalI // (subset_trans nW1E) ?normal_norm. +have [P2_1 | ntP2] := eqsVneq P2 1%g. + by left; rewrite -defE P2_1 sdprodg1 in defL. +have solNW1: solvable 'N(W1). + by rewrite mFT_sol ?mFT_norm_proper // mFT_sol_proper (solvableS sW1E). +have [zy /=] := Hall_subJ solNW1 hallW2 (subset_trans sP2E nW1E) q'P2. +rewrite -{1}(sdprodWC defNW1) => /mulsgP[z y W2z Qy ->{zy}]. +rewrite conjsgM (conjGid W2z) {z W2z} => sP2W2y. +right; exists y => //; congr (_ ><| _ = _): defL. +rewrite -(sdprodWY defE); congr (W1 <*> _). +by apply/eqP; rewrite eqEsubset sP2W2y prime_meetG ?cardJg ?(setIidPr _). +Qed. + +Local Notation Imu2 := (primeTI_Iirr ptiWS). +Local Notation mu2_ i j := (primeTIirr ptiWS i j). + +Definition FTtypeP_bridge j := 'Ind[S, P <*> W1] 1 - mu2_ 0 j. +Local Notation beta_ := FTtypeP_bridge. +Definition FTtypeP_bridge_gap := tau (beta_ #1) - 1 + eta_ 0 #1. +Local Notation Gamma := FTtypeP_bridge_gap. + +Let u := #|U|. + +(* This is Peterfalvi (13.18). *) +(* Part (d) is stated with a slightly weaker hypothesis that fits better with *) +(* the usage pattern in (13.19) and (14.9). *) +Lemma FTtypeP_bridge_facts (V_S := class_support (cyclicTIset defW) S) : + [/\ (*a*) [/\ forall j, j != 0 -> beta_ j \in 'CF(S, 'A0(S)) + & forall j, j != 0 -> beta_ j \in 'CF(S, P^# :|: V_S)], + (*b*) forall j, j != 0 -> '[beta_ j] = (u.-1 %/ q + 2)%:R, + (*c*) [/\ forall j, j != 0 -> tau (beta_ j) - 1 + eta_ 0 j = Gamma, + '[Gamma, 1] = 0 & cfReal Gamma], + (*d*) forall X Y : 'CF(G), + Gamma = X + Y -> '[X, Y] = 0 -> + orthogonal Y (map sigma (irr W)) -> + '[Y] <= (u.-1 %/ q)%:R + & q %| u.-1]. +Proof. +have [_ sW1S _ nPUW1 tiPUW1] := sdprod_context defS. +have /mulG_sub[sPPU sUPU] := sdprodW defPU. +have sPW1S: P <*> W1 \subset S by rewrite join_subG gFsub. +have /= defS_P := Ptype_Fcore_sdprod StypeP; have nsPS: P <| S := gFnormal _ _. +have defPW1: P ><| W1 = P <*> W1 := sdprod_subr defS_P (joing_subr U W1). +pose W1bar := (W1 / P)%g; pose Sbar := (S / P)%g; pose Ubar := (U / P)%g. +pose gamma := 'Ind[Sbar, W1bar] 1. +have Dgamma: 'Ind[S, P <*> W1] 1 = (gamma %% P)%CF. + rewrite -(rmorph1 _ : 1 %% P = 1)%CF cfIndMod ?joing_subl //. + by rewrite quotientYidl //; have [] := sdprodP defPW1. +have gamma1: gamma 1%g = u%:R. + rewrite -cfMod1 -Dgamma cfInd1 // cfun11 -divgS // -(sdprod_card defPW1). + by rewrite mulr1 -(sdprod_card defS) -(sdprod_card defPU) divnMr // mulKn. +have frobUW1: [Frobenius U <*> W1 = U ><| W1] by have [[]] := Sfacts. +have q_dv_u1: q %| u.-1 := Frobenius_dvd_ker1 frobUW1. +have [nP_UW1 /isomP[/=]] := sdprod_isom defS_P; set h := restrm _ _ => injh hS. +have /joing_sub[sUUW1 sW1UW1] := erefl (U <*> W1). +have [hU hW1]: h @* U = Ubar /\ h @* W1 = W1bar. + by rewrite !morphim_restrm /= !(setIidPr _). +have{hS} frobSbar: [Frobenius Sbar = Ubar ><| W1bar]. + by rewrite -[Sbar]hS -hU -hW1 injm_Frobenius. +have tiW1bar: normedTI W1bar^# Sbar W1bar by have /and3P[] := frobSbar. +have gammaW1 xbar: xbar \in W1bar^# -> gamma xbar = 1. + move=> W1xbar; have [ntxbar _] := setD1P W1xbar. + rewrite cfIndE ?quotientS //; apply: canLR (mulKf (neq0CG _)) _. + have ->: #|W1bar| = #|Sbar :&: W1bar| by rewrite (setIidPr _) ?quotientS. + rewrite mulr1 cardsE -sumr_const big_mkcondr; apply: eq_bigr => zbar Szbar. + have [_ _ W1bar_xJ] := normedTI_memJ_P tiW1bar. + by rewrite -mulrb -(W1bar_xJ xbar) // !inE conjg_eq1 ntxbar cfun1E. +have PVSbeta j: j != 0 -> beta_ j \in 'CF(S, P^# :|: V_S). + move=> nzj; apply/cfun_onP=> z; rewrite !inE => /norP[P'z VS'z]. + have [Sz | /cfun0->//] := boolP (z \in S); apply/eqP; rewrite !cfunE subr_eq0. + have [[_ mulW12 _ tiW12] C1] := (dprodP defW, FTtypeP_reg_Fcore maxS StypeP). + have [PUz {VS'z} | PU'z {P'z}] := boolP (z \in PU). + rewrite eq_sym -(cfResE _ _ PUz) ?gFsub // -['Res _](scalerK (neq0CG W1)). + rewrite cfRes_prTIirr -cfRes_prTIred -/q cfunE cfResE ?gFsub // mulrC. + case/nandP: P'z => [/negbNE/eqP-> | P'z]. + rewrite Dgamma cfModE // morph1 gamma1 FTprTIred1 // C1 indexg1. + by rewrite natrM mulfK ?neq0CG. + have:= seqInd_on (Fitting_normal S) (FTprTIred_Ind_Fitting maxS StypeP nzj). + have [/= <- _ _ _] := typeP_context StypeP; rewrite C1 dprodg1 -/(mu_ j). + move/cfun_on0->; rewrite // mul0r (cfun_on0 (cfInd_on _ (cfun_onG _))) //. + rewrite -(sdprodW defPW1); apply: contra P'z => /imset2P[x t PW1x St Dz]. + rewrite Dz !memJ_norm ?(subsetP (gFnorm _ _)) // in PUz *. + by rewrite -(mulg1 P) -tiPUW1 setIC group_modl // inE PW1x. + have /imset2P[x t /setD1P[ntx W1x] St ->]: z \in class_support W1^# S. + have /bigcupP[_ /rcosetsP[x W1x ->]]: z \in cover (rcosets PU W1). + by rewrite (cover_partition (rcosets_partition_mul _ _)) (sdprodW defS). + have [-> | ntx] := eqVneq x 1%g; first by rewrite mulg1 => /idPn[]. + have nPUx: x \in 'N(PU) by rewrite (subsetP nPUW1). + have coPUx: coprime #|PU| #[x] by rewrite (coprime_dvdr (order_dvdG W1x)). + have [/cover_partition <- _] := partition_cent_rcoset nPUx coPUx. + have [_ _ _ [_ _ _ _ prPUW1] _] := StypeP; rewrite {}prPUW1 ?inE ?ntx //. + rewrite cover_imset => /bigcupP[t PUt /imsetP[_ /rcosetP[y W2y ->] Dz]]. + have{PUt} St: t \in S by rewrite (subsetP _ _ PUt) ?der_sub. + have [y1 | nty] := eqVneq y 1%g. + by rewrite Dz y1 mul1g memJ_class_support // !inE ntx. + rewrite Dz memJ_class_support // !inE groupMr // groupMl // in VS'z. + rewrite -(dprodWC defW) mem_mulg // andbT; apply/norP. + by rewrite -!in_set1 -set1gE -tiW12 !inE W1x W2y andbT in ntx nty. + rewrite !cfunJ // Dgamma cfModE ?(subsetP sW1S) // gammaW1; last first. + by rewrite !inE (morph_injm_eq1 injh) ?(subsetP sW1UW1) ?ntx ?mem_quotient. + rewrite prTIirr_id ?FTprTIsign // ?scale1r ?dprod_IirrEr; last first. + rewrite -in_set1 -set1gE -tiW12 inE W1x /= in ntx. + by rewrite inE ntx -mulW12 (subsetP (mulG_subl W2 W1)). + by rewrite -[x]mulg1 cfDprodEr ?lin_char1 ?irr_prime_lin. +have A0beta j: j != 0 -> beta_ j \in 'CF(S, 'A0(S)). + move/PVSbeta; apply: cfun_onS; rewrite (FTtypeP_supp0_def _ StypeP) //. + by rewrite setSU ?(subset_trans _ (FTsupp1_sub _)) ?setSD ?Fcore_sub_FTcore. +have norm_beta j: j != 0 -> '[beta_ j] = (u.-1 %/ q + 2)%:R. + move=> nzj; rewrite cfnormBd ?Dgamma; last first. + apply: contraNeq (cfker_prTIres pddS nzj); rewrite -irr_consttE => S1_mu0j. + rewrite -(cfRes_prTIirr _ 0) sub_cfker_Res //. + rewrite (subset_trans _ (cfker_constt _ S1_mu0j)) ?cfker_mod //. + by rewrite -Dgamma cfInd_char ?rpred1. + have [[/eqP defUW1 _] [/eqP defSbar _]] := (andP frobUW1, andP frobSbar). + rewrite cfnorm_irr cfMod_iso //. + rewrite (cfnormE (cfInd_on _ (cfun_onG _))) ?quotientS // -/gamma. + rewrite card_quotient ?gFnorm // -(index_sdprod defS_P) -(sdprod_card defUW1). + rewrite -/u -/q (big_setD1 1%g) ?mem_class_support ?group1 //=. + have{tiW1bar} [_ tiW1bar /eqP defNW1bar] := and3P tiW1bar. + rewrite gamma1 normr_nat class_supportD1 big_trivIset //=. + rewrite (eq_bigr (fun xbar => #|W1bar|.-1%:R)) ?sumr_const; last first. + rewrite (cardsD1 1%g) group1 /= => _ /imsetP[tbar Stbar ->]. + rewrite -sumr_const big_imset /=; last exact: in2W (conjg_inj tbar). + by apply: eq_bigr => xbar W1xbar; rewrite cfunJ ?gammaW1 // normr1 expr1n. + rewrite card_conjugates -divgS ?subsetIl //= -(sdprod_card defSbar) defNW1bar. + rewrite mulnK ?cardG_gt0 // -hU -hW1 ?card_injm // -/q -/u natrM invfM mulrC. + rewrite -[rhs in _ ^+ 2 + rhs]mulr_natr -mulrDl mulrA mulfK ?neq0CG //. + rewrite -subn1 natrB ?cardG_gt0 // addrCA mulrDl divff ?neq0CG //. + by rewrite -natrB ?cardG_gt0 // subn1 -natf_div // addrAC addrC natrD. +have nzj1: #1 != 0 :> Iirr W2 by apply: Iirr1_neq0. +have [_ _ _ _ [_ Dtau]] := Sfacts; pose eta01 := eta_ 0 #1. +have oeta01_1: '[eta01, 1] = 0. + by rewrite -(cycTIiso1 ctiWG) -(cycTIirr00 defW) cfdot_cycTIiso (negPf nzj1). +have Deta01s: eta01^*%CF = eta_ 0 (conjC_Iirr #1). + by rewrite cfAut_cycTIiso /w_ !dprod_IirrEr cfAutDprodr aut_IirrE. +have oGamma1: '[Gamma, 1] = 0. + rewrite cfdotDl cfdotBl cfnorm1 oeta01_1 addr0 Dtau ?A0beta //. + rewrite -cfdot_Res_r rmorph1 cfdotBl -cfdot_Res_r rmorph1 cfnorm1. + by rewrite -(prTIirr00 ptiWS) cfdot_prTIirr (negPf nzj1) subr0 subrr. +have defGamma j: j != 0 -> tau (beta_ j) - 1 + eta_ 0 j = Gamma. + move=> nzj; apply/eqP; rewrite -subr_eq0 opprD addrACA opprB !addrA subrK. + rewrite -linearB opprD addrACA subrr add0r -opprD linearN /=. + move/prDade_sub_TIirr: pddS => -> //; last first. + by apply: (mulfI (neq0CG W1)); rewrite -!prTIred_1 !FTprTIred1. + by rewrite -/sigma FTprTIsign // scale1r -addrA addNr. +have GammaReal: cfReal Gamma. + rewrite /cfReal rmorphD rmorphB rmorph1 /= Deta01s Dtau ?A0beta // cfAutInd. + rewrite rmorphB /= cfAutInd rmorph1 -prTIirr_aut aut_Iirr0 -/(beta_ _). + by rewrite -Dtau ?A0beta ?defGamma ?aut_Iirr_eq0. +split=> // X Y defXY oXY oYeta; pose a := '[Gamma, eta01]. +have Za: a \in Cint. + rewrite Cint_cfdot_vchar ?(rpredB, rpredD, rpred1, cycTIiso_vchar) //. + by rewrite Dtau ?A0beta // !(cfInd_vchar, rpredB) ?rpred1 ?irr_vchar. +have{oYeta} oYeta j: '[Y, eta_ 0 j] = 0. + by rewrite (orthoPl oYeta) ?map_f ?mem_irr. +have o_eta1s1: '[eta01^*, eta01] = 0. + rewrite Deta01s cfdot_cycTIiso /= -(inj_eq irr_inj) aut_IirrE. + by rewrite odd_eq_conj_irr1 ?mFT_odd // irr_eq1 (negPf nzj1). +rewrite -(ler_add2r 2%:R) -natrD -(norm_beta #1) //. +have ->: '[beta_ #1] = '[Gamma - eta01 + 1]. + by rewrite addrK subrK Dade_isometry ?A0beta. +rewrite addrA cfnormDd ?cfnorm1 ?ler_add2r; last first. + by rewrite cfdotBl oeta01_1 oGamma1 subrr. +rewrite defXY addrAC addrC cfnormDd ?ler_add2r; last first. + by rewrite cfdotBl oXY cfdotC oYeta conjC0 subrr. +have oXeta j: '[X, eta_ 0 j] = '[Gamma, eta_ 0 j]. + by rewrite defXY cfdotDl oYeta addr0. +pose X1 := X - a *: eta01 - a *: eta01^*%CF. +have ->: X - eta01 = X1 + a *: eta01^*%CF + (a - 1) *: eta01. + by rewrite scalerBl scale1r addrA !subrK. +rewrite cfnormDd; last first. + rewrite cfdotZr subrK cfdotBl oXeta -/a cfdotZl cfnorm_cycTIiso mulr1. + by rewrite subrr mulr0. +rewrite cfnormDd; last first. + rewrite cfdotZr !cfdotBl !cfdotZl Deta01s cfnorm_cycTIiso oXeta -Deta01s. + rewrite !cfdot_conjCr o_eta1s1 conjC0 mulr0 ((_ =P Gamma) GammaReal) -/a. + by rewrite conj_Cint // mulr1 subr0 subrr mulr0. +rewrite -addrA ler_paddl ?cfnorm_ge0 // !cfnormZ Deta01s !cfnorm_cycTIiso. +rewrite !mulr1 !Cint_normK ?rpredB ?rpred1 // sqrrB1 !addrA -mulr2n. +by rewrite -subr_ge0 addrK subr_ge0 ler_pmuln2r ?Cint_ler_sqr. +Qed. + +(* The assumptions of Peterfalvi (13.19). *) +(* We do not need to put these in a subsection as this is the last Lemma. *) +Variable L : {group gT}. +Hypotheses (maxL : L \in 'M) (Ltype1 : FTtype L == 1%N). + +Local Notation "` 'L'" := (gval L) (at level 0, only parsing) : group_scope. +Local Notation H := `L`_\F%G. +Local Notation "` 'H'" := `L`_\F (at level 0) : group_scope. + +Let e := #|L : H|. +Let tauL := FT_DadeF maxL. +Let calL := seqIndD H L H 1. + +Let frobL : [Frobenius L with kernel H]. Proof. exact: FTtype1_Frobenius. Qed. + +(* The coherence part of the preamble of (13.19). *) +Lemma FTtype1_coherence : coherent calL L^# tauL. +Proof. +have [_ [tau1 [IZtau1 Dtau1]]] := FT_Frobenius_coherence maxL frobL. +exists tau1; split=> // phi Sphi; rewrite ?Dtau1 //. +move/(zcharD1_seqInd_on (Fcore_normal _)) in Sphi. +by rewrite /tauL FT_DadeF_E ?FT_DadeE ?(cfun_onS (Fcore_sub_FTsupp _)). +Qed. + +Lemma FTtype1_Ind_irr : {subset calL <= irr L}. +Proof. by case: (FT_Frobenius_coherence maxL frobL). Qed. +Let irrL := FTtype1_Ind_irr. + +(* We re-quantify over the witnesses so that the main part of the lemma can *) +(* be used for Section variables in the very last part of Section 14. *) +Variables (tau1 : {additive 'CF(L) -> 'CF(G)}) (phi : 'CF(L)). +Hypothesis cohL : coherent_with calL L^# tauL tau1. +Hypotheses (Lphi : phi \in calL) (phi1e : phi 1%g = e%:R). + +Let betaL := 'Ind[L, H] 1 - phi. +Let betaS := beta_ #1. +Let eta01 := eta_ 0 #1. + +(* This is Peterfalvi (13.19). *) +Lemma FTtypeI_bridge_facts : + [/\ (*a*) 'A~(L) :&: (class_support P G :|: class_support W G) = set0, + (*b*) orthogonal (map tau1 calL) (map sigma (irr W)), + (*c*) forall j, j != 0 -> '[tauL betaL, eta_ 0 j] = '[tauL betaL, eta01] + & (*c1*) ('[tau betaS, tau1 phi] == 1 %[mod 2])%C + /\ #|H|.-1%:R / e%:R <= (u.-1 %/ q)%:R :> algC + \/ (*c2*) ('[tauL betaL, eta01] == 1 %[mod 2])%C /\ (p <= e)%N]. +Proof. +have nsHL: H <| L := gFnormal _ L; have [sHL nHL] := andP nsHL. +have coHr T r: T \in 'M -> FTtype T != 1%N -> r.-abelem T`_\F -> coprime #|H| r. + move=> maxT notTtype1 /andP[rR _]. + have [_ _ [n oR]] := pgroup_pdiv rR (mmax_Fcore_neq1 maxT). + rewrite -(coprime_pexpr _ r (ltn0Sn n)) -oR /= -FTcore_type1 //. + apply: coprimegS (Fcore_sub_FTcore maxT) _. + have [_ -> //] := FT_Dade_support_partition gT. + by apply: contra notTtype1 => /imsetP[y _ ->] /=; rewrite FTtypeJ. +have coHp: coprime #|H| p by apply: (coHr S) => //; have [_ []] := Sfacts. +have{coHr} coHq: coprime #|H| q. + have [T pairST [xdefW [V TtypeP]]] := FTtypeP_pair_witness maxS StypeP. + have [[_ _ maxT] _ _ _ _] := pairST; have Ttype'1 := FTtypeP_neq1 maxT TtypeP. + by rewrite (coHr T) ?Ttype'1 //; have [_ []] := FTtypeP_facts maxT TtypeP. +have defA: 'A(L) = H^# := FTsupp_Frobenius maxL frobL. +set PWG := class_support P G :|: class_support W G. +have tiA_PWG: 'A~(L) :&: PWG = set0. + apply/setP=> x; rewrite !inE; apply/andP=> [[Ax PWGx]]. + suffices{Ax}: \pi(H)^'.-elt x. + have [y Ay /imset2P[_ t /rcosetP[z Rz ->] _ ->]] := bigcupP Ax => H'zyt. + do [rewrite -def_FTsignalizer //; set ddL := FT_Dade_hyp maxL] in Rz. + have /setD1P[nty Hy]: y \in H^# by rewrite -defA. + have /idPn[]: (z * y).`_\pi('C_H[y]) == 1%g. + rewrite (constt1P _) // -(p_eltJ _ _ t); apply: sub_in_pnat H'zyt => r _. + by apply: contra; apply: piSg; apply: subsetIl. + rewrite consttM; last first. + exact: cent1P (subsetP (Dade_signalizer_cent _ y) z Rz). + rewrite (constt1P (mem_p_elt _ Rz)) ?mul1g; last first. + rewrite /pgroup -coprime_pi' ?cardG_gt0 // coprime_sym. + by rewrite (coprimegS _ (Dade_coprime _ Ay Ay)) ?setSI. + by rewrite (constt_p_elt (mem_p_elt (pgroup_pi _) _)) // inE Hy cent1id. + suffices /pnat_dvd: #[x] %| #|P| * #|W|. + have [_ [_ ->] _ _ _] := Sfacts; rewrite -(dprod_card defW) -/p -/q. + by apply; rewrite !pnat_mul pnat_exp -!coprime_pi' ?cardG_gt0 ?coHp ?coHq. + case/orP: PWGx => /imset2P[y z PWy _ ->]; rewrite {z}orderJ. + by rewrite dvdn_mulr ?order_dvdG. + by rewrite dvdn_mull ?order_dvdG. +have ZsubL psi: psi \in calL -> psi - psi^*%CF \in 'Z[calL, L^#]. + have ZcalL: {subset calL <= 'Z[irr L]} by apply: seqInd_vcharW. + by move=> Lpsi; rewrite sub_aut_zchar ?zchar_onG ?mem_zchar ?cfAut_seqInd. +have mem_eta j: eta_ 0 j \in map sigma (irr W) by rewrite map_f ?mem_irr. +have otau1eta: orthogonal (map tau1 calL) (map sigma (irr W)). + apply/orthogonalP=> _ _ /mapP[psi Lpsi ->] /mapP[w irr_w ->]. + have{w irr_w} [i [j ->]] := cycTIirrP defW irr_w; rewrite -/(w_ i j). + pose Psi := tau1 (psi - psi^*%CF); pose NC := cyclicTI_NC ctiWG. + have [[Itau1 Ztau1] Dtau1] := cohL. + have Lpsis: psi^*%CF \in calL by rewrite cfAut_seqInd. + have Z1dpsi := ZsubL _ Lpsi; have Zdpsi := zcharW Z1dpsi. + have{Dtau1} PsiV0: {in V, Psi =1 \0}. + move=> x /setDP[Wx _]; rewrite /Psi Dtau1 ?(cfun_on0 (Dade_cfunS _ _)) //. + rewrite FT_DadeF_supportE -defA; apply: contra_eqN tiA_PWG => Ax. + by apply/set0Pn; exists x; rewrite !inE Ax orbC mem_class_support. + have opsi: '[psi, psi^*] = 0 by apply: seqInd_conjC_ortho (mFT_odd _) _ Lpsi. + have n2Psi: '[Psi] = 2%:R. + by rewrite Itau1 ?cfnormBd // cfnorm_conjC ?irrWnorm ?irrL. + have NC_Psi: (NC Psi < minn q p)%N. + by rewrite (@leq_ltn_trans 2) ?leq_min ?qgt2 // cycTI_NC_norm ?Ztau1 ?n2Psi. + apply: contraTeq (NC_Psi) => t1psi_eta; rewrite -leqNgt cycTI_NC_minn //. + rewrite mul2n -addnn (leq_trans NC_Psi) ?leq_addl // andbT card_gt0. + suffices [b Deta]: exists b : bool, eta_ i j = (-1) ^+ b *: tau1 psi. + apply/set0Pn; exists (i, j); rewrite !inE /= /Psi raddfB cfdotBl {2}Deta. + by rewrite cfdotZr Itau1 ?mem_zchar // cfdot_conjCl opsi conjC0 mulr0 subr0. + exists (tau1 psi == - eta_ i j); apply: (canRL (signrZK _)). + move/eqP: t1psi_eta; rewrite cfdot_dirr ?cycTIiso_dirr //; last first. + by rewrite dirrE Itau1 ?Ztau1 ?mem_zchar //= irrWnorm ?irrL. + by rewrite scaler_sign; do 2!case: eqP => //. +have [[A0beta PVbeta] n2beta [defGa Ga1 R_Ga] ubGa dvu] := FTtypeP_bridge_facts. +have [_ _ _ _ [_ Dtau]] := Sfacts. +have o_tauL_S zeta j: j != 0 -> '[tauL zeta, tau (beta_ j)] = 0. + move=> nzj; pose ABS := class_support (P^# :|: class_support V S) G. + have ABSbeta: tau (beta_ j) \in 'CF(G, ABS). + by rewrite Dtau ?A0beta // cfInd_on ?subsetT ?PVbeta. + have{ABSbeta} PWGbeta: tau (beta_ j) \in 'CF(G, PWG). + apply: cfun_onS ABSbeta; apply/subsetP=> _ /imset2P[x t PVSx _ ->]. + case/setUP: PVSx => [/setD1P[_ Px] | /imset2P[y z /setDP[Wy _] _ ->]]. + by rewrite inE memJ_class_support ?inE. + by rewrite -conjgM inE orbC memJ_class_support ?inE. + rewrite (cfdotElr (Dade_cfunS _ _) PWGbeta) big_pred0 ?mulr0 // => x. + by rewrite FT_DadeF_supportE -defA tiA_PWG inE. +have betaLeta j: j != 0 -> '[tauL betaL, eta_ 0 j] = '[tauL betaL, eta01]. + move=> nzj; apply/eqP; rewrite -subr_eq0 -cfdotBr. + rewrite (canRL (addKr _) (defGa j nzj)) !addrA addrK -addrA addrCA. + by rewrite opprD subrK cfdotBr !o_tauL_S ?subrr ?Iirr1_neq0. +split=> //; have [[[Itau1 Ztau1] Dtau1] irr_phi] := (cohL, irrL Lphi). +pose GammaL := tauL betaL - (1 - tau1 phi). +have DbetaL: tauL betaL = 1 - tau1 phi + GammaL by rewrite addrC subrK. +have RealGammaL: cfReal GammaL. + rewrite /cfReal -subr_eq0 !rmorphB rmorph1 /= !opprB !addrA subrK addrC. + rewrite -addrA addrCA addrA addr_eq0 opprB -Dade_aut -linearB /= -/tauL. + rewrite rmorphB /= cfAutInd rmorph1 addrC opprB addrA subrK. + by rewrite (cfConjC_Dade_coherent cohL) ?mFT_odd // -raddfB Dtau1 // ZsubL. +have:= Dade_Ind1_sub_lin cohL _ irr_phi Lphi; rewrite -/betaL -/tauL -/calL. +rewrite (seqInd_nontrivial _ _ _ irr_phi) ?odd_Frobenius_index_ler ?mFT_odd //. +case=> // -[o_tauL_1 o_betaL_1 ZbetaL] ub_betaL _. +have{o_tauL_1 o_betaL_1} o_GaL_1: '[GammaL, 1] = 0. + by rewrite !cfdotBl cfnorm1 o_betaL_1 (orthoPr o_tauL_1) ?map_f ?subr0 ?subrr. +have Zt1phi: tau1 phi \in 'Z[irr G] by rewrite Ztau1 ?mem_zchar. +have Zeta01: eta01 \in 'Z[irr G] by apply: cycTIiso_vchar. +have ZbetaS: tau betaS \in 'Z[irr G]. + rewrite Dade_vchar // zchar_split A0beta ?Iirr1_neq0 //. + by rewrite rpredB ?irr_vchar ?cfInd_vchar ?rpred1. +have Z_Ga: Gamma \in 'Z[irr G] by rewrite rpredD ?rpredB ?rpred1. +have Z_GaL: GammaL \in 'Z[irr G] by rewrite !rpredB ?rpred1. +have{RealGammaL} Gamma_even: (2 %| '[GammaL, Gamma])%C. + by rewrite cfdot_real_vchar_even ?mFT_odd // o_GaL_1 (dvdC_nat 2 0). +set bSphi := '[tau betaS, tau1 phi]; set bLeta := '[tauL betaL, eta01]. +have [ZbSphi ZbLeta]: bSphi \in Cint /\ bLeta \in Cint. + by rewrite !Cint_cfdot_vchar. +have{Gamma_even} odd_bSphi_bLeta: (bSphi + bLeta == 1 %[mod 2])%C. + rewrite -(conj_Cint ZbSphi) -cfdotC /bLeta DbetaL cfdotDl cfdotBl. + have: '[tauL betaL, tau betaS] == 0 by rewrite o_tauL_S ?Iirr1_neq0. + have ->: tau betaS = 1 - eta01 + Gamma by rewrite addrCA !addrA !subrK. + rewrite !['[tau1 _, _]]cfdotDr 2!cfdotDr !cfdotNr DbetaL. + rewrite 2!cfdotDl 2!['[_, eta01]]cfdotDl 2!['[_, Gamma]]cfdotDl !cfdotNl. + rewrite cfnorm1 o_GaL_1 ['[1, Gamma]]cfdotC Ga1 conjC0 addr0 add0r. + have ->: 1 = eta_ 0 0 by rewrite /w_ cycTIirr00 cycTIiso1. + rewrite cfdot_cycTIiso mulrb ifN_eqC ?Iirr1_neq0 // add0r. + rewrite 2?(orthogonalP otau1eta _ _ (map_f _ _) (mem_eta _)) // oppr0 !add0r. + by rewrite addr0 addrA addrC addr_eq0 !opprB addrA /eqCmod => /eqP <-. +have abs_mod2 a: a \in Cint -> {b : bool | a == b%:R %[mod 2]}%C. + move=> Za; pose n := truncC `|a|; exists (odd n). + apply: eqCmod_trans (eqCmod_addl_mul _ (rpred_nat _ n./2) _). + rewrite addrC -natrM -natrD muln2 odd_double_half truncCK ?Cnat_norm_Cint //. + rewrite -{1}[a]mul1r -(canLR (signrMK _) (CintEsign Za)) eqCmodMr // signrE. + by rewrite /eqCmod opprB addrC subrK dvdC_nat dvdn2 odd_double. +have [[bL DbL] [bS DbS]] := (abs_mod2 _ ZbLeta, abs_mod2 _ ZbSphi). +have{odd_bSphi_bLeta} xor_bS_bL: bS (+) bL. + rewrite eqCmod_sym in odd_bSphi_bLeta. + have:= eqCmod_trans odd_bSphi_bLeta (eqCmodD DbS DbL). + rewrite -natrD eqCmod_sym -(eqCmodDr _ 1) -mulrSr => xor_bS_bL. + have:= eqCmod_trans xor_bS_bL (eqCmodm0 _); rewrite /eqCmod subr0. + by rewrite (dvdC_nat 2 _.+1) dvdn2 /= negbK odd_add !oddb; case: (_ (+) _). +have ?: (0 != 1 %[mod 2])%C by rewrite eqCmod_sym /eqCmod subr0 (dvdC_nat 2 1). +case is_c1: bS; [left | right]. + rewrite is_c1 in DbS; split=> //. + pose a_ (psi : 'CF(L)) := psi 1%g / e%:R. + have Na_ psi: psi \in calL -> a_ psi \in Cnat by apply: dvd_index_seqInd1. + have [X tau1X [D [dGa oXD oDtau1]]] := orthogonal_split (map tau1 calL) Gamma. + have oo_L: orthonormal calL. + by apply: sub_orthonormal (irr_orthonormal L); rewrite ?seqInd_uniq. + have oo_tau1L: orthonormal (map tau1 calL) by apply: map_orthonormal. + have defX: X = bSphi *: (\sum_(psi <- calL) a_ psi *: tau1 psi). + have [_ -> defX] := orthonormal_span oo_tau1L tau1X. + rewrite defX big_map scaler_sumr; apply: eq_big_seq => psi Lpsi. + rewrite scalerA; congr (_ *: _); apply/eqP; rewrite -subr_eq0 mulrC. + rewrite -[X](addrK D) -dGa cfdotBl (orthoPl oDtau1) ?map_f // subr0. + rewrite cfdotC cfdotDr cfdotBr -/betaS -/eta01. + have ->: 1 = eta_ 0 0 by rewrite /w_ cycTIirr00 cycTIiso1. + rewrite 2?(orthogonalP otau1eta _ _ (map_f _ _) (mem_eta _)) // subrK. + rewrite -cfdotC -(conj_Cnat (Na_ _ Lpsi)) -cfdotZr -cfdotBr. + rewrite -raddfZ_Cnat ?Na_ // -raddfB cfdotC. + rewrite Dtau1; last by rewrite zcharD1_seqInd ?seqInd_sub_lin_vchar. + by rewrite o_tauL_S ?Iirr1_neq0 ?conjC0. + have nz_bSphi: bSphi != 0 by apply: contraTneq DbS => ->. + have ub_a: \sum_(psi <- calL) a_ psi ^+ 2 <= (u.-1 %/ q)%:R. + apply: ler_trans (ubGa D X _ _ _); first 1 last; first by rewrite addrC. + - by rewrite cfdotC oXD conjC0. + - apply/orthoPl=> eta Weta; rewrite (span_orthogonal otau1eta) //. + exact: memv_span. + rewrite defX cfnormZ cfnorm_sum_orthonormal // mulr_sumr !big_seq. + apply: ler_sum => psi Lpsi; rewrite -{1}(norm_Cnat (Na_ _ _)) //. + by rewrite ler_pemull ?exprn_ge0 ?normr_ge0 // Cint_normK // sqr_Cint_ge1. + congr (_ <= _): ub_a; do 2!apply: (mulIf (neq0CiG L H)); rewrite -/e. + rewrite divfK ?neq0CiG // -mulrA -expr2 mulr_suml. + rewrite -subn1 natrB ?neq0CG // -indexg1 mulrC. + rewrite -(sum_seqIndD_square nsHL) ?normal1 ?sub1G // -/calL. + apply: eq_big_seq => psi Lpsi; rewrite irrWnorm ?irrL // divr1. + by rewrite -exprMn divfK ?neq0CiG. +rewrite is_c1 /= in xor_bS_bL; rewrite xor_bS_bL in DbL; split=> //. +have nz_bL: bLeta != 0 by apply: contraTneq DbL => ->. +have{ub_betaL} [X [otau1X oX1 [a Za defX]] [//|_ ubX]] := ub_betaL. +rewrite -/e in defX; rewrite -leC_nat -(ler_add2r (-1)); apply: ler_trans ubX. +pose calX0 := [seq w_ 0 j | j in predC1 0]. +have ooX0: orthonormal calX0. + apply: sub_orthonormal (irr_orthonormal W). + by move=> _ /imageP[j _ ->]; apply: mem_irr. + by apply/dinjectiveP=> j1 j2 _ _ /irr_inj/dprod_Iirr_inj[]. +have Isigma: {in 'Z[calX0] &, isometry sigma}. + by apply: in2W; apply: cycTIisometry. +rewrite -[X](subrK (bLeta *: (\sum_(xi <- calX0) sigma xi))). +rewrite cfnormDd ?ler_paddl ?cfnorm_ge0 //; last first. + rewrite cfdotZr cfdot_sumr big1_seq ?mulr0 // => xi X0xi. + apply/eqP; rewrite cfdotBl scaler_sumr cfproj_sum_orthonormal // subr_eq0. + have {xi X0xi}[j nzj ->] := imageP X0xi; rewrite inE /= in nzj. + rewrite -[bLeta](betaLeta j nzj) defX cfdotDl -addrA cfdotDl. + have ->: 1 = eta_ 0 0 by rewrite /w_ cycTIirr00 cycTIiso1. + rewrite cfdot_cycTIiso mulrb (ifN_eqC _ _ nzj) add0r eq_sym -subr_eq0 addrK. + rewrite (span_orthogonal otau1eta) //; last by rewrite memv_span ?mem_eta. + rewrite big_seq rpredD ?(rpredN, rpredZ, rpred_sum) ?memv_span ?map_f //. + by move=> xi Lxi; rewrite rpredZ ?memv_span ?map_f. +rewrite cfnormZ cfnorm_map_orthonormal // size_image cardC1 nirrW2. +rewrite -(natrB _ (prime_gt0 pr_p)) Cint_normK // subn1. +by rewrite ler_pemull ?ler0n ?sqr_Cint_ge1. +Qed. + +End Thirteen_17_to_19. + +End Thirteen. + diff --git a/mathcomp/odd_order/PFsection14.v b/mathcomp/odd_order/PFsection14.v new file mode 100644 index 0000000..bd7ae60 --- /dev/null +++ b/mathcomp/odd_order/PFsection14.v @@ -0,0 +1,1257 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime binomial ssralg poly finset. +Require Import fingroup morphism perm automorphism quotient action finalg zmodp. +Require Import gfunctor gproduct center cyclic commutator gseries nilpotent. +Require Import pgroup sylow hall abelian maximal frobenius. +Require Import matrix mxalgebra mxrepresentation mxabelem vector. +Require Import BGsection1 BGsection3 BGsection7. +Require Import BGsection14 BGsection15 BGsection16 BGappendixC. +Require Import ssrnum rat algC cyclotomic algnum. +Require Import classfun character integral_char inertia vcharacter. +Require Import PFsection1 PFsection2 PFsection3 PFsection4. +Require Import PFsection5 PFsection6 PFsection7 PFsection8 PFsection9. +Require Import PFsection10 PFsection11 PFsection12 PFsection13. + +(******************************************************************************) +(* This file covers Peterfalvi, Section 14: Non_existence of G. *) +(* It completes the proof of the Odd Order theorem. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory FinRing.Theory Num.Theory. + +Section Fourteen. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). +Implicit Types (p q : nat) (x y z : gT). +Implicit Types H K L N P Q R S T U W : {group gT}. + +Local Notation "#1" := (inord 1) (at level 0). + +(* Supplementary results that apply to both S and T, but that are not *) +(* formally stated as such; T, V, L, tau1L and phi are only used at the end *) +(* of this section, to state and prove FTtype2_support_coherence. *) +Section MoreSTlemmas. + +Local Open Scope ring_scope. +Variables W W1 W2 S T U V L : {group gT}. +Variables (tau1L : {additive 'CF(L) -> 'CF(G)}) (phi : 'CF(L)). + +(* Implicit (dependent) forward assuptions. *) +Hypotheses (defW : W1 \x W2 = W) (xdefW : W2 \x W1 = W) (maxL : L \in 'M). + +Local Notation "` 'S'" := (gval S) (at level 0, only parsing) : group_scope. +Local Notation P := `S`_\F%G. +Local Notation "` 'P'" := `S`_\F (at level 0) : group_scope. +Local Notation PU := S^`(1)%G. +Local Notation "` 'PU'" := `S^`(1)%g (at level 0) : group_scope. +Local Notation "` 'L'" := (gval L) (at level 0, only parsing). +Local Notation H := `L`_\F%G. +Local Notation "` 'H'" := `L`_\F%g (at level 0, format "` 'H'") : group_scope. + +Let p := #|W2|. +Let q := #|W1|. +Let u := #|U|. +Let v := #|V|. +Let h := #|H|. +Let e := #|L : H|. +Let ccG A := class_support A G. + +Let calL := seqIndD H L H 1. +Let betaL := 'Ind[L, H] 1 - phi. +Local Notation tauL := (FT_DadeF maxL). + +(* Explicit (non-dependent) forward assumptions. *) +Hypotheses (StypeP : of_typeP S U defW) (TtypeP : of_typeP T V xdefW). +Hypothesis (cohL : coherent_with calL L^# tauL tau1L) (Lphi : phi \in calL). + +(* The remaining assumptions can be generated as backchaining gools. *) +Hypotheses (maxS : S \in 'M) (maxT : T \in 'M). + +Let pddS := FT_prDade_hypF maxS StypeP. +Let pddT := FT_prDade_hypF maxT TtypeP. +Let ctiWG : cyclicTI_hypothesis G defW := pddS. +Let sigma := cyclicTIiso ctiWG. +Let w_ i j := cyclicTIirr defW i j. + +(* An inequality used in the proof of (14.11.4), at the bottom of page 90, to *) +(* show that 1/uq and 1/vp are less that 1/2q^2 (so Wn is either W1 or W2). *) +Lemma FTtypeP_complV_ltr (Wn : {group gT}) : + (#|Wn| <= q)%N -> (u * q)%:R^-1 < (2 * #|Wn| ^ 2)%:R^-1 :> algC. +Proof. +move=> leWn_q; rewrite !natrM ltf_pinv ?rpredM ?qualifE ?gt0CG ?ltr0n //. +rewrite -!natrM ltr_nat (@leq_ltn_trans (2 * q ^ 2)) ?mulnA ?leq_mul // mul2n. +have: [Frobenius U <*> W1 = U ><| W1] by have [[]] := FTtypeP_facts maxS StypeP. +by move/ltn_odd_Frobenius_ker/implyP; rewrite mFT_odd ltn_pmul2r ?cardG_gt0. +Qed. + +(* This formalizes the loose symmetry used in (14.11.3) to show that #[g] is *) +(* coprime to pq. *) +Lemma coprime_typeP_Galois_core g : + typeP_Galois StypeP -> g \notin ccG W^# -> g \notin ccG P^# -> coprime #[g] p. +Proof. +move=> galS W'g; apply: contraR => p_g. +have ntg: g != 1%g by apply: contraNneq p_g => ->; rewrite order1 coprime1n. +have [pr_q pr_p]: prime q /\ prime p := FTtypeP_primes maxS StypeP. +have [[_ hallW1 _ defS] [_ _ _ defPU] _ [_ _ sW2P _ regPUW1] _] := StypeP. +have coPUq: coprime #|PU| q by rewrite (coprime_sdprod_Hall_r defS). +have [[_ _ nPUW1 _] [_ _ nPU _]] := (sdprodP defS, sdprodP defPU). +have ntP: P :!=: 1%g := mmax_Fcore_neq1 maxS. +have frobPU: [Frobenius PU = P ><| U]. + have notS5 := FTtype5_exclusion maxS. + have inN1 x: x \in 'N(1) by rewrite norm1 inE. + have [_ ntU _ _] := compl_of_typeII_IV maxS StypeP notS5. + have [] := typeP_Galois_P maxS notS5 galS; rewrite Ptype_factor_prime //. + rewrite (group_inj (Ptype_Fcore_kernel_trivial _ _)) // => F [fP [fU _]]. + rewrite Ptype_Fcompl_kernel_trivial //. + case=> /trivgP injfU fJ [_ /isomP[injfP _] _] _. + apply/Frobenius_semiregularP=> // y /setD1P[nty Uy]. + apply/trivgP/subsetP=> x /setIP[Px /cent1P-cxy]; apply: contraR nty. + rewrite -(morph_injm_eq1 injfU) // -val_eqE -(cosetpre1 1) !(inN1, inE) /=. + rewrite -(morph_injm_eq1 injfP) ?mem_quotient //= => /mulfI/inj_eq <-. + rewrite mulr1 -[_ * _]fJ ?mem_quotient //= qactE ?dom_qactJ //=. + by rewrite conjgE cxy mulKg. +have pP: p.-group P by have [_ [/andP[]]] := FTtypeP_facts _ StypeP. +have{p_g}[y [a P1a cagy]]: exists y, exists2 a, a \in P^# & g ^ y \in 'C[a]. + have sylP: p.-Sylow(G) P. + have [/Hall_pi/= hallP _ _] := FTcore_facts maxS; apply: etrans hallP. + have [_ _ [n ->]] := pgroup_pdiv pP (mmax_Fcore_neq1 maxS). + by apply/eq_pHall => r1; rewrite pi_of_exp ?pi_of_prime. + have [y _ Pa] := Sylow_Jsub sylP (subsetT _) (p_elt_constt p g). + pose a := g.`_p ^ y; have{Pa} Pa: a \in P by rewrite -cycle_subG cycleJ. + exists y, a; last by rewrite cent1C /a conjXg groupX ?cent1id. + rewrite !inE conjg_eq1 (contraNneq _ p_g) // => /constt1P/p'nat_coprime-> //. + exact: pnat_id. +have /(mem_sdprod defS)[x [w [PUx W1w Dgy _]]]: g ^ y \in S. + have A0a: a \in 'A0(S) := subsetP (Fcore_sub_FTsupp0 maxS) a P1a. + have [_ _ _ _ [tiA0 _]] := FTtypeP_facts _ StypeP. + by rewrite (subsetP (cent1_normedTI tiA0 A0a)) // 2!inE. +suffices w_eq1: w = 1%g. + have sCaP: 'C_PU[a] \subset P := Frobenius_cent1_ker frobPU P1a. + rewrite -[g](conjgK y) mem_imset2 ?inE //= conjg_eq1 ntg /=. + by rewrite (subsetP sCaP) // inE cagy Dgy w_eq1 mulg1 PUx. +apply: contraNeq W'g => ntw; have nPUw := subsetP nPUW1 w W1w. +have{x PUx Dgy} /imset2P[x z W2w_x _ Dgy]: g ^ y \in class_support (W2 :* w) PU. + rewrite -(regPUW1 w) ?inE ?ntw // class_supportEr -cover_imset. + have coPUw := coprime_dvdr (order_dvdG W1w) coPUq. + have [/cover_partition-> _] := partition_cent_rcoset nPUw coPUw. + by rewrite Dgy mem_rcoset mulgK. +rewrite -[g](conjgK (y * z^-1)%g) mem_imset2 ?inE //= conjg_eq1 ntg /= conjgM. +by rewrite Dgy conjgK -(dprodWC defW) -[x](mulgKV w) mem_mulg -?mem_rcoset. +Qed. + +Hypothesis Stype2 : FTtype S == 2. + +(* This is used to bound #|ccG P^#| and #|ccG Q^#| in the proof of (14.11.4). *) +Lemma FTtype2_cc_core_ler : #|G|%:R^-1 * #|ccG P^#|%:R <= (u * q)%:R^-1 :> algC. +Proof. +have ->: (u * q)%:R^-1 = #|S|%:R^-1 * #|P|%:R :> algC. + have [[_ _ _ /sdprod_card <-] [_ _ _ /sdprod_card <-] _ _ _] := StypeP. + by rewrite mulrC -mulnA [in RHS]natrM invfM mulVKf ?neq0CG. +have [_ _] := FTtypeII_ker_TI maxS Stype2; rewrite FTsupp1_type2 // => tiP1. +rewrite {tiP1}(card_support_normedTI tiP1) natrM natf_indexg ?subsetT //. +rewrite mulrCA mulKf ?neq0CG // mulrC ler_pmul2l ?invr_gt0 ?gt0CG // leC_nat. +by rewrite cardsDS ?sub1G ?leq_subr. +Qed. + +Hypotheses (maxNU_L : L \in 'M('N(U))) (phi1 : phi 1%g = e%:R). + +(* This is Peterfalvi (14.11.2), stated for S and L rather than T and M; it *) +(* is loosely used in this form at the very end of the proof of (14.16). *) +Lemma FTtype2_support_coherence : + (u.-1 %/ q < h.-1 %/ e)%N -> (v.-1 %/ p < h.-1 %/ e)%N -> + [/\ e = (p * q)%N + & exists nb, exists2 chi, chi = tau1L phi \/ chi = - tau1L phi^*%CF + & tauL betaL = \sum_ij (-1)^+ nb ij *: sigma 'chi_ij - chi]. +Proof. +move=> ub_u ub_v; have nsHL : H <| L := gFnormal _ _. +have pairST := of_typeP_pair maxS StypeP maxT TtypeP. +have [//|frobL sUH defL] := FTtypeII_support_facts maxS StypeP _ pairST maxNU_L. +have Ltype1 := FT_Frobenius_type1 maxL frobL. +have irr_phi: phi \in irr L by apply: FTtype1_Ind_irr Lphi. +have betaL_P := FTtypeI_bridge_facts _ _ Ltype1 cohL Lphi phi1. +have e_dv_h1: e %| h.-1 by apply: Frobenius_ker_dvd_ker1. +pose a i j := '[tauL betaL, sigma (w_ i j)]. +have a0j j: j != 0 -> (a 0 j == 1 %[mod 2])%C. + rewrite /a => nz_j; case/betaL_P: StypeP => _ _ -> //. + by case=> [[_ /idPn[]] | [//]]; rewrite -natf_div // leC_nat -ltnNge. +have ai0 i: i != 0 -> (a i 0 == 1 %[mod 2])%C. + rewrite /a (cycTIisoC _ pddT) => nz_i; case/betaL_P: TtypeP => _ _ -> //. + by case=> [[_ /idPn[]] | [//]]; rewrite -natf_div // leC_nat -ltnNge. +have HbetaL: betaL \in 'CF(L, H^#) by apply: cfInd1_sub_lin_on Lphi phi1. +have betaL_W_0: {in cyclicTIset defW, tauL betaL =1 \0}. + move=> z; case/betaL_P: StypeP => tiAM_W _ _ _. + rewrite !inE -(setCK W) inE => /andP[_]; apply: cfun_onP z. + apply: cfun_onS (Dade_cfunS _ _); rewrite FT_DadeF_supportE -disjoints_subset. + rewrite -FTsupp_Frobenius // -setI_eq0 -subset0 -tiAM_W setIS //. + by rewrite setUC subsetU ?sub_class_support. +have calL_gt1: (1 < size calL)%N. + by apply: seqInd_nontrivial Lphi; rewrite ?mFT_odd. +have [] := Dade_Ind1_sub_lin cohL calL_gt1 irr_phi Lphi phi1; rewrite -/betaL. +rewrite -/calL odd_Frobenius_index_ler ?mFT_odd //= -/e -/h. +case=> _ a00 ZbetaL [Gamma [o_tau1_Ga o_1_Ga [aa Zaa Dbeta] []// _ ubGa _]]. +have{a00} a00: a 0 0 = 1 by rewrite /a /w_ cycTIirr00 cycTIiso1. +have{a0j ai0} a_odd i j: (a i j == 1 %[mod 2])%C. + have [[-> | /ai0 ai01] [-> | /a0j a0j1] //] := (eqVneq i 0, eqVneq j 0). + by rewrite a00 (eqCmod_nat 2 1 1). + by rewrite -(eqCmodDr _ 1) -{1}a00 cycTIiso_cfdot_exchange // eqCmodD. +have [_ o_tauLeta _ _] := FTtypeI_bridge_facts _ StypeP Ltype1 cohL Lphi phi1. +pose etaW := map sigma (irr W). +have o1eta: orthonormal etaW := cycTIiso_orthonormal _. +have [X etaX [Y [defGa oXY oYeta]]] := orthogonal_split etaW (Gamma + 1). +have lbY: 0 <= '[Y] ?= iff (Y == 0). + by split; rewrite ?cfnorm_ge0 // eq_sym cfnorm_eq0. +have [b Db defX] := orthonormal_span o1eta etaX. +do [rewrite addrC !addrA addrAC -addrA; set Z := _ - _] in Dbeta. +have oZeta: orthogonal Z etaW. + apply/orthoPl=> xi /memv_span; apply: {xi}(span_orthogonal o_tauLeta). + rewrite rpredB ?rpredZ ?big_seq ?rpred_sum ?memv_span ?map_f // => xi Lxi. + by rewrite rpredZ ?memv_span ?map_f. +have lb_b ij (b_ij := b (sigma 'chi_ij)): + 1 <= `|b_ij| ^+ 2 ?= iff [exists n : bool, b_ij == (-1) ^+ n]. +- have /codomP[[i j] Dij] := dprod_Iirr_onto defW ij. + have{b_ij} ->: b_ij = a i j. + rewrite /a /w_ -Dij Dbeta defGa 2!cfdotDl. + have ->: '[X, sigma 'chi_ij] = b_ij by rewrite /b_ij Db. + by rewrite (orthoPl oYeta) ?(orthoPl oZeta) ?map_f ?mem_irr // !addr0. + have Zaij: a i j \in Cint by rewrite Cint_cfdot_vchar ?cycTIiso_vchar. + rewrite Cint_normK //; split. + rewrite sqr_Cint_ge1 //; apply: contraTneq (a_odd i j) => ->. + by rewrite (eqCmod_nat 2 0 1). + apply/eqP/exists_eqP=> [a2_1|[n ->]]; last by rewrite sqrr_sign. + rewrite (CintEsign Zaij) normC_def conj_Cint // -expr2 -a2_1 sqrtC1 mulr1. + by exists (a i j < 0). +have ub_e: e%:R <= #|Iirr W|%:R ?= iff (e == p * q)%N :> algC. + rewrite lerif_nat card_Iirr_cyclic //; last by have [] := ctiWG. + rewrite -(dprod_card xdefW); apply: leqif_eq. + case: defL => [|[y Qy]] defL; rewrite /e -(index_sdprod defL). + by rewrite leq_pmull ?cardG_gt0. + suffices /normP <-: y \in 'N(W1). + by rewrite -conjYg !cardJg (dprodWY defW) -(dprod_card xdefW). + have cQQ: abelian T`_\F by have [_ [/and3P[]]] := FTtypeP_facts maxT TtypeP. + have sW1Q: W1 \subset T`_\F by have [_ _ _ []] := TtypeP. + by rewrite (subsetP _ y Qy) // sub_abelian_norm. +have /(_ predT) := lerif_add (lerif_sum (in1W lb_b)) lbY. +rewrite sumr_const addr0 => /(lerif_trans ub_e)/ger_lerif/esym. +have ->: \sum_i `|b (sigma 'chi_i)| ^+ 2 = '[X]. + rewrite defX cfnorm_sum_orthonormal // big_map (big_nth 0) big_mkord. + by rewrite size_tuple; apply: eq_bigr => ij _; rewrite -tnth_nth. +rewrite -cfnormDd // -defGa cfnormDd // cfnorm1 -ler_subr_addr ubGa. +case/and3P=> /eqP-De /'forall_exists_eqP/fin_all_exists[/= n Dn] /eqP-Y0. +pose chi := X - tauL betaL; split=> //; exists n, chi; last first. + apply: canRL (addrK _) _; rewrite addrC subrK defX big_map (big_nth 0). + by rewrite big_mkord size_tuple; apply: eq_bigr => ij; rewrite -tnth_nth Dn. +have Z1chi: chi \in dirr G. + rewrite dirrE rpredB //=; last first. + rewrite defX big_map (big_nth 0) big_mkord size_tuple rpred_sum //= => ij. + have [_ Zsigma] := cycTI_Zisometry ctiWG. + by rewrite -tnth_nth Dn rpredZsign ?Zsigma ?irr_vchar. + apply/eqP/(addIr '[X]); rewrite -cfnormBd; last first. + rewrite /chi Dbeta defGa Y0 addr0 opprD addNKr cfdotNl. + by rewrite (span_orthogonal oZeta) ?oppr0 // memv_span ?mem_head. + rewrite addrAC subrr add0r cfnormN Dade_isometry // cfnormBd; last first. + by rewrite cfdotC (seqInd_ortho_Ind1 _ _ Lphi) ?conjC0. + rewrite cfnorm_Ind_cfun1 // -/e irrWnorm // addrC; congr (1 + _). + rewrite defX cfnorm_sum_orthonormal // big_map big_tuple. + rewrite De (dprod_card xdefW) -card_Iirr_cyclic //; last by have[]:= ctiWG. + by rewrite -sumr_const; apply: eq_bigr => ij _; rewrite Dn normr_sign expr1n. +have [[Itau1 Ztau1] Dtau1] := cohL. +suffices /cfdot_add_dirr_eq1: '[tau1L phi - tau1L phi^*%CF, chi] = 1. + rewrite -(cfConjC_Dade_coherent cohL) ?mFT_odd // rpredN dirr_aut. + by apply; rewrite // dirrE Ztau1 ?Itau1 ?mem_zchar ?irrWnorm /=. +rewrite cfdotBr (span_orthogonal o_tauLeta) ?add0r //; last first. + by rewrite rpredB ?memv_span ?map_f ?cfAut_seqInd. +have Zdphi := seqInd_sub_aut_zchar nsHL conjC Lphi. +rewrite -raddfB Dtau1 ?zcharD1_seqInd // Dade_isometry ?(zchar_on Zdphi) //. +rewrite cfdotBr !cfdotBl cfdot_conjCl cfAutInd rmorph1 irrWnorm //. +rewrite (seqInd_ortho_Ind1 _ _ Lphi) // conjC0 subrr add0r opprK. +by rewrite cfdot_conjCl (seqInd_conjC_ortho _ _ _ Lphi) ?mFT_odd ?conjC0 ?subr0. +Qed. + +End MoreSTlemmas. + +Section NonconjType1. +(* Properties of non-conjugate type I groups, used symmetrically for L and M *) +(* in the proofs of (14.14) and (14.16). *) + +Local Open Scope ring_scope. +Variables (M L : {group gT}) (phi : 'CF(L)) (psi : 'CF(M)). +Variable (tau1L : {additive 'CF(L) -> 'CF(G)}). +Variable (tau1M : {additive 'CF(M) -> 'CF(G)}). +Hypotheses (maxL : L \in 'M) (maxM : M \in 'M). +Let ddL := FT_DadeF_hyp maxL. +Let ddM := FT_DadeF_hyp maxM. +Let tauL := Dade ddL. +Let tauM := Dade ddM. +Let H := L`_\F%G. +Let K := M`_\F%G. +Let calL := seqIndD H L H 1. +Let calM := seqIndD K M K 1. +Let u : algC := #|L : H|%:R. +Let v : algC := #|M : K|%:R. +Let betaL := 'Ind[L, H] 1 - phi. +Let a := '[tauL betaL, tau1M psi]. + +Hypothesis (cohL : coherent_with calL L^# tauL tau1L). +Hypothesis (cohM : coherent_with calM M^# tauM tau1M). +Hypotheses (Lphi : phi \in calL) (Mpsi : psi \in calM). +Hypotheses (phi1 : phi 1%g = u) (psi1 : psi 1%g = v). +Hypotheses (Ltype1 : FTtype L == 1%N) (Mtype1 : FTtype M == 1%N). +Hypothesis not_MG_L : gval L \notin M :^: G. + +Let irrL := FTtype1_Ind_irr maxL Ltype1. +Let irrM := FTtype1_Ind_irr maxM Mtype1. + +Lemma disjoint_Dade_FTtype1 : [disjoint Dade_support ddM & Dade_support ddL]. +Proof. +by rewrite !FT_DadeF_supportE -!FTsupp1_type1 ?FT_Dade1_support_disjoint. +Qed. +Let TItauML := disjoint_Dade_FTtype1. + +Lemma coherent_FTtype1_ortho : orthogonal (map tau1M calM) (map tau1L calL). +Proof. +apply/orthogonalP=> _ _ /mapP[xiM Mxi ->] /mapP[xiL Lxi ->]. +have [irrLxi irrMxi] := (irrL Lxi, irrM Mxi). +exact: (disjoint_coherent_ortho (mFT_odd _) _ cohM cohL). +Qed. +Let oML := coherent_FTtype1_ortho. + +(* This is the inequality used in both branches of (14.14). *) +Lemma coherent_FTtype1_core_ltr : a != 0 -> #|K|.-1%:R / v <= u - 1. +Proof. +have [nsHL nsKM]: H <| L /\ K <| M by rewrite !gFnormal. +have [irr_phi irr_psi] := (irrL Lphi, irrM Mpsi). +have frobL: [Frobenius L with kernel H] := FTtype1_Frobenius maxL Ltype1. +have [[Itau1 Ztau1] Dtau1] := cohM. +have o1M: orthonormal (map tau1M calM). + apply: map_orthonormal Itau1 _. + exact: sub_orthonormal (undup_uniq _) (irr_orthonormal M). +have Lgt1: (1 < size calL)%N by apply: seqInd_nontrivial (mFT_odd _ ) _ _ Lphi. +have [[_ _]] := Dade_Ind1_sub_lin cohL Lgt1 irr_phi Lphi phi1. +rewrite -/tauL -/betaL -/calL => ZbetaL [Gamma [_ _ [b _ Dbeta]]]. +rewrite odd_Frobenius_index_ler ?mFT_odd // -/u => -[]// [_ ub_Ga] _ nz_a. +have Za: a \in Cint by rewrite Cint_cfdot_vchar // ?Ztau1 ?mem_zchar. +have [X M_X [Del [defGa oXD oDM]]] := orthogonal_split (map tau1M calM) Gamma. +apply: ler_trans ub_Ga; rewrite defGa cfnormDd // ler_paddr ?cfnorm_ge0 //. +suffices ->: '[X] = (a / v) ^+ 2 * (\sum_(xi <- calM) xi 1%g ^+ 2 / '[xi]). + rewrite sum_seqIndC1_square // -(natrB _ (cardG_gt0 K)) subn1. + rewrite exprMn !mulrA divfK ?neq0CiG // mulrAC -mulrA. + by rewrite ler_pemull ?sqr_Cint_ge1 // divr_ge0 ?ler0n. +have [_ -> defX] := orthonormal_span o1M M_X. +have Mgt1: (1 < size calM)%N by apply: seqInd_nontrivial (mFT_odd _ ) _ _ Mpsi. +have [[oM1 _ _] _ _] := Dade_Ind1_sub_lin cohM Mgt1 irr_psi Mpsi psi1. +rewrite exprMn -(Cint_normK Za) -[v]normr_nat -normfV -/v mulr_sumr. +rewrite defX cfnorm_sum_orthonormal // big_map; apply: eq_big_seq => xi Mxi. +have Zxi1 := Cint_seqInd1 Mxi; rewrite -(Cint_normK Zxi1) -(conj_Cint Zxi1). +rewrite irrWnorm ?irrM // divr1 -!exprMn -!normrM; congr (`|_| ^+ 2). +rewrite -mulrA mulrC -mulrA; apply: canRL (mulKf (neq0CiG _ _)) _. +rewrite -(canLR (addrK _) defGa) cfdotBl (orthoPl oDM) ?map_f // subr0. +rewrite -(canLR (addKr _) Dbeta) cfdotDl cfdotNl cfdotC cfdotDr cfdotBr. +rewrite (orthoPr oM1) ?map_f // (orthogonalP oML) ?map_f // subrr add0r. +rewrite cfdotZr cfdot_sumr big1_seq ?mulr0 ?oppr0 => [|nu Mnu]; last first. + by rewrite cfdotZr (orthogonalP oML) ?map_f ?mulr0. +apply/eqP; rewrite conjC0 oppr0 add0r -subr_eq0 -conjC_nat -!cfdotZr. +rewrite -raddfZnat -raddfZ_Cint // -cfdotBr -raddfB -/v -psi1. +rewrite Dtau1 ?zcharD1_seqInd ?sub_seqInd_zchar //. +rewrite (cfdotElr (Dade_cfunS _ _) (Dade_cfunS _ _)) setIC. +by have:= TItauML; rewrite -setI_eq0 => /eqP->; rewrite big_set0 mulr0. +Qed. + +End NonconjType1. + +(* This is the context associated with Hypothesis (13.1). *) +Variables S T U V W W1 W2 : {group gT}. +Hypotheses (defW : W1 \x W2 = W) (xdefW : W2 \x W1 = W). +Hypotheses (pairST : typeP_pair S T defW) (maxS : S \in 'M) (maxT : T \in 'M). +Hypotheses (StypeP : of_typeP S U defW) (TtypeP : of_typeP T V xdefW). + +Local Notation "` 'W1'" := (gval W1) (at level 0, only parsing) : group_scope. +Local Notation "` 'W2'" := (gval W2) (at level 0, only parsing) : group_scope. +Local Notation "` 'W'" := (gval W) (at level 0, only parsing) : group_scope. +Local Notation What := (cyclicTIset defW). + +Local Notation "` 'S'" := (gval S) (at level 0, only parsing) : group_scope. +Local Notation P := `S`_\F%G. +Local Notation "` 'P'" := `S`_\F (at level 0) : group_scope. +Local Notation PU := S^`(1)%G. +Local Notation "` 'PU'" := `S^`(1) (at level 0) : group_scope. +Local Notation "` 'U'" := (gval U) (at level 0, only parsing) : group_scope. + +Local Notation "` 'T'" := (gval T) (at level 0, only parsing) : group_scope. +Local Notation Q := `T`_\F%G. +Local Notation "` 'Q'" := `T`_\F (at level 0) : group_scope. +Local Notation QV := T^`(1)%G. +Local Notation "` 'QV'" := `T^`(1) (at level 0) : group_scope. +Local Notation "` 'V'" := (gval V) (at level 0, only parsing) : group_scope. + +Let defS : PU ><| W1 = S. Proof. by have [[]] := StypeP. Qed. +Let defPU : P ><| U = PU. Proof. by have [_ []] := StypeP. Qed. + +Let defT : QV ><| W2 = T. Proof. by have [[]] := TtypeP. Qed. +Let defQV : Q ><| V = QV. Proof. by have [_ []] := TtypeP. Qed. + +Let notStype1 : FTtype S != 1%N. Proof. exact: FTtypeP_neq1 StypeP. Qed. +Let notStype5 : FTtype S != 5%N. Proof. exact: FTtype5_exclusion maxS. Qed. + +Let pddS := FT_prDade_hypF maxS StypeP. +Let ptiWS : primeTI_hypothesis S PU defW := FT_primeTI_hyp StypeP. +Let ctiWG : cyclicTI_hypothesis G defW := pddS. + +Let pddT := FT_prDade_hypF maxT TtypeP. +Let ptiWT : primeTI_hypothesis T QV xdefW := FT_primeTI_hyp TtypeP. + +Let ntW1 : W1 :!=: 1. Proof. by have [[]] := StypeP. Qed. +Let ntW2 : W2 :!=: 1. Proof. by have [_ _ _ []] := StypeP. Qed. +Let cycW1 : cyclic W1. Proof. by have [[]] := StypeP. Qed. +Let cycW2 : cyclic W2. Proof. by have [_ _ _ []] := StypeP. Qed. + +Let p := #|W2|. +Let q := #|W1|. +Let u := #|U|. +Let v := #|V|. +Let nU := (p ^ q).-1 %/ p.-1. +Let nV := (q ^ p).-1 %/ q.-1. + +Let pr_p : prime p. Proof. by have [] := FTtypeP_primes maxS StypeP. Qed. +Let pr_q : prime q. Proof. by have [] := FTtypeP_primes maxS StypeP. Qed. + +Local Open Scope ring_scope. + +Let qgt2 : (q > 2)%N. Proof. by rewrite odd_gt2 ?mFT_odd ?cardG_gt1. Qed. +Let pgt2 : (p > 2)%N. Proof. by rewrite odd_gt2 ?mFT_odd ?cardG_gt1. Qed. + +Let coPUq : coprime #|PU| q. +Proof. by rewrite (coprime_sdprod_Hall_r defS); have [[]] := StypeP. Qed. + +Let nirrW1 : #|Iirr W1| = q. Proof. by rewrite card_Iirr_cyclic. Qed. +Let nirrW2 : #|Iirr W2| = p. Proof. by rewrite card_Iirr_cyclic. Qed. +Let NirrW1 : Nirr W1 = q. Proof. by rewrite -nirrW1 card_ord. Qed. +Let NirrW2 : Nirr W2 = p. Proof. by rewrite -nirrW2 card_ord. Qed. + +Let sigma := (cyclicTIiso ctiWG). +Let w_ i j := (cyclicTIirr defW i j). +Local Notation eta_ i j := (sigma (w_ i j)). + +Local Notation Imu2 := (primeTI_Iirr ptiWS). +Let mu2_ i j := primeTIirr ptiWS i j. +Let mu_ := primeTIred ptiWS. +Local Notation chi_ j := (primeTIres ptiWS j). + +Local Notation Inu2 := (primeTI_Iirr ptiWT). +Let nu2_ i j := primeTIirr ptiWT j i. +Let nu_ := primeTIred ptiWT. + +Local Notation tauS := (FT_Dade0 maxS). +Local Notation tauT := (FT_Dade0 maxT). + +Let calS0 := seqIndD PU S S`_\s 1. +Let rmR_S := FTtypeP_coh_base maxS StypeP. +Let scohS0 : subcoherent calS0 tauS rmR_S. +Proof. exact: FTtypeP_subcoherent StypeP. Qed. + +Let calS := seqIndD PU S P 1. +Let sSS0 : cfConjC_subset calS calS0. +Proof. exact/seqInd_conjC_subset1/Fcore_sub_FTcore. Qed. + +Let calT := seqIndD QV T Q 1. + +(* This is Hypothesis (14.1). *) +Hypothesis ltqp: (q < p)%N. + +(* This corresponds to Peterfalvi, Theorem (14.2). *) +(* As we import the conclusion of BGappendixC, which covers Appendix C of the *) +(* Bender and Glauberman text, we can state this theorem negatively. This *) +(* will avoid having to repeat its statement thoughout the proof : we will *) +(* simply end each nested set of assumptions (corresponding to (14.3) and *) +(* (14.10)) with a contradiction. *) +Theorem no_full_FT_Galois_structure : + ~ [/\ (*a*) exists Fpq : finFieldImage P W2 U, + [/\ #|P| = (p ^ q)%N, #|U| = nU & coprime nU p.-1] + & (*b*) [/\ q.-abelem Q, W2 \subset 'N(Q) + & exists2 y, y \in Q & W2 :^ y \subset 'N(U)]]. +Proof. +case=> [[Fpq [oP oU coUp1]] [abelQ nQW2 nU_W2Q]]. +have /idPn[] := ltqp; rewrite -leqNgt. +exact: (prime_dim_normed_finField _ _ _ defPU) nU_W2Q. +Qed. + +(* Justification for Hypothesis (14.3). *) +Fact FTtypeP_max_typeII : FTtype S == 2. +Proof. by have [[_ ->]] := FTtypeP_facts maxS StypeP. Qed. +Let Stype2 := FTtypeP_max_typeII. + +(* These correspond to Peterfalvi, Hypothesis (14.3). *) +Variables (L : {group gT}) (tau1L : {additive 'CF(L) -> 'CF(G)}) (phi : 'CF(L)). +Local Notation "` 'L'" := (gval L) (at level 0, only parsing). +Local Notation H := `L`_\F%G. +Local Notation "` 'H'" := `L`_\F%g (at level 0, format "` 'H'") : group_scope. + +Hypothesis maxNU_L : L \in 'M('N(U)). + +(* Consequences of the above. *) +Hypotheses (maxL : L \in 'M) (sNUL : 'N(U) \subset L) (sUH : U \subset H). +Hypotheses (frobL : [Frobenius L with kernel H]) (Ltype1 : FTtype L == 1%N). + +Let calL := seqIndD H L H 1. +Local Notation tauL := (FT_DadeF maxL). +Let nsHL : H <| L. Proof. exact: gFnormal. Qed. +Let irrL : {subset calL <= irr L}. Proof. exact: FTtype1_Ind_irr. Qed. + +Hypothesis cohL : coherent_with calL L^# tauL tau1L. +Hypotheses (Lphi : phi \in calL) (phi1 : phi 1%g = #|L : H|%:R). + +Let betaS := FTtypeP_bridge StypeP #1. +Let betaT := FTtypeP_bridge TtypeP #1. +Let betaL := 'Ind[L, H] 1 - phi. + +(* This is the first assertion of Peterfalvi (14.4). *) +Let galT : typeP_Galois TtypeP. +Proof. +apply: contraLR ltqp => /(FTtypeP_nonGalois_facts maxT)[]. +by rewrite -/p -leqNgt => ->. +Qed. + +(* This is the second assertion of Peterfalvi (14.4). *) +Let oV : v = nV. +Proof. +rewrite /v (card_FTtypeP_Galois_compl maxT galT) -/nV. +by rewrite !modn_small ?gtn_eqF // ltnW. +Qed. + +(* This is Peterfalvi (14.5). *) +Let defL : exists2 y, y \in Q & H ><| (W1 <*> W2 :^ y) = L. +Proof. +have [//|_ _ []// defL] := FTtypeII_support_facts maxS StypeP _ pairST maxNU_L. +have [_ _ /negP[]] := compl_of_typeII maxS StypeP Stype2. +have [_ _ _] := FTtypeI_bridge_facts maxS StypeP Ltype1 cohL Lphi phi1. +case=> [[_ ubH] | [_ /idPn[]]]; last by rewrite -(index_sdprod defL) -ltnNge. +have{ubH} /eqP defH: `H == U. + rewrite eq_sym eqEcard sUH /= -(prednK (cardG_gt0 U)) -add1n -leq_subLR subn1. + have [_ _ _ _ /divnK <-] := FTtypeP_bridge_facts maxS StypeP. + by rewrite -leC_nat natrM -ler_pdivr_mulr ?gt0CG // {1}(index_sdprod defL). +rewrite (subset_trans sNUL) // -(sdprodW defL) -(sdprodW defS) mulSg //. +by rewrite -(sdprodW defPU) defH mulG_subr. +Qed. + +Let indexLH : #|L : H| = (p * q)%N. +Proof. +have [y Qy /index_sdprod <-] := defL; rewrite (dprod_card xdefW). +suffices /normP <-: y \in 'N(W1) by rewrite -conjYg cardJg (dprodWY defW). +have cQQ: abelian Q by have [_ [/and3P[]]] := FTtypeP_facts _ TtypeP. +by apply: (subsetP (sub_abelian_norm cQQ _)) => //; have [_ _ _ []] := TtypeP. +Qed. + +(* This is Peterfalvi (14.6). *) +Let galS : typeP_Galois StypeP. +Proof. +apply/idPn=> gal'S; have [q3 oU] := FTtypeP_nonGalois_facts maxS gal'S. +have [H1 [_ _ _ _]] := typeP_Galois_Pn maxS (FTtype5_exclusion maxS) gal'S. +rewrite def_Ptype_factor_prime // Ptype_Fcompl_kernel_trivial // -/p q3 /=. +set a := #|U : _| => [] [a_gt1 a_dv_p1 _ [U1 isoU1]]. +have{isoU1} isoU: U \isog U1 := isog_trans (quotient1_isog U) isoU1. +have{a_gt1 a_dv_p1} defU1: U1 :=: [set: 'rV_2]. + apply/eqP; rewrite eqEcard subsetT -(card_isog isoU) oU. + rewrite cardsT card_matrix card_ord Zp_cast // leq_sqr -/p. + apply: dvdn_leq; first by rewrite -(subnKC pgt2). + rewrite -divn2 -(@Gauss_dvdl a _ 2) ?divnK //. + by rewrite dvdn2 -subn1 odd_sub ?odd_gt0 ?mFT_odd. + by rewrite coprimen2 (dvdn_odd (dvdn_indexg U _)) ?mFT_odd. +have [r pr_r r_r_U] := rank_witness U. +have [R0 sylR0] := Sylow_exists r U; have [sR0U rR0 _] := and3P sylR0. +have [R sylR sR0R] := Sylow_superset (subset_trans sR0U sUH) rR0. +have [sRH rR _] := and3P sylR. +have cUU: abelian U by have [[]] := FTtypeP_facts maxS StypeP. +have tiA0: normedTI 'A0(S) G S by have [_ _ _ _ []] := FTtypeP_facts _ StypeP. +have [_ sUPU _ nPU _] := sdprod_context defPU. +have coPU := coprimegS (joing_subl U W1) (Ptype_Fcore_coprime StypeP). +have abR0: abelian R0 := abelianS sR0U cUU. +have{a U1 defU1 isoU r_r_U} rR0_2: 'r(R0) = 2. + by rewrite (rank_Sylow sylR0) -r_r_U (isog_rank isoU) defU1 rank_mx_group. +have piUr: r \in \pi(U) by rewrite -p_rank_gt0 -(rank_Sylow sylR0) rR0_2. +have /exists_inP[x /setD1P[ntx R0x] ntCPx]: [exists x in R0^#, 'C_P[x] != 1%g]. + have ncycR0: ~~ cyclic R0 by rewrite abelian_rank1_cyclic ?rR0_2. + have coPR0: coprime #|P| #|R0| := coprimegS sR0U coPU. + rewrite -negb_forall_in; apply: contra (mmax_Fcore_neq1 maxS) => regR0P. + rewrite -subG1 -(coprime_abelian_gen_cent1 abR0 _ (subset_trans sR0U nPU)) //. + by rewrite gen_subG; apply/bigcupsP=> x /(eqfun_inP regR0P)->. +have{x ntx R0x ntCPx} sZR_R0: 'Z(R) \subset R0. + have A0x: x \in 'A0(S). + have [z /setIP[Pz cyz] ntz] := trivgPn _ ntCPx. + apply/setUP; left; apply/bigcupP; exists z. + by rewrite !inE ntz (subsetP (Fcore_sub_FTcore maxS)). + by rewrite (eqP Stype2) 3!inE ntx cent1C (subsetP sUPU) ?(subsetP sR0U). + have sCxS: 'C[x] \subset S by rewrite -['C[x]]setTI (cent1_normedTI tiA0). + suffices <-: 'C_R[x] = R0. + by rewrite -cent_set1 setIS ?centS // sub1set (subsetP sR0R). + have /Hall_pi hallU: Hall PU U by rewrite -(coprime_sdprod_Hall_r defPU). + have /Hall_pi hallPU: Hall S PU by rewrite -(coprime_sdprod_Hall_l defS). + have sylR0_S: r.-Sylow(S) R0. + by apply: subHall_Sylow piUr sylR0; apply: subHall_Hall (piSg sUPU) hallU. + rewrite ['C_R[x]](sub_pHall sylR0_S) ?(pgroupS _ rR) ?subsetIl //. + by rewrite subsetI sR0R sub_cent1 (subsetP abR0). + by rewrite subIset ?sCxS ?orbT. +pose R1 := 'Ohm_1('Z(R))%G; pose m := logn r #|R1|. +have sR10: R1 \subset R0 by rewrite (subset_trans (Ohm_sub 1 _)). +have oR1: #|R1| = (r ^ m)%N by rewrite -card_pgroup ?(pgroupS sR10). +have{sZR_R0 rR0_2} m12: pred2 1%N 2 m. + transitivity (0 < m < 1 + 2)%N; first by rewrite -mem_iota !inE. + rewrite -[m]p_rank_abelian ?center_abelian -?rank_pgroup ?(pgroupS sZR_R0) //. + rewrite rank_gt0 ltnS -rR0_2 rankS // center_nil_eq1 ?(pgroup_nil rR) //. + by rewrite (subG1_contra sR0R) // -rank_gt0 rR0_2. +have [y Qy defLy] := defL; have [_ _ /joing_subP[_ nHW2y] _] := sdprodP defLy. +have chR1H: R1 \char H. + apply: char_trans (char_trans (Ohm_char 1 _) (center_char R)) _. + by rewrite (nilpotent_Hall_pcore (Fcore_nil L) sylR) gFchar. +have nR1W2y: W2 :^ y \subset 'N(R1) := char_norm_trans chR1H nHW2y. +have regR1W2y: semiregular R1 (W2 :^ y). + have /Frobenius_reg_ker regHW12y := set_Frobenius_compl defLy frobL. + exact: semiregularS (char_sub chR1H) (joing_subr _ _) regHW12y. +have /idPn[]: r %| p.-1./2. + have:= piUr; rewrite mem_primes => /and3P[_ _ /=]. + by rewrite oU Euclid_dvdX ?andbT. +rewrite gtnNdvd //; first by rewrite -(subnKC pgt2). +apply: leq_trans (_ : p.-1 <= r)%N. + by rewrite -divn2 ltn_divLR // -{1}[p.-1]muln1 -(subnKC pgt2) ltn_pmul2l. +have: p %| (r ^ m).-1. + by have:= regular_norm_dvd_pred nR1W2y regR1W2y; rewrite cardJg oR1. +rewrite -[p.-1]subn1 leq_subLR predn_exp Euclid_dvdM // => /orP[]/dvdn_leq. + by rewrite -(subnKC (prime_gt1 pr_r)) => /implyP/leq_trans->; rewrite 2?ltnW. +move/implyP; case/pred2P: m12 => ->; rewrite !big_ord_recl big_ord0 ?addn0 //=. +by rewrite -(subnKC pgt2). +Qed. + +(* This is Peterfalvi (14.7). *) +Let not_charUH : ~~ (U \char H). +Proof. +have [y Qy defLy] := defL; have [_ _ /joing_subP[_ nHW2y] _] := sdprodP defLy. +apply/negP=> chUH; have nUW2y := char_norm_trans chUH nHW2y. +case: no_full_FT_Galois_structure; split; last first. + split; [by have [_ []] := FTtypeP_facts _ TtypeP | | by exists y]. + by have /sdprodP[_ _ /joing_subP[]] := Ptype_Fcore_sdprod TtypeP. +have <-: #|U| = nU. + have regUW2y: semiregular U (W2 :^ y). + have /Frobenius_reg_ker regHW12y := set_Frobenius_compl defLy frobL. + exact: semiregularS (char_sub chUH) (joing_subr _ _) regHW12y. + case: ifP (card_FTtypeP_Galois_compl maxS galS) => //. + rewrite -/p -/q -/nU => p_modq_1 oU. + have{p_modq_1 oU} oU: (#|U| * q)%N = nU. + by rewrite oU divnK //; have [|_ ->] := FTtypeP_primes_mod_cases _ StypeP. + have /eqP Umodp: #|U| == 1 %[mod p]. + have:= regular_norm_dvd_pred nUW2y regUW2y. + by rewrite cardJg -/p -subn1 eqn_mod_dvd. + have: nU == 1 %[mod p]. + rewrite /nU predn_exp mulKn; last by rewrite -(subnKC pgt2). + rewrite -(ltn_predK qgt2) big_ord_recl addnC -modnDml -modn_summ modnDml. + by rewrite big1 // => i _; rewrite expnS modnMr. + by rewrite -oU -modnMml Umodp modnMml mul1n !modn_small ?gtn_eqF ?prime_gt1. +have [F []] := typeP_Galois_P maxS (FTtype5_exclusion maxS) galS. +rewrite Ptype_factor_prime ?(group_inj (Ptype_Fcore_kernel_trivial _ _)) //. +rewrite Ptype_Fcompl_kernel_trivial // => psiP [psiU _ [/trivgP inj_psiU psiJ]]. +rewrite /= -injm_subcent ?coset1_injm ?norms1 // -morphim_comp -/p. +rewrite (typeP_cent_core_compl StypeP) => [[_ /isomP[inj_psiP im_psiP] psiW2]]. +rewrite -(card_isog (quotient1_isog U)) => [[_ coUp1 _]]. +suffices FPU: finFieldImage P W2 U. + by exists FPU; have [_ []] := FTtypeP_facts maxS StypeP. +have /domP[sig [Dsig Ksig _ im_sig]]: 'dom (psiP \o coset 1) = P. + by apply: injmK; rewrite ?coset1_injm ?norms1. +have{Ksig} inj_sig: 'injm sig by rewrite Ksig injm_comp ?coset1_injm. +exists F sig; first by apply/isomP; rewrite im_sig morphim_comp. + by rewrite -psiW2 -im_sig injmK // -(typeP_cent_core_compl StypeP) subsetIl. +exists psiU => // z x Pz Ux /=; have inN1 x1: x1 \in 'N(1) by rewrite norm1 inE. +by rewrite !Dsig -psiJ ?mem_morphim //= qactE ?dom_qactJ. +Qed. + +(* This is Peterfalvi (14.8)(a). *) +(* In order to avoid the use of real analysis and logarithms we bound the *) +(* binomial expansion of n.+1 ^ q.+1 directly. *) +Let qp1_gt_pq1 : (q ^ p.+1 > p ^ q.+1)%N. +Proof. +have: (4 < p)%N by rewrite odd_geq ?mFT_odd ?(leq_trans _ ltqp). +elim: p ltqp => // n IHn; rewrite !ltnS => ngeq. +rewrite leq_eqVlt => /predU1P[/esym n4 | ngt4]. + suffices /eqP <-: 3 == q by rewrite n4. + by rewrite eqn_leq qgt2 -ltnS -(odd_ltn 5) ?mFT_odd // -n4. +apply: leq_trans (_ : q * n ^ q.+1 <= _)%N; last first. + rewrite (expnS q) leq_mul //. + by move: ngeq; rewrite leq_eqVlt => /predU1P[-> | /IHn/(_ ngt4)/ltnW]. +apply: leq_trans (_ : (2 * q.+1 + n) * n ^ q <= _)%N; last first. + rewrite expnS mulnA leq_mul // addnC. + move: ngeq; rewrite leq_eqVlt => /predU1P[-> | n_gtq]. + apply: leq_trans (_ : 4 * n <= _)%N; last by rewrite leq_mul // ltnW. + by rewrite mulnSr addnA -mulSn (mulSnr 3) leq_add2l 3?ltnW. + by rewrite -{2}(subnKC qgt2) addSn (mulSn _ n) leq_add2l leq_mul. +rewrite mulnDl -expnS -[n.+1]add1n expnDn big_ord_recr binn subnn !mul1n /=. +rewrite ltn_add2r -(@ltn_pmul2l (2 ^ q)) ?expn_gt0 // !mulnA -expnSr. +apply: leq_ltn_trans (_ : (2 ^ q.+1).-1 * q.+1 * n ^ q < _)%N; last first. + by rewrite -(subnKC ngt4) !ltn_pmul2r ?prednK ?expn_gt0. +rewrite -mulnA predn_exp mul1n big_distrr big_distrl leq_sum // => [[i]] /=. +rewrite ltnS exp1n mul1n => leiq _; rewrite -{1 4}(subnKC leiq) !expnD. +rewrite -mulnA leq_mul // mulnA mulnCA mulnC leq_mul // -bin_sub ?leqW //. +rewrite -(leq_pmul2r (fact_gt0 (q.+1 - i))) -mulnA bin_ffact mulnC subSn //. +rewrite ffactnS /= -!mulnA leq_mul //=; elim: {i leiq}(q - i)%N => //= i IHi. +rewrite ffactnSr expnSr mulnACA expnS factS (mulnACA n) mulnC leq_mul //. +by rewrite leq_mul // (leq_trans (leq_subr _ _)). +Qed. + +(* This is Peterfalvi (14.8)(b). *) +Let v1p_gt_u1q : (v.-1 %/ p > u.-1 %/ q)%N. +Proof. +have ub_u: (u.-1 <= nU - 1)%N. + rewrite -subn1 leq_sub2r //; have [_ _] := FTtypeP_facts maxS StypeP. + by rewrite (FTtypeP_reg_Fcore maxS StypeP) indexg1. +rewrite ltn_divLR ?prime_gt0 // {ub_u}(leq_ltn_trans ub_u) //. +have p_dv_v1: p %| v.-1 by have [] := FTtypeP_bridge_facts maxT TtypeP. +rewrite divn_mulAC // ltn_divRL ?dvdn_mulr // oV -subn1. +rewrite -(@ltn_pmul2l q.-1) ?(mulnCA q.-1); last by rewrite -(subnKC qgt2). +rewrite !mulnA -(@ltn_pmul2l p.-1); last by rewrite -(subnKC pgt2). +rewrite -mulnA mulnCA mulnA !(mulnBl _ _ _.-1) !divnK ?dvdn_pred_predX //. +rewrite !mul1n mulnCA -!subn1 ltn_mul ?ltn_sub2r ?prime_gt1 //. +rewrite -!subnDA !subnKC ?prime_gt0 // !mulnBl -!expnSr !mulnn. +by rewrite -subSn ?leq_exp2l ?leqW ?prime_gt1 ?leq_sub ?leq_exp2r // ltnW. +Qed. + +Let calT0 := seqIndD QV T T`_\s 1. +Let rmR_T := FTtypeP_coh_base maxT TtypeP. +Let scohT0 : subcoherent calT0 tauT rmR_T. +Proof. exact: FTtypeP_subcoherent. Qed. + +Let sTT0 : cfConjC_subset calS calS0. +Proof. exact/seqInd_conjC_subset1/Fcore_sub_FTcore. Qed. + +(* This is Peterfalvi (14.9). *) +Lemma FTtypeP_min_typeII : FTtype T == 2. +Proof. +apply: contraLR v1p_gt_u1q => notTtype2; rewrite -leqNgt -leC_nat. +have [o_betaT0_eta _ [Ttype3 _]] := FTtype34_structure maxT TtypeP notTtype2. +have Ttype_gt2: (2 < FTtype T)%N by rewrite (eqP Ttype3). +have [[_ _ frobVW2 cVV] _ _ _ _] := FTtypeP_facts _ TtypeP. +pose calT1 := seqIndD QV T QV Q; have sT10: cfConjC_subset calT1 calT0. + by apply/seqInd_conjC_subset1; rewrite /= FTcore_eq_der1. +rewrite (FTtypeP_reg_Fcore maxT TtypeP) (group_inj (joingG1 _)) in o_betaT0_eta. +do [rewrite -/calT1; set eta_0 := \sum_j _] in o_betaT0_eta. +have scohT1: subcoherent calT1 tauT rmR_T := subset_subcoherent scohT0 sT10. +have [nsQQV sVQV _ _ _] := sdprod_context defQV. +have nsQVT: QV <| T := der_normal 1 T. +have calT1_1p zeta: zeta \in calT1 -> zeta 1%g = p%:R. + case/seqIndP=> s /setDP[kerQs _] -> /=; rewrite inE in kerQs. + rewrite cfInd1 ?gFsub // -(index_sdprod defT) lin_char1 ?mulr1 //. + rewrite lin_irr_der1 (subset_trans _ kerQs) // der1_min ?normal_norm //. + by rewrite -(isog_abelian (sdprod_isog defQV)). +have [tau1T cohT1]: coherent calT1 T^# tauT. + apply/(uniform_degree_coherence scohT1)/(@all_pred1_constant _ p%:R). + by apply/allP=> _ /mapP[zeta T1zeta ->]; rewrite /= calT1_1p. +have irrT1: {subset calT1 <= irr T}. + move=> _ /seqIndP[s /setDP[kerQs nz_s] ->]; rewrite inE in kerQs. + rewrite inE subGcfker in nz_s; rewrite -(quo_IirrK nsQQV kerQs) mod_IirrE //. + rewrite cfIndMod ?normal_sub ?cfMod_irr ?gFnormal //. + rewrite irr_induced_Frobenius_ker ?quo_Iirr_eq0 //=. + have /sdprod_isom[nQ_VW1 /isomP[injQ <-]] := Ptype_Fcore_sdprod TtypeP. + have ->: (QV / Q)%g = (V / Q)%g by rewrite -(sdprodW defQV) quotientMidl. + have ->: (V / Q)%g = restrm nQ_VW1 (coset Q) @* V. + by rewrite morphim_restrm (setIidPr _) // joing_subl. + by rewrite injm_Frobenius_ker // (FrobeniusWker frobVW2). +have [[A0betaS PVbetaS] _ [_]] := FTtypeP_bridge_facts maxS StypeP. +rewrite -/q -/u; set Gamma := FTtypeP_bridge_gap _ _ => oGa1 R_Ga lb_Ga _. +have oT1eta: orthogonal (map tau1T calT1) (map sigma (irr W)). + apply/orthogonalP=> _ _ /mapP[zeta T1zeta ->] /mapP[omega Womega ->]. + have{omega Womega} [i [j ->]] := cycTIirrP defW Womega. + by rewrite (cycTIisoC _ pddT) (coherent_ortho_cycTIiso _ sT10 cohT1) ?irrT1. +have [[Itau1T Ztau1T] Dtau1T] := cohT1. +have nzT1_Ga zeta: zeta \in calT1 -> `|'[Gamma, tau1T zeta]| ^+ 2 >= 1. + have Z_Ga: Gamma \in 'Z[irr G]. + rewrite rpredD ?cycTIiso_vchar // rpredB ?rpred1 ?Dade_vchar // zchar_split. + by rewrite A0betaS ?Iirr1_neq0 // rpredB ?cfInd_vchar ?rpred1 ?irr_vchar. + move=> T1zeta; rewrite expr_ge1 ?normr_ge0 // norm_Cint_ge1 //. + by rewrite Cint_cfdot_vchar ?Ztau1T ?(mem_zchar T1zeta). + suffices: ('[Gamma, tau1T zeta] == 1 %[mod 2])%C. + by apply: contraTneq => ->; rewrite (eqCmod_nat 2 0 1). + pose betaT0 := nu_ 0 - zeta. + have{o_betaT0_eta} o_eta0_betaT0 j: '[eta_ 0 j, tauT betaT0] = (j == 0)%:R. + transitivity '[eta_ 0 j, eta_0]; rewrite (cycTIisoC _ pddT). + apply/eqP; rewrite -subr_eq0 -cfdotBr cfdotC. + by rewrite (orthoPl (o_betaT0_eta _ _)) ?conjC0 // map_f ?mem_irr. + rewrite cfdot_sumr (bigD1 0) //= cfdot_cycTIiso andbT big1 ?addr0 //. + by move=> i /negPf nz_i; rewrite cfdot_cycTIiso andbC eq_sym nz_i. + have QVbetaT0: betaT0 \in 'CF(T, QV^#). + rewrite cfun_onD1 rpredB ?(seqInd_on _ T1zeta) //=; last first. + by rewrite /nu_ -cfInd_prTIres cfInd_normal. + by rewrite !cfunE prTIred_1 prTIirr0_1 mulr1 calT1_1p ?subrr. + have A0betaT0: betaT0 \in 'CF(T, 'A0(T)). + by rewrite (cfun_onS (FTsupp1_sub0 _)) // /'A1(T) ?FTcore_eq_der1. + have ZbetaT0: betaT0 \in 'Z[irr T]. + by rewrite rpredB ?char_vchar ?(seqInd_char T1zeta) ?prTIred_char. + pose Delta := tauT betaT0 - 1 + tau1T zeta. + have nz_i1: #1 != 0 := Iirr1_neq0 ntW2. + rewrite -(canLR (addKr _) (erefl Delta)) opprB cfdotDr cfdotBr oGa1 add0r. + rewrite cfdotDl cfdotBl -/betaS o_eta0_betaT0 (negPf nz_i1) // addr0 opprB. + rewrite -(cycTIiso1 pddS) -(cycTIirr00 defW) {}o_eta0_betaT0 mulr1n. + have QV'betaS: tauS betaS \in 'CF(G, ~: class_support QV^# G). + have [_ [pP _] _ _ [_ ->]] := FTtypeP_facts _ StypeP; rewrite ?A0betaS //. + apply: cfun_onS (cfInd_on (subsetT S) (PVbetaS _ nz_i1)). + apply/subsetP=> x PWx; rewrite inE. + have{PWx}: p \in \pi(#[x]). + case/imset2P: PWx => {x}x y PWx _ ->; rewrite {y}orderJ. + case/setUP: PWx => [/setD1P[ntx Px] | /imset2P[{x}x y Wx _ ->]]. + rewrite -p_rank_gt0 -rank_pgroup ?rank_gt0 ?cycle_eq1 //. + exact: mem_p_elt (abelem_pgroup pP) Px. + case/setDP: Wx; rewrite {y}orderJ; have [_ <- cW12 _] := dprodP defW. + case/mulsgP=> {x}x y W1x W2y ->; have cyx := centsP cW12 _ W2y _ W1x. + have [-> | nty _] := eqVneq y 1%g; first by rewrite inE mulg1 W1x. + have p'x: p^'.-elt x. + by rewrite (mem_p_elt _ W1x) /pgroup ?pnatE ?inE ?ltn_eqF. + have p_y: p.-elt y by rewrite (mem_p_elt (pnat_id _)). + rewrite -cyx orderM ?(pnat_coprime p_y) // pi_ofM // inE /=. + by rewrite -p_rank_gt0 -rank_pgroup // rank_gt0 cycle_eq1 nty. + apply: contraL => /imset2P[z y /setD1P[_ QVz] _ ->]; rewrite {x y}orderJ. + rewrite -p'natEpi // [_.-nat _](mem_p_elt _ QVz) // /pgroup ?p'natE //. + rewrite -prime_coprime // coprime_sym (coprime_sdprod_Hall_r defT). + by have [[]] := TtypeP. + have [_ _ _ _ [_ -> //]] := FTtypeP_facts _ TtypeP. + rewrite (cfdotElr QV'betaS (cfInd_on _ QVbetaT0)) ?subsetT //=. + rewrite setIC setICr big_set0 mulr0 subr0 addrC /eqCmod addrK. + rewrite cfdot_real_vchar_even ?mFT_odd ?oGa1 ?rpred0 //; split. + rewrite rpredD ?Ztau1T ?(mem_zchar T1zeta) // rpredB ?rpred1 //. + by rewrite Dade_vchar // zchar_split ZbetaT0. + rewrite /cfReal -subr_eq0 opprD opprB rmorphD rmorphB rmorph1 /= addrACA. + rewrite !addrA subrK -Dade_aut -linearB /= -/tauT rmorphB opprB /=. + rewrite -prTIred_aut aut_Iirr0 -/nu_ [sum in tauT sum]addrC addrA subrK. + rewrite -Dtau1T; last first. + by rewrite (zchar_onS _ (seqInd_sub_aut_zchar _ _ _)) // setSD ?der_sub. + rewrite raddfB -addrA addrC addrA subrK subr_eq0. + by rewrite (cfConjC_Dade_coherent cohT1) ?mFT_odd ?irrT1. +have [Y T1_Y [X [defGa oYX oXT1]]] := orthogonal_split (map tau1T calT1) Gamma. +apply: ler_trans (lb_Ga X Y _ _ _); first 1 last; rewrite 1?addrC //. +- by rewrite cfdotC oYX conjC0. +- by apply/orthoPl=> eta Weta; rewrite (span_orthogonal oT1eta) // memv_span. +have ->: v.-1 = (p * size calT1)%N; last rewrite mulKn ?prime_gt0 //. + rewrite [p](index_sdprod defT); have isoV := sdprod_isog defQV. + rewrite [v](card_isog isoV) -card_Iirr_abelian -?(isog_abelian isoV) //. + rewrite -(card_imset _ (can_inj (mod_IirrK nsQQV))) (cardD1 0) /=. + rewrite -{1}(mod_Iirr0 QV Q) mem_imset //=. + rewrite (size_irr_subseq_seqInd _ (subseq_refl _)) //=. + apply: eq_card => s; rewrite !inE mem_seqInd ?gFnormal // !inE subGcfker. + congr (_ && _); apply/idP/idP=> [/imsetP[r _ ->] | kerQs]. + by rewrite mod_IirrE ?cfker_mod. + by rewrite -(quo_IirrK nsQQV kerQs) mem_imset. +have o1T1: orthonormal (map tau1T calT1). + rewrite map_orthonormal ?(sub_orthonormal irrT1) ?seqInd_uniq //. + exact: irr_orthonormal. +have [_ -> ->] := orthonormal_span o1T1 T1_Y. +rewrite cfnorm_sum_orthonormal // big_map -sum1_size natr_sum !big_seq. +apply: ler_sum => // zeta T1zeta; rewrite -(canLR (addrK X) defGa). +by rewrite cfdotBl (orthoPl oXT1) ?subr0 ?nzT1_Ga ?map_f. +Qed. +Let Ttype2 := FTtypeP_min_typeII. + +(* These declarations correspond to Hypothesis (14.10). *) +Variables (M : {group gT}) (tau1M : {additive 'CF(M) -> 'CF(G)}) (psi : 'CF(M)). +Hypothesis maxNV_M : M \in 'M('N(V)). + +Local Notation "` 'M'" := (gval M) (at level 0, only parsing). +Local Notation K := `M`_\F%G. +Local Notation "` 'K'" := `M`_\F%g (at level 0, format "` 'K'") : group_scope. + +(* Consequences of the above. *) +Hypotheses (maxM : M \in 'M) (sNVM : 'N(V) \subset M). +Hypotheses (frobM : [Frobenius M with kernel K]) (Mtype1 : FTtype M == 1%N). + +Let calM := seqIndD K M K 1. +Local Notation tauM := (FT_DadeF maxM). +Let nsKM : K <| M. Proof. exact: gFnormal. Qed. +Let irrM : {subset calM <= irr M}. Proof. exact: FTtype1_Ind_irr. Qed. + +Hypothesis cohM : coherent_with calM M^# tauM tau1M. +Hypotheses (Mpsi : psi \in calM) (psi1 : psi 1%g = #|M : K|%:R). + +Let betaM := 'Ind[M, K] 1 - psi. + +Let pairTS : typeP_pair T S xdefW. Proof. exact: typeP_pair_sym pairST. Qed. + +Let pq : algC := (p * q)%:R. +Let h := #|H|. + +(* This is the first (and main) part of Peterfalvi (14.11). *) +Let defK : `K = V. +Proof. +pose e := #|M : K|; pose k := #|K|; apply: contraTeq isT => notKV. +have [_ sVK defM] := FTtypeII_support_facts maxT TtypeP Ttype2 pairTS maxNV_M. +have ltVK: V \proper K by rewrite properEneq eq_sym notKV. +have e_dv_k1: e %| k.-1 := Frobenius_ker_dvd_ker1 frobM. +have [e_lepq regKW2]: (e <= p * q)%N /\ semiregular K W2. + case: defM => [|[y Py]] defM; rewrite /e -(index_sdprod defM). + have /Frobenius_reg_ker regHW1 := set_Frobenius_compl defM frobM. + by rewrite leq_pmulr ?cardG_gt0. + have /Frobenius_reg_ker regHW21y := set_Frobenius_compl defM frobM. + split; last exact: semiregularS (joing_subl _ _) regHW21y. + suffices /normP <-: y \in 'N(W2). + by rewrite -conjYg cardJg (dprodWY xdefW) -(dprod_card xdefW). + have cPP: abelian P by have [_ [/and3P[]]] := FTtypeP_facts maxS StypeP. + have sW2P: W2 \subset P by have [_ _ _ []] := StypeP. + by rewrite (subsetP _ y Py) // sub_abelian_norm. +(* This is (14.11.1). *) +have{regKW2} [lb_k lb_k1e_v]: (2 * p * v < k /\ v.-1 %/ p < k.-1 %/ e)%N. + have /dvdnP[x Dk]: v %| k := cardSg sVK. + have lb_x: (p.*2 < x)%N. + have x_gt1: (1 < x)%N. + by rewrite -(ltn_pmul2r (cardG_gt0 V)) -Dk mul1n proper_card. + have x_gt0 := ltnW x_gt1; rewrite -(prednK x_gt0) ltnS -subn1. + rewrite dvdn_leq ?subn_gt0 // -mul2n Gauss_dvd ?coprime2n ?mFT_odd //. + rewrite dvdn2 odd_sub // (dvdn_odd _ (mFT_odd K)) -/k ?Dk ?dvdn_mulr //=. + rewrite -eqn_mod_dvd // -[x]muln1 -modnMmr. + have nVW2: W2 \subset 'N(V) by have [_ []] := TtypeP. + have /eqP{1} <-: (v == 1 %[mod p]). + rewrite eqn_mod_dvd ?cardG_gt0 // subn1 regular_norm_dvd_pred //. + exact: semiregularS regKW2. + rewrite modnMmr -Dk /k eqn_mod_dvd // subn1 regular_norm_dvd_pred //. + by rewrite (subset_trans (subset_trans nVW2 sNVM)) ?gFnorm. + have lb_k: (2 * p * v < k)%N by rewrite mul2n Dk ltn_pmul2r ?cardG_gt0. + split=> //; rewrite ltn_divLR ?cardG_gt0 // divn_mulAC ?prednK ?cardG_gt0 //. + rewrite leq_divRL ?indexg_gt0 // (leq_trans (leq_mul (leqnn v) e_lepq)) //. + rewrite mulnA mulnAC leq_mul // -ltnS prednK ?cardG_gt0 //. + apply: leq_ltn_trans lb_k; rewrite mulnC leq_mul // ltnW ?(leq_trans ltqp) //. + by rewrite mul2n -addnn leq_addl. +have lb_k1e_u := ltn_trans v1p_gt_u1q lb_k1e_v; have irr_psi := irrM Mpsi. +have Mgt1: (1 < size calM)%N by apply: seqInd_nontrivial Mpsi; rewrite ?mFT_odd. +(* This is (14.11.2). *) +have [] // := FTtype2_support_coherence TtypeP StypeP cohM Mpsi. +rewrite -/e -/p -/q mulnC /= => De [nb [chi Dchi]]. +rewrite cycTIiso_irrelC -/sigma -/betaM => DbetaM. +pose ddMK := FT_DadeF_hyp maxM; pose AM := Dade_support ddMK. +have defAM: AM = 'A~(M) by rewrite FTsupp_Frobenius -?FT_DadeF_supportE. +pose ccG A := class_support A G. +pose G0 := ~: ('A~(M) :|: ccG What :|: ccG P^# :|: ccG Q^#). +have sW2P: W2 \subset P by have [_ _ _ []] := StypeP. +have sW1Q: W1 \subset Q by have [_ _ _ []] := TtypeP. +(* This is (14.11.3). *) +have lbG0 g: g \in G0 -> 1 <= `|tau1M psi g| ^+ 2. + rewrite !inE ?expr_ge1 ?normr_ge0 // => /norP[/norP[/norP[AM'g W'g P'g Q'g]]]. + have{W'g} /coprime_typeP_Galois_core-co_p_g: g \notin ccG W^#. + apply: contra W'g => /imset2P[x y /setD1P[ntx Wx] Gy Dg]. + rewrite Dg mem_imset2 // !inE Wx andbT; apply/norP; split. + by apply: contra Q'g => /(subsetP sW1Q)?; rewrite Dg mem_imset2 ?inE ?ntx. + by apply: contra P'g => /(subsetP sW2P)Px; rewrite Dg mem_imset2 ?inE ?ntx. + have{AM'g} betaMg0: tauM betaM g = 0. + by apply: cfun_on0 AM'g; rewrite -defAM Dade_cfunS. + suffices{betaMg0}: 1 <= `|(\sum_ij (-1) ^+ nb ij *: sigma 'chi_ij) g|. + rewrite -[\sum_i _](subrK chi) -DbetaM !cfunE betaMg0 add0r. + case: Dchi => -> //; rewrite cfunE normrN. + by rewrite -(cfConjC_Dade_coherent cohM) ?mFT_odd ?cfunE ?norm_conjC. + have{co_p_g} Zeta_g ij: sigma 'chi_ij g \in Cint. + apply/Cint_cycTIiso_coprime/(coprime_dvdr (cforder_lin_char_dvdG _)). + by apply: irr_cyclic_lin; have [] := ctiWG. + rewrite -(dprod_card defW) coprime_mulr. + by apply/andP; split; [apply: co_p_g galT _ | apply: co_p_g galS _]. + rewrite sum_cfunE norm_Cint_ge1 ?rpred_sum // => [ij _|]. + by rewrite cfunE rpredMsign. + set a := \sum_i _; suffices: (a == 1 %[mod 2])%C. + by apply: contraTneq=> ->; rewrite (eqCmod_nat 2 0 1). + have signCmod2 n ij (b := sigma 'chi_ij g): ((-1) ^+ n * b == b %[mod 2])%C. + rewrite -signr_odd mulr_sign eqCmod_sym; case: ifP => // _. + by rewrite -(eqCmodDl _ b) subrr -[b + b](mulr_natr b 2) eqCmodMl0 /b. + rewrite -[1]addr0 [a](bigD1 0) {a}//= cfunE eqCmodD //. + by rewrite (eqCmod_trans (signCmod2 _ _)) // irr0 cycTIiso1 cfun1E inE. + rewrite (partition_big_imset (fun ij => [set ij; conjC_Iirr ij])) /= eqCmod0. + apply: rpred_sum => _ /=/imsetP[ij /negPf nz_ij ->]. + rewrite (bigD1 ij) /=; last by rewrite unfold_in nz_ij eqxx. + rewrite (big_pred1 (conjC_Iirr ij)) => [|ij1 /=]; last first. + rewrite unfold_in eqEsubset !subUset !sub1set !inE !(eq_sym ij). + rewrite !(can_eq (@conjC_IirrK _ _)) (canF_eq (@conjC_IirrK _ _)). + rewrite -!(eq_sym ij1) -!(orbC (_ == ij)) !andbb andbAC -andbA. + rewrite andb_orr andNb andbA andb_idl // => /eqP-> {ij1}. + rewrite conjC_Iirr_eq0 nz_ij -(inj_eq irr_inj) conjC_IirrE. + by rewrite odd_eq_conj_irr1 ?mFT_odd // irr_eq1 nz_ij. + rewrite -signr_odd -[odd _]negbK signrN !cfunE mulNr addrC. + apply: eqCmod_trans (signCmod2 _ _) _. + by rewrite eqCmod_sym conjC_IirrE -cfAut_cycTIiso cfunE conj_Cint. +have cardG_D1 R: #|R^#| = #|R|.-1 by rewrite [#|R|](cardsD1 1%g) group1. +pose rho := invDade ddMK; pose nG : algC := #|G|%:R. +pose sumG0 := \sum_(g in G0) `|tau1M psi g| ^+ 2. +pose sumG0_diff := sumG0 - (#|G0| + #|ccG What| + #|ccG P^#| + #|ccG Q^#|)%:R. +have ub_rho: '[rho (tau1M psi)] <= k.-1%:R / #|M|%:R - nG^-1 * sumG0_diff. + have NtauMpsi: '[tau1M psi] = 1. + by have [[Itau1 _] _] := cohM; rewrite Itau1 ?mem_zchar //= irrWnorm. + rewrite ler_subr_addl -subr_le0 -addrA. + have ddM_ i j: i != j :> 'I_1 -> [disjoint AM & AM] by rewrite !ord1. + apply: ler_trans (Dade_cover_inequality ddM_ NtauMpsi); rewrite -/nG -/AM. + rewrite !big_ord1 cardG_D1 ler_add2r ler_pmul2l ?invr_gt0 ?gt0CG //= defAM. + rewrite setTD ler_add ?ler_opp2 ?leC_nat //; last first. + do 3!rewrite -?addnA -cardsUI ?addnA (leq_trans _ (leq_addr _ _)) //. + by rewrite subset_leq_card // -setCD setCS -!setUA subDset setUC. + rewrite (big_setID G0) /= (setIidPr _) ?setCS -?setUA ?subsetUl // ler_addl. + by apply: sumr_ge0 => g _; rewrite ?exprn_ge0 ?normr_ge0. +have lb_rho: 1 - pq / k%:R <= '[rho (tau1M psi)]. + have [_] := Dade_Ind1_sub_lin cohM Mgt1 irr_psi Mpsi psi1; rewrite -/e -/k. + rewrite odd_Frobenius_index_ler ?mFT_odd // => -[_ _ [|/(ler_trans _)->] //]. + by rewrite ler_add2l ler_opp2 ler_pmul2r ?invr_gt0 ?gt0CG // leC_nat. +have{rho sumG0 sumG0_diff ub_rho lb_rho} []: + ~ pq / k%:R + 2%:R / pq + (u * q)%:R^-1 + (v * p)%:R^-1 < p%:R^-1 + q%:R^-1. +- rewrite ler_gtF // -!addrA -ler_subl_addl -ler_subr_addl -(ler_add2l 1). + apply: ler_trans {ub_rho lb_rho}(ler_trans lb_rho ub_rho) _. + rewrite /sumG0_diff -!addnA natrD opprD addrA mulrBr opprB addrA. + rewrite ler_subl_addr ler_paddr //. + by rewrite mulr_ge0 ?invr_ge0 ?ler0n // subr_ge0 -sumr_const ler_sum. + rewrite mulrDl -!addrA addrCA [1 + _]addrA [_ + (_ - _)]addrA ler_add //. + rewrite -(Lagrange (normal_sub nsKM)) natrM invfM mulrA -/k -/e /pq -De. + rewrite ler_pmul2r ?invr_gt0 ?gt0CiG // ler_pdivr_mulr ?gt0CG //. + by rewrite mul1r leC_nat leq_pred. + rewrite [1 + _ + _]addrA addrAC !natrD !mulrDr !ler_add //; first 1 last. + + exact: (FTtype2_cc_core_ler StypeP). + + exact: (FTtype2_cc_core_ler TtypeP). + have [_ _ /card_support_normedTI->] := ctiWG. + rewrite natrM natf_indexg ?subsetT // mulrCA mulKf ?neq0CG // card_cycTIset. + rewrite mulnC -(dprod_card xdefW) /pq !natrM -!subn1 !natrB // -/p -/q invfM. + rewrite mulrACA !mulrBl ?divff ?neq0CG // !mul1r mulrBr mulr1 opprB. + by rewrite addrACA -opprB opprK. +rewrite -!addrA ler_lt_add //; last first. + pose q2 : algC := (q ^ 2)%:R. + apply: ltr_le_trans (_ : 2%:R / q2 + (2%:R * q2)^-1 *+ 2 <= _); last first. + rewrite addrC -[_ *+ 2]mulr_natl invfM mulVKf ?pnatr_eq0 //. + rewrite mulr_natl -mulrS -mulr_natl [q2]natrM. + by rewrite ler_pdivr_mulr ?mulr_gt0 ?gt0CG // mulKf ?neq0CG ?leC_nat. + rewrite -natrM !addrA ltr_add ?(FTtypeP_complV_ltr TtypeP) 1?ltnW //. + rewrite ltr_add ?(FTtypeP_complV_ltr StypeP) // /pq mulnC /q2 !natrM !invfM. + by rewrite !ltr_pmul2l ?ltf_pinv ?invr_gt0 ?qualifE ?gt0CG ?ltr0n ?ltr_nat. +rewrite ler_pdivr_mulr ?ler_pdivl_mull ?gt0CG // -natrM leC_nat. +apply: leq_trans lb_k; rewrite leqW // mulnAC mulnC leq_mul //. +have [[_ _ frobVW2 _] _ _ _ _] := FTtypeP_facts maxT TtypeP. +rewrite -[(p * q)%N]mul1n leq_mul // (leq_trans _ (leq_pred v)) // dvdn_leq //. + by rewrite -subn1 subn_gt0 cardG_gt1; have[] := Frobenius_context frobVW2. +rewrite Gauss_dvd ?prime_coprime ?(dvdn_prime2 pr_p pr_q) ?gtn_eqF //. +rewrite (Frobenius_dvd_ker1 frobVW2) /= oV /nV predn_exp. +rewrite -(subnKC qgt2) -(ltn_predK pgt2) mulKn // subnKC //. +by rewrite big_ord_recl dvdn_sum // => i _; rewrite expnS dvdn_mulr. +Qed. + +(* This is the first part of Peterfalvi (14.11). *) +Let indexMK : #|M : K| = (p * q)%N. +Proof. +have [_ _ [defM|]] := FTtypeII_support_facts maxT TtypeP Ttype2 pairTS maxNV_M. + have:= Ttype2; rewrite (mmax_max maxM (mmax_proper maxT)) ?(eqP Mtype1) //. + rewrite -(sdprodW (Ptype_Fcore_sdprod TtypeP)) -defK (sdprodWY defM). + exact: mulG_subr. +case=> y Py /index_sdprod <-; rewrite (dprod_card xdefW) -(dprodWY xdefW). +suffices /normP {1}<-: y \in 'N(W2) by rewrite -conjYg cardJg. +have cPP: abelian P by have [_ [/and3P[]]] := FTtypeP_facts maxS StypeP. +by rewrite (subsetP (sub_abelian_norm cPP _)) //; have [_ _ _ []] := StypeP. +Qed. + +(* This is Peterfalvi (14.12), and also (14.13) since we have already proved *) +(* the negation of Theorem (14.2). *) +Let not_MG_L : (L : {set gT}) \notin M :^: G. +Proof. +rewrite orbit_sym; apply: contra not_charUH => /imsetP[z _ /= defLz]. +rewrite sub_cyclic_char // -(cyclicJ _ z) -FcoreJ -defLz defK. +have [_ _ [cycV _ _]] := typeP_Galois_P maxT (FTtype5_exclusion maxT) galT. +rewrite Ptype_Fcompl_kernel_trivial // in cycV. +by rewrite -(isog_cyclic (quotient1_isog V)) in cycV. +Qed. + +(* This is Peterfalvi (14.14). *) +Let LM_cases : + '[tauM betaM, tau1L phi] != 0 /\ h.-1%:R / pq <= pq - 1 + \/ '[tauL betaL, tau1M psi] != 0 /\ q = 3 /\ p = 5. +Proof. +have [irr_phi irr_psi] := (irrL Lphi, irrM Mpsi). +have:= Dade_sub_lin_nonorthogonal (mFT_odd _) _ cohM cohL _ Mpsi _ _ Lphi. +rewrite -/betaL -/betaM disjoint_Dade_FTtype1 //. +case=> //; set a := '[_, _] => nz_a; [left | right]; split=> //. + rewrite {1}/pq -indexLH /pq -indexMK. + by rewrite (coherent_FTtype1_core_ltr cohM cohL Mpsi Lphi) // orbit_sym. +have ub_v: v.-1%:R / pq <= pq - 1. + rewrite {1}/pq -indexMK /pq -indexLH /v -defK. + exact: (coherent_FTtype1_core_ltr cohL cohM Lphi Mpsi). +have{ub_v} ub_qp: (q ^ (p - 3) < p ^ 2)%N. + rewrite -(@ltn_pmul2l (q ^ 3)) ?expn_gt0 ?cardG_gt0 // -expnD subnKC //. + have: v.-1%:R < pq ^+ 2. + rewrite -ltr_pdivr_mulr ?ltr0n ?muln_gt0 ?cardG_gt0 //. + by rewrite (ler_lt_trans ub_v) // ltr_subl_addl -mulrS ltC_nat. + rewrite -natrX ltC_nat prednK ?cardG_gt0 // mulnC expnMn oV. + rewrite leq_divLR ?dvdn_pred_predX // mulnC -subn1 leq_subLR. + move/leq_ltn_trans->; rewrite // -addSn addnC -(leq_add2r (q ^ 2 * p ^ 2)). + rewrite addnAC -mulSnr prednK ?cardG_gt0 // mulnA leq_add2l -expnMn. + by rewrite (ltn_sqr 1) (@ltn_mul 1 1) ?prime_gt1. +have q3: q = 3. + apply/eqP; rewrite eqn_leq qgt2 -ltnS -(odd_ltn 5) ?mFT_odd // -ltnS. + rewrite -(ltn_exp2l _ _ (ltnW pgt2)) (leq_trans qp1_gt_pq1) // ltnW //. + by rewrite -{1}(subnK pgt2) -addnS expnD (expnD p 2 4) ltn_mul ?ltn_exp2r. +split=> //; apply/eqP; rewrite eqn_leq -ltnS andbC. +rewrite (odd_geq 5) -1?(odd_ltn 7) ?mFT_odd //= doubleS -{1}q3 ltqp /=. +move: ub_qp; rewrite 2!ltnNge q3; apply: contra. +elim: p => // x IHx; rewrite ltnS leq_eqVlt => /predU1P[<- // | xgt6]. +apply: (@leq_trans (3 * x ^ 2)); last first. + rewrite subSn ?(leq_trans _ xgt6) //. + by rewrite [rhs in (_ <= rhs)%N]expnS leq_mul ?IHx. +rewrite -addn1 sqrnD -addnA (mulSn 2) leq_add2l muln1. +rewrite (@leq_trans (2 * (x * 7))) ?leq_mul //. +by rewrite mulnCA (mulnDr x 12 2) mulnC leq_add2r -(subnKC xgt6). +Qed. + +(* This is Peterfalvi (14.15). *) +Let oU : u = nU. +Proof. +case: ifP (card_FTtypeP_Galois_compl maxS galS) => // p1modq oU. +pose x := #|H : U|; rewrite -/u -/nU -/p -/q in p1modq oU. +have DnU: (q * u)%N = nU. + rewrite mulnC oU divnK //. + by have [_ ->] := FTtypeP_primes_mod_cases maxS StypeP. +have oH: h = (u * x)%N by rewrite Lagrange. +have xmodp: x = q %[mod p]. + have hmodp: h = 1 %[mod p]. + apply/eqP; rewrite eqn_mod_dvd ?cardG_gt0 // subn1. + apply: dvdn_trans (Frobenius_ker_dvd_ker1 frobL). + have [y _ /index_sdprod <-] := defL. + by rewrite -[p](cardJg _ y) cardSg ?joing_subr. + rewrite -[q]muln1 -modnMmr -hmodp modnMmr oH mulnA DnU -modnMml. + suffices ->: nU = 1 %[mod p] by rewrite modnMml mul1n. + rewrite /nU predn_exp mulKn; last by rewrite -(subnKC pgt2). + apply/eqP; rewrite -(ltn_predK qgt2) big_ord_recl eqn_mod_dvd ?subn1 //=. + by apply: dvdn_sum => i _; rewrite expnS dvdn_mulr. +have{xmodp} [n Dx]: {n | x = q + n * p}%N. + by exists (x %/ p); rewrite -(modn_small ltqp) addnC -xmodp -divn_eq. +have nmodq: n = 1 %[mod q]. + have [y _ defLy] := defL; have [_ _ /joing_subP[nHW1 _] _] := sdprodP defLy. + have regHW1: semiregular H W1. + have /Frobenius_reg_ker := set_Frobenius_compl defLy frobL. + by apply: semiregularS; rewrite ?joing_subl. + have hmodq: h = 1 %[mod q]. + apply/eqP; rewrite eqn_mod_dvd ?cardG_gt0 // subn1. + exact: regular_norm_dvd_pred regHW1. + have umodq: u = 1 %[mod q]. + apply/eqP; rewrite eqn_mod_dvd ?cardG_gt0 // subn1. + apply: regular_norm_dvd_pred; first by have [_ []] := StypeP. + exact: semiregularS regHW1. + rewrite -hmodq oH -modnMml umodq modnMml mul1n Dx modnDl. + by rewrite -modnMmr (eqP p1modq) modnMmr muln1. +have{n nmodq Dx} lb_x: (q + q.+1 * p <= x)%N. + rewrite (divn_eq n q) nmodq (modn_small (ltnW qgt2)) addn1 in Dx. + rewrite Dx leq_add2l leq_mul // ltnS leq_pmull // lt0n. + have: odd x by rewrite (dvdn_odd (dvdn_indexg _ _)) ?mFT_odd. + by rewrite Dx odd_add odd_mul !mFT_odd; apply: contraNneq => ->. +have lb_h: (p ^ q < h)%N. + rewrite (@leq_trans (p * nU)) //; last first. + rewrite -DnU oH mulnA mulnC leq_mul // (leq_trans _ lb_x) //. + by rewrite mulSn addnA mulnC leq_addl. + rewrite /nU predn_exp mulKn; last by rewrite -(subnKC pgt2). + rewrite -(subnKC (ltnW qgt2)) subn2 big_ord_recr big_ord_recl /=. + by rewrite -add1n !mulnDr -!expnS -addnA leq_add ?leq_addl // cardG_gt0. +have ub_h: (h <= p ^ 2 * q ^ 2)%N. + have [[_ ub_h] | [_ [q3 p5]]] := LM_cases; last by rewrite q3 p5 in p1modq. + rewrite -expnMn -(ltn_predK lb_h) -ltC_nat natrM -/pq. + rewrite -ltr_pdivr_mulr ?ltr0n ?muln_gt0 ?cardG_gt0 //. + by rewrite (ler_lt_trans ub_h) // ltr_subl_addl -mulrS ltC_nat. +have{lb_h} lb_q2: (p ^ q.-2 < q ^ 2)%N. + rewrite -(@ltn_pmul2l (p ^ 2)) ?expn_gt0 ?cardG_gt0 // (leq_trans _ ub_h) //. + by rewrite -subn2 -expnD subnKC // ltnW. +have q3: q = 3. + apply/eqP; rewrite eqn_leq qgt2 -(subnKC (ltnW qgt2)) subn2 ltnS. + by rewrite -(ltn_exp2l _ _ (ltnW pgt2)) (ltn_trans lb_q2) ?ltn_exp2r. +have{lb_q2 p1modq} p7: p = 7. + suff: p \in [seq n <- iota 4 5 | prime n & n == 1 %[mod 3]] by case/predU1P. + by rewrite mem_filter pr_p mem_iota -q3 p1modq ltqp; rewrite q3 in lb_q2 *. +rewrite oH mulnC oU /nU q3 p7 -leq_divRL //= in ub_h lb_x. +by have:= leq_trans lb_x ub_h. +Qed. + +(* This is Peterfalvi (14.16), the last step towards the final contradiction. *) +Let defH : `H = U. +Proof. +pose x := #|H : U|; have oH: h = (u * x)%N by rewrite Lagrange. +apply/eqP/idPn; rewrite eqEsubset sUH andbT -indexg_gt1 -/x => xgt1. +have hmodpq: h = 1 %[mod p * q]. + apply/eqP; rewrite eqn_mod_dvd ?cardG_gt0 // -indexLH subn1. + exact: Frobenius_ker_dvd_ker1. +have [[_ _ frobUW1 _] _ _ _ _] := FTtypeP_facts maxS StypeP. +have /eqP umodpq: u == 1 %[mod p * q]. + rewrite chinese_remainder ?prime_coprime ?dvdn_prime2 ?(gtn_eqF ltqp) //. + rewrite !eqn_mod_dvd ?cardG_gt0 // subn1 (Frobenius_dvd_ker1 frobUW1). + rewrite oU /nU predn_exp mulKn; last by rewrite -(subnKC pgt2). + by rewrite -(ltn_predK qgt2) big_ord_recl dvdn_sum //= => i; rewrite dvdn_exp. +have{hmodpq} lb_x: (p * q < x)%N. + rewrite -(subnKC (ltnW xgt1)) ltnS dvdn_leq ?subn_gt0 //. + by rewrite -eqn_mod_dvd 1?ltnW // -hmodpq oH -modnMml umodpq modnMml mul1n. +have [[_ ub_h] | [nz_a [q3 p5]]] := LM_cases. + have /idPn[]: (p * q < u)%N. + have ugt1: (1 < u)%N. + by rewrite cardG_gt1; have [] := Frobenius_context frobUW1. + rewrite -(subnKC (ltnW ugt1)) ltnS dvdn_leq ?subn_gt0 //. + by rewrite -eqn_mod_dvd ?umodpq 1?ltnW. + rewrite -leqNgt -(leq_pmul2r (indexg_gt0 L H)) indexLH. + apply: (@leq_trans h.-1). + by rewrite -ltnS prednK ?cardG_gt0 // oH ltn_pmul2l ?cardG_gt0. + rewrite -indexLH -leC_nat natrM -ler_pdivr_mulr ?gt0CiG // indexLH -/pq. + by rewrite (ler_trans ub_h) // ler_subl_addl -mulrS leC_nat ltnW. +have lb_h1e_v: (v.-1 %/ p < h.-1 %/ #|L : H|)%N. + rewrite -(@ltn_pmul2l u) ?cardG_gt0 // -oH oU /nU q3 p5 /= in lb_x. + rewrite -(ltn_subRL 1) /= subn1 in lb_x. + by rewrite leq_divRL ?indexG_gt0 // oV /nV indexLH q3 p5 (leq_trans _ lb_x). +have oLM: orthogonal (map tau1L calL) (map tau1M calM). + by rewrite orthogonal_sym coherent_FTtype1_ortho. +case/eqP: nz_a; have lb_h1e_u := ltn_trans v1p_gt_u1q lb_h1e_v. +have [] // := FTtype2_support_coherence StypeP TtypeP cohL Lphi. +rewrite -/tauL -/sigma => _ [nb [chi Dchi ->]]. +rewrite cfdotBl cfdot_suml big1 => [|ij _]; last first. + have [_ o_tauMeta _ _] := FTtypeI_bridge_facts _ StypeP Mtype1 cohM Mpsi psi1. + rewrite cfdotZl cfdotC (orthogonalP o_tauMeta) ?map_f ?mem_irr //. + by rewrite conjC0 mulr0. +case: Dchi => ->; first by rewrite (orthogonalP oLM) ?map_f // subr0. +by rewrite cfdotNl opprK add0r (orthogonalP oLM) ?map_f // cfAut_seqInd. +Qed. + +Lemma FTtype2_exclusion : False. +Proof. by have /negP[] := not_charUH; rewrite /= defH char_refl. Qed. + +End Fourteen. + +Lemma no_minSimple_odd_group (gT : minSimpleOddGroupType) : False. +Proof. +have [/forall_inP | [S [T [_ W W1 W2 defW pairST]]]] := FTtypeP_pair_cases gT. + exact/negP/not_all_FTtype1. +have xdefW: W2 \x W1 = W by rewrite dprodC. +have pairTS := typeP_pair_sym xdefW pairST. +pose p := #|W2|; pose q := #|W1|. +have p'q: q != p. + have [[[ctiW _ _] _ _ _ _] /mulG_sub[sW1W sW2W]] := (pairST, dprodW defW). + have [cycW _ _] := ctiW; apply: contraTneq (cycW) => eq_pq. + rewrite (cyclic_dprod defW) ?(cyclicS _ cycW) // -/q eq_pq. + by rewrite /coprime gcdnn -trivg_card1; have [] := cycTI_nontrivial ctiW. +without loss{p'q} ltqp: S T W1 W2 defW xdefW pairST pairTS @p @q / q < p. + move=> IH_ST; rewrite neq_ltn in p'q. + by case/orP: p'q; [apply: (IH_ST S T) | apply: (IH_ST T S)]. +have [[_ maxS maxT] _ _ _ _] := pairST. +have [[U StypeP] [V TtypeP]] := (typeP_pairW pairST, typeP_pairW pairTS). +have Stype2: FTtype S == 2 := FTtypeP_max_typeII maxS StypeP ltqp. +have Ttype2: FTtype T == 2 := FTtypeP_min_typeII maxS maxT StypeP TtypeP ltqp. +have /mmax_exists[L maxNU_L]: 'N(U) \proper setT. + have [[_ ntU _ _] cUU _ _ _] := compl_of_typeII maxS StypeP Stype2. + by rewrite mFT_norm_proper // mFT_sol_proper abelian_sol. +have /mmax_exists[M maxNV_M]: 'N(V) \proper setT. + have [[_ ntV _ _] cVV _ _ _] := compl_of_typeII maxT TtypeP Ttype2. + by rewrite mFT_norm_proper // mFT_sol_proper abelian_sol. +have [[maxL sNU_L] [maxM sNV_M]] := (setIdP maxNU_L, setIdP maxNV_M). +have [frobL sUH _] := FTtypeII_support_facts maxS StypeP Stype2 pairST maxNU_L. +have [frobM _ _] := FTtypeII_support_facts maxT TtypeP Ttype2 pairTS maxNV_M. +have Ltype1 := FT_Frobenius_type1 maxL frobL. +have Mtype1 := FT_Frobenius_type1 maxM frobM. +have [tau1L cohL] := FTtype1_coherence maxL Ltype1. +have [tau1M cohM] := FTtype1_coherence maxM Mtype1. +have [phi Lphi phi1] := FTtype1_ref_irr maxL. +have [psi Mpsi psi1] := FTtype1_ref_irr maxM. +exact: (FTtype2_exclusion pairST maxS maxT StypeP TtypeP ltqp + maxNU_L sNU_L sUH frobL Ltype1 cohL Lphi phi1 + maxNV_M sNV_M frobM Mtype1 cohM Mpsi psi1). +Qed. + +Theorem Feit_Thompson (gT : finGroupType) (G : {group gT}) : + odd #|G| -> solvable G. +Proof. exact: (minSimpleOdd_ind no_minSimple_odd_group). Qed. + +Theorem simple_odd_group_prime (gT : finGroupType) (G : {group gT}) : + odd #|G| -> simple G -> prime #|G|. +Proof. exact: (minSimpleOdd_prime no_minSimple_odd_group). Qed. + + diff --git a/mathcomp/odd_order/PFsection2.v b/mathcomp/odd_order/PFsection2.v new file mode 100644 index 0000000..9eef9e8 --- /dev/null +++ b/mathcomp/odd_order/PFsection2.v @@ -0,0 +1,822 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg poly finset center. +Require Import fingroup morphism perm automorphism quotient action zmodp. +Require Import gfunctor gproduct cyclic pgroup frobenius ssrnum. +Require Import matrix mxalgebra mxrepresentation vector algC classfun character. +Require Import inertia vcharacter PFsection1. + +(******************************************************************************) +(* This file covers Peterfalvi, Section 2: the Dade isometry *) +(* Defined here: *) +(* Dade_hypothesis G L A <-> G, L, and A satisfy the hypotheses under which *) +(* which the Dade isometry relative to G, L and *) +(* A is well-defined. *) +(* For ddA : Dade_hypothesis G L A, we also define *) +(* Dade ddA == the Dade isometry relative to G, L and A. *) +(* Dade_signalizer ddA a == the normal complement to 'C_L[a] in 'C_G[a] for *) +(* a in A (this is usually denoted by H a). *) +(* Dade_support1 ddA a == the set of elements identified with a by the Dade *) +(* isometry. *) +(* Dade_support ddA == the natural support of the Dade isometry. *) +(* The following are used locally in expansion of the Dade isometry as a sum *) +(* of induced characters: *) +(* Dade_transversal ddA == a transversal of the L-conjugacy classes *) +(* of non empty subsets of A. *) +(* Dade_set_signalizer ddA B == the generalization of H to B \subset A, *) +(* denoted 'H(B) below. *) +(* Dade_set_normalizer ddA B == the generalization of 'C_G[a] to B. *) +(* denoted 'M(B) = 'H(B) ><| 'N_L(B) below. *) +(* Dade_cfun_restriction ddA B aa == the composition of aa \in 'CF(L, A) *) +(* with the projection of 'M(B) onto 'N_L(B), *) +(* parallel to 'H(B). *) +(* In addition, if sA1A : A1 \subset A and nA1L : L \subset 'N(A1), we have *) +(* restr_Dade_hyp ddA sA1A nA1L : Dade_hypothesis G L A1 H *) +(* restr_Dade ddA sA1A nA1L == the restriction of the Dade isometry to *) +(* 'CF(L, A1). *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory Num.Theory. +Local Open Scope ring_scope. + +Reserved Notation "alpha ^\tau" (at level 2, format "alpha ^\tau"). + +Section Two. + +Variable gT : finGroupType. + +(* This is Peterfalvi (2.1). *) +Lemma partition_cent_rcoset (H : {group gT}) g (C := 'C_H[g]) (Cg := C :* g) : + g \in 'N(H) -> coprime #|H| #[g] -> + partition (Cg :^: H) (H :* g) /\ #|Cg :^: H| = #|H : C|. +Proof. +move=> nHg coHg; pose pi := \pi(#[g]). +have notCg0: Cg != set0 by apply/set0Pn; exists g; exact: rcoset_refl. +have id_pi: {in Cg, forall u, u.`_ pi = g}. + move=> _ /rcosetP[u /setIP[Hu cgu] ->]; rewrite consttM; last exact/cent1P. + rewrite (constt_p_elt (pgroup_pi _)) (constt1P _) ?mul1g //. + by rewrite (mem_p_elt _ Hu) // /pgroup -coprime_pi' // coprime_sym. +have{id_pi} /and3P[_ tiCg /eqP defC]: normedTI Cg H C. + apply/normedTI_P; rewrite subsetI subsetIl normsM ?normG ?subsetIr //. + split=> // x Hx /pred0Pn[u /andP[/= Cu Cxu]]; rewrite !inE Hx /= conjg_set1. + by rewrite -{2}(id_pi _ Cu) -(conjgKV x u) consttJ id_pi -?mem_conjg. +have{tiCg} partCg := partition_class_support notCg0 tiCg. +have{defC} oCgH: #|Cg :^: H| = #|H : C| by rewrite -defC -astab1Js -card_orbit. +split=> //; congr (partition _ _): (partCg); apply/eqP. +rewrite eqEcard card_rcoset {1}class_supportEr; apply/andP; split. + apply/bigcupsP=> x Hx; rewrite conjsgE -rcosetM conjgCV rcosetM mulgA. + by rewrite mulSg ?mul_subG ?subsetIl // sub1set ?memJ_norm ?groupV. +have oCg Cx: Cx \in Cg :^: H -> #|Cx| = #|C|. + by case/imsetP=> x _ ->; rewrite cardJg card_rcoset. +by rewrite (card_uniform_partition oCg partCg) oCgH mulnC Lagrange ?subsetIl. +Qed. + +Definition is_Dade_signalizer (G L A : {set gT}) (H : gT -> {group gT}) := + {in A, forall a, H a ><| 'C_L[a] = 'C_G[a]}. + +(* This is Peterfalvi Definition (2.2). *) +Definition Dade_hypothesis (G L A : {set gT}) := + [/\ A <| L, L \subset G, 1%g \notin A, + (*a*) {in A &, forall x, {subset x ^: G <= x ^: L}} + & (*b*) exists2 H, is_Dade_signalizer G L A H + & (*c*) {in A &, forall a b, coprime #|H a| #|'C_L[b]| }]. + +Variables (G L : {group gT}) (A : {set gT}). + +Let pi := [pred p | [exists a in A, p \in \pi('C_L[a])]]. + +Let piCL a : a \in A -> pi.-group 'C_L[a]. +Proof. +move=> Aa; apply: sub_pgroup (pgroup_pi _) => p cLa_p. +by apply/exists_inP; exists a. +Qed. + +Fact Dade_signalizer_key : unit. Proof. by []. Qed. +Definition Dade_signalizer_def a := 'O_pi^'('C_G[a])%G. +Definition Dade_signalizer of Dade_hypothesis G L A := + locked_with Dade_signalizer_key Dade_signalizer_def. + +Hypothesis ddA : Dade_hypothesis G L A. +Notation H := (Dade_signalizer ddA). +Canonical Dade_signalizer_unlockable := [unlockable fun H]. + +Let pi'H a : pi^'.-group (H a). Proof. by rewrite unlock pcore_pgroup. Qed. +Let nsHC a : H a <| 'C_G[a]. Proof. by rewrite unlock pcore_normal. Qed. + +Lemma Dade_signalizer_sub a : H a \subset G. +Proof. by have /andP[/subsetIP[]] := nsHC a. Qed. + +Lemma Dade_signalizer_cent a : H a \subset 'C[a]. +Proof. by have /andP[/subsetIP[]] := nsHC a. Qed. + +Let nsAL : A <| L. Proof. by have [->] := ddA. Qed. +Let sAL : A \subset L. Proof. exact: normal_sub nsAL. Qed. +Let nAL : L \subset 'N(A). Proof. exact: normal_norm nsAL. Qed. +Let sLG : L \subset G. Proof. by have [_ ->] := ddA. Qed. +Let notA1 : 1%g \notin A. Proof. by have [_ _ ->] := ddA. Qed. +Let conjAG : {in A &, forall x, {subset x ^: G <= x ^: L}}. +Proof. by have [_ _ _ ? _] := ddA. Qed. +Let sHG := Dade_signalizer_sub. +Let cHA := Dade_signalizer_cent. +Let notHa0 a : H a :* a :!=: set0. +Proof. by rewrite -cards_eq0 -lt0n card_rcoset cardG_gt0. Qed. + +Let HallCL a : a \in A -> pi.-Hall('C_G[a]) 'C_L[a]. +Proof. +move=> Aa; have [_ _ _ _ [H1 /(_ a Aa)/sdprodP[_ defCa _ _] coH1L]] := ddA. +have [|//] := coprime_mulGp_Hall defCa _ (piCL Aa). +apply: sub_pgroup (pgroup_pi _) => p; apply: contraL => /exists_inP[b Ab]. +by apply: (@pnatPpi \pi(_)^'); rewrite -coprime_pi' ?cardG_gt0 ?coH1L. +Qed. + +Lemma def_Dade_signalizer H1 : is_Dade_signalizer G L A H1 -> {in A, H =1 H1}. +Proof. +move=> defH1 a Aa; apply/val_inj; rewrite unlock /=; have defCa := defH1 a Aa. +have /sdprod_context[nsH1Ca _ _ _ _] := defCa. +by apply/normal_Hall_pcore=> //; apply/(sdprod_normal_pHallP _ (HallCL Aa)). +Qed. + +Lemma Dade_sdprod : is_Dade_signalizer G L A H. +Proof. +move=> a Aa; have [_ _ _ _ [H1 defH1 _]] := ddA. +by rewrite (def_Dade_signalizer defH1) ?defH1. +Qed. +Let defCA := Dade_sdprod. + +Lemma Dade_coprime : {in A &, forall a b, coprime #|H a| #|'C_L[b]| }. +Proof. by move=> a b _ Ab; apply: p'nat_coprime (pi'H a) (piCL Ab). Qed. +Let coHL := Dade_coprime. + +Definition Dade_support1 a := class_support (H a :* a) G. +Local Notation dd1 := Dade_support1. + +Lemma mem_Dade_support1 a x : a \in A -> x \in H a -> (x * a)%g \in dd1 a. +Proof. by move=> Aa Hx; rewrite -(conjg1 (x * a)) !mem_imset2 ?set11. Qed. + +(* This is Peterfalvi (2.3), except for the existence part, which is covered *) +(* below in the NormedTI section. *) +Lemma Dade_normedTI_P : + reflect (A != set0 /\ {in A, forall a, H a = 1%G}) (normedTI A G L). +Proof. +apply: (iffP idP) => [tiAG | [nzA trivH]]. + split=> [|a Aa]; first by have [] := andP tiAG. + apply/trivGP; rewrite -(coprime_TIg (coHL Aa Aa)) subsetIidl subsetI cHA. + by rewrite (subset_trans (normal_sub (nsHC a))) ?(cent1_normedTI tiAG). +apply/normedTI_memJ_P; split=> // a g Aa Gg. +apply/idP/idP=> [Aag | Lg]; last by rewrite memJ_norm ?(subsetP nAL). +have /imsetP[k Lk def_ag] := conjAG Aa Aag (mem_imset _ Gg). +suffices: (g * k^-1)%g \in 'C_G[a]. + by rewrite -Dade_sdprod ?trivH // sdprod1g inE groupMr ?groupV // => /andP[]. +rewrite !inE groupM ?groupV // ?(subsetP sLG) //=. +by rewrite conjg_set1 conjgM def_ag conjgK. +Qed. + +(* This is Peterfalvi (2.4)(a) (extended to all a thanks to our choice of H). *) +Lemma DadeJ a x : x \in L -> H (a ^ x) :=: H a :^ x. +Proof. +by move/(subsetP sLG)=> Gx; rewrite unlock -pcoreJ conjIg -cent1J conjGid. +Qed. + +Lemma Dade_support1_id a x : x \in L -> dd1 (a ^ x) = dd1 a. +Proof. +move=> Lx; rewrite {1}/dd1 DadeJ // -conjg_set1 -conjsMg. +by rewrite class_supportGidl ?(subsetP sLG). +Qed. + +Let piHA a u : a \in A -> u \in H a :* a -> u.`_pi = a. +Proof. +move=> Aa /rcosetP[{u}u Hu ->]; have pi'u: pi^'.-elt u by apply: mem_p_elt Hu. +rewrite (consttM _ (cent1P (subsetP (cHA a) u Hu))). +suffices pi_a: pi.-elt a by rewrite (constt1P pi'u) (constt_p_elt _) ?mul1g. +by rewrite (mem_p_elt (piCL Aa)) // inE cent1id (subsetP sAL). +Qed. + +(* This is Peterfalvi (2.4)(b). *) +Lemma Dade_support1_TI : {in A &, forall a b, + ~~ [disjoint dd1 a & dd1 b] -> exists2 x, x \in L & b = a ^ x}. +Proof. +move=> a b Aa Ab /= /pred0Pn[_ /andP[/imset2P[x u /(piHA Aa) def_x Gu ->]]] /=. +case/imset2P=> y v /(piHA Ab) def_y Gv /(canLR (conjgK v)) def_xuv. +have def_b: a ^ (u * v^-1) = b by rewrite -def_x -consttJ conjgM def_xuv def_y. +by apply/imsetP/conjAG; rewrite // -def_b mem_imset ?groupM ?groupV. +Qed. + +(* This is an essential strengthening of Peterfalvi (2.4)(c). *) +Lemma Dade_cover_TI : {in A, forall a, normedTI (H a :* a) G 'C_G[a]}. +Proof. +move=> a Aa; apply/normedTI_P; split=> // [|g Gg]. + by rewrite subsetI subsetIl normsM ?subsetIr ?normal_norm ?nsHC. +rewrite disjoint_sym => /pred0Pn[_ /andP[/imsetP[u Ha_u ->] Ha_ug]]. +by rewrite !inE Gg /= conjg_set1 -{1}(piHA Aa Ha_u) -consttJ (piHA Aa). +Qed. + +(* This is Peterfalvi (2.4)(c). *) +Lemma norm_Dade_cover : {in A, forall a, 'N_G(H a :* a) = 'C_G[a]}. +Proof. by move=> a /Dade_cover_TI /and3P[_ _ /eqP]. Qed. + +Definition Dade_support := \bigcup_(a in A) dd1 a. +Local Notation Atau := Dade_support. + +Lemma not_support_Dade_1 : 1%g \notin Atau. +Proof. +apply: contra notA1 => /bigcupP[a Aa /imset2P[u x Ha_u _ ux1]]. +suffices /set1P <-: a \in [1] by []. +have [_ _ _ <-] := sdprodP (defCA Aa). +rewrite 2!inE cent1id (subsetP sAL) // !andbT. +by rewrite -groupV -(mul1g a^-1)%g -mem_rcoset -(conj1g x^-1) ux1 conjgK. +Qed. + +Lemma Dade_support_sub : Atau \subset G. +Proof. +apply/bigcupsP=> a Aa; rewrite class_support_subG // mul_subG ?sHG //. +by rewrite sub1set (subsetP sLG) ?(subsetP sAL). +Qed. + +Lemma Dade_support_norm : G \subset 'N(Atau). +Proof. +by rewrite norms_bigcup //; apply/bigcapsP=> a _; exact: class_support_norm. +Qed. + +Lemma Dade_support_normal : Atau <| G. +Proof. by rewrite /normal Dade_support_sub Dade_support_norm. Qed. + +Lemma Dade_support_subD1 : Atau \subset G^#. +Proof. by rewrite subsetD1 Dade_support_sub not_support_Dade_1. Qed. + +(* This is Peterfalvi Definition (2.5). *) +Fact Dade_subproof (alpha : 'CF(L)) : + is_class_fun <> [ffun x => oapp alpha 0 [pick a in A | x \in dd1 a]]. +Proof. +rewrite genGid; apply: intro_class_fun => [x y Gx Gy | x notGx]. + congr (oapp _ _); apply: eq_pick => a; rewrite memJ_norm //. + apply: subsetP Gy; exact: class_support_norm. +case: pickP => // a /andP[Aa Ha_u]. +by rewrite (subsetP Dade_support_sub) // in notGx; apply/bigcupP; exists a. +Qed. +Definition Dade alpha := Cfun 1 (Dade_subproof alpha). + +Lemma Dade_is_linear : linear Dade. +Proof. +move=> mu alpha beta; apply/cfunP=> x; rewrite !cfunElock. +by case: pickP => [a _ | _] /=; rewrite ?mulr0 ?addr0 ?cfunE. +Qed. +Canonical Dade_additive := Additive Dade_is_linear. +Canonical Dade_linear := Linear Dade_is_linear. + +Local Notation "alpha ^\tau" := (Dade alpha). + +(* This is the validity of Peterfalvi, Definition (2.5) *) +Lemma DadeE alpha a u : a \in A -> u \in dd1 a -> alpha^\tau u = alpha a. +Proof. +move=> Aa Ha_u; rewrite cfunElock. +have [b /= /andP[Ab Hb_u] | ] := pickP; last by move/(_ a); rewrite Aa Ha_u. +have [|x Lx ->] := Dade_support1_TI Aa Ab; last by rewrite cfunJ. +by apply/pred0Pn; exists u; rewrite /= Ha_u. +Qed. + +Lemma Dade_id alpha : {in A, forall a, alpha^\tau a = alpha a}. +Proof. +by move=> a Aa; rewrite /= -{1}[a]mul1g (DadeE _ Aa) ?mem_Dade_support1. +Qed. + +Lemma Dade_cfunS alpha : alpha^\tau \in 'CF(G, Atau). +Proof. +apply/cfun_onP=> x; rewrite cfunElock. +by case: pickP => [a /andP[Aa Ha_x] /bigcupP[] | //]; exists a. +Qed. + +Lemma Dade_cfun alpha : alpha^\tau \in 'CF(G, G^#). +Proof. by rewrite (cfun_onS Dade_support_subD1) ?Dade_cfunS. Qed. + +Lemma Dade1 alpha : alpha^\tau 1%g = 0. +Proof. by rewrite (cfun_on0 (Dade_cfun _)) // !inE eqxx. Qed. + +Lemma Dade_id1 : + {in 'CF(L, A) & 1%g |: A, forall alpha a, alpha^\tau a = alpha a}. +Proof. +move=> alpha a Aalpha; case/setU1P=> [-> |]; last exact: Dade_id. +by rewrite Dade1 (cfun_on0 Aalpha). +Qed. + +Section AutomorphismCFun. + +Variable u : {rmorphism algC -> algC}. +Local Notation "alpha ^u" := (cfAut u alpha). + +Lemma Dade_aut alpha : (alpha^u)^\tau = (alpha^\tau)^u. +Proof. +apply/cfunP => g; rewrite cfunE. +have [/bigcupP[a Aa A1g] | notAtau_g] := boolP (g \in Atau). + by rewrite !(DadeE _ Aa A1g) cfunE. +by rewrite !(cfun_on0 _ notAtau_g) ?rmorph0 ?Dade_cfunS. +Qed. + +End AutomorphismCFun. + +Lemma Dade_conjC alpha : (alpha^*)^\tau = ((alpha^\tau)^*)%CF. +Proof. exact: Dade_aut. Qed. + +(* This is Peterfalvi (2.7), main part *) +Lemma general_Dade_reciprocity alpha (phi : 'CF(G)) (psi : 'CF(L)) : + alpha \in 'CF(L, A) -> + {in A, forall a, psi a = #|H a|%:R ^-1 * (\sum_(x in H a) phi (x * a)%g)} -> + '[alpha^\tau, phi] = '[alpha, psi]. +Proof. +move=> CFalpha psiA; rewrite (cfdotEl _ (Dade_cfunS _)). +pose T := [set repr (a ^: L) | a in A]. +have sTA: {subset T <= A}. + move=> _ /imsetP[a Aa ->]; have [x Lx ->] := repr_class L a. + by rewrite memJ_norm ?(subsetP nAL). +pose P_G := [set dd1 x | x in T]. +have dd1_id: {in A, forall a, dd1 (repr (a ^: L)) = dd1 a}. + by move=> a Aa /=; have [x Lx ->] := repr_class L a; apply: Dade_support1_id. +have ->: Atau = cover P_G. + apply/setP=> u; apply/bigcupP/bigcupP=> [[a Aa Fa_u] | [Fa]]; last first. + by case/imsetP=> a /sTA Aa -> Fa_u; exists a. + by exists (dd1 a) => //; rewrite -dd1_id //; do 2!apply: mem_imset. +have [tiP_G inj_dd1]: trivIset P_G /\ {in T &, injective dd1}. + apply: trivIimset => [_ _ /imsetP[a Aa ->] /imsetP[b Ab ->] |]; last first. + apply/imsetP=> [[a]]; move/sTA=> Aa; move/esym; move/eqP; case/set0Pn. + by exists (a ^ 1)%g; apply: mem_imset2; rewrite ?group1 ?rcoset_refl. + rewrite !dd1_id //; apply: contraR. + by case/Dade_support1_TI=> // x Lx ->; rewrite classGidl. +rewrite big_trivIset //= big_imset {P_G tiP_G inj_dd1}//=. +symmetry; rewrite (cfdotEl _ CFalpha). +pose P_A := [set a ^: L | a in T]. +have rLid x: repr (x ^: L) ^: L = x ^: L. + by have [y Ly ->] := repr_class L x; rewrite classGidl. +have {1}<-: cover P_A = A. + apply/setP=> a; apply/bigcupP/idP=> [[_ /imsetP[d /sTA Ab ->]] | Aa]. + by case/imsetP=> x Lx ->; rewrite memJ_norm ?(subsetP nAL). + by exists (a ^: L); rewrite ?class_refl // -rLid; do 2!apply: mem_imset. +have [tiP_A injFA]: trivIset P_A /\ {in T &, injective (class^~ L)}. + apply: trivIimset => [_ _ /imsetP[a Aa ->] /imsetP[b Ab ->] |]; last first. + by apply/imsetP=> [[a _ /esym/eqP/set0Pn[]]]; exists a; exact: class_refl. + rewrite !rLid; apply: contraR => /pred0Pn[c /andP[/=]]. + by do 2!move/class_transr <-. +rewrite big_trivIset //= big_imset {P_A tiP_A injFA}//=. +apply: canRL (mulKf (neq0CG G)) _; rewrite mulrA big_distrr /=. +apply: eq_bigr => a /sTA=> {T sTA}Aa. +have [La def_Ca] := (subsetP sAL a Aa, defCA Aa). +rewrite (eq_bigr (fun _ => alpha a * (psi a)^*)) => [|ax]; last first. + by case/imsetP=> x Lx ->{ax}; rewrite !cfunJ. +rewrite sumr_const -index_cent1 mulrC -mulr_natr -!mulrA. +rewrite (eq_bigr (fun xa => alpha a * (phi xa)^*)) => [|xa Fa_xa]; last first. + by rewrite (DadeE _ Aa). +rewrite -big_distrr /= -rmorph_sum; congr (_ * _). +rewrite mulrC mulrA -natrM mulnC -(Lagrange (subsetIl G 'C[a])). +rewrite -mulnA mulnCA -(sdprod_card def_Ca) -mulnA Lagrange ?subsetIl //. +rewrite mulnA natrM mulfK ?neq0CG // -conjC_nat -rmorphM; congr (_ ^*). +have /and3P[_ tiHa _] := Dade_cover_TI Aa. +rewrite (set_partition_big _ (partition_class_support _ _)) //=. +rewrite (eq_bigr (fun _ => \sum_(x in H a) phi (x * a)%g)); last first. + move=> _ /imsetP[x Gx ->]; rewrite -rcosetE. + rewrite (big_imset _ (in2W (conjg_inj x))) (big_imset _ (in2W (mulIg a))) /=. + by apply: eq_bigr => u Hu; rewrite cfunJ ?groupM ?(subsetP sLG a). +rewrite sumr_const card_orbit astab1Js norm_Dade_cover //. +by rewrite natrM -mulrA mulr_natl psiA // mulVKf ?neq0CG. +Qed. + +(* This is Peterfalvi (2.7), second part. *) +Lemma Dade_reciprocity alpha (phi : 'CF(G)) : + alpha \in 'CF(L, A) -> + {in A, forall a, {in H a, forall u, phi (u * a)%g = phi a}} -> + '[alpha^\tau, phi] = '[alpha, 'Res[L] phi]. +Proof. +move=> CFalpha phiH; apply: general_Dade_reciprocity => // a Aa. +rewrite cfResE ?(subsetP sAL) //; apply: canRL (mulKf (neq0CG _)) _. +by rewrite mulr_natl -sumr_const; apply: eq_bigr => x Hx; rewrite phiH. +Qed. + +(* This is Peterfalvi (2.6)(a). *) +Lemma Dade_isometry : {in 'CF(L, A) &, isometry Dade}. +Proof. +move=> alpha beta CFalpha CFbeta /=. +rewrite Dade_reciprocity ?Dade_cfun => // [|a Aa u Hu]; last first. + by rewrite (DadeE _ Aa) ?mem_Dade_support1 ?Dade_id. +rewrite !(cfdotEl _ CFalpha); congr (_ * _); apply: eq_bigr => x Ax. +by rewrite cfResE ?(subsetP sAL) // Dade_id. +Qed. + +(* Supplement to Peterfalvi (2.3)/(2.6)(a); implies Isaacs Lemma 7.7. *) +Lemma Dade_Ind : normedTI A G L -> {in 'CF(L, A), Dade =1 'Ind}. +Proof. +case/Dade_normedTI_P=> _ trivH alpha Aalpha. +rewrite [alpha^\tau]cfun_sum_cfdot ['Ind _]cfun_sum_cfdot. +apply: eq_bigr => i _; rewrite -cfdot_Res_r -Dade_reciprocity // => a Aa /= u. +by rewrite trivH // => /set1P->; rewrite mul1g. +Qed. + +Definition Dade_set_signalizer (B : {set gT}) := \bigcap_(a in B) H a. +Local Notation "''H' ( B )" := (Dade_set_signalizer B) + (at level 8, format "''H' ( B )") : group_scope. +Canonical Dade_set_signalizer_group B := [group of 'H(B)]. +Definition Dade_set_normalizer B := 'H(B) <*> 'N_L(B). +Local Notation "''M' ( B )" := (Dade_set_normalizer B) + (at level 8, format "''M' ( B )") : group_scope. +Canonical Dade_set_normalizer_group B := [group of 'M(B)]. + +Let calP := [set B : {set gT} | B \subset A & B != set0]. + +(* This is Peterfalvi (2.8). *) +Lemma Dade_set_sdprod : {in calP, forall B, 'H(B) ><| 'N_L(B) = 'M(B)}. +Proof. +move=> B /setIdP[sBA notB0]; apply: sdprodEY => /=. + apply/subsetP=> x /setIP[Lx nBx]; rewrite inE. + apply/bigcapsP=> a Ba; have Aa := subsetP sBA a Ba. + by rewrite sub_conjg -DadeJ ?groupV // bigcap_inf // memJ_norm ?groupV. +have /set0Pn[a Ba] := notB0; have Aa := subsetP sBA a Ba. +have [_ /mulG_sub[sHaC _] _ tiHaL] := sdprodP (defCA Aa). +rewrite -(setIidPl sLG) -setIA setICA (setIidPl sHaC) in tiHaL. +by rewrite setICA ['H(B)](bigD1 a) //= !setIA tiHaL !setI1g. +Qed. + +Section DadeExpansion. + +Variable aa : 'CF(L). +Hypothesis CFaa : aa \in 'CF(L, A). + +Definition Dade_restrm B := + if B \in calP then remgr 'H(B) 'N_L(B) else trivm 'M(B). +Fact Dade_restrM B : {in 'M(B) &, {morph Dade_restrm B : x y / x * y}%g}. +Proof. +rewrite /Dade_restrm; case: ifP => calP_B; last exact: morphM. +have defM := Dade_set_sdprod calP_B; have [nsHM _ _ _ _] := sdprod_context defM. +by apply: remgrM; first exact: sdprod_compl. +Qed. +Canonical Dade_restr_morphism B := Morphism (@Dade_restrM B). +Definition Dade_cfun_restriction B := + cfMorph ('Res[Dade_restrm B @* 'M(B)] aa). + +Local Notation "''aa_' B" := (Dade_cfun_restriction B) + (at level 3, B at level 2, format "''aa_' B") : ring_scope. + +Definition Dade_transversal := [set repr (B :^: L) | B in calP]. +Local Notation calB := Dade_transversal. + +Lemma Dade_restrictionE B x : + B \in calP -> 'aa_B x = aa (remgr 'H(B) 'N_L(B) x) *+ (x \in 'M(B)). +Proof. +move=> calP_B; have /sdprodP[_ /= defM _ _] := Dade_set_sdprod calP_B. +have [Mx | /cfun0-> //] := boolP (x \in 'M(B)). +rewrite mulrb cfMorphE // morphimEdom /= /Dade_restrm calP_B. +rewrite cfResE ?mem_imset {x Mx}//= -defM. +by apply/subsetP=> _ /imsetP[x /mem_remgr/setIP[Lx _] ->]. +Qed. +Local Notation rDadeE := Dade_restrictionE. + +Lemma Dade_restriction_vchar B : aa \in 'Z[irr L] -> 'aa_B \in 'Z[irr 'M(B)]. +Proof. +rewrite /'aa_B => /vcharP[a1 Na1 [a2 Na2 ->]]. +by rewrite !linearB /= rpredB // char_vchar ?cfMorph_char ?cfRes_char. +Qed. + +Let sMG B : B \in calP -> 'M(B) \subset G. +Proof. +case/setIdP=> /subsetP sBA /set0Pn[a Ba]. +by rewrite join_subG ['H(B)](bigD1 a Ba) !subIset ?sLG ?sHG ?sBA. +Qed. + +(* This is Peterfalvi (2.10.1) *) +Lemma Dade_Ind_restr_J : + {in L & calP, forall x B, 'Ind[G] 'aa_(B :^ x) = 'Ind[G] 'aa_B}. +Proof. +move=> x B Lx dB; have [defMB [sBA _]] := (Dade_set_sdprod dB, setIdP dB). +have dBx: B :^ x \in calP. + by rewrite !inE -{2}(normsP nAL x Lx) conjSg -!cards_eq0 cardJg in dB *. +have defHBx: 'H(B :^ x) = 'H(B) :^ x. + rewrite /'H(_) (big_imset _ (in2W (conjg_inj x))) -bigcapJ /=. + by apply: eq_bigr => a Ba; rewrite DadeJ ?(subsetP sBA). +have defNBx: 'N_L(B :^ x) = 'N_L(B) :^ x by rewrite conjIg -normJ (conjGid Lx). +have [_ mulHNB _ tiHNB] := sdprodP defMB. +have defMBx: 'M(B :^ x) = 'M(B) :^ x. + rewrite -mulHNB conjsMg -defHBx -defNBx. + by case/sdprodP: (Dade_set_sdprod dBx). +have def_aa_x y: 'aa_(B :^ x) (y ^ x) = 'aa_B y. + rewrite !rDadeE // defMBx memJ_conjg !mulrb -mulHNB defHBx defNBx. + have [[h z Hh Nz ->] | // ] := mulsgP. + by rewrite conjMg !remgrMid ?cfunJ ?memJ_conjg // -conjIg tiHNB conjs1g. +apply/cfunP=> y; have Gx := subsetP sLG x Lx. +rewrite [eq]lock !cfIndE ?sMG //= {1}defMBx cardJg -lock; congr (_ * _). +rewrite (reindex_astabs 'R x) ?astabsR //=. +by apply: eq_bigr => z _; rewrite conjgM def_aa_x. +Qed. + +(* This is Peterfalvi (2.10.2) *) +Lemma Dade_setU1 : {in calP & A, forall B a, 'H(a |: B) = 'C_('H(B))[a]}. +Proof. +move=> B a dB Aa; rewrite /'H(_) bigcap_setU big_set1 -/'H(B). +apply/eqP; rewrite setIC eqEsubset setIS // subsetI subsetIl /=. +have [sHBG pi'HB]: 'H(B) \subset G /\ pi^'.-group 'H(B). + have [sBA /set0Pn[b Bb]] := setIdP dB; have Ab := subsetP sBA b Bb. + have sHBb: 'H(B) \subset H b by rewrite ['H(B)](bigD1 b) ?subsetIl. + by rewrite (pgroupS sHBb) ?pi'H ?(subset_trans sHBb) ?sHG. +have [nsHa _ defCa _ _] := sdprod_context (defCA Aa). +have [hallHa _] := coprime_mulGp_Hall defCa (pi'H a) (piCL Aa). +by rewrite (sub_normal_Hall hallHa) ?(pgroupS (subsetIl _ _)) ?setSI. +Qed. + +Let calA g (X : {set gT}) := [set x in G | g ^ x \in X]%g. + +(* This is Peterfalvi (2.10.3) *) +Lemma Dade_Ind_expansion B g : + B \in calP -> + [/\ g \notin Atau -> ('Ind[G, 'M(B)] 'aa_B) g = 0 + & {in A, forall a, g \in dd1 a -> + ('Ind[G, 'M(B)] 'aa_B) g = + (aa a / #|'M(B)|%:R) * + \sum_(b in 'N_L(B) :&: a ^: L) #|calA g ('H(B) :* b)|%:R}]. +Proof. +move=> dB; set LHS := 'Ind _ g. +have defMB := Dade_set_sdprod dB; have [_ mulHNB nHNB tiHNB] := sdprodP defMB. +have [sHMB sNMB] := mulG_sub mulHNB. +have{LHS} ->: LHS = #|'M(B)|%:R^-1 * \sum_(x in calA g 'M(B)) 'aa_B (g ^ x). + rewrite {}/LHS cfIndE ?sMG //; congr (_ * _). + rewrite (bigID [pred x | g ^ x \in 'M(B)]) /= addrC big1 ?add0r => [|x]. + by apply: eq_bigl => x; rewrite inE. + by case/andP=> _ notMgx; rewrite cfun0. +pose fBg x := remgr 'H(B) 'N_L(B) (g ^ x). +pose supp_aBg := [pred b in A | g \in dd1 b]. +have supp_aBgP: {in calA g 'M(B), forall x, + ~~ supp_aBg (fBg x) -> 'aa_B (g ^ x)%g = 0}. +- move=> x /setIdP[]; set b := fBg x => Gx MBgx notHGx; rewrite rDadeE // MBgx. + have Nb: b \in 'N_L(B) by rewrite mem_remgr ?mulHNB. + have Cb: b \in 'C_L[b] by rewrite inE cent1id; have [-> _] := setIP Nb. + rewrite (cfun_on0 CFaa) // -/(fBg x) -/b; apply: contra notHGx => Ab. + have nHb: b \in 'N('H(B)) by rewrite (subsetP nHNB). + have [sBA /set0Pn[a Ba]] := setIdP dB; have Aa := subsetP sBA a Ba. + have [|/= partHBb _] := partition_cent_rcoset nHb. + rewrite (coprime_dvdr (order_dvdG Cb)) //= ['H(B)](bigD1 a) //=. + by rewrite (coprimeSg (subsetIl _ _)) ?coHL. + have Hb_gx: g ^ x \in 'H(B) :* b by rewrite mem_rcoset mem_divgr ?mulHNB. + have [defHBb _ _] := and3P partHBb; rewrite -(eqP defHBb) in Hb_gx. + case/bigcupP: Hb_gx => Cy; case/imsetP=> y HBy ->{Cy} Cby_gx. + have sHBa: 'H(B) \subset H a by rewrite bigcap_inf. + have sHBG: 'H(B) \subset G := subset_trans sHBa (sHG a). + rewrite Ab -(memJ_conjg _ x) class_supportGidr // -(conjgKV y (g ^ x)). + rewrite mem_imset2 // ?(subsetP sHBG) {HBy}// -mem_conjg. + apply: subsetP Cby_gx; rewrite {y}conjSg mulSg //. + have [nsHb _ defCb _ _] := sdprod_context (defCA Ab). + have [hallHb _] := coprime_mulGp_Hall defCb (pi'H b) (piCL Ab). + rewrite (sub_normal_Hall hallHb) ?setSI // (pgroupS _ (pi'H a)) //=. + by rewrite subIset ?sHBa. +split=> [notHGg | a Aa Hag]. + rewrite big1 ?mulr0 // => x; move/supp_aBgP; apply; set b := fBg x. + by apply: contra notHGg; case/andP=> Ab Hb_x; apply/bigcupP; exists b. +rewrite -mulrA mulrCA; congr (_ * _); rewrite big_distrr /=. +set nBaL := _ :&: _; rewrite (bigID [pred x | fBg x \in nBaL]) /= addrC. +rewrite big1 ?add0r => [|x /andP[calAx not_nBaLx]]; last first. + apply: supp_aBgP => //; apply: contra not_nBaLx. + set b := fBg x => /andP[Ab Hb_g]; have [Gx MBx] := setIdP calAx. + rewrite inE mem_remgr ?mulHNB //; apply/imsetP/Dade_support1_TI => //. + by apply/pred0Pn; exists g; exact/andP. +rewrite (partition_big fBg (mem nBaL)) /= => [|x]; last by case/andP. +apply: eq_bigr => b; case/setIP=> Nb aLb; rewrite mulr_natr -sumr_const. +apply: eq_big => x; rewrite ![x \in _]inE -!andbA. + apply: andb_id2l=> Gx; apply/and3P/idP=> [[Mgx _] /eqP <- | HBb_gx]. + by rewrite mem_rcoset mem_divgr ?mulHNB. + suffices ->: fBg x = b. + by rewrite inE Nb (subsetP _ _ HBb_gx) // -mulHNB mulgS ?sub1set. + by rewrite /fBg; have [h Hh ->] := rcosetP HBb_gx; exact: remgrMid. +move/and4P=> [_ Mgx _ /eqP def_fx]. +rewrite rDadeE // Mgx -/(fBg x) def_fx; case/imsetP: aLb => y Ly ->. +by rewrite cfunJ // (subsetP sAL). +Qed. + +(* This is Peterfalvi (2.10) *) +Lemma Dade_expansion : + aa^\tau = - \sum_(B in calB) (- 1) ^+ #|B| *: 'Ind[G, 'M(B)] 'aa_B. +Proof. +apply/cfunP=> g; rewrite !cfunElock sum_cfunE. +pose n1 (B : {set gT}) : algC := (-1) ^+ #|B| / #|L : 'N_L(B)|%:R. +pose aa1 B := ('Ind[G, 'M(B)] 'aa_B) g. +have dBJ: {acts L, on calP | 'Js}. + move=> x Lx /= B; rewrite !inE -!cards_eq0 cardJg. + by rewrite -{1}(normsP nAL x Lx) conjSg. +transitivity (- (\sum_(B in calP) n1 B * aa1 B)); last first. + congr (- _); rewrite {1}(partition_big_imset (fun B => repr (B :^: L))) /=. + apply: eq_bigr => B /imsetP[B1 dB1 defB]. + have B1L_B: B \in B1 :^: L by rewrite defB (mem_repr B1) ?orbit_refl. + have{dB1} dB1L: {subset B1 :^: L <= calP}. + by move=> _ /imsetP[x Lx ->]; rewrite dBJ. + have dB: B \in calP := dB1L B B1L_B. + rewrite (eq_bigl (mem (B :^: L))) => [|B2 /=]; last first. + apply/andP/idP=> [[_ /eqP <-] | /(orbit_trans B1L_B) B1L_B2]. + by rewrite orbit_sym (mem_repr B2) ?orbit_refl. + by rewrite [B2 :^: L](orbit_transl B1L_B2) -defB dB1L. + rewrite (eq_bigr (fun _ => n1 B * aa1 B)) => [|_ /imsetP[x Lx ->]]. + rewrite cfunE sumr_const -mulr_natr mulrAC card_orbit astab1Js divfK //. + by rewrite pnatr_eq0 -lt0n indexg_gt0. + rewrite /aa1 Dade_Ind_restr_J //; congr (_ * _). + by rewrite /n1 cardJg -{1 2}(conjGid Lx) normJ -conjIg indexJg. +case: pickP => /= [a /andP[Aa Ha_g] | notHAg]; last first. + rewrite big1 ?oppr0 // /aa1 => B dB. + have [->] := Dade_Ind_expansion g dB; first by rewrite mulr0. + by apply/bigcupP=> [[a Aa Ha_g]]; case/andP: (notHAg a). +pose P_ b := [set B in calP | b \in 'N_L(B)]. +pose aa2 B b : algC := #|calA g ('H(B) :* b)|%:R. +pose nn2 (B : {set gT}) : algC := (-1) ^+ #|B| / #|'H(B)|%:R. +pose sumB b := \sum_(B in P_ b) nn2 B * aa2 B b. +transitivity (- aa a / #|L|%:R * \sum_(b in a ^: L) sumB b); last first. + rewrite !mulNr; congr (- _). + rewrite (exchange_big_dep (mem calP)) => [|b B _] /=; last by case/setIdP. + rewrite big_distrr /aa1; apply: eq_bigr => B dB; rewrite -big_distrr /=. + have [_ /(_ a) -> //] := Dade_Ind_expansion g dB; rewrite !mulrA. + congr (_ * _); last by apply: eq_bigl => b; rewrite inE dB /= andbC -in_setI. + rewrite -mulrA mulrCA -!mulrA; congr (_ * _). + rewrite -invfM mulrCA -invfM -!natrM; congr (_ / _%:R). + rewrite -(sdprod_card (Dade_set_sdprod dB)) mulnA mulnAC; congr (_ * _)%N. + by rewrite mulnC Lagrange ?subsetIl. +rewrite (eq_bigr (fun _ => sumB a)) /= => [|_ /imsetP[x Lx ->]]; last first. + rewrite {1}/sumB (reindex_inj (@conjsg_inj _ x)) /=. + symmetry; apply: eq_big => B. + rewrite ![_ \in P_ _]inE dBJ //. + by rewrite -{2}(conjGid Lx) normJ -conjIg memJ_conjg. + case/setIdP=> dB Na; have [sBA _] := setIdP dB. + have defHBx: 'H(B :^ x) = 'H(B) :^ x. + rewrite /'H(_) (big_imset _ (in2W (conjg_inj x))) -bigcapJ /=. + by apply: eq_bigr => b Bb; rewrite DadeJ ?(subsetP sBA). + rewrite /nn2 /aa2 defHBx !cardJg; congr (_ * _%:R). + rewrite -(card_rcoset _ x); apply: eq_card => y. + rewrite !(inE, mem_rcoset, mem_conjg) conjMg conjVg conjgK -conjgM. + by rewrite groupMr // groupV (subsetP sLG). +rewrite sumr_const mulrC [sumB a](bigD1 [set a]) /=; last first. + by rewrite 3!inE cent1id sub1set Aa -cards_eq0 cards1 (subsetP sAL). +rewrite -[_ *+ _]mulr_natr -mulrA mulrDl -!mulrA ['H(_)]big_set1 cards1. +have ->: aa2 [set a] a = #|'C_G[a]|%:R. + have [u x Ha_ux Gx def_g] := imset2P Ha_g. + rewrite -(card_lcoset _ x^-1); congr _%:R; apply: eq_card => y. + rewrite ['H(_)]big_set1 mem_lcoset invgK inE def_g -conjgM. + rewrite -(groupMl y Gx) inE; apply: andb_id2l => Gxy. + by have [_ _ -> //] := normedTI_memJ_P (Dade_cover_TI Aa); rewrite inE Gxy. +rewrite mulN1r mulrC mulrA -natrM -(sdprod_card (defCA Aa)). +rewrite -mulnA card_orbit astab1J Lagrange ?subsetIl // mulnC natrM. +rewrite mulrAC mulfK ?neq0CG // mulrC divfK ?neq0CG // opprK. +rewrite (bigID [pred B : {set gT} | a \in B]) /= mulrDl addrA. +apply: canRL (subrK _) _; rewrite -mulNr -sumrN; congr (_ + _ * _). +symmetry. +rewrite (reindex_onto (fun B => a |: B) (fun B => B :\ a)) /=; last first. + by move=> B; case/andP=> _; exact: setD1K. +symmetry; apply: eq_big => B. + rewrite setU11 andbT -!andbA; apply/and3P/and3P; case. + do 2![case/setIdP] => sBA ntB /setIP[La nBa] _ notBa. + rewrite 3!inE subUset sub1set Aa sBA La setU1K // -cards_eq0 cardsU1 notBa. + rewrite -sub1set normsU ?sub1set ?cent1id //= eq_sym eqEcard subsetUl /=. + by rewrite cards1 cardsU1 notBa ltnS leqn0 cards_eq0. + do 2![case/setIdP] => /subUsetP[_ sBA] _ /setIP[La]. + rewrite inE conjUg (normP (cent1id a)) => /subUsetP[_ sBa_aB]. + rewrite eq_sym eqEcard subsetUl cards1 (cardsD1 a) setU11 ltnS leqn0 /=. + rewrite cards_eq0 => notB0 /eqP defB. + have notBa: a \notin B by rewrite -defB setD11. + split=> //; last by apply: contraNneq notBa => ->; exact: set11. + rewrite !inE sBA La -{1 3}defB notB0 subsetD1 sBa_aB. + by rewrite mem_conjg /(a ^ _) invgK mulgA mulgK. +do 2![case/andP] => /setIdP[dB Na] _ notBa. +suffices ->: aa2 B a = #|'H(B) : 'H(a |: B)|%:R * aa2 (a |: B) a. + rewrite /nn2 cardsU1 notBa exprS mulN1r !mulNr; congr (- _). + rewrite !mulrA; congr (_ * _); rewrite -!mulrA; congr (_ * _). + apply: canLR (mulKf (neq0CG _)) _; apply: canRL (mulfK (neq0CG _)) _ => /=. + by rewrite -natrM mulnC Lagrange //= Dade_setU1 ?subsetIl. +rewrite /aa2 Dade_setU1 //= -natrM; congr _%:R. +have defMB := Dade_set_sdprod dB; have [_ mulHNB nHNB tiHNB] := sdprodP defMB. +have [sHMB sNMB] := mulG_sub mulHNB; have [La nBa] := setIP Na. +have nHa: a \in 'N('H(B)) by rewrite (subsetP nHNB). +have Ca: a \in 'C_L[a] by rewrite inE cent1id La. +have [|/= partHBa nbHBa] := partition_cent_rcoset nHa. + have [sBA] := setIdP dB; case/set0Pn=> b Bb; have Ab := subsetP sBA b Bb. + rewrite (coprime_dvdr (order_dvdG Ca)) //= ['H(B)](bigD1 b) //=. + by rewrite (coprimeSg (subsetIl _ _)) ?coHL. +pose pHBa := mem ('H(B) :* a). +rewrite -sum1_card (partition_big (fun x => g ^ x) pHBa) /= => [|x]; last first. + by case/setIdP=> _ ->. +rewrite (set_partition_big _ partHBa) /= -nbHBa -sum_nat_const. +apply: eq_bigr => _ /imsetP[x Hx ->]. +rewrite (big_imset _ (in2W (conjg_inj x))) /=. +rewrite -(card_rcoset _ x) -sum1_card; symmetry; set HBaa := 'C_(_)[a] :* a. +rewrite (partition_big (fun y => g ^ (y * x^-1)) (mem HBaa)); last first. + by move=> y; rewrite mem_rcoset => /setIdP[]. +apply: eq_bigr => /= u Ca_u; apply: eq_bigl => z. +rewrite -(canF_eq (conjgKV x)) -conjgM; apply: andb_id2r; move/eqP=> def_u. +have sHBG: 'H(B) \subset G. + have [sBA /set0Pn[b Bb]] := setIdP dB; have Ab := subsetP sBA b Bb. + by rewrite (bigcap_min b) ?sHG. +rewrite mem_rcoset !inE groupMr ?groupV ?(subsetP sHBG x Hx) //=. +congr (_ && _); have [/eqP defHBa _ _] := and3P partHBa. +symmetry; rewrite def_u Ca_u -defHBa -(mulgKV x z) conjgM def_u -/HBaa. +by rewrite cover_imset -class_supportEr mem_imset2. +Qed. + +End DadeExpansion. + +(* This is Peterfalvi (2.6)(b) *) +Lemma Dade_vchar alpha : alpha \in 'Z[irr L, A] -> alpha^\tau \in 'Z[irr G]. +Proof. +rewrite [alpha \in _]zchar_split => /andP[Zaa CFaa]. +rewrite Dade_expansion // rpredN rpred_sum // => B dB. +suffices calP_B: B \in calP. + by rewrite rpredZsign cfInd_vchar // Dade_restriction_vchar. +case/imsetP: dB => B0 /setIdP[sB0A notB00] defB. +have [x Lx ->]: exists2 x, x \in L & B = B0 :^ x. + by apply/imsetP; rewrite defB (mem_repr B0) ?orbit_refl. +by rewrite inE -cards_eq0 cardJg cards_eq0 -(normsP nAL x Lx) conjSg sB0A. +Qed. + +(* This summarizes Peterfalvi (2.6). *) +Lemma Dade_Zisometry : {in 'Z[irr L, A], isometry Dade, to 'Z[irr G, G^#]}. +Proof. +split; first by apply: sub_in2 Dade_isometry; exact: zchar_on. +by move=> phi Zphi; rewrite /= zchar_split Dade_vchar ?Dade_cfun. +Qed. + +End Two. + +Section RestrDade. + +Variables (gT : finGroupType) (G L : {group gT}) (A A1 : {set gT}). +Hypothesis ddA : Dade_hypothesis G L A. +Hypotheses (sA1A : A1 \subset A) (nA1L : L \subset 'N(A1)). +Let ssA1A := subsetP sA1A. + +(* This is Peterfalvi (2.11), first part. *) +Lemma restr_Dade_hyp : Dade_hypothesis G L A1. +Proof. +have [/andP[sAL nAL] notA_1 sLG conjAG [H defCa coHL]] := ddA. +have nsA1L: A1 <| L by rewrite /normal (subset_trans sA1A). +split; rewrite ?(contra (@ssA1A _)) //; first exact: sub_in2 conjAG. +by exists H; [exact: sub_in1 defCa | exact: sub_in2 coHL]. +Qed. +Local Notation ddA1 := restr_Dade_hyp. + +Local Notation H dd := (Dade_signalizer dd). +Lemma restr_Dade_signalizer H1 : {in A, H ddA =1 H1} -> {in A1, H ddA1 =1 H1}. +Proof. +move=> defH1; apply: def_Dade_signalizer => a /ssA1A Aa. +by rewrite -defH1 ?Dade_sdprod. +Qed. + +Lemma restr_Dade_support1 : {in A1, Dade_support1 ddA1 =1 Dade_support1 ddA}. +Proof. +by move=> a A1a; rewrite /Dade_support1 (@restr_Dade_signalizer (H ddA)). +Qed. + +Lemma restr_Dade_support : + Dade_support ddA1 = \bigcup_(a in A1) Dade_support1 ddA a. +Proof. by rewrite -(eq_bigr _ restr_Dade_support1). Qed. + +Definition restr_Dade := Dade ddA1. + +(* This is Peterfalvi (2.11), second part. *) +Lemma restr_DadeE : {in 'CF(L, A1), restr_Dade =1 Dade ddA}. +Proof. +move=> aa CF1aa; apply/cfunP=> g; rewrite cfunElock. +have CFaa: aa \in 'CF(L, A) := cfun_onS sA1A CF1aa. +have [a /= /andP[A1a Ha_g] | no_a /=] := pickP. + by apply/esym/DadeE; rewrite -1?restr_Dade_support1 ?ssA1A. +rewrite cfunElock; case: pickP => //= a /andP[_ Ha_g]. +rewrite (cfun_on0 CF1aa) //; apply: contraFN (no_a a) => A1a. +by rewrite A1a restr_Dade_support1. +Qed. + +End RestrDade. + +Section NormedTI. + +Variables (gT : finGroupType) (G L : {group gT}) (A : {set gT}). +Hypotheses (tiAG : normedTI A G L) (sAG1 : A \subset G^#). + +(* This is the existence part of Peterfalvi (2.3). *) +Lemma normedTI_Dade : Dade_hypothesis G L A. +Proof. +have [[sAG notA1] [_ _ /eqP defL]] := (subsetD1P sAG1, and3P tiAG). +have [_ sLG tiAG_L] := normedTI_memJ_P tiAG. +split=> // [|a b Aa Ab /imsetP[x Gx def_b]|]. +- rewrite /(A <| L) -{2}defL subsetIr andbT; apply/subsetP=> a Aa. + by rewrite -(tiAG_L a) ?(subsetP sAG) // conjgE mulKg. +- by rewrite def_b mem_imset // -(tiAG_L a) -?def_b. +exists (fun _ => 1%G) => [a Aa | a b _ _]; last by rewrite cards1 coprime1n. +by rewrite sdprod1g -(setIidPl sLG) -setIA (setIidPr (cent1_normedTI tiAG Aa)). +Qed. + +Let def_ddA := Dade_Ind normedTI_Dade tiAG. + +(* This is the identity part of Isaacs, Lemma 7.7. *) +Lemma normedTI_Ind_id1 : + {in 'CF(L, A) & 1%g |: A, forall alpha, 'Ind[G] alpha =1 alpha}. +Proof. by move=> aa a CFaa A1a; rewrite /= -def_ddA // Dade_id1. Qed. + +(* A more restricted, but more useful form. *) +Lemma normedTI_Ind_id : + {in 'CF(L, A) & A, forall alpha, 'Ind[G] alpha =1 alpha}. +Proof. by apply: sub_in11 normedTI_Ind_id1 => //; apply/subsetP/subsetUr. Qed. + +(* This is the isometry part of Isaacs, Lemma 7.7. *) +(* The statement in Isaacs is slightly more general in that it allows for *) +(* beta \in 'CF(L, 1%g |: A); this appears to be more cumbersome than useful. *) +Lemma normedTI_isometry : {in 'CF(L, A) &, isometry 'Ind[G]}. +Proof. by move=> aa bb CFaa CFbb; rewrite /= -!def_ddA // Dade_isometry. Qed. + +End NormedTI. \ No newline at end of file diff --git a/mathcomp/odd_order/PFsection3.v b/mathcomp/odd_order/PFsection3.v new file mode 100644 index 0000000..063aacc --- /dev/null +++ b/mathcomp/odd_order/PFsection3.v @@ -0,0 +1,1854 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg matrix poly finset. +Require Import fingroup morphism perm automorphism quotient action finalg zmodp. +Require Import gfunctor center gproduct cyclic pgroup abelian frobenius. +Require Import mxalgebra mxrepresentation vector falgebra fieldext galois. +Require Import ssrnum rat algC algnum classfun character. +Require Import integral_char inertia vcharacter. +Require Import PFsection1 PFsection2. + +(******************************************************************************) +(* This file covers Peterfalvi, Section 3: TI-Subsets with Cyclic Normalizers *) +(******************************************************************************) +(* Given a direct product decomposition defW : W1 \x W2 = W, we define here: *) +(* cyclicTIset defW == the set complement of W1 and W2 in W; this *) +(* (locally) V definition is usually Let-bound to V. *) +(* := W :\: (W1 :|: W2). *) +(* cyclicTI_hypothesis G defW <-> W is a cyclic of odd order that is the *) +(* normaliser in G of its non-empty TI subset *) +(* V = cyclicTIset defW = W :\: (W1 :|: W2). *) +(* -> This is Peterfalvi, Hypothesis (3.1), or Feit-Thompson (13.1). *) +(* cyclicTIirr defW i j == the irreducible character of W coinciding with *) +(* (locally) w_ i j chi_i and 'chi_j on W1 and W2, respectively. *) +(* This notation is usually Let-bound to w_ i j. *) +(* := 'chi_(dprod_Iirr defW (i, j)). *) +(* cfCyclicTIset defW i j == the virtual character of 'Z[irr W, V] coinciding *) +(* (locally) alpha_ i j with 1 - chi_i and 1 - 'chi_j on W1 and W2, *) +(* respectively. This definition is denoted by *) +(* alpha_ i j in this file, and is only used in the *) +(* proof if Peterfalvi (13.9) in the sequel. *) +(* := cfDprod defW (1 - 'chi_i) (1 - 'chi_j). *) +(* = 1 - w_ i 0 - w_ 0 j + w_ i j. *) +(* cfCyclicTIsetBase defW := the tuple of all the alpha_ i j, for i, j != 0. *) +(* (locally) cfWVbase This is a basis of 'CF(W, V); this definition is *) +(* not used outside this file. *) +(* For ctiW : cyclicTI_hypothesis defW G we also define *) +(* cyclicTIiso ctiW == a linear isometry from 'CF(W) to 'CF(G) that *) +(* (locally) sigma that extends induction on 'CF(W, V), maps the *) +(* w_ i j to virtual characters, and w_ 0 0 to 1. *) +(* This definition is usually Let-bound to sigma, *) +(* and only depends extensionally on W, V and G. *) +(* (locally) eta_ i j := sigma (w_ i j), as in sections 13 and 14 of *) +(* tha Peterfalv text. *) +(* cyclicTI_NC ctiW phi == the number of eta_ i j constituents of phi. *) +(* (locally) NC phi := #|[set ij | '[phi, eta_ ij .1 ij.2] != 0]|. *) +(* The construction of sigma involves a large combinatorial proof, for which *) +(* it is worthwhile to use reflection techniques to automate mundane and *) +(* repetitive arguments. We isolate the necessary boilerplate in a separate *) +(* CyclicTIisoReflexion module. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory Num.Theory. +Local Open Scope ring_scope. + +Section Definitions. + +Variables (gT : finGroupType) (G W W1 W2 : {set gT}). + +Definition cyclicTIset of W1 \x W2 = W := W :\: (W1 :|: W2). + +Definition cyclicTI_hypothesis (defW : W1 \x W2 = W) := + [/\ cyclic W, odd #|W| & normedTI (cyclicTIset defW) G W]. + +End Definitions. + +(* These is defined as a Notation which clients can bind with a Section Let *) +(* that can be folded easily. *) +Notation cyclicTIirr defW i j := 'chi_(dprod_Iirr defW (i, j)). + +Module CyclicTIisoReflexion. + +(******************************************************************************) +(* Support for carrying out the combinatorial parts of the proof of Theorem *) +(* (3.5) by reflection. Specifically, we need to show that in a rectangular *) +(* array of virtual characters of norm 3, of even dimensions, and such that *) +(* the dot product of two entries is 1 if they are on the same row or column, *) +(* the entries of each column contain a "pivot" normal virtual character *) +(* orthogonal to all other columns. The proof never needs to consider more *) +(* than a 4 x 2 rectangle, but frequently renumbers lines, columns and *) +(* orthonormal components in order to do so. *) +(* We want to use reflection to automate this renumbering; we also want to *) +(* automate the evaluation of the dot product constaints for partially *) +(* described entries of the matrix. *) +(* To do so we define a "theory" data structure to store a reifed form of *) +(* such partial descriptions: a set of "clauses", each consisting in an index *) +(* (i, j) into the array, and a collection of "literals" (k, v) representing *) +(* constraints '[b_(i, j), x`_k] = v%:~R, with v = 0, 1 or -1. A clause with *) +(* exactly three nonzero literals defines b_(i, j) exactly. *) +(* We define special notation for the concrete instances that appear in *) +(* reflected proofs; for example *) +(* |= & b11 = -x1 + x2 + x3 & x1, ~x2 in b12 & ? in b31 *) +(* denotes the "theory" of arrays whose two left entries decomposes into *) +(* x1 + x2 + x3 for some orthonormal x1, x2, and x3, such that the second top *) +(* entry has x1 is a signed component but is orthogonal to x2, and which have *) +(* an (unconstrained) first entry in the third column. (The concrete encoding *) +(* shifts indices to start at 0.) *) +(* The "models" in which such theories are interpreted supply the dimensions *) +(* of the array, which must be even, nonequal and at least 2, the function *) +(* mapping indices to array entries, which must be virtual characters with *) +(* the requisite norms and dot products, and an orthonormal sequence of *) +(* virtual characters that will be used to interpret the xij; a model coerces *) +(* to any of these three components. *) +(* We are primarily interested in two predicates: *) +(* sat m th <=> the interpretation of th in m is well-defined (no out of *) +(* bound indices) and valid (all constraints true). *) +(* unsat th <-> forall m, ~ sat m th *) +(* While the main theorem of this section, column_pivot, can be seen as an *) +(* instance of "sat", all the principal combinatorial lemmas use "unsat", *) +(* whose universal quantifier allows symmetry reductions. We present the set *) +(* of lemmas implementing reflection-assisted proofs of "unsat th" as a small *) +(* domain-specific proof language consisting of the following tactics: *) +(* consider bij ::= add a clause for bij, which must not appear in th, *) +(* changing the goal to unsat th & ? in bij. *) +(* bij must be within a 4 x 2 bounding box, and th *) +(* must be symmetric if bij "breaks" the 2 x 2 box. *) +(* fill bij ::= add an x(k.+1) literal to the bij clause in th, *) +(* where x1, ..., xk are all the normal characters *) +(* appearing in th, and the clause for bij exists and *) +(* contains assumptions for all of x1, ..., xk, at *) +(* two of which are nonzero. *) +(* uwlog Dcl: cl [by tac] ::= add the clause cl to th, replacing an existing *) +(* clause for the same matrix entry. This produces a *) +(* side goal of unsat th, but with an additional *) +(* assumption Dcl : unsat th+cl, which can be resolved *) +(* with the optional "by tac". *) +(* uhave lit in bij as T(ij, kl) ::= adds the literal lit (one of xk, -xk, or *) +(* ~xk) to an existing clause for bij in th, using the *) +(* reflection lemma T(ij, kl) to rule out the other *) +(* possibilities for xk. Here T can be either O *) +(* (general dot product evaluation) or L (specific *) +(* line/column constraints following from (3.5.2)). *) +(* uhave lit, lit' in bij as T(ij, kl) ::= adds both lit and lit'. *) +(* uhave lit | lit' in bij as T(ij, kl) ::= produces two subgoals, where lit *) +(* (resp. lit') is added to the ... in bij clause in *) +(* th, using T(ij, kl) to eliminate the third literal. *) +(* (lit and lit' must constrain the same component). *) +(* uhave lit | lit' | lit'' in bij ::= produces three subgoals, where lit *) +(* (resp. lit', lit'') is added to the bij clause in *) +(* th; lit, lit', lit'' should be a permutation of xk, *) +(* -xk, and ~xk for some k. *) +(* uwlog Ebij: lit | lit' in bij as T(ij, kl) ::= adds lit to the bij clause *) +(* in th, but produces a side goal where lit' has been *) +(* added instead, with an additional assumption *) +(* Ebij: th + (lit in bij); T(ij, kl) is used to rule *) +(* out the third value. *) +(* counter to T(ij, kl) ::= use T(ij, kl) to conclude that unsat th. *) +(* uexact Hth' ::= use Hth' : unsat th', where th' is a subset of th *) +(* (with the same order of literals) to conclude. *) +(* symmetric to Hth' ::= use Hth' : unsat th', where th' is a permutation *) +(* of a subset of th (preserving columns, and with at *) +(* most one row exchange) to conclude. *) +(******************************************************************************) + +Import ssrint. + +(* Clause left-hand side, a reference to a value of beta; in the reference *) +(* model m, (i, j) stands for beta_ (inord i.+1) (inord j.+1). *) +Definition ref := (nat * nat)%type. +Implicit Type ij : ref. +Definition Ref b_ij : ref := edivn (b_ij - 11) 10. (* Ref 21 = (1, 0). *) +Notation "''b' ij" := (Ref ij) (at level 0, ij at level 0, format "''b' ij"). +Notation b11 := 'b11. Notation b12 := 'b12. +Notation b21 := 'b21. Notation b22 := 'b22. +Notation b31 := 'b31. Notation b32 := 'b32. +Notation b41 := 'b41. Notation b42 := 'b42. + +Definition bbox := (nat * nat)%type. (* bounding box for refs. *) +Implicit Type bb : bbox. +Identity Coercion pair_of_bbox : bbox >-> prod. + +Definition sub_bbox bb1 bb2 := (bb1.1 <= bb2.1)%N && (bb1.2 <= bb2.2)%N. +Definition wf_ref bb := [pred ij : ref | (ij.1 < bb.1)%N && (ij.2 < bb.2)%N]. +Definition dot_ref ij1 ij2 := ((ij1.1 == ij2.1).+1 * (ij1.2 == ij2.2).+1 - 1)%N. + +Lemma bbox_refl bb : sub_bbox bb bb. Proof. exact/andP. Qed. + +(* Clause right-hand side litteral, denoting the projection of the left-hand *) +(* side on an irreducible character of G: in a valid model m, (k, v) stands *) +(* for the component m`_k *~ v = (model_xi m)`_k, and for the projection *) +(* constraint '[m i j, m`_k] == v%:~R. *) +Definition lit := (nat * int)%type. (* +x1 = (0,1) ~x2 = (1,0) -x3 = (2, -1) *) +Implicit Types (kv : lit) (kvs : seq lit). +Definition Lit k1 v : lit := if (0 + k1)%N is k.+1 then (k, v) else (k1, v). +Notation "+x k" := (Lit k 1) (at level 0, k at level 0, format "+x k"). +Notation "-x k" := (Lit k (-1)) (at level 0, k at level 0, format "-x k"). +Notation "~x k" := (Lit k 0) (at level 0, k at level 0, format "~x k"). +Notation x1 := +x1. Notation x2 := +x2. +Notation x3 := +x3. Notation x4 := +x4. +Notation x5 := +x5. Notation x6 := +x6. +Notation x7 := +x7. Notation x8 := +x8. + +Definition AndLit kvs kv := kv :: kvs. +Definition AddLit := AndLit. +Notation "(*dummy*)" := (Prop Prop) (at level 0) : defclause_scope. +Arguments Scope AddLit [defclause_scope _]. +Infix "+" := AddLit : defclause_scope. +Definition SubLit kvs kv := AddLit kvs (kv.1, - kv.2). +Arguments Scope SubLit [defclause_scope _]. +Infix "-" := SubLit : defclause_scope. +Coercion LastLit kv := [:: kv]. + +Fixpoint norm_cl kvs : nat := + (if kvs is (_, v) :: kvs1 then `|v| ^ 2 + norm_cl kvs1 else 0)%N. + +Definition clause := (ref * seq lit)%type. +Implicit Type cl : clause. +Definition Clause ij kvs : clause := (ij, kvs). +Notation "& kv1 , .. , kvn 'in' ij" := + (Clause ij (AndLit .. (AndLit nil kv1) .. kvn)) + (at level 200, ij, kv1, kvn at level 0, + format "& kv1 , .. , kvn 'in' ij"). +Notation "& ? 'in' ij" := (Clause ij nil) + (at level 200, ij at level 0, format "& ? 'in' ij"). +Definition DefClause := Clause. +Arguments Scope DefClause [_ defclause_scope]. +Notation "& ij = kvs" := (DefClause ij kvs) + (at level 200, ij at level 0, format "& ij = kvs"). + +Definition theory := seq clause. +Implicit Type th : theory. +Definition AddClause th cl : theory := cl :: th. +Notation "|= cl1 .. cln" := (AddClause .. (AddClause nil cl1) .. cln) + (at level 8, cl1, cln at level 200, + format "|= '[hv' cl1 '/' .. '/' cln ']'"). + +(* Transpose (W1 / W2 symmetry). *) + +Definition tr (ij : nat * nat) : ref := (ij.2, ij.1). +Definition tr_th th : theory := [seq (tr cl.1, cl.2) | cl <- th]. + +Lemma trK : involutive tr. Proof. by case. Qed. +Lemma tr_thK : involutive tr_th. Proof. by apply: mapK => [[[i j] kvs]]. Qed. + +(* Index range of a theory. *) + +Fixpoint th_bbox th : bbox := + if th is (i, j, _) :: th1 then + let: (ri, rj) := th_bbox th1 in (maxn i.+1 ri, maxn j.+1 rj) + else (0, 0)%N. + +Lemma th_bboxP th bb : + reflect {in th, forall cl, cl.1 \in wf_ref bb} (sub_bbox (th_bbox th) bb). +Proof. +pose in_bb := [pred cl : clause | cl.1 \in wf_ref bb]. +suffices ->: sub_bbox (th_bbox th) bb = all in_bb th by apply: allP. +elim: th => [|[[i j] _] th] //=; case: (th_bbox th) => ri rj /=. +by rewrite /sub_bbox /= !geq_max andbACA => ->. +Qed. +Implicit Arguments th_bboxP [th bb]. + +Fixpoint th_dim th : nat := + if th is (_, kvs) :: th1 then + foldr (fun kv => maxn kv.1.+1) (th_dim th1) kvs + else 0%N. + +Lemma th_dimP th bk : + reflect {in th, forall cl, {in cl.2, forall kv, kv.1 < bk}}%N + (th_dim th <= bk)%N. +Proof. +pose in_bk := [pred cl : clause | all (fun kv => kv.1 < bk)%N cl.2]. +suffices ->: (th_dim th <= bk)%N = all in_bk th. + by apply: (iffP allP) => bk_th cl /bk_th/allP. +elim: th => // [[_ kvs] th /= <-]; elim: kvs => //= kv kvs. +by rewrite -andbA geq_max => ->. +Qed. +Implicit Arguments th_dimP [th bk]. + +(* Theory and clause lookup. *) + +CoInductive get_spec T (P : T -> Prop) (Q : Prop) : option T -> Prop := + | GetSome x of P x : get_spec P Q (Some x) + | GetNone of Q : get_spec P Q None. + +Fixpoint get_cl ij (th : theory) : option clause := + if th is cl :: th1 then if cl.1 == ij then Some cl else get_cl ij th1 + else None. + +Lemma get_clP ij (th : theory) : + get_spec (fun cl : clause => cl \in th /\ cl.1 = ij) True (get_cl ij th). +Proof. +elim: th => /= [|cl th IHth]; first by right. +case: eqP => [Dij | _]; first by left; rewrite ?mem_head. +by case: IHth => [cl1 [th_cl1 Dij]|]; constructor; rewrite // mem_behead. +Qed. + +Fixpoint get_lit (k0 : nat) kvs : option int := + if kvs is (k, v) :: kvs1 then if k == k0 then Some v else get_lit k0 kvs1 + else None. + +Lemma get_litP k0 kvs : + get_spec (fun v => (k0, v) \in kvs) (k0 \notin unzip1 kvs) (get_lit k0 kvs). +Proof. +elim: kvs => [|[k v] kvs IHkvs /=]; [by right | rewrite inE eq_sym]. +have [-> | k'0] := altP eqP; first by left; rewrite ?mem_head. +by have [v0 kvs_k0v | kvs'k0] := IHkvs; constructor; rewrite // mem_behead. +Qed. + +(* Theory extension. *) + +Fixpoint set_cl cl2 th : wrapped theory := + if th is cl :: th1 then + let: Wrap th2 := set_cl cl2 th1 in + if cl.1 == cl2.1 then Wrap (AddClause th2 cl2) else Wrap (AddClause th2 cl) + else Wrap nil. + +Definition ext_cl th cl k v := + let: (ij, kvs) := cl in set_cl (Clause ij (AndLit kvs (Lit k.+1 v))) th. + +Definition wf_ext_cl cl k rk := (k \notin unzip1 cl.2) && (k < rk)%N. + +Definition wf_fill k kvs := (size kvs == k) && (norm_cl kvs < 3)%N. + +Lemma ext_clP cl1 th k v (cl1k := (cl1.1, (k, v) :: cl1.2)) : + cl1 \in th -> + exists2 th1, ext_cl th cl1 k v = Wrap th1 + & cl1k \in th1 + /\ th1 =i [pred cl | if cl.1 == cl1.1 then cl == cl1k else cl \in th]. +Proof. +case: cl1 => ij kvs /= in cl1k * => th_cl1; set th1p := [pred cl | _]. +pose th1 := [seq if cl.1 == ij then cl1k else cl | cl <- th]. +exists th1; first by elim: (th) @th1 => //= cl th' ->; rewrite -2!fun_if. +suffices Dth1: th1 =i th1p by rewrite Dth1 !inE !eqxx. +move=> cl; rewrite inE; apply/mapP/idP=> [[{cl}cl th_cl ->] | ]. + by case cl_ij: (cl.1 == ij); rewrite ?eqxx ?cl_ij. +case: ifP => [_ /eqP-> | cl'ij th_cl]; last by exists cl; rewrite ?cl'ij. +by exists (ij, kvs); rewrite ?eqxx. +Qed. + +(* Satisfiability tests. *) + +Definition sat_test (rO : rel clause) ij12 th := + if get_cl (Ref ij12.1) th is Some cl1 then + oapp (rO cl1) true (get_cl (Ref ij12.2) th) + else true. + +(* This reflects the application of (3.5.1) for an arbitrary pair of entries. *) +Definition Otest cl1 cl2 := + let: (ij1, kvs1) := cl1 in let: (ij2, kvs2) := cl2 in + let fix loop s1 s2 kvs2 := + if kvs2 is (k, v2) :: kvs2 then + if get_lit k kvs1 is Some v1 then loop (v1 * v2 + s1) s2 kvs2 else + loop s1 s2.+1 kvs2 + else (s1, if norm_cl kvs1 == 3 then 0%N else s2) in + let: (s1, s2) := loop 0 0%N kvs2 in + (norm_cl kvs2 == 3) ==> (`|s1 - dot_ref ij1 ij2| <= s2)%N. + +(* Matching up to a permutation of the rows, columns, and base vectors. *) + +Definition sub_match th1 th2 := + let match_cl cl1 cl2 := + if cl2.1 == cl1.1 then subseq cl1.2 cl2.2 else false in + all [pred cl1 | has (match_cl cl1) th2] th1. + +Definition wf_consider ij th (ri := (th_bbox th).1) := + (ij.1 < 2 + ((2 < ri) || sub_match th (tr_th th)).*2)%N && (ij.2 < 2)%N. + +CoInductive sym := Sym (si : seq nat) (sj : seq nat) (sk : seq nat). + +Definition sym_match s th1 th2 := + let: Sym si sj sk := s in let: (ri, rj, rk) := (th_bbox th1, th_dim th1) in + let is_sym r s := uniq s && all (gtn r) s in + let match_cl cl2 := + let: (i2, j2, kvs2) := cl2 in let ij := (nth ri si i2, nth rj sj j2) in + let match_lit kvs1 kv := (nth rk sk kv.1, kv.2) \in kvs1 in + let match_cl1 cl1 := + let: (ij1, kvs1) := cl1 in (ij1 == ij) && all (match_lit kvs1) kvs2 in + uniq (unzip1 kvs2) && has match_cl1 th1 in + [&& is_sym ri si, is_sym rj sj, is_sym rk sk & all match_cl th2]. + +(* Try to compute the base vector permutation for a given row and column *) +(* permutation. We assume each base vector is determined by the entries of *) +(* which it is a proper constituent, and that there are at most two columns. *) +Definition find_sym_k th1 th2 (si sj : seq nat) := + let store_lit c kv ksig := + let: (k, v) := kv in if v == 0 then ksig else let cv := (c, v) in + let fix insert_in (cvs : seq (nat * int)) := + if cvs is cv' :: cvs' then + if (c < cv'.1)%N then cv :: cvs else cv' :: insert_in cvs' + else [:: cv] in + set_nth nil ksig k (insert_in (nth nil ksig k)) in + let fix read_lit ksig1 ksig2 := + if ksig1 is cvs :: ksig1' then + let k := index cvs ksig2 in + k :: read_lit ksig1' (set_nth nil ksig2 k nil) + else nil in + let fix store2 ksig1 ksig2 cls1 := + if cls1 is (i1, j1, kvs1) :: cls1' then + if get_cl (nth 0 si i1, nth 0 sj j1)%N th2 is Some (_, kvs2) then + let st_kvs := foldr (store_lit (i1.*2 + j1)%N) in (* assume j1 <= 1 *) + store2 (st_kvs ksig1 kvs1) (st_kvs ksig2 kvs2) cls1' + else None + else + let sk := read_lit ksig1 ksig2 in + if all (gtn (size ksig2)) sk then Some (Sym si sj sk) else None in + store2 nil nil th1. + +(* Try to find a symmetry that maps th1 to th2, assuming the same number of *) +(* rows and columns, and considering at most one row exchange. *) +Definition find_sym th1 th2 := + let: (ri, rj) := th_bbox th2 in let si := iota 0 ri in let sj := iota 0 rj in + if find_sym_k th1 th2 si sj is Some _ as s then s else + let fix loop m := + if m is i.+1 then + let fix inner_loop m' := + if m' is i'.+1 then + let si' := (set_nth 0 (set_nth 0 si i i') i' i)%N in + if find_sym_k th1 th2 si' sj is Some _ as s then s else inner_loop i' + else None in + if inner_loop i is Some _ as s then s else loop i + else None in + loop ri. + +Section Interpretation. + +Variables (gT : finGroupType) (G : {group gT}). + +Definition is_Lmodel bb b := + [/\ [/\ odd bb.1.+1, odd bb.2.+1, bb.1 > 1, bb.2 > 1 & bb.1 != bb.2]%N, + forall ij, b ij \in 'Z[irr G] + & {in wf_ref bb &, forall ij1 ij2, '[b ij1, b ij2] = (dot_ref ij1 ij2)%:R}]. + +Definition is_Rmodel X := orthonormal X /\ {subset X <= 'Z[irr G]}. + +Inductive model := Model bb f X of is_Lmodel bb f & is_Rmodel X. + +Coercion model_bbox m := let: Model d _ _ _ _ := m in d. +Definition model_entry m := let: Model _ f _ _ _ := m in f. +Coercion model_entry : model >-> Funclass. +Coercion model_basis m := let: Model _ _ X _ _ := m in X. +Lemma LmodelP (m : model) : is_Lmodel m m. Proof. by case: m. Qed. +Lemma RmodelP (m : model) : is_Rmodel m. Proof. by case: m. Qed. + +Fact nil_RmodelP : is_Rmodel nil. Proof. by []. Qed. + +Definition eval_cl (m : model) kvs := \sum_(kv <- kvs) m`_kv.1 *~ kv.2. + +Definition sat_lit (m : model) ij kv := '[m ij, m`_kv.1] == kv.2%:~R. +Definition sat_cl m cl := uniq (unzip1 cl.2) && all (sat_lit m cl.1) cl.2. + +Definition sat (m : model) th := + [&& sub_bbox (th_bbox th) m, th_dim th <= size m & all (sat_cl m) th]%N. +Definition unsat th := forall m, ~ sat m th. + +Lemma satP (m : model) th : + reflect {in th, forall cl, + [/\ cl.1 \in wf_ref m, uniq (unzip1 cl.2) + & {in cl.2, forall kv, kv.1 < size m /\ sat_lit m cl.1 kv}%N]} + (sat m th). +Proof. +apply: (iffP and3P) => [[/th_bboxP thbP /th_dimP thdP /allP thP] cl th_cl |thP]. + have /andP[-> clP] := thP _ th_cl; split=> // [|kv cl_kv]; first exact: thbP. + by rewrite (thdP _ th_cl) ?(allP clP). +split; first by apply/th_bboxP=> cl /thP[]. + by apply/th_dimP=> cl /thP[_ _ clP] kv /clP[]. +by apply/allP=> cl /thP[_ Ucl clP]; rewrite /sat_cl Ucl; apply/allP=> kv /clP[]. +Qed. +Implicit Arguments satP [m th]. + +(* Reflexion of the dot product. *) + +Lemma norm_clP m th cl : + sat m th -> cl \in th -> + let norm := norm_cl cl.2 in let beta := m cl.1 in + [/\ (norm <= 3)%N, norm == 3 -> beta = eval_cl m cl.2 + & (norm < 3)%N -> size cl.2 == size m -> + exists2 dk, dk \in dirr_constt beta & orthogonal (dchi dk) m]. +Proof. +case: cl => ij kvs /satP thP /thP[wf_ij Uks clP] norm beta. +have [[_ ZmL Dm] [o1m ZmR]] := (LmodelP m, RmodelP m). +set ks := unzip1 kvs in Uks; pose Aij := [seq m`_k | k <- ks]. +have lt_ks k: k \in ks -> (k < size m)%N by case/mapP=> kv /clP[ltk _] ->. +have sAm: {subset Aij <= (m : seq _)} + by move=> _ /mapP[k /lt_ks ltk ->]; rewrite mem_nth. +have o1Aij: orthonormal Aij. + have [Um _] := orthonormalP o1m; apply: sub_orthonormal o1m => //. + rewrite map_inj_in_uniq // => k1 k2 /lt_ks ltk1 /lt_ks ltk2 /eqP. + by apply: contraTeq; rewrite nth_uniq. +have [X AijX [Y [defXY oXY oYij]]] := orthogonal_split Aij beta. +have{AijX} defX: X = \sum_(xi <- Aij) '[beta, xi] *: xi. + have [_ -> ->] := orthonormal_span o1Aij AijX; apply: eq_big_seq => xi CFxi. + by rewrite defXY cfdotDl (orthoPl oYij) ?addr0. +have ->: eval_cl m kvs = X. + rewrite {}defX !big_map; apply: eq_big_seq => kv /clP[_ /eqP->]. + by rewrite scaler_int. +rewrite -leC_nat -ltC_nat -eqC_nat /=. +have <-: '[beta] = 3%:R by rewrite Dm // /dot_ref !eqxx. +have <-: '[X] = norm%:R. + rewrite {}defX {}/norm cfnorm_sum_orthonormal // {o1Aij oYij sAm}/Aij. + transitivity (\sum_(kv <- kvs) `|kv.2%:~R| ^+ 2 : algC). + by rewrite !big_map; apply: eq_big_seq => kv /clP[_ /eqP->]. + rewrite unlock /=; elim: (kvs) => //= [[k v] kvs' ->]. + by rewrite -intr_norm -natrX -natrD. +rewrite defXY cfnormDd //; split; first by rewrite ler_paddr ?cfnorm_ge0. + by rewrite eq_sym addrC -subr_eq0 addrK cfnorm_eq0 => /eqP->; rewrite addr0. +have{ZmL} Zbeta: beta \in 'Z[irr G] by apply: ZmL. +have Z_X: X \in 'Z[irr G]. + rewrite defX big_seq rpred_sum // => xi /sAm/ZmR Zxi. + by rewrite rpredZ_Cint ?Cint_cfdot_vchar. +rewrite -ltr_subl_addl subrr cnorm_dconstt; last first. + by rewrite -[Y](addKr X) -defXY addrC rpredB. +have [-> | [dk Ydk] _ /eqP sz_kvs] := set_0Vmem (dirr_constt Y). + by rewrite big_set0 ltrr. +have Dks: ks =i iota 0 (size m). + have: {subset ks <= iota 0 (size m)} by move=> k /lt_ks; rewrite mem_iota. + by case/leq_size_perm=> //; rewrite size_iota size_map sz_kvs. +suffices o_dk_m: orthogonal (dchi dk) m. + exists dk; rewrite // dirr_consttE defX cfdotDl cfdot_suml. + rewrite big1_seq ?add0r -?dirr_consttE // => xi /sAm CFxi. + by rewrite cfdotC cfdotZr (orthoPl o_dk_m) // mulr0 conjC0. +apply/orthoPl=> _ /(nthP 0)[k ltk <-]; have [Um o_m] := orthonormalP o1m. +have Z1k: m`_k \in dirr G by rewrite dirrE ZmR ?o_m ?eqxx ?mem_nth. +apply: contraTeq Ydk => /eqP; rewrite dirr_consttE cfdot_dirr ?dirr_dchi //. +have oYm: '[Y, m`_k] = 0 by rewrite (orthoPl oYij) ?map_f // Dks mem_iota. +by do 2?case: eqP => [-> | _]; rewrite // ?cfdotNr oYm ?oppr0 ltrr. +Qed. + +Lemma norm_cl_eq3 m th cl : + sat m th -> cl \in th -> norm_cl cl.2 == 3 -> m cl.1 = eval_cl m cl.2. +Proof. by move=> m_th /(norm_clP m_th)[]. Qed. + +Lemma norm_lit m th cl kv : + sat m th -> cl \in th -> kv \in cl.2 -> (`|kv.2| <= 1)%N. +Proof. +move=> m_th /(norm_clP m_th)[cl_le3 _ _]. +elim: cl.2 => //= [[k v] kvs IHkvs] in cl_le3 * => /predU1P[-> | /IHkvs->//]. + by apply: contraLR cl_le3; rewrite -ltnNge -leq_sqr => /subnKC <-. +exact: leq_trans (leq_addl _ _) cl_le3. +Qed. + +(* Decision procedure framework (in which we will define O and L). *) + +Definition is_sat_test (tO : pred theory) := forall m th, sat m th -> tO th. + +Lemma sat_testP (rO : rel clause) ij12 : + (forall m th cl1 cl2, sat m th -> cl1 \in th -> cl2 \in th -> rO cl1 cl2) -> + is_sat_test (sat_test rO ij12). +Proof. +rewrite /sat_test => O m th /O O_th; case: get_clP => // cl1 [th_cl1 _]. +by case: get_clP => // cl2 [th_cl2 _]; apply: O_th. +Qed. + +(* Case analysis on the value of a specific projection. *) + +Definition lit_vals : seq int := [:: 0; 1; -1]. + +Lemma sat_cases (m : model) th k cl : + sat m th -> cl \in th -> wf_ext_cl cl k (size m) -> + exists2 v, v \in lit_vals & sat m (unwrap (ext_cl th cl k v)). +Proof. +case: cl => ij kvs /satP thP th_cl /andP[cl'k ltkm]. +have [[_ ZmL _] [o1m ZmR]] := (LmodelP m, RmodelP m). +have [m_ij Uij clP] := thP _ th_cl. +have /CintP[v Dv]: '[m ij, m`_k] \in Cint. + by rewrite Cint_cfdot_vchar ?ZmL ?ZmR ?mem_nth. +have [/= th1 Dthx [th1_cl Dth1]] := ext_clP k v th_cl. +suffices{Dthx} m_th1: sat m th1. + exists v; last by rewrite /ext_cl Dthx. + by case: (v) (norm_lit m_th1 th1_cl (mem_head _ _)); do 2?case. +apply/satP=> cl1; rewrite Dth1 inE; case: ifP => [_ /eqP-> | _ /thP] //=. +by rewrite cl'k; split=> // kv /predU1P[-> | /clP//]; rewrite /sat_lit Dv. +Qed. +Implicit Arguments sat_cases [m th cl]. + +Definition unsat_cases_hyp th0 kvs tO cl := + let: (k, _) := head (2, 0) kvs in let thk_ := ext_cl th0 cl k in + let th's := [seq unwrap (thk_ v) | v <- lit_vals & v \notin unzip2 kvs] in + let add hyp kv := + let: (_, v) := kv in let: Wrap th := thk_ v in hyp /\ unsat th in + foldl add (wf_ext_cl cl k (th_dim th0) && all (predC tO) th's) kvs. + +Lemma unsat_cases th ij kvs tO : + is_sat_test tO -> oapp (unsat_cases_hyp th kvs tO) False (get_cl ij th) -> + unsat th. +Proof. +case: get_clP => //= cl [th_cl _] O; rewrite /unsat_cases_hyp. +case: head => k _; set thk_ := ext_cl th cl k; set add := fun _ _ => _. +set wf_kvs := _ && _; rewrite -[kvs]revK foldl_rev => Ukvs m m_th. +have{Ukvs}: all (fun kv => ~~ sat m (unwrap (thk_ kv.2))) (rev kvs) && wf_kvs. + elim: rev Ukvs => // [[_ v] /= kvs' IH]; case Dthk: (thk_ v) => [thv] [/IH]. + by rewrite -andbA => -> Uthk; rewrite andbT; apply/negP; apply: Uthk. +case/and3P=> /allP Uthkvs /andP[cl'k ltkr] /allP Uthkv's. +have [|{cl'k ltkr} v lit_v m_thv] := sat_cases k m_th th_cl. + by rewrite /wf_ext_cl cl'k (leq_trans ltkr) //; have [] := and3P m_th. +have /idPn[] := O _ _ m_thv; apply: Uthkv's; apply: map_f. +rewrite mem_filter lit_v andbT -mem_rev -map_rev. +by apply: contraL m_thv => /mapP[kv /Uthkvs m'thkv ->]. +Qed. + +(* Dot product reflection. *) + +Lemma O ij12 : is_sat_test (sat_test Otest ij12). +Proof. +apply: sat_testP => m th [ij1 kvs1] [ij2 kvs2] /= m_th th_cl1 th_cl2. +set cl1eq := _ == 3; set cl2eq := _ == 3; have [_ _ Dm] := LmodelP m. +pose goal s1 s2 := cl2eq ==> (`|s1 - (dot_ref ij1 ij2)%:~R| <= s2%:R :> algC). +set kvs := kvs2; set s1 := 0; set s2 := {2}0%N; have thP := satP m_th. +have{thP} [[wf_cl1 _ cl1P] [wf_cl2 _ cl2P]] := (thP _ th_cl1, thP _ th_cl2). +have: goal (s1%:~R + '[m ij1, eval_cl m kvs]) (if cl1eq then 0%N else s2). + apply/implyP=> /(norm_cl_eq3 m_th th_cl2) <-. + by rewrite if_same Dm // addrK normr0. +have /allP: {subset kvs <= kvs2} by []. +rewrite cfdot_sumr unlock; elim: kvs s1 s2 => [|[k v2] kvs IHkvs] s1 s2 /=. + by rewrite addr0 /goal -rmorphB pmulrn -!CintrE. +case/andP=> kvs2_v /IHkvs{IHkvs}IHkvs; have{cl2P} [ltk _] := cl2P _ kvs2_v. +have [v1 /cl1P[_ /eqP/=Dv1] | kvs1'k] := get_litP. + rewrite addrA => gl12; apply: IHkvs; congr (goal (_ + _) _): gl12. + by rewrite raddfMz addrC /= Dv1 -mulrzA -rmorphD. +move=> gl12; apply: IHkvs; case: ifP gl12 => [/(norm_cl_eq3 m_th th_cl1)->|_]. + rewrite cfdot_suml big1_seq ?add0r //= => kv1 kvs1_kv1. + have [[ltk1 _] [/orthonormalP[Um oom] _]] := (cl1P _ kvs1_kv1, RmodelP m). + rewrite -!scaler_int cfdotZl cfdotZr oom ?mem_nth ?nth_uniq // mulrb. + by rewrite ifN ?mulr0 //; apply: contraNneq kvs1'k => <-; apply: map_f. +rewrite /goal -(ler_add2r 1) -mulrSr; case: (cl2eq) => //; apply: ler_trans. +set s := '[_, _]; rewrite -[_ + _](addrK s) (ler_trans (ler_norm_sub _ _)) //. +rewrite 2![_ + s]addrAC addrA ler_add2l {}/s -scaler_int cfdotZr rmorph_int. +have [|v1 _] := sat_cases k m_th th_cl1; first exact/andP. +have [th1 -> /= [th1_cl1 _] m_th1] := ext_clP k v1 th_cl1. +have [_ _ /(_ _ (mem_head _ _))[_ /eqP->]] := satP m_th1 _ th1_cl1. +have ubv1: (`|v1| <= 1)%N := norm_lit m_th1 th1_cl1 (mem_head _ _). +have ubv2: (`|v2| <= 1)%N := norm_lit m_th th_cl2 kvs2_v. +by rewrite -rmorphM -intr_norm lern1 abszM /= (leq_mul ubv2 ubv1). +Qed. + +(* "Without loss" cut rules. *) + +Lemma unsat_wlog cl th : + (let: Wrap th1 := set_cl cl th in (unsat th1 -> unsat th) /\ unsat th1) -> + unsat th. +Proof. by case: set_cl => th1 [Uth /Uth]. Qed. + +Lemma unsat_wlog_cases th1 th2 : + (unsat th1 -> unsat th2) -> unsat th1 -> (true /\ unsat th1) /\ unsat th2. +Proof. by move=> Uth2 Uth1; split; last exact: Uth2. Qed. + +(* Extend the orthonormal basis *) + +Lemma sat_fill m th cl (k := th_dim th) : + sat m th -> cl \in th -> wf_fill k cl.2 -> + exists mr : {CFk | is_Rmodel CFk}, + sat (Model (LmodelP m) (svalP mr)) (unwrap (ext_cl th cl k 1)). +Proof. +move=> m_th th_cl /andP[/eqP sz_kvs n3cl]. +wlog sz_m: m m_th / size m = k. + have lekm: (k <= size m)%N by have [] := and3P m_th. + have mrP: is_Rmodel (take k m). + have [] := RmodelP m; rewrite -{1 2}(cat_take_drop k m) orthonormal_cat /=. + by case/andP=> o1mr _ /allP; rewrite all_cat => /andP[/allP]. + move/(_ (Model (LmodelP m) mrP)); apply; rewrite ?size_takel //. + congr (_ && _): m_th; rewrite lekm size_takel ?leqnn //=. + apply: eq_in_all => cl1 /th_dimP lt_cl1; congr (_ && _). + by apply: eq_in_all => kv1 /lt_cl1 lt_kv1; rewrite /sat_lit nth_take ?lt_kv1. +have [_ _ [//||dk cl_dk o_dk_m]] := norm_clP m_th th_cl. + by rewrite sz_kvs sz_m. +have CFkP: is_Rmodel (rcons m (dchi dk)). + have [o1m /allP Zm] := RmodelP m. + split; last by apply/allP; rewrite all_rcons /= dchi_vchar. + rewrite -cats1 orthonormal_cat o1m orthogonal_sym o_dk_m. + by rewrite /orthonormal /= cfnorm_dchi eqxx. +exists (exist _ _ CFkP); set mk := Model _ _. +have{m_th} mk_th: sat mk th. + congr (_ && _): m_th; rewrite size_rcons sz_m leqnn ltnW //=. + apply: eq_in_all => cl1 /th_dimP lt_cl1; congr (_ && _). + apply: eq_in_all => kv1 /lt_cl1 lt_kv1; congr ('[_, _] == _). + by rewrite nth_rcons sz_m lt_kv1. +have [|{mk_th}v ub_v m_th] := sat_cases k mk_th th_cl. + rewrite /wf_ext_cl size_rcons sz_m (contraFN _ (ltnn k)) //=. + by case/mapP=> kv kv_cl {1}->; rewrite (th_dimP _ _ th_cl). +suffices: 0 < v by case/or4P: ub_v m_th => // /eqP->. +case: (ext_clP k v th_cl) m_th => th1 -> [th1_cl1 _] /and3P[_ _]. +case/allP/(_ _ th1_cl1)/and3P=> _ /eqP/=. +by rewrite nth_rcons sz_m ltnn eqxx CintrE => <- _; rewrite -dirr_consttE. +Qed. + +Lemma unsat_fill ij th : + let fill_cl cl := + if (th_dim th).+1 %/ 1 is k.+1 then + let: Wrap thk := ext_cl th cl k 1 in wf_fill k cl.2 /\ unsat thk + else True in + oapp fill_cl False (get_cl ij th) -> unsat th. +Proof. +rewrite divn1; case: get_clP => //= cl [th_cl _]. +case Dthk: ext_cl => [th1] [wf_thk Uth1] m m_th. +by have [mk] := sat_fill m_th th_cl wf_thk; rewrite Dthk => /Uth1. +Qed. + +(* Matching an assumption exactly. *) + +Lemma sat_exact m th1 th2 : sub_match th1 th2 -> sat m th2 -> sat m th1. +Proof. +move/allP=> s_th12 /satP th2P; apply/satP => cl1 /s_th12/hasP[cl2 th_cl2]. +case: eqP => // <- s_cl12; have [wf_ij2 Ucl2 cl2P] := th2P _ th_cl2. +split=> // [|kv /(mem_subseq s_cl12)/cl2P//]. +by rewrite (subseq_uniq _ Ucl2) ?map_subseq. +Qed. + +Lemma unsat_exact th1 th2 : sub_match th1 th2 -> unsat th1 -> unsat th2. +Proof. by move=> sth21 Uth1 m /(sat_exact sth21)/Uth1. Qed. + +(* Transpose (W1 / W2 symmetry). *) + +Fact tr_Lmodel_subproof (m : model) : is_Lmodel (tr m) (fun ij => m (tr ij)). +Proof. +case: m => /= d f _ [[odd_d1 odd_d2 d1gt1 d2gt1 neq_d12] Zf fP] _. +split=> // [|[j1 i1] [j2 i2]]; first by rewrite eq_sym. +by rewrite ![_ \in _]andbC /= => wf_ij1 wf_ij2; rewrite fP // /dot_ref mulnC. +Qed. + +Definition tr_model m := Model (tr_Lmodel_subproof m) (RmodelP m). + +Lemma sat_tr m th : sat m th -> sat (tr_model m) (tr_th th). +Proof. +move/satP=> thP; apply/satP=> _ /mapP[[[i j] kvs] /thP[m_ij Uks kvsP] ->]. +by rewrite inE /= andbC. +Qed. + +(* Extend the theory (add a new empty clause). *) + +Lemma unsat_consider ij th : + wf_consider ij th -> unsat (AddClause th (& ? in ij)) -> unsat th. +Proof. +case: ij => i j; case/andP; set sym_t := sub_match _ _ => lti ltj Uthij m m_th. +wlog le_m21: m m_th / sym_t -> (m.2 <= m.1)%N. + move=> IH; apply: (IH m m_th) => sym_th. + rewrite leqNgt; apply/negP=> /leqW le_m1_m2. + by have /(sat_exact sym_th)/IH[] := sat_tr m_th. +apply: (Uthij m); congr (_ && _): (m_th) => /=; case: (th_bbox th) => ri rj /=. +have [[odd_m1 _ m1gt1 m2gt1 neq_m12] _ _] := LmodelP m. +rewrite /sub_bbox !geq_max (leq_trans ltj) ?(leq_trans lti) //; case: orP => //. +rewrite -(ltnS 4) (odd_geq _ odd_m1) ltnS. +case=> [/leq_trans-> // | /le_m21]; first by have [/andP[]] := and3P m_th. +by rewrite leq_eqVlt eq_sym (negPf neq_m12); apply: leq_trans. +Qed. + +(* Matching up to a permutation of the rows, columns, and base vectors. *) + +Lemma unsat_match s th1 th2 : sym_match s th1 th2 -> unsat th2 -> unsat th1. +Proof. +pose I_ si mi := si ++ filter [predC si] (iota 0 mi). +have SsP mi si ri (Ii := I_ si mi): + uniq si && all (gtn ri) si -> (ri <= mi)%N -> + [/\ {in Ii, forall i, i < mi}%N, uniq Ii & size Ii = mi]. +- case/andP=> Usi /allP/=ltsi le_ri_mi; have uIm := iota_uniq 0 mi. + have uIi: uniq Ii by rewrite cat_uniq Usi -all_predC filter_all filter_uniq. + have defIi: Ii =i iota 0 mi. + move=> i; rewrite mem_cat mem_filter orb_andr orbN mem_iota. + by apply: orb_idl => /ltsi/leq_trans->. + split=> // [i|]; first by rewrite defIi mem_iota. + by rewrite (perm_eq_size (uniq_perm_eq _ _ defIi)) ?size_iota. +have lt_nth ri si i: (nth ri si i < ri)%N -> (i < size si)%N. + by rewrite !ltnNge; apply: contra => le_si; rewrite nth_default. +case: s => [si sj sk] /= sym12 Uth2 m m_th1; case/and3P: (m_th1) sym12. +case: th_bbox (th_bboxP (bbox_refl (th_bbox th1))) => ri rj rijP. +case/andP=> /= leri lerj lerk _ /and4P[Ssi Ssj /andP[Usk /allP/=lesrk] sym12]. +have{Ssi} /SsP/(_ leri)[ltIi uIi szIi] := Ssi. +have{Ssj SsP} /SsP/(_ lerj)[ltIj uIj szIj] := Ssj. +pose smL ij := m (nth ri (I_ si m.1) ij.1, nth rj (I_ sj m.2) ij.2)%N. +pose smR := [seq m`_k | k <- sk]. +have [[lb_m ZmL Dm] [o1m ZmR]] := (LmodelP m, RmodelP m). +have{lb_m} smLP: is_Lmodel m smL. + split=> // [ij | ij1 ij2 /andP[lti1 ltj1] /andP[lti2 ltj2]]; first exact: ZmL. + by rewrite Dm ?inE /dot_ref/= ?nth_uniq ?ltIi ?ltIj ?mem_nth ?szIi ?szIj. +have{lesrk} ubk k: k \in sk -> (k < size m)%N by move=> /lesrk/leq_trans->. +have smRP: is_Rmodel smR. + have ssmR: {subset smR <= (m : seq _)}. + by move=> _ /mapP[k s_k ->]; rewrite mem_nth ?ubk. + split=> [|xi /ssmR/ZmR//]; have [Um _] := orthonormalP o1m. + apply: sub_orthonormal o1m; rewrite ?map_inj_in_uniq //. + by apply: can_in_inj (index^~ m) _ => k s_k; rewrite /= index_uniq ?ubk. +apply: (Uth2 (Model smLP smRP)); apply/satP=> [][[i2 j2] kvs2] /(allP sym12). +case/andP=> -> /hasP[[[i1 j1] kvs1] th1_cl1 /andP[/eqP[Di1 Dj1] /allP s_kv12]]. +have:= rijP _ th1_cl1; rewrite Di1 Dj1 => /andP[/lt_nth lti1 /lt_nth ltj1]. +rewrite !inE -szIi -szIj !size_cat !(leq_trans _ (leq_addr _ _)) //. +split=> // kv /s_kv12 kvs1_kv1; rewrite size_map /sat_lit /=. +have /lt_nth ltk := th_dimP (leqnn _) _ th1_cl1 _ kvs1_kv1; split=> //. +rewrite (nth_map (th_dim th1)) // /smL !nth_cat lti1 ltj1 -Di1 -Dj1. +by have [_ _ /(_ _ kvs1_kv1)[]] := satP m_th1 _ th1_cl1. +Qed. + +Lemma unsat_sym th1 th2 : + (if find_sym th1 th2 is Some s then sym_match s th2 th1 else false) -> + unsat th1 -> unsat th2. +Proof. by case: find_sym => // s; apply: unsat_match. Qed. + +End Interpretation. + +Implicit Arguments satP [gT G m th]. +Implicit Arguments unsat [gT G]. +Implicit Arguments sat_cases [gT G m th cl]. +Implicit Arguments unsat_cases [gT G th tO]. +Implicit Arguments unsat_wlog [gT G]. +Implicit Arguments unsat_fill [gT G]. +Implicit Arguments unsat_consider [gT G]. +Implicit Arguments unsat_match [gT G th1 th2]. + +(* The domain-specific tactic language. *) + +Tactic Notation "consider" constr(ij) := + apply: (unsat_consider ij); first exact isT. + +(* Note that "split" here would be significantly less efficient, because it *) +(* would evaluate the reflected assumption four times. *) +Tactic Notation "fill" constr(ij) := + apply: (unsat_fill ij); apply: (conj isT _). + +Tactic Notation "uwlog" simple_intropattern(IH) ":" constr(cl) := + apply: (unsat_wlog cl); split=> [IH | ]. + +Tactic Notation "uwlog" simple_intropattern(IH) ":" constr(cl) + "by" tactic4(tac) := + apply: (unsat_wlog cl); split=> [IH | ]; first by [tac]. + +Tactic Notation "uhave" constr(kv) "in" constr(ij) + "as" constr(T) constr(ij12) := + apply: (unsat_cases ij [:: kv] (T ij12)); apply: (conj isT _). + +Tactic Notation "uhave" constr(kv1) "," constr(kv2) "in" constr(ij) + "as" constr(T) constr(ij12) := + uhave kv1 in ij as T ij12; uhave kv2 in ij as T ij12. + +Tactic Notation "uhave" constr(kv1) "|" constr(kv2) "in" constr(ij) + "as" constr(T) constr(ij12) := + apply: (unsat_cases ij [:: kv1; kv2] (T ij12)); apply: (conj (conj isT _) _). + +Tactic Notation "uhave" constr(kv1) "|" constr(kv2) "|" constr(kv3) + "in" constr(ij) := + apply: (unsat_cases ij [:: kv1; kv2; kv3] (fun _ _ _ => isT)); + apply: (conj (conj (conj isT _) _) _). + +Tactic Notation "uwlog" simple_intropattern(IH) ":" + constr(kv1) "|" constr(kv2) "in" constr(ij) + "as" constr(T) constr(ij12) := + apply: (unsat_cases ij [:: kv1; kv2] (T ij12)); + apply: unsat_wlog_cases => [IH | ]. + +Tactic Notation "counter" "to" constr(T) constr(ij12) := by move=> ? /(T ij12). + +Tactic Notation "uexact" constr(IH) := apply: unsat_exact IH; exact isT. + +Tactic Notation "symmetric" "to" constr(IH) := apply: unsat_sym (IH); exact isT. + +End CyclicTIisoReflexion. + +Section Three. + +Variables (gT : finGroupType) (G W W1 W2 : {group gT}). +Hypothesis defW : W1 \x W2 = W. + +Let V := cyclicTIset defW. +Let w_ i j := cyclicTIirr defW i j. +Let w1 := #|W1|. +Let w2 := #|W2|. + +Lemma cyclicTIirrC (xdefW : W2 \x W1 = W) i j : + cyclicTIirr xdefW j i = w_ i j. +Proof. by rewrite (dprod_IirrC xdefW defW). Qed. + +Lemma cycTIirrP chi : chi \in irr W -> {i : Iirr W1 & {j | chi = w_ i j}}. +Proof. +case/irrP/sig_eqW=> k ->{chi}. +by have /codomP/sig_eqW[[i j] ->] := dprod_Iirr_onto defW k; exists i, j. +Qed. + +Lemma cycTIirr_aut u i j : w_ (aut_Iirr u i) (aut_Iirr u j) = cfAut u (w_ i j). +Proof. by rewrite /w_ !dprod_IirrE cfAutDprod !aut_IirrE. Qed. + +Let sW1W : W1 \subset W. Proof. by have /mulG_sub[] := dprodW defW. Qed. +Let sW2W : W2 \subset W. Proof. by have /mulG_sub[] := dprodW defW. Qed. + +Lemma card_cycTIset : #|V| = (w1.-1 * w2.-1)%N. +Proof. +have [_ _ _ tiW12] := dprodP defW. +rewrite cardsD (setIidPr _) ?subUset ?sW1W // cardsU {}tiW12 cards1. +rewrite -(dprod_card defW) -addnBA // -!subn1 -/w1 -/w2 subnDA. +by rewrite mulnBl mulnBr mul1n muln1. +Qed. + +Definition cfCyclicTIset i j := cfDprod defW (1 - 'chi_i) (1 - 'chi_j). +Local Notation alpha_ := cfCyclicTIset. + +Lemma cycTIirr00 : w_ 0 0 = 1. Proof. by rewrite /w_ dprod_Iirr0 irr0. Qed. +Local Notation w_00 := cycTIirr00. + +Lemma cycTIirr_split i j : w_ i j = w_ i 0 * w_ 0 j. +Proof. by rewrite /w_ !dprod_IirrE !irr0 cfDprod_split. Qed. + +Lemma cfker_cycTIl j : W1 \subset cfker (w_ 0 j). +Proof. by rewrite /w_ dprod_IirrE irr0 cfDprod_cfun1l cfker_sdprod. Qed. + +Lemma cfker_cycTIr i : W2 \subset cfker (w_ i 0). +Proof. by rewrite /w_ dprod_IirrE irr0 cfDprod_cfun1r cfker_sdprod. Qed. + +Let cfdot_w i1 j1 i2 j2 : '[w_ i1 j1, w_ i2 j2] = ((i1 == i2) && (j1 == j2))%:R. +Proof. exact: cfdot_dprod_irr. Qed. + +Lemma cfCycTI_E i j : alpha_ i j = 1 - w_ i 0 - w_ 0 j + w_ i j. +Proof. +rewrite -w_00 -[w_ i j]opprK /w_ !dprod_IirrE !irr0 -addrA -opprD -!mulrBl. +by rewrite -mulrBr -!rmorphB. +Qed. +Local Notation alphaE := cfCycTI_E. + +Lemma cfCycTI_vchar i j : alpha_ i j \in 'Z[irr W]. +Proof. by rewrite alphaE rpredD ?rpredB ?rpred1 ?irr_vchar. Qed. + +Definition cfCyclicTIsetBase := + [seq alpha_ ij.1 ij.2 | ij in setX [set~ 0] [set~ 0]]. +Local Notation cfWVbase := cfCyclicTIsetBase. + +Let cfdot_alpha_w i1 j1 i2 j2 : + i2 != 0 -> j2 != 0 -> '[alpha_ i1 j1, w_ i2 j2] = [&& i1 == i2 & j1 == j2]%:R. +Proof. +move=> nzi2 nzj2; rewrite alphaE -w_00 !cfdotDl !cfdotNl !cfdot_w. +by rewrite !(eq_sym 0) (negPf nzi2) (negPf nzj2) /= andbF !subr0 add0r. +Qed. + +Let cfdot_alpha_1 i j : i != 0 -> j != 0 -> '[alpha_ i j, 1] = 1. +Proof. +move=> nzi nzj; rewrite alphaE -w_00 !cfdotDl !cfdotNl !cfdot_w. +by rewrite !eqxx andbT /= (negPf nzi) (negPf nzj) addr0 !subr0. +Qed. + +Let cfnorm_alpha i j : i != 0 -> j != 0 -> '[alpha_ i j] = 4%:R. +Proof. +move=> nzi nzj; rewrite -[4]/(size [:: 1; - w_ i 0; - w_ 0 j; w_ i j]). +rewrite -cfnorm_orthonormal 3?big_cons ?big_seq1 ?addrA -?alphaE //. +rewrite /orthonormal -w_00 /= !cfdotNl !cfdotNr !opprK !oppr_eq0 !cfnorm_irr. +by rewrite !cfdot_w !eqxx /= !(eq_sym 0) (negPf nzi) (negPf nzj) !eqxx. +Qed. + +Lemma cfCycTIbase_free : free cfWVbase. +Proof. +apply/freeP=> s /= s_alpha_0 ij; case def_ij: (enum_val ij) => [i j]. +have /andP[nzi nzj]: (i != 0) && (j != 0). + by rewrite -!in_setC1 -in_setX -def_ij enum_valP. +have:= congr1 (cfdotr (w_ i j)) s_alpha_0; rewrite raddf_sum raddf0 => <-. +rewrite (bigD1 ij) //= nth_image def_ij cfdotZl cfdot_alpha_w // !eqxx mulr1. +rewrite big1 ?addr0 // => ij1; rewrite nth_image -(inj_eq enum_val_inj) def_ij. +case: (enum_val ij1) => i1 j1 /= => ne_ij1_ij. +by rewrite cfdotZl cfdot_alpha_w // mulr_natr mulrb ifN. +Qed. + +(* Further results on alpha_ depend on the assumption that W is cyclic. *) + +Hypothesis ctiW : cyclicTI_hypothesis G defW. + +Let cycW : cyclic W. Proof. by case: ctiW. Qed. +Let oddW : odd #|W|. Proof. by case: ctiW. Qed. +Let tiV : normedTI V G W. Proof. by case: ctiW. Qed. +Let ntV : V != set0. Proof. by case/andP: tiV. Qed. + +Lemma cyclicTIhyp_sym (xdefW : W2 \x W1 = W) : cyclicTI_hypothesis G xdefW. +Proof. by split; rewrite // /cyclicTIset setUC. Qed. + +Let cycW1 : cyclic W1. Proof. exact: cyclicS cycW. Qed. +Let cycW2 : cyclic W2. Proof. exact: cyclicS cycW. Qed. +Let coW12 : coprime w1 w2. Proof. by rewrite -(cyclic_dprod defW). Qed. + +Let Wlin k : 'chi[W]_k \is a linear_char. Proof. exact/irr_cyclic_lin. Qed. +Let W1lin i : 'chi[W1]_i \is a linear_char. Proof. exact/irr_cyclic_lin. Qed. +Let W2lin i : 'chi[W2]_i \is a linear_char. Proof. exact/irr_cyclic_lin. Qed. +Let w_lin i j : w_ i j \is a linear_char. Proof. exact: Wlin. Qed. + +Let nirrW1 : #|Iirr W1| = w1. Proof. exact: card_Iirr_cyclic. Qed. +Let nirrW2 : #|Iirr W2| = w2. Proof. exact: card_Iirr_cyclic. Qed. +Let NirrW1 : Nirr W1 = w1. Proof. by rewrite -nirrW1 card_ord. Qed. +Let NirrW2 : Nirr W2 = w2. Proof. by rewrite -nirrW2 card_ord. Qed. + +Lemma cycTI_nontrivial : W1 :!=: 1%g /\ W2 :!=: 1%g. +Proof. +apply/andP; rewrite -!cardG_gt1 -!(subn_gt0 1) !subn1 -muln_gt0. +by rewrite -card_cycTIset card_gt0. +Qed. + +Let ntW1 : W1 :!=: 1%g. Proof. by case: cycTI_nontrivial. Qed. +Let ntW2 : W2 :!=: 1%g. Proof. by case: cycTI_nontrivial. Qed. +Let oddW1 : odd w1. Proof. exact: oddSg oddW. Qed. +Let oddW2 : odd w2. Proof. exact: oddSg oddW. Qed. +Let w1gt2 : (2 < w1)%N. Proof. by rewrite odd_gt2 ?cardG_gt1. Qed. +Let w2gt2 : (2 < w2)%N. Proof. by rewrite odd_gt2 ?cardG_gt1. Qed. + +Let neq_w12 : w1 != w2. +Proof. +by apply: contraTneq coW12 => ->; rewrite /coprime gcdnn -(subnKC w2gt2). +Qed. + +Let cWW : abelian W. Proof. exact: cyclic_abelian. Qed. +Let nsVW : V <| W. Proof. by rewrite -sub_abelian_normal ?subsetDl. Qed. +Let sWG : W \subset G. Proof. by have [_ /subsetIP[]] := normedTI_P tiV. Qed. +Let sVG : V \subset G^#. Proof. by rewrite setDSS ?subsetU ?sub1G. Qed. + +Let alpha1 i j : alpha_ i j 1%g = 0. +Proof. by rewrite cfDprod1 !cfunE cfun11 lin_char1 // subrr mul0r. Qed. + +(* This first part of Peterfalvi (3.4) will be used in (4.10) and (13.9). *) +Lemma cfCycTI_on i j : alpha_ i j \in 'CF(W, V). +Proof. +apply/cfun_onP=> x; rewrite !inE negb_and negbK orbC. +case/or3P => [/cfun0->// | W1x | W2x]. + by rewrite -[x]mulg1 cfDprodE // !cfunE cfun11 lin_char1 ?subrr ?mulr0. +by rewrite -[x]mul1g cfDprodE // !cfunE cfun11 lin_char1 ?subrr ?mul0r. +Qed. + +(* This is Peterfalvi (3.4). *) +Lemma cfCycTIbase_basis : basis_of 'CF(W, V) cfWVbase. +Proof. +rewrite basisEfree cfCycTIbase_free /=. +have ->: \dim 'CF(W, V) = #|V| by rewrite dim_cfun_on_abelian ?subsetDl. +rewrite size_tuple cardsX !cardsC1 nirrW1 nirrW2 -card_cycTIset leqnn andbT. +by apply/span_subvP=> _ /imageP[[i j] _ ->]; apply: cfCycTI_on. +Qed. +Local Notation cfWVbasis := cfCycTIbase_basis. + +Section CyclicTIisoBasis. + +Import CyclicTIisoReflexion ssrint. + +Local Notation unsat := (@unsat gT G). +Local Notation O := (@O gT G). +Local Notation "#1" := (inord 1). + +(* This is the combinatorial core of Peterfalvi (3.5.2). *) +(* Peterfalvi uses evaluation at 1%g to conclude after the second step; since *) +(* this is not covered by our model, we have used the dot product constraints *) +(* between b12 and b11, b21 instead. *) +Let unsat_J : unsat |= & x1 in b11 & -x1 in b21. +Proof. +uwlog b11x1: (& b11 = x1 + x2 + x3) by do 2!fill b11. +uwlog b21x1: (& b21 = -x1 + x2 + x3) by uhave x2, x3 in b21 as O(21, 11). +consider b12; uhave -x2 | x2 | ~x2 in b12. +- by uhave x1 in b12 as O(12, 11); counter to O(12, 21). +- uhave x1 | ~x1 in b12 as O(12, 21). + by uhave ~x3 in b12 as O(12, 21); counter to O(12, 11). + by uhave ~x3 in b12 as O(12, 11); counter to O(12, 21). +uhave x3 | ~x3 in b12 as O(12, 11). + by uhave x1 in b12 as O(12, 21); counter to O(12, 11). +by uhave x1 in b12 as O(12, 11); counter to O(12, 21). +Qed. + +Let unsat_II: unsat |= & x1, x2 in b11 & x1, x2 in b21. +Proof. by fill b11; uhave -x3 in b21 as O(21, 11); symmetric to unsat_J. Qed. + +(* This reflects the application of (3.5.2), but only to rule out nonzero *) +(* components of the first entry that conflict with positive components of *) +(* the second entry; Otest covers all the other uses of (3.5.2) in the proof. *) +Let Ltest (cl1 cl2 : clause) := + let: (i1, j1, kvs1) := cl1 in let: (i2, j2, kvs2) := cl2 in + let fix loop mm kvs2' := + if kvs2' is (k, v2) :: kvs2'' then + let v1 := odflt 0 (get_lit k kvs1) in + if (v2 != 1) || (v1 == 0) then loop mm kvs2'' else + if (v1 != 1) || mm then false else loop true kvs2'' + else true in + (i1 == i2) (+) (j1 == j2) ==> loop false kvs2. + +Let L ij12 : is_sat_test G (sat_test Ltest ij12). +Proof. +apply: sat_testP => m th [[i1 j1] kvs1] [[i2 j2] kvs2] m_th th_cl1 th_cl2. +wlog eq_j: m th i1 i2 j1 j2 m_th th_cl1 th_cl2 / j1 == j2. + move=> IH; case eq_j: (j1 == j2); first exact: IH m_th th_cl1 th_cl2 eq_j. + case eq_i: (i1 == i2); last by rewrite /= eq_i eq_j. + have /(_ (_, _, _)) mem_trt: _ \in tr_th th := map_f _ _. + by rewrite /= addbC; apply: IH (sat_tr m_th) _ _ eq_i; rewrite ?mem_trt. +apply/implyP; rewrite eq_j addbT => neq_i. +rewrite -[f in f _ kvs2]/(idfun _); set f := idfun _; rewrite /= in f *. +have [/= _ Ukvs2 kvsP] := satP m_th _ th_cl2. +move: Ukvs2; set kvs2' := kvs2; set mm := false. +have /allP: {subset kvs2' <= kvs2} by []. +pose lit12 k := (k, 1) \in kvs1 /\ (k, 1) \in kvs2. +have: mm -> {k | lit12 k & k \notin unzip1 kvs2'} by []. +elim: kvs2' mm => [|[k v2] kvs2' IH] //= mm mmP /andP[kvs2k /IH{IH}IHkvs]. +case/andP=> kvs2'k /IHkvs{IHkvs}IHkvs; case: ifP => [_ | /norP[]]. + by apply/IHkvs=> /mmP[kv kvs12kv /norP[]]; exists kv. +have [v1 /= kvs1k | //] := get_litP; case: eqP => // -> in kvs2k * => _ nz_v1. +case Dbb: (th_bbox th) (th_bboxP (bbox_refl (th_bbox th))) => [ri rj] rijP. +have [/andP[/=lti1r ltj1r] /andP[/=lti2r _]] := (rijP _ th_cl1, rijP _ th_cl2). +have rkP := th_dimP (leqnn _) _ th_cl1; have /= ltkr := rkP _ kvs1k. +have symP := unsat_match (Sym [:: i2; i1] [:: j1] _) _ _ m m_th. +rewrite /= Dbb lti1r lti2r ltj1r inE eq_sym neq_i /= in symP. +have [Dv1 | v1_neq1] /= := altP eqP; first rewrite Dv1 in kvs1k. + case: ifP => [/mmP[k0 [kvs1k0 kvs2k0]] | _]; last by apply: IHkvs; exists k. + case/norP=> k'k0; have [/=] := symP [:: k0; k] _ _ unsat_II. + rewrite inE k'k0 ltkr (rkP _ kvs1k0) /= andbT; apply/andP; split; apply/hasP. + by exists (i1, j1, kvs1) => //=; rewrite eqxx kvs1k kvs1k0. + by exists (i2, j2, kvs2) => //=; rewrite (eqP eq_j) eqxx kvs2k kvs2k0. +have{nz_v1 v1_neq1} Dv1: v1 = -1; last rewrite Dv1 in kvs1k. + by case: (v1) nz_v1 v1_neq1 (norm_lit m_th th_cl1 kvs1k) => [[|[]] | []]. +have[] := symP [:: k] _ _ unsat_J; rewrite /= ltkr !andbT /=; apply/andP; split. + by apply/hasP; exists (i1, j1, kvs1); rewrite //= eqxx kvs1k. +by apply/hasP; exists (i2, j2, kvs2); rewrite //= (eqP eq_j) eqxx kvs2k. +Qed. + +(* This is the combinatorial core of Peterfalvi (3.5.4). *) +(* We have made a few simplifications to the combinatorial analysis in the *) +(* text: we omit the (unused) step (3.5.4.4) entirely, which lets us inline *) +(* step (3.5.4.1) in the proof of (3.5.4.2); we clear the assumptions on b31 *) +(* and b32 before the final step (3.5.4.5), exposing a hidden symmetry. *) +Let unsat_Ii : unsat |= & x1 in b11 & x1 in b21 & ~x1 in b31. +Proof. +uwlog Db11: (& b11 = x1 + x2 + x3) by do 2!fill b11. +uwlog Db21: (& b21 = x1 + x4 + x5). + by uhave ~x2, ~x3 in b21 as L(21, 11); do 2!fill b21; uexact Db21. +uwlog Db31: (& b31 = x2 + x4 + x6). + uwlog b31x2: x2 | ~x2 in b31 as L(31, 11). + by uhave x3 in b31 as O(31, 11); symmetric to b31x2. + uwlog b31x4: x4 | ~x4 in b31 as L(31, 21). + by uhave x5 in b31 as O(31, 21); symmetric to b31x4. + uhave ~x3 in b31 as O(31, 11); uhave ~x5 in b31 as L(31, 21). + by fill b31; uexact Db31. +consider b41; uwlog b41x1: x1 | ~x1 in b41 as L(41, 11). + uwlog Db41: (& b41 = x3 + x5 + x6) => [|{b41x1}]. + uhave ~x2 | x2 in b41 as L(41, 11); last symmetric to b41x1. + uhave ~x4 | x4 in b41 as L(41, 21); last symmetric to b41x1. + uhave x3 in b41 as O(41, 11); uhave x5 in b41 as O(41, 21). + by uhave x6 in b41 as O(41, 31); uexact Db41. + consider b12; uwlog b12x1: x1 | ~x1 in b12 as L(12, 11). + uhave ~x2 | x2 in b12 as L(12, 11); last symmetric to b12x1. + by uhave x3 in b12 as O(12, 11); symmetric to b12x1. + uwlog b12x4: -x4 | ~x4 in b12 as O(12, 21). + by uhave -x5 in b12 as O(12, 21); symmetric to b12x4. + uhave ~x2, ~x3 in b12 as L(12, 11); uhave ~x5 in b12 as O(12, 21). + by uhave x6 in b12 as O(12, 31); counter to O(12, 41). +uwlog Db41: (& b41 = x1 + x6 + x7). + uhave ~x2, ~x3 in b41 as L(41, 11); uhave ~x4, ~x5 in b41 as L(41, 21). + by uhave x6 in b41 as O(41, 31); fill b41; uexact Db41. +consider b32; uwlog Db32: (& b32 = x6 - x7 + x8). + uwlog b32x6: x6 | ~x6 in b32 as L(32, 31). + uhave ~x2 | x2 in b32 as L(32, 31); last symmetric to b32x6. + by uhave x4 in b32 as O(32, 31); symmetric to b32x6. + uhave ~x2, ~x4 in b32 as L(32, 31). + uhave -x7 | ~x7 in b32 as O(32, 41). + uhave ~x1 in b32 as O(32, 41); uhave ~x3 in b32 as O(32, 11). + by uhave ~x5 in b32 as O(32, 21); fill b32; uexact Db32. + uhave -x1 in b32 as O(32, 41). + by uhave x3 in b32 as O(32, 11); counter to O(32, 21). +consider b42; uwlog Db42: (& b42 = x6 - x4 + x5). + uhave ~x6 | x6 in b42 as L(42, 41). + uhave ~x7 | x7 in b42 as L(42, 41); last counter to O(42, 32). + uhave x1 in b42 as O(42, 41); uhave x8 in b42 as O(42, 32). + uhave ~x2 | -x2 in b42 as O(42, 11); last counter to O(42, 21). + by uhave -x3 in b42 as O(42, 11); counter to O(42, 21). + uwlog b42x4: -x4 | ~x4 in b42 as O(42, 31). + by uhave -x2 in b42 as O(42, 31); symmetric to b42x4. + by uhave ~x1 in b42 as L(42, 41); uhave x5 in b42 as O(42, 21); uexact Db42. +uwlog Db32: (& ? in b32); first uexact Db32. +uwlog Db41: (& ? in b41); first uexact Db41. +consider b12; uwlog b12x5: x5 | ~x5 in b12 as L(12, 42). + uhave ~x6 | x6 in b12 as L(12, 42); last by consider b22; symmetric to b12x5. + uhave -x4 in b12 as O(12, 42); uhave x1 in b12 as O(12, 21). + by uhave ~x2 in b12 as L(12, 11); counter to O(12, 31). +uhave ~x6 in b12 as L(12, 42); uhave ~x4 in b12 as O(12, 42). +uhave ~x2 in b12 as O(12, 31). +by uhave -x1 in b12 as O(12, 21); counter to L(12, 11). +Qed. + +Let unsat_C : unsat |= & x1 in b11 & x1 in b21 & x1 in b12. +Proof. +consider b31; uwlog Db21: (& b21 = x1 + x2 + x3) by do 2!fill b21. +uwlog Db12: (& b12 = x1 - x2 + x4). + uwlog b21x2: -x2 | ~x2 in b12 as O(12, 21). + by uhave -x3 in b12 as O(12, 21); symmetric to b21x2. + by uhave ~x3 in b12 as O(12, 21); fill b12; uexact Db12. +uwlog Db31: (& b31 = x1 - x4 + x5). + uhave x1 | ~x1 in b31 as L(31, 21); last uexact unsat_Ii. + uhave ~x2, ~x3 in b31 as L(31, 21). + by uhave -x4 in b31 as O(31, 12); fill b31; uexact Db31. +consider b41; uhave x1 | ~x1 in b41 as L(41, 21); last symmetric to unsat_Ii. +uhave ~x5 in b41 as L(41, 31); uhave ~x4 in b41 as O(41, 31). +by uhave ~x2 in b41 as L(41, 21); counter to O(41, 12). +Qed. + +(* This refinement of Peterfalvi (3.5.4) is the essential part of (3.5.5). *) +Let column_pivot (m : model G) (j0 : 'I_m.2.+1) : + exists dk, forall (i : 'I_m.1.+1) (j : 'I_m.2.+1), + j0 != 0 -> i != 0 -> j != 0 -> '[m (i.-1, j.-1), dchi dk] = (j == j0)%:R. +Proof. +pose t_i (i0 i1 : nat) := [eta id with i0 |-> i1, i1 |-> i0]. +pose t_ij i0 i1 ij : ref := (t_i i0 i1 ij.1, ij.2). +have t_iK i0 i1: involutive (t_i i0 i1). + move=> i /=; have [-> | i0'i] := altP (i =P i0). + by rewrite eqxx; case: eqP. + by have [-> | /negPf->] := altP (i =P i1); rewrite ?eqxx // ifN. +have lt_t_i i0 i1 ri i: (i0 <= i1 < ri)%N -> (t_i i0 i1 i < ri)%N = (i < ri)%N. + case/andP=> le_i01 lti1 /=. + by do 2?case: eqP => [-> | _] //; rewrite ?(leq_trans _ lti1). +have t_mP i0 i1 (m0 : model G): + (i0 <= i1 < m0.1)%N -> is_Lmodel m0 (m0 \o t_ij i0 i1). +- have [lbm0 Zm0 Dm0] := LmodelP m0; split=> //= ij1 ij2 wf_ij1 wf_ij2. + by rewrite Dm0 /dot_ref ?(can_eq (t_iK _ _)) // !inE ?lt_t_i. +pose t_m i0 i1 m0 lti01 := Model (t_mP i0 i1 m0 lti01) (RmodelP m0). +without loss suffices{j0 lt_t_i} IHm: m / + exists dk, {in wf_ref m, forall ij, '[m ij, dchi dk] = (ij.2 == 0%N)%:R}. +- have [_ | nzj0] := altP eqP; first by exists (dirr1 G). + have ltj0: (j0.-1 < m.2)%N by rewrite prednK ?lt0n ?leq_ord. + have{IHm} [dk Ddk] := IHm (tr_model (t_m 0%N j0.-1 (tr_model m) ltj0)). + exists dk => i j _ nzi nzj; rewrite -[j.-1](t_iK 0%N j0.-1). + rewrite (Ddk (_, _)) ?inE ?lt_t_i // ?prednK ?lt0n ?leq_ord //. + by rewrite (inv_eq (t_iK _ _)) -eqSS !prednK ?lt0n. +pose cl11 := & b11 = x1 + x2 + x3. +without loss m_th: m / sat m |= cl11 & ? in b21. + move=> IHm; suffices{IHm}: sat m |= & ? in b11 & ? in b21. + have fill_b11 := sat_fill _ (mem_nth cl11 (_ : 1 < _))%N. + by do 3![case/fill_b11=> // ?]; apply: IHm. + have [[_ _ m1gt2 /ltnW m2gt0 _] _ _] := LmodelP m. + by rewrite /sat /= -!andbA /= m2gt0 -(subnKC m1gt2). +without loss{m_th} m_th: m / sat m |= & x1 in b11 & x1 in b21. + pose sat123P := @allP _ (fun k => sat_lit m _ (k, _)) (rev (iota 0 3)). + have [m123 | ] := altP (sat123P b21 0). + suffices: sat m |= cl11 & ~x1, ~x2, ~x3 in b21 by move/(O(21, 11)). + by rewrite /sat /= {1}/sat_cl /= !m123. + case/allPn=> k k012 /negP nz_m21 IHm; rewrite -[sat_lit _ _ _]andbT in nz_m21. + have ltk3: (k < 3)%N by rewrite mem_rev mem_iota in k012. + have [[/andP[/allP/=n1m _] Zm] [_ /= m_gt2 _]] := (RmodelP m, and3P m_th). + have ltk := leq_trans ltk3 m_gt2. + have{n1m Zm} mkP: is_Rmodel [:: m`_k]. + by split=> [|_ /predU1P[->|//]]; rewrite /orthonormal /= ?n1m ?Zm ?mem_nth. + pose mk := Model (LmodelP m) mkP; apply: {IHm}(IHm mk). + have{m_th} [v lit_v m_th] := sat_cases k m_th (mem_head _ _) ltk. + suffices: sat mk |= & x1 in b11 & (Lit 1 v) in b21. + by case/or4P: lit_v m_th => // /eqP-> => [/and4P[] | | _ /(L(21,11))]. + have [m_bb _ m_b21 /sat123P m_b11 _] := and5P m_th. + by apply/and5P; split; rewrite // /sat_cl /= [sat_lit _ _ _]m_b11. +have /dIrrP[dk Ddk]: m`_0 \in dirr G. + have [[/andP[/allP n1m _] Zm] [_ m_gt0 _]] := (RmodelP m, and3P m_th). + by rewrite dirrE Zm ?[_ == 1]n1m ?mem_nth. +exists dk => [][i j] /andP[/= lti ltj]; apply/eqP. +suffices{dk Ddk}: sat_cl m (& (Lit 1 (j == 0))%N in (i, j)). + by rewrite /sat_cl /= andbT /sat_lit Ddk. +without loss{i lti} ->: m i ltj m_th / i = 0%N. + have [bb21_m m_gt0 m11_x1 m21_x1 _] := and5P m_th. + move=> IHi; suffices{IHi} m_i1_x1: sat_lit m (i, 0)%N x1 && true. + apply: (IHi (t_m 0%N i m lti) 0%N); rewrite /sat /sat_cl //= bb21_m m_gt0. + by rewrite /= m_i1_x1 /sat_lit /= andbT /t_ij /=; case: ifP. + case i_gt1: (1 < i)%N; last by case: (i) i_gt1 => [|[|[]]]. + have itv_i: (1 < i < m.1)%N by [apply/andP]; pose m2 := t_m 2 i m itv_i. + have m2_th: sat m2 |= & x1 in b11 & x1 in b21 & ? in b31. + rewrite /sat m_gt0 -andbA (leq_trans _ lti) ?(leq_trans _ ltj) /sat_cl //=. + by rewrite /sat_lit /= -(subnKC i_gt1); have [_ _] := and3P m_th. + have [v] := sat_cases _ m2_th (mem_head _ _) m_gt0; rewrite !inE. + by case/or3P=> /eqP-> => [/unsat_Ii | /and4P[] | /(L(31,11))]. +have [-> | nzj] := posnP j; first by case/and5P: m_th. +without loss{ltj nzj} ->: m j m_th / j = 1%N. + have itv_j: (0 < j < m.2)%N by rewrite nzj. + move/(_ (tr_model (t_m _ j (tr_model m) itv_j)) _ _ (erefl _)) => /=. + by rewrite /sat /sat_cl /sat_lit /= -(prednK nzj) => ->. +have{m_th}[/= _ m_gt0 m_x1] := and3P m_th. +have{m_x1} m_th: sat m |= & x1 in b11 & x1 in b21 & ? in b12. + by rewrite /sat m_gt0 /sub_bbox; have [[_ _ -> ->]] := LmodelP m. +have [v] := sat_cases 0%N m_th (mem_head _ _) m_gt0; rewrite !inE. +by case/or3P=> /eqP-> => [/and4P[] | /unsat_C | /(L(12,11))]. +Qed. + +(* This is Peterfalvi (3.5). *) +(* We have inlined part of the proof of (3.5.5) in this main proof, replacing *) +(* some combinatorial arguments with direct computation of the dot product, *) +(* this avoids the duplicate case analysis required to exploit (3.5.5) as it *) +(* is stated in the text. *) +Lemma cyclicTIiso_basis_exists : + exists xi_ : Iirr W1 -> Iirr W2 -> 'CF(G), + [/\ xi_ 0 0 = 1, forall i j, xi_ i j \in 'Z[irr G], + forall i j, i != 0 -> j != 0 -> + 'Ind (alpha_ i j) = 1 - xi_ i 0 - xi_ 0 j + xi_ i j + & forall i1 j1 i2 j2, '[xi_ i1 j1, xi_ i2 j2] = ((i1, j1) == (i2, j2))%:R]. +Proof. +(* Instantiate the abstract theory vertically and horizontally. *) +pose beta i j : 'CF(G) := 'Ind[G] (alpha_ i j) - 1. +have Zbeta i j: beta i j \in 'Z[irr G]. + by rewrite rpredB ?rpred1 ?cfInd_vchar ?cfCycTI_vchar. +have o_alphaG_1 i j: i != 0 -> j != 0 -> '['Ind[G] (alpha_ i j), 1] = 1. + by move=> nz_i nz_j; rewrite -cfdot_Res_r rmorph1 cfdot_alpha_1. +have o_beta_1 i j: i != 0 -> j != 0 -> '[beta i j, 1] = 0. + by move=> nzi nzj; rewrite cfdotBl o_alphaG_1 // cfnorm1 subrr. +have o_beta i1 j1 i2 j2 : i1 != 0 -> j1 != 0 -> i2 != 0 -> j2 != 0 -> + '[beta i1 j1, beta i2 j2] = ((i1 == i2).+1 * (j1 == j2).+1 - 1)%:R. +- move=> nzi1 nzj1 nzi2 nzj2; rewrite mulSnr addnS mulnSr /=. + rewrite cfdotBr o_beta_1 // subr0 cfdotBl (cfdotC 1) o_alphaG_1 //. + rewrite (normedTI_isometry tiV) ?cfCycTI_on // rmorph1 addrC. + rewrite (alphaE i2) cfdotDr !cfdotBr cfdot_alpha_1 // -!addrA addKr addrA. + rewrite addrC cfdot_alpha_w // subn1 -addnA !natrD mulnb; congr (_ + _). + rewrite alphaE -w_00 !(cfdotBl, cfdotDl) !cfdot_w !eqxx !(eq_sym 0). + rewrite (negPf nzi1) (negPf nzj1) (negPf nzi2) (negPf nzj2) /= !andbF !andbT. + by rewrite !addr0 !subr0 !opprB !subr0. +pose beta_fun := [fun ij => beta (inord ij.1.+1) (inord ij.2.+1)]. +have beta_modelP: is_Lmodel ((Nirr W1).-1, (Nirr W2).-1) beta_fun. + split=> [ | //= | ij1 ij2 /=/andP[lti1 ltj1] /andP[lti2 ltj2]]. + by rewrite -!(ltnS 2) -eqSS NirrW1 NirrW2. + by rewrite o_beta -?val_eqE /= ?inordK. +pose beta_model := Model beta_modelP (nil_RmodelP G). +have betaE i j: i != 0 -> j != 0 -> beta i j = beta_fun (i.-1, j.-1). + by move=> nzi nzj /=; rewrite !prednK ?lt0n ?inord_val. +have /fin_all_exists [dXi0 betaXi0] i0: exists dX, i0 != 0 -> + forall i j, i != 0 -> j != 0 -> '[beta i j, dchi dX] = (i == i0)%:R. +- have [/= dX DdX] := @column_pivot (tr_model beta_model) i0. + by exists dX => nzi0 i j nzi nzj; rewrite betaE ?DdX. +have /fin_all_exists [dX0j betaX0j] j0: exists dX, j0 != 0 -> + forall i j, i != 0 -> j != 0 -> '[beta i j, dchi dX] = (j == j0)%:R. +- have [dX DdX] := @column_pivot beta_model j0. + by exists dX => nzj0 i j nzi nzj; rewrite betaE ?DdX. +pose Xi0 j := dchi (dXi0 j); pose X0j i := dchi (dX0j i). +(* Construct the orthonormal family xi_ i j. *) +pose xi_ i j := if i == 0 then if j == 0 then 1 else - X0j j else + if j == 0 then - Xi0 i else beta i j - Xi0 i - X0j j. +exists xi_; split=> [| i j | i j nzi nzj | i1 j1 i2 j2]. +- by rewrite /xi_ !eqxx. +- rewrite /xi_; do 2!case: ifP => _; rewrite ?rpred1 ?rpredN ?dchi_vchar //. + by rewrite 2?rpredB ?dchi_vchar. +- by rewrite /xi_ /= !ifN // addrCA subrK addrACA subrK addrA addrK. +have o_dchi i j dk1 dk2 (phi := beta i j): + '[phi, dchi dk1] = 1 -> '[phi, dchi dk2] = 0 -> '[dchi dk1, dchi dk2] = 0. +- move=> phi1 phi0; have /eqP: 1 != 0 :> algC := oner_neq0 _. + rewrite -phi1 cfdot_dchi; do 2!case: eqP => [->|_]; rewrite ?subrr //. + by rewrite dchi_ndirrE cfdotNr phi0 oppr0. +have [nzi01 nzj01] := (Iirr1_neq0 ntW1, Iirr1_neq0 ntW2). +have X0j_1 j: j != 0 -> '[X0j j, 1] = 0. + by move=> nzj; rewrite -dchi1 (o_dchi #1 j) ?betaX0j ?eqxx ?dchi1 ?o_beta_1. +have Xi0_1 i: i != 0 -> '[Xi0 i, 1] = 0. + by move=> nzi; rewrite -dchi1 (o_dchi i #1) ?betaXi0 ?eqxx ?dchi1 ?o_beta_1. +have Xi0_X0j i j: i != 0 -> j != 0 -> '[Xi0 i, X0j j] = 0. + move=> nzi nzj; pose j' := conjC_Iirr j. + apply: (o_dchi i j'); rewrite (betaX0j, betaXi0) ?conjC_Iirr_eq0 ?eqxx //. + by rewrite -(inj_eq irr_inj) conjC_IirrE mulrb ifN ?odd_eq_conj_irr1 ?irr_eq1. +have X0j_X0j j j0: j != 0 -> j0 != 0 -> '[X0j j, X0j j0] = (j == j0)%:R. + move=> nzj nzj0; case: (altP eqP) => [-> | j0'j]; first exact: cfnorm_dchi. + by apply: (o_dchi #1 j); rewrite ?betaX0j ?eqxx ?(negPf j0'j). +have Xi0_Xi0 i i0: i != 0 -> i0 != 0 -> '[Xi0 i, Xi0 i0] = (i == i0)%:R. + move=> nzi nzi0; case: (altP eqP) => [-> | i0'i]; first exact: cfnorm_dchi. + by apply: (o_dchi i #1); rewrite ?betaXi0 ?eqxx ?(negPf i0'i). +have oxi_00 i j: '[xi_ i j, xi_ 0 0] = ((i == 0) && (j == 0))%:R. + rewrite /xi_; case: ifPn => [_ | nzi]. + by case: ifPn => [_ | nzj]; rewrite ?cfnorm1 // cfdotNl X0j_1 ?oppr0. + case: ifPn => [_ | nzj]; first by rewrite cfdotNl Xi0_1 ?oppr0. + by rewrite 2!cfdotBl o_beta_1 ?X0j_1 ?Xi0_1 ?subr0. +have oxi_0j i j j0: '[xi_ i j, xi_ 0 j0] = ((i == 0) && (j == j0))%:R. + rewrite /xi_; have [-> | nzj0] := altP (j0 =P 0); first exact: oxi_00. + rewrite cfdotNr; case: ifPn => [_ | nzi]. + have [-> | nzj] := altP eqP; last by rewrite cfdotNl opprK X0j_X0j. + by rewrite cfdotC X0j_1 // conjC0 oppr0 mulrb ifN_eqC. + have [_ | nzj] := ifPn; first by rewrite cfdotNl Xi0_X0j ?oppr0. + by rewrite 2!cfdotBl Xi0_X0j // subr0 betaX0j ?X0j_X0j // subrr oppr0. +have{oxi_00} oxi_i0 i j i0: '[xi_ i j, xi_ i0 0] = ((i == i0) && (j == 0))%:R. + rewrite /xi_; have [-> | nzi0] := altP (i0 =P 0); first exact: oxi_00. + rewrite cfdotNr andbC; have [_ | nzj] := boolP (j == 0). + have [-> | nzi] := altP eqP; last by rewrite cfdotNl opprK Xi0_Xi0. + by rewrite cfdotC Xi0_1 // conjC0 oppr0 mulrb ifN_eqC. + have [_ | nzi] := ifPn; first by rewrite cfdotNl opprK cfdotC Xi0_X0j ?conjC0. + rewrite 2!cfdotBl betaXi0 ?Xi0_Xi0 // subrr add0r opprK. + by rewrite cfdotC Xi0_X0j // conjC0. +have [-> | nzi2] := altP (i2 =P 0); first exact: oxi_0j. +have [-> | nzj2] := altP (j2 =P 0); first exact: oxi_i0. +rewrite cfdotC eq_sym; apply: canLR conjCK _; rewrite rmorph_nat. +have [-> | nzi1] := altP (i1 =P 0); first exact: oxi_0j. +have [-> | nzj1] := altP (j1 =P 0); first exact: oxi_i0. +have ->: xi_ i1 j1 = beta i1 j1 + xi_ i1 0 + xi_ 0 j1 by rewrite /xi_ !ifN. +rewrite 2!cfdotDr oxi_i0 oxi_0j andbC /xi_ (negPf nzi2) (negPf nzj2) !addr0. +rewrite eq_sym xpair_eqE cfdotC 2!cfdotBr o_beta // betaXi0 ?betaX0j //. +by rewrite -!CintrE /= rmorph_int; do 2!case: (_ == _). +Qed. + +End CyclicTIisoBasis. + +(* This is PeterFalvi, Theorem (3.2)(a, b, c). *) +Theorem cyclicTIiso_exists : + {sigma : 'Hom(cfun_vectType W, cfun_vectType G) | + [/\ {in 'Z[irr W], isometry sigma, to 'Z[irr G]}, sigma 1 = 1 + & {in 'CF(W, V), forall phi : 'CF(W), sigma phi = 'Ind[G] phi}]}. +Proof. +pose sigmaVP f := ('CF(W, V) <= lker (linfun f - linfun 'Ind[G]))%VS. +pose sigmaP f := [&& orthonormal (map f (irr W)), f 1 == 1 & sigmaVP f]. +pose sigma_base f := [seq (dchi (f k) : 'CF(G)) | k : Iirr W]. +pose sigma_spec f := sigmaP (sval (linear_of_free (irr W) (sigma_base f))). +suffices /sigW[f /and3P[]]: exists f : {ffun _}, sigma_spec f. + case: linear_of_free => /=sigma Dsigma o1sigma /eqP sigma1 /eqlfun_inP sigmaV. + exists (linfun sigma); split=> [|| phi /sigmaV]; try by rewrite !lfunE. + do [rewrite size_map !size_tuple => /(_ (irr_free W) (card_ord _))] in Dsigma. + have [inj_sigma dot_sigma] := orthonormalP o1sigma. + rewrite -(map_tnth_enum (irr W)) -map_comp in Dsigma inj_sigma. + move/eq_in_map in Dsigma; move/injectiveP in inj_sigma. + split=> [|_ /zchar_tuple_expansion[z Zz ->]]. + apply: isometry_in_zchar=> _ _ /irrP[k1 ->] /irrP[k2 ->] /=. + by rewrite !lfunE dot_sigma ?map_f ?mem_irr // cfdot_irr (inj_eq inj_sigma). + rewrite linear_sum rpred_sum // => k _; rewrite linearZ rpredZ_Cint //=. + by rewrite -tnth_nth lfunE [sigma _]Dsigma ?mem_enum ?dchi_vchar. +have [xi_ [xi00 Zxi Dxi o1xi]] := cyclicTIiso_basis_exists. +pose f := [ffun k => dirr_dIirr (prod_curry xi_) (inv_dprod_Iirr defW k)]. +exists f; apply/and3P; case: linear_of_free => /= sigma Dsigma. +have{f Dsigma} Deta i j: sigma (w_ i j) = xi_ i j. + rewrite /w_ -tnth_map /= (tnth_nth 0) /=. + rewrite Dsigma ?irr_free //; last by rewrite !size_tuple card_ord. + rewrite nth_mktuple ffunE dprod_IirrK dirr_dIirrE // => {i j} [[i j]] /=. + by rewrite dirrE Zxi o1xi !eqxx. +have sigma1: sigma 1 = 1 by rewrite -w_00 Deta. +rewrite sigma1 /sigmaVP -(span_basis cfWVbasis); split=> //. + rewrite map_orthonormal ?irr_orthonormal //; apply: isometry_in_zchar. + move=> _ _ /cycTIirrP[i1 [j1 ->]] /cycTIirrP[i2 [j2 ->]] /=. + by rewrite !Deta o1xi cfdot_w. +apply/span_subvP=> _ /imageP[[i j] /setXP[nzi nzj] ->]; rewrite !inE in nzi nzj. +rewrite memv_ker !lfun_simp /= subr_eq0 Dxi //. +by rewrite alphaE linearD !linearB sigma1 !Deta. +Qed. + +Fact cyclicTIiso_key : unit. Proof. by []. Qed. +Definition cyclicTIiso := + locked_with cyclicTIiso_key (lfun_linear (sval cyclicTIiso_exists)). +Local Notation sigma := cyclicTIiso. +Let im_sigma := map sigma (irr W). +Let eta_ i j := sigma (w_ i j). + +Lemma cycTI_Zisometry : {in 'Z[irr W], isometry sigma, to 'Z[irr G]}. +Proof. by rewrite [sigma]unlock; case: cyclicTIiso_exists => ? []. Qed. + +Let Isigma : {in 'Z[irr W] &, isometry sigma}. +Proof. by case: cycTI_Zisometry. Qed. +Let Zsigma : {in 'Z[irr W], forall phi, sigma phi \in 'Z[irr G]}. +Proof. by case: cycTI_Zisometry. Qed. + +Lemma cycTIisometry : isometry sigma. +Proof. +move=> phi psi; have [[a ->] [b ->]] := (cfun_irr_sum phi, cfun_irr_sum psi). +rewrite !linear_sum !cfdot_suml; apply: eq_bigr => i _. +rewrite !cfdot_sumr; apply: eq_bigr => j _. +by rewrite !linearZ !cfdotZl !cfdotZr /= Isigma ?irr_vchar. +Qed. + +Lemma cycTIiso_vchar i j : eta_ i j \in 'Z[irr G]. +Proof. by rewrite Zsigma ?irr_vchar. Qed. + +Lemma cfdot_cycTIiso i1 i2 j1 j2 : + '[eta_ i1 j1, eta_ i2 j2] = ((i1 == i2) && (j1 == j2))%:R. +Proof. by rewrite cycTIisometry. Qed. + +Lemma cfnorm_cycTIiso i j : '[eta_ i j] = 1. +Proof. by rewrite cycTIisometry cfnorm_irr. Qed. + +Lemma cycTIiso_dirr i j : eta_ i j \in dirr G. +Proof. by rewrite dirrE cycTIiso_vchar /= cfnorm_cycTIiso. Qed. + +Lemma cycTIiso_orthonormal : orthonormal im_sigma. +Proof. by rewrite map_orthonormal ?irr_orthonormal. Qed. + +Lemma cycTIiso_eqE i1 i2 j1 j2 : + (eta_ i1 j1 == eta_ i2 j2) = ((i1 == i2) && (j1 == j2)). +Proof. +have /inj_in_eq-> := Zisometry_inj Isigma; try exact: irr_vchar. +by rewrite (inj_eq irr_inj) (inj_eq (dprod_Iirr_inj _)). +Qed. + +Lemma cycTIiso_neqN i1 i2 j1 j2 : (eta_ i1 j1 == - eta_ i2 j2) = false. +Proof. +rewrite -addr_eq0; apply/eqP=> /(congr1 (cfdot (eta_ i1 j1)))/eqP. +by rewrite cfdot0r cfdotDr !cfdot_cycTIiso !eqxx -mulrS pnatr_eq0. +Qed. + +Lemma cycTIiso1 : sigma 1 = 1. +Proof. by rewrite [sigma]unlock; case: cyclicTIiso_exists => ? []. Qed. + +Lemma cycTIiso_Ind : {in 'CF(W, V), forall phi, sigma phi = 'Ind[G, W] phi}. +Proof. by rewrite [sigma]unlock; case: cyclicTIiso_exists => ? []. Qed. + +Let sigma_Res_V : + [/\ forall phi, {in V, sigma phi =1 phi} + & forall psi : 'CF(G), orthogonal psi im_sigma -> {in V, psi =1 \0}]. +Proof. +have sigW i j : '[sigma 'chi_i, sigma 'chi_j] = (i == j)%:R. + by rewrite cycTIisometry cfdot_irr. +have [j | sigmaV sigma'V] := equiv_restrict_compl_ortho sWG nsVW cfWVbasis sigW. + rewrite /= -/cfWVbase -(eq_bigr _ (fun _ _ => linearZ _ _)) /= -linear_sum. + rewrite -cfun_sum_cfdot cycTIiso_Ind //. + by rewrite (basis_mem cfWVbasis) ?mem_nth ?size_image. +split=> [phi v Vv | psi /orthoPl o_psi_sigma]. + rewrite [phi]cfun_sum_cfdot linear_sum !sum_cfunE. + by apply: eq_bigr => k _; rewrite linearZ !cfunE sigmaV. +by apply: sigma'V => k; rewrite o_psi_sigma ?map_f ?mem_irr. +Qed. + +(* This is Peterfalvi, Theorem (3.2)(d). *) +Theorem cycTIiso_restrict phi : {in V, sigma phi =1 phi}. +Proof. by case: sigma_Res_V. Qed. + +(* This is Peterfalvi, Theorem (3.2)(e). *) +Theorem ortho_cycTIiso_vanish (psi : 'CF(G)) : + orthogonal psi im_sigma -> {in V, forall x, psi x = 0}. +Proof. by case: sigma_Res_V psi. Qed. + +(* This is PeterFalvi (3.7). *) +Lemma cycTIiso_cfdot_exchange (psi : 'CF(G)) i1 i2 j1 j2 : + {in V, forall x, psi x = 0} -> + '[psi, eta_ i1 j1] + '[psi, eta_ i2 j2] + = '[psi, eta_ i1 j2] + '[psi, eta_ i2 j1]. +Proof. +move=> psiV_0; pose phi : 'CF(W) := w_ i1 j1 + w_ i2 j2 - w_ i1 j2 - w_ i2 j1. +have Vphi: phi \in 'CF(W, V). + apply/cfun_onP=> g; rewrite inE negb_and negbK !inE orbC. + case/or3P=> [/cfun0-> // | W1g | W2g]; apply/eqP; rewrite !cfunE subr_eq0. + by rewrite addrC -[g]mulg1 /w_ !dprod_IirrE !cfDprodE ?lin_char1 ?addKr. + by rewrite -[g]mul1g /w_ !dprod_IirrE !cfDprodE ?lin_char1 ?addrK. +suffices: '[psi, 'Ind[G] phi] == 0. + rewrite -!cycTIiso_Ind // !linearB !linearD !cfdotBr !cfdotDr. + by rewrite -addrA -opprD subr_eq0 => /eqP. +rewrite (cfdotEr _ (cfInd_on sWG Vphi)) big1 ?mulr0 //. +by move=> _ /imset2P[x y Vx Gy ->]; rewrite cfunJ ?psiV_0 ?mul0r. +Qed. + +(* This is NC as defined in PeterFalvi (3.6). *) +Definition cyclicTI_NC phi := #|[set ij | '[phi, eta_ ij.1 ij.2] != 0]|. +Local Notation NC := cyclicTI_NC. + +Lemma cycTI_NC_opp (phi : 'CF(G)) : (NC (- phi)%R = NC phi)%N. +Proof. by apply: eq_card=> [[i j]]; rewrite !inE cfdotNl oppr_eq0. Qed. + +Lemma cycTI_NC_sign (phi : 'CF(G)) n : (NC ((-1) ^+ n *: phi)%R = NC phi)%N. +Proof. +elim: n=> [|n IH]; rewrite ?(expr0,scale1r) //. +by rewrite exprS -scalerA scaleN1r cycTI_NC_opp. +Qed. + +Lemma cycTI_NC_iso i j : NC (eta_ i j) = 1%N. +Proof. +rewrite -(cards1 (i, j)); apply: eq_card => [[i1 j1]]; rewrite !inE /=. +rewrite cfdot_cycTIiso //= pnatr_eq0 (can_eq oddb _ false) eqbF_neg negbK. +by rewrite -xpair_eqE eq_sym. +Qed. + +Lemma cycTI_NC_irr i : (NC 'chi_i <= 1)%N. +Proof. +apply: wlog_neg; rewrite -ltnNge => /ltnW/card_gt0P[[i1 j1]]. +rewrite inE cfdot_dirr ?(irr_dirr, cycTIiso_dirr) //=. +case: ('chi_i =P _) => [-> | _]; first by rewrite cycTI_NC_opp cycTI_NC_iso. +by case: ('chi_i =P _)=> [-> | _]; rewrite (cycTI_NC_iso, eqxx). +Qed. + +Lemma cycTI_NC_dirr f : f \in dirr G -> (NC f <= 1)%N. +Proof. by case/dirrP=> b [i ->]; rewrite cycTI_NC_sign cycTI_NC_irr. Qed. + +Lemma cycTI_NC_dchi di : (NC (dchi di) <= 1)%N. +Proof. by rewrite cycTI_NC_dirr ?dirr_dchi. Qed. + +Lemma cycTI_NC_0 : NC 0 = 0%N. +Proof. by apply: eq_card0 => ij; rewrite !inE cfdot0l eqxx. Qed. + +Lemma cycTI_NC_add n1 n2 phi1 phi2 : + (NC phi1 <= n1 -> NC phi2 <= n2 -> NC (phi1 + phi2)%R <= n1 + n2)%N. +Proof. +move=> ub1 ub2; apply: leq_trans {ub1 ub2}(leq_add ub1 ub2). +rewrite -cardsUI -[NC _]addn0 leq_add // subset_leq_card //. +apply/subsetP=> [[i j]]; rewrite !inE /= -negb_and cfdotDl. +by apply: contra => /andP[/eqP-> /eqP->]; rewrite addr0. +Qed. + +Lemma cycTI_NC_sub n1 n2 phi1 phi2 : + (NC phi1 <= n1 -> NC phi2 <= n2 -> NC (phi1 - phi2)%R <= n1 + n2)%N. +Proof. by move=> ub1 ub2; rewrite cycTI_NC_add ?cycTI_NC_opp. Qed. + +Lemma cycTI_NC_scale_nz a phi : a != 0 -> NC (a *: phi) = NC phi. +Proof. +move=> nz_a; apply: eq_card => ij. +by rewrite !inE cfdotZl mulf_eq0 negb_or nz_a. +Qed. + +Lemma cycTI_NC_scale a phi n : (NC phi <= n -> NC (a *: phi) <= n)%N. +Proof. +have [-> _ | /cycTI_NC_scale_nz-> //] := eqVneq a 0. +by rewrite scale0r cycTI_NC_0. +Qed. + +Lemma cycTI_NC_norm phi n : + phi \in 'Z[irr G] -> '[phi] <= n%:R -> (NC phi <= n)%N. +Proof. +move=> Zphi ub_phi; apply: leq_trans (_ : #|dirr_constt phi| <= n)%N. + rewrite {1}[phi]cfun_sum_dconstt // -sum1_card. + elim/big_rec2: _ => [|/= i n1 phi1 _]; first by rewrite cycTI_NC_0. + by apply: cycTI_NC_add; rewrite cycTI_NC_scale ?cycTI_NC_dchi. +rewrite -leC_nat (ler_trans _ ub_phi) ?cnorm_dconstt // -sumr_const. +apply: ler_sum => i phi_i; rewrite sqr_Cint_ge1 ?Cint_Cnat ?Cnat_dirr //. +by rewrite gtr_eqF -?dirr_consttE. +Qed. + +(* This is PeterFalvi (3.8). *) +Lemma small_cycTI_NC phi i0 j0 (a0 := '[phi, eta_ i0 j0]) : + {in V, forall x, phi x = 0} -> (NC phi < 2 * minn w1 w2)%N -> a0 != 0 -> + (forall i j, '[phi, eta_ i j] = (j == j0)%:R * a0) + \/ (forall i j, '[phi, eta_ i j] = (i == i0)%:R * a0). +Proof. +pose a i j := '[phi, eta_ i j]; pose A := [set ij | a ij.1 ij.2 != 0]. +rewrite -[NC phi]/#|A| ltnNge => phiV_0 ubA nz_a0. +have{phiV_0} Da i2 j2 i1 j1 : a i1 j1 = a i1 j2 + a i2 j1 - a i2 j2. + by rewrite cycTIiso_cfdot_exchange ?addrK. +have ubA2: ~~ (w2 + w1 <= #|A| + 2)%N. + rewrite addnC addn2 -ltnS (contra _ ubA) //; apply: (@leq_trans _ _.+3). + rewrite odd_geq /= ?odd_add ?oddW1 ?oddW2 // mul2n -addn_min_max -addnn. + by rewrite uphalf_double leq_add2l gtn_min !leq_max !ltnn orbF -neq_ltn. +(* This is step (3.8.1). *) +have Za i1 i2 j1 j2 : a i1 j2 == 0 -> a i2 j1 == 0 -> a i1 j1 == 0. + have [-> // | /negPf i2'1 /eqP Za12 /eqP Za21] := eqVneq i1 i2. + apply: contraR ubA2 => nz_a11. + pose L := [set (if a i1 j == 0 then i2 else i1, j) | j : Iirr W2]. + pose C := [set (i, if a i j1 == 0 then j2 else j1) | i : Iirr W1]. + have [<- <-]: #|L| = w2 /\ #|C| = w1 by rewrite !card_imset // => ? ? []. + have <-: #|[set (i1, j1); (i2, j2)]| = 2 by rewrite cards2 xpair_eqE i2'1. + rewrite -cardsUI leq_add ?subset_leq_card //; last first. + apply/subsetP=> _ /setIP[/imsetP[j _ ->] /imsetP[i _ []]]. + by case: ifP => _ <- ->; rewrite !inE ?Za21 ?(negPf nz_a11) !eqxx ?orbT. + apply/subsetP=> ij /setUP[] /imsetP[] => [j | i] _ {ij}->; rewrite inE. + by case: ifPn => // /eqP Za1j; rewrite (Da i1 j1) Za21 Za1j !add0r oppr_eq0. + by case: ifPn => // /eqP Zai1; rewrite (Da i1 j1) Za12 Zai1 !add0r oppr_eq0. +pose L i := [set ij | ij.1 == i] :&: A; pose C j := [set ij | ij.2 == j] :&: A. +have{ubA2} ubLC i j: (#|L i| + #|C j| != w2 + w1)%N. + apply: contraNneq ubA2 => <-; rewrite addnS leqW // -cardsUI -setIUl -setIIl. + rewrite -(card1 (i, j)) leq_add ?subset_leq_card ?subsetIr //. + by apply/subsetP=> ij /setIP[]; rewrite !inE. +have lbA L1 L2: L1 :&: L2 =i set0 -> (#|L1 :&: A| + #|L2 :&: A| <= #|A|)%N. + rewrite -cardsUI -setIUl -setIIl => /setP->. + by rewrite set0I cards0 addn0 subset_leq_card ?subsetIr. +have oL i1: ~~ [exists j, a i1 j == 0] -> #|L i1| = w2. + rewrite negb_exists => /forallP nz_a1. + transitivity #|predX (pred1 i1) (Iirr W2)|; last by rewrite cardX card1 mul1n. + by apply/eq_card=> ij; rewrite !inE andbT andb_idr // => /eqP->. +have oC i1 j1 j2 : a i1 j1 != 0 -> a i1 j2 == 0 -> #|C j1| = w1. + move=> nz_a11 /(Za i1)/contra/(_ nz_a11) nz_a1. + transitivity #|predX (Iirr W1) (pred1 j1)|; last by rewrite cardX card1 muln1. + by apply/eq_card=> ij; rewrite !inE andb_idr // => /eqP->. +(* This is step (3.8.2). *) +have [/existsP[j1 Za01] | /oL oL0] := boolP [exists j, a i0 j == 0]. + have j0'1 : j1 != j0 by apply: contraTneq Za01 => ->. + have oC0: #|C j0| = w1 by apply: oC nz_a0 Za01. + suffices Za0 i j: j != j0 -> a i j = 0. + left=> i j; rewrite -/(a i j) mulr_natl mulrb; have [->|/Za0//] := altP eqP. + by rewrite (Da i0 j1) !(Za0 _ j1) // subr0 add0r. + move=> j0'j; apply: contraNeq (ubLC i j0) => nz_aij; rewrite oC0 oL //. + apply: contra ubA => /existsP[_ /Za/contra/(_ nz_aij) nz_a_j]. + rewrite minn_mulr geq_min mul2n -addnn -{2}oC0 -(oC i0 j j1) ?lbA // => ij. + by rewrite !inE; apply/andP=> [[/eqP-> /idPn]]. +(* This is step (3.8.3). *) +suffices Za0 i j: i != i0 -> a i j = 0. + right=> i j; rewrite -/(a i j) mulr_natl mulrb; have [->|/Za0//] := altP eqP. + have /card_gt0P[i1 i0'i]: (0 < #|predC1 i0|)%N. + by rewrite cardC1 nirrW1 -(subnKC w1gt2). + by rewrite (Da i1 j0) !(Za0 i1) // subr0 addr0. +move=> i0'i; suffices /existsP[j1 Zai1]: [exists j, a i j == 0]. + by apply: contraNeq (ubLC i0 j) => /oC/(_ Zai1)->; rewrite oL0. +apply: contraR ubA; rewrite minn_mulr geq_min orbC mul2n -addnn => /oL{1}<-. +by rewrite -oL0 lbA // => ij; rewrite !inE; apply/andP=> [[/eqP-> /idPn]]. +Qed. + +(* A weaker version of PeterFalvi (3.8). *) +Lemma cycTI_NC_minn (phi : 'CF(G)) : + {in V, forall x, phi x = 0} -> (0 < NC phi < 2 * minn w1 w2)%N -> + (minn w1 w2 <= NC phi)%N. +Proof. +move=> phiV_0 /andP[/card_gt0P[[i0 j0]]]; rewrite inE /= => nz_a0 ubNC. +pose L := [seq (i0, j) | j : Iirr W2]; pose C := [seq (i, j0) | i : Iirr W1]. +have [oL oC]: #|L| = w2 /\ #|C| = w1 by rewrite !card_image // => i j []. +have [Da | Da] := small_cycTI_NC phiV_0 ubNC nz_a0. + rewrite geq_min -oC subset_leq_card //. + by apply/subsetP=> _ /codomP[i ->]; rewrite !inE /= Da eqxx mul1r. +rewrite geq_min orbC -oL subset_leq_card //. +by apply/subsetP=> _ /codomP[j ->]; rewrite !inE /= Da eqxx mul1r. +Qed. + +(* Another consequence of (3.8), used in (4.8), (10.5), (10.10) and (11.8). *) +Lemma eq_signed_sub_cTIiso phi e i j1 j2 : + let rho := (-1) ^+ e *: (eta_ i j1 - eta_ i j2) in + phi \in 'Z[irr G] -> '[phi] = 2%:R -> j1 != j2 -> + {in V, phi =1 rho} -> phi = rho. +Proof. +set rho := _ - _; move: phi => phi0 /= Zphi0 n2phi0 neq_j12 eq_phi_rho. +pose phi := (-1) ^+ e *: phi0; pose psi := phi - rho. +have{eq_phi_rho} psiV0 z: z \in V -> psi z = 0. + by move=> Vz; rewrite !cfunE eq_phi_rho // !cfunE signrMK subrr. +have{Zphi0} Zphi: phi \in 'Z[irr G] by rewrite rpredZsign. +have{n2phi0} n2phi: '[phi] = 2%:R by rewrite cfnorm_sign. +have Zrho: rho \in 'Z[irr G] by rewrite rpredB ?cycTIiso_vchar. +have n2rho: '[rho] = 2%:R. + by rewrite cfnormBd !cfdot_cycTIiso ?eqxx ?(negPf neq_j12) ?andbF. +have [oIphi _ Dphi] := dirr_small_norm Zphi n2phi isT. +have [oIrho _ Drho] := dirr_small_norm Zrho n2rho isT. +set Iphi := dirr_constt _ in oIphi Dphi. +set Irho := dirr_constt _ in oIrho Drho. +suffices /eqP eqIrho: Irho == Iphi by rewrite Drho eqIrho -Dphi signrZK. +have psi_phi'_lt0 di: di \in Irho :\: Iphi -> '[psi, dchi di] < 0. + case/setDP=> rho_di phi'di; rewrite cfdotBl subr_lt0. + move: rho_di; rewrite dirr_consttE; apply: ler_lt_trans. + rewrite real_lerNgt -?dirr_consttE ?real0 ?Creal_Cint //. + by rewrite Cint_cfdot_vchar ?dchi_vchar. +have NCpsi: (NC psi < 2 * minn w1 w2)%N. + suffices NCpsi4: (NC psi <= 2 + 2)%N. + by rewrite (leq_ltn_trans NCpsi4) // !addnn mul2n ltn_double leq_min w1gt2. + by rewrite cycTI_NC_sub // cycTI_NC_norm ?n2phi ?n2rho. +pose rhoId := dirr_dIirr (fun sk => (-1) ^+ (sk.1 : bool) *: eta_ i sk.2). +have rhoIdE s k: dchi (rhoId (s, k)) = (-1) ^+ s *: eta_ i k. + by apply: dirr_dIirrE => sk; rewrite rpredZsign cycTIiso_dirr. +rewrite eqEcard oIrho oIphi andbT -setD_eq0; apply/set0Pn=> [[dk1 phi'dk1]]. +have [[rho_dk1 _] psi_k1_lt0] := (setDP phi'dk1, psi_phi'_lt0 _ phi'dk1). +have dot_dk1: '[rho, dchi dk1] = 1. + rewrite Drho cfdot_suml (big_setD1 dk1) //= cfnorm_dchi big1 ?addr0 //. + move=> dk2 /setD1P[/negPf dk1'2 /dirr_constt_oppl]; rewrite cfdot_dchi dk1'2. + by case: eqP => [-> /negP[] | _ _]; rewrite ?subrr ?ndirrK. +have dot_dk2: 0 < '[rho, rho - dchi dk1]. + by rewrite cfdotBr dot_dk1 n2rho addrK ltr01. +have{dot_dk1 dot_dk2} [s [k Dk1 rho_k2]]: + exists s, exists2 k, rhoId (s, k.1) = dk1 & rhoId (~~ s, k.2) \in Irho. +- move/cfdot_add_dirr_eq1: dot_dk1. + rewrite dirr_dchi rpredN !cycTIiso_dirr //. + case=> // Dk1; [exists false, (j1, j2) | exists true, (j2, j1)]; + try apply: dirr_inj; rewrite ?dirr_consttE rhoIdE scaler_sign //=. + + by rewrite addrC Dk1 addKr in dot_dk2. + by rewrite Dk1 addrK in dot_dk2. +rewrite -Dk1 rhoIdE cfdotZr rmorph_sign in psi_k1_lt0. +have psi_k1_neq0: '[psi, eta_ i k.1] != 0. + by rewrite -(can_eq (signrMK s)) mulr0 ltr_eqF. +set dk2 := rhoId _ in rho_k2. +have NCk2'_le1 (dI : {set _}): + dk2 \in dI -> #|dI| = 2%N -> (NC (\sum_(dk in dI :\ dk2) dchi dk)%R <= 1)%N. +- rewrite (cardsD1 dk2) => -> /eqP/cards1P[dk ->]. + by rewrite big_set1 cycTI_NC_dirr ?dirr_dchi. +suffices /psi_phi'_lt0/ltr_geF/idP[]: dk2 \in Irho :\: Iphi. + rewrite rhoIdE cfdotZr signrN rmorphN mulNr oppr_ge0 rmorph_sign. + have := small_cycTI_NC psiV0 NCpsi psi_k1_neq0. + by case=> // ->; rewrite mulrCA nmulr_lle0 ?ler0n. +have: (1 + 1 < NC psi)%N. + apply (@leq_trans (minn w1 w2)); first by rewrite leq_min w1gt2. + apply: cycTI_NC_minn => //; rewrite NCpsi /NC. + by rewrite (cardsD1 (i, k.1)) inE /= psi_k1_neq0. +rewrite inE rho_k2 andbT ltnNge; apply: contra => phi_k2. +rewrite /psi Drho (big_setD1 dk2) //= Dphi (big_setD1 dk2) //=. +by rewrite addrAC opprD addNKr addrC cycTI_NC_sub ?NCk2'_le1. +Qed. + +(* This is PeterFalvi (3.9)(a). *) +Lemma eq_in_cycTIiso (i : Iirr W) (phi : 'CF(G)) : + phi \in dirr G -> {in V, phi =1 'chi_i} -> phi = sigma 'chi_i. +Proof. +move=> Dphi; rewrite -(inv_dprod_IirrK defW i). +case: (inv_dprod_Iirr _)=> /= i1 j1 EphiC. +pose psi : 'CF(G) := eta_ i1 j1 - phi. +have ZpsiV: {in V, forall g, psi g = 0}=> [g GiV|]. + by rewrite /psi !cfunE cycTIiso_restrict // -(EphiC _ GiV) subrr. +pose a i j := '[psi, eta_ i j]; pose S := [set ij | a ij.1 ij.2 != 0]. +case: (boolP ((i1, j1) \in S))=> [I1J1iS|]; last first. + rewrite inE negbK /a cfdotBl cfdot_cycTIiso !eqxx /=. + rewrite cfdot_dirr ?(irr_dirr, cycTIiso_dirr) //. + case: (boolP (phi == _))=> [|_]. + by rewrite opprK -(natrD _ 1 1) pnatr_eq0. + case: (boolP (phi == _))=> [/eqP //|]. + by rewrite subr0 oner_eq0. +have SPos : (0 < #|S|)%N by rewrite (cardD1 (i1,j1)) I1J1iS. +have SLt: (#|S| <= 2)%N. + by rewrite -[2]add1n cycTI_NC_sub // !cycTI_NC_dirr // cycTIiso_dirr. +have: (0 < #|S| < 2 * minn w1 w2)%N. + rewrite SPos; apply: leq_ltn_trans SLt _. + by rewrite -{1}[2%N]muln1 ltn_mul2l /= leq_min ![(1 < _)%N]ltnW. +move/(cycTI_NC_minn ZpsiV); rewrite leqNgt; case/negP. +by apply: leq_ltn_trans SLt _; rewrite leq_min w1gt2. +Qed. + +(* This is the second part of Peterfalvi (3.9)(a). *) +Lemma cfAut_cycTIiso u phi : cfAut u (sigma phi) = sigma (cfAut u phi). +Proof. +rewrite [phi]cfun_sum_cfdot !raddf_sum; apply: eq_bigr => ij _. +rewrite /= !(linearZ, cfAutZ) /= -aut_IirrE; congr (_ *: _) => {phi}. +apply: eq_in_cycTIiso => [|x Vx /=]. + by have /cycTIirrP[i [j ->]] := mem_irr ij; rewrite dirr_aut cycTIiso_dirr. +by rewrite cfunE cycTIiso_restrict // aut_IirrE cfunE. +Qed. + +Section AutCyclicTI. + +Variable iw : Iirr W. +Let w := 'chi_iw. +Let a := #[w]%CF. + +Let Zsigw : sigma w \in 'Z[irr G]. +Proof. by have [_ -> //] := cycTI_Zisometry; apply: irr_vchar. Qed. + +Let lin_w: w \is a linear_char := Wlin iw. + +(* This is Peterfalvi (3.9)(b). *) +Lemma cycTIiso_aut_exists k : + coprime k a -> + [/\ exists u, sigma (w ^+ k) = cfAut u (sigma w) + & forall x, coprime #[x] a -> sigma (w ^+ k) x = sigma w x]. +Proof. +case/(make_pi_cfAut G)=> u Du_a Du_a'. +suffices Dwk: sigma (w ^+ k) = cfAut u (sigma w). + by split=> [|x co_x_a]; [exists u | rewrite Dwk Du_a']. +rewrite cfAut_cycTIiso; congr (sigma _); apply/cfun_inP=> x Wx. +have Wxbar: coset _ x \in (W / cfker w)%G by rewrite mem_quotient. +rewrite exp_cfunE // cfunE -cfQuoEker //. +rewrite -lin_charX ?cfQuo_lin_char ?cfker_normal // -Du_a ?cfunE //. + by rewrite char_vchar ?cfQuo_char ?irr_char. +by rewrite [a]cforder_lin_char // dvdn_exponent. +Qed. + +(* This is Peterfalvi (3.9)(c). *) +Lemma Cint_cycTIiso_coprime x : coprime #[x] a -> sigma w x \in Cint. +Proof. +move=> co_x_a; apply: Cint_rat_Aint (Aint_vchar _ Zsigw). +have [Qb galQb [QbC AutQbC [w_b genQb memQb]]] := group_num_field_exists <[x]>. +have{memQb} [wx Dwx]: exists wx, sigma w x = QbC wx. + have /memQb Qbx := dvdnn #[x]. + have [sw1 /Qbx[wx1 Dwx1] [sw2 /Qbx[wx2 Dwx2] ->]] := vcharP _ Zsigw. + by exists (wx1 - wx2); rewrite rmorphB !cfunE Dwx1 Dwx2. +suffices: wx \in fixedField 'Gal({:Qb} / 1). + rewrite Dwx (galois_fixedField galQb) ?subvf // => /vlineP[z ->]. + by rewrite -in_algE fmorph_eq_rat fmorph_rat Crat_rat. +apply/fixedFieldP=> [|v_b _]; first exact: memvf. +have [v Dv] := AutQbC v_b; apply: (fmorph_inj QbC); rewrite Dv -Dwx. +have [u uQb uQb'] := dvd_restrict_cfAut (W / cfker w) #[x] v. +transitivity (sigma (cfAut u w) x); first by rewrite -cfAut_cycTIiso cfunE -uQb. +congr (sigma _ _); apply/cfun_inP=> y Wy; rewrite cfunE -cfQuoEker //. +rewrite uQb' ?char_vchar ?cfQuo_char ?irr_char // coprime_sym. +apply: coprime_dvdr co_x_a; rewrite [a]cforder_lin_char //. +by rewrite dvdn_exponent ?mem_quotient. +Qed. + +End AutCyclicTI. + +End Three. + +Implicit Arguments ortho_cycTIiso_vanish [gT G W W1 W2 defW psi]. + +Section ThreeSymmetry. + +Variables (gT : finGroupType) (G W W1 W2 : {group gT}). +Implicit Types (defW : W1 \x W2 = W) (xdefW : W2 \x W1 = W). +Local Notation sigma_ := (@cyclicTIiso gT G W _ _). +Local Notation w_ defW i j := (cyclicTIirr defW i j). + +Lemma cycTIisoC defW xdefW ctiW xctiW i j : + @sigma_ defW ctiW (w_ defW i j) = @sigma_ xdefW xctiW (w_ xdefW j i). +Proof. +apply: eq_in_cycTIiso; first exact: cycTIiso_dirr. +by rewrite /cyclicTIset setUC cyclicTIirrC; apply: cycTIiso_restrict. +Qed. + +Lemma cycTIiso_irrelC defW xdefW ctiW xctiW : + @sigma_ defW ctiW = @sigma_ xdefW xctiW. +Proof. +suffices: sigma_ ctiW =1 sigma_ xctiW by rewrite ![sigma_ _]unlock => /lfunP->. +move=> phi; have [z_ ->] := cfun_irr_sum phi; rewrite !linear_sum. +apply/eq_bigr=> ij _; have [i [j ->]] := cycTIirrP defW (mem_irr ij). +by rewrite !linearZ /= {1}cycTIisoC cyclicTIirrC. +Qed. + +Lemma cycTIiso_irrel defW defW' ctiW ctiW' : + @sigma_ defW ctiW = @sigma_ defW' ctiW'. +Proof. +have xdefW: W2 \x W1 = W by rewrite dprodC. +by rewrite !(cycTIiso_irrelC _ (cyclicTIhyp_sym ctiW xdefW)). +Qed. + +End ThreeSymmetry. diff --git a/mathcomp/odd_order/PFsection4.v b/mathcomp/odd_order/PFsection4.v new file mode 100644 index 0000000..816ac05 --- /dev/null +++ b/mathcomp/odd_order/PFsection4.v @@ -0,0 +1,987 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg poly finset fingroup. +Require Import morphism perm automorphism quotient action gfunctor gproduct. +Require Import center commutator zmodp cyclic pgroup nilpotent hall frobenius. +Require Import matrix mxalgebra mxrepresentation vector ssrnum algC classfun. +Require Import character inertia vcharacter PFsection1 PFsection2 PFsection3. + +(******************************************************************************) +(* This file covers Peterfalvi, Section 4: The Dade isometry of a certain *) +(* type of subgroup. *) +(* Given defW : W1 \x W2 = W, we define here: *) +(* primeTI_hypothesis L K defW <-> *) +(* L = K ><| W1, where W1 acts in a prime manner on K (see *) +(* semiprime in frobenius.v), and both W1 and W2 = 'C_K(W1) *) +(* are nontrivial and cyclic of odd order; these conditions *) +(* imply that cyclicTI_hypothesis L defW holds. *) +(* -> This is Peterfalvi, Hypothesis (4.2), or Feit-Thompson (13.2). *) +(* prime_Dade_definition L K H A A0 defW <-> *) +(* A0 = A :|: class_support (cyclicTIset defW) L where A is *) +(* an L-invariant subset of K^# containing all the elements *) +(* of K that do not act freely on H <| L; in addition *) +(* W2 \subset H \subset K. *) +(* prime_Dade_hypothesis G L K H A A0 defW <-> *) +(* The four assumptions primeTI_hypothesis L K defW, *) +(* cyclicTI_hypothesis G defW, Dade_hypothesis G L A0 and *) +(* prime_Dade_definition L K H A A0 defW hold jointly. *) +(* -> This is Peterfalvi, Hypothesis (4.6), or Feit-Thompson (13.3) (except *) +(* that H is not required to be nilpotent, and the "supporting groups" *) +(* assumptions have been replaced by Dade hypothesis). *) +(* -> This hypothesis is one of the alternatives under which Sibley's *) +(* coherence theorem holds (see PFsection6.v), and is verified by all *) +(* maximal subgroups of type P in a minimal simple odd group. *) +(* -> prime_Dade_hypothesis coerces to Dade_hypothesis, cyclicTI_hypothesis, *) +(* primeTI_hypothesis and prime_Dade_definition. *) +(* For ptiW : primeTI_hypothesis L K defW we also define: *) +(* prime_cycTIhyp ptiW :: cyclicTI_hypothesis L defW (though NOT a coercion) *) +(* primeTIirr ptiW i j == the (unique) irreducible constituent of the image *) +(* (locally) mu2_ i j in 'CF(L) of w_ i j = cyclicTIirr defW i j under *) +(* the sigma = cyclicTIiso (prime_cycTIhyp ptiW). *) +(* primeTI_Iirr ptiW ij == the index of mu2_ ij.1 ij.2; indeed mu2_ i j is *) +(* just notation for 'chi_(primeTI_Iirr ptiW (i, j)). *) +(* primeTIsign ptiW j == the sign of mu2_ i j in sigma (w_ i j), which does *) +(* (locally) delta_ j not depend on i. *) +(* primeTI_Isign ptiW j == the boolean b such that delta_ j := (-1) ^+ b. *) +(* primeTIres ptiW j == the restriction to K of mu2_ i j, which is an *) +(* (locally) chi_ j irreducible character that does not depend on i. *) +(* primeTI_Ires ptiW j == the index of chi_ j := 'chi_(primeTI_Ires ptiW j). *) +(* primeTIred ptiW j == the (reducible) character equal to the sum of all *) +(* (locally) mu_ j the mu2_ i j, and also to 'Ind (chi_ j). *) +(* uniform_prTIred_seq ptiW k == the sequence of all the mu_ j, j != 0, with *) +(* the same degree as mu_ k (s.t. mu_ j 1 = mu_ k 1). *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory Num.Theory. +Local Open Scope ring_scope. + +Section Four_1_to_2. + +(* This is Peterfalvi (4.1). *) + +Variable gT : finGroupType. + +Lemma vchar_pairs_orthonormal (X : {group gT}) (a b c d : 'CF(X)) u v : + {subset (a :: b) <= 'Z[irr X]} /\ {subset (c :: d) <= 'Z[irr X]} -> + orthonormal (a :: b) && orthonormal (c :: d) -> + [&& u \is Creal, v \is Creal, u != 0 & v != 0] -> + [&& '[a - b, u *: c - v *: d] == 0, + (a - b) 1%g == 0 & (u *: c - v *: d) 1%g == 0] -> + orthonormal [:: a; b; c; d]. +Proof. +have osym2 (e f : 'CF(X)) : orthonormal (e :: f) -> orthonormal (f :: e). + by rewrite !(orthonormal_cat [::_] [::_]) orthogonal_sym andbCA. +have def_o f S: orthonormal (f :: S) -> '[f : 'CF(X)] = 1. + by case/andP=> /andP[/eqP]. +case=> /allP/and3P[Za Zb _] /allP/and3P[Zc Zd _] /andP[o_ab o_cd]. +rewrite (orthonormal_cat (a :: b)) o_ab o_cd /=. +case/and4P=> r_u r_v nz_u nz_v /and3P[o_abcd ab1 cd1]. +wlog suff: a b c d u v Za Zb Zc Zd o_ab o_cd r_u r_v nz_u nz_v o_abcd ab1 cd1 / + '[a, c]_X == 0. +- move=> IH; rewrite /orthogonal /= !andbT (IH a b c d u v) //=. + have vc_sym (e f : 'CF(X)) : ((e - f) 1%g == 0) = ((f - e) 1%g == 0). + by rewrite -opprB cfunE oppr_eq0. + have ab_sym e: ('[b - a, e] == 0) = ('[a - b, e] == 0). + by rewrite -opprB cfdotNl oppr_eq0. + rewrite (IH b a c d u v) // 1?osym2 1?vc_sym ?ab_sym //=. + rewrite -oppr_eq0 -cfdotNr opprB in o_abcd. + by rewrite (IH a b d c v u) ?(IH b a d c v u) // 1?osym2 1?vc_sym ?ab_sym. +apply: contraLR cd1 => nz_ac. +have [/orthonormal2P[ab0 a1 b1] /orthonormal2P[cd0 c1 d1]] := (o_ab, o_cd). +have [ea [ia def_a]] := vchar_norm1P Za a1. +have{nz_ac} [e defc]: exists e : bool, c = (-1) ^+ e *: a. + have [ec [ic def_c]] := vchar_norm1P Zc c1; exists (ec (+) ea). + move: nz_ac; rewrite def_a def_c scalerA; rewrite -signr_addb addbK. + rewrite cfdotZl cfdotZr cfdot_irr mulrA mulrC mulf_eq0. + by have [-> // | _]:= ia =P ic; rewrite eqxx. +have def_vbd: v * '[b, d]_X = - ((-1) ^+ e * u). + apply/eqP; have:= o_abcd; rewrite cfdotDl cfdotNl !raddfB /=. + rewrite defc !cfdotZr a1 (cfdotC b) ab0 rmorph0 mulr1. + rewrite -[a]scale1r -{2}[1]/((-1) ^+ false) -(addbb e) signr_addb -scalerA. + rewrite -defc cfdotZl cd0 !mulr0 opprK addrA !subr0 mulrC addrC addr_eq0. + by rewrite rmorph_sign !conj_Creal. +have nz_bd: '[b, d] != 0. + move/esym/eqP: def_vbd; apply: contraTneq => ->. + by rewrite mulr0 oppr_eq0 mulf_eq0 signr_eq0. +have{nz_bd} defd: d = '[b, d] *: b. + move: nz_bd; have [eb [ib ->]] := vchar_norm1P Zb b1. + have [ed [id ->]] := vchar_norm1P Zd d1. + rewrite scalerA cfdotZl cfdotZr rmorph_sign mulrA cfdot_irr. + have [-> _ | _] := ib =P id; last by rewrite !mulr0 eqxx. + by rewrite mulr1 mulrAC -!signr_addb addbb. +rewrite defd scalerA def_vbd scaleNr opprK defc scalerA mulrC -raddfD cfunE. +rewrite !mulf_neq0 ?signr_eq0 // -(subrK a b) -opprB addrCA 2!cfunE. +rewrite (eqP ab1) oppr0 add0r cfunE -mulr2n -mulr_natl mulf_eq0 pnatr_eq0. +by rewrite /= def_a cfunE mulf_eq0 signr_eq0 /= irr1_neq0. +Qed. + +Corollary orthonormal_vchar_diff_ortho (X : {group gT}) (a b c d : 'CF(X)) : + {subset a :: b <= 'Z[irr X]} /\ {subset c :: d <= 'Z[irr X]} -> + orthonormal (a :: b) && orthonormal (c :: d) -> + [&& '[a - b, c - d] == 0, (a - b) 1%g == 0 & (c - d) 1%g == 0] -> + '[a, c] = 0. +Proof. +move=> Zabcd Oabcd; rewrite -[c - d]scale1r scalerBr. +move/(vchar_pairs_orthonormal Zabcd Oabcd) => /implyP. +rewrite rpred1 oner_eq0 (orthonormal_cat (a :: b)) /=. +by case/and3P=> _ _ /andP[] /andP[] /eqP. +Qed. + +(* This is Peterfalvi, Hypothesis (4.2), with explicit parameters. *) +Definition primeTI_hypothesis (L K W W1 W2 : {set gT}) of W1 \x W2 = W := + [/\ (*a*) [/\ K ><| W1 = L, W1 != 1, Hall L W1 & cyclic W1], + (*b*) [/\ W2 != 1, W2 \subset K & cyclic W2], + {in W1^#, forall x, 'C_K[x] = W2} + & (*c*) odd #|W|]%g. + +End Four_1_to_2. + +Arguments Scope primeTI_hypothesis + [_ group_scope group_scope group_scope _ group_scope group_scope]. + +Section Four_3_to_5. + +Variables (gT : finGroupType) (L K W W1 W2 : {group gT}) (defW : W1 \x W2 = W). +Hypothesis ptiWL : primeTI_hypothesis L K defW. + +Let V := cyclicTIset defW. +Let w1 := #|W1|. +Let w2 := #|W2|. + +Let defL : K ><| W1 = L. Proof. by have [[]] := ptiWL. Qed. +Let ntW1 : W1 :!=: 1%g. Proof. by have [[]] := ptiWL. Qed. +Let cycW1 : cyclic W1. Proof. by have [[]] := ptiWL. Qed. +Let hallW1 : Hall L W1. Proof. by have [[]] := ptiWL. Qed. + +Let ntW2 : W2 :!=: 1%g. Proof. by have [_ []] := ptiWL. Qed. +Let sW2K : W2 \subset K. Proof. by have [_ []] := ptiWL. Qed. +Let cycW2 : cyclic W2. Proof. by have [_ []] := ptiWL. Qed. +Let prKW1 : {in W1^#, forall x, 'C_K[x] = W2}. Proof. by have [] := ptiWL. Qed. + +Let oddW : odd #|W|. Proof. by have [] := ptiWL. Qed. + +Let nsKL : K <| L. Proof. by case/sdprod_context: defL. Qed. +Let sKL : K \subset L. Proof. by case/andP: nsKL. Qed. +Let sW1L : W1 \subset L. Proof. by case/sdprod_context: defL. Qed. +Let sWL : W \subset L. +Proof. by rewrite -(dprodWC defW) -(sdprodW defL) mulgSS. Qed. +Let sW1W : W1 \subset W. Proof. by have /mulG_sub[] := dprodW defW. Qed. +Let sW2W : W2 \subset W. Proof. by have /mulG_sub[] := dprodW defW. Qed. + +Let coKW1 : coprime #|K| #|W1|. +Proof. by rewrite (coprime_sdprod_Hall_r defL). Qed. +Let coW12 : coprime #|W1| #|W2|. +Proof. by rewrite coprime_sym (coprimeSg sW2K). Qed. + +Let cycW : cyclic W. Proof. by rewrite (cyclic_dprod defW). Qed. +Let cWW : abelian W. Proof. exact: cyclic_abelian. Qed. +Let oddW1 : odd w1. Proof. exact: oddSg oddW. Qed. +Let oddW2 : odd w2. Proof. exact: oddSg oddW. Qed. + +Let ntV : V != set0. +Proof. +by rewrite -card_gt0 card_cycTIset muln_gt0 -!subn1 !subn_gt0 !cardG_gt1 ntW1. +Qed. + +Let sV_V2 : V \subset W :\: W2. Proof. by rewrite setDS ?subsetUr. Qed. + +Lemma primeTIhyp_quotient (M : {group gT}) : + (W2 / M != 1)%g -> M \subset K -> M <| L -> + {defWbar : (W1 / M) \x (W2 / M) = W / M + & primeTI_hypothesis (L / M) (K / M) defWbar}%g. +Proof. +move=> ntW2bar sMK /andP[_ nML]. +have coMW1: coprime #|M| #|W1| by rewrite (coprimeSg sMK). +have [nMW1 nMW] := (subset_trans sW1L nML, subset_trans sWL nML). +have defWbar: (W1 / M) \x (W2 / M) = (W / M)%g. + by rewrite (quotient_coprime_dprod nMW) ?quotient_odd. +exists defWbar; split; rewrite ?quotient_odd ?quotient_cyclic ?quotientS //. + have isoW1: W1 \isog W1 / M by rewrite quotient_isog ?coprime_TIg. + by rewrite -(isog_eq1 isoW1) ?morphim_Hall // (quotient_coprime_sdprod nML). +move=> Kx /setD1P[ntKx /morphimP[x nKx W1x defKx]] /=. +rewrite -cent_cycle -cycle_eq1 {Kx}defKx -quotient_cycle // in ntKx *. +rewrite -strongest_coprime_quotient_cent ?cycle_subG //; first 1 last. +- by rewrite subIset ?sMK. +- by rewrite (coprimeSg (subsetIl M _)) // (coprimegS _ coMW1) ?cycle_subG. +- by rewrite orbC abelian_sol ?cycle_abelian. +rewrite cent_cycle prKW1 // !inE W1x (contraNneq _ ntKx) // => ->. +by rewrite cycle1 quotient1. +Qed. + +(* This is the first part of PeterFalvi, Theorem (4.3)(a). *) +Theorem normedTI_prTIset : normedTI (W :\: W2) L W. +Proof. +have [[_ _ cW12 _] [_ _ nKW1 tiKW1]] := (dprodP defW, sdprodP defL). +have nV2W: W \subset 'N(W :\: W2) by rewrite sub_abelian_norm ?subsetDl. +have piW1_W: {in W1 & W2, forall x y, (x * y).`_\pi(W1) = x}. + move=> x y W1x W2y /=; rewrite consttM /commute ?(centsP cW12 y) //. + rewrite constt_p_elt ?(mem_p_elt _ W1x) ?pgroup_pi // (constt1P _) ?mulg1 //. + by rewrite /p_elt -coprime_pi' // (coprimegS _ coW12) ?cycle_subG. +have nzV2W: W :\: W2 != set0 by apply: contraNneq ntV; rewrite -subset0 => <-. +apply/normedTI_memJ_P; split=> // xy g V2xy Lg. +apply/idP/idP=> [| /(subsetP nV2W)/memJ_norm->//]. +have{xy V2xy} [/(mem_dprod defW)[x [y [W1x W2y -> _]]] W2'xy] := setDP V2xy. +have{W2'xy} ntx: x != 1%g by have:= W2'xy; rewrite groupMr // => /group1_contra. +have{g Lg} [k [w [Kk /(subsetP sW1W)Ww -> _]]] := mem_sdprod defL Lg. +rewrite conjgM memJ_norm ?(subsetP nV2W) ?(groupMr k) // => /setDP[Wxyk _]. +have{Wxyk piW1_W} W1xk: x ^ k \in W1. + have [xk [yk [W1xk W2yk Dxyk _]]] := mem_dprod defW Wxyk. + by rewrite -(piW1_W x y) // -consttJ Dxyk piW1_W. +rewrite (subsetP sW2W) // -(@prKW1 x) ?in_setD1 ?ntx // inE Kk /=. +rewrite cent1C (sameP cent1P commgP) -in_set1 -set1gE -tiKW1 inE. +by rewrite (subsetP _ _ (mem_commg W1x Kk)) ?commg_subr // groupM ?groupV. +Qed. + +(* Second part of PeterFalvi, Theorem (4.3)(a). *) +Theorem prime_cycTIhyp : cyclicTI_hypothesis L defW. +Proof. +have nVW: W \subset 'N(V) by rewrite sub_abelian_norm ?subsetDl. +by split=> //; apply: normedTI_S normedTI_prTIset. +Qed. +Local Notation ctiW := prime_cycTIhyp. +Let sigma := cyclicTIiso ctiW. +Let w_ i j := cyclicTIirr defW i j. + +Let Wlin k : 'chi[W]_k \is a linear_char. Proof. exact/irr_cyclic_lin. Qed. +Let W1lin i : 'chi[W1]_i \is a linear_char. Proof. exact/irr_cyclic_lin. Qed. +Let W2lin i : 'chi[W2]_i \is a linear_char. Proof. exact/irr_cyclic_lin. Qed. +Let w_lin i j : w_ i j \is a linear_char. Proof. exact: Wlin. Qed. + +Let nirrW1 : #|Iirr W1| = w1. Proof. exact: card_Iirr_cyclic. Qed. +Let nirrW2 : #|Iirr W2| = w2. Proof. exact: card_Iirr_cyclic. Qed. +Let NirrW1 : Nirr W1 = w1. Proof. by rewrite -nirrW1 card_ord. Qed. +Let NirrW2 : Nirr W2 = w2. Proof. by rewrite -nirrW2 card_ord. Qed. +Let w1gt1 : (1 < w1)%N. Proof. by rewrite cardG_gt1. Qed. + +Let cfdot_w i1 j1 i2 j2 : '[w_ i1 j1, w_ i2 j2] = ((i1 == i2) && (j1 == j2))%:R. +Proof. exact: cfdot_dprod_irr. Qed. + +(* Witnesses for Theorem (4.3)(b). *) +Fact primeTIdIirr_key : unit. Proof. by []. Qed. +Definition primeTIdIirr_def := dirr_dIirr (sigma \o prod_curry w_). +Definition primeTIdIirr := locked_with primeTIdIirr_key primeTIdIirr_def. +Definition primeTI_Iirr ij := (primeTIdIirr ij).2. +Definition primeTI_Isign j := (primeTIdIirr (0, j)).1. +Local Notation Imu2 := primeTI_Iirr. +Local Notation mu2_ i j := 'chi_(primeTI_Iirr (i, j)). +Local Notation delta_ j := (GRing.sign algCring (primeTI_Isign j)). + +Let ew_ i j := w_ i j - w_ 0 j. +Let V2ew i j : ew_ i j \in 'CF(W, W :\: W2). +Proof. +apply/cfun_onP=> x; rewrite !inE negb_and negbK => /orP[W2x | /cfun0->//]. +by rewrite -[x]mul1g !cfunE /w_ !dprod_IirrE !cfDprodE ?lin_char1 ?subrr. +Qed. + +(* This is Peterfalvi, Theorem (4.3)(b, c). *) +Theorem primeTIirr_spec : + [/\ (*b*) injective Imu2, + forall i j, 'Ind (ew_ i j) = delta_ j *: (mu2_ i j - mu2_ 0 j), + forall i j, sigma (w_ i j) = delta_ j *: mu2_ i j, + (*c*) forall i j, {in W :\: W2, mu2_ i j =1 delta_ j *: w_ i j} + & forall k, k \notin codom Imu2 -> {in W :\: W2, 'chi_k =1 \0}]. +Proof. +have isoV2 := normedTI_isometry normedTI_prTIset (setDSS sWL (sub1G W2)). +have /fin_all_exists2[dmu injl_mu Ddmu] j: + exists2 dmu : bool * {ffun Iirr W1 -> Iirr L}, injective dmu.2 + & forall i, 'Ind (ew_ i j) = dchi (dmu.1, dmu.2 i) - dchi (dmu.1, dmu.2 0). +- pose Sj := [tuple w_ i j | i < Nirr W1]. + have Sj0: Sj`_0 = w_ 0 j by rewrite (nth_mktuple _ 0 0). + have irrSj: {subset Sj <= irr W} by move=> ? /mapP[i _ ->]; apply: mem_irr. + have: {in 'Z[Sj, W :\: W2], isometry 'Ind, to 'Z[irr L, L^#]}. + split=> [|phi]; first by apply: sub_in2 isoV2; apply: zchar_on. + move/(zchar_subset irrSj)/(zchar_onS (setDS W (sub1G W2))). + by rewrite !zcharD1E cfInd1 // mulf_eq0 orbC => /andP[/cfInd_vchar-> // ->]. + case/vchar_isometry_base=> // [|||i|mu Umu [d Ddmu]]; first by rewrite NirrW1. + + rewrite orthonormal_free // (sub_orthonormal irrSj) ?irr_orthonormal //. + by apply/injectiveP=> i1 i2 /irr_inj/dprod_Iirr_inj[]. + + by move=> _ /mapP[i _ ->]; rewrite Sj0 !lin_char1. + + by rewrite nth_mktuple Sj0 V2ew. + exists (d, [ffun i => tnth mu i]) => [|i]. + apply/injectiveP; congr (uniq _): Umu. + by rewrite (eq_map (ffunE _)) map_tnth_enum. + by rewrite -scalerBr /= !ffunE !(tnth_nth 0 mu) -Ddmu nth_mktuple Sj0. +pose Imu ij := (dmu ij.2).2 ij.1; pose mu i j := 'chi_(Imu (i, j)). +pose d j : algC := (-1) ^+ (dmu j).1. +have{Ddmu} Ddmu i j: 'Ind (ew_ i j) = d j *: (mu i j - mu 0 j). + by rewrite Ddmu scalerBr. +have{injl_mu} inj_Imu: injective Imu. + move=> [i1 j1] [i2 j2]; rewrite /Imu /=; pose S i j k := mu i j :: mu k j. + have [-> /injl_mu-> // | j2'1 /eqP/negPf[] /=] := eqVneq j1 j2. + apply/(can_inj oddb)/eqP; rewrite -eqC_nat -cfdot_irr -!/(mu _ _) mulr0n. + have oIew_j12 i k: '['Ind[L] (ew_ i j1), 'Ind[L] (ew_ k j2)] = 0. + by rewrite isoV2 // cfdotBl !cfdotBr !cfdot_w (negPf j2'1) !andbF !subr0. + have defSd i j k: mu i j - mu k j = d j *: ('Ind (ew_ i j) - 'Ind (ew_ k j)). + by rewrite !Ddmu -scalerBr signrZK opprB addrA subrK. + have Sd1 i j k: (mu i j - mu k j) 1%g == 0. + by rewrite defSd !(cfunE, cfInd1) ?lin_char1 // !subrr mulr0. + have exS i j: {k | {subset S i j k <= 'Z[irr L]} & orthonormal (S i j k)}. + have:= w1gt1; rewrite -nirrW1 (cardD1 i) => /card_gt0P/sigW[k /andP[i'k _]]. + exists k; first by apply/allP; rewrite /= !irr_vchar. + apply/andP; rewrite /= !cfdot_irr !eqxx !andbT /=. + by rewrite (inj_eq (injl_mu j)) mulrb ifN_eqC. + have [[k1 ZS1 o1S1] [k2 ZS2 o1S2]] := (exS i1 j1, exS i2 j2). + rewrite (orthonormal_vchar_diff_ortho (conj ZS1 ZS2)) ?o1S1 ?Sd1 ?andbT //. + by rewrite !defSd cfdotZl cfdotZr cfdotBl !cfdotBr !oIew_j12 !subrr !mulr0. +pose V2base := [tuple of [seq ew_ ij.1 ij.2 | ij in predX (predC1 0) predT]]. +have V2basis: basis_of 'CF(W, W :\: W2) V2base. + suffices V2free: free V2base. + rewrite basisEfree V2free size_image /= cardX cardC1 nirrW1 nirrW2 -subn1. + rewrite mulnBl mul1n dim_cfun_on_abelian ?subsetDl //. + rewrite cardsD (setIidPr _) // (dprod_card defW) leqnn andbT. + by apply/span_subvP=> _ /mapP[ij _ ->]. + apply/freeP=> /= z zV2e0 k. + move Dk: (enum_val k) (enum_valP k) => [i j] /andP[/= nz_i _]. + rewrite -(cfdot0l (w_ i j)) -{}zV2e0 cfdot_suml (bigD1 k) //= cfdotZl. + rewrite nth_image Dk cfdotBl !cfdot_w !eqxx eq_sym (negPf nz_i) subr0 mulr1. + rewrite big1 ?addr0 // => k1; rewrite -(inj_eq enum_val_inj) {}Dk nth_image. + case: (enum_val k1) => /= i1 j1 ij'ij1. + rewrite cfdotZl cfdotBl !cfdot_dprod_irr [_ && _](negPf ij'ij1). + by rewrite eq_sym (negPf nz_i) subr0 mulr0. +have nsV2W: W :\: W2 <| W by rewrite -sub_abelian_normal ?subsetDl. +pose muW k := let: ij := inv_dprod_Iirr defW k in d ij.2 *: mu ij.1 ij.2. +have inW := codomP (dprod_Iirr_onto defW _). +have ImuW k1 k2: '[muW k1, muW k2] = (k1 == k2)%:R. + have [[[i1 j1] -> {k1}] [[i2 j2] -> {k2}]] := (inW k1, inW k2). + rewrite cfdotZl cfdotZr !dprod_IirrK (can_eq (dprod_IirrK _)) /= rmorph_sign. + rewrite cfdot_irr (inj_eq inj_Imu (_, _) (_, _)) -/(d _). + by case: eqP => [[_ ->] | _]; rewrite ?signrMK ?mulr0. +have [k|muV2 mu'V2] := equiv_restrict_compl_ortho sWL nsV2W V2basis ImuW. + rewrite nth_image; case: (enum_val k) (enum_valP k) => /= i j /andP[/= nzi _]. + pose inWj i1 := dprod_Iirr defW (i1, j); rewrite (bigD1 (inWj 0)) //=. + rewrite (bigD1 (inWj i)) ?(can_eq (dprod_IirrK _)) ?xpair_eqE ?(negPf nzi) //. + rewrite /= big1 ?addr0 => [|k1 /andP[]]; last first. + rewrite !(eq_sym k1); have [[i1 j1] -> {k1}] := inW k1. + rewrite !(can_eq (dprod_IirrK _)) => ij1'i ij1'0. + by rewrite cfdotBl !cfdot_w !mulrb !ifN // subrr scale0r. + rewrite /muW !dprod_IirrK /= addrC !cfdotBl !cfdot_w !eqxx /= !andbT. + by rewrite eq_sym (negPf nzi) subr0 add0r scaleNr !scale1r -scalerBr. +have Dsigma i j: sigma (w_ i j) = d j *: mu i j. + apply/esym/eq_in_cycTIiso=> [|x Vx]; first exact: (dirr_dchi (_, _)). + by rewrite -muV2 ?(subsetP sV_V2) // /muW dprod_IirrK. +have /all_and2[Dd Dmu] j: d j = delta_ j /\ forall i, Imu (i, j) = Imu2 (i, j). + suffices DprTI i: primeTIdIirr (i, j) = ((dmu j).1, (dmu j).2 i). + by split=> [|i]; rewrite /primeTI_Isign /Imu2 DprTI. + apply: dirr_inj; rewrite /primeTIdIirr unlock_with dirr_dIirrE /= ?Dsigma //. + by case=> i1 j1; apply: cycTIiso_dirr. +split=> [[i1 j1] [i2 j2] | i j | i j | i j x V2x | k mu2p'k]. +- by rewrite -!Dmu => /inj_Imu. +- by rewrite -!Dmu -Dd -Ddmu. +- by rewrite -Dmu -Dd -Dsigma. +- by rewrite cfunE -muV2 // /muW dprod_IirrK Dd cfunE signrMK -Dmu. +apply: mu'V2 => k1; have [[i j] ->{k1}] := inW k1. +apply: contraNeq mu2p'k; rewrite cfdotZr rmorph_sign mulf_eq0 signr_eq0 /=. +rewrite /mu Dmu dprod_IirrK -irr_consttE constt_irr inE /= => /eqP <-. +exact: codom_f. +Qed. + +(* These lemmas restate the various parts of Theorem (4.3)(b, c) separately. *) +Lemma prTIirr_inj : injective Imu2. Proof. by case: primeTIirr_spec. Qed. + +Corollary cfdot_prTIirr i1 j1 i2 j2 : + '[mu2_ i1 j1, mu2_ i2 j2] = ((i1 == i2) && (j1 == j2))%:R. +Proof. by rewrite cfdot_irr (inj_eq prTIirr_inj). Qed. + +Lemma cfInd_sub_prTIirr i j : + 'Ind[L] (w_ i j - w_ 0 j) = delta_ j *: (mu2_ i j - mu2_ 0 j). +Proof. by case: primeTIirr_spec i j. Qed. + +Lemma cycTIiso_prTIirr i j : sigma (w_ i j) = delta_ j *: mu2_ i j. +Proof. by case: primeTIirr_spec. Qed. + +Lemma prTIirr_id i j : {in W :\: W2, mu2_ i j =1 delta_ j *: w_ i j}. +Proof. by case: primeTIirr_spec. Qed. + +Lemma not_prTIirr_vanish k : k \notin codom Imu2 -> {in W :\: W2, 'chi_k =1 \0}. +Proof. by case: primeTIirr_spec k. Qed. + +(* This is Peterfalvi, Theorem (4.3)(d). *) +Theorem prTIirr1_mod i j : (mu2_ i j 1%g == delta_ j %[mod w1])%C. +Proof. +rewrite -(cfRes1 W1) -['Res _](subrK ('Res (delta_ j *: w_ i j))) cfunE. +set phi := _ - _; pose a := '[phi, 1]. +have phi_on_1: phi \in 'CF(W1, 1%g). + apply/cfun_onP=> g; have [W1g | /cfun0-> //] := boolP (g \in W1). + rewrite -(coprime_TIg coW12) inE W1g !cfunE !cfResE //= => W2'g. + by rewrite prTIirr_id ?cfunE ?subrr // inE W2'g (subsetP sW1W). +have{phi_on_1} ->: phi 1%g = a * w1%:R. + rewrite mulrC /a (cfdotEl _ phi_on_1) mulVKf ?neq0CG //. + by rewrite big_set1 cfun11 conjC1 mulr1. +rewrite cfResE // cfunE lin_char1 // mulr1 eqCmod_addl_mul //. +by rewrite Cint_cfdot_vchar ?rpred1 ?rpredB ?cfRes_vchar ?rpredZsign ?irr_vchar. +Qed. + +Lemma prTIsign_aut u j : delta_ (aut_Iirr u j) = delta_ j. +Proof. +have /eqP := cfAut_cycTIiso ctiW u (w_ 0 j). +rewrite -cycTIirr_aut aut_Iirr0 -/sigma !cycTIiso_prTIirr raddfZsign /=. +by rewrite -aut_IirrE eq_scaled_irr => /andP[/eqP]. +Qed. + +Lemma prTIirr_aut u i j : + mu2_ (aut_Iirr u i) (aut_Iirr u j) = cfAut u (mu2_ i j). +Proof. +rewrite -!(canLR (signrZK _) (cycTIiso_prTIirr _ _)) -!/(delta_ _). +by rewrite prTIsign_aut raddfZsign /= cfAut_cycTIiso -cycTIirr_aut. +Qed. + +(* The (reducible) column sums of the prime TI irreducibles. *) +Definition primeTIred j : 'CF(L) := \sum_i mu2_ i j. +Local Notation mu_ := primeTIred. + +Definition uniform_prTIred_seq j0 := + image mu_ [pred j | j != 0 & mu_ j 1%g == mu_ j0 1%g]. + +Lemma prTIred_aut u j : mu_ (aut_Iirr u j) = cfAut u (mu_ j). +Proof. +rewrite raddf_sum [mu_ _](reindex_inj (aut_Iirr_inj u)). +by apply: eq_bigr => i _; rewrite /= prTIirr_aut. +Qed. + +Lemma cfdot_prTIirr_red i j k : '[mu2_ i j, mu_ k] = (j == k)%:R. +Proof. +rewrite cfdot_sumr (bigD1 i) // cfdot_prTIirr eqxx /=. +rewrite big1 ?addr0 // => i1 neq_i1i. +by rewrite cfdot_prTIirr eq_sym (negPf neq_i1i). +Qed. + +Lemma cfdot_prTIred j1 j2 : '[mu_ j1, mu_ j2] = ((j1 == j2) * w1)%:R. +Proof. +rewrite cfdot_suml (eq_bigr _ (fun i _ => cfdot_prTIirr_red i _ _)) sumr_const. +by rewrite mulrnA card_Iirr_cyclic. +Qed. + +Lemma cfnorm_prTIred j : '[mu_ j] = w1%:R. +Proof. by rewrite cfdot_prTIred eqxx mul1n. Qed. + +Lemma prTIred_neq0 j : mu_ j != 0. +Proof. by rewrite -cfnorm_eq0 cfnorm_prTIred neq0CG. Qed. + +Lemma prTIred_char j : mu_ j \is a character. +Proof. by apply: rpred_sum => i _; apply: irr_char. Qed. + +Lemma prTIred_1_gt0 j : 0 < mu_ j 1%g. +Proof. by rewrite char1_gt0 ?prTIred_neq0 ?prTIred_char. Qed. + +Lemma prTIred_1_neq0 i : mu_ i 1%g != 0. +Proof. by rewrite char1_eq0 ?prTIred_neq0 ?prTIred_char. Qed. + +Lemma prTIred_inj : injective mu_. +Proof. +move=> j1 j2 /(congr1 (cfdot (mu_ j1)))/esym/eqP; rewrite !cfdot_prTIred. +by rewrite eqC_nat eqn_pmul2r ?cardG_gt0 // eqxx; case: (j1 =P j2). +Qed. + +Lemma prTIred_not_real j : j != 0 -> ~~ cfReal (mu_ j). +Proof. +apply: contraNneq; rewrite -prTIred_aut -irr_eq1 -odd_eq_conj_irr1 //. +by rewrite -aut_IirrE => /prTIred_inj->. +Qed. + +Lemma prTIsign0 : delta_ 0 = 1. +Proof. +have /esym/eqP := cycTIiso_prTIirr 0 0; rewrite -[sigma _]scale1r. +by rewrite /w_ /sigma cycTIirr00 cycTIiso1 -irr0 eq_scaled_irr => /andP[/eqP]. +Qed. + +Lemma prTIirr00 : mu2_ 0 0 = 1. +Proof. +have:= cycTIiso_prTIirr 0 0; rewrite prTIsign0 scale1r. +by rewrite /w_ /sigma cycTIirr00 cycTIiso1. +Qed. + +(* This is PeterFalvi (4.4). *) +Lemma prTIirr0P k : + reflect (exists i, 'chi_k = mu2_ i 0) (K \subset cfker 'chi_k). +Proof. +suff{k}: [set k | K \subset cfker 'chi_k] == [set Imu2 (i, 0) | i : Iirr W1]. + move/eqP/setP/(_ k); rewrite inE => ->. + by apply: (iffP imsetP) => [[i _]|[i /irr_inj]] ->; exists i. +have [isoW1 abW1] := (sdprod_isog defL, cyclic_abelian cycW1). +have abLbar: abelian (L / K) by rewrite -(isog_abelian isoW1). +rewrite eqEcard andbC card_imset ?nirrW1 => [| i1 i2 /prTIirr_inj[] //]. +rewrite [w1](card_isog isoW1) -card_Iirr_abelian //. +rewrite -(card_image (can_inj (mod_IirrK nsKL))) subset_leq_card; last first. + by apply/subsetP=> _ /imageP[k1 _ ->]; rewrite inE mod_IirrE ?cfker_mod. +apply/subsetP=> k; rewrite inE => kerKk. +have /irrP[ij DkW]: 'Res 'chi_k \in irr W. + rewrite lin_char_irr ?cfRes_lin_char // lin_irr_der1. + by apply: subset_trans kerKk; rewrite der1_min ?normal_norm. +have{ij DkW} [i DkW]: exists i, 'Res 'chi_k = w_ i 0. + have /codomP[[i j] Dij] := dprod_Iirr_onto defW ij; exists i. + rewrite DkW Dij; congr (w_ i _); apply/eqP; rewrite -subGcfker. + rewrite -['chi_j](cfDprodKr_abelian defW i) // -dprod_IirrE -{}Dij -{}DkW. + by rewrite cfResRes // sub_cfker_Res // (subset_trans sW2K kerKk). +apply/imsetP; exists i => //=; apply/irr_inj. +suffices ->: 'chi_k = delta_ 0 *: mu2_ i 0 by rewrite prTIsign0 scale1r. +rewrite -cycTIiso_prTIirr -(eq_in_cycTIiso _ (irr_dirr k)) // => x /setDP[Wx _]. +by rewrite -/(w_ i 0) -DkW cfResE. +Qed. + +(* This is the first part of PeterFalvi, Theorem (4.5)(a). *) +Theorem cfRes_prTIirr_eq0 i j : 'Res[K] (mu2_ i j) = 'Res (mu2_ 0 j). +Proof. +apply/eqP; rewrite -subr_eq0 -rmorphB /=; apply/eqP/cfun_inP=> x0 Kx0. +rewrite -(canLR (signrZK _) (cfInd_sub_prTIirr i j)) -/(delta_ j). +rewrite cfResE // !cfunE (cfun_on0 (cfInd_on _ (V2ew i j))) ?mulr0 //. +apply: contraL Kx0 => /imset2P[x y /setDP[Wx W2'x] Ly ->] {x0}. +rewrite memJ_norm ?(subsetP (normal_norm nsKL)) //; apply: contra W2'x => Kx. +by rewrite -(mul1g W2) -(coprime_TIg coKW1) group_modr // inE Kx (dprodW defW). +Qed. + +Lemma prTIirr_1 i j : mu2_ i j 1%g = mu2_ 0 j 1%g. +Proof. by rewrite -!(@cfRes1 _ K L) cfRes_prTIirr_eq0. Qed. + +Lemma prTIirr0_1 i : mu2_ i 0 1%g = 1. +Proof. by rewrite prTIirr_1 prTIirr00 cfun11. Qed. + +Lemma prTIirr0_linear i : mu2_ i 0 \is a linear_char. +Proof. by rewrite qualifE irr_char /= prTIirr0_1. Qed. + +Lemma prTIred_1 j : mu_ j 1%g = w1%:R * mu2_ 0 j 1%g. +Proof. +rewrite mulr_natl -nirrW1 sum_cfunE. +by rewrite -sumr_const; apply: eq_bigr => i _; rewrite prTIirr_1. +Qed. + +Definition primeTI_Ires j : Iirr K := cfIirr ('Res[K] (mu2_ 0 j)). +Local Notation Ichi := primeTI_Ires. +Local Notation chi_ j := 'chi_(Ichi j). + +(* This is the rest of PeterFalvi, Theorem (4.5)(a). *) +Theorem prTIres_spec j : chi_ j = 'Res (mu2_ 0 j) /\ mu_ j = 'Ind (chi_ j). +Proof. +rewrite /Ichi; set chi_j := 'Res _. +have [k chi_j_k]: {k | k \in irr_constt chi_j} := constt_cfRes_irr K _. +have Nchi_j: chi_j \is a character by rewrite cfRes_char ?irr_char. +have lb_mu_1: w1%:R * 'chi_k 1%g <= mu_ j 1%g ?= iff (chi_j == 'chi_k). + have [chi' Nchi' Dchi_j] := constt_charP _ Nchi_j chi_j_k. + rewrite prTIred_1 (mono_lerif (ler_pmul2l (gt0CG W1))). + rewrite -subr_eq0 Dchi_j addrC addKr -(canLR (addrK _) Dchi_j) !cfunE. + rewrite lerif_subLR addrC -lerif_subLR cfRes1 subrr -char1_eq0 // eq_sym. + by apply: lerif_eq; rewrite char1_ge0. +pose psi := 'Ind 'chi_k - mu_ j; have Npsi: psi \is a character. + apply/forallP=> l; rewrite coord_cfdot cfdotBl; set a := '['Ind _, _]. + have Na: a \in Cnat by rewrite Cnat_cfdot_char_irr ?cfInd_char ?irr_char. + have [[i /eqP Dl] | ] := altP (@existsP _ (fun i => 'chi_l == mu2_ i j)). + have [n Da] := CnatP a Na; rewrite Da cfdotC Dl cfdot_prTIirr_red. + rewrite rmorph_nat -natrB ?Cnat_nat // eqxx lt0n -eqC_nat -Da. + by rewrite -irr_consttE constt_Ind_Res Dl cfRes_prTIirr_eq0. + rewrite negb_exists => /forallP muj'l. + rewrite cfdot_suml big1 ?subr0 // => i _. + rewrite cfdot_irr -(inj_eq irr_inj) mulrb ifN_eqC ?muj'l //. +have ub_mu_1: mu_ j 1%g <= 'Ind[L] 'chi_k 1%g ?= iff ('Ind 'chi_k == mu_ j). + rewrite -subr_eq0 -/psi (canRL (subrK _) (erefl psi)) cfunE -lerif_subLR. + by rewrite subrr -char1_eq0 // eq_sym; apply: lerif_eq; rewrite char1_ge0. +have [_ /esym] := lerif_trans lb_mu_1 ub_mu_1; rewrite cfInd1 //. +by rewrite -(index_sdprod defL) eqxx => /andP[/eqP-> /eqP <-]; rewrite irrK. +Qed. + +Lemma cfRes_prTIirr i j : 'Res[K] (mu2_ i j) = chi_ j. +Proof. by rewrite cfRes_prTIirr_eq0; case: (prTIres_spec j). Qed. + +Lemma cfInd_prTIres j : 'Ind[L] (chi_ j) = mu_ j. +Proof. by have [] := prTIres_spec j. Qed. + +Lemma cfRes_prTIred j : 'Res[K] (mu_ j) = w1%:R *: chi_ j. +Proof. +rewrite -nirrW1 scaler_nat -sumr_const linear_sum /=; apply: eq_bigr => i _. +exact: cfRes_prTIirr. +Qed. + +Lemma prTIres_aut u j : chi_ (aut_Iirr u j) = cfAut u (chi_ j). +Proof. +by rewrite -(cfRes_prTIirr (aut_Iirr u 0)) prTIirr_aut -cfAutRes cfRes_prTIirr. +Qed. + +Lemma prTIres0 : chi_ 0 = 1. +Proof. by rewrite -(cfRes_prTIirr 0) prTIirr00 cfRes_cfun1. Qed. + +Lemma prTIred0 : mu_ 0 = w1%:R *: '1_K. +Proof. +by rewrite -cfInd_prTIres prTIres0 cfInd_cfun1 // -(index_sdprod defL). +Qed. + +Lemma prTIres_inj : injective Ichi. +Proof. by move=> j1 j2 Dj; apply: prTIred_inj; rewrite -!cfInd_prTIres Dj. Qed. + +(* This is the first assertion of Peterfalvi (4.5)(b). *) +Theorem prTIres_irr_cases k (theta := 'chi_k) (phi := 'Ind theta) : + {j | theta = chi_ j} + {phi \in irr L /\ (forall i j, phi != mu2_ i j)}. +Proof. +pose imIchi := [set Ichi j | j : Iirr W2]. +have [/imsetP/sig2_eqW[j _] | imIchi'k] := boolP (k \in imIchi). + by rewrite /theta => ->; left; exists j. +suffices{phi} theta_inv: 'I_L[theta] = K. + have irr_phi: phi \in irr L by apply: inertia_Ind_irr; rewrite ?theta_inv. + right; split=> // i j; apply: contraNneq imIchi'k => Dphi; apply/imsetP. + exists j => //; apply/eqP; rewrite -[k == _]constt_irr -(cfRes_prTIirr i). + by rewrite -constt_Ind_Res -/phi Dphi irr_consttE cfnorm_irr oner_eq0. +rewrite -(sdprodW (sdprod_modl defL (sub_inertia _))); apply/mulGidPl. +apply/subsetP=> z /setIP[W1z Itheta_z]; apply: contraR imIchi'k => K'z. +have{K'z} [Lz ntz] := (subsetP sW1L z W1z, group1_contra K'z : z != 1%g). +have [p p_pr p_z]: {p | prime p & p %| #[z]} by apply/pdivP; rewrite order_gt1. +have coKp := coprime_dvdr (dvdn_trans p_z (order_dvdG W1z)) coKW1. +wlog{p_z} p_z: z W1z Lz Itheta_z ntz / p.-elt z. + move/(_ z.`_p)->; rewrite ?groupX ?p_elt_constt //. + by rewrite (sameP eqP constt1P) /p_elt p'natE ?negbK. +have JirrP: is_action L (@conjg_Iirr gT K); last pose Jirr := Action JirrP. + split=> [y k1 k2 eq_k12 | k1 y1 y2 Gy1 Gy2]; apply/irr_inj. + by apply/(can_inj (cfConjgK y)); rewrite -!conjg_IirrE eq_k12. + by rewrite !conjg_IirrE (cfConjgM _ nsKL). +have [[_ nKL] [nKz _]] := (andP nsKL, setIdP Itheta_z). +suffices{k theta Itheta_z} /eqP->: imIchi == 'Fix_Jirr[z]. + by apply/afix1P/irr_inj; rewrite conjg_IirrE inertiaJ. +rewrite eqEcard; apply/andP; split. + apply/subsetP=> _ /imsetP[j _ ->]; apply/afix1P/irr_inj. + by rewrite conjg_IirrE -(cfRes_prTIirr 0) (cfConjgRes _ _ nsKL) ?cfConjg_id. +have ->: #|imIchi| = w2 by rewrite card_imset //; apply: prTIres_inj. +have actsL_KK: [acts L, on classes K | 'Js \ subsetT L]. + rewrite astabs_ract subsetIidl; apply/subsetP=> y Ly; rewrite !inE /=. + apply/subsetP=> _ /imsetP[x Kx ->]; rewrite !inE /= -class_rcoset. + by rewrite norm_rlcoset ?class_lcoset ?mem_classes ?memJ_norm ?(subsetP nKL). +rewrite (card_afix_irr_classes Lz actsL_KK) => [|k x y Kx /=]; last first. + by case/imsetP=> _ /imsetP[t Kt ->] ->; rewrite conjg_IirrE cfConjgEJ ?cfunJ. +apply: leq_trans (subset_leq_card _) (leq_imset_card (class^~ K) _). +apply/subsetP=> _ /setIP[/imsetP[x Kx ->] /afix1P/normP nxKz]. +suffices{Kx} /pred0Pn[t /setIP[xKt czt]]: #|'C_(x ^: K)[z]| != 0%N. + rewrite -(class_transr xKt); apply: mem_imset; have [y Ky Dt] := imsetP xKt. + by rewrite -(@prKW1 z) ?(czt, inE) ?ntz // Dt groupJ. +have{coKp}: ~~ (p %| #|K|) by rewrite -prime_coprime // coprime_sym. +apply: contraNneq => /(congr1 (modn^~ p))/eqP; rewrite mod0n. +rewrite -cent_cycle -afixJ -sylow.pgroup_fix_mod ?astabsJ ?cycle_subG //. +by move/dvdn_trans; apply; rewrite -index_cent1 dvdn_indexg. +Qed. + +(* Implicit elementary converse to the above. *) +Lemma prTIred_not_irr j : mu_ j \notin irr L. +Proof. by rewrite irrEchar cfnorm_prTIred pnatr_eq1 gtn_eqF ?andbF. Qed. + +(* This is the second assertion of Peterfalvi (4.5)(b). *) +Theorem prTIind_irr_cases ell (phi := 'chi_ell) : + {i : _ & {j | phi = mu2_ i j}} + + {k | k \notin codom Ichi & phi = 'Ind 'chi_k}. +Proof. +have [k] := constt_cfRes_irr K ell; rewrite -constt_Ind_Res => kLell. +have [[j Dk] | [/irrP/sig_eqW[l1 DkL] chi'k]] := prTIres_irr_cases k. + have [i /=/eqP <- | mu2j'l] := pickP (fun i => mu2_ i j == phi). + by left; exists i, j. + case/eqP: kLell; rewrite Dk cfInd_prTIres cfdot_suml big1 // => i _. + by rewrite cfdot_irr -(inj_eq irr_inj) mu2j'l. +right; exists k; last by move: kLell; rewrite DkL constt_irr inE => /eqP <-. +apply/codomP=> [[j Dk]]; have/negP[] := prTIred_not_irr j. +by rewrite -cfInd_prTIres -Dk DkL mem_irr. +Qed. + +End Four_3_to_5. + +Notation primeTIsign ptiW j := + (GRing.sign algCring (primeTI_Isign ptiW j)) (only parsing). +Notation primeTIirr ptiW i j := 'chi_(primeTI_Iirr ptiW (i, j)) (only parsing). +Notation primeTIres ptiW j := 'chi_(primeTI_Ires ptiW j) (only parsing). + +Implicit Arguments prTIirr_inj [gT L K W W1 W2 defW x1 x2]. +Implicit Arguments prTIred_inj [gT L K W W1 W2 defW x1 x2]. +Implicit Arguments prTIres_inj [gT L K W W1 W2 defW x1 x2]. +Implicit Arguments not_prTIirr_vanish [gT L K W W1 W2 defW k]. + +Section Four_6_t0_10. + +Variables (gT : finGroupType) (G L K H : {group gT}) (A A0 : {set gT}). +Variables (W W1 W2 : {group gT}) (defW : W1 \x W2 = W). + +Local Notation V := (cyclicTIset defW). + +(* These correspond to Peterfalvi, Hypothesis (4.6). *) +Definition prime_Dade_definition := + [/\ (*c*) [/\ H <| L, W2 \subset H & H \subset K], + (*d*) [/\ A <| L, \bigcup_(h in H^#) 'C_K[h]^# \subset A & A \subset K^#] + & (*e*) A0 = A :|: class_support V L]. + +Record prime_Dade_hypothesis : Prop := PrimeDadeHypothesis { + prDade_cycTI :> cyclicTI_hypothesis G defW; + prDade_prTI :> primeTI_hypothesis L K defW; + prDade_hyp :> Dade_hypothesis G L A0; + prDade_def :> prime_Dade_definition +}. + +Hypothesis prDadeHyp : prime_Dade_hypothesis. + +Let ctiWG : cyclicTI_hypothesis G defW := prDadeHyp. +Let ptiWL : primeTI_hypothesis L K defW := prDadeHyp. +Let ctiWL : cyclicTI_hypothesis L defW := prime_cycTIhyp ptiWL. +Let ddA0 : Dade_hypothesis G L A0 := prDadeHyp. +Local Notation ddA0def := (prDade_def prDadeHyp). + +Local Notation w_ i j := (cyclicTIirr defW i j). +Local Notation sigma := (cyclicTIiso ctiWG). +Local Notation eta_ i j := (sigma (w_ i j)). +Local Notation mu2_ i j := (primeTIirr ptiWL i j). +Local Notation delta_ j := (primeTIsign ptiWL j). +Local Notation chi_ j := (primeTIres ptiWL j). +Local Notation mu_ := (primeTIred ptiWL). +Local Notation tau := (Dade ddA0). + +Let defA0 : A0 = A :|: class_support V L. Proof. by have [] := ddA0def. Qed. +Let nsAL : A <| L. Proof. by have [_ []] := ddA0def. Qed. +Let sAA0 : A \subset A0. Proof. by rewrite defA0 subsetUl. Qed. + +Let nsHL : H <| L. Proof. by have [[]] := ddA0def. Qed. +Let sHK : H \subset K. Proof. by have [[]] := ddA0def. Qed. +Let defL : K ><| W1 = L. Proof. by have [[]] := ptiWL. Qed. +Let sKL : K \subset L. Proof. by have /mulG_sub[] := sdprodW defL. Qed. +Let coKW1 : coprime #|K| #|W1|. +Proof. by rewrite (coprime_sdprod_Hall_r defL); have [[]] := ptiWL. Qed. + +Let sIH_A : \bigcup_(h in H^#) 'C_K[h]^# \subset A. +Proof. by have [_ []] := ddA0def. Qed. + +Let sW2H : W2 \subset H. Proof. by have [[]] := ddA0def. Qed. +Let ntW1 : W1 :!=: 1%g. Proof. by have [[]] := ptiWL. Qed. +Let ntW2 : W2 :!=: 1%g. Proof. by have [_ []] := ptiWL. Qed. + +Let oddW : odd #|W|. Proof. by have [] := ctiWL. Qed. +Let sW1W : W1 \subset W. Proof. by have /mulG_sub[] := dprodW defW. Qed. +Let sW2W : W2 \subset W. Proof. by have /mulG_sub[] := dprodW defW. Qed. +Let tiW12 : W1 :&: W2 = 1%g. Proof. by have [] := dprodP defW. Qed. + +Let cycW : cyclic W. Proof. by have [] := ctiWG. Qed. +Let cycW1 : cyclic W1. Proof. by have [[]] := ptiWL. Qed. +Let cycW2 : cyclic W2. Proof. by have [_ []] := ptiWL. Qed. +Let sLG : L \subset G. Proof. by case: ddA0. Qed. +Let sW2K : W2 \subset K. Proof. by have [_ []] := ptiWL. Qed. + +Let sWL : W \subset L. +Proof. by rewrite -(dprodWC defW) -(sdprodW defL) mulgSS. Qed. +Let sWG : W \subset G. Proof. exact: subset_trans sWL sLG. Qed. + +Let oddW1 : odd #|W1|. Proof. exact: oddSg oddW. Qed. +Let oddW2 : odd #|W2|. Proof. exact: oddSg oddW. Qed. + +Let w1gt1 : (2 < #|W1|)%N. Proof. by rewrite odd_gt2 ?cardG_gt1. Qed. +Let w2gt2 : (2 < #|W2|)%N. Proof. by rewrite odd_gt2 ?cardG_gt1. Qed. + +Let nirrW1 : #|Iirr W1| = #|W1|. Proof. exact: card_Iirr_cyclic. Qed. +Let nirrW2 : #|Iirr W2| = #|W2|. Proof. exact: card_Iirr_cyclic. Qed. +Let W1lin i : 'chi[W1]_i \is a linear_char. Proof. exact/irr_cyclic_lin. Qed. +Let W2lin i : 'chi[W2]_i \is a linear_char. Proof. exact/irr_cyclic_lin. Qed. + +(* This is the first part of Peterfalvi (4.7). *) +Lemma prDade_irr_on k : + ~~ (H \subset cfker 'chi[K]_k) -> 'chi_k \in 'CF(K, 1%g |: A). +Proof. +move=> kerH'i; apply/cfun_onP=> g; rewrite !inE => /norP[ntg A'g]. +have [Kg | /cfun0-> //] := boolP (g \in K). +apply: not_in_ker_char0 (normalS _ _ nsHL) kerH'i _ => //. +apply/trivgP/subsetP=> h /setIP[Hh cgh]; apply: contraR A'g => nth. +apply/(subsetP sIH_A)/bigcupP; exists h; first exact/setDP. +by rewrite 3!inE ntg Kg cent1C. +Qed. + +(* This is the second part of Peterfalvi (4.7). *) +Lemma prDade_Ind_irr_on k : + ~~ (H \subset cfker 'chi[K]_k) -> 'Ind[L] 'chi_k \in 'CF(L, 1%g |: A). +Proof. +move/prDade_irr_on/(cfInd_on sKL); apply: cfun_onS; rewrite class_supportEr. +by apply/bigcupsP=> _ /normsP-> //; rewrite normsU ?norms1 ?normal_norm. +Qed. + +(* Third part of Peterfalvi (4.7). *) +Lemma cfker_prTIres j : j != 0 -> ~~ (H \subset cfker (chi_ j)). +Proof. +rewrite -(cfRes_prTIirr _ 0) cfker_Res ?irr_char // subsetI sHK /=. +apply: contra => kerHmu0j; rewrite -irr_eq1; apply/eqP/cfun_inP=> y W2y. +have [[x W1x ntx] mulW] := (trivgPn _ ntW1, dprodW defW). +rewrite cfun1E W2y -(cfDprodEr defW _ W1x W2y) -dprodr_IirrE -dprod_Iirr0l. +have{ntx} W2'x: x \notin W2 by rewrite -[x \in W2]andTb -W1x -in_setI tiW12 inE. +have V2xy: (x * y)%g \in W :\: W2 by rewrite inE -mulW mem_mulg ?groupMr ?W2'x. +rewrite -[w_ 0 j](signrZK (primeTI_Isign ptiWL j)) cfunE -prTIirr_id //. +have V2x: x \in W :\: W2 by rewrite inE W2'x (subsetP sW1W). +rewrite cfkerMr ?(subsetP (subset_trans sW2H kerHmu0j)) ?prTIirr_id // cfunE. +by rewrite signrMK -[x]mulg1 dprod_Iirr0l dprodr_IirrE cfDprodEr ?lin_char1. +Qed. + +(* Fourth part of Peterfalvi (4.7). *) +Lemma prDade_TIres_on j : j != 0 -> chi_ j \in 'CF(K, 1%g |: A). +Proof. by move/cfker_prTIres/prDade_irr_on. Qed. + +(* Last part of Peterfalvi (4.7). *) +Lemma prDade_TIred_on j : j != 0 -> mu_ j \in 'CF(L, 1%g |: A). +Proof. by move/cfker_prTIres/prDade_Ind_irr_on; rewrite cfInd_prTIres. Qed. + +Import ssrint. + +(* Second part of PeterFalvi (4.8). *) +Lemma prDade_TIsign_eq i j k : + mu2_ i j 1%g = mu2_ i k 1%g -> delta_ j = delta_ k. +Proof. +move=> eqjk; have{eqjk}: (delta_ j == delta_ k %[mod #|W1|])%C. + apply: eqCmod_trans (prTIirr1_mod ptiWL i k). + by rewrite eqCmod_sym -eqjk (prTIirr1_mod ptiWL). +have /negP: ~~ (#|W1| %| 2) by rewrite gtnNdvd. +rewrite /eqCmod -![delta_ _]intr_sign -rmorphB dvdC_int ?Cint_int //= intCK. +by do 2!case: (primeTI_Isign _ _). +Qed. + +(* First part of PeterFalvi (4.8). *) +Lemma prDade_sub_TIirr_on i j k : + j != 0 -> k != 0 -> mu2_ i j 1%g = mu2_ i k 1%g -> + mu2_ i j - mu2_ i k \in 'CF(L, A0). +Proof. +move=> nzj nzk eq_mu1. +apply/cfun_onP=> g; rewrite defA0 !inE negb_or !cfunE => /andP[A'g V'g]. +have [Lg | L'g] := boolP (g \in L); last by rewrite !cfun0 ?subrr. +have{Lg} /bigcupP[_ /rcosetsP[x W1x ->] Kx_g]: g \in cover (rcosets K W1). + by rewrite (cover_partition (rcosets_partition_mul W1 K)) (sdprodW defL). +have [x1 | ntx] := eqVneq x 1%g. + have [-> | ntg] := eqVneq g 1%g; first by rewrite eq_mu1 subrr. + have{A'g} A1'g: g \notin 1%g |: A by rewrite !inE negb_or ntg. + rewrite x1 mulg1 in Kx_g; rewrite -!(cfResE (mu2_ i _) sKL) ?cfRes_prTIirr //. + by rewrite !(cfun_onP (prDade_TIres_on _)) ?subrr. +have coKx: coprime #|K| #[x] by rewrite (coprime_dvdr (order_dvdG W1x)). +have nKx: x \in 'N(K) by have [_ _ /subsetP->] := sdprodP defL. +have [/cover_partition defKx _] := partition_cent_rcoset nKx coKx. +have def_cKx: 'C_K[x] = W2 by have [_ _ -> //] := ptiWL; rewrite !inE ntx. +move: Kx_g; rewrite -defKx def_cKx cover_imset => /bigcupP[z /(subsetP sKL)Lz]. +case/imsetP=> _ /rcosetP[y W2y ->] Dg; rewrite Dg !cfunJ //. +have V2yx: (y * x)%g \in W :\: W2. + rewrite inE -(dprodWC defW) mem_mulg // andbT groupMl //. + by rewrite -[x \in W2]andTb -W1x -in_setI tiW12 inE. +rewrite 2?{1}prTIirr_id //. +have /set1P->: y \in [1]. + rewrite -tiW12 inE W2y andbT; apply: contraR V'g => W1'y. + by rewrite Dg mem_imset2 // !inE negb_or -andbA -in_setD groupMr ?W1'y. +rewrite -commute1 (prDade_TIsign_eq eq_mu1) !cfunE -mulrBr. +by rewrite !dprod_IirrE !cfDprodE // !lin_char1 // subrr mulr0. +Qed. + +(* This is last part of PeterFalvi (4.8). *) +Lemma prDade_sub_TIirr i j k : + j != 0 -> k != 0 -> mu2_ i j 1%g = mu2_ i k 1%g -> + tau (mu2_ i j - mu2_ i k) = delta_ j *: (eta_ i j - eta_ i k). +Proof. +move=> nz_j nz_k eq_mu2jk_1. +have [-> | k'j] := eqVneq j k; first by rewrite !subrr !raddf0. +have [[Itau Ztau] [_ Zsigma]] := (Dade_Zisometry ddA0, cycTI_Zisometry ctiWL). +set dmu2 := _ - _; set dsw := _ - _; have Dmu2 := prTIirr_id ptiWL. +have Zmu2: dmu2 \in 'Z[irr L, A0]. + by rewrite zchar_split rpredB ?irr_vchar ?prDade_sub_TIirr_on. +apply: eq_signed_sub_cTIiso => // [||x Vx]. +- exact: zcharW (Ztau _ Zmu2). +- rewrite Itau // cfnormBd ?cfnorm_irr // (cfdot_prTIirr ptiWL). + by rewrite (negPf k'j) andbF. +have V2x: x \in W :\: W2 by rewrite (subsetP _ x Vx) // setDS ?subsetUr. +rewrite !(cfunE, Dade_id) ?(cycTIiso_restrict _ _ Vx) //; last first. + by rewrite defA0 inE orbC mem_class_support. +by rewrite !Dmu2 // (prDade_TIsign_eq eq_mu2jk_1) !cfunE -mulrBr. +Qed. + +Lemma prDade_supp_disjoint : V \subset ~: K. +Proof. +rewrite subDset setUC -subDset setDE setCK setIC -(dprod_modr defW sW2K). +by rewrite coprime_TIg // dprod1g subsetUr. +Qed. + +(* This is Peterfalvi (4.9). *) +(* We have added the "obvious" fact that calT is pairwise orthogonal, since *) +(* we require this to prove membership in 'Z[calT], we encapsulate the *) +(* construction of tau1, and state its conformance to tau on the "larger" *) +(* domain 'Z[calT, L^#], so that clients can avoid using the domain equation *) +(* in part (a). *) +Theorem uniform_prTIred_coherent k (calT := uniform_prTIred_seq ptiWL k) : + k != 0 -> + (*a*) [/\ pairwise_orthogonal calT, ~~ has cfReal calT, conjC_closed calT, + 'Z[calT, L^#] =i 'Z[calT, A] + & exists2 psi, psi != 0 & psi \in 'Z[calT, A]] + (*b*) /\ (exists2 tau1 : {linear 'CF(L) -> 'CF(G)}, + forall j, tau1 (mu_ j) = delta_ k *: (\sum_i sigma (w_ i j)) + & {in 'Z[calT], isometry tau1, to 'Z[irr G]} + /\ {in 'Z[calT, L^#], tau1 =1 tau}). +Proof. +have uniqT: uniq calT by apply/dinjectiveP; apply: in2W; apply: prTIred_inj. +have sTmu: {subset calT <= codom mu_} by exact: image_codom. +have oo_mu: pairwise_orthogonal (codom mu_). + apply/pairwise_orthogonalP; split=> [|_ _ /codomP[j1 ->] /codomP[j2 ->]]. + apply/andP; split; last by apply/injectiveP; apply: prTIred_inj. + by apply/codomP=> [[i /esym/eqP/idPn[]]]; apply: prTIred_neq0. + by rewrite cfdot_prTIred; case: (j1 =P j2) => // -> /eqP. +have real'T: ~~ has cfReal calT. + by apply/hasPn=> _ /imageP[j /andP[nzj _] ->]; apply: prTIred_not_real. +have ccT: conjC_closed calT. + move=> _ /imageP[j Tj ->]; rewrite -prTIred_aut image_f // inE aut_Iirr_eq0. + by rewrite prTIred_aut cfunE conj_Cnat ?Cnat_char1 ?prTIred_char. +have TonA: 'Z[calT, L^#] =i 'Z[calT, A]. + have A'1: 1%g \notin A by apply: contra (subsetP sAA0 _) _; have [] := ddA0. + move => psi; rewrite zcharD1E -(setU1K A'1) zcharD1; congr (_ && _). + apply/idP/idP; [apply: zchar_trans_on psi => psi Tpsi | exact: zcharW]. + have [j /andP[nz_j _] Dpsi] := imageP Tpsi. + by rewrite zchar_split mem_zchar // Dpsi prDade_TIred_on. +move=> nzk; split. + split=> //; first exact: sub_pairwise_orthogonal oo_mu. + have Tmuk: mu_ k \in calT by rewrite image_f // inE nzk /=. + exists ((mu_ k)^*%CF - mu_ k); first by rewrite subr_eq0 (hasPn real'T). + rewrite -TonA -rpredN opprB sub_aut_zchar ?zchar_onG ?mem_zchar ?ccT //. + by move=> _ /mapP[j _ ->]; rewrite char_vchar ?prTIred_char. +pose f0 j := delta_ k *: (\sum_i eta_ i j); have in_mu := codom_f mu_. +pose f1 psi := f0 (iinv (valP (insigd (in_mu k) psi))). +have f1mu j: f1 (mu_ j) = f0 j. + have in_muj := in_mu j. + rewrite /f1 /insigd /insubd /= insubT /=; [idtac]. + by rewrite iinv_f //; apply: prTIred_inj. +have iso_f1: {in codom mu_, isometry f1, to 'Z[irr G]}. + split=> [_ _ /codomP[j1 ->] /codomP[j2 ->] | _ /codomP[j ->]]; last first. + by rewrite f1mu rpredZsign rpred_sum // => i _; apply: cycTIiso_vchar. + rewrite !f1mu cfdotZl cfdotZr rmorph_sign signrMK !cfdot_suml. + apply: eq_bigr => i1 _; rewrite !cfdot_sumr; apply: eq_bigr => i2 _. + by rewrite cfdot_cycTIiso cfdot_prTIirr. +have [tau1 Dtau1 Itau1] := Zisometry_of_iso oo_mu iso_f1. +exists tau1 => [j|]; first by rewrite Dtau1 ?codom_f ?f1mu. +split=> [|psi]; first by apply: sub_iso_to Itau1 => //; apply: zchar_subset. +rewrite zcharD1E => /andP[/zchar_expansion[//|z _ Dpsi] /eqP psi1_0]. +rewrite -[psi]subr0 -(scale0r (mu_ k)) -(mul0r (mu_ k 1%g)^-1) -{}psi1_0. +rewrite {psi}Dpsi sum_cfunE mulr_suml scaler_suml -sumrB !raddf_sum /=. +apply: eq_big_seq => _ /imageP[j /andP[nzj /eqP eq_mujk_1] ->]. +rewrite cfunE eq_mujk_1 mulfK ?prTIred_1_neq0 // -scalerBr !linearZ /=. +congr (_ *: _); rewrite {z}linearB !Dtau1 ?codom_f // !f1mu -scalerBr -!sumrB. +rewrite !linear_sum; apply: eq_bigr => i _ /=. +have{eq_mujk_1} eq_mu2ijk_1: mu2_ i j 1%g = mu2_ i k 1%g. + by apply: (mulfI (neq0CG W1)); rewrite !prTIirr_1 -!prTIred_1. +by rewrite -(prDade_TIsign_eq eq_mu2ijk_1) prDade_sub_TIirr. +Qed. + +(* This is Peterfalvi (4.10). *) +Lemma prDade_sub2_TIirr i j : + tau (delta_ j *: mu2_ i j - delta_ j *: mu2_ 0 j - mu2_ i 0 + mu2_ 0 0) + = eta_ i j - eta_ 0 j - eta_ i 0 + eta_ 0 0. +Proof. +pose V0 := class_support V L; have sVV0: V \subset V0 := sub_class_support L V. +have sV0A0: V0 \subset A0 by rewrite defA0 subsetUr. +have nV0L: L \subset 'N(V0) := class_support_norm V L. +have [_ _ /normedTI_memJ_P[ntV _ tiV]] := ctiWG. +have [/andP[sA0L _] _ A0'1 _ _] := ddA0. +have{sA0L A0'1} sV0G: V0 \subset G^#. + by rewrite (subset_trans sV0A0) // subsetD1 A0'1 (subset_trans sA0L). +have{sVV0} ntV0: V0 != set0 by apply: contraNneq ntV; rewrite -subset0 => <-. +have{ntV} tiV0: normedTI V0 G L. + apply/normedTI_memJ_P; split=> // _ z /imset2P[u y Vu Ly ->] Gz. + apply/idP/idP=> [/imset2P[u1 y1 Vu1 Ly1 Duyz] | Lz]; last first. + by rewrite -conjgM mem_imset2 ?groupM. + rewrite -[z](mulgKV y1) groupMr // -(groupMl _ Ly) (subsetP sWL) //. + by rewrite -(tiV u) ?groupM ?groupV // ?(subsetP sLG) // !conjgM Duyz conjgK. +have{ntV0 sV0A0 nV0L tiV0} DtauV0: {in 'CF(L, V0), tau =1 'Ind}. + by move=> beta V0beta; rewrite /= -(restr_DadeE _ sV0A0) //; apply: Dade_Ind. +pose alpha := cfCyclicTIset defW i j; set beta := _ *: mu2_ i j - _ - _ + _. +have Valpha: alpha \in 'CF(W, V) := cfCycTI_on ctiWL i j. +have Dalpha: alpha = w_ i j - w_ 0 j - w_ i 0 + w_ 0 0. + by rewrite addrC {1}cycTIirr00 addrA addrAC addrA addrAC -cfCycTI_E. +rewrite -!(linearB sigma) -linearD -Dalpha cycTIiso_Ind //. +suffices ->: beta = 'Ind[L] alpha by rewrite DtauV0 ?cfInd_on ?cfIndInd. +rewrite Dalpha -addrA -[w_ 0 0]opprK -opprD linearB /= /beta -scalerBr. +by rewrite !(cfInd_sub_prTIirr ptiWL) prTIsign0 scale1r opprD opprK addrA. +Qed. + +End Four_6_t0_10. diff --git a/mathcomp/odd_order/PFsection5.v b/mathcomp/odd_order/PFsection5.v new file mode 100644 index 0000000..0c3b1eb --- /dev/null +++ b/mathcomp/odd_order/PFsection5.v @@ -0,0 +1,1607 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg poly finset center. +Require Import fingroup morphism perm automorphism quotient action zmodp. +Require Import gfunctor gproduct cyclic pgroup frobenius. +Require Import matrix mxalgebra mxrepresentation vector ssrint. +Require Import ssrnum algC classfun character inertia vcharacter. +Require Import PFsection1 PFsection2 PFsection3 PFsection4. + +(******************************************************************************) +(* This file covers Peterfalvi, Section 5: Coherence. *) +(* Defined here: *) +(* coherent_with S A tau tau1 <-> tau1 is a Z-linear isometry from 'Z[S] to *) +(* 'Z[irr G] that coincides with tau on 'Z[S, A]. *) +(* coherent S A tau <-> (S, A, tau) is coherent, i.e., there is a Z-linear *) +(* isometry tau1 s.t. coherent_with S A tau tau1. *) +(* subcoherent S tau R <-> S : seq 'cfun(L) is non empty, pairwise orthogonal *) +(* and closed under complex conjugation, tau is an *) +(* isometry from 'Z[S, L^#] to virtual characters in *) +(* G that maps the difference chi - chi^*, for each *) +(* chi \in S, to the sum of an orthonormal family *) +(* R chi of virtual characters of G; also, R chi and *) +(* R phi are orthogonal unless phi \in chi :: chi^*. *) +(* dual_iso nu == the Z-linear (additive) mapping phi |-> - nu phi^* *) +(* for nu : {additive 'CF(L) -> 'CF(G)}. If nu is an *) +(* isometry extending a subcoherent tau on 'Z[S] with *) +(* size S = 2, then so is dual_iso nu. *) +(* We provide a set of definitions that cover the various \cal S notations *) +(* introduces in Peterfalvi sections 5, 6, 7, and 9 to 14. *) +(* Iirr_ker K A == the set of all i : Iirr K such that the kernel of *) +(* 'chi_i contains A. *) +(* Iirr_kerD K B A == the set of all i : Iirr K such that the kernel of *) +(* 'chi_i contains A but not B. *) +(* seqInd L calX == the duplicate-free sequence of characters of L *) +(* induced from K by the 'chi_i for i in calX. *) +(* seqIndT K L == the duplicate-free sequence of all characters of L *) +(* induced by irreducible characters of K. *) +(* seqIndD K L H M == the duplicate-free sequence of characters of L *) +(* induced by irreducible characters of K that have M *) +(* in their kernel, but not H. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory Num.Theory. +Local Open Scope ring_scope. + +(* Results about the set of induced irreducible characters *) +Section InducedIrrs. + +Variables (gT : finGroupType) (K L : {group gT}). +Implicit Types (A B : {set gT}) (H M : {group gT}). +Implicit Type u : {rmorphism algC -> algC}. + +Section KerIirr. + +Definition Iirr_ker A := [set i | A \subset cfker 'chi[K]_i]. + +Lemma Iirr_kerS A B : B \subset A -> Iirr_ker A \subset Iirr_ker B. +Proof. by move/subset_trans=> sBA; apply/subsetP=> i; rewrite !inE => /sBA. Qed. + +Lemma sum_Iirr_ker_square H : + H <| K -> \sum_(i in Iirr_ker H) 'chi_i 1%g ^+ 2 = #|K : H|%:R. +Proof. +move=> nsHK; rewrite -card_quotient ?normal_norm // -irr_sum_square. +rewrite (eq_bigl _ _ (in_set _)) (reindex _ (mod_Iirr_bij nsHK)) /=. +by apply: eq_big => [i | i _]; rewrite mod_IirrE ?cfker_mod ?cfMod1. +Qed. + +Definition Iirr_kerD B A := Iirr_ker A :\: Iirr_ker B. + +Lemma sum_Iirr_kerD_square H M : + H <| K -> M <| K -> M \subset H -> + \sum_(i in Iirr_kerD H M) 'chi_i 1%g ^+ 2 = #|K : H|%:R * (#|H : M|%:R - 1). +Proof. +move=> nsHK nsMK sMH; have [sHK _] := andP nsHK. +rewrite mulrBr mulr1 -natrM Lagrange_index // -!sum_Iirr_ker_square //. +apply/esym/(canLR (addrK _)); rewrite /= addrC (big_setID (Iirr_ker H)). +by rewrite (setIidPr _) ?Iirr_kerS //. +Qed. + +Lemma Iirr_ker_aut u A i : (aut_Iirr u i \in Iirr_ker A) = (i \in Iirr_ker A). +Proof. by rewrite !inE aut_IirrE cfker_aut. Qed. + +Lemma Iirr_ker_conjg A i x : + x \in 'N(A) -> (conjg_Iirr i x \in Iirr_ker A) = (i \in Iirr_ker A). +Proof. +move=> nAx; rewrite !inE conjg_IirrE. +have [nKx | /cfConjgEout-> //] := boolP (x \in 'N(K)). +by rewrite cfker_conjg // -{1}(normP nAx) conjSg. +Qed. + +Lemma Iirr_kerDS A1 A2 B1 B2 : + A2 \subset A1 -> B1 \subset B2 -> Iirr_kerD B1 A1 \subset Iirr_kerD B2 A2. +Proof. by move=> sA12 sB21; rewrite setDSS ?Iirr_kerS. Qed. + +Lemma Iirr_kerDY B A : Iirr_kerD (A <*> B) A = Iirr_kerD B A. +Proof. by apply/setP=> i; rewrite !inE join_subG; apply: andb_id2r => ->. Qed. + +Lemma mem_Iirr_ker1 i : (i \in Iirr_kerD K 1%g) = (i != 0). +Proof. by rewrite !inE sub1G andbT subGcfker. Qed. + +End KerIirr. + +Hypothesis nsKL : K <| L. +Let sKL := normal_sub nsKL. +Let nKL := normal_norm nsKL. +Let e := #|L : K|%:R : algC. +Let nze : e != 0 := neq0CiG _ _. + +Section SeqInd. + +Variable calX : {set (Iirr K)}. + +(* The set of characters induced from the irreducibles in calX. *) +Definition seqInd := undup [seq 'Ind[L] 'chi_i | i in calX]. +Local Notation S := seqInd. + +Lemma seqInd_uniq : uniq S. Proof. exact: undup_uniq. Qed. + +Lemma seqIndP phi : + reflect (exists2 i, i \in calX & phi = 'Ind[L] 'chi_i) (phi \in S). +Proof. by rewrite mem_undup; exact: imageP. Qed. + +Lemma seqInd_on : {subset S <= 'CF(L, K)}. +Proof. by move=> _ /seqIndP[i _ ->]; exact: cfInd_normal. Qed. + +Lemma seqInd_char : {subset S <= character}. +Proof. by move=> _ /seqIndP[i _ ->]; rewrite cfInd_char ?irr_char. Qed. + +Lemma Cnat_seqInd1 phi : phi \in S -> phi 1%g \in Cnat. +Proof. by move/seqInd_char/Cnat_char1. Qed. + +Lemma Cint_seqInd1 phi : phi \in S -> phi 1%g \in Cint. +Proof. by rewrite CintE; move/Cnat_seqInd1->. Qed. + +Lemma seqInd_neq0 psi : psi \in S -> psi != 0. +Proof. by move=> /seqIndP[i _ ->]; exact: Ind_irr_neq0. Qed. + +Lemma seqInd1_neq0 psi : psi \in S -> psi 1%g != 0. +Proof. by move=> Spsi; rewrite char1_eq0 ?seqInd_char ?seqInd_neq0. Qed. + +Lemma cfnorm_seqInd_neq0 psi : psi \in S -> '[psi] != 0. +Proof. by move/seqInd_neq0; rewrite cfnorm_eq0. Qed. + +Lemma seqInd_ortho : {in S &, forall phi psi, phi != psi -> '[phi, psi] = 0}. +Proof. +move=> _ _ /seqIndP[i _ ->] /seqIndP[j _ ->]. +by case: ifP (cfclass_Ind_cases i j nsKL) => // _ -> /eqP. +Qed. + +Lemma seqInd_orthogonal : pairwise_orthogonal S. +Proof. +apply/pairwise_orthogonalP; split; last exact: seqInd_ortho. +by rewrite /= undup_uniq andbT; move/memPn: seqInd_neq0. +Qed. + +Lemma seqInd_free : free S. +Proof. exact: (orthogonal_free seqInd_orthogonal). Qed. + +Lemma seqInd_zcharW : {subset S <= 'Z[S]}. +Proof. by move=> phi Sphi; rewrite mem_zchar ?seqInd_free. Qed. + +Lemma seqInd_zchar : {subset S <= 'Z[S, K]}. +Proof. by move=> phi Sphi; rewrite zchar_split seqInd_zcharW ?seqInd_on. Qed. + +Lemma seqInd_vcharW : {subset S <= 'Z[irr L]}. +Proof. by move=> phi Sphi; rewrite char_vchar ?seqInd_char. Qed. + +Lemma seqInd_vchar : {subset S <= 'Z[irr L, K]}. +Proof. by move=> phi Sphi; rewrite zchar_split seqInd_vcharW ?seqInd_on. Qed. + +Lemma zcharD1_seqInd : 'Z[S, L^#] =i 'Z[S, K^#]. +Proof. +move=> phi; rewrite zcharD1E (zchar_split _ K^#) cfun_onD1. +by apply: andb_id2l => /(zchar_trans_on seqInd_zchar)/zchar_on->. +Qed. + +Lemma zcharD1_seqInd_on : {subset 'Z[S, L^#] <= 'CF(L, K^#)}. +Proof. by move=> phi; rewrite zcharD1_seqInd => /zchar_on. Qed. + +Lemma zcharD1_seqInd_Dade A : + 1%g \notin A -> {subset S <= 'CF(L, 1%g |: A)} -> 'Z[S, L^#] =i 'Z[S, A]. +Proof. +move=> notA1 A_S phi; rewrite zcharD1E (zchar_split _ A). +apply/andb_id2l=> ZSphi; apply/idP/idP=> [phi10 | /cfun_on0-> //]. +rewrite -(setU1K notA1) cfun_onD1 {}phi10 andbT. +have{phi ZSphi} [c -> _] := free_span seqInd_free (zchar_span ZSphi). +by rewrite big_seq memv_suml // => xi /A_S/memvZ. +Qed. + +Lemma dvd_index_seqInd1 phi : phi \in S -> phi 1%g / e \in Cnat. +Proof. +by case/seqIndP=> i _ ->; rewrite cfInd1 // mulrC mulKf ?Cnat_irr1. +Qed. + +Lemma sub_seqInd_zchar phi psi : + phi \in S -> psi \in S -> psi 1%g *: phi - phi 1%g *: psi \in 'Z[S, K^#]. +Proof. +move=> Sphi Spsi; rewrite zcharD1 !cfunE mulrC subrr eqxx. +by rewrite rpredB ?scale_zchar ?Cint_seqInd1 ?seqInd_zchar. +Qed. + +Lemma sub_seqInd_on phi psi : + phi \in S -> psi \in S -> psi 1%g *: phi - phi 1%g *: psi \in 'CF(L, K^#). +Proof. by move=> Sphi Spsi; exact: zchar_on (sub_seqInd_zchar Sphi Spsi). Qed. + +Lemma size_irr_subseq_seqInd S1 : + subseq S1 S -> {subset S1 <= irr L} -> + (#|L : K| * size S1 = #|[set i | 'Ind 'chi[K]_i \in S1]|)%N. +Proof. +move=> sS1S irrS1; rewrite (card_imset_Ind_irr nsKL) => [|i|i y]; first 1 last. +- by rewrite inE => /irrS1. +- rewrite !inE => S1iG Ly; congr (_ \in S1): S1iG. + by apply: cfclass_Ind => //; apply/cfclassP; exists y; rewrite ?conjg_IirrE. +congr (_ * _)%N; rewrite -(size_map (@cfIirr _ _)) -(card_uniqP _); last first. + rewrite map_inj_in_uniq ?(subseq_uniq sS1S) ?seqInd_uniq //. + by apply: (@can_in_inj _ _ _ _ (tnth (irr L))) => phi /irrS1/cfIirrE. +apply: eq_card => s; apply/mapP/imsetP=> [[phi S1phi ->] | [i]]. + have /seqIndP[i _ Dphi] := mem_subseq sS1S S1phi. + by exists i; rewrite ?inE -Dphi. +by rewrite inE => S1iG ->; exists ('Ind 'chi_i). +Qed. + +Section Beta. + +Variable xi : 'CF(L). +Hypotheses (Sxi : xi \in S) (xi1 : xi 1%g = e). + +Lemma cfInd1_sub_lin_vchar : 'Ind[L, K] 1 - xi \in 'Z[irr L, K^#]. +Proof. +rewrite zcharD1 !cfunE xi1 cfInd1 // cfun11 mulr1 subrr eqxx andbT. +rewrite rpredB ?(seqInd_vchar Sxi) // zchar_split cfInd_normal ?char_vchar //. +by rewrite cfInd_char ?cfun1_char. +Qed. + +Lemma cfInd1_sub_lin_on : 'Ind[L, K] 1 - xi \in 'CF(L, K^#). +Proof. exact: zchar_on cfInd1_sub_lin_vchar. Qed. + +Lemma seqInd_sub_lin_vchar : + {in S, forall phi : 'CF(L), phi - (phi 1%g / e) *: xi \in 'Z[S, K^#]}. +Proof. +move=> phi Sphi; rewrite /= zcharD1 !cfunE xi1 divfK // subrr eqxx. +by rewrite rpredB ?scale_zchar ?seqInd_zchar // CintE dvd_index_seqInd1. +Qed. + +Lemma seqInd_sub_lin_on : + {in S, forall phi : 'CF(L), phi - (phi 1%g / e) *: xi \in 'CF(L, K^#)}. +Proof. by move=> phi /seqInd_sub_lin_vchar/zchar_on. Qed. + +End Beta. + +End SeqInd. + +Implicit Arguments seqIndP [calX phi]. + +Lemma seqIndS (calX calY : {set Iirr K}) : + calX \subset calY -> {subset seqInd calX <= seqInd calY}. +Proof. +by move=> sXY _ /seqIndP[i /(subsetP sXY)Yi ->]; apply/seqIndP; exists i. +Qed. + +Definition seqIndT := seqInd setT. + +Lemma seqInd_subT calX : {subset seqInd calX <= seqIndT}. +Proof. exact: seqIndS (subsetT calX). Qed. + +Lemma mem_seqIndT i : 'Ind[L, K] 'chi_i \in seqIndT. +Proof. by apply/seqIndP; exists i; rewrite ?inE. Qed. + +Lemma seqIndT_Ind1 : 'Ind[L, K] 1 \in seqIndT. +Proof. by rewrite -irr0 mem_seqIndT. Qed. + +Lemma cfAut_seqIndT u : cfAut_closed u seqIndT. +Proof. +by move=> _ /seqIndP[i _ ->]; rewrite cfAutInd -aut_IirrE mem_seqIndT. +Qed. + +Definition seqIndD H M := seqInd (Iirr_kerD H M). + +Lemma seqIndDY H M : seqIndD (M <*> H) M = seqIndD H M. +Proof. by rewrite /seqIndD Iirr_kerDY. Qed. + +Lemma mem_seqInd H M i : + H <| L -> M <| L -> ('Ind 'chi_i \in seqIndD H M) = (i \in Iirr_kerD H M). +Proof. +move=> nsHL nsML; apply/seqIndP/idP=> [[j Xj] | Xi]; last by exists i. +case/cfclass_Ind_irrP/cfclassP=> // y Ly; rewrite -conjg_IirrE => /irr_inj->. +by rewrite inE !Iirr_ker_conjg -?in_setD ?(subsetP _ y Ly) ?normal_norm. +Qed. + +Lemma seqIndC1P phi : + reflect (exists2 i, i != 0 & phi = 'Ind 'chi[K]_i) (phi \in seqIndD K 1). +Proof. +by apply: (iffP seqIndP) => [] [i nzi ->]; + exists i; rewrite // mem_Iirr_ker1 in nzi *. +Qed. + +Lemma seqIndC1_filter : seqIndD K 1 = filter (predC1 ('Ind[L, K] 1)) seqIndT. +Proof. +rewrite filter_undup filter_map (eq_enum (in_set _)) enumT. +congr (undup (map _ _)); apply: eq_filter => i /=. +by rewrite mem_Iirr_ker1 cfInd_irr_eq1. +Qed. + +Lemma seqIndC1_rem : seqIndD K 1 = rem ('Ind[L, K] 1) seqIndT. +Proof. by rewrite rem_filter ?seqIndC1_filter ?undup_uniq. Qed. + +Section SeqIndD. + +Variables H0 H M : {group gT}. + +Local Notation S := (seqIndD H M). + +Lemma cfAut_seqInd u : cfAut_closed u S. +Proof. +move=> _ /seqIndP[i /setDP[kMi not_kHi] ->]; rewrite cfAutInd -aut_IirrE. +by apply/seqIndP; exists (aut_Iirr u i); rewrite // inE !Iirr_ker_aut not_kHi. +Qed. + +Lemma seqInd_conjC_subset1 : H \subset H0 -> cfConjC_subset S (seqIndD H0 1). +Proof. +move=> sHH0; split; [exact: seqInd_uniq | apply: seqIndS | exact: cfAut_seqInd]. +by rewrite Iirr_kerDS ?sub1G. +Qed. + +Lemma seqInd_sub_aut_zchar u : + {in S, forall phi, phi - cfAut u phi \in 'Z[S, K^#]}. +Proof. +move=> phi Sphi /=; rewrite sub_aut_zchar ?seqInd_zchar ?cfAut_seqInd //. +exact: seqInd_vcharW. +Qed. + +Hypothesis sHK : H \subset K. + +Lemma seqInd_sub : {subset S <= seqIndD K 1}. +Proof. by apply: seqIndS; exact: Iirr_kerDS (sub1G M) sHK. Qed. + +Lemma seqInd_ortho_Ind1 : {in S, forall phi, '[phi, 'Ind[L, K] 1] = 0}. +Proof. +move=> _ /seqInd_sub/seqIndC1P[i nzi ->]. +by rewrite -irr0 not_cfclass_Ind_ortho // irr0 cfclass1 // inE irr_eq1. +Qed. + +Lemma seqInd_ortho_cfuni : {in S, forall phi, '[phi, '1_K] = 0}. +Proof. +move=> phi /seqInd_ortho_Ind1/eqP; apply: contraTeq => not_o_phi_1K. +by rewrite cfInd_cfun1 // cfdotZr rmorph_nat mulf_neq0. +Qed. + +Lemma seqInd_ortho_1 : {in S, forall phi, '[phi, 1] = 0}. +Proof. +move=> _ /seqInd_sub/seqIndC1P[i nzi ->]. +by rewrite -cfdot_Res_r cfRes_cfun1 // -irr0 cfdot_irr (negbTE nzi). +Qed. + +Lemma sum_seqIndD_square : + H <| L -> M <| L -> M \subset H -> + \sum_(phi <- S) phi 1%g ^+ 2 / '[phi] = #|L : H|%:R * (#|H : M|%:R - 1). +Proof. +move=> nsHL nsML sMH; rewrite -(Lagrange_index sKL sHK) natrM -/e -mulrA. +rewrite -sum_Iirr_kerD_square ?(normalS _ sKL) ?(subset_trans sMH) //. +pose h i := @Ordinal (size S).+1 _ (index_size ('Ind 'chi[K]_i) S). +rewrite (partition_big h (ltn^~ (size S))) => /= [|i Xi]; last first. + by rewrite index_mem mem_seqInd. +rewrite big_distrr big_ord_narrow //= big_index_uniq ?seqInd_uniq //=. +apply: eq_big_seq => phi Sphi; rewrite /eq_op insubT ?index_mem //= => _. +have /seqIndP[i kHMi def_phi] := Sphi. +have/cfunP/(_ 1%g) := scaled_cfResInd_sum_cfclass i nsKL. +rewrite !cfunE sum_cfunE -def_phi cfResE // mulrAC => ->; congr (_ * _). +rewrite reindex_cfclass //=; apply/esym/eq_big => j; last by rewrite !cfunE. +rewrite (sameP (cfclass_Ind_irrP _ _ nsKL) eqP) -def_phi -mem_seqInd //. +by apply/andP/eqP=> [[/(nth_index 0){2}<- /eqP->] | -> //]; exact: nth_index. +Qed. + +Section Odd. + +Hypothesis oddL : odd #|L|. + +Lemma seqInd_conjC_ortho : {in S, forall phi, '[phi, phi^*] = 0}. +Proof. +by move=> _ /seqInd_sub/seqIndC1P[i nzi ->]; exact: odd_induced_orthogonal. +Qed. + +Lemma seqInd_conjC_neq : {in S, forall phi, phi^* != phi}%CF. +Proof. +move=> phi Sphi; apply: contraNneq (cfnorm_seqInd_neq0 Sphi) => {2}<-. +by rewrite seqInd_conjC_ortho. +Qed. + +Lemma seqInd_notReal : ~~ has cfReal S. +Proof. exact/hasPn/seqInd_conjC_neq. Qed. + +Variable chi : 'CF(L). +Hypotheses (irr_chi : chi \in irr L) (Schi : chi \in S). + +Lemma seqInd_conjC_ortho2 : orthonormal (chi :: chi^*)%CF. +Proof. +by rewrite /orthonormal/= cfnorm_conjC irrWnorm ?seqInd_conjC_ortho ?eqxx. +Qed. + +Lemma seqInd_nontrivial_irr : (#|[set i | 'chi_i \in S]| > 1)%N. +Proof. +have /irrP[i Dchi] := irr_chi; rewrite (cardsD1 i) (cardsD1 (conjC_Iirr i)). +rewrite !inE -(inj_eq irr_inj) conjC_IirrE -Dchi seqInd_conjC_neq //. +by rewrite cfAut_seqInd Schi. +Qed. + +Lemma seqInd_nontrivial : (size S > 1)%N. +Proof. +apply: (@leq_trans (size [seq 'chi_i | i in [pred i | 'chi_i \in S]])). + by rewrite size_map -cardE -cardsE seqInd_nontrivial_irr. +apply: uniq_leq_size => [| _ /imageP[i Schi_i ->] //]. +exact/dinjectiveP/(in2W irr_inj). +Qed. + +End Odd. + +End SeqIndD. + +Lemma sum_seqIndC1_square : + \sum_(phi <- seqIndD K 1) phi 1%g ^+ 2 / '[phi] = e * (#|K|%:R - 1). +Proof. by rewrite sum_seqIndD_square ?normal1 ?sub1G // indexg1. Qed. + +End InducedIrrs. + +Implicit Arguments seqIndP [gT K L calX phi]. +Implicit Arguments seqIndC1P [gT K L phi]. + +Section Five. + +Variable gT : finGroupType. + +Section Defs. + +Variables L G : {group gT}. + +(* This is Peterfalvi, Definition (5.1). *) +(* We depart from the text in Section 5 on three points: *) +(* - We drop non-triviality condition in Z[S, A], which is not used *) +(* consistently in the rest of the proof. In particular, it is *) +(* incompatible with the use of "not coherent" in (6.2), and it is only *) +(* really used in (7.8), where it is equivalent to the simpler condition *) +(* (size S > 1). For us the empty S is coherent; this avoids duplicate *) +(* work in some inductive proofs, e.g., subcoherent_norm - Lemma (5.4) - *) +(* belom. *) +(* - The preconditions for coherence (A < L, S < Z[irr L], and tau Z-linear *) +(* on some E < Z[irr L]) are not part of the definition of "coherent". *) +(* These will be captured as separate requirements; in particular in the *) +(* Odd Order proof tau will always be C-linear on all of 'CF(L). *) +(* - By contrast, our "coherent" only supplies an additive (Z-linear) *) +(* isometry, where the source text ambiguously specifies "linear" one. *) +(* When S consists of virtual characters this implies the existence of *) +(* a C-linear one: the linear extension of the restriction of the *) +(* isometry to a basis of the Z-module Z[S]; the latter being given by *) +(* the Smith normal form (see intdiv.v). The weaker requirement lets us *) +(* use the dual_iso construction when size S = 2. *) +(* Finally, note that although we have retained the A parameter, in the *) +(* sequel we shall always take A = L^#, as in the text it is always the case *) +(* that Z[S, A] = Z[S, L^#]. *) +Definition coherent_with S A tau (tau1 : {additive 'CF(L) -> 'CF(G)}) := + {in 'Z[S], isometry tau1, to 'Z[irr G]} /\ {in 'Z[S, A], tau1 =1 tau}. + +Definition coherent S A tau := exists tau1, coherent_with S A tau tau1. + +(* This is Peterfalvi, Hypothesis (5.2). *) +(* The Z-linearity constraint on tau will be expressed by an additive or *) +(* linear structure on tau. *) +Definition subcoherent S tau R := + [/\ (*a*) [/\ {subset S <= character}, ~~ has cfReal S & conjC_closed S], + (*b*) {in 'Z[S, L^#], isometry tau, to 'Z[@irr gT G, G^#]}, + (*c*) pairwise_orthogonal S, + (*d*) {in S, forall xi : 'CF(L : {set gT}), + [/\ {subset R xi <= 'Z[irr G]}, orthonormal (R xi) + & tau (xi - xi^*)%CF = \sum_(alpha <- R xi) alpha]} + & (*e*) {in S &, forall xi phi : 'CF(L), + orthogonal phi (xi :: xi^*%CF) -> orthogonal (R phi) (R xi)}]. + +Definition dual_iso (nu : {additive 'CF(L) -> 'CF(G)}) := + [additive of -%R \o nu \o cfAut conjC]. + +End Defs. + +Section SubsetCoherent. + +Variables L G : {group gT}. +Implicit Type tau : 'CF(L) -> 'CF(G). + +Lemma subgen_coherent S1 S2 A tau: + {subset S2 <= 'Z[S1]} -> coherent S1 A tau -> coherent S2 A tau. +Proof. +move/zchar_trans=> sS21 [tau1 [[Itau1 Ztau1] def_tau]]. +exists tau1; split; last exact: sub_in1 def_tau. +by split; [exact: sub_in2 Itau1 | exact: sub_in1 Ztau1]. +Qed. + +Lemma subset_coherent S1 S2 A tau: + {subset S2 <= S1} -> coherent S1 A tau -> coherent S2 A tau. +Proof. +by move=> sS21; apply: subgen_coherent => phi /sS21/mem_zchar->. +Qed. + +Lemma subset_coherent_with S1 S2 A tau (tau1 : {additive 'CF(L) -> 'CF(G)}) : + {subset S1 <= S2} -> coherent_with S2 A tau tau1 -> + coherent_with S1 A tau tau1. +Proof. +move=> /zchar_subset sS12 [Itau1 Dtau1]. +by split=> [|xi /sS12/Dtau1//]; exact: sub_iso_to Itau1. +Qed. + +Lemma perm_eq_coherent S1 S2 A tau: + perm_eq S1 S2 -> coherent S1 A tau -> coherent S2 A tau. +Proof. +by move=> eqS12; apply: subset_coherent => phi; rewrite (perm_eq_mem eqS12). +Qed. + +Lemma dual_coherence S tau R nu : + subcoherent S tau R -> coherent_with S L^# tau nu -> (size S <= 2)%N -> + coherent_with S L^# tau (dual_iso nu). +Proof. +move=> [[charS nrS ccS] _ oSS _ _] [[Inu Znu] Dnu] szS2. +split=> [|{Inu Znu oSS} phi ZSphi]. + have{oSS} ccZS := cfAut_zchar ccS. + have vcharS: {subset S <= 'Z[irr L]} by move=> phi /charS/char_vchar. + split=> [phi1 phi2 Sphi1 Sphi2 | phi Sphi]. + rewrite cfdotNl cfdotNr opprK Inu ?ccZS // cfdot_conjC aut_Cint //. + by rewrite Cint_cfdot_vchar ?(zchar_sub_irr vcharS). + by rewrite rpredN Znu ?ccZS. +rewrite -{}Dnu //; move: ZSphi; rewrite zcharD1E => /andP[]. +case/zchar_nth_expansion=> x Zx -> {phi} /=. +case: S charS nrS ccS szS2 x Zx => [_ _ _ _ x _| eta S1]. + by rewrite big_ord0 !raddf0. +case/allP/andP=> Neta _ /norP[eta'c _] /allP/andP[S1_etac _]. +rewrite inE [_ == _](negPf eta'c) /= in S1_etac. +case S1E: S1 S1_etac => [|u []] // /predU1P[] //= <- _ z Zz. +rewrite big_ord_recl big_ord1 !raddfD !raddfZ_Cint //=. +rewrite !cfunE (conj_Cnat (Cnat_char1 Neta)) -mulrDl mulf_eq0. +rewrite addr_eq0 char1_eq0 // !scalerN /= cfConjCK addrC. +by case/pred2P => ->; rewrite ?raddf0 //= !scaleNr opprK. +Qed. + +Lemma coherent_seqInd_conjCirr S tau R nu r : + subcoherent S tau R -> coherent_with S L^# tau nu -> + let chi := 'chi_r in let chi2 := (chi :: chi^*)%CF in + chi \in S -> + [/\ {subset map nu chi2 <= 'Z[irr G]}, orthonormal (map nu chi2), + chi - chi^*%CF \in 'Z[S, L^#] & (nu chi - nu chi^*)%CF 1%g == 0]. +Proof. +move=> [[charS nrS ccS] [_ Ztau] oSS _ _] [[Inu Znu] Dnu] chi chi2 Schi. +have sSZ: {subset S <= 'Z[S]} by apply: mem_zchar. +have vcharS: {subset S <= 'Z[irr L]} by move=> phi /charS/char_vchar. +have Schi2: {subset chi2 <= 'Z[S]} by apply/allP; rewrite /= !sSZ ?ccS. +have Schi_diff: chi - chi^*%CF \in 'Z[S, L^#]. + by rewrite sub_aut_zchar // zchar_onG sSZ ?ccS. +split=> // [_ /mapP[xi /Schi2/Znu ? -> //]||]. + apply: map_orthonormal; first by apply: sub_in2 Inu; exact: zchar_trans_on. + rewrite orthonormalE (conjC_pair_orthogonal ccS) //=. + by rewrite cfnorm_conjC !cfnorm_irr !eqxx. +by rewrite -raddfB -cfunD1E Dnu // irr_vchar_on ?Ztau. +Qed. + +End SubsetCoherent. + +(* This is Peterfalvi (5.3)(a). *) +Lemma irr_subcoherent (L G : {group gT}) S tau : + cfConjC_subset S (irr L) -> ~~ has cfReal S -> + {in 'Z[S, L^#], isometry tau, to 'Z[irr G, G^#]} -> + {R | subcoherent S tau R}. +Proof. +case=> U_S irrS ccS nrS [isoL Ztau]. +have N_S: {subset S <= character} by move=> _ /irrS/irrP[i ->]; exact: irr_char. +have vcS: {subset S <= 'Z[irr L]} by move=> chi /N_S/char_vchar. +have o1SS: orthonormal S by exact: sub_orthonormal (irr_orthonormal L). +have [[_ dotSS] oSS] := (orthonormalP o1SS, orthonormal_orthogonal o1SS). +have freeS := orthogonal_free oSS. +pose beta chi := tau (chi - chi^*)%CF; pose eqBP := _ =P beta _. +have Zbeta: {in S, forall chi, chi - (chi^*)%CF \in 'Z[S, L^#]}. + move=> chi Schi; rewrite /= zcharD1E rpredB ?mem_zchar ?ccS //= !cfunE. + by rewrite subr_eq0 conj_Cnat // Cnat_char1 ?N_S. +pose sum_beta chi R := \sum_(alpha <- R) alpha == beta chi. +pose Zortho R := all (mem 'Z[irr G]) R && orthonormal R. +have R chi: {R : 2.-tuple 'CF(G) | (chi \in S) ==> sum_beta chi R && Zortho R}. + apply: sigW; case Schi: (chi \in S) => /=; last by exists [tuple 0; 0]. + move/(_ _ Schi) in Zbeta; have /irrP[i def_chi] := irrS _ Schi. + have: '[beta chi] = 2%:R. + rewrite isoL // cfnormBd ?dotSS ?ccS ?eqxx // eq_sym -/(cfReal _). + by rewrite (negPf (hasPn nrS _ _)). + case/zchar_small_norm; rewrite ?(zcharW (Ztau _ _)) // => R [oR ZR sumR]. + by exists R; apply/and3P; split; [exact/eqP | exact/allP | ]. +exists (fun xi => val (val (R xi))); split=> // [chi Schi | chi phi Schi Sphi]. + by case: (R chi) => Rc /=; rewrite Schi => /and3P[/eqBP-> /allP]. +case/andP => /and3P[/= /eqP opx /eqP opx' _] _. +have{opx opx'} obpx: '[beta phi, beta chi] = 0. + rewrite isoL ?Zbeta // cfdotBl !cfdotBr -{3}[chi]cfConjCK. + by rewrite !cfdot_conjC opx opx' rmorph0 !subr0. +case: (R phi) => [[[|a [|b []]] //= _]]. +rewrite Sphi => /and3P[/eqBP sum_ab Zab o_ab]. +case: (R chi) => [[[|c [|d []]] //= _]]. +rewrite Schi => /and3P[/eqBP sum_cd Zcd o_cd]. +suffices: orthonormal [:: a; - b; c; d]. + rewrite (orthonormal_cat [:: a; _]) => /and3P[_ _]. + by rewrite /orthogonal /= !cfdotNl !oppr_eq0. +apply: vchar_pairs_orthonormal 1 (-1) _ _ _ _. +- by split; apply/allP; rewrite //= rpredN. +- by rewrite o_cd andbT /orthonormal/= cfnormN /orthogonal /= cfdotNr !oppr_eq0. +- by rewrite oppr_eq0 oner_eq0 rpredN rpred1. +rewrite !(big_seq1, big_cons) in sum_ab sum_cd. +rewrite scale1r scaleN1r !opprK sum_ab sum_cd obpx eqxx /=. +by rewrite !(cfun_on0 (zchar_on (Ztau _ _))) ?Zbeta ?inE ?eqxx. +Qed. + +(* This is Peterfalvi (5.3)(b). *) +Lemma prDade_subcoherent (G L K H W W1 W2 : {group gT}) A A0 S + (defW : W1 \x W2 = W) (ddA : prime_Dade_hypothesis G L K H A A0 defW) + (w_ := fun i j => cyclicTIirr defW i j) (sigma := cyclicTIiso ddA) + (mu := primeTIred ddA) (delta := fun j => primeTIsign ddA j) + (tau := Dade ddA) : + let dsw j k := [seq delta j *: sigma (w_ i k) | i : Iirr W1] in + let Rmu j := dsw j j ++ map -%R (dsw j (conjC_Iirr j)) in + cfConjC_subset S (seqIndD K L H 1) -> ~~ has cfReal S -> + {R | [/\ subcoherent S tau R, + {in [predI S & irr L] & irr W, + forall phi w, orthogonal (R phi) (sigma w)} + & forall j, R (mu j) = Rmu j ]}. +Proof. +pose mu2 i j := primeTIirr ddA i j. +set S0 := seqIndD K L H 1 => dsw Rmu [uS sSS0 ccS] nrS. +have nsKL: K <| L by have [[/sdprod_context[]]] := prDade_prTI ddA. +have /subsetD1P[sAK notA1]: A \subset K^# by have [_ []] := prDade_def ddA. +have [_ _ defA0] := prDade_def ddA. +have defSA: 'Z[S, L^#] =i 'Z[S, A]. + have sS0A1: {subset S0 <= 'CF(L, 1%g |: A)}. + move=> _ /seqIndP[i /setDP[_ kerH'i] ->]; rewrite inE in kerH'i. + exact: (prDade_Ind_irr_on ddA) kerH'i. + move=> phi; have:= zcharD1_seqInd_Dade nsKL notA1 sS0A1 phi. + rewrite !{1}(zchar_split _ A, zchar_split _ L^#) => eq_phiAL. + by apply: andb_id2l => /(zchar_subset sSS0) S0phi; rewrite S0phi in eq_phiAL. +have Itau: {in 'Z[S, L^#], isometry tau, to 'Z[irr G, G^#]}. + apply: sub_iso_to sub_refl (Dade_Zisometry _) => phi; rewrite defSA => SAphi. + rewrite defA0; apply: zchar_onS (subsetUl _ _) _ _. + by apply: zchar_sub_irr SAphi => ? /sSS0/seqInd_vcharW. +have orthoS: pairwise_orthogonal S. + exact: sub_pairwise_orthogonal sSS0 uS (seqInd_orthogonal nsKL _). +pose S1 := filter (mem (irr L)) S. +have sS1S: {subset S1 <= S} by apply: mem_subseq; exact: filter_subseq. +have sZS1S: {subset 'Z[S1, L^#] <= 'Z[S, L^#]}. + by apply: zchar_subset sS1S; exact: orthogonal_free. +have [||R1 cohR1] := irr_subcoherent _ _ (sub_iso_to sZS1S sub_refl Itau). +- split=> [|phi|phi]; rewrite ?mem_filter ?filter_uniq //; try case/andP=> //. + by case/irrP=> i {2}-> /=/ccS->; rewrite cfConjC_irr. +- by apply/hasPn=> phi /sS1S/(hasPn nrS). +have{cohR1} [[charS1 _ _] _ _ R1ok R1ortho] := cohR1. +pose R phi := oapp Rmu (R1 phi) [pick j | phi == mu j]. +have inS1 phi: [pred j | phi == mu j] =1 pred0 -> phi \in S -> phi \in S1. + move=> mu'phi Sphi; rewrite mem_filter Sphi andbT /=. + have{Sphi} /seqIndP[ell _ Dphi] := sSS0 _ Sphi; rewrite Dphi. + have [[j Dell] | [] //] := prTIres_irr_cases ddA ell. + by have /=/eqP[] := mu'phi j; rewrite Dphi Dell cfInd_prTIres. +have Smu_nz j: mu j \in S -> j != 0. + move/(hasPn nrS); apply: contraNneq => ->. + by rewrite /cfReal -(prTIred_aut ddA) aut_Iirr0. +have oS1sigma phi: phi \in S1 -> orthogonal (R1 phi) (map sigma (irr W)). + move=> S1phi; have [zR1 oR1] := R1ok _ S1phi; set psi := _ - _=> Dpsi. + suffices o_psi_sigma: orthogonal (tau psi) (map sigma (irr W)). + apply/orthogonalP=> aa sw R1aa Wsw; have:= orthoPl o_psi_sigma _ Wsw. + have{sw Wsw} /dirrP[bw [lw ->]]: sw \in dirr G. + have [_ /(cycTIirrP defW)[i [j ->]] ->] := mapP Wsw. + exact: cycTIiso_dirr. + have [|ba [la Daa]] := vchar_norm1P (zR1 _ R1aa). + by have [_ -> //] := orthonormalP oR1; rewrite eqxx. + rewrite Daa cfdotZl !cfdotZr cfdot_irr. + case: eqP => [<-{lw} | _ _]; last by rewrite !mulr0. + move/(congr1 ( *%R ((-1) ^+ (ba (+) bw))^*)); rewrite mulr0 => /eqP/idPn[]. + rewrite mulrA -rmorphM -signr_addb {bw}addbK -cfdotZr -{ba la}Daa. + rewrite Dpsi -(eq_bigr _ (fun _ _ => scale1r _)). + by rewrite cfproj_sum_orthonormal ?oner_eq0. + apply/orthoPl=> _ /mapP[_ /(cycTIirrP defW)[i [j ->]] ->]; rewrite -/w_. + pose w1 := #|W1|; pose w2 := #|W2|. + have minw_gt2: (2 < minn w1 w2)%N. + have [[_ ntW1 _ _] [ntW2 _ _] _] := prDade_prTI ddA. + rewrite -(dprod_card defW) odd_mul => /andP[oddW1 oddW2]. + by rewrite leq_min !odd_gt2 ?cardG_gt1. + apply: contraTeq (minw_gt2) => ntNC; rewrite -leqNgt. + pose NC := cyclicTI_NC ddA. + have /andP[/=/irrP[l Dphi] Sphi]: phi \in [predI irr L & S]. + by rewrite mem_filter in S1phi. + have Zpsi: psi \in 'Z[S, L^#]. + rewrite sub_aut_zchar ?mem_zchar_on ?orthogonal_free ?ccS ?cfun_onG //. + by move=> ? /sSS0/seqInd_vcharW. + have NCpsi_le2: (NC (tau psi) <= 2)%N. + have{Itau} [Itau Ztau] := Itau. + suff: '[tau psi] <= 2%:R by apply: cycTI_NC_norm; apply: zcharW (Ztau _ _). + rewrite Itau // cfnormBd; first by rewrite cfnorm_conjC Dphi cfnorm_irr. + have /pairwise_orthogonalP[_ -> //] := orthoS; first exact: ccS. + by rewrite eq_sym (hasPn nrS). + apply: leq_trans (NCpsi_le2). + have: (0 < NC (tau psi) < 2 * minn w1 w2)%N. + rewrite -(subnKC minw_gt2) (leq_ltn_trans NCpsi_le2) // andbT lt0n. + by apply/existsP; exists (i, j); rewrite /= topredE inE. + apply: cycTI_NC_minn (ddA) _ _ => x Vx. + rewrite Dade_id; last by rewrite defA0 inE orbC mem_class_support. + rewrite defSA in Zpsi; rewrite (cfun_on0 (zchar_on Zpsi)) // -in_setC. + by apply: subsetP (subsetP (prDade_supp_disjoint ddA) x Vx); rewrite setCS. +exists R; split=> [|phi w S1phi irr_w|j]; first 1 last. +- rewrite /R; case: pickP => [j /eqP Dphi | _ /=]. + by case/nandP: S1phi; right; rewrite /= Dphi (prTIred_not_irr ddA). + apply/orthoPr=> aa R1aa; rewrite (orthogonalP (oS1sigma phi _)) ?map_f //. + by rewrite mem_filter andbC. +- by rewrite /R; case: pickP => /= [k /eqP/(prTIred_inj ddA)-> | /(_ j)/eqP]. +have Zw i j: w_ i j \in 'Z[irr W] by exact: irr_vchar. +have{oS1sigma} oS1dsw psi j: psi \in S1 -> orthogonal (R1 psi) (dsw _ j). + move/oS1sigma/orthogonalP=> opsiW. + apply/orthogonalP=> aa _ R1aa /codomP[i ->]. + by rewrite cfdotZr opsiW ?map_f ?mem_irr ?mulr0. +have odsw j1 j2: j1 != j2 -> orthogonal (dsw _ j1) (dsw _ j2). + move/negPf=> j2'1; apply/orthogonalP=> _ _ /codomP[i1 ->] /codomP[i2 ->]. + by rewrite cfdotZl cfdotZr (cfdot_cycTIiso ddA) j2'1 andbF !mulr0. +split=> // [|phi Sphi|phi xi Sphi Sxi]. +- by split=> // phi /sSS0; exact: seqInd_char. +- rewrite /R; case: pickP => [j /eqP Dphi /= | /inS1/(_ Sphi)/R1ok//]. + have nz_j: j != 0 by rewrite Smu_nz -?Dphi. + have [Isig Zsig]: {in 'Z[irr W], isometry sigma, to 'Z[irr G]}. + exact: cycTI_Zisometry. + split=> [aa | |]. + - rewrite mem_cat -map_comp => /orP. + by case=> /codomP[i ->]; rewrite ?rpredN rpredZsign Zsig. + - rewrite orthonormal_cat orthogonal_oppr odsw ?andbT; last first. + rewrite -(inj_eq (prTIred_inj ddA)) (prTIred_aut ddA) -/mu -Dphi. + by rewrite eq_sym (hasPn nrS). + suffices oNdsw k: orthonormal (dsw j k). + by rewrite map_orthonormal ?oNdsw //; apply: in2W; exact: opp_isometry. + apply/orthonormalP; split=> [|_ _ /codomP[i1 ->] /codomP[i2 ->]]. + rewrite map_inj_uniq ?enum_uniq // => i1 i2 /(can_inj (signrZK _))/eqP. + by rewrite (cycTIiso_eqE ddA) eqxx andbT => /eqP. + rewrite cfdotZl cfdotZr rmorph_sign signrMK (cfdot_cycTIiso ddA). + by rewrite -(cycTIiso_eqE ddA) (inj_eq (can_inj (signrZK _))). + have [Tstruct [tau1 Dtau1 [_ Dtau]]] := uniform_prTIred_coherent ddA nz_j. + have{Tstruct} [/orthogonal_free freeT _ ccT _ _] := Tstruct. + have phi1c: (phi 1%g)^* = phi 1%g := conj_Cnat (Cnat_seqInd1 (sSS0 _ Sphi)). + rewrite -[tau _]Dtau; last first. + rewrite zcharD1E !cfunE phi1c subrr Dphi eqxx andbT. + by rewrite rpredB ?mem_zchar ?ccT ?image_f ?inE // nz_j eqxx. + rewrite linearB Dphi -(prTIred_aut ddA) !Dtau1 -/w_ -/sigma -/(delta j). + by rewrite big_cat /= !big_map !raddf_sum. +rewrite /R; case: pickP => [j1 /eqP Dxi | /inS1/(_ Sxi)S1xi]; last first. + case: pickP => [j2 _ _ | /inS1/(_ Sphi)S1phi]; last exact: R1ortho. + by rewrite orthogonal_catr orthogonal_oppr !oS1dsw. +case: pickP => [j2 /eqP Dphi | /inS1/(_ Sphi)S1phi _]; last first. + by rewrite orthogonal_sym orthogonal_catr orthogonal_oppr !oS1dsw. +case/andP=> /and3P[/= /eqP o_xi_phi /eqP o_xi_phi'] _ _. +have /eqP nz_xi: '[xi] != 0 := cfnorm_seqInd_neq0 nsKL (sSS0 _ Sxi). +have [Dj1 | j2'1] := eqVneq j1 j2. + by rewrite {2}Dxi Dj1 -Dphi o_xi_phi in nz_xi. +have [Dj1 | j2c'1] := eqVneq j1 (conjC_Iirr j2). + by rewrite {2}Dxi Dj1 /mu (prTIred_aut ddA) -/mu -Dphi o_xi_phi' in nz_xi. +rewrite orthogonal_catl andbC orthogonal_oppl. +rewrite !orthogonal_catr !orthogonal_oppr !odsw ?(inj_eq (aut_Iirr_inj _)) //. +by rewrite (inv_eq (@conjC_IirrK _ _)). +Qed. + +Section SubCoherentProperties. + +Variables (L G : {group gT}) (S : seq 'CF(L)) (R : 'CF(L) -> seq 'CF(G)). +Variable tau : {linear 'CF(L) -> 'CF(G)}. +Hypothesis cohS : subcoherent S tau R. + +Lemma nil_coherent A : coherent [::] A tau. +Proof. +exists [additive of 'Ind[G]]; split=> [|u /zchar_span]; last first. + by rewrite span_nil memv0 => /eqP-> /=; rewrite !raddf0. +split=> [u v | u] /zchar_span; rewrite span_nil memv0 => /eqP->. + by rewrite raddf0 !cfdot0l. +by rewrite raddf0 rpred0. +Qed. + +Lemma subset_subcoherent S1 : cfConjC_subset S1 S -> subcoherent S1 tau R. +Proof. +case=> uS1 sS1 ccS1; have [[N_S nrS _] Itau oS defR oR] := cohS. +split; last 1 [exact: sub_in1 defR | exact: sub_in2 oR]. +- split=> // [xi /sS1/N_S// | ]. + by apply/hasPn; exact: sub_in1 (hasPn nrS). +- by apply: sub_iso_to Itau => //; apply: zchar_subset. +exact: sub_pairwise_orthogonal oS. +Qed. + +Lemma subset_ortho_subcoherent S1 chi : + {subset S1 <= S} -> chi \in S -> chi \notin S1 -> orthogonal S1 chi. +Proof. +move=> sS1S Schi S1'chi; apply/orthoPr=> phi S1phi; have Sphi := sS1S _ S1phi. +have [_ _ /pairwise_orthogonalP[_ -> //]] := cohS. +by apply: contraNneq S1'chi => <-. +Qed. + +Lemma subcoherent_split chi beta : + chi \in S -> beta \in 'Z[irr G] -> + exists2 X, X \in 'Z[R chi] + & exists Y, [/\ beta = X - Y, '[X, Y] = 0 & orthogonal Y (R chi)]. +Proof. +move=> Schi Zbeta; have [_ _ _ /(_ _ Schi)[ZR oRR _] _] := cohS. +have [X RX [Y [defXY oXY oYR]]] := orthogonal_split (R chi) beta. +exists X; last first. + by exists (- Y); rewrite opprK (orthogonal_oppl Y) cfdotNr oXY oppr0. +have [_ -> ->] := orthonormal_span oRR RX; rewrite big_seq rpred_sum // => a Ra. +rewrite rpredZ_Cint ?mem_zchar // -(addrK Y X) -defXY. +by rewrite cfdotBl (orthoPl oYR) // subr0 Cint_cfdot_vchar // ZR. +Qed. + +(* This is Peterfalvi (5.4). *) +(* The assumption X \in 'Z[R chi] has been weakened to '[X, Y] = 0; this *) +(* stronger form of the lemma is needed to strengthen the proof of (5.6.3) so *) +(* that it can actually be reused in (9.11.8), as the text suggests. *) +Lemma subcoherent_norm chi psi (tau1 : {additive 'CF(L) -> 'CF(G)}) X Y : + [/\ chi \in S, psi \in 'Z[irr L] & orthogonal (chi :: chi^*)%CF psi] -> + let S0 := chi - psi :: chi - chi^*%CF in + {in 'Z[S0], isometry tau1, to 'Z[irr G]} -> + tau1 (chi - chi^*)%CF = tau (chi - chi^*)%CF -> + [/\ tau1 (chi - psi) = X - Y, '[X, Y] = 0 & orthogonal Y (R chi)] -> + [/\ (*a*) '[chi] <= '[X] + & (*b*) '[psi] <= '[Y] -> + [/\ '[X] = '[chi], '[Y] = '[psi] + & exists2 E, subseq E (R chi) & X = \sum_(xi <- E) xi]]. +Proof. +case=> Schi Zpsi /and3P[/andP[/eqP ochi_psi _] /andP[/eqP ochic_psi _] _] S0. +move=> [Itau1 Ztau1] tau1dchi [defXY oXY oYR]. +have [[ZS nrS ccS] [tS Zt] oS /(_ _ Schi)[ZR o1R tau_dchi] _] := cohS. +have [/=/andP[S'0 uS] oSS] := pairwise_orthogonalP oS. +have [nRchi Schic] := (hasPn nrS _ Schi, ccS _ Schi). +have ZtauS00: tau1 S0`_0 \in 'Z[irr G] by rewrite Ztau1 ?mem_zchar ?mem_head. +have{ZtauS00} [X1 R_X1 [Y1 [dXY1 oXY1 oY1R]]] := subcoherent_split Schi ZtauS00. +have [uR _] := orthonormalP o1R; have [a Za defX1] := zchar_expansion uR R_X1. +have dotS00R xi: xi \in R chi -> '[tau1 S0`_0, xi] = a xi. + move=> Rxi; rewrite dXY1 cfdotBl (orthoPl oY1R) // subr0. + by rewrite defX1 cfproj_sum_orthonormal. +have nchi: '[chi] = \sum_(xi <- R chi) a xi. + transitivity '[S0`_0, S0`_1]. + rewrite [rhs in _ = rhs]cfdotC cfdotBl !cfdotBr ochi_psi ochic_psi. + by rewrite (oSS _ _ Schic) // !subr0 -cfdotC. + rewrite -Itau1 ?mem_zchar ?mem_nth // tau1dchi tau_dchi cfdot_sumr. + exact: eq_big_seq. +have nX: '[X1] <= '[X] ?= iff (X == X1). + rewrite -subr_eq0 -{1 2}[X](subrK X1) cfnormDd. + rewrite -lerif_subLR subrr -cfnorm_eq0 eq_sym. + by apply: lerif_eq; apply: cfnorm_ge0. + rewrite defX1 cfdot_sumr big1_seq // => xi Rxi; rewrite cfdotZr cfdotBl. + rewrite cfproj_sum_orthonormal // -[X](subrK Y) cfdotDl -defXY dotS00R //. + by rewrite (orthoPl oYR) // addr0 subrr mulr0. +pose is01a xi := a xi == (a xi != 0)%:R. +have leXa xi: a xi <= `|a xi| ^+ 2 ?= iff is01a xi. + apply/lerifP; rewrite /is01a; have /CintP[b ->] := Za xi. + rewrite -intr_norm -rmorphX ltr_int intr_eq0 pmulrn !eqr_int. + by case: b => [[|[|n]]|] //=; rewrite ltr_eexpr. +have{nchi nX} part_a: '[chi] <= '[X] ?= iff all is01a (R chi) && (X == X1). + apply: lerif_trans nX; rewrite nchi defX1 cfnorm_sum_orthonormal //. + by rewrite -big_all !(big_tnth _ _ (R chi)) big_andE; apply: lerif_sum. +split=> [|/lerif_eq part_b]; first by case: part_a. +have [_ /esym] := lerif_add part_a part_b; rewrite -!cfnormBd // -defXY. +rewrite Itau1 ?mem_zchar ?mem_head // eqxx => /andP[a_eq /eqP->]. +split=> //; first by apply/esym/eqP; rewrite part_a. +have{a_eq} [/allP a01 /eqP->] := andP a_eq; rewrite defX1. +exists (filter [preim a of predC1 0] (R chi)); first exact: filter_subseq. +rewrite big_filter [rhs in _ = rhs]big_mkcond /=. +by apply: eq_big_seq => xi /a01/eqP{1}->; rewrite scaler_nat -mulrb. +Qed. + +(* This is Peterfalvi (5.5). *) +Lemma coherent_sum_subseq chi (tau1 : {additive 'CF(L) -> 'CF(G)}) : + chi \in S -> + {in 'Z[chi :: chi^*%CF], isometry tau1, to 'Z[irr G]} -> + tau1 (chi - chi^*%CF) = tau (chi - chi^*%CF) -> + exists2 E, subseq E (R chi) & tau1 chi = \sum_(a <- E) a. +Proof. +set S1 := (chi :: _) => Schi [iso_t1 Zt1] t1cc'. +have freeS1: free S1. + have [[_ nrS ccS] _ oS _ _] := cohS. + by rewrite orthogonal_free ?(conjC_pair_orthogonal ccS). +have subS01: {subset 'Z[chi - 0 :: chi - chi^*%CF] <= 'Z[S1]}. + apply: zchar_trans setT _; apply/allP; rewrite subr0 /= andbT. + by rewrite rpredB !mem_zchar ?inE ?eqxx ?orbT. +have Zt1c: tau1 (chi - 0) \in 'Z[irr G]. + by rewrite subr0 Zt1 ?mem_zchar ?mem_head. +have [X R_X [Y defXY]] := subcoherent_split Schi Zt1c. +case/subcoherent_norm: (defXY); last 2 [by []]. +- by rewrite /orthogonal /= !cfdot0r eqxx Schi cfun0_zchar. +- by split; [apply: sub_in2 iso_t1 | apply: sub_in1 Zt1]. +move=> _ [|_ /eqP]; rewrite cfdot0l ?cfnorm_ge0 // cfnorm_eq0 => /eqP Y0. +case=> E sER defX; exists E => //; rewrite -defX -[X]subr0 -Y0 -[chi]subr0. +by case: defXY. +Qed. + +(* A reformulation of (5.5) that is more convenient to use. *) +Corollary mem_coherent_sum_subseq S1 chi (tau1 : {additive 'CF(L) -> 'CF(G)}) : + cfConjC_subset S1 S -> coherent_with S1 L^# tau tau1 -> chi \in S1 -> + exists2 E, subseq E (R chi) & tau1 chi = \sum_(a <- E) a. +Proof. +move=> uccS1 [Itau1 Dtau1] S1chi; have [uS1 sS1S ccS1] := uccS1. +have S1chi_s: chi^*%CF \in S1 by exact: ccS1. +apply: coherent_sum_subseq; first exact: sS1S. + by apply: sub_iso_to Itau1 => //; apply: zchar_subset; apply/allP/and3P. +apply: Dtau1; rewrite sub_aut_zchar ?zchar_onG ?mem_zchar // => phi /sS1S. +by have [[charS _ _] _ _ _ _] := cohS => /charS/char_vchar. +Qed. + +(* A frequently used consequence of (5.5). *) +Corollary coherent_ortho_supp S1 chi (tau1 : {additive 'CF(L) -> 'CF(G)}) : + cfConjC_subset S1 S -> coherent_with S1 L^# tau tau1 -> + chi \in S -> chi \notin S1 -> + orthogonal (map tau1 S1) (R chi). +Proof. +move=> uccS1 cohS1 Schi S1'chi; have [uS1 sS1S ccS1] := uccS1. +apply/orthogonalP=> _ mu /mapP[phi S1phi ->] Rmu; have Sphi := sS1S _ S1phi. +have [e /mem_subseq Re ->] := mem_coherent_sum_subseq uccS1 cohS1 S1phi. +rewrite cfdot_suml big1_seq // => xi {e Re}/Re Rxi. +apply: orthogonalP xi mu Rxi Rmu; have [_ _ _ _ -> //] := cohS. +rewrite /orthogonal /= !andbT cfdot_conjCr fmorph_eq0. +by rewrite !(orthoPr (subset_ortho_subcoherent sS1S _ _)) ?ccS1 ?eqxx. +Qed. + +(* An even more frequently used corollary of the corollary above. *) +Corollary coherent_ortho S1 S2 (tau1 tau2 : {additive 'CF(L) -> 'CF(G)}) : + cfConjC_subset S1 S -> coherent_with S1 L^# tau tau1 -> + cfConjC_subset S2 S -> coherent_with S2 L^# tau tau2 -> + {subset S2 <= [predC S1]} -> + orthogonal (map tau1 S1) (map tau2 S2). +Proof. +move=> uccS1 cohS1 uccS2 cohS2 S1'2; have [_ sS2S _] := uccS2. +apply/orthogonalP=> mu _ S1mu /mapP[phi S2phi ->]. +have [e /mem_subseq Re ->] := mem_coherent_sum_subseq uccS2 cohS2 S2phi. +rewrite cfdot_sumr big1_seq // => xi {e Re}/Re; apply: orthogonalP mu xi S1mu. +by apply: coherent_ortho_supp; rewrite ?sS2S //; apply: S1'2. +Qed. + +(* A glueing lemma exploiting the corollary above. *) +Lemma bridge_coherent S1 S2 (tau1 tau2 : {additive 'CF(L) -> 'CF(G)}) chi phi : + cfConjC_subset S1 S -> coherent_with S1 L^# tau tau1 -> + cfConjC_subset S2 S -> coherent_with S2 L^# tau tau2 -> + {subset S2 <= [predC S1]} -> + [/\ chi \in S1, phi \in 'Z[S2] & chi - phi \in 'CF(L, L^#)] -> + tau (chi - phi) = tau1 chi - tau2 phi -> + coherent (S1 ++ S2) L^# tau. +Proof. +move=> uccS1 cohS1 uccS2 cohS2 S1'2 [S1chi S2phi chi1_phi] tau_chi_phi. +do [rewrite cfunD1E !cfunE subr_eq0 => /eqP] in chi1_phi. +have [[uS1 sS1S _] [uS2 sS2S _]] := (uccS1, uccS2). +have [[[Itau1 Ztau1] Dtau1] [[Itau2 Ztau2] Dtau2]] := (cohS1, cohS2). +have [[N_S1 _ _] _ oS11 _ _] := subset_subcoherent uccS1. +have [_ _ oS22 _ _] := subset_subcoherent uccS2. +have{N_S1} nz_chi1: chi 1%g != 0; last move/mem_zchar in S1chi. + by rewrite char1_eq0 ?N_S1 //; have [/memPn->] := andP oS11. +have oS12: orthogonal S1 S2. + apply/orthogonalP=> xi1 xi2 Sxi1 Sxi2; apply: orthoPr xi1 Sxi1. + by rewrite subset_ortho_subcoherent ?sS2S //; apply: S1'2. +pose S3 := S1 ++ S2; pose Y := map tau1 S1 ++ map tau2 S2. +have oS33: pairwise_orthogonal S3 by rewrite pairwise_orthogonal_cat oS11 oS22. +have oYY: pairwise_orthogonal Y. + by rewrite pairwise_orthogonal_cat !map_pairwise_orthogonal ?coherent_ortho. +have Z_Y: {subset Y <= 'Z[irr G]}. + move=> xi_tau; rewrite mem_cat => /orP[] /mapP[xi Sxi ->] {xi_tau}. + by rewrite Ztau1 ?mem_zchar. + by rewrite Ztau2 ?mem_zchar. +have nY: map cfnorm Y = map cfnorm (S1 ++ S2). + rewrite !map_cat -!map_comp; congr (_ ++ _). + by apply/eq_in_map => xi S1xi; rewrite /= Itau1 ?mem_zchar. + by apply/eq_in_map => xi S2xi; rewrite /= Itau2 ?mem_zchar. +have [tau3 /eqP defY ZItau3] := Zisometry_of_cfnorm oS33 oYY nY Z_Y. +exists tau3; split=> {ZItau3}// xi; rewrite zcharD1E /= => /andP[S3xi]. +have{defY} [defY1 defY2]: {in S1, tau3 =1 tau1} /\ {in S2, tau3 =1 tau2}. + have:= defY; rewrite map_cat eqseq_cat ?size_map // => /andP[]. + by split; apply/eq_in_map/eqP. +have{S3xi} [xi1 [xi2 [Sxi1 Sxi2 ->] {xi}]]: + exists xi1, exists xi2, [/\ xi1 \in 'Z[S1], xi2 \in 'Z[S2] & xi = xi1 + xi2]. +- have uS3 := free_uniq (orthogonal_free oS33). + have [z Zz ->] := zchar_expansion uS3 S3xi; rewrite big_cat. + pose Y_ S4 := \sum_(mu <- S4) z mu *: mu. + suffices ZS_Y S4: Y_ S4 \in 'Z[S4] by exists (Y_ S1), (Y_ S2). + by rewrite /Y_ big_seq rpred_sum // => psi /mem_zchar/rpredZ_Cint->. +rewrite cfunE addrC addr_eq0 linearD => /eqP xi2_1. +transitivity (tau1 xi1 + tau2 xi2). + have [z1 Zz1 ->] := zchar_nth_expansion Sxi1. + have [z2 Zz2 ->] := zchar_nth_expansion Sxi2. + rewrite !raddf_sum; congr(_ + _); apply: eq_bigr => i _; + by rewrite !raddfZ_Cint -?(defY1, defY2) ?mem_nth. +have Z_S1_1 zeta: zeta \in 'Z[S1] -> zeta 1%g \in Cint. + move=> Szeta; rewrite Cint_vchar1 // (zchar_sub_irr _ Szeta) {zeta Szeta}//. + by move=> zeta /sS1S Szeta; apply: char_vchar; have [[->]] := cohS. +have [Zchi1 Zxi1] := (Z_S1_1 _ S1chi, Z_S1_1 _ Sxi1). +apply: (scalerI nz_chi1); rewrite scalerDr -!raddfZ_Cint // scalerDr. +rewrite -[_ *: _](subrK (xi1 1%g *: chi)) raddfD -[_ + _]addrA. +rewrite -[rhs in _ = tau rhs]addrA linearD Dtau1; last first. + by rewrite zcharD1E rpredB ?rpredZ_Cint ?Z_S1_1 //= !cfunE mulrC subrr. +congr (_ + _); rewrite -[_ *: xi2](addKr (xi1 1%g *: phi)) (raddfD tau2). +rewrite [_ + _]addrA [rhs in tau rhs]addrA linearD; congr (_ + _); last first. + rewrite Dtau2 // zcharD1E rpredD ?rpredZ_Cint ?Z_S1_1 //=. + by rewrite !cfunE mulrC xi2_1 chi1_phi mulrN subrr. +rewrite raddfN (raddfZ_Cint tau1) // (raddfZ_Cint tau2) // -!scalerBr linearZ. +by congr (_ *: _). +Qed. + +(* This is essentially Peterfalvi (5.6.3), which gets reused in (9.11.8). *) +Lemma extend_coherent_with S1 (tau1 : {additive 'CF(L) -> 'CF(G)}) chi phi a X : + cfConjC_subset S1 S -> coherent_with S1 L^# tau tau1 -> + [/\ phi \in S1, chi \in S & chi \notin S1] -> + [/\ a \in Cint, chi 1%g = a * phi 1%g & '[X, a *: tau1 phi] = 0] -> + tau (chi - a *: phi) = X - a *: tau1 phi -> + coherent (chi :: chi^*%CF :: S1) L^# tau. +Proof. +set beta := _ - _ => sS10 cohS1 [S1phi Schi S1'chi] [Za chi1 oXaphi] tau_beta. +have [[uS1 sS1S ccS1] [[Itau1 Ztau1] _]] := (sS10, cohS1). +have [[N_S nrS ccS] ZItau _ R_P _] := cohS; have [Itau Ztau] := ZItau. +have [Sphi [ZR o1R sumR]] := (sS1S _ S1phi, R_P _ Schi). +have Zbeta: beta \in 'Z[S, L^#]. + by rewrite zcharD1E !cfunE -chi1 subrr rpredB ?scale_zchar ?mem_zchar /=. +have o_aphi_R: orthogonal (a *: tau1 phi) (R chi). + have /orthogonalP oS1R := coherent_ortho_supp sS10 cohS1 Schi S1'chi. + by apply/orthoPl=> xi Rxi; rewrite cfdotZl oS1R ?map_f ?mulr0. +have /orthoPl o_chi_S1: orthogonal chi S1. + by rewrite orthogonal_sym subset_ortho_subcoherent. +have Zdchi: chi - chi^*%CF \in 'Z[S, L^#]. + by rewrite sub_aut_zchar ?zchar_onG ?mem_zchar ?ccS // => xi /N_S/char_vchar. +have [||_] := subcoherent_norm _ _ (erefl _) (And3 tau_beta oXaphi o_aphi_R). +- rewrite Schi rpredZ_Cint ?char_vchar ?N_S /orthogonal //= !cfdotZr. + by rewrite cfdot_conjCl !o_chi_S1 ?ccS1 // conjC0 !mulr0 !eqxx. +- apply: sub_iso_to ZItau; [apply: zchar_trans_on; apply/allP | exact: zcharW]. + by rewrite /= Zbeta Zdchi. +case=> [|nX _ [e Re defX]]; first by rewrite !cfnormZ Itau1 ?mem_zchar. +have uR: uniq (R chi) by have [] := orthonormalP o1R. +have{uR} De: e = filter (mem e) (R chi) by apply/subseq_uniqP. +pose ec := filter [predC e] (R chi); pose Xc := - \sum_(xi <- ec) xi. +have defR: perm_eq (e ++ ec) (R chi) by rewrite De perm_filterC. +pose S2 := chi :: chi^*%CF; pose X2 := X :: Xc. +have{nrS} uS2: uniq S2 by rewrite /= andbT inE eq_sym (hasPn nrS). +have sS20: cfConjC_subset S2 S. + by split=> //; apply/allP; rewrite /= ?cfConjCK ?inE ?eqxx ?orbT // ccS Schi. +have oS2: pairwise_orthogonal S2 by have [] := subset_subcoherent sS20. +have nz_chi: chi != 0 by rewrite eq_sym; have [/norP[]] := andP oS2. +have o_chi_chic: '[chi, chi^*] = 0 by have [_ /andP[/andP[/eqP]]] := and3P oS2. +have def_XXc: X - Xc = tau (chi - chi^*%CF). + by rewrite opprK defX -big_cat sumR; apply: eq_big_perm. +have oXXc: '[X, Xc] = 0. + have /span_orthogonal o_e_ec: orthogonal e ec. + by move: o1R; rewrite -(eq_orthonormal defR) orthonormal_cat => /and3P[]. + by rewrite defX /Xc !big_seq o_e_ec ?rpredN ?rpred_sum // => xi /memv_span. +have{o_chi_chic} nXc: '[Xc] = '[chi^*]. + by apply: (addrI '[X]); rewrite -cfnormBd // nX def_XXc Itau // cfnormBd. +have{oXXc} oX2: pairwise_orthogonal X2. + rewrite /pairwise_orthogonal /= oXXc eqxx !inE !(eq_sym 0) -!cfnorm_eq0. + by rewrite nX nXc cfnorm_conjC cfnorm_eq0 orbb nz_chi. +have{nX nXc} nX2: map cfnorm X2 = map cfnorm S2 by congr [:: _; _]. +have [|tau2 [tau2X tau2Xc] Itau2] := Zisometry_of_cfnorm oS2 oX2 nX2. + apply/allP; rewrite /= defX De rpredN !big_seq. + by rewrite !rpred_sum // => xi; rewrite mem_filter => /andP[_ /ZR]. +have{Itau2} cohS2: coherent_with S2 L^# tau tau2. + split=> // psi; rewrite zcharD1E => /andP[/zchar_expansion[//|z Zz ->]]. + rewrite big_cons big_seq1 !cfunE conj_Cnat ?Cnat_char1 ?N_S // addrC addr_eq0. + rewrite -mulNr (inj_eq (mulIf _)) ?char1_eq0 ?N_S // => /eqP->. + by rewrite scaleNr -scalerBr !raddfZ_Cint // raddfB /= tau2X tau2Xc -def_XXc. +have: tau beta = tau2 chi - tau1 (a *: phi) by rewrite tau2X raddfZ_Cint. +apply: (bridge_coherent sS20 cohS2 sS10 cohS1) => //. + by apply/hasPn; rewrite has_sym !negb_or S1'chi (contra (ccS1 _)) ?cfConjCK. +by rewrite mem_head (zchar_on Zbeta) rpredZ_Cint ?mem_zchar. +Qed. + +(* This is Peterfalvi (5.6). *) +Lemma extend_coherent S1 xi1 chi : + cfConjC_subset S1 S -> [/\ xi1 \in S1, chi \in S & chi \notin S1] -> + [/\ (*a*) coherent S1 L^# tau, + (*b*) (xi1 1%g %| chi 1%g)%C + & (*c*) 2%:R * chi 1%g * xi1 1%g < \sum_(xi <- S1) xi 1%g ^+ 2 / '[xi]] -> + coherent (chi :: chi^*%CF :: S1) L^# tau. +Proof. +move=> ccsS1S [S1xi1 Schi notS1chi] [[tau1 cohS1] xi1_dv_chi1 ub_chi1]. +have [[uS1 sS1S ccS1] [[Itau1 Ztau1] Dtau1]] := (ccsS1S, cohS1). +have{xi1_dv_chi1} [a Za chi1] := dvdCP _ _ xi1_dv_chi1. +have [[N_S nrS ccS] ZItau oS R_P oR] := cohS; have [Itau Ztau] := ZItau. +have [Sxi1 [ZRchi o1Rchi sumRchi]] := (sS1S _ S1xi1, R_P _ Schi). +have ocS1 xi: xi \in S1 -> '[chi, xi] = 0. + by apply: orthoPl; rewrite orthogonal_sym subset_ortho_subcoherent. +have /andP[/memPn/=nzS _] := oS; have [Nchi nz_chi] := (N_S _ Schi, nzS _ Schi). +have oS1: pairwise_orthogonal S1 by exact: sub_pairwise_orthogonal oS. +have [freeS freeS1] := (orthogonal_free oS, orthogonal_free oS1). +have nz_nS1 xi: xi \in S1 -> '[xi] != 0 by rewrite cfnorm_eq0 => /sS1S/nzS. +have nz_xi11: xi1 1%g != 0 by rewrite char1_eq0 ?N_S ?nzS. +have inj_tau1: {in 'Z[S1] &, injective tau1} := Zisometry_inj Itau1. +have Z_S1: {subset S1 <= 'Z[S1]} by move=> xi /mem_zchar->. +have inj_tau1_S1: {in S1 &, injective tau1} := sub_in2 Z_S1 inj_tau1. +pose a_ t1xi := S1`_(index t1xi (map tau1 S1)) 1%g / xi1 1%g / '[t1xi]. +have a_E xi: xi \in S1 -> a_ (tau1 xi) = xi 1%g / xi1 1%g / '[xi]. + by move=> S1xi; rewrite /a_ nth_index_map // Itau1 ?Z_S1. +have a_xi1 : a_ (tau1 xi1) = '[xi1]^-1 by rewrite a_E // -mulrA mulVKf //. +have Zachi: chi - a *: xi1 \in 'Z[S, L^#]. + by rewrite zcharD1E !cfunE -chi1 subrr rpredB ?scale_zchar ?mem_zchar /=. +have Ztau_achi := zcharW (Ztau _ Zachi). +have [X R_X [Y defXY]] := subcoherent_split Schi Ztau_achi. +have [eqXY oXY oYRchi] := defXY; pose X1 := map tau1 (in_tuple S1). +have oX1: pairwise_orthogonal X1 by exact: map_pairwise_orthogonal. +have N_S1_1 xi: xi \in S1 -> xi 1%g \in Cnat by move/sS1S/N_S/Cnat_char1. +have oRchiX1 psi: psi \in 'Z[R chi] -> orthogonal psi X1. + move/zchar_span=> Rpsi; apply/orthoPl=> chi2 /memv_span. + by apply: span_orthogonal Rpsi; rewrite orthogonal_sym coherent_ortho_supp. +have [lam Zlam [Z oZS1 defY]]: + exists2 lam, lam \in Cint & exists2 Z : 'CF(G), orthogonal Z (map tau1 S1) & + Y = a *: tau1 xi1 - lam *: (\sum_(xi <- X1) a_ xi *: xi) + Z. +- pose lam := a * '[xi1] - '[Y, tau1 xi1]; exists lam. + rewrite rpredD ?mulr_natl ?rpredN //. + by rewrite rpredM // CintE Cnat_cfdot_char ?N_S. + rewrite Cint_cfdot_vchar ?Ztau1 ?Z_S1 // -(subrK X Y) -opprB -eqXY addrC. + by rewrite rpredB // (zchar_trans ZRchi). + set Z' := _ - _; exists (Y - Z'); last by rewrite addrC subrK. + have oXtau1 xi: xi \in S1 -> '[Y, tau1 xi] = - '[X - Y, tau1 xi]. + move=> S1xi; rewrite cfdotBl opprB. + by rewrite (orthogonalP (oRchiX1 X R_X) X) ?subr0 ?mem_head ?map_f. + apply/orthogonalP=> _ _ /predU1P[-> | //] /mapP[xi S1xi ->]. + rewrite !cfdotBl !cfdotZl Itau1 ?mem_zchar //. + rewrite cfproj_sum_orthogonal ?map_f // a_E // Itau1 ?Z_S1 //. + apply: (mulIf nz_xi11); rewrite divfK ?nz_nS1 // 2!mulrBl mulrA divfK //. + rewrite mul0r mulrBl opprB -addrA addrCA addrC !addrA !oXtau1 // !mulNr. + rewrite -(conj_Cnat (N_S1_1 _ S1xi)) -(conj_Cnat (N_S1_1 _ S1xi1)). + rewrite opprK [- _ + _]addrC -!(mulrC _^*) -!cfdotZr -cfdotBr. + rewrite -!raddfZ_Cnat ?N_S1_1 // -raddfB; set beta : 'CF(L) := _ - _. + have Zbeta: beta \in 'Z[S1, L^#]. + rewrite zcharD1E !cfunE mulrC subrr eqxx. + by rewrite rpredB ?rpredZ_Cint ?Z_S1 // CintE N_S1_1. + rewrite -eqXY Dtau1 // Itau // ?(zchar_subset sS1S) //. + rewrite cfdotBl !cfdotBr !cfdotZr !ocS1 // !mulr0 subrr add0r !cfdotZl. + by rewrite opprB addrAC subrK subrr. +have [|| leXchi _] := subcoherent_norm _ _ (erefl _) defXY. +- rewrite Schi scale_zchar ?char_vchar ?N_S /orthogonal //= !cfdotZr ocS1 //. + by rewrite -[xi1]cfConjCK cfdot_conjC ocS1 ?ccS1 // conjC0 mulr0 eqxx. +- apply: sub_iso_to ZItau; [apply: zchar_trans_on; apply/allP | exact: zcharW]. + rewrite /= Zachi sub_aut_zchar ?zchar_onG ?mem_zchar ?ccS //. + by move=> xi /N_S/char_vchar. +have{defY leXchi lam Z Zlam oZS1 ub_chi1} defY: Y = a *: tau1 xi1. + have nXY: '[X] + '[Y] = '[chi] + '[a *: xi1]. + by rewrite -!cfnormBd // ?cfdotZr ?ocS1 ?mulr0 // -eqXY Itau. + have{leXchi nXY}: '[Y] <= a ^+ 2 * '[xi1]. + by rewrite -(ler_add2l '[X]) nXY cfnormZ Cint_normK // ler_add2r. + rewrite defY cfnormDd; last first. + rewrite cfdotC (span_orthogonal oZS1) ?rmorph0 ?memv_span1 //. + rewrite big_seq memvB ?memvZ ?memv_suml ?memv_span ?map_f //. + by move=> theta S1theta; rewrite memvZ ?memv_span. + rewrite -subr_ge0 cfnormB cfnormZ Cint_normK // Itau1 ?Z_S1 //. + rewrite -2!addrA (opprD (_ * _)) addNKr cfnormZ Cint_normK // oppr_ge0. + rewrite cfnorm_sum_orthogonal //; set sum_a := \sum_(xi <- _) _. + rewrite -cfdotC cfdotC cfdotZl cfdotZr cfproj_sum_orthogonal ?map_f // a_xi1. + rewrite Itau1 ?Z_S1 // 3!rmorphM !(aut_Cint _ Za) fmorphV aut_Cint //. + rewrite -cfdotC -mulr2n 2!mulrA divfK ?nz_nS1 // -mulrnAr addrA => ub_lam. + have [lam0 | nz_lam] := eqVneq lam 0. + suffices /eqP->: Z == 0 by rewrite lam0 scale0r subr0 addr0. + rewrite -cfnorm_eq0 eqr_le cfnorm_ge0 andbT. + by rewrite lam0 -mulrA !mul0r subrr add0r in ub_lam. + set d := \sum_(xi <- _) _ in ub_chi1; pose b := 2%:R * chi 1%g * xi1 1%g / d. + have pos_S1_1 := Cnat_ge0 (Cnat_char1 (N_S _ (sS1S _ _))). + have xi11_gt0: 0 < xi1 1%g by rewrite ltr_def nz_xi11 pos_S1_1. + have d_gt0: 0 < d. + have a_xi_ge0 xi: xi \in S1 -> 0 <= xi 1%g ^+ 2 / '[xi]. + by move/pos_S1_1 => xi_1_pos; rewrite 2?mulr_ge0 // invr_ge0 cfnorm_ge0. + rewrite [d]big_seq; case defS1: {1 2}S1 S1xi1 => // [xi S1'] _. + have{defS1} S1xi: xi \in S1 by rewrite defS1 mem_head. + rewrite big_cons S1xi ltr_spaddl ?sumr_ge0 // ltr_def a_xi_ge0 //=. + by rewrite !mulf_neq0 ?invr_eq0 ?char1_eq0 -?cfnorm_eq0 ?nz_nS1 ?N_S ?sS1S. + have nz_d: d != 0 by rewrite eqr_le ltr_geF. + have b_gt0: 0 < b. + rewrite !pmulr_rgt0 ?ltr0n ?invr_gt0 // lt0r. + by rewrite Cnat_ge0 ?Cnat_char1 ?char1_eq0 ?N_S // nzS. + have{ub_chi1} b_lt1: b < 1 by rewrite ltr_pdivr_mulr ?mul1r. + have{ub_lam} ub_lam: lam ^+ 2 <= b * lam. + rewrite -(ler_pmul2r d_gt0) (mulrAC b) divfK //. + rewrite -[d](divfK (mulf_neq0 nz_xi11 nz_xi11)) chi1 mulr_natl -mulrnAl. + rewrite !mulrA 2!(mulrAC _ _ lam) 2?ler_pmul2r // -mulrA -expr2. + have ->: d / xi1 1%g ^+ 2 = sum_a. + rewrite big_distrl /sum_a big_map !big_seq; apply: eq_bigr => xi S1xi /=. + rewrite a_E // Itau1 ?Z_S1 //= (normr_idP _); last first. + by rewrite !(cfnorm_ge0, mulr_ge0, invr_ge0) ?pos_S1_1. + rewrite mulrAC 2!exprMn -!exprVn [p in p * '[xi]]mulrA. + by rewrite divfK ?nz_nS1. + rewrite -subr_ge0 -opprB oppr_ge0 (ler_trans _ ub_lam) //. + by rewrite (mulrC lam) -{1}[_ - _]addr0 ler_add2l cfnorm_ge0. + have lam_gt0: 0 < lam. + rewrite ltr_def nz_lam -(ler_pmul2l b_gt0) mulr0. + by apply: ler_trans ub_lam; rewrite -Cint_normK // mulr_ge0 ?normr_ge0. + rewrite ler_pmul2r // ltr_geF // in ub_lam. + rewrite (ltr_le_trans b_lt1) //; have:= lam_gt0. + have /CnatP[n ->]: lam \in Cnat by rewrite CnatEint Zlam ltrW. + by rewrite ltr0n ler1n. +by move: eqXY; rewrite defY; apply: extend_coherent_with => //; rewrite -defY. +Qed. + +(* This is Peterfalvi (5.7). *) +(* This is almost a superset of (1.4): we could use it to get a coherent *) +(* isometry, which would necessarily map irreducibles to signed irreducibles. *) +(* It would then only remain to show that the signs are chosen consistently, *) +(* by considering the degrees of the differences. *) +Lemma uniform_degree_coherence : + constant [seq chi 1%g | chi : 'CF(L) <- S] -> coherent S L^# tau. +Proof. +case defS: {1}S => /= [|chi S1] szS; first by rewrite defS; exact: nil_coherent. +have{szS} unifS xi: xi \in S -> xi 1%g = chi 1%g. + by rewrite defS => /predU1P[-> // | S'xi]; apply/eqP/(allP szS)/map_f. +have Schi: chi \in S by rewrite defS mem_head. +have [[N_S nrS ccS] IZtau oS R_P oR] := cohS; have [Itau Ztau] := IZtau. +have freeS := orthogonal_free oS. +have Zd: {in S &, forall xi1 xi2, xi1 - xi2 \in 'Z[S, L^#]}. + move=> xi1 xi2 Sxi1 Sxi2 /=. + by rewrite zcharD1E rpredB ?mem_zchar //= !cfunE !unifS ?subrr. +have [neq_chic Schic] := (hasPn nrS _ Schi, ccS _ Schi). +have [/andP[/memPn notS0 _] ooS] := pairwise_orthogonalP oS. +pose S' xi := [predD1 S & xi]; pose S'c xi := predD1 (S' xi) xi^*%CF. +have{oR} oR xi1 xi2: xi1 \in S -> xi2 \in S'c xi1 -> orthogonal (R xi1) (R xi2). + move=> Sxi1 /and3P[/= neq_xi21c neq_xi21 Sxi2]. + by rewrite orthogonal_sym oR // /orthogonal /= !ooS ?eqxx // ccS. +have oSc xi: xi \in S -> '[xi, xi^*] = 0. + by move=> Sxi; rewrite ooS ?ccS // -[_ == _]negbK eq_sym (hasPn nrS). +pose D xi := tau (chi - xi). +have Z_D xi: xi \in S -> D xi \in 'Z[irr G] by move/(Zd _ _ Schi)/Ztau/zcharW. +have /CnatP[N defN]: '[chi] \in Cnat by rewrite Cnat_cfdot_char ?N_S. +have dotD: {in S' chi &, forall xi1 xi2, '[D xi1, D xi2] = N%:R + '[xi1, xi2]}. +- move=> xi1 xi2 /andP[ne_xi1chi Sxi1] /andP[ne_xi2chi Sxi2]. + rewrite Itau ?Zd // cfdotBl !cfdotBr defN. + by rewrite 2?ooS // 1?eq_sym // opprB !subr0. +have /R_P[ZRchi o1Rchi defRchi] := Schi; have frRchi := orthonormal_free o1Rchi. +have szRchi: size (R chi) = (N + N)%N. + apply: (can_inj natCK); rewrite -cfnorm_orthonormal // -defRchi. + by rewrite dotD ?inE ?ccS ?(hasPn nrS) // cfnorm_conjC defN -natrD. +pose sub_Rchi X := exists2 E, subseq E (R chi) & X = \sum_(a <- E) a. +pose Xspec X := [/\ X \in 'Z[R chi], '[X]_G = N%:R & sub_Rchi X]. +pose Xi_spec X xi := X - D xi \in 'Z[R xi] /\ '[X, D xi] = N%:R. +have haveX xi: xi \in S'c chi -> exists2 X, Xspec X & Xi_spec X xi. + move=> S'xi; have /and3P[/= ne_xi_chi' ne_xi_chi Sxi] := S'xi. + have [neq_xi' Sxi'] := (hasPn nrS xi Sxi, ccS xi Sxi). + have [X RchiX [Y1 defXY1]] := subcoherent_split Schi (Z_D _ Sxi). + have [eqXY1 oXY1 oY1chi] := defXY1; have sRchiX := zchar_span RchiX. + have Z_Y1: Y1 \in 'Z[irr G]. + rewrite -[Y1](subrK X) -opprB -eqXY1 addrC rpredB ?Z_D //. + exact: (zchar_trans ZRchi). + have [X1 RxiX1 [Y defX1Y]] := subcoherent_split Sxi Z_Y1; pose Y2 := X + Y. + have [eqX1Y oX1Y oYxi] := defX1Y; pose D2 := tau (xi - chi). + have oY2Rxi: orthogonal Y2 (R xi). + apply/orthogonalP=> _ phi /predU1P[-> | //] Rxi_phi. + rewrite cfdotDl (orthoPl oYxi) // addr0. + by rewrite (span_orthogonal (oR _ _ _ S'xi)) // (memv_span Rxi_phi). + have{oY2Rxi} defX1Y2: [/\ D2 = X1 - Y2, '[X1, Y2] = 0 & orthogonal Y2 (R xi)]. + rewrite -opprB -addrA -opprB -eqX1Y -eqXY1 -linearN opprB cfdotC. + by rewrite (span_orthogonal oY2Rxi) ?conjC0 ?memv_span1 ?(zchar_span RxiX1). + have [||minX eqX1] := subcoherent_norm _ _ (erefl _) defXY1. + - by rewrite char_vchar ?N_S /orthogonal //= !ooS ?eqxx // eq_sym. + - apply: sub_iso_to IZtau; last exact: zcharW. + by apply: zchar_trans_on; apply/allP; rewrite /= !Zd. + have [||minX1 _]:= subcoherent_norm _ _ (erefl _) defX1Y2. + - rewrite char_vchar ?N_S /orthogonal //= !ooS ?eqxx //. + by rewrite (inv_eq (@cfConjCK _ _)). + - apply: sub_iso_to IZtau; last exact: zcharW. + by apply: zchar_trans_on; apply/allP; rewrite /= !Zd. + have span_head := memv_span (mem_head _ _); have sRxiX1 := zchar_span RxiX1. + have Y0: Y = 0. + apply/eqP; rewrite -cfnorm_eq0 eqr_le cfnorm_ge0 andbT. + rewrite -(ler_add2l ('[X] + '[X1])) -!addrA. + rewrite -2?cfnormBd -?eqX1Y -?eqXY1 ?addr0; first last. + - by rewrite cfdotC (span_orthogonal oYxi) ?rmorph0 ?span_head. + - by rewrite cfdotC (span_orthogonal oY1chi) ?rmorph0 ?span_head. + by rewrite dotD ?inE ?ne_xi_chi // -defN ler_add. + rewrite eqX1Y Y0 subr0 defN in eqX1. + have [nX _ defX] := eqX1 minX1; exists X => //; red. + rewrite eqXY1 eqX1Y Y0 subr0 opprD opprK addNKr cfdotBr nX. + by rewrite (span_orthogonal (oR _ _ _ S'xi)) ?subr0 ?(zchar_span RxiX1). +pose X_spec X := forall xi, X - D xi \in 'Z[irr G] /\ '[X, D xi] = N%:R. +have [X [RchiX nX defX] X_S'c]: exists2 X, Xspec X & {in S'c chi, X_spec X}. + have [S_chi | /allPn[xi1 Sxi1]] := altP (@allP _ (pred2 chi chi^*%CF) S). + pose E := take N (R chi); pose Ec := drop N (R chi). + have eqRchi: E ++ Ec = R chi by rewrite cat_take_drop. + have:= o1Rchi; rewrite -eqRchi orthonormal_cat => /and3P[onE onEc oEEc]. + exists (\sum_(a <- E) a) => [|xi /and3P[? ? /S_chi/norP[] //]]. + split; last by exists E; rewrite // -[E]cats0 -eqRchi cat_subseq ?sub0seq. + rewrite big_seq rpred_sum // => a Ea. + by rewrite mem_zchar // -eqRchi mem_cat Ea. + by rewrite cfnorm_orthonormal //= size_takel ?szRchi ?leq_addl. + case/norP=> ne_xi1chi ne_xi1chi'; have S'xi1: xi1 \in S'c chi by exact/and3P. + have [X [RchiX nX defX] [Rxi1X1 XD_N]] := haveX _ S'xi1. + exists X => // xi S'xi; have [ne_xi_chi' ne_xi_chi /= Sxi] := and3P S'xi. + have /R_P[ZRxi _ _] := Sxi; have /R_P[ZRxi1 _ defRxi1] := Sxi1. + have [-> | ne_xi_xi1] := eqVneq xi xi1; first by rewrite (zchar_trans ZRxi1). + have [sRchiX sRxi1X1] := (zchar_span RchiX, zchar_span Rxi1X1). + have [-> | ne_xi_xi1'] := eqVneq xi xi1^*%CF. + rewrite /D -[chi](subrK xi1) -addrA linearD cfdotDr XD_N opprD addrA. + rewrite defRxi1 big_seq (span_orthogonal (oR _ _ _ S'xi1)) ?addr0 //. + by rewrite rpredB ?rpred_sum // (zchar_trans ZRxi1). + by rewrite memv_suml // => a /memv_span. + have [X' [RchiX' nX' _] [RxiX' X'D_N]] := haveX _ S'xi. + have [ZXi sRxiX'] := (zchar_trans ZRxi RxiX', zchar_span RxiX'). + suffices: '[X - X'] == 0 by rewrite cfnorm_eq0 subr_eq0 => /eqP->. + rewrite cfnormB subr_eq0 nX nX' aut_Cint -?mulr2n; last first. + by rewrite Cint_cfdot_vchar ?(zchar_trans ZRchi). + apply/eqP; congr (_ *+ _); transitivity '[D xi1, D xi]. + by rewrite dotD ?inE ?ne_xi_chi ?ne_xi1chi ?ooS ?addr0 // eq_sym. + rewrite -[D xi](subrK X') -opprB addrC -[D _](subrK X) -opprB addrC. + rewrite cfdotBr cfdotBl -addrA addrC -addrA addrCA cfdotBl opprB. + rewrite (span_orthogonal (oR xi1 xi _ _)) //; last exact/and3P. + rewrite (span_orthogonal (oR chi xi _ _)) // subrr add0r. + rewrite cfdotC (span_orthogonal (oR chi xi1 _ _)) ?rmorph0 ?oppr0 ?add0r //. + exact: (zchar_span RchiX'). +have ZX: X \in 'Z[irr G] := zchar_trans ZRchi RchiX. +have{defX X_S'c} X_S': {in S' chi, X_spec X}. + move=> xi. + have [-> _| ne_xi_chi' S'xi] := eqVneq xi chi^*%CF; last exact/X_S'c/andP. + rewrite /D defRchi {1}big_seq rpredB ?rpred_sum //. + have{defX} [E sER defX] := defX; pose Ec := filter [predC E] (R chi). + have eqRchi: perm_eq (R chi) (E ++ Ec). + by rewrite -(perm_filterC (mem E)) -(subseq_uniqP _ _) ?free_uniq. + have:= o1Rchi; rewrite (eq_orthonormal eqRchi) orthonormal_cat. + case/and3P=> onE _ oEEc. + rewrite (eq_big_perm _ eqRchi) big_cat /= -defX cfdotDr nX defX !big_seq. + by rewrite (span_orthogonal oEEc) ?addr0 // memv_suml // => ? /memv_span. +pose X_ xi := X - D xi. +have X_chi: X_ chi = X by rewrite /X_ /D subrr linear0 subr0. +have{X_S'} ZI_X: {in S, isometry X_, to 'Z[irr G]}. + have dotXD_N xi: xi \in S' chi -> '[X, D xi] = N%:R by case/X_S'. + have S_S': {subset S <= [predU1 chi & [predD1 S' chi & chi]]}. + by move=> xi; rewrite !inE; case: eqP. + split=> [xi1 xi2 Sxi1 Sxi2 | xi]; last first. + by case/S_S'/predU1P=> [-> | /andP[_ /X_S'[]//]]; rewrite X_chi. + have /predU1P[-> | /andP[chi'xi1 S'xi1]] := S_S' _ Sxi1. + have /predU1P[->|/andP[chi'xi2 S'xi2]] := S_S' _ Sxi2; rewrite X_chi ?nX //. + by rewrite cfdotBr nX dotXD_N // subrr ooS // eq_sym. + have /predU1P[->|/andP[chi'xi2 S'xi2]] := S_S' _ Sxi2. + by rewrite X_chi cfdotBl nX cfdotC dotXD_N // rmorph_nat subrr ooS. + rewrite cfdotBl !cfdotBr nX (cfdotC _ X) !dotXD_N // conjC_nat. + by rewrite opprB subrr add0r dotD // addrC addKr. +have [tau1 Dtau1 Itau1] := Zisometry_of_iso oS ZI_X. +exists tau1; split=> // xi; rewrite zcharD1E. +case/andP=> /zchar_expansion[|z Zz ->{xi}]; first exact: free_uniq. +rewrite defS big_cons /= !cfunE addr_eq0 => eq_z. +have{eq_z} ->: z chi = - \sum_(xi <- S1) z xi. + have nz_chi1: chi 1%g != 0 by rewrite char1_eq0 ?N_S // notS0. + apply: (mulIf nz_chi1); rewrite (eqP eq_z) sum_cfunE mulNr mulr_suml. + congr (- _); apply: eq_big_seq => xi S1xi. + by rewrite cfunE unifS // defS !inE S1xi orbT. +rewrite scaleNr scaler_suml addrC -opprB -sumrB !linearN !linear_sum /=. +apply: eq_big_seq => xi S1xi; rewrite -scalerBr !linearZ /= -/(D _). +congr (_ *: - _); rewrite linearB !Dtau1 // ?defS 1?mem_behead //. +by rewrite X_chi opprD addNKr opprK. +Qed. + +End SubCoherentProperties. + +(* A corollary of Peterfalvi (5.7) used (sometimes implicitly!) in the proof *) +(* of lemmas (11.9), (12.4) and (12.5). *) +Lemma pair_degree_coherence L G S (tau : {linear _ -> 'CF(gval G)}) R : + subcoherent S tau R -> + {in S &, forall phi1 phi2 : 'CF(gval L), phi1 1%g == phi2 1%g -> + exists S1 : seq 'CF(L), + [/\ phi1 \in S1, phi2 \in S1, cfConjC_subset S1 S & coherent S1 L^# tau]}. +Proof. +move=> scohS phi1 phi2 Sphi1 Sphi2 /= eq_phi12_1. +have [[N_S _ ccS] _ _ _ _] := scohS. +pose S1 := undup (phi1 :: phi1^* :: phi2 :: phi2^*)%CF. +have sS1S: cfConjC_subset S1 S. + split=> [|chi|chi]; rewrite ?undup_uniq //= !mem_undup; move: chi; apply/allP. + by rewrite /= !ccS ?Sphi1 ?Sphi2. + by rewrite /= !inE !cfConjCK !eqxx !orbT. +exists S1; rewrite !mem_undup !inE !eqxx !orbT; split=> //. +apply: uniform_degree_coherence (subset_subcoherent scohS sS1S) _. +apply/(@all_pred1_constant _ (phi2 1%g))/allP=> _ /mapP[chi S1chi ->] /=. +rewrite mem_undup in S1chi; move: chi S1chi; apply/allP. +by rewrite /= !cfAut_char1 ?N_S // eqxx eq_phi12_1. +Qed. + +(* This is Peterfalvi (5.8). *) +Lemma coherent_prDade_TIred (G H L K W W1 W2 : {group gT}) S A A0 + k (tau1 : {additive 'CF(L) -> 'CF(G)}) + (defW : W1 \x W2 = W) (ddA : prime_Dade_hypothesis G L K H A A0 defW) + (sigma := cyclicTIiso ddA) + (eta_ := fun i j => sigma (cyclicTIirr defW i j)) + (mu := primeTIred ddA) (dk := primeTIsign ddA k) (tau := Dade ddA) : + cfConjC_subset S (seqIndD K L H 1) -> + [/\ ~~ has cfReal S, has (mem (irr L)) S & mu k \in S] -> + coherent_with S L^# tau tau1 -> + let j := conjC_Iirr k in + tau1 (mu k) = dk *: (\sum_i eta_ i k) + \/ tau1 (mu k) = - dk *: (\sum_i eta_ i j) + /\ (forall ell, mu ell \in S -> mu ell 1%g = mu k 1%g -> ell = k \/ ell = j). +Proof. +set phi := tau1 (mu k) => uccS [nrS /hasP[zeta Szeta irr_zeta] Sk] cohS j. +pose sum_eta a ell := \sum_i a i ell *: eta_ i ell. +have [R [subcohS oS1sig defR]] := prDade_subcoherent ddA uccS nrS. +have [[charS _ ccS] _ /orthogonal_free freeS Rok _] := subcohS. +have [[Itau1 _] Dtau1] := cohS. +have natS1 xi: xi \in S -> xi 1%g \in Cnat by move/charS/Cnat_char1. +have k'j: j != k by rewrite -(inj_eq (prTIred_inj ddA)) prTIred_aut (hasPn nrS). +have nzSmu l (Sl : mu l \in S): l != 0. + apply: contraNneq (hasPn nrS _ Sl) => ->. + by rewrite /cfReal -prTIred_aut aut_Iirr0. +have [nzk nzj]: k != 0 /\ j != 0 by rewrite !nzSmu // /mu (prTIred_aut ddA) ccS. +have sSS: cfConjC_subset S S by have:= free_uniq freeS; split. +have{sSS} Dtau1S:= mem_coherent_sum_subseq subcohS sSS cohS. +have o_sum_eta a j1 i j2: j1 != j2 -> '[sum_eta a j1, eta_ i j2] = 0. + move/negPf=> neq_j; rewrite cfdot_suml big1 // => i1 _. + by rewrite cfdotZl cfdot_cycTIiso neq_j andbF mulr0. +have proj_sum_eta a i j1: '[sum_eta a j1, eta_ i j1] = a i j1. + rewrite cfdot_suml (bigD1 i) //= cfdotZl cfdot_cycTIiso !eqxx mulr1. + rewrite big1 ?addr0 // => i1 /negPf i'i1. + by rewrite cfdotZl cfdot_cycTIiso i'i1 mulr0. +have [a Dphi Da0]: exists2 a, phi = sum_eta a k + sum_eta a j + & pred2 0 dk (a 0 k) /\ pred2 0 (- dk) (a 0 j). +- have uRk: uniq (R (mu k)) by have [_ /orthonormal_free/free_uniq] := Rok _ Sk. + have [E sER Dphi] := Dtau1S _ Sk; rewrite /phi Dphi (subseq_uniqP uRk sER). + pose a i ell (alpha := dk *: eta_ i ell) := + if alpha \in E then dk else if - alpha \in E then - dk else 0. + have sign_eq := inj_eq (can_inj (signrZK _)). + have E'Nsk i: (- (dk *: eta_ i k) \in E) = false. + apply/idP=> /(mem_subseq sER); rewrite defR -/dk -/sigma mem_cat -map_comp. + case/orP=> /codomP[i1 /esym/eqP/idPn[]]. + by rewrite -scalerN sign_eq cycTIiso_neqN. + by rewrite (inj_eq oppr_inj) sign_eq cycTIiso_eqE (negPf k'j) andbF. + have E'sj i: (dk *: eta_ i j \in E) = false. + apply/idP=> /(mem_subseq sER); rewrite defR -/dk -/sigma mem_cat -map_comp. + case/orP=> /codomP[i1 /eqP/idPn[]]. + by rewrite sign_eq cycTIiso_eqE (negPf k'j) andbF. + by rewrite /= -scalerN sign_eq cycTIiso_neqN. + exists a; last first. + by rewrite !(fun_if (pred2 _ _)) /= !eqxx !orbT E'Nsk !(if_same, E'sj). + rewrite big_filter big_mkcond defR big_cat !big_map -/dk -/sigma /=. + congr (_ + _); apply: eq_bigr => i _; rewrite /a -/(eta_ i _). + by rewrite E'Nsk; case: ifP => // _; rewrite scale0r. + by rewrite E'sj; case: ifP => _; rewrite (scaleNr, scale0r). +pose V := cyclicTIset defW; have zetaV0: {in V, tau1 zeta =1 \0}. + apply: (ortho_cycTIiso_vanish ddA); apply/orthoPl=> _ /mapP[ww Www ->]. + rewrite (span_orthogonal (oS1sig zeta ww _ _)) ?memv_span1 ?inE ?Szeta //. + have [E sER ->] := Dtau1S _ Szeta; rewrite big_seq rpred_sum // => aa Raa. + by rewrite memv_span ?(mem_subseq sER). +pose zeta1 := zeta 1%g *: mu k - mu k 1%g *: zeta. +have Zzeta1: zeta1 \in 'Z[S, L^#]. + rewrite zcharD1E !cfunE mulrC subrr eqxx andbT. + by rewrite rpredB ?scale_zchar ?mem_zchar // CintE ?natS1. +have /cfun_onP A1zeta1: zeta1 \in 'CF(L, 1%g |: A). + rewrite memvB ?memvZ ?prDade_TIred_on //; have [_ sSS0 _] := uccS. + have /seqIndP[kz /setIdP[kerH'kz _] Dzeta] := sSS0 _ Szeta. + by rewrite Dzeta (prDade_Ind_irr_on ddA) //; rewrite inE in kerH'kz. +have{A1zeta1} zeta1V0: {in V, zeta1 =1 \0}. + move=> x Vx; rewrite /= A1zeta1 // -in_setC. + apply: subsetP (subsetP (prDade_supp_disjoint ddA) x Vx); rewrite setCS. + by rewrite subUset sub1G; have [/= _ _ _ [_ [_ _ /subsetD1P[->]]]] := ddA. +have o_phi_0 i: '[phi, eta_ i 0] = 0 by rewrite Dphi cfdotDl !o_sum_eta ?addr0. +have{o_phi_0 zeta1V0} proj_phi0 i ell: '[phi, eta_ i ell] = '[phi, eta_ 0 ell]. + rewrite -[LHS]add0r -(o_phi_0 0) -[RHS]addr0 -(o_phi_0 i). + apply: (cycTIiso_cfdot_exchange ddA); rewrite -/V => x Vx. + have: tau zeta1 x == 0. + have [_ _ defA0] := prDade_def ddA; rewrite Dade_id ?zeta1V0 //. + by rewrite defA0 inE orbC mem_class_support. + rewrite -Dtau1 // raddfB !raddfZ_Cnat ?natS1 // !cfunE zetaV0 //. + rewrite oppr0 mulr0 addr0 mulf_eq0 => /orP[/idPn[] | /eqP->//]. + by have /irrP[iz ->] := irr_zeta; apply: irr1_neq0. +have Dphi_j i: '[phi, eta_ i j] = a i j. + by rewrite Dphi cfdotDl proj_sum_eta o_sum_eta 1?eq_sym ?add0r. +have Dphi_k i: '[phi, eta_ i k] = a i k. + by rewrite Dphi cfdotDl proj_sum_eta o_sum_eta ?addr0. +have Da_j i: a i j = a 0 j by rewrite -!Dphi_j. +have{proj_phi0} Da_k i: a i k = a 0 k by rewrite -!Dphi_k. +have oW1: #|W1| = #|Iirr W1|. + by rewrite card_Iirr_cyclic //; have [[]] := prDade_prTI ddA. +have{oW1}: `|a 0 j| ^+ 2 + `|a 0 k| ^+ 2 == 1. + apply/eqP/(mulfI (neq0CG W1)); rewrite mulr1 {}[in LHS]oW1. + transitivity '[phi]; last by rewrite Itau1 ?mem_zchar ?cfnorm_prTIred. + rewrite {2}Dphi cfdotDr !cfdot_sumr mulrDr addrC !mulr_natl -!sumr_const. + congr (_ + _); apply: eq_bigr => i _; rewrite cfdotZr mulrC normCK. + by rewrite Dphi_k (Da_k i). + by rewrite Dphi_j (Da_j i). +have{Da0}[/pred2P[]Da0k /pred2P[]Da0j] := Da0; rewrite Da0k Da0j; last 2 first. +- left; rewrite Dphi [sum_eta a j]big1 ?addr0 => [|i _]; last first. + by rewrite Da_j Da0j scale0r. + by rewrite scaler_sumr; apply: eq_bigr => i _; rewrite Da_k Da0k. +- by rewrite normrN normr_sign expr1n (eqr_nat _ 2 1). +- by rewrite normr0 expr0n add0r (eqr_nat _ 0 1). +have{Dphi} Dphi: phi = - dk *: (\sum_i eta_ i j). + rewrite Dphi [sum_eta a k]big1 ?add0r => [|i _]; last first. + by rewrite Da_k Da0k scale0r. + by rewrite raddf_sum; apply: eq_bigr => i _; rewrite Da_j Da0j. +clear 1; right; split=> // l Sl deg_l; apply/pred2P. +have [_ [tau2 Dtau2 [_ Dtau]]] := uniform_prTIred_coherent ddA nzk. +have nz_l: l != 0 := nzSmu l Sl. +have Tmukl: mu k - mu l \in 'Z[uniform_prTIred_seq ddA k, L^#]. + rewrite zcharD1E !cfunE deg_l subrr eqxx andbT. + by rewrite rpredB ?mem_zchar ?image_f // !inE ?nzk ?nz_l ?deg_l eqxx. +pose ak (_ : Iirr W1) (_ : Iirr W2) := dk. +have: phi - tau1 (mu l) = sum_eta ak k - sum_eta ak l. + rewrite -raddfB Dtau1; last first. + by rewrite zcharD1E rpredB ?mem_zchar //= !cfunE deg_l subrr. + by rewrite -[tau _]Dtau // raddfB /= !Dtau2 2!raddf_sum. +have [E /mem_subseq sER ->] := Dtau1S _ Sl. +move/esym/(congr1 (cfdotr (eta_ 0 k))); apply: contra_eqT => /norP[k'l j'l] /=. +rewrite !cfdotBl Dphi_k Da0k proj_sum_eta o_sum_eta // cfdot_suml. +rewrite big_seq big1 ?subr0 ?signr_eq0 // => aa /sER; rewrite defR -map_comp. +rewrite mem_cat => /orP[]/codomP[/= i ->]; rewrite -/(eta_ i _). + by rewrite cfdotZl cfdot_cycTIiso (negPf k'l) andbF mulr0. +rewrite cfdotNl cfdotZl cfdot_cycTIiso (inv_eq (@conjC_IirrK _ _)) -/j. +by rewrite (negPf j'l) andbF mulr0 oppr0. +Qed. + +Section DadeAut. + +Variables (L G : {group gT}) (A : {set gT}). +Implicit Types K H M : {group gT}. +Hypothesis ddA : Dade_hypothesis G L A. + +Local Notation tau := (Dade ddA). +Local Notation "alpha ^\tau" := (tau alpha). + +Section DadeAutIrr. +Variable u : {rmorphism algC -> algC}. +Local Notation "alpha ^u" := (cfAut u alpha). + +(* This is Peterfalvi (5.9)(a), slightly reformulated to allow calS to also *) +(* contain non-irreducible characters; for groups of odd order, the second *) +(* assumption holds uniformly for all calS of the form seqIndD. *) +(* We have stated the coherence assumption directly over L^#; this lets us *) +(* drop the Z{S, A] = Z{S, L^#] assumption, and is more consistent with the *) +(* rest of the proof. *) +Lemma cfAut_Dade_coherent calS tau1 chi : + coherent_with calS L^# tau tau1 -> + (1 < #|[set i | 'chi_i \in calS]|)%N /\ cfAut_closed u calS -> + chi \in irr L -> chi \in calS -> + (tau1 chi)^u = tau1 (chi^u). +Proof. +case=> [[Itau1 Ztau1] tau1_tau] [irrS_gt1 sSuS] /irrP[i {chi}->] Schi. +have sSZS: {subset calS <= 'Z[calS]} by move=> phi Sphi; apply: mem_zchar. +pose mu j := 'chi_j 1%g *: 'chi_i - 'chi_i 1%g *: 'chi_j. +have ZAmu j: 'chi_j \in calS -> mu j \in 'Z[calS, L^#]. + move=> Sxj; rewrite zcharD1E !cfunE mulrC subrr. + by rewrite rpredB //= scale_zchar ?sSZS // ?Cint_Cnat ?Cnat_irr1. +have Npsi j: 'chi_j \in calS -> '[tau1 'chi_j] = 1%:R. + by move=> Sxj; rewrite Itau1 ?sSZS ?cfnorm_irr. +have{Npsi} Dtau1 Sxj := vchar_norm1P (Ztau1 _ (sSZS _ Sxj)) (Npsi _ Sxj). +have [e [r tau1_chi]] := Dtau1 _ Schi; set eps := (-1) ^+ e in tau1_chi. +have{Dtau1} Dtau1 j: 'chi_j \in calS -> exists t, tau1 'chi_j = eps *: 'chi_t. + move=> Sxj; suffices: 0 <= (eps *: tau1 'chi_j) 1%g. + have [f [t ->]] := Dtau1 j Sxj. + have [-> | neq_f_eps] := eqVneq f e; first by exists t. + rewrite scalerA -signr_addb scaler_sign addbC -negb_eqb neq_f_eps. + by rewrite cfunE oppr_ge0 ltr_geF ?irr1_gt0. + rewrite -(pmulr_rge0 _ (irr1_gt0 i)) cfunE mulrCA. + have: tau1 (mu j) 1%g == 0 by rewrite tau1_tau ?ZAmu ?Dade1. + rewrite raddfB 2?raddfZ_Cnat ?Cnat_irr1 // !cfunE subr_eq0 => /eqP <-. + by rewrite tau1_chi cfunE mulrCA signrMK mulr_ge0 ?Cnat_ge0 ?Cnat_irr1. +have SuSirr j: 'chi_j \in calS -> 'chi_(aut_Iirr u j) \in calS. + by rewrite aut_IirrE => /sSuS. +have [j Sxj neq_ij]: exists2 j, 'chi_j \in calS & 'chi_i != 'chi_j. + move: irrS_gt1; rewrite (cardsD1 i) inE Schi ltnS card_gt0 => /set0Pn[j]. + by rewrite !inE -(inj_eq irr_inj) eq_sym => /andP[]; exists j. +have: (tau1 (mu j))^u == tau1 (mu j)^u. + by rewrite !tau1_tau ?cfAut_zchar ?ZAmu ?Dade_aut. +rewrite !raddfB [-%R]lock !raddfZ_Cnat ?Cnat_irr1 //= -lock -!aut_IirrE. +have [/Dtau1[ru ->] /Dtau1[tu ->]] := (SuSirr i Schi, SuSirr j Sxj). +have: (tau1 'chi_i)^u != (tau1 'chi_j)^u. + apply: contraNneq neq_ij => /cfAut_inj/(isometry_raddf_inj Itau1)/eqP. + by apply; rewrite ?sSZS //; apply: rpredB. +have /Dtau1[t ->] := Sxj; rewrite tau1_chi !cfAutZ_Cint ?rpred_sign //. +rewrite !scalerA -!(mulrC eps) -!scalerA -!scalerBr -!aut_IirrE. +rewrite !(inj_eq (scalerI _)) ?signr_eq0 // (inj_eq irr_inj) => /negPf neq_urt. +have [/CnatP[a ->] /CnatP[b xj1]] := (Cnat_irr1 i, Cnat_irr1 j). +rewrite xj1 eq_subZnat_irr neq_urt orbF andbC => /andP[_]. +by rewrite eqn0Ngt -ltC_nat -xj1 irr1_gt0 /= => /eqP->. +Qed. + +End DadeAutIrr. + +(* This covers all the uses of (5.9)(a) in the rest of Peterfalvi, except *) +(* one instance in (6.8.2.1). *) +Lemma cfConjC_Dade_coherent K H M (calS := seqIndD K L H M) tau1 chi : + coherent_with calS L^# (Dade ddA) tau1 -> + [/\ odd #|G|, K <| L & H \subset K] -> chi \in irr L -> chi \in calS -> + (tau1 chi)^*%CF = tau1 chi^*%CF. +Proof. +move=> cohS [oddG nsKL sHK] irr_chi Schi. +apply: (cfAut_Dade_coherent cohS) => //; split; last exact: cfAut_seqInd. +have oddL: odd #|L| by apply: oddSg oddG; have [_] := ddA. +exact: seqInd_nontrivial_irr Schi. +Qed. + +(* This is Peterfalvi (5.9)(b). *) +Lemma Dade_irr_sub_conjC chi (phi := chi - chi^*%CF) : + chi \in irr L -> chi \in 'CF(L, 1%g |: A) -> + exists t, phi^\tau = 'chi_t - ('chi_t)^*%CF. +Proof. +case/irrP=> i Dchi Achi; rewrite {chi}Dchi in phi Achi *. +have [Rchi | notRchi] := eqVneq (conjC_Iirr i) i. + by exists 0; rewrite irr0 cfConjC_cfun1 /phi -conjC_IirrE Rchi !subrr linear0. +have Zphi: phi \in 'Z[irr L, A]. + have notA1: 1%g \notin A by have [] := ddA. + by rewrite -(setU1K notA1) sub_conjC_vchar // zchar_split irr_vchar. +have Zphi_tau: phi^\tau \in 'Z[irr G, G^#]. + by rewrite zchar_split Dade_cfun Dade_vchar ?Zphi. +have norm_phi_tau : '[phi^\tau] = 2%:R. + rewrite Dade_isometry ?(zchar_on Zphi) // cfnormB -conjC_IirrE. + by rewrite !cfdot_irr !eqxx eq_sym (negPf notRchi) rmorph0 addr0 subr0. +have [j [k ne_kj phi_tau]] := vchar_norm2 Zphi_tau norm_phi_tau. +suffices def_k: conjC_Iirr j = k by exists j; rewrite -conjC_IirrE def_k. +have/esym:= eq_subZnat_irr 1 1 k j (conjC_Iirr j) (conjC_Iirr k). +rewrite (negPf ne_kj) orbF /= !scale1r !conjC_IirrE -rmorphB. +rewrite -opprB -phi_tau /= -Dade_conjC // rmorphB /= cfConjCK. +by rewrite -linearN opprB eqxx => /andP[/eqP->]. +Qed. + +End DadeAut. + +End Five. + +Implicit Arguments coherent_prDade_TIred + [gT G H L K W W1 W2 A0 A S0 k tau1 defW]. \ No newline at end of file diff --git a/mathcomp/odd_order/PFsection6.v b/mathcomp/odd_order/PFsection6.v new file mode 100644 index 0000000..d74185a --- /dev/null +++ b/mathcomp/odd_order/PFsection6.v @@ -0,0 +1,1649 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg poly finset center. +Require Import fingroup morphism perm automorphism quotient action zmodp. +Require Import gfunctor gproduct cyclic pgroup commutator gseries nilpotent. +Require Import sylow abelian maximal hall frobenius. +Require Import matrix mxalgebra mxrepresentation vector ssrnum algC algnum. +Require Import classfun character inertia vcharacter integral_char. +Require Import PFsection1 PFsection2 PFsection3 PFsection4 PFsection5. + +(******************************************************************************) +(* This file covers Peterfalvi, Section 6: *) +(* Some Coherence Theorems *) +(* Defined here: *) +(* odd_Frobenius_quotient K L M <-> *) +(* L has odd order, M <| L, K with K / M is nilpotent, and L / H1 is a *) +(* Frobenius group with kernel K / H1, where H1 / M = (K / M)^(1). *) +(* This is the statement of Peterfalvi, Hypothesis (6.4), except for *) +(* the K <| L and subcoherence assumptions, to be required separately. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory Num.Theory. +Local Open Scope ring_scope. + +(* The main section *) +Section Six. + +Variables (gT : finGroupType) (G : {group gT}). +Implicit Types H K L M : {group gT}. + +(* Grouping lemmas that assume Hypothesis (6.1). *) +Section GeneralCoherence. + +Variables K L : {group gT}. +Local Notation S M := (seqIndD K L K M). +Local Notation calS := (S 1). + +Variables (R : 'CF(L) -> seq 'CF(G)) (tau : {linear 'CF(L) -> 'CF(G)}). + +(* These may need to be grouped, in order to make the proofs of 6.8, 10.10, *) +(* and 12.6 more manageable. *) +Hypotheses (nsKL : K <| L) (solK : solvable K). +Hypothesis Itau : {in 'Z[calS, L^#] &, isometry tau}. +Hypothesis scohS : subcoherent calS tau R. + +Let sKL : K \subset L. Proof. exact: normal_sub. Qed. +Let nKL : L \subset 'N(K). Proof. exact: normal_norm. Qed. +Let orthS: pairwise_orthogonal calS. Proof. by case: scohS. Qed. +Let sSS M : {subset S M <= calS}. Proof. exact: seqInd_sub. Qed. +Let ccS M : conjC_closed (S M). Proof. exact: cfAut_seqInd. Qed. +Let uniqS M : uniq (S M). Proof. exact: seqInd_uniq. Qed. +Let nrS : ~~ has cfReal calS. Proof. by case: scohS => [[]]. Qed. + +Lemma exists_linInd M : + M \proper K -> M <| K -> exists2 phi, phi \in S M & phi 1%g = #|L : K|%:R. +Proof. +move=> ltMK nsMK; have [sMK nMK] := andP nsMK. +have ntKM: (K / M)%g != 1%g by rewrite -subG1 quotient_sub1 // proper_subn. +have [r /andP[_ r1] ntr] := solvable_has_lin_char ntKM (quotient_sol M solK). +exists ('Ind[L, K] ('chi_r %% M)%CF); last first. + by rewrite cfInd1 // cfModE // morph1 (eqP r1) mulr1. +apply/seqIndP; exists (mod_Iirr r); last by rewrite mod_IirrE. +rewrite !inE subGcfker mod_IirrE ?cfker_mod //= andbT. +apply: contraNneq ntr => /(canRL (mod_IirrK nsMK))->. +by rewrite quo_IirrE // irr0 ?cfker_cfun1 ?cfQuo_cfun1. +Qed. + +(* This is Peterfalvi (6.2). *) +Lemma coherent_seqIndD_bound (A B C D : {group gT}) : + [/\ A <| L, B <| L, C <| L & D <| L] -> + (*a*) [/\ A \proper K, B \subset D, D \subset C, C \subset K + & D / B \subset 'Z(C / B)]%g -> + (*b1*) coherent (S A) L^# tau -> + (*b2*) coherent (S B) L^# tau + \/ #|K : A|%:R - 1 <= 2%:R * #|L : C|%:R * sqrtC #|C : D|%:R. +Proof. +move=> [nsAL nsBL nsCL nsDL] [ltAK sBD sDC sCK sDbZC] cohA. +have [|not_ineq] := boolP (_ <= _); [by right | left]. +have sBC := subset_trans sBD sDC; have sBK := subset_trans sBC sCK. +have [sAK nsBK] := (proper_sub ltAK, normalS sBK sKL nsBL). +have{sBC} [nsAK nsBC] := (normalS sAK sKL nsAL, normalS sBC sCK nsBK). +pose wf S1 := [/\ uniq S1, {subset S1 <= calS} & conjC_closed S1]. +pose S1 := [::] ++ S A; set S2 := [::] in S1; rewrite -[S A]/S1 in cohA. +have wfS1: wf S1 by split; [apply: uniqS | apply: sSS | apply: ccS]. +move: {2}_.+1 (ltnSn (size calS - size S1)) => n. +elim: n => // n IHn in (S2) S1 wfS1 cohA *; rewrite ltnS => leSnS1. +have [uniqS1 sS1S ccS1] := wfS1. +have [sAB1 | /allPn[psi /= SBpsi notS1psi]] := altP (@allP _ (mem S1) (S B)). + by apply: subset_coherent cohA. +have [neq_psi_c SBpsic] := (hasPn nrS _ (sSS SBpsi), ccS SBpsi). +have wfS1': wf [:: psi, psi^* & S1]%CF. + split=> [|xi|xi]; rewrite /= !inE 1?andbC. + - rewrite negb_or eq_sym neq_psi_c notS1psi uniqS1 (contra (ccS1 _)) //. + by rewrite cfConjCK. + - by case/predU1P=> [|/predU1P[|/sS1S]] -> //; rewrite (@sSS B). + do 2![case/predU1P=> [-> |]; first by rewrite ?cfConjCK eqxx ?orbT // eq_sym]. + by move/ccS1=> ->; rewrite !orbT. +apply: (IHn [:: psi, psi^* & S2]%CF) => //; last first. + rewrite -subSn ?uniq_leq_size //; try by case: wfS1'. + by rewrite /= subSS (leq_trans _ leSnS1) // leq_sub2l ?leqW. +have [phi SAphi phi1] := exists_linInd ltAK nsAK. +have: [/\ phi \in S1, psi \in calS & psi \notin S1]. + by rewrite mem_cat SAphi orbT (@sSS B). +have /seqIndP[i /setDP[kBi _] def_psi] := SBpsi; rewrite inE in kBi. +move/(extend_coherent scohS); apply; rewrite // {phi SAphi}phi1; split=> //. + by rewrite def_psi cfInd1 // dvdC_mulr // CintE Cnat_irr1. +have Spos xi: xi \in calS -> 0 <= xi 1%g by move/Cnat_seqInd1/Cnat_ge0. +rewrite big_cat sum_seqIndD_square //= -subr_gt0 -addrA ltr_paddl //=. + rewrite big_seq sumr_ge0 // => xi S2xi. + by rewrite !mulr_ge0 ?invr_ge0 ?cfnorm_ge0 ?Spos ?sS1S // mem_cat S2xi. +rewrite mulrC -mulrBl pmulr_rgt0 ?gt0CiG // subr_gt0. +rewrite real_ltrNge ?rpredB ?rpredM ?rpred_nat ?rpred1 //; last first. + by rewrite realE Spos ?(sSS SBpsi). +apply: contra not_ineq => /ler_trans-> //. +rewrite -mulrA ler_pmul2l ?ltr0n // def_psi cfInd1 //. +rewrite -(Lagrange_index sKL sCK) natrM -mulrA ler_pmul2l ?gt0CiG //. +exact: irr1_bound_quo sDbZC. +Qed. + +(* This is Peterfalvi, Theorem (6.3). *) +Theorem bounded_seqIndD_coherent M H H1 : + [/\ M <| L, H <| L & H1 <| L] -> + [/\ M \subset H1, H1 \subset H & H \subset K] -> + (*a*) nilpotent (H / M)%g -> + (*b*) coherent (S H1) L^# tau -> + (*c*) (#|H : H1| > 4 * #|L : K| ^ 2 + 1)%N -> + coherent (S M) L^# tau. +Proof. +move: H1 => A [nsML nsHL nsAL] [sMA sAH sHK] nilHb cohA lbHA. +elim: {A}_.+1 {-2}A (ltnSn #|A|) => // m IHm A leAm in nsAL sMA sAH cohA lbHA *. +have [/group_inj-> // | ltMA] := eqVproper sMA; have [sAL nAL] := andP nsAL. +have{ltMA} [B maxB sMB]: {B : {group gT} | maxnormal B A L & M \subset B}. + by apply: maxgroup_exists; rewrite ltMA normal_norm. +have /andP[ltBA nBL] := maxgroupp maxB; have [sBA not_sAB] := andP ltBA. +have [sBH sBL] := (subset_trans sBA sAH, subset_trans sBA sAL). +have nsBL: B <| L by apply/andP. +suffices{m IHm leAm} cohB: coherent (S B) L^# tau. + apply: IHm cohB _ => //; first exact: leq_trans (proper_card ltBA) _. + by rewrite (leq_trans lbHA) // dvdn_leq // indexgS. +have /andP[sHL nHL] := nsHL. +have sAbZH: (A / B \subset 'Z(H / B))%g. + have nBA := subset_trans sAL nBL; have nsBA : B <| A by apply/andP. + have minBb: minnormal (A / B)%g (L / B)%g. + apply/mingroupP; split=> [|Db /andP[ntDb nDLb] sDAb]. + by rewrite -subG1 quotient_sub1 // not_sAB quotient_norms. + have: Db <| (L / B)%g by rewrite /normal (subset_trans sDAb) ?quotientS. + case/(inv_quotientN nsBL)=> D defDb sBD /andP[sDL nDL]. + apply: contraNeq ntDb => neqDAb; rewrite defDb quotientS1 //. + case/maxgroupP: maxB => /= _ /(_ D) {1}<- //. + rewrite -(quotient_proper (normalS sBD sDL nsBL)) // -defDb. + by rewrite properEneq sDAb neqDAb. + apply/setIidPl; case/mingroupP: minBb => /andP[ntAb nALb]. + apply; rewrite ?subsetIl //. + have nZHb := char_norm_trans (center_char (H / B)) (quotient_norms _ nHL). + rewrite andbC normsI //= meet_center_nil //=; last first. + by rewrite quotient_normal // (normalS sAH sHL). + suffices /homgP[f /= <-]: (H / B)%g \homg (H / M)%g by rewrite morphim_nil. + by apply: homg_quotientS; rewrite ?(subset_trans sHL) ?normal_norm. +have [defA | ltAH] := eqVproper sAH. + by rewrite addn1 defA indexgg in lbHA. +have [sAK ltAK] := (subset_trans sAH sHK, proper_sub_trans ltAH sHK). +case: (@coherent_seqIndD_bound A B H A) => // /idPn[]. +apply: contraL lbHA; rewrite -ltnNge -ltC_nat -(Lagrange_index sHK sAH) natrM. +set x := #|H : A|%:R => ub_x. +have nz_x2: sqrtC x != 0 by rewrite sqrtC_eq0 neq0CiG. +have x2_gt0: 0 < sqrtC x by rewrite ltr_def nz_x2 sqrtC_ge0 ler0n. +have{ub_x}: sqrtC x - (sqrtC x)^-1 <= (2 * #|L : K|)%:R. + rewrite -(ler_pmul2r (gt0CiG K H)) -natrM -mulnA Lagrange_index //. + rewrite natrM -(ler_pmul2r x2_gt0) mulrC mulrBl mulrBr. + rewrite !mulrA -expr2 sqrtCK divff // (ler_trans _ ub_x) // mulrC. + by rewrite ler_add2l ler_opp2 mul1r ler1n. +rewrite -(@ler_pexpn2r _ 2) -?topredE /= ?ler0n //; last first. + rewrite subr_ge0 -(ler_pmul2r x2_gt0) -expr2 mulVf // sqrtCK. + by rewrite ler1n. +rewrite -natrX expnMn -(ler_add2r 2%:R) -addnS natrD. +apply: ltr_le_trans; rewrite sqrrB // exprVn sqrtCK divff //. +by rewrite addrAC subrK addrC -subr_gt0 addrK invr_gt0 gt0CiG. +Qed. + +(* This is the statement of Peterfalvi, Hypothesis (6.4). *) +Definition odd_Frobenius_quotient M (H1 := K^`(1) <*> M) := + [/\ (*a*) odd #|L|, + (*b*) [/\ M <| L, M \subset K & nilpotent (K / M)] + & (*c*) [Frobenius L / H1 with kernel K / H1] ]%g. + +(* This is Peterfalvi (6.5). *) +Lemma non_coherent_chief M (H1 := (K^`(1) <*> M)%G) : + odd_Frobenius_quotient M -> + coherent (S M) L^# tau +\/ [/\ (*a*) chief_factor L H1 K /\ (#|K : H1| <= 4 * #|L : K| ^ 2 + 1)%N + & (*b*) exists2 p : nat, p.-group (K / M)%g /\ ~~ abelian (K / M)%g + & (*c*) ~~ (#|L : K| %| p - 1)]. +Proof. +case=> oddL [nsML sMK nilKb]; rewrite /= -(erefl (gval H1)) => frobLb. +set e := #|L : K|; have odd_e: odd e := dvdn_odd (dvdn_indexg L K) oddL. +have{odd_e} mod1e_lb m: (odd m -> m > 1 -> m == 1 %[mod e] -> 2 * e + 1 <= m)%N. + move=> odd_m m_gt1; rewrite eqn_mod_dvd ?(ltnW m_gt1) //. + rewrite -[m]odd_double_half odd_m subn1 /= -mul2n addn1 ltnS leq_pmul2l //. + rewrite Gauss_dvdr; last by rewrite coprime_sym prime_coprime // dvdn2 odd_e. + by apply: dvdn_leq; rewrite -(subnKC m_gt1). +have nsH1L: H1 <| L by rewrite normalY // (char_normal_trans (der_char 1 K)). +have sH1K: H1 \subset K by rewrite join_subG der_sub. +have cohH1: coherent (S H1) L^# tau. + apply: uniform_degree_coherence (subset_subcoherent scohS _) _ => //. + apply/(@all_pred1_constant _ #|L : K|%:R)/allP=> _ /mapP[chi Schi ->] /=. + have [i /setIdP[_]] := seqIndP Schi; rewrite inE join_subG -lin_irr_der1. + by do 2![case/andP]=> _ /eqP chi1 _ ->; rewrite cfInd1 // chi1 mulr1. +have sMH1: M \subset H1 by apply: joing_subr. +have [ubK | lbK] := leqP; last by left; apply: bounded_seqIndD_coherent lbK. +have{ubK} ubK: (#|K : H1| < (2 * e + 1) ^ 2)%N. + rewrite sqrnD expnMn (leq_ltn_trans ubK) // -subn_gt0 addKn. + by rewrite !muln_gt0 indexg_gt0. +have [-> | neqMH1] := eqVneq M H1; [by left | right]. +have{neqMH1} ltMH1: M \proper H1 by rewrite properEneq neqMH1. +have{frobLb} [[E1b frobLb] [sH1L nH1L]] := (existsP frobLb, andP nsH1L). +have [defLb ntKb _ _ /andP[sE1L _]] := Frobenius_context frobLb. +have nH1K: K \subset 'N(H1) := subset_trans sKL nH1L. +have chiefH1: chief_factor L H1 K. + have ltH1K: H1 \proper K by rewrite /proper sH1K -quotient_sub1 ?subG1. + rewrite /chief_factor nsKL andbT; apply/maxgroupP; rewrite ltH1K. + split=> // H2 /andP[ltH2K nH2L] sH12; have sH2K := proper_sub ltH2K. + have /eqVproper[// | ltH21] := sH12; case/idPn: ubK; rewrite -leqNgt. + have dv_e H3: H1 \subset H3 -> H3 \subset K -> L \subset 'N(H3) -> + #|H3 : H1| == 1 %[mod e]. + - move=> sH13 sH3K nH3L; rewrite eqn_mod_dvd // subn1. + rewrite /e -(index_quotient_eq _ sKL nH1L) ?subIset ?sH1K ?orbT //. + rewrite -[#|_ : _|]divgS ?quotientS // -(sdprod_card defLb) mulKn //. + rewrite -card_quotient ?(subset_trans (subset_trans sH3K sKL)) //. + rewrite regular_norm_dvd_pred ?(subset_trans sE1L) ?quotient_norms //. + apply: semiregular_sym; apply: sub_in1 (Frobenius_reg_compl frobLb). + by apply/subsetP; rewrite setSD ?quotientS. + have dv_H21 := dv_e H2 sH12 sH2K nH2L. + have dv_KH2: #|K : H2| == 1 %[mod e]. + have:= dv_e K sH1K (subxx K) nKL; rewrite -(Lagrange_index sH2K sH12). + by rewrite -modnMmr (eqP dv_H21) modnMmr muln1. + have odd_iK := dvdn_odd (dvdn_indexg _ _) (oddSg (subset_trans _ sKL) oddL). + have iK_gt1 H3 H4: H4 \proper H3 -> (#|H3 : H4| > 1)%N. + by rewrite indexg_gt1 => /andP[]. + by rewrite -(Lagrange_index sH2K sH12) leq_mul ?mod1e_lb ?odd_iK ?iK_gt1. +split=> //; have nMK := subset_trans sKL (normal_norm nsML). +have not_abKb: ~~ abelian (K / M). + apply: contra (proper_subn ltMH1) => /derG1P/trivgP. + rewrite /= join_subG subxx andbT -quotient_der ?quotient_sub1 //. + exact: subset_trans (der_sub 1 K) nMK. +have /is_abelemP[p p_pr /and3P[pKb _ _]]: is_abelem (K / H1)%g. + have: solvable (K / H1)%g by apply: quotient_sol solK. + by case/(minnormal_solvable (chief_factor_minnormal chiefH1)). +have [_ p_dv_Kb _] := pgroup_pdiv pKb ntKb. +have iso3M := third_isog sMH1 (normalS sMK sKL nsML) (normalS sH1K sKL nsH1L). +have pKM: p.-group (K / M)%g. + have /dprodP[_ defKM cKMpp' tiKMpp'] := nilpotent_pcoreC p nilKb. + rewrite -defKM (eqP (forall_inP (nilpotent_sol nilKb) 'O_p^'(_)%G _)). + by rewrite mulg1 pcore_pgroup. + have /isomP[inj_quo im_quo] := quotient_isom (cents_norm cKMpp') tiKMpp'. + rewrite subsetI pcore_sub /= -(injmSK inj_quo) // (morphim_der _ 1) //. + rewrite {inj_quo}im_quo /= -[Q in Q^`(1)%g]quotientMidl defKM. + rewrite -quotient_der ?gFnorm ?quotientS //. + rewrite -quotient_sub1 ?(subset_trans (pcore_sub _ _) (der_norm _ _)) //. + rewrite -[(_ / _)%g]setIid coprime_TIg //. + apply: pnat_coprime (quotient_pgroup _ (pcore_pgroup _ _)). + apply: pgroupS (quotientS _ (pcore_sub _ _)) _. + rewrite /= -quotient_der // -(quotientYidr (subset_trans (der_sub 1 K) nMK)). + by rewrite (isog_pgroup _ iso3M) ?(normalS sMK sKL nsML). +exists p => //; apply: contra not_abKb => e_dv_p1. +rewrite cyclic_abelian // Phi_quotient_cyclic //. +have /homgP[f <-]: (K / M / 'Phi(K / M) \homg K / H1)%g. + apply: homg_trans (isog_hom iso3M). + rewrite homg_quotientS ?gFnorm ?quotient_norms //=. + rewrite quotientYidr ?(subset_trans (der_sub 1 K)) // quotient_der //. + by rewrite (Phi_joing pKM) joing_subl. +rewrite {f}morphim_cyclic // abelian_rank1_cyclic; last first. + by rewrite sub_der1_abelian ?joing_subl. +rewrite (rank_pgroup pKb) (leq_trans (p_rank_le_logn _ _)) //. +rewrite -ltnS -(ltn_exp2l _ _ (prime_gt1 p_pr)) -p_part part_pnat_id //. +rewrite card_quotient // (leq_trans ubK) // leq_exp2r //. +have odd_p: odd p := dvdn_odd p_dv_Kb (quotient_odd _ (oddSg sKL oddL)). +by rewrite mod1e_lb // ?eqn_mod_dvd ?prime_gt0 ?prime_gt1. +Qed. + +(* This is Peterfalvi (6.6). *) +Lemma seqIndD_irr_coherence (Z : {group gT}) (calX := seqIndD K L Z 1) : + odd_Frobenius_quotient 1%G -> + [/\ Z <| L, Z :!=: 1 & Z \subset 'Z(K)]%g -> + {subset calX <= irr L} -> + calX =i [pred chi in irr L | ~~ (Z \subset cfker chi)] + /\ coherent calX L^#tau. +Proof. +move=> Frob_quo1 [nsZL ntZ sZ_ZK] irrX; have [sZL nZL] := andP nsZL. +have abZ: abelian Z by rewrite (abelianS sZ_ZK) ?center_abelian. +have /andP[sZK nZK]: Z <| K := sub_center_normal sZ_ZK. +split=> [chi|]. + apply/idP/andP=> [Xchi | [/irrP[r ->{chi}] nkerZr]]. + rewrite irrX //; case/seqIndP: Xchi => t /setIdP[nkerZt _] ->. + by rewrite inE in nkerZt; rewrite sub_cfker_Ind_irr. + have [t Res_r_t] := neq0_has_constt (Res_irr_neq0 K r). + pose chi := 'Ind[L] 'chi_t; have chi_r: '[chi, 'chi_r] != 0. + by rewrite -cfdot_Res_r cfdotC fmorph_eq0 -irr_consttE. + have Xchi: chi \in calX. + apply/seqIndP; exists t; rewrite // !inE sub1G andbT. + rewrite -(sub_cfker_Ind_irr t sKL nZL). + apply: contra nkerZr => /subset_trans-> //. + by rewrite cfker_constt // cfInd_char ?irr_char //. + case/irrX/irrP: Xchi chi_r (Xchi) => r' ->. + by rewrite cfdot_irr pnatr_eq0 -lt0n; case: eqP => // ->. +have [|[]] := non_coherent_chief Frob_quo1. + by apply: subset_coherent; apply: seqInd_sub. +have [oddL _] := Frob_quo1; rewrite /= joingG1 => frobLb _ [p []]. +set e := #|L : K|; have e_gt0: (e > 0)%N by apply: indexg_gt0. +have isoK1 := isog_symr (quotient1_isog K). +rewrite (isog_abelian isoK1) {isoK1}(isog_pgroup _ isoK1). +have [-> | ntK pK _ not_e_dv_p1] := eqsVneq K [1]; first by rewrite abelian1. +have{ntK} [p_pr p_dv_K _] := pgroup_pdiv pK ntK. +set Y := calX; pose d (xi : 'CF(L)) := logn p (truncC (xi 1%g) %/ e). +have: conjC_closed Y by apply: cfAut_seqInd. +have: perm_eq (Y ++ [::]) calX by rewrite cats0. +have: {in Y & [::], forall xi1 xi2, d xi1 <= d xi2}%N by []. +elim: {Y}_.+1 {-2}Y [::] (ltnSn (size Y)) => // m IHm Y X' leYm leYX' defX ccY. +have sYX: {subset Y <= calX}. + by move=> xi Yxi; rewrite -(perm_eq_mem defX) mem_cat Yxi. +have sX'X: {subset X' <= calX}. + by move=> xi X'xi; rewrite -(perm_eq_mem defX) mem_cat X'xi orbT. +have uniqY: uniq Y. + have: uniq calX := seqInd_uniq L _. + by rewrite -(perm_eq_uniq defX) cat_uniq => /and3P[]. +have sYS: {subset Y <= calS} by move=> xi /sYX/seqInd_sub->. +case homoY: (constant [seq xi 1%g | xi : 'CF(L) <- Y]). + exact: uniform_degree_coherence (subset_subcoherent scohS _) homoY. +have Ndg: {in calX, forall xi : 'CF(L), xi 1%g = (e * p ^ d xi)%:R}. + rewrite /d => _ /seqIndP[i _ ->]; rewrite cfInd1 // -/e. + have:= dvd_irr1_cardG i; have /CnatP[n ->] := Cnat_irr1 i. + rewrite -natrM natCK dvdC_nat mulKn // -p_part => dv_n_K. + by rewrite part_pnat_id // (pnat_dvd dv_n_K). +have [chi Ychi leYchi]: {chi | chi \in Y & {in Y, forall xi, d xi <= d chi}%N}. + have [/eqP/nilP Y0 | ntY] := posnP (size Y); first by rewrite Y0 in homoY. + pose i := [arg max_(i > Ordinal ntY) d Y`_i]. + exists Y`_i; [exact: mem_nth | rewrite {}/i; case: arg_maxP => //= i _ max_i]. + by move=> _ /(nthP 0)[j ltj <-]; apply: (max_i (Ordinal ltj)). +have{homoY} /hasP[xi1 Yxi1 lt_xi1_chi]: has (fun xi => d xi < d chi)%N Y. + apply: contraFT homoY => geYchi; apply: (@all_pred1_constant _ (chi 1%g)). + rewrite all_map; apply/allP=> xi Yxi; rewrite /= !Ndg ?sYX // eqr_nat. + rewrite eqn_pmul2l // eqn_exp2l ?prime_gt1 //. + by rewrite eqn_leq leYchi //= leqNgt (hasPn geYchi). +pose Y' := rem chi^*%CF (rem chi Y); pose X'' := [:: chi, chi^*%CF & X']. +have ccY': conjC_closed Y'. + move=> xi; rewrite !(inE, mem_rem_uniq) ?rem_uniq //. + by rewrite !(inv_eq (@cfConjCK _ _)) cfConjCK => /and3P[-> -> /ccY->]. +have Xchi := sYX _ Ychi; have defY: perm_eq [:: chi, chi^*%CF & Y'] Y. + rewrite (perm_eqrP (perm_to_rem Ychi)) perm_cons perm_eq_sym perm_to_rem //. + by rewrite mem_rem_uniq ?inE ?ccY // (seqInd_conjC_neq _ _ _ Xchi). +apply: perm_eq_coherent (defY) _. +have d_chic: d chi^*%CF = d chi. + by rewrite /d cfunE conj_Cnat // (Cnat_seqInd1 Xchi). +have /andP[uniqY' Y'x1]: uniq Y' && (xi1 \in Y'). + rewrite !(inE, mem_rem_uniq) ?rem_uniq // Yxi1 andbT -negb_or. + by apply: contraL lt_xi1_chi => /pred2P[] ->; rewrite ?d_chic ltnn. +have xi1P: [/\ xi1 \in Y', chi \in calS & chi \notin Y']. + by rewrite Y'x1 sYS ?(inE, mem_rem_uniq) ?rem_uniq // eqxx andbF. +have sY'Y: {subset Y' <= Y} by move=> xi /mem_rem/mem_rem. +apply: (extend_coherent scohS) xi1P _; first by split=> // xi /sY'Y/sYS. +have{defX} defX: perm_eq (Y' ++ X'') calX. + by rewrite (perm_catCA Y' [::_; _]) catA -(perm_eqrP defX) perm_cat2r. +have{d_chic} le_chi_X'': {in X'', forall xi, d chi <= d xi}%N. + by move=> xi /or3P[/eqP-> | /eqP-> | /leYX'->] //; rewrite d_chic. +rewrite !Ndg ?sYX // dvdC_nat dvdn_pmul2l // dvdn_exp2l 1?ltnW //; split=> //. + apply: IHm defX ccY' => [|xi xi' /sY'Y/leYchi le_xi_chi /le_chi_X'']. + by rewrite -ltnS // (leq_trans _ leYm) // -(perm_eq_size defY) ltnW. + exact: leq_trans. +have pos_p n: (0 < p ^ n)%N by rewrite expn_gt0 prime_gt0. +rewrite -!natrM; apply: (@ltr_le_trans _ (e ^ 2 * (p ^ d chi) ^ 2)%:R). + rewrite ltr_nat -expnMn -mulnn mulnAC !mulnA 2?ltn_pmul2r //. + rewrite -mulnA mulnCA ltn_pmul2l // -(subnK lt_xi1_chi) addnS expnS. + rewrite expnD mulnA ltn_pmul2r // -(muln1 3) leq_mul //. + rewrite ltn_neqAle prime_gt1 // eq_sym (sameP eqP (prime_oddPn p_pr)). + by rewrite (dvdn_odd p_dv_K) // (oddSg sKL). +have [r] := seqIndP (sYX _ Ychi); rewrite !inE => /andP[nkerZr _] def_chi. +have d_r: 'chi_r 1%g = (p ^ d chi)%:R. + by apply: (mulfI (neq0CiG L K)); rewrite -cfInd1 // -def_chi -natrM Ndg. +pose sum_p2d S := (\sum_(xi <- S) p ^ (d xi * 2))%N. +pose sum_xi1 (S : seq 'CF(L)) := \sum_(xi <- S) xi 1%g ^+ 2 / '[xi]. +have def_sum_xi1 S: {subset S <= calX} -> sum_xi1 S = (e ^ 2 * sum_p2d S)%:R. + move=> sSX; rewrite big_distrr natr_sum /=; apply: eq_big_seq => xi /sSX Xxi. + rewrite expnM -expnMn natrX -Ndg //. + by have /irrP[i ->] := irrX _ Xxi; rewrite cfnorm_irr divr1. +rewrite -/(sum_xi1 _) def_sum_xi1 ?leC_nat 1?dvdn_leq => [|||_ /sY'Y/sYX] //. + by rewrite muln_gt0 expn_gt0 e_gt0 [_ Y'](bigD1_seq xi1) //= addn_gt0 pos_p. +have coep: coprime e p. + have:= Frobenius_ker_coprime frobLb; rewrite coprime_sym. + have /andP[_ nK'L] := char_normal_trans (der_char 1 K) nsKL. + rewrite index_quotient_eq ?subIset ?der_sub ?orbT {nK'L}// -/e. + have ntKb: (K / K^`(1))%g != 1%g by case/Frobenius_kerP: frobLb. + have [_ _ [k ->]] := pgroup_pdiv (quotient_pgroup _ pK) ntKb. + by rewrite coprime_pexpr. +rewrite -expnM Gauss_dvd ?coprime_expl ?coprime_expr {coep}// dvdn_mulr //=. +have /dvdn_addl <-: p ^ (d chi * 2) %| e ^ 2 * sum_p2d X''. + rewrite big_distrr big_seq dvdn_sum //= => xi /le_chi_X'' le_chi_xi. + by rewrite dvdn_mull // dvdn_exp2l ?leq_pmul2r. +rewrite -mulnDr -big_cat (eq_big_perm _ defX) -(natCK (e ^ 2 * _)) /=. +rewrite -def_sum_xi1 // /sum_xi1 sum_seqIndD_square ?normal1 ?sub1G //. +rewrite indexg1 -(natrB _ (cardG_gt0 Z)) -natrM natCK. +rewrite -(Lagrange_index sKL sZK) mulnAC dvdn_mull //. +have /p_natP[k defKZ]: p.-nat #|K : Z| by rewrite (pnat_dvd (dvdn_indexg K Z)). +rewrite defKZ dvdn_exp2l // -(leq_exp2l _ _ (prime_gt1 p_pr)) -{k}defKZ. +rewrite -leC_nat expnM natrX -d_r ?(ler_trans (irr1_bound r).1) //. +rewrite ler_nat dvdn_leq ?indexgS ?(subset_trans sZ_ZK) //=. +by rewrite -cap_cfcenter_irr bigcap_inf. +Qed. + +End GeneralCoherence. + +(* This is Peterfalvi (6.7). *) +(* In (6.8) we only know initially the P is Sylow in L; perhaps the lemma *) +(* should be stated with this equivalent (but weaker) assumption. *) +Lemma constant_irr_mod_TI_Sylow (Z L P : {group gT}) p i : + p.-Sylow(G) P -> odd #|L| -> normedTI P^# G L -> + [/\ Z <| L, Z :!=: 1%g & Z \subset 'Z(P)] -> + {in Z^# &, forall x y, #|'C_L[x]| = #|'C_L[y]| } -> + let phi := 'chi[G]_i in + {in Z^# &, forall x y, phi x = phi y} -> + {in Z^#, forall x, phi x \in Cint /\ (#|P| %| phi x - phi 1%g)%C}. +Proof. +move=> sylP oddL tiP [/andP[sZL nZL] ntZ sZ_ZP] prZL; move: i. +pose a := @gring_classM_coef _ G; pose C (i : 'I_#|classes G|) := enum_val i. +have [[sPG pP p'PiG] [sZP cPZ]] := (and3P sylP, subsetIP sZ_ZP). +have [ntP sLG memJ_P1] := normedTI_memJ_P tiP; rewrite setD_eq0 subG1 in ntP. +have nsPL: P <| L. + by have [_ _ /eqP<-] := and3P tiP; rewrite normD1 normal_subnorm. +have [p_pr _ [e oP]] := pgroup_pdiv pP ntP. +have [sZG [sPL _]] := (subset_trans sZP sPG, andP nsPL). +pose dC i (A : {set gT}) := [disjoint C i & A]. +have actsGC i: {acts G, on C i | 'J}. + apply/actsP; rewrite astabsJ /C; have /imsetP[x _ ->] := enum_valP i. + by apply/normsP; apply: classGidr. +have{actsGC} PdvKa i j s: + ~~ dC i Z^# -> ~~ dC j Z^# -> dC s Z -> (#|P| %| a i j s * #|C s|)%N. +- pose Omega := [set uv in [predX C i & C j] | mulgm uv \in C s]%g. + pose to_fn uv x := prod_curry (fun u v : gT => (u ^ x, v ^ x)%g) uv. + have toAct: is_action setT to_fn. + by apply: is_total_action => [[u v]|[u v] x y] /=; rewrite ?conjg1 ?conjgM. + move=> Zi Zj Z's; pose to := Action toAct. + have actsPO: [acts P, on Omega | to]. + apply/(subset_trans sPG)/subsetP=> x Gx; rewrite !inE. + apply/subsetP=> [[u v] /setIdP[/andP/=[Ciu Cjv] Csuv]]. + by rewrite !inE /= -conjMg !actsGC // Ciu Cjv. + have <-: #|Omega| = (a i j s * #|C s|)%N. + have /repr_classesP[_ defCs] := enum_valP s; rewrite -/(C s) in defCs. + rewrite -sum1_card mulnC -sum_nat_const. + rewrite (partition_big mulgm (mem (C s))) => [|[u v] /setIdP[]//]. + apply: eq_bigr; rewrite /= defCs => _ /imsetP[z Gz ->]. + rewrite -[a i j s]sum1_card -!/(C _) (reindex_inj (act_inj to z)) /=. + apply: eq_bigl => [[u v]]; rewrite !inE /= -conjMg (inj_eq (conjg_inj _)). + by apply: andb_id2r => /eqP->; rewrite {2}defCs mem_imset ?andbT ?actsGC. + suffices regPO: {in Omega, forall uv, 'C_P[uv | to] = 1%g}. + rewrite -(acts_sum_card_orbit actsPO) dvdn_sum // => _ /imsetP[uv Ouv ->]. + by rewrite card_orbit regPO // indexg1. + case=> u v /setIdP[/andP[/= Ciu Cjv] Csuv]; apply: contraTeq Z's. + case/trivgPn=> x /setIP[Px /astab1P[/= cux cvx]] nt_x. + suffices inZ k y: y \in C k -> ~~ dC k Z^# -> y ^ x = y -> y \in Z. + apply/exists_inP; exists (u * v)%g => //=. + by rewrite groupM // (inZ i u, inZ j v). + rewrite /dC /C; have /imsetP[_ _ ->{k} /class_transr <-] := enum_valP k. + case/exists_inP=> _ /imsetP[g Gg ->] /setD1P[nt_yg Zyg] yx. + have xy: (x ^ y = x)%g by rewrite /conjg (conjgCV x) -{2}yx conjgK mulKg. + rewrite -(memJ_conjg _ g) (normsP nZL) //. + rewrite -(memJ_P1 y) ?inE //=; first by rewrite nt_yg (subsetP sZP). + rewrite -order_eq1 -(orderJ y g) order_eq1 nt_yg. + rewrite (mem_normal_Hall (pHall_subl sPL sLG sylP)) //. + by rewrite -(p_eltJ _ _ g) (mem_p_elt pP) ?(subsetP sZP). + rewrite -(memJ_P1 x) // ?xy ?inE ?nt_x // -[y](conjgK g) groupJ ?groupV //. + by rewrite (subsetP sZG). +pose a2 i j := (\sum_(s | ~~ dC s Z^#) a i j s)%N. +pose kerZ l := {in Z^# &, forall x y, 'chi[G]_l x = 'chi_l y}. +move=> l phi kerZl z Z1z; move: l @phi {kerZl}(kerZl : kerZ l). +have [ntz Zz] := setD1P Z1z. +have [[Pz Lz] Gz] := (subsetP sZP z Zz, subsetP sZL z Zz, subsetP sZG z Zz). +pose inC y Gy := enum_rank_in (@mem_classes _ y G Gy) (y ^: G). +have CE y Gy: C (inC y Gy) = y ^: G by rewrite /C enum_rankK_in ?mem_classes. +pose i0 := inC _ (group1 G); pose i1 := inC z Gz; pose i2 := inC _ (groupVr Gz). +suffices Ea2 l (phi := 'chi[G]_l): + kerZ l -> (phi z *+ a2 i1 i1 == phi 1%g + phi z *+ a2 i1 i2 %[mod #|P|])%A. +- move=> l phi kerZphi. + have Zphi1: phi 1%g \in Cint by rewrite irr1_degree rpred_nat. + have chi0 x: x \in Z -> 'chi[G]_0 x = 1. + by rewrite irr0 cfun1E => /(subsetP sZG) ->. + have: kerZ 0 by move=> x y /setD1P[_ Zx] /setD1P[_ Zy]; rewrite !chi0. + move/Ea2/(eqAmodMl (Aint_irr l z)); rewrite !{}chi0 // -/phi eqAmod_sym. + rewrite mulrDr mulr1 !mulr_natr => /eqAmod_trans/(_ (Ea2 l kerZphi)). + rewrite eqAmodDr -/phi eqAmod_rat ?rpred_nat ?(rpred_Cint _ Zphi1) //. + move=> PdvDphi; split; rewrite // -[phi z](subrK (phi 1%g)) rpredD //. + by have /dvdCP[b Zb ->] := PdvDphi; rewrite rpredM ?rpred_nat. + have nz_Z1: #|Z^#|%:R != 0 :> algC. + by rewrite pnatr_eq0 cards_eq0 setD_eq0 subG1. + rewrite -[phi z](mulfK nz_Z1) rpred_div ?rpred_nat // mulr_natr. + rewrite -(rpredDl _ (rpred_Cint _ Zphi1)) //. + rewrite -[_ + _](mulVKf (neq0CG Z)) rpredM ?rpred_nat //. + have: '['Res[Z] phi, 'chi_0] \in Crat. + by rewrite rpred_Cnat ?Cnat_cfdot_char ?cfRes_char ?irr_char. + rewrite irr0 cfdotE (big_setD1 _ (group1 Z)) cfun1E cfResE ?group1 //=. + rewrite rmorph1 mulr1; congr (_ * (_ + _) \in Crat). + rewrite -sumr_const; apply: eq_bigr => x Z1x; have [_ Zx] := setD1P Z1x. + by rewrite cfun1E cfResE ?Zx // rmorph1 mulr1; apply: kerZphi. +move=> kerZphi; pose alpha := 'omega_l['K_i1]; pose phi1 := phi 1%g. +have tiZG: {in Z^#, forall y, 'C_G[y] \subset L}. + move=> y /setD1P[nty /(subsetP sZP)Py]. + apply/subsetP=> u /setIP[Gu /cent1P cuy]. + by rewrite -(memJ_P1 y) // /conjg -?cuy ?mulKg !inE nty. +have Dalpha s: ~~ dC s Z^# -> alpha = 'omega_l['K_s]. + case/exists_inP=> x /= /gring_mode_class_sum_eq-> Z1x. + have Ci1z: z \in C i1 by rewrite CE class_refl. + rewrite [alpha](gring_mode_class_sum_eq _ Ci1z) -/phi (kerZphi z x) //. + have{tiZG} tiZG: {in Z^#, forall y, 'C_G[y] = 'C_L[y]}. + by move=> y /tiZG/setIidPr; rewrite setIA (setIidPl sLG). + by rewrite -!index_cent1 -!divgS ?subsetIl //= !tiZG ?(prZL z x). +have Ci01: 1%g \in C i0 by rewrite CE class_refl. +have rCi10: repr (C i0) = 1%g by rewrite CE class1G repr_set1. +have Dalpha2 i j: ~~ dC i Z^# -> ~~ dC j Z^# -> + (phi1 * alpha ^+ 2 == phi1 * ((a i j i0)%:R + alpha *+ a2 i j) %[mod #|P|])%A. +- move=> Z1i Z1j. + have ->: phi1 * alpha ^+ 2 = \sum_s (phi1 *+ a i j s) * 'omega_l['K_s]. + rewrite expr2 {1}(Dalpha i Z1i) (Dalpha j Z1j). + rewrite -gring_irr_modeM ?gring_class_sum_central //. + rewrite gring_classM_expansion raddf_sum mulr_sumr; apply: eq_bigr => s _. + by rewrite scaler_nat raddfMn mulrnAl mulrnAr. + rewrite (bigID (fun s => dC s Z^#)) (bigD1 i0) //=; last first. + by rewrite [dC _ _]disjoints_subset CE class1G sub1set !inE eqxx. + rewrite (gring_mode_class_sum_eq _ Ci01) mulfK ?irr1_neq0 //. + rewrite class1G cards1 mulr1 mulrDr mulr_natr -addrA eqAmodDl. + rewrite /eqAmod -addrA rpredD //; last first. + rewrite -mulr_natr natr_sum !mulr_sumr -sumrB rpred_sum // => s Z1s. + by rewrite -Dalpha // mulr_natr mulrnAl mulrnAr subrr rpred0. + apply: rpred_sum => // s /andP[Z1'Cs ntCs]; rewrite mulrnAl mulrC. + have /imsetP[x _ defCs] := enum_valP s. + have Cs_x: x \in C s by rewrite /C defCs class_refl. + rewrite (gring_mode_class_sum_eq _ Cs_x) divfK ?irr1_neq0 // -defCs -/(C s). + rewrite -mulrnAl -mulrnA mulnC -[_%:R]subr0 mulrBl. + apply: eqAmodMr; first exact: Aint_irr. + rewrite eqAmod0_rat ?rpred_nat // dvdC_nat PdvKa //. + rewrite -(setD1K (group1 Z)) [dC _ _]disjoint_sym disjoints_subset. + rewrite subUset sub1set inE -disjoints_subset disjoint_sym. + rewrite (contra _ ntCs) // [C s]defCs => /class_transr. + by rewrite -(inj_eq enum_val_inj) defCs -/(C _) CE => ->. +have zG'z1: (z^-1 \notin z ^: G)%g. + have genL2 y: y \in L -> <[y]> = <[y ^+ 2]>. + move=> Ly; apply/eqP; rewrite [_ == _]generator_coprime. + by rewrite coprime_sym prime_coprime // dvdn2 (oddSg _ oddL) ?cycle_subG. + apply: contra (ntz) => /imsetP[y Gy zy]. + have cz_y2: (y ^+ 2 \in 'C[z])%g. + by rewrite !inE conjg_set1 conjgM -zy conjVg -zy invgK. + rewrite -cycle_eq1 genL2 // cycle_eq1 -eq_invg_mul zy (sameP eqP conjg_fixP). + rewrite (sameP commgP cent1P) cent1C -cycle_subG genL2 ?cycle_subG //. + by rewrite -(memJ_P1 z) -?zy ?in_setD ?groupV ?inE ?ntz. +have a110: a i1 i1 i0 = 0%N. + apply: contraNeq zG'z1 => /existsP[[u v] /setIdP[/andP[/=]]]. + rewrite rCi10 -!/(C _) !CE -eq_invg_mul => /imsetP[x Gx ->] /class_transr <-. + by move/eqP <-; rewrite -conjVg classGidl ?class_refl. +have a120: a i1 i2 i0 = #|C i1|. + rewrite -(card_imset _ (@can_inj _ _ (fun y => (y, y^-1)%g) (@fst _ _) _)) //. + apply/eq_card=> [[u v]]; rewrite !inE rCi10 -eq_invg_mul -!/(C _) !CE -andbA. + apply/and3P/imsetP=> /= [[zGu _ /eqP<-] | [y zGy [-> ->]]]; first by exists u. + by rewrite classVg inE invgK. +have Z1i1: ~~ dC i1 Z^#. + by apply/exists_inP; exists z; rewrite //= CE class_refl. +have Z1i2: ~~ dC i2 Z^#. + apply/exists_inP; exists z^-1%g; first by rewrite /= CE class_refl. + by rewrite /= in_setD !groupV !inE ntz. +have{Dalpha2}: (phi1 * (alpha *+ a2 i1 i1) + == phi1 * (#|C i1|%:R + alpha *+ a2 i1 i2) %[mod #|P|])%A. +- rewrite -a120; apply: eqAmod_trans (Dalpha2 i1 i2 Z1i1 Z1i2). + by have:= Dalpha2 _ _ Z1i1 Z1i1; rewrite a110 add0r eqAmod_sym. +rewrite mulrDr !mulrnAr mulr1 -/phi1. +have ->: phi1 * alpha = phi z *+ #|C i1|. + have Ci1z: z \in C i1 by rewrite CE class_refl. + rewrite [alpha](gring_mode_class_sum_eq _ Ci1z) mulrC divfK ?irr1_neq0 //. + by rewrite mulr_natl CE. +rewrite -!mulrnA !(mulnC #|C _|) !mulrnA -mulrnDl. +have [|r _ /dvdnP[q Dqr]] := @Bezoutl #|C i1| #|P|. + by rewrite CE -index_cent1. +have Zq: q%:R \in Aint by apply: rpred_nat. +move/(eqAmodMr Zq); rewrite ![_ *+ #|C _| * _]mulrnAl -!mulrnAr -mulrnA -Dqr. +have /eqnP->: coprime #|C i1| #|P|. + rewrite (p'nat_coprime _ pP) // (pnat_dvd _ p'PiG) // CE -index_cent1. + by rewrite indexgS // subsetI sPG sub_cent1 (subsetP cPZ). +rewrite add1n !mulrS !mulrDr !mulr1 natrM !mulrA. +set u := _ * r%:R; set v := _ * r%:R; rewrite -[u](subrK v) mulrDl addrA. +rewrite eqAmodDr; apply: eqAmod_trans; rewrite eqAmod_sym addrC. +rewrite eqAmod_addl_mul // -mulrBl mulr_natr. +by rewrite !(rpredB, rpredD, rpredMn, Aint_irr). +Qed. + +(* This is Peterfalvi, Theorem (6.8). *) +(* We omit the semi-direct structure of L in assumption (a), since it is *) +(* implied by our statement of assumption (c). *) +Theorem Sibley_coherence (L H W1 : {group gT}) : + (*a*) [/\ odd #|L|, nilpotent H & normedTI H^# G L] -> + (*b*) let calS := seqIndD H L H 1 in let tau := 'Ind[G, L] in + (*c*) [\/ (*c1*) [Frobenius L = H ><| W1] + | (*c2*) exists2 W2 : {group gT}, prime #|W2| /\ W2 \subset H^`(1)%G + & exists A0, exists W : {group gT}, exists defW : W1 \x W2 = W, + prime_Dade_hypothesis G L H H H^# A0 defW] -> + coherent calS L^# tau. +Proof. +set A := H^# => [][oddL nilH tiA] S tau structL. +set case_c1 := [Frobenius L = H ><| W1] in structL. +have sLG: L \subset G by have [_ _ /eqP <-] := and3P tiA; apply: subsetIl. +have [defL ntH ntW1]: [/\ H ><| W1 = L, H :!=: 1 & W1 :!=: 1]%g. + have [/Frobenius_context[]// | [W2 _ [A0 [W [defW []]]]]] := structL. + by move=> _ [[-> -> _ _] [ntW2 /subG1_contra->]]. +have [nsHL _ /mulG_sub[sHL sW1L] _ _] := sdprod_context defL. +have [uccS nrS]: cfConjC_subset S S /\ ~~ has cfReal S. + by do 2?split; rewrite ?seqInd_uniq ?seqInd_notReal //; apply: cfAut_seqInd. +have defZS: 'Z[S, L^#] =i 'Z[S, A] by apply: zcharD1_seqInd. +have c1_irr: case_c1 -> {subset S <= irr L}. + move/FrobeniusWker=> frobL _ /seqIndC1P[i nz_i ->]. + exact: irr_induced_Frobenius_ker. +move defW2: 'C_H(W1)%G => W2; move defW: (W1 <*> W2)%G => W. +have{defW} defW: W1 \x W2 = W. + rewrite -defW dprodEY // -defW2 ?subsetIr // setICA setIA. + by have [_ _ _ ->] := sdprodP defL; rewrite setI1g. +pose V := cyclicTIset defW; pose A0 := A :|: class_support V L. +pose c2hyp := prime_Dade_hypothesis G L H H A A0 defW. +have c1W2: case_c1 -> W2 = 1%G by move/Frobenius_trivg_cent/group_inj <-. +have{structL} c2W2: ~~ case_c1 -> [/\ prime #|W2|, W2 \subset H^`(1)%G & c2hyp]. + case: structL => [-> // | [W20 [prW20 sW20H'] W20hyp] _]. + have{W20hyp} [A00 [W0 [defW0 W20hyp]]] := W20hyp. + suffices /group_inj defW20: W2 :=: W20. + have eqW0: W0 = W by apply: group_inj; rewrite -defW0 -defW20. + rewrite -defW20 eqW0 in prW20 sW20H' defW0 W20hyp; split=> //. + rewrite /c2hyp (eq_irrelevance defW defW0) /A0. + by have [_ _ <-] := prDade_def W20hyp. + have [[_ _ _ cycW1] [_ _ _ prW120] _] := prDade_prTI W20hyp. + have [x defW1] := cyclicP cycW1; rewrite -defW2 /= defW1 cent_cycle prW120 //. + by rewrite !inE defW1 cycle_id -cycle_eq1 -defW1 ntW1. +have{c2W2} [prW2 sW2H' c2W2] := all_and3 c2W2. +have{sW2H'} sW2H': W2 \subset H^`(1)%G. + by have [/c1W2-> | /sW2H'//] := boolP case_c1; apply: sub1G. +pose sigma := cyclicTIiso (c2W2 _). +have [R scohS oRW]: exists2 R, subcoherent S tau R & forall c2 : ~~ case_c1, + {in [predI S & irr L] & irr W, forall phi w, orthogonal (R phi) (sigma c2 w)}. +- have sAG: A \subset G^# by rewrite setSD // (subset_trans (normal_sub nsHL)). + have Itau: {in 'Z[S, L^#], isometry tau, to 'Z[irr G, G^#]}. + split=> [xi1 xi2 | xi]. + rewrite !defZS => /zchar_on Axi1 /zchar_on Axi2. + exact: normedTI_isometry Axi1 Axi2. + rewrite !zcharD1E => /andP[Zxi /eqP xi1_0]. + rewrite cfInd1 // xi1_0 mulr0 eqxx cfInd_vchar //. + by apply: zchar_trans_on Zxi; apply: seqInd_vcharW. + have [/= Hc1 | Hc2] := boolP (idfun case_c1). + suffices [R]: {R | subcoherent S tau R} by exists R => // /negP[]. + by apply: irr_subcoherent => //; first by case: uccS (c1_irr Hc1). + have ddA0 := c2W2 Hc2. + have [R [subcohR oRW _]] := prDade_subcoherent ddA0 uccS nrS. + exists R => [|not_c1 phi w irrSphi irr_w]; last first. + by rewrite /sigma -(cycTIiso_irrel ddA0) oRW. + set tau0 := Dade _ in subcohR. + have Dtau: {in 'CF(L, A), tau =1 tau0}. + have nAL: L \subset 'N(A) by rewrite normD1 normal_norm. + move=> phi Aphi; rewrite /tau0 -(restr_DadeE ddA0 (subsetUl _ _) nAL) //. + by rewrite /restr_Dade Dade_Ind. + have [Sok _ oSS Rok oRR] := subcohR; split=> // phi Sphi. + have [ZR oNR <-] := Rok _ Sphi; split=> //. + by rewrite Dtau ?irr_vchar_on ?sub_conjC_vchar ?(seqInd_vchar nsHL Sphi). +have [nsH'H nsH'L] := (der_normal 1 H, char_normal_trans (der_char 1 H) nsHL). +have [nH'L solH] := (normal_norm nsH'L, nilpotent_sol nilH). +have ltH'H: H^`(1)%g \proper H by rewrite ?(nil_comm_properl nilH) ?subsetIidl. +have coHW1: coprime #|H| #|W1|. + have [/Frobenius_coprime// | /c2W2[_ [[_ _]]]] := boolP case_c1. + by rewrite (coprime_sdprod_Hall_r defL). +have oW1: #|W1| = #|L : H| by rewrite -divgS // -(sdprod_card defL) mulKn. +have frobL1: [Frobenius L / H^`(1) = (H / H^`(1)) ><| (W1 / H^`(1))]%g. + apply: (Frobenius_coprime_quotient defL nsH'L) => //; split=> // x W1x. + have [/Frobenius_reg_ker-> //|] := boolP case_c1; first exact: sub1G. + by case/c2W2=> _ [_ [_ _ _ ->]]. +have odd_frobL1: odd_Frobenius_quotient H L 1. + have ? := FrobeniusWker frobL1. + by split=> //=; rewrite ?joingG1 // normal1 sub1G quotient_nil. +without loss [/p_groupP[p p_pr pH] not_cHH]: / p_group H /\ ~~ abelian H. + have [//| [_] [p []]] := non_coherent_chief nsHL solH scohS odd_frobL1. + rewrite (isog_abelian (quotient1_isog H)) -(isog_pgroup p (quotient1_isog H)). + by move=> /pgroup_p-> -> _; apply. +have sylH: p.-Sylow(G) H. (* required for (6.7) *) + have sylH: p.-Sylow(L) H. + apply/and3P; split=> //; rewrite -oW1 p'natE // -prime_coprime //. + by case/pgroup_pdiv: pH coHW1 => // _ _ [m ->]; rewrite coprime_pexpl. + have [P sylP sHP] := Sylow_superset (subset_trans sHL sLG) pH. + have [sPG pP _] := and3P sylP; have nilP := pgroup_nil pP. + rewrite -(nilpotent_sub_norm nilP sHP) // (sub_normal_Hall sylH) //. + exact: pgroupS (subsetIl P _) pP. + by have [_ _ /eqP <-] := and3P tiA; rewrite normD1 setSI. +pose caseA := 'Z(H) :&: W2 == [1]. +have caseB_P: ~~ caseA -> [/\ ~~ case_c1, W2 :!=: [1] & W2 \subset 'Z(H)]. + rewrite /caseA; have [-> |] := eqsVneq W2 [1]; first by rewrite setIg1 eqxx. + have [/c1W2->/eqP[]// | /prW2 pW2 ->] := boolP case_c1. + by rewrite setIC => /prime_meetG->. +pose Z := if caseA then ('Z(H) :&: H^`(1))%G else W2. +have /subsetIP[sZZ sZH']: Z \subset 'Z(H) :&: H^`(1)%g. + by rewrite /Z; case: ifPn => // /caseB_P[/c2W2[]] *; apply/subsetIP. +have caseB_cZL: ~~ caseA -> Z \subset 'Z(L). + move=> inB; have [_ _ /subsetIP[sW2H cW2H]] := caseB_P inB. + have [_ mulHW1 _ _] := sdprodP defL. + rewrite /Z (negPf inB) subsetI (subset_trans sW2H) //. + by rewrite -mulHW1 centM subsetI cW2H -defW2 subsetIr. +have nsZL: Z <| L. + have [inA | /caseB_cZL/sub_center_normal//] := boolP caseA. + by rewrite /Z inA (char_normal_trans _ nsHL) // charI ?gFchar. +have ntZ: Z :!=: 1%g. + rewrite /Z; case: ifPn => [_ | /caseB_P[]//]. + by rewrite /= setIC meet_center_nil // (sameP eqP derG1P). +have nsZH := sub_center_normal sZZ; have [sZH nZH] := andP nsZH. +have regZL: {in Z^# &, forall x y, #|'C_L[x]| = #|'C_L[y]| }. + have [inA | /caseB_cZL cZL] := boolP caseA; last first. + suffices defC x: x \in Z^# -> 'C_L[x] = L by move=> x y /defC-> /defC->. + by case/setD1P=> _ /(subsetP cZL)/setIP[_]; rewrite -sub_cent1 => /setIidPl. + suffices defC x: x \in Z^# -> 'C_L[x] = H by move=> x y /defC-> /defC->. + case/setD1P=> ntx Zx; have /setIP[Hx cHx] := subsetP sZZ x Zx. + have [_ <- _ _] := sdprodP defL; rewrite -group_modl ?sub_cent1 //=. + suffices ->: 'C_W1[x] = 1%g by rewrite mulg1. + have [/Frobenius_reg_compl-> // | in_c2] := boolP case_c1; first exact/setD1P. + have [_ [_ [_ _ _ regW1] _] _ _] := c2W2 in_c2. + apply: contraNeq ntx => /trivgPn[y /setIP[W1y cxy] nty]. + rewrite -in_set1 -set1gE -((_ =P [1]) inA) -(regW1 y) 2!inE ?nty //. + by rewrite inE cent1C cHx Hx. +have Zconst_modH := + constant_irr_mod_TI_Sylow sylH oddL tiA (And3 nsZL ntZ sZZ) regZL. +pose X := seqIndD H L Z 1; pose Y := seqIndD H L H H^`(1). +have ccsXS: cfConjC_subset X S by apply: seqInd_conjC_subset1. +have ccsYS: cfConjC_subset Y S by apply: seqInd_conjC_subset1. +have [[uX sXS ccX] [uY sYS ccY]] := (ccsXS, ccsYS). +have X'Y: {subset Y <= [predC X]}. + move=> _ /seqIndP[i /setIdP[_ kH'i] ->]; rewrite inE in kH'i. + by rewrite !inE mem_seqInd ?normal1 // !inE sub1G (subset_trans sZH'). +have irrY: {subset Y <= irr L}. + move=> _ /seqIndP[i /setIdP[not_kHi kH'i] ->]; rewrite !inE in not_kHi kH'i. + have kH'iInd: H^`(1)%g \subset cfker ('Ind[L] 'chi_i). + by rewrite sub_cfker_Ind_irr ?normal_norm. + rewrite -(cfQuoK nsH'L kH'iInd) -cfIndQuo // -quo_IirrE //. + set i1 := quo_Iirr _ i; have /irrP[k ->]: 'Ind 'chi_i1 \in irr (L / H^`(1)). + apply: irr_induced_Frobenius_ker; first exact: FrobeniusWker frobL1. + apply: contraNneq not_kHi; rewrite -(quo_IirrK nsH'H kH'i) -/i1 => ->. + by rewrite mod_IirrE // irr0 cfMod_cfun1 ?cfker_cfun1. + by rewrite -mod_IirrE ?mem_irr. +have uniY: {in Y, forall phi : 'CF(L), phi 1%g = #|W1|%:R}. + move=> _ /seqIndP[i /setIdP[_ kH'i] ->]; rewrite inE -lin_irr_der1 in kH'i. + rewrite cfInd1 // -divgS // -(sdprod_card defL) mulKn //. + by case/andP: kH'i => _ /eqP->; rewrite mulr1. +have scohY: subcoherent Y tau R by apply: (subset_subcoherent scohS). +have [tau1 cohY]: coherent Y L^# tau. + apply/(uniform_degree_coherence scohY)/(@all_pred1_constant _ #|W1|%:R). + by apply/allP=> _ /mapP[phi Yphi ->]; rewrite /= uniY. +have [[Itau1 Ztau1] Dtau1] := cohY. +have [eta1 Yeta1]: exists eta1, eta1 \in Y. + pose IY := Iirr_kerD H H H^`(1)%G. + have [IY0 | [j IYj]] := set_0Vmem IY; last first. + by exists ('Ind 'chi_j); apply/seqIndP; exists j. + have /idPn[]: \sum_(j in IY) ('chi_j 1%g) ^+ 2 == 0 by rewrite IY0 big_set0. + rewrite sum_Iirr_kerD_square ?der_sub // indexgg mul1r subr_eq0. + by rewrite pnatr_eq1 indexg_eq1 proper_subn. +have caseA_coh12: caseA -> coherent (X ++ Y) L^# tau. + move=> haveA. + have scohX: subcoherent X tau R by apply: subset_subcoherent ccsXS. + have irrX: {subset X <= irr L}. + have [/c1_irr irrS | in_c2] := boolP case_c1. + move=> phi Xphi; apply: irrS; apply: seqIndS phi Xphi. + by rewrite Iirr_kerDS // (subset_trans sZH') ?der_sub. + move/(_ in_c2) in prW2; have [_ ptiL _ _] := c2W2 in_c2. + have [[_ _ _ cycW1] [ntW2 sW2H cycW2 prW1H] oddW] := ptiL. + have nZL := normal_norm nsZL; have nZW1 := subset_trans sW1L nZL. + have isoW2: (W2 / Z)%g \isog W2. + apply/isog_symr/quotient_isog; first exact: subset_trans sW2H nZH. + by rewrite -(setIidPr sZZ) setIAC ((_ =P [1]) haveA) setI1g. + have [|defWb ptiLZ] := primeTIhyp_quotient ptiL _ sZH nsZL. + by rewrite (isog_eq1 isoW2). + pose Ichi := primeTI_Ires ptiL; pose IchiZ := primeTI_Ires ptiLZ. + have eq_Ichi: codom (fun j1 => mod_Iirr (IchiZ j1)) =i codom Ichi. + apply/subset_cardP. + rewrite !card_codom; last first; try exact: prTIres_inj. + apply: inj_comp (prTIres_inj ptiLZ). + exact: can_inj (mod_IirrK (sub_center_normal sZZ)). + by rewrite !card_ord !NirrE (nclasses_isog isoW2). + apply/subsetP=> _ /codomP[/= j1 ->]. + have [[j2 /irr_inj->] | ] := prTIres_irr_cases ptiL (mod_Iirr (IchiZ j1)). + exact: codom_f. + case=> /idPn[]; rewrite mod_IirrE // cfIndMod // cfInd_prTIres. + apply: contra (prTIred_not_irr ptiLZ j1) => /irrP[ell Dell]. + by rewrite -[_ j1]cfModK // Dell -quo_IirrE ?mem_irr // -Dell cfker_mod. + move=> _ /seqIndP[k /setDP[_ kZ'k] ->]. + have [[j /irr_inj Dk] | [] //] := prTIres_irr_cases ptiL k. + case/negP: kZ'k; have: k \in codom Ichi by rewrite Dk codom_f. + by rewrite -eq_Ichi => /codomP[j1 ->]; rewrite !inE mod_IirrE ?cfker_mod. + have [//|] := seqIndD_irr_coherence nsHL solH scohS odd_frobL1 _ irrX. + rewrite -/X => defX [tau2 cohX]; have [[Itau2 Ztau2] Dtau2] := cohX. + have [xi1 Xxi1 Nd]: + exists2 xi1, xi1 \in X & forall xi, xi \in X -> (xi1 1%g %| xi 1%g)%C. + - pose IX := Iirr_kerD H Z 1%G; have [i0 IXi0]: exists i0, i0 \in IX. + apply/set0Pn; apply: contraNneq ntZ => IX_0. + have: \sum_(i in IX) ('chi_i 1%g) ^+ 2 == 0 by rewrite IX_0 big_set0. + rewrite sum_Iirr_kerD_square ?normal1 ?sub1G // indexg1 mulf_eq0. + by rewrite (negPf (neq0CiG H Z)) subr_eq0 trivg_card1 -eqC_nat. + have:= erefl [arg min_(i < i0 in IX) truncC ('chi_i 1%g)]. + have [//|{i0 IXi0} i1 IXi1 min_i1 _] := arg_minP. + exists ('Ind 'chi_i1); first by apply/seqIndP; exists i1. + move=> _ /seqIndP[i /min_i1 le_i1_i] ->; rewrite !cfInd1 //. + have pHP := p_natP (pnat_dvd _ pH). + move: (dvd_irr1_cardG i1) (dvd_irr1_cardG i) le_i1_i. + rewrite !irr1_degree -!natrM !dvdC_nat => /pHP[m1 ->] /pHP[m ->]. + rewrite !natCK leq_exp2l ?prime_gt1 // => /subnKC <-. + by rewrite expnD mulnA dvdn_mulr. + pose d (xi : 'CF(L)) : algC := (truncC (xi 1%g / xi1 1%g))%:R. + have{Nd} def_d xi: xi \in X -> xi 1%g = d xi * xi1 1%g. + rewrite /d => Xxi; move: Xxi (Nd _ Xxi) => /irrX/irrP[i ->]. + have /irrX/irrP[i1 ->] := Xxi1. + rewrite !irr1_degree dvdC_nat => /dvdnP[q ->]. + by rewrite natrM -irr1_degree mulfK ?irr1_neq0 // natCK. + have d_xi1: d xi1 = 1. + by apply: (mulIf (seqInd1_neq0 nsHL Xxi1)); rewrite mul1r -def_d. + have oXY: orthogonal X Y. + apply/orthogonalP=> xi eta Xxi Yeta; apply: orthoPr xi Xxi. + exact: (subset_ortho_subcoherent scohS sXS (sYS _ Yeta) (X'Y _ Yeta)). + have [_ [Itau Ztau] /orthogonal_free freeS _ _] := scohS. + have o_tauXY: orthogonal (map tau2 X) (map tau1 Y). + exact: (coherent_ortho scohS). + have [a Na Dxi11]: exists2 a, a \in Cnat & xi1 1%g = a * #|W1|%:R. + have [i1 _ ->] := seqIndP Xxi1. + exists ('chi_i1 1%g); first exact: Cnat_irr1. + by rewrite cfInd1 // -divgS // -(sdprod_card defL) ?mulKn // mulrC. + pose psi1 := xi1 - a *: eta1; have Za: a \in Cint by rewrite CintE Na. + have Zpsi1: psi1 \in 'Z[S, L^#]. + rewrite zcharD1E !cfunE (uniY _ Yeta1) -Dxi11 subrr eqxx. + by rewrite rpredB ?scale_zchar ?mem_zchar ?(sXS _ Xxi1) // sYS. + have [Y1 dY1 [X1 [dX1 _ oX1tauY]]] := orthogonal_split (map tau1 Y)(tau psi1). + have oY: orthonormal Y by apply: sub_orthonormal (irr_orthonormal L). + have oYtau: orthonormal (map tau1 Y) by apply: map_orthonormal. + have{dX1 Y1 dY1} [b Zb Dpsi1]: {b | b \in Cint & + tau psi1 = X1 - a *: tau1 eta1 + b *: (\sum_(eta <- Y) tau1 eta)}. + - exists ('[tau psi1, tau1 eta1] + a). + rewrite rpredD // Cint_cfdot_vchar ?Ztau1 ?seqInd_zcharW //. + exact: zcharW (Ztau _ Zpsi1). + rewrite {1}dX1 addrC -addrA; congr (_ + _). + have [_ -> ->] := orthonormal_span oYtau dY1. + rewrite -[Y1](addrK X1) -dX1 big_map !(big_rem eta1 Yeta1) /=. + rewrite cfdotBl (orthoPl oX1tauY) ?map_f // subr0. + rewrite scalerDr addrA; congr (_ + _). + by rewrite addrC -scaleNr -scalerDl addrK. + rewrite raddf_sum; apply: eq_big_seq => eta. + rewrite mem_rem_uniq ?seqInd_uniq // => /andP[eta1'eta /= Yeta]. + congr (_ *: _); rewrite cfdotBl (orthoPl oX1tauY) ?map_f // subr0 addrC. + apply: canRL (subrK _) _; rewrite -2!raddfB /=. + have Zeta: (eta - eta1) \in 'Z[Y, L^#]. + by rewrite zcharD1E rpredB ?seqInd_zcharW //= !cfunE !uniY ?subrr. + rewrite Dtau1 // Itau // ?(zchar_subset sYS) //. + rewrite cfdotBl cfdotZl !cfdotBr 2?(orthogonalP oXY) // subr0 add0r. + have [_ oYY] := orthonormalP oY; rewrite !oYY // eqxx. + by rewrite eq_sym (negPf eta1'eta) add0r mulrN mulr1 opprK. + pose psi := 'Res[L] (tau1 eta1). + have [X2 dX2 [xi' [dxi' _ oxi'X]]] := orthogonal_split X psi. + have oX: orthonormal X by apply: sub_orthonormal (irr_orthonormal L). + have Zpsi: psi \in 'Z[irr L] by rewrite cfRes_vchar ?Ztau1 ?seqInd_zcharW. + pose sumXd := \sum_(xi <- X) d xi *: xi. + have Zxi1Xd xi: xi \in X -> xi - d xi *: xi1 \in 'Z[X, L^#]. + move=> Xxi; rewrite zcharD1E !cfunE -def_d // subrr eqxx. + by rewrite rpredB ?scale_zchar ?seqInd_zcharW ?rpred_nat. + have{dxi' X2 dX2} [c Zc Dpsi]: {c | c \in Cint & psi = c *: sumXd + xi'}. + exists '[psi, xi1]; first by rewrite Cint_cfdot_vchar ?(seqInd_vcharW Xxi1). + rewrite {1}dxi'; congr (_ + _); have [_ -> ->] := orthonormal_span oX dX2. + rewrite -[X2](addrK xi') -dxi' raddf_sum; apply: eq_big_seq => /= xi Xxi. + rewrite cfdotBl (orthoPl oxi'X) // subr0 scalerA; congr (_ *: _). + apply/eqP; rewrite -subr_eq0 mulrC -[d xi]conj_Cnat ?Cnat_nat //. + rewrite -cfdotZr -cfdotBr cfdot_Res_l -Dtau2 ?Zxi1Xd //. + rewrite cfdotC raddfB raddfZ_Cnat ?Cnat_nat // cfdotBl cfdotZl. + by rewrite !(orthogonalP o_tauXY) ?map_f // mulr0 subr0 conjC0. + have Exi' z: z \in Z -> xi' z = xi' 1%g. + move=> Zz; rewrite [xi']cfun_sum_cfdot !sum_cfunE; apply: eq_bigr => ell _. + have [Xell |] := boolP ('chi_ell \in X). + by rewrite !cfunE (orthoPl oxi'X) ?mul0r. + by rewrite !cfunE defX inE /= mem_irr negbK => /subsetP/(_ z Zz)/cfker1->. + have Eba: '[psi, psi1] = b - a. + rewrite cfdot_Res_l -/tau Dpsi1 -addrA !cfdotDr cfdotNr cfdotZr. + rewrite cfdotC (orthoPl oX1tauY) ?map_f // conjC0 add0r addrC. + rewrite cfdotC raddf_sum cfproj_sum_orthonormal // !aut_Cint //. + by have [_ ->] := orthonormalP oYtau; rewrite ?map_f // eqxx mulr1. + have nz_xi11: xi1 1%g != 0 by have /irrX/irrP[i ->] := Xxi1; apply: irr1_neq0. + have {Eba} Ebc: (a %| b - c)%C. + rewrite -[b](subrK a) -Eba cfdotBr {1}Dpsi cfdotDl cfdotZl. + rewrite cfproj_sum_orthonormal // (orthoPl oxi'X) // addr0 d_xi1 mulr1. + rewrite addrC -addrA addKr addrC rpredB ?dvdC_refl //= cfdotZr aut_Cint //. + by rewrite dvdC_mulr // Cint_cfdot_vchar ?(seqInd_vcharW Yeta1). + have DsumXd: sumXd = (xi1 1%g)^-1 *: (cfReg L - (cfReg (L / Z)%g %% Z)%CF). + apply: canRL (scalerK nz_xi11) _; rewrite !cfReg_sum 2!linear_sum /=. + pose F (xi : 'CF(L)) := xi 1%g *: xi; transitivity (\sum_(xi <- X) F xi). + by apply: eq_big_seq => xi Xxi; rewrite scalerA mulrC -def_d. + rewrite (bigID (mem (Iirr_ker L Z))) /=; apply: canRL (addrK _) _. + rewrite addrC; congr (_ + _). + rewrite (eq_bigl _ _ (in_set _)) (reindex _ (mod_Iirr_bij nsZL)) /=. + apply: eq_big => [i | i _]; first by rewrite mod_IirrE ?cfker_mod. + by rewrite linearZ mod_IirrE // cfMod1. + transitivity (\sum_(xi <- [seq 'chi_i | i in [predC Iirr_ker L Z]]) F xi). + apply: eq_big_perm; apply: uniq_perm_eq => // [|xi]. + by rewrite (map_inj_uniq irr_inj) ?enum_uniq. + rewrite defX inE /=; apply/andP/imageP=> [[/irrP[i ->] kerZ'i] | [i]]. + by exists i; rewrite ?inE. + by rewrite !inE => ? ->; rewrite mem_irr. + by rewrite big_map big_filter; apply: eq_bigl => i; rewrite !inE. + have eta1tauZ z: z \in Z^# -> tau1 eta1 z - tau1 eta1 1%g = - c * #|H|%:R / a. + case/setD1P=> ntz Zz; transitivity (psi z - psi 1%g). + by rewrite !cfResE ?(subsetP (normal_sub nsZL)). + rewrite Dpsi DsumXd !cfunE Exi' ?cfuniE ?normal1 // set11 inE (negPf ntz). + rewrite mulr0 mulr1 sub0r Dxi11 cfker1 ?cfker_reg_quo //. + set cc := c * _ + _; rewrite 2!mulrDr -[rhs in _ - rhs]addrA -/cc. + rewrite addrC opprD {cc}subrK -(sdprod_card defL) mulnC natrM. + by rewrite invfM !mulrA divfK ?neq0CG // mulrAC -2!mulNr. + have{eta1tauZ} dvHpsi: (#|H| %| - c * #|H|%:R / a)%C. + have /dirrP[e [i Deta1]]: tau1 eta1 \in dirr G. + rewrite dirrE Ztau1 ?Itau1 ?seqInd_zcharW //=. + by have [_ ->] := orthonormalP oY; rewrite ?eqxx. + have [z ntz Zz] := trivgPn _ ntZ; have Z1z: z \in Z^# by apply/setD1P. + have /(Zconst_modH i)[|_] := Z1z. + move=> z1 z2 Zz1 Zz2; rewrite -(canLR (signrZK e) Deta1) !cfunE. + by apply/eqP; do 2!rewrite eq_sym (canRL (subrK _) (eta1tauZ _ _)) //. + by rewrite -(canLR (signrZK e) Deta1) !cfunE -mulrBr eta1tauZ // rpredMsign. + have nz_a: a != 0 by rewrite Dxi11 mulf_eq0 negb_or neq0CG andbT in nz_xi11. + have{dvHpsi} dv_ac: (a %| c)%C. + move: dvHpsi; rewrite !mulNr mulrAC rpredN => /dvdCP[q Zq]. + by move/(mulIf (neq0CG H))/(canRL (divfK nz_a))->; apply: dvdC_mull. + have{Ebc dv_ac} /dvdCP[q Zq Db]: (a %| b)%C by rewrite -[b](subrK c) rpredD. + pose m : algC := (size Y)%:R. + have Da1: 1 + a ^+ 2 = '[X1] + a ^+ 2 * ((q - 1) ^+ 2 + (m - 1) * q ^+ 2). + transitivity '[psi1]. + rewrite cfnormBd; last by rewrite cfdotZr (orthogonalP oXY) ?mulr0. + rewrite cfnormZ Cint_normK //. + have [[_ -> //] [_ -> //]]:= (orthonormalP oX, orthonormalP oY). + by rewrite !eqxx mulr1. + rewrite -Itau // Dpsi1 -addrA cfnormDd; last first. + rewrite addrC cfdotBr !cfdotZr cfdot_sumr (orthoPl oX1tauY) ?map_f //. + rewrite big_seq big1 ?mulr0 ?subrr // => eta Yeta. + by rewrite (orthoPl oX1tauY) ?map_f //. + congr (_ + _); rewrite cfnormD cfnormN !cfnormZ. + have [_ ->] := orthonormalP oYtau; rewrite ?map_f // eqxx mulr1. + rewrite cfnorm_map_orthonormal // -/m !Cint_normK // cfdotNl cfdotZl. + rewrite linear_sum cfdotC cfproj_sum_orthonormal // rmorphN rmorphM. + rewrite conjCK !aut_Cint // -mulr2n mulNrn -[_ - _]addrAC. + rewrite mulrDr -{1}[m](addNKr 1) mulrDr mulr1 addrA -sqrrB. + congr (_ + _); last by rewrite mulrCA -exprMn (mulrC a) addrC -Db mulrC. + by rewrite -exprMn -sqrrN opprB mulrBr mulr1 (mulrC a) -Db. + have{Da1} maxq: ~~ (2%:R <= (q - 1) ^+ 2 + (m - 1) * q ^+ 2). + have a2_gt1: a ^+ 2 > 1. + have /seqIndP[i1 /setDP[_ not_kerH'i1] Dxi1] := Xxi1. + apply: contraR not_kerH'i1; rewrite inE expr_gt1 ?Cnat_ge0 //. + have [n Da] := CnatP a Na; rewrite Da ltr1n -leqNgt leq_eqVlt. + rewrite ltnNge lt0n -!eqC_nat -{n}Da nz_a orbF => /eqP a_eq1. + rewrite (subset_trans sZH') // -lin_irr_der1 qualifE irr_char. + rewrite -(inj_eq (mulfI (neq0CiG L H))) -cfInd1 // -Dxi1 Dxi11 a_eq1. + by rewrite mul1r mulr1 -divgS //= -(sdprod_card defL) mulKn. + rewrite -(ler_pmul2l (ltr_trans ltr01 a2_gt1)) ltr_geF // mulr_natr. + apply: ler_lt_trans (_ : 1 + a ^+ 2 < _); last by rewrite ltr_add2r. + by rewrite Da1 -subr_ge0 addrK cfnorm_ge0. + clear psi Dpsi Zpsi Zb c sumXd DsumXd Zc xi' Exi' oxi'X. + wlog{Dpsi1 Itau1 Ztau1 Dtau1 oYtau b q maxq Db Zq} Dpsi1: + tau1 cohY o_tauXY oX1tauY / tau psi1 = X1 - a *: tau1 eta1. + - move=> IH; have [q0 | nz_q] := eqVneq q 0. + by apply: (IH tau1) => //; rewrite Dpsi1 Db q0 mul0r scale0r addr0. + have m1_ge1: 1 <= m - 1. + rewrite -(@ler_add2r _ 1) subrK (ler_nat _ 2). + exact: seqInd_nontrivial (irrY _ Yeta1) (Yeta1). + have q1: q = 1. + apply: contraNeq maxq; rewrite -subr_eq0 => nz_q1. + rewrite ler_add // ?sqr_Cint_ge1 ?rpredB //. + rewrite (ler_trans m1_ge1) // -{1}[m - 1]mulr1. + by rewrite ler_pmul2l ?sqr_Cint_ge1 // (ltr_le_trans ltr01). + have szY2: (size Y <= 2)%N. + move: maxq; rewrite q1 subrr exprS mul0r add0r mulrA !mulr1. + by rewrite -(ler_add2r 1) subrK -mulrSr ler_nat -leqNgt. + have defY: perm_eq Y (eta1 :: eta1^*)%CF. + have uYeta: uniq (eta1 :: eta1^*)%CF. + by rewrite /= andbT inE eq_sym; have [[_ /hasPn/=->]] := scohY. + rewrite perm_eq_sym uniq_perm_eq //. + have [|//]:= leq_size_perm uYeta _ szY2. + by apply/allP; rewrite /= Yeta1 ccY. + have memYtau1c: {subset map (tau1 \o cfAut conjC) Y <= map tau1 Y}. + by move=> _ /mapP[eta Yeta ->]; rewrite /= map_f ?ccY. + apply: (IH _ (dual_coherence scohY cohY szY2)). + - rewrite (map_comp -%R) orthogonal_oppr. + by apply/orthogonalP=> phi psi ? /memYtau1c; apply: (orthogonalP o_tauXY). + - rewrite (map_comp -%R) orthogonal_oppr. + by apply/orthoPl=> psi /memYtau1c; apply: (orthoPl oX1tauY). + rewrite Dpsi1 (eq_big_perm _ defY) Db q1 /= mul1r big_cons big_seq1. + by rewrite scalerDr addrA subrK -scalerN opprK. + have [[[Itau1 Ztau1] Dtau1] [_ oXX]] := (cohY, orthonormalP oX). + have n1X1: '[X1] = 1. + apply: (addIr '[a *: tau1 eta1]); rewrite -cfnormBd; last first. + by rewrite cfdotZr (orthoPl oX1tauY) ?mulr0 ?map_f. + rewrite -Dpsi1 Itau // cfnormBd; last first. + by rewrite cfdotZr (orthogonalP oXY) ?mulr0. + by rewrite !cfnormZ Itau1 ?seqInd_zcharW // oXX ?eqxx. + without loss{Itau2 Ztau2 Dtau2} defX1: tau2 cohX o_tauXY / X1 = tau2 xi1. + move=> IH; have ZX: {subset X <= 'Z[X]} by apply: seqInd_zcharW. + have dirrXtau xi: xi \in X -> tau2 xi \in dirr G. + by move=> Xxi; rewrite dirrE Ztau2 1?Itau2 ?ZX //= oXX ?eqxx. + have dirrX1: X1 \in dirr G. + rewrite dirrE n1X1 eqxx -[X1](subrK (a *: tau1 eta1)) -Dpsi1. + rewrite rpredD ?scale_zchar ?(zcharW (Ztau _ _)) //. + by rewrite Ztau1 ?seqInd_zcharW. + have oX1_Xd xi: + xi \in X -> xi != xi1 -> '[d xi *: tau2 xi1 - tau2 xi, X1] = d xi. + - move=> Xxi xi1'xi; have ZXxi := Zxi1Xd xi Xxi. + rewrite -[X1](subrK (a *: tau1 eta1)) -Dpsi1 cfdotDr cfdotZr addrC. + rewrite cfdotBl cfdotZl 2?(orthogonalP o_tauXY) ?map_f //. + rewrite !(mulr0, subr0, conjC0) add0r -{1}raddfZ_Cnat ?Cnat_nat //. + rewrite -opprB cfdotNl -raddfB Dtau2 //. + rewrite Itau //; last exact: zchar_subset ZXxi. + rewrite cfdotBr cfdotZr addrC !cfdotBl !cfdotZl. + rewrite 2?(orthogonalP oXY) // !(mulr0, oppr0, add0r, conjC0). + by rewrite !oXX // eqxx (negPf xi1'xi) add0r opprK mulr1. + have Xxi2: xi1^*%CF \in X by apply: ccX. + have xi1'2: xi1^*%CF != xi1 by have [[_ /hasPn->]] := scohX. + have xi2tau_irr: - tau2 xi1^*%CF \in dirr G by rewrite dirr_opp dirrXtau. + have d_xi2: d xi1^*%CF = 1. + by rewrite /d cfunE conj_Cnat // (Cnat_seqInd1 Xxi1). + have [||def_X1]:= cfdot_add_dirr_eq1 (dirrXtau _ Xxi1) xi2tau_irr dirrX1. + - by rewrite -[tau2 xi1]scale1r -d_xi2 oX1_Xd. + - exact: IH. + have sX_xi12: {subset X <= xi1 :: xi1^*%CF}. + apply/allP/allPn=> [[xi3 Xxi3 /norP[xi1'3 /norP[xi2'3 _]]]]. + suffices d3_0: d xi3 = 0. + by have:= seqInd1_neq0 nsHL Xxi3; rewrite def_d // d3_0 mul0r eqxx. + rewrite -oX1_Xd // def_X1 cfdotNr cfdotBl cfdotZl !Itau2 ?ZX //. + by rewrite !oXX // (negPf xi2'3) eq_sym (negPf xi1'2) mulr0 add0r opprK. + have{sX_xi12 defX} defX: perm_eq X (xi1 :: xi1^*%CF). + have uXxi: uniq (xi1 :: xi1^*)%CF by rewrite /= andbT inE eq_sym. + rewrite perm_eq_sym uniq_perm_eq // => xi. + by apply/idP/idP; [rewrite !inE => /pred2P[]-> | apply: sX_xi12]. + have szX2: (size X <= 2)%N by rewrite (perm_eq_size defX). + apply: (IH _ (dual_coherence scohX cohX szX2)) def_X1. + rewrite (map_comp -%R) orthogonal_oppl. + apply/orthogonalP=> _ eta /mapP[xi Xxi ->]. + by apply: (orthogonalP o_tauXY); rewrite map_f ?ccX. + move: Dpsi1; rewrite -raddfZ_Cnat // defX1. + apply: (bridge_coherent scohS ccsXS cohX ccsYS cohY X'Y). + by rewrite (zchar_on Zpsi1) rpredZ_Cnat ?mem_zchar. +have{caseA_coh12} cohXY: coherent (X ++ Y) L^# tau. + have [/caseA_coh12// | caseB] := boolP caseA. + have defZ: Z = W2 by rewrite /Z (negPf caseB). + have{caseB} [case_c2 _ _] := caseB_P caseB. + move/(_ case_c2) in oRW; pose PtypeL := c2W2 case_c2. + have{prW2} pr_w2 := prW2 case_c2; set w2 := #|W2| in pr_w2. + have /cyclicP[z0 cycZ]: cyclic Z by rewrite defZ prime_cyclic. + have idYZ: {in Y & Z^#, forall (eta : 'CF(L)) x, tau1 eta x = tau1 eta z0}. + move=> eta x Yeta; rewrite !inE andbC cycZ => /andP[/cyclePmin[k]]. + rewrite orderE -cycZ defZ -/w2 => lt_k_w2 -> nt_z0k. + have k_gt0: (0 < k)%N by rewrite lt0n (contraNneq _ nt_z0k) // => ->. + have cokw2: coprime k w2 by rewrite coprime_sym prime_coprime // gtnNdvd. + have sW2G: W2 \subset G by rewrite -defW2 subIset // (subset_trans sHL). + have [u Du _]:= make_pi_cfAut G cokw2. + rewrite -Du ?Ztau1 ?seqInd_zcharW //; last by rewrite orderE -cycZ defZ. + have nAL: L \subset 'N(A) by rewrite normD1 normal_norm. + pose ddA := restr_Dade_hyp PtypeL (subsetUl _ _) nAL. + have cohY_Dade: coherent_with Y L^# (Dade ddA) tau1. + split=> // phi Yphi; rewrite Dtau1 ?Dade_Ind //. + by rewrite (@zchar_on _ _ Y) -?zcharD1_seqInd. + rewrite (cfAut_Dade_coherent cohY_Dade) ?irrY //; last first. + split; last exact: cfAut_seqInd. + exact: seqInd_nontrivial_irr (irrY _ Yeta) (Yeta). + rewrite -[cfAut u _](subrK eta) raddfD cfunE. + apply: canLR (subrK _) _; rewrite subrr. + have [_ ->] := cohY_Dade; last first. + by rewrite -opprB rpredN zcharD1_seqInd // seqInd_sub_aut_zchar. + rewrite Dade_id; last first. + by rewrite !inE -cycle_eq1 -cycle_subG -cycZ ntZ. + rewrite !cfunE cfker1 ?aut_Cnat ?subrr ?(Cnat_seqInd1 Yeta) //. + rewrite -cycle_subG -cycZ (subset_trans sZH') //. + have [j /setDP[kerH'j _] ->] := seqIndP Yeta. + by rewrite inE in kerH'j; rewrite sub_cfker_Ind_irr. + have [_ [Itau _] oSS _ _] := scohS. + have oY: orthonormal Y by apply: sub_orthonormal (irr_orthonormal L). + have oYtau: orthonormal (map tau1 Y) by apply: map_orthonormal. + have oXY: orthogonal X Y. + apply/orthogonalP=> xi eta Xxi Yeta; apply: orthoPr xi Xxi. + exact: (subset_ortho_subcoherent scohS sXS (sYS _ Yeta) (X'Y _ Yeta)). + have [Y1 Dpsi1 defY1]: exists2 Y1, + forall i : Iirr Z, i != 0 -> + exists2 X1 : 'CF(G), orthogonal X1 (map tau1 Y) + & tau ('Ind 'chi_i - #|H : Z|%:R *: eta1) = X1 - #|H : Z|%:R *: Y1 + & Y1 = tau1 eta1 \/ size Y = 2 /\ Y1 = dual_iso tau1 eta1. + - have [i0 nz_i0]: exists i0 : Iirr Z, i0 != 0. + by apply: (ex_intro _ (Sub 1%N _)) => //; rewrite NirrE classes_gt1. + pose psi1 := tau1 eta1; pose b := psi1 z0. + pose a := (psi1 1%g - b) / #|Z|%:R. + have sZL := normal_sub nsZL; have sZG := subset_trans sZL sLG. + have Dpsi1: 'Res psi1 = a *: cfReg Z + b%:A. + apply/cfun_inP=> z Zz. + rewrite cfResE // !cfunE cfun1E Zz mulr1 cfuniE ?normal1 // inE. + have [-> | ntz] := altP eqP; first by rewrite mulr1 divfK ?neq0CG ?subrK. + by rewrite !mulr0 add0r idYZ // !inE ntz. + have /dvdCP[x0 Zx0 Dx0]: (#|H : Z| %| a)%C. + have /dvdCP[x Zx Dx]: (#|H| %| b - psi1 1%g)%C. + have psi1Z z: z \in Z^# -> psi1 z = b. + case/setD1P=> ntz Zz; rewrite -(cfResE _ _ Zz) // Dpsi1 !cfunE cfun1E. + by rewrite cfuniE ?normal1 // Zz inE (negPf ntz) !mulr0 mulr1 add0r. + have /dirrP[e [i /(canLR (signrZK e)) Epsi1]]: psi1 \in dirr G. + have [_ oYt] := orthonormalP oYtau. + by rewrite dirrE oYt ?map_f // !eqxx Ztau1 ?seqInd_zcharW. + have Zz: z0 \in Z^# by rewrite !inE -cycle_eq1 -cycle_subG -cycZ ntZ /=. + have/(Zconst_modH i)[z1 Zz1 z2 Zz2 |_] := Zz. + by rewrite -Epsi1 !cfunE !psi1Z. + by rewrite -Epsi1 !cfunE -mulrBr rpredMsign psi1Z. + apply/dvdCP; exists (- x); first by rewrite rpredN. + rewrite /a -opprB Dx -(Lagrange sZH) mulnC [p in x * p]natrM -!mulNr. + by rewrite !mulrA !mulfK ?neq0CG. + pose x1 := '[eta1, 'Res psi1]; pose x := x0 + 1 - x1. + have Zx: x \in Cint. + rewrite rpredB ?rpredD // Cint_cfdot_vchar // ?(seqInd_vcharW Yeta1) //. + by rewrite cfRes_vchar // Ztau1 ?seqInd_zcharW. + pose Y1 := - \sum_(eta <- Y) (x - (eta == eta1)%:R) *: tau1 eta. + pose alpha i := 'Ind[L, Z] 'chi_i - #|H : Z|%:R *: eta1. + have IZfacts i: i != 0 -> + [/\ 'chi_i 1%g = 1, 'Ind[L, Z] 'chi_i \in 'Z[X] & alpha i \in 'Z[S, L^#]]. + - move=> nzi; have /andP[_ /eqP lin_i]: 'chi_i \is a linear_char. + by rewrite lin_irr_der1 (derG1P _) ?sub1G // cycZ cycle_abelian. + have Xchi: 'Ind 'chi_i \in 'Z[X]. + rewrite -(cfIndInd _ sHL) // ['Ind[H] _]cfun_sum_constt linear_sum. + apply: rpred_sum => k k_i; rewrite linearZ; apply: scale_zchar. + by rewrite Cint_cfdot_vchar_irr // cfInd_vchar ?irr_vchar. + rewrite seqInd_zcharW //; apply/seqIndP; exists k => //. + rewrite !inE sub1G andbT; apply: contra k_i => kerZk. + rewrite -Frobenius_reciprocity. + have ->: 'Res[Z] 'chi_k = ('chi_k 1%g)%:A. + apply: cfun_inP => z Zz; rewrite cfunE cfun1E Zz mulr1 cfResE //. + by rewrite cfker1 ?(subsetP kerZk). + by rewrite cfdotZr -irr0 cfdot_irr (negPf nzi) mulr0. + split=> //; rewrite zcharD1E !cfunE cfInd1 // uniY // lin_i mulr1. + rewrite -divgS // -(sdprod_card defL) -(Lagrange sZH) -mulnA mulKn //. + rewrite -natrM subrr rpredB //=; first by rewrite (zchar_subset sXS). + by rewrite scale_zchar ?rpred_nat // seqInd_zcharW ?sYS. + have Dalpha (i : Iirr Z) (nzi : i != 0) : + exists2 X1 : 'CF(G), orthogonal X1 (map tau1 Y) + & tau (alpha i) = X1 - #|H : Z|%:R *: Y1. + - have [lin_i Xchi Zalpha] := IZfacts i nzi. + have Da: '[tau (alpha i), psi1] = a - #|H : Z|%:R * x1. + rewrite !(=^~ Frobenius_reciprocity, cfdotBl) cfResRes // cfdotZl. + congr (_ - _); rewrite cfdotC Dpsi1 cfdotDl cfdotZl cfReg_sum. + rewrite cfdot_suml (bigD1 i) //= big1 => [|j i'j]; last first. + by rewrite cfdotZl cfdot_irr (negPf i'j) mulr0. + rewrite !cfdotZl cfnorm_irr lin_i addr0 !mulr1. + rewrite -irr0 cfdot_irr eq_sym (negPf nzi) mulr0 addr0. + by rewrite aut_Cint // Dx0 rpredM ?rpred_nat. + have [Y2 dY2 [X1 [dX1 _ oX1Yt]]] := + orthogonal_split (map tau1 Y) (tau (alpha i)). + exists X1 => //; rewrite dX1 addrC scalerN opprK scaler_sumr. + congr (_ + _); have [_ -> ->] := orthonormal_span oYtau dY2. + rewrite big_map; apply: eq_big_seq => eta Yeta. + rewrite scalerA -[Y2](addrK X1) -dX1 cfdotBl (orthoPl oX1Yt) ?map_f //. + congr (_ *: _); rewrite subr0 !mulrBr mulrDr mulrC -Dx0. + rewrite (addrAC a) -Da -addrA -mulrBr addrC; apply: canRL (subrK _) _. + have Zeta: eta - eta1 \in 'Z[Y, L^#]. + by rewrite zcharD1E rpredB ?seqInd_zcharW //= !cfunE !uniY ?subrr. + rewrite -cfdotBr -raddfB Dtau1 // Itau //; last first. + by rewrite (zchar_subset sYS) ?seqInd_free. + rewrite cfdotBl (span_orthogonal oXY) ?(zchar_span Xchi)//; last first. + by rewrite memvB ?memv_span. + have [_ oYY] := orthonormalP oY; rewrite cfdotZl cfdotBr !oYY //. + by rewrite eqxx sub0r -mulrN opprB eq_sym. + exists Y1 => //; have{Dalpha} [X1 oX1Y Dalpha] := Dalpha i0 nz_i0. + have [lin_i Xchi Zalpha] := IZfacts i0 nz_i0. + have norm_alpha: '[tau (alpha i0)] = (#|L : Z| + #|H : Z| ^ 2)%:R. + rewrite natrD Itau // cfnormBd; last first. + rewrite (span_orthogonal oXY) ?(zchar_span Xchi) //. + by rewrite memvZ ?memv_span. + rewrite cfnorm_Ind_irr //; congr (#|_ : _|%:R + _). + apply/setIidPl; apply: subset_trans (cent_sub_inertia _). + rewrite -(sdprodW defL) mulG_subG (centsS sZZ) centsC ?subsetIr //=. + by rewrite defZ -defW2 subsetIr. + have [_ oYY] := orthonormalP oY; rewrite cfnormZ oYY // eqxx mulr1. + by rewrite normCK rmorph_nat -natrM. + have{norm_alpha} ub_norm_alpha: '[tau (alpha i0)] < (#|H : Z| ^ 2).*2%:R. + rewrite norm_alpha -addnn ltr_nat ltn_add2r. + rewrite -divgS // -(sdprod_card defL) -(Lagrange sZH) -mulnA mulKn //. + rewrite ltn_pmul2l //. + have frobL2: [Frobenius L / Z = (H / Z) ><| (W1 / Z)]%g. + apply: (Frobenius_coprime_quotient defL nsZL) => //. + split=> [|y W1y]; first exact: sub_proper_trans ltH'H. + by rewrite defZ; have [/= ? [_ [_ _ _ ->]]] := PtypeL. + have nZW1 := subset_trans sW1L (normal_norm nsZL). + rewrite (card_isog (quotient_isog nZW1 _)); last first. + by rewrite coprime_TIg ?(coprimeSg sZH). + rewrite -(prednK (indexg_gt0 H Z)) ltnS -card_quotient //. + rewrite dvdn_leq ?(Frobenius_dvd_ker1 frobL2) // -subn1 subn_gt0. + by rewrite cardG_gt1; case/Frobenius_context: frobL2. + pose m : algC := (size Y)%:R. + have{ub_norm_alpha} ub_xm: ~~ (2%:R <= (x - 1) ^+ 2 + (m - 1) * x ^+ 2). + have: ~~ (2%:R <= '[Y1]). + rewrite -2!(ler_pmul2l (gt0CiG H Z)) -!natrM mulnA muln2. + rewrite ltr_geF //; apply: ler_lt_trans ub_norm_alpha. + rewrite Dalpha cfnormBd. + by rewrite cfnormZ normCK rmorph_nat mulrA -subr_ge0 addrK cfnorm_ge0. + rewrite scalerN -scaleNr cfdotZr cfdot_sumr big_seq. + rewrite big1 ?mulr0 // => eta Yeta. + by rewrite cfdotZr (orthoPl oX1Y) ?map_f ?mulr0. + rewrite cfnormN cfnorm_sum_orthonormal // (big_rem eta1) //= eqxx. + rewrite big_seq (eq_bigr (fun _ => (x ^+ 2))) => [|eta]; last first. + rewrite mem_rem_uniq // => /andP[/negPf-> _]. + by rewrite subr0 Cint_normK. + rewrite Cint_normK 1?rpredB //= -big_seq; congr (~~ (_ <= _ + _)). + rewrite big_const_seq count_predT // -Monoid.iteropE. + rewrite /m (perm_eq_size (perm_to_rem Yeta1)) /=. + by rewrite mulrSr addrK mulr_natl. + have [x_eq0 | nz_x] := eqVneq x 0. + left; rewrite /Y1 x_eq0 (big_rem eta1) //= eqxx sub0r scaleN1r. + rewrite big_seq big1 => [|eta]; last first. + by rewrite mem_rem_uniq // => /andP[/negPf-> _]; rewrite subrr scale0r. + by rewrite addr0 opprK. + have m1_ge1: 1 <= m - 1. + rewrite -(@ler_add2r _ 1) subrK (ler_nat _ 2). + exact: seqInd_nontrivial (irrY _ Yeta1) (Yeta1). + right; have x_eq1: x = 1. + apply: contraNeq ub_xm; rewrite -subr_eq0 => nz_x1; apply: ler_add. + by rewrite sqr_Cint_ge1 // rpredB. + rewrite (ler_trans m1_ge1) // -{1}[m - 1]mulr1 ler_pmul2l. + exact: sqr_Cint_ge1. + exact: ltr_le_trans ltr01 m1_ge1. + have szY2: size Y = 2. + apply: contraNeq ub_xm => Yneq2; rewrite x_eq1 /m subrr !exprS mul0r. + rewrite add0r !mul1r mulr1 -(ler_add2r 1) subrK -mulrSr ler_nat. + by rewrite ltn_neqAle eq_sym Yneq2 -leC_nat -/m -[m](subrK 1) ler_add2r. + have eta1'2: eta1^*%CF != eta1 by apply: seqInd_conjC_neq Yeta1. + have defY: perm_eq Y (eta1 :: eta1^*%CF). + have uY2: uniq (eta1 :: eta1^*%CF) by rewrite /= inE eq_sym eta1'2. + rewrite perm_eq_sym uniq_perm_eq //. + have sY2Y: {subset (eta1 :: eta1^*%CF) <= Y}. + by apply/allP; rewrite /= cfAut_seqInd ?Yeta1. + by have [|//]:= leq_size_perm uY2 sY2Y; rewrite szY2. + split=> //; congr (- _); rewrite (eq_big_perm _ defY) /= x_eq1. + rewrite big_cons big_seq1 eqxx (negPf eta1'2) subrr scale0r add0r. + by rewrite subr0 scale1r. + have [a Za Dxa]: exists2 a, forall xi, a xi \in Cint + & forall xi, xi \in X -> xi 1%g = a xi * #|W1|%:R + /\ (exists2 X1 : 'CF(G), orthogonal X1 (map tau1 Y) + & tau (xi - a xi *: eta1) = X1 - a xi *: Y1). + - pose aX (xi : 'CF(L)) : algC := (truncC (xi 1%g / #|W1|%:R))%:R. + exists aX => [xi | xi Xxi]; first exact: rpred_nat. + have [k kerZ'k def_xi] := seqIndP Xxi; rewrite !inE sub1G andbT in kerZ'k. + set a := aX xi; have Dxi1: xi 1%g = a * #|W1|%:R. + rewrite /a /aX def_xi cfInd1 // -divgS // -(sdprod_card defL) mulKn //. + by rewrite mulrC mulfK ?neq0CG // irr1_degree natCK. + split=> //; have Da: a = 'chi_k 1%g. + apply: (mulIf (neq0CG W1)); rewrite -Dxi1 def_xi cfInd1 //. + by rewrite mulrC -divgS // -(sdprod_card defL) mulKn. + have [i0 nzi0 Res_k]: exists2 i: Iirr Z, i != 0 & 'Res 'chi_k = a *: 'chi_i. + have [chi /andP[Nchi lin_chi] defRkZ] := cfcenter_Res 'chi_k. + have sZ_Zk: Z \subset 'Z('chi_k)%CF. + by rewrite (subset_trans sZZ) // -cap_cfcenter_irr bigcap_inf. + have{Nchi lin_chi} /irrP[i defRk] : 'Res chi \in irr Z. + by rewrite lin_char_irr // qualifE cfRes_char // cfRes1. + have{chi defRk defRkZ} defRk: 'Res 'chi_k = a *: 'chi_i. + by rewrite -defRk -linearZ -/a Da -defRkZ /= cfResRes ?cfcenter_sub. + exists i => //; apply: contra kerZ'k. + rewrite -subGcfker => /subsetP sZker. + apply/subsetP=> t Zt; rewrite cfkerEirr inE. + by rewrite -!(cfResE _ sZH) // defRk !cfunE cfker1 ?sZker. + set phi := 'chi_i0 in Res_k; pose a_ i := '['Ind[H] phi, 'chi_i]. + pose rp := irr_constt ('Ind[H] phi). + have defIphi: 'Ind phi = \sum_(i in rp) a_ i *: 'chi_i. + exact: cfun_sum_constt. + have a_k: a_ k = a. + by rewrite /a_ -cfdot_Res_r Res_k cfdotZr cfnorm_irr mulr1 rmorph_nat. + have rp_k: k \in rp by rewrite inE ['[_, _]]a_k Da irr1_neq0. + have resZr i: i \in rp -> 'Res[Z] 'chi_i = a_ i *: phi. + move=> r_i; rewrite ['Res _]cfun_sum_cfdot. + rewrite (bigD1 i0) // big1 => /= [|j i0'j]. + rewrite cfdot_Res_l addr0 -/phi cfdotC conj_Cnat //. + by rewrite Cnat_cfdot_char_irr ?cfInd_char ?irr_char. + apply/eqP; rewrite scaler_eq0 cfdot_Res_l. + rewrite -(inj_eq (mulfI r_i)) mulr0 -/(a_ i) -cfdotZl. + have: '['Ind[H] phi, 'Ind[H] 'chi_j] = 0. + apply: not_cfclass_Ind_ortho => //. + have defIj: 'I_H['chi_j] = H. + apply/setIidPl; apply: subset_trans (cent_sub_inertia _). + by rewrite centsC (subset_trans sZZ) ?subsetIr. + rewrite -(congr1 (cfclass _) defIj) cfclass_inertia inE. + by rewrite eq_sym (inj_eq irr_inj). + rewrite defIphi cfdot_suml => /psumr_eq0P-> //; first by rewrite eqxx. + move=> i1 _; rewrite cfdotZl. + by rewrite mulr_ge0 ?Cnat_ge0 ?Cnat_cfdot_char ?cfInd_char ?irr_char. + have lin_phi: phi 1%g = 1. + apply: (mulfI (irr1_neq0 k)); have /resZr/cfunP/(_ 1%g) := rp_k. + by rewrite cfRes1 // cfunE mulr1 a_k Da. + have Da_ i: i \in rp -> 'chi_i 1%g = a_ i. + move/resZr/cfunP/(_ 1%g); rewrite cfRes1 // cfunE => ->. + by rewrite lin_phi mulr1. + pose chi i := 'Ind[L, H] 'chi_i; pose alpha i := chi i - a_ i *: eta1. + have Aalpha i: i \in rp -> alpha i \in 'CF(L, A). + move=> r_i; rewrite cfun_onD1 !cfunE cfInd1 // (uniY _ Yeta1). + rewrite -divgS // -(sdprod_card defL) mulKn // Da_ // mulrC subrr eqxx. + by rewrite memvB ?cfInd_normal ?memvZ // (seqInd_on _ Yeta1). + have [sum_alpha sum_a2]: + 'Ind phi - #|H : Z|%:R *: eta1 = \sum_(i in rp) a_ i *: alpha i + /\ \sum_(i in rp) a_ i ^+ 2 = #|H : Z|%:R. + + set rhs2 := _%:R; set lhs1 := _ - _; set rhs1 := \sum_(i | _) _. + set lhs2 := \sum_(i | _) _. + have eq_diff: lhs1 - rhs1 = (lhs2 - rhs2) *: eta1. + rewrite scalerBl addrAC; congr (_ - _). + rewrite -(cfIndInd _ sHL sZH) defIphi linear_sum -sumrB scaler_suml. + apply: eq_bigr => i rp_i; rewrite linearZ scalerBr opprD addNKr. + by rewrite opprK scalerA. + have: (lhs1 - rhs1) 1%g == 0. + rewrite !cfunE -(cfIndInd _ sHL sZH) !cfInd1 // lin_phi mulr1. + rewrite -divgS // -(sdprod_card defL) mulKn // mulrC uniY // subrr. + rewrite sum_cfunE big1 ?subrr // => i rp_i. + by rewrite cfunE (cfun_on0 (Aalpha i rp_i)) ?mulr0 // !inE eqxx. + rewrite eq_diff cfunE mulf_eq0 subr_eq0 (negPf (seqInd1_neq0 _ Yeta1)) //. + rewrite orbF => /eqP sum_a2; split=> //; apply/eqP; rewrite -subr_eq0. + by rewrite eq_diff sum_a2 subrr scale0r. + have Xchi i: i \in rp -> chi i \in X. + move=> rp_i; apply/seqIndP; exists i => //; rewrite !inE sub1G andbT. + apply: contra rp_i => kerZi; rewrite -cfdot_Res_r. + suffices ->: 'Res[Z] 'chi_i = ('chi_i 1%g)%:A. + by rewrite cfdotZr -irr0 cfdot_irr (negPf nzi0) mulr0. + apply/cfun_inP=> t Zt; rewrite cfResE // cfunE cfun1E Zt mulr1. + by rewrite cfker1 ?(subsetP kerZi). + have oRY i: i \in rp -> orthogonal (R (chi i)) (map tau1 Y). + move/Xchi=> Xchi_i; rewrite orthogonal_sym. + by rewrite (coherent_ortho_supp scohS) // ?sXS // (contraL (X'Y _)). + have n1Y1: '[Y1] = 1. + have [_ oYYt] := orthonormalP oYtau. + have [-> | [_ ->]] := defY1; + by rewrite ?cfnormN oYYt ?eqxx ?map_f // cfAut_seqInd. + have YtauY1: Y1 \in 'Z[map tau1 Y]. + have [-> | [_ ->]] := defY1; + by rewrite ?rpredN mem_zchar ?map_f ?cfAut_seqInd. + have /fin_all_exists[XbZ defXbZ] i: exists XbZ, let: (X1, b, Z1) := XbZ in + [/\ tau (alpha i) = X1 - b *: Y1 + Z1, + i \in rp -> X1 \in 'Z[R (chi i)], i \in rp -> b \is Creal, + '[Z1, Y1] = 0 & i \in rp -> orthogonal Z1 (R (chi i))]. + - have [X1 dX1 [YZ1 [dXYZ _ oYZ1R]]] := + orthogonal_split (R (chi i)) (tau (alpha i)). + have [Y1b dY1b [Z1 [dYZ1 _ oZY1]]] := orthogonal_split Y1 YZ1. + have{dY1b} [|b Db dY1b] := orthogonal_span _ dY1b. + by rewrite /pairwise_orthogonal /= inE eq_sym -cfnorm_eq0 n1Y1 oner_eq0. + exists (X1, - b Y1, Z1); split. + + by rewrite dXYZ dYZ1 dY1b scaleNr big_seq1 opprK addrA. + + have [_ _ _ Rok _] := scohS => /Xchi/sXS/Rok[ZR oRR _]. + have [_ -> ->] := orthonormal_span oRR dX1. + rewrite big_seq rpred_sum // => aa Raa. + rewrite scale_zchar ?mem_zchar //. + rewrite -[X1](addrK YZ1) -dXYZ cfdotBl (orthoPl oYZ1R) // subr0. + rewrite Cint_cfdot_vchar ?(ZR aa) //. + rewrite !(rpredB, cfInd_vchar) ?irr_vchar //. + rewrite scale_zchar ?(seqInd_vcharW Yeta1) // Cint_cfdot_vchar_irr //. + by rewrite cfInd_vchar ?irr_vchar. + + move=> rp_i; rewrite Db -[Y1b](addrK Z1) -dYZ1 cfdotBl (orthoP oZY1). + rewrite subr0 n1Y1 divr1 -[YZ1](addKr X1) -dXYZ cfdotDl cfdotNl. + rewrite (span_orthogonal (oRY i rp_i)) ?(zchar_span YtauY1) //. + rewrite oppr0 add0r Creal_Cint // rpredN Cint_cfdot_vchar //. + rewrite !(cfInd_vchar, rpredB) ?irr_vchar //. + rewrite -Da_ // scale_zchar ?Cint_Cnat ?Cnat_irr1 //. + exact: (seqInd_vcharW Yeta1). + apply: zchar_trans_on YtauY1 => _ /mapP[eta Yeta ->]. + by rewrite Ztau1 ?seqInd_zcharW. + + exact: (orthoP oZY1). + move/oRY=> oRiY; apply/orthoPl=> aa Raa. + rewrite -[Z1](addKr Y1b) -dYZ1 cfdotDl cfdotNl cfdotC (orthoPl oYZ1R) //. + rewrite dY1b addr0 big_seq1 cfdotZr. + by have [-> | [_ ->]] := defY1; + rewrite ?cfdotNr (orthogonalP oRiY) ?map_f ?cfAut_seqInd //; + rewrite ?(oppr0, mulr0, rmorph0). + pose X1 i := (XbZ i).1.1; pose b i := (XbZ i).1.2; pose Z1 i := (XbZ i).2. + have R_X1 i: i \in rp -> X1 i \in 'Z[R (chi i)]. + by rewrite /X1; case: (XbZ i) (defXbZ i) => [[? ?] ?] []. + have Rb i: i \in rp -> b i \is Creal. + by rewrite /b; case: (XbZ i) (defXbZ i) => [[? ?] ?] []. + have oZY1 i: '[Z1 i, Y1] = 0. + by rewrite /Z1; case: (XbZ i) (defXbZ i) => [[? ?] ?] []. + have oZ1R i: i \in rp -> orthogonal (Z1 i) (R (chi i)). + by rewrite /Z1; case: (XbZ i) (defXbZ i) => [[? ?] ?] []. + have{defXbZ} defXbZ i: tau (alpha i) = X1 i - b i *: Y1 + Z1 i. + by rewrite /X1 /b /Z1; case: (XbZ i) (defXbZ i) => [[? ?] ?] []. + have ub_alpha i: i \in rp -> + [/\ '[chi i] <= '[X1 i] + & '[a_ i *: eta1] <= '[b i *: Y1 - Z1 i] -> + [/\ '[X1 i] = '[chi i], '[b i *: Y1 - Z1 i] = '[a_ i *: eta1] + & exists2 E, subseq E (R (chi i)) & X1 i = \sum_(aa <- E) aa]]. + - move=> rp_i; apply: (subcoherent_norm scohS) (erefl _) _. + + rewrite sXS ?Xchi // scale_zchar ?(seqInd_vcharW Yeta1) //; last first. + by rewrite Cint_cfdot_vchar_irr // cfInd_vchar ?irr_vchar. + split=> //; apply/orthoPr=> xi2; rewrite !inE => Dxi2. + rewrite cfdotZr (orthogonalP oXY) ?mulr0 //. + by case/pred2P: Dxi2 => ->; rewrite ?cfAut_seqInd ?Xchi. + + have [_ IZtau _ _ _] := scohS. + apply: sub_iso_to IZtau; [apply: zchar_trans_on | exact: zcharW]. + apply/allP; rewrite /= zchar_split (cfun_onS (setSD _ sHL)) ?Aalpha //. + rewrite rpredB ?scale_zchar ?seqInd_zcharW ?(sYS eta1) ?sXS ?Xchi //. + by rewrite sub_aut_zchar ?zchar_onG ?seqInd_zcharW ?cfAut_seqInd; + rewrite ?sXS ?Xchi //; apply: seqInd_vcharW. + by rewrite -Da_ // irr1_degree rpred_nat. + suffices oYZ_R: orthogonal (b i *: Y1 - Z1 i) (R (chi i)). + rewrite opprD opprK addrA -defXbZ cfdotC. + rewrite (span_orthogonal oYZ_R) ?memv_span1 ?conjC0 //. + exact: (zchar_span (R_X1 i rp_i)). + apply/orthoPl=> aa Raa. + rewrite cfdotBl cfdotZl (orthoPl (oZ1R i _)) //. + by rewrite subr0 cfdotC; have [-> | [_ ->]] := defY1; + rewrite ?cfdotNr (orthogonalP (oRY i _)) ?map_f ?cfAut_seqInd //; + by rewrite ?(mulr0, oppr0, rmorph0). + have leba i: i \in rp -> b i <= a_ i. + move=> rp_i; have ai_gt0: a_ i > 0 by rewrite -Da_ ?irr1_gt0. + have /orP [b_le0|b_ge0] := Rb i rp_i; last first. + by rewrite (ler_trans b_ge0) ?ltrW. + rewrite -(@ler_pexpn2r _ 2) //; last exact: ltrW. + apply: ler_trans (_ : '[b i *: Y1 - Z1 i] <= _). + rewrite cfnormBd; last by rewrite cfdotZl cfdotC oZY1 ?conjC0 ?mulr0. + rewrite cfnormZ (normr_idP _) // n1Y1 mulr1 addrC -subr_ge0 addrK. + exact: cfnorm_ge0. + rewrite -(ler_add2l '[X1 i]) -cfnormBd; last first. + rewrite cfdotBr cfdotZr (span_orthogonal (oRY i _)) //; last first. + - exact: (zchar_span YtauY1). + - exact: (zchar_span (R_X1 i rp_i)). + rewrite mulr0 sub0r cfdotC (span_orthogonal (oZ1R i _)) ?raddf0 //. + exact: memv_span1. + exact: (zchar_span (R_X1 i rp_i)). + have Salpha: alpha i \in 'Z[S, L^#]. + rewrite zchar_split (cfun_onS (setSD _ sHL)) ?Aalpha //. + rewrite rpredB ?scale_zchar ?seqInd_zcharW + ?(sYS _ Yeta1) ?sXS ?Xchi //. + by rewrite -Da_ // irr1_degree rpred_nat. + rewrite opprD opprK addrA -defXbZ // Itau ?Salpha //. + rewrite cfnormBd; last first. + by rewrite cfdotZr (orthogonalP oXY) ?mulr0 ?Xchi. + rewrite cfnormZ (normr_idP _) ?(ltrW ai_gt0) //. + have [_ /(_ eta1)->//] := orthonormalP oY; rewrite eqxx mulr1 ler_add2r. + by have [] := ub_alpha i rp_i. + have{leba} eq_ab: {in rp, a_ =1 b}. + move=> i rp_i; apply/eqP; rewrite -subr_eq0; apply/eqP. + apply: (mulfI (irr1_neq0 i)); rewrite mulr0 Da_ // mulrBr. + move: i rp_i; apply: psumr_eq0P => [i rp_i | ]. + by rewrite subr_ge0 ler_pmul2l ?leba // -Da_ ?irr1_gt0. + have [X2 oX2Y /(congr1 (cfdotr Y1))] := Dpsi1 i0 nzi0. + rewrite sumrB sum_a2 sum_alpha /tau linear_sum /= cfdot_suml cfdotBl. + rewrite (span_orthogonal oX2Y) ?memv_span1 ?(zchar_span YtauY1) // add0r. + rewrite cfdotZl n1Y1 mulr1 => /(canLR (@opprK _)) <-. + rewrite -opprD -big_split big1 ?oppr0 //= => i rp_i. + rewrite linearZ cfdotZl /= -/tau defXbZ addrC cfdotDl oZY1 addr0. + rewrite cfdotBl cfdotZl n1Y1 mulr1. + rewrite (span_orthogonal (oRY i _)) ?(zchar_span YtauY1) //. + by rewrite add0r mulrN subrr. + exact: (zchar_span (R_X1 i rp_i)). + exists (X1 k). + apply/orthoPl=> psi /memv_span Ypsi. + by rewrite (span_orthogonal (oRY k _)) // (zchar_span (R_X1 k rp_k)). + apply/eqP; rewrite -/a def_xi -a_k defXbZ addrC -subr_eq0 eq_ab // addrK. + have n1eta1: '[eta1] = 1 by have [_ -> //] := orthonormalP oY; rewrite eqxx. + rewrite -cfnorm_eq0 -(inj_eq (addrI '[b k *: Y1])). + have [_ [|_]] := ub_alpha k rp_k. + rewrite cfnormBd; last by rewrite cfdotZl cfdotC oZY1 conjC0 mulr0. + by rewrite addrC !cfnormZ eq_ab // n1Y1 n1eta1 -subr_ge0 addrK cfnorm_ge0. + rewrite cfnormBd; last by rewrite cfdotZl cfdotC oZY1 conjC0 mulr0. + by move=> -> _; rewrite addr0 !cfnormZ eq_ab // n1Y1 n1eta1. + have oX: pairwise_orthogonal X by rewrite (sub_pairwise_orthogonal sXS). + have [_ oYY] := orthonormalP oY. + have [[N_S _ _] [_ /(_ _ _)/zcharW/=Ztau] _ _ _] := scohS. + have n1eta: '[eta1] = 1 by rewrite oYY ?eqxx. + have n1Y1: '[Y1] = 1. + have [_ oYYt] := orthonormalP oYtau. + have [-> | [_ ->]] := defY1; + by rewrite ?cfnormN oYYt ?eqxx ?map_f // cfAut_seqInd. + have YtauY1: Y1 \in <>%VS. + by have [-> | [_ ->]] := defY1; + rewrite ?memvN memv_span ?map_f ?cfAut_seqInd. + have Z_Y1: Y1 \in 'Z[irr G]. + by case: defY1 => [|[_]] ->; rewrite ?rpredN Ztau1 ?mem_zchar ?ccY. + have Zalpha xi: xi \in X -> xi - a xi *: eta1 \in 'Z[S, L^#]. + move=> Xxi; rewrite zcharD1E rpredB ?scale_zchar; + rewrite ?seqInd_zcharW ?(sXS xi) ?sYS //. + by rewrite !cfunE (uniY eta1) //= subr_eq0; have [<-] := Dxa xi Xxi. + have Zbeta eta: eta \in Y -> eta - eta1 \in 'Z[S, L^#]. + move=> Yeta; rewrite zcharD1E rpredB ?seqInd_zcharW ?sYS //=. + by rewrite !cfunE !uniY ?subrr. + have nza xi: xi \in X -> a xi != 0. + move=> Xxi; have [/eqP Dxi1 _] := Dxa _ Xxi; apply: contraTneq Dxi1 => ->. + by rewrite mul0r (seqInd1_neq0 _ Xxi). + have alphaY xi: xi \in X -> '[tau (xi - a xi *: eta1), Y1] = - a xi. + case/Dxa=> _ [X1 oX1Y ->]; rewrite cfdotBl cfdotZl n1Y1 mulr1. + by rewrite (span_orthogonal oX1Y) ?memv_span1 ?add0r. + have betaY eta: eta \in Y -> '[tau (eta - eta1), Y1] = (eta == eta1)%:R - 1. + move=> Yeta; rewrite -Dtau1; last first. + by rewrite zchar_split (zchar_on (Zbeta eta _)) ?rpredB ?seqInd_zcharW. + rewrite raddfB cfdotBl. + have [-> | [szY2 ->]] := defY1. + by rewrite !{1}Itau1 ?seqInd_zcharW // !oYY // !eqxx. + rewrite !cfdotNr opprK !{1}Itau1 ?oYY ?seqInd_zcharW ?cfAut_seqInd //. + have defY: (eta1 :: eta1^*)%CF =i Y. + apply: proj1 (leq_size_perm _ _ _); last by rewrite szY2. + by rewrite /= inE eq_sym (seqInd_conjC_neq _ _ _ Yeta1). + by apply/allP; rewrite /= Yeta1 cfAut_seqInd. + rewrite -defY !inE in Yeta; case/pred2P: Yeta => ->. + rewrite eqxx eq_sym (negPf (seqInd_conjC_neq _ _ _ Yeta1)) //. + by rewrite addrC !subrr. + by rewrite eqxx eq_sym (negPf (seqInd_conjC_neq _ _ _ Yeta1)) ?add0r ?addr0. + pose tau2_X xi := tau (xi - a xi *: eta1) + a xi *: Y1. + pose tau3_Y eta := tau (eta - eta1) + Y1. + have Itau2_X: {in X, isometry tau2_X, to 'Z[irr G]}. + split=> [xi1 xi2 Xxi1 Xxi2 | xi Xxi]; last first. + by rewrite rpredD ?rpredZ_Cint ?Za ?Ztau ?Zalpha. + rewrite /= cfdotDl !cfdotDr Itau ?Zalpha // cfdotBl !cfdotBr opprB !cfdotZr. + rewrite !aut_Cint ?Za // !cfdotZl (cfdotC Y1) !alphaY // n1Y1 n1eta rmorphN. + rewrite aut_Cint // (cfdotC eta1) !(orthogonalP oXY _ eta1) // conjC0. + by rewrite !mulr0 !subr0 !mulr1 !mulrN mulrC !addrA subrK addrK. + have{Itau2_X} [tau2 Dtau2 Itau2] := Zisometry_of_iso oX Itau2_X. + have{Itau2} cohX: coherent_with X L^# tau tau2. + split=> // xi; rewrite zcharD1E => /andP[/zchar_expansion[]// z Zz ->{xi}]. + pose sum_za := \sum_(xi <- X) z xi * a xi => /eqP sum_xi_0. + have{sum_xi_0} sum_za_0: sum_za = 0. + apply: (mulIf (neq0CG W1)); rewrite mul0r -{}sum_xi_0 sum_cfunE mulr_suml. + by apply: eq_big_seq => xi /Dxa[xi_1 _]; rewrite !cfunE xi_1 mulrA. + rewrite -[rhs in tau rhs](subrK (sum_za *: eta1)) {1}scaler_suml -sumrB. + rewrite -[tau _](addrK (sum_za *: Y1)) {1 3}sum_za_0 !scale0r addr0 subr0. + rewrite scaler_suml !raddf_sum [tau _]raddf_sum -big_split /= -/tau. + apply: eq_big_seq => xi Xxi; rewrite raddfZ_Cint //= Dtau2 //. + by rewrite -!scalerA -scalerBr [tau _]linearZ -scalerDr. + have Itau3_Y: {in Y, isometry tau3_Y, to 'Z[irr G]}. + split=> [eta3 eta4 Yeta3 Yeta4 | eta Yeta]; last first. + by rewrite rpredD // Ztau ?Zbeta. + rewrite /= cfdotDl !cfdotDr n1Y1 (cfdotC Y1) !betaY // Itau ?Zbeta //. + rewrite cfdotBl !cfdotBr !oYY // eqxx rmorphB rmorph1 rmorph_nat subrK. + rewrite (eq_sym eta1) opprB !addrA 3!(addrAC _ (- _)) addrK. + by rewrite(addrAC _ 1) subrK addrK. + have{oY} oY := orthonormal_orthogonal oY. + have{Itau3_Y} [tau3 Dtau3 Itau3] := Zisometry_of_iso oY Itau3_Y. + have{Itau3 cohY} cohY: coherent_with Y L^# tau tau3. + split=> // eta; rewrite zcharD1E => /andP[/zchar_expansion[]//z Zz ->{eta}]. + pose sum_z := \sum_(eta <- Y) z eta => /eqP sum_eta_0. + have{sum_eta_0} sum_z_0: sum_z = 0. + apply: (mulIf (neq0CG W1)); rewrite mul0r -sum_eta_0 sum_cfunE mulr_suml. + by apply: eq_big_seq => xi /uniY eta_1; rewrite !cfunE eta_1. + rewrite -[rhs in tau rhs](subrK (sum_z *: eta1)) {1}scaler_suml -sumrB. + rewrite -[tau _](addrK (sum_z *: Y1)) {1 3}sum_z_0 !scale0r addr0 subr0. + rewrite scaler_suml !raddf_sum [tau _]raddf_sum -big_split /= -/tau. + apply: eq_big_seq => eta Yeta; rewrite raddfZ_Cint //= Dtau3 //. + by rewrite -scalerBr [tau _]linearZ -scalerDr. + have [-> | ] := altP (@nilP _ X); first by exists tau3. + rewrite -lt0n -has_predT => /hasP[xi1 Xxi1 _]. + have: tau (xi1 - a xi1 *: eta1) = tau2 xi1 - tau3 (a xi1 *: eta1). + rewrite [tau3 _]linearZ Dtau2 //= Dtau3 // /tau3_Y subrr [tau 0]linear0. + by rewrite add0r addrK. + apply: (bridge_coherent scohS ccsXS cohX ccsYS cohY X'Y). + by rewrite (zchar_on (Zalpha _ Xxi1)) // rpredZ_Cint ?mem_zchar. +pose wf S1 := cfConjC_subset S1 S /\ {subset X ++ Y <= S1}. +pose S1 := [::] ++ X ++ Y; set S2 := [::] in S1; rewrite -[X ++ Y]/S1 in cohXY. +have wfS1: wf S1. + do 2!split=> //; rewrite /S1 /= ?cat_uniq ?uX ?uY ?(introT hasPn) //. + by apply/allP; rewrite all_cat !(introT allP). + by move=> phi; rewrite !mem_cat => /orP[/ccX|/ccY]->; rewrite ?orbT. +move: {2}_.+1 (ltnSn (size S - size S1)) => n. +elim: n => // n IHn in (S2) S1 wfS1 cohXY *; rewrite ltnS => leSnS1. +have [ccsS1S sXYS1] := wfS1; have [uS1 sS1S ccS1] := ccsS1S. +have [sSS1 | /allPn[psi /= Spsi notS1psi]] := altP (@allP _ (mem S1) S). + exact: subset_coherent cohXY. +have [_ _ ccS] := uccS. +have [neq_psi_c Spsic] := (hasPn nrS _ Spsi, ccS _ Spsi). +have wfS1': wf [:: psi, psi^* & S1]%CF. + split; last by move=> xi XYxi; rewrite !inE sXYS1 ?orbT. + split=> [|xi|xi]; rewrite /= !inE. + - by rewrite negb_or eq_sym neq_psi_c notS1psi (contra (ccS1 _)) ?cfConjCK. + - by do 2?[case/predU1P=> [-> //|]] => /sS1S. + rewrite (inv_eq (@cfConjCK _ _)) (can_eq (@cfConjCK _ _)) orbCA !orbA. + by case: pred2P => // _ /ccS1. +apply: (IHn [:: psi, psi^* & S2]%CF) => //; last first. + rewrite -subSn ?uniq_leq_size //; try by have [[]] := wfS1'. + by rewrite /= subSS (leq_trans _ leSnS1) // leq_sub2l ?leqW. +have ltZH': Z \proper H^`(1)%g. + rewrite properEneq sZH' andbT; apply: contraNneq notS1psi => eqZH'. + have [i /setDP[_ nt_i] ->] := seqIndP Spsi; rewrite sXYS1 // mem_cat. + rewrite !mem_seqInd ?normal1 //= -eqZH' !inE in nt_i *. + by rewrite sub1G nt_i andbT orNb. +have: [/\ eta1 \in S1, psi \in S & psi \notin S1]. + by rewrite Spsi sXYS1 // mem_cat Yeta1 orbT. +have /seqIndC1P[i nzi Dpsi] := Spsi. +move/(extend_coherent scohS ccsS1S); apply; split=> //. + rewrite (uniY _ Yeta1) Dpsi cfInd1 // (index_sdprod defL) dvdC_mulr //. + by rewrite Cint_Cnat ?Cnat_irr1. +rewrite !big_cat //= (big_rem _ Yeta1) /= addrC -!addrA -big_cat //=. +rewrite sum_seqIndD_square ?normal1 ?sub1G // indexg1 addrC. +rewrite -subr_gt0 -!addrA ltr_spaddl //. + have /irrY/irrP[j ->] := Yeta1. + by rewrite cfnorm_irr divr1 exprn_gt0 ?irr1_gt0. +rewrite big_seq addr_ge0 ?sumr_ge0 // => [phi Sphi|]. + rewrite mulr_ge0 ?invr_ge0 ?cfnorm_ge0 ?exprn_ge0 // ?char1_pos //. + suffices /seqInd_char: phi \in S by apply: char1_ge0. + rewrite sS1S // !mem_cat; rewrite mem_cat in Sphi. + by case/orP: Sphi => [/mem_rem-> | ->]; rewrite ?orbT. +rewrite subr_ge0 -(Lagrange_index sHL sZH) -oW1 natrM mulrC -mulrA. +rewrite uniY ?ler_pmul2l ?gt0CG //. +rewrite -(prednK (cardG_gt0 Z)) [zz in zz - 1]mulrSr addrK -natrM. +rewrite Dpsi cfInd1 // -oW1. +rewrite -(@ler_pexpn2r _ 2) -?topredE /= ?mulr_ge0 ?ler0n //; last first. + by rewrite char1_ge0 ?irr_char. +rewrite !exprMn -!natrX mulrA -natrM. +apply: ler_trans (_ : (4 * #|W1| ^ 2)%:R * #|H : Z|%:R <= _). + rewrite ler_pmul2l; last by rewrite ltr0n muln_gt0 !expn_gt0 cardG_gt0. + rewrite (ler_trans (irr1_bound i)) // ler_nat dvdn_leq // indexgS //. + by rewrite (subset_trans sZZ) // -cap_cfcenter_irr bigcap_inf. +rewrite -natrM ler_nat expnMn mulnC -mulnA leq_pmul2l //. +have [in_caseA | in_caseB] := boolP caseA. + have regW1Z: semiregular Z W1. + have [in_c1 | in_c2] := boolP case_c1. + move=> x /(Frobenius_reg_ker in_c1) regHx; apply/trivgP. + by rewrite -regHx setSI. + have [/= _ [_ [_ _ _ prW1H] _] _ _] := c2W2 in_c2. + move=> x /prW1H prHx; apply/trivgP; rewrite -((_ =P [1]) in_caseA) -prHx. + by rewrite subsetI subIset ?sZZ // setSI. + rewrite -(mul1n (4 * _)%N) leq_mul // -(expnMn 2 _ 2) leq_exp2r //. + rewrite dvdn_leq //; first by rewrite -subn1 subn_gt0 cardG_gt1. + rewrite Gauss_dvd ?(@pnat_coprime 2) -?odd_2'nat ?(oddSg sW1L) //. + rewrite dvdn2 -{1}subn1 odd_sub // (oddSg (normal_sub nsZL)) //=. + by rewrite regular_norm_dvd_pred // (subset_trans sW1L) ?normal_norm. +rewrite -(muln1 (4 * _)%N) leq_mul //; last first. + by rewrite expn_gt0 -subn1 subn_gt0 orbF cardG_gt1. +rewrite -(expnMn 2 _ 2) -(Lagrange_index (der_sub 1 H) sZH') leq_mul //. + rewrite -(prednK (indexg_gt0 _ _)) leqW // dvdn_leq //. + by rewrite -subn1 subn_gt0 indexg_gt1 proper_subn. + rewrite Gauss_dvd ?(@pnat_coprime 2) -?odd_2'nat ?(oddSg sW1L) //. + rewrite dvdn2 -{1}subn1 odd_sub // -card_quotient ?der_norm //. + rewrite quotient_odd ?(oddSg sHL) //=. + rewrite (card_isog (quotient_isog (subset_trans sW1L nH'L) _)); last first. + by rewrite coprime_TIg ?(coprimeSg (der_sub 1 H)). + exact: Frobenius_dvd_ker1 frobL1. +rewrite -(prednK (indexg_gt0 _ _)) leqW // dvdn_leq //. + by rewrite -subn1 subn_gt0 indexg_gt1 proper_subn. +rewrite Gauss_dvd ?(@pnat_coprime 2) -?odd_2'nat ?(oddSg sW1L) //. +rewrite dvdn2 -{1}subn1 odd_sub //. +rewrite -card_quotient ?(subset_trans (der_sub 1 H)) //. +rewrite quotient_odd ?(oddSg (der_sub 1 H)) ?(oddSg sHL) //=. +have /andP[sZL nZL] := nsZL. +rewrite (card_isog (quotient_isog (subset_trans sW1L nZL) _)); last first. + by rewrite coprime_TIg ?(coprimeSg sZH). +suffices: [Frobenius (H^`(1) / Z) <*> (W1 / Z) = (H^`(1) / Z) ><| (W1 / Z)]%g. + exact: Frobenius_dvd_ker1. +suffices: [Frobenius (L / Z) = (H / Z) ><| (W1 / Z)]%g. + apply: Frobenius_subl (quotientS Z (der_sub 1 H)) _. + by rewrite quotient_neq1 // (normalS sZH' (der_sub 1 H)). + by rewrite quotient_norms ?(subset_trans sW1L). +apply: (Frobenius_coprime_quotient defL nsZL) => //; split=> [|x W1x]. + exact: sub_proper_trans sZH' ltH'H. +have /caseB_P[/c2W2[_ [_ [_ _ _ -> //] _] _ _] _ _] := in_caseB. +by rewrite /Z (negPf in_caseB). +Qed. + +End Six. + + diff --git a/mathcomp/odd_order/PFsection7.v b/mathcomp/odd_order/PFsection7.v new file mode 100644 index 0000000..eed77b7 --- /dev/null +++ b/mathcomp/odd_order/PFsection7.v @@ -0,0 +1,819 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg poly finset center. +Require Import fingroup morphism perm automorphism quotient action zmodp. +Require Import gfunctor gproduct cyclic pgroup commutator nilpotent frobenius. +Require Import matrix mxalgebra mxrepresentation BGsection3 vector. +Require Import ssrnum algC classfun character inertia vcharacter. +Require Import PFsection1 PFsection2 PFsection4 PFsection5 PFsection6. + +(******************************************************************************) +(* This file covers Peterfalvi, Section 7: *) +(* Non-existence of a Certain Type of Group of Odd Order *) +(* Defined here: *) +(* inDade ddA == the right inverse to the Dade isometry with respect to G, *) +(* L, A, given ddA : Dade_hypothesis G L A. *) +(* phi^\rho == locally-bindable Notation for invDade ddA phi. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory Num.Theory. +Local Open Scope ring_scope. + +Reserved Notation "alpha ^\rho" (at level 2, format "alpha ^\rho"). + +Section Seven. + +Variables (gT : finGroupType) (G : {group gT}). +Implicit Types (L H P : {group gT}) (DH : gT -> {group gT}). + +(* Properties of the inverse to the Dade isometry (Peterfalvi (7.1) to (7.3). *) +Section InverseDade. + +Variables (A : {set gT}) (L : {group gT}). +Hypothesis ddA : Dade_hypothesis G L A. + +Local Notation "alpha ^\tau" := (Dade ddA alpha). +Local Notation Atau := (Dade_support ddA). +Local Notation H := (Dade_signalizer ddA). + +Let nsAL : A <| L. Proof. by have [] := ddA. Qed. +Let sAL : A \subset L. Proof. exact: normal_sub nsAL. Qed. +Let nAL : L \subset 'N(A). Proof. exact: normal_norm nsAL. Qed. +Let sLG : L \subset G. Proof. by have [] := ddA. Qed. + +(* This is the Definition embedded in Peterfalvi, Hypothesis (7.1). *) +Fact invDade_subproof (chi : 'CF(G)) : + is_class_fun <> + [ffun a => #|H a|%:R^-1 * (\sum_(x in H a) chi (x * a)%g) *+ (a \in A)]. +Proof. +rewrite genGid; apply: intro_class_fun => [x y Lx Ly | x notLx]; last first. + by rewrite (contraNF (subsetP sAL x)). +rewrite memJ_norm ?(subsetP nAL) // !mulrb; case: ifP => // Ax. +rewrite (DadeJ ddA) // cardJg; congr (_ * _). +rewrite big_imset /= => [|z y0 _ _ /=]; last exact: conjg_inj. +by apply: eq_bigr => u Hu; rewrite -conjMg cfunJ // (subsetP sLG). +Qed. +Definition invDade alpha := Cfun 1 (invDade_subproof alpha). + +Local Notation "alpha ^\rho" := (invDade alpha). + +Fact invDade_is_linear : linear invDade. +Proof. +move=> mu alpha beta; apply/cfunP=> a; rewrite !cfunElock. +rewrite mulrnAr -mulrnDl mulrCA -mulrDr; congr (_ * _ *+ _). +by rewrite big_distrr -big_split; apply: eq_bigr => x _; rewrite !cfunE. +Qed. +Canonical invDade_linear := Linear invDade_is_linear. +Canonical invDade_additive := Additive invDade_is_linear. + +Lemma invDade_on chi : chi^\rho \in 'CF(L, A). +Proof. by apply/cfun_onP=> x notAx; rewrite cfunElock (negPf notAx). Qed. + +Lemma invDade_cfun1 : 1^\rho = '1_A. +Proof. +apply/cfunP=> x; rewrite cfuniE // cfunElock mulrb; case: ifP => //= Ax. +apply: canLR (mulKf (neq0CG _)) _; rewrite mulr1 -sumr_const. +apply: eq_bigr => u Hu; rewrite cfun1E (subsetP (subsetIl G 'C[x])) //. +have /sdprodP[_ <- _ _] := Dade_sdprod ddA Ax. +by rewrite mem_mulg // inE cent1id (subsetP sAL). +Qed. + +(* This is Peterfalvi (2.7), restated using invDade. *) +Lemma invDade_reciprocity chi alpha : + alpha \in 'CF(L, A) -> '[alpha^\tau, chi] = '[alpha, chi^\rho]. +Proof. +move=> Aalpha; apply: general_Dade_reciprocity => //= a Aa. +by rewrite cfunElock Aa. +Qed. + +(* This is Peterfalvi (7.2)(a). *) +Lemma DadeK alpha : alpha \in 'CF(L, A) -> (alpha^\tau)^\rho = alpha. +Proof. +move=> Aalpha; apply/cfunP=> a; rewrite cfunElock mulrb. +case: ifPn => [Aa | /cfun_on0-> //]; apply: canLR (mulKf (neq0CG _)) _. +rewrite mulr_natl -sumr_const; apply: eq_bigr => x Hx. +by rewrite (DadeE _ Aa) ?mem_class_support // mem_mulg ?set11. +Qed. + +(* This is Peterfalvi (7.2)(b); note that by (7.2)(a) chi is in the image of *) +(* tau iff chi = (chi^\rho)^\tau, and this condition is easier to write. *) +Lemma leC_norm_invDade chi : + '[chi^\rho] <= '[chi] ?= iff (chi == (chi^\rho)^\tau). +Proof. +have Achi_rho := invDade_on chi; rewrite -(Dade_isometry ddA) //. +set chi1 := _^\tau; rewrite -subr_eq0 -cfnorm_eq0; set mu := chi - chi1. +have owv: '[chi1, mu] = 0. + by rewrite invDade_reciprocity ?raddfB //= DadeK ?subrr. +rewrite -(subrK chi1 chi) -/mu addrC cfnormD owv conjC0 !addr0. +split; first by rewrite -subr_ge0 addrC addKr cfnorm_ge0. +by rewrite eq_sym addrC -subr_eq0 addrK. +Qed. + +(* This is Peterfalvi (7.3). *) +Lemma leC_cfnorm_invDade_support chi : + '[chi^\rho] <= #|G|%:R^-1 * (\sum_(g in Atau) `|chi g| ^+ 2) + ?= iff [forall a in A, forall u in H a, chi (u * a)%g == chi a]. +Proof. +have nsAtauG: Atau <| G := Dade_support_normal ddA. +pose chi1 := chi * '1_Atau; set RHS := _ * _. +have inA1 a x: a \in A -> x \in H a -> (x * a)%g \in Dade_support1 ddA a. + by move=> Aa Hx; rewrite mem_class_support ?mem_mulg ?set11. +have chi1E a x: a \in A -> x \in H a -> chi1 (x * a)%g = chi (x * a)%g. + move=> Aa Hx; rewrite cfunE cfuniE // mulr_natr mulrb. + by case: bigcupP => // [[]]; exists a; rewrite ?inA1. +have ->: chi^\rho = chi1^\rho. + apply/cfunP => a; rewrite !cfunElock !mulrb; case: ifP => // Aa. + by congr (_ * _); apply: eq_bigr => x /chi1E->. +have Achi1: chi1 \in 'CF(G, Atau). + by apply/cfun_onP=> x ?; rewrite cfunE (cfun_onP (cfuni_on _ _)) ?mulr0. +have{Achi1 RHS} <-: '[chi1] = RHS. + rewrite (cfnormE Achi1); congr (_ * _). + by apply: eq_bigr => x Atau_x; rewrite cfunE cfuniE // Atau_x mulr1. +congr (_ <= _ ?= iff _): (leC_norm_invDade chi1). +apply/eqP/forall_inP=> [chi1_id a Aa | chi_id]. + apply/forall_inP => x Ha_x; rewrite -{2}[a]mul1g -!chi1E // chi1_id mul1g. + by rewrite (DadeE _ Aa) ?inA1 ?Dade_id. +apply/cfunP => g; rewrite cfunE cfuniE // mulr_natr mulrb. +case: ifPn => [/bigcupP[a Aa] | /(cfun_onP (Dade_cfunS _ _))-> //]. +case/imset2P=> _ z /rcosetP[x Hx ->] Gz ->{g}; rewrite !cfunJ {z Gz}//. +have{chi_id} chi_id := eqP (forall_inP (chi_id a Aa) _ _). +rewrite chi_id // (DadeE _ Aa) ?inA1 {x Hx}// cfunElock mulrb Aa. +apply: canRL (mulKf (neq0CG _)) _; rewrite mulr_natl -sumr_const. +by apply: eq_bigr => x Hx; rewrite chi1E ?chi_id. +Qed. + +(* This is the norm expansion embedded in Peterfalvi (7.3). *) +Lemma cfnormE_invDade chi : + '[chi^\rho] = #|L|%:R^-1 * (\sum_(a in A) `|chi^\rho a| ^+ 2). +Proof. by apply: cfnormE; exact: invDade_on. Qed. + +End InverseDade. + +(* Hypothesis (7.4) and Lemma (7.5). *) +Section DadeCoverInequality. + +(* These declarations correspond to Peterfalvi, Hypothesis (7.4); as it is *) +(* only instantiated twice after this section we leave it unbundled. *) +Variables (I : finType) (L : I -> {group gT}) (A : I -> {set gT}). +Hypothesis ddA : forall i : I, Dade_hypothesis G (L i) (A i). + +Local Notation Atau i := (Dade_support (ddA i)). +Local Notation "alpha ^\rho" := (invDade (ddA _) alpha). +Hypothesis disjointA : forall i j, i != j -> [disjoint Atau i & Atau j]. + +(* This is Peterfalvi (7.5), generalised to all class functions of norm 1. *) +Lemma Dade_cover_inequality (chi : 'CF(G)) (G0 := G :\: \bigcup_i Atau i) : + '[chi] = 1 -> + #|G|%:R^-1 * (\sum_(g in G0) `|chi g| ^+ 2 - #|G0|%:R) + + \sum_i ('[chi^\rho]_(L i) - #|A i|%:R / #|L i|%:R) <= 0. +Proof. +move=> Nchi1; set vG := _^-1; rewrite sumrB /= addrCA mulrBr -addrA. +pose F (xi : 'CF(G)) (B : {set gT}) := vG * \sum_(g in B) `|xi g| ^+ 2. +have sumF xi: F xi G0 + \sum_i F xi (Atau i) = '[xi]. + rewrite (cfnormE (cfun_onG _)) -mulr_sumr -mulrDr; congr (_ * _). + rewrite -partition_disjoint_bigcup //=; set U_A := \bigcup_i _. + have sUG: U_A \subset G by apply/bigcupsP=> i _; apply: Dade_support_sub. + by rewrite -(setIidPr sUG) addrC -big_setID. +have ->: \sum_i #|A i|%:R / #|L i|%:R = \sum_i F 1 (Atau i). + apply: eq_bigr => i _; apply/eqP; rewrite /F. + have [[/andP[sAL nAL] _ _ _ _] sHG] := (ddA i, Dade_signalizer_sub (ddA i)). + rewrite -{1}[A i]setIid -cfdot_cfuni /normal ?sAL // -(invDade_cfun1 (ddA i)). + rewrite leC_cfnorm_invDade_support; apply/forall_inP=> a Aa. + by apply/forall_inP=> x Hx; rewrite !cfun1E groupMl // (subsetP (sHG a)). +have ->: vG * #|G0|%:R = F 1 G0. + congr (_ * _); rewrite -sumr_const; apply: eq_bigr => x /setDP[Gx _]. + by rewrite cfun1E Gx normr1 expr1n. +rewrite -opprD sumF cfnorm1 -Nchi1 -sumF opprD addNKr -oppr_ge0 opprB -sumrB. +by rewrite sumr_ge0 // => i _; rewrite subr_ge0 leC_cfnorm_invDade_support. +Qed. + +(* +set vG := _^-1; rewrite sumrB /= addrCA mulrBr -addrA. +pose F t (B : {set gT}) := vG * \sum_(g in B) `|'chi[G]_t g| ^+ 2. +have sumF t: F t G0 + \sum_i F t (Atau i) = 1. + rewrite -(cfnorm_irr t) (cfnormE (cfun_onG _)) -mulr_sumr -mulrDr. + congr (_ * _); rewrite -partition_disjoint_bigcup //=; set U_A := \bigcup_i _. + have sUG: U_A \subset G by apply/bigcupsP=> i _; apply: Dade_support_sub. + by rewrite -(setIidPr sUG) addrC -big_setID. +have ->: \sum_i #|A i|%:R / #|L i|%:R = \sum_i F 0 (Atau i). + apply: eq_bigr => i _; apply/eqP; rewrite /F irr0. + have [[/andP[sAL nAL] _ _ _ _] sHG] := (ddA i, Dade_signalizer_sub (ddA i)). + rewrite -{1}[A i]setIid -cfdot_cfuni /normal ?sAL // -(invDade_cfun1 (ddA i)). + rewrite leC_cfnorm_invDade_support; apply/forall_inP=> a Aa. + by apply/forall_inP=> x Hx; rewrite !cfun1E groupMl // (subsetP (sHG a)). +have ->: vG * #|G0|%:R = F 0 G0. + congr (_ * _); rewrite -sumr_const; apply: eq_bigr => x /setDP[Gx _]. + by rewrite irr0 cfun1E Gx normr1 expr1n. +rewrite -opprD sumF -(sumF r) opprD addNKr -oppr_ge0 opprB -sumrB. +by rewrite sumr_ge0 // => i _; rewrite subr_ge0 leC_cfnorm_invDade_support. +Qed. +*) + +End DadeCoverInequality. + +(* Hypothesis (7.6), and Lemmas (7.7) and (7.8) *) +Section Dade_seqIndC1. + +(* In this section, A = H^# with H <| L. *) +Variables L H : {group gT}. +Let A := H^#. +Hypothesis ddA : Dade_hypothesis G L A. + +Local Notation Atau := (Dade_support ddA). +Local Notation "alpha ^\tau" := (Dade ddA alpha). +Local Notation "alpha ^\rho" := (invDade ddA alpha). + +Let calT := seqIndT H L. +Local Notation calS := (seqIndD H L H 1). +Local Notation Ind1H := ('Ind[gval L, gval H] 1). +Let uniqS : uniq calS := seqInd_uniq _ _. + +Let h := #|H|%:R : algC. +Let e := #|L : H|%:R : algC. + +Let nsAL : A <| L. Proof. by have [] := ddA. Qed. +Let sLG : L \subset G. Proof. by have [] := ddA. Qed. +Let nsHL : H <| L. Proof. by rewrite -normalD1. Qed. +Let sHL := normal_sub nsHL. +Let nHL := normal_norm nsHL. + +Let nzh : h != 0 := neq0CG H. +Let nze : e != 0 := neq0CiG L H. +Let nzL : #|L|%:R != 0 := neq0CG L. + +Let eh : e * h = #|L|%:R. Proof. by rewrite -natrM mulnC Lagrange. Qed. + +Section InvDadeSeqInd. + +Variables (xi0 : 'CF(L)) (S : seq 'CF(L)) (chi : 'CF(G)). +Implicit Types xi mu : 'CF(L). + +Let d xi := xi 1%g / xi0 1%g. +Let psi xi := xi - d xi *: xi0. +Let c xi := '[(psi xi)^\tau, chi]. + +Let uc c xi mu := (c xi)^* * c mu / ('[xi] * '[mu]). +Let u c xi mu := uc c xi mu * ('[xi, mu] - xi 1%g * mu 1%g / (e * h)). + +(* This is Peterfalvi (7.7); it is stated using a bespoke concrete Prop so as *) +(* to encapsulate the coefficient definitions given above. *) +CoInductive is_invDade_seqInd_sum : Prop := + InvDadeSeqIndSum (c := c) (u := u c) of + (*a*) {in A, forall x, (chi^\rho) x = \sum_(xi <- S) (c xi)^* / '[xi] * xi x} + & (*b*) '[chi^\rho] = \sum_(xi <- S) \sum_(mu <- S) u xi mu. + +Lemma invDade_seqInd_sum : perm_eq calT (xi0 :: S) -> is_invDade_seqInd_sum. +Proof. +move=> defT; pose chi0 := \sum_(xi <- S) (c xi)^* / '[xi] *: xi. +have Txi0: xi0 \in calT by rewrite (perm_eq_mem defT) mem_head. +have sST : {subset S <= calT}. + by move=> xi Sxi; rewrite (perm_eq_mem defT) mem_behead. +have nz_xi01 : xi0 1%g != 0 by apply: seqInd1_neq0 Txi0. +have part_a: {in A, chi^\rho =1 chi0}. + pose phi := (chi^\rho - chi0) * '1_A. + have Aphi : phi \in 'CF(L, A) := mul_cfuni_on A _. + suffices: '[phi, chi^\rho - chi0] == 0; last clearbody phi. + rewrite -(eq_cfdotr Aphi (eq_mul_cfuni _ nsAL)) cfnorm_eq0 => /eqP phi0. + by move=> x Ax; rewrite -[chi0]add0r -phi0 cfunE eq_mul_cfuni ?cfunE ?subrK. + have{Aphi} [Hphi phi1]: phi \in 'CF(L, H) /\ phi 1%g = 0. + by move: Aphi; rewrite cfun_onD1 => /andP[-> /eqP]. + have{Hphi} def_phi: phi = e^-1 *: 'Ind ('Res[H] phi). + apply/cfunP=> y; have [Hy | notHy] := boolP (y \in H); last first. + by rewrite cfunE !(cfun_on0 _ notHy) ?mulr0 ?cfInd_normal. + rewrite cfunE cfIndE // mulrA -invfM eh. + apply: (canRL (mulKf nzL)); rewrite mulr_natl -sumr_const. + by apply: eq_bigr => z Lz; rewrite cfResE ?memJ_norm ?cfunJ ?(subsetP nHL). + have{def_phi} Tphi: phi \in <>%VS. + rewrite def_phi memvZ // ['Res _]cfun_sum_cfdot linear_sum. + apply: memv_suml => i _; rewrite linearZ memvZ ?memv_span //=. + by apply/seqIndP; exists i; rewrite ?inE. + have{Tphi} [z def_phi _] := free_span (seqInd_free nsHL _) Tphi. + have {phi def_phi phi1} ->: phi = \sum_(xi <- S) z xi *: psi xi. + rewrite def_phi (eq_big_perm _ defT) !big_cons /= 2!cfunE in phi1 *. + rewrite (canRL (mulfK nz_xi01) (canRL (addrK _) phi1)) add0r addrC mulNr. + rewrite sum_cfunE mulr_suml scaleNr scaler_suml -sumrB. + by apply: eq_bigr => xi _; rewrite cfunE -mulrA -scalerA -scalerBr. + rewrite cfdot_suml big1_seq //= => xi Sxi; have Txi := sST xi Sxi. + rewrite cfdotZl cfdotBr -invDade_reciprocity -/(c xi); last first. + rewrite cfun_onD1 !cfunE divfK // subrr eqxx andbT. + by rewrite memvB ?memvZ //= ((seqInd_on _) setT). + have [oSS /orthoPl o_xi0S]: pairwise_orthogonal S /\ orthogonal xi0 S. + have:= seqInd_orthogonal nsHL setT; rewrite (eq_pairwise_orthogonal defT). + by rewrite /= -cat1s pairwise_orthogonal_cat => /and3P[]. + rewrite cfdotBl cfdotC cfproj_sum_orthogonal {oSS}// cfdotZl cfdot_sumr. + rewrite big1_seq ?mulr0 => [|mu Smu]; last by rewrite cfdotZr o_xi0S ?mulr0. + by rewrite subr0 divfK ?(cfnorm_seqInd_neq0 _ Txi) // conjCK subrr mulr0. +split=> [x /part_a-> | ]. + by rewrite sum_cfunE; apply: eq_bigr => ?; rewrite cfunE. +rewrite (cfdotEl _ (invDade_on ddA _)) mulrC mulr_suml. +pose F xi mu x := uc c xi mu * (xi x * (mu x)^*) / #|L|%:R. +transitivity (\sum_(x in A) \sum_(xi <- S) \sum_(mu <- S) F xi mu x). + apply: eq_bigr => x Ax; rewrite part_a // sum_cfunE -mulrA mulr_suml. + apply: eq_bigr => xi _; rewrite mulrA -mulr_suml rmorph_sum; congr (_ * _). + rewrite mulr_sumr; apply: eq_bigr => mu _; rewrite !cfunE (cfdotC mu). + rewrite -{1}[mu x]conjCK -fmorph_div -rmorphM conjCK -4!mulrA 2!(mulrCA _^-1). + by rewrite (mulrA _^-1) -invfM 2!(mulrCA (xi x)) mulrA 2!(mulrA _^*). +rewrite exchange_big; apply: eq_bigr => xi _; rewrite exchange_big /=. +apply: eq_big_seq => mu Smu; have Tmu := sST mu Smu. +rewrite /u eh (cfdotEr _ (seqInd_on nsHL Tmu)) (mulrC _^-1) -mulrBl mulrA. +rewrite -mulr_suml -mulr_sumr (big_setD1 1%g (group1 H)) /=; congr (_ * _ * _). +by rewrite addrC conj_Cnat ?addKr // (Cnat_seqInd1 Tmu). +Qed. + +End InvDadeSeqInd. + +Notation "1" := (1 : 'CF(_)) : classfun_scope. + +(* This is Peterfalvi (7.8). *) +(* Our version is slightly stronger because we state the nontriviality of S *) +(* directly than through the coherence premise (see the discussion of (5.2)). *) +Lemma Dade_Ind1_sub_lin (nu : {additive 'CF(L) -> 'CF(G)}) zeta : + coherent_with calS L^# (Dade ddA) nu -> (1 < size calS)%N -> + zeta \in irr L -> zeta \in calS -> zeta 1%g = e -> + let beta := (Ind1H - zeta)^\tau in let calSnu := map nu calS in + let sumSnu := \sum_(xi <- calS) xi 1%g / e / '[xi] *: nu xi in + [/\ (*a1*) [/\ orthogonal calSnu 1%CF, '[beta, 1] = 1 & beta \in 'Z[irr G]], + exists2 Gamma : 'CF(G), + (*a2*) [/\ orthogonal calSnu Gamma, '[Gamma, 1] = 0 + & exists2 a, a \in Cint & beta = 1 - nu zeta + a *: sumSnu + Gamma] + & (*b*) e <= (h - 1) / 2%:R -> + '[(nu zeta)^\rho] >= 1 - e / h /\ '[Gamma] <= e - 1 + & (*c*) {in irr G, forall chi : 'CF(G), orthogonal calSnu chi -> + [/\ {in A, forall x, chi^\rho x = '[beta, chi]} + & '[chi^\rho] = #|A|%:R / #|L|%:R * '[beta, chi] ^+ 2]}]. +Proof. +move=> [[Inu Znu] nu_tau] nt_calS /irrWnorm Nzeta1 Szeta zeta1. +set mu := _ - _ => beta calSnu sumSnu; pose S1 := rem zeta calS. +have defS: perm_eq calS (zeta :: S1) := perm_to_rem Szeta. +have defZS: 'Z[calS, L^#] =i 'Z[calS, A] by apply: zcharD1_seqInd. +have S1P xi: xi \in S1 -> xi != zeta /\ xi \in calS. + by rewrite mem_rem_uniq // => /andP[]. +have defT: perm_eql calT [:: Ind1H, zeta & S1]. + apply/perm_eqlP; have Tind1: Ind1H \in calT := seqIndT_Ind1 H L. + by rewrite (perm_eqlP (perm_to_rem Tind1)) perm_cons -seqIndC1_rem. +have mu_vchar: mu \in 'Z[irr L, A] := cfInd1_sub_lin_vchar nsHL Szeta zeta1. +have beta_vchar: beta \in 'Z[irr G] by apply: Dade_vchar. +have [mu_on beta_on] := (zchar_on mu_vchar, zchar_on beta_vchar). +have{nt_calS} ntS1: (size S1 > 0)%N by rewrite size_rem // -subn1 subn_gt0. +case defS1: S1 ntS1 => // [phi S2] _. +have /S1P[neq_phi Sphi]: phi \in S1 by rewrite defS1 mem_head. +have nz_phi1: phi 1%g != 0 by rewrite (seqInd1_neq0 nsHL Sphi). +have NatS1e xi (Sxi : xi \in calS) := dvd_index_seqInd1 nsHL Sxi. +have oS1: {in calS, forall psi, '[psi, 1] = 0} by apply: seqInd_ortho_1. +have oS1H: {in calS, forall psi, '[psi, Ind1H] = 0} by apply: seqInd_ortho_Ind1. +have InuS: {in calS &, isometry nu} by apply: sub_in2 Inu; exact: seqInd_zcharW. +have ZnuS xi (Sxi : xi \in calS) := Znu xi (seqInd_zcharW Sxi). +have S_Se xi (Sxi : xi \in calS) := seqInd_sub_lin_vchar nsHL Szeta zeta1 Sxi. +have oSnu1: orthogonal calSnu 1%CF. + have dotSnu1 psi : psi \in calS -> '[nu psi, 1] = psi 1%g / e * '[nu zeta, 1]. + move=> Spsi; apply/eqP; rewrite -subr_eq0 -cfdotZl -cfdotBl. + rewrite -raddfZ_Cnat ?NatS1e // -raddfB; have Spi := S_Se _ Spsi. + rewrite nu_tau ?defZS // invDade_reciprocity ?(zchar_on Spi) //. + rewrite invDade_cfun1 (eq_cfdotr (zchar_on Spi) (eq_cfuni nsAL)). + by rewrite cfdotBl cfdotZl !oS1 // mulr0 subr0. + suffices oz1: '[nu zeta, 1] = 0. + by apply/orthoPr=> _ /mapP[psi Spsi ->]; rewrite dotSnu1 // oz1 mulr0. + have norm_nu_zeta : '[nu zeta] = 1 by rewrite InuS // irrWnorm. + have [et [t defz]] := vchar_norm1P (ZnuS _ Szeta) norm_nu_zeta. + rewrite defz cfdotZl -{1}irr0 cfdot_irr mulr_natr mulrb; case: eqP => // t0. + have /eqP/idPn[] := seqInd_ortho nsHL Sphi Szeta neq_phi. + rewrite -InuS // defz t0 cfdotZr irr0 dotSnu1 // mulrCA -irr0 -t0. + by rewrite -cfdotZr -defz norm_nu_zeta mulr1 mulf_neq0 ?invr_eq0. +have dot_beta_1: '[beta, 1] = 1. + rewrite invDade_reciprocity // invDade_cfun1 (eq_cfdotr _ (eq_cfuni nsAL)) //. + by rewrite cfdotBl -Frobenius_reciprocity cfRes_cfun1 ?cfnorm1 ?oS1 ?subr0. +have o_beta1: '[beta - 1, 1] = 0 by rewrite cfdotBl dot_beta_1 cfnorm1 subrr. +have [X SnuX [Gamma [def_beta1 _ oSnuG]]]:= orthogonal_split calSnu (beta - 1). +have oG1: '[Gamma, 1] = 0. + rewrite -(addKr X Gamma) -def_beta1 addrC cfdotBl o_beta1. + by rewrite (span_orthogonal oSnu1) ?subr0 // memv_span ?mem_head. +have oSS: pairwise_orthogonal calS by apply: seqInd_orthogonal. +have oSnuS: pairwise_orthogonal calSnu by apply: map_pairwise_orthogonal. +have [a_ def_a defX] := orthogonal_span oSnuS SnuX. +have{def_a} def_a: {in calS, forall xi, a_ (nu xi) = '[beta, nu xi] / '[xi]}. + move=> xi Sxi; rewrite (canRL (subrK 1) def_beta1) !cfdotDl def_a InuS //. + by rewrite (cfdotC 1) (orthoPl oSnuG) ?(orthoPr oSnu1) ?map_f ?conjC0 ?addr0. +pose a := '[beta, nu zeta] + 1; have Z1 := Cint1. +have{Z1} Za: a \in Cint by rewrite rpredD ?Cint_cfdot_vchar // ZnuS. +have {a_ def_a defX} defX: X = - nu zeta + a *: sumSnu. + rewrite linear_sum defX big_map !(eq_big_perm _ defS) !big_cons /= addrCA. + rewrite def_a // Nzeta1 !divr1 zeta1 divff // scalerDl !scale1r addrA. + rewrite addrK; congr (_ + _); apply: eq_big_seq => xi /S1P[neq_xi Sxi]. + rewrite def_a // scalerA mulrA mulrDl mul1r; congr (_ / _ *: _). + rewrite mulrC -(conj_Cnat (NatS1e _ Sxi)) -cfdotZr -raddfZ_Cnat ?NatS1e //. + rewrite addrC; apply: canRL (subrK _) _; rewrite -!raddfB /= -/e. + have Spi := S_Se xi Sxi; rewrite nu_tau ?defZS //. + rewrite Dade_isometry ?(zchar_on Spi) // cfdotC cfdotBl cfdotZl !cfdotBr. + by rewrite !oS1H ?(seqInd_ortho _ Sxi) // Nzeta1 subr0 !add0r mulrN1 opprK. +have Ind1H1: Ind1H 1%g = e by rewrite cfInd1 // cfun11 mulr1. +split=> // [ | chi /irrP[t def_chi] o_chiSnu]. + rewrite (canRL (subrK 1) def_beta1) defX addrC 2!addrA. + exists Gamma; first by rewrite orthogonal_sym; split; last exists a. + move=> lt_e_h2; pose v := h^-1; pose u := e^-1 * (1 - v); set w := 1 - e / h. + have hu: h * u = e^-1 * (h - 1) by rewrite mulrCA (mulrBr h) mulr1 divff. + have ->: '[(nu zeta)^\rho] = u * a ^+ 2 - v * a *+ 2 + w. + have defT1: perm_eq calT [:: phi, Ind1H, zeta & S2]. + by rewrite defT defS1 (perm_catCA [::_ ; _] phi). + have [c ua _ ->] := invDade_seqInd_sum (nu zeta) defT1. + have def_c xi: xi \in calS -> c xi = '[xi, zeta]. + move=> S2xi; rewrite /c mulrC -{1}[xi]scale1r -(mulVf nz_phi1) -!scalerA. + rewrite -scalerBr linearZ cfdotZl /=; set pi := _ - _. + have Spi: pi \in 'Z[calS, A] by apply: sub_seqInd_zchar. + rewrite -nu_tau ?defZS // Inu ?(zcharW Spi) ?seqInd_zcharW //. + by rewrite cfdotBl !cfdotZl (seqInd_ortho _ Sphi) // mulr0 subr0 mulKf. + have c2: c zeta = 1 by rewrite def_c. + have c1: c Ind1H = a. + by rewrite /a -c2 -cfdotDl -linearD !addrA subrK zeta1 -Ind1H1. + have{def_c} c3 xi: xi \in S2 -> c xi = 0. + move=> S2xi; have /S1P[neq_xi Sxi]: xi \in S1 by rewrite defS1 mem_behead. + by rewrite def_c // (seqInd_ortho _ Sxi). + rewrite !big_cons; have kill0 := (mul0r, mulr0, big1, conjC0). + rewrite !big1_seq /ua; try by move=> psi /c3->; do 2?rewrite ?kill0 => *. + rewrite !addr0 c1 c2 Nzeta1 cfnorm_Ind_cfun1 // -/e Ind1H1 zeta1 conjC1. + rewrite cfdotC (seqInd_ortho_Ind1 _ _ Szeta) // !kill0 sub0r !mulrN !mulr1. + rewrite divr1 !mul1r !invfM mulrBr !mulrA !mulfK ?divfK // -/w. + rewrite aut_Cint // -[_ / h]mulrA -{1}[e^-1]mulr1 -2!mulrBr -/u -/v. + by rewrite mulrC mulrA addrA (mulrC v) -[_ - _]addrA -opprD. + have ->: '[Gamma] = e - 1 - h * (u * a ^+ 2 - v * a *+ 2). + have /(canLR (addrK 1)) <-: '[beta] = e + 1. + rewrite Dade_isometry // cfnormBd ?cfnorm_Ind_cfun1 ?Nzeta1 //. + by rewrite cfdotC (seqInd_ortho_Ind1 _ _ Szeta) ?conjC0. + rewrite -[beta](subrK 1) cfnormDd; last first. + by rewrite cfdotBl dot_beta_1 cfnorm1 subrr. + rewrite cfnorm1 addrK def_beta1 (addrC X) cfnormDd; last first. + by rewrite (span_orthogonal oSnuG) // memv_span ?mem_head. + do 2!apply: canRL (addrK _) _; rewrite -addrA; congr (_ + _). + rewrite defX (addrC (- nu _)) cfnormB cfnormZ Cint_normK // InuS //. + rewrite cfdotZl cfproj_sum_orthogonal // Nzeta1 zeta1 divff // divr1. + rewrite !mulr1 aut_Cint // mulrBr mulrDr mulVKf // addrAC. + rewrite mulrA mulrC hu -[e^-1](divfK nze) -expr2; congr (_ * _ - _ + 1). + rewrite -mulrA -sum_seqIndC1_square // mulr_sumr cfnorm_sum_orthogonal //. + apply: eq_big_seq => xi Sxi. + have [nz_xi Nxi1] := (cfnorm_seqInd_neq0 nsHL Sxi, Cnat_seqInd1 Sxi). + rewrite (normr_idP _) ?mulr_ge0 ?invr_ge0 ?ler0n ?cfnorm_ge0 ?Cnat_ge0 //. + by rewrite mulrCA !exprMn ['[xi]]lock !mulrA divfK // -lock. + apply/andP; rewrite -subr_ge0 addrK andbC -subr_ge0 addrC opprB subrK. + rewrite pmulr_rge0 ?gt0CG // andbb -mulr_natr (mulrAC v). + have v_ge0: 0 <= v by [rewrite invr_ge0 ler0n]; have L_gt0 := gt0CG L. + have Lu: #|L|%:R * u = h - 1 by rewrite -eh -mulrA hu mulVKf. + have h1ge0: 0 <= h - 1 by rewrite subr_ge0 ler1n cardG_gt0. + have{h1ge0} u_ge0: 0 <= u by rewrite -Lu pmulr_rge0 in h1ge0. + have [a_le0 | ] := boolP (a <= 0). + by rewrite -mulrN -sqrrN addr_ge0 ?(u_ge0, mulr_ge0) ?oppr_ge0 ?ler0n. + rewrite -real_ltrNge ?Creal_Cint // ltr_def => /andP[]. + move/(norm_Cint_ge1 Za)=> a_ge1 a_ge0; rewrite mulrA -mulrBl. + rewrite (normr_idP _) // -(@mulVf _ 2%:R) ?pnatr_eq0 // in a_ge1. + rewrite mulr_ge0 // subr_ge0 (ler_trans _ (ler_wpmul2l u_ge0 a_ge1)) // mulrA. + by rewrite ler_wpmul2r ?ler0n // -(ler_pmul2l L_gt0) mulrA Lu -eh mulfK. +have Zchi: chi \in 'Z[irr G] by rewrite def_chi irr_vchar. +have def_chi0: {in A, chi^\rho =1 (fun _ => '[beta, chi])}. + have defT1: perm_eq calT [:: zeta, Ind1H & S1]. + by rewrite defT (perm_catCA Ind1H zeta). + move=> x Ax; have [_ Hx] := setD1P Ax. + have [c _ -> // _] := invDade_seqInd_sum chi defT1. + rewrite big_cons big1_seq ?addr0 /c => [|xi /S1P[neq_xi /= Sxi]]; last first. + rewrite zeta1 -nu_tau ?defZS ?S_Se // raddfB cfdotBl raddfZ_Cnat ?NatS1e //. + by rewrite cfdotZl !(orthoPr o_chiSnu) ?map_f // mulr0 subr0 conjC0 !mul0r. + rewrite Ind1H1 zeta1 divff // scale1r -/beta aut_Cint ?Cint_cfdot_vchar //. + by rewrite cfnorm_Ind_cfun1 ?cfInd_cfun1 // cfunE cfuniE // Hx mulr1 divfK. +split=> //; rewrite -mulrA mulrCA cfnormE_invDade; congr (_ * _). +rewrite mulr_natl -sumr_const; apply: eq_bigr => _ /def_chi0->. +by rewrite Cint_normK ?Cint_cfdot_vchar. +Qed. + +End Dade_seqIndC1. + +(* The other results of the section are specific to groups of odd order. *) +Hypothesis oddG : odd #|G|. + +(* We explicitly factor out several intermediate results from the proof of *) +(* (7.9) that are reused throughout the proof (including in (7.10) below). *) + +Import ssrint. +Lemma cfdot_real_vchar_even phi psi : + phi \in 'Z[irr G] /\ cfReal phi -> psi \in 'Z[irr G] /\ cfReal psi -> + (2 %| '[phi, psi])%C = (2 %| '[phi, 1])%C || (2 %| '[psi, 1])%C. +Proof. +move=> [Zphi Rphi] [Zpsi Rpsi]; rewrite cfdot_vchar_r // (bigD1 (0 : 'I__)) //=. +rewrite addrC -irr0 (bigID [pred i | conjC_Iirr i < i]%N) /=. +set a1 := \sum_(i | _) _; set a2 := \sum_(i | _) _; suffices ->: a1 = a2. + rewrite -mulr2n -mulr_natr (rpredDl _ (dvdC_mull _ _)) //; last first. + by rewrite rpred_sum // => i; rewrite rpredM ?Cint_cfdot_vchar_irr. + have /CintP[m1 ->] := Cint_cfdot_vchar_irr 0 Zphi. + have /CintP[m2 ->] := Cint_cfdot_vchar_irr 0 Zpsi. + rewrite [m1]intEsign [m2]intEsign !rmorphMsign mulrACA -!mulrA !rpredMsign. + by rewrite -natrM !(dvdC_nat 2) Euclid_dvdM. +rewrite /a2 (reindex_inj (inv_inj (@conjC_IirrK _ _))) /=. +apply: eq_big => [t | t _]; last first. + by rewrite !conjC_IirrE !cfdot_real_conjC ?aut_Cint ?Cint_cfdot_vchar_irr. +rewrite (inv_eq (@conjC_IirrK _ _)) conjC_IirrK -leqNgt ltn_neqAle val_eqE. +rewrite -!(inj_eq irr_inj) !conjC_IirrE irr0 cfConjC_cfun1 odd_eq_conj_irr1 //. +by rewrite andbA andbb. +Qed. + +Section DisjointDadeOrtho. + +Variables (L1 L2 H1 H2 : {group gT}). +Let A1 := H1^#. +Let A2 := H2^#. + +Hypothesis ddA1 : Dade_hypothesis G L1 A1. +Hypothesis ddA2 : Dade_hypothesis G L2 A2. +Let Atau1 := Dade_support ddA1. +Let tau1 := Dade ddA1. +Let Atau2 := Dade_support ddA2. +Let tau2 := Dade ddA2. + +Hypothesis disjointA : [disjoint Atau1 & Atau2]. + +Lemma disjoint_Dade_ortho phi psi : '[tau1 phi, tau2 psi] = 0. +Proof. +rewrite (cfdot_complement (Dade_cfunS _ _)) ?(cfun_onS _ (Dade_cfunS _ _)) //. +by rewrite subsetD disjoint_sym Dade_support_sub. +Qed. + +Let odd_Dade_context L H : Dade_hypothesis G L H^# -> H <| L /\ odd #|L|. +Proof. by case=> nsAL sLG _ _ _; rewrite -normalD1 (oddSg sLG). Qed. + +(* This lemma encapsulates uses of lemma (4.1) in sections 7 and 14. *) +Lemma disjoint_coherent_ortho nu1 nu2 chi1 chi2 : + let S1 := seqIndD H1 L1 H1 1 in coherent_with S1 L1^# tau1 nu1 -> + let S2 := seqIndD H2 L2 H2 1 in coherent_with S2 L2^# tau2 nu2 -> + chi1 \in irr L1 -> chi1 \in S1 -> chi2 \in irr L2 -> chi2 \in S2 -> + '[nu1 chi1, nu2 chi2] = 0. +Proof. +move=> S1 cohS1 S2 cohS2 /irrP[i1 ->] Schi1 /irrP[i2 ->] Schi2. +have [[nsHL1 oddL1] [[Inu1 Znu1] nu1tau]] := (odd_Dade_context ddA1, cohS1). +have [[nsHL2 oddL2] [[Inu2 Znu2] nu2tau]] := (odd_Dade_context ddA2, cohS2). +pose nu_chiC L (nu : 'CF(L) -> 'CF(G)) i := map nu ('chi_i :: ('chi_i)^*)%CF. +have: orthonormal (nu_chiC L1 nu1 i1) && orthonormal (nu_chiC L2 nu2 i2). + rewrite /orthonormal /= !andbT !Inu1 ?Inu2 ?seqInd_zcharW ?cfAut_seqInd //=. + rewrite !cfnorm_conjC !cfnorm_irr (seqInd_conjC_ortho _ _ _ Schi1) ?eqxx //=. + by rewrite (seqInd_conjC_ortho _ _ _ Schi2). +move/orthonormal_vchar_diff_ortho=> -> //. + by split; apply/allP; rewrite /= !(Znu1, Znu2) ?seqInd_zcharW ?cfAut_seqInd. +rewrite -!raddfB !(nu1tau, nu2tau) ?zcharD1_seqInd ?seqInd_sub_aut_zchar //. +by rewrite !Dade1 disjoint_Dade_ortho !eqxx. +Qed. + +(* This is Peterfalvi (7.9). *) +(* We have inlined Hypothesis (7.4) because although it is readily available *) +(* for the proof of (7.10), it would be inconvenient to establish in (14.4). *) +(* Note that our Delta corresponds to Delta - 1 in the Peterfalvi proof. *) +Let beta L H ddA zeta := @Dade _ G L H^# ddA ('Ind[L, H] 1 - zeta). +Lemma Dade_sub_lin_nonorthogonal nu1 nu2 zeta1 zeta2 : + let S1 := seqIndD H1 L1 H1 1 in coherent_with S1 L1^# tau1 nu1 -> + let S2 := seqIndD H2 L2 H2 1 in coherent_with S2 L2^# tau2 nu2 -> + zeta1 \in irr L1 -> zeta1 \in S1 -> zeta1 1%g = #|L1 : H1|%:R -> + zeta2 \in irr L2 -> zeta2 \in S2 -> zeta2 1%g = #|L2 : H2|%:R -> + '[beta ddA1 zeta1, nu2 zeta2] != 0 \/ '[beta ddA2 zeta2, nu1 zeta1] != 0. +Proof. +move=> S1 cohS1 S2 cohS2 irr_zeta1 Szeta1 zeta1_1 irr_zeta2 Szeta2 zeta2_1. +apply/nandP; pose Delta ddA nu zeta := beta ddA zeta + nu zeta. +have Delta_context L H (A := H^#) ddA (tau := Dade ddA) nu zeta : + let S := seqIndD H L H 1 in coherent_with S L^# tau nu -> + zeta \in irr L -> zeta \in S -> zeta 1%g = #|L : H|%:R -> + let D := Delta L H ddA nu zeta in '[D, 1] = 1 /\ D \in 'Z[irr G] /\ cfReal D. +- move=> S cohS irr_zeta Szeta zeta_1 D. + have [[nsHL oddL] [[_ Znu] nu_tau]] := (odd_Dade_context ddA, cohS). + have ntS: (size S > 1)%N by apply: seqInd_nontrivial Szeta. + have [[nuS1_0 beta1_1 Zbeta] _ _] := + Dade_Ind1_sub_lin cohS ntS irr_zeta Szeta zeta_1. + rewrite cfdotDl {}beta1_1 {nuS1_0}(orthoPr nuS1_0) ?map_f // addr0. + rewrite rpredD ?{}Znu ?seqInd_zcharW {Zbeta}// /cfReal; do !split=> //. + rewrite rmorphD /= -subr_eq0 opprD addrAC addrA -addrA addr_eq0 opprD. + rewrite (cfConjC_Dade_coherent cohS) // opprK -Dade_conjC -!raddfB /=. + rewrite nu_tau ?zcharD1_seqInd ?seqInd_sub_aut_zchar //=. + by rewrite rmorphB /= conj_cfInd cfConjC_cfun1 opprB addrC addrA subrK. +have: ~~ (2 %| '[Delta L1 H1 ddA1 nu1 zeta1, Delta L2 H2 ddA2 nu2 zeta2])%C. + have /Delta_context/(_ irr_zeta1 Szeta1 zeta1_1)[Delta1_1 ZR_Delta1] := cohS1. + have /Delta_context/(_ irr_zeta2 Szeta2 zeta2_1)[Delta2_1 ZR_Delta2] := cohS2. + by rewrite cfdot_real_vchar_even // Delta1_1 Delta2_1 (dvdC_nat 2 1). +rewrite cfdotDl !cfdotDr disjoint_Dade_ortho // add0r addrC cfdotC. +apply: contra => /andP[/eqP-> /eqP->]; rewrite conjC0 add0r addr0. +by rewrite (disjoint_coherent_ortho cohS1 cohS2) ?dvdC0. +Qed. + +End DisjointDadeOrtho. + +(* A numerical fact used in Sections 7 and 14. *) +Lemma odd_Frobenius_index_ler (R : numFieldType) (K L : {group gT}) : + odd #|L| -> [Frobenius L with kernel K] -> + #|L : K|%:R <= (#|K|%:R - 1) / 2%:R :> R. +Proof. +move=> oddL /existsP[H frobL]; rewrite ler_pdivl_mulr ?ltr0n // ler_subr_addl. +have ->: #|L : K| = #|H| by have [/index_sdprod] := Frobenius_context frobL. +by rewrite -natrM -mulrS ler_nat muln2 (ltn_odd_Frobenius_ker frobL). +Qed. + +(* This final section factors the assumptions common to (7.10) and (7.11). *) +(* We add solvability of the Frobenius groups, so as not to rely on the *) +(* theorem of Thompson asserting the nilpotence of Frobenius kernels. *) + +Section CoherentFrobeniusPartition. + +Variables (k : nat) (L H E : 'I_k -> {group gT}). + +Local Notation A i := (gval (H i))^#. +Let h_ i : algC := #|H i|%:R. +Let e_ i : algC := #|L i : H i|%:R. +Let G0 := G :\: \bigcup_(i < k) class_support (H i)^# G. + +Hypothesis k_ge2: (k >= 2)%N. + +(*a*) Hypothesis frobeniusL_G : + forall i, [/\ L i \subset G, solvable (L i) & [Frobenius L i = H i ><| E i]]. + +(*b*) Hypothesis normedTI_A : forall i, normedTI (A i) G (L i). + +(*c*) Hypothesis card_coprime : forall i j, i != j -> coprime #|H i| #|H j|. + +(* A numerical fact that is used in both (7.10) and (7.11) *) +Let e_bounds i : 1 < e_ i /\ e_ i <= (h_ i - 1) / 2%:R. +Proof. +have [/oddSg/(_ oddG)oddL _ frobL] := frobeniusL_G i. +rewrite ltr1n odd_Frobenius_index_ler ?(FrobeniusWker frobL) //. +by have [/index_sdprod <-] := Frobenius_context frobL; rewrite cardG_gt1. +Qed. + +(* This is Peterfalvi (7.10). *) +Lemma coherent_Frobenius_bound : exists i, let e := e_ i in let h := h_ i in + (e - 1) * ((h - 2%:R * e - 1) / (e * h) + 2%:R / (h * (h + 2%:R))) + <= (#|G0|%:R - 1) / #|G|%:R. +Proof. +have [sLG solL frobL] := all_and3 frobeniusL_G. +have oddL i := oddSg (sLG i) oddG. +have /all_and2[nsHL ntH] i: H i <| L i /\ H i :!=: 1%g. + by case/Frobenius_context: (frobL i) => /sdprod_context[]. +have sHL i: H i \subset L i by case/andP: (nsHL i). +pose DH i := @Dade_signalizer gT G (L i) (A i). +have /fin_all_exists[ddA DH1] i: exists dd, {in A i, forall a, DH i dd a = 1%G}. + have /Dade_normedTI_P[|ddAi _] := normedTI_A i; last by exists ddAi. + by apply: normedTI_Dade => //; rewrite setSD // (subset_trans (sHL i)). +pose tau i := Dade (ddA i); pose rho i := invDade (ddA i). +pose Atau i := Dade_support (ddA i). +have defAtau i: Atau i = class_support (A i) G. + rewrite class_supportEl; apply: eq_bigr => x Ax. + by rewrite /Dade_support1 -/(DH i) DH1 // mul1g class_support_set1l. +have disjoint_Atau i j : i != j -> [disjoint Atau i & Atau j]. + move=> neq_ij; rewrite !defAtau !class_supportEr -setI_eq0 big_distrlr /=. + rewrite pair_big big1 // => [[x y] _] /=; apply/eqP. + by rewrite !conjD1g -setDIl setD_eq0 coprime_TIg // !cardJg card_coprime. +have{defAtau} defG0: G0 = G :\: \bigcup_i Atau i. + by congr (_ :\: _); apply: eq_bigr => i; rewrite defAtau. +pose S i := seqIndD (H i) (L i) (H i) 1. +have irrS i: {subset S i <= irr (L i)}. + move=> _ /seqIndC1P[t nz_t ->]; rewrite irr_induced_Frobenius_ker //. + exact: FrobeniusWker (frobL i). +have /fin_all_exists[r lin_r] i: exists r, 'chi_r \in S i /\ 'chi_r 1%g = e_ i. + have lt1Hi: [1] \proper H i by rewrite proper1G. + have solHi := solvableS (sHL i) (solL i). + have [xi Sxi lin_xi] := exists_linInd (nsHL i) solHi lt1Hi (normal1 _). + by have /irrP[r def_xi] := irrS i xi Sxi; exists r; rewrite -def_xi. +have{lin_r} [Sr r1] := all_and2 lin_r. +have ntS i: (size (S i) > 1)%N by apply: seqInd_nontrivial (mem_irr _) (Sr i). +have /fin_all_exists[nu cohS] i: coherent (S i) (L i)^# 'Ind[G, L i]. + have [[[frobLi tiAiL] sLiG] oddLi] := (frobL i, normedTI_A i, sLG i, oddL i). + have [defLi ntHi ntEi _ _] := Frobenius_context frobLi. + have{ntEi} nilHi: nilpotent (H i) by apply: (Frobenius_sol_kernel_nil frobLi). + exact: Sibley_coherence (or_introl _ frobLi). +have{cohS} [/all_and2[Inu Znu] nu_Ind] := all_and2 cohS. +have{DH DH1 nu_Ind} cohS i: coherent_with (S i) (L i)^# (tau i) (nu i). + split=> // phi Sphi; rewrite /tau nu_Ind ?Dade_Ind //. + by rewrite (@zchar_on _ _ (S i)) -?zcharD1_seqInd. +have n1S i xi: xi \in S i -> '[xi] = 1. + by case/irrS/irrP=> t ->; rewrite cfnorm_irr. +have n1Snu i xi: xi \in S i -> '[nu i xi] = 1. + by move=> Sxi; rewrite Inu ?n1S ?seqInd_zcharW. +have o_nu i j: i != j -> {in S i & S j, forall xi xj, '[nu i xi, nu j xj] = 0}. + move/disjoint_Atau/disjoint_coherent_ortho=> o_ij xi xj Sxi Sxj. + by rewrite o_ij ?irrS //; apply: cohS. +have /all_and2[nze nzh] i: e_ i != 0 /\ h_ i != 0 by rewrite neq0CiG neq0CG. +have h_gt1 i: 1 < h_ i by rewrite ltr1n cardG_gt1. +have eh i: e_ i * h_ i = #|L i|%:R by rewrite -natrM mulnC Lagrange. +have def_h1 i: h_ i - 1 = #|A i|%:R. + by rewrite /h_ (cardsD1 1%g) group1 addnC natrD addrK. +have [i1 min_i1]: {i1 | forall i, i != i1 -> h_ i1 + 2%:R <= h_ i}. + exists [arg min_(i < Ordinal k_ge2) #|H i|]; case: arg_minP => // i1 _ min_i1. + have oddH i: #|H i| = #|H i|./2.*2.+1. + by rewrite -{1}[#|H i|]odd_double_half (oddSg (sHL i)). + move=> i neq_i; rewrite -natrD ler_nat (oddH i) oddH addn2 -doubleS ltnS. + rewrite leq_double ltn_neqAle andbC half_leq ?min_i1 //=. + apply: contraTneq (card_coprime neq_i) => eqHii1. + by rewrite oddH -eqHii1 -oddH /coprime gcdnn -trivg_card1. +exists i1 => e h; set lhs := (e - 1) * _. +have nzh2: h + 2%:R != 0 by rewrite -natrD addnC pnatr_eq0. +have{lhs} ->: lhs = 1 - e / h - (h - 1) / (e * h) - (e - 1) / (h + 2%:R). + rewrite {}/lhs -{2}(addrK h 2%:R) !invfM (mulrBl _ _ h) mulVKf ?nzh //. + rewrite addrCA (addrC _ h) mulrCA mulrA addrA mulrBr; congr (_ - _). + rewrite mulfK // mulrDr addrAC addrC mulrC mulrBl -mulrA mulVKf ?nze //. + rewrite mulrC mulrBr mulrBl mul1r addrAC addrC addrA; congr (_ - _). + rewrite mulrCA mulVKf ?nze // addrCA mulrCA mulr_natl opprD addNKr. + by rewrite !mulrBl opprB addrA subrK divff ?nzh. +pose beta i := tau i ('Ind[L i, H i] 1 - 'chi_(r i)). +have betaP i := Dade_Ind1_sub_lin (cohS i) (ntS i) (mem_irr _) (Sr i) (r1 i). +pose chi i := nu i 'chi_(r i); pose c i j := '[beta i, chi j]. +have:= betaP i1; rewrite -/(S _) -/(tau _) -/(beta _) -/(chi _) -/(e_ _) -/e. +move=> [[oSnu1 o_beta1 Zbeta1] [Gamma [oSnuGamma oGamma1] [a Za def_beta1]]]. +have [_ lt_e_h2] := e_bounds i1; rewrite -/(rho _) -/(h_ _) -/h. +case/(_ lt_e_h2)=> min_rho1 maxGamma _ {lt_e_h2}. +pose calB := [set i | (i != i1) && (c i i1 == 0)]. +pose sumB := \sum_(i in calB) (h_ i - 1) / (e_ i * h_ i). +suffices{min_rho1} sumB_max: sumB <= (e - 1) / (h + 2%:R). + rewrite -subr_ge0 opprB addrCA -opprB subr_ge0; apply: ler_trans sumB_max. + rewrite -subr_ge0 opprB addrCA -(opprB _ sumB) subr_ge0. + have Zchi1: chi i1 \in 'Z[irr G] by rewrite Znu ?seqInd_zcharW ?Sr. + have [eps [t def_chi1]] := vchar_norm1P Zchi1 (n1Snu i1 'chi_(r i1) (Sr i1)). + pose sumG0 := \sum_(g in G0) `|'chi_t g| ^+ 2. + apply: (@ler_trans _ ((#|G0|%:R - sumG0) / #|G|%:R)); last first. + rewrite ler_pmul2r ?invr_gt0 ?gt0CG // ler_add2l ler_opp2. + rewrite [sumG0](bigD1 1%g) /=; last first. + rewrite !inE group1 andbT; apply/bigcupP=> [[i _]]. + by rewrite class_supportEr => /bigcupP[x _]; rewrite conjD1g !inE eqxx. + rewrite -[1]addr0 ler_add ?sumr_ge0 // => [|x _]; last first. + by rewrite -normrX normr_ge0. + have Zchit1: 'chi_t 1%g \in Cint by rewrite CintE Cnat_irr1. + by rewrite expr_ge1 ?normr_ge0 // norm_Cint_ge1 ?irr1_neq0. + pose ea i : algC := #|(H i)^#|%:R / #|L i|%:R. + apply: (@ler_trans _ (\sum_i ('[rho i 'chi_t] - ea i))); last first. + rewrite -subr_ge0 -opprB oppr_ge0 -mulNr opprB addrC mulrC. + by rewrite /sumG0 defG0 Dade_cover_inequality ?cfnorm_irr. + rewrite (bigID (mem calB)) /= addrC ler_add //. + rewrite -subr_ge0 opprK -big_split sumr_ge0 //= => i _. + by rewrite def_h1 eh subrK cfnorm_ge0. + rewrite (bigD1 i1) ?inE ?eqxx ?andbF //= -ler_subl_addl (@ler_trans _ 0) //. + rewrite opprB /ea -def_h1 -eh -/h -/e addrA subrK subr_le0. + by rewrite -(cfnorm_sign eps) -linearZ -def_chi1. + rewrite sumr_ge0 // => i; rewrite inE /c andbC => /andP[neq_i]. + rewrite neq_i subr_ge0 def_chi1 cfdotZr mulf_eq0 => /norP[_ not_o_beta_chi]. + have [[_ _ Zbeta_i] _ /(_ _ (mem_irr t))[|_ ->]] := betaP i. + apply/orthoPr=> _ /mapP[xi Sxi ->]; rewrite -['chi_t](signrZK eps). + by rewrite -def_chi1 cfdotZr o_nu ?mulr0 ?Sr. + rewrite -[ea i]mulr1 /ea ler_wpmul2l ?mulr_ge0 ?invr_ge0 ?ler0n //. + by rewrite -/(tau i) -/(beta i) sqr_Cint_ge1 ?Cint_cfdot_vchar_irr. +rewrite -(mulfK nzh2 sumB) -{2 3}natrD ler_wpmul2r ?invr_ge0 ?ler0n //. +apply: ler_trans maxGamma; rewrite mulr_suml. +pose phi i : 'CF(G) := \sum_(xi <- S i) xi 1%g / e_ i / '[xi] *: nu i xi. +have o_phi_nu i j xi: i != j -> xi \in S j -> '[phi i, nu j xi] = 0. + move/o_nu=> o_ij Sxi; rewrite cfdot_suml big1_seq //= => pi Spi. + by rewrite cfdotZl o_ij ?mulr0. +have o_phi i j: i != j -> '[phi i, phi j] = 0. + move/o_phi_nu=> o_ij; rewrite cfdot_sumr big1_seq // => xi Sxi. + by rewrite cfdotZr o_ij ?mulr0. +pose X : 'CF(G) := \sum_(i in calB) c i1 i *: phi i; pose Gamma1 := Gamma - X. +have ->: Gamma = Gamma1 + X by rewrite subrK. +have{betaP def_beta1} /cfnormDd->: '[Gamma1, X] = 0. + rewrite cfdot_sumr big1 // => i Bi; have [neq_i _] := setIdP Bi. + rewrite cfdotZr cfdot_sumr big1_seq ?mulr0 //= => xi Sxi. + apply/eqP; rewrite cfdotZr cfdotBl mulf_eq0; apply/pred2P; right. + rewrite cfdot_suml (bigD1 i) ?big1 //= => [|j /andP[_ neq_j]]; last first. + by rewrite cfdotZl o_phi_nu ?mulr0. + rewrite cfdotZl cfproj_sum_orthogonal ?seqInd_orthogonal //; last exact: Inu. + rewrite n1S // divr1 mulr1 addr0 mulrC -(canLR (addKr _) def_beta1). + rewrite !(cfdotDl, cfdotNl) cfdotZl o_nu ?o_phi_nu ?Sr 1?eq_sym // mulr0. + have[[/orthoPr oSnui_1 _ _] _ _] := betaP i; rewrite -/(S i) in oSnui_1. + rewrite cfdotC oSnui_1 ?map_f // conjC0 !(add0r, oppr0). + have Nxie: xi 1%g / e_ i \in Cnat by apply: dvd_index_seqInd1 _ Sxi. + rewrite -(conj_Cnat Nxie) // -cfdotZr -raddfZ_Cnat // -!raddfB /=. + have [_ Dnu] := cohS i. + rewrite Dnu ?zcharD1_seqInd ?seqInd_sub_lin_vchar ?Sr ?r1 //. + by rewrite disjoint_Dade_ortho ?disjoint_Atau 1?eq_sym. +rewrite -subr_ge0 cfdot_sumr -addrA -sumrB addr_ge0 ?cfnorm_ge0 //. +rewrite sumr_ge0 // => i Bi; have [neq_i ci1_0] := setIdP Bi. +have n_phi: '[phi i] = (h_ i - 1) / e_ i. + rewrite cfnorm_sum_orthogonal ?seqInd_orthogonal //; last exact: Inu. + rewrite -[_ - 1](mulKf (nze i)) -sum_seqIndC1_square // -/(S i) mulrAC. + rewrite -invfM mulrC mulr_suml; apply: eq_big_seq => _ /irrS/irrP[t ->]. + rewrite cfnorm_irr !divr1 mulr1 -expr2 -exprVn -exprMn. + by rewrite (normr_idP _) // mulr_ge0 ?invr_ge0 ?ler0n // ltrW ?irr1_gt0. +rewrite subr_ge0 cfdotZr cfdot_suml (bigD1 i) //=. +rewrite big1 ?addr0 => [|j /andP[_ ne_j]]; last by rewrite cfdotZl o_phi ?mulr0. +rewrite cfdotZl invfM 2!mulrA -n_phi -[_ * _]mulrA mulrC. +rewrite ler_wpmul2r ?cfnorm_ge0 // (@ler_trans _ 1) //. + by rewrite -{2}(mulVf (nzh i)) ler_wpmul2l ?invr_ge0 ?ler0n ?min_i1. +rewrite mulrC -normCK expr_ge1 ?normr_ge0 // norm_Cint_ge1 //. + rewrite Cint_cfdot_vchar ?Znu ?seqInd_zcharW ?Sr //. +suffices /orP: c i i1 != 0 \/ c i1 i != 0 by rewrite ci1_0. +apply: Dade_sub_lin_nonorthogonal; rewrite ?mem_irr ?Sr ?r1 //; try exact: cohS. +exact: disjoint_Atau. +Qed. + +(* This is Peterfalvi (7.11). *) +Theorem no_coherent_Frobenius_partition : G0 != 1%G. +Proof. +have [i] := coherent_Frobenius_bound; apply: contraTneq => ->. +have [] := e_bounds i; set e := e_ i; set h := h_ i => e_gt1 le_e_h2. +rewrite cards1 subrr mul0r ltr_geF // pmulr_rgt0 ?subr_gt0 // ltr_paddl //. + rewrite ?(mulr_ge0, invr_ge0) ?ler0n // addrAC subr_ge0. + by rewrite -[_ - 1](@divfK _ 2%:R) ?pnatr_eq0 // mulrC ler_wpmul2r ?ler0n. +by rewrite -natrD addnC ?(pmulr_rgt0, invr_gt0) ?ltr0n. +Qed. + +End CoherentFrobeniusPartition. + +End Seven. + diff --git a/mathcomp/odd_order/PFsection8.v b/mathcomp/odd_order/PFsection8.v new file mode 100644 index 0000000..72a0d00 --- /dev/null +++ b/mathcomp/odd_order/PFsection8.v @@ -0,0 +1,1128 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime ssralg poly finset center. +Require Import fingroup morphism perm automorphism quotient action finalg zmodp. +Require Import gfunctor gproduct cyclic commutator nilpotent pgroup. +Require Import sylow hall abelian maximal frobenius. +Require Import matrix mxalgebra mxrepresentation vector. +Require Import BGsection1 BGsection3 BGsection7 BGsection10. +Require Import BGsection14 BGsection15 BGsection16. +Require ssrnum. +Require Import algC classfun character inertia vcharacter. +Require Import PFsection1 PFsection2 PFsection3 PFsection4 PFsection5. + +(******************************************************************************) +(* This file covers Peterfalvi, Section 8: Structure of a Minimal Simple *) +(* Group of Odd Order. Actually, most Section 8 definitions can be found in *) +(* BGsection16, which holds the conclusions of the Local Analysis part of the *) +(* proof, as the B & G text has been adapted to fit the usage in Section 8. *) +(* Most of the definitions of Peterfalvi Section 8 are covered in BGsection7, *) +(* BGsection15 and BGsection16; we only give here: *) +(* FT_Pstructure S T defW <-> the groups W, W1, W2, S, and T satisfy the *) +(* conclusion of Theorem (8.8)(b), in particular, S and T *) +(* are of type P, S = S^(1) ><| W1, and T = T^`(1) ><| W2. *) +(* The assumption defW : W1 \x W2 = W is a parameter. *) +(* 'R[x] == the "signalizer" group of x \in 'A1(M) for the Dade *) +(* hypothesis of M (note: this is only extensionally equal *) +(* to the 'R[x] defined in BGsection14). *) +(* 'R_M == the signalizer functor for the Dade hypothesis of M. *) +(* Note that this only maps x to 'R[x] for x in 'A1(M). *) +(* The casual use of the R(x) in Peterfalvi is improper, *) +(* as its meaning depends on which maximal group is *) +(* considered. *) +(* 'A~(M, A) == the support of the image of 'CF(M, A) under the Dade *) +(* isometry of a maximal group M. *) +(* 'A1~(M) := 'A~(M, 'A1(M)). *) +(* 'A~(M) := 'A~(M, 'A(M)). *) +(* 'A0~(M) := 'A~(M, 'A0(M)). *) +(* FT_Dade maxM, FT_Dade0 maxM, FT_Dade1 maxM, FT_DadeF maxM *) +(* FT_Dade_hyp maxM, FT_Dade0_hyp maxM, FT_Dade1_hyp maxM, FT_DadeF_hyp maxM *) +(* == for maxM : M \in 'M, the Dade isometry of M, with *) +(* domain 'A(M), 'A0(M), 'A1(M) and M`_\F^#, respectively, *) +(* and the proofs of the corresponding Dade hypotheses. *) +(* Note that we use an additional restriction (to M`_\F^#) *) +(* to fit better with the conventions of PFsection7. *) +(* FTsupports M L <-> L supports M in the sense of (8.14) and (8.18). This *) +(* definition is not used outside this file. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory. + +Local Open Scope ring_scope. + +(* Supercedes the notation in BGsection14. *) +Notation "''R' [ x ]" := 'C_((gval 'N[x])`_\F)[x] + (at level 8, format "''R' [ x ]") : group_scope. +Notation "''R' [ x ]" := 'C_('N[x]`_\F)[x]%G : Group_scope. + +Section Definitions. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). +Implicit Types L M X : {set gT}. + +(* These cover Peterfalvi, Definition (8.14). *) +Definition FTsignalizer M x := if 'C[x] \subset M then 1%G else 'R[x]%G. + +Definition FTsupports M L := + [exists x in 'A(M), ~~ ('C[x] \subset M) && ('C[x] \subset L)]. + +Definition FT_Dade_support M X := + \bigcup_(x in X) class_support (FTsignalizer M x :* x) G. + +End Definitions. + +Notation "''R_' M" := (FTsignalizer M) + (at level 8, M at level 2, format "''R_' M") : group_scope. + +Notation "''A~' ( M , A )" := (FT_Dade_support M A) + (at level 8, format "''A~' ( M , A )"). + +Notation "''A1~' ( M )" := 'A~(M, 'A1(M)) (at level 8, format "''A1~' ( M )"). +Notation "''A~' ( M )" := 'A~(M, 'A(M)) (at level 8, format "''A~' ( M )"). +Notation "''A0~' ( M )" := 'A~(M, 'A0(M)) (at level 8, format "''A0~' ( M )"). + +Section Eight. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). +Implicit Types (p q : nat) (x y z : gT) (A B : {set gT}). +Implicit Types H K L M N P Q R S T U V W : {group gT}. + +(* Peterfalvi, Definition (8.1) is covered by BGsection16.of_typeF. *) + +(* This is the remark following Definition (8.1). *) +Remark compl_of_typeF M U V (H := M`_\F) : + H ><| U = M -> of_typeF M V -> of_typeF M U. +Proof. +move=> defM_U [[]]; rewrite -/H => ntH ntV defM part_b part_c. +have oU: #|U| = #|V|. + apply/eqP; rewrite -(@eqn_pmul2l #|H|) ?cardG_gt0 //. + by rewrite (sdprod_card defM) (sdprod_card defM_U). +have [x Mx defU]: exists2 x, x \in M & U :=: V :^ x. + pose pi := \pi(V); have hallV: pi.-Hall(M) V. + by rewrite Hall_pi // -(sdprod_Hall defM) (pHall_Hall (Fcore_Hall M)). + apply: Hall_trans (hallV). + rewrite mFT_sol // (sub_proper_trans _ (mFT_norm_proper ntH _)) ?gFnorm //. + rewrite (proper_sub_trans _ (subsetT M)) // properEcard gFsub. + by rewrite -(sdprod_card defM) ltn_Pmulr ?cardG_gt0 ?cardG_gt1. + rewrite pHallE -(card_Hall hallV) oU eqxx andbT. + by case/sdprod_context: defM_U. +have nHx: x \in 'N(H) by apply: subsetP Mx; rewrite gFnorm. +split; first by rewrite {1}defU conjsg_eq1. + have [U1 [nsU1U abU1 prU1H]] := part_b. + rewrite defU; exists (U1 :^ x)%G; split; rewrite ?normalJ ?abelianJ //. + rewrite -/H -(normP nHx) -conjD1g => _ /imsetP[h Hh ->]. + by rewrite -conjg_set1 normJ -conjIg conjSg prU1H. +have [U0 [sU0V expU0 frobHU0]] := part_c. +have [defHU0 _ ntU0 _ _] := Frobenius_context frobHU0. +rewrite defU; exists (U0 :^ x)%G; split; rewrite ?conjSg ?exponentJ //. +by rewrite -/H -(normP nHx) -conjYg FrobeniusJ. +Qed. + +Lemma Frobenius_of_typeF M U (H := M`_\F) : + [Frobenius M = H ><| U] -> of_typeF M U. +Proof. +move=> frobM; have [defM ntH ntU _ _] := Frobenius_context frobM. +have [_ _ nHU tiHU] := sdprodP defM. +split=> //; last by exists U; split; rewrite // -sdprodEY ?defM. +exists 1%G; split; rewrite ?normal1 ?abelian1 //. +by move=> x /(Frobenius_reg_compl frobM)->. +Qed. + +(* This is Peterfalvi (8.2). *) +Lemma typeF_context M U (H := M`_\F) : + of_typeF M U -> + [/\ (*a*) forall U0, is_typeF_complement M U U0 -> #|U0| = exponent U, + (*b*) [Frobenius M = H ><| U] = Zgroup U + & (*c*) forall U1 (i : Iirr H), + is_typeF_inertia M U U1 -> i != 0 -> 'I_U['chi_i] \subset U1]. +Proof. +case; rewrite -/H => [[ntH ntM defM] _ exU0]; set part_a := forall U0, _. +have [nsHM sUG mulHU nHU _] := sdprod_context defM. +have oU0: part_a. + move=> U0 [sU0U <- /Frobenius_reg_ker regU0]; rewrite exponent_Zgroup //. + apply/forall_inP=> S /SylowP[p _ /and3P[sSU0 pS _]]. + apply: odd_regular_pgroup_cyclic pS (mFT_odd S) ntH _ _. + by rewrite (subset_trans (subset_trans sSU0 sU0U)). + by move=> x /setD1P[ntx /(subsetP sSU0) U0x]; rewrite regU0 // !inE ntx. +split=> // [|U1 i [nsU1U abU1 s_cUH_U1] nz_i]. + apply/idP/idP=> [frobU | ZgU]. + apply/forall_inP=> S /SylowP[p _ /and3P[sSU pS _]]. + apply: odd_regular_pgroup_cyclic pS (mFT_odd S) ntH _ _. + by rewrite (subset_trans sSU). + move=> x /setD1P[ntx /(subsetP sSU) Ux]. + by rewrite (Frobenius_reg_ker frobU) // !inE ntx. + have [U0 [sU0U expU0 frobU0]] := exU0; have regU0 := Frobenius_reg_ker frobU0. + suffices defU0: U0 :=: U by rewrite defU0 norm_joinEr ?mulHU // in frobU0. + by apply/eqP; rewrite eqEcard sU0U /= (oU0 U0) // exponent_Zgroup. +have itoP: is_action M (fun (j : Iirr H) x => conjg_Iirr j x). + split=> [x | j x y Mx My]. + apply: can_inj (fun j => conjg_Iirr j x^-1) _ => j. + by apply: irr_inj; rewrite !conjg_IirrE cfConjgK. + by apply: irr_inj; rewrite !conjg_IirrE (cfConjgM _ nsHM). +pose ito := Action itoP; pose cto := ('Js \ subsetT M)%act. +have actsMcH: [acts M, on classes H | cto]. + apply/subsetP=> x Mx; rewrite !inE Mx; apply/subsetP=> _ /imsetP[y Hy ->]. + have nHx: x \in 'N(H) by rewrite (subsetP (gFnorm _ _)). + rewrite !inE /= -class_rcoset norm_rlcoset // class_lcoset mem_classes //. + by rewrite memJ_norm. +apply/subsetP=> g /setIP[Ug /setIdP[nHg c_i_g]]; have Mg := subsetP sUG g Ug. +apply: contraR nz_i => notU1g; rewrite (sameP eqP set1P). +suffices <-: 'Fix_ito[g] = [set 0 : Iirr H]. + by rewrite !inE sub1set inE -(inj_eq (@irr_inj _ _)) conjg_IirrE. +apply/eqP; rewrite eq_sym eqEcard cards1 !(inE, sub1set) /=. +rewrite -(inj_eq (@irr_inj _ _)) conjg_IirrE irr0 cfConjg_cfun1 eqxx. +rewrite (card_afix_irr_classes Mg actsMcH) => [|j y z Hy /=]; last first. + case/imsetP=> _ /imsetP[t Ht ->] -> {z}. + by rewrite conjg_IirrE cfConjgE // conjgK cfunJ. +rewrite -(cards1 [1 gT]) subset_leq_card //= -/H. +apply/subsetP=> _ /setIP[/imsetP[a Ha ->] /afix1P caHg]; rewrite inE classG_eq1. +have{caHg} /imsetP[x Hgx cax]: a \in a ^: (H :* g). + by rewrite class_rcoset caHg class_refl. +have coHg: coprime #|H| #[g]. + apply: (coprime_dvdr (order_dvdG Ug)). + by rewrite (coprime_sdprod_Hall_l defM) (pHall_Hall (Fcore_Hall M)). +have /imset2P[z y cHgg_z Hy defx]: x \in class_support ('C_H[g] :* g) H. + have [/and3P[/eqP defUcHgg _ _] _] := partition_cent_rcoset nHg coHg. + by rewrite class_supportEr -cover_imset defUcHgg. +rewrite -(can_eq (conjgKV y)) conj1g; apply: contraR notU1g => nt_ay'. +have{nt_ay'} Hay': a ^ y^-1 \in H^# by rewrite !inE nt_ay' groupJ ?groupV. +rewrite (subsetP (s_cUH_U1 _ Hay')) // inE Ug. +have ->: g = z.`_(\pi(H)^'). + have [h /setIP[Hh /cent1P cgh] ->] := rcosetP cHgg_z. + rewrite consttM // (constt1P _) ?mul1g ?constt_p_elt //. + by rewrite /p_elt -coprime_pi' ?cardG_gt0. + by rewrite (mem_p_elt _ Hh) // pgroupNK pgroup_pi. +by rewrite groupX //= -conjg_set1 normJ mem_conjgV -defx !inE conjg_set1 -cax. +Qed. + +(* Peterfalvi, Definition (8.3) is covered by BGsection16.of_typeI. *) +(* Peterfalvi, Definition (8.4) is covered by BGsection16.of_typeP. *) + +Section TypeP_Remarks. +(* These correspond to the remarks following Definition (8.4). *) + +Variables (M U W W1 W2 : {group gT}) (defW : W1 \x W2 = W). +Let H := M`_\F. +Let M' := M^`(1)%g. + +Hypothesis MtypeP : of_typeP M U defW. + +Remark of_typeP_sol : solvable M. +Proof. +have [_ [nilU _ _ defM'] _ _ _] := MtypeP. +have [nsHM' _ mulHU _ _] := sdprod_context defM'. +rewrite (series_sol (der_normal 1 M)) (abelian_sol (der_abelian 0 M)) andbT. +rewrite (series_sol nsHM') (nilpotent_sol (Fcore_nil M)). +by rewrite -mulHU quotientMidl quotient_sol ?(nilpotent_sol nilU). +Qed. + +Remark typeP_cent_compl : 'C_M'(W1) = W2. +Proof. +have [[/cyclicP[x ->] _ ntW1 _] _ _ [_ _ _ _ prM'W1] _] := MtypeP. +by rewrite cent_cycle prM'W1 // !inE cycle_id -cycle_eq1 ntW1. +Qed. + +Remark typeP_cent_core_compl : 'C_H(W1) = W2. +Proof. +have [sW2H sHM']: W2 \subset H /\ H \subset M'. + by have [_ [_ _ _ /sdprodW/mulG_sub[-> _]] _ []] := MtypeP. +by apply/eqP; rewrite eqEsubset subsetI sW2H -typeP_cent_compl ?subsetIr ?setSI. +Qed. + +Lemma typePF_exclusion K : ~ of_typeF M K. +Proof. +move=> [[ntH ntU1 defM_K] _ [U0 [sU01 expU0] frobU0]]. +have [[cycW1 hallW1 ntW1 defM] [_ _ _ defM'] _ [_]] := MtypeP; case/negP. +pose p := pdiv #|W1|; rewrite -/M' -/H in defM defM' frobU0 *. +have piW1p: p \in \pi(W1) by rewrite pi_pdiv cardG_gt1. +have piU0p: p \in \pi(U0). + rewrite -pi_of_exponent expU0 pi_of_exponent (pi_of_dvd _ _ piW1p) //=. + rewrite -(@dvdn_pmul2l #|H|) ?cardG_gt0 // (sdprod_card defM_K). + rewrite -(sdprod_card defM) dvdn_pmul2r ?cardSg //. + by case/sdprodP: defM' => _ <- _ _; exact: mulG_subl. +have [|X EpX]:= @p_rank_geP _ p 1 U0 _; first by rewrite p_rank_gt0. +have [ntX [sXU0 abelX _]] := (nt_pnElem EpX isT, pnElemP EpX). +have piW1_X: \pi(W1).-group X by apply: pi_pgroup piW1p; case/andP: abelX. +have sXM: X \subset M. + by rewrite -(sdprodWY defM_K) joingC sub_gen ?subsetU // (subset_trans sXU0). +have nHM: M \subset 'N(H) by apply: gFnorm. +have [regU0 solM] := (Frobenius_reg_ker frobU0, of_typeP_sol). +have [a Ma sXaW1] := Hall_Jsub solM (Hall_pi hallW1) sXM piW1_X. +rewrite -subG1 -(conjs1g a) -(cent_semiregular regU0 sXU0 ntX) conjIg -centJ. +by rewrite (normsP nHM) // -typeP_cent_core_compl ?setIS ?centS. +Qed. + +Remark of_typeP_compl_conj W1x : M' ><| W1x = M -> W1x \in W1 :^: M. +Proof. +case/sdprodP=> [[{W1x}_ W1x _ ->] mulM'W1x _ tiM'W1x]. +have [[_ /Hall_pi hallW1 _ defM] _ _ _ _] := MtypeP. +apply/imsetP; apply: Hall_trans of_typeP_sol _ (hallW1). +rewrite pHallE -(card_Hall hallW1) -(@eqn_pmul2l #|M'|) ?cardG_gt0 //. +by rewrite (sdprod_card defM) -mulM'W1x mulG_subr /= TI_cardMg. +Qed. + +Remark conj_of_typeP x : + {defWx : W1 :^ x \x W2 :^ x = W :^ x | of_typeP (M :^ x) (U :^ x) defWx}. +Proof. +have defWx: W1 :^ x \x W2 :^ x = W :^ x by rewrite -dprodJ defW. +exists defWx; rewrite /of_typeP !derJ FcoreJ FittingJ centJ -conjIg normJ. +rewrite !cyclicJ !conjsg_eq1 /Hall !conjSg indexJg cardJg -[_ && _]/(Hall M W1). +rewrite -(isog_nil (conj_isog U x)) -!sdprodJ -conjsMg -conjD1g. +rewrite -(conjGid (in_setT x)) -conjUg -conjDg normedTI_J. +have [[-> -> -> ->] [-> -> -> ->] [-> -> -> ->] [-> -> -> -> prW1] ->]:= MtypeP. +by do 2![split]=> // _ /imsetP[y /prW1<- ->]; rewrite cent1J -conjIg. +Qed. + +(* This is Peterfalvi (8.5), with an extra clause in anticipation of (8.15). *) +Lemma typeP_context : + [/\ (*a*) H \x 'C_U(H) = 'F(M), + (*b*) U^`(1)%g \subset 'C(H) /\ (U :!=: 1%g -> ~~ (U \subset 'C(H))), + (*c*) normedTI (cyclicTIset defW) G W + & cyclicTI_hypothesis G defW]. +Proof. +have defW2 := typeP_cent_core_compl. +case: MtypeP; rewrite /= -/H => [] [cycW1 hallW1 ntW1 defM] [nilU _ _ defM']. +set V := W :\: _ => [] [_ sM''F defF sFM'] [cycW2 ntW2 sW2H _ _] TI_V. +have [/andP[sHM' nHM'] sUM' mulHU _ tiHU] := sdprod_context defM'. +have sM'M : M' \subset M by apply: der_sub. +have hallM': \pi(M').-Hall(M) M' by rewrite Hall_pi // (sdprod_Hall defM). +have hallH_M': \pi(H).-Hall(M') H := pHall_subl sHM' sM'M (Fcore_Hall M). +have{defF} defF: (H * 'C_U(H))%g = 'F(M). + rewrite -(setIidPl sFM') -defF -group_modl //= -/H. + rewrite setIAC (setIidPr (der_sub 1 M)). + rewrite -(coprime_mulG_setI_norm mulHU) ?norms_cent //; last first. + by rewrite (coprime_sdprod_Hall_l defM') (pHall_Hall hallH_M'). + by rewrite mulgA (mulGSid (subsetIl _ _)). +have coW12: coprime #|W1| #|W2|. + rewrite coprime_sym (coprimeSg (subset_trans sW2H sHM')) //. + by rewrite (coprime_sdprod_Hall_r defM). +have cycW: cyclic W by rewrite (cyclic_dprod defW). +have ctiW: cyclicTI_hypothesis G defW by split; rewrite ?mFT_odd. +split=> //; first by rewrite dprodE ?subsetIr //= setIA tiHU setI1g. +split. + apply: subset_trans (_ : U :&: 'F(M) \subset _). + by rewrite subsetI der_sub (subset_trans (dergS 1 sUM')). + by rewrite -defF -group_modr ?subsetIl // setIC tiHU mul1g subsetIr. +apply: contra => cHU; rewrite -subG1 -tiHU subsetIidr (subset_trans sUM') //. +by rewrite (Fcore_max hallM') ?der_normal // -mulHU mulg_nil ?Fcore_nil. +Qed. + +End TypeP_Remarks. + +Remark FTtypeP_witness M : + M \in 'M -> FTtype M != 1%N -> exists_typeP (of_typeP M). +Proof. +move=> maxM /negbTE typeMnot1. +have:= FTtype_range M; rewrite -mem_iota !inE typeMnot1 /=. +by case/or4P=> /FTtypeP[//|U W W1 W2 defW [[]]]; exists U W W1 W2 defW. +Qed. + +(* Peterfalvi, Definition (8.6) is covered by BGsection16.of_typeII_IV et al. *) +(* Peterfalvi, Definition (8.7) is covered by BGsection16.of_typeV. *) + +Section FTypeP_Remarks. +(* The remarks for Definition (8.4) also apply to (8.6) and (8.7). *) + +Variables (M U W W1 W2 : {group gT}) (defW : W1 \x W2 = W). +Let H := M`_\F. +Let M' := M^`(1)%g. + +Hypotheses (maxM : M \in 'M) (MtypeP : of_typeP M U defW). + +Remark of_typeP_conj (Ux W1x W2x Wx : {group gT}) (defWx : W1x \x W2x = Wx) : + of_typeP M Ux defWx -> + exists x, + [/\ x \in M, U :^ x = Ux, W1 :^ x = W1x, W2 :^ x = W2x & W :^ x = Wx]. +Proof. +move=> MtypePx; have [[_ _ _ defMx] [_ _ nUW1x defM'x] _ _ _] := MtypePx. +have [[_ hallW1 _ defM] [_ _ nUW1 defM'] _ _ _] := MtypeP. +have [/mulG_sub[/= sHM' sUM'] [_ _ nM'W1 _]] := (sdprodW defM', sdprodP defM). +rewrite -/M' -/H in defMx defM'x defM defM' sHM' sUM' nM'W1. +have /imsetP[x2 Mx2 defW1x2] := of_typeP_compl_conj MtypeP defMx. +have /andP[sM'M nM'M]: M' <| M by apply: der_normal. +have solM': solvable M' := solvableS sM'M (of_typeP_sol MtypeP). +have [hallU hallUx]: \pi(H)^'.-Hall(M') U /\ \pi(H)^'.-Hall(M') (Ux :^ x2^-1). + have hallH: \pi(H).-Hall(M') H by apply: pHall_subl (Fcore_Hall M). + rewrite pHallJnorm ?(subsetP nM'M) ?groupV // -!(compl_pHall _ hallH). + by rewrite (sdprod_compl defM') (sdprod_compl defM'x). +have coM'W1: coprime #|M'| #|W1| by rewrite (coprime_sdprod_Hall_r defM). +have nUxW1: W1 \subset 'N(Ux :^ x2^-1) by rewrite normJ -sub_conjg -defW1x2. +have [x1] := coprime_Hall_trans nM'W1 coM'W1 solM' hallUx nUxW1 hallU nUW1. +case/setIP=> /(subsetP sM'M) My /(normsP (cent_sub _)) nW1x1 defUx1. +pose x := (x1 * x2)%g; have Mx: x \in M by rewrite groupM. +have defW1x: W1 :^ x = W1x by rewrite conjsgM nW1x1. +have defW2x: W2 :^ x = W2x. + rewrite -(typeP_cent_compl MtypeP) -(typeP_cent_compl MtypePx). + by rewrite conjIg -centJ defW1x (normsP nM'M). +by exists x; rewrite -defW dprodJ defW1x defW2x conjsgM -defUx1 conjsgKV. +Qed. + +Lemma FTtypeP_neq1 : FTtype M != 1%N. +Proof. by apply/FTtypeP=> // [[V [/(typePF_exclusion MtypeP)]]]. Qed. + +Remark compl_of_typeII_IV : FTtype M != 5 -> of_typeII_IV M U defW. +Proof. +move=> Mtype'5. +have [Ux Wx W1x W2x defWx Mtype24]: exists_typeP (of_typeII_IV M). + have:= FTtype_range M; rewrite leq_eqVlt eq_sym (leq_eqVlt _ 5). + rewrite (negPf FTtypeP_neq1) (negPf Mtype'5) /= -mem_iota !inE. + by case/or3P=> /FTtypeP[]// Ux Wx W1x W2x dWx []; exists Ux Wx W1x W2x dWx. +have [MtypePx ntUx prW1x tiFM] := Mtype24. +have [x [Mx defUx defW1x _ _]] := of_typeP_conj MtypePx. +by rewrite -defUx -defW1x cardJg conjsg_eq1 in ntUx prW1x. +Qed. + +Remark compl_of_typeII : FTtype M == 2 -> of_typeII M U defW. +Proof. +move=> Mtype2. +have [Ux Wx W1x W2x defWx [[MtypePx _ _ _]]] := FTtypeP 2 maxM Mtype2. +have [x [Mx <- _ _ _]] := of_typeP_conj MtypePx; rewrite -/M' -/H. +rewrite abelianJ normJ -{1}(conjGid Mx) conjSg => cUU not_sNUM M'typeF defH. +split=> //; first by apply: compl_of_typeII_IV; rewrite // (eqP Mtype2). +by apply: compl_of_typeF M'typeF; rewrite defH; have [_ []] := MtypeP. +Qed. + +Remark compl_of_typeIII : FTtype M == 3 -> of_typeIII M U defW. +Proof. +move=> Mtype3. +have [Ux Wx W1x W2x defWx [[MtypePx _ _ _]]] := FTtypeP 3 maxM Mtype3. +have [x [Mx <- _ _ _]] := of_typeP_conj MtypePx; rewrite -/M' -/H. +rewrite abelianJ normJ -{1}(conjGid Mx) conjSg. +by split=> //; apply: compl_of_typeII_IV; rewrite // (eqP Mtype3). +Qed. + +Remark compl_of_typeIV : FTtype M == 4 -> of_typeIV M U defW. +Proof. +move=> Mtype4. +have [Ux Wx W1x W2x defWx [[MtypePx _ _ _]]] := FTtypeP 4 maxM Mtype4. +have [x [Mx <- _ _ _]] := of_typeP_conj MtypePx; rewrite -/M' -/H. +rewrite abelianJ normJ -{1}(conjGid Mx) conjSg. +by split=> //; apply: compl_of_typeII_IV; rewrite // (eqP Mtype4). +Qed. + +Remark compl_of_typeV : FTtype M == 5 -> of_typeV M U defW. +Proof. +move=> Mtype5. +have [Ux Wx W1x W2x defWx [[MtypePx /eqP]]] := FTtypeP 5 maxM Mtype5. +have [x [Mx <- <- _ _]] := of_typeP_conj MtypePx; rewrite -/M' -/H. +by rewrite cardJg conjsg_eq1 => /eqP. +Qed. + +End FTypeP_Remarks. + +(* This is the statement of Peterfalvi, Theorem (8.8)(a). *) +Definition all_FTtype1 := [forall M : {group gT} in 'M, FTtype M == 1%N]. + +(* This is the statement of Peterfalvi, Theorem (8.8)(b). *) +Definition typeP_pair S T (W W1 W2 : {set gT}) (defW : W1 \x W2 = W) := + [/\ [/\ cyclicTI_hypothesis G defW, S \in 'M & T \in 'M], + (*b1*) [/\ S^`(1) ><| W1 = S, T^`(1) ><| W2 = T & S :&: T = W]%g, + (*b2*) (FTtype S == 2) || (FTtype T == 2), + (*b3*) (1 < FTtype S <= 5 /\ 1 < FTtype T <= 5)%N + & (*b4*) {in 'M, forall M, FTtype M != 1%N -> gval M \in S :^: G :|: T :^: G}]. + +Lemma typeP_pair_sym S T W W1 W2 (defW : W1 \x W2 = W) (xdefW : W2 \x W1 = W) : + typeP_pair S T defW -> typeP_pair T S xdefW. +Proof. +by case=> [[/cyclicTIhyp_sym ? ? ?] [? ?]]; rewrite setIC setUC orbC => ? ? []. +Qed. + +(* This is Peterfalvi, Theorem (8.8). *) +Lemma FTtypeP_pair_cases : + (*a*) {in 'M, forall M, FTtype M == 1%N} + \/ (*b*) exists S, exists T, exists_typeP (fun _ => typeP_pair S T). +Proof. +have [_ [| [[S T] [[maxS maxT] [[W1 W2] /=]]]]] := BGsummaryI gT; first by left. +set W := W1 <*> W2; set V := W :\: (W1 :|: W2). +case=> [[cycW tiV _] [defS defT tiST]] b4 /orP b2 b3. +have [cWW /joing_sub[sW1W sW2W]] := (cyclic_abelian cycW, erefl W). +have ntV: V != set0 by have [] := andP tiV. +suffices{tiST tiV cWW sW1W sW2W b3 b4} tiW12: W1 :&: W2 = 1%g. + have defW: W1 \x W2 = W by rewrite dprodEY ?(centSS _ _ cWW). + right; exists S, T; exists S _ _ _ defW; split=> // [|M _ /b4[] // x]. + by do 2?split; rewrite ?mFT_odd // /normedTI tiV nVW setTI /=. + by case=> <-; rewrite inE mem_orbit ?orbT. +wlog {b2 T defT maxT} Stype2: S W1 W2 @W @V maxS defS cycW ntV / FTtype S == 2. + move=> IH; case/orP: b2 cycW ntV => /IH; first exact. + by rewrite setIC /V /W /= joingC setUC; apply. +have{maxS Stype2 defS} prW1: prime #|W1|. + have [U ? W1x ? ? [[StypeP _ prW1x _] _ _ _ _]] := FTtypeP 2 maxS Stype2. + by have /imsetP[x _ ->] := of_typeP_compl_conj StypeP defS; rewrite cardJg. +rewrite prime_TIg //; apply: contra ntV => sW12. +by rewrite setD_eq0 (setUidPr sW12) join_subG sW12 /=. +Qed. + +(* This is Peterfalvi (8.9). *) +(* We state the lemma using the of_typeP predicate, as it is the Skolemised *) +(* form of Peterfalvi, Definition (8.4). *) +Lemma typeP_pairW S T W W1 W2 (defW : W1 \x W2 = W) : + typeP_pair S T defW -> exists U : {group gT}, of_typeP S U defW. +Proof. +case=> [[[cycW _ /and3P[_ _ /eqP nVW]] maxS _] [defS _ defST] _ [Stype25 _] _]. +set S' := S^`(1)%g in defS; have [nsS'S _ _ _ tiS'W1] := sdprod_context defS. +have{Stype25} Stype'1: FTtype S != 1%N by apply: contraTneq Stype25 => ->. +have [/mulG_sub[sW1W sW2W] [_ mulW12 cW12 _]] := (dprodW defW, dprodP defW). +have [cycW1 cycW2] := (cyclicS sW1W cycW, cyclicS sW2W cycW). +have{cycW1 cycW2} coW12: coprime #|W1| #|W2| by rewrite -(cyclic_dprod defW). +have{maxS Stype'1} [Ux Wx W1x W2x defWx StypeP] := FTtypeP_witness maxS Stype'1. +have /imsetP[y Sy defW1] := of_typeP_compl_conj StypeP defS. +suffices defW2: W2 :=: W2x :^ y. + have [] := conj_of_typeP StypeP y; rewrite -defWx dprodJ -defW1 -defW2. + by rewrite (conjGid Sy) {-1}defW; exists (Ux :^ y)%G. +have [[_ hallW1x _ defSx] _ _ [/cyclic_abelian abW2x _ _ _ _] _] := StypeP. +have{Sy} nS'y: y \in 'N(S') by rewrite (subsetP (normal_norm nsS'S)). +have{nS'y} defW2xy: W2x :^ y = 'C_S'(W1). + by rewrite -(typeP_cent_compl StypeP) conjIg -centJ -defW1 (normP nS'y). +have{nsS'S} sW2S': W2 \subset S'. + have sW2S: W2 \subset S by rewrite (subset_trans sW2W) // -defST subsetIl. + have{hallW1x} hallW1: \pi(W1).-Hall(S) W1x by rewrite defW1 /= cardJg Hall_pi. + have hallS': \pi(W1)^'.-Hall(S) S' by apply/(sdprod_normal_pHallP _ hallW1). + by rewrite coprime_pi' // (sub_normal_Hall hallS') in coW12 *. +have sW2xy: W2 \subset W2x :^ y by rewrite defW2xy subsetI sW2S'. +have defW2: W2 :=: S' :&: W by rewrite -mulW12 -group_modr ?tiS'W1 ?mul1g. +apply/eqP; rewrite eqEsubset sW2xy defW2 subsetI {1}defW2xy subsetIl /=. +rewrite -nVW /= setTI cents_norm // (centsS (subsetDl _ _)) // -mulW12. +by rewrite centM subsetI {1}defW2xy subsetIr sub_abelian_cent // abelianJ. +Qed. + +Section OneMaximal. + +Variable M U W W1 W2 : {group gT}. (* W, W1 and W2 are only used later. *) +Hypothesis maxM : M \in 'M. + +(* Peterfalvi, Definition (8.10) is covered in BGsection16. *) + +(* This is Peterfalvi (8.11). *) +Lemma FTcore_facts : + [/\ Hall G M`_\F, Hall G M`_\s + & forall S, Sylow M`_\s S -> S :!=: 1%g -> 'N(S) \subset M]. +Proof. +have hallMs := Msigma_Hall_G maxM; have [_ sMs _] := and3P hallMs. +rewrite def_FTcore // (pHall_Hall hallMs). +split=> // [|S /SylowP[p _ sylS] ntS]. + have sMF_Ms:= Fcore_sub_Msigma maxM. + apply: (@pHall_Hall _ \pi(M`_\F)); apply: (subHall_Hall hallMs). + by move=> p /(piSg sMF_Ms)/(pnatPpi sMs). + exact: pHall_subl (pcore_sub _ M) (Fcore_Hall M). +have s_p: p \in \sigma(M). + by rewrite (pnatPpi sMs) // -p_rank_gt0 -(rank_Sylow sylS) rank_gt0. +by apply: (norm_sigma_Sylow s_p); exact: (subHall_Sylow (Msigma_Hall maxM)). +Qed. + +(* This is Peterfalvi (8.12). *) +(* (b) could be stated for subgroups of U wlog -- usage should be checked. *) +Lemma FTtypeI_II_facts n (H := M`_\F) : + FTtype M == n -> H ><| U = M ^`(n.-1)%g -> + if 0 < n <= 2 then + [/\ (*a*) forall p S, p.-Sylow(U) S -> abelian S /\ ('r(S) <= 2)%N, + (*b*) forall X, X != set0 -> X \subset U^# -> 'C_H(X) != 1%g -> + 'M('C(X)) = [set M] + & (*c*) let B := 'A(M) :\: 'A1(M) in B != set0 -> normedTI B G M + ] else True. +Proof. +move=> typeM defMn; have [n12 | //] := ifP; rewrite -mem_iota !inE in n12. +have defH: H = M`_\sigma. + by rewrite -def_FTcore -?(Fcore_eq_FTcore _ _) // (eqP typeM) !inE orbA n12. +have [K complU]: exists K : {group gT}, kappa_complement M U K. + have [[V K] /= complV] := kappa_witness maxM. + have [[hallV hallK gVK] [_ sUMn _ _ _]] := (complV, sdprod_context defMn). + have hallU: \sigma_kappa(M)^'.-Hall(M) U. + rewrite pHallE -(card_Hall hallV) (subset_trans sUMn) ?der_sub //=. + rewrite -(@eqn_pmul2l #|H|) ?cardG_gt0 // (sdprod_card defMn) defH. + rewrite (sdprod_card (sdprod_FTder maxM complV)) (eqP typeM). + by case/pred2P: n12 => ->. + have [x Mx defU] := Hall_trans (mmax_sol maxM) hallU hallV. + exists (K :^ x)%G; split; rewrite ?pHallJ // defU -conjsMg. + by rewrite -(gen_set_id gVK) groupP. +have [part_a _ _ [part_b part_c]] := BGsummaryB maxM complU. +rewrite eqEsubset FTsupp1_sub // andbT -setD_eq0 in part_c. +split=> // X notX0 /subsetD1P[sXU notX1]; rewrite -cent_gen defH. +apply: part_b; rewrite -?subG1 ?gen_subG //. +by rewrite -setD_eq0 setDE (setIidPl _) // subsetC sub1set inE. +Qed. + +(* This is Peterfalvi (8.13). *) +(* We have substituted the B & G notation for the unique maximal supergroup *) +(* of 'C[x], and specialized the lemma to X := 'A0(M). *) +Lemma FTsupport_facts (X := 'A0(M)) (D := [set x in X | ~~('C[x] \subset M)]) : + [/\ (*a*) {in X &, forall x, {subset x ^: G <= x ^: M}}, + (*b*) D \subset 'A1(M) /\ {in D, forall x, 'M('C[x]) = [set 'N[x]]} + & (*c*) {in D, forall x (L := 'N[x]) (H := L`_\F), + [/\ (*c1*) H ><| (M :&: L) = L /\ 'C_H[x] ><| 'C_M[x] = 'C[x], + (*c2*) {in X, forall y, coprime #|H| #|'C_M[y]| }, + (*c3*) x \in 'A(L) :\: 'A1(L) + & (*c4*) 1 <= FTtype L <= 2 + /\ (FTtype L == 2 -> [Frobenius M with kernel M`_\F])]}]. +Proof. +have defX: X \in pred2 'A(M) 'A0(M) by rewrite !inE eqxx orbT. +have [sDA1 part_a part_c] := BGsummaryII maxM defX. +have{part_a} part_a: {in X &, forall x, {subset x ^: G <= x ^: M}}. + move=> x y A0x A0y /= /imsetP[g Gg def_y]; rewrite def_y. + by apply/imsetP/part_a; rewrite -?def_y. +do [split=> //; first split=> //] => x /part_c[_ ] //. +rewrite /= -(mem_iota 1) !inE => -> [-> ? -> -> L2_frob]. +by do 2![split=> //] => /L2_frob[E /FrobeniusWker]. +Qed. + +(* A generic proof of the first assertion of Peterfalvi (8.15). *) +Let norm_FTsuppX A : + M \subset 'N(A) -> 'A1(M) \subset A -> A \subset 'A0(M) -> 'N(A) = M. +Proof. +move=> nAM sA1A sAA0; apply: mmax_max => //. +rewrite (sub_proper_trans (norm_gen _)) ?mFT_norm_proper //; last first. + rewrite (sub_proper_trans _ (mmax_proper maxM)) // gen_subG. + by rewrite (subset_trans sAA0) // (subset_trans (FTsupp0_sub M)) ?subsetDl. +rewrite (subG1_contra (genS sA1A)) //= genD1 ?group1 //. +by rewrite genGid /= def_FTcore ?Msigma_neq1. +Qed. + +Lemma norm_FTsupp1 : 'N('A1(M)) = M. +Proof. exact: norm_FTsuppX (FTsupp1_norm M) _ (FTsupp1_sub0 maxM). Qed. + +Lemma norm_FTsupp : 'N('A(M)) = M. +Proof. exact: norm_FTsuppX (FTsupp_norm M) (FTsupp1_sub _) (FTsupp_sub0 M). Qed. + +Lemma norm_FTsupp0 : 'N('A0(M)) = M. +Proof. exact: norm_FTsuppX (FTsupp0_norm M) (FTsupp1_sub0 _) _. Qed. + +Lemma FTsignalizerJ x y : 'R_(M :^ x) (y ^ x) :=: 'R_M y :^ x. +Proof. +rewrite /'R__ /= {1}cent1J conjSg; case: ifP => _ /=; first by rewrite conjs1g. +by rewrite cent1J FT_signalizer_baseJ FcoreJ -conjIg. +Qed. + +Let is_FTsignalizer : is_Dade_signalizer G M 'A0(M) 'R_M. +Proof. +rewrite /'R_M => x A0x /=; rewrite setTI. +case: ifPn => [sCxM | not_sCxM]; first by rewrite sdprod1g (setIidPr sCxM). +by have [_ _ /(_ x)[| [] //]] := FTsupport_facts; exact/setIdP. +Qed. + +(* This is Peterfalvi (8.15), second assertion. *) +Lemma FT_Dade0_hyp : Dade_hypothesis G M 'A0(M). +Proof. +have [part_a _ parts_bc] := FTsupport_facts. +have /subsetD1P[sA0M notA0_1] := FTsupp0_sub M. +split; rewrite // /normal ?sA0M ?norm_FTsupp0 //=. +exists 'R_M => [|x y A0x A0y]; first exact: is_FTsignalizer. +rewrite /'R_M; case: ifPn => [_ | not_sCxM]; first by rewrite cards1 coprime1n. +rewrite (coprimeSg (subsetIl _ _)) //=. +by have [| _ -> //] := parts_bc x; apply/setIdP. +Qed. + +Definition FT_Dade_hyp := + restr_Dade_hyp FT_Dade0_hyp (FTsupp_sub0 M) (FTsupp_norm M). + +Definition FT_Dade1_hyp := + restr_Dade_hyp FT_Dade0_hyp (FTsupp1_sub0 maxM) (FTsupp1_norm M). + +Definition FT_DadeF_hyp := + restr_Dade_hyp FT_Dade0_hyp (Fcore_sub_FTsupp0 maxM) (normsD1 (gFnorm _ _)). + +Lemma def_FTsignalizer0 : {in 'A0(M), Dade_signalizer FT_Dade0_hyp =1 'R_M}. +Proof. exact: def_Dade_signalizer. Qed. + +Lemma def_FTsignalizer : {in 'A(M), Dade_signalizer FT_Dade_hyp =1 'R_M}. +Proof. exact: restr_Dade_signalizer def_FTsignalizer0. Qed. + +Lemma def_FTsignalizer1 : {in 'A1(M), Dade_signalizer FT_Dade1_hyp =1 'R_M}. +Proof. exact: restr_Dade_signalizer def_FTsignalizer0. Qed. + +Lemma def_FTsignalizerF : {in M`_\F^#, Dade_signalizer FT_DadeF_hyp =1 'R_M}. +Proof. exact: restr_Dade_signalizer def_FTsignalizer0. Qed. + +Local Notation tau := (Dade FT_Dade0_hyp). +Local Notation FT_Dade := (Dade FT_Dade_hyp). +Local Notation FT_Dade1 := (Dade FT_Dade1_hyp). +Local Notation FT_DadeF := (Dade FT_DadeF_hyp). + +Lemma FT_DadeE : {in 'CF(M, 'A(M)), FT_Dade =1 tau}. +Proof. exact: restr_DadeE. Qed. + +Lemma FT_Dade1E : {in 'CF(M, 'A1(M)), FT_Dade1 =1 tau}. +Proof. exact: restr_DadeE. Qed. + +Lemma FT_DadeF_E : {in 'CF(M, M`_\F^#), FT_DadeF =1 tau}. +Proof. exact: restr_DadeE. Qed. + +Lemma FT_Dade_supportS A B : A \subset B -> 'A~(M, A) \subset 'A~(M, B). +Proof. +by move/subsetP=> sAB; apply/bigcupsP=> x Ax; rewrite (bigcup_max x) ?sAB. +Qed. + +Lemma FT_Dade0_supportE : Dade_support FT_Dade0_hyp = 'A0~(M). +Proof. by apply/eq_bigr=> x /def_FTsignalizer0 <-. Qed. + +Let defA A (sAA0 : A \subset 'A0(M)) (nAM : M \subset 'N(A)) : + Dade_support (restr_Dade_hyp FT_Dade0_hyp sAA0 nAM) = 'A~(M, A). +Proof. +by apply/eq_bigr=> x /(restr_Dade_signalizer sAA0 nAM def_FTsignalizer0) <-. +Qed. + +Lemma FT_Dade_supportE : Dade_support FT_Dade_hyp = 'A~(M). +Proof. exact: defA. Qed. + +Lemma FT_Dade1_supportE : Dade_support FT_Dade1_hyp = 'A1~(M). +Proof. exact: defA. Qed. + +Lemma FT_DadeF_supportE : Dade_support FT_DadeF_hyp = 'A~(M, M`_\F^#). +Proof. exact: defA. Qed. + +Lemma FT_Dade0_supportJ x : 'A0~(M :^ x) = 'A0~(M). +Proof. +rewrite /'A0~(_) FTsupp0J big_imset /=; last exact: in2W (conjg_inj x). +apply: eq_bigr => y _; rewrite FTsignalizerJ -conjg_set1 -conjsMg. +by rewrite class_supportGidl ?inE. +Qed. + +Lemma FT_Dade1_supportJ x : 'A1~(M :^ x) = 'A1~(M). +Proof. +rewrite /'A1~(_) FTsupp1J big_imset /=; last exact: in2W (conjg_inj x). +apply: eq_bigr => y _; rewrite FTsignalizerJ -conjg_set1 -conjsMg. +by rewrite class_supportGidl ?inE. +Qed. + +Lemma FT_Dade_supportJ x : 'A~(M :^ x) = 'A~(M). +Proof. +rewrite /'A~(_) FTsuppJ big_imset /=; last exact: in2W (conjg_inj x). +apply: eq_bigr => y _; rewrite FTsignalizerJ -conjg_set1 -conjsMg. +by rewrite class_supportGidl ?inE. +Qed. + +(* Subcoherence and cyclicTI properties of type II-V subgroups. *) +Hypotheses (defW : W1 \x W2 = W) (MtypeP : of_typeP M U defW). +Let H := M`_\F%G. +Let K := M^`(1)%G. + +Lemma FT_cyclicTI_hyp : cyclicTI_hypothesis G defW. +Proof. by case/typeP_context: MtypeP. Qed. +Let ctiW := FT_cyclicTI_hyp. + +(* This is a useful combination of Peterfalvi (8.8) and (8.9). *) +Lemma FTtypeP_pair_witness : + exists2 T, typeP_pair M T defW + & exists xdefW : W2 \x W1 = W, exists V : {group gT}, of_typeP T V xdefW. +Proof. +have Mtype'1 := FTtypeP_neq1 maxM MtypeP. +case: FTtypeP_pair_cases => [/(_ M maxM)/idPn[] // | [S [T]]]. +case=> _ Wx W1x W2x defWx pairST. +without loss /imsetP[y2 _ defSy]: S T W1x W2x defWx pairST / gval M \in S :^: G. + have [_ _ _ _ coverST] := pairST => IH. + have /setUP[] := coverST M maxM Mtype'1; first exact: IH pairST. + by apply: IH (typeP_pair_sym _ pairST); rewrite dprodC. +have [U_S StypeP] := typeP_pairW pairST. +have [[_ maxS maxT] [defS defT defST] b2 b3 b4] := pairST. +have [[[_ _ _ defM] _ _ _ _] defW2] := (MtypeP, typeP_cent_compl MtypeP). +have /imsetP[y1 Sy1 /(canRL (conjsgKV _)) defW1]: W1 :^ y2^-1 \in W1x :^: S. + apply: (of_typeP_compl_conj StypeP). + by rewrite -(conjsgK y2 S) -defSy derJ -sdprodJ defM. +pose y := (y1 * y2)%g; rewrite -conjsgM -/y in defW1. +have{defSy} defSy: S :^ y = M by rewrite conjsgM (conjGid Sy1). +have{defW2} defW2: W2 :=: W2x :^ y. + by rewrite -(typeP_cent_compl StypeP) conjIg -derJ -centJ defSy -defW1. +suffices pairMTy: typeP_pair M (T :^ y) defW. + exists (T :^ y)%G => //; have xdefW: W2 \x W1 = W by rewrite dprodC. + by exists xdefW; apply: typeP_pairW (typeP_pair_sym xdefW pairMTy). +do [split; rewrite ?defM -?defSy ?mmaxJ ?FTtypeJ //] => [|L maxL /(b4 L maxL)]. + by rewrite -defW defW1 defW2 derJ -sdprodJ -dprodJ -conjIg defT defST defWx. +by rewrite !conjugates_conj lcoset_id // inE. +Qed. + +(* A converse to the above. *) +Lemma of_typeP_pair (xdefW : W2 \x W1 = W) T V : + T \in 'M -> of_typeP T V xdefW -> typeP_pair M T defW. +Proof. +have [S pairMS [xdefW' [V1 StypeP]]] := FTtypeP_pair_witness => maxT TtypeP. +have [[cycW2 /andP[sW2T _] ntW2 _] _ _ [cycW1 _ _ sW1T'' _] _] := TtypeP. +have{sW1T'' sW2T} sWT: W \subset T. + by rewrite -(dprodW defW) mul_subG ?(subset_trans sW1T'') ?gFsub. +have [cycW _ /and3P[_ _ /eqP defNW]] := ctiW. +rewrite (@group_inj _ T S) //; have{pairMS} [_ _ _ _ defT] := pairMS. +have /defT/setUP[] := FTtypeP_neq1 maxT TtypeP => {defT}// /imsetP[x _ defT]. + have [defWx] := conj_of_typeP MtypeP x; rewrite -defT. + case/(of_typeP_conj TtypeP)=> y [_ _ _ defW1y _]. + have /idP[]:= negbF cycW; rewrite (cyclic_dprod defW) // /coprime. + by rewrite -(cardJg _ y) defW1y cardJg gcdnn -trivg_card1. +have [defWx] := conj_of_typeP StypeP x; rewrite -defT. +case/(of_typeP_conj TtypeP)=> y [Ty _ defW2y defW1y defWy]. +have Wyx: (y * x^-1)%g \in W. + by rewrite -defNW !inE /= conjDg conjUg !conjsgM defW2y defW1y defWy !conjsgK. +by rewrite -(conjGid (subsetP sWT _ Wyx)) conjsgM (conjGid Ty) defT conjsgK. +Qed. + +Lemma FT_primeTI_hyp : primeTI_hypothesis M K defW. +Proof. +have [[cycW1 ntW1 hallW1 defM] _ _ [cycW2 ntW2 _ sW2M'' prM'W1] _] := MtypeP. +by split; rewrite ?mFT_odd // (subset_trans sW2M'') ?der_subS. +Qed. +Let ptiWM := FT_primeTI_hyp. + +Lemma FTtypeP_supp0_def : + 'A0(M) = 'A(M) :|: class_support (cyclicTIset defW) M. +Proof. +rewrite -(setID 'A0(M) 'A(M)) (FTsupp0_typeP maxM MtypeP) (setIidPr _) //. +exact: FTsupp_sub0. +Qed. + +Fact FT_Fcore_prime_Dade_def : prime_Dade_definition M K H 'A(M) 'A0(M) defW. +Proof. +have [_ [_ _ _ /sdprodW/mulG_sub[sHK _]] _ [_ _ sW2H _ _] _] := MtypeP. +split; rewrite ?gFnormal //; last exact: FTtypeP_supp0_def. +rewrite /normal FTsupp_norm andbT /'A(M) (FTtypeP_neq1 maxM MtypeP) /=. +do ?split=> //; apply/bigcupsP=> x A1x; last by rewrite setSD ?subsetIl. + by rewrite setDE -setIA subIset // gFsub. +by rewrite (bigcup_max x) // (subsetP _ x A1x) // setSD ?Fcore_sub_FTcore. +Qed. + +Definition FT_prDade_hypF : prime_Dade_hypothesis _ M K H 'A(M) 'A0(M) defW := + PrimeDadeHypothesis ctiW ptiWM FT_Dade0_hyp FT_Fcore_prime_Dade_def. + +Fact FT_core_prime_Dade_def : prime_Dade_definition M K M`_\s 'A(M) 'A0(M) defW. +Proof. +have [[_ sW2H sHK] [nsAM sCA sAK] defA0] := FT_Fcore_prime_Dade_def. +have [_ [_ sW2K _ _] _] := ptiWM. +split=> //=; first by rewrite FTcore_normal /M`_\s; case: ifP. +rewrite nsAM /= /'A(M) /M`_\s (FTtypeP_neq1 maxM MtypeP); split=> //=. +by apply/bigcupsP=> x _; rewrite setSD ?subsetIl. +Qed. + +Definition FT_prDade_hyp : prime_Dade_hypothesis _ M K M`_\s 'A(M) 'A0(M) defW + := PrimeDadeHypothesis ctiW ptiWM FT_Dade0_hyp FT_core_prime_Dade_def. + +Let calS := seqIndD K M M`_\s 1. + +Fact FTtypeP_cohererence_base_subproof : cfConjC_subset calS calS. +Proof. exact: seqInd_conjC_subset1. Qed. + +Fact FTtypeP_cohererence_nonreal_subproof : ~~ has cfReal calS. +Proof. by rewrite seqInd_notReal ?mFT_odd ?FTcore_sub_der1 ?der_normal. Qed. + +Definition FTtypeP_coh_base_sig := + prDade_subcoherent FT_prDade_hyp + FTtypeP_cohererence_base_subproof FTtypeP_cohererence_nonreal_subproof. + +Definition FTtypeP_coh_base := sval FTtypeP_coh_base_sig. + +Local Notation R := FTtypeP_coh_base. + +Lemma FTtypeP_subcoherent : subcoherent calS tau R. +Proof. by rewrite /R; case: FTtypeP_coh_base_sig => R1 []. Qed. +Let scohS := FTtypeP_subcoherent. + +Let w_ i j := cyclicTIirr defW i j. +Let sigma := cyclicTIiso ctiW. +Let eta_ i j := sigma (w_ i j). +Let mu_ := primeTIred ptiWM. +Let delta_ := fun j => primeTIsign ptiWM j. + +Lemma FTtypeP_base_ortho : + {in [predI calS & irr M] & irr W, forall phi w, orthogonal (R phi) (sigma w)}. +Proof. by rewrite /R; case: FTtypeP_coh_base_sig => R1 []. Qed. + +Lemma FTtypeP_base_TIred : + let dsw j k := [seq delta_ j *: eta_ i k | i : Iirr W1] in + let Rmu j := dsw j j ++ map -%R (dsw j (conjC_Iirr j)) in + forall j, R (mu_ j) = Rmu j. +Proof. by rewrite /R; case: FTtypeP_coh_base_sig => R1 []. Qed. + +Lemma coherent_ortho_cycTIiso calS1 (tau1 : {additive 'CF(M) -> 'CF(G)}) : + cfConjC_subset calS1 calS -> coherent_with calS1 M^# tau tau1 -> + forall chi i j, chi \in calS1 -> chi \in irr M -> '[tau1 chi, eta_ i j] = 0. +Proof. +move=> ccsS1S cohS1 chi i j S1chi chi_irr; have [_ sS1S _] := ccsS1S. +have [e /mem_subseq Re ->] := mem_coherent_sum_subseq scohS ccsS1S cohS1 S1chi. +rewrite cfdot_suml big1_seq // => xi /Re; apply: orthoPr. +by apply: FTtypeP_base_ortho (mem_irr _); rewrite !inE sS1S. +Qed. + +Import ssrnum Num.Theory. + +(* A reformuation of Peterfalvi (5.8) for the Odd Order proof context. *) +Lemma FTtypeP_coherent_TIred calS1 tau1 zeta j : + cfConjC_subset calS1 calS -> coherent_with calS1 M^# tau tau1 -> + zeta \in irr M -> zeta \in calS1 -> mu_ j \in calS1 -> + let d := primeTI_Isign ptiWM j in let k := conjC_Iirr j in + {dk : bool * Iirr W2 | tau1 (mu_ j) = (-1) ^+ dk.1 *: (\sum_i eta_ i dk.2) + & dk.1 = d /\ dk.2 = j + \/ [/\ dk.1 = ~~ d, dk.2 = k + & forall l, mu_ l \in calS1 -> mu_ l 1%g = mu_ j 1%g -> pred2 j k l]}. +Proof. +move=> ccsS1S cohS1 irr_zeta S1zeta S1mu_j d k. +have irrS1: [/\ ~~ has cfReal calS1, has (mem (irr M)) calS1 & mu_ j \in calS1]. + have [[_ -> _] _ _ _ _] := subset_subcoherent scohS ccsS1S. + by split=> //; apply/hasP; exists zeta. +have Dmu := coherent_prDade_TIred FT_prDade_hyp ccsS1S irrS1 cohS1. +rewrite -/mu_ -/d in Dmu; pose mu_sum d1 k1 := (-1) ^+ d1 *: (\sum_i eta_ i k1). +have mu_sumK (d1 d2 : bool) k1 k2: + ('[mu_sum d1 k1, (-1) ^+ d2 *: eta_ 0 k2] > 0) = (d1 == d2) && (k1 == k2). +- rewrite cfdotZl cfdotZr rmorph_sign mulrA -signr_addb cfdot_suml. + rewrite (bigD1 0) //= cfdot_cycTIiso !eqxx big1 => [|i nz_i]; last first. + by rewrite cfdot_cycTIiso (negPf nz_i). + rewrite addr0 /= andbC; case: (k1 == k2); rewrite ?mulr0 ?ltrr //=. + by rewrite mulr1 signr_gt0 negb_add. +have [dk tau1mu_j]: {dk : bool * Iirr W2 | tau1 (mu_ j) = mu_sum dk.1 dk.2}. + apply: sig_eqW; case: Dmu => [-> | [-> _]]; first by exists (d, j). + by exists (~~ d, k); rewrite -signrN. +exists dk => //; have:= mu_sumK dk.1 dk.1 dk.2 dk.2; rewrite !eqxx -tau1mu_j. +case: Dmu => [-> | [-> all_jk]]; + rewrite -?signrN mu_sumK => /andP[/eqP <- /eqP <-]; [by left | right]. +by split=> // j1 S1j1 /(all_jk j1 S1j1)/pred2P. +Qed. + +Lemma size_red_subseq_seqInd_typeP (calX : {set Iirr K}) calS1 : + uniq calS1 -> {subset calS1 <= seqInd M calX} -> + {subset calS1 <= [predC irr M]} -> + size calS1 = #|[set i : Iirr K | 'Ind 'chi_i \in calS1]|. +Proof. +move=> uS1 sS1S redS1; pose h s := 'Ind[M, K] 'chi_s. +apply/eqP; rewrite cardE -(size_map h) -uniq_size_uniq // => [|xi]; last first. + apply/imageP/idP=> [[i] | S1xi]; first by rewrite inE => ? ->. + by have /seqIndP[s _ Dxi] := sS1S _ S1xi; exists s; rewrite ?inE -?Dxi. +apply/dinjectiveP; pose h1 xi := cfIirr (#|W1|%:R^-1 *: 'Res[K, M] xi). +apply: can_in_inj (h1) _ => s; rewrite inE => /redS1 red_s. +have cycW1: cyclic W1 by have [[]] := MtypeP. +have [[j /irr_inj->] | [/idPn[]//]] := prTIres_irr_cases ptiWM s. +by rewrite /h cfInd_prTIres /h1 cfRes_prTIred scalerK ?neq0CG ?irrK. +Qed. + +End OneMaximal. + +(* This is Peterfalvi (8.16). *) +Lemma FTtypeII_ker_TI M : + M \in 'M -> FTtype M == 2 -> + [/\ normedTI 'A0(M) G M, normedTI 'A(M) G M & normedTI 'A1(M) G M]. +Proof. +move=> maxM typeM; have [sA1A sAA0] := (FTsupp1_sub maxM, FTsupp_sub0 M). +have [sA10 sA0M] := (subset_trans sA1A sAA0, FTsupp0_sub M). +have nzA1: 'A1(M) != set0 by rewrite setD_eq0 def_FTcore ?subG1 ?Msigma_neq1. +have [nzA nzA0] := (subset_neq0 sA1A nzA1, subset_neq0 sA10 nzA1). +suffices nTI_A0: normedTI 'A0(M) G M. + by rewrite nTI_A0 !(normedTI_S _ _ _ nTI_A0) // ?FTsupp_norm ?FTsupp1_norm. +have [U W W1 W2 defW [[MtypeP _ _ tiFM] _ _ _ _]] := FTtypeP 2 maxM typeM. +apply/(Dade_normedTI_P (FT_Dade0_hyp maxM)); split=> // x A0x. +rewrite /= def_FTsignalizer0 /'R_M //=; have [// | not_sCxM] := ifPn. +have [y cxy /negP[]] := subsetPn not_sCxM. +apply: subsetP cxy; rewrite -['C[x]]setTI (cent1_normedTI tiFM) //. +have /setD1P[ntx Ms_x]: x \in 'A1(M). + by have [_ [/subsetP-> // ]] := FTsupport_facts maxM; apply/setIdP. +rewrite !inE ntx (subsetP (Fcore_sub_Fitting M)) //. +by rewrite (Fcore_eq_FTcore _ _) ?(eqP typeM). +Qed. + +(* This is Peterfalvi, Theorem (8.17). *) +Theorem FT_Dade_support_partition : + [/\ (*a1*) + \pi(G) =i [pred p | [exists M : {group gT} in 'M, p \in \pi(M`_\s)]], + (*a2*) {in 'M &, forall M L, + gval L \notin M :^: G -> coprime #|M`_\s| #|L`_\s| }, + (*b*) {in 'M, forall M, #|'A1~(M)| = (#|M`_\s|.-1 * #|G : M|)%N} + & (*c*) let PG := [set 'A1~(Mi) | Mi : {group gT} in 'M^G] in + [/\ {in 'M^G &, injective (fun M => 'A1~(M))}, + all_FTtype1 -> partition PG G^# + & forall S T W W1 W2 (defW : W1 \x W2 = W), + let VG := class_support (cyclicTIset defW) G in + typeP_pair S T defW -> partition (VG |: PG) G^# /\ VG \notin PG]]. +Proof. +have defDsup M: M \in 'M -> class_support M^~~ G = 'A1~(M). + move=> maxM; rewrite class_supportEr /'A1~(M) /'A1(M) def_FTcore //. + rewrite -(eq_bigr _ (fun _ _ => bigcupJ _ _ _ _)) exchange_big /=. + apply: eq_bigr => x Ms_x; rewrite -class_supportEr. + rewrite -norm_rlcoset ?(subsetP (cent_sub _)) ?cent_FT_signalizer //=. + congr (class_support (_ :* x) G); rewrite /'R_M. + have [_ _ /(_ x Ms_x)[_ defCx _] /(_ x Ms_x)defNF]:= BGsummaryD maxM. + have [sCxM | /defNF[[_ <-]] //] := ifPn. + apply/eqP; rewrite trivg_card1 -(eqn_pmul2r (cardG_gt0 'C_M[x])). + by rewrite (sdprod_card defCx) mul1n /= (setIidPr _). +have [b [a1 a2] [/and3P[_ _ not_PG_set0] _ _]] := BGsummaryE gT. +split=> [p | M L maxM maxL /a2 | M maxM | {b a1 a2}PG]. +- apply/idP/exists_inP=> [/a1[M maxM sMp] | [M _]]. + by exists M => //; rewrite def_FTcore // pi_Msigma. + exact: piSg (subsetT _) p. +- move/(_ maxM maxL)=> coML; rewrite coprime_pi' // !def_FTcore //. + apply: sub_pgroup (pcore_pgroup _ L) => p; apply/implyP. + by rewrite implybN /= pi_Msigma // implybE -negb_and [_ && _]coML. +- by rewrite -defDsup // def_FTcore // b. +have [/subsetP sMG_M _ injMG sM_MG] := mmax_transversalP gT. +have{PG} ->: PG = [set class_support M^~~ G | M : {group gT} in 'M]. + apply/setP=> AG; apply/imsetP/imsetP=> [] [M maxM ->]. + by move/sMG_M in maxM; exists M; rewrite ?defDsup //. + have [x MG_Mx] := sM_MG M maxM. + by exists (M :^ x)%G; rewrite // defDsup ?mmaxJ ?FT_Dade1_supportJ. +have [c1 c2] := mFT_partition gT. +split=> [M H maxM maxH eq_MH | Gtype1 | S T W W1 W2 defW VG pairST]. +- apply: injMG => //; move/sMG_M in maxM; move/sMG_M in maxH. + apply/orbit_transl/idPn => not_HG_M. + have /negP[]: ~~ [disjoint 'A1~(M) & 'A1~(H)]. + rewrite eq_MH -setI_eq0 setIid -defDsup //. + by apply: contraNneq not_PG_set0 => <-; exact: mem_imset. + rewrite -!defDsup // -setI_eq0 class_supportEr big_distrl -subset0. + apply/bigcupsP=> x /class_supportGidr <- /=; rewrite -conjIg sub_conjg conj0g. + rewrite class_supportEr big_distrr /=; apply/bigcupsP=> {x}x _. + rewrite subset0 setI_eq0 -sigma_supportJ sigma_support_disjoint ?mmaxJ //. + by rewrite (orbit_transr _ (mem_orbit _ _ _)) ?in_setT // orbit_sym. +- rewrite c1 // setD_eq0; apply/subsetP=> M maxM. + by rewrite FTtype_Fmax ?(forall_inP Gtype1). +have [[[cycW maxS _] _ _ _ _] [U_S StypeP]] := (pairST, typeP_pairW pairST). +have Stype'1 := FTtypeP_neq1 maxS StypeP. +have maxP_S: S \in TypeP_maxgroups _ by rewrite FTtype_Pmax. +have hallW1: \kappa(S).-Hall(S) W1. + have [[U1 K] /= complU1] := kappa_witness maxS. + have ntK: K :!=: 1%g by rewrite -(trivgPmax maxS complU1). + have [[defS_K _ _] [//|defS' _] _ _ _] := kappa_structure maxS complU1. + rewrite {}defS' in defS_K. + have /imsetP[x Sx defK] := of_typeP_compl_conj StypeP defS_K. + by have [_ hallK _] := complU1; rewrite defK pHallJ in hallK. +have{cycW} [[ntW1 ntW2] [cycW _ _]] := (cycTI_nontrivial cycW, cycW). +suffices defW2: 'C_(S`_\sigma)(W1) = W2. + by have [] := c2 _ _ maxP_S hallW1; rewrite defW2 /= (dprodWY defW). +have [U1 complU1] := ex_kappa_compl maxS hallW1. +have [[_ [_ _ sW2'F] _] _ _ _] := BGsummaryC maxS complU1 ntW1. +rewrite -(setIidPr sW2'F) setIA (setIidPl (Fcore_sub_Msigma maxS)). +exact: typeP_cent_core_compl StypeP. +Qed. + +(* This is Peterfalvi (8.18). Note that part (a) is not actually used later. *) +Lemma FT_Dade_support_disjoint S T : + S \in 'M -> T \in 'M -> gval T \notin S :^: G -> + [/\ (*a*) FTsupports S T = ~~ [disjoint 'A1(S) & 'A(T)] + /\ {in 'A1(S) :&: 'A(T), forall x, + ~~ ('C[x] \subset S) /\ 'C[x] \subset T}, + (*b*) [exists x, FTsupports S (T :^ x)] = ~~ [disjoint 'A1~(S) & 'A~(T)] + & (*c*) [disjoint 'A1~(S) & 'A~(T)] \/ [disjoint 'A1~(T) & 'A~(S)]]. +Proof. +move: S T; pose NC S T := gval T \notin S :^: G. +have part_a2 S T (maxS : S \in 'M) (maxT : T \in 'M) (ncST : NC S T) : + {in 'A1(S) :&: 'A(T), forall x, ~~ ('C[x] \subset S) /\ 'C[x] \subset T}. +- move=> x /setIP[/setD1P[ntx Ss_x] ATx]. + have coxTs: coprime #[x] #|T`_\s|. + apply: (coprime_dvdl (order_dvdG Ss_x)). + by have [_ ->] := FT_Dade_support_partition. + have [z /setD1P[ntz Ts_z] /setD1P[_ /setIP[Tn_x czx]]] := bigcupP ATx. + set n := FTtype T != 1%N in Tn_x. + have typeT: FTtype T == n.+1. + have notTs_x: x \notin T`_\s. + apply: contra ntx => Ts_x. + by rewrite -order_eq1 -dvdn1 -(eqnP coxTs) dvdn_gcd dvdnn order_dvdG. + apply: contraLR ATx => typeT; rewrite FTsupp_eq1 // ?inE ?ntx //. + move: (FTtype_range T) typeT; rewrite -mem_iota /n. + by do 5!case/predU1P=> [-> // | ]. + have defTs: T`_\s = T`_\F. + by apply/esym/Fcore_eq_FTcore; rewrite // (eqP typeT); case n. + have [U Ux defTn]: exists2 U : {group gT}, x \in U & T`_\F ><| U = T^`(n)%g. + have [[U K] /= complU] := kappa_witness maxT. + have defTn: T`_\s ><| U = T^`(n)%g. + by rewrite def_FTcore // (sdprod_FTder maxT complU). + have nsTsTn: T`_\s <| T^`(n)%g by case/sdprod_context: defTn. + have [sTsTn nTsTn] := andP nsTsTn. + have hallTs: \pi(T`_\s).-Hall(T^`(n)%g) T`_\s. + by rewrite defTs (pHall_subl _ (der_sub n T) (Fcore_Hall T)) //= -defTs. + have hallU: \pi(T`_\s)^'.-Hall(T^`(n)%g) U. + by apply/sdprod_Hall_pcoreP; rewrite /= (normal_Hall_pcore hallTs). + have solTn: solvable T^`(n)%g := solvableS (der_sub n T) (mmax_sol maxT). + rewrite coprime_sym coprime_pi' // in coxTs. + have [|y Tn_y] := Hall_subJ solTn hallU _ coxTs; rewrite cycle_subG //. + exists (U :^ y)%G; rewrite // -defTs. + by rewrite -(normsP nTsTn y Tn_y) -sdprodJ defTn conjGid. + have uniqCx: 'M('C[x]) = [set T]. + have:= FTtypeI_II_facts maxT typeT defTn; rewrite !ltnS leq_b1 -cent_set1. + case=> _ -> //; first by rewrite -cards_eq0 cards1. + by rewrite sub1set !inE ntx. + by apply/trivgPn; exists z; rewrite //= -defTs inE Ts_z cent_set1 cent1C. + split; last by case/mem_uniq_mmax: uniqCx. + by apply: contra ncST => /(eq_uniq_mmax uniqCx maxS)->; exact: orbit_refl. +have part_a1 S T (maxS : S \in 'M) (maxT : T \in 'M) (ncST : NC S T) : + FTsupports S T = ~~ [disjoint 'A1(S) & 'A(T)]. +- apply/existsP/pred0Pn=> [[x /and3P[ASx not_sCxS sCxT]] | [x /andP[A1Sx Atx]]]. + have [_ [/subsetP]] := FTsupport_facts maxS; set D := finset _. + have Dx: x \in D by rewrite !inE ASx. + move=> /(_ x Dx) A1x /(_ x Dx)uniqCx /(_ x Dx)[_ _ /setDP[ATx _] _]. + by rewrite (eq_uniq_mmax uniqCx maxT sCxT); exists x; exact/andP. + exists x; rewrite (subsetP (FTsupp1_sub maxS)) //=. + by apply/andP/part_a2=> //; exact/setIP. +have part_b S T (maxS : S \in 'M) (maxT : T \in 'M) (ncST : NC S T) : + [exists x, FTsupports S (T :^ x)] = ~~ [disjoint 'A1~(S) & 'A~(T)]. +- apply/existsP/pred0Pn=> [[x] | [y /andP[/= A1GSy AGTy]]]. + rewrite part_a1 ?mmaxJ // => [/pred0Pn[y /andP/=[A1Sy ATyx]]|]; last first. + by rewrite /NC -(rcoset_id (in_setT x)) orbit_rcoset. + rewrite FTsuppJ mem_conjg in ATyx; exists (y ^ x^-1); apply/andP; split. + by apply/bigcupP; exists y => //; rewrite mem_imset2 ?rcoset_refl ?inE. + apply/bigcupP; exists (y ^ x^-1) => //. + by rewrite mem_class_support ?rcoset_refl. + have{AGTy} [x2 ATx2 x2R_yG] := bigcupP AGTy. + have [sCx2T | not_sCx2T] := boolP ('C[x2] \subset T); last first. + have [_ _ _ [injA1G pGI pGP]] := FT_Dade_support_partition. + have{pGI pGP} tiA1g: trivIset [set 'A1~(M) | M : {group gT} in 'M^G]. + case: FTtypeP_pair_cases => [/forall_inP/pGI/and3P[] // | [M [L]]]. + by case=> _ W W1 W2 defW1 /pGP[]/and3P[_ /(trivIsetS (subsetUr _ _))]. + have [_ _ injMG sM_MG] := mmax_transversalP gT. + have [_ [sDA1T _] _] := FTsupport_facts maxT. + have [[z1 maxSz] [z2 maxTz]] := (sM_MG S maxS, sM_MG T maxT). + case/imsetP: ncST; exists (z1 * z2^-1)%g; first by rewrite inE. + rewrite conjsgM; apply/(canRL (conjsgK _))/congr_group/injA1G=> //. + apply/eqP/idPn=> /(trivIsetP tiA1g)/pred0Pn[]; try exact: mem_imset. + exists y; rewrite !FT_Dade1_supportJ /= A1GSy andbT. + by apply/bigcupP; exists x2; rewrite // (subsetP sDA1T) ?inE ?ATx2. + have{x2R_yG} /imsetP[z _ def_y]: y \in x2 ^: G. + by rewrite /'R_T {}sCx2T mul1g class_support_set1l in x2R_yG. + have{A1GSy} [x1 A1Sx1] := bigcupP A1GSy; rewrite {y}def_y -mem_conjgV. + rewrite class_supportGidr ?inE {z}//. + case/imset2P=> _ z /rcosetP[y Hy ->] _ def_x2. + exists z^-1%g; rewrite part_a1 ?mmaxJ //; last first. + by rewrite /NC (orbit_transr _ (mem_orbit _ _ _)) ?inE. + apply/pred0Pn; exists x1; rewrite /= A1Sx1 FTsuppJ mem_conjgV; apply/bigcupP. + pose ddS := FT_Dade1_hyp maxS; have [/andP[sA1S _] _ notA1_1 _ _] := ddS. + have [ntx1 Sx1] := (memPn notA1_1 _ A1Sx1, subsetP sA1S _ A1Sx1). + have [coHS defCx1] := (Dade_coprime ddS A1Sx1 A1Sx1, Dade_sdprod ddS A1Sx1). + rewrite def_FTsignalizer1 // in coHS defCx1. + have[u Ts_u /setD1P[_ cT'ux2]] := bigcupP ATx2. + exists u => {Ts_u}//; rewrite 2!inE -(conj1g z) (can_eq (conjgK z)) ntx1. + suffices{u cT'ux2} ->: x1 = (y * x1).`_(\pi('R_S x1)^'). + by rewrite -consttJ -def_x2 groupX. + have /setIP[_ /cent1P cx1y]: y \in 'C_G[x1]. + by case/sdprod_context: defCx1 => /andP[/subsetP->]. + rewrite consttM // (constt1P _) ?p_eltNK ?(mem_p_elt (pgroup_pi _)) // mul1g. + have piR'_Cx1: \pi('R_S x1)^'.-group 'C_S[x1] by rewrite coprime_pi' in coHS. + by rewrite constt_p_elt ?(mem_p_elt piR'_Cx1) // inE Sx1 cent1id. +move=> S T maxS maxT ncST; split; first split; auto. +apply/orP/idPn; rewrite negb_or -part_b // => /andP[suppST /negP[]]. +without loss{suppST} suppST: T maxT ncST / FTsupports S T. + move=> IH; case/existsP: suppST => x /IH {IH}. + rewrite FT_Dade1_supportJ (orbit_transr _ (mem_orbit _ _ _)) ?in_setT //. + by rewrite mmaxJ => ->. +have{suppST} [y /and3P[ASy not_sCyS sCyT]] := existsP suppST. +have Dy: y \in [set z in 'A0(S) | ~~ ('C[z] \subset S)] by rewrite !inE ASy. +have [_ [_ /(_ y Dy) uCy] /(_ y Dy)[_ coTcS _ typeT]] := FTsupport_facts maxS. +rewrite -mem_iota -(eq_uniq_mmax uCy maxT sCyT) !inE in coTcS typeT. +apply/negbNE; rewrite -part_b /NC 1?orbit_sym // negb_exists. +apply/forallP=> x; rewrite part_a1 ?mmaxJ ?negbK //; last first. + by rewrite /NC (orbit_transr _ (mem_orbit _ _ _)) ?in_setT // orbit_sym. +rewrite -setI_eq0 -subset0 FTsuppJ -bigcupJ big_distrr; apply/bigcupsP=> z Sxz. +rewrite conjD1g /= -setDIl coprime_TIg ?setDv //= cardJg. +rewrite -(Fcore_eq_FTcore maxT _) ?inE ?orbA; last by have [->] := typeT. +by rewrite (coprimegS _ (coTcS z _)) ?(subsetP (FTsupp1_sub0 _)) ?setSI ?gFsub. +Qed. + +(* A corollary to the above, which Peterfalvi derives from (8.17a) (i.e., *) +(* FT_Dade_support_partition) in the proof of (12.16). *) +Lemma FT_Dade1_support_disjoint S T : + S \in 'M -> T \in 'M -> gval T \notin S :^: G -> [disjoint 'A1~(S) & 'A1~(T)]. +Proof. +move=> maxS maxT /FT_Dade_support_disjoint[] // _ _ tiA1A. +without loss{tiA1A maxT}: S T maxS / [disjoint 'A1~(T) & 'A~(S)]. + by move=> IH_ST; case: tiA1A => /IH_ST; first rewrite disjoint_sym; apply. +by rewrite disjoint_sym; apply/disjoint_trans/FT_Dade_supportS/FTsupp1_sub. +Qed. + +End Eight. + +Notation FT_Dade0 maxM := (Dade (FT_Dade0_hyp maxM)). +Notation FT_Dade maxM := (Dade (FT_Dade_hyp maxM)). +Notation FT_Dade1 maxM := (Dade (FT_Dade1_hyp maxM)). +Notation FT_DadeF maxM := (Dade (FT_DadeF_hyp maxM)). + diff --git a/mathcomp/odd_order/PFsection9.v b/mathcomp/odd_order/PFsection9.v new file mode 100644 index 0000000..361d5fe --- /dev/null +++ b/mathcomp/odd_order/PFsection9.v @@ -0,0 +1,2205 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice. +Require Import fintype tuple finfun bigop prime binomial ssralg poly finset. +Require Import fingroup morphism perm automorphism quotient action finalg zmodp. +Require Import gfunctor gproduct cyclic commutator center gseries nilpotent. +Require Import pgroup sylow hall abelian maximal frobenius. +Require Import matrix mxalgebra mxrepresentation mxabelem vector. +Require Import BGsection1 BGsection3 BGsection7 BGsection15 BGsection16. +Require Import algC classfun character inertia vcharacter. +Require Import PFsection1 PFsection2 PFsection3 PFsection4. +Require Import PFsection5 PFsection6 PFsection8. + +(******************************************************************************) +(* This file covers Peterfalvi, Section 9: On the maximal subgroups of Types *) +(* II, III and IV. For defW : W1 \x W2 = W, MtypeP : of_typeP M U defW, and *) +(* H := M`_\F we define : *) +(* Ptype_Fcore_kernel MtypeP == a maximal normal subgroup of M contained *) +(* (locally) H0 in H and containing 'C_H(U), provided M is *) +(* not a maximal subgroup of type V. *) +(* Ptype_Fcore_kernel MtypeP == the stabiliser of Hbar := H / H0 in U; this *) +(* (locally to this file) C is locked for performance reasons. *) +(* typeP_Galois MtypeP <=> U acts irreducibly on Hbar; this implies *) +(* that M / H0C is isomorphic to a Galois group *) +(* acting on the semidirect product of the *) +(* additive group of a finite field with a *) +(* a subgroup of its multiplicative group. *) +(* --> This predicate reflects alternative (b) in Peterfalvi (9.7). *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope GRing.Theory FinRing.Theory. + +Section Nine. + +Variable gT : minSimpleOddGroupType. +Local Notation G := (TheMinSimpleOddGroup gT). +Implicit Types (p q : nat) (x y z : gT). +Implicit Types H K L N P Q R S T U V W : {group gT}. + +(* Peterfalvi (9.1) is covered by BGsection3.Frobenius_Wielandt_fixpoint. *) + +(* These assumptions correspond to Peterfalvi, Hypothesis (9.2). *) + +Variables M U W W1 W2 : {group gT}. +Hypotheses (maxM : M \in 'M) (defW : W1 \x W2 = W) (MtypeP: of_typeP M U defW). +Hypothesis notMtype5 : FTtype M != 5. + +Local Notation "` 'M'" := (gval M) (at level 0, only parsing) : group_scope. +Local Notation "` 'U'" := (gval U) (at level 0, only parsing) : group_scope. +Local Notation "` 'W1'" := (gval W1) (at level 0, only parsing) : group_scope. +Local Notation H := `M`_\F%G. +Local Notation "` 'H'" := `M`_\F (at level 0) : group_scope. +Local Notation "` 'W2'" := (gval W2) (at level 0, only parsing) : group_scope. +Local Notation HU := M^`(1)%G. +Local Notation "` 'HU'" := `M^`(1) (at level 0) : group_scope. +Local Notation U' := U^`(1)%G. +Local Notation "` 'U''" := `U^`(1) (at level 0) : group_scope. + +Let q := #|W1|. + +Let defM : HU ><| W1 = M. Proof. by have [[]] := MtypeP. Qed. +Let defHU : H ><| U = HU. Proof. by have [_ []] := MtypeP. Qed. +Let nUW1 : W1 \subset 'N(U). Proof. by have [_ []] := MtypeP. Qed. +Let cHU' : U' \subset 'C(H). Proof. by have [_ []] := typeP_context MtypeP. Qed. + +Let notMtype1 : FTtype M != 1%N. Proof. exact: FTtypeP_neq1 MtypeP. Qed. + +Local Notation Mtype24 := (compl_of_typeII_IV maxM MtypeP notMtype5). +Let ntU : U :!=: 1. Proof. by have [] := Mtype24. Qed. +Let pr_q : prime q. Proof. by have [] := Mtype24. Qed. +Let ntW2 : W2 :!=: 1. Proof. by have [_ _ _ []] := MtypeP. Qed. +Let sW2H : W2 \subset H. Proof. by have [_ _ _ []] := MtypeP. Qed. +Let defW2 : 'C_H(W1) = W2. Proof. exact: typeP_cent_core_compl MtypeP. Qed. + +Lemma Ptype_Fcore_sdprod : H ><| (U <*> W1) = M. +Proof. +have [_ /= sW1M mulHUW1 _ tiHUW1] := sdprod_context defM. +have [/= /andP[sHHU _] sUHU mulHU nHU tiHU] := sdprod_context defHU. +rewrite sdprodE /= norm_joinEr // ?mulgA ?mulHU //. + by rewrite mulG_subG nHU (subset_trans sW1M) ?gFnorm. +rewrite setIC -(setIidPr sHHU) setIA -group_modl //. +by rewrite (setIC W1) tiHUW1 mulg1 setIC tiHU. +Qed. +Local Notation defHUW1 := Ptype_Fcore_sdprod. + +Lemma Ptype_Fcore_coprime : coprime #|H| #|U <*> W1|. +Proof. +by rewrite (coprime_sdprod_Hall_l defHUW1) ?(pHall_Hall (Fcore_Hall M)). +Qed. +Let coH_UW1 := Ptype_Fcore_coprime. +Let coHU : coprime #|H| #|U|. +Proof. exact: coprimegS (joing_subl U W1) coH_UW1. Qed. + +Let not_cHU : ~~ (U \subset 'C(H)). +Proof. by have [_ [_ ->]] := typeP_context MtypeP. Qed. + +Lemma Ptype_compl_Frobenius : [Frobenius U <*> W1 = U ><| W1]. +Proof. +have [[_ _ ntW1 _] _ _ [_ _ _ _ prHU_W1] _] := MtypeP. +have [[_ _ _ tiHUW1] [_ sUHU _ _ tiHU]] := (sdprodP defM, sdprod_context defHU). +apply/Frobenius_semiregularP=> // [|x /prHU_W1 defCx]. + by rewrite sdprodEY //; apply/trivgP; rewrite -tiHUW1 setSI. +by apply/trivgP; rewrite -tiHU /= -{1}(setIidPr sUHU) setIAC defCx setSI. +Qed. +Local Notation frobUW1 := Ptype_compl_Frobenius. + +Let nilH : nilpotent H. Proof. exact: Fcore_nil. Qed. +Let solH : solvable H. Proof. exact: nilpotent_sol. Qed. + +(* This is Peterfalvi (9.3). *) +Lemma typeII_IV_core (p := #|W2|) : + if FTtype M == 2 then 'C_H(U) = 1 /\ #|H| = (#|W2| ^ q)%N + else [/\ prime p, 'C_H(U <*> W1) = 1 & #|H| = (p ^ q * #|'C_H(U)|)%N]. +Proof. +have [_ _ nHUW1 _] := sdprodP defHUW1. +have /= [oH _ oH1] := Frobenius_Wielandt_fixpoint frobUW1 nHUW1 coH_UW1 solH. +have [Mtype2 {oH}| notMtype2 {oH1}] := boolP (FTtype M == 2). + suffices regHU: 'C_H(U) = 1 by rewrite -defW2 oH1. + have [_ _ _ HUtypeF defHUF] := compl_of_typeII maxM MtypeP Mtype2. + have [_ _ [U0 [sU0U _]]] := HUtypeF; rewrite {}defHUF => frobHU0. + have /set0Pn[x U0x]: U0^# != set0. + by rewrite setD_eq0 subG1; case/Frobenius_context: frobHU0. + apply/trivgP; rewrite -(Frobenius_reg_ker frobHU0 U0x) setIS // -cent_cycle. + by rewrite centS // cycle_subG (subsetP sU0U) //; case/setD1P: U0x. +have p_pr: prime p. + have [S pairMS [xdefW [U_S StypeP]]] := FTtypeP_pair_witness maxM MtypeP. + have [[_ _ maxS] _] := pairMS; rewrite {1}(negPf notMtype2) /= => Stype2 _ _. + by have [[]] := compl_of_typeII maxS StypeP Stype2. +rewrite -/q -/p centY setICA defW2 setIC in oH *. +suffices regW2U: 'C_W2(U) = 1 by rewrite -oH regW2U cards1 exp1n mul1n. +apply: prime_TIg => //=; apply: contra not_cHU => /setIidPl cUW2. +rewrite centsC (sameP setIidPl eqP) eqEcard subsetIl. +by rewrite -(@leq_pmul2l (p ^ q)) -?oH ?cUW2 //= expn_gt0 cardG_gt0. +Qed. + +(* Existential witnesses for Peterfalvi (9.4). *) +Definition Ptype_Fcore_kernel of of_typeP M U defW := + odflt 1%G [pick H0 : {group gT} | chief_factor M H0 H & 'C_H(U) \subset H0]. +Let H0 := (Ptype_Fcore_kernel MtypeP). +Local Notation "` 'H0'" := (gval H0) (at level 0, only parsing) : group_scope. +Local Notation Hbar := (H / `H0)%G. +Local Notation "` 'Hbar'" := (`H / `H0)%g (at level 0) : group_scope. +Let p := pdiv #|Hbar|. + +(* This corresponds to Peterfalvi (9.4). *) +Lemma Ptype_Fcore_kernel_exists : chief_factor M H0 H /\ 'C_H(U) \subset H0. +Proof. +pose S := <> . +suffices [H1 maxH sCH1]: {H1 : {group gT} | maxnormal H1 H M & S \subset H1}. + apply/andP; rewrite /H0 /Ptype_Fcore_kernel; case: pickP => // /(_ H1)/idP[]. + rewrite /chief_factor maxH Fcore_normal (subset_trans _ sCH1) ?sub_gen //. + exact: sub_class_support. +apply/maxgroup_exists/andP; split. + have snCH: 'C_H(U) <|<| H by rewrite nilpotent_subnormal ?subsetIl. + by have [/setIidPl/idPn[] | // ] := subnormalEsupport snCH; rewrite centsC. +have [_ {3}<- nHUW1 _] := (sdprodP defHUW1). +rewrite norms_gen // mulG_subG class_support_norm norms_class_support //. +by rewrite normsI ?norms_cent // join_subG normG. +Qed. + +Let chiefH0 : chief_factor M H0 H. +Proof. by have [] := Ptype_Fcore_kernel_exists. Qed. +Let ltH0H : H0 \proper H. +Proof. by case/andP: chiefH0 => /maxgroupp/andP[]. Qed. +Let nH0M : M \subset 'N(H0). +Proof. by case/andP: chiefH0 => /maxgroupp/andP[]. Qed. +Let sH0H : H0 \subset H. Proof. exact: proper_sub ltH0H. Qed. +Let nsH0M : H0 <| M. Proof. by rewrite /normal (subset_trans sH0H) ?gFsub. Qed. +Let nsH0H : H0 <| H. Proof. by rewrite (normalS _ (Fcore_sub _)). Qed. +Let minHbar : minnormal Hbar (M / H0). +Proof. exact: chief_factor_minnormal. Qed. +Let ntHbar : Hbar :!=: 1. Proof. by case/mingroupp/andP: minHbar. Qed. +Let solHbar: solvable Hbar. Proof. by rewrite quotient_sol. Qed. +Let abelHbar : p.-abelem Hbar. +Proof. by have [] := minnormal_solvable minHbar _ solHbar. Qed. +Let p_pr : prime p. Proof. by have [/pgroup_pdiv[]] := and3P abelHbar. Qed. +Let abHbar : abelian Hbar. Proof. exact: abelem_abelian abelHbar. Qed. + +(* This is Peterfalvi, Hypothesis (9.5). *) +Fact Ptype_Fcompl_kernel_key : unit. Proof. by []. Qed. +Definition Ptype_Fcompl_kernel := + locked_with Ptype_Fcompl_kernel_key 'C_U(Hbar | 'Q)%G. +Local Notation C := Ptype_Fcompl_kernel. +Local Notation "` 'C'" := (gval C) (at level 0, only parsing) : group_scope. +Local Notation Ubar := (U / `C)%G. +Local Notation "` 'Ubar'" := (`U / `C)%g (at level 0) : group_scope. +Local Notation W1bar := (W1 / `H0)%G. +Local Notation "` 'W1bar'" := (`W1 / `H0)%g (at level 0) : group_scope. +Local Notation W2bar := 'C_Hbar(`W1bar)%G. +Local Notation "` 'W2bar'" := 'C_`Hbar(`W1bar) (at level 0) : group_scope. +Let c := #|C|. +Let u := #|Ubar|. +Local Notation tau := (FT_Dade0 maxM). +Local Notation "chi ^\tau" := (tau chi). +Let calX := Iirr_kerD M^`(1) H 1. +Let calS := seqIndD M^`(1) M M`_\F 1. +Let X_ Y := Iirr_kerD M^`(1) H Y. +Let S_ Y := seqIndD M^`(1) M M`_\F Y. + +Local Notation inMb := (coset (gval H0)). + +Local Notation H0C := (`H0 <*> `C)%G. +Local Notation "` 'H0C'" := (`H0 <*> `C) (at level 0) : group_scope. +Local Notation HC := (`H <*> `C)%G. +Local Notation "` 'HC'" := (`H <*> `C) (at level 0) : group_scope. +Local Notation H0U' := (`H0 <*> `U')%G. +Local Notation "` 'H0U''" := (gval H0 <*> `U')%G (at level 0) : group_scope. +Local Notation H0C' := (`H0 <*> `C^`(1)%g)%G. +Local Notation "` 'H0C''" := (`H0 <*> `C^`(1)) (at level 0) : group_scope. + +Let defW2bar : W2bar :=: W2 / H0. +Proof. +rewrite -defW2 coprime_quotient_cent ?(subset_trans _ nH0M) //. + by have [_ /mulG_sub[]] := sdprodP defM. +exact: coprimegS (joing_subr _ _) coH_UW1. +Qed. + +Let sCU : C \subset U. Proof. by rewrite [C]unlock subsetIl. Qed. + +Let nsCUW1 : C <| U <*> W1. +Proof. +have [_ sUW1M _ nHUW1 _] := sdprod_context defHUW1. +rewrite /normal [C]unlock subIset ?joing_subl // normsI //. + by rewrite join_subG normG. +rewrite /= astabQ norm_quotient_pre ?norms_cent ?quotient_norms //. +exact: subset_trans sUW1M nH0M. +Qed. + +Lemma Ptype_Fcore_extensions_normal : + [/\ H0C <| M, HC <| M, H0U' <| M & H0C' <| M]. +Proof. +have [nsHUM sW1M /mulG_sub[sHUM _] nHUW1 tiHUW1] := sdprod_context defM. +have [nsHHU sUHU /mulG_sub[sHHU _] nHU tiHU] := sdprod_context defHU. +have [sHM sUM] := (subset_trans sHHU sHUM, subset_trans sUHU sHUM). +have sCM: C \subset M := subset_trans sCU sUM. +have sH0C_M: H0C \subset M by rewrite /normal join_subG (subset_trans sH0H). +have [nH0C nH0_H0C] := (subset_trans sCM nH0M, subset_trans sH0C_M nH0M). +have nsH0C: H0C <| M. + rewrite /normal sH0C_M -{1}defM sdprodEY //= -defHU sdprodEY //= -joingA. + rewrite join_subG andbC normsY ?(normal_norm nsCUW1) //=; last first. + by rewrite (subset_trans _ nH0M) // join_subG sUM. + rewrite -quotientYK // -{1}(quotientGK nsH0H) morphpre_norms //= [C]unlock. + by rewrite cents_norm // centsC -quotient_astabQ quotientS ?subsetIr. +split=> //; first by rewrite /= -{1}(joing_idPl sH0H) -joingA normalY ?gFnormal. + rewrite normalY // /normal (subset_trans (der_sub 1 U)) //=. + rewrite -{1}defM sdprodEY //= -defHU sdprodEY //=. + rewrite !join_subG gFnorm cents_norm 1?centsC //=. + by rewrite (char_norm_trans (der_char _ _)). +suffices ->: H0C' :=: H0 <*> H0C^`(1). + by rewrite normalY ?(char_normal_trans (der_char _ _)). +rewrite /= -?quotientYK ?(subset_trans (der_sub _ _)) ?subsetIl //=. +by rewrite !quotient_der ?cosetpreK ?subsetIl. +Qed. +Local Notation nsH0xx_M := Ptype_Fcore_extensions_normal. + +Let Du : u = #|HU : HC|. +Proof. +have nCU := subset_trans (joing_subl U W1) (normal_norm nsCUW1). +by rewrite -(index_sdprodr defHU) -?card_quotient. +Qed. + +(* This is Peterfalvi (9.6). *) +Lemma Ptype_Fcore_factor_facts : + [/\ C :!=: U, #|W2bar| = p & #|Hbar| = p ^ q]%N. +Proof. +have [defUW1 _ ntW1 _ _] := Frobenius_context Ptype_compl_Frobenius. +have coHW1: coprime #|H| #|W1| := coprimegS (joing_subr U W1) coH_UW1. +have [_ sUW1M _ nHUW1 _] := sdprod_context defHUW1. +have nH0UW1 := subset_trans sUW1M nH0M; have [nH0U nH0W1] := joing_subP nH0UW1. +have regUHb: 'C_Hbar(U / H0) = 1. + have [_ sCH0] := Ptype_Fcore_kernel_exists. + by rewrite -coprime_quotient_cent ?(nilpotent_sol nilH) ?quotientS1. +have ->: C != U. + apply: contraNneq ntHbar => defU; rewrite -subG1 -regUHb subsetIidl centsC. + by rewrite -defU [C]unlock -quotient_astabQ quotientS ?subsetIr. +have frobUW1b: [Frobenius U <*> W1 / H0 = (U / H0) ><| W1bar]. + have tiH0UW1 := coprime_TIg (coprimeSg sH0H coH_UW1). + have /isomP[inj_f im_f] := quotient_isom nH0UW1 tiH0UW1. + have:= injm_Frobenius (subxx _) inj_f frobUW1. + by rewrite im_f !morphim_restrm !(setIidPr _) ?joing_subl ?joing_subr. +have{frobUW1b} oHbar: #|Hbar| = (#|W2bar| ^ q)%N. + have nHbUW1 : U <*> W1 / H0 \subset 'N(Hbar) := quotient_norms H0 nHUW1. + have coHbUW1 : coprime #|Hbar| #|U <*> W1 / H0| by apply: coprime_morph. + have [//|_ _ -> //] := Frobenius_Wielandt_fixpoint frobUW1b nHbUW1 coHbUW1 _. + by rewrite -(card_isog (quotient_isog _ _)) // coprime_TIg ?(coprimeSg sH0H). +have abelW2bar: p.-abelem W2bar := abelemS (subsetIl _ _) abelHbar. +rewrite -(part_pnat_id (abelem_pgroup abelW2bar)) p_part in oHbar *. +suffices /eqP cycW2bar: logn p #|W2bar| == 1%N by rewrite oHbar cycW2bar. +have cycW2: cyclic W2 by have [_ _ _ []] := MtypeP. +rewrite eqn_leq -abelem_cyclic //= -/W2bar {1}defW2bar quotient_cyclic //=. +rewrite lt0n; apply: contraNneq ntHbar => W2bar1. +by rewrite trivg_card1 oHbar W2bar1 exp1n. +Qed. + +Lemma def_Ptype_factor_prime : prime #|W2| -> p = #|W2|. +Proof. +move=> prW2; suffices: p \in \pi(W2) by rewrite !(primes_prime, inE) // => /eqP. +rewrite mem_primes p_pr cardG_gt0; have [_ <- _] := Ptype_Fcore_factor_facts. +by rewrite defW2bar dvdn_quotient. +Qed. + +(* The first assertion of (9.4)(b) (the rest is subsumed by (9.6)). *) +Lemma typeIII_IV_core_prime : FTtype M != 2 -> p = #|W2|. +Proof. +by have:= typeII_IV_core => /=; case: ifP => // _ [/def_Ptype_factor_prime]. +Qed. + +Let frobUW1c : [Frobenius U <*> W1 / C = Ubar ><| W1 / C]. +Proof. +apply: Frobenius_quotient frobUW1 _ nsCUW1 _. + by apply: nilpotent_sol; have [_ []] := MtypeP. +by have [] := Ptype_Fcore_factor_facts; rewrite eqEsubset sCU. +Qed. + +Definition typeP_Galois := acts_irreducibly U Hbar 'Q. + +(* This is Peterfalvi (9.7)(a). *) +Lemma typeP_Galois_Pn : + ~~ typeP_Galois -> + {H1 : {group coset_of H0} | + [/\ #|H1| = p, U / H0 \subset 'N(H1), [acts U, on H1 | 'Q], + \big[dprod/1]_(w in W1bar) H1 :^ w = Hbar + & let a := #|U : 'C_U(H1 | 'Q)| in + [/\ a > 1, a %| p.-1, cyclic (U / 'C_U(H1 | 'Q)) + & exists V : {group 'rV['Z_a]_q.-1}, Ubar \isog V]]}. +Proof. +have [_ sUW1M defHUW1 nHUW1 _] := sdprod_context defHUW1. +have [nHU nHW1] := joing_subP nHUW1. +have nH0UW1 := subset_trans sUW1M nH0M; have [nH0U nH0W1] := joing_subP nH0UW1. +rewrite /typeP_Galois acts_irrQ //= => not_minHbarU. +have [H1 minH1 sH1Hb]: {H1 | minnormal (gval H1) (U / H0) & H1 \subset Hbar}. + by apply: mingroup_exists; rewrite ntHbar quotient_norms. +exists H1; have [defH1 | ltH1H] := eqVproper sH1Hb. + by rewrite -defH1 minH1 in not_minHbarU. +have [/andP[ntH1 nH1U] _] := mingroupP minH1. +have actsUH1: [acts U, on H1 | 'Q]. + by rewrite -(cosetpreK H1) actsQ ?norm_quotient_pre. +have [nH0H [neqCU _ oHbar]] := (normal_norm nsH0H, Ptype_Fcore_factor_facts). +have nUW1b: W1bar \subset 'N(U / H0) by apply: quotient_norms. +have oW1b: #|W1bar| = q. + rewrite -(card_isog (quotient_isog _ _)) // coprime_TIg //. + by rewrite (coprimeSg sH0H) // (coprimegS (joing_subr U W1)). +have [oH1 defHbar]: #|H1| = p /\ \big[dprod/1]_(w in W1bar) H1 :^ w = Hbar. + have nHbUW1: U <*> W1 / H0 \subset 'N(Hbar) by apply: quotient_norms. + pose rUW1 := abelem_repr abelHbar ntHbar nHbUW1. + have irrUW1: mx_irreducible rUW1. + apply/abelem_mx_irrP/mingroupP; split=> [|H2]; first by rewrite ntHbar. + case/andP=> ntH2 nH2UW1 sH2H; case/mingroupP: minHbar => _; apply=> //. + by rewrite ntH2 -defHUW1 quotientMl // mulG_subG sub_abelian_norm. + have nsUUW1: U / H0 <| U <*> W1 / H0 by rewrite quotient_normal // normalYl. + pose rU := subg_repr rUW1 (normal_sub nsUUW1). + pose V1 := rowg_mx (abelem_rV abelHbar ntHbar @* H1). + have simV1: mxsimple rU V1 by apply/mxsimple_abelem_subg/mxsimple_abelemGP. + have [W0 /subsetP sW01 [sumW0 dxW0]] := Clifford_basis irrUW1 simV1. + have def_q: q = (#|W0| * \rank V1)%N. + transitivity (\rank (\sum_(w in W0) V1 *m rUW1 w))%R. + by rewrite sumW0 mxrank1 /= (dim_abelemE abelHbar) // oHbar pfactorK. + rewrite (mxdirectP dxW0) -sum_nat_const; apply: eq_bigr => x /sW01/= Wx. + by rewrite mxrankMfree ?row_free_unit ?repr_mx_unit. + have oH1: #|H1| = (p ^ \rank V1)%N. + by rewrite -{1}(card_Fp p_pr) -card_rowg rowg_mxK card_injm ?abelem_rV_injm. + have oW0: #|W0| = q. + apply/prime_nt_dvdP=> //; last by rewrite def_q dvdn_mulr. + apply: contraTneq (proper_card ltH1H) => trivW0. + by rewrite oHbar def_q trivW0 mul1n -oH1 ltnn. + have q_gt0 := prime_gt0 pr_q. + rewrite oH1 -(mulKn (\rank V1) q_gt0) -{1}oW0 -def_q divnn q_gt0. + have defHbar: \big[dprod/1]_(w in W0) H1 :^ w = Hbar. + have inj_rV_Hbar := rVabelem_injm abelHbar ntHbar. + have/(injm_bigdprod _ inj_rV_Hbar)/= := bigdprod_rowg sumW0 dxW0. + rewrite sub_im_abelem_rV rowg1 im_rVabelem => <- //=; apply: eq_bigr => w. + by move/sW01=> Ww; rewrite abelem_rowgJ ?rowg_mxK ?abelem_rV_mK. + have injW0: {in W0 &, injective (fun w => H1 :^ w)}. + move=> x y Wx Wy /= eq_Hxy; apply: contraNeq ntH1 => neq_xy. + rewrite -(conjsg_eq1 _ x) -[H1 :^ x]setIid {1}eq_Hxy; apply/eqP. + rewrite (bigD1 y) // (bigD1 x) /= ?Wx // dprodA in defHbar. + by case/dprodP: defHbar => [[_ _ /dprodP[_ _ _ ->] _]]. + have defH1W0: [set H1 :^ w | w in W0] = [set H1 :^ w | w in W1 / H0]. + apply/eqP; rewrite eqEcard (card_in_imset injW0) oW0 -oW1b leq_imset_card. + rewrite andbT; apply/subsetP=> _ /imsetP[w /sW01/= Ww ->]. + move: Ww; rewrite norm_joinEr ?quotientMl // => /mulsgP[x w1 Ux Ww1 ->]. + by rewrite conjsgM (normsP nH1U) // mem_imset. + have injW1: {in W1 / H0 &, injective (fun w => H1 :^ w)}. + by apply/imset_injP; rewrite -defH1W0 (card_in_imset injW0) oW0 oW1b. + by rewrite -(big_imset id injW1) -defH1W0 big_imset. +split=> //; set a := #|_ : _|; pose q1 := #|(W1 / H0)^#|. +have a_gt1: a > 1. + rewrite indexg_gt1 subsetIidl /= astabQ -sub_quotient_pre //. + apply: contra neqCU => cH1U; rewrite [C]unlock (sameP eqP setIidPl) /= astabQ. + rewrite -sub_quotient_pre // -(bigdprodWY defHbar) cent_gen centsC. + by apply/bigcupsP=> w Ww; rewrite centsC centJ -(normsP nUW1b w) ?conjSg. +have Wb1: 1 \in W1bar := group1 _. +have ->: q.-1 = q1 by rewrite -oW1b (cardsD1 1) Wb1. +have /cyclicP[h defH1]: cyclic H1 by rewrite prime_cyclic ?oH1. +have o_h: #[h] = p by rewrite defH1 in oH1. +have inj_Zp_h w := injm_Zp_unitm (h ^ w). +pose phi w := invm (inj_Zp_h w) \o restr_perm <[h ^ w]> \o actperm 'Q. +have dU w: w \in W1bar -> {subset U <= 'dom (phi w)}. + move=> Ww x Ux; have Qx := subsetP (acts_dom actsUH1) x Ux. + rewrite inE Qx /= im_Zp_unitm inE mem_morphpre //=; last first. + by apply: Aut_restr_perm (actperm_Aut 'Q _); rewrite //= quotientT. + rewrite cycleJ -defH1 !inE /=; apply/subsetP=> z H1w_z; rewrite inE actpermK. + rewrite qactJ (subsetP nH0U) ?memJ_norm // normJ mem_conjg. + by rewrite (subsetP nH1U) // -mem_conjg (normsP nUW1b) ?mem_quotient. +have sUD := introT subsetP (dU _ _). +have Kphi w: 'ker (phi w) = 'C(H1 :^ w | 'Q). + rewrite !ker_comp ker_invm -kerE ker_restr_perm defH1 -cycleJ. + apply/setP=> x; rewrite !inE; congr (_ && _) => /=. + by apply: eq_subset_r => h1; rewrite !inE actpermK. +have o_phiU w: w \in W1bar -> #|phi w @* U| = a. + move=> Ww; have [w1 Nw1 Ww1 def_w] := morphimP Ww. + rewrite card_morphim Kphi (setIidPr _) ?sUD // /a indexgI /= !astabQ. + by rewrite centJ def_w morphpreJ // -{1}(normsP nUW1 w1 Ww1) indexJg. +have a_dv_p1: a %| p.-1. + rewrite -(o_phiU 1) // (dvdn_trans (cardSg (subsetT _))) // card_units_Zp //. + by rewrite conjg1 o_h (@totient_pfactor p 1) ?muln1. +have cycZhw w: cyclic (units_Zp #[h ^ w]). + rewrite -(injm_cyclic (inj_Zp_h w)) // im_Zp_unitm Aut_prime_cyclic //=. + by rewrite -orderE orderJ o_h. +have cyc_phi1U: cyclic (phi 1 @* U) := cyclicS (subsetT _) (cycZhw 1). +split=> //; last have{cyc_phi1U a_dv_p1} [z def_z] := cyclicP cyc_phi1U. + by rewrite -(conjsg1 H1) -Kphi (isog_cyclic (first_isog_loc _ _)) ?sUD. +have o_hw w: #[h ^ w] = #[h ^ 1] by rewrite !orderJ. +pose phi1 w x := eq_rect _ (fun m => {unit 'Z_m}) (phi w x) _ (o_hw w). +have val_phi1 w x: val (phi1 w x) = val (phi w x) :> nat. + by rewrite /phi1; case: _ / (o_hw _). +have mem_phi1 w x: w \in W1bar -> x \in U -> phi1 w x \in <[z]>%G. + move=> Ww Ux; have: #|<[z]>%G| = a by rewrite /= -def_z o_phiU. + rewrite /phi1; case: _ / (o_hw w) <[z]>%G => A oA /=. + suffices <-: phi w @* U = A by rewrite mem_morphim // dU. + by apply/eqP; rewrite (eq_subG_cyclic (cycZhw w)) ?subsetT // oA o_phiU. +have o_z: #[z] = a by rewrite orderE -def_z o_phiU. +pose phi0 w x := ecast m 'Z_m o_z (invm (injm_Zpm z) (phi1 w x)). +pose psi x := (\row_(i < q1) (phi0 (enum_val i) x * (phi0 1 x)^-1)%g)%R. +have psiM: {in U &, {morph psi: x y / x * y}}. + have phi0M w: w \in W1bar -> {in U &, {morph phi0 w: x y / x * y}}. + move=> Ww x y Ux Uy; rewrite /phi0; case: (a) / (o_z) => /=. + rewrite -morphM; first 1 [congr (invm _ _)] || by rewrite im_Zpm mem_phi1. + by rewrite /phi1; case: _ / (o_hw w); rewrite /= -morphM ?dU. + move=> x y Ux Uy; apply/rowP=> i; have /setD1P[_ Ww] := enum_valP i. + by rewrite !{1}mxE !{1}phi0M // addrCA -addrA -opprD addrCA addrA. +suffices Kpsi: 'ker (Morphism psiM) = C. + by exists [group of Morphism psiM @* U]; rewrite /Ubar -Kpsi first_isog. +apply/esym/eqP; rewrite eqEsubset; apply/andP; split. + rewrite [C]unlock -(bigdprodWY defHbar); apply/subsetP=> x /setIP[Ux cHx]. + suffices phi0x1 w: w \in W1bar -> phi0 w x = 1. + rewrite !inE Ux; apply/eqP/rowP=> i; have /setD1P[_ Ww] := enum_valP i. + by rewrite !mxE !phi0x1 ?mulgV. + move=> Ww; apply: val_inj; rewrite /phi0; case: (a) / (o_z); congr (val _). + suffices /eqP->: phi1 w x == 1 by rewrite morph1. + rewrite -2!val_eqE [val _]val_phi1 -(o_hw w) [phi _ _]mker // Kphi. + by apply: subsetP (astabS _ _) _ cHx; rewrite sub_gen // (bigcup_sup w). +have sKU: 'ker (Morphism psiM) \subset U by apply: subsetIl. +rewrite -quotient_sub1 -?(Frobenius_trivg_cent frobUW1c); last first. + by apply: subset_trans (normal_norm nsCUW1); rewrite subIset ?joing_subl. +rewrite subsetI quotientS //= quotient_cents2r // [C]unlock subsetI. +rewrite (subset_trans (commSg W1 sKU)) ?commg_subl //= astabQ gen_subG /=. +apply/subsetP=> _ /imset2P[x w1 Kx Ww1 ->]. +have:= Kx; rewrite -groupV 2!inE groupV => /andP[Ux /set1P/rowP psi_x'0]. +have [nH0x Ux'] := (subsetP nH0U x Ux, groupVr Ux); pose x'b := (inMb x)^-1. +rewrite mem_morphpre ?groupR ?morphR //= ?(subsetP nH0W1) //. +have conj_x'b w: w \in W1bar -> (h ^ w) ^ x'b = (h ^ w) ^+ val (phi 1 x^-1). + move=> Ww; transitivity (Zp_unitm (phi w x^-1) (h ^ w)). + have /morphpreP[_ /morphpreP[Px' Rx']] := dU w Ww x^-1 Ux'. + rewrite invmK ?restr_permE ?cycle_id //. + by rewrite actpermE qactJ groupV nH0x morphV. + have:= Ww; rewrite -(setD1K Wb1) autE ?cycle_id // => /setU1P[-> // | W'w]. + have /eqP := psi_x'0 (enum_rank_in W'w w); rewrite 2!mxE enum_rankK_in //. + rewrite -eq_mulgV1 -val_eqE /phi0; case: (a) / (o_z); rewrite /= val_eqE. + rewrite (inj_in_eq (injmP (injm_invm _))) /= ?im_Zpm ?mem_phi1 //. + by rewrite -2!val_eqE /= !val_phi1 // => /eqP->. +rewrite -sub_cent1 -(bigdprodWY defHbar) gen_subG; apply/bigcupsP=> w2 Ww2. +rewrite defH1 -cycleJ cycle_subG cent1C inE conjg_set1 !conjgM // conj_x'b //. +rewrite conjXg -!conjgM -conj_x'b ?groupM ?groupV ?mem_quotient //. +by rewrite !conjgM !conjgKV. +Qed. + +(* This is Peterfalvi (9.7)(b). *) +(* Note that part of this statement feeds directly into the final chapter of *) +(* the proof (PFsection14 and BGappendixC) and is not used before; we have *) +(* thus chosen to formulate the statement of (9.7)(b) accordingly. *) +(* For example, we supply separately the three component of the semi-direct *) +(* product isomorphism, because no use is made of the global isomorphism. We *) +(* also state explicitly that the image of W2bar is Fp because this is the *) +(* fact used in B & G, Appendix C, it is readily available during the proof, *) +(* whereas it can only be derived from the original statement of (9.7)(b) by *) +(* using Galois theory. Indeed the Galois part of the isomorphism is only *) +(* needed for this -- so with the formulation below it will not be used. *) +(* In order to avoid the use of the Wedderburn theorem on finite division *) +(* rings we build the field F from the enveloping algebra of the *) +(* representation of U rather than its endomorphism ring: then the fact that *) +(* Ubar is abelian yields commutativity directly. *) +Lemma typeP_Galois_P : + typeP_Galois -> + {F : finFieldType & {phi : {morphism Hbar >-> F} + & {psi : {morphism U >-> {unit F}} & {eta : {morphism W1 >-> {perm F}} + & forall alpha : {perm F}, reflect (rmorphism alpha) (alpha \in eta @* W1) + & [/\ 'injm eta, {in Hbar & W1, morph_act 'Q 'P phi eta} + & {in U & W1, forall x w, val (psi (x ^ w)) = eta w (val (psi x))}]} + & 'ker psi = C /\ {in Hbar & U, morph_act 'Q 'U phi psi}} + & [/\ #|F| = (p ^ q)%N, isom Hbar [set: F] phi & phi @* W2bar = <[1%R : F]>]} + & [/\ cyclic Ubar, coprime u p.-1 & u %| (p ^ q).-1 %/ p.-1]}. +Proof. +move=> irrU; have [_ sUW1M _ /joing_subP[nHU nHW1] _] := sdprod_context defHUW1. +have [nHbU nHbW1] := (quotient_norms H0 nHU, quotient_norms H0 nHW1). +have{sUW1M} /joing_subP[nH0U nH0W1] := subset_trans sUW1M nH0M. +have [ltCU oW2b oHb] := Ptype_Fcore_factor_facts. +pose rU := abelem_repr abelHbar ntHbar nHbU. +pose inHb := rVabelem abelHbar ntHbar; pose outHb := abelem_rV abelHbar ntHbar. +have{irrU} irrU: mx_irreducible rU by apply/abelem_mx_irrP; rewrite -acts_irrQ. +pose E_U := [pred A | (A \in enveloping_algebra_mx rU)%MS]. +have cEE A: A \in E_U -> centgmx rU A. + case/envelop_mxP=> z_ ->{A}; rewrite -memmx_cent_envelop linear_sum. + rewrite summx_sub // => x Ux; rewrite linearZ scalemx_sub {z_}//=. + rewrite memmx_cent_envelop; apply/centgmxP=> y Uy. + rewrite -repr_mxM // commgC 2?repr_mxM ?(groupR, groupM) // -/rU. + apply/row_matrixP=> i; rewrite row_mul; move: (row i _) => h. + have cHbH': (U / H0)^`(1) \subset 'C(Hbar). + by rewrite -quotient_der ?quotient_cents. + apply: rVabelem_inj; rewrite rVabelemJ ?groupR //. + by apply: (canLR (mulKg _)); rewrite -(centsP cHbH') ?mem_commg ?mem_rVabelem. +have{cEE} [F [outF [inF outFK inFK] E_F]]: + {F : finFieldType & {outF : {rmorphism F -> 'M(Hbar)%Mg} + & {inF : {additive _} | cancel outF inF & {in E_U, cancel inF outF}} + & forall a, outF a \in E_U}}%R. +- pose B := row_base (enveloping_algebra_mx rU). + have freeB: row_free B by apply: row_base_free. + pose outF := [additive of vec_mx \o mulmxr B]. + pose inF := [additive of mulmxr (pinvmx B) \o mxvec]. + have E_F a: outF a \in E_U by rewrite !inE vec_mxK mulmx_sub ?eq_row_base. + have inK: {in E_U, cancel inF outF}. + by move=> A E_A; rewrite /= mulmxKpV ?mxvecK ?eq_row_base. + have outI: injective outF := inj_comp (can_inj vec_mxK) (row_free_inj freeB). + have outK: cancel outF inF by move=> a; apply: outI; rewrite inK ?E_F. + pose one := inF 1%R; pose mul a b := inF (outF a * outF b)%R. + have outM: {morph outF: a b / mul a b >-> a * b}%R. + by move=> a b; rewrite inK //; apply: envelop_mxM; exact: E_F. + have out0: outF 0%R = 0%R by apply: raddf0. + have out1: outF one = 1%R by rewrite inK //; exact: envelop_mx1. + have nzFone: one != 0%R by rewrite -(inj_eq outI) out1 out0 oner_eq0. + have mulA: associative mul by move=> *; apply: outI; rewrite !{1}outM mulrA. + have mulC: commutative mul. + move=> a b; apply: outI; rewrite !{1}outM. + by apply: cent_mxP (E_F a); rewrite memmx_cent_envelop cEE ?E_F. + have mul1F: left_id one mul by move=> a; apply: outI; rewrite outM out1 mul1r. + have mulD: left_distributive mul +%R%R. + by move=> a1 a2 b; apply: canLR outK _; rewrite !raddfD mulrDl -!{1}outM. + pose Fring_NC := RingType 'rV__ (ComRingMixin mulA mulC mul1F mulD nzFone). + pose Fring := ComRingType Fring_NC mulC. + have outRM: multiplicative (outF : Fring -> _) by []. + have mulI (nza : {a | a != 0%R :> Fring}): GRing.rreg (val nza). + case: nza => a /=; rewrite -(inj_eq outI) out0 => nzA b1 b2 /(congr1 outF). + rewrite !{1}outM => /row_free_inj eqB12; apply/outI/eqB12. + by rewrite row_free_unit (mx_Schur irrU) ?cEE ?E_F. + pose inv (a : Fring) := oapp (fun nza => invF (mulI nza) one) a (insub a). + have inv0: (inv 0 = 0)%R by rewrite /inv insubF ?eqxx. + have mulV: GRing.Field.axiom inv. + by move=> a nz_a; rewrite /inv insubT /= (f_invF (mulI (exist _ _ _))). + pose Funit := FieldUnitMixin mulV inv0. + pose FringUcl := @GRing.ComUnitRing.Class _ (GRing.ComRing.class Fring) Funit. + have Ffield := @FieldMixin (GRing.ComUnitRing.Pack FringUcl nat) _ mulV inv0. + pose F := FieldType (IdomainType _ (FieldIdomainMixin Ffield)) Ffield. + by exists [finFieldType of F], (AddRMorphism outRM); first exists inF. +pose in_uF (a : F) : {unit F} := insubd (1 : {unit F}) a. +have in_uF_E a: a != 1 -> val (in_uF a) = a. + by move=> nt_a; rewrite insubdK /= ?unitfE. +have [psi psiK]: {psi : {morphism U >-> {unit F}} + | {in U, forall x, outF (val (psi x)) = rU (inMb x)}}. +- pose psi x := in_uF (inF (rU (inMb x))). + have psiK x: x \in U -> outF (val (psi x)) = rU (inMb x). + move/(mem_quotient H0)=> Ux; have EUx := envelop_mx_id rU Ux. + rewrite in_uF_E ?inFK //; apply: contraTneq (repr_mx_unitr rU Ux). + by move/(canRL_in inFK EUx)->; rewrite rmorph0 unitr0. + suffices psiM: {in U &, {morph psi: x y / x * y}} by exists (Morphism psiM). + move=> x y Ux Uy /=; apply/val_inj/(can_inj outFK); rewrite rmorphM //. + by rewrite !{1}psiK ?groupM // morphM ?(subsetP nH0U) ?repr_mxM ?mem_quotient. +have /trivgPn/sig2W[s W2s nts]: W2bar != 1%G. + by rewrite -cardG_gt1 oW2b prime_gt1. +pose sb := outHb s; have [Hs cW1s] := setIP W2s. +have nz_sb: sb != 0%R by rewrite morph_injm_eq1 ?abelem_rV_injm. +pose phi' a : coset_of H0 := inHb (sb *m outF a)%R. +have Hphi' a: phi' a \in Hbar by apply: mem_rVabelem. +have phi'D: {in setT &, {morph phi' : a b / a * b}}. + by move=> a b _ _; rewrite /phi' !raddfD [inHb _]morphM ?mem_im_abelem_rV. +have inj_phi': injective phi'. + move=> a b /rVabelem_inj eq_sab; apply: contraNeq nz_sb. + rewrite -[sb]mulmx1 idmxE -(rmorph1 outF) -subr_eq0 => /divff <-. + by rewrite rmorphM mulmxA !raddfB /= eq_sab subrr mul0mx. +have injm_phi': 'injm (Morphism phi'D) by apply/injmP; exact: in2W. +have Dphi: 'dom (invm injm_phi') = Hbar. + apply/setP=> h; apply/morphimP/idP=> [[a _ _ ->] // | Hh]. + have /cyclic_mxP[A E_A def_h]: (outHb h <= cyclic_mx rU sb)%MS. + by rewrite -(mxsimple_cyclic irrU) ?submx1. + by exists (inF A); rewrite ?inE //= /phi' inFK // -def_h [inHb _]abelem_rV_K. +have [phi [def_phi Kphi _ im_phi]] := domP _ Dphi. +have{Kphi} inj_phi: 'injm phi by rewrite Kphi injm_invm. +have{im_phi} im_phi: phi @* Hbar = setT by rewrite im_phi -Dphi im_invm. +have phiK: {in Hbar, cancel phi phi'} by rewrite def_phi -Dphi; exact: invmK. +have{def_phi Dphi injm_phi'} phi'K: cancel phi' phi. + by move=> a; rewrite def_phi /= invmE ?inE. +have phi'1: phi' 1%R = s by rewrite /phi' rmorph1 mulmx1 [inHb _]abelem_rV_K. +have phi_s: phi s = 1%R by rewrite -phi'1 phi'K. +have phiJ: {in Hbar & U, forall h x, phi (h ^ inMb x) = phi h * val (psi x)}%R. + move=> h x Hh Ux; have Uxb := mem_quotient H0 Ux. + apply: inj_phi'; rewrite phiK ?memJ_norm ?(subsetP nHbU) // /phi' rmorphM. + by rewrite psiK // mulmxA [inHb _]rVabelemJ // -/inHb [inHb _]phiK. +have Kpsi: 'ker psi = C. + apply/setP=> x; rewrite [C]unlock 2!in_setI /= astabQ; apply: andb_id2l => Ux. + have Ubx := mem_quotient H0 Ux; rewrite 3!inE (subsetP nH0U) //= inE. + apply/eqP/centP=> [psi_x1 h Hh | cHx]; last first. + by apply/val_inj; rewrite -[val _]mul1r -phi_s -phiJ // conjgE -cHx ?mulKg. + red; rewrite (conjgC h) -[h ^ _]phiK ?memJ_norm ?(subsetP nHbU) ?phiJ //. + by rewrite psi_x1 mulr1 phiK. +have etaP (w : subg_of W1): injective (fun a => phi (phi' a ^ inMb (val w))). + case: w => w /=/(mem_quotient H0)/(subsetP nHbW1) => nHw a b eq_ab. + apply/inj_phi'/(conjg_inj (inMb w)). + by apply: (injmP inj_phi) eq_ab; rewrite memJ_norm ?mem_rVabelem. +pose eta w : {perm F} := perm (etaP (subg W1 w)). +have etaK: {in Hbar & W1, forall h w, eta w (phi h) = phi (h ^ inMb w)}. + by move=> h w Hh Ww; rewrite /= permE subgK ?phiK. +have eta1 w: w \in W1 -> eta w 1%R = 1%R. + move=> Ww; rewrite -phi_s etaK //. + by rewrite conjgE (centP cW1s) ?mulKg ?mem_quotient. +have etaM: {in W1 &, {morph eta: w1 w2 / w1 * w2}}. + move=> w1 w2 Ww1 Ww2; apply/permP=> a; rewrite -[a]phi'K permM. + rewrite !etaK ?memJ_norm ?groupM ?(subsetP nHbW1) ?mem_quotient //. + by rewrite -conjgM -morphM ?(subsetP nH0W1). +have etaMpsi a: {in U & W1, forall x w, + eta w (a * val (psi x)) = eta w a * val (psi (x ^ w)%g)}%R. +- move=> x w Ux Ww; rewrite -[a]phi'K (etaK _ w (Hphi' a) Ww). + rewrite -!phiJ // ?memJ_norm ?(subsetP nHbW1, subsetP nUW1) ?mem_quotient //. + rewrite etaK ?memJ_norm ?(subsetP nHbU) ?mem_quotient // -!conjgM. + by rewrite conjgC -morphJ ?(subsetP nH0U x Ux, subsetP nH0W1 w Ww). +have psiJ: {in U & W1, forall x w, val (psi (x ^ w)) = eta w (val (psi x))}. + by move=> x w Ux Ww /=; rewrite -[val _]mul1r -(eta1 w Ww) -etaMpsi ?mul1r. +have etaRM w: w \in W1 -> rmorphism (eta w). + move=> Ww; have nUw := subsetP nHbW1 _ (mem_quotient _ Ww). + have etaD: additive (eta w). + move=> a b; rewrite -[a]phi'K -[b]phi'K -!zmodMgE -!zmodVgE. + rewrite -morphV // -morphM ?{1}etaK ?groupM ?groupV // conjMg conjVg. + by rewrite morphM 1?morphV ?groupV // memJ_norm. + do 2![split=> //] => [a b|]; last exact: eta1. + rewrite -[a]outFK; have /envelop_mxP[d ->] := E_F a. + rewrite raddf_sum mulr_suml ![eta w _](raddf_sum (Additive etaD)) mulr_suml. + apply: eq_bigr => _ /morphimP[x Nx Ux ->]; move: {d}(d _) => dx. + rewrite -[dx]natr_Zp scaler_nat !(mulrnAl, raddfMn); congr (_ *+ dx)%R. + by rewrite -psiK //= outFK mulrC etaMpsi // mulrC psiJ. +have oF: #|F| = (p ^ q)%N by rewrite -cardsT -im_phi card_injm. +pose nF := <[1%R : F]>; have o_nF: #|nF| = p. + by rewrite -orderE -phi_s (order_injm inj_phi) // (abelem_order_p abelHbar). +have cyc_uF := @field_unit_group_cyclic F. +exists F. + exists phi; last first. + split=> //; first exact/isomP; apply/esym/eqP; rewrite eqEcard o_nF -phi_s. + by rewrite (@cycle_subG F) mem_morphim //= card_injm ?subsetIl ?oW2b. + exists psi => //; last first. + by split=> // h x Hh Ux; rewrite qactJ (subsetP nH0U) ?phiJ. + have inj_eta: 'injm (Morphism etaM). + have /properP[_ [h Hh notW2h]]: W2bar \proper Hbar. + by rewrite properEcard subsetIl oW2b oHb (ltn_exp2l 1) prime_gt1. + apply/subsetP=> w /morphpreP[Ww /set1P/permP/(_ (phi h))]. + rewrite etaK // permE => /(injmP inj_phi) => chw. + rewrite -(@prime_TIg _ W1 <[w]>) //; first by rewrite inE Ww cycle_id. + rewrite proper_subn // properEneq cycle_subG Ww andbT. + apply: contraNneq notW2h => defW1; rewrite inE Hh /= -defW1. + rewrite quotient_cycle ?(subsetP nH0W1) // cent_cycle cent1C inE. + by rewrite conjg_set1 chw ?memJ_norm // (subsetP nHbW1) ?mem_quotient. + exists (Morphism etaM) => [alpha |]; last first. + by split=> // h w Hh Ww /=; rewrite qactJ (subsetP nH0W1) -?etaK. + pose autF (f : {perm F}) := rmorphism f. (* Bits of Galois theory... *) + have [r prim_r]: {r : F | forall f g, autF f -> autF g -> f r = g r -> f = g}. + have /cyclicP/sig_eqW[r def_uF] := cyc_uF [set: {unit F}]%G. + exists (val r) => f g fRM gRM eq_fgr; apply/permP=> a. + rewrite (_ : f =1 RMorphism fRM) // (_ : g =1 RMorphism gRM) //. + have [-> | /in_uF_E <-] := eqVneq a 0%R; first by rewrite !rmorph0. + have /cycleP[m ->]: in_uF a \in <[r]> by rewrite -def_uF inE. + by rewrite val_unitX !rmorphX /= eq_fgr. + have /sigW[P /and3P[Pr0 nP lePq]]: + exists P: {poly F}, [&& root P r, all (mem nF) P & #|root P| <= q]. + - pose Mr := (\matrix_(i < q.+1) (sb *m outF (r ^+ i)))%R. + have /rowV0Pn[v /sub_kermxP vMr0 nz_v]: kermx Mr != 0%R. + rewrite kermx_eq0 neq_ltn ltnS (leq_trans (rank_leq_col Mr)) //. + by rewrite (dim_abelemE abelHbar) // oHb pfactorK. + pose P : {poly F} := (\poly_(i < q.+1) (v 0 (inord i))%:R)%R. + have szP: size P <= q.+1 by apply: size_poly. + exists P; apply/and3P; split. + + apply/eqP/inj_phi'; congr (inHb _); rewrite rmorph0 mulmx0 -vMr0. + rewrite horner_poly !raddf_sum mulmx_sum_row; apply: eq_bigr => i _. + rewrite rowK inord_val //= mulr_natl rmorphMn -scaler_nat scalemxAr. + by rewrite natr_Zp. + + apply/(all_nthP 0%R)=> i /leq_trans/(_ szP) le_i_q. + by rewrite coef_poly /= le_i_q mem_cycle. + rewrite cardE -ltnS (leq_trans _ szP) //. + rewrite max_poly_roots ?enum_uniq //; last first. + by apply/allP=> r'; rewrite mem_enum. + apply: contraNneq nz_v => /polyP P0; apply/eqP/rowP=> i; apply/eqP. + have /eqP := P0 i; rewrite mxE coef0 coef_poly ltn_ord inord_val. + have charF: p \in [char F]%R by rewrite !inE p_pr -order_dvdn -o_nF /=. + by rewrite -(dvdn_charf charF) (dvdn_charf (char_Fp p_pr)) natr_Zp. + have{Pr0 nP} fPr0 f: autF f -> root P (f r). + move=> fRM; suff <-: map_poly (RMorphism fRM) P = P by apply: rmorph_root. + apply/polyP=> i; rewrite coef_map. + have [/(nth_default _)-> | lt_i_P] := leqP (size P) i; first exact: rmorph0. + by have /cycleP[n ->] := all_nthP 0%R nP i lt_i_P; exact: rmorph_nat. + apply: (iffP morphimP) => [[w _ Ww ->] | alphaRM]; first exact: etaRM. + suffices /setP/(_ (alpha r)): [set (eta w) r | w in W1] = [set t | root P t]. + rewrite inE fPr0 // => /imsetP[w Ww def_wr]; exists w => //. + by apply: prim_r => //; exact: etaRM. + apply/eqP; rewrite eqEcard; apply/andP; split. + by apply/subsetP=> _ /imsetP[w Ww ->]; rewrite inE fPr0 //; exact: etaRM. + rewrite (@cardsE F) card_in_imset // => w1 w2 Ww1 Ww2 /= /prim_r eq_w12. + by apply: (injmP inj_eta) => //; apply: eq_w12; exact: etaRM. +have isoUb: isog Ubar (psi @* U) by rewrite /Ubar -Kpsi first_isog. +pose unF := [set in_uF a | a in nF^#]. +have unF_E: {in nF^#, cancel in_uF val} by move=> a /setD1P[/in_uF_E]. +have unFg: group_set unF. + apply/group_setP; split=> [|_ _ /imsetP[a nFa ->] /imsetP[b nFb ->]]. + have nF1: 1%R \in nF^# by rewrite !inE cycle_id oner_eq0. + by apply/imsetP; exists 1%R => //; apply: val_inj; rewrite unF_E. + have nFab: (a * b)%R \in nF^#. + rewrite !inE mulf_eq0 negb_or. + have [[-> /cycleP[m ->]] [-> /cycleP[n ->]]] := (setD1P nFa, setD1P nFb). + by rewrite -natrM mem_cycle. + by apply/imsetP; exists (a * b)%R => //; apply: val_inj; rewrite /= !unF_E. +have <-: #|Group unFg| = p.-1. + by rewrite -o_nF (cardsD1 1 nF) group1 (card_in_imset (can_in_inj unF_E)). +have <-: #|[set: {unit F}]| = (p ^ q).-1. + rewrite -oF -(cardC1 1) cardsT card_sub; apply: eq_card => a /=. + by rewrite !inE unitfE. +rewrite /u (isog_cyclic isoUb) (card_isog isoUb) cyc_uF. +suffices co_u_p1: coprime #|psi @* U| #|Group unFg|. + by rewrite -(Gauss_dvdr _ co_u_p1) mulnC divnK ?cardSg ?subsetT. +rewrite -(cyclic_dprod (dprodEY _ _)) ?cyc_uF //. + by rewrite (sub_abelian_cent2 (cyclic_abelian (cyc_uF [set:_]%G))) ?subsetT. +apply/trivgP/subsetP=> _ /setIP[/morphimP[x Nx Ux ->] /imsetP[a nFa /eqP]]. +have nCx: x \in 'N(C) by rewrite -Kpsi (subsetP (ker_norm _)). +rewrite -val_eqE (unF_E a) //; case/setD1P: nFa => _ /cycleP[n {a}->]. +rewrite zmodXgE => /eqP def_psi_x; rewrite mker ?set11 // Kpsi coset_idr //. +apply/set1P; rewrite -set1gE -(Frobenius_trivg_cent frobUW1c) /= -/C. +rewrite inE mem_quotient //= -sub1set -quotient_set1 ?quotient_cents2r //. +rewrite gen_subG /= -/C -Kpsi; apply/subsetP=> _ /imset2P[_ w /set1P-> Ww ->]. +have Uxw: x ^ w \in U by rewrite memJ_norm ?(subsetP nUW1). +apply/kerP; rewrite (morphM, groupM) ?morphV ?groupV //. +apply/(canLR (mulKg _))/val_inj; rewrite psiJ // mulg1 def_psi_x. +exact: (rmorph_nat (RMorphism (etaRM w Ww))). +Qed. + +Local Open Scope ring_scope. + +Let redM := [predC irr M]. +Let mu_ := filter redM (S_ H0). + +(* This subproof is shared between (9.8)(b) and (9.9)(b). *) +Let nb_redM_H0 : size mu_ = p.-1 /\ {subset mu_ <= S_ H0C}. +Proof. +have pddM := FT_prDade_hypF maxM MtypeP; pose ptiWM := prDade_prTI pddM. +have [nsHUM sW1M /mulG_sub[sHUM _] nHUW1 tiHUW1] := sdprod_context defM. +have [nsHHU sUHU /mulG_sub[sHHU _] nHU tiHU] := sdprod_context defHU. +have nb_redM K: + K <| M -> K \subset HU -> K :&: H = H0 -> count redM (S_ K) = p.-1. +- move=> nsKM sKHU tiKHbar; have [sKM nKM] := andP nsKM; pose b L := (L / K)%G. + have [nsKHU [_ [_ sW2HU cycW2 _] _]] := (normalS sKHU sHUM nsKM, ptiWM). + have nKW2 := subset_trans sW2HU (normal_norm nsKHU). + have oW2b: #|b W2| = p. + have [_ <- _] := Ptype_Fcore_factor_facts; rewrite defW2bar. + rewrite !card_quotient ?(subset_trans (subset_trans sW2HU sHUM)) //. + by rewrite -indexgI -{2}(setIidPl sW2H) setIAC -setIA tiKHbar indexgI. + have{cycW2} cycW2b: cyclic (b W2) by apply: quotient_cyclic. + have ntW2b: (W2 / K != 1)%g by rewrite -cardG_gt1 oW2b prime_gt1. + have{ntW2b} [defWb ptiWMb]:= primeTIhyp_quotient ptiWM ntW2b sKHU nsKM. + pose muK j := (primeTIred ptiWMb j %% K)%CF. + apply/eqP; have <-: size (image muK (predC1 0)) = p.-1. + by rewrite size_map -cardE cardC1 card_Iirr_cyclic ?oW2b. + rewrite -size_filter -uniq_size_uniq ?filter_uniq ?seqInd_uniq // => [|phi]. + by apply/dinjectiveP=> j1 j2 _ _ /(can_inj (cfModK nsKM))/prTIred_inj. + rewrite mem_filter; apply/imageP/andP=> [[j nz_j ->] | [red_phi]]; last first. + case/seqIndP=> s /setDP[kerK ker'H] Dphi; rewrite !inE in kerK ker'H. + pose s1 := quo_Iirr K s; have Ds: s = mod_Iirr s1 by rewrite quo_IirrK. + rewrite {phi}Dphi Ds mod_IirrE ?cfIndMod // in kerK ker'H red_phi *. + have [[j Ds1] | [/idPn[]]] := prTIres_irr_cases ptiWMb s1. + rewrite Ds1 cfInd_prTIres -/(muK j) in ker'H *; exists j => //. + by apply: contraNneq ker'H => ->; rewrite prTIres0 rmorph1 cfker_cfun1. + by apply: contra red_phi => /cfMod_irr/= ->. + have red_j: redM (muK j). + apply: contra (prTIred_not_irr ptiWMb j) => /(cfQuo_irr nsKM). + by rewrite cfker_mod ?cfModK // => ->. + have [s DmuKj]: exists s, muK j = 'Ind[M, HU] 'chi_s. + exists (mod_Iirr (primeTI_Ires ptiWMb j)). + by rewrite mod_IirrE // cfIndMod // cfInd_prTIres. + split=> //; apply/seqIndP; exists s; rewrite // !inE andbC. + rewrite -(@sub_cfker_Ind_irr _ M) ?gFnorm // -DmuKj cfker_mod //=. + have [[j1 Ds] | [/idPn]] := prTIres_irr_cases ptiWM s; last by rewrite -DmuKj. + rewrite Ds cfker_prTIres //; apply: contraNneq nz_j => j1_0. + apply/eqP/(prTIred_inj ptiWMb)/(can_inj (cfModK nsKM)); rewrite -{1}/(muK j). + by rewrite DmuKj Ds j1_0 -cfInd_prTIres !prTIres0 -cfIndMod ?rmorph1. +have [sH0HU sH0M] := (subset_trans sH0H sHHU, subset_trans sH0H (gFsub _ _)). +have sz_mu: size mu_ = p.-1. + by rewrite size_filter nb_redM ?(setIidPl sH0H) // /normal sH0M. +have s_muC_mu: {subset filter redM (S_ H0C) <= mu_}. + move=> phi; rewrite /= !mem_filter => /andP[->]; apply: seqIndS. + by rewrite setSD // Iirr_kerS ?joing_subl. +have UmuC: uniq (filter redM (S_ H0C)) by rewrite filter_uniq ?seqInd_uniq. +have [|Dmu _] := leq_size_perm UmuC s_muC_mu; last first. + by split=> // phi; rewrite -Dmu mem_filter => /andP[]. +have [nsH0C_M _ _ _] := nsH0xx_M. +have sCHU := subset_trans sCU sUHU; have sCM := subset_trans sCHU sHUM. +have sHOC_HU: H0C \subset HU by apply/joing_subP. +rewrite sz_mu size_filter nb_redM //= norm_joinEr ?(subset_trans sCM) //. +by rewrite -group_modl //= setIC [C]unlock setIA tiHU setI1g mulg1. +Qed. + +Let isIndHC (zeta : 'CF(M)) := + [/\ zeta 1%g = (q * u)%:R, zeta \in S_ H0C + & exists2 xi : 'CF(HC), xi \is a linear_char & zeta = 'Ind xi]. + +(* This is Peterfalvi (9.8). *) +Lemma typeP_nonGalois_characters (not_Galois : ~~ typeP_Galois) : + let a := #|U : 'C_U(sval (typeP_Galois_Pn not_Galois) | 'Q)| in + [/\ (*a*) {in X_ H0, forall s, (a %| 'chi_s 1%g)%C}, + (*b*) size mu_ = p.-1 /\ {in mu_, forall mu_j, isIndHC mu_j}, + (*c*) exists t, isIndHC 'chi_t + & (*d*) let irr_qa := [pred zeta in irr M | zeta 1%g == (q * a)%:R] in + let lb_n := (p.-1 * #|U|)%N in let lb_d := (a ^ 2 * #|U'|)%N in + (lb_d %| lb_n /\ lb_n %/ lb_d <= count irr_qa (S_ H0U'))%N]. +Proof. +case: (typeP_Galois_Pn _) => H1 [oH1 nH1U nH1Uq defHbar aP]; rewrite [sval _]/=. +move => a; case: aP; rewrite -/a => a_gt1 a_dv_p1 cycUb1 isoUb. +set part_a := ({in _, _}); pose HCbar := (HC / H0)%G. +have [_ /mulG_sub[sHUM sW1M] nHUW1 tiHUW1] := sdprodP defM. +have [nsHHU _ /mulG_sub[sHHU sUHU] nHU tiHU] := sdprod_context defHU. +have [nH0H nHHU] := (normal_norm nsH0H, normal_norm nsHHU). +have sHHC: H \subset HC by rewrite joing_subl. +have [nH0HU sCHU] := (subset_trans sHUM nH0M, subset_trans sCU sUHU). +have nsH0_HU: H0 <| HU by rewrite /normal (subset_trans sH0H). +have nH0C := subset_trans sCHU nH0HU. +have [nsH0C_M nsHC_M nsH0U'_M _] := nsH0xx_M; have [sHC_M _] := andP nsHC_M. +have nsH0HC: H0 <| HC := normalS (subset_trans sH0H sHHC) sHC_M nsH0M. +have defHCbar: Hbar \x (C / H0) = HCbar. + rewrite /= quotientY // [C]unlock /= astabQ quotient_setIpre. + by rewrite dprodEY ?subsetIr // setIA -quotientGI // tiHU quotient1 setI1g. +have sHC_HU: HC \subset HU by rewrite join_subG sHHU. +have nsHC_HU: HC <| HU := normalS sHC_HU sHUM nsHC_M. +have defHb1 := defHbar; rewrite (big_setD1 1%g) ?group1 ?conjsg1 //= in defHb1. +have [[_ H1c _ defH1c] _ _ _] := dprodP defHb1; rewrite defH1c in defHb1. +have [nsH1H _] := dprod_normal2 defHb1; have [sH1H nH1H] := andP nsH1H. +have nHW1: W1 \subset 'N(H) := subset_trans sW1M (gFnorm _ _). +have nHbW1: W1bar \subset 'N(Hbar) by rewrite quotient_norms. +have sH1wH w: w \in W1bar -> H1 :^ w \subset Hbar. + by move/(normsP nHbW1) <-; rewrite conjSg. +have nsH1wHUb w: w \in W1bar -> H1 :^ w <| HU / H0. + move=> W1w; rewrite -(normsP (quotient_norms _ nHUW1) w W1w) normalJ. + rewrite /normal (subset_trans sH1H) ?quotientS //. + by rewrite -defHU sdprodE // quotientMl // mulG_subG nH1H. +have nH1wHUb := normal_norm (nsH1wHUb _ _). +have Part_a: part_a. + move=> s; rewrite !inE => /andP[kers'H kersH0]. + have [t sHt] := constt_cfRes_irr H s; pose theta := ('chi_t / H0)%CF. + have{kers'H} t_neq0: t != 0. + by rewrite -subGcfker (sub_cfker_constt_Res_irr sHt). + have{kersH0} kertH0: H0 \subset cfker 'chi_t. + by rewrite (sub_cfker_constt_Res_irr sHt). + have Ltheta: theta \is a linear_char. + by rewrite /theta -quo_IirrE // (char_abelianP _ _). + have Dtheta : _ = theta := cfBigdprod_Res_lin defHbar Ltheta. + set T := 'I_HU['chi_t]; have sHT: H \subset T by rewrite sub_Inertia. + have sTHU: T \subset HU by rewrite Inertia_sub. + suffices{s sHt} a_dv_iTHU: a %| #|HU : T|. + have [_ defInd_t _ imInd_t _] := cfInd_sum_Inertia t nsHHU. + have /imsetP[r tTr ->]: s \in Ind_Iirr HU @: irr_constt ('Ind[T] 'chi_t). + by rewrite imInd_t constt_Ind_Res. + by rewrite defInd_t ?cfInd1 // dvdC_mulr ?dvdC_nat // Cint_Cnat ?Cnat_irr1. + have /exists_inP[w W1w nt_t_w]: [exists w in W1bar, 'Res[H1 :^ w] theta != 1]. + rewrite -negb_forall_in; apply: contra t_neq0 => /forall_inP=> tH1w1. + rewrite -irr_eq1 -(cfQuoK nsH0H kertH0) -/theta -Dtheta. + rewrite [cfBigdprod _ _]big1 ?rmorph1 // => w /tH1w1/eqP->. + by rewrite /cfBigdprodi rmorph1. + have defT: H ><| (U :&: T) = T. + by rewrite (sdprod_modl defHU) // (setIidPr sTHU). + have /irrP[k Dk]: 'Res theta \in irr (H1 :^ w). + by rewrite lin_char_irr ?cfRes_lin_char. + rewrite -divgS // -(sdprod_card defHU) -(sdprod_card defT) divnMl // divgI. + rewrite -indexgI; have ->: a = #|U : 'C_U(H1 :^ w | 'Q)|. + have [w1 nH0w1 W1w1 ->] := morphimP W1w; rewrite astabQ centJ morphpreJ //. + by rewrite -astabQ indexgI -(normsP nUW1 _ W1w1) indexJg -indexgI. + rewrite indexgS ?setIS // sub_astabQ ?(subset_trans sTHU) //= -inertia_quo //. + apply: subset_trans (sub_inertia_Res _ (nH1wHUb w W1w)) _. + by rewrite Dk (inertia_irr_prime _ p_pr) ?subsetIr ?cardJg // -irr_eq1 -Dk. +pose isoJ := conj_isom H1; pose cfJ w i := 'chi_(isom_Iirr (isoJ w) i). +pose thetaH (f : {ffun _}) := cfBigdprod defHbar (fun w => cfJ w (f w)). +pose theta f := cfDprodl defHCbar (thetaH f). +have abH1: abelian H1 by rewrite cyclic_abelian ?prime_cyclic ?oH1. +have linH1 i: 'chi[H1]_i \is a linear_char by apply/char_abelianP. +have lin_thetaH f: thetaH f \is a linear_char. + by apply: cfBigdprod_lin_char => w _; rewrite /cfJ isom_IirrE cfIsom_lin_char. +have nz_thetaH f: thetaH f 1%g != 0 by rewrite lin_char_neq0. +have Dtheta f: {in W1bar & H1, forall w xb, theta f (xb ^ w) = 'chi_(f w) xb}. + move=> w xb W1w H1xb /=; have sHHCb := quotientS H0 sHHC. + transitivity ('Res[H1 :^ w] ('Res[Hbar] (theta f)) (xb ^ w)); last first. + by rewrite cfDprodlK cfBigdprodKabelian // isom_IirrE cfIsomE. + by rewrite cfResRes ?sH1wH // cfResE ?memJ_conjg ?(subset_trans (sH1wH w _)). +have lin_theta f: theta f \is a linear_char by apply: cfDprodl_lin_char. +pose Ftheta := pffun_on (0 : Iirr H1) W1bar (predC1 0). +have inj_theta: {in Ftheta &, injective theta}. + move=> f1 f2 /pffun_onP[/supportP W1f1 _] /pffun_onP[/supportP W1f2 _] eq_f12. + apply/ffunP=> w. + have [W1w | W1'w] := boolP (w \in W1bar); last by rewrite W1f1 ?W1f2. + by apply/irr_inj/cfun_inP=> x H1x; rewrite -!Dtheta ?eq_f12. +have irr_thetaH0 f: (theta f %% H0)%CF \in irr HC. + by rewrite cfMod_irr ?lin_char_irr. +have def_Itheta f: f \in Ftheta -> 'I_HU[theta f %% H0]%CF = HC. + case/pffun_onP=> _ nz_fW1; apply/eqP; rewrite eqEsubset sub_Inertia //. + rewrite inertia_mod_pre //= -{1}(sdprodW defHU) -group_modl; last first. + rewrite (subset_trans sHHC) // -sub_quotient_pre ?normal_norm //. + by rewrite sub_Inertia ?quotientS. + rewrite -gen_subG genM_join genS ?setUS //= {2}[C]unlock setIS //= astabQ. + rewrite morphpreS // centsC -{1}(bigdprodWY defHbar) gen_subG. + apply/bigcupsP=> w W1w; rewrite centsC. + apply: subset_trans (sub_inertia_Res _ (quotient_norms _ nHHU)) _. + rewrite cfDprodlK inertia_bigdprod_irr // subIset // orbC (bigcap_min w) //. + rewrite (inertia_irr_prime _ p_pr) ?cardJg ?subsetIr // isom_Iirr_eq0. + by apply: nz_fW1; apply: image_f. +have irrXtheta f: f \in Ftheta -> 'Ind (theta f %% H0)%CF \in irr HU. + move/def_Itheta; rewrite -(cfIirrE (irr_thetaH0 f)) => I_f_HC. + by rewrite inertia_Ind_irr ?I_f_HC //. +pose Mtheta := [set cfIirr (theta f %% H0)%CF | f in Ftheta]. +pose Xtheta := [set cfIirr ('Ind[HU] 'chi_t) | t in Mtheta]. +have oXtheta: (u * #|Xtheta| = p.-1 ^ q)%N. + transitivity #|Ftheta|; last first. + rewrite card_pffun_on cardC1 card_Iirr_abelian // oH1. + rewrite -(card_isog (quotient_isog _ _)) ?oW1 ?(subset_trans sW1M) //. + by apply/trivgP; rewrite -tiHUW1 setSI ?(subset_trans sH0H). + rewrite Du -card_imset_Ind_irr ?card_in_imset //. + - move=> f1 f2 Df1 Df2 /(congr1 (tnth (irr HC))); rewrite !{1}cfIirrE //. + by move/(can_inj (cfModK nsH0HC)); apply: inj_theta. + - by move=> _ /imsetP[f Df ->]; rewrite cfIirrE ?irrXtheta. + move=> _ y /imsetP[f /familyP Ff ->] HUy; apply/imsetP. + pose yb := inMb y; have HUyb: yb \in (HU / H0)%g by apply: mem_quotient. + have nHb_y: inMb y \in 'N(Hbar) by rewrite (subsetP (quotient_norms _ nHHU)). + have nH1b_y := subsetP (nH1wHUb _ _) yb HUyb. + exists [ffun w => conjg_Iirr (f w) (inMb y ^ w^-1)]. + apply/familyP=> w; rewrite ffunE. + by case: ifP (Ff w) => _; rewrite !inE conjg_Iirr_eq0. + apply: irr_inj; rewrite !(cfIirrE, conjg_IirrE) // (cfConjgMod _ nsHC_HU) //. + rewrite cfConjgDprodl //; first congr (cfDprodl _ _ %% H0)%CF; last first. + rewrite /= -quotientYidl // (subsetP _ _ HUyb) ?quotient_norms //. + by rewrite (subset_trans sHUM) ?normal_norm. + rewrite cfConjgBigdprod //; apply: eq_bigr => w W1w; congr (cfBigdprodi _ _). + rewrite ffunE /cfJ !isom_IirrE conjg_IirrE. + apply/cfun_inP=> _ /imsetP[x Hx ->]; rewrite cfIsomE // cfConjgE ?nH1b_y //. + rewrite -conjgM conjgCV conjVg conjgM cfIsomE //; last first. + by rewrite -mem_conjg (normP _) // -mem_conjg -normJ ?nH1b_y. + by rewrite cfConjgE // -mem_conjg -normJ ?nH1b_y. +have sXthXH0C: Xtheta \subset X_ H0C. + apply/subsetP=> _ /imsetP[t Mt ->]; have{Mt} [f Ff Dt] := imsetP Mt. + rewrite !inE cfIirrE; last by rewrite Dt cfIirrE ?irrXtheta. + rewrite !sub_cfker_Ind_irr ?(subset_trans sHUM) ?normal_norm ?gFnormal //. + rewrite {t}Dt cfIirrE // join_subG andbCA {1}cfker_mod //. + rewrite !{1}sub_cfker_mod //= andbC {1}cfker_sdprod /=. + apply: contraL (familyP Ff 1%g) => kerHb; rewrite group1 negbK. + have:= sub_cfker_Res (subxx _) kerHb; rewrite cfDprodlK. + move/(subset_trans (sH1wH _ (group1 _)))/(sub_cfker_Res (subxx _)). + rewrite cfBigdprodKabelian // isom_IirrE cfker_isom morphim_conj /=. + by rewrite !conjsg1 subsetIidl subGcfker. +pose mu_f (i : Iirr H1) := [ffun w => if w \in W1bar then i else 0]. +have Fmu_f (i : Iirr H1): i != 0 -> mu_f i \in Ftheta. + by move=> nz_i; apply/familyP=> w; rewrite ffunE; case: ifP; rewrite !inE. +pose mk_mu i := 'Ind[HU] (theta (mu_f i) %% H0)%CF. +have sW1_Imu i: W1 \subset 'I[theta (mu_f i) %% H0]%CF. + apply/subsetP=> w W1w; have Mw := subsetP sW1M w W1w. + have nHC_W1 := subset_trans sW1M (normal_norm nsHC_M). + rewrite inE (subsetP nHC_W1) ?(cfConjgMod _ nsHC_M) //; apply/eqP. + have W1wb: inMb w \in W1bar by rewrite mem_quotient. + rewrite cfConjgDprodl ?(subsetP _ _ W1wb) ?quotient_norms //; last first. + by rewrite (subset_trans (joing_subr U W1)) ?normal_norm. + congr (cfDprodl _ _ %% H0)%CF. + apply/cfun_inP=> _ /(mem_bigdprod defHbar)[x [H1x -> _]]. + have Hx w1: w1 \in W1bar -> x w1 \in Hbar. + by move=> W1w1; rewrite (subsetP (sH1wH w1 _)) ?H1x. + rewrite !lin_char_prod ?cfConjg_lin_char //; apply/eq_bigr=> w1 W1w1. + rewrite cfConjgE ?(subsetP nHbW1) //. + have W1w1w: (w1 * (inMb w)^-1)%g \in W1bar by rewrite !in_group. + rewrite -(cfResE _ (sH1wH _ W1w1w)) -?mem_conjg -?conjsgM ?mulgKV ?H1x //. + rewrite -(cfResE _ (sH1wH _ W1w1)) ?H1x ?cfBigdprodKabelian //. + rewrite !ffunE W1w1 W1w1w -[x w1](conjgKV w1) -conjgM !isom_IirrE. + by rewrite !cfIsomE -?mem_conjg ?H1x. +have inj_mu: {in predC1 0 &, injective (fun i => cfIirr (mk_mu i))}. + move=> i1 i2 nz_i1 nz_i2 /(congr1 (tnth (irr HU))). + rewrite !{1}cfIirrE ?irrXtheta ?Fmu_f // /mk_mu. + do 2![move/esym; rewrite -{1}(cfIirrE (irr_thetaH0 _))]. + move/(cfclass_Ind_irrP _ _ nsHC_HU); rewrite !{1}cfIirrE //. + case/cfclassP=> _ /(mem_sdprod defHU)[x [y [Hx Uy -> _]]]. + rewrite (cfConjgM _ nsHC_HU) ?(subsetP sHHU x) ?(subsetP sUHU) //. + rewrite {x Hx}(cfConjg_id _ (subsetP sHHC x Hx)) => Dth1. + suffices /setIP[_ /inertiaJ]: y \in 'I_HU[theta (mu_f i2) %% H0]%CF. + rewrite -Dth1 => /(can_inj (cfModK nsH0HC))/inj_theta/ffunP/(_ 1%g). + by rewrite !ffunE group1 => -> //; apply: Fmu_f. + rewrite def_Itheta ?Fmu_f //= (subsetP (joing_subr _ _)) //. + have nCy: y \in 'N(C). + by rewrite (subsetP (normal_norm nsCUW1)) ?mem_gen ?inE ?Uy. + have [_ _ /trivgPn[wb W1wb ntwb] _ _] := Frobenius_context frobUW1c. + have /morphimP[w nCw W1w Dw] := W1wb; have Mw := subsetP sW1M w W1w. + rewrite coset_idr //; apply/set1P; rewrite -set1gE; apply: wlog_neg => nty. + rewrite -((Frobenius_reg_ker frobUW1c) wb); last by rewrite !inE ntwb. + rewrite inE mem_quotient //=; apply/cent1P/commgP. + rewrite Dw -morphR //= coset_id //. + suffices: [~ y, w] \in U :&: HC. + rewrite /= norm_joinEr ?(subset_trans sCU) // -group_modr ?subsetIl //=. + by rewrite setIC tiHU mul1g. + have Uyw: [~ y, w] \in U; last rewrite inE Uyw. + by rewrite {1}commgEl groupMl ?groupV // memJ_norm ?(subsetP nUW1) // Uy. + rewrite -(def_Itheta _ (Fmu_f _ nz_i1)) 2!inE /= andbA -in_setI. + rewrite (setIidPl (normal_norm nsHC_HU)) (subsetP sUHU) //=. + rewrite Dth1 -(cfConjgM _ nsHC_HU) ?(subsetP sUHU) //. + have My: y \in M := subsetP (subset_trans sUHU sHUM) y Uy. + rewrite mulKVg (cfConjgM _ nsHC_M) ?in_group //. + have /inertiaJ-> := subsetP (sW1_Imu i2) _ (groupVr W1w). + rewrite (cfConjgM _ nsHC_M) // -Dth1. + by have /inertiaJ-> := subsetP (sW1_Imu i1) w W1w. +pose Xmu := [set cfIirr (mk_mu i) | i in predC1 0]. +have def_IXmu: {in Xmu, forall s, 'I_M['chi_s] = M}. + move=> _ /imsetP[i nz_i ->]; apply/setIidPl. + rewrite -subsetIidl -{1}(sdprodW defM) mulG_subG sub_Inertia //. + rewrite !cfIirrE ?irrXtheta ?Fmu_f //=. + apply: subset_trans (sub_inertia_Ind _ (der_norm 1 M)). + by rewrite subsetI sW1M /=. +pose Smu := [seq 'Ind[M] 'chi_s | s in Xmu]. +have sSmu_mu: {subset Smu <= mu_}. + move=> _ /imageP[s Xmu_s ->]; rewrite mem_filter /=. + rewrite irrEchar cfnorm_Ind_irr ?gFnormal // def_IXmu //. + rewrite -(index_sdprod defM) (eqC_nat _ 1) gtn_eqF ?prime_gt1 // andbF. + rewrite mem_seqInd ?gFnormal /normal ?(subset_trans sH0H) ?gFsub //=. + suffices /(subsetP sXthXH0C): s \in Xtheta. + by apply: subsetP; rewrite setSD // Iirr_kerS ?joing_subl. + have /imsetP[i nz_i ->] := Xmu_s; rewrite /Xtheta -imset_comp. + by apply/imsetP; exists (mu_f i); rewrite /= ?cfIirrE ?Fmu_f. +have ResIndXmu: {in Xmu, forall s, 'Res ('Ind[M] 'chi_s) = q%:R *: 'chi_s}. + move=> s /def_IXmu Imu_s; rewrite cfResInd_sum_cfclass ?gFnormal ?Imu_s //. + by rewrite -(index_sdprod defM) -Imu_s cfclass_inertia big_seq1. +have uSmu: uniq Smu. + apply/dinjectiveP=> s1 s2 Xs1 Xs2 /(congr1 'Res[HU]); rewrite !ResIndXmu //. + by move/(can_inj (scalerK (neq0CG W1)))/irr_inj. +have sz_Smu: size Smu = p.-1. + by rewrite size_map -cardE card_in_imset // cardC1 card_Iirr_abelian ?oH1. +have [sz_mu s_mu_H0C] := nb_redM_H0. +have Dmu: Smu =i mu_. + by have [|//] := leq_size_perm uSmu sSmu_mu; rewrite sz_mu sz_Smu. +split=> {Part_a part_a}//. +- split=> // phi mu_phi; have S_HOC_phi := s_mu_H0C _ mu_phi. + move: mu_phi; rewrite -Dmu => /imageP[_ /imsetP[i nz_i ->]]. + rewrite cfIirrE ?irrXtheta ?Fmu_f // => Dphi. + split=> //; rewrite Dphi ?cfInd1 ?cfIndInd //. + rewrite -(index_sdprod defM) -/q -Du mulrA -natrM. + by rewrite lin_char1 1?cfMod_lin_char ?mulr1. + by exists (theta (mu_f i) %% H0)%CF; rewrite 1?cfMod_lin_char. +- have /eqVproper: Xmu \subset Xtheta. + apply/subsetP=> _ /imsetP[i nz_i ->]; rewrite -[Xtheta]imset_comp /=. + by apply/imsetP; exists (mu_f i); rewrite /= ?cfIirrE ?Fmu_f. + case=> [defXmu | /andP[_ /subsetPn[s theta_s Xmu'_s]]]; last first. + have [_ /imsetP[f Dth_f ->] Ds] := imsetP theta_s; rewrite cfIirrE // in Ds. + have /irrP[t Dt]: 'Ind 'chi_s \in irr M; last 1 [exists t; rewrite -{t}Dt]. + apply: contraR Xmu'_s => red_Ind_s. + have: 'Ind 'chi_s \in mu_. + rewrite mem_filter /= red_Ind_s mem_seqInd ?gFnormal //=. + apply: subsetP theta_s; rewrite (subset_trans sXthXH0C) ?setSD //. + by rewrite Iirr_kerS ?joing_subl. + rewrite -Dmu => /imageP[s1 Xmu_s1] /(congr1 (cfdot ('Ind 'chi_s1)))/eqP. + rewrite cfnorm_Ind_irr ?gFnormal // eq_sym -cfdot_Res_l. + rewrite ResIndXmu // cfdotZl cfdot_irr -natrM mulnC. + by case: (s1 =P s) => [<- // | _] /idPn[]; apply: neq0CiG. + split; first 2 [by rewrite mem_seqInd ?gFnormal ?(subsetP sXthXH0C)]. + rewrite Ds cfIirrE ?irrXtheta ?cfInd1 // -Du -(index_sdprod defM) -/q. + by rewrite mulrA -natrM lin_char1 ?cfMod_lin_char ?mulr1. + exists (theta f %% H0)%CF; first by rewrite cfMod_lin_char. + by rewrite Ds cfIirrE ?irrXtheta //= cfIndInd. + suffices /(congr1 odd): u = (p.-1 ^ q.-1)%N. + rewrite odd_exp -(subnKC (prime_gt1 pr_q)) /= -subn1 odd_sub ?prime_gt0 //. + by rewrite -oH1 (oddSg sH1H) ?quotient_odd // mFT_odd. + have p1_gt0: (0 < p.-1)%N by rewrite -(subnKC (prime_gt1 p_pr)). + apply/eqP; rewrite -(eqn_pmul2r p1_gt0) -expnSr prednK ?prime_gt0 //. + by rewrite -oXtheta -defXmu card_in_imset // cardC1 card_Iirr_abelian ?oH1. +clear Xmu def_IXmu Smu sSmu_mu ResIndXmu uSmu sz_Smu sz_mu s_mu_H0C Dmu. +clear Mtheta Xtheta irrXtheta oXtheta sXthXH0C mu_f Fmu_f mk_mu sW1_Imu inj_mu. +clear nz_thetaH lin_thetaH lin_theta Ftheta inj_theta irr_thetaH0 def_Itheta. +clear theta Dtheta => irr_qa lb_n lb_d. +have sU'U: U' \subset U := der_sub 1 U. +have nH0U := subset_trans sUHU nH0HU; have nH0U' := subset_trans sU'U nH0U. +have sU'CH1: U' \subset 'C_U(H1 | 'Q). + by rewrite subsetI sU'U sub_astabQ nH0U' (centsS sH1H) ?quotient_cents. +have sCH1_U: 'C_U(H1 | 'Q) \subset U := subsetIl U _. +have dvd_lb: lb_d %| lb_n. + rewrite -[lb_d]mulnA dvdn_mul // -(Lagrange sCH1_U). + by rewrite mulnC dvdn_pmul2r ?cardSg ?indexg_gt0. +split; rewrite ?leq_divLR // /lb_n -(Lagrange sCH1_U) -/a -(Lagrange sU'CH1). +rewrite mulnCA -mulnA mulnC !mulnA !leq_pmul2r ?cardG_gt0 ?indexg_gt0 // mulnC. +pose H1CH1 := (H1 <*> 'C_(U / H0)(H1))%G; pose HCH1 := (H <*> 'C_U(H1 | 'Q))%G. +have defH1CH1: H1 \x 'C_(U / H0)(H1) = H1CH1. + rewrite dprodEY ?subsetIr ?coprime_TIg ?(coprimeSg sH1H) //. + by rewrite (coprimegS (subsetIl _ _)) ?coprime_morph. +have sHCH1_HU: HCH1 \subset HU by rewrite join_subG sHHU (subset_trans sCH1_U). +have nsHCH1_HU: HCH1 <| HU. + rewrite /normal sHCH1_HU -(sdprodW defHU) mulG_subG normsG ?joing_subl //=. + by rewrite normsY // sub_der1_norm. +have nsH0_HCH1: H0 <| HCH1. + by rewrite (normalS _ sHCH1_HU) // (subset_trans sH0H) ?joing_subl. +have nsH1cHU: H1c <| HU / H0. + rewrite -(bigdprodWY defH1c) /normal gen_subG norms_gen ?andbT //. + by apply/bigcupsP=> w /setD1P[_ /nsH1wHUb/andP[]]. + by apply/norms_bigcup/bigcapsP=> w /setD1P[_ /nH1wHUb]. +have defHCH1: H1c ><| H1CH1 = (HCH1 / H0)%G. + have /sdprodP[_ /mulG_sub[sH1cH _] nH1cH1 tiH1cH1] := dprodWsdC defHb1. + rewrite sdprodE /= -(dprodW defH1CH1). + - rewrite mulgA (dprodWC defHb1) -morphim_setIpre -astabQ -quotientMl //. + by rewrite norm_joinEr // (subset_trans sCH1_U). + - rewrite mul_subG ?subIset // (subset_trans (quotientS _ sUHU)) //. + exact: normal_norm nsH1cHU. + rewrite -(setIidPl sH1cH) setIAC -setIA -group_modl // coprime_TIg ?mulg1 //. + by rewrite coprime_sym (coprimegS (subsetIl _ _)) ?coprime_morph. +have [nsH1cHCH1 sH1CH1_HCH1 _ nH1cH1C _] := sdprod_context defHCH1. +pose Clam := ('C_(U / H0)(H1) / (U' / H0))%G. +pose lam (j : Iirr Clam) := 'chi_(mod_Iirr j). +pose theta i j := cfSdprod defHCH1 (cfDprod defH1CH1 'chi_i (lam j)). +have nsU'CH1: U' <| 'C_U(H1 | 'Q) by rewrite (normalS _ sCH1_U) ?gFnormal. +have nsU'CH1b: U' / H0 <| 'C_(U / H0)(H1). + by rewrite -morphim_setIpre -astabQ quotient_normal. +have abClam: abelian Clam. + by rewrite sub_der1_abelian //= quotient_der ?dergS ?subsetIl. +have lam_lin j: lam j \is a linear_char. + by rewrite /lam mod_IirrE ?cfMod_lin_char //; apply/char_abelianP. +have theta_lin i j: theta i j \is a linear_char. + by rewrite cfSdprod_lin_char ?cfDprod_lin_char. +have <-: #|Clam| = #|'C_U(H1 | 'Q) : U'|. + rewrite -card_quotient ?normal_norm //= /= -morphim_setIpre -astabQ. + have nsU'U : U' <| U by apply: der_normal. + rewrite -(restrmEsub _ _ sCH1_U) -(restrm_quotientE _ sU'U) -morphim_quotm. + rewrite card_injm ?quotientS ?injm_quotm ?(isom_inj (quotient_isom _ _)) //. + by rewrite coprime_TIg ?(coprimeSg sH0H). +pose Mtheta := [set mod_Iirr (cfIirr (theta i j)) | i in [set~ 0], j in setT]. +have ->: (p.-1 * #|Clam|)%N = #|Mtheta|. + rewrite [Mtheta]curry_imset2X card_imset ?cardsX => [|[i1 j1] [i2 j2] /=/eqP]. + by rewrite cardsC1 cardsT !card_Iirr_abelian ?(abelianS sH1H) ?oH1. + rewrite (can_eq (mod_IirrK _)) // -(inj_eq irr_inj) !cfIirrE ?lin_char_irr //. + rewrite (can_eq (cfSdprodK _)) -!dprod_IirrE (inj_eq irr_inj). + by rewrite (can_eq (dprod_IirrK _)) => /eqP[->] /(can_inj (mod_IirrK _))->. +have{lam_lin} thetaH1 i j: 'Res[H1] (theta i j) = 'chi_i. + rewrite -(cfResRes _ _ sH1CH1_HCH1) ?joing_subl // cfSdprodK cfDprodKl //. + exact: lin_char1. +have Itheta r: r \in Mtheta -> 'I_HU['chi_r]%CF = HCH1. + case/imset2P=> i j; rewrite /= in_setC1 => nz_i _ Dr; apply/eqP. + rewrite eqEsubset sub_Inertia //= Dr mod_IirrE // cfIirrE ?lin_char_irr //. + rewrite andbT -(quotientSGK _ (normal_sub nsH0_HCH1)) ?subIset ?nH0HU //. + rewrite inertia_mod_quo //. + apply: subset_trans (sub_inertia_Res _ (nH1wHUb _ (group1 _))) _. + rewrite /= conjsg1 thetaH1 (inertia_irr_prime _ p_pr) //. + rewrite -quotient_setIpre -astabQ quotientS // -{1}(sdprodW defHU). + by rewrite -genM_join sub_gen // group_modl // sub_astabQ nH0H (centsS sH1H). +have irr_Xtheta: {in Mtheta, forall r, 'Ind[HU] 'chi_r \in irr HU}. + by move=> r Mr; rewrite /= inertia_Ind_irr ?Itheta. +pose Xtheta := [set cfIirr ('Ind[HU] 'chi_r) | r in Mtheta]. +have Da: a = #|HU : HCH1| by rewrite -(index_sdprodr defHU). +have Xtheta_1: {in Xtheta, forall s, 'chi_s 1%g = a%:R}. + move=> _ /imsetP[r Mr ->]; have /imset2P[i j _ _ Dr] := Mr. + rewrite cfIirrE ?irr_Xtheta ?cfInd1 //= -Da lin_char1 ?mulr1 //. + by rewrite Dr mod_IirrE ?cfMod_lin_char // cfIirrE ?lin_char_irr. +have nsH0U'HU: H0U' <| HU. + by apply: normalS nsH0U'_M; rewrite // -(sdprodWY defHU) genS ?setUSS. +have sXthetaXH0U': Xtheta \subset X_ H0U'. + apply/subsetP=> _ /imsetP[r Mr ->]; have [i j nz_i _ Dr] := imset2P Mr. + rewrite !inE cfIirrE ?irr_Xtheta ?sub_cfker_Ind_irr //= ?normal_norm //. + rewrite Dr mod_IirrE // cfIirrE ?lin_char_irr // join_subG andbCA. + rewrite {1}cfker_mod //= !{1}sub_cfker_mod //; apply/andP; split; last first. + rewrite -(sdprodWY (sdprod_cfker _ _)) sub_gen ?subsetU // orbC. + rewrite (subset_trans _ (cfker_dprod _ _ _)) // sub_gen ?subsetU // orbC. + by rewrite /lam mod_IirrE ?cfker_mod. + apply: contraL nz_i => /(subset_trans sH1H); rewrite !inE negbK. + by move/(sub_cfker_Res (subxx _)); rewrite thetaH1 subGcfker. +have nsCH1_U: 'C_U(H1 | 'Q) <| U by rewrite sub_der1_normal. +have nH1cU: (U / H0)%g \subset 'N(H1c). + rewrite -(bigdprodWY defH1c) norms_gen ?norms_bigcup //. + apply/bigcapsP=> w /setD1P[_ W1w]. + by rewrite normJ -sub_conjgV (normsP (quotient_norms H0 nUW1)) ?groupV. +have ->: #|Mtheta| = (#|Xtheta| * a)%N. + rewrite Da mulnC -card_imset_Ind_irr // => _ xy /imset2P[i j nz_i _ ->]. + case/(mem_sdprod defHU)=> x [y [Hx Uy -> _]]; have HUy := subsetP sUHU y Uy. + pose yb := inMb y; have Uyb: yb \in (U / H0)%g by rewrite mem_quotient. + pose iy := conjg_Iirr i yb; pose jy := conjg_Iirr j (coset (U' / H0)%g yb). + apply/imset2P; exists iy jy; rewrite !inE ?conjg_Iirr_eq0 // in nz_i *. + apply: irr_inj; have HCH1x: x \in HCH1 by rewrite mem_gen ?inE ?Hx. + rewrite conjg_IirrE (cfConjgM _ nsHCH1_HU) ?(subsetP sHHU x) {Hx}//. + rewrite {x HCH1x}(cfConjg_id _ HCH1x) !{1}mod_IirrE //. + rewrite !{1}cfIirrE ?lin_char_irr //. + rewrite cfConjgMod_norm ?(subsetP nH0U) ?(subsetP (normal_norm nsHCH1_HU)) //. + have nCH1_Ub: (U / H0)%g \subset 'N('C_(U / H0)(H1)). + by rewrite normsI ?normG ?norms_cent. + rewrite cfConjgSdprod ?cfConjgDprod ?(subsetP _ _ Uyb) ?normsY //. + rewrite /theta /lam !{1}mod_IirrE // !{1}conjg_IirrE. + by rewrite cfConjgMod_norm ?(subsetP _ _ Uyb) // quotient_norms ?gFnorm. +rewrite leq_pmul2r ?indexg_gt0 // cardE -(size_map (fun s => 'Ind[M] 'chi_s)). +have kerH1c s: s \in Xtheta -> H1c \subset (cfker 'chi_s / H0)%g. + case/imsetP=> r Mr ->; have [i j _ _ Dr] := imset2P Mr. + rewrite -(setIidPr (normal_sub nsH1cHCH1)) -morphim_setIpre quotientS //. + rewrite cfIirrE ?irr_Xtheta ?sub_cfker_Ind_irr //; last first. + by rewrite normsI ?normal_norm // -(quotientGK nsH0_HU) cosetpre_normal. + rewrite Dr mod_IirrE // cfker_morph ?normal_norm // cfIirrE ?lin_char_irr //. + by rewrite setIS ?joing_subl ?morphpreS // cfker_sdprod. +have injXtheta: + {in M & Xtheta &, forall w s1 s2, 'chi_s1 = 'chi_s2 ^ w -> w \in HU}%CF. +- move=> _ s1 s2 /(mem_sdprod defM)[y [w [HUy W1w -> _]]] Xs1 Xs2. + rewrite groupMl // cfConjgMnorm ?(subsetP (normG _) y) ?(subsetP nHUW1) //. + rewrite {y HUy}(cfConjg_id _ HUy) => Ds1. + have nH0w: w \in 'N(H0) by rewrite ?(subsetP nH0M) ?(subsetP sW1M). + rewrite (subsetP (normal_sub nsH0_HU)) // coset_idr //. + have /setDP[]:= subsetP sXthetaXH0U' s1 Xs1; rewrite !inE join_subG /=. + case/andP=> kerH0s1 _; apply: contraNeq; rewrite -eq_invg1 => ntw. + rewrite -(quotientSGK nH0H) // -(dprodW defHb1) mul_subG ?kerH1c //=. + rewrite Ds1 cfker_conjg ?(subsetP nHUW1) // quotientJ // -sub_conjgV. + rewrite (subset_trans _ (kerH1c s2 Xs2)) // -(bigdprodWY defH1c) sub_gen //. + by rewrite (bigcup_max (inMb w)^-1%g) // !inE ntw groupV mem_quotient. +rewrite -size_filter uniq_leq_size //. + apply/dinjectiveP=> s1 s2 Xs1 Xs2. + case/(cfclass_Ind_irrP _ _ (der_normal 1 M))/cfclassP=> y My Ds2. + by apply: irr_inj; rewrite Ds2 cfConjg_id ?(injXtheta y s1 s2). +move=> _ /imageP[s Xs ->]; rewrite mem_filter /= cfInd1 // -(index_sdprod defM). +rewrite Xtheta_1 // -natrM eqxx mem_seqInd ?gFnormal //. +rewrite (subsetP sXthetaXH0U') // !andbT inertia_Ind_irr ?gFnormal //. +by apply/subsetP=> y /setIP[My /inertiaJ/esym/injXtheta->]. +Qed. + +Import ssrnum Num.Theory. + +(* This is Peterfalvi (9.9); we have exported the fact that HU / H0 is a *) +(* Frobenius group in case (c), as this is directly used in (9.10). *) +Lemma typeP_Galois_characters (is_Galois : typeP_Galois) : + [/\ (*a*) {in X_ H0, forall s, (u %| 'chi_s 1%g)%Cx}, + {in X_ H0C', forall s, 'chi_s 1%g = u%:R /\ + (exists2 xi : 'CF(HC), xi \is a linear_char & 'chi_s = 'Ind xi)}, + (*b*) size mu_ = p.-1 /\ {in mu_, forall mu_j, isIndHC mu_j} + & (*c*) all redM (S_ H0C') -> + [/\ C :=: 1%g, u = (p ^ q).-1 %/ p.-1 + & [Frobenius HU / H0 = Hbar ><| (U / H0)]]]. +Proof. +have [F [phi [psi _ [Kpsi phiJ]]]] := typeP_Galois_P is_Galois. +case=> [oF /isomP[inj_phi im_phi] phiW2] [cycUbar co_u_p1 u_dv_pq1]. +have [nsHUM sW1M /mulG_sub[sHUM _] nHUW1 tiHUW1] := sdprod_context defM. +have [nsHHU sUHU /mulG_sub[sHHU _] nHU tiHU] := sdprod_context defHU. +have [nsH0C_M nsHC_M _ nsH0C'_M] := nsH0xx_M; have nH0H := normal_norm nsH0H. +have nsH0HU: H0 <| HU := normalS (subset_trans sH0H sHHU) sHUM nsH0M. +have nH0U: U \subset 'N(H0) := subset_trans sUHU (normal_norm nsH0HU). +have nH0C := subset_trans sCU nH0U. +have sH0C_HU: H0C \subset HU by rewrite -(sdprodWY defHU) genS ?setUSS. +have nsH0C_HU: H0C <| HU := normalS sH0C_HU sHUM nsH0C_M. +have nH0C_HU := normal_norm nsH0C_HU. +have [coH0U coHC] := (coprimeSg sH0H coHU, coprimegS sCU coHU). +have [nH0C_H nH0C_U] := (subset_trans sHHU nH0C_HU, subset_trans sUHU nH0C_HU). +have tiHOC_H: H0C :&: H = H0. + by rewrite /= norm_joinEr // -group_modl // setIC coprime_TIg ?mulg1. +have{coH0U} tiHOC_U: H0C :&: U = C. + by rewrite /= norm_joinEr // setIC -group_modr // setIC coprime_TIg ?mul1g. +have isoHbar: Hbar \isog H / H0C. + by have:= second_isog nH0C_H; rewrite tiHOC_H. +have isoUbar: Ubar \isog U / H0C. + by have:= second_isog nH0C_U; rewrite tiHOC_U. +have frobHU: [Frobenius HU / H0C = (H / H0C) ><| (U / H0C)]. + have defHUbar: (H / H0C) ><| (U / H0C) = (HU / H0C)%g. + exact: quotient_coprime_sdprod. + apply/Frobenius_semiregularP=> //; first by rewrite -(isog_eq1 isoHbar). + by rewrite -(isog_eq1 isoUbar); have [] := Frobenius_context frobUW1c. + move=> yb /setD1P[ntyb /morphimP[y nH0Cy Uy] Dyb] /=; rewrite Dyb. + apply/trivgP/subsetP=> _ /setIP[/morphimP[/= x nHOCx Hx ->] /cent1P/commgP]. + rewrite -morphR //; set xy := [~ x, y] => /eqP/coset_idr/=H0Cxy. + have [nH0x nH0y] := (subsetP nH0H x Hx, subsetP nH0U y Uy). + rewrite inE coset_id ?mem_gen // inE coset_idr //; apply: contraNeq ntyb. + rewrite -(morph_injm_eq1 inj_phi) ?mem_quotient // => nz_x. + rewrite {yb}Dyb /= coset_id ?mem_gen // -Kpsi !inE Uy orbC /= -val_eqE. + rewrite -(inj_eq (mulfI nz_x)) mulr1 -[_ * _]phiJ ?mem_quotient // qactJ nH0y. + rewrite -morphJ // conjg_mulR -/xy mkerr ?eqxx // ker_coset -tiHOC_H inE. + by rewrite andbC groupM ?groupV ?memJ_norm ?(subsetP nHU) //= H0Cxy ?groupR. +have{coHC} tiHbC: (Hbar :&: C / H0 = 1)%g by rewrite coprime_TIg ?coprime_morph. +have{tiHbC} defHCbar: Hbar \x (C / H0) = (HC / H0)%g. + by rewrite dprodEY ?quotientY // [C]unlock/= astabQ quotient_setIpre subsetIr. +have sHCHU: HC \subset HU by rewrite -(sdprodWY defHU) genS ?setUS. +have nsHCHU: HC <| HU := normalS sHCHU sHUM nsHC_M. +have sH0HC: H0 \subset HC := subset_trans sH0H (joing_subl H C). +have nsH0HC: H0 <| HC := normalS sH0HC sHCHU nsH0HU. +have nsHHUb: Hbar <| HU / H0 by rewrite quotient_normal. +have I_XH0_C i: i != 0 -> 'I_HU['chi[Hbar]_i %% H0]%CF = HC. + move=> /= nz_i; apply/esym/eqP. + have nsCHUb: C / H0 <| HU / H0 by rewrite -quotientYidl ?quotient_normal. + have sH0C_HC: H0C \subset HC by rewrite genS ?setSU. + have nsH0C_HC: H0C <| HC := normalS sH0C_HC sHCHU nsH0C_HU. + have [j Dj]: exists j, 'chi_j = (cfDprodl defHCbar 'chi_i %% H0)%CF. + by rewrite -dprodl_IirrE -mod_IirrE //; set j := mod_Iirr _; exists j. + have kerH0Cj: H0C \subset cfker 'chi_j. + by rewrite Dj sub_cfker_mod ?join_subG ?normG // quotientYidl ?cfker_sdprod. + rewrite inertia_mod_pre // -(inertia_dprodl defHCbar) ?normal_norm //. + rewrite -inertia_mod_pre // -Dj eqEsubset sub_Inertia //=. + rewrite -(quotientSGK _ sH0C_HC) ?subIset ?nH0C_HU -?inertia_quo //. + rewrite -(quotientYidr nH0C_H) joingA (joing_idPl sH0H) in frobHU. + rewrite -?quo_IirrE ?(inertia_Frobenius_ker (FrobeniusWker frobHU)) //. + by rewrite quo_Iirr_eq0 // -irr_eq1 Dj cfMod_eq1 // cfDprodl_eq1 irr_eq1. +have{I_XH0_C} irr_IndHC r: r \in Iirr_kerD HC H H0 -> 'Ind 'chi_r \in irr HU. + rewrite !inE => /andP[ker'H kerH0]; apply: inertia_Ind_irr => //. + apply: subset_trans (sub_inertia_Res _ (normal_norm nsHHU)) _. + rewrite -{kerH0}(quo_IirrK _ kerH0) // mod_IirrE // in ker'H *. + have /codomP[[i j] Dr] := dprod_Iirr_onto defHCbar (quo_Iirr H0 r). + rewrite {r}Dr dprod_IirrE cfResMod ?joing_subl ?sub_cfker_mod //= in ker'H *. + rewrite cfDprod_Resl linearZ inertia_scale_nz ?irr1_neq0 ?I_XH0_C //. + by apply: contraNneq ker'H => ->; rewrite irr0 cfDprod_cfun1l cfker_sdprod. +have [nb_mu H0C_mu] := nb_redM_H0; set part_a' := ({in X_ H0C', _}). +have Part_a s: s \in X_ H0 -> exists r, 'chi_s = 'Ind[HU, HC] 'chi_r. + rewrite !inE => /andP[Ks'H KsH0]; have [r sHCr] := constt_cfRes_irr HC s. + have{KsH0} KrH0: H0 \subset cfker 'chi_r. + by rewrite (sub_cfker_constt_Res_irr sHCr) // ?normal_norm. + have{Ks'H} Kr'H: ~~ (H \subset cfker 'chi_r). + by rewrite (sub_cfker_constt_Res_irr sHCr) ?joing_subl // ?normal_norm. + have [|s1 Ds1] := irrP _ (irr_IndHC r _); first by rewrite !inE Kr'H. + rewrite -constt_Ind_Res Ds1 constt_irr inE in sHCr. + by rewrite (eqP sHCr) -Ds1; exists r. +have [nH0HC nH0C'] := (normal_norm nsH0HC, subset_trans (der_sub 1 _) nH0C). +have Part_a': part_a'. + move=> s /setDP[KsH0C' Ks'H]; have [|r Ds] := Part_a s. + by rewrite inE Ks'H (subsetP (Iirr_kerS _ _) _ KsH0C') ?joing_subl. + suffices lin_r: 'chi_r \is a linear_char. + by split; [rewrite Du Ds cfInd1 ?lin_char1 ?mulr1 | exists 'chi_r]. + have KrH0C': H0C' \subset cfker 'chi_r. + rewrite inE Ds sub_cfker_Ind_irr // in KsH0C'. + by rewrite (subset_trans sHUM) ?normal_norm. + rewrite lin_irr_der1 (subset_trans _ KrH0C') //= (norm_joinEr nH0C'). + rewrite -quotientSK ?(subset_trans (der_sub 1 _)) ?quotient_der //= -/C. + by rewrite -(der_dprod 1 defHCbar) (derG1P abHbar) dprod1g. +split=> // [s /Part_a[r ->] | | {Part_a' part_a'}red_H0C']. +- by rewrite Du cfInd1 // dvdC_mulr // Cint_Cnat ?Cnat_irr1. +- split=> // mu_j /H0C_mu H0C_mu_j; have [s XH0Cs Dmuj] := seqIndP H0C_mu_j. + have [|s1u [xi lin_xi Ds]] := Part_a' s. + by rewrite (subsetP _ _ XH0Cs) ?Iirr_kerDS // genS ?setUS ?der_sub. + split=> //; first by rewrite Dmuj cfInd1 // s1u -natrM -(index_sdprod defM). + by rewrite Dmuj Ds cfIndInd //; exists xi. +have C1: C :=: 1%g. + apply: contraTeq red_H0C' => ntC; apply/allPn. + have sCM: C \subset M := subset_trans sCU (subset_trans sUHU sHUM). + have{sCM} solCbar: solvable (C / H0). + by rewrite quotient_sol ?(solvableS sCM) ?mmax_sol. + have [|{ntC solCbar} j lin_j nz_j] := solvable_has_lin_char _ solCbar. + rewrite -(isog_eq1 (quotient_isog _ _)) ?(subset_trans sCU) //. + by rewrite coprime_TIg ?(coprimegS sCU) ?(coprimeSg sH0H). + have [i lin_i nz_i] := solvable_has_lin_char ntHbar solHbar. + pose r := mod_Iirr (dprod_Iirr defHCbar (i, j)). + have KrH0: H0 \subset cfker 'chi_r by rewrite mod_IirrE ?cfker_mod. + have Kr'H: ~~ (H \subset cfker 'chi_r). + rewrite -subsetIidl -cfker_Res ?joing_subl ?irr_char // mod_IirrE //. + rewrite cfResMod ?joing_subl // sub_cfker_mod // dprod_IirrE. + by rewrite cfDprodKl ?lin_char1 // subGcfker -irr_eq1. + have [|s Ds] := irrP _ (irr_IndHC r _); first by rewrite !inE Kr'H. + have Ks'H: s \notin Iirr_ker HU H. + by rewrite inE -Ds sub_cfker_Ind_irr ?normal_norm. + exists ('Ind 'chi_s). + rewrite mem_seqInd ?gFnormal // inE Ks'H inE -Ds. + rewrite sub_cfker_Ind_irr // ?(subset_trans sHUM) ?normal_norm //=. + rewrite mod_IirrE // join_subG cfker_mod // sub_cfker_mod ?quotient_der //. + apply: subset_trans (dergS 1 (quotientS H0 (joing_subr H C))) _. + by rewrite -lin_irr_der1 dprod_IirrE cfDprod_lin_char. + apply: contra nz_j => red_j; have /implyP := H0C_mu ('Ind 'chi_s). + rewrite mem_filter red_j !mem_seqInd ?gFnormal // !in_setD Ks'H !inE -Ds. + rewrite irr_eq1 !sub_cfker_Ind_irr ?(normal_norm nsH0HU) //. + rewrite mod_IirrE // join_subG cfker_mod //= sub_cfker_mod // dprod_IirrE. + by move/(sub_cfker_Res (subxx _)); rewrite cfDprodKr ?lin_char1 ?subGcfker. +rewrite /= -/C C1 joingG1 in frobHU; split=> //; move/FrobeniusWker in frobHU. +have nsHbHU: Hbar <| (HU / H0) by rewrite quotient_normal. +have ->: (p ^ q).-1 = (#|X_ H0| * u)%N. + rewrite -oF -cardsT -im_phi card_injm // -(card_Iirr_abelian abHbar). + rewrite -(cardsC1 0) (card_imset_Ind_irr nsHbHU) => [|i|i y]; last first. + - by rewrite !inE conjg_Iirr_eq0. + - by rewrite !inE => nz_i; rewrite inertia_Ind_irr ?inertia_Frobenius_ker. + rewrite index_quotient_eq ?(subset_trans sHUM) ?subIset ?sH0H ?orbT //. + apply/eqP; rewrite Du /= C1 joingG1 mulnC eqn_pmul2r //. + rewrite -(card_imset _ (can_inj (mod_IirrK _))) // -imset_comp. + apply/eqP/eq_card=> s; apply/imsetP/idP=> [[i nz_i -> /=] | Xs]. + rewrite !inE mod_IirrE 1?{1}cfker_mod // andbT in nz_i *. + rewrite cfIirrE ?inertia_Ind_irr ?inertia_Frobenius_ker // sub_cfker_mod //. + by rewrite sub_cfker_Ind_irr ?quotientS ?normal_norm // subGcfker. + have [[]] := (Part_a s Xs, setDP Xs). + rewrite /= C1 joingG1 !inE => r Ds [kerH0s]. + have:= kerH0s; rewrite Ds !sub_cfker_Ind_irr ?normal_norm // => kerH0 ker'H. + exists (quo_Iirr H0 r). + by rewrite !inE -subGcfker quo_IirrE // cfker_quo ?quotientSGK. + by rewrite quo_IirrE // cfIndQuo // -Ds -quo_IirrE // irrK quo_IirrK. +suffices ->: #|X_ H0| = p.-1 by rewrite -(subnKC (prime_gt1 p_pr)) mulKn. +rewrite -nb_mu (size_red_subseq_seqInd_typeP MtypeP _ H0C_mu) //; last first. +- exact/allP/filter_all. +- by rewrite filter_uniq ?seqInd_uniq. +apply/esym/eq_card => i; rewrite inE mem_filter mem_seqInd ?gFnormal //. +rewrite andb_idl // => Xi; rewrite (allP red_H0C') //. +by rewrite mem_seqInd ?gFnormal //= C1 (trivgP (der_sub 1 _)) joingG1. +Qed. + +(* This combination of (9.8)(b) and (9.9)(b) covers most uses of these lemmas *) +(* in sections 10-14. *) +Lemma typeP_reducible_core_Ind (ptiWM := FT_primeTI_hyp MtypeP) : + [/\ size mu_ = p.-1, has predT mu_, + {subset mu_ <= [seq primeTIred ptiWM j | j in predC1 0]} + & {in mu_, forall mu_j, isIndHC mu_j}]. +Proof. +have [[sz_mu _] /mulG_sub[sHHU _]] := (nb_redM_H0, sdprodW defHU). +rewrite has_predT sz_mu -subn1 subn_gt0 prime_gt1 //; split=> // [mu_j|]. + rewrite mem_filter => /andP[red_chi /seqIndP[s /setDP[_ kerH's] Dchi]]. + have [[j Ds] | [/idPn[]]] := prTIres_irr_cases ptiWM s; last by rewrite -Dchi. + rewrite Dchi Ds cfInd_prTIres image_f ?inE //=. + by apply: contraNneq kerH's => j0; rewrite inE Ds j0 prTIres0 cfker_cfun1. +have[/typeP_Galois_characters[_ _ []] // | Gal'M] := boolP typeP_Galois. +by have [_ []] := typeP_nonGalois_characters Gal'M. +Qed. + +(* This is Peterfalvi (9.10), formulated as a constructive alternative. *) +Lemma typeP_reducible_core_cases : + {t : Iirr M & 'chi_t \in S_ H0C' /\ 'chi_t 1%g = (q * u)%:R + & {xi | xi \is a linear_char & 'chi_t = 'Ind[M, HC] xi}} + + [/\ typeP_Galois, [Frobenius HU / H0 = Hbar ><| (U / H0)], + cyclic U, #|U| = (p ^ q).-1 %/ p.-1 + & FTtype M == 2 -> [Frobenius HU = H ><| U]]. +Proof. +have [GalM | Gal'M] := boolP typeP_Galois; last first. + pose eqInHCb nu r := ('chi_r \is a linear_char) && (nu == 'Ind[M, HC] 'chi_r). + pose isIndHCb (nu : 'CF(M)) := + (nu 1%g == (q * u)%:R) && [exists r, eqInHCb nu r]. + suffices /sig2W[t H0C't]: exists2 t, 'chi_t \in S_ H0C' & isIndHCb 'chi_t. + case/andP=> /eqP t1qu /exists_inP/sig2W[r lin_r /eqP def_t]. + by left; exists t => //; exists 'chi_r. + have [_ _ [t [t1qu H0Ct IndHCt]] _] := typeP_nonGalois_characters Gal'M. + exists t; first by rewrite (seqIndS _ H0Ct) ?Iirr_kerDS ?genS ?setUS ?der_sub. + rewrite /isIndHCb t1qu eqxx; have [xi lin_xi ->] := IndHCt. + by apply/exists_inP; exists (cfIirr xi); rewrite cfIirrE ?lin_char_irr. +have [_ IndHC_SH0C' _] := typeP_Galois_characters GalM; rewrite all_predC. +case: hasP => [/sig2W[eta H0C'eta /irrP/sig_eqW[t Dt]] _ | _ [//|C1 <- frobHU]]. + have /sig2_eqW[s /IndHC_SH0C'[s1u IndHCs] Deta] := seqIndP H0C'eta. + have [joinHU [xi lin_xi Ds]] := (sdprodWY defHU, sig2_eqW IndHCs). + left; exists t; first split; rewrite -Dt // Deta. + by rewrite cfInd1 ?der_sub // -(index_sdprod defM) s1u -natrM. + by exists xi; rewrite ?Ds ?cfIndInd ?der_sub // -joinHU genS ?setUS ?subsetIl. +have cycU: cyclic U. + rewrite (isog_cyclic (quotient1_isog _)) -C1. + by have [_ _ []] := typeP_Galois_P GalM. +right; split=> //; first by rewrite /u /Ubar C1 -(card_isog (quotient1_isog _)). +case/(compl_of_typeII maxM MtypeP) => /= _ _ _ UtypeF <-. +have [_ -> _] := typeF_context UtypeF. +by apply/forall_inP=> S /and3P[_ /cyclicS->]. +Qed. + +Import ssrint. + +(* This is Peterfalvi (9.11) *) +(* We had to cover a small gap in step (9.11.4) of the proof, which starts by *) +(* proving that U1 \subset {1} u A(M), then asserts this obviously implies *) +(* HU1 \subset {1} u A(M). It is not, as while {1} u A(M) does contain H, it *) +(* is not (necessarily) a subgroup. We had to use the solvability of HU1 in a *) +(* significant way (using Philip Hall's theorems) to bridge the gap; it's *) +(* also possible to exploit lemma (2.1) (partition_cent_rcoset in PFsection1) *) +(* in a slightly different argument, but the inference is nontrivial in *) +(* either case. *) +Lemma Ptype_core_coherence : coherent (S_ H0C') M^# tau. +Proof. +have [nsHUM sW1M /mulG_sub[sHUM _] nHUW1 tiHUW1] := sdprod_context defM. +have [nsHHU sUHU /mulG_sub[sHHU _] nHU tiHU] := sdprod_context defHU. +have nsCU: C <| U := normalS sCU (joing_subl _ _) nsCUW1. +have [_ nCU] := andP nsCU; have sC'C: C^`(1)%g \subset C := der_sub 1 _. +have coHC := coprimegS sCU coHU; have coH0C := coprimeSg sH0H coHC. +have [nsH0C_M nsHC_M nsH0U'_M nsH0C'_M] := nsH0xx_M; have [_ nH0H]:= andP nsH0H. +have nH0HU := subset_trans sHUM nH0M; have nH0U := subset_trans sUHU nH0HU. +have nH0C := subset_trans sCU nH0U; have nH0C' := subset_trans sC'C nH0C. +have sHCHU: HC \subset HU by rewrite join_subG sHHU (subset_trans sCU). +have [nsHCHU nHC] := (normalS sHCHU sHUM nsHC_M, subset_trans sCU nHU). +have tiHCbar: Hbar :&: (C / H0)%g = 1%g by rewrite coprime_TIg ?coprime_morph. +have defHCbar: Hbar \x (C / H0) = (HC / H0)%g. + by rewrite dprodEY ?quotientY // [C]unlock/= astabQ quotient_setIpre subsetIr. +have{tiHCbar} defHC'bar: (HC / H0)^`(1)%g = (C^`(1) / H0)%g. + by rewrite -(der_dprod 1 defHCbar) (derG1P abHbar) dprod1g quotient_der. +have sU'U := der_sub 1 U; have nH0U' := subset_trans sU'U nH0U. +have sU'C: U' \subset C. + by rewrite [C]unlock subsetI sub_astabQ sU'U nH0U' quotient_cents. +have uS0: uniq (S_ H0C') by apply: seqInd_uniq. +have [rmR scohS0]: exists R : 'CF(M) -> seq 'CF(G), subcoherent (S_ H0C') tau R. + move: (FTtypeP_coh_base _ _) (FTtypeP_subcoherent maxM MtypeP) => R scohR. + exists R; apply: (subset_subcoherent scohR). + split=> //; last exact: cfAut_seqInd. + by apply: seqIndS; rewrite Iirr_kerDS ?sub1G ?Fcore_sub_FTcore. +have [GalM | Gal'M] := boolP typeP_Galois. + have [_ XOC'u _ _] := typeP_Galois_characters GalM. + apply: uniform_degree_coherence scohS0 _. + apply: all_pred1_constant (#|M : HU| * u)%:R _ _; rewrite all_map. + by apply/allP=> _ /seqIndP[s /XOC'u[s1u _] ->] /=; rewrite natrM cfInd1 ?s1u. +have:= typeP_nonGalois_characters Gal'M. +set U1 := 'C_U(_ | _); set a := #|_ : _|. +case: (_ Gal'M) => /= H1 [oH1 nH1U _ defHbar aP] in U1 a *. +rewrite -/U1 -/a in aP; case: aP => a_gt1 a_dv_p1 cycU1 _. +case=> [a_dv_XH0 [nb_mu IndHCmu] has_irrHC lb_Sqa]; rewrite -[S_ _]/(S_ H0C'). +have defHb1 := defHbar; rewrite (big_setD1 1%g) ?group1 ?conjsg1 //= in defHb1. +have [[_ H1c _ defH1c] _ _ _] := dprodP defHb1; rewrite defH1c in defHb1. +have [nsH1H _] := dprod_normal2 defHb1; have [sH1H _] := andP nsH1H. +have nsU1U: U1 <| U; last have [sU1U nU1U] := andP nsU1U. + by rewrite norm_normalI // astabQ norm_quotient_pre ?norms_cent. +have Da: a = #|HU : H <*> U1|. + rewrite /a -!divgS /= ?join_subG ?sHHU ?norm_joinEr ?(subset_trans sU1U) //=. + by rewrite -(sdprod_card defHU) coprime_cardMg ?(coprimegS sU1U) ?divnMl. +have sCU1: C \subset U1 by rewrite [C]unlock setIS ?astabS. +have a_dv_u: a %| u by rewrite Da Du indexgS ?genS ?setUS. +have [a_gt0 q_gt0 u_gt0 p1_gt0]: [/\ 0 < a, 0 < q, 0 < u & 0 < p.-1]%N. + rewrite !cardG_gt0 ltnW // -subn1 subn_gt0 prime_gt1 //. +have [odd_p odd_q odd_a]: [/\ odd p, odd q & odd a]. + by rewrite mFT_odd -oH1 (oddSg sH1H) ?(dvdn_odd a_dv_u) ?mFT_quo_odd. +have Dp: p = (2 * p.-1./2 + 1)%N. + by rewrite mul2n -[p]odd_double_half odd_p half_double addn1. +(* Start of main proof. *) +pose S1 := filter [pred zeta : 'CF(M) | zeta 1%g == (q * a)%:R] (S_ H0C'). +have ntS1: (0 < size S1)%N. + have [lb_dv lbS1] := lb_Sqa; apply: leq_trans (leq_trans lbS1 _). + by rewrite ltn_divRL // mul0n muln_gt0 p1_gt0 cardG_gt0. + rewrite -size_filter uniq_leq_size ?filter_uniq ?seqInd_uniq // => chi. + rewrite !mem_filter -andbA /= => /and3P[_ ->]. + by apply: seqIndS; rewrite Iirr_kerDS // genS ?setUS ?dergS ?subsetIl. +have sS10: cfConjC_subset S1 (S_ H0C'). + split=> [||chi]; first by rewrite filter_uniq. + by apply: mem_subseq; apply: filter_subseq. + rewrite !mem_filter !inE cfunE => /andP[/eqP <- S0chi]. + by rewrite cfAut_seqInd // andbT conj_Cnat ?(Cnat_seqInd1 S0chi). +have cohS1: coherent S1 M^# tau. + apply: uniform_degree_coherence (subset_subcoherent scohS0 sS10) _. + by apply: all_pred1_constant (q * a)%:R _ _; rewrite all_map filter_all. +pose S3 := filter [predC S1] (S_ H0C'); move: {2}_.+1 (ltnSn (size S3)) => nS. +move: @S3 (sS10) (cohS1); have: {subset S1 <= S1} by []. +elim: nS {-1}S1 => // nS IHnS S2 => sS12 S3 sS20 cohS2; rewrite ltnS => leS3nS. +have [ntS3|] := boolP (size S3 > 0)%N; last first. + rewrite size_filter -has_count has_predC negbK => /allP sS02. + exact: subset_coherent sS02 cohS2. +(* Ultimateley we'll contradict the maximality of S2 in (9.11.1) & (9.11.8). *) +suff [chi]: exists2 chi, chi \in S3 & coherent (chi :: chi^* :: S2)%CF M^# tau. + rewrite mem_filter => /andP[/= S2'chi S0chi]; have [uS2 sS2S0 ccS2] := sS20. + move/IHnS; apply=> [psi /sS12 S1psi||]; first by rewrite 2?mem_behead. + split. + - rewrite /= !inE negb_or S2'chi (contra (ccS2 _)) ?cfConjCK // eq_sym. + by rewrite (seqInd_conjC_neq _ _ _ S0chi) ?mFT_odd. + - by apply/allP; rewrite /= S0chi cfAut_seqInd //=; apply/allP. + apply/allP; rewrite /= !inE cfConjCK !eqxx orbT /=. + by apply/allP=> psi /ccS2; rewrite !inE orbA orbC => ->. + apply: leq_trans leS3nS; rewrite ltnNge; apply: contra S2'chi. + case/leq_size_perm=> [|psi|/(_ chi)]; first by rewrite filter_uniq. + by rewrite !mem_filter !inE orbA negb_or -andbA => /andP[]. + by rewrite !mem_filter !inE eqxx S0chi !andbT => /esym/negbFE. +(* This is step (9.11.1). *) clear nS IHnS leS3nS. +without loss [[eqS12 irrS1 H0C_S1] [Da_p defC] [S3qu ne_qa_qu] [oS1 oS1ua]]: + / [/\ [/\ S1 =i S2, {subset S1 <= irr M} & {subset S1 <= S_ H0C}], + a = p.-1./2 /\ C :=: U', + (forall chi, chi \in S3 -> chi 1%g == (q * u)%:R) /\ (q * u != q * a)%N + & size S1 = (p.-1 * u %/ a ^ 2)%N /\ size S1 = (2 * u %/ a)%N]. +- move=> IHwlog; have{sS20} [[uS2 sS20 ccS2] [uS1 _ _]] := (sS20, sS10). + pose is_qu := [pred chi : 'CF(M) | chi 1%g == (q * u)%:R]. + pose isn't_qu := [pred chi | is_qu chi ==> all is_qu S3]. + have /hasP[chi S3chi qu'chi]: has isn't_qu S3. + rewrite /isn't_qu; have [_|] := boolP (all _ _); last by rewrite has_predC. + by rewrite (eq_has (fun _ => implybT _)) has_predT. + have [S2'chi S0chi]: chi \notin S2 /\ chi \in S_ H0C'. + by apply/andP; rewrite mem_filter in S3chi. + have [s X0C's Dchi] := seqIndP S0chi. + have Dchi1: chi 1%g = q%:R * 'chi_s 1%g. + by rewrite Dchi cfInd1 // -(index_sdprod defM). + (* We'll show lb0 <= lb1 <= lb <= lb3 <= sumnS S1' <= sumnS S2 <= lb0, *) + (* with equality under conditions that imply the conclusion of (9.11.1). *) + pose lb0 := (2 * q * a)%:R * chi 1%g. + pose lb1 : algC := (2 * a * q ^ 2 * u)%:R. + pose lb2 : algC := (p.-1 * q ^ 2 * u)%:R. + pose lb3 : algC := (p.-1 * q ^ 2 * #|U : U'|)%:R. + pose S1' := filter [predI irr M & S_ H0U'] S1. + pose szS1' := ((p.-1 * #|U : U'|) %/ a ^ 2)%N; set lbS1' := _ %/ _ in lb_Sqa. + pose Snorm (psi : 'CF(M)) := psi 1%g ^+ 2 / '[psi]. + pose sumnS Si := \sum_(psi <- Si) Snorm psi. + have lb01: lb0 <= lb1 ?= iff (chi 1%g == (q * u)%:R). + rewrite /lb1 mulnA -mulnA natrM /lb0 mulnAC mono_lerif; last first. + by apply: ler_pmul2l; rewrite ltr0n !muln_gt0 a_gt0. + apply: lerif_eq; rewrite Dchi1 natrM ler_pmul2l ?gt0CG //. + have [KsH0C' _] := setDP X0C's; rewrite inE in KsH0C'. + have [t sHCt] := constt_cfRes_irr HC s. + have KtH0C': H0C' \subset cfker 'chi_t. + apply: subset_trans (cfker_constt (cfRes_char _ (irr_char s)) sHCt). + by rewrite cfker_Res ?irr_char // subsetI genS ?setUSS. + rewrite -constt_Ind_Res in sHCt. + apply: ler_trans (char1_ge_constt (cfInd_char _ (irr_char t)) sHCt) _. + rewrite cfInd1 // -Du lin_char1 ?mulr1 // lin_irr_der1. + apply: subset_trans KtH0C'; rewrite /= (norm_joinEr nH0C') /= -/C. + rewrite -quotientSK ?(subset_trans (der_sub _ _)) ?(subset_trans sHCHU) //. + by rewrite -defHC'bar quotient_der ?(subset_trans sHCHU). + have lb12: lb1 <= lb2 ?= iff (a == p.-1./2). + rewrite -(@eqn_pmul2l 2) // -(canLR (addnK 1) Dp) subn1 lerif_nat. + rewrite !(mono_leqif (fun _ _ => leq_pmul2r _)) ?expn_gt0 ?q_gt0 //. + apply: leqif_eq; rewrite dvdn_leq // Gauss_dvd //. + by rewrite {1}Dp addn1 dvdn_mulr. + by rewrite prime_coprime ?dvdn2 ?negbK. + have lb23: lb2 <= lb3 ?= iff (C :==: U') :> algC. + rewrite lerif_nat [u]card_quotient //. + rewrite (mono_leqif (fun _ _ => leq_pmul2l _)) ?muln_gt0 ?p1_gt0 ?q_gt0 //. + rewrite -(mono_leqif (fun _ _ => leq_pmul2l (cardG_gt0 C))) Lagrange //. + rewrite -(Lagrange sU'U) (mono_leqif (fun _ _ => leq_pmul2r _)) //. + by rewrite eq_sym; apply: subset_leqif_cards. + have lb3S1': lb3 <= sumnS S1' ?= iff (size S1' == szS1'). + rewrite /szS1' -(divnMr (cardG_gt0 U')) mulnAC -mulnA Lagrange // -/lbS1'. + have{lb_Sqa} [dv_lb lbSqa] := lb_Sqa; rewrite [sumnS S1']big_seq. + rewrite (eq_bigr (fun _ => ((q * a) ^ 2)%:R)) => [|psi]; last first. + rewrite !mem_filter -!andbA => /and4P[/irrP[r ->] _ /=/eqP r1qa _]. + by rewrite /Snorm cfnorm_irr divr1 r1qa natrX. + rewrite -big_seq (big_nth 0) -natr_sum sum_nat_const_nat subn0. + rewrite mulnC natrM [*%R]lock /lb3 natrM natf_indexg ?der_sub // mulrA. + rewrite -natrM mulnAC -(divnK dv_lb) mulnAC mulnA natrM mulfK ?neq0CG //. + rewrite -/lbS1' -mulnA -expnMn natrM mulrC -lock mono_lerif; last first. + by apply: ler_pmul2l; rewrite ltr0n !muln_gt0 a_gt0 q_gt0. + rewrite eq_sym lerif_nat; apply: leqif_eq; rewrite (leq_trans lbSqa) //. + rewrite -size_filter uniq_leq_size ?filter_uniq ?seqInd_uniq // => psi. + rewrite !mem_filter -!andbA /= => /and3P[-> -> S0psi]; rewrite S0psi. + by apply: seqIndS S0psi; rewrite Iirr_kerDS //= genS ?setUS ?dergS. + have lbS1'2: sumnS S1' <= sumnS S2 ?= iff ~~ has [predC S1'] S2. + have Ds2: perm_eq S2 (S1' ++ filter [predC S1'] S2). + rewrite -(perm_filterC (mem S1')) perm_cat2r. + rewrite uniq_perm_eq ?filter_uniq // => psi. + by rewrite mem_filter andb_idr //= mem_filter => /andP[_ /sS12]. + rewrite [sumnS S2](eq_big_perm _ Ds2) big_cat /= -/(sumnS S1') big_filter. + rewrite -all_predC -big_all_cond !(big_tnth _ _ S2) big_andE. + rewrite -{1}[_ S1']addr0 mono_lerif; last exact: ler_add2l. + set sumS2' := \sum_(i | _) _; rewrite -[0]/(sumS2' *+ 0) -sumrMnl. + apply: lerif_sum => i _; apply/lerifP; rewrite lt0r !mulf_eq0 invr_eq0. + set psi := tnth _ i; have Spsi := sS20 psi (mem_tnth _ _). + rewrite !negb_or (seqInd1_neq0 _ Spsi) //= (cfnorm_seqInd_neq0 _ Spsi) //=. + by rewrite divr_ge0 ?exprn_ge0 ?cfnorm_ge0 ?Cnat_ge0 ?(Cnat_seqInd1 Spsi). + have [lb0S2 | ] := boolP (lb0 < sumnS S2). + exists chi => //; have /hasP[xi S1xi _]: has predT S1 by rewrite has_predT. + have xi1: xi 1%g = (q * a)%:R. + by rewrite mem_filter in S1xi; have [/eqP] := andP S1xi. + apply: ((extend_coherent scohS0) _ xi) => //; first by rewrite S0chi sS12. + split=> //; last by rewrite mulrAC xi1 -natrM mulnA. + rewrite xi1 Dchi1 irr1_degree -natrM dvdC_nat dvdn_pmul2l ?cardG_gt0 //. + rewrite -dvdC_nat /= !nCdivE -irr1_degree a_dv_XH0 //. + by rewrite (subsetP (Iirr_kerDS _ _ _) _ X0C's) ?joing_subl. + have lb1S2 := lerif_trans lb12 (lerif_trans lb23 (lerif_trans lb3S1' lbS1'2)). + rewrite ltr_neqAle !(lerif_trans lb01 lb1S2) andbT has_predC !negbK. + case/and5P=> /eqP chi1qu /eqP Da_p /eqP defC /eqP sz_S1' /allP sS21'. + have defS1': S1' = S1. + apply/eqP; rewrite -(geq_leqif (size_subseq_leqif (filter_subseq _ S1))). + by rewrite uniq_leq_size // => psi /sS12/sS21'. + apply: IHwlog; split=> //. + + split=> psi; do 1?[rewrite -defS1' mem_filter andbC => /and3P[_ _] //=]. + by apply/idP/idP=> [/sS12 | /sS21']; rewrite ?defS1'. + by congr (_ \in S_ _); apply/group_inj; rewrite /= defC. + + split; first by apply/allP; apply: contraLR qu'chi; rewrite /= chi1qu eqxx. + rewrite -eqC_nat -chi1qu; apply: contra S2'chi => chi1qa. + by rewrite sS12 // mem_filter /= chi1qa. + rewrite -defS1' sz_S1' /szS1' -defC -card_quotient // -/u. + by split=> //; rewrite -mulnn {1}Dp addn1 -Da_p mulnAC divnMr. +have nCW1: W1 \subset 'N(C). + by rewrite (subset_trans (joing_subr U W1)) ?normal_norm. +(* This is step (9.11.2). *) clear sS20 cohS2 sS12 has_irrHC lb_Sqa sU'C. +have [tiU1 le_u_a2]: {in W1^#, forall w, U1 :&: U1 :^ w = C} /\ (u <= a ^ 2)%N. + have tiU1 w: w \in W1^# -> U1 :&: U1 :^ w = C; last split => //. + case/setD1P=> ntw W1w; have nH0w := subsetP (subset_trans sW1M nH0M) w W1w. + pose wb := coset H0 w; have W1wb: wb \in W1bar^#. + rewrite !inE mem_quotient ?(contraNneq _ ntw) // => /coset_idr H0w. + rewrite -in_set1 -set1gE -tiHUW1 inE (subsetP sHHU) // (subsetP sH0H) //. + by rewrite H0w. + have ntH1 w1: H1 :^ w1 :!=: 1%g by rewrite -cardG_gt1 cardJg oH1 prime_gt1. + pose t_ w1 := + if pred2 1%g wb w1 then sval (has_nonprincipal_irr (ntH1 w1)) else 0. + pose theta := + cfDprodl defHCbar (cfBigdprod defHbar (fun w1 => 'chi_(t_ w1))). + have lin_theta : theta \is a linear_char. + rewrite cfDprodl_lin_char ?cfBigdprod_lin_char // => w1 _. + by rewrite irr_prime_lin ?cardJg ?oH1. + have nsH0HC: H0 <| HC. + by rewrite /normal join_subG nH0H sub_gen ?subsetU ?sH0H. + move defK: H0C => K. (* to avoid divergence in Coq kernel *) + have kerK: K \subset cfker (theta %% H0). + rewrite -defK sub_cfker_mod ?join_subG ?normG ?quotientYidl //. + exact: cfker_sdprod. + have sKHC: K \subset HC by rewrite -defK genS ?setSU. + have nsKHC: K <| HC by rewrite (normalS sKHC (normal_sub nsHC_M)) -?defK. + have sH0K: H0 \subset K by rewrite -defK joing_subl. + have nsKHU: K <| HU. + by rewrite (normalS (subset_trans sKHC sHCHU) sHUM) -?defK. + have [t2 Dt2]: {t2 : Iirr (HC / K) | 'chi_t2 %% K = theta %% H0}%CF. + exists (cfIirr ((theta %% H0) / K)). + by rewrite cfIirrE ?cfQuoK ?cfQuo_irr ?cfMod_irr ?lin_char_irr. + have nsHChatHU: HC / K <| HU / K by rewrite quotient_normal. + have sHChatHU := normal_sub nsHChatHU. + pose That := 'I_(HU / K)['chi_t2]%G. + have sThatHU: That \subset (HU / K)%G := Inertia_sub _ _. + have abThatHC: abelian (That / (HC / K)). + rewrite (abelianS (quotientS _ sThatHU)) //. + rewrite (isog_abelian (third_isog _ _ _)) // defC. + rewrite -(isog_abelian (quotient_sdprodr_isog defHU _)) ?gFnormal //. + by rewrite sub_der1_abelian. + have hallHChat: Hall That (HC / K). + rewrite /Hall -(card_isog (third_isog sH0K nsH0HC nsKHC)) /=. + rewrite sub_Inertia // -[in #|_|]defK /= quotientYidl //. + rewrite -(card_isog (sdprod_isog (dprodWsdC defHCbar))). + apply: coprime_dvdr (indexSg (sub_Inertia _ sHChatHU) sThatHU) _. + apply: coprime_dvdr (index_quotient _) _. + by rewrite subIset // normal_norm. + by rewrite -Du coprime_morphl // coprime_morphr. + have [s t2HUs] := constt_cfInd_irr t2 sHChatHU. + have s_1: ('chi_s %% K)%CF 1%g = #|U : U1 :&: U1 :^ w|%:R. + rewrite cfMod1. + have [||_ _ ->] // := cfInd_Hall_central_Inertia _ abThatHC. + rewrite -cfMod1 Dt2 cfMod1 lin_char1 //= mulr1 -inertia_mod_quo // Dt2. + rewrite index_quotient_eq ?normal_norm ?Inertia_sub ?setIS //; last first. + by rewrite (subset_trans sKHC) ?sub_inertia. + rewrite /= inertia_morph_pre //= -quotientE inertia_dprodl; first 1 last. + - by rewrite quotient_norms ?normal_norm. + - rewrite /= -(quotientYidl nH0C) quotient_norms ?normal_norm //. + by rewrite -defK in nsKHU. + have nH1wHU w1: w1 \in (W1 / H0)%g -> (HU / H0)%g \subset 'N(H1 :^ w1). + move=> W1w1; rewrite -(normsP (quotient_norms H0 nHUW1) _ W1w1) normJ. + rewrite conjSg /= -(sdprodW defHU) quotientMl ?mul_subG //. + exact: normal_norm. + rewrite indexgI /= inertia_bigdprod_irr // (big_setD1 1%g) ?group1 //=. + rewrite 2!{1}setIA setIid (bigD1 wb) //= {1 2}/t_ /= !eqxx ?orbT /=. + rewrite !(inertia_irr_prime _ p_pr) ?cardJg //=; + try by case: (has_nonprincipal_irr _). + rewrite conjsg1 centJ setIA -setIIr /=. + elim/big_rec: _ => [|w1 Uk /andP[/setD1P[ntw1 Ww1] w'w1] IHk]; last first. + rewrite /t_ -if_neg negb_or ntw1 w'w1 irr0 Inertia1 -?setIIr 1?setIA //. + rewrite /normal nH1wHU //= -(normsP (quotient_norms H0 nHUW1) _ Ww1). + by rewrite conjSg (subset_trans sH1H) ?quotientS. + rewrite setIT !morphpreI morphpreJ ?(subsetP nH0W1) //= -astabQ. + rewrite quotientGK //; last by rewrite /normal (subset_trans sH0H). + rewrite -(sdprodWY (sdprod_modl defHU _)); last first. + rewrite subsetI -sub_conjgV. + rewrite (normsP (gFnorm _ _)) ?groupV ?(subsetP sW1M) //= andbb. + by rewrite sub_astabQ nH0H sub_abelian_cent. + rewrite -(index_sdprodr defHU) ?subsetIl // conjIg (normsP nUW1) //. + by rewrite -setIIr. + apply/esym/eqP; rewrite eqEcard subsetI -sub_conjgV. + rewrite (normsP _ _ (groupVr W1w)) ?sCU1 /=; last first. + by rewrite (subset_trans (joing_subr U W1)) ?normal_norm. + have{s_1} : pred2 u a #|U : U1 :&: U1 :^ w|. + rewrite /= -!eqC_nat -{}s_1 -mod_IirrE //. + pose phi := 'Ind[M] 'chi_(mod_Iirr s). + have Sphi: phi \in S_ H0C'. + rewrite mem_seqInd ?gFnormal // !inE mod_IirrE //. + rewrite andbC (subset_trans _ (cfker_mod _ _)) //=; last first. + by rewrite -defK genS ?setUS ?der_sub. + rewrite sub_cfker_mod ?(subset_trans sHHU) ?normal_norm //. + have sHHC: H \subset HC by rewrite joing_subl. + rewrite -(sub_cfker_constt_Ind_irr t2HUs) ?quotientS //; last first. + by rewrite quotient_norms ?normal_norm. + rewrite -sub_cfker_mod ?(subset_trans sHHU (normal_norm nsKHU)) //. + rewrite Dt2 sub_cfker_mod //. + apply: contra (valP (has_nonprincipal_irr (ntH1 1%g))). + move/eq_cfker_Res; rewrite cfDprodlK => kerHbar. + have:= sH1H; rewrite -{1}(conjsg1 H1) -kerHbar => /eq_cfker_Res. + by rewrite cfBigdprodKabelian ?group1 // /t_ /= eqxx -subGcfker => ->. + have [/S3qu | ] := boolP (phi \in S3). + rewrite cfInd1 // natrM -(index_sdprod defM). + by rewrite (inj_eq (mulfI (neq0CG _))) => ->. + rewrite mem_filter Sphi andbT negbK /= -eqS12 mem_filter Sphi andbT /=. + rewrite cfInd1 // natrM -(index_sdprod defM) (inj_eq (mulfI (neq0CG _))). + by rewrite orbC => ->. + case/pred2P=> [iUCu | iUCa]. + rewrite -(leq_pmul2r u_gt0) -{1}iUCu /u card_quotient ?Lagrange //. + by rewrite /= -setIA subsetIl. + rewrite subset_leq_card // subIset // [C]unlock subsetI subsetIl sub_astabQ. + rewrite subIset ?nH0U //= centsC -(bigdprodWY defHbar) gen_subG. + apply/orP; left; apply/bigcupsP=> w1 Ww1; rewrite centsC centJ -sub_conjgV. + rewrite (normsP _ _ (groupVr Ww1)) ?quotient_norms //. + by rewrite /U1 astabQ quotient_setIpre subsetIr. + rewrite prime_meetG //; apply/trivgPn; exists w; rewrite // !inE W1w. + rewrite (sameP setIidPr eqP) eqEcard subsetIr /= cardJg. + by rewrite -(leq_pmul2r a_gt0) -{2}iUCa !Lagrange //= -setIA subsetIl. + have /trivgPn[w W1w ntw]: W1 :!=: 1%g by rewrite -cardG_gt1 prime_gt1. + rewrite -(leq_pmul2l u_gt0) mulnn. + have nCU1 := subset_trans sU1U nCU. + have {1}->: u = (#|(U1 / C)%g| * a)%N. + by rewrite mulnC /u !card_quotient // Lagrange_index. + rewrite expnMn leq_pmul2r ?expn_gt0 ?orbF // -mulnn. + rewrite -{2}[U1](conjsgK w) quotientJ ?groupV ?(subsetP nCW1) //. + rewrite cardJg -TI_cardMg /= -/U1 ?subset_leq_card //. + rewrite mul_subG ?quotientS ?subsetIl //. + by rewrite -(normsP nUW1 w W1w) conjSg subsetIl. + by rewrite -quotientGI // tiU1 ?trivg_quotient // !inE ntw. +pose S4 := filter [predD S_ H0C & redM] S3. +have sS43: {subset S4 <= S3} by apply: mem_subseq; apply: filter_subseq. +(* This is step (9.11.3). *) +have nsHM: H <| M by apply: gFnormal. +have oS4: (q * u * size S4 + p.-1 * (q + u))%N = (p ^ q).-1. + rewrite mulnAC {1}[q](index_sdprod defM) -[S4]filter_predI. + rewrite (size_irr_subseq_seqInd _ (filter_subseq _ _)) //; last first. + by move=> xi; rewrite mem_filter -!andbA negbK => /andP[]. + set Xn := finset _; pose sumH0C := \sum_(s in X_ H0C) 'chi_s 1%g ^+ 2. + have /eqP: sumH0C = (q * size S1 * a ^ 2 + (#|Xn| + p.-1) * u ^ 2)%:R. + rewrite [q](index_sdprod defM) natrD natrM natrX. + rewrite (size_irr_subseq_seqInd _ (filter_subseq _ _)) //= -/S1. + have sH0CC': {subset S_ H0C <= S_ H0C'}. + by apply: seqIndS; rewrite Iirr_kerDS // genS ?setUS ?der_sub. + rewrite [sumH0C](big_setID [set s | 'Ind 'chi_s \in S1]) /=; congr (_ + _). + rewrite mulr_natl -[rhs in _ = rhs]sumr_const; apply: eq_big => s. + by rewrite in_setI inE andb_idl // => /H0C_S1; rewrite mem_seqInd. + rewrite 2!inE mem_filter andbCA /= cfInd1 // -(index_sdprod defM) natrM. + by case/andP=> /eqP/(mulfI (neq0CG _))->. + rewrite (eq_bigr (fun _ => u%:R ^+ 2)) => [|s]; last first. + rewrite 2!inE eqS12 => /andP[S2's H0Cs]; congr (_ ^+ 2). + have /S3qu/eqP: 'Ind 'chi_s \in S3. + by rewrite mem_filter /= S2's sH0CC' ?mem_seqInd. + by rewrite natrM cfInd1 // -(index_sdprod defM) => /(mulfI (neq0CG _)). + rewrite sumr_const -mulr_natl natrM natrX -nb_mu; congr (_%:R * _). + have [_ s_mu_H0C] := nb_redM_H0. + rewrite (size_red_subseq_seqInd_typeP MtypeP _ s_mu_H0C); last first. + - by apply/allP; apply: filter_all. + - by rewrite filter_uniq ?seqInd_uniq. + rewrite -/mu_ -[#|_|](cardsID Xn) (setIidPr _); last first. + apply/subsetP=> s; rewrite inE in_setD mem_filter /= -!andbA -eqS12. + rewrite mem_seqInd ?gFnormal // => /and4P[_ -> S1'xi _]. + by rewrite inE S1'xi. + congr (_ + _)%N; apply: eq_card => i; rewrite inE -/mu_ 2!inE. + rewrite -[seqInd M _]/(S_ H0C') mem_filter /= andbC 2!inE eqS12 -!andbA. + rewrite -(mem_seqInd nsHUM) // -/(S_ H0C); set xi := 'Ind _. + apply/idP/idP=> [/and3P[-> H0Cxi] | mu_xi]. + rewrite H0Cxi sH0CC' //= andbT negbK mem_filter unfold_in => ->. + by rewrite (seqIndS _ H0Cxi) // Iirr_kerDS ?joing_subl. + have [xi1u H0Cxi _] := IndHCmu _ mu_xi. + rewrite H0Cxi -eqS12 mem_filter sH0CC' //= !andbT xi1u eqC_nat ne_qa_qu. + by rewrite andbT negbK mem_filter in mu_xi *; case/andP: mu_xi. + rewrite oS1 -mulnA divnK ?dvdn_mul // !mulnA -mulnDl mulnC natrM {}/sumH0C. + rewrite /X_ -Iirr_kerDY joingC joingA (joing_idPl sH0H) /=. + rewrite sum_Iirr_kerD_square ?genS ?setSU //; last first. + by apply: normalS nsH0C_M; rewrite // -(sdprodWY defHU) genS ?setUSS. + rewrite -Du (inj_eq (mulfI (neq0CG _))) -(prednK (indexg_gt0 _ _)). + rewrite mulrSr addrK eqC_nat addnC mulnDl addnAC (mulnC q) -addnA -mulnDr. + move/eqP <-; congr _.-1. + have nH0HC: HC \subset 'N(H0) by rewrite join_subG nH0H. + rewrite -(index_quotient_eq _ _ nH0HC) ?genS ?setSU //; last first. + by rewrite setIC subIset ?joing_subl. + rewrite quotientYidl // -(index_sdprod (dprodWsdC defHCbar)). + by case: Ptype_Fcore_factor_facts. +have /hasP[psi1 S1psi1 _]: has predT S1 by rewrite has_predT. +pose gamma := 'Ind[M, H <*> U1] 1; pose alpha := gamma - psi1. +(* This is step (9.11.4). *) +pose nm_alpha : algC := a%:R + 1 + (q.-1 * a ^ 2)%:R / u%:R. +have [Aalpha Nalpha]: alpha \in 'CF(M, 'A(M)) /\ '[alpha] = nm_alpha. + have sHU1_HU: H <*> U1 \subset HU by rewrite -(sdprodWY defHU) genS ?setUS. + have sHU1_M := subset_trans sHU1_HU sHUM. + have sHU1_A1: H <*> U1 \subset 1%g |: 'A(M). + pose pi := \pi(H); rewrite -subDset; apply/subsetP=> y /setD1P[nty HU1y]. + apply/bigcupP; rewrite notMtype1 /=; have sHMs := Fcore_sub_FTcore maxM. + have defHU1: H ><| U1 = H <*> U1 := sdprod_subr defHU sU1U. + have nsH_HU1: H <| H <*> U1 by have [] := sdprod_context defHU1. + have [HUy [_ nH_HU1]] := (subsetP sHU1_HU y HU1y, normalP nsH_HU1). + have hallH: pi.-Hall(H <*> U1) H. + by rewrite Hall_pi // -(coprime_sdprod_Hall_l defHU1) (coprimegS sU1U). + have hallU1: pi^'.-Hall(H <*> U1) U1. + by rewrite -(compl_pHall _ hallH) sdprod_compl. + have [pi'y | pi_y] := boolP (pi^'.-elt y); last first. + exists y.`_pi; last by rewrite 3!inE nty HUy cent1C groupX ?cent1id. + rewrite !inE (sameP eqP constt1P) pi_y (subsetP sHMs) //. + by rewrite (mem_normal_Hall hallH) ?groupX ?p_elt_constt. + have solHU1: solvable (H <*> U1) by rewrite (solvableS sHU1_M) ?mmax_sol. + have [||z HU1z U1yz] := Hall_Jsub _ hallU1 _ pi'y; rewrite ?cycle_subG //. + have /trivgPn[x /setIP[Hx cxyz] ntx]: 'C_H[y ^ z] != 1%g. + apply: contraTneq (prime_gt1 p_pr) => regHy; rewrite -oH1 cardG_gt1 negbK. + move: U1yz; rewrite -cycleJ subsetI sub_astabQ => /and3P[sYU nHY cH1Y]. + rewrite centsC in cH1Y; rewrite -(setIidPl cH1Y) -(setIidPl sH1H) -setIA. + rewrite -coprime_quotient_cent ?(coprimegS sYU) // cent_cycle regHy. + by rewrite quotient1 setIg1. + exists (x ^ z^-1)%g; last by rewrite 3!inE nty HUy cent1J mem_conjgV cent1C. + by rewrite 2!inE conjg_eq1 ntx (subsetP sHMs) // -mem_conjg nH_HU1. + have{sHU1_A1} Aalpha: alpha \in 'CF(M, 'A(M)). + have A'1: 1%g \notin 'A(M) by have /subsetD1P[] := FTsupp_sub M. + rewrite -['A(M)](setU1K A'1) cfun_onD1 !cfunE subr_eq0 cfInd1 // cfun11. + rewrite mulr1 -(Lagrange_index sHUM) // -(index_sdprod defM) -/q. + rewrite -(index_sdprodr defHU) ?subsetIl // -/a eq_sym andbC. + have:= S1psi1; rewrite mem_filter /= => /andP[-> _] /=. + rewrite rpredB //. + apply: cfun_onS (cfInd_on sHU1_M (cfun_onG _)). + rewrite class_supportEr; apply/bigcupsP=> w Mw. + by rewrite sub_conjg conjUg conjs1g (normsP (FTsupp_norm M)) ?groupV. + have /seqIndP[s /setDP[_ ker'H ] ->] := H0C_S1 _ S1psi1. + rewrite (prDade_Ind_irr_on (FT_prDade_hypF maxM MtypeP)) //. + by rewrite inE in ker'H. + have ->: '[alpha] = '[gamma] + 1. + have /irrP[t Dt] := irrS1 _ S1psi1. + rewrite cfnormBd; first by rewrite Dt cfnorm_irr. + have /seqIndP[s /setDP[_ ker'H ] Dpsi1] := H0C_S1 _ S1psi1. + apply: contraNeq ker'H; rewrite Dt /gamma -irr0 -irr_consttE => tHU1_0. + rewrite inE -(sub_cfker_Ind_irr _ sHUM) ?gFnorm // -Dpsi1 Dt. + rewrite -(sub_cfker_constt_Ind_irr tHU1_0) ?gFnorm ?joing_subl //. + by rewrite irr0 cfker_cfun1 joing_subl. + split=> //; rewrite /nm_alpha addrAC natrM mulrAC mulrC; congr (_ + 1). + rewrite -{1}(mulnK a a_gt0) natf_div ?dvdn_mull // -mulrDr mulnn natrX. + have /sdprod_isom[nH_UW1 isomMH]: H ><| (U <*> W1) = M. + rewrite sdprodEY ?join_subG ?nHU ?(subset_trans sW1M) ?gFnorm //. + by rewrite joingA (sdprodWY defHU) (sdprodWY defM). + rewrite /= -(setIidPl sHHU) norm_joinEr // setIAC -setIA -group_modl //. + by rewrite (setIC W1) tiHUW1 mulg1. + have sU1_UW1: U1 \subset U <*> W1 by rewrite subIset ?joing_subl. + rewrite /gamma -(cfMod_cfun1 _ H) cfIndMod ?joing_subl //. + rewrite cfMod_iso //= quotientYidl ?(subset_trans sU1_UW1) //. + rewrite -(restrm_quotientE _ sU1_UW1) -(cfIsom_cfun1 (restr_isom _ isomMH)). + rewrite (cfIndIsom isomMH) // {nH_UW1 isomMH}cfIsom_iso. + rewrite -(cfIndInd _ (joing_subl U W1)) // cfInd_cfun1 //= -/U1 -/a. + rewrite linearZ cfnormZ normr_nat /=; congr (_ * _). + have defUW1: U ><| W1 = U <*> W1. + by rewrite sdprodEY // -(setIidPl sUHU) -setIA tiHUW1 setIg1. + apply: canLR (mulKf (neq0CG _)) _; rewrite -(sdprod_card defUW1) natrM -/q. + rewrite mulrAC mulrDr mulrCA -{1}(Lagrange sU1U) /= -/U1 -/a -(Lagrange sCU). + rewrite -card_quotient // !natrM !mulfK ?neq0CiG ?neq0CG //. + transitivity (\sum_(x in U <*> W1) \sum_(w1 in W1) \sum_(w2 in W1) + (x ^ w1 \in U1 :&: U1 :^ w2)%g%:R : algC). + - apply: eq_bigr => x _; rewrite (cfIndEsdprod _ _ defUW1) mulr_suml. + apply: eq_bigr => w1 W1w1; rewrite rmorph_sum mulr_sumr. + rewrite (reindex_inj invg_inj) (eq_bigl _ _ (groupV W1)) /=. + rewrite (reindex_acts 'R _ (groupVr W1w1)) ?astabsR //=. + apply: eq_bigr => w2 _; rewrite inE !cfuniE // rmorph_nat -natrM mulnb. + by congr (_ && _)%:R; rewrite invMg invgK conjgM -mem_conjg. + rewrite exchange_big /= mulr_natr -sumr_const; apply: eq_bigr => w1 W1w1. + transitivity (\sum_(w in W1) #|U1 :&: U1 :^ w|%:R : algC). + rewrite exchange_big /=; apply: eq_bigr => w W1w. + rewrite (reindex_acts 'J _ (groupVr W1w1)) ?astabsJ ?normsG ?joing_subr //=. + symmetry; rewrite big_mkcond -sumr_const /= big_mkcond /=. + apply: eq_bigr => x _; rewrite conjgKV. + by case: setIP => [[/(subsetP sU1_UW1)-> //] | _]; rewrite if_same. + rewrite (big_setD1 1%g) //= conjsg1 setIid; congr (_ + _). + rewrite [q](cardsD1 1%g) group1 /= mulr_natl -sumr_const. + by apply: eq_bigr => w W1w; rewrite tiU1. +(* This is step (9.11.5). *) +have [gtS4alpha s4gt0]: (size S4)%:R > '[alpha] /\ (size S4 > 0)%N. + suffices gtS4alpha: (size S4)%:R > '[alpha]. + by split=> //; rewrite -ltC_nat (ler_lt_trans (cfnorm_ge0 alpha)). + rewrite Nalpha -(@ltr_pmul2r _ u%:R) ?ltr0n // mulrDl divfK ?neq0CG //. + rewrite -(ltr_pmul2l (gt0CG W1)) -/q -mulrSr -!(natrM, natrD) ltC_nat. + rewrite mulnA mulnAC -(ltn_add2r (p.-1 * (q + u))) oS4 {1}Dp addn1 -Da_p /=. + apply: leq_ltn_trans (_ : q.+2 * a ^ 3 + q ^ 2 * a ^ 2 + 2 * q * a < _)%N. + rewrite (addnC q) 2!mulnDr addnA (mulnAC _ a q) leq_add2r. + rewrite mulnA addnAC -mulnDl mulnS -addnA -mulnDl addn2 mulnCA -mulnA. + rewrite -[q in (_ <= _ + q * _)%N](prednK q_gt0) (mulSn q.-1) addnA. + by rewrite leq_add2r mulnA -mulnDl addnC leq_mul. + have q_gt2: (2 < q)%N. + by rewrite ltn_neqAle prime_gt1 ?(contraTneq _ odd_q) => // <-. + apply: leq_trans (_ : a.*2 ^ q + 'C(q, 2) * a.*2 ^ 2 + q * a.*2 <= _)%N. + rewrite -mul2n (mulnCA q) (mulnA 2) ltn_add2r !expnMn -addSn leq_add //. + apply: leq_ltn_trans (_ : q.-1.*2.+1 * a ^ q < _)%N. + rewrite leq_mul ?leq_pexp2l //. + by rewrite -(subnKC q_gt2) -addnn !addnS !ltnS leq_addl. + rewrite ltn_pmul2r ?expn_gt0 ?a_gt0 // -doubleS. + by rewrite -(prednK q_gt0) expnS mul2n leq_double ltn_expl. + rewrite mulnA leq_pmul2r ?expn_gt0 ?a_gt0 // -(subnKC q_gt2). + rewrite mulnCA mulnA addSn -mul_Sm_binm bin1 -mulnA leq_pmul2l //. + by rewrite mulnS -addSnnS leq_addr. + rewrite Dp -Da_p mul2n (addnC a.*2) expnDn -(subnKC q_gt2) !addSn add0n. + rewrite 3!big_ord_recl big_ord_recr /= !exp1n /= bin1 binn !mul1n /bump /=. + by do 2!rewrite addnC leq_add2l; apply: leq_addl. +have{cohS1} [tau1 cohS1] := cohS1; have [[Itau1 Ztau1] Dtau1] := cohS1. +have sS30: cfConjC_subset S3 (S_ H0C'). + split=> [|chi|chi]; first by rewrite filter_uniq ?seqInd_uniq. + by rewrite mem_filter => /andP[]. + rewrite !mem_filter /= -!eqS12 => /andP[S1'chi S_chi]. + rewrite cfAut_seqInd // (contra _ S1'chi) //. + by have [_ _ ccS1] := sS10; move/ccS1; rewrite cfConjCK. +have scohS3: subcoherent S3 tau rmR := subset_subcoherent scohS0 sS30. +have [tau3 cohS3]: coherent S3 M^# tau. + apply: uniform_degree_coherence scohS3 _. + apply: all_pred1_constant (q * u)%:R _ _. + by rewrite all_map; apply/allP=> chi /S3qu. +have [IZtau3 Dtau3] := cohS3; have [Itau3 Ztau3] := IZtau3. +have notA1: 1%g \notin 'A(M) by have /subsetD1P[] := FTsupp_sub M. +have sS0_1A: {subset S_ H0C' <= 'CF(M, 1%g |: 'A(M))}. + move=> _ /seqIndP[s /setDP[_ ker'H] ->]; rewrite inE in ker'H. + by rewrite (prDade_Ind_irr_on (FT_prDade_hypF maxM MtypeP)). +have sS0A: {subset 'Z[S_ H0C', M^#] <= 'Z[irr M, 'A(M)]}. + move=> chi; rewrite (zcharD1_seqInd_Dade _ notA1) //. + by apply: zchar_sub_irr; apply: seqInd_vcharW. +have Zalpha: alpha \in 'Z[irr M]. + rewrite rpredB ?char_vchar ?cfInd_char ?rpred1 //. + exact: seqInd_char (H0C_S1 _ S1psi1). +have ZAalpha: alpha \in 'Z[irr M, 'A(M)] by rewrite zchar_split Zalpha. +have [Itau Ztau]: {in 'Z[irr M, 'A(M)], isometry tau, to 'Z[irr G]}. + apply: sub_iso_to (Dade_Zisometry _); last exact: zcharW. + by apply: zchar_onS; apply: FTsupp_sub0. +have oSgamma: {in S_ H0C', forall lam, '[gamma, lam] = 0}. + move=> _ /seqIndP[s /setDP[_ ker'H ] ->]. + rewrite ['Ind _]cfun_sum_constt cfdot_sumr big1 // => t sMt. + rewrite cfdotZr [gamma]cfun_sum_constt cfdot_suml big1 ?mulr0 // => t0 gMt0. + rewrite cfdotZl cfdot_irr (negPf (contraNneq _ ker'H)) ?mulr0 // => Dt0. + rewrite inE (sub_cfker_constt_Ind_irr sMt) ?gFnorm // -Dt0. + rewrite /gamma -irr0 in gMt0. + rewrite -(sub_cfker_constt_Ind_irr gMt0) ?gFnorm ?joing_subl //. + by rewrite irr0 cfker_cfun1 joing_subl. + by rewrite (subset_trans _ sHUM) // join_subG sHHU subIset ?sUHU. +(* This is step (9.11.6). *) +have [/eqP psi1qa Spsi1]: psi1 1%g == (q * a)%:R /\ psi1 \in S_ H0C'. + by move: S1psi1; rewrite mem_filter => /andP[]. +have o_alpha_S3: orthogonal alpha^\tau (map tau3 S3). + rewrite /orthogonal /= andbT all_map. + apply: contraFT (ltr_geF gtS4alpha) => /allPn[lam0 S3lam0 /= alpha_lam0]. + set ca := '[_, _] in alpha_lam0; pose al0 := (-1) ^+ (ca < 0)%R *: alpha. + have{alpha_lam0} al0_lam0: '[al0^\tau, tau3 lam0] > 0. + have Zca: ca \in Cint by rewrite Cint_cfdot_vchar ?Ztau // Ztau3 ?mem_zchar. + by rewrite linearZ cfdotZl (canLR (signrMK _) (CintEsign Zca)) normr_gt0. + rewrite -Itau // -(cfnorm_sign (ca < 0)%R) -linearZ /= -/al0. + have S4_dIirrK: {in map tau3 S4, cancel (dirr_dIirr id) (@dchi _ _)}. + apply: dirr_dIirrPE => _ /mapP[lam S4lam ->]. + rewrite mem_filter -andbA negbK in S4lam. + have [/irrP[i Dlam] _ S3lam] := and3P S4lam. + by rewrite dirrE Itau3 ?Ztau3 ?mem_zchar //= Dlam cfnorm_irr. + rewrite -(size_map tau3) -(size_map (dirr_dIirr id)). + rewrite -(card_uniqP _); last first. + rewrite !map_inj_in_uniq ?filter_uniq ?seqInd_uniq //. + apply: sub_in2 (Zisometry_inj Itau3) => lam. + by rewrite mem_filter => /andP[_ /mem_zchar->]. + exact: can_in_inj S4_dIirrK. + apply: ler_trans (_ : #|dirr_constt al0^\tau|%:R <= _); last first. + have Zal0: al0^\tau \in 'Z[irr G] by rewrite Ztau ?rpredZsign. + rewrite cnorm_dconstt // -sumr_const ler_sum // => i al0_i. + by rewrite sqr_Cint_ge1 ?gtr_eqF -?dirr_consttE // Cint_Cnat ?Cnat_dirr. + rewrite leC_nat subset_leq_card //; apply/subsetP=> _ /mapP[nu S4nu ->]. + rewrite dirr_consttE S4_dIirrK //; congr (_ > 0): al0_lam0. + rewrite {al0}linearZ !cfdotZl /=; congr (_ * _) => {ca}; apply/eqP. + have{nu S4nu} [lam S4lam ->] := mapP S4nu. + rewrite mem_filter in S4lam; have{S4lam} [_ S3lam] := andP S4lam. + have Zdlam: lam0 - lam \in 'Z[S3, M^#]. + rewrite zcharD1E rpredB ?mem_zchar //= !cfunE subr_eq0. + by have [/eqP->] := (S3qu _ S3lam, S3qu _ S3lam0). + rewrite -subr_eq0 -cfdotBr -raddfB Dtau3 //. + rewrite Itau // ?sS0A //; last exact: zchar_filter Zdlam. + suffices{lam S3lam Zdlam} oS3a: {in S3, forall lam, '[alpha, lam] = 0}. + by rewrite cfdotBr subr_eq0 !oS3a. + move=> lam; rewrite mem_filter /= -eqS12 => /andP[S1'lam H0C'lam]. + by rewrite cfdotBl oSgamma // (seqInd_ortho _ Spsi1) ?(memPn S1'lam) // subr0. +have{s4gt0 gtS4alpha} /hasP[lam1 S4lam1 _]: has predT S4 by rewrite has_predT. +have [/irrP[l1 Dl1] S3lam1]: lam1 \in irr M /\ lam1 \in S3. + by move: S4lam1; rewrite mem_filter -andbA negbK => /and3P[]. +have [S1'lam1 Slam1]: lam1 \notin S1 /\ lam1 \in S_ H0C'. + by move: S3lam1; rewrite mem_filter eqS12 => /andP[]. +have S3lam1s: lam1^*%CF \in S3 by have [[_ _ ->]] := scohS3. +have ZS3dlam1: lam1 - lam1^*%CF \in 'Z[S3, M^#]. + rewrite zcharD1E rpredB ?mem_zchar //. + by have:= seqInd_sub_aut_zchar nsHUM conjC Slam1; rewrite zcharD1 => /andP[]. +have ZAdlam1: lam1 - lam1^*%CF \in 'Z[irr M, 'A(M)]. + rewrite sS0A // zchar_split rpredB ?mem_zchar ?cfAut_seqInd //. + by rewrite (zchar_on ZS3dlam1). +pose beta := lam1 - (u %/ a)%:R *: psi1. +have ZAbeta: beta \in 'Z[irr M, 'A(M)]. + apply: sS0A; rewrite zcharD1E rpredB ?scaler_nat ?rpredMn ?mem_zchar //=. + by rewrite !cfunE subr_eq0 psi1qa -natrM mulnCA divnK // S3qu. +have [_ _ poSS _ _] := scohS0; have [_ oSS] := pairwise_orthogonalP poSS. +have o1S1: orthonormal S1. + rewrite orthonormalE filter_pairwise_orthogonal // andbT. + by apply/allP=> _ /irrS1/irrP[t ->]; rewrite /= cfnorm_irr. +have o1S4: orthonormal S4. + rewrite orthonormalE !filter_pairwise_orthogonal // andbT. + apply/allP=> nu; rewrite mem_filter /= -andbA negbK. + by case/andP=> /irrP[t ->]; rewrite cfnorm_irr. +have n1psi1: '[psi1] = 1 by have [_ -> //] := orthonormalP o1S1; rewrite eqxx. +have n1lam1: '[lam1] = 1 by have [_ -> //] := orthonormalP o1S4; rewrite eqxx. +have oS14tau: orthogonal (map tau1 S1) (map tau3 S4). + apply/orthogonalP=> psi _ S1psi /mapP[lam /sS43 S3lam ->]. + apply: {psi lam S3lam}orthogonalP S1psi (map_f tau3 S3lam). + apply: (coherent_ortho scohS0 sS10 cohS1 sS30 cohS3) => psi /=. + by rewrite mem_filter !inE eqS12 => /andP[-> _]. +have [Gamma [S4_Gamma normGamma [b Dbeta]]]: + exists Gamma, [/\ Gamma \in 'Z[map tau3 S4], '[Gamma] = 1 + & exists b : bool, beta^\tau + = Gamma - (u %/ a)%:R *: tau1 psi1 + b%:R *: \sum_(psi <- S1) tau1 psi]. +- have [G S4G [G' [Dbeta _ oG'4]]] := orthogonal_split (map tau3 S4) beta^\tau. + have [B S1B [Delta [dG' _ oD1]]] := orthogonal_split (map tau1 S1) G'. + have sZS43: {subset 'Z[S4] <= 'Z[S3]} := zchar_subset sS43. + have [Itau34 Ztau34] := sub_iso_to sZS43 sub_refl IZtau3. + have Z_G: G \in 'Z[map tau3 S4]. + have [_ -> ->] := orthonormal_span (map_orthonormal Itau34 o1S4) S4G. + rewrite big_seq rpred_sum // => xi S4xi; rewrite rpredZ_Cint ?mem_zchar //. + rewrite -(addrK G' G) -Dbeta cfdotBl (orthoPl oG'4) // subr0. + rewrite Cint_cfdot_vchar ?Ztau //. + by have{xi S4xi} [xi S4xi ->] := mapP S4xi; rewrite Ztau34 ?mem_zchar. + have oD4: orthogonal Delta (map tau3 S4). + apply/orthoPl=> xi S4xi; rewrite -(addKr B Delta) addrC -dG' cfdotBl. + by rewrite (orthoPl oG'4) // (span_orthogonal oS14tau) ?subrr // memv_span. + have [_ -> dB] := orthonormal_span (map_orthonormal Itau1 o1S1) S1B. + pose b := (u %/ a)%:R + '[B, tau1 psi1]. + have betaS1_B: {in S1, forall psi, '[beta^\tau, tau1 psi] = '[B, tau1 psi]}. + move=> psi S1psi; rewrite Dbeta dG' !cfdotDl (orthoPl oD1) ?map_f // addr0. + rewrite cfdotC (span_orthogonal oS14tau) ?rmorph0 ?add0r //. + by rewrite memv_span ?map_f. + have Zb: b \in Cint. + rewrite rpredD ?rpred_nat // -betaS1_B // Cint_cfdot_vchar ?Ztau //. + by rewrite Ztau1 ?mem_zchar. + have{dB} dB: B = - (u %/ a)%:R *: tau1 psi1 + b *: \sum_(psi <- S1) tau1 psi. + rewrite dB big_map !(big_rem _ S1psi1) /= scalerDr addrA -scalerDl addKr. + rewrite scaler_sumr; congr (_ + _); apply: eq_big_seq => psi. + rewrite mem_rem_uniq ?filter_uniq ?seqInd_uniq // => /andP[/= psi_1' S1psi]. + apply/esym/eqP; rewrite -subr_eq0 -scalerBl -addrA -!betaS1_B // -cfdotBr. + have [/eqP psi_qa Spsi]: psi 1%g == (q * a)%:R /\ psi \in S_ H0C'. + by move: S1psi; rewrite mem_filter => /andP[]. + have Z1dpsi: psi1 - psi \in 'Z[S1, M^#]. + by rewrite zcharD1E rpredB ?mem_zchar //= !cfunE psi1qa psi_qa subrr. + rewrite -raddfB Dtau1 // Itau //; last first. + by rewrite sS0A // zchar_split rpredB ?mem_zchar ?(zchar_on Z1dpsi). + rewrite cfdotC cfdotBr cfdotZr !cfdotBl 2?oSS ?(memPn S1'lam1) // subrr. + by rewrite add0r n1psi1 oSS // subr0 mulr1 rmorphN conjCK subrr scale0r. + have Gge1: 1 <= '[G] ?= iff ('[G] == 1). + rewrite eq_sym; apply: lerif_eq. + have N_G: '[G] \in Cnat. + apply: Cnat_cfnorm_vchar; apply: zchar_sub_irr Z_G => _ /mapP[nu S4nu ->]. + by rewrite Ztau34 ?mem_zchar. + rewrite -(truncCK N_G) ler1n lt0n -eqC_nat truncCK {N_G}// cfnorm_eq0. + have: '[beta^\tau, (lam1 - lam1^*%CF)^\tau] != 0. + rewrite Itau // cfdotBl cfdotZl !cfdotBr n1lam1. + rewrite (seqInd_conjC_ortho _ _ _ Slam1) ?mFT_odd // subr0. + rewrite !oSS ?cfAut_seqInd -?(inv_eq (@cfConjCK _ _)) ?(memPn S1'lam1) //. + by rewrite !(subr0, mulr0) oner_eq0. + by have [_ _ ->] := sS10. + rewrite Dbeta -Dtau3 //; apply: contraNneq => ->. + rewrite add0r raddfB cfdotBr !(orthoPl oG'4) ?map_f ?subr0 //. + rewrite mem_filter /= negbK /= S3lam1s irr_aut. + move: S4lam1; rewrite mem_filter /= negbK /= -andbA => /and3P[-> H0Clam1 _]. + by rewrite cfAut_seqInd. + have ubG: '[G] + (b ^+ 2 - b) * (u %/ a).*2%:R + '[Delta] = 1. + apply: (addrI ((u %/ a) ^ 2)%:R); transitivity '[beta^\tau]. + rewrite -!addrA addrCA Dbeta cfnormDd; last first. + by rewrite cfdotC (span_orthogonal oG'4) ?rmorph0 // memv_span ?inE. + congr (_ + _); rewrite !addrA dG' cfnormDd; last first. + by rewrite cfdotC (span_orthogonal oD1) ?rmorph0 // memv_span ?inE. + congr (_ + _); rewrite dB scaleNr [- _ + _]addrC cfnormB !cfnormZ. + rewrite normr_nat Cint_normK // scaler_sumr cfdotZr rmorph_nat. + rewrite cfnorm_map_orthonormal // cfproj_sum_orthonormal //. + rewrite Itau1 ?mem_zchar // n1psi1 mulr1 rmorphM rmorph_nat conj_Cint //. + rewrite -mulr2n oS1ua -muln_divA // mul2n -addrA addrCA -natrX mulrBl. + by congr (_ + (_ - _)); rewrite -mulrnAl -mulrnA muln2 mulrC. + rewrite Itau // cfnormBd; last first. + by rewrite cfdotZr oSS ?mulr0 // (memPnC S1'lam1). + by rewrite cfnormZ normr_nat n1psi1 n1lam1 mulr1 addrC -natrX. + have ubDelta: '[G] <= '[G] + '[Delta] ?= iff (Delta == 0). + rewrite addrC -lerif_subLR subrr -cfnorm_eq0 eq_sym. + by apply: lerif_eq; apply: cfnorm_ge0. + have{ubG} ubDeltaG: '[G] + '[Delta] <= 1 ?= iff pred2 0 1 b. + rewrite -{1}ubG addrAC [_ + _ + _] addrC -lerif_subLR subrr /=. + set n := _%:R; rewrite mulrC -{1}(mulr0 n) mono_lerif; last first. + by apply: ler_pmul2l; rewrite ltr0n double_gt0 divn_gt0 // dvdn_leq. + rewrite /= -(subr_eq0 b 1) -mulf_eq0 mulrBr mulr1 eq_sym. + apply: lerif_eq; rewrite subr_ge0. + have [-> | nz_b] := eqVneq b 0; first by rewrite expr2 mul0r. + rewrite (ler_trans (real_ler_norm _)) ?Creal_Cint // -[`|b|]mulr1. + by rewrite -Cint_normK // ler_pmul2l ?normr_gt0 // norm_Cint_ge1. + have [_ /esym] := lerif_trans Gge1 (lerif_trans ubDelta ubDeltaG). + rewrite eqxx => /and3P[/eqP normG1 /eqP Delta0 /pred2P b01]. + exists G; split=> //; exists (b != 0). + rewrite Dbeta dG' Delta0 addr0 dB scaleNr addrA; congr (_ + _ *: _). + by case: b01 => ->; rewrite ?eqxx ?oner_eq0. +(* Final step (9.11.8). *) +have alpha_beta: '[alpha^\tau, beta^\tau] = (u %/ a)%:R. + rewrite Itau // cfdotBr cfdotZr rmorph_nat !cfdotBl !oSgamma // !sub0r. + by rewrite n1psi1 mulrN opprK mulr1 addrC oSS ?subr0 // (memPn S1'lam1). +have [X S1X [Delta [Dalpha _ oD1]]]:= orthogonal_split (map tau1 S1) alpha^\tau. +pose x := 1 + '[X, tau1 psi1]. +have alphaS1_X: {in S1, forall psi, '[alpha^\tau, tau1 psi] = '[X, tau1 psi]}. + by move=> psi S1psi; rewrite Dalpha cfdotDl (orthoPl oD1) ?map_f // addr0. +have Zx: x \in Cint. + rewrite rpredD ?rpred1 // -alphaS1_X // Cint_cfdot_vchar ?Ztau //. + by rewrite Ztau1 ?mem_zchar. +have{alphaS1_X S1X} defX: X = x *: (\sum_(psi <- S1) tau1 psi) - tau1 psi1. + have [_ -> ->] := orthonormal_span (map_orthonormal Itau1 o1S1) S1X. + rewrite addrC -scaleN1r big_map !(big_rem _ S1psi1) /= scalerDr addrA. + rewrite -scalerDl addKr scaler_sumr; congr (_ + _); apply: eq_big_seq => psi. + rewrite mem_rem_uniq ?filter_uniq ?seqInd_uniq // => /andP[/= psi_1' S1psi]. + apply/esym/eqP; rewrite -subr_eq0 -scalerBl -addrA -!alphaS1_X // -cfdotBr. + have [/eqP psi_qa Spsi]: psi 1%g == (q * a)%:R /\ psi \in S_ H0C'. + by move: S1psi; rewrite mem_filter => /andP[]. + have Z1dpsi: psi1 - psi \in 'Z[S1, M^#]. + by rewrite zcharD1E rpredB ?mem_zchar //= !cfunE psi1qa psi_qa subrr. + rewrite -raddfB Dtau1 // Itau //; last first. + by rewrite sS0A // zchar_split rpredB ?mem_zchar ?(zchar_on Z1dpsi). + rewrite cfdotBr !cfdotBl !oSgamma // n1psi1 cfdotC oSS // rmorph0. + by rewrite !subr0 add0r subrr scale0r. +have{x Zx X defX Delta Dalpha oD1} b_mod_ua: (b == 0 %[mod u %/ a])%C. + rewrite -oppr0 -eqCmodN (eqCmod_trans _ (eqCmodm0 _)) // {2}nCdivE. + rewrite -alpha_beta Dbeta -addrA cfdotDr. + rewrite (span_orthogonal o_alpha_S3) ?add0r; first 1 last. + - by rewrite memv_span ?inE. + - apply: subvP (zchar_span S4_Gamma); apply: sub_span; apply: mem_subseq. + by rewrite map_subseq ?filter_subseq. + rewrite Dalpha addrC cfdotDl (span_orthogonal oD1); first 1 last. + - by rewrite memv_span ?inE. + - rewrite addrC rpredB ?rpredZ //; last by rewrite memv_span ?map_f. + by rewrite big_seq rpred_sum // => psi S1psi; rewrite memv_span ?map_f. + rewrite add0r addrC defX cfdotBr cfdotBl cfdotZl cfdotZr !scaler_sumr. + rewrite cfdotZr !rmorph_nat cfdotBl Itau1 ?mem_zchar // n1psi1. + rewrite cfnorm_map_orthonormal // cfdotC !cfproj_sum_orthonormal //. + rewrite rmorph_nat oS1ua -muln_divA // natrM !mulrA addrC mulrC addrA. + rewrite -mulNr -mulrDl eqCmod_sym eqCmod_addl_mul // addrC !rpredB ?rpred1 //. + by rewrite !rpredM ?rpred_nat. +have{b_mod_ua alpha_beta} b0: b = 0%N :> nat. + have:= b_mod_ua; rewrite /eqCmod subr0 dvdC_nat => /eqnP. + rewrite modn_small // (leq_ltn_trans (leq_b1 b)) // ltn_divRL // mul1n. + by rewrite ltn_neqAle -(eqn_pmul2l q_gt0) eq_sym ne_qa_qu dvdn_leq. +exists lam1 => //; suffices: coherent (lam1 :: lam1^* :: S1)%CF M^# tau. + by apply: subset_coherent => phi; rewrite !inE eqS12. +move: Dbeta; rewrite b0 scale0r addr0. +apply: (extend_coherent_with scohS0 sS10 cohS1); first by []. +rewrite rpred_nat psi1qa -natrM mulnCA (eqP (S3qu _ S3lam1)) divnK //. +rewrite cfdotC (span_orthogonal oS14tau) ?(zchar_span S4_Gamma) ?conjC0 //. +by rewrite rpredZ ?memv_span ?map_f. +Qed. + +End Nine. diff --git a/mathcomp/odd_order/all.v b/mathcomp/odd_order/all.v new file mode 100644 index 0000000..613acb0 --- /dev/null +++ b/mathcomp/odd_order/all.v @@ -0,0 +1,33 @@ +Require Export BGappendixAB. +Require Export BGappendixC. +Require Export BGsection10. +Require Export BGsection11. +Require Export BGsection12. +Require Export BGsection13. +Require Export BGsection14. +Require Export BGsection15. +Require Export BGsection16. +Require Export BGsection1. +Require Export BGsection2. +Require Export BGsection3. +Require Export BGsection4. +Require Export BGsection5. +Require Export BGsection6. +Require Export BGsection7. +Require Export BGsection8. +Require Export BGsection9. +Require Export PFsection10. +Require Export PFsection11. +Require Export PFsection12. +Require Export PFsection13. +Require Export PFsection14. +Require Export PFsection1. +Require Export PFsection2. +Require Export PFsection3. +Require Export PFsection4. +Require Export PFsection5. +Require Export PFsection6. +Require Export PFsection7. +Require Export PFsection8. +Require Export PFsection9. +Require Export stripped_odd_order_theorem. diff --git a/mathcomp/odd_order/stripped_odd_order_theorem.v b/mathcomp/odd_order/stripped_odd_order_theorem.v new file mode 100644 index 0000000..8123683 --- /dev/null +++ b/mathcomp/odd_order/stripped_odd_order_theorem.v @@ -0,0 +1,204 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Prelude ssreflect ssrbool ssrfun eqtype ssrnat fintype finset fingroup. +Require morphism quotient action gfunctor gproduct commutator gseries nilpotent. +Require PFsection14. + +(******************************************************************************) +(* This file contains a minimal, self-contained reformulation of the Odd *) +(* Order theorem, using only the bare Coq logic, and avoiding any use of *) +(* extra-logical features such as notation, coercion or implicit arguments. *) +(* This stripped theorem would hardly be usable, however; it just provides *) +(* evidence for the sceptics. *) +(******************************************************************************) + +(* Equivalence and equality *) + +Inductive equivalent P Q := Equivalent (P_to_Q : P -> Q) (Q_to_P : Q -> P). + +Inductive equal T (x : T) : T -> Type := Equal : equal T x x. + +(* Arithmetic *) + +Inductive natural := Zero | Add_1_to (n : natural). + +Fixpoint add (m n : natural) : natural := + match m with Zero => n | Add_1_to m_minus_1 => add m_minus_1 (Add_1_to n) end. + +Definition double (n : natural) : natural := add n n. + +Inductive odd (n : natural) := + Odd (half : natural) + (n_odd : equal natural n (Add_1_to (double half))). + +Inductive less_than (m n : natural) := + LessThan (diff : natural) + (m_lt_n : equal natural n (Add_1_to (add m diff))). + +(* Finite subsets *) + +Definition injective_in T R (D : T -> Type) (f : T -> R) := + forall x y, D x -> D y -> equal R (f x) (f y) -> equal T x y. + +Inductive in_image T R (D : T -> Type) (f : T -> R) (a : R) := + InImage (x : T) (x_in_D : D x) (a_is_fx : equal R a (f x)). + +Inductive finite_of_order T (D : T -> Type) (n : natural) := + FiniteOfOrder (rank : T -> natural) + (rank_injective : injective_in T natural D rank) + (rank_onto : + forall i, equivalent (less_than i n) (in_image T natural D rank i)). + +(* Elementary group theory *) + +Inductive group_axioms T (mul : T -> T -> T) (one : T) (inv : T -> T) := + GroupAxioms + (associativity : forall x y z, equal T (mul x (mul y z)) (mul (mul x y) z)) + (left_identity : forall x, equal T (mul one x) x) + (left_inverse : forall x, equal T (mul (inv x) x) one). + +Inductive group T mul one inv (G : T -> Type) := + Group + (G_closed_under_mul : forall x y, G x -> G y -> G (mul x y)) + (one_in_G : G one) + (G_closed_under_inv : forall x, G x -> G (inv x)). + +Inductive subgroup T mul one inv (H G : T -> Type) := + Subgroup + (H_group : group T mul one inv H) + (H_subset_G : forall x, H x -> G x). + +Inductive normal_subgroup T mul one inv (H G : T -> Type) := + NormalSubgroup + (H_subgroup_G : subgroup T mul one inv H G) + (H_is_G_invariant : forall x y, H x -> G y -> H (mul (inv y) (mul x y))). + +Inductive commute_mod T mul (x y : T) (H : T -> Type) := + CommuteMod (z : T) + (z_in_H : H z) + (xy_eq_zyx : equal T (mul x y) (mul z (mul y x))). + +Inductive abelian_factor T mul one inv (G H : T -> Type) := + AbelianFactor + (G_group : group T mul one inv G) + (H_normal_in_G : normal_subgroup T mul one inv H G) + (G_on_H_abelian : forall x y, G x -> G y -> commute_mod T mul x y H). + +Inductive solvable_group T mul one inv (G : T -> Type) := +| TrivialGroupSolvable + (G_trivial : forall x, equivalent (G x) (equal T x one)) +| AbelianExtensionSolvable (H : T -> Type) + (H_solvable : solvable_group T mul one inv H) + (G_on_H_abelian : abelian_factor T mul one inv G H). + +(* begin hide *) +Module InternalSkepticOddOrderProof. + +Local Notation Aeq := (equal _). +Local Notation Aadd := add. +Local Notation Adouble := double. +Local Notation Aodd := odd. +Local Notation Alt := less_than. +Local Notation Agroup := group. +Local Notation Asubgroup := subgroup. +Local Notation Anormal := normal_subgroup. +Local Notation Aabel_quo := abelian_factor. +Local Notation Asol := solvable_group. + +Import Prelude ssreflect ssrbool ssrfun eqtype ssrnat fintype finset fingroup. +Import morphism quotient action gfunctor gproduct commutator gseries nilpotent. +Import GroupScope. + +Lemma main T mul one inv G nn : + group_axioms T mul one inv -> Agroup T mul one inv G -> + finite_of_order T G nn -> Aodd nn -> + Asol T mul one inv G. +Proof. +pose fix natN n := if n is n1.+1 then Add_1_to (natN n1) else Zero. +pose fix Nnat mm := if mm is Add_1_to mm1 then (Nnat mm1).+1 else 0. +have natN_K: cancel natN Nnat by elim=> //= n ->. +have NnatK: cancel Nnat natN by elim=> //= mm ->. +have AaddE nn1 nn2: Nnat (Aadd nn1 nn2) = Nnat nn1 + Nnat nn2. + by elim: nn1 nn2 => //= nn1 IHnn nn2; rewrite IHnn addnS. +have AltE m n: Alt (natN m) (natN n) -> m < n. + by rewrite -{2}[n]natN_K => [[dd ->]]; rewrite /= ltnS AaddE natN_K leq_addr. +have AltI m n: m < n -> Alt (natN m) (natN n). + move/subnKC <-; exists (natN (n - m.+1)). + by rewrite -[Add_1_to _]NnatK /= AaddE !natN_K. +have AoddE n: Aodd (natN n) -> odd n. + by rewrite -{2}[n]natN_K => [[hh ->]]; rewrite /= AaddE addnn odd_double. +case=> mulA mul1T mulVT [mulG oneG invG] [rG inj_rG im_rG] odd_nn. +pose n := Nnat nn; have{odd_nn} odd_n: odd n by rewrite AoddE ?NnatK. +have{rG inj_rG im_rG} [gT o_gT [f [g Gf [fK gK]] [fM f1 fV]]]: + {gT : finGroupType & #|gT| = n & {f : gT -> T + & {g : _ & forall a, G (f a) & cancel f g /\ forall x, G x -> f (g x) = x} + & [/\ {morph f : a b / a * b >-> mul a b}, f 1 = one + & {morph f : a / a^-1 >-> inv a}]}}. +- pose gT := 'I_n.-1.+1; pose g x : gT := inord (Nnat (rG x)). + have ub_rG x: G x -> Nnat (rG x) < n. + move=> Gx; rewrite AltE ?NnatK //. + by have [_] := im_rG (rG x); apply; exists x. + have Dn: n.-1.+1 = n := ltn_predK (ub_rG one oneG). + have fP a: {x : T & G x * (g x = a)}%type. + have a_lt_n: Alt (natN a) nn by rewrite -(canLR NnatK Dn); apply: AltI. + have [/(_ a_lt_n)[x Gx rGx] _] := im_rG (natN a). + by exists x; split; rewrite // /g -rGx natN_K inord_val. + pose f a := tag (fP a); have Gf a: G (f a) by rewrite /f; case: (fP) => x []. + have fK: cancel f g by rewrite /f => a; case: (fP a) => x []. + have Ng x & G x: natN (g x) = rG x by rewrite inordK ?Dn ?ub_rG ?NnatK. + have{Ng} gK x: G x -> f (g x) = x. + by move=> Gx; rewrite (inj_rG (f (g x)) x) // -!Ng ?fK. + pose m a b := g (mul (f a) (f b)). + pose o := g one; pose v a := g (inv (f a)). + have fM: {morph f: a b / m a b >-> mul a b} by move=> a b; apply/gK/mulG. + have f1: f o = one by apply: gK. + have fV: {morph f: a / v a >-> inv a} by move=> a; apply/gK/invG. + have mA: associative m by move=> a b c; apply: canLR fK _; rewrite !fM mulA. + have m1: left_id o m by move=> a; apply: canLR fK _; rewrite f1 mul1T. + have mV: left_inverse o v m. + by move=> a; apply: canLR fK _; rewrite fV f1 mulVT. + pose bT := BaseFinGroupType _ (FinGroup.Mixin mA m1 mV). + exists (@FinGroupType bT mV); first by rewrite card_ord Dn. + by exists f; first exists g. +pose im (H : {group gT}) x := (G x * (g x \in H))%type. +have imG H : Agroup T mul one inv (im H). + split=> [x y [Gx Hx] [Gy Hy] | | x [Gx Hx]]; first 1 last. + - by split; rewrite // -(canRL fK f1). + - by split; [auto | rewrite -(gK x Gx) -fV fK groupV]. + by split; [auto | rewrite -(gK x Gx) -(gK y Gy) -fM fK groupM]. +pose G0 := [set: gT]%G. +have sGG0 x: G x -> im G0 x by split; rewrite ?inE. +have mulVV1 x: mul (inv (inv x)) one = x by rewrite -(mulVT x) mulA mulVT mul1T. +have{mulVV1} mulT1 x: mul x one = x by rewrite -[x]mulVV1 -mulA mul1T. +pose comm x y := mul (mul x y) (inv (mul y x)). +suffices solH: Asol T mul one inv (im G0). + right with (im G0) => //; split=> // [|x y Gx Gy]. + by split=> // [|x y [Gx _] Gy]; [split=> // x [] | apply: sGG0; auto]. + by exists (comm x y); [rewrite /comm; auto | rewrite -mulA mulVT -mulA mulT1]. +have solG0: solvable G0 by rewrite PFsection14.Feit_Thompson ?cardsT ?o_gT. +elim: _.+1 {-2}G0 (ltnSn #|G0|) => // m IHm H; rewrite ltnS => leHm. +have [-> | ntH] := eqVneq H 1%G. + left=> // x; split=> [[Gx /set1P] | ->]. + by rewrite -f1 => <-; rewrite gK. + by split; rewrite // -f1 fK. +have ltH'H: H^`(1) \proper H := sol_der1_proper solG0 (subsetT H) ntH. +right with (im H^`(1)%G); first exact: IHm (leq_trans (proper_card _) leHm). +have /andP[/subsetP sH'H /subsetP nH'H]: H^`(1) <| H := der_normal 1 H. +split=> // [|x y [Gx Hx] [Gy Hy]]. + split=> // [|x y [Gx H'x] [Gy Hy]]; first by split=> // x [Gx /sH'H]. + split; first by [auto]; rewrite -(gK x Gx) -(gK y Gy) -!(fM, fV) !fK. + by rewrite memJ_norm ?nH'H. +exists (comm x y); last by rewrite -mulA mulVT -mulA mulT1. +rewrite /comm; split; first by [auto]; rewrite -(gK x Gx) -(gK y Gy). +by rewrite -!(fM, fV) fK -[g x * g y]invgK !invMg -mulgA mem_commg ?groupV. +Qed. + +End InternalSkepticOddOrderProof. +(* end hide *) + +(* The Odd Order theorem *) + +Theorem stripped_Odd_Order T mul one inv (G : T -> Type) (n : natural) : + group_axioms T mul one inv -> group T mul one inv G -> + finite_of_order T G n -> odd n -> + solvable_group T mul one inv G. +Proof. exact (InternalSkepticOddOrderProof.main T mul one inv G n). Qed. diff --git a/mathcomp/real_closed/all.v b/mathcomp/real_closed/all.v new file mode 100644 index 0000000..c9de2b6 --- /dev/null +++ b/mathcomp/real_closed/all.v @@ -0,0 +1,9 @@ +Require Export bigenough. +Require Export cauchyreals. +Require Export complex. +Require Export ordered_qelim. +Require Export polyorder. +Require Export polyrcf. +Require Export qe_rcf_th. +Require Export qe_rcf. +Require Export realalg. diff --git a/mathcomp/real_closed/bigenough.v b/mathcomp/real_closed/bigenough.v new file mode 100644 index 0000000..d9c89ca --- /dev/null +++ b/mathcomp/real_closed/bigenough.v @@ -0,0 +1,118 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype. + +(****************************************************************************) +(* This is a small library to do epsilon - N reasonning. *) +(* In order to use it, one only has to know the following tactics: *) +(* *) +(* pose_big_enough i == pose a big enough natural number i *) +(* pose_big_modulus m F == pose a function m : F -> nat which should *) +(* provide a big enough return value *) +(* exists_big_modulus m F := pose_big_modulus m F; exists m *) +(* big_enough == replaces a big enough constraint x <= i *) +(* by true and implicity remembers that i should *) +(* be bigger than x. *) +(* close == all "pose" tactics create a dummy subgoal to *) +(* force the user to explictely indicate that all *) +(* constraints have been found *) +(****************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Module BigEnough. + +Record big_rel_class_of T (leq : rel T) := + BigRelClass { + leq_big_internal_op : rel T; + bigger_than_op : seq T -> T; + _ : leq_big_internal_op = leq; + _ : forall i s, leq_big_internal_op i (bigger_than_op (i :: s)); + _ : forall i j s, leq_big_internal_op i (bigger_than_op s) -> + leq_big_internal_op i (bigger_than_op (j :: s)) +}. + +Record big_rel_of T := BigRelOf { + leq_big :> rel T; + big_rel_class : big_rel_class_of leq_big +}. + +Definition bigger_than_of T (b : big_rel_of T) + (phb : phantom (rel T) b) := + bigger_than_op (big_rel_class b). +Notation bigger_than leq := (@bigger_than_of _ _ (Phantom (rel _) leq)). + +Definition leq_big_internal_of T (b : big_rel_of T) + (phb : phantom (rel T) b) := + leq_big_internal_op (big_rel_class b). +Notation leq_big_internal leq := (@leq_big_internal_of _ _ (Phantom (rel _) leq)). + +Lemma next_bigger_than T (b : big_rel_of T) i j s : + leq_big_internal b i (bigger_than b s) -> + leq_big_internal b i (bigger_than b (j :: s)). +Proof. by case: b i j s => [? []]. Qed. + +Lemma instantiate_bigger_than T (b : big_rel_of T) i s : + leq_big_internal b i (bigger_than b (i :: s)). +Proof. by case: b i s => [? []]. Qed. + +Lemma leq_big_internalE T (b : big_rel_of T) : leq_big_internal b = leq_big b. +Proof. by case: b => [? []]. Qed. + +(* Lemma big_enough T (b : big_rel_of T) i s : *) +(* leq_big_internal b i (bigger_than b s) -> *) +(* leq_big b i (bigger_than b s). *) +(* Proof. by rewrite leq_big_internalE. Qed. *) + +Lemma context_big_enough P T (b : big_rel_of T) i s : + leq_big_internal b i (bigger_than b s) -> + P true -> + P (leq_big b i (bigger_than b s)). +Proof. by rewrite leq_big_internalE => ->. Qed. + +Definition big_rel_leq_class : big_rel_class_of leq. +Proof. +exists leq (foldr maxn 0%N) => [|i s|i j s /leq_trans->] //; +by rewrite (leq_maxl, leq_maxr). +Qed. +Canonical big_enough_nat := BigRelOf big_rel_leq_class. + +Definition closed T (i : T) := {j : T | j = i}. +Ltac close := match goal with + | |- context [closed ?i] => + instantiate (1 := [::]) in (Value of i); exists i + end. + +Ltac pose_big_enough i := + evar (i : nat); suff : closed i; first do + [move=> _; instantiate (1 := bigger_than leq _) in (Value of i)]. + +Ltac pose_big_modulus m F := + evar (m : F -> nat); suff : closed m; first do + [move=> _; instantiate (1 := (fun e => bigger_than leq _)) in (Value of m)]. + +Ltac exists_big_modulus m F := pose_big_modulus m F; first exists m. + +Ltac olddone := + trivial; hnf; intros; solve + [ do ![solve [trivial | apply: sym_equal; trivial] + | discriminate | contradiction | split] + | case not_locked_false_eq_true; assumption + | match goal with H : ~ _ |- _ => solve [case H; trivial] end]. + +Ltac big_enough := + do ?[ apply context_big_enough; + first do [do ?[ now apply instantiate_bigger_than + | apply next_bigger_than]]]. + +Ltac big_enough_trans := + match goal with + | [leq_nm : is_true (?n <= ?m)%N |- is_true (?x <= ?m)] => + apply: leq_trans leq_nm; big_enough; olddone + | _ => big_enough; olddone + end. + +Ltac done := do [olddone|big_enough_trans]. + +End BigEnough. diff --git a/mathcomp/real_closed/cauchyreals.v b/mathcomp/real_closed/cauchyreals.v new file mode 100644 index 0000000..83504be --- /dev/null +++ b/mathcomp/real_closed/cauchyreals.v @@ -0,0 +1,1681 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype. +Require Import bigop ssralg ssrnum ssrint rat poly polydiv polyorder. +Require Import perm matrix mxpoly polyXY binomial bigenough. + +(***************************************************************************) +(* This is a standalone construction of Cauchy reals over an arbitrary *) +(* discrete archimedian field R. *) +(* creals R == setoid of Cauchy sequences, it is not discrete and *) +(* cannot be equipped with any ssreflect algebraic structure *) +(***************************************************************************) + +Import GRing.Theory Num.Theory Num.Def BigEnough. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Delimit Scope creal_scope with CR. + +Section poly_extra. + +Local Open Scope ring_scope. + +Lemma monic_monic_from_neq0 (F : fieldType) (p : {poly F}) : + (p != 0)%B -> (lead_coef p) ^-1 *: p \is monic. +Proof. by move=> ?; rewrite monicE lead_coefZ mulVf ?lead_coef_eq0. Qed. + +(* GG -- lemmas with ssrnum dependencies cannot go in poly! *) +Lemma size_derivn (R : realDomainType) (p : {poly R}) n : + size p^`(n) = (size p - n)%N. +Proof. +elim: n=> [|n ihn]; first by rewrite derivn0 subn0. +by rewrite derivnS size_deriv ihn -subnS. +Qed. + +Lemma size_nderivn (R : realDomainType) (p : {poly R}) n : + size p^`N(n) = (size p - n)%N. +Proof. +rewrite -size_derivn nderivn_def -mulr_natl. +by rewrite -polyC1 -!polyC_muln size_Cmul // pnatr_eq0 -lt0n fact_gt0. +Qed. + +End poly_extra. + +Local Notation eval := horner_eval. + +Section ordered_extra. + +Definition gtr0E := (invr_gt0, exprn_gt0, ltr0n, @ltr01). +Definition ger0E := (invr_ge0, exprn_ge0, ler0n, @ler01). + +End ordered_extra. + +Section polyorder_extra. + +Variable F : realDomainType. + +Local Open Scope ring_scope. + +Definition poly_bound (p : {poly F}) (a r : F) : F + := 1 + \sum_(i < size p) `|p`_i| * (`|a| + `|r|) ^+ i. + +Lemma poly_boundP p a r x : `|x - a| <= r -> + `|p.[x]| <= poly_bound p a r. +Proof. +have [r_ge0|r_lt0] := lerP 0 r; last first. + by move=> hr; have := ler_lt_trans hr r_lt0; rewrite normr_lt0. +rewrite ler_distl=> /andP[lx ux]. +rewrite ler_paddl //. +elim/poly_ind: p=> [|p c ihp]. + by rewrite horner0 normr0 size_poly0 big_ord0. +rewrite hornerMXaddC size_MXaddC. +have [->|p_neq0 /=] := altP eqP. + rewrite horner0 !mul0r !add0r size_poly0. + have [->|c_neq0] /= := altP eqP; first by rewrite normr0 big_ord0. + rewrite big_ord_recl big_ord0 addr0 coefC /=. + by rewrite ler_pmulr ?normr_gt0 // ler_addl ler_maxr !normr_ge0. +rewrite big_ord_recl coefD coefMX coefC eqxx add0r. +rewrite (ler_trans (ler_norm_add _ _)) // addrC ler_add //. + by rewrite expr0 mulr1. +rewrite normrM. +move: ihp=> /(ler_wpmul2r (normr_ge0 x)) /ler_trans-> //. +rewrite mulr_suml ler_sum // => i _. +rewrite coefD coefC coefMX /= addr0 exprSr mulrA. +rewrite ler_wpmul2l //. + by rewrite ?mulr_ge0 ?exprn_ge0 ?ler_maxr ?addr_ge0 ?normr_ge0 // ltrW. +rewrite (ger0_norm r_ge0) ler_norml opprD. +rewrite (ler_trans _ lx) ?(ler_trans ux) // ler_add2r. + by rewrite ler_normr lerr. +by rewrite ler_oppl ler_normr lerr orbT. +Qed. + +Lemma poly_bound_gt0 p a r : 0 < poly_bound p a r. +Proof. +rewrite ltr_paddr // sumr_ge0 // => i _. +by rewrite mulr_ge0 ?exprn_ge0 ?addr_ge0 ?ler_maxr ?normr_ge0 // ltrW. +Qed. + +Lemma poly_bound_ge0 p a r : 0 <= poly_bound p a r. +Proof. by rewrite ltrW // poly_bound_gt0. Qed. + +Definition poly_accr_bound (p : {poly F}) (a r : F) : F + := (maxr 1 (2%:R * r)) ^+ (size p).-1 + * (1 + \sum_(i < (size p).-1) poly_bound p^`N(i.+1) a r). + +Lemma poly_accr_bound1P p a r x y : + `|x - a| <= r -> `|y - a| <= r -> + `|p.[y] - p.[x]| <= `|y - x| * poly_accr_bound p a r. +Proof. +have [|r_lt0] := lerP 0 r; last first. + by move=> hr; have := ler_lt_trans hr r_lt0; rewrite normr_lt0. +rewrite le0r=> /orP[/eqP->|r_gt0 hx hy]. + by rewrite !normr_le0 !subr_eq0=> /eqP-> /eqP->; rewrite !subrr normr0 mul0r. +rewrite mulrA mulrDr mulr1 ler_paddl ?mulr_ge0 ?normr_ge0 //=. + by rewrite exprn_ge0 ?ler_maxr ?mulr_ge0 ?ger0E ?ltrW. +rewrite -{1}(addNKr x y) [- _ + _]addrC /= -mulrA. +rewrite nderiv_taylor; last exact: mulrC. +have [->|p_neq0] := eqVneq p 0. + rewrite size_poly0 big_ord0 horner0 subr0 normr0 mulr_ge0 ?normr_ge0 //. + by rewrite big_ord0 mulr0 lerr. +rewrite -[size _]prednK ?lt0n ?size_poly_eq0 //. +rewrite big_ord_recl expr0 mulr1 nderivn0 addrC addKr !mulr_sumr. +have := ler_trans (ler_norm_sum _ _ _); apply. +rewrite ler_sum // => i _. +rewrite exprSr mulrA !normrM mulrC ler_wpmul2l ?normr_ge0 //. +suff /ler_wpmul2l /ler_trans : + `|(y - x) ^+ i| <= maxr 1 (2%:R * r) ^+ (size p).-1. + apply; rewrite ?normr_ge0 // mulrC ler_wpmul2l ?poly_boundP //. + by rewrite ?exprn_ge0 // ler_maxr ler01 mulr_ge0 ?ler0n ?ltrW. +case: maxrP=> hr. + rewrite expr1n normrX exprn_ile1 ?normr_ge0 //. + rewrite (ler_trans (ler_dist_add a _ _)) // addrC distrC. + by rewrite (ler_trans _ hr) // mulrDl ler_add ?mul1r. +rewrite (@ler_trans _ ((2%:R * r) ^+ i)) //. + rewrite normrX @ler_expn2r -?topredE /= ?normr_ge0 ?mulr_ge0 ?ler0n //. + by rewrite ltrW. + rewrite (ler_trans (ler_dist_add a _ _)) // addrC distrC. + by rewrite mulrDl ler_add ?mul1r. +by rewrite ler_eexpn2l // ltnW. +Qed. + +Lemma poly_accr_bound_gt0 p a r : 0 < poly_accr_bound p a r. +Proof. +rewrite /poly_accr_bound pmulr_rgt0 //. + rewrite ltr_paddr ?ltr01 //. + by rewrite sumr_ge0 // => i; rewrite poly_bound_ge0. +by rewrite exprn_gt0 // ltr_maxr ltr01 pmulr_rgt0 ?ltr0n. +Qed. + +Lemma poly_accr_bound_ge0 p a r : 0 <= poly_accr_bound p a r. +Proof. by rewrite ltrW // poly_accr_bound_gt0. Qed. + +(* Todo : move to polyorder => need char 0 *) +Lemma gdcop_eq0 (p q : {poly F}) : + (gdcop p q == 0)%B = (q == 0)%B && (p != 0)%B. +Proof. +have [[->|q_neq0] [->|p_neq0] /=] := (altP (q =P 0), altP (p =P 0)). ++ by rewrite gdcop0 eqxx oner_eq0. ++ by rewrite gdcop0 (negPf p_neq0) eqxx. ++ apply/negP=> /eqP hg; have := coprimep_gdco 0 q_neq0. + by rewrite hg coprimep0 eqp01. +by apply/negP=> /eqP hg; have := dvdp_gdco p q; rewrite hg dvd0p; apply/negP. +Qed. + +End polyorder_extra. + +Section polyXY_order_extra. + +Variable F : realFieldType. +Local Open Scope ring_scope. + +Local Notation "p ^ f" := (map_poly f p) : ring_scope. +Local Notation "'Y" := 'X%:P. + +Definition norm_poly2 (p : {poly {poly F}}) := p ^ (map_poly (fun x => `|x|)). + +Lemma coef_norm_poly2 p i j : (norm_poly2 p)`_i`_j = `|p`_i`_j|. +Proof. +rewrite !coef_map_id0 ?normr0 //; last first. +by rewrite /map_poly poly_def size_poly0 big_ord0. +Qed. + +Lemma size_norm_poly2 p : size (norm_poly2 p) = size p. +Proof. +rewrite /norm_poly2; have [->|p0] := eqVneq p 0. + by rewrite /map_poly poly_def !(size_poly0, big_ord0). +rewrite /map_poly size_poly_eq // -size_poly_eq0 size_poly_eq //. + by rewrite -lead_coefE size_poly_eq0 lead_coef_eq0. +by rewrite -!lead_coefE normr_eq0 !lead_coef_eq0. +Qed. + +End polyXY_order_extra. + +Section polyorder_field_extra. + +Variable F : realFieldType. + +Local Open Scope ring_scope. + +Definition poly_accr_bound2 (p : {poly F}) (a r : F) : F + := (maxr 1 (2%:R * r)) ^+ (size p).-2 + * (1 + \sum_(i < (size p).-2) poly_bound p^`N(i.+2) a r). + +Lemma poly_accr_bound2_gt0 p a r : 0 < poly_accr_bound2 p a r. +Proof. +rewrite /poly_accr_bound pmulr_rgt0 //. + rewrite ltr_paddr ?ltr01 //. + by rewrite sumr_ge0 // => i; rewrite poly_bound_ge0. +by rewrite exprn_gt0 // ltr_maxr ltr01 pmulr_rgt0 ?ltr0n. +Qed. + +Lemma poly_accr_bound2_ge0 p a r : 0 <= poly_accr_bound2 p a r. +Proof. by rewrite ltrW // poly_accr_bound2_gt0. Qed. + +Lemma poly_accr_bound2P p (a r x y : F) : (x != y)%B -> + `|x - a| <= r -> `|y - a| <= r -> + `|(p.[y] - p.[x]) / (y - x) - p^`().[x]| + <= `|y - x| * poly_accr_bound2 p a r. +Proof. +have [|r_lt0] := lerP 0 r; last first. + by move=> _ hr; have := ler_lt_trans hr r_lt0; rewrite normr_lt0. +rewrite le0r=> /orP[/eqP->|r_gt0]. + rewrite !normr_le0 !subr_eq0. + by move=> nxy /eqP xa /eqP xb; rewrite xa xb eqxx in nxy. +move=> neq_xy hx hy. +rewrite mulrA mulrDr mulr1 ler_paddl ?mulr_ge0 ?normr_ge0 //=. + by rewrite exprn_ge0 ?ler_maxr ?mulr_ge0 ?ger0E ?ltrW. +rewrite -{1}(addNKr x y) [- _ + _]addrC /= -mulrA. +rewrite nderiv_taylor; last exact: mulrC. +have [->|p_neq0] := eqVneq p 0. + by rewrite derivC !horner0 size_poly0 !(big_ord0, subrr, mul0r) normr0 !mulr0. +rewrite -[size _]prednK ?lt0n ?size_poly_eq0 //. +rewrite big_ord_recl expr0 mulr1 nderivn0 /= -size_deriv. +have [->|p'_neq0] := eqVneq p^`() 0. + by rewrite horner0 size_poly0 !big_ord0 addr0 !(subrr, mul0r) normr0 !mulr0. +rewrite -[size _]prednK ?lt0n ?size_poly_eq0 // big_ord_recl expr1. +rewrite addrAC subrr add0r mulrDl mulfK; last by rewrite subr_eq0 eq_sym. +rewrite nderivn1 addrAC subrr add0r mulr_sumr normrM normfV. +rewrite ler_pdivr_mulr ?normr_gt0; last by rewrite subr_eq0 eq_sym. +rewrite mulrAC -expr2 mulrC mulr_suml. +have := ler_trans (ler_norm_sum _ _ _); apply. +rewrite ler_sum // => i _ /=; rewrite /bump /= !add1n. +rewrite normrM normrX 3!exprSr expr1 !mulrA !ler_wpmul2r ?normr_ge0 //. +suff /ler_wpmul2l /ler_trans : + `|(y - x)| ^+ i <= maxr 1 (2%:R * r) ^+ (size p^`()).-1. + apply; rewrite ?normr_ge0 // mulrC ler_wpmul2l ?poly_boundP //. + by rewrite ?exprn_ge0 // ler_maxr ler01 mulr_ge0 ?ler0n ?ltrW. +case: maxrP=> hr. + rewrite expr1n exprn_ile1 ?normr_ge0 //. + rewrite (ler_trans (ler_dist_add a _ _)) // addrC distrC. + by rewrite (ler_trans _ hr) // mulrDl ler_add ?mul1r. +rewrite (@ler_trans _ ((2%:R * r) ^+ i)) //. + rewrite @ler_expn2r -?topredE /= ?normr_ge0 ?mulr_ge0 ?ler0n //. + by rewrite ltrW. + rewrite (ler_trans (ler_dist_add a _ _)) // addrC distrC. + by rewrite mulrDl ler_add ?mul1r. +by rewrite ler_eexpn2l // ltnW. +Qed. + +End polyorder_field_extra. + +Section monotony. + +Variable F : realFieldType. + +Local Open Scope ring_scope. + +Definition accr_pos p (a r : F) := + ({ k | 0 < k & forall x y, (x != y)%B -> + `|x - a| <= r -> `|y - a| <= r -> (p.[x] - p.[y]) / (x - y) > k } + * forall x, `|x - a| <= r -> p^`().[x] > 0)%type. + +Definition accr_neg p (a r : F) := + ({ k | 0 < k & forall x y, (x != y)%B -> + `|x - a| <= r -> `|y - a| <= r -> (p.[x] - p.[y]) / (x - y) < - k} + * forall x, `|x - a| <= r -> p^`().[x] < 0)%type. + +Definition strong_mono p (a r : F) := (accr_pos p a r + accr_neg p a r)%type. + +Lemma accr_pos_incr p a r : accr_pos p a r -> + forall x y, `|x - a| <= r -> `|y - a| <= r -> (p.[x] <= p.[y]) = (x <= y). +Proof. +move=> [[k k_gt0 hk] _] x y hx hy. +have [->|neq_xy] := eqVneq x y; first by rewrite !lerr. +have hkxy := hk _ _ neq_xy hx hy. +have := ltr_trans k_gt0 hkxy. +have [lpxpy|lpypx|->] := ltrgtP p.[x] p.[y]. ++ by rewrite nmulr_rgt0 ?subr_lt0 // ?invr_lt0 subr_lt0=> /ltrW->. ++ by rewrite pmulr_rgt0 ?subr_gt0 // ?invr_gt0 subr_gt0 lerNgt=> ->. +by rewrite subrr mul0r ltrr. +Qed. + +Lemma accr_neg_decr p a r : accr_neg p a r -> + forall x y, `|x - a| <= r -> `|y - a| <= r -> (p.[x] <= p.[y]) = (y <= x). +Proof. +move=> [] [k]; rewrite -oppr_lt0=> Nk_lt0 hk _ x y hx hy. +have [->|neq_xy] := eqVneq x y; first by rewrite !lerr. +have hkxy := hk _ _ neq_xy hx hy. +have := ltr_trans hkxy Nk_lt0. +have [lpxpy|lpypx|->] := ltrgtP p.[x] p.[y]. ++ by rewrite nmulr_rlt0 ?subr_lt0 // ?invr_gt0 subr_gt0=> /ltrW->. ++ by rewrite pmulr_rlt0 ?subr_gt0 // ?invr_lt0 subr_lt0 lerNgt=> ->. +by rewrite subrr mul0r ltrr. +Qed. + +Lemma accr_negN p a r : accr_pos p a r -> accr_neg (- p) a r. +Proof. +case=> [[k k_gt0 hk] h]. +split; [ exists k=> // x y nxy hx hy; + by rewrite !hornerN -opprD mulNr ltr_opp2; apply: hk + | by move=> x hx; rewrite derivN hornerN oppr_lt0; apply: h ]. +Qed. + +Lemma accr_posN p a r : accr_neg p a r -> accr_pos (- p) a r. +Proof. +case=> [[k k_gt0 hk] h]. +split; [ exists k=> // x y nxy hx hy; + by rewrite !hornerN -opprD mulNr ltr_oppr; apply: hk + | by move=> x hx; rewrite derivN hornerN oppr_gt0; apply: h ]. +Qed. + +Lemma strong_monoN p a r : strong_mono p a r -> strong_mono (- p) a r. +Proof. by case=> [] hp; [right; apply: accr_negN|left; apply: accr_posN]. Qed. + +Lemma strong_mono_bound p a r : strong_mono p a r + -> {k | 0 < k & forall x y, `|x - a| <= r -> `|y - a| <= r -> + `| x - y | <= k * `| p.[x] - p.[y] | }. +Proof. +case=> [] [[k k_gt0 hk] _]; exists k^-1; rewrite ?invr_gt0=> // x y hx hy; +have [->|neq_xy] := eqVneq x y; do ?[by rewrite !subrr normr0 mulr0]; +move: (hk _ _ neq_xy hx hy); rewrite 1?ltr_oppr ler_pdivl_mull //; +rewrite -ler_pdivl_mulr ?normr_gt0 ?subr_eq0 // => /ltrW /ler_trans-> //; +by rewrite -normfV -normrM ler_normr lerr ?orbT. +Qed. + +Definition merge_intervals (ar1 ar2 : F * F) := + let l := minr (ar1.1 - ar1.2) (ar2.1 - ar2.2) in + let u := maxr (ar1.1 + ar1.2) (ar2.1 + ar2.2) in + ((l + u) / 2%:R, (u - l) / 2%:R). +Local Notation center ar1 ar2 := ((merge_intervals ar1 ar2).1). +Local Notation radius ar1 ar2 := ((merge_intervals ar1 ar2).2). + +Lemma split_interval (a1 a2 r1 r2 x : F) : + 0 < r1 -> 0 < r2 -> `|a1 - a2| <= r1 + r2 -> + (`|x - center (a1, r1) (a2, r2)| <= radius (a1, r1) (a2, r2)) + = (`|x - a1| <= r1) || (`|x - a2| <= r2). +Proof. +move=> r1_gt0 r2_gt0 le_ar. +rewrite /merge_intervals /=. +set l := minr _ _; set u := maxr _ _. +rewrite ler_pdivl_mulr ?gtr0E // -{2}[2%:R]ger0_norm ?ger0E //. +rewrite -normrM mulrBl mulfVK ?pnatr_eq0 // ler_distl. +rewrite opprB addrCA addrK (addrC (l + u)) addrA addrNK. +rewrite -!mulr2n !mulr_natr !ler_muln2r !orFb. +rewrite ler_minl ler_maxr !ler_distl. +have [] := lerP=> /= a1N; have [] := lerP=> //= a1P; +have [] := lerP=> //= a2P; rewrite ?(andbF, andbT) //; symmetry. + rewrite ltrW // (ler_lt_trans _ a1P) //. + rewrite (monoLR (addrK _) (ler_add2r _)) -addrA. + rewrite (monoRL (addNKr _) (ler_add2l _)) addrC. + by rewrite (ler_trans _ le_ar) // ler_normr opprB lerr orbT. +rewrite ltrW // (ltr_le_trans a1N) //. +rewrite (monoLR (addrK _) (ler_add2r _)) -addrA. +rewrite (monoRL (addNKr _) (ler_add2l _)) addrC ?[r2 + _]addrC. +by rewrite (ler_trans _ le_ar) // ler_normr lerr. +Qed. + +Lemma merge_mono p a1 a2 r1 r2 : + 0 < r1 -> 0 < r2 -> + `|a1 - a2| <= (r1 + r2) -> + strong_mono p a1 r1 -> strong_mono p a2 r2 -> + strong_mono p (center (a1, r1) (a2, r2)) (radius (a1, r1) (a2, r2)). +Proof. +move=> r1_gt0 r2_gt0 har sm1; wlog : p sm1 / accr_pos p a1 r1. + move=> hwlog; case: (sm1); first exact: hwlog. + move=> accr_p smp; rewrite -[p]opprK; apply: strong_monoN. + apply: hwlog=> //; do ?exact: strong_monoN. + exact: accr_posN. +case=> [[k1 k1_gt0 hk1]] h1. +move=> [] accr2_p; last first. + set m := (r2 * a1 + r1 * a2) / (r1 + r2). + have pm_gt0 := h1 m. + case: accr2_p=> [_] /(_ m) pm_lt0. + suff: 0 < 0 :> F by rewrite ltrr. + have r_gt0 : 0 < r1 + r2 by rewrite ?addr_gt0. + apply: (ltr_trans (pm_gt0 _) (pm_lt0 _)). + rewrite -(@ler_pmul2l _ (r1 + r2)) //. + rewrite -{1}[r1 + r2]ger0_norm ?(ltrW r_gt0) //. + rewrite -normrM mulrBr /m mulrC mulrVK ?unitfE ?gtr_eqF //. + rewrite mulrDl opprD addrA addrC addrA addKr. + rewrite distrC -mulrBr normrM ger0_norm ?(ltrW r1_gt0) //. + by rewrite mulrC ler_wpmul2r // ltrW. + rewrite -(@ler_pmul2l _ (r1 + r2)) //. + rewrite -{1}[r1 + r2]ger0_norm ?(ltrW r_gt0) //. + rewrite -normrM mulrBr /m mulrC mulrVK ?unitfE ?gtr_eqF //. + rewrite mulrDl opprD addrA addrK. + rewrite -mulrBr normrM ger0_norm ?(ltrW r2_gt0) //. + by rewrite mulrC ler_wpmul2r // ltrW. +case: accr2_p=> [[k2 k2_gt0 hk2]] h2. +left; split; last by move=> x; rewrite split_interval // => /orP [/h1|/h2]. +exists (minr k1 k2); first by rewrite ltr_minr k1_gt0. +move=> x y neq_xy; rewrite !split_interval //. +wlog lt_xy: x y neq_xy / y < x. + move=> hwlog; have [] := ltrP y x; first exact: hwlog. + rewrite ler_eqVlt (negPf neq_xy) /= => /hwlog hwlog' hx hy. + rewrite -mulrNN -!invrN !opprB. + by apply: hwlog'; rewrite // eq_sym. +move=> {h1} {h2} {sm1}. +wlog le_xr1 : a1 a2 r1 r2 k1 k2 + r1_gt0 r2_gt0 k1_gt0 k2_gt0 har hk1 hk2 / `|x - a1| <= r1. + move=> hwlog h; move: (h)=> /orP [/hwlog|]; first exact. + move=> /(hwlog a2 a1 r2 r1 k2 k1) hwlog' ley; rewrite minrC. + by apply: hwlog'; rewrite 1?orbC // distrC [r2 + _]addrC. +move=> _. +have [le_yr1|gt_yr1] := (lerP _ r1)=> /= [_|le_yr2]. + by rewrite ltr_minl hk1. +rewrite ltr_pdivl_mulr ?subr_gt0 //. +pose z := a1 - r1. +have hz1 : `|z - a1| <= r1 by rewrite addrC addKr normrN gtr0_norm. +have gt_yr1' : y + r1 < a1. + rewrite addrC; move: gt_yr1. + rewrite (monoLR (addrNK _) (ltr_add2r _)). + rewrite /z ltr_normr opprB=> /orP[|-> //]. + rewrite (monoRL (addrK a1) (ltr_add2r _))=> /ltr_trans /(_ lt_xy). + by rewrite ltrNge addrC; move: le_xr1; rewrite ler_distl=> /andP [_ ->]. +have lt_yz : y < z by rewrite (monoRL (addrK _) (ltr_add2r _)). +have hz2 : `|z - a2| <= r2. + move: (har); rewrite ler_norml=> /andP [la ua]. + rewrite addrAC ler_distl ua andbT. + rewrite -[a1](addrNK y) -[_ - _ + _ - _]addrA. + rewrite ler_add //. + by rewrite (monoRL (addrK _) (ler_add2r _)) addrC ltrW. + by move: le_yr2; rewrite ler_norml=> /andP[]. +have [<-|neq_zx] := eqVneq z x. + by rewrite -ltr_pdivl_mulr ?subr_gt0 // ltr_minl hk2 ?orbT // gtr_eqF. +have lt_zx : z < x. + rewrite ltr_neqAle neq_zx /=. + move: le_xr1; rewrite distrC ler_norml=> /andP[_]. + by rewrite !(monoLR (addrK _) (ler_add2r _)) addrC. +rewrite -{1}[x](addrNK z) -{1}[p.[x]](addrNK p.[z]). +rewrite !addrA -![_ - _ + _ - _]addrA mulrDr ltr_add //. + rewrite -ltr_pdivl_mulr ?subr_gt0 //. + by rewrite ltr_minl hk1 ?gtr_eqF. +rewrite -ltr_pdivl_mulr ?subr_gt0 //. +by rewrite ltr_minl hk2 ?orbT ?gtr_eqF. +Qed. + +End monotony. + +Section CauchyReals. + +Local Open Scope nat_scope. +Local Open Scope creal_scope. +Local Open Scope ring_scope. + +Definition asympt1 (R : numDomainType) (P : R -> nat -> Prop) + := {m : R -> nat | forall eps i, 0 < eps -> (m eps <= i)%N -> P eps i}. + +Definition asympt2 (R : numDomainType) (P : R -> nat -> nat -> Prop) + := {m : R -> nat | forall eps i j, 0 < eps -> (m eps <= i)%N -> (m eps <= j)%N -> P eps i j}. + +Notation "{ 'asympt' e : i / P }" := (asympt1 (fun e i => P)) + (at level 0, e ident, i ident, format "{ 'asympt' e : i / P }") : type_scope. + +Notation "{ 'asympt' e : i j / P }" := (asympt2 (fun e i j => P)) + (at level 0, e ident, i ident, j ident, format "{ 'asympt' e : i j / P }") : type_scope. + +Lemma asympt1modP (R : numDomainType) P (a : asympt1 P) e i : + 0 < e :> R -> (projT1 a e <= i)%N -> P e i. +Proof. by case: a e i. Qed. + +Lemma asympt2modP (R : numDomainType) P (a : asympt2 P) e i j : + 0 < e :> R -> (projT1 a e <= i)%N -> (projT1 a e <= j)%N -> P e i j. +Proof. by case: a e i j. Qed. + +Variable F : realFieldType. + +(* Lemma asympt_mulLR (k : F) (hk : 0 < k) (P : F -> nat -> Prop) : *) +(* {asympt e : i / P e i} -> {asympt e : i / P (e * k) i}. *) +(* Proof. *) +(* case=> m hm; exists (fun e => m (e * k))=> e i he hi. *) +(* by apply: hm=> //; rewrite -ltr_pdivr_mulr // mul0r. *) +(* Qed. *) + +(* Lemma asympt_mulRL (k : F) (hk : 0 < k) (P : F -> nat -> Prop) : *) +(* {asympt e : i / P (e * k) i} -> {asympt e : i / P e i}. *) +(* Proof. *) +(* case=> m hm; exists (fun e => m (e / k))=> e i he hi. *) +(* rewrite -[e](@mulfVK _ k) ?gtr_eqF //. *) +(* by apply: hm=> //; rewrite -ltr_pdivr_mulr ?invr_gt0 // mul0r. *) +(* Qed. *) + +Lemma asymptP (P1 : F -> nat -> Prop) (P2 : F -> nat -> Prop) : + (forall e i, 0 < e -> P1 e i -> P2 e i) -> + {asympt e : i / P1 e i} -> {asympt e : i / P2 e i}. +Proof. +by move=> hP; case=> m hm; exists m=> e i he me; apply: hP=> //; apply: hm. +Qed. + +(* Lemma asympt2_mulLR (k : F) (hk : 0 < k) (P : F -> nat -> nat -> Prop) : *) +(* {asympt e : i j / P e i j} -> {asympt e : i j / P (e * k) i j}. *) +(* Proof. *) +(* case=> m hm; exists (fun e => m (e * k))=> e i j he hi hj. *) +(* by apply: hm=> //; rewrite -ltr_pdivr_mulr // mul0r. *) +(* Qed. *) + +(* Lemma asympt2_mulRL (k : F) (hk : 0 < k) (P : F -> nat -> nat -> Prop) : *) +(* {asympt e : i j / P (e * k) i j} -> {asympt e : i j / P e i j}. *) +(* Proof. *) +(* case=> m hm; exists (fun e => m (e / k))=> e i j he hi hj. *) +(* rewrite -[e](@mulfVK _ k) ?gtr_eqF //. *) +(* by apply: hm=> //; rewrite -ltr_pdivr_mulr ?invr_gt0 // mul0r. *) +(* Qed. *) + +(* Lemma asympt2P (P1 : F -> nat -> nat -> Prop) (P2 : F -> nat -> nat -> Prop) : *) +(* (forall e i j, 0 < e -> P1 e i j -> P2 e i j) -> *) +(* {asympt e : i j / P1 e i j} -> {asympt e : i j / P2 e i j}. *) +(* Proof. *) +(* move=> hP; case=> m hm; exists m=> e i j he mei mej. *) +(* by apply: hP=> //; apply: hm. *) +(* Qed. *) + +Lemma splitf (n : nat) (e : F) : e = iterop n +%R (e / n%:R) e. +Proof. +case: n=> // n; set e' := (e / _). +have -> : e = e' * n.+1%:R by rewrite mulfVK ?pnatr_eq0. +move: e'=> {e} e; rewrite iteropS. +by elim: n=> /= [|n <-]; rewrite !mulr_natr ?mulr1n. +Qed. + +Lemma splitD (x y e : F) : x < e / 2%:R -> y < e / 2%:R -> x + y < e. +Proof. by move=> hx hy; rewrite [e](splitf 2) ltr_add. Qed. + +Lemma divrn_gt0 (e : F) (n : nat) : 0 < e -> (0 < n)%N -> 0 < e / n%:R. +Proof. by move=> e_gt0 n_gt0; rewrite pmulr_rgt0 ?gtr0E. Qed. + +Lemma split_norm_add (x y e : F) : + `|x| < e / 2%:R -> `|y| < e / 2%:R -> `|x + y| < e. +Proof. by move=> hx hy; rewrite (ler_lt_trans (ler_norm_add _ _)) // splitD. Qed. + +Lemma split_norm_sub (x y e : F) : + `|x| < e / 2%:R -> `|y| < e / 2%:R -> `|x - y| < e. +Proof. by move=> hx hy; rewrite (ler_lt_trans (ler_norm_sub _ _)) // splitD. Qed. + +Lemma split_dist_add (z x y e : F) : + `|x - z| < e / 2%:R -> `|z - y| < e / 2%:R -> `|x - y| < e. +Proof. +by move=> *; rewrite (ler_lt_trans (ler_dist_add z _ _)) ?splitD // 1?distrC. +Qed. + +Definition creal_axiom (x : nat -> F) := {asympt e : i j / `|x i - x j| < e}. + +CoInductive creal := CReal {cauchyseq :> nat -> F; _ : creal_axiom cauchyseq}. +Bind Scope creal_scope with creal. + +Lemma crealP (x : creal) : {asympt e : i j / `|x i - x j| < e}. +Proof. by case: x. Qed. + +Definition cauchymod := + nosimpl (fun (x : creal) => let: CReal _ m := x in projT1 m). + +Lemma cauchymodP (x : creal) eps i j : 0 < eps -> + (cauchymod x eps <= i)%N -> (cauchymod x eps <= j)%N -> `|x i - x j| < eps. +Proof. by case: x=> [x [m mP] //] /mP; apply. Qed. + +Definition neq_creal (x y : creal) : Prop := + exists eps, (0 < eps) && + (eps * 3%:R <= `|x (cauchymod x eps) - y (cauchymod y eps)|). +Notation "!=%CR" := neq_creal : creal_scope. +Notation "x != y" := (neq_creal x y) : creal_scope. + +Definition eq_creal x y := (~ (x != y)%CR). +Notation "x == y" := (eq_creal x y) : creal_scope. + +Lemma ltr_distl_creal (e : F) (i : nat) (x : creal) (j : nat) (a b : F) : + 0 < e -> (cauchymod x e <= i)%N -> (cauchymod x e <= j)%N -> + `| x i - a | <= b - e -> `| x j - a | < b. +Proof. +move=> e_gt0 hi hj hb. +rewrite (ler_lt_trans (ler_dist_add (x i) _ _)) ?ltr_le_add //. +by rewrite -[b](addrNK e) addrC ler_lt_add ?cauchymodP. +Qed. + +Lemma ltr_distr_creal (e : F) (i : nat) (x : creal) (j : nat) (a b : F) : + 0 < e -> (cauchymod x e <= i)%N -> (cauchymod x e <= j)%N -> + a + e <= `| x i - b | -> a < `| x j - b |. +Proof. +move=> e_gt0 hi hj hb; apply: contraLR hb; rewrite -ltrNge -lerNgt. +by move=> ha; rewrite (@ltr_distl_creal e j) // addrK. +Qed. + +(* Lemma asympt_neq (x y : creal) : x != y -> *) +(* {e | 0 < e & forall i, (cauchymod x e <= i)%N -> *) +(* (cauchymod y e <= i)%N -> `|x i - y i| >= e}. *) +(* Proof. *) +(* case/sigW=> e /andP[e_gt0 hxy]. *) +(* exists e=> // i hi hj; move: hxy; rewrite !lerNgt; apply: contra=> hxy. *) +(* rewrite !mulrDr !mulr1 distrC (@ltr_distl_creal i) //. *) +(* by rewrite distrC ltrW // (@ltr_distl_creal i) // ltrW. *) +(* Qed. *) + +Definition lbound (x y : creal) (neq_xy : x != y) : F := + projT1 (sigW neq_xy). + +Lemma lboundP (x y : creal) (neq_xy : x != y) i : + (cauchymod x (lbound neq_xy) <= i)%N -> + (cauchymod y (lbound neq_xy) <= i)%N -> lbound neq_xy <= `|x i - y i|. +Proof. +rewrite /lbound; case: (sigW _)=> /= d /andP[d_gt0 hd] hi hj. +apply: contraLR hd; rewrite -!ltrNge=> hd. +rewrite (@ltr_distl_creal d i) // distrC ltrW // (@ltr_distl_creal d i) //. +by rewrite distrC ltrW // !mulrDr mulr1 !addrA !addrK. +Qed. + +Notation lbound_of p := (@lboundP _ _ p _ _ _). + +Lemma lbound_gt0 (x y : creal) (neq_xy : x != y) : lbound neq_xy > 0. +Proof. by rewrite /lbound; case: (sigW _)=> /= d /andP[]. Qed. + +Definition lbound_ge0 x y neq_xy := (ltrW (@lbound_gt0 x y neq_xy)). + +Lemma cst_crealP (x : F) : creal_axiom (fun _ => x). +Proof. by exists (fun _ => 0%N)=> *; rewrite subrr normr0. Qed. +Definition cst_creal (x : F) := CReal (cst_crealP x). +Notation "x %:CR" := (cst_creal x) + (at level 2, left associativity, format "x %:CR") : creal_scope. +Notation "0" := (0 %:CR) : creal_scope. + +Lemma lbound0P (x : creal) (x_neq0 : x != 0) i : + (cauchymod x (lbound x_neq0) <= i)%N -> + (cauchymod 0%CR (lbound x_neq0) <= i)%N -> lbound x_neq0 <= `|x i|. +Proof. by move=> cx c0; rewrite -[X in `|X|]subr0 -[0]/(0%CR i) lboundP. Qed. + +Notation lbound0_of p := (@lbound0P _ p _ _ _). + +Lemma neq_crealP e i j (e_gt0 : 0 < e) (x y : creal) : + (cauchymod x (e / 5%:R) <= i)%N -> (cauchymod y (e / 5%:R) <= j)%N -> + e <= `|x i - y j| -> x != y. +Proof. +move=> hi hj he; exists (e / 5%:R); rewrite pmulr_rgt0 ?gtr0E //=. +rewrite distrC ltrW // (@ltr_distr_creal (e / 5%:R) j) ?pmulr_rgt0 ?gtr0E //. +rewrite distrC ltrW // (@ltr_distr_creal (e / 5%:R) i) ?pmulr_rgt0 ?gtr0E //. +by rewrite mulr_natr -!mulrSr -mulrnAr -mulr_natr mulVf ?pnatr_eq0 ?mulr1. +Qed. + +Lemma eq_crealP (x y : creal) : {asympt e : i / `|x i - y i| < e} -> + (x == y)%CR. +Proof. +case=> m hm neq_xy; pose d := lbound neq_xy. +pose_big_enough i. + have := (hm d i); rewrite lbound_gt0; big_enough => /(_ isT isT). + by apply/negP; rewrite -lerNgt lboundP. +by close. +Qed. + +Lemma eq0_crealP (x : creal) : {asympt e : i / `|x i| < e} -> x == 0. +Proof. +by move=> hx; apply: eq_crealP; apply: asymptP hx=> e i; rewrite subr0. +Qed. + +Lemma asympt_eq (x y : creal) (eq_xy : x == y) : + {asympt e : i / `|x i - y i| < e}. +Proof. +exists_big_modulus m F. + move=> e i e0 hi; rewrite ltrNge; apply/negP=> he; apply: eq_xy. + by apply: (@neq_crealP e i i). +by close. +Qed. + +Lemma asympt_eq0 (x : creal) : x == 0 -> {asympt e : i / `|x i| < e}. +Proof. by move/asympt_eq; apply: asymptP=> e i; rewrite subr0. Qed. + +Definition eq_mod (x y : creal) (eq_xy : x == y) := projT1 (asympt_eq eq_xy). +Lemma eq_modP (x y : creal) (eq_xy : x == y) eps i : 0 < eps -> + (eq_mod eq_xy eps <= i)%N -> `|x i - y i| < eps. +Proof. +by move=> eps_gt0; rewrite /eq_mod; case: (asympt_eq _)=> /= m hm /hm; apply. +Qed. +Lemma eq0_modP (x : creal) (x_eq0 : x == 0) eps i : 0 < eps -> + (eq_mod x_eq0 eps <= i)%N -> `|x i| < eps. +Proof. +by move=> eps_gt0 hi; rewrite -[X in `|X|]subr0 -[0]/(0%CR i) eq_modP. +Qed. + +Lemma eq_creal_refl x : x == x. +Proof. +apply: eq_crealP; exists (fun _ => 0%N). +by move=> e i e_gt0 _; rewrite subrr normr0. +Qed. +Hint Resolve eq_creal_refl. + +Lemma neq_creal_sym x y : x != y -> y != x. +Proof. +move=> neq_xy; pose_big_enough i. + apply: (@neq_crealP (lbound neq_xy) i i); + by rewrite ?lbound_gt0 1?distrC ?(lbound_of neq_xy). +by close. +Qed. + +Lemma eq_creal_sym x y : x == y -> y == x. +Proof. by move=> eq_xy /neq_creal_sym. Qed. + +Lemma eq_creal_trans x y z : x == y -> y == z -> x == z. +Proof. +move=> eq_xy eq_yz; apply: eq_crealP; exists_big_modulus m F. + by move=> e i *; rewrite (@split_dist_add (y i)) ?eq_modP ?divrn_gt0. +by close. +Qed. + +Lemma creal_neq_always (x y : creal) i (neq_xy : x != y) : + (cauchymod x (lbound neq_xy) <= i)%N -> + (cauchymod y (lbound neq_xy) <= i)%N -> (x i != y i)%B. +Proof. +move=> hx hy; rewrite -subr_eq0 -normr_gt0. +by rewrite (ltr_le_trans _ (lbound_of neq_xy)) ?lbound_gt0. +Qed. + +Definition creal_neq0_always (x : creal) := @creal_neq_always x 0. + +Definition lt_creal (x y : creal) : Prop := + exists eps, (0 < eps) && + (x (cauchymod x eps) + eps * 3%:R <= y (cauchymod y eps)). +Notation "<%CR" := lt_creal : creal_scope. +Notation "x < y" := (lt_creal x y) : creal_scope. + +Definition le_creal (x y : creal) : Prop := ~ (y < x)%CR. +Notation "<=%CR" := le_creal : creal_scope. +Notation "x <= y" := (le_creal x y) : creal_scope. + +Lemma ltr_creal (e : F) (i : nat) (x : creal) (j : nat) (a : F) : + 0 < e -> (cauchymod x e <= i)%N -> (cauchymod x e <= j)%N -> + x i <= a - e -> x j < a. +Proof. +move=> e_gt0 hi hj ha; have := cauchymodP e_gt0 hj hi. +rewrite ltr_distl=> /andP[_ /ltr_le_trans-> //]. +by rewrite -(ler_add2r (- e)) addrK. +Qed. + +Lemma gtr_creal (e : F) (i : nat) (x : creal) (j : nat) (a : F) : + 0 < e -> (cauchymod x e <= i)%N -> (cauchymod x e <= j)%N -> + a + e <= x i-> a < x j. +Proof. +move=> e_gt0 hi hj ha; have := cauchymodP e_gt0 hj hi. +rewrite ltr_distl=> /andP[/(ler_lt_trans _)-> //]. +by rewrite -(ler_add2r e) addrNK. +Qed. + +Definition diff (x y : creal) (lt_xy : (x < y)%CR) : F := projT1 (sigW lt_xy). + +Lemma diff_gt0 (x y : creal) (lt_xy : (x < y)%CR) : diff lt_xy > 0. +Proof. by rewrite /diff; case: (sigW _)=> /= d /andP[]. Qed. + +Definition diff_ge0 x y lt_xy := (ltrW (@diff_gt0 x y lt_xy)). + +Lemma diffP (x y : creal) (lt_xy : (x < y)%CR) i : + (cauchymod x (diff lt_xy) <= i)%N -> + (cauchymod y (diff lt_xy) <= i)%N -> x i + diff lt_xy <= y i. +Proof. +rewrite /diff; case: (sigW _)=> /= e /andP[e_gt0 he] hi hj. +rewrite ltrW // (@gtr_creal e (cauchymod y e)) // (ler_trans _ he) //. +rewrite !mulrDr mulr1 !addrA !ler_add2r ltrW //. +by rewrite (@ltr_creal e (cauchymod x e)) // addrK. +Qed. + +Notation diff_of p := (@diffP _ _ p _ _ _). + +Lemma diff0P (x : creal) (x_gt0 : (0 < x)%CR) i : + (cauchymod x (diff x_gt0) <= i)%N -> + (cauchymod 0%CR (diff x_gt0) <= i)%N -> diff x_gt0 <= x i. +Proof. by move=> cx c0; rewrite -[diff _]add0r -[0]/(0%CR i) diffP. Qed. + +Notation diff0_of p := (@diff0P _ p _ _ _). + +Lemma lt_crealP e i j (e_gt0 : 0 < e) (x y : creal) : + (cauchymod x (e / 5%:R) <= i)%N -> (cauchymod y (e / 5%:R) <= j)%N -> + x i + e <= y j -> (x < y)%CR. +Proof. +move=> hi hj he; exists (e / 5%:R); rewrite pmulr_rgt0 ?gtr0E //=. +rewrite ltrW // (@gtr_creal (e / 5%:R) j) ?pmulr_rgt0 ?gtr0E //. +rewrite (ler_trans _ he) // -addrA (monoLR (addrNK _) (ler_add2r _)). +rewrite ltrW // (@ltr_creal (e / 5%:R) i) ?pmulr_rgt0 ?gtr0E //. +rewrite -!addrA ler_addl !addrA -mulrA -{1}[e]mulr1 -!(mulrBr, mulrDr). +rewrite pmulr_rge0 // {1}[1](splitf 5) /= !mul1r !mulrDr mulr1. +by rewrite !opprD !addrA !addrK addrN. +Qed. + +Lemma le_crealP i (x y : creal) : + (forall j, (i <= j)%N -> x j <= y j) -> (x <= y)%CR. +Proof. +move=> hi lt_yx; pose_big_enough j. + have := hi j; big_enough => /(_ isT); apply/negP; rewrite -ltrNge. + by rewrite (ltr_le_trans _ (diff_of lt_yx)) ?ltr_spaddr ?diff_gt0. +by close. +Qed. + +Lemma le_creal_refl (x : creal) : (x <= x)%CR. +Proof. by apply: (@le_crealP 0%N). Qed. +Hint Resolve le_creal_refl. + +Lemma lt_neq_creal (x y : creal) : (x < y)%CR -> x != y. +Proof. +move=> ltxy; pose_big_enough i. + apply: (@neq_crealP (diff ltxy) i i) => //; first by rewrite diff_gt0. + by rewrite distrC lerNgt ltr_distl negb_and -!lerNgt diffP ?orbT. +by close. +Qed. + +Lemma creal_lt_always (x y : creal) i (lt_xy : (x < y)%CR) : + (cauchymod x (diff lt_xy) <= i)%N -> + (cauchymod y (diff lt_xy) <= i)%N -> x i < y i. +Proof. +by move=> hx hy; rewrite (ltr_le_trans _ (diff_of lt_xy)) ?ltr_addl ?diff_gt0. +Qed. + +Definition creal_gt0_always := @creal_lt_always 0. + +Lemma eq_le_creal (x y : creal) : x == y -> (x <= y)%CR. +Proof. by move=> /eq_creal_sym ? /lt_neq_creal. Qed. + +Lemma asympt_le (x y : creal) (le_xy : (x <= y)%CR) : + {asympt e : i / x i < y i + e}. +Proof. +exists_big_modulus m F. + move=> e i e0 hm; rewrite ltrNge; apply/negP=> he; apply: le_xy. + by apply: (@lt_crealP e i i). +by close. +Qed. + +Lemma asympt_ge0 (x : creal) : (0 <= x)%CR -> {asympt e : i / - e < x i}. +Proof. by move/asympt_le; apply: asymptP=> *; rewrite -subr_gt0 opprK. Qed. + +Definition le_mod (x y : creal) (le_xy : (x <= y)%CR) := projT1 (asympt_le le_xy). + +Lemma le_modP (x y : creal) (le_xy : (x <= y)%CR) eps i : 0 < eps -> + (le_mod le_xy eps <= i)%N -> x i < y i + eps. +Proof. +by move=> eps_gt0; rewrite /le_mod; case: (asympt_le _)=> /= m hm /hm; apply. +Qed. + +Lemma ge0_modP (x : creal) (x_ge0 : (0 <= x)%CR) eps i : 0 < eps -> + (le_mod x_ge0 eps <= i)%N -> - eps < x i. +Proof. +by move=> eps_gt0 hi; rewrite -(ltr_add2r eps) addNr -[0]/(0%CR i) le_modP. +Qed. + +Lemma opp_crealP (x : creal) : creal_axiom (fun i => - x i). +Proof. by case: x=> [x [m mP]]; exists m=> *; rewrite /= -opprD normrN mP. Qed. +Definition opp_creal (x : creal) := CReal (opp_crealP x). +Notation "-%CR" := opp_creal : creal_scope. +Notation "- x" := (opp_creal x) : creal_scope. + +Lemma add_crealP (x y : creal) : creal_axiom (fun i => x i + y i). +Proof. +exists_big_modulus m F. + move=> e i j he hi hj; rewrite opprD addrAC addrA -addrA [- _ + _]addrC. + by rewrite split_norm_add ?cauchymodP ?divrn_gt0. +by close. +Qed. +Definition add_creal (x y : creal) := CReal (add_crealP x y). +Notation "+%CR" := add_creal : creal_scope. +Notation "x + y" := (add_creal x y) : creal_scope. +Notation "x - y" := (x + - y)%CR : creal_scope. + + +Lemma ubound_subproof (x : creal) : {b : F | b > 0 & forall i, `|x i| <= b}. +Proof. +pose_big_enough i; first set b := 1 + `|x i|. + exists (foldl maxr b [seq `|x n| | n <- iota 0 i]) => [|n]. + have : 0 < b by rewrite ltr_spaddl. + by elim: iota b => //= a l IHl b b_gt0; rewrite IHl ?ltr_maxr ?b_gt0. + have [|le_in] := (ltnP n i). + elim: i b => [|i IHi] b //. + rewrite ltnS -addn1 iota_add add0n map_cat foldl_cat /= ler_maxr leq_eqVlt. + by case/orP=> [/eqP->|/IHi->] //; rewrite lerr orbT. + set xn := `|x n|; suff : xn <= b. + by elim: iota xn b => //= a l IHl xn b Hxb; rewrite IHl ?ler_maxr ?Hxb. + rewrite -ler_subl_addr (ler_trans (ler_norm _)) //. + by rewrite (ler_trans (ler_dist_dist _ _)) ?ltrW ?cauchymodP. +by close. +Qed. + +Definition ubound (x : creal) := + nosimpl (let: exist2 b _ _ := ubound_subproof x in b). + +Lemma uboundP (x : creal) i : `|x i| <= ubound x. +Proof. by rewrite /ubound; case: ubound_subproof. Qed. + +Lemma ubound_gt0 x : 0 < ubound x. +Proof. by rewrite /ubound; case: ubound_subproof. Qed. + +Definition ubound_ge0 x := (ltrW (ubound_gt0 x)). + +Lemma mul_crealP (x y : creal) : creal_axiom (fun i => x i * y i). +Proof. +exists_big_modulus m F. + move=> e i j e_gt0 hi hj. + rewrite -[_ * _]subr0 -(subrr (x j * y i)) opprD opprK addrA. + rewrite -mulrBl -addrA -mulrBr split_norm_add // !normrM. + have /ler_wpmul2l /ler_lt_trans-> // := uboundP y i. + rewrite -ltr_pdivl_mulr ?ubound_gt0 ?cauchymodP //. + by rewrite !pmulr_rgt0 ?invr_gt0 ?ubound_gt0 ?ltr0n. + rewrite mulrC; have /ler_wpmul2l /ler_lt_trans-> // := uboundP x j. + rewrite -ltr_pdivl_mulr ?ubound_gt0 ?cauchymodP //. + by rewrite !pmulr_rgt0 ?gtr0E ?ubound_gt0. +by close. +Qed. +Definition mul_creal (x y : creal) := CReal (mul_crealP x y). +Notation "*%CR" := mul_creal : creal_scope. +Notation "x * y" := (mul_creal x y) : creal_scope. + +Lemma inv_crealP (x : creal) (x_neq0 : x != 0) : creal_axiom (fun i => (x i)^-1). +Proof. +pose d := lbound x_neq0. +exists_big_modulus m F. + (* exists (fun e => [CC x # e * d ^+ 2; ! x_neq0]). *) + move=> e i j e_gt0 hi hj. + have /andP[xi_neq0 xj_neq0] : (x i != 0) && (x j != 0). + by rewrite -!normr_gt0 !(ltr_le_trans _ (lbound0_of x_neq0)) ?lbound_gt0. + rewrite -(@ltr_pmul2r _ `|x i * x j|); last by rewrite normr_gt0 mulf_neq0. + rewrite -normrM !mulrBl mulrA mulVf // mulrCA mulVf // mul1r mulr1. + apply: (@ltr_le_trans _ (e * d ^+ 2)). + by apply: cauchymodP; rewrite // !pmulr_rgt0 ?lbound_gt0. + rewrite ler_wpmul2l ?(ltrW e_gt0) // normrM. + have /(_ j) hx := lbound0_of x_neq0; rewrite /=. + have -> // := (ler_trans (@ler_wpmul2l _ d _ _ _ (hx _ _))). + by rewrite ltrW // lbound_gt0. + by rewrite ler_wpmul2r ?normr_ge0 // lbound0P. +by close. +Qed. +Definition inv_creal (x : creal) (x_neq0 : x != 0) := CReal (inv_crealP x_neq0). +Notation "x_neq0 ^-1" := (inv_creal x_neq0) : creal_scope. +Notation "x / y_neq0" := (x * (y_neq0 ^-1))%CR : creal_scope. + +Lemma norm_crealP (x : creal) : creal_axiom (fun i => `|x i|). +Proof. +exists (cauchymod x). +by move=> *; rewrite (ler_lt_trans (ler_dist_dist _ _)) ?cauchymodP. +Qed. +Definition norm_creal x := CReal (norm_crealP x). +Local Notation "`| x |" := (norm_creal x) : creal_scope. + +Lemma horner_crealP (p : {poly F}) (x : creal) : + creal_axiom (fun i => p.[x i]). +Proof. +exists_big_modulus m F=> [e i j e_gt0 hi hj|]. + rewrite (ler_lt_trans (@poly_accr_bound1P _ p (x (cauchymod x 1)) 1 _ _ _ _)); + do ?[by rewrite ?e_gt0 | by rewrite ltrW // cauchymodP]. + rewrite -ltr_pdivl_mulr ?poly_accr_bound_gt0 ?cauchymodP //. + by rewrite pmulr_rgt0 ?invr_gt0 ?poly_accr_bound_gt0. +by close. +Qed. +Definition horner_creal (p : {poly F}) (x : creal) := CReal (horner_crealP p x). +Notation "p .[ x ]" := (horner_creal p x) : creal_scope. + +Lemma neq_creal_horner p (x y : creal) : p.[x] != p.[y] -> x != y. +Proof. +move=> neq_px_py. +pose d := lbound neq_px_py. +pose_big_enough i. + pose k := 2%:R + poly_accr_bound p (y i) d. + have /andP[d_gt0 k_gt0] : (0 < d) && (0 < k). + rewrite ?(ltr_spaddl, poly_accr_bound_ge0); + by rewrite ?ltr0n ?ltrW ?ltr01 ?lbound_gt0. + pose_big_enough j. + apply: (@neq_crealP (d / k) j j) => //. + by rewrite ?(pmulr_lgt0, invr_gt0, ltr0n). + rewrite ler_pdivr_mulr //. + have /(_ j) // := (lbound_of neq_px_py). + big_enough=> /(_ isT isT). + apply: contraLR; rewrite -!ltrNge=> hxy. + rewrite (ler_lt_trans (@poly_accr_bound1P _ _ (y i) d _ _ _ _)) //. + + by rewrite ltrW // cauchymodP. + + rewrite ltrW // (@split_dist_add (y j)) //; last first. + by rewrite cauchymodP ?divrn_gt0. + rewrite ltr_pdivl_mulr ?ltr0n // (ler_lt_trans _ hxy) //. + by rewrite ler_wpmul2l ?normr_ge0 // ler_paddr // poly_accr_bound_ge0. + rewrite (ler_lt_trans _ hxy) // ler_wpmul2l ?normr_ge0 //. + by rewrite ler_paddl // ?ler0n. + by close. +by close. +Qed. + +Lemma eq_creal_horner p (x y : creal) : x == y -> p.[x] == p.[y]. +Proof. by move=> hxy /neq_creal_horner. Qed. + +Import Setoid Relation_Definitions. + +Add Relation creal eq_creal + reflexivity proved by eq_creal_refl + symmetry proved by eq_creal_sym + transitivity proved by eq_creal_trans +as eq_creal_rel. +Global Existing Instance eq_creal_rel. + +Add Morphism add_creal with + signature eq_creal ==> eq_creal ==> eq_creal as add_creal_morph. +Proof. +move=> x y eq_xy z t eq_zt; apply: eq_crealP. +exists_big_modulus m F. + move=> e i e_gt0 hi; rewrite opprD addrA [X in X + _]addrAC -addrA. + by rewrite split_norm_add ?eq_modP ?divrn_gt0. +by close. +Qed. +Global Existing Instance add_creal_morph_Proper. + + +Add Morphism opp_creal with + signature eq_creal ==> eq_creal as opp_creal_morph. +Proof. +move=> x y /asympt_eq [m hm]; apply: eq_crealP; exists m. +by move=> e i e_gt0 hi /=; rewrite -opprD normrN hm. +Qed. +Global Existing Instance opp_creal_morph_Proper. + +Add Morphism mul_creal with + signature eq_creal ==> eq_creal ==> eq_creal as mul_creal_morph. +Proof. +move=> x y eq_xy z t eq_zt; apply: eq_crealP. +exists_big_modulus m F. + move=> e i e_gt0 hi. + rewrite (@split_dist_add (y i * z i)) // -(mulrBl, mulrBr) normrM. + have /ler_wpmul2l /ler_lt_trans-> // := uboundP z i. + rewrite -ltr_pdivl_mulr ?ubound_gt0 ?eq_modP //. + by rewrite !pmulr_rgt0 ?invr_gt0 ?ubound_gt0 ?ltr0n. + rewrite mulrC; have /ler_wpmul2l /ler_lt_trans-> // := uboundP y i. + rewrite -ltr_pdivl_mulr ?ubound_gt0 ?eq_modP //. + by rewrite !pmulr_rgt0 ?invr_gt0 ?ubound_gt0 ?ltr0n. +by close. +Qed. +Global Existing Instance mul_creal_morph_Proper. + +Lemma eq_creal_inv (x y : creal) (x_neq0 : x != 0) (y_neq0 : y != 0) : + (x == y) -> (x_neq0^-1 == y_neq0^-1). +Proof. +move=> eq_xy; apply: eq_crealP; exists_big_modulus m F. + move=> e i e_gt0 hi /=. + rewrite -(@ltr_pmul2r _ (lbound x_neq0 * lbound y_neq0)); + do ?by rewrite ?pmulr_rgt0 ?lbound_gt0. + rewrite (@ler_lt_trans _ (`|(x i)^-1 - (y i)^-1| * (`|x i| * `|y i|))) //. + rewrite ler_wpmul2l ?normr_ge0 //. + rewrite (@ler_trans _ (`|x i| * lbound y_neq0)) //. + by rewrite ler_wpmul2r ?lbound_ge0 ?lbound0P. + by rewrite ler_wpmul2l ?normr_ge0 ?lbound0P. + rewrite -!normrM mulrBl mulKf ?creal_neq0_always //. + rewrite mulrCA mulVf ?mulr1 ?creal_neq0_always //. + by rewrite distrC eq_modP ?pmulr_rgt0 ?lbound_gt0. +by close. +Qed. + +Add Morphism horner_creal with + signature (@eq _) ==> eq_creal ==> eq_creal as horner_creal_morph. +Proof. exact: eq_creal_horner. Qed. +Global Existing Instance horner_creal_morph_Proper. + +Add Morphism lt_creal with + signature eq_creal ==> eq_creal ==> iff as lt_creal_morph. +Proof. +move=> x y eq_xy z t eq_zt. +wlog lxz : x y z t eq_xy eq_zt / (x < z)%CR. + move=> hwlog; split=> h1; move: (h1) => /hwlog; apply=> //; + by apply: eq_creal_sym. +split=> // _. +pose e' := diff lxz / 4%:R. +have e'_gt0 : e' > 0 by rewrite pmulr_rgt0 ?gtr0E ?diff_gt0. +have le_zt : (z <= t)%CR by apply: eq_le_creal. +have le_xy : (y <= x)%CR by apply: eq_le_creal; apply: eq_creal_sym. +pose_big_enough i. + apply: (@lt_crealP e' i i)=> //. + rewrite ltrW // -(ltr_add2r e'). + rewrite (ler_lt_trans _ (@le_modP _ _ le_zt _ _ _ _)) //. + rewrite -addrA (monoLR (@addrNK _ _) (@ler_add2r _ _)) ltrW //. + rewrite (ltr_le_trans (@le_modP _ _ le_xy e' _ _ _)) //. + rewrite -(monoLR (@addrNK _ _) (@ler_add2r _ _)) ltrW //. + rewrite (ltr_le_trans _ (diff_of lxz)) //. + rewrite -addrA ler_lt_add // /e' -!mulrDr gtr_pmulr ?diff_gt0 //. + by rewrite [X in _ < X](splitf 4) /= mul1r !ltr_addr ?gtr0E. +by close. +Qed. +Global Existing Instance lt_creal_morph_Proper. + +Add Morphism le_creal with + signature eq_creal ==> eq_creal ==> iff as le_creal_morph. +Proof. by move=> x y exy z t ezt; rewrite /le_creal exy ezt. Qed. +Global Existing Instance le_creal_morph_Proper. + +Add Morphism norm_creal + with signature eq_creal ==> eq_creal as norm_creal_morph. +Proof. +move=> x y hxy; apply: eq_crealP; exists_big_modulus m F. + move=> e i e_gt0 hi. + by rewrite (ler_lt_trans (ler_dist_dist _ _)) ?eq_modP. +by close. +Qed. +Global Existing Instance norm_creal_morph_Proper. + +Lemma neq_creal_ltVgt (x y : creal) : x != y -> {(x < y)%CR} + {(y < x)%CR}. +Proof. +move=> neq_xy; pose_big_enough i. + have := (@lboundP _ _ neq_xy i); big_enough => /(_ isT isT). + have [le_xy|/ltrW le_yx'] := lerP (x i) (y i). + rewrite -(ler_add2r (x i)) ?addrNK addrC. + move=> /lt_crealP; rewrite ?lbound_gt0; big_enough. + by do 3!move/(_ isT); left. + rewrite -(ler_add2r (y i)) ?addrNK addrC. + move=> /lt_crealP; rewrite ?lbound_gt0; big_enough. + by do 3!move/(_ isT); right. +by close. +Qed. + +Lemma lt_creal_neq (x y : creal) : (x < y -> x != y)%CR. +Proof. +move=> lxy; pose_big_enough i. + apply: (@neq_crealP (diff lxy) i i); rewrite ?diff_gt0 //. + rewrite distrC ler_normr (monoRL (addrK _) (ler_add2r _)) addrC. + by rewrite (diff_of lxy). +by close. +Qed. + +Lemma gt_creal_neq (x y : creal) : (y < x -> x != y)%CR. +Proof. by move/lt_creal_neq /neq_creal_sym. Qed. + +Lemma lt_creal_trans (x y z : creal) : (x < y -> y < z -> x < z)%CR. +Proof. +move=> lt_xy lt_yz; pose_big_enough i. + apply: (@lt_crealP (diff lt_xy + diff lt_yz) i i) => //. + by rewrite addr_gt0 ?diff_gt0. + rewrite (ler_trans _ (diff_of lt_yz)) //. + by rewrite addrA ler_add2r (diff_of lt_xy). +by close. +Qed. + +Lemma lt_crealW (x y : creal) : (x < y)%CR -> (x <= y)%CR. +Proof. by move=> /lt_creal_trans /(_ _) /le_creal_refl. Qed. + +Add Morphism neq_creal with + signature eq_creal ==> eq_creal ==> iff as neq_creal_morph. +Proof. +move=> x y eq_xy z t eq_zt; split=> /neq_creal_ltVgt []. ++ by rewrite eq_xy eq_zt=> /lt_creal_neq. ++ by rewrite eq_xy eq_zt=> /gt_creal_neq. ++ by rewrite -eq_xy -eq_zt=> /lt_creal_neq. +by rewrite -eq_xy -eq_zt=> /gt_creal_neq. +Qed. +Global Existing Instance neq_creal_morph_Proper. + +Local Notation m0 := (fun (_ : F) => 0%N). + +Lemma add_0creal x : 0 + x == x. +Proof. by apply: eq_crealP; exists m0=> * /=; rewrite add0r subrr normr0. Qed. + +Lemma add_creal0 x : x + 0 == x. +Proof. by apply: eq_crealP; exists m0=> * /=; rewrite addr0 subrr normr0. Qed. + +Lemma mul_creal0 x : x * 0 == 0. +Proof. by apply: eq_crealP; exists m0=> * /=; rewrite mulr0 subrr normr0. Qed. + +Lemma mul_0creal x : 0 * x == 0. +Proof. by apply: eq_crealP; exists m0=> * /=; rewrite mul0r subrr normr0. Qed. + +Lemma mul_creal1 x : x * 1%:CR == x. +Proof. by apply: eq_crealP; exists m0=> * /=; rewrite mulr1 subrr normr0. Qed. + +Lemma mul_1creal x : 1%:CR * x == x. +Proof. by apply: eq_crealP; exists m0=> * /=; rewrite mul1r subrr normr0. Qed. + +Lemma opp_creal0 : - 0 == 0. +Proof. by apply: eq_crealP; exists m0=> * /=; rewrite oppr0 addr0 normr0. Qed. + +Lemma horner_crealX (x : creal) : 'X.[x] == x. +Proof. by apply: eq_crealP; exists m0=> *; rewrite /= hornerX subrr normr0. Qed. + +Lemma horner_crealM (p q : {poly F}) (x : creal) : + ((p * q).[x] == p.[x] * q.[x])%CR. +Proof. +by apply: eq_crealP; exists m0=> * /=; rewrite hornerM subrr normr0. +Qed. + +Lemma neq_creal_cst x y : reflect (cst_creal x != cst_creal y) (x != y). +Proof. +apply: (iffP idP)=> neq_xy; pose_big_enough i. ++ by apply (@neq_crealP `|x - y| i i); rewrite ?normr_gt0 ?subr_eq0 . ++ by close. ++ by rewrite (@creal_neq_always _ _ i neq_xy). ++ by close. +Qed. + +Lemma eq_creal_cst x y : reflect (cst_creal x == cst_creal y) (x == y). +Proof. +apply: (iffP idP)=> [|eq_xy]; first by move/eqP->. +by apply/negP=> /negP /neq_creal_cst; rewrite eq_xy; apply: eq_creal_refl. +Qed. + +Lemma lt_creal_cst x y : reflect (cst_creal x < cst_creal y)%CR (x < y). +Proof. +apply: (iffP idP)=> lt_xy; pose_big_enough i. ++ apply: (@lt_crealP (y - x) i i); rewrite ?subr_gt0 //=. + by rewrite addrCA subrr addr0. ++ by close. ++ by rewrite (@creal_lt_always _ _ i lt_xy). ++ by close. +Qed. + +Lemma le_creal_cst x y : reflect (cst_creal x <= cst_creal y)%CR (x <= y). +Proof. +apply: (iffP idP)=> [le_xy /lt_creal_cst|eq_xy]; first by rewrite ltrNge le_xy. +by rewrite lerNgt; apply/negP=> /lt_creal_cst. +Qed. + + +Lemma mul_creal_neq0 x y : x != 0 -> y != 0 -> x * y != 0. +Proof. +move=> x_neq0 y_neq0. +pose d := lbound x_neq0 * lbound y_neq0. +have d_gt0 : 0 < d by rewrite pmulr_rgt0 lbound_gt0. +pose_big_enough i. + apply: (@neq_crealP d i i)=> //; rewrite subr0 normrM. + rewrite (@ler_trans _ (`|x i| * lbound y_neq0)) //. + by rewrite ler_wpmul2r ?lbound_ge0 // lbound0P. + by rewrite ler_wpmul2l ?normr_ge0 // lbound0P. +by close. +Qed. + +Lemma mul_neq0_creal x y : x * y != 0 -> y != 0. +Proof. +move=> xy_neq0; pose_big_enough i. + apply: (@neq_crealP ((ubound x)^-1 * lbound xy_neq0) i i) => //. + by rewrite pmulr_rgt0 ?invr_gt0 ?lbound_gt0 ?ubound_gt0. + rewrite subr0 ler_pdivr_mull ?ubound_gt0 //. + have /(_ i)-> // := (ler_trans (lbound0_of xy_neq0)). + by rewrite normrM ler_wpmul2r ?normr_ge0 ?uboundP. +by close. +Qed. + +Lemma poly_mul_creal_eq0_coprime p q x : + coprimep p q -> + p.[x] * q.[x] == 0 -> {p.[x] == 0} + {q.[x] == 0}. +Proof. +move=> /Bezout_eq1_coprimepP /sig_eqW [[u v] /= hpq]; pose_big_enough i. + have := (erefl ((1 : {poly F}).[x i])). + rewrite -{1}hpq /= hornerD hornerC. + set upxi := (u * _).[_]. + move=> hpqi. + have [p_small|p_big] := lerP `|upxi| 2%:R^-1=> pqx0; [left|right]. + move=> px0; apply: pqx0; apply: mul_creal_neq0=> //. + apply: (@mul_neq0_creal v.[x]). + apply: (@neq_crealP 2%:R^-1 i i); rewrite ?gtr0E //. + rewrite /= subr0 -hornerM -(ler_add2l `|upxi|). + rewrite (ler_trans _ (ler_norm_add _ _)) // hpqi normr1. + rewrite (monoLR (addrNK _) (ler_add2r _)). + by rewrite {1}[1](splitf 2) /= mul1r addrK. + move=> qx0; apply: pqx0; apply: mul_creal_neq0=> //. + apply: (@mul_neq0_creal u.[x]). + apply: (@neq_crealP 2%:R^-1 i i); rewrite ?gtr0E //. + by rewrite /= subr0 -hornerM ltrW. +by close. +Qed. + +Lemma dvdp_creal_eq0 p q x : p %| q -> p.[x] == 0 -> q.[x] == 0. +Proof. +by move=> dpq px0; rewrite -[q](divpK dpq) horner_crealM px0 mul_creal0. +Qed. + +Lemma root_poly_expn_creal p k x : (0 < k)%N + -> (p ^+ k).[x] == 0 -> p.[x] == 0. +Proof. +move=> k_gt0 pkx_eq0; apply: eq_crealP; exists_big_modulus m F. + move=> e i e_gt0 hi; rewrite /= subr0. + rewrite -(@ltr_pexpn2r _ k) -?topredE /= ?normr_ge0 ?ltrW //. + by rewrite -normrX -horner_exp (@eq0_modP _ pkx_eq0) ?exprn_gt0 //. +by close. +Qed. + +Lemma horner_cst_creal c x : c%:P.[x] == c%:CR. +Proof. +apply: eq_crealP; exists (fun _ => 0%N)=> e i e_gt0 _. +by rewrite /= hornerC subrr normr0. +Qed. + +Lemma horner_creal_cst (p : {poly F}) (x : F) : p.[x%:CR] == p.[x]%:CR. +Proof. by apply: eq_crealP; exists m0=> *; rewrite /= subrr normr0. Qed. + + +Lemma poly_mul_creal_eq0 p q x : + p.[x] * q.[x] == 0 -> {p.[x] == 0} + {q.[x] == 0}. +Proof. +move=> mul_px_qx_eq0. +have [->|p_neq0] := altP (p =P 0); first by left; rewrite horner_cst_creal. +have [->|q_neq0] := altP (q =P 0); first by right; rewrite horner_cst_creal. +pose d := gcdp p q; pose p' := gdcop d p; pose q' := gdcop d q. +have cop_q'_d': coprimep p' q'. + rewrite /coprimep size_poly_eq1. + apply: (@coprimepP _ p' d _). + + by rewrite coprimep_gdco. + + by rewrite dvdp_gcdl. + rewrite dvdp_gcd (dvdp_trans (dvdp_gcdl _ _)) ?dvdp_gdco //. + by rewrite (dvdp_trans (dvdp_gcdr _ _)) ?dvdp_gdco. +suff : (p' * q').[x] * (d ^+ (size p + size q)).[x] == 0. + case/poly_mul_creal_eq0_coprime. + + by rewrite coprimep_expr // coprimep_mull ?coprimep_gdco. + + move=> p'q'x_eq0. + have : p'.[x] * q'.[x] == 0 by rewrite -horner_crealM. + case/poly_mul_creal_eq0_coprime=> // /dvdp_creal_eq0 hp'q'. + by left; apply: hp'q'; rewrite dvdp_gdco. + by right; apply: hp'q'; rewrite dvdp_gdco. + move/root_poly_expn_creal. + rewrite addn_gt0 lt0n size_poly_eq0 p_neq0=> /(_ isT) dx_eq0. + by left; apply: dvdp_creal_eq0 dx_eq0; rewrite dvdp_gcdl. +move: mul_px_qx_eq0; rewrite -!horner_crealM. +rewrite exprD mulrAC mulrA -mulrA [_ ^+ _ * _]mulrC. +apply: dvdp_creal_eq0; rewrite ?dvdp_mul // dvdp_gdcor //; +by rewrite gcdp_eq0 negb_and p_neq0. +Qed. + +Lemma coprimep_root (p q : {poly F}) x : + coprimep p q -> p.[x] == 0 -> q.[x] != 0. +Proof. +move=> /Bezout_eq1_coprimepP /sig_eqW [[u v] hpq] px0. +have upx_eq0 : u.[x] * p.[x] == 0 by rewrite px0 mul_creal0. +pose_big_enough i. + have := (erefl ((1 : {poly F}).[x i])). + rewrite -{1}hpq /= hornerD hornerC. + set upxi := (u * _).[_]; move=> hpqi. + apply: (@neq_crealP ((ubound v.[x])%CR^-1 / 2%:R) i i) => //. + by rewrite pmulr_rgt0 ?gtr0E // ubound_gt0. + rewrite /= subr0 ler_pdivr_mull ?ubound_gt0 //. + rewrite (@ler_trans _ `|(v * q).[x i]|) //; last first. + by rewrite hornerM normrM ler_wpmul2r ?normr_ge0 ?(uboundP v.[x]). + rewrite -(ler_add2l `|upxi|) (ler_trans _ (ler_norm_add _ _)) // hpqi normr1. + rewrite (monoLR (addrNK _) (ler_add2r _)). + rewrite {1}[1](splitf 2) /= mul1r addrK ltrW // /upxi hornerM. + by rewrite (@eq0_modP _ upx_eq0) ?gtr0E. +by close. +Qed. + +Lemma deriv_neq0_mono (p : {poly F}) (x : creal) : p^`().[x] != 0 -> + { r : F & 0 < r & + { i : nat & (cauchymod x r <= i)%N & (strong_mono p (x i) r)} }. +Proof. +move=> px_neq0. +wlog : p px_neq0 / (0 < p^`().[x])%CR. + case/neq_creal_ltVgt: (px_neq0)=> px_lt0; last exact. + case/(_ (- p)). + + pose_big_enough i. + apply: (@neq_crealP (lbound px_neq0) i i); do ?by rewrite ?lbound_gt0. + rewrite /= derivN hornerN subr0 normrN. + by rewrite (lbound0_of px_neq0). + by close. + + pose_big_enough i. + apply: (@lt_crealP (diff px_lt0) i i); do ?by rewrite ?diff_gt0. + rewrite /= add0r derivN hornerN -subr_le0 opprK addrC. + by rewrite (diff_of px_lt0) //. + by close. + move=> r r_ge0 [i hi]; move/strong_monoN; rewrite opprK=> sm. + by exists r=> //; exists i. +move=> px_gt0. +pose b1 := poly_accr_bound p^`() 0 (1 + ubound x). +pose b2 := poly_accr_bound2 p 0 (1 + ubound x). +pose r := minr 1 (minr + (diff px_gt0 / 4%:R / b1) + (diff px_gt0 / 4%:R / b2 / 2%:R)). +exists r. + rewrite !ltr_minr ?ltr01 ?pmulr_rgt0 ?gtr0E ?diff_gt0; + by rewrite ?poly_accr_bound2_gt0 ?poly_accr_bound_gt0. +pose_big_enough i. + exists i => //; left; split; last first. + move=> y hy; have := (@poly_accr_bound1P _ p^`() 0 (1 + ubound x) (x i) y). + rewrite ?subr0 ler_paddl ?ler01 ?uboundP //. + rewrite (@ler_trans _ (r + `|x i|)) ?subr0; last 2 first. + + rewrite (monoRL (addrNK _) (ler_add2r _)). + by rewrite (ler_trans (ler_sub_dist _ _)). + + by rewrite ler_add ?ler_minl ?lerr ?uboundP. + move=> /(_ isT isT). + rewrite ler_distl=> /andP[le_py ge_py]. + rewrite (ltr_le_trans _ le_py) // subr_gt0 -/b1. + rewrite (ltr_le_trans _ (diff0_of px_gt0)) //. + rewrite (@ler_lt_trans _ (r * b1)) //. + by rewrite ler_wpmul2r ?poly_accr_bound_ge0. + rewrite -ltr_pdivl_mulr ?poly_accr_bound_gt0 //. + rewrite !ltr_minl ltr_pmul2r ?invr_gt0 ?poly_accr_bound_gt0 //. + by rewrite gtr_pmulr ?diff_gt0 // invf_lt1 ?gtr0E ?ltr1n ?orbT. + exists (diff px_gt0 / 4%:R). + by rewrite pmulr_rgt0 ?gtr0E ?diff_gt0. + move=> y z neq_yz hy hz. + have := (@poly_accr_bound1P _ p^`() 0 (1 + ubound x) (x i) z). + have := @poly_accr_bound2P _ p 0 (1 + ubound x) z y; rewrite eq_sym !subr0. + rewrite neq_yz ?ler01 ?ubound_ge0=> // /(_ isT). + rewrite (@ler_trans _ (r + `|x i|)); last 2 first. + + rewrite (monoRL (addrNK _) (ler_add2r _)). + by rewrite (ler_trans (ler_sub_dist _ _)). + + rewrite ler_add ?ler_minl ?lerr ?uboundP //. + rewrite (@ler_trans _ (r + `|x i|)); last 2 first. + + rewrite (monoRL (addrNK _) (ler_add2r _)). + by rewrite (ler_trans (ler_sub_dist _ _)). + + rewrite ler_add ?ler_minl ?lerr ?uboundP //. + rewrite ler_paddl ?uboundP ?ler01 //. + move=> /(_ isT isT); rewrite ler_distl=> /andP [haccr _]. + move=> /(_ isT isT); rewrite ler_distl=> /andP [hp' _]. + rewrite (ltr_le_trans _ haccr) // (monoRL (addrK _) (ltr_add2r _)). + rewrite (ltr_le_trans _ hp') // (monoRL (addrK _) (ltr_add2r _)). + rewrite (ltr_le_trans _ (diff0_of px_gt0)) //. + rewrite {2}[diff _](splitf 4) /= -!addrA ltr_add2l ltr_spaddl //. + by rewrite pmulr_rgt0 ?gtr0E ?diff_gt0. + rewrite -/b1 -/b2 ler_add //. + rewrite -ler_pdivl_mulr ?poly_accr_bound2_gt0 //. + rewrite (@ler_trans _ (r * 2%:R)) //. + rewrite (ler_trans (ler_dist_add (x i) _ _)) //. + by rewrite mulrDr mulr1 ler_add // distrC. + by rewrite -ler_pdivl_mulr ?ltr0n // !ler_minl lerr !orbT. + rewrite -ler_pdivl_mulr ?poly_accr_bound_gt0 //. + by rewrite (@ler_trans _ r) // !ler_minl lerr !orbT. +by close. +Qed. + +Lemma smaller_factor (p q : {poly F}) x : + p \is monic-> p.[x] == 0 -> + ~~(p %| q) -> ~~ coprimep p q -> + {r : {poly F} | (size r < size p)%N && (r \is monic) & r.[x] == 0}. +Proof. +move=> monic_p px0 ndvd_pq. +rewrite /coprimep; set d := gcdp _ _=> sd_neq1. +pose r1 : {poly F} := (lead_coef d)^-1 *: d. +pose r2 := p %/ r1. +have ld_neq0 : lead_coef d != 0 :> F. + by rewrite lead_coef_eq0 gcdp_eq0 negb_and monic_neq0. +have monic_r1 : r1 \is monic. + by rewrite monicE /r1 -mul_polyC lead_coefM lead_coefC mulVf. +have eq_p_r2r1: p = r2 * r1. + by rewrite divpK // (@eqp_dvdl _ d) ?dvdp_gcdl // eqp_scale ?invr_eq0. +have monic_r2 : r2 \is monic by rewrite -(monicMr _ monic_r1) -eq_p_r2r1. +have eq_sr1_sd : size r1 = size d by rewrite size_scale ?invr_eq0. +have sr1 : (1 < size r1)%N. + by rewrite ltn_neqAle eq_sym lt0n size_poly_eq0 monic_neq0 ?andbT ?eq_sr1_sd. +have sr2 : (1 < size r2)%N. + rewrite size_divp ?size_dvdp ?monic_neq0 //. + rewrite ltn_subRL addn1 prednK ?(leq_trans _ sr1) // eq_sr1_sd. + rewrite ltn_neqAle dvdp_leq ?monic_neq0 ?andbT ?dvdp_size_eqp ?dvdp_gcdl //. + by apply: contra ndvd_pq=> /eqp_dvdl <-; rewrite dvdp_gcdr. +move: (px0); rewrite eq_p_r2r1=> r2r1x_eq0. +have : (r2.[x] * r1.[x] == 0) by rewrite -horner_crealM. +case/poly_mul_creal_eq0=> [r2x_eq0|r1x_eq0]. + exists r2; rewrite ?monic_r2 ?andbT // mulrC. + by rewrite -ltn_divpl ?divpp ?monic_neq0 // size_poly1. +exists r1; rewrite ?monic_r1 ?andbT //. +by rewrite -ltn_divpl ?divpp ?monic_neq0 // size_poly1. +Qed. + +Lemma root_cst_creal (x : F) : ('X - x%:P).[cst_creal x] == 0. +Proof. +apply: eq_crealP; exists_big_modulus m F. + by move=> e i e_gt0 hi; rewrite /= subr0 !hornerE subrr normr0. +by close. +Qed. + +Lemma has_root_creal_size_gt1 (x : creal) (p : {poly F}) : + (p != 0)%B -> p.[x] == 0 -> (1 < size p)%N. +Proof. +move=> p_neq0 rootpa. +rewrite ltnNge leq_eqVlt ltnS leqn0 size_poly_eq0 (negPf p_neq0) orbF. +apply/negP=> /size_poly1P [c c_neq0 eq_pc]; apply: rootpa. +by rewrite eq_pc horner_cst_creal; apply/neq_creal_cst. +Qed. + +Definition bound_poly_bound (z : creal) (q : {poly {poly F}}) (a r : F) i := + (1 + \sum_(j < sizeY q) + `|(norm_poly2 q).[(ubound z)%:P]^`N(i.+1)`_j| * (`|a| + `|r|) ^+ j). + +Lemma bound_poly_boundP (z : creal) i (q : {poly {poly F}}) (a r : F) j : + poly_bound q.[(z i)%:P]^`N(j.+1) a r <= bound_poly_bound z q a r j. +Proof. +rewrite /poly_bound. +pose f q (k : nat) := `|q^`N(j.+1)`_k| * (`|a| + `|r|) ^+ k. +rewrite ler_add //=. +rewrite (big_ord_widen (sizeY q) (f q.[(z i)%:P])); last first. + rewrite size_nderivn leq_subLR (leq_trans (max_size_evalC _ _)) //. + by rewrite leq_addl. +rewrite big_mkcond /= ler_sum // /f => k _. +case: ifP=> _; last by rewrite mulr_ge0 ?exprn_ge0 ?addr_ge0 ?normr_ge0. +rewrite ler_wpmul2r ?exprn_ge0 ?addr_ge0 ?normr_ge0 //. +rewrite !horner_coef. +rewrite !(@big_morph _ _ (fun p => p^`N(j.+1)) 0 +%R); + do ?[by rewrite raddf0|by move=> x y /=; rewrite raddfD]. +rewrite !coef_sum. +rewrite (ler_trans (ler_norm_sum _ _ _)) //. +rewrite ger0_norm; last first. + rewrite sumr_ge0=> //= l _. + rewrite coef_nderivn mulrn_wge0 ?natr_ge0 //. + rewrite -polyC_exp coefMC coef_norm_poly2 mulr_ge0 ?normr_ge0 //. + by rewrite exprn_ge0 ?ltrW ?ubound_gt0. +rewrite size_norm_poly2 ler_sum //= => l _. +rewrite !{1}coef_nderivn normrMn ler_pmuln2r ?bin_gt0 ?leq_addr //. +rewrite -!polyC_exp !coefMC coef_norm_poly2 normrM ler_wpmul2l ?normr_ge0 //. +rewrite normrX; case: (val l)=> // {l} l. +by rewrite ler_pexpn2r -?topredE //= ?uboundP ?ltrW ?ubound_gt0. +Qed. + +Lemma bound_poly_bound_ge0 z q a r i : 0 <= bound_poly_bound z q a r i. +Proof. +by rewrite (ler_trans _ (bound_poly_boundP _ 0%N _ _ _ _)) ?poly_bound_ge0. +Qed. + +Definition bound_poly_accr_bound (z : creal) (q : {poly {poly F}}) (a r : F) := + maxr 1 (2%:R * r) ^+ (sizeY q).-1 * + (1 + \sum_(i < (sizeY q).-1) bound_poly_bound z q a r i). + +Lemma bound_poly_accr_boundP (z : creal) i (q : {poly {poly F}}) (a r : F) : + poly_accr_bound q.[(z i)%:P] a r <= bound_poly_accr_bound z q a r. +Proof. +rewrite /poly_accr_bound /bound_poly_accr_bound /=. +set ui := _ ^+ _; set u := _ ^+ _; set vi := 1 + _. +rewrite (@ler_trans _ (u * vi)) //. + rewrite ler_wpmul2r //. + by rewrite addr_ge0 ?ler01 // sumr_ge0 //= => j _; rewrite poly_bound_ge0. + rewrite /ui /u; case: maxrP; first by rewrite !expr1n. + move=> r2_gt1; rewrite ler_eexpn2l //. + rewrite -subn1 leq_subLR add1n (leq_trans _ (leqSpred _)) //. + by rewrite max_size_evalC. +rewrite ler_wpmul2l ?exprn_ge0 ?ler_maxr ?ler01 // ler_add //. +pose f j := poly_bound q.[(z i)%:P]^`N(j.+1) a r. +rewrite (big_ord_widen (sizeY q).-1 f); last first. + rewrite -subn1 leq_subLR add1n (leq_trans _ (leqSpred _)) //. + by rewrite max_size_evalC. +rewrite big_mkcond /= ler_sum // /f => k _. +by case: ifP=> _; rewrite ?bound_poly_bound_ge0 ?bound_poly_boundP. +Qed. + +Lemma bound_poly_accr_bound_gt0 (z : creal) (q : {poly {poly F}}) (a r : F) : + 0 < bound_poly_accr_bound z q a r. +Proof. +rewrite (ltr_le_trans _ (bound_poly_accr_boundP _ 0%N _ _ _)) //. +by rewrite poly_accr_bound_gt0. +Qed. + +Lemma horner2_crealP (p : {poly {poly F}}) (x y : creal) : + creal_axiom (fun i => p.[x i, y i]). +Proof. +set a := x (cauchymod x 1). +exists_big_modulus m F. + move=> e i j e_gt0 hi hj; rewrite (@split_dist_add p.[x i, y j]) //. + rewrite (ler_lt_trans (@poly_accr_bound1P _ _ 0 (ubound y) _ _ _ _)) //; + do ?by rewrite ?subr0 ?uboundP. + rewrite (@ler_lt_trans _ (`|y i - y j| + * bound_poly_accr_bound x p 0 (ubound y))) //. + by rewrite ler_wpmul2l ?normr_ge0 // bound_poly_accr_boundP. + rewrite -ltr_pdivl_mulr ?bound_poly_accr_bound_gt0 //. + by rewrite cauchymodP // !pmulr_rgt0 ?gtr0E ?bound_poly_accr_bound_gt0. + rewrite -[p]swapXYK ![(swapXY (swapXY _)).[_, _]]horner2_swapXY. + rewrite (ler_lt_trans (@poly_accr_bound1P _ _ 0 (ubound x) _ _ _ _)) //; + do ?by rewrite ?subr0 ?uboundP. + rewrite (@ler_lt_trans _ (`|x i - x j| + * bound_poly_accr_bound y (swapXY p) 0 (ubound x))) //. + by rewrite ler_wpmul2l ?normr_ge0 // bound_poly_accr_boundP. + rewrite -ltr_pdivl_mulr ?bound_poly_accr_bound_gt0 //. + by rewrite cauchymodP // !pmulr_rgt0 ?gtr0E ?bound_poly_accr_bound_gt0. +by close. +Qed. + +Definition horner2_creal (p : {poly {poly F}}) (x y : creal) := + CReal (horner2_crealP p x y). +Notation "p .[ x , y ]" := (horner2_creal p x y) + (at level 2, left associativity) : creal_scope. + +Lemma root_monic_from_neq0 (p : {poly F}) (x : creal) : + p.[x] == 0 -> ((lead_coef p) ^-1 *: p).[x] == 0. +Proof. by rewrite -mul_polyC horner_crealM; move->; rewrite mul_creal0. Qed. + +Lemma root_sub_annihilant_creal (x y : creal) (p q : {poly F}) : + (p != 0)%B -> (q != 0)%B -> p.[x] == 0 -> q.[y] == 0 -> + (sub_annihilant p q).[x - y] == 0. +Proof. +move=> p_neq0 q_neq0 px_eq0 qy_eq0. +have [||[u v] /= [hu hv] hpq] := @sub_annihilant_in_ideal _ p q. ++ by rewrite (@has_root_creal_size_gt1 x). ++ by rewrite (@has_root_creal_size_gt1 y). +apply: eq_crealP; exists_big_modulus m F. + move=> e i e_gt0 hi /=; rewrite subr0. + rewrite (hpq (y i)) addrCA subrr addr0 split_norm_add // normrM. + rewrite (@ler_lt_trans _ ((ubound u.[y, x - y]) * `|p.[x i]|)) //. + by rewrite ler_wpmul2r ?normr_ge0 // (uboundP u.[y, x - y] i). + rewrite -ltr_pdivl_mull ?ubound_gt0 //. + by rewrite (@eq0_modP _ px_eq0) // !pmulr_rgt0 ?gtr0E ?ubound_gt0. + rewrite (@ler_lt_trans _ ((ubound v.[y, x - y]) * `|q.[y i]|)) //. + by rewrite ler_wpmul2r ?normr_ge0 // (uboundP v.[y, x - y] i). + rewrite -ltr_pdivl_mull ?ubound_gt0 //. + by rewrite (@eq0_modP _ qy_eq0) // !pmulr_rgt0 ?gtr0E ?ubound_gt0. +by close. +Qed. + +Lemma root_div_annihilant_creal (x y : creal) (p q : {poly F}) (y_neq0 : y != 0) : + (p != 0)%B -> (q != 0)%B -> p.[x] == 0 -> q.[y] == 0 -> + (div_annihilant p q).[(x / y_neq0)%CR] == 0. +Proof. +move=> p_neq0 q_neq0 px_eq0 qy_eq0. +have [||[u v] /= [hu hv] hpq] := @div_annihilant_in_ideal _ p q. ++ by rewrite (@has_root_creal_size_gt1 x). ++ by rewrite (@has_root_creal_size_gt1 y). +apply: eq_crealP; exists_big_modulus m F. + move=> e i e_gt0 hi /=; rewrite subr0. + rewrite (hpq (y i)) mulrCA divff ?mulr1; last first. + by rewrite -normr_gt0 (ltr_le_trans _ (lbound0_of y_neq0)) ?lbound_gt0. + rewrite split_norm_add // normrM. + rewrite (@ler_lt_trans _ ((ubound u.[y, x / y_neq0]) * `|p.[x i]|)) //. + by rewrite ler_wpmul2r ?normr_ge0 // (uboundP u.[y, x / y_neq0] i). + rewrite -ltr_pdivl_mull ?ubound_gt0 //. + by rewrite (@eq0_modP _ px_eq0) // !pmulr_rgt0 ?gtr0E ?ubound_gt0. + rewrite (@ler_lt_trans _ ((ubound v.[y, x / y_neq0]) * `|q.[y i]|)) //. + by rewrite ler_wpmul2r ?normr_ge0 // (uboundP v.[y, x / y_neq0] i). + rewrite -ltr_pdivl_mull ?ubound_gt0 //. + by rewrite (@eq0_modP _ qy_eq0) // !pmulr_rgt0 ?gtr0E ?ubound_gt0. +by close. +Qed. + +Definition exp_creal x n := (iterop n *%CR x 1%:CR). +Notation "x ^+ n" := (exp_creal x n) : creal_scope. + +Add Morphism exp_creal with + signature eq_creal ==> (@eq _) ==> eq_creal as exp_creal_morph. +Proof. +move=> x y eq_xy [//|n]; rewrite /exp_creal !iteropS. +by elim: n=> //= n ->; rewrite eq_xy. +Qed. +Global Existing Instance exp_creal_morph_Proper. + +Lemma horner_coef_creal p x : + p.[x] == \big[+%CR/0%:CR]_(i < size p) ((p`_i)%:CR * (x ^+ i))%CR. +Proof. +apply: eq_crealP; exists m0=> e n e_gt0 hn /=; rewrite horner_coef. +rewrite (@big_morph _ _ (fun u : creal => u n) 0%R +%R) //. +rewrite -sumrB /= big1 ?normr0=> //= i _. +apply/eqP; rewrite subr_eq0; apply/eqP; congr (_ * _). +case: val=> {i} // i; rewrite exprS /exp_creal iteropS. +by elim: i=> [|i ihi]; rewrite ?expr0 ?mulr1 //= exprS ihi. +Qed. + +End CauchyReals. + +Notation "x == y" := (eq_creal x y) : creal_scope. +Notation "!=%CR" := neq_creal : creal_scope. +Notation "x != y" := (neq_creal x y) : creal_scope. + +Notation "x %:CR" := (cst_creal x) + (at level 2, left associativity, format "x %:CR") : creal_scope. +Notation "0" := (0 %:CR)%CR : creal_scope. + +Notation "<%CR" := lt_creal : creal_scope. +Notation "x < y" := (lt_creal x y) : creal_scope. + +Notation "<=%CR" := le_creal : creal_scope. +Notation "x <= y" := (le_creal x y) : creal_scope. + +Notation "-%CR" := opp_creal : creal_scope. +Notation "- x" := (opp_creal x) : creal_scope. + +Notation "+%CR" := add_creal : creal_scope. +Notation "x + y" := (add_creal x y) : creal_scope. +Notation "x - y" := (x + - y)%CR : creal_scope. + +Notation "*%CR" := mul_creal : creal_scope. +Notation "x * y" := (mul_creal x y) : creal_scope. + +Notation "x_neq0 ^-1" := (inv_creal x_neq0) : creal_scope. +Notation "x / y_neq0" := (x * (y_neq0 ^-1))%CR : creal_scope. +Notation "p .[ x ]" := (horner_creal p x) : creal_scope. +Notation "p .[ x , y ]" := (horner2_creal p x y) + (at level 2, left associativity) : creal_scope. +Notation "x ^+ n" := (exp_creal x n) : creal_scope. + +Notation "`| x |" := (norm_creal x) : creal_scope. + +Hint Resolve eq_creal_refl. +Hint Resolve le_creal_refl. + +Notation lbound_of p := (@lboundP _ _ _ p _ _ _). +Notation lbound0_of p := (@lbound0P _ _ p _ _ _). +Notation diff_of p := (@diffP _ _ _ p _ _ _). +Notation diff0_of p := (@diff0P _ _ p _ _ _). + +Notation "{ 'asympt' e : i / P }" := (asympt1 (fun e i => P)) + (at level 0, e ident, i ident, format "{ 'asympt' e : i / P }") : type_scope. +Notation "{ 'asympt' e : i j / P }" := (asympt2 (fun e i j => P)) + (at level 0, e ident, i ident, j ident, format "{ 'asympt' e : i j / P }") : type_scope. diff --git a/mathcomp/real_closed/complex.v b/mathcomp/real_closed/complex.v new file mode 100644 index 0000000..1c26a9d --- /dev/null +++ b/mathcomp/real_closed/complex.v @@ -0,0 +1,1252 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype. +Require Import bigop ssralg ssrint div ssrnum rat poly closed_field polyrcf. +Require Import matrix mxalgebra tuple mxpoly zmodp binomial realalg. + +(**********************************************************************) +(* This files defines the extension R[i] of a real field R, *) +(* and provide it a structure of numeric field with a norm operator. *) +(* When R is a real closed field, it also provides a structure of *) +(* algebraically closed field for R[i], using a proof by Derksen *) +(* (cf comments below, thanks to Pierre Lairez for finding the paper) *) +(**********************************************************************) + +Import GRing.Theory Num.Theory. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope ring_scope. + +Reserved Notation "x +i* y" + (at level 40, left associativity, format "x +i* y"). +Reserved Notation "x -i* y" + (at level 40, left associativity, format "x -i* y"). +Reserved Notation "R [i]" + (at level 2, left associativity, format "R [i]"). + +Local Notation sgr := Num.sg. +Local Notation sqrtr := Num.sqrt. + +CoInductive complex (R : Type) : Type := Complex { Re : R; Im : R }. + +Definition real_complex_def (F : ringType) (phF : phant F) (x : F) := + Complex x 0. +Notation real_complex F := (@real_complex_def _ (Phant F)). +Notation "x %:C" := (real_complex _ x) + (at level 2, left associativity, format "x %:C") : ring_scope. +Notation "x +i* y" := (Complex x y) : ring_scope. +Notation "x -i* y" := (Complex x (- y)) : ring_scope. +Notation "x *i " := (Complex 0 x) (at level 8, format "x *i") : ring_scope. +Notation "''i'" := (Complex 0 1) : ring_scope. +Notation "R [i]" := (complex R) + (at level 2, left associativity, format "R [i]"). + +Module ComplexEqChoice. +Section ComplexEqChoice. + +Variable R : Type. + +Definition sqR_of_complex (x : R[i]) := let: a +i* b := x in [::a; b]. +Definition complex_of_sqR (x : seq R) := + if x is [:: a; b] then Some (a +i* b) else None. + +Lemma complex_of_sqRK : pcancel sqR_of_complex complex_of_sqR. +Proof. by case. Qed. + +End ComplexEqChoice. +End ComplexEqChoice. + +Definition complex_eqMixin (R : eqType) := + PcanEqMixin (@ComplexEqChoice.complex_of_sqRK R). +Definition complex_choiceMixin (R : choiceType) := + PcanChoiceMixin (@ComplexEqChoice.complex_of_sqRK R). +Definition complex_countMixin (R : countType) := + PcanCountMixin (@ComplexEqChoice.complex_of_sqRK R). + +Canonical Structure complex_eqType (R : eqType) := + EqType R[i] (complex_eqMixin R). +Canonical Structure complex_choiceType (R : choiceType) := + ChoiceType R[i] (complex_choiceMixin R). +Canonical Structure complex_countType (R : countType) := + CountType R[i] (complex_countMixin R). + +Lemma eq_complex : forall (R : eqType) (x y : complex R), + (x == y) = (Re x == Re y) && (Im x == Im y). +Proof. +move=> R [a b] [c d] /=. +apply/eqP/andP; first by move=> [-> ->]; split. +by case; move/eqP->; move/eqP->. +Qed. + +Lemma complexr0 : forall (R : ringType) (x : R), x +i* 0 = x%:C. Proof. by []. Qed. + +Module ComplexField. +Section ComplexField. + +Variable R : rcfType. +Local Notation C := R[i]. +Local Notation C0 := ((0 : R)%:C). +Local Notation C1 := ((1 : R)%:C). + +Definition addc (x y : R[i]) := let: a +i* b := x in let: c +i* d := y in + (a + c) +i* (b + d). +Definition oppc (x : R[i]) := let: a +i* b := x in (- a) +i* (- b). + +Lemma addcC : commutative addc. +Proof. by move=> [a b] [c d] /=; congr (_ +i* _); rewrite addrC. Qed. +Lemma addcA : associative addc. +Proof. by move=> [a b] [c d] [e f] /=; rewrite !addrA. Qed. + +Lemma add0c : left_id C0 addc. +Proof. by move=> [a b] /=; rewrite !add0r. Qed. + +Lemma addNc : left_inverse C0 oppc addc. +Proof. by move=> [a b] /=; rewrite !addNr. Qed. + +Definition complex_ZmodMixin := ZmodMixin addcA addcC add0c addNc. +Canonical Structure complex_ZmodType := ZmodType R[i] complex_ZmodMixin. + +Definition mulc (x y : R[i]) := let: a +i* b := x in let: c +i* d := y in + ((a * c) - (b * d)) +i* ((a * d) + (b * c)). + +Lemma mulcC : commutative mulc. +Proof. +move=> [a b] [c d] /=. +by rewrite [c * b + _]addrC ![_ * c]mulrC ![_ * d]mulrC. +Qed. + +Lemma mulcA : associative mulc. +Proof. +move=> [a b] [c d] [e f] /=. +rewrite !mulrDr !mulrDl !mulrN !mulNr !mulrA !opprD -!addrA. +by congr ((_ + _) +i* (_ + _)); rewrite !addrA addrAC; + congr (_ + _); rewrite addrC. +Qed. + +Definition invc (x : R[i]) := let: a +i* b := x in let n2 := (a ^+ 2 + b ^+ 2) in + (a / n2) -i* (b / n2). + +Lemma mul1c : left_id C1 mulc. +Proof. by move=> [a b] /=; rewrite !mul1r !mul0r subr0 addr0. Qed. + +Lemma mulc_addl : left_distributive mulc addc. +Proof. +move=> [a b] [c d] [e f] /=; rewrite !mulrDl !opprD -!addrA. +by congr ((_ + _) +i* (_ + _)); rewrite addrCA. +Qed. + +Lemma nonzero1c : C1 != C0. Proof. by rewrite eq_complex /= oner_eq0. Qed. + +Definition complex_comRingMixin := + ComRingMixin mulcA mulcC mul1c mulc_addl nonzero1c. +Canonical Structure complex_Ring := + Eval hnf in RingType R[i] complex_comRingMixin. +Canonical Structure complex_comRing := Eval hnf in ComRingType R[i] mulcC. + +Lemma mulVc : forall x, x != C0 -> mulc (invc x) x = C1. +Proof. +move=> [a b]; rewrite eq_complex => /= hab; rewrite !mulNr opprK. +rewrite ![_ / _ * _]mulrAC [b * a]mulrC subrr complexr0 -mulrDl mulfV //. +by rewrite paddr_eq0 -!expr2 ?expf_eq0 ?sqr_ge0. +Qed. + +Lemma invc0 : invc C0 = C0. Proof. by rewrite /= !mul0r oppr0. Qed. + +Definition ComplexFieldUnitMixin := FieldUnitMixin mulVc invc0. +Canonical Structure complex_unitRing := + Eval hnf in UnitRingType C ComplexFieldUnitMixin. +Canonical Structure complex_comUnitRing := + Eval hnf in [comUnitRingType of R[i]]. + +Lemma field_axiom : GRing.Field.mixin_of complex_unitRing. +Proof. by []. Qed. + +Definition ComplexFieldIdomainMixin := (FieldIdomainMixin field_axiom). +Canonical Structure complex_iDomain := + Eval hnf in IdomainType R[i] (FieldIdomainMixin field_axiom). +Canonical Structure complex_fieldMixin := FieldType R[i] field_axiom. + +Ltac simpc := do ? + [ rewrite -[(_ +i* _) - (_ +i* _)]/(_ +i* _) + | rewrite -[(_ +i* _) + (_ +i* _)]/(_ +i* _) + | rewrite -[(_ +i* _) * (_ +i* _)]/(_ +i* _)]. + +Lemma real_complex_is_rmorphism : rmorphism (real_complex R). +Proof. +split; [|split=> //] => a b /=; simpc; first by rewrite subrr. +by rewrite !mulr0 !mul0r addr0 subr0. +Qed. + +Canonical Structure real_complex_rmorphism := + RMorphism real_complex_is_rmorphism. +Canonical Structure real_complex_additive := + Additive real_complex_is_rmorphism. + +Lemma Re_is_additive : additive (@Re R). +Proof. by case=> a1 b1; case=> a2 b2. Qed. + +Canonical Structure Re_additive := Additive Re_is_additive. + +Lemma Im_is_additive : additive (@Im R). +Proof. by case=> a1 b1; case=> a2 b2. Qed. + +Canonical Structure Im_additive := Additive Im_is_additive. + +Definition lec (x y : R[i]) := + let: a +i* b := x in let: c +i* d := y in + (d == b) && (a <= c). + +Definition ltc (x y : R[i]) := + let: a +i* b := x in let: c +i* d := y in + (d == b) && (a < c). + +Definition normc (x : R[i]) : R := + let: a +i* b := x in sqrtr (a ^+ 2 + b ^+ 2). + +Notation normC x := (normc x)%:C. + +Lemma ltc0_add : forall x y, ltc 0 x -> ltc 0 y -> ltc 0 (x + y). +Proof. +move=> [a b] [c d] /= /andP [/eqP-> ha] /andP [/eqP-> hc]. +by rewrite addr0 eqxx addr_gt0. +Qed. + +Lemma eq0_normc x : normc x = 0 -> x = 0. +Proof. +case: x => a b /= /eqP; rewrite sqrtr_eq0 ler_eqVlt => /orP [|]; last first. + by rewrite ltrNge addr_ge0 ?sqr_ge0. +by rewrite paddr_eq0 ?sqr_ge0 ?expf_eq0 //= => /andP[/eqP -> /eqP ->]. +Qed. + +Lemma eq0_normC x : normC x = 0 -> x = 0. Proof. by case=> /eq0_normc. Qed. + +Lemma ge0_lec_total x y : lec 0 x -> lec 0 y -> lec x y || lec y x. +Proof. +move: x y => [a b] [c d] /= /andP[/eqP -> a_ge0] /andP[/eqP -> c_ge0]. +by rewrite eqxx ler_total. +Qed. + +(* :TODO: put in ssralg ? *) +Lemma exprM (a b : R) : (a * b) ^+ 2 = a ^+ 2 * b ^+ 2. +Proof. by rewrite mulrACA. Qed. + +Lemma normcM x y : normc (x * y) = normc x * normc y. +Proof. +move: x y => [a b] [c d] /=; rewrite -sqrtrM ?addr_ge0 ?sqr_ge0 //. +rewrite sqrrB sqrrD mulrDl !mulrDr -!exprM. +rewrite mulrAC [b * d]mulrC !mulrA. +suff -> : forall (u v w z t : R), (u - v + w) + (z + v + t) = u + w + (z + t). + by rewrite addrAC !addrA. +by move=> u v w z t; rewrite [_ - _ + _]addrAC [z + v]addrC !addrA addrNK. +Qed. + +Lemma normCM x y : normC (x * y) = normC x * normC y. +Proof. by rewrite -rmorphM normcM. Qed. + +Lemma subc_ge0 x y : lec 0 (y - x) = lec x y. +Proof. by move: x y => [a b] [c d] /=; simpc; rewrite subr_ge0 subr_eq0. Qed. + +Lemma lec_def x y : lec x y = (normC (y - x) == y - x). +Proof. +rewrite -subc_ge0; move: (_ - _) => [a b]; rewrite eq_complex /= eq_sym. +have [<- /=|_] := altP eqP; last by rewrite andbF. +by rewrite [0 ^+ _]mul0r addr0 andbT sqrtr_sqr ger0_def. +Qed. + +Lemma ltc_def x y : ltc x y = (y != x) && lec x y. +Proof. +move: x y => [a b] [c d] /=; simpc; rewrite eq_complex /=. +by have [] := altP eqP; rewrite ?(andbF, andbT) //= ltr_def. +Qed. + +Lemma lec_normD x y : lec (normC (x + y)) (normC x + normC y). +Proof. +move: x y => [a b] [c d] /=; simpc; rewrite addr0 eqxx /=. +rewrite -(@ler_pexpn2r _ 2) -?topredE /= ?(ler_paddr, sqrtr_ge0) //. +rewrite [X in _ <= X] sqrrD ?sqr_sqrtr; + do ?by rewrite ?(ler_paddr, sqrtr_ge0, sqr_ge0, mulr_ge0) //. +rewrite -addrA addrCA (monoRL (addrNK _) (ler_add2r _)) !sqrrD. +set u := _ *+ 2; set v := _ *+ 2. +rewrite [a ^+ _ + _ + _]addrAC [b ^+ _ + _ + _]addrAC -addrA. +rewrite [u + _] addrC [X in _ - X]addrAC [b ^+ _ + _]addrC. +rewrite [u]lock [v]lock !addrA; set x := (a ^+ 2 + _ + _ + _). +rewrite -addrA addrC addKr -!lock addrC. +have [huv|] := ger0P (u + v); last first. + by move=> /ltrW /ler_trans -> //; rewrite pmulrn_lge0 // mulr_ge0 ?sqrtr_ge0. +rewrite -(@ler_pexpn2r _ 2) -?topredE //=; last first. + by rewrite ?(pmulrn_lge0, mulr_ge0, sqrtr_ge0) //. +rewrite -mulr_natl !exprM !sqr_sqrtr ?(ler_paddr, sqr_ge0) //. +rewrite -mulrnDl -mulr_natl !exprM ler_pmul2l ?exprn_gt0 ?ltr0n //. +rewrite sqrrD mulrDl !mulrDr -!exprM addrAC. +rewrite [_ + (b * d) ^+ 2]addrC [X in _ <= X]addrAC -!addrA !ler_add2l. +rewrite mulrAC mulrA -mulrA mulrACA mulrC. +by rewrite -subr_ge0 addrAC -sqrrB sqr_ge0. +Qed. + +Definition complex_POrderedMixin := NumMixin lec_normD ltc0_add eq0_normC + ge0_lec_total normCM lec_def ltc_def. +Canonical Structure complex_numDomainType := + NumDomainType R[i] complex_POrderedMixin. + +End ComplexField. +End ComplexField. + +Canonical complex_ZmodType (R : rcfType) := + ZmodType R[i] (ComplexField.complex_ZmodMixin R). +Canonical complex_Ring (R : rcfType) := + Eval hnf in RingType R[i] (ComplexField.complex_comRingMixin R). +Canonical complex_comRing (R : rcfType) := + Eval hnf in ComRingType R[i] (@ComplexField.mulcC R). +Canonical complex_unitRing (R : rcfType) := + Eval hnf in UnitRingType R[i] (ComplexField.ComplexFieldUnitMixin R). +Canonical complex_comUnitRing (R : rcfType) := + Eval hnf in [comUnitRingType of R[i]]. +Canonical complex_iDomain (R : rcfType) := + Eval hnf in IdomainType R[i] (FieldIdomainMixin (@ComplexField.field_axiom R)). +Canonical complex_fieldType (R : rcfType) := + FieldType R[i] (@ComplexField.field_axiom R). +Canonical complex_numDomainType (R : rcfType) := + NumDomainType R[i] (ComplexField.complex_POrderedMixin R). +Canonical complex_numFieldType (R : rcfType) := + [numFieldType of complex R]. + +Canonical ComplexField.real_complex_rmorphism. +Canonical ComplexField.real_complex_additive. +Canonical ComplexField.Re_additive. +Canonical ComplexField.Im_additive. + +Definition conjc {R : ringType} (x : R[i]) := let: a +i* b := x in a -i* b. +Notation "x ^*" := (conjc x) (at level 2, format "x ^*"). + +Ltac simpc := do ? + [ rewrite -[(_ +i* _) - (_ +i* _)]/(_ +i* _) + | rewrite -[(_ +i* _) + (_ +i* _)]/(_ +i* _) + | rewrite -[(_ +i* _) * (_ +i* _)]/(_ +i* _) + | rewrite -[(_ +i* _) <= (_ +i* _)]/((_ == _) && (_ <= _)) + | rewrite -[(_ +i* _) < (_ +i* _)]/((_ == _) && (_ < _)) + | rewrite -[`|_ +i* _|]/(sqrtr (_ + _))%:C + | rewrite (mulrNN, mulrN, mulNr, opprB, opprD, mulr0, mul0r, + subr0, sub0r, addr0, add0r, mulr1, mul1r, subrr, opprK, oppr0, + eqxx) ]. + + +Section ComplexTheory. + +Variable R : rcfType. + +Lemma ReiNIm : forall x : R[i], Re (x * 'i) = - Im x. +Proof. by case=> a b; simpc. Qed. + +Lemma ImiRe : forall x : R[i], Im (x * 'i) = Re x. +Proof. by case=> a b; simpc. Qed. + +Lemma complexE x : x = (Re x)%:C + 'i * (Im x)%:C :> R[i]. +Proof. by case: x => *; simpc. Qed. + +Lemma real_complexE x : x%:C = x +i* 0 :> R[i]. Proof. done. Qed. + +Lemma sqr_i : 'i ^+ 2 = -1 :> R[i]. +Proof. by rewrite exprS; simpc; rewrite -real_complexE rmorphN. Qed. + +Lemma complexI : injective (real_complex R). Proof. by move=> x y []. Qed. + +Lemma ler0c (x : R) : (0 <= x%:C) = (0 <= x). Proof. by simpc. Qed. + +Lemma lecE : forall x y : R[i], (x <= y) = (Im y == Im x) && (Re x <= Re y). +Proof. by move=> [a b] [c d]. Qed. + +Lemma ltcE : forall x y : R[i], (x < y) = (Im y == Im x) && (Re x < Re y). +Proof. by move=> [a b] [c d]. Qed. + +Lemma lecR : forall x y : R, (x%:C <= y%:C) = (x <= y). +Proof. by move=> x y; simpc. Qed. + +Lemma ltcR : forall x y : R, (x%:C < y%:C) = (x < y). +Proof. by move=> x y; simpc. Qed. + +Lemma conjc_is_rmorphism : rmorphism (@conjc R). +Proof. +split=> [[a b] [c d]|] /=; first by simpc; rewrite [d - _]addrC. +by split=> [[a b] [c d]|] /=; simpc. +Qed. + +Canonical conjc_rmorphism := RMorphism conjc_is_rmorphism. +Canonical conjc_additive := Additive conjc_is_rmorphism. + +Lemma conjcK : involutive (@conjc R). +Proof. by move=> [a b] /=; rewrite opprK. Qed. + +Lemma mulcJ_ge0 (x : R[i]) : 0 <= x * x ^*. +Proof. +by move: x=> [a b]; simpc; rewrite mulrC addNr eqxx addr_ge0 ?sqr_ge0. +Qed. + +Lemma conjc_real (x : R) : x%:C^* = x%:C. +Proof. by rewrite /= oppr0. Qed. + +Lemma ReJ_add (x : R[i]) : (Re x)%:C = (x + x^*) / 2%:R. +Proof. +case: x => a b; simpc; rewrite [0 ^+ 2]mul0r addr0 /=. +rewrite -!mulr2n -mulr_natr -mulrA [_ * (_ / _)]mulrA. +by rewrite divff ?mulr1 // -natrM pnatr_eq0. +Qed. + +Lemma ImJ_sub (x : R[i]) : (Im x)%:C = (x^* - x) / 2%:R * 'i. +Proof. +case: x => a b; simpc; rewrite [0 ^+ 2]mul0r addr0 /=. +rewrite -!mulr2n -mulr_natr -mulrA [_ * (_ / _)]mulrA. +by rewrite divff ?mulr1 ?opprK // -natrM pnatr_eq0. +Qed. + +Lemma ger0_Im (x : R[i]) : 0 <= x -> Im x = 0. +Proof. by move: x=> [a b] /=; simpc => /andP [/eqP]. Qed. + +(* Todo : extend theory of : *) +(* - signed exponents *) + +Lemma conj_ge0 : forall x : R[i], (0 <= x ^*) = (0 <= x). +Proof. by move=> [a b] /=; simpc; rewrite oppr_eq0. Qed. + +Lemma conjc_nat : forall n, (n%:R : R[i])^* = n%:R. +Proof. exact: rmorph_nat. Qed. + +Lemma conjc0 : (0 : R[i]) ^* = 0. +Proof. exact: (conjc_nat 0). Qed. + +Lemma conjc1 : (1 : R[i]) ^* = 1. +Proof. exact: (conjc_nat 1). Qed. + +Lemma conjc_eq0 : forall x : R[i], (x ^* == 0) = (x == 0). +Proof. by move=> [a b]; rewrite !eq_complex /= eqr_oppLR oppr0. Qed. + +Lemma conjc_inv: forall x : R[i], (x^-1)^* = (x^* )^-1. +Proof. exact: fmorphV. Qed. + +Lemma complex_root_conj (p : {poly R[i]}) (x : R[i]) : + root (map_poly conjc p) x = root p x^*. +Proof. by rewrite /root -{1}[x]conjcK horner_map /= conjc_eq0. Qed. + +Lemma complex_algebraic_trans (T : comRingType) (toR : {rmorphism T -> R}) : + integralRange toR -> integralRange (real_complex R \o toR). +Proof. +set f := _ \o _ => R_integral [a b]. +have integral_real x : integralOver f (x%:C) by apply: integral_rmorph. +rewrite [_ +i* _]complexE. +apply: integral_add => //; apply: integral_mul => //=. +exists ('X^2 + 1). + by rewrite monicE lead_coefDl ?size_polyXn ?size_poly1 ?lead_coefXn. +by rewrite rmorphD rmorph1 /= ?map_polyXn rootE !hornerE -expr2 sqr_i addNr. +Qed. + +Lemma normc_def (z : R[i]) : `|z| = (sqrtr ((Re z)^+2 + (Im z)^+2))%:C. +Proof. by case: z. Qed. + +Lemma add_Re2_Im2 (z : R[i]) : ((Re z)^+2 + (Im z)^+2)%:C = `|z|^+2. +Proof. by rewrite normc_def -rmorphX sqr_sqrtr ?addr_ge0 ?sqr_ge0. Qed. + +Lemma addcJ (z : R[i]) : z + z^* = 2%:R * (Re z)%:C. +Proof. by rewrite ReJ_add mulrC mulfVK ?pnatr_eq0. Qed. + +Lemma subcJ (z : R[i]) : z - z^* = 2%:R * (Im z)%:C * 'i. +Proof. +rewrite ImJ_sub mulrCA mulrA mulfVK ?pnatr_eq0 //. +by rewrite -mulrA ['i * _]sqr_i mulrN1 opprB. +Qed. + +End ComplexTheory. + +(* Section RcfDef. *) + +(* Variable R : realFieldType. *) +(* Notation C := (complex R). *) + +(* Definition rcf_odd := forall (p : {poly R}), *) +(* ~~odd (size p) -> {x | p.[x] = 0}. *) +(* Definition rcf_square := forall x : R, *) +(* {y | (0 <= y) && if 0 <= x then (y ^ 2 == x) else y == 0}. *) + +(* Lemma rcf_odd_sqr_from_ivt : rcf_axiom R -> rcf_odd * rcf_square. *) +(* Proof. *) +(* move=> ivt. *) +(* split. *) +(* move=> p sp. *) +(* move: (ivt p). *) +(* admit. *) +(* move=> x. *) +(* case: (boolP (0 <= x)) (@ivt ('X^2 - x%:P) 0 (1 + x))=> px; last first. *) +(* by move=> _; exists 0; rewrite lerr eqxx. *) +(* case. *) +(* * by rewrite ler_paddr ?ler01. *) +(* * rewrite !horner_lin oppr_le0 px /=. *) +(* rewrite subr_ge0 (@ler_trans _ (1 + x)) //. *) +(* by rewrite ler_paddl ?ler01 ?lerr. *) +(* by rewrite ler_pemulr // addrC -subr_ge0 ?addrK // subr0 ler_paddl ?ler01. *) +(* * move=> y hy; rewrite /root !horner_lin; move/eqP. *) +(* move/(canRL (@addrNK _ _)); rewrite add0r=> <-. *) +(* by exists y; case/andP: hy=> -> _; rewrite eqxx. *) +(* Qed. *) + +(* Lemma ivt_from_closed : GRing.ClosedField.axiom [ringType of C] -> rcf_axiom R. *) +(* Proof. *) +(* rewrite /GRing.ClosedField.axiom /= => hclosed. *) +(* move=> p a b hab. *) +(* Admitted. *) + +(* Lemma closed_form_rcf_odd_sqr : rcf_odd -> rcf_square *) +(* -> GRing.ClosedField.axiom [ringType of C]. *) +(* Proof. *) +(* Admitted. *) + +(* Lemma closed_form_ivt : rcf_axiom R -> GRing.ClosedField.axiom [ringType of C]. *) +(* Proof. *) +(* move/rcf_odd_sqr_from_ivt; case. *) +(* exact: closed_form_rcf_odd_sqr. *) +(* Qed. *) + +(* End RcfDef. *) + +Section ComplexClosed. + +Variable R : rcfType. + +Definition sqrtc (x : R[i]) : R[i] := + let: a +i* b := x in + let sgr1 b := if b == 0 then 1 else sgr b in + let r := sqrtr (a^+2 + b^+2) in + (sqrtr ((r + a)/2%:R)) +i* (sgr1 b * sqrtr ((r - a)/2%:R)). + +Lemma sqr_sqrtc : forall x, (sqrtc x) ^+ 2 = x. +Proof. +have sqr: forall x : R, x ^+ 2 = x * x. + by move=> x; rewrite exprS expr1. +case=> a b; rewrite exprS expr1; simpc. +have F0: 2%:R != 0 :> R by rewrite pnatr_eq0. +have F1: 0 <= 2%:R^-1 :> R by rewrite invr_ge0 ler0n. +have F2: `|a| <= sqrtr (a^+2 + b^+2). + rewrite -sqrtr_sqr ler_wsqrtr //. + by rewrite addrC -subr_ge0 addrK exprn_even_ge0. +have F3: 0 <= (sqrtr (a ^+ 2 + b ^+ 2) - a) / 2%:R. + rewrite mulr_ge0 // subr_ge0 (ler_trans _ F2) //. + by rewrite -(maxrN a) ler_maxr lerr. +have F4: 0 <= (sqrtr (a ^+ 2 + b ^+ 2) + a) / 2%:R. + rewrite mulr_ge0 // -{2}[a]opprK subr_ge0 (ler_trans _ F2) //. + by rewrite -(maxrN a) ler_maxr lerr orbT. +congr (_ +i* _); set u := if _ then _ else _. + rewrite mulrCA !mulrA. + have->: (u * u) = 1. + rewrite /u; case: (altP (_ =P _)); rewrite ?mul1r //. + by rewrite -expr2 sqr_sg => ->. + rewrite mul1r -!sqr !sqr_sqrtr //. + rewrite [_+a]addrC -mulrBl opprD addrA addrK. + by rewrite opprK -mulr2n -mulr_natl [_*a]mulrC mulfK. +rewrite mulrCA -mulrA -mulrDr [sqrtr _ * _]mulrC. +rewrite -mulr2n -sqrtrM // mulrAC !mulrA ?[_ * (_ - _)]mulrC -subr_sqr. +rewrite sqr_sqrtr; last first. + by rewrite ler_paddr // exprn_even_ge0. +rewrite [_^+2 + _]addrC addrK -mulrA -expr2 sqrtrM ?exprn_even_ge0 //. +rewrite !sqrtr_sqr -mulr_natr. +rewrite [`|_^-1|]ger0_norm // -mulrA [_ * _%:R]mulrC divff //. +rewrite mulr1 /u; case: (_ =P _)=>[->|]. + by rewrite normr0 mulr0. +by rewrite mulr_sg_norm. +Qed. + +Lemma sqrtc_sqrtr : + forall (x : R[i]), 0 <= x -> sqrtc x = (sqrtr (Re x))%:C. +Proof. +move=> [a b] /andP [/eqP->] /= a_ge0. +rewrite eqxx mul1r [0 ^+ _]exprS mul0r addr0 sqrtr_sqr. +rewrite ger0_norm // subrr mul0r sqrtr0 -mulr2n. +by rewrite -[_*+2]mulr_natr mulfK // pnatr_eq0. +Qed. + +Lemma sqrtc0 : sqrtc 0 = 0. +Proof. by rewrite sqrtc_sqrtr ?lerr // sqrtr0. Qed. + +Lemma sqrtc1 : sqrtc 1 = 1. +Proof. by rewrite sqrtc_sqrtr ?ler01 // sqrtr1. Qed. + +Lemma sqrtN1 : sqrtc (-1) = 'i. +Proof. +rewrite /sqrtc /= oppr0 eqxx [0^+_]exprS mulr0 addr0. +rewrite exprS expr1 mulN1r opprK sqrtr1 subrr mul0r sqrtr0. +by rewrite mul1r -mulr2n divff ?sqrtr1 // pnatr_eq0. +Qed. + +Lemma sqrtc_ge0 (x : R[i]) : (0 <= sqrtc x) = (0 <= x). +Proof. +apply/idP/idP=> [psx|px]; last first. + by rewrite sqrtc_sqrtr // lecR sqrtr_ge0. +by rewrite -[x]sqr_sqrtc exprS expr1 mulr_ge0. +Qed. + +Lemma sqrtc_eq0 (x : R[i]) : (sqrtc x == 0) = (x == 0). +Proof. +apply/eqP/eqP=> [eqs|->]; last by rewrite sqrtc0. +by rewrite -[x]sqr_sqrtc eqs exprS mul0r. +Qed. + +Lemma normcE x : `|x| = sqrtc (x * x^*). +Proof. +case: x=> a b; simpc; rewrite [b * a]mulrC addNr sqrtc_sqrtr //. +by simpc; rewrite /= addr_ge0 ?sqr_ge0. +Qed. + +Lemma sqr_normc (x : R[i]) : (`|x| ^+ 2) = x * x^*. +Proof. by rewrite normcE sqr_sqrtc. Qed. + +Lemma normc_ge_Re (x : R[i]) : `|Re x|%:C <= `|x|. +Proof. +by case: x => a b; simpc; rewrite -sqrtr_sqr ler_wsqrtr // ler_addl sqr_ge0. +Qed. + +Lemma normcJ (x : R[i]) : `|x^*| = `|x|. +Proof. by case: x => a b; simpc; rewrite /= sqrrN. Qed. + +Lemma invc_norm (x : R[i]) : x^-1 = `|x|^-2 * x^*. +Proof. +case: (altP (x =P 0)) => [->|dx]; first by rewrite rmorph0 mulr0 invr0. +apply: (mulIf dx); rewrite mulrC divff // -mulrA [_^* * _]mulrC -(sqr_normc x). +by rewrite mulVf // expf_neq0 ?normr_eq0. +Qed. + +Lemma canonical_form (a b c : R[i]) : + a != 0 -> + let d := b ^+ 2 - 4%:R * a * c in + let r1 := (- b - sqrtc d) / 2%:R / a in + let r2 := (- b + sqrtc d) / 2%:R / a in + a *: 'X^2 + b *: 'X + c%:P = a *: (('X - r1%:P) * ('X - r2%:P)). +Proof. +move=> a_neq0 d r1 r2. +rewrite !(mulrDr, mulrDl, mulNr, mulrN, opprK, scalerDr). +rewrite [_ * _%:P]mulrC !mul_polyC !scalerN !scalerA -!addrA; congr (_ + _). +rewrite addrA; congr (_ + _). + rewrite -opprD -scalerDl -scaleNr; congr(_ *: _). + rewrite ![a * _]mulrC !divfK // !mulrDl addrACA !mulNr addNr addr0. + by rewrite -opprD opprK -mulrDr -mulr2n -mulr_natl divff ?mulr1 ?pnatr_eq0. +symmetry; rewrite -!alg_polyC scalerA; congr (_%:A). +rewrite [a * _]mulrC divfK // /r2 mulrA mulrACA -invfM -natrM -subr_sqr. +rewrite sqr_sqrtc sqrrN /d opprB addrC addrNK -2!mulrA. +by rewrite mulrACA -natf_div // mul1r mulrAC divff ?mul1r. +Qed. + +Lemma monic_canonical_form (b c : R[i]) : + let d := b ^+ 2 - 4%:R * c in + let r1 := (- b - sqrtc d) / 2%:R in + let r2 := (- b + sqrtc d) / 2%:R in + 'X^2 + b *: 'X + c%:P = (('X - r1%:P) * ('X - r2%:P)). +Proof. +by rewrite /= -['X^2]scale1r canonical_form ?oner_eq0 // scale1r mulr1 !divr1. +Qed. + +Section extramx. +(* missing lemmas from matrix.v or mxalgebra.v *) + +Lemma mul_mx_rowfree_eq0 (K : fieldType) (m n p: nat) + (W : 'M[K]_(m,n)) (V : 'M[K]_(n,p)) : + row_free V -> (W *m V == 0) = (W == 0). +Proof. by move=> free; rewrite -!mxrank_eq0 mxrankMfree ?mxrank_eq0. Qed. + +Lemma sub_sums_genmxP (F : fieldType) (I : finType) (P : pred I) (m n : nat) + (A : 'M[F]_(m, n)) (B_ : I -> 'M_(m, n)) : +reflect (exists u_ : I -> 'M_m, A = \sum_(i | P i) u_ i *m B_ i) + (A <= \sum_(i | P i) <>)%MS. +Proof. +apply: (iffP idP); last first. + by move=> [u_ ->]; rewrite summx_sub_sums // => i _; rewrite genmxE submxMl. +move=> /sub_sumsmxP [u_ hA]. +have Hu i : exists v, u_ i *m <>%MS = v *m B_ i. + by apply/submxP; rewrite (submx_trans (submxMl _ _)) ?genmxE. +exists (fun i => projT1 (sig_eqW (Hu i))); rewrite hA. +by apply: eq_bigr => i /= P_i; case: sig_eqW. +Qed. + +Lemma mulmxP (K : fieldType) (m n : nat) (A B : 'M[K]_(m, n)) : + reflect (forall u : 'rV__, u *m A = u *m B) (A == B). +Proof. +apply: (iffP eqP) => [-> //|eqAB]. +apply: (@row_full_inj _ _ _ _ 1%:M); first by rewrite row_full_unit unitmx1. +by apply/row_matrixP => i; rewrite !row_mul eqAB. +Qed. + +Section Skew. + +Variable (K : numFieldType). + +Implicit Types (phK : phant K) (n : nat). + +Definition skew_vec n i j : 'rV[K]_(n * n) := + (mxvec ((delta_mx i j)) - (mxvec (delta_mx j i))). + +Definition skew_def phK n : 'M[K]_(n * n) := + (\sum_(i | ((i.2 : 'I__) < (i.1 : 'I__))%N) <>)%MS. + +Variable (n : nat). +Local Notation skew := (@skew_def (Phant K) n). + + +Lemma skew_direct_sum : mxdirect skew. +Proof. +apply/mxdirect_sumsE => /=; split => [i _|]; first exact: mxdirect_trivial. +apply/mxdirect_sumsP => [] [i j] /= lt_ij; apply/eqP; rewrite -submx0. +apply/rV_subP => v; rewrite sub_capmx => /andP []; rewrite !genmxE. +move=> /submxP [w ->] /sub_sums_genmxP [/= u_]. +move/matrixP => /(_ 0 (mxvec_index i j)); rewrite !mxE /= big_ord1. +rewrite /skew_vec /= !mxvec_delta !mxE !eqxx /=. +have /(_ _ _ (_, _) (_, _)) /= eq_mviE := + inj_eq (bij_inj (onT_bij (curry_mxvec_bij _ _))). +rewrite eq_mviE xpair_eqE -!val_eqE /= eq_sym andbb. +rewrite ltn_eqF // subr0 mulr1 summxE big1. + rewrite [w as X in X *m _]mx11_scalar => ->. + by rewrite mul_scalar_mx scale0r submx0. +move=> [i' j'] /= /andP[lt_j'i']. +rewrite xpair_eqE /= => neq'_ij. +rewrite /= !mxvec_delta !mxE big_ord1 !mxE !eqxx !eq_mviE. +rewrite !xpair_eqE /= [_ == i']eq_sym [_ == j']eq_sym (negPf neq'_ij) /=. +set z := (_ && _); suff /negPf -> : ~~ z by rewrite subrr mulr0. +by apply: contraL lt_j'i' => /andP [/eqP <- /eqP <-]; rewrite ltnNge ltnW. +Qed. +Hint Resolve skew_direct_sum. + +Lemma rank_skew : \rank skew = (n * n.-1)./2. +Proof. +rewrite /skew (mxdirectP _) //= -bin2 -triangular_sum big_mkord. +rewrite (eq_bigr (fun _ => 1%N)); last first. + move=> [i j] /= lt_ij; rewrite genmxE. + apply/eqP; rewrite eqn_leq rank_leq_row /= lt0n mxrank_eq0. + rewrite /skew_vec /= !mxvec_delta /= subr_eq0. + set j1 := mxvec_index _ _. + apply/negP => /eqP /matrixP /(_ 0 j1) /=; rewrite !mxE eqxx /=. + have /(_ _ _ (_, _) (_, _)) -> := + inj_eq (bij_inj (onT_bij (curry_mxvec_bij _ _))). + rewrite xpair_eqE -!val_eqE /= eq_sym andbb ltn_eqF //. + by move/eqP; rewrite oner_eq0. +transitivity (\sum_(i < n) (\sum_(j < n | j < i) 1))%N. + by rewrite pair_big_dep. +apply: eq_bigr => [] [[|i] Hi] _ /=; first by rewrite big1. +rewrite (eq_bigl _ _ (fun _ => ltnS _ _)). +have [n_eq0|n_gt0] := posnP n; first by move: Hi (Hi); rewrite {1}n_eq0. +rewrite -[n]prednK // big_ord_narrow_leq /=. + by rewrite -ltnS prednK // (leq_trans _ Hi). +by rewrite sum_nat_const card_ord muln1. +Qed. + +Lemma skewP (M : 'rV_(n * n)) : + reflect ((vec_mx M)^T = - vec_mx M) (M <= skew)%MS. +Proof. +apply: (iffP idP). + move/sub_sumsmxP => [v ->]; rewrite !linear_sum /=. + apply: eq_bigr => [] [i j] /= lt_ij; rewrite !mulmx_sum_row !linear_sum /=. + apply: eq_bigr => k _; rewrite !linearZ /=; congr (_ *: _) => {v}. + set r := << _ >>%MS; move: (row _ _) (row_sub k r) => v. + move: @r; rewrite /= genmxE => /sub_rVP [a ->]; rewrite !linearZ /=. + by rewrite /skew_vec !linearB /= !mxvecK !scalerN opprK addrC !trmx_delta. +move=> skewM; pose M' := vec_mx M. +pose xM i j := (M' i j - M' j i) *: skew_vec i j. +suff -> : M = 2%:R^-1 *: + (\sum_(i | true && ((i.2 : 'I__) < (i.1 : 'I__))%N) xM i.1 i.2). + rewrite scalemx_sub // summx_sub_sums // => [] [i j] /= lt_ij. + by rewrite scalemx_sub // genmxE. +rewrite /xM /= /skew_vec (eq_bigr _ (fun _ _ => scalerBr _ _ _)). +rewrite big_split /= sumrN !(eq_bigr _ (fun _ _ => scalerBl _ _ _)). +rewrite !big_split /= !sumrN opprD ?opprK addrACA [- _ + _]addrC. +rewrite -!sumrN -2!big_split /=. +rewrite /xM /= /skew_vec -!(eq_bigr _ (fun _ _ => scalerBr _ _ _)). +apply: (can_inj vec_mxK); rewrite !(linearZ, linearB, linearD, linear_sum) /=. +have -> /= : vec_mx M = 2%:R^-1 *: (M' - M'^T). + by rewrite skewM opprK -mulr2n -scaler_nat scalerA mulVf ?pnatr_eq0 ?scale1r. +rewrite {1 2}[M']matrix_sum_delta; congr (_ *: _). +rewrite pair_big /= !linear_sum /= -big_split /=. +rewrite (bigID (fun ij => (ij.2 : 'I__) < (ij.1 : 'I__))%N) /=; congr (_ + _). + apply: eq_bigr => [] [i j] /= lt_ij. + by rewrite !linearZ linearB /= ?mxvecK trmx_delta scalerN scalerBr. +rewrite (bigID (fun ij => (ij.1 : 'I__) == (ij.2 : 'I__))%N) /=. +rewrite big1 ?add0r; last first. + by move=> [i j] /= /andP[_ /eqP ->]; rewrite linearZ /= trmx_delta subrr. +rewrite (@reindex_inj _ _ _ _ (fun ij => (ij.2, ij.1))) /=; last first. + by move=> [? ?] [? ?] [] -> ->. +apply: eq_big => [] [i j] /=; first by rewrite -leqNgt ltn_neqAle andbC. +by rewrite !linearZ linearB /= ?mxvecK trmx_delta scalerN scalerBr. +Qed. + +End Skew. + +Notation skew K n := (@skew_def _ (Phant K) n). + +Section Companion. + +Variable (K : fieldType). + +Lemma companion_subproof (p : {poly K}) : + {M : 'M[K]_((size p).-1)| p \is monic -> char_poly M = p}. +Proof. +have simp := (castmxE, mxE, castmx_id, cast_ord_id). +case Hsp: (size p) => [|sp] /=. + move/eqP: Hsp; rewrite size_poly_eq0 => /eqP ->. + by exists 0; rewrite qualifE lead_coef0 eq_sym oner_eq0. +case: sp => [|sp] in Hsp *. + move: Hsp => /eqP/size_poly1P/sig2_eqW [c c_neq0 ->]. + by exists ((-c)%:M); rewrite monicE lead_coefC => /eqP ->; apply: det_mx00. +have addn1n n : (n + 1 = 1 + n)%N by rewrite addn1. +exists (castmx (erefl _, addn1n _) + (block_mx (\row_(i < sp) - p`_(sp - i)) (-p`_0)%:M + 1%:M 0)). +elim/poly_ind: p sp Hsp (addn1n _) => [|p c IHp] sp; first by rewrite size_poly0. +rewrite size_MXaddC. +have [->|p_neq0] //= := altP eqP; first by rewrite size_poly0; case: ifP. +move=> [Hsp] eq_cast. +rewrite monicE lead_coefDl ?size_polyC ?size_mul ?polyX_eq0 //; last first. + by rewrite size_polyX addn2 Hsp ltnS (leq_trans (leq_b1 _)). +rewrite lead_coefMX -monicE => p_monic. +rewrite -/_`_0 coefD coefMX coefC eqxx add0r. +case: sp => [|sp] in Hsp p_neq0 p_monic eq_cast *. + move: Hsp p_monic => /eqP/size_poly1P [l l_neq0 ->]. + rewrite monicE lead_coefC => /eqP ->; rewrite mul1r. + rewrite /char_poly /char_poly_mx thinmx0 flatmx0 castmx_id. + set b := (block_mx _ _ _ _); rewrite [map_mx _ b]map_block_mx => {b}. + rewrite !map_mx0 map_scalar_mx (@opp_block_mx _ 1 0 0 1) !oppr0. + set b := block_mx _ _ _ _; rewrite (_ : b = c%:P%:M); last first. + apply/matrixP => i j; rewrite !mxE; case: splitP => k /= Hk; last first. + by move: (ltn_ord i); rewrite Hk. + rewrite !ord1 !mxE; case: splitP => {k Hk} k /= Hk; first by move: (ltn_ord k). + by rewrite ord1 !mxE mulr1n rmorphN opprK. + by rewrite -rmorphD det_scalar. +rewrite /char_poly /char_poly_mx (expand_det_col _ ord_max). +rewrite big_ord_recr /= big_ord_recl //= big1 ?simp; last first. + move=> i _; rewrite !simp. + case: splitP => k /=; first by rewrite /bump leq0n ord1. + rewrite /bump leq0n => [] [Hik]; rewrite !simp. + case: splitP => l /=; first by move/eqP; rewrite gtn_eqF. + rewrite !ord1 addn0 => _ {l}; rewrite !simp -!val_eqE /=. + by rewrite /bump leq0n ltn_eqF ?ltnS ?add1n // mulr0n subrr mul0r. +case: splitP => i //=; rewrite !ord1 !simp => _ {i}. +case: splitP => i //=; first by move/eqP; rewrite gtn_eqF. +rewrite ord1 !simp => {i}. +case: splitP => i //=; rewrite ?ord1 ?simp // => /esym [eq_i_sp] _. +case: splitP => j //=; first by move/eqP; rewrite gtn_eqF. +rewrite ord1 !simp => {j} _. +rewrite eqxx mulr0n ?mulr1n rmorphN ?opprK !add0r !addr0 subr0 /=. +rewrite -[c%:P in X in _ = X]mulr1 addrC mulrC. +rewrite /cofactor -signr_odd addnn odd_double expr0 mul1r /=. +rewrite !linearB /= -!map_col' -!map_row'. +congr (_ * 'X + c%:P * _). + have coefE := (coefD, coefMX, coefC, eqxx, add0r, addr0). + rewrite -[X in _ = X](IHp sp Hsp _ p_monic) /char_poly /char_poly_mx. + congr (\det (_ - _)). + apply/matrixP => k l; rewrite !simp -val_eqE /=; + by rewrite /bump ![(sp < _)%N]ltnNge ?leq_ord. + apply/matrixP => k l; rewrite !simp. + case: splitP => k' /=; rewrite ?ord1 /bump ltnNge leq_ord add0n. + case: splitP => [k'' /= |k'' -> //]; rewrite ord1 !simp => k_eq0 _. + case: splitP => l' /=; rewrite ?ord1 /bump ltnNge leq_ord add0n !simp; + last by move/eqP; rewrite ?addn0 ltn_eqF. + move<-; case: splitP => l'' /=; rewrite ?ord1 ?addn0 !simp. + by move<-; rewrite subSn ?leq_ord ?coefE. + move->; rewrite eqxx mulr1n ?coefE subSn ?subrr //=. + by rewrite !rmorphN ?subnn addr0. + case: splitP => k'' /=; rewrite ?ord1 => -> // []; rewrite !simp. + case: splitP => l' /=; rewrite /bump ltnNge leq_ord add0n !simp -?val_eqE /=; + last by rewrite ord1 addn0 => /eqP; rewrite ltn_eqF. + by case: splitP => l'' /= -> <- <-; rewrite !simp // ?ord1 ?addn0 ?ltn_eqF. +move=> {IHp Hsp p_neq0 p_monic}; rewrite add0n; set s := _ ^+ _; +apply: (@mulfI _ s); first by rewrite signr_eq0. +rewrite mulrA -expr2 sqrr_sign mulr1 mul1r /s. +pose fix D n : 'M[{poly K}]_n.+1 := + if n is n'.+1 then block_mx (-1 :'M_1) ('X *: pid_mx 1) + 0 (D n') else -1. +pose D' n : 'M[{poly K}]_n.+1 := \matrix_(i, j) ('X *+ (i.+1 == j) - (i == j)%:R). +set M := (_ - _); have -> : M = D' sp. + apply/matrixP => k l; rewrite !simp. + case: splitP => k' /=; rewrite ?ord1 !simp // /bump leq0n add1n; case. + case: splitP => l' /=; rewrite /bump ltnNge leq_ord add0n; last first. + by move/eqP; rewrite ord1 addn0 ltn_eqF. + rewrite !simp -!val_eqE /= /bump leq0n ltnNge leq_ord [(true + _)%N]add1n ?add0n. + by move=> -> ->; rewrite polyC_muln. +have -> n : D' n = D n. + clear -simp; elim: n => [|n IHn] //=; apply/matrixP => i j; rewrite !simp. + by rewrite !ord1 /= ?mulr0n sub0r. + case: splitP => i' /=; rewrite -!val_eqE /= ?ord1 !simp => -> /=. + case: splitP => j' /=; rewrite ?ord1 !simp => -> /=; first by rewrite sub0r. + by rewrite eqSS andbT subr0 mulr_natr. + by case: splitP => j' /=; rewrite ?ord1 -?IHn ?simp => -> //=; rewrite subr0. +elim: sp {eq_cast i M eq_i_sp s} => [|n IHn]. + by rewrite /= (_ : -1 = (-1)%:M) ?det_scalar // rmorphN. +rewrite /= (@det_ublock _ 1 n.+1) IHn. +by rewrite (_ : -1 = (-1)%:M) ?det_scalar // rmorphN. +Qed. + +Definition companion (p : {poly K}) : 'M[K]_((size p).-1) := + projT1 (companion_subproof p). + +Lemma companionK (p : {poly K}) : p \is monic -> char_poly (companion p) = p. +Proof. exact: projT2 (companion_subproof _). Qed. + +End Companion. + +Section Restriction. + +Variable K : fieldType. +Variable m : nat. +Variables (V : 'M[K]_m). + +Implicit Types f : 'M[K]_m. + +Definition restrict f : 'M_(\rank V) := row_base V *m f *m (pinvmx (row_base V)). + +Lemma stable_row_base f : + (row_base V *m f <= row_base V)%MS = (V *m f <= V)%MS. +Proof. +rewrite eq_row_base. +by apply/idP/idP=> /(submx_trans _) ->; rewrite ?submxMr ?eq_row_base. +Qed. + +Lemma eigenspace_restrict f : (V *m f <= V)%MS -> + forall n a (W : 'M_(n, \rank V)), + (W <= eigenspace (restrict f) a)%MS = + (W *m row_base V <= eigenspace f a)%MS. +Proof. +move=> f_stabV n a W; apply/eigenspaceP/eigenspaceP; rewrite scalemxAl. + by move<-; rewrite -mulmxA -[X in _ = X]mulmxA mulmxKpV ?stable_row_base. +move/(congr1 (mulmx^~ (pinvmx (row_base V)))). +rewrite -2!mulmxA [_ *m (f *m _)]mulmxA => ->. +by apply: (row_free_inj (row_base_free V)); rewrite mulmxKpV ?submxMl. +Qed. + +Lemma eigenvalue_restrict f : (V *m f <= V)%MS -> + {subset eigenvalue (restrict f) <= eigenvalue f}. +Proof. +move=> f_stabV a /eigenvalueP [x /eigenspaceP]; rewrite eigenspace_restrict //. +move=> /eigenspaceP Hf x_neq0; apply/eigenvalueP. +by exists (x *m row_base V); rewrite ?mul_mx_rowfree_eq0 ?row_base_free. +Qed. + +Lemma restrictM : {in [pred f | (V *m f <= V)%MS] &, + {morph restrict : f g / f *m g}}. +Proof. +move=> f g; rewrite !inE => Vf Vg /=. +by rewrite /restrict 2!mulmxA mulmxA mulmxKpV ?stable_row_base. +Qed. + +End Restriction. + +End extramx. +Notation skew K n := (@skew_def _ (Phant K) n). + +Section Paper_HarmDerksen. + +(* Following http://www.math.lsa.umich.edu/~hderksen/preprints/linalg.pdf *) +(* quite literally except for Lemma5 where we don't use hermitian matrices. *) +(* Instead we encode the morphism by hand in 'M[R]_(n * n), which turns out *) +(* to be very clumsy for formalizing commutation and the end of Lemma 4. *) +(* Moreover, the Qed takes time, so it would be far much better to formalize *) +(* Herm C n and use it instead ! *) + +Implicit Types (K : fieldType). + +Definition CommonEigenVec_def K (phK : phant K) (d r : nat) := + forall (m : nat) (V : 'M[K]_m), ~~ (d %| \rank V) -> + forall (sf : seq 'M_m), size sf = r -> + {in sf, forall f, (V *m f <= V)%MS} -> + {in sf &, forall f g, f *m g = g *m f} -> + exists2 v : 'rV_m, (v != 0) & forall f, f \in sf -> + exists a, (v <= eigenspace f a)%MS. +Notation CommonEigenVec K d r := (@CommonEigenVec_def _ (Phant K) d r). + +Definition Eigen1Vec_def K (phK : phant K) (d : nat) := + forall (m : nat) (V : 'M[K]_m), ~~ (d %| \rank V) -> + forall (f : 'M_m), (V *m f <= V)%MS -> exists a, eigenvalue f a. +Notation Eigen1Vec K d := (@Eigen1Vec_def _ (Phant K) d). + +Lemma Eigen1VecP (K : fieldType) (d : nat) : + CommonEigenVec K d 1%N <-> Eigen1Vec K d. +Proof. +split=> [Hd m V HV f|Hd m V HV [] // f [] // _ /(_ _ (mem_head _ _))] f_stabV. + have [] := Hd _ _ HV [::f] (erefl _). + + by move=> ?; rewrite in_cons orbF => /eqP ->. + + by move=> ? ?; rewrite /= !in_cons !orbF => /eqP -> /eqP ->. + move=> v v_neq0 /(_ f (mem_head _ _)) [a /eigenspaceP]. + by exists a; apply/eigenvalueP; exists v. +have [a /eigenvalueP [v /eigenspaceP v_eigen v_neq0]] := Hd _ _ HV _ f_stabV. +by exists v => // ?; rewrite in_cons orbF => /eqP ->; exists a. +Qed. + +Lemma Lemma3 K d : Eigen1Vec K d -> forall r, CommonEigenVec K d r.+1. +Proof. +move=> E1V_K_d; elim => [|r IHr m V]; first exact/Eigen1VecP. +move: (\rank V) {-2}V (leqnn (\rank V)) => n {V}. +elim: n m => [|n IHn] m V. + by rewrite leqn0 => /eqP ->; rewrite dvdn0. +move=> le_rV_Sn HrV [] // f sf /= [] ssf f_sf_stabV f_sf_comm. +have [->|f_neq0] := altP (f =P 0). + have [||v v_neq0 Hsf] := (IHr _ _ HrV _ ssf). + + by move=> g f_sf /=; rewrite f_sf_stabV // in_cons f_sf orbT. + + move=> g h g_sf h_sf /=. + by apply: f_sf_comm; rewrite !in_cons ?g_sf ?h_sf ?orbT. + exists v => // g; rewrite in_cons => /orP [/eqP->|]; last exact: Hsf. + by exists 0; apply/eigenspaceP; rewrite mulmx0 scale0r. +have f_stabV : (V *m f <= V)%MS by rewrite f_sf_stabV ?mem_head. +have sf_stabV : {in sf, forall f, (V *m f <= V)%MS}. + by move=> g g_sf /=; rewrite f_sf_stabV // in_cons g_sf orbT. +pose f' := restrict V f; pose sf' := map (restrict V) sf. +have [||a a_eigen_f'] := E1V_K_d _ 1%:M _ f'; do ?by rewrite ?mxrank1 ?submx1. +pose W := (eigenspace f' a)%MS; pose Z := (f' - a%:M). +have rWZ : (\rank W + \rank Z)%N = \rank V. + by rewrite (mxrank_ker (f' - a%:M)) subnK // rank_leq_row. +have f'_stabW : (W *m f' <= W)%MS. + by rewrite (eigenspaceP (submx_refl _)) scalemx_sub. +have f'_stabZ : (Z *m f' <= Z)%MS. + rewrite (submx_trans _ (submxMl f' _)) //. + by rewrite mulmxDl mulmxDr mulmxN mulNmx scalar_mxC. +have sf'_comm : {in [::f' & sf'] &, forall f g, f *m g = g *m f}. + move=> g' h' /=; rewrite -!map_cons. + move=> /mapP [g g_s_sf -> {g'}] /mapP [h h_s_sf -> {h'}]. + by rewrite -!restrictM ?inE /= ?f_sf_stabV // f_sf_comm. +have sf'_stabW : {in sf', forall f, (W *m f <= W)%MS}. + move=> g g_sf /=; apply/eigenspaceP. + rewrite -mulmxA -[g *m _]sf'_comm ?(mem_head, in_cons, g_sf, orbT) //. + by rewrite mulmxA scalemxAl (eigenspaceP (submx_refl _)). +have sf'_stabZ : {in sf', forall f, (Z *m f <= Z)%MS}. + move=> g g_sf /=. + rewrite mulmxBl sf'_comm ?(mem_head, in_cons, g_sf, orbT) //. + by rewrite -scalar_mxC -mulmxBr submxMl. +have [eqWV|neqWV] := altP (@eqmxP _ _ _ _ W 1%:M). + have [] // := IHr _ W _ sf'; do ?by rewrite ?eqWV ?mxrank1 ?size_map. + move=> g h g_sf' h_sf'; apply: sf'_comm; + by rewrite in_cons (g_sf', h_sf') orbT. + move=> v v_neq0 Hv; exists (v *m row_base V). + by rewrite mul_mx_rowfree_eq0 ?row_base_free. + move=> g; rewrite in_cons => /orP [/eqP ->|g_sf]; last first. + have [|b] := Hv (restrict V g); first by rewrite map_f. + by rewrite eigenspace_restrict // ?sf_stabV //; exists b. + by exists a; rewrite -eigenspace_restrict // eqWV submx1. +have lt_WV : (\rank W < \rank V)%N. + rewrite -[X in (_ < X)%N](@mxrank1 K) rank_ltmx //. + by rewrite ltmxEneq neqWV // submx1. +have ltZV : (\rank Z < \rank V)%N. + rewrite -[X in (_ < X)%N]rWZ -subn_gt0 addnK lt0n mxrank_eq0 -lt0mx. + move: a_eigen_f' => /eigenvalueP [v /eigenspaceP] sub_vW v_neq0. + by rewrite (ltmx_sub_trans _ sub_vW) // lt0mx. +have [] // := IHn _ (if d %| \rank Z then W else Z) _ _ [:: f' & sf']. ++ by rewrite -ltnS (@leq_trans (\rank V)) //; case: ifP. ++ by apply: contra HrV; case: ifP => [*|-> //]; rewrite -rWZ dvdn_add. ++ by rewrite /= size_map ssf. ++ move=> g; rewrite in_cons => /= /orP [/eqP -> {g}|g_sf']; case: ifP => _ //; + by rewrite (sf'_stabW, sf'_stabZ). +move=> v v_neq0 Hv; exists (v *m row_base V). + by rewrite mul_mx_rowfree_eq0 ?row_base_free. +move=> g Hg; have [|b] := Hv (restrict V g); first by rewrite -map_cons map_f. +rewrite eigenspace_restrict //; first by exists b. +by move: Hg; rewrite in_cons => /orP [/eqP -> //|/sf_stabV]. +Qed. + +Lemma Lemma4 r : CommonEigenVec R 2 r.+1. +Proof. +apply: Lemma3=> m V hV f f_stabV. +have [|a] := @odd_poly_root _ (char_poly (restrict V f)). + by rewrite size_char_poly /= -dvdn2. +rewrite -eigenvalue_root_char => /eigenvalueP [v] /eigenspaceP v_eigen v_neq0. +exists a; apply/eigenvalueP; exists (v *m row_base V). + by apply/eigenspaceP; rewrite -eigenspace_restrict. +by rewrite mul_mx_rowfree_eq0 ?row_base_free. +Qed. + +Notation toC := (real_complex R). +Notation MtoC := (map_mx toC). + +Lemma Lemma5 : Eigen1Vec R[i] 2. +Proof. +move=> m V HrV f f_stabV. +suff: exists a, eigenvalue (restrict V f) a. + by move=> [a /eigenvalue_restrict Hf]; exists a; apply: Hf. +move: (\rank V) (restrict V f) => {f f_stabV V m} n f in HrV *. +pose u := map_mx (@Re R) f; pose v := map_mx (@Im R) f. +have fE : f = MtoC u + 'i *: MtoC v. + rewrite /u /v [f]lock; apply/matrixP => i j; rewrite !mxE /=. + by case: (locked f i j) => a b; simpc. +move: u v => u v in fE *. +pose L1fun : 'M[R]_n -> _ := + 2%:R^-1 \*: (mulmxr u \+ (mulmxr v \o trmx) + \+ ((mulmx (u^T)) \- (mulmx (v^T) \o trmx))). +pose L1 := lin_mx [linear of L1fun]. +pose L2fun : 'M[R]_n -> _ := + 2%:R^-1 \*: (((@GRing.opp _) \o (mulmxr u \o trmx) \+ mulmxr v) + \+ ((mulmx (u^T) \o trmx) \+ (mulmx (v^T)))). +pose L2 := lin_mx [linear of L2fun]. +have [] := @Lemma4 _ _ 1%:M _ [::L1; L2] (erefl _). ++ by move: HrV; rewrite mxrank1 !dvdn2 ?negbK odd_mul andbb. ++ by move=> ? _ /=; rewrite submx1. ++ suff {f fE}: L1 *m L2 = L2 *m L1. + move: L1 L2 => L1 L2 commL1L2 La Lb. + rewrite !{1}in_cons !{1}in_nil !{1}orbF. + by move=> /orP [] /eqP -> /orP [] /eqP -> //; symmetry. + apply/eqP/mulmxP => x; rewrite [X in X = _]mulmxA [X in _ = X]mulmxA. + rewrite 4!mul_rV_lin !mxvecK /= /L1fun /L2fun /=; congr (mxvec (_ *: _)). + move=> {L1 L2 L1fun L2fun}. + case: n {x} (vec_mx x) => [//|n] x in HrV u v *. + do ?[rewrite -(scalemxAl, scalemxAr, scalerN, scalerDr) + |rewrite (mulmxN, mulNmx, trmxK, trmx_mul) + |rewrite ?[(_ *: _)^T]linearZ ?[(_ + _)^T]linearD ?[(- _)^T]linearN /=]. + congr (_ *: _). + rewrite !(mulmxDr, mulmxDl, mulNmx, mulmxN, mulmxA, opprD, opprK). + do ![move: (_ *m _ *m _)] => t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12. + rewrite [X in X + _ + _]addrC [X in X + _ = _]addrACA. + rewrite [X in _ = (_ + _ + X) + _]addrC [X in _ = X + _]addrACA. + rewrite [X in _ + (_ + _ + X)]addrC [X in _ + X = _]addrACA. + rewrite [X in _ = _ + (X + _)]addrC [X in _ = _ + X]addrACA. + rewrite [X in X = _]addrACA [X in _ = X]addrACA; congr (_ + _). + by rewrite addrC [X in X + _ = _]addrACA [X in _ + X = _]addrACA. +move=> g g_neq0 Hg; have [] := (Hg L1, Hg L2). +rewrite !(mem_head, in_cons, orbT) => []. +move=> [//|a /eigenspaceP g_eigenL1] [//|b /eigenspaceP g_eigenL2]. +rewrite !mul_rV_lin /= /L1fun /L2fun /= in g_eigenL1 g_eigenL2. +do [move=> /(congr1 vec_mx); rewrite mxvecK linearZ /=] in g_eigenL1. +do [move=> /(congr1 vec_mx); rewrite mxvecK linearZ /=] in g_eigenL2. +move=> {L1 L2 L1fun L2fun Hg HrV}. +set vg := vec_mx g in g_eigenL1 g_eigenL2. +exists (a +i* b); apply/eigenvalueP. +pose w := (MtoC vg - 'i *: MtoC vg^T). +exists (nz_row w); last first. + rewrite nz_row_eq0 subr_eq0; apply: contraNneq g_neq0 => Hvg. + rewrite -vec_mx_eq0; apply/eqP/matrixP => i j; rewrite !mxE /=. + move: Hvg => /matrixP /(_ i j); rewrite !mxE /=; case. + by rewrite !(mul0r, mulr0, add0r, mul1r, oppr0) => ->. +apply/eigenspaceP. +case: n f => [|n] f in u v g g_neq0 vg w fE g_eigenL1 g_eigenL2 *. + by rewrite thinmx0 eqxx in g_neq0. +rewrite (submx_trans (nz_row_sub _)) //; apply/eigenspaceP. +rewrite fE [a +i* b]complexE /=. +rewrite !(mulmxDr, mulmxBl, =^~scalemxAr, =^~scalemxAl) -!map_mxM. +rewrite !(scalerDl, scalerDr, scalerN, =^~scalemxAr, =^~scalemxAl). +rewrite !scalerA /= mulrAC ['i * _]sqr_i ?mulN1r scaleN1r scaleNr !opprK. +rewrite [_ * 'i]mulrC -!scalerA -!map_mxZ /=. +do 2!rewrite [X in (_ - _) + X]addrC [_ - 'i *: _ + _]addrACA. +rewrite ![- _ + _]addrC -!scalerBr -!(rmorphB, rmorphD) /=. +congr (_ + 'i *: _); congr map_mx; rewrite -[_ *: _^T]linearZ /=; +rewrite -g_eigenL1 -g_eigenL2 linearZ -(scalerDr, scalerBr); +do ?rewrite ?trmxK ?trmx_mul ?[(_ + _)^T]linearD ?[(- _)^T]linearN /=; +rewrite -[in X in _ *: (_ + X)]addrC 1?opprD 1?opprB ?mulmxN ?mulNmx; +rewrite [X in _ *: X]addrACA. + rewrite -mulr2n [X in _ *: (_ + X)]addrACA subrr addNr !addr0. + by rewrite -scaler_nat scalerA mulVf ?pnatr_eq0 // scale1r. +rewrite subrr addr0 addrA addrAC -addrA -mulr2n addrC. +by rewrite -scaler_nat scalerA mulVf ?pnatr_eq0 // scale1r. +Qed. + +Lemma Lemma6 k r : CommonEigenVec R[i] (2^k.+1) r.+1. +Proof. +elim: k {-2}k (leqnn k) r => [|k IHk] l. + by rewrite leqn0 => /eqP ->; apply: Lemma3; apply: Lemma5. +rewrite leq_eqVlt ltnS => /orP [/eqP ->|/IHk //] r {l}. +apply: Lemma3 => m V Hn f f_stabV {r}. +have [dvd2n|Ndvd2n] := boolP (2 %| \rank V); last first. + exact: @Lemma5 _ _ Ndvd2n _ f_stabV. +suff: exists a, eigenvalue (restrict V f) a. + by move=> [a /eigenvalue_restrict Hf]; exists a; apply: Hf. +case: (\rank V) (restrict V f) => {f f_stabV V m} [|n] f in Hn dvd2n *. + by rewrite dvdn0 in Hn. +pose L1 := lin_mx [linear of mulmxr f \+ (mulmx f^T)]. +pose L2 := lin_mx [linear of mulmxr f \o mulmx f^T]. +have [] /= := IHk _ (leqnn _) _ _ (skew R[i] n.+1) _ [::L1; L2] (erefl _). ++ rewrite rank_skew; apply: contra Hn. + rewrite -(@dvdn_pmul2r 2) //= -expnSr muln2 -[_.*2]add0n. + have n_odd : odd n by rewrite dvdn2 /= ?negbK in dvd2n *. + have {2}<- : odd (n.+1 * n) = 0%N :> nat by rewrite odd_mul /= andNb. + by rewrite odd_double_half Gauss_dvdl // coprime_pexpl // coprime2n. ++ move=> L; rewrite 2!in_cons in_nil orbF => /orP [] /eqP ->; + apply/rV_subP => v /submxP [s -> {v}]; rewrite mulmxA; apply/skewP; + set u := _ *m skew _ _; + do [have /skewP : (u <= skew R[i] n.+1)%MS by rewrite submxMl]; + rewrite mul_rV_lin /= !mxvecK => skew_u. + by rewrite opprD linearD /= !trmx_mul skew_u mulmxN mulNmx addrC trmxK. + by rewrite !trmx_mul trmxK skew_u mulNmx mulmxN mulmxA. ++ suff commL1L2: L1 *m L2 = L2 *m L1. + move=> La Lb; rewrite !in_cons !in_nil !orbF. + by move=> /orP [] /eqP -> /orP [] /eqP -> //; symmetry. + apply/eqP/mulmxP => u; rewrite !mulmxA !mul_rV_lin ?mxvecK /=. + by rewrite !(mulmxDr, mulmxDl, mulmxA). +move=> v v_neq0 HL1L2; have [] := (HL1L2 L1, HL1L2 L2). +rewrite !(mem_head, in_cons) orbT => [] [] // a vL1 [] // b vL2 {HL1L2}. +move/eigenspaceP in vL1; move/eigenspaceP in vL2. +move: vL2 => /(congr1 vec_mx); rewrite linearZ mul_rV_lin /= mxvecK. +move: vL1 => /(congr1 vec_mx); rewrite linearZ mul_rV_lin /= mxvecK. +move=> /(canRL (addKr _)) ->; rewrite mulmxDl mulNmx => Hv. +pose p := 'X^2 + (- a) *: 'X + b%:P. +have : vec_mx v *m (horner_mx f p) = 0. + rewrite !(rmorphN, rmorphB, rmorphD, rmorphM) /= linearZ /=. + rewrite horner_mx_X horner_mx_C !mulmxDr mul_mx_scalar -Hv. + rewrite addrAC addrA mulmxA addrN add0r. + by rewrite -scalemxAl -scalemxAr scaleNr addrN. +rewrite [p]monic_canonical_form; move: (_ / 2%:R) (_ / 2%:R). +move=> r2 r1 {Hv p a b L1 L2 Hn}. +rewrite rmorphM !rmorphB /= horner_mx_X !horner_mx_C mulmxA => Hv. +have: exists2 w : 'M_n.+1, w != 0 & exists a, (w <= eigenspace f a)%MS. + move: Hv; set w := vec_mx _ *m _. + have [w_eq0 _|w_neq0 r2_eigen] := altP (w =P 0). + exists (vec_mx v); rewrite ?vec_mx_eq0 //; exists r1. + apply/eigenspaceP/eqP. + by rewrite -mul_mx_scalar -subr_eq0 -mulmxBr -/w w_eq0. + exists w => //; exists r2; apply/eigenspaceP/eqP. + by rewrite -mul_mx_scalar -subr_eq0 -mulmxBr r2_eigen. +move=> [w w_neq0 [a /(submx_trans (nz_row_sub _)) /eigenspaceP Hw]]. +by exists a; apply/eigenvalueP; exists (nz_row w); rewrite ?nz_row_eq0. +Qed. + +(* We enunciate a corollary of Theorem 7 *) +Corollary Theorem7' (m : nat) (f : 'M[R[i]]_m) : (0 < m)%N -> exists a, eigenvalue f a. +Proof. +case: m f => // m f _; have /Eigen1VecP := @Lemma6 m 0. +move=> /(_ m.+1 1 _ f) []; last by move=> a; exists a. ++ by rewrite mxrank1 (contra (dvdn_leq _)) // -ltnNge ltn_expl. ++ by rewrite submx1. +Qed. + +Lemma C_acf_axiom : GRing.ClosedField.axiom [ringType of R[i]]. +Proof. +move=> n c n_gt0; pose p := 'X^n - \poly_(i < n) c i. +suff [x rpx] : exists x, root p x. + exists x; move: rpx; rewrite /root /p hornerD hornerN hornerXn subr_eq0. + by move=> /eqP ->; rewrite horner_poly. +have p_monic : p \is monic. + rewrite qualifE lead_coefDl ?lead_coefXn //. + by rewrite size_opp size_polyXn ltnS size_poly. +have sp_gt1 : (size p > 1)%N. + by rewrite size_addl size_polyXn // size_opp ltnS size_poly. +case: n n_gt0 p => //= n _ p in p_monic sp_gt1 *. +have [] := Theorem7' (companion p); first by rewrite -(subnK sp_gt1) addn2. +by move=> x; rewrite eigenvalue_root_char companionK //; exists x. +Qed. + +Definition C_decFieldMixin := closed_fields_QEMixin C_acf_axiom. +Canonical C_decField := DecFieldType R[i] C_decFieldMixin. +Canonical C_closedField := ClosedFieldType R[i] C_acf_axiom. + +End Paper_HarmDerksen. + +End ComplexClosed. + +Definition complexalg := realalg[i]. + +Canonical complexalg_eqType := [eqType of complexalg]. +Canonical complexalg_choiceType := [choiceType of complexalg]. +Canonical complexalg_countype := [choiceType of complexalg]. +Canonical complexalg_zmodType := [zmodType of complexalg]. +Canonical complexalg_ringType := [ringType of complexalg]. +Canonical complexalg_comRingType := [comRingType of complexalg]. +Canonical complexalg_unitRingType := [unitRingType of complexalg]. +Canonical complexalg_comUnitRingType := [comUnitRingType of complexalg]. +Canonical complexalg_idomainType := [idomainType of complexalg]. +Canonical complexalg_fieldType := [fieldType of complexalg]. +Canonical complexalg_decDieldType := [decFieldType of complexalg]. +Canonical complexalg_closedFieldType := [closedFieldType of complexalg]. +Canonical complexalg_numDomainType := [numDomainType of complexalg]. +Canonical complexalg_numFieldType := [numFieldType of complexalg]. +Canonical complexalg_numClosedFieldType := [numClosedFieldType of complexalg]. + +Lemma complexalg_algebraic : integralRange (@ratr [unitRingType of complexalg]). +Proof. +move=> x; suff [p p_monic] : integralOver (real_complex _ \o realalg_of _) x. + by rewrite (eq_map_poly (fmorph_eq_rat _)); exists p. +by apply: complex_algebraic_trans; apply: realalg_algebraic. +Qed. diff --git a/mathcomp/real_closed/ordered_qelim.v b/mathcomp/real_closed/ordered_qelim.v new file mode 100644 index 0000000..c718d74 --- /dev/null +++ b/mathcomp/real_closed/ordered_qelim.v @@ -0,0 +1,1180 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div choice fintype. +Require Import bigop ssralg finset fingroup zmodp. +Require Import poly ssrnum. + + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope ring_scope. +Import GRing. + +Reserved Notation "p <% q" (at level 70, no associativity). +Reserved Notation "p <=% q" (at level 70, no associativity). + +(* Set Printing Width 30. *) + +Module ord. + +Section Formulas. + +Variable T : Type. + +Inductive formula : Type := +| Bool of bool +| Equal of (term T) & (term T) +| Lt of (term T) & (term T) +| Le of (term T) & (term T) +| Unit of (term T) +| And of formula & formula +| Or of formula & formula +| Implies of formula & formula +| Not of formula +| Exists of nat & formula +| Forall of nat & formula. + +End Formulas. + +Fixpoint term_eq (T : eqType)(t1 t2 : term T) := + match t1, t2 with + | Var n1, Var n2 => n1 == n2 + | Const r1, Const r2 => r1 == r2 + | NatConst n1, NatConst n2 => n1 == n2 + | Add r1 s1, Add r2 s2 => (term_eq r1 r2) && (term_eq s1 s2) + | Opp r1, Opp r2 => term_eq r1 r2 + | NatMul r1 n1, NatMul r2 n2 => (term_eq r1 r2) && (n1 == n2) + | Mul r1 s1, Mul r2 s2 => (term_eq r1 r2) && (term_eq s1 s2) + | Inv r1, Inv r2 => term_eq r1 r2 + | Exp r1 n1, Exp r2 n2 => (term_eq r1 r2) && (n1 == n2) + |_, _ => false + end. + +Lemma term_eqP (T : eqType) : Equality.axiom (@term_eq T). +Proof. +move=> t1 t2; apply: (iffP idP) => [|<-]; last first. + by elim: t1 {t2} => //= t -> // n; rewrite eqxx. +elim: t1 t2. +- by move=> n1 /= [] // n2 /eqP ->. +- by move=> r1 /= [] // r2 /eqP ->. +- by move=> n1 /= [] // n2 /eqP ->. +- by move=> r1 hr1 r2 hr2 [] //= s1 s2 /andP [] /hr1 -> /hr2 ->. +- by move=> r1 hr1 [] //= s1 /hr1 ->. +- by move=> s1 hs1 n1 [] //= s2 n2 /andP [] /hs1 -> /eqP ->. +- by move=> r1 hr1 r2 hr2 [] //= s1 s2 /andP [] /hr1 -> /hr2 ->. +- by move=> r1 hr1 [] //= s1 /hr1 ->. +- by move=> s1 hs1 n1 [] //= s2 n2 /andP [] /hs1 -> /eqP ->. +Qed. + +Canonical term_eqMixin (T : eqType) := EqMixin (@term_eqP T). +Canonical term_eqType (T : eqType) := + Eval hnf in EqType (term T) (@term_eqMixin T). + +Implicit Arguments term_eqP [x y]. +Prenex Implicits term_eq. + + +Bind Scope oterm_scope with term. +Bind Scope oterm_scope with formula. +Arguments Scope Add [_ oterm_scope oterm_scope]. +Arguments Scope Opp [_ oterm_scope]. +Arguments Scope NatMul [_ oterm_scope nat_scope]. +Arguments Scope Mul [_ oterm_scope oterm_scope]. +Arguments Scope Mul [_ oterm_scope oterm_scope]. +Arguments Scope Inv [_ oterm_scope]. +Arguments Scope Exp [_ oterm_scope nat_scope]. +Arguments Scope Equal [_ oterm_scope oterm_scope]. +Arguments Scope Unit [_ oterm_scope]. +Arguments Scope And [_ oterm_scope oterm_scope]. +Arguments Scope Or [_ oterm_scope oterm_scope]. +Arguments Scope Implies [_ oterm_scope oterm_scope]. +Arguments Scope Not [_ oterm_scope]. +Arguments Scope Exists [_ nat_scope oterm_scope]. +Arguments Scope Forall [_ nat_scope oterm_scope]. + +Implicit Arguments Bool [T]. +Prenex Implicits Const Add Opp NatMul Mul Exp Bool Unit And Or Implies Not. +Prenex Implicits Exists Forall Lt. + +Notation True := (Bool true). +Notation False := (Bool false). + +Delimit Scope oterm_scope with oT. +Notation "''X_' i" := (Var _ i) : oterm_scope. +Notation "n %:R" := (NatConst _ n) : oterm_scope. +Notation "x %:T" := (Const x) : oterm_scope. +Notation "0" := 0%:R%oT : oterm_scope. +Notation "1" := 1%:R%oT : oterm_scope. +Infix "+" := Add : oterm_scope. +Notation "- t" := (Opp t) : oterm_scope. +Notation "t - u" := (Add t (- u)) : oterm_scope. +Infix "*" := Mul : oterm_scope. +Infix "*+" := NatMul : oterm_scope. +Notation "t ^-1" := (Inv t) : oterm_scope. +Notation "t / u" := (Mul t u^-1) : oterm_scope. +Infix "^+" := Exp : oterm_scope. +Notation "t ^- n" := (t^-1 ^+ n)%oT : oterm_scope. +Infix "==" := Equal : oterm_scope. +Infix "<%" := Lt : oterm_scope. +Infix "<=%" := Le : oterm_scope. +Infix "/\" := And : oterm_scope. +Infix "\/" := Or : oterm_scope. +Infix "==>" := Implies : oterm_scope. +Notation "~ f" := (Not f) : oterm_scope. +Notation "x != y" := (Not (x == y)) : oterm_scope. +Notation "''exists' ''X_' i , f" := (Exists i f) : oterm_scope. +Notation "''forall' ''X_' i , f" := (Forall i f) : oterm_scope. + +Section Substitution. + +Variable T : Type. + + +Fixpoint fsubst (f : formula T) (s : nat * term T) := + match f with + | Bool _ => f + | (t1 == t2) => (tsubst t1 s == tsubst t2 s) + | (t1 <% t2) => (tsubst t1 s <% tsubst t2 s) + | (t1 <=% t2) => (tsubst t1 s <=% tsubst t2 s) + | (Unit t1) => Unit (tsubst t1 s) + | (f1 /\ f2) => (fsubst f1 s /\ fsubst f2 s) + | (f1 \/ f2) => (fsubst f1 s \/ fsubst f2 s) + | (f1 ==> f2) => (fsubst f1 s ==> fsubst f2 s) + | (~ f1) => (~ fsubst f1 s) + | ('exists 'X_i, f1) => ('exists 'X_i, if i == s.1 then f1 else fsubst f1 s) + | ('forall 'X_i, f1) => ('forall 'X_i, if i == s.1 then f1 else fsubst f1 s) + end%oT. + +End Substitution. + +Section OrderedClause. + +Inductive oclause (R : Type) : Type := + Oclause : seq (term R) -> seq (term R) -> seq (term R) -> seq (term R) -> oclause R. + +Definition eq_of_oclause (R : Type)(x : oclause R) := + let: Oclause y _ _ _ := x in y. +Definition neq_of_oclause (R : Type)(x : oclause R) := + let: Oclause _ y _ _ := x in y. +Definition lt_of_oclause (R : Type) (x : oclause R) := + let: Oclause _ _ y _ := x in y. +Definition le_of_oclause (R : Type) (x : oclause R) := + let: Oclause _ _ _ y := x in y. + +End OrderedClause. + +Delimit Scope oclause_scope with OCLAUSE. +Open Scope oclause_scope. + +Notation "p .1" := (@eq_of_oclause _ p) + (at level 2, left associativity, format "p .1") : oclause_scope. +Notation "p .2" := (@neq_of_oclause _ p) + (at level 2, left associativity, format "p .2") : oclause_scope. + +Notation "p .3" := (@lt_of_oclause _ p) + (at level 2, left associativity, format "p .3") : oclause_scope. +Notation "p .4" := (@le_of_oclause _ p) + (at level 2, left associativity, format "p .4") : oclause_scope. + +Definition oclause_eq (T : eqType)(t1 t2 : oclause T) := + let: Oclause eq_l1 neq_l1 lt_l1 leq_l1 := t1 in + let: Oclause eq_l2 neq_l2 lt_l2 leq_l2 := t2 in + [&& eq_l1 == eq_l2, neq_l1 == neq_l2, lt_l1 == lt_l2 & leq_l1 == leq_l2]. + +Lemma oclause_eqP (T : eqType) : Equality.axiom (@oclause_eq T). +Proof. +move=> t1 t2; apply: (iffP idP) => [|<-] /= ; last first. + by rewrite /oclause_eq; case: t1=> l1 l2 l3 l4; rewrite !eqxx. +case: t1 => [l1 l2 l3 l4]; case: t2 => m1 m2 m3 m4 /=; case/and4P. +by move/eqP=> -> /eqP -> /eqP -> /eqP ->. +Qed. + +Canonical oclause_eqMixin (T : eqType) := EqMixin (@oclause_eqP T). +Canonical oclause_eqType (T : eqType) := + Eval hnf in EqType (oclause T) (@oclause_eqMixin T). + +Implicit Arguments oclause_eqP [x y]. +Prenex Implicits oclause_eq. + +Section EvalTerm. + +Variable R : realDomainType. + +(* Evaluation of a reified formula *) + +Fixpoint holds (e : seq R) (f : ord.formula R) {struct f} : Prop := + match f with + | Bool b => b + | (t1 == t2)%oT => eval e t1 = eval e t2 + | (t1 <% t2)%oT => eval e t1 < eval e t2 + | (t1 <=% t2)%oT => eval e t1 <= eval e t2 + | Unit t1 => eval e t1 \in unit + | (f1 /\ f2)%oT => holds e f1 /\ holds e f2 + | (f1 \/ f2)%oT => holds e f1 \/ holds e f2 + | (f1 ==> f2)%oT => holds e f1 -> holds e f2 + | (~ f1)%oT => ~ holds e f1 + | ('exists 'X_i, f1)%oT => exists x, holds (set_nth 0 e i x) f1 + | ('forall 'X_i, f1)%oT => forall x, holds (set_nth 0 e i x) f1 + end. + + +(* Extensionality of formula evaluation *) +Lemma eq_holds e e' f : same_env e e' -> holds e f -> holds e' f. +Proof. +pose sv := set_nth (0 : R). +have eq_i i v e1 e2: same_env e1 e2 -> same_env (sv e1 i v) (sv e2 i v). + by move=> eq_e j; rewrite !nth_set_nth /= eq_e. +elim: f e e' => //=. +- by move=> t1 t2 e e' eq_e; rewrite !(eq_eval _ eq_e). +- by move=> t1 t2 e e' eq_e; rewrite !(eq_eval _ eq_e). +- by move=> t1 t2 e e' eq_e; rewrite !(eq_eval _ eq_e). +- by move=> t e e' eq_e; rewrite (eq_eval _ eq_e). +- by move=> f1 IH1 f2 IH2 e e' eq_e; move/IH2: (eq_e); move/IH1: eq_e; tauto. +- by move=> f1 IH1 f2 IH2 e e' eq_e; move/IH2: (eq_e); move/IH1: eq_e; tauto. +- by move=> f1 IH1 f2 IH2 e e' eq_e f12; move/IH1: (same_env_sym eq_e); eauto. +- by move=> f1 IH1 e e'; move/same_env_sym; move/IH1; tauto. +- by move=> i f1 IH1 e e'; move/(eq_i i)=> eq_e [x f_ex]; exists x; eauto. +by move=> i f1 IH1 e e'; move/(eq_i i); eauto. +Qed. + +(* Evaluation and substitution by a constant *) +Lemma holds_fsubst e f i v : + holds e (fsubst f (i, v%:T)%T) <-> holds (set_nth 0 e i v) f. +Proof. +elim: f e => //=; do [ + by move=> *; rewrite !eval_tsubst +| move=> f1 IHf1 f2 IHf2 e; move: (IHf1 e) (IHf2 e); tauto +| move=> f IHf e; move: (IHf e); tauto +| move=> j f IHf e]. +- case eq_ji: (j == i); first rewrite (eqP eq_ji). + by split=> [] [x f_x]; exists x; rewrite set_set_nth eqxx in f_x *. + split=> [] [x f_x]; exists x; move: f_x; rewrite set_set_nth eq_sym eq_ji; + have:= IHf (set_nth 0 e j x); tauto. +case eq_ji: (j == i); first rewrite (eqP eq_ji). + by split=> [] f_ x; move: (f_ x); rewrite set_set_nth eqxx. +split=> [] f_ x; move: (IHf (set_nth 0 e j x)) (f_ x); + by rewrite set_set_nth eq_sym eq_ji; tauto. +Qed. + +(* Boolean test selecting formulas in the theory of rings *) +Fixpoint rformula (f : formula R) := + match f with + | Bool _ => true + | t1 == t2 => rterm t1 && rterm t2 + | t1 <% t2 => rterm t1 && rterm t2 + | t1 <=% t2 => rterm t1 && rterm t2 + | Unit t1 => false + | (f1 /\ f2) | (f1 \/ f2) | (f1 ==> f2) => rformula f1 && rformula f2 + | (~ f1) | ('exists 'X__, f1) | ('forall 'X__, f1) => rformula f1 + end%oT. + +(* An oformula stating that t1 is equal to 0 in the ring theory. *) +Definition eq0_rform t1 := + let m := @ub_var R t1 in + let: (t1', r1) := to_rterm t1 [::] m in + let fix loop r i := match r with + | [::] => t1' == 0 + | t :: r' => + let f := ('X_i * t == 1 /\ t * 'X_i == 1) in + 'forall 'X_i, (f \/ 'X_i == t /\ ~ ('exists 'X_i, f)) ==> loop r' i.+1 + end%oT + in loop r1 m. + +(* An oformula stating that t1 is less than 0 in the equational ring theory. +Definition leq0_rform t1 := + let m := @ub_var R t1 in + let: (t1', r1) := to_rterm t1 [::] m in + let fix loop r i := match r with + | [::] => 'exists 'X_m.+1, t1' == 'X_m.+1 * 'X_m.+1 + | t :: r' => + let f := ('X_i * t == 1 /\ t * 'X_i == 1) in + 'forall 'X_i, (f \/ 'X_i == t /\ ~ ('exists 'X_i, f)) ==> loop r' i.+1 + end%oT + in loop r1 m. +*) +Definition leq0_rform t1 := + let m := @ub_var R t1 in + let: (t1', r1) := to_rterm t1 [::] m in + let fix loop r i := match r with + | [::] => t1' <=% 0 + | t :: r' => + let f := ('X_i * t == 1 /\ t * 'X_i == 1) in + 'forall 'X_i, (f \/ 'X_i == t /\ ~ ('exists 'X_i, f)) ==> loop r' i.+1 + end%oT + in loop r1 m. + + +(* Definition lt0_rform t1 := *) +(* let m := @ub_var R t1 in *) +(* let: (t1', r1) := to_rterm t1 [::] m in *) +(* let fix loop r i := match r with *) +(* | [::] => 'exists 'X_m.+1, (t1' == 'X_m.+1 * 'X_m.+1 /\ ~ ('X_m.+1 == 0)) *) +(* | t :: r' => *) +(* let f := ('X_i * t == 1 /\ t * 'X_i == 1) in *) +(* 'forall 'X_i, (f \/ 'X_i == t /\ ~ ('exists 'X_i, f)) ==> loop r' i.+1 *) +(* end%oT *) +(* in loop r1 m. *) + +Definition lt0_rform t1 := + let m := @ub_var R t1 in + let: (t1', r1) := to_rterm t1 [::] m in + let fix loop r i := match r with + | [::] => t1' <% 0 + | t :: r' => + let f := ('X_i * t == 1 /\ t * 'X_i == 1) in + 'forall 'X_i, (f \/ 'X_i == t /\ ~ ('exists 'X_i, f)) ==> loop r' i.+1 + end%oT + in loop r1 m. + +(* Transformation of a formula in the theory of rings with units into an *) + +(* equivalent formula in the sub-theory of rings. *) +Fixpoint to_rform f := + match f with + | Bool b => f + | t1 == t2 => eq0_rform (t1 - t2) + | t1 <% t2 => lt0_rform (t1 - t2) + | t1 <=% t2 => leq0_rform (t1 - t2) + | Unit t1 => eq0_rform (t1 * t1^-1 - 1) + | f1 /\ f2 => to_rform f1 /\ to_rform f2 + | f1 \/ f2 => to_rform f1 \/ to_rform f2 + | f1 ==> f2 => to_rform f1 ==> to_rform f2 + | ~ f1 => ~ to_rform f1 + | ('exists 'X_i, f1) => 'exists 'X_i, to_rform f1 + | ('forall 'X_i, f1) => 'forall 'X_i, to_rform f1 + end%oT. + +(* The transformation gives a ring formula. *) +(* the last part of the proof consists in 3 cases that are exactly the same. + how to factorize ? *) +Lemma to_rform_rformula f : rformula (to_rform f). +Proof. +suffices [h1 h2 h3]: + [/\ forall t1, rformula (eq0_rform t1), + forall t1, rformula (lt0_rform t1) & + forall t1, rformula (leq0_rform t1)]. + by elim: f => //= => f1 ->. +split=> t1. +- rewrite /eq0_rform; move: (ub_var t1) => m. + set tr := _ m. + suffices: all (@rterm R) (tr.1 :: tr.2)%PAIR. + case: tr => {t1} t1 r /= /andP[t1_r]. + by elim: r m => [|t r IHr] m; rewrite /= ?andbT // => /andP[->]; exact: IHr. + have: all (@rterm R) [::] by []. + rewrite {}/tr; elim: t1 [::] => //=. + + move=> t1 IHt1 t2 IHt2 r. + move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /= /andP[t1_r]. + move/IHt2; case: to_rterm => {t2 r IHt2} t2 r /= /andP[t2_r]. + by rewrite t1_r t2_r. + + by move=> t1 IHt1 r /IHt1; case: to_rterm. + + by move=> t1 IHt1 n r /IHt1; case: to_rterm. + + move=> t1 IHt1 t2 IHt2 r. + move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /= /andP[t1_r]. + move/IHt2; case: to_rterm => {t2 r IHt2} t2 r /= /andP[t2_r]. + by rewrite t1_r t2_r. + + move=> t1 IHt1 r. + by move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /=; rewrite all_rcons. + + by move=> t1 IHt1 n r /IHt1; case: to_rterm. +- rewrite /lt0_rform; move: (ub_var t1) => m; set tr := _ m. + suffices: all (@rterm R) (tr.1 :: tr.2)%PAIR. + case: tr => {t1} t1 r /= /andP[t1_r]. + by elim: r m => [|t r IHr] m; rewrite /= ?andbT // => /andP[->]; exact: IHr. + have: all (@rterm R) [::] by []. + rewrite {}/tr; elim: t1 [::] => //=. + + move=> t1 IHt1 t2 IHt2 r. + move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /= /andP[t1_r]. + move/IHt2; case: to_rterm => {t2 r IHt2} t2 r /= /andP[t2_r]. + by rewrite t1_r t2_r. + + by move=> t1 IHt1 r /IHt1; case: to_rterm. + + by move=> t1 IHt1 n r /IHt1; case: to_rterm. + + move=> t1 IHt1 t2 IHt2 r. + move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /= /andP[t1_r]. + move/IHt2; case: to_rterm => {t2 r IHt2} t2 r /= /andP[t2_r]. + by rewrite t1_r t2_r. + + move=> t1 IHt1 r. + by move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /=; rewrite all_rcons. + + by move=> t1 IHt1 n r /IHt1; case: to_rterm. +- rewrite /leq0_rform; move: (ub_var t1) => m; set tr := _ m. + suffices: all (@rterm R) (tr.1 :: tr.2)%PAIR. + case: tr => {t1} t1 r /= /andP[t1_r]. + by elim: r m => [|t r IHr] m; rewrite /= ?andbT // => /andP[->]; exact: IHr. + have: all (@rterm R) [::] by []. + rewrite {}/tr; elim: t1 [::] => //=. + + move=> t1 IHt1 t2 IHt2 r. + move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /= /andP[t1_r]. + move/IHt2; case: to_rterm => {t2 r IHt2} t2 r /= /andP[t2_r]. + by rewrite t1_r t2_r. + + by move=> t1 IHt1 r /IHt1; case: to_rterm. + + by move=> t1 IHt1 n r /IHt1; case: to_rterm. + + move=> t1 IHt1 t2 IHt2 r. + move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /= /andP[t1_r]. + move/IHt2; case: to_rterm => {t2 r IHt2} t2 r /= /andP[t2_r]. + by rewrite t1_r t2_r. + + move=> t1 IHt1 r. + by move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /=; rewrite all_rcons. + + by move=> t1 IHt1 n r /IHt1; case: to_rterm. +Qed. + +Import Num.Theory. + +(* Correctness of the transformation. *) +Lemma to_rformP e f : holds e (to_rform f) <-> holds e f. +Proof. +suffices{e f} [equal0_equiv lt0_equiv le0_equiv]: + [/\ forall e t1 t2, holds e (eq0_rform (t1 - t2)) <-> (eval e t1 == eval e t2), + forall e t1 t2, holds e (lt0_rform (t1 - t2)) <-> (eval e t1 < eval e t2) & + forall e t1 t2, holds e (leq0_rform (t1 - t2)) <-> (eval e t1 <= eval e t2)]. +- elim: f e => /=; try tauto. + + move=> t1 t2 e. + by split; [move/equal0_equiv/eqP | move/eqP/equal0_equiv]. + + by move=> t1 t2 e; split; move/lt0_equiv. + + by move=> t1 t2 e; split; move/le0_equiv. + + move=> t1 e; rewrite unitrE; exact: equal0_equiv. + + move=> f1 IHf1 f2 IHf2 e; move: (IHf1 e) (IHf2 e); tauto. + + move=> f1 IHf1 f2 IHf2 e; move: (IHf1 e) (IHf2 e); tauto. + + move=> f1 IHf1 f2 IHf2 e; move: (IHf1 e) (IHf2 e); tauto. + + move=> f1 IHf1 e; move: (IHf1 e); tauto. + + by move=> n f1 IHf1 e; split=> [] [x] /IHf1; exists x. + + by move=> n f1 IHf1 e; split=> Hx x; apply/IHf1. +suffices h e t1 t2 : + [/\ holds e (eq0_rform (t1 - t2)) <-> (eval e t1 == eval e t2), + holds e (lt0_rform (t1 - t2)) <-> (eval e t1 < eval e t2) & + holds e (leq0_rform (t1 - t2)) <-> (eval e t1 <= eval e t2)]. + by split => e t1 t2; case: (h e t1 t2). +rewrite -{1}(add0r (eval e t2)) -(can2_eq (subrK _) (addrK _)). +rewrite -subr_lt0 -subr_le0 -/(eval e (t1 - t2)); move: (t1 - t2)%T => {t1 t2} t. +have sub_var_tsubst s t0: (s.1%PAIR >= ub_var t0)%N -> tsubst t0 s = t0. + elim: t0 {t} => //=. + - by move=> n; case: ltngtP. + - by move=> t1 IHt1 t2 IHt2; rewrite geq_max => /andP[/IHt1-> /IHt2->]. + - by move=> t1 IHt1 /IHt1->. + - by move=> t1 IHt1 n /IHt1->. + - by move=> t1 IHt1 t2 IHt2; rewrite geq_max => /andP[/IHt1-> /IHt2->]. + - by move=> t1 IHt1 /IHt1->. + - by move=> t1 IHt1 n /IHt1->. +pose fix rsub t' m r : term R := + if r is u :: r' then tsubst (rsub t' m.+1 r') (m, u^-1)%T else t'. +pose fix ub_sub m r : Prop := + if r is u :: r' then (ub_var u <= m)%N /\ ub_sub m.+1 r' else true. +suffices{t} rsub_to_r t r0 m: (m >= ub_var t)%N -> ub_sub _ m r0 -> + let: (t', r) := to_rterm t r0 m in + [/\ take (size r0) r = r0, + ub_var t' <= m + size r, ub_sub _ m r & rsub t' m r = t]%N. +- have:= rsub_to_r t [::] _ (leqnn _); rewrite /eq0_rform /lt0_rform /leq0_rform. + case: (to_rterm _ _ _) => [t1' r1] /= [//| _ _ ub_r1 def_t]. + rewrite -{2 4 6}def_t {def_t}. + elim: r1 (ub_var t) e ub_r1 => [|u r1 IHr1] m e /= => [_|[ub_u ub_r1]]. + by split => //; split=> /eqP. + rewrite eval_tsubst /=; set y := eval e u; split; split => //= t_h0. + + case: (IHr1 m.+1 (set_nth 0 e m y^-1) ub_r1) => h _ _; apply/h. + apply: t_h0. + rewrite nth_set_nth /= eqxx -(eval_tsubst e u (m, Const _)). + rewrite sub_var_tsubst //= -/y. + case Uy: (y \in unit); [left | right]; first by rewrite mulVr ?divrr. + split=> [|[z]]; first by rewrite invr_out ?Uy. + rewrite nth_set_nth /= eqxx. + rewrite -!(eval_tsubst _ _ (m, Const _)) !sub_var_tsubst // -/y => yz1. + by case/unitrP: Uy; exists z. + + move=> x def_x. + case: (IHr1 m.+1 (set_nth 0 e m x) ub_r1) => h _ _. apply/h. + suff ->: x = y^-1 by []; move: def_x. + rewrite nth_set_nth /= eqxx -(eval_tsubst e u (m, Const _)). + rewrite sub_var_tsubst //= -/y; case=> [[xy1 yx1] | [xy nUy]]. + by rewrite -[y^-1]mul1r -[1]xy1 mulrK //; apply/unitrP; exists x. + rewrite invr_out //; apply/unitrP=> [[z yz1]]; case: nUy; exists z. + rewrite nth_set_nth /= eqxx -!(eval_tsubst _ _ (m, _%:T)%T). + by rewrite !sub_var_tsubst. + + case: (IHr1 m.+1 (set_nth 0 e m y^-1) ub_r1) => _ h _. apply/h. + apply: t_h0. + rewrite nth_set_nth /= eqxx -(eval_tsubst e u (m, Const _)). + rewrite sub_var_tsubst //= -/y. + case Uy: (y \in unit); [left | right]; first by rewrite mulVr ?divrr. + split=> [|[z]]; first by rewrite invr_out ?Uy. + rewrite nth_set_nth /= eqxx. + rewrite -!(eval_tsubst _ _ (m, Const _)) !sub_var_tsubst // -/y => yz1. + by case/unitrP: Uy; exists z. + + move=> x def_x. + case: (IHr1 m.+1 (set_nth 0 e m x) ub_r1) => _ h _. apply/h. + suff ->: x = y^-1 by []; move: def_x. + rewrite nth_set_nth /= eqxx -(eval_tsubst e u (m, Const _)). + rewrite sub_var_tsubst //= -/y; case=> [[xy1 yx1] | [xy nUy]]. + by rewrite -[y^-1]mul1r -[1]xy1 mulrK //; apply/unitrP; exists x. + rewrite invr_out //; apply/unitrP=> [[z yz1]]; case: nUy; exists z. + rewrite nth_set_nth /= eqxx -!(eval_tsubst _ _ (m, _%:T)%T). + by rewrite !sub_var_tsubst. + + case: (IHr1 m.+1 (set_nth 0 e m y^-1) ub_r1) => _ _ h. apply/h. + apply: t_h0. + rewrite nth_set_nth /= eqxx -(eval_tsubst e u (m, Const _)). + rewrite sub_var_tsubst //= -/y. + case Uy: (y \in unit); [left | right]; first by rewrite mulVr ?divrr. + split=> [|[z]]; first by rewrite invr_out ?Uy. + rewrite nth_set_nth /= eqxx. + rewrite -!(eval_tsubst _ _ (m, Const _)) !sub_var_tsubst // -/y => yz1. + by case/unitrP: Uy; exists z. + + move=> x def_x. + case: (IHr1 m.+1 (set_nth 0 e m x) ub_r1) => _ _ h. apply/h. + suff ->: x = y^-1 by []; move: def_x. + rewrite nth_set_nth /= eqxx -(eval_tsubst e u (m, Const _)). + rewrite sub_var_tsubst //= -/y; case=> [[xy1 yx1] | [xy nUy]]. + by rewrite -[y^-1]mul1r -[1]xy1 mulrK //; apply/unitrP; exists x. + rewrite invr_out //; apply/unitrP=> [[z yz1]]; case: nUy; exists z. + rewrite nth_set_nth /= eqxx -!(eval_tsubst _ _ (m, _%:T)%T). + by rewrite !sub_var_tsubst. +have rsub_id r t0 n: (ub_var t0 <= n)%N -> rsub t0 n r = t0. + by elim: r n => //= t1 r IHr n let0n; rewrite IHr ?sub_var_tsubst ?leqW. +have rsub_acc r s t1 m1: + (ub_var t1 <= m1 + size r)%N -> rsub t1 m1 (r ++ s) = rsub t1 m1 r. + elim: r t1 m1 => [|t1 r IHr] t2 m1 /=; first by rewrite addn0; apply: rsub_id. + by move=> letmr; rewrite IHr ?addSnnS. +elim: t r0 m => /=; try do [ + by move=> n r m hlt hub; rewrite take_size (ltn_addr _ hlt) rsub_id +| by move=> n r m hlt hub; rewrite leq0n take_size rsub_id +| move=> t1 IHt1 t2 IHt2 r m; rewrite geq_max; case/andP=> hub1 hub2 hmr; + case: to_rterm {IHt1 hub1 hmr}(IHt1 r m hub1 hmr) => t1' r1; + case=> htake1 hub1' hsub1 <-; + case: to_rterm {IHt2 hub2 hsub1}(IHt2 r1 m hub2 hsub1) => t2' r2 /=; + rewrite geq_max; case=> htake2 -> hsub2 /= <-; + rewrite -{1 2}(cat_take_drop (size r1) r2) htake2; set r3 := drop _ _; + rewrite size_cat addnA (leq_trans _ (leq_addr _ _)) //; + split=> {hsub2}//; + first by [rewrite takel_cat // -htake1 size_take geq_minr]; + rewrite -(rsub_acc r1 r3 t1') {hub1'}// -{htake1}htake2 {r3}cat_take_drop; + by elim: r2 m => //= u r2 IHr2 m; rewrite IHr2 +| do [ move=> t1 IHt1 r m; do 2!move/IHt1=> {IHt1}IHt1 + | move=> t1 IHt1 n r m; do 2!move/IHt1=> {IHt1}IHt1]; + case: to_rterm IHt1 => t1' r1 [-> -> hsub1 <-]; split=> {hsub1}//; + by elim: r1 m => //= u r1 IHr1 m; rewrite IHr1]. +move=> t1 IH r m letm /IH {IH} /(_ letm) {letm}. +case: to_rterm => t1' r1 /= [def_r ub_t1' ub_r1 <-]. +rewrite size_rcons addnS leqnn -{1}cats1 takel_cat ?def_r; last first. + by rewrite -def_r size_take geq_minr. +elim: r1 m ub_r1 ub_t1' {def_r} => /= [|u r1 IHr1] m => [_|[->]]. + by rewrite addn0 eqxx. +by rewrite -addSnnS => /IHr1 IH /IH[_ _ ub_r1 ->]. +Qed. + +(* The above proof is ugly but is in fact copypaste *) + +(* Boolean test selecting formulas which describe a constructible set, *) +(* i.e. formulas without quantifiers. *) + +(* The quantifier elimination check. *) +Fixpoint qf_form (f : formula R) := + match f with + | Bool _ | _ == _ | Unit _ | Lt _ _ | Le _ _ => true + | f1 /\ f2 | f1 \/ f2 | f1 ==> f2 => qf_form f1 && qf_form f2 + | ~ f1 => qf_form f1 + | _ => false + end%oT. + +(* Boolean holds predicate for quantifier free formulas *) +Definition qf_eval e := fix loop (f : formula R) : bool := + match f with + | Bool b => b + | t1 == t2 => (eval e t1 == eval e t2)%bool + | t1 <% t2 => (eval e t1 < eval e t2)%bool + | t1 <=% t2 => (eval e t1 <= eval e t2)%bool + | Unit t1 => eval e t1 \in unit + | f1 /\ f2 => loop f1 && loop f2 + | f1 \/ f2 => loop f1 || loop f2 + | f1 ==> f2 => (loop f1 ==> loop f2)%bool + | ~ f1 => ~~ loop f1 + |_ => false + end%oT. + +(* qf_eval is equivalent to holds *) +Lemma qf_evalP e f : qf_form f -> reflect (holds e f) (qf_eval e f). +Proof. +elim: f => //=; try by move=> *; exact: idP. +- move=> t1 t2 _; exact: eqP. +- move=> f1 IHf1 f2 IHf2 /= /andP[/IHf1[] f1T]; last by right; case. + by case/IHf2; [left | right; case]. +- move=> f1 IHf1 f2 IHf2 /= /andP[/IHf1[] f1F]; first by do 2 left. + by case/IHf2; [left; right | right; case]. +- move=> f1 IHf1 f2 IHf2 /= /andP[/IHf1[] f1T]; last by left. + by case/IHf2; [left | right; move/(_ f1T)]. +by move=> f1 IHf1 /IHf1[]; [right | left]. +Qed. + +(* Quantifier-free formula are normalized into DNF. A DNF is *) +(* represented by the type seq (seq (term R) * seq (term R)), where we *) +(* separate positive and negative literals *) + + +(* DNF preserving conjunction *) + +Definition and_odnf (bcs1 bcs2 : seq (oclause R)) := + \big[cat/nil]_(bc1 <- bcs1) + map (fun bc2 : oclause R => + (Oclause (bc1.1 ++ bc2.1) (bc1.2 ++ bc2.2) (bc1.3 ++ bc2.3) (bc1.4 ++ bc2.4)))%OCLAUSE bcs2. + +(* Computes a DNF from a qf ring formula *) +Fixpoint qf_to_odnf (f : formula R) (neg : bool) {struct f} : seq (oclause R) := + match f with + | Bool b => if b (+) neg then [:: (Oclause [::] [::] [::] [::])] else [::] + | t1 == t2 => + [:: if neg then (Oclause [::] [:: t1 - t2] [::] [::]) else (Oclause [:: t1 - t2] [::] [::] [::])] + | t1 <% t2 => + [:: if neg then (Oclause [::] [::] [::] [:: t1 - t2]) else (Oclause [::] [::] [:: t2 - t1] [::])] + | t1 <=% t2 => + [:: if neg then (Oclause [::] [::] [:: t1 - t2] [::]) else (Oclause [::] [::] [::] [:: t2 - t1])] + | f1 /\ f2 => (if neg then cat else and_odnf) [rec f1, neg] [rec f2, neg] + | f1 \/ f2 => (if neg then and_odnf else cat) [rec f1, neg] [rec f2, neg] + | f1 ==> f2 => (if neg then and_odnf else cat) [rec f1, ~~ neg] [rec f2, neg] + | ~ f1 => [rec f1, ~~ neg] + | _ => if neg then [:: (Oclause [::] [::] [::] [::])] else [::] + end%oT where "[ 'rec' f , neg ]" := (qf_to_odnf f neg). + +(* Conversely, transforms a DNF into a formula *) +Definition odnf_to_oform := + let pos_lit t := And (t == 0)%oT in let neg_lit t := And (t != 0)%oT in + let lt_lit t := And (0 <% t)%oT in let le_lit t := And (0 <=% t)%oT in + let ocls (bc : oclause R) := + Or + (foldr pos_lit True bc.1 /\ foldr neg_lit True bc.2 /\ + foldr lt_lit True bc.3 /\ foldr le_lit True bc.4) in + foldr ocls False. + +(* Catenation of dnf is the Or of formulas *) +Lemma cat_dnfP e bcs1 bcs2 : + qf_eval e (odnf_to_oform (bcs1 ++ bcs2)) + = qf_eval e (odnf_to_oform bcs1 \/ odnf_to_oform bcs2). +Proof. +by elim: bcs1 => //= bc1 bcs1 IH1; rewrite -orbA; congr orb; rewrite IH1. +Qed. + + + +(* and_dnf is the And of formulas *) +Lemma and_odnfP e bcs1 bcs2 : + qf_eval e (odnf_to_oform (and_odnf bcs1 bcs2)) + = qf_eval e (odnf_to_oform bcs1 /\ odnf_to_oform bcs2). +Proof. +elim: bcs1 => [|bc1 bcs1 IH1] /=; first by rewrite /and_odnf big_nil. +rewrite /and_odnf big_cons -/(and_odnf bcs1 bcs2) cat_dnfP /=. +rewrite {}IH1 /= andb_orl; congr orb. +elim: bcs2 bc1 {bcs1} => [|bc2 bcs2 IH] bc1 /=; first by rewrite andbF. +rewrite {}IH /= andb_orr; congr orb => {bcs2}. +suffices aux (l1 l2 : seq (term R)) g : let redg := foldr (And \o g) True in + qf_eval e (redg (l1 ++ l2)) = qf_eval e (redg l1 /\ redg l2)%oT. ++ rewrite !aux /= !andbA; congr (_ && _); rewrite -!andbA; congr (_ && _). + rewrite -andbCA; congr (_ && _); bool_congr; rewrite andbCA; bool_congr. + by rewrite andbA andbC !andbA. +by elim: l1 => [| t1 l1 IHl1] //=; rewrite -andbA IHl1. +Qed. + +Lemma qf_to_dnfP e : + let qev f b := qf_eval e (odnf_to_oform (qf_to_odnf f b)) in + forall f, qf_form f && rformula f -> qev f false = qf_eval e f. +Proof. +move=> qev; have qevT f: qev f true = ~~ qev f false. + rewrite {}/qev; elim: f => //=; do [by case | move=> f1 IH1 f2 IH2 | ]. + - by move=> t1 t2; rewrite !andbT !orbF. + - by move=> t1 t2; rewrite !andbT !orbF; rewrite !subr_gte0 -lerNgt. + - by move=> t1 t2; rewrite !andbT !orbF; rewrite !subr_gte0 -ltrNge. + - by rewrite and_odnfP cat_dnfP negb_and -IH1 -IH2. + - by rewrite and_odnfP cat_dnfP negb_or -IH1 -IH2. + - by rewrite and_odnfP cat_dnfP /= negb_or IH1 -IH2 negbK. + by move=> t1 ->; rewrite negbK. +rewrite /qev; elim=> //=; first by case. +- by move=> t1 t2 _; rewrite subr_eq0 !andbT orbF. +- by move=> t1 t2 _; rewrite orbF !andbT subr_gte0. +- by move=> t1 t2 _; rewrite orbF !andbT subr_gte0. +- move=> f1 IH1 f2 IH2; rewrite andbCA -andbA andbCA andbA; case/andP. + by rewrite and_odnfP /= => /IH1-> /IH2->. +- move=> f1 IH1 f2 IH2; rewrite andbCA -andbA andbCA andbA; case/andP. + by rewrite cat_dnfP /= => /IH1-> => /IH2->. +- move=> f1 IH1 f2 IH2; rewrite andbCA -andbA andbCA andbA; case/andP. + by rewrite cat_dnfP /= [qf_eval _ _]qevT -implybE => /IH1 <- /IH2->. +by move=> f1 IH1 /IH1 <-; rewrite -qevT. +Qed. + +Lemma dnf_to_form_qf bcs : qf_form (odnf_to_oform bcs). +Proof. +elim: bcs => //= [[clT clF] clLt clLe ? ->] /=; elim: clT => //=. +by rewrite andbT; elim: clF; elim: clLt => //; elim: clLe. +Qed. + +Definition dnf_rterm (cl : oclause R) := + [&& all (@rterm R) cl.1, all (@rterm R) cl.2, + all (@rterm R) cl.3 & all (@rterm R) cl.4]. + +Lemma qf_to_dnf_rterm f b : rformula f -> all dnf_rterm (qf_to_odnf f b). +Proof. +set ok := all dnf_rterm. +have cat_ok bcs1 bcs2: ok bcs1 -> ok bcs2 -> ok (bcs1 ++ bcs2). + by move=> ok1 ok2; rewrite [ok _]all_cat; exact/andP. +have and_ok bcs1 bcs2: ok bcs1 -> ok bcs2 -> ok (and_odnf bcs1 bcs2). + rewrite /and_odnf unlock; elim: bcs1 => //= cl1 bcs1 IH1; rewrite -andbA. + case/and3P=> ok11 ok12 ok1 ok2; rewrite cat_ok ?{}IH1 {bcs1 ok1}//. + elim: bcs2 ok2 => //= cl2 bcs2 IH2 /andP[ok2 /IH2->]. + by rewrite /dnf_rterm /= !all_cat andbT ok11; case/and3P: ok12=> -> -> ->. +elim: f b => //=; try by [move=> _ ? ? [] | move=> ? ? ? ? [] /= /andP[]; auto]. +- by do 2!case. +- by rewrite /dnf_rterm => ? ? [] /= ->. +- by rewrite /dnf_rterm => ? ? [] /=; rewrite andbC !andbT. +- by rewrite /dnf_rterm => ? ? [] /=; rewrite andbC !andbT. +by auto. +Qed. + +Lemma dnf_to_rform bcs : rformula (odnf_to_oform bcs) = all dnf_rterm bcs. +Proof. +elim: bcs => //= [[cl1 cl2 cl3 cl4] bcs ->]; rewrite {2}/dnf_rterm /=; congr (_ && _). +congr andb; first by elim: cl1 => //= t cl ->; rewrite andbT. +congr andb; first by elim: cl2 => //= t cl ->; rewrite andbT. +congr andb; first by elim: cl3 => //= t cl ->. +by elim: cl4 => //= t cl ->. +Qed. + +Implicit Type f : formula R. + +Fixpoint leq_elim_aux (eq_l lt_l le_l : seq (term R)) := + match le_l with + [::] => [:: (eq_l, lt_l)] + |le1 :: le_l' => + let res := leq_elim_aux eq_l lt_l le_l' in + let as_eq := map (fun x => (le1 :: x.1%PAIR, x.2%PAIR)) res in + let as_lt := map (fun x => (x.1%PAIR, le1 :: x.2%PAIR)) res in + as_eq ++ as_lt + end. + +Definition oclause_leq_elim oc : seq (oclause R) := + let: Oclause eq_l neq_l lt_l le_l := oc in + map (fun x => Oclause x.1%PAIR neq_l x.2%PAIR [::]) + (leq_elim_aux eq_l lt_l le_l). + +Definition terms_of_oclause (oc : oclause R) := + let: Oclause eq_l neq_l lt_l le_l := oc in + eq_l ++ neq_l ++ lt_l ++ le_l. + +Lemma terms_of_leq_elim oc1 oc2: + oc2 \in (oclause_leq_elim oc1) -> + (terms_of_oclause oc2) =i (terms_of_oclause oc1). +case: oc1 => eq1 neq1 lt1 leq1 /=. +elim: leq1 eq1 lt1 oc2 => [|t1 leq1 ih] eq1 lt1 [eq2 neq2 lt2 leq2] /=. + by rewrite inE; case/eqP=> -> -> -> -> ?. +rewrite map_cat /= mem_cat -!map_comp; set f := fun _ => _. +rewrite -/f in ih; case/orP. + case/mapP=> [[y1 y2]] yin ye. + move: (ih eq1 lt1 (f (y1, y2))); rewrite mem_map //; last first. + by move=> [u1 u2] [v1 v2]; rewrite /f /=; case=> -> ->. + move/(_ yin); move: ye; rewrite /f /=; case=> -> -> -> -> /= h. + move=> u; rewrite in_cons (h u) !mem_cat in_cons. + by rewrite orbC !orbA; set x := _ || (u \in lt1); rewrite orbAC. +case/mapP=> [[y1 y2]] yin ye. +move: (ih eq1 lt1 (f (y1, y2))); rewrite mem_map //; last first. + by move=> [u1 u2] [v1 v2]; rewrite /f /=; case=> -> ->. +move/(_ yin); move: ye; rewrite /f /=; case=> -> -> -> -> /= h u. +rewrite !mem_cat !in_cons orbA orbCA -!orbA; move: (h u); rewrite !mem_cat=> ->. +by rewrite orbC !orbA; set x := _ || (u \in lt1); rewrite orbAC. +Qed. + +Lemma odnf_to_oform_cat e c d : holds e (odnf_to_oform (c ++ d)) + <-> holds e ((odnf_to_oform c) \/ (odnf_to_oform d))%oT. +Proof. +elim: c d => [| tc c ihc] d /=; first by split => // hd; [right | case: hd]. +rewrite ihc /=; split. + case; first by case=> ?; case => ?; case => ? ?; left; left. + case; first by move=> ?; left; right. + by move=> ?; right. +case; last by move=> ?; right; right. +case; last by move=> ?; right; left. +by do 3!case=> ?; move=> ?; left. +Qed. + +Lemma oclause_leq_elimP oc e : + holds e (odnf_to_oform [:: oc]) <-> + holds e (odnf_to_oform (oclause_leq_elim oc)). +Proof. +case: oc => eq_l neq_l lt_l le_l; rewrite /oclause_leq_elim. +elim: le_l eq_l neq_l lt_l => [|t le_l ih] eq_l neq_l lt_l //=. +move: (ih eq_l neq_l lt_l) => /= {ih}. +set x1 := foldr _ _ _; set x2 := foldr _ _ _; set x3 := foldr _ _ _. +set x4 := foldr _ _ _ => h. +have -> : (holds e x1 /\ holds e x2 /\ holds e x3 /\ 0%:R <= eval e t /\ + holds e x4 \/ false) <-> + (0%:R <= eval e t) /\ (holds e x1 /\ holds e x2 /\ holds e x3 /\ + holds e x4 \/ false). + split; first by case=> //; do 4! (case => ?); move=> ?; split => //; left. + by case=> ?; case => //; do 3! (case=> ?); move=> ?; left. +rewrite h {h} /= !map_cat /= -!map_comp. +set s1 := [seq _ | _ <- _]; set s2 := [seq _ | _ <- _]. +set s3 := [seq _ | _ <- _]. rewrite odnf_to_oform_cat. +suff {x1 x2 x3 x4} /= -> : + holds e (odnf_to_oform s2) <-> eval e t == 0%:R /\ holds e (odnf_to_oform s1). + suff /= -> : + holds e (odnf_to_oform s3) <-> 0%:R < eval e t /\ holds e (odnf_to_oform s1). + rewrite ler_eqVlt eq_sym; split; first by case; case/orP=> -> ?; [left|right]. + by case; [case=> -> ? /= |case=> ->; rewrite orbT]. + rewrite /s1 /s3. + elim: (leq_elim_aux eq_l lt_l le_l) => /= [| t1 l ih]; first by split=> // [[]]. + rewrite /= ih; split. + case; last by case=> -> ?; split=> //; right. + by do 2!case=> ?; case; case=> -> ? _; split => //; auto. + by case=> ->; case; [do 3!case=> ?; move=> _; left | right]. +rewrite /s2 /s1. +elim: (leq_elim_aux eq_l lt_l le_l) => /= [| t1 l ih]; first by split=> // [[]]. +rewrite /= ih; split. + case; last by case=> -> ?; split=> //; right. + by case; case=> /eqP ? ?; do 2! case=> ?; move=> _; split=>//; left. +case=> /eqP ?; case; first by do 3!case=> ?; move=> _; left. +by right; split=> //; apply/eqP. +Qed. + +Fixpoint neq_elim_aux (lt_l neq_l : seq (term R)) := + match neq_l with + [::] => [:: lt_l] + |neq1 :: neq_l' => + let res := neq_elim_aux lt_l neq_l' in + let as_pos := map (fun x => neq1 :: x) res in + let as_neg := map (fun x => Opp neq1 :: x) res in + as_pos ++ as_neg + end. + +Definition oclause_neq_elim oc : seq (oclause R) := + let: Oclause eq_l neq_l lt_l le_l := oc in + map (fun x => Oclause eq_l [::] x le_l) (neq_elim_aux lt_l neq_l). + +Lemma terms_of_neq_elim oc1 oc2: + oc2 \in (oclause_neq_elim oc1) -> + {subset (terms_of_oclause oc2) <= (terms_of_oclause oc1) ++ (map Opp oc1.2)}. +Proof. +case: oc1 => eq1 neq1 lt1 leq1 /=. +elim: neq1 lt1 oc2 => [|t1 neq1 ih] lt1 [eq2 neq2 lt2 leq2] /=. + by rewrite inE; case/eqP=> -> -> -> ->; rewrite !cats0 !cat0s. +rewrite map_cat /= mem_cat -!map_comp; set f := fun _ => _. +rewrite -/f in ih; case/orP. + case/mapP=> y yin ye. + move: (ih lt1 (f y)); rewrite mem_map //; last first. + by move=> u v; rewrite /f /=; case. + move/(_ yin); move: ye; rewrite /f /=; case=> -> -> -> -> /= h. + move=> u. rewrite !mem_cat !in_cons orbAC orbC mem_cat -!orbA. + case/orP; first by move->; rewrite !orbT. + rewrite !orbA [_ || (_ \in eq1)]orbC; move: (h u); rewrite !mem_cat=> hu. + by move/hu; do 2! (case/orP; last by move->; rewrite !orbT); move->. +case/mapP=> y yin ye. +move: (ih lt1 (f y)); rewrite mem_map //; last first. + by move=> u v; rewrite /f /=; case. +move/(_ yin); move: ye; rewrite /f /=; case=> -> -> -> -> /= h. +move=> u; rewrite !mem_cat !in_cons orbAC orbC mem_cat -!orbA. +case/orP; first by move->; rewrite !orbT. +rewrite !orbA [_ || (_ \in eq1)]orbC; move: (h u); rewrite !mem_cat=> hu. +by move/hu; do 2! (case/orP; last by move->; rewrite !orbT); move->. +Qed. + + +Lemma oclause_neq_elimP oc e : + holds e (odnf_to_oform [:: oc]) <-> + holds e (odnf_to_oform (oclause_neq_elim oc)). +Proof. +case: oc => eq_l neq_l lt_l le_l; rewrite /oclause_neq_elim. +elim: neq_l lt_l => [|t neq_l ih] lt_l //=. +move: (ih lt_l) => /= {ih}. +set x1 := foldr _ _ _; set x2 := foldr _ _ _; set x3 := foldr _ _ _. +set x4 := foldr _ _ _ => h /=. +have -> : holds e x1 /\ + (eval e t <> 0%:R /\ + holds e x2) /\ + holds e x3 /\ holds e x4 \/ + false <-> + (eval e t <> 0%:R) /\ (holds e x1 /\ holds e x2 /\ holds e x3 /\ + holds e x4 \/ false). + split; case => //. + - by case=> ?; case; case=> ? ? [] ? ?; split=> //; left. + - by move=> ?; case => //; do 3! case => ?; move=> ?; left. +rewrite h {h} /= !map_cat /= -!map_comp. +set s1 := [seq _ | _ <- _]; set s2 := [seq _ | _ <- _]. +set s3 := [seq _ | _ <- _]; rewrite odnf_to_oform_cat. +suff {x1 x2 x3 x4} /= -> : + holds e (odnf_to_oform s2) <-> 0%:R < eval e t/\ holds e (odnf_to_oform s1). + suff /= -> : + holds e (odnf_to_oform s3) <-> 0%:R < - eval e t /\ holds e (odnf_to_oform s1). + rewrite oppr_gt0; split. + by case; move/eqP; rewrite neqr_lt; case/orP=> -> h1; [right | left]. + by case; case=> h ?; split=> //; apply/eqP; rewrite neqr_lt h ?orbT. + rewrite /s1 /s3. + elim: (neq_elim_aux lt_l neq_l) => /= [| t1 l ih] /=; first by split => //; case. + set y1 := foldr _ _ _; set y2 := foldr _ _ _; set y3 := foldr _ _ _. + rewrite ih; split. + case; first by case=> ?; case=> _; case; case=> -> ? ?; split=> //; left. + by case=> ? ?; split=> //; right. + by case=> ->; case; [case=> ?; case=> _; case=> ? ?; left| move=> ? ; right]. +rewrite /s1 /s2. +elim: (neq_elim_aux lt_l neq_l) => /= [| t1 l ih] /=; first by split => //; case. +set y1 := foldr _ _ _; set y2 := foldr _ _ _; set y3 := foldr _ _ _. +rewrite ih; split. + case; first by case=> ? [] _ [] [] ? ? ?; split=> //; left. + by case=> ? ?; split=> //; right. +case=> ? []; last by right. +by case=> ? [] _ [] ? ?; left. +Qed. + +Definition oclause_neq_leq_elim oc := + flatten (map oclause_neq_elim (oclause_leq_elim oc)). + +Lemma terms_of_neq_leq_elim oc1 oc2: + oc2 \in (oclause_neq_leq_elim oc1) -> + {subset (terms_of_oclause oc2) <= (terms_of_oclause oc1) ++ map Opp oc1.2}. +Proof. +rewrite /oclause_neq_leq_elim /flatten; rewrite foldr_map. +suff : forall oc3, + oc3 \in (oclause_leq_elim oc1) -> + (terms_of_oclause oc3 =i terms_of_oclause oc1) /\ oc3.2 = oc1.2. + elim: (oclause_leq_elim oc1) => [| t l ih] //= h1. + rewrite mem_cat; case/orP. + - move/terms_of_neq_elim=> h u; move/(h u); rewrite !mem_cat. + by case: (h1 t (mem_head _ _)); move/(_ u)=> -> ->. + - by move=> h; apply: (ih _ h) => ? loc3; apply: h1; rewrite in_cons loc3 orbT. +move=> {oc2} oc3 hoc3; split; first exact: terms_of_leq_elim. +case: oc3 hoc3=> eq2 neq2 lt2 leq2 /=; case: oc1=> eq1 neq1 lt1 leq1 /=. +elim: leq1 => [| t1 le1 ih] //=; first by rewrite inE; case/eqP=> _ ->. +rewrite map_cat mem_cat; move: ih. +elim: (leq_elim_aux eq1 lt1 le1) => [| t2 l2 ih2] //=; rewrite !in_cons. +move=> h1; case/orP=> /=. + case/orP; first by case/eqP. + by move=> h2; apply: ih2; rewrite ?h2 //; move=> h3; apply: h1; rewrite h3 orbT. +case/orP; first by case/eqP. +move=> h3; apply: ih2; last by rewrite h3 orbT. +by move=> h2; apply: h1; rewrite h2 orbT. +Qed. + +Lemma oclause_neq_leq_elimP oc e : + holds e (odnf_to_oform [:: oc]) <-> + holds e (odnf_to_oform (oclause_neq_leq_elim oc)). +Proof. +rewrite /oclause_neq_leq_elim. +rewrite oclause_leq_elimP; elim: (oclause_leq_elim oc) => [| t l ih] //=. +rewrite odnf_to_oform_cat /= ih -oclause_neq_elimP /=. +suff -> : forall A, A \/ false <-> A by []. +by intuition. +Qed. + +Definition oclause_to_w oc := + let s := oclause_neq_leq_elim oc in + map (fun x => let: Oclause eq_l neq_l lt_l leq_l := x in (eq_l, lt_l)) s. + +Definition w_to_oclause (t : seq (term R) * seq (term R)) := + Oclause t.1%PAIR [::] t.2%PAIR [::]. + +Lemma oclause_leq_elim4 bc oc : oc \in (oclause_leq_elim bc) -> oc.4 == [::]. +Proof. +case: bc => bc1 bc2 bc3 bc4; elim: bc4 bc1 bc3 oc => [|t bc4 ih] bc1 bc3 /= oc. + by rewrite inE; move/eqP; case: oc => ? ? ? oc4 /=; case=> _ _ _ /eqP. +rewrite map_cat; move: (ih bc1 bc3 oc) => /= {ih}. +elim: (leq_elim_aux bc1 bc3 bc4) => [| t2 l2 ih2] //= ih1. +rewrite in_cons; case/orP. + by move/eqP; case: oc {ih1 ih2} => ? ? ? ? [] /= _ _ _ /eqP. +rewrite mem_cat; case/orP=> [hoc1|]. + apply: ih2; first by move=> hoc2; apply: ih1; rewrite in_cons hoc2 orbT. + by rewrite mem_cat hoc1. +rewrite in_cons; case/orP=> [| hoc1]. + by move/eqP; case: {ih1 ih2} oc=> ? ? ? ? [] /= _ _ _ /eqP. +apply: ih2; first by move=> hoc2; apply: ih1; rewrite in_cons hoc2 orbT. +by rewrite mem_cat hoc1 orbT. +Qed. + +Lemma oclause_neq_elim2 bc oc : + oc \in (oclause_neq_elim bc) -> (oc.2 == [::]) && (oc.4 == bc.4). +Proof. +case: bc => bc1 bc2 bc3 bc4; elim: bc2 bc4 oc => [|t bc2 /= ih] bc4 /= oc. + by rewrite inE; move/eqP; case: oc => ? ? ? oc4 /=; case=> _ /eqP -> _ /eqP. +rewrite map_cat; move: (ih bc4 oc) => /= {ih}. +elim: (neq_elim_aux bc3 bc2) => [| t2 l2 ih2] //= ih1. +rewrite in_cons; case/orP. + by move/eqP; case: oc {ih1 ih2} => ? ? ? ? [] /= _ -> _ ->; rewrite !eqxx. +rewrite mem_cat; case/orP=> [hoc1|]. + apply: ih2; first by move=> hoc2; apply: ih1; rewrite in_cons hoc2 orbT. + by rewrite mem_cat hoc1. +rewrite in_cons; case/orP=> [| hoc1]. + by move/eqP; case: {ih1 ih2} oc=> ? ? ? ? [] /= _ -> _ ->; rewrite !eqxx. +apply: ih2; first by move=> hoc2; apply: ih1; rewrite in_cons hoc2 orbT. +by rewrite mem_cat hoc1 orbT. +Qed. + +Lemma oclause_to_wP e bc : + holds e (odnf_to_oform (oclause_neq_leq_elim bc)) <-> + holds e (odnf_to_oform (map w_to_oclause (oclause_to_w bc))). +Proof. +rewrite /oclause_to_w /oclause_neq_leq_elim. +move: (@oclause_leq_elim4 bc). +elim: (oclause_leq_elim bc) => [| t1 l1 ih1] //= h4. +rewrite !map_cat !odnf_to_oform_cat. +rewrite -[holds e (_ \/ _)]/(holds e _ \/ holds e _). +suff <- : (oclause_neq_elim t1) = map w_to_oclause + [seq (let: Oclause eq_l _ lt_l _ := x in (eq_l, lt_l)) + | x <- oclause_neq_elim t1]. + by rewrite ih1 //; move=> oc hoc; apply: h4; rewrite in_cons hoc orbT. +have : forall oc, oc \in (oclause_neq_elim t1) -> oc.2 = [::] /\ oc.4 = [::]. + move=> oc hoc; move/oclause_neq_elim2: (hoc); case/andP=> /eqP -> /eqP ->. + by move/eqP: (h4 _ (mem_head _ _))->. +elim: (oclause_neq_elim t1) => [| [teq1 tneq1 tleq1 tlt1] l2 ih2] h24 //=. +rewrite /w_to_oclause /=; move: (h24 _ (mem_head _ _ ))=> /= [] -> ->. +by congr (_ :: _); apply: ih2 => oc hoc; apply: h24; rewrite in_cons hoc orbT. +Qed. + +Variable wproj : nat -> (seq (term R) * seq (term R)) -> formula R. + +Definition proj (n : nat)(oc : oclause R) := + foldr Or False (map (wproj n) (oclause_to_w oc)). + +Hypothesis wf_QE_wproj : forall i bc (bc_i := wproj i bc), + dnf_rterm (w_to_oclause bc) -> qf_form bc_i && rformula bc_i. + +Lemma dnf_rterm_subproof bc : dnf_rterm bc -> + all (dnf_rterm \o w_to_oclause) (oclause_to_w bc). +Proof. +case: bc => leq lneql llt lle; rewrite /dnf_rterm /=; case/and4P=> req rneq rlt rle. +rewrite /oclause_to_w /= !all_map. +apply/allP => [] [oc_eq oc_neq oc_le oc_lt] hoc; rewrite /dnf_rterm /= andbT. +rewrite -all_cat; apply/allP=> u hu; move/terms_of_neq_leq_elim: hoc => /=. +move/(_ u); rewrite !mem_cat. +have {hu} hu : [|| u \in oc_eq, u \in oc_neq, u \in oc_le | u \in oc_lt]. + by move: hu; rewrite mem_cat; case/orP=> ->; rewrite ?orbT. +move/(_ hu); case/orP; last first. + move: rneq. + have <- : (all (@rterm R) (map Opp lneql)) = all (@rterm R) lneql. + by elim: lneql => [| t l] //= ->. + by move/allP; apply. +case/orP; first by apply: (allP req). +case/orP; first by apply: (allP rneq). +case/orP; first by apply: (allP rlt). +exact: (allP rle). +Qed. + + +Lemma wf_QE_proj i : forall bc (bc_i := proj i bc), + dnf_rterm bc -> qf_form bc_i && rformula bc_i. +Proof. +case=> leq lneql llt lle /= hdnf; move: (hdnf). +rewrite /dnf_rterm /=; case/and4P=> req rneq rlt rle; rewrite /proj; apply/andP. +move: (dnf_rterm_subproof hdnf). +elim: (oclause_to_w _ ) => //= [a t] ih /andP [h1 h2]. +by case: (ih h2)=> -> ->; case/andP: (wf_QE_wproj i h1) => -> ->. +Qed. + +Hypothesis valid_QE_wproj : + forall i bc (bc' := w_to_oclause bc) + (ex_i_bc := ('exists 'X_i, odnf_to_oform [:: bc'])%oT) e, + dnf_rterm bc' -> + reflect (holds e ex_i_bc) (qf_eval e (wproj i bc)). + +Lemma valid_QE_proj e i : forall bc (bc_i := proj i bc) + (ex_i_bc := ('exists 'X_i, odnf_to_oform [:: bc])%oT), + dnf_rterm bc -> reflect (holds e ex_i_bc) (qf_eval e (proj i bc)). +Proof. +move=> bc; rewrite /dnf_rterm => hdnf; rewrite /proj; apply: (equivP idP). +have -> : holds e ('exists 'X_i, odnf_to_oform [:: bc]) <-> + (exists x : R, holds (set_nth 0 e i x) + (odnf_to_oform (oclause_neq_leq_elim bc))). + split; case=> x h; exists x; first by rewrite -oclause_neq_leq_elimP. + by rewrite oclause_neq_leq_elimP. +have -> : + (exists x : R, + holds (set_nth 0 e i x) (odnf_to_oform (oclause_neq_leq_elim bc))) <-> + (exists x : R, + holds (set_nth 0 e i x) (odnf_to_oform (map w_to_oclause (oclause_to_w bc)))). + by split; case=> x; move/oclause_to_wP=> h; exists x. +move: (dnf_rterm_subproof hdnf). +rewrite /oclause_to_w; elim: (oclause_neq_leq_elim bc) => /= [|a l ih]. + by split=> //; case. +case/andP=> h1 h2; have {ih h2} ih := (ih h2); split. +- case/orP. + move/(valid_QE_wproj i e h1)=> /= [x /=] [] // [] h2 [] _ [] h3 _; exists x. + by left. + by case/ih => x h; exists x; right. +- case=> x [] /=. + + case=> h2 [] _ h3; apply/orP; left; apply/valid_QE_wproj => //=. + by exists x; left. + + by move=> hx; apply/orP; right; apply/ih; exists x. +Qed. + +Let elim_aux f n := foldr Or False (map (proj n) (qf_to_odnf f false)). + +Fixpoint quantifier_elim f := + match f with + | f1 /\ f2 => (quantifier_elim f1) /\ (quantifier_elim f2) + | f1 \/ f2 => (quantifier_elim f1) \/ (quantifier_elim f2) + | f1 ==> f2 => (~ quantifier_elim f1) \/ (quantifier_elim f2) + | ~ f => ~ quantifier_elim f + | ('exists 'X_n, f) => elim_aux (quantifier_elim f) n + | ('forall 'X_n, f) => ~ elim_aux (~ quantifier_elim f) n + | _ => f + end%oT. + +Lemma quantifier_elim_wf f : + let qf := quantifier_elim f in rformula f -> qf_form qf && rformula qf. +Proof. +suffices aux_wf f0 n : let qf := elim_aux f0 n in + rformula f0 -> qf_form qf && rformula qf. +- by elim: f => //=; do ?[ move=> f1 IH1 f2 IH2; + case/andP=> rf1 rf2; + case/andP:(IH1 rf1)=> -> ->; + case/andP:(IH2 rf2)=> -> -> // + | move=> n f1 IH rf1; + case/andP: (IH rf1)=> qff rf; + rewrite aux_wf ]. +rewrite /elim_aux => rf. +suffices or_wf fs : let ofs := foldr Or False fs in + all qf_form fs && all rformula fs -> qf_form ofs && rformula ofs. +- apply: or_wf. + suffices map_proj_wf bcs: let mbcs := map (proj n) bcs in + all dnf_rterm bcs -> all qf_form mbcs && all rformula mbcs. + by apply: map_proj_wf; exact: qf_to_dnf_rterm. + elim: bcs => [|bc bcs ihb] bcsr //= /andP[rbc rbcs]. + by rewrite andbAC andbA wf_QE_proj //= andbC ihb. +elim: fs => //= g gs ihg; rewrite -andbA => /and4P[-> qgs -> rgs] /=. +by apply: ihg; rewrite qgs rgs. +Qed. + +Lemma quantifier_elim_rformP e f : + rformula f -> reflect (holds e f) (qf_eval e (quantifier_elim f)). +Proof. +pose rc e n f := exists x, qf_eval (set_nth 0 e n x) f. +have auxP f0 e0 n0: qf_form f0 && rformula f0 -> + reflect (rc e0 n0 f0) (qf_eval e0 (elim_aux f0 n0)). ++ rewrite /elim_aux => cf; set bcs := qf_to_odnf f0 false. + apply: (@iffP (rc e0 n0 (odnf_to_oform bcs))); last first. + - by case=> x; rewrite -qf_to_dnfP //; exists x. + - by case=> x; rewrite qf_to_dnfP //; exists x. + have: all dnf_rterm bcs by case/andP: cf => _; exact: qf_to_dnf_rterm. + elim: {f0 cf}bcs => [|bc bcs IHbcs] /=; first by right; case. + case/andP=> r_bc /IHbcs {IHbcs}bcsP. + have f_qf := dnf_to_form_qf [:: bc]. + case: valid_QE_proj => //= [ex_x|no_x]. + left; case: ex_x => x /(qf_evalP _ f_qf); rewrite /= orbF => bc_x. + by exists x; rewrite /= bc_x. + apply: (iffP bcsP) => [[x bcs_x] | [x]] /=. + by exists x; rewrite /= bcs_x orbT. + case/orP => [bc_x|]; last by exists x. + by case: no_x; exists x; apply/(qf_evalP _ f_qf); rewrite /= bc_x. +elim: f e => //. +- move=> b e _; exact: idP. +- move=> t1 t2 e _; exact: eqP. +- move=> t1 t2 e _; exact: idP. +- move=> t1 t2 e _; exact: idP. +- move=> f1 IH1 f2 IH2 e /= /andP[/IH1[] f1e]; last by right; case. + by case/IH2; [left | right; case]. +- move=> f1 IH1 f2 IH2 e /= /andP[/IH1[] f1e]; first by do 2!left. + by case/IH2; [left; right | right; case]. +- move=> f1 IH1 f2 IH2 e /= /andP[/IH1[] f1e]; last by left. + by case/IH2; [left | right; move/(_ f1e)]. +- by move=> f IHf e /= /IHf[]; [right | left]. +- move=> n f IHf e /= rf; have rqf := quantifier_elim_wf rf. + by apply: (iffP (auxP _ _ _ rqf)) => [] [x]; exists x; exact/IHf. +move=> n f IHf e /= rf; have rqf := quantifier_elim_wf rf. +case: auxP => // [f_x|no_x]; first by right=> no_x; case: f_x => x /IHf[]. +by left=> x; apply/IHf=> //; apply/idPn=> f_x; case: no_x; exists x. +Qed. + +Definition proj_sat e f := qf_eval e (quantifier_elim (to_rform f)). + +Lemma proj_satP : forall e f, reflect (holds e f) (proj_sat e f). +Proof. +move=> e f; have fP := quantifier_elim_rformP e (to_rform_rformula f). +by apply: (iffP fP); move/to_rformP. +Qed. + +End EvalTerm. + +End ord. \ No newline at end of file diff --git a/mathcomp/real_closed/polyorder.v b/mathcomp/real_closed/polyorder.v new file mode 100644 index 0000000..be4b7cc --- /dev/null +++ b/mathcomp/real_closed/polyorder.v @@ -0,0 +1,273 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype. +Require Import ssralg poly ssrnum zmodp polydiv interval. + +Import GRing.Theory. +Import Num.Theory. + +Import Pdiv.Idomain. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope ring_scope. + +Section Multiplicity. + +Variable R : idomainType. +Implicit Types x y c : R. +Implicit Types p q r d : {poly R}. + +(* Definition multiplicity (x : R) (p : {poly R}) : nat := *) +(* (odflt ord0 (pick (fun i : 'I_(size p).+1 => ((('X - x%:P) ^+ i %| p)) *) +(* && (~~ (('X - x%:P) ^+ i.+1 %| p))))). *) + +(* Notation "'\mu_' x" := (multiplicity x) *) +(* (at level 8, format "'\mu_' x") : ring_scope. *) + +(* Lemma mu0 : forall x, \mu_x 0 = 0%N. *) +(* Proof. *) +(* by move=> x; rewrite /multiplicity; case: pickP=> //= i; rewrite !dvdp0. *) +(* Qed. *) + +(* Lemma muP : forall p x, p != 0 -> *) +(* (('X - x%:P) ^+ (\mu_x p) %| p) && ~~(('X - x%:P) ^+ (\mu_x p).+1 %| p). *) +(* Proof. *) +(* move=> p x np0; rewrite /multiplicity; case: pickP=> //= hp. *) +(* have {hp} hip: forall i, i <= size p *) +(* -> (('X - x%:P) ^+ i %| p) -> (('X - x%:P) ^+ i.+1 %| p). *) +(* move=> i; rewrite -ltnS=> hi; move/negbT: (hp (Ordinal hi)). *) +(* by rewrite -negb_imply negbK=> /implyP. *) +(* suff: forall i, i <= size p -> ('X - x%:P) ^+ i %| p. *) +(* move=> /(_ _ (leqnn _)) /(size_dvdp np0). *) +(* rewrite -[size _]prednK; first by rewrite size_exp size_XsubC mul1n ltnn. *) +(* by rewrite lt0n size_poly_eq0 expf_eq0 polyXsubC_eq0 lt0n size_poly_eq0 np0. *) +(* elim=> [|i ihi /ltnW hsp]; first by rewrite expr0 dvd1p. *) +(* by rewrite hip // ihi. *) +(* Qed. *) + +(* Lemma cofactor_XsubC : forall p a, p != 0 -> *) +(* exists2 q : {poly R}, (~~ root q a) & p = q * ('X - a%:P) ^+ (\mu_a p). *) +(* Proof. *) +(* move=> p a np0. *) + +Definition multiplicity (x : R) (p : {poly R}) := + if p == 0 then 0%N else sval (multiplicity_XsubC p x). + +Notation "'\mu_' x" := (multiplicity x) + (at level 8, format "'\mu_' x") : ring_scope. + +Lemma mu_spec p a : p != 0 -> + { q : {poly R} & (~~ root q a) + & ( p = q * ('X - a%:P) ^+ (\mu_a p)) }. +Proof. +move=> nz_p; rewrite /multiplicity -if_neg. +by case: (_ p a) => m /=/sig2_eqW[q]; rewrite nz_p; exists q. +Qed. + +Lemma mu0 x : \mu_x 0 = 0%N. +Proof. by rewrite /multiplicity {1}eqxx. Qed. + +Lemma root_mu p x : ('X - x%:P) ^+ (\mu_x p) %| p. +Proof. +case p0: (p == 0); first by rewrite (eqP p0) mu0 expr0 dvd1p. +case: (@mu_spec p x); first by rewrite p0. +by move=> q qn0 hp //=; rewrite {2}hp dvdp_mulIr. +Qed. + +(* Lemma size_exp_XsubC : forall x n, size (('X - x%:P) ^+ n) = n.+1. *) +(* Proof. *) +(* move=> x n; rewrite -[size _]prednK ?size_exp ?size_XsubC ?mul1n //. *) +(* by rewrite ltnNge leqn0 size_poly_eq0 expf_neq0 // polyXsubC_eq0. *) +(* Qed. *) + +Lemma root_muN p x : p != 0 -> + (('X - x%:P)^+(\mu_x p).+1 %| p) = false. +Proof. +move=> pn0; case: (mu_spec x pn0)=> q qn0 hp /=. +rewrite {2}hp exprS dvdp_mul2r; last first. + by rewrite expf_neq0 // polyXsubC_eq0. +apply: negbTE; rewrite -eqp_div_XsubC; apply: contra qn0. +by move/eqP->; rewrite rootM root_XsubC eqxx orbT. +Qed. + +Lemma root_le_mu p x n : p != 0 -> ('X - x%:P)^+n %| p = (n <= \mu_x p)%N. +Proof. +move=> pn0; case: leqP=> hn; last apply/negP=> hp. + apply: (@dvdp_trans _ (('X - x%:P) ^+ (\mu_x p))); last by rewrite root_mu. + by rewrite dvdp_Pexp2l // size_XsubC. +suff : ('X - x%:P) ^+ (\mu_x p).+1 %| p by rewrite root_muN. +by apply: dvdp_trans hp; rewrite dvdp_Pexp2l // size_XsubC. +Qed. + +Lemma muP p x n : p != 0 -> + (('X - x%:P)^+n %| p) && ~~(('X - x%:P)^+n.+1 %| p) = (n == \mu_x p). +Proof. +move=> hp0; rewrite !root_le_mu//; case: (ltngtP n (\mu_x p))=> hn. ++ by rewrite ltnW//=. ++ by rewrite leqNgt hn. ++ by rewrite hn leqnn. +Qed. + +Lemma mu_gt0 p x : p != 0 -> (0 < \mu_x p)%N = root p x. +Proof. by move=> pn0; rewrite -root_le_mu// expr1 root_factor_theorem. Qed. + +Lemma muNroot p x : ~~ root p x -> \mu_x p = 0%N. +Proof. +case p0: (p == 0); first by rewrite (eqP p0) rootC eqxx. +by move=> pnx0; apply/eqP; rewrite -leqn0 leqNgt mu_gt0 ?p0. +Qed. + +Lemma mu_polyC c x : \mu_x (c%:P) = 0%N. +Proof. +case c0: (c == 0); first by rewrite (eqP c0) mu0. +by apply: muNroot; rewrite rootC c0. +Qed. + +Lemma cofactor_XsubC_mu x p n : + ~~ root p x -> \mu_x (p * ('X - x%:P) ^+ n) = n. +Proof. +move=> p0; apply/eqP; rewrite eq_sym -muP//; last first. + apply: contra p0; rewrite mulf_eq0 expf_eq0 polyXsubC_eq0 andbF orbF. + by move/eqP->; rewrite root0. +rewrite dvdp_mulIr /= exprS dvdp_mul2r -?root_factor_theorem //. +by rewrite expf_eq0 polyXsubC_eq0 andbF //. +Qed. + +Lemma mu_mul p q x : p * q != 0 -> + \mu_x (p * q) = (\mu_x p + \mu_x q)%N. +Proof. +move=>hpqn0; apply/eqP; rewrite eq_sym -muP//. +rewrite exprD dvdp_mul ?root_mu//=. +move:hpqn0; rewrite mulf_eq0 negb_or; case/andP=> hp0 hq0. +move: (mu_spec x hp0)=> [qp qp0 hp]. +move: (mu_spec x hq0)=> [qq qq0 hq]. +rewrite {2}hp {2}hq exprS exprD !mulrA [qp * _ * _]mulrAC. +rewrite !dvdp_mul2r ?expf_neq0 ?polyXsubC_eq0 // -eqp_div_XsubC. +move: (mulf_neq0 qp0 qq0); rewrite -hornerM; apply: contra; move/eqP->. +by rewrite hornerM hornerXsubC subrr mulr0. +Qed. + +Lemma mu_XsubC x : \mu_x ('X - x%:P) = 1%N. +Proof. +apply/eqP; rewrite eq_sym -muP; last by rewrite polyXsubC_eq0. +by rewrite expr1 dvdpp/= -{2}[_ - _]expr1 dvdp_Pexp2l // size_XsubC. +Qed. + +Lemma mu_mulC c p x : c != 0 -> \mu_x (c *: p) = \mu_x p. +Proof. +move=> cn0; case p0: (p == 0); first by rewrite (eqP p0) scaler0. +by rewrite -mul_polyC mu_mul ?mu_polyC// mulf_neq0 ?p0 ?polyC_eq0. +Qed. + +Lemma mu_opp p x : \mu_x (-p) = \mu_x p. +Proof. +rewrite -mulN1r -polyC1 -polyC_opp mul_polyC mu_mulC //. +by rewrite -oppr0 (inj_eq (inv_inj (@opprK _))) oner_eq0. +Qed. + +Lemma mu_exp p x n : \mu_x (p ^+ n) = (\mu_x p * n)%N. +Proof. +elim: n p => [|n ihn] p; first by rewrite expr0 mu_polyC muln0. +case p0: (p == 0); first by rewrite (eqP p0) exprS mul0r mu0 mul0n. +by rewrite exprS mu_mul ?ihn ?mulnS// mulf_eq0 expf_eq0 p0 andbF. +Qed. + +Lemma mu_addr p q x : p != 0 -> (\mu_x p < \mu_x q)%N -> + \mu_x (p + q) = \mu_x p. +Proof. +move=> pn0 mupq. +have pqn0 : p + q != 0. + move: mupq; rewrite ltnNge; apply: contra. + by rewrite -[q]opprK subr_eq0; move/eqP->; rewrite opprK mu_opp leqnn. +have qn0: q != 0 by move: mupq; apply: contraL; move/eqP->; rewrite mu0 ltn0. +case: (mu_spec x pn0)=> [qqp qqp0] hp. +case: (mu_spec x qn0)=> [qqq qqq0] hq. +rewrite hp hq -(subnK (ltnW mupq)). +rewrite mu_mul ?mulf_eq0; last first. + rewrite expf_eq0 polyXsubC_eq0 andbF orbF. + by apply: contra qqp0; move/eqP->; rewrite root0. +rewrite mu_exp mu_XsubC mul1n [\mu_x qqp]muNroot // add0n. +rewrite exprD mulrA -mulrDl mu_mul; last first. + by rewrite mulrDl -mulrA -exprD subnK 1?ltnW // -hp -hq. +rewrite muNroot ?add0n ?mu_exp ?mu_XsubC ?mul1n //. +rewrite rootE !hornerE horner_exp hornerXsubC subrr. +by rewrite -subnSK // subnS exprS mul0r mulr0 addr0. +Qed. + +Lemma mu_addl p q x : q != 0 -> (\mu_x p > \mu_x q)%N -> + \mu_x (p + q) = \mu_x q. +Proof. by move=> q0 hmu; rewrite addrC mu_addr. Qed. + +Lemma mu_div p x n : (n <= \mu_x p)%N -> + \mu_x (p %/ ('X - x%:P) ^+ n) = (\mu_x p - n)%N. +Proof. +move=> hn. +case p0: (p == 0); first by rewrite (eqP p0) div0p mu0 sub0n. +case: (@mu_spec p x); rewrite ?p0 // => q hq hp. +rewrite {1}hp -{1}(subnK hn) exprD mulrA. +rewrite Pdiv.IdomainMonic.mulpK; last by apply: monic_exp; exact: monicXsubC. +rewrite mu_mul ?mulf_eq0 ?expf_eq0 ?polyXsubC_eq0 ?andbF ?orbF; last first. + by apply: contra hq; move/eqP->; rewrite root0. +by rewrite mu_exp muNroot // add0n mu_XsubC mul1n. +Qed. + +End Multiplicity. + +Notation "'\mu_' x" := (multiplicity x) + (at level 8, format "'\mu_' x") : ring_scope. + + +Section PolyrealIdomain. + + (*************************************************************************) + (* This should be replaced by a 0-characteristic condition + integrality *) + (* and merged into poly and polydiv *) + (*************************************************************************) + +Variable R : realDomainType. + +Lemma size_deriv (p : {poly R}) : size p^`() = (size p).-1. +Proof. +have [lep1|lt1p] := leqP (size p) 1. + by rewrite {1}[p]size1_polyC // derivC size_poly0 -subn1 (eqnP lep1). +rewrite size_poly_eq // mulrn_eq0 -subn2 -subSn // subn2. +by rewrite lead_coef_eq0 -size_poly_eq0 -(subnKC lt1p). +Qed. + +Lemma derivn_poly0 : forall (p : {poly R}) n, (size p <= n)%N = (p^`(n) == 0). +Proof. +move=> p n; apply/idP/idP. + move=> Hpn; apply/eqP; apply/polyP=>i; rewrite coef_derivn. + rewrite nth_default; first by rewrite mul0rn coef0. + by apply: leq_trans Hpn _; apply leq_addr. +elim: n {-2}n p (leqnn n) => [m | n ihn [| m]] p. +- by rewrite leqn0; move/eqP->; rewrite derivn0 leqn0 -size_poly_eq0. +- by move=> _; apply: ihn; rewrite leq0n. +- rewrite derivSn => hmn hder; case e: (size p) => [|sp] //. + rewrite -(prednK (ltn0Sn sp)) [(_.-1)%N]lock -e -lock -size_deriv ltnS. + exact: ihn. +Qed. + +Lemma mu_deriv : forall x (p : {poly R}), root p x -> + \mu_x (p^`()) = (\mu_x p - 1)%N. +Proof. +move=> x p px0; have [-> | nz_p] := eqVneq p 0; first by rewrite derivC mu0. +have [q nz_qx Dp] := mu_spec x nz_p. +case Dm: (\mu_x p) => [|m]; first by rewrite Dp Dm mulr1 (negPf nz_qx) in px0. +rewrite subn1 Dp Dm !derivCE exprS mul1r mulrnAr -mulrnAl mulrA -mulrDl. +rewrite cofactor_XsubC_mu // rootE !(hornerE, hornerMn) subrr mulr0 add0r. +by rewrite mulrn_eq0. +Qed. + +Lemma mu_deriv_root : forall x (p : {poly R}), p != 0 -> root p x -> + \mu_x p = (\mu_x (p^`()) + 1)%N. +Proof. +by move=> x p p0 rpx; rewrite mu_deriv // subn1 addn1 prednK // mu_gt0. +Qed. + +End PolyrealIdomain. + + + diff --git a/mathcomp/real_closed/polyrcf.v b/mathcomp/real_closed/polyrcf.v new file mode 100644 index 0000000..b49e729 --- /dev/null +++ b/mathcomp/real_closed/polyrcf.v @@ -0,0 +1,1857 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype. +Require Import bigop ssralg poly polydiv ssrnum zmodp. +Require Import polyorder path interval ssrint. + +(****************************************************************************) +(* This files contains basic (and unformatted) theory for polynomials *) +(* over a realclosed fields. From the IVT (contained in the rcfType *) +(* structure), we derive Rolle's Theorem, the Mean Value Theorem, a root *) +(* isolation procedure and the notion of neighborhood. *) +(* *) +(* sgp_minfty p == the sign of p in -oo *) +(* sgp_pinfty p == the sign of p in +oo *) +(* cauchy_bound p == the cauchy bound of p *) +(* (this strictly bounds the norm of roots of p) *) +(* roots p a b == the ordered list of roots of p in `[a, b] *) +(* defaults to [::] when p == 0 *) +(* rootsR p == the ordered list of all roots of p, ([::] if p == 0). *) +(* next_root p x b == the smallest root of p contained in `[x, maxn x b] *) +(* if p has no root on `[x, maxn x b], we pick maxn x b. *) +(* prev_root p x a == the smallest root of p contained in `[minn x a, x] *) +(* if p has no root on `[minn x a, x], we pick minn x a. *) +(* neighpr p a b := `]a, next_root p a b[. *) +(* == an open interval of the form `]a, x[, with x <= b *) +(* in which p has no root. *) +(* neighpl p a b := `]prev_root p a b, b[. *) +(* == an open interval of the form `]x, b[, with a <= x *) +(* in which p has no root. *) +(* sgp_right p a == the sign of p on the right of a. *) +(****************************************************************************) + + +Import GRing.Theory Num.Theory Num.Def. +Import Pdiv.Idomain. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope nat_scope. +Local Open Scope ring_scope. + +Local Notation noroot p := (forall x, ~~ root p x). +Local Notation mid x y := ((x + y) / 2%:R). + +Section more. +Section SeqR. + +Lemma last1_neq0 : forall (R : ringType) (s: seq R) (c:R), c != 0 -> + (last c s != 0) = (last 1 s != 0). +Proof. by move=> R'; elim=> [|t s ihs] c cn0 //; rewrite oner_eq0 cn0. Qed. + +End SeqR. + +Section poly. +Import Pdiv.Ring Pdiv.ComRing. + +Variable R : idomainType. + +Implicit Types p q : {poly R}. + +Lemma lead_coefDr p q : + (size q > size p)%N -> lead_coef (p + q) = lead_coef q. +Proof. by move/lead_coefDl<-; rewrite addrC. Qed. + +Lemma leq1_size_polyC (c : R) : (size c%:P <= 1)%N. +Proof. by rewrite size_polyC; case: (c == 0). Qed. + +Lemma my_size_exp p n : p != 0 -> + (size (p ^+ n)) = ((size p).-1 * n).+1%N. +Proof. +by move=> hp; rewrite -size_exp prednK // lt0n size_poly_eq0 expf_neq0. +Qed. + +Lemma coef_comp_poly p q n : + (p \Po q)`_n = \sum_(i < size p) p`_i * (q ^+ i)`_n. +Proof. +rewrite comp_polyE coef_sum. +by elim/big_ind2: _ => [//|? ? ? ? -> -> //|i]; rewrite coefZ. +Qed. + +Lemma gt_size_poly p n : (size p > n)%N -> p != 0. +Proof. +by move=> h; rewrite -size_poly_eq0 lt0n_neq0 //; apply: leq_ltn_trans h. +Qed. + +Lemma lead_coef_comp_poly p q : (size q > 1)%N -> + lead_coef (p \Po q) = (lead_coef p) * (lead_coef q) ^+ (size p).-1. +Proof. +move=> sq; rewrite !lead_coefE coef_comp_poly size_comp_poly. +case hp: (size p) => [|n]. + move/eqP: hp; rewrite size_poly_eq0 => /eqP ->. + by rewrite big_ord0 coef0 mul0r. +rewrite big_ord_recr /= big1 => [|i _]. + by rewrite add0r -lead_coefE -lead_coef_exp lead_coefE size_exp mulnC. +rewrite [X in _ * X]nth_default ?mulr0 ?(leq_trans (size_exp_leq _ _)) //. +by rewrite mulnC ltn_mul2r -subn1 subn_gt0 sq /=. +Qed. + +End poly. +End more. + +(******************************************************************) +(* Definitions and properties for polynomials in a numDomainType. *) +(******************************************************************) +Section PolyNumDomain. + +Variable R : numDomainType. +Implicit Types (p q : {poly R}). + +Definition sgp_pinfty (p : {poly R}) := sgr (lead_coef p). +Definition sgp_minfty (p : {poly R}) := + sgr ((-1) ^+ (size p).-1 * (lead_coef p)). + +End PolyNumDomain. + +(******************************************************************) +(* Definitions and properties for polynomials in a realFieldType. *) +(******************************************************************) +Section PolyRealField. + +Variable R : realFieldType. +Implicit Types (p q : {poly R}). + +Section SgpInfty. + +Lemma sgp_pinfty_sym p : sgp_pinfty (p \Po -'X) = sgp_minfty p. +Proof. +rewrite /sgp_pinfty /sgp_minfty lead_coef_comp_poly ?size_opp ?size_polyX //. +by rewrite lead_coef_opp lead_coefX mulrC. +Qed. + +Lemma poly_pinfty_gt_lc p : lead_coef p > 0 -> + exists n, forall x, x >= n -> p.[x] >= lead_coef p. +Proof. +elim/poly_ind: p => [| q c IHq]; first by rewrite lead_coef0 ltrr. +have [->|q_neq0] := eqVneq q 0. + by rewrite mul0r add0r lead_coefC => c_gt0; exists 0 => x _; rewrite hornerC. +rewrite lead_coefDl ?size_mul ?polyX_eq0 // ?lead_coefMX; last first. + rewrite size_polyX addn2 size_polyC /= ltnS. + by rewrite (leq_trans (leq_b1 _)) // size_poly_gt0. +move=> lq_gt0; have [y Hy] := IHq lq_gt0. +pose z := (1 + (lead_coef q) ^-1 * `|c|); exists (maxr y z) => x. +have z_gt0 : 0 < z by rewrite ltr_spaddl ?ltr01 ?mulr_ge0 ?invr_ge0 // ltrW. +rewrite !hornerE ler_maxl => /andP[/Hy Hq Hc]. +rewrite (@ler_trans _ (lead_coef q * z + c)) //; last first. + rewrite ler_add2r (@ler_trans _ (q.[x] * z)) // ?ler_pmul2r //. + by rewrite ler_pmul2l // (ltr_le_trans _ Hq). +rewrite mulrDr mulr1 -addrA ler_addl mulVKf ?gtr_eqF //. +by rewrite -[c]opprK subr_ge0 normrN ler_norm. +Qed. + +(* :REMARK: not necessary here ! *) +Lemma poly_lim_infty p m : lead_coef p > 0 -> (size p > 1)%N -> + exists n, forall x, x >= n -> p.[x] >= m. +Proof. +elim/poly_ind: p m => [| q c _] m; first by rewrite lead_coef0 ltrr. +have [-> _|q_neq0] := eqVneq q 0. + by rewrite mul0r add0r size_polyC ltnNge leq_b1. +rewrite lead_coefDl ?size_mul ?polyX_eq0 // ?lead_coefMX; last first. + rewrite size_polyX addn2 size_polyC /= ltnS. + by rewrite (leq_trans (leq_b1 _)) // size_poly_gt0. +move=> lq_gt0; have [y Hy _] := poly_pinfty_gt_lc lq_gt0. +pose z := (1 + (lead_coef q) ^-1 * (`|m| + `|c|)); exists (maxr y z) => x. +have z_gt0 : 0 < z. + by rewrite ltr_spaddl ?ltr01 ?mulr_ge0 ?invr_ge0 ?addr_ge0 // ?ltrW. +rewrite !hornerE ler_maxl => /andP[/Hy Hq Hc]. +rewrite (@ler_trans _ (lead_coef q * z + c)) //; last first. + rewrite ler_add2r (@ler_trans _ (q.[x] * z)) // ?ler_pmul2r //. + by rewrite ler_pmul2l // (ltr_le_trans _ Hq). +rewrite mulrDr mulr1 mulVKf ?gtr_eqF // addrA -addrA ler_paddr //. + by rewrite -[c]opprK subr_ge0 normrN ler_norm. +by rewrite ler_paddl ?ler_norm // ?ltrW. +Qed. + +End SgpInfty. + +Section CauchyBound. + +Definition cauchy_bound (p : {poly R}) := + 1 + `|lead_coef p|^-1 * \sum_(i < size p) `|p`_i|. + +(* Could be a sharp bound, and proof should shrink... *) +Lemma cauchy_boundP : forall (p : {poly R}) x, + p != 0 -> p.[x] = 0 -> `| x | < cauchy_bound p. +Proof. +move=> p x np0 rpx; rewrite ltr_spaddl ?ltr01 //. +case e: (size p) => [|n]; first by move: np0; rewrite -size_poly_eq0 e eqxx. +have lcp : `|lead_coef p| > 0 by move: np0; rewrite -lead_coef_eq0 -normr_gt0. +have lcn0 : `|lead_coef p| != 0 by rewrite normr_eq0 -normr_gt0. +case: (lerP `|x| 1) => cx1. + rewrite (ler_trans cx1) // /cauchy_bound ler_pdivl_mull // mulr1. + by rewrite big_ord_recr /= /lead_coef e ler_addr sumr_ge0. +case es: n e => [|m] e. + suff p0 : p = 0 by rewrite p0 eqxx in np0. + by move: rpx; rewrite (@size1_polyC _ p) ?e ?lerr // hornerC; move->. +move: rpx; rewrite horner_coef e -es big_ord_recr /=; move/eqP; rewrite eq_sym. +rewrite -subr_eq sub0r; move/eqP => h1. +have {h1} h1 : `|p`_n| * `|x| ^+ n <= \sum_(i < n) `|p`_i * x ^+ i|. + rewrite -normrX -normrM -normrN h1. + by rewrite (ler_trans (ler_norm_sum _ _ _)) // lerr. +have xp : `| x | > 0 by rewrite (ltr_trans _ cx1) ?ltr01. +move: h1; rewrite {-1}es exprS mulrA -ler_pdivl_mulr ?exprn_gt0 // big_distrl /=. +rewrite big_ord_recr /= normrM normrX -mulrA es mulfV; last first. + by rewrite expf_eq0 negb_and eq_sym (ltr_eqF xp) orbT. +have pnp : 0 < `|p`_n| by move: lcp; rewrite /lead_coef e es. +rewrite mulr1 -es mulrC -ler_pdivl_mulr //. +rewrite [_ / _]mulrC /cauchy_bound /lead_coef e -es /=. +move=> h1; apply: (ler_trans h1) => //. +rewrite ler_pmul2l ?invr_gt0 ?(ltrW pnp) // big_ord_recr /=. +rewrite es [_ + `|p`_m.+1|]addrC ler_paddl // ?normr_ge0 //. +rewrite big_ord_recr /= ler_add2r; apply: ler_sum => i. +rewrite normrM normrX. +rewrite -mulrA ler_pimulr ?normrE // ler_pdivr_mulr ?exprn_gt0 // mul1r. +by rewrite ler_eexpn2l // 1?ltrW //; case: i=> i hi /=; rewrite ltnW. +(* this could be improved a little bit with int exponents *) +Qed. + +Lemma le_cauchy_bound p : p != 0 -> {in `]-oo, (- cauchy_bound p)], noroot p}. +Proof. +move=> p_neq0 x; rewrite inE /= lerNgt; apply: contra => /rootP. +by move=> /(cauchy_boundP p_neq0) /ltr_normlP []; rewrite ltr_oppl. +Qed. +Hint Resolve le_cauchy_bound. + +Lemma ge_cauchy_bound p : p != 0 -> {in `[cauchy_bound p, +oo[, noroot p}. +Proof. +move=> p_neq0 x; rewrite inE andbT /= lerNgt; apply: contra => /rootP. +by move=> /(cauchy_boundP p_neq0) /ltr_normlP []; rewrite ltr_oppl. +Qed. +Hint Resolve ge_cauchy_bound. + +Lemma cauchy_bound_gt0 p : cauchy_bound p > 0. +Proof. +rewrite ltr_spaddl ?ltr01 ?mulr_ge0 ?invr_ge0 ?normr_ge0 //. +by rewrite sumr_ge0 // => i; rewrite normr_ge0. +Qed. +Hint Resolve cauchy_bound_gt0. + +Lemma cauchy_bound_ge0 p : cauchy_bound p >= 0. +Proof. by rewrite ltrW. Qed. +Hint Resolve cauchy_bound_ge0. + +End CauchyBound. + +End PolyRealField. + +(************************************************************) +(* Definitions and properties for polynomials in a rcfType. *) +(************************************************************) +Section PolyRCF. + +Variable R : rcfType. + +Section Prelim. + +Implicit Types a b c : R. +Implicit Types x y z t : R. +Implicit Types p q r : {poly R}. + +(* we restate poly_ivt in a nicer way. Perhaps the def of PolyRCF should *) +(* be moved in this file, juste above this section *) + +Lemma poly_ivt (p : {poly R}) (a b : R) : + a <= b -> 0 \in `[p.[a], p.[b]] -> { x : R | x \in `[a, b] & root p x }. +Proof. by move=> leab root_p_ab; exact/sig2W/poly_ivt. Qed. + +Lemma polyrN0_itv (i : interval R) (p : {poly R}) : {in i, noroot p} + -> forall y x : R, y \in i -> x \in i -> sgr p.[x] = sgr p.[y]. +Proof. +move=> hi y x hy hx; wlog xy: x y hx hy / x <= y=> [hwlog|]. + by case/orP: (ler_total x y)=> xy; [|symmetry]; apply: hwlog. +have hxyi: {subset `[x, y] <= i}. + move=> z; apply: subitvP=> /=. + by case: i hx hy {hi}=> [[[] ?|] [[] ?|]] /=; do ?[move/itvP->|move=> ?]. +do 2![case: sgrP; first by move/rootP; rewrite (negPf (hi _ _))]=> //. + move=> /ltrW py0 /ltrW p0x; case: (@poly_ivt (- p) x y)=> //. + by rewrite inE !hornerN !oppr_cp0 p0x. + by move=> z hz; rewrite rootN (negPf (hi z _)) // hxyi. +move=> /ltrW p0y /ltrW px0; case: (@poly_ivt p x y); rewrite ?inE ?px0 //. +by move=> z hz; rewrite (negPf (hi z _)) // hxyi. +Qed. + +Lemma poly_div_factor : forall (a:R) (P : {poly R} -> Prop), + (forall k, P k%:P) -> + (forall p n k, p.[a] != 0 -> P p -> + P (p * ('X - a%:P)^+(n.+1) + k%:P)%R) + -> forall p, P p. +Proof. +move=> a P Pk Pq p. +move: {-2}p (leqnn (size p)); elim: (size p)=> {p} [|n ihn] p spn. + move: spn; rewrite leqn0 size_poly_eq0; move/eqP->; rewrite -polyC0. + exact: Pk. +case: (leqP (size p) 1)=> sp1; first by rewrite [p]size1_polyC ?sp1//. +rewrite (Pdiv.IdomainMonic.divp_eq (monicXsubC a) p) [_ %% _]size1_polyC; last first. + rewrite -ltnS. + by rewrite (@leq_trans (size ('X - a%:P))) // ?ltn_modp ?polyXsubC_eq0 ?size_XsubC. +have [n' [q hqa hp]] := multiplicity_XsubC (p %/ ('X - a%:P)) a. +rewrite divpN0 ?size_XsubC ?polyXsubC_eq0 ?sp1 //= in hqa. +rewrite hp -mulrA -exprSr; apply: Pq=> //; apply: ihn. +rewrite (@leq_trans (size (q * ('X - a%:P) ^+ n'))) //. + rewrite size_mul ?expf_eq0 ?polyXsubC_eq0 ?andbF //; last first. + by apply: contra hqa; move/eqP->; rewrite root0. + by rewrite size_exp_XsubC addnS leq_addr. +by rewrite -hp size_divp ?polyXsubC_eq0 ?size_XsubC // leq_subLR. +Qed. + +Lemma nth_root x n : x > 0 -> { y | y > 0 & y ^+ (n.+1) = x }. +Proof. +move=> l0x. +case: (ltrgtP x 1)=> hx; last by exists 1; rewrite ?hx ?lter01// expr1n. + case: (@poly_ivt ('X ^+ n.+1 - x%:P) 0 1); first by rewrite ler01. + rewrite ?(hornerE,horner_exp) ?inE. + by rewrite exprS mul0r sub0r expr1n oppr_cp0 subr_gte0/= !ltrW. + move=> y; case/andP=> [l0y ly1]; rewrite rootE ?(hornerE,horner_exp). + rewrite subr_eq0; move/eqP=> hyx; exists y=> //; rewrite lt0r l0y. + rewrite andbT; apply/eqP=> y0; move: hyx; rewrite y0. + by rewrite exprS mul0r=> x0; move: l0x; rewrite -x0 ltrr. +case: (@poly_ivt ('X ^+ n.+1 - x%:P) 0 x); first by rewrite ltrW. + rewrite ?(hornerE,horner_exp) exprS mul0r sub0r ?inE. + by rewrite oppr_cp0 (ltrW l0x) subr_ge0 ler_eexpr // ltrW. +move=> y; case/andP=> l0y lyx; rewrite rootE ?(hornerE,horner_exp). +rewrite subr_eq0; move/eqP=> hyx; exists y=> //; rewrite lt0r l0y. +rewrite andbT; apply/eqP=> y0; move: hyx; rewrite y0. +by rewrite exprS mul0r=> x0; move: l0x; rewrite -x0 ltrr. +Qed. + +Lemma poly_cont x p e : e > 0 -> exists2 d, + d > 0 & forall y, `|y - x| < d -> `|p.[y] - p.[x]| < e. +Proof. +elim/(@poly_div_factor x): p e. + move=> e ep; exists 1; rewrite ?ltr01// => y hy. + by rewrite !hornerC subrr normr0. +move=> p n k pxn0 Pp e ep. +case: (Pp (`|p.[x]|/2%:R)). + by rewrite pmulr_lgt0 ?invr_gte0//= ?ltr0Sn// normrE. +move=> d' d'p He'. +case: (@nth_root (e / ((3%:R / 2%:R) * `|p.[x]|)) n). + by rewrite ltr_pdivl_mulr ?mul0r ?pmulr_rgt0 ?invr_gt0 ?normrE ?ltr0Sn. +move=> d dp rootd. +exists (minr d d'); first by rewrite ltr_minr dp. +move=> y; rewrite ltr_minr; case/andP=> hxye hxye'. +rewrite !(hornerE, horner_exp) subrr [0 ^+ _]exprS mul0r mulr0 add0r addrK. +rewrite normrM (@ler_lt_trans _ (`|p.[y]| * d ^+ n.+1)) //. + by rewrite ler_wpmul2l ?normrE // normrX ler_expn2r -?topredE /= ?normrE 1?ltrW. +rewrite rootd mulrCA gtr_pmulr //. +rewrite ltr_pdivr_mulr ?mul1r ?pmulr_rgt0 ?invr_gt0 ?ltr0Sn ?normrE //. +rewrite mulrDl mulrDl divff; last by rewrite -mulr2n pnatr_eq0. +rewrite !mul1r mulrC -ltr_subl_addr. +by rewrite (ler_lt_trans _ (He' y _)) // ler_sub_dist. +Qed. + +(* Todo : orderedpoly !! *) +(* Lemma deriv_expz_nat : forall (n : nat) p, (p ^ n)^`() = (p^`() * p ^ (n.-1)) *~ n. *) +(* Proof. *) +(* elim=> [|n ihn] p /=; first by rewrite expr0z derivC mul0zr. *) +(* rewrite exprSz_nat derivM ihn mulzrAr mulrCA -exprSz_nat. *) +(* by case: n {ihn}=> [|n] //; rewrite mul0zr addr0 mul1zr. *) +(* Qed. *) + +(* Definition derivCE := (derivE, deriv_expz_nat). *) + +(* Lemma size_poly_ind : forall K : {poly R} -> Prop, *) +(* K 0 -> *) +(* (forall p sp, size p = sp.+1 -> *) +(* forall q, (size q <= sp)%N -> K q -> K p) *) +(* -> forall p, K p. *) +(* Proof. *) +(* move=> K K0 ihK p. *) +(* move: {-2}p (leqnn (size p)); elim: (size p)=> {p} [|n ihn] p spn. *) +(* by move: spn; rewrite leqn0 size_poly_eq0; move/eqP->. *) +(* case spSn: (size p == n.+1). *) +(* move/eqP:spSn; move/ihK=> ihKp; apply: (ihKp 0)=>//. *) +(* by rewrite size_poly0. *) +(* by move:spn; rewrite leq_eqVlt spSn /= ltnS; by move/ihn. *) +(* Qed. *) + +(* Lemma size_poly_indW : forall K : {poly R} -> Prop, *) +(* K 0 -> *) +(* (forall p sp, size p = sp.+1 -> *) +(* forall q, size q = sp -> K q -> K p) *) +(* -> forall p, K p. *) +(* Proof. *) +(* move=> K K0 ihK p. *) +(* move: {-2}p (leqnn (size p)); elim: (size p)=> {p} [|n ihn] p spn. *) +(* by move: spn; rewrite leqn0 size_poly_eq0; move/eqP->. *) +(* case spSn: (size p == n.+1). *) +(* move/eqP:spSn; move/ihK=> ihKp; case: n ihn spn ihKp=> [|n] ihn spn ihKp. *) +(* by apply: (ihKp 0)=>//; rewrite size_poly0. *) +(* apply: (ihKp 'X^n)=>//; first by rewrite size_polyXn. *) +(* by apply: ihn; rewrite size_polyXn. *) +(* by move:spn; rewrite leq_eqVlt spSn /= ltnS; by move/ihn. *) +(* Qed. *) + +Lemma poly_ltsp_roots : forall p (rs : seq R), + (size rs >= size p)%N -> uniq rs -> all (root p) rs -> p = 0. +Proof. +move=> p rs hrs urs rrs; apply/eqP; apply: contraLR hrs=> np0. +by rewrite -ltnNge; apply: max_poly_roots. +Qed. + +Lemma ivt_sign : forall (p : {poly R}) (a b : R), + a <= b -> sgr p.[a] * sgr p.[b] = -1 -> { x : R | x \in `]a, b[ & root p x}. +Proof. +move=> p a b hab /eqP; rewrite mulrC mulr_sg_eqN1=> /andP [spb0 /eqP spb]. + case: (@poly_ivt (sgr p.[b] *: p) a b)=> //. + by rewrite !hornerZ {1}spb mulNr -!normrEsg inE /= oppr_cp0 !normrE. +move=> c hc; rewrite rootZ ?sgr_eq0 // => rpc; exists c=> //. +(* need for a lemma reditvP *) +rewrite inE /= !ltr_neqAle andbCA -!andbA [_ && (_ <= _)]hc andbT eq_sym -negb_or. +apply/negP=> /orP [] /eqP ec; move: rpc; rewrite -ec /root ?(negPf spb0) //. +by rewrite -sgr_cp0 -[sgr _]opprK -spb eqr_oppLR oppr0 sgr_cp0 (negPf spb0). +Qed. + +Let rolle_weak : forall a b p, a < b -> + p.[a] = 0 -> p.[b] = 0 -> + {c | (c \in `]a, b[) & (p^`().[c] == 0) || (p.[c] == 0)}. +Proof. +move=> a b p lab pa0 pb0; apply/sig2W. +case p0: (p == 0). + rewrite (eqP p0); exists (mid a b); first by rewrite mid_in_itv. + by rewrite derivC horner0 eqxx. +have [n [p' p'a0 hp]] := multiplicity_XsubC p a; rewrite p0 /= in p'a0. +case: n hp pa0 p0 pb0 p'a0=> [ | n -> _ p0 pb0 p'a0]. + by rewrite {1}expr0 mulr1 rootE=> ->; move/eqP->. +have [m [q qb0 hp']] := multiplicity_XsubC p' b. +rewrite (contraNneq _ p'a0) /= in qb0 => [|->]; last exact: root0. +case: m hp' pb0 p0 p'a0 qb0=> [|m]. + rewrite {1}expr0 mulr1=> ->; move/eqP. + rewrite !(hornerE, horner_exp, mulf_eq0). + by rewrite !expf_eq0 !subr_eq0 !(gtr_eqF lab) !andbF !orbF !rootE=> ->. +move=> -> _ p0 p'a0 qb0; case: (sgrP (q.[a] * q.[b])); first 2 last. +- move=> sqasb; case: (@ivt_sign q a b)=> //; first exact: ltrW. + by apply/eqP; rewrite -sgrM sgr_cp0. + move=> c lacb rqc; exists c=> //. + by rewrite !hornerM (eqP rqc) !mul0r eqxx orbT. +- move/eqP; rewrite mulf_eq0 (rootPf qb0) orbF; move/eqP=> qa0. + by move: p'a0; rewrite ?rootM rootE qa0 eqxx. +- move=> hspq; rewrite !derivCE /= !mul1r mulrDl !pmulrn. + set xan := (('X - a%:P) ^+ n); set xbm := (('X - b%:P) ^+ m). + have ->: ('X - a%:P) ^+ n.+1 = ('X - a%:P) * xan by rewrite exprS. + have ->: ('X - b%:P) ^+ m.+1 = ('X - b%:P) * xbm by rewrite exprS. + rewrite -mulrzl -[_ *~ n.+1]mulrzl. + have fac : forall x y z : {poly R}, x * (y * xbm) * (z * xan) + = (y * z * x) * (xbm * xan). + by move=> x y z; rewrite mulrCA !mulrA [_ * y]mulrC mulrA. + rewrite !fac -!mulrDl; set r := _ + _ + _. + case: (@ivt_sign (sgr q.[b] *: r) a b); first exact: ltrW. + rewrite !hornerZ !sgr_smul mulrACA -expr2 sqr_sg (rootPf qb0) mul1r. + rewrite !(subrr, mul0r, mulr0, addr0, add0r, hornerC, hornerXsubC, + hornerD, hornerN, hornerM, hornerMn). + rewrite [_ * _%:R]mulrC -!mulrA !pmulrn !mulrzl !sgrMz -sgrM. + rewrite mulrAC mulrA -mulrA sgrM -opprB mulNr sgrN sgrM. + by rewrite !gtr0_sg ?subr_gt0 ?mulr1 // mulrC. +move=> c lacb; rewrite rootE hornerZ mulf_eq0. +rewrite sgr_cp0 (rootPf qb0) orFb=> rc0. +by exists c=> //; rewrite !hornerM !mulf_eq0 rc0. +Qed. + +Theorem rolle : forall a b p, a < b -> + p.[a] = p.[b] -> {c | c \in `]a, b[ & p^`().[c] = 0}. +Proof. +move=> a b p lab pab. +wlog pb0 : p pab / p.[b] = 0=> [hwlog|]. + case: (hwlog (p - p.[b]%:P)); rewrite ?hornerE ?pab ?subrr //. + by move=> c acb; rewrite derivE derivC subr0=> hc; exists c. +move: pab; rewrite pb0=> pa0. +have: (forall rs : seq R, {subset rs <= `]a, b[} -> + (size p <= size rs)%N -> uniq rs -> all (root p) rs -> p = 0). + by move=> rs hrs; apply: poly_ltsp_roots. +elim: (size p) a b lab pa0 pb0=> [|n ihn] a b lab pa0 pb0 max_roots. + rewrite (@max_roots [::]) //=. + by exists (mid a b); rewrite ?mid_in_itv // derivE horner0. +case: (@rolle_weak a b p); rewrite // ?pa0 ?pb0 //=. +move=> c hc; case: (altP (_ =P 0))=> //= p'c0 pc0; first by exists c. +suff: { d : R | d \in `]a, c[ & (p^`()).[d] = 0 }. + case=> [d hd] p'd0; exists d=> //. + by apply: subitvPr hd; rewrite //= (itvP hc). +apply: ihn=> //; first by rewrite (itvP hc). + exact/eqP. +move=> rs hrs srs urs rrs; apply: (max_roots (c :: rs))=> //=; last exact/andP. + move=> x; rewrite in_cons; case/predU1P=> hx; first by rewrite hx. + have: x \in `]a, c[ by apply: hrs. + by apply: subitvPr; rewrite /= (itvP hc). +by rewrite urs andbT; apply/negP; move/hrs; rewrite bound_in_itv. +Qed. + +Theorem mvt : forall a b p, a < b -> + {c | c \in `]a, b[ & p.[b] - p.[a] = p^`().[c] * (b - a)}. +Proof. +move=> a b p lab. +pose q := (p.[b] - p.[a])%:P * ('X - a%:P) - (b - a)%:P * (p - p.[a]%:P). +case: (@rolle a b q)=> //. + by rewrite /q !hornerE !(subrr,mulr0) mulrC subrr. +move=> c lacb q'x0; exists c=> //. +move: q'x0; rewrite /q !derivE !(mul0r,add0r,subr0,mulr1). +by move/eqP; rewrite !hornerE mulrC subr_eq0; move/eqP. +Qed. + +Lemma deriv_sign : forall a b p, + (forall x, x \in `]a, b[ -> p^`().[x] >= 0) + -> (forall x y, (x \in `]a, b[) && (y \in `]a, b[) + -> x < y -> p.[x] <= p.[y] ). +Proof. +move=> a b p Pab x y; case/andP=> hx hy xy. +rewrite -subr_gte0; case: (@mvt x y p)=> //. +move=> c hc ->; rewrite pmulr_lge0 ?subr_gt0 ?Pab //. +by apply: subitvP hc; rewrite //= ?(itvP hx) ?(itvP hy). +Qed. + +End Prelim. + +Section MonotonictyAndRoots. + +Section NoRoot. + +Variable (p : {poly R}). + +Variables (a b : R). + +Hypothesis der_pos : forall x, x \in `]a, b[ -> (p^`()).[x] > 0. + +Lemma derp0r : 0 <= p.[a] -> forall x, x \in `]a, b] -> p.[x] > 0. +Proof. +move=> pa0 x; case/itv_dec=> ax xb; case: (mvt p ax) => c acx. +move/(canRL (@subrK _ _))->; rewrite ltr_paddr //. +by rewrite pmulr_rgt0 ?subr_gt0 // der_pos //; apply: subitvPr acx. +Qed. + +Lemma derppr : 0 < p.[a] -> forall x, x \in `[a, b] -> p.[x] > 0. +Proof. +move=> pa0 x hx; case exa: (x == a); first by rewrite (eqP exa). +case: (@mvt a x p); first by rewrite ltr_def exa (itvP hx). +move=> c hc; move/eqP; rewrite subr_eq; move/eqP->; rewrite ltr_spsaddr //. +rewrite pmulr_rgt0 ?subr_gt0 //; first by rewrite ltr_def exa (itvP hx). +by rewrite der_pos // (subitvPr _ hc) //= ?(itvP hx). +Qed. + +Lemma derp0l : p.[b] <= 0 -> forall x, x \in `[a, b[ -> p.[x] < 0. +Proof. +move=> pb0 x hx; rewrite -oppr_gte0 /=. +case: (@mvt x b p)=> //; first by rewrite (itvP hx). +move=> c hc; move/(canRL (@addKr _ _))->; rewrite ltr_spaddr ?oppr_ge0 //. +rewrite pmulr_rgt0 // ?subr_gt0 ?(itvP hx) //. +by rewrite der_pos // (subitvPl _ hc) //= (itvP hx). +Qed. + +Lemma derpnl : p.[b] < 0 -> forall x, x \in `[a, b] -> p.[x] < 0. +Proof. +move=> pbn x hx; case xb: (b == x) pbn; first by rewrite -(eqP xb). +case: (@mvt x b p); first by rewrite ltr_def xb ?(itvP hx). +move=> y hy; move/eqP; rewrite subr_eq; move/eqP->. +rewrite !ltrNge; apply: contra=> hpx; rewrite ler_paddr // ltrW //. +rewrite pmulr_rgt0 ?subr_gt0 ?(itvP hy) //. +by rewrite der_pos // (subitvPl _ hy) //= (itvP hx). +Qed. + +End NoRoot. + +Section NoRoot_sg. + +Variable (p : {poly R}). + +Variables (a b c : R). + +Hypothesis derp_neq0 : {in `]a, b[, noroot p^`()}. +Hypothesis acb : c \in `]a, b[. + +Local Notation sp'c := (sgr p^`().[c]). +Local Notation q := (sp'c *: p). + +Fact derq_pos x : x \in `]a, b[ -> (q^`()).[x] > 0. +Proof. +move=> hx; rewrite derivZ hornerZ -sgr_cp0. +rewrite sgrM sgr_id mulr_sg_eq1 derp_neq0 //=. +by apply/eqP; apply: (@polyrN0_itv `]a, b[). +Qed. + +Fact sgp x : sgr p.[x] = sp'c * sgr q.[x]. +Proof. +by rewrite hornerZ sgr_smul mulrA -expr2 sqr_sg derp_neq0 ?mul1r. +Qed. + +Fact hsgp x : 0 < q.[x] -> sgr p.[x] = sp'c. +Proof. by rewrite -sgr_cp0 sgp => /eqP->; rewrite mulr1. Qed. + +Fact hsgpN x : q.[x] < 0 -> sgr p.[x] = - sp'c. +Proof. by rewrite -sgr_cp0 sgp => /eqP->; rewrite mulrN1. Qed. + +Lemma ders0r : p.[a] = 0 -> forall x, x \in `]a, b] -> sgr p.[x] = sp'c. +Proof. +move=> pa0 x hx; rewrite hsgp // (@derp0r _ a b) //; first exact: derq_pos. +by rewrite hornerZ pa0 mulr0. +Qed. + +Lemma derspr : sgr p.[a] = sp'c -> forall x, x \in `[a, b] -> sgr p.[x] = sp'c. +Proof. +move=> spa x hx; rewrite hsgp // (@derppr _ a b) //; first exact: derq_pos. +by rewrite -sgr_cp0 hornerZ sgrM sgr_id spa -expr2 sqr_sg derp_neq0. +Qed. + +Lemma ders0l : p.[b] = 0 -> forall x, x \in `[a, b[ -> sgr p.[x] = -sp'c. +Proof. +move=> pa0 x hx; rewrite hsgpN // (@derp0l _ a b) //; first exact: derq_pos. +by rewrite hornerZ pa0 mulr0. +Qed. + +Lemma derspl : sgr p.[b] = -sp'c -> forall x, x \in `[a, b] -> sgr p.[x] = -sp'c. +Proof. +move=> spb x hx; rewrite hsgpN // (@derpnl _ a b) //; first exact: derq_pos. +by rewrite -sgr_cp0 hornerZ sgr_smul spb mulrN -expr2 sqr_sg derp_neq0. +Qed. + +End NoRoot_sg. + +Variable (p : {poly R}). + +Variables (a b : R). + +Section der_root. + +Hypothesis der_pos : forall x, x \in `]a, b[ -> (p^`()).[x] > 0. + +Lemma derp_root : a <= b -> 0 \in `]p.[a], p.[b][ -> + { r : R | + [/\ forall x, x \in `[a, r[ -> p.[x] < 0, + p.[r] = 0, + r \in `]a, b[ & + forall x, x \in `]r, b] -> p.[x] > 0] }. +Proof. +move=> leab hpab. +have /eqP hs : sgr p.[a] * sgr p.[b] == -1. + by rewrite -sgrM sgr_cp0 pmulr_llt0 ?(itvP hpab). +case: (ivt_sign leab hs) => r arb pr0; exists r; split => //; last 2 first. +- by move/eqP: pr0. +- move=> x rxb; have hd : forall t, t \in `]r, b[ -> 0 < (p^`()).[t]. + by move=> t ht; rewrite der_pos // ?(subitvPl _ ht) //= ?(itvP arb). + by rewrite (derp0r hd) ?(eqP pr0). +- move=> x rxb; have hd : forall t, t \in `]a, r[ -> 0 < (p^`()).[t]. + by move=> t ht; rewrite der_pos // ?(subitvPr _ ht) //= ?(itvP arb). + by rewrite (derp0l hd) ?(eqP pr0). +Qed. + +End der_root. + +(* Section der_root_sg. *) + +(* Hypothesis der_pos : forall x, x \in `]a, b[ -> (p^`()).[x] != 0. *) + +(* Lemma derp_root : a <= b -> sgr p.[a] != sgr p.[b] -> *) +(* { r : R | *) +(* [/\ forall x, x \in `[a, r[ -> p.[x] < 0, *) +(* p.[r] = 0, *) +(* r \in `]a, b[ & *) +(* forall x, x \in `]r, b] -> p.[x] > 0] }. *) +(* Proof. *) +(* move=> leab hpab. *) +(* have hs : sgr p.[a] * sgr p.[b] == -1. *) +(* by rewrite -sgrM sgr_cp0 mulr_lt0_gt0 ?(itvP hpab). *) +(* case: (ivt_sign ivt leab hs) => r arb pr0; exists r; split => //; last 2 first. *) +(* - by move/eqP: pr0. *) +(* - move=> x rxb; have hd : forall t, t \in `]r, b[ -> 0 < (p^`()).[t]. *) +(* by move=> t ht; rewrite der_pos // ?(subitvPl _ ht) //= ?(itvP arb). *) +(* by rewrite (derp0r hd) ?(eqP pr0). *) +(* - move=> x rxb; have hd : forall t, t \in `]a, r[ -> 0 < (p^`()).[t]. *) +(* by move=> t ht; rewrite der_pos // ?(subitvPr _ ht) //= ?(itvP arb). *) +(* by rewrite (derp0l hd) ?(eqP pr0). *) +(* Qed. *) + +(* End der_root. *) + +End MonotonictyAndRoots. + +Section RootsOn. + +Variable T : predType R. + +Definition roots_on (p : {poly R}) (i : T) (s : seq R) := + forall x, (x \in i) && (root p x) = (x \in s). + +Lemma roots_onP : forall p i s, roots_on p i s -> {in i, root p =1 mem s}. +Proof. by move=> p i s hp x hx; move: (hp x); rewrite hx. Qed. + +Lemma roots_on_in : forall p i s, + roots_on p i s -> forall x, x \in s -> x \in i. +Proof. by move=> p i s hp x; rewrite -hp; case/andP. Qed. + +Lemma roots_on_root : forall p i s, + roots_on p i s -> forall x, x \in s -> root p x. +Proof. by move=> p i s hp x; rewrite -hp; case/andP. Qed. + +Lemma root_roots_on : forall p i s, + roots_on p i s -> forall x, x \in i -> root p x -> x \in s. +Proof. by move=> p i s hp x; rewrite -hp=> ->. Qed. + +Lemma roots_on_opp : forall p i s, + roots_on (- p) i s -> roots_on p i s. +Proof. by move=> p i s hp x; rewrite -hp rootN. Qed. + +Lemma roots_on_nil : forall p i, roots_on p i [::] -> {in i, noroot p}. +Proof. +by move=> p i hp x hx; move: (hp x); rewrite in_nil hx /=; move->. +Qed. + +Lemma roots_on_same : forall s' p i s, + s =i s' -> (roots_on p i s <-> roots_on p i s'). +Proof. by move=> s' p i s hss'; split=> hs x; rewrite (hss', (I, hss')). Qed. + +End RootsOn. + + +(* (* Symmetry of center a *) *) +(* Definition symr (a x : R) := a - x. *) + +(* Lemma symr_inv : forall a, involutive (symr a). *) +(* Proof. by move=> a y; rewrite /symr opprD addrA subrr opprK add0r. Qed. *) + +(* Lemma symr_inj : forall a, injective (symr a). *) +(* Proof. by move=> a; apply: inv_inj; apply: symr_inv. Qed. *) + +(* Lemma ltr_sym : forall a x y, (symr a x < symr a y) = (y < x). *) +(* Proof. by move=> a x y; rewrite lter_add2r lter_oppr opprK. Qed. *) + +(* Lemma symr_add_itv : forall a b x, *) +(* (a < symr (a + b) x < b) = (a < x < b). *) +(* Proof. *) +(* move=> a b x; rewrite andbC. *) +(* by rewrite lter_subrA lter_add2r -lter_addlA lter_add2l. *) +(* Qed. *) + +Lemma roots_on_comp : forall p a b s, + roots_on (p \Po (-'X)) `](-b), (-a)[ + (map (-%R) s) <-> roots_on p `]a, b[ s. +Proof. +move=> p a b /= s; split=> hs x; rewrite ?root_comp ?hornerE. + move: (hs (-x)); rewrite mem_map; last exact: (inv_inj (@opprK _)). + by rewrite root_comp ?hornerE oppr_itv !opprK. +rewrite -[x]opprK oppr_itv /= mem_map; last exact: (inv_inj (@opprK _)). +by move: (hs (-x)); rewrite !opprK. +Qed. + +Lemma min_roots_on : forall p a b x s, + all (> x) s -> roots_on p `]a, b[ (x :: s) + -> [/\ x \in `]a, b[, (roots_on p `]a, x[ [::]), + (root p x) & (roots_on p `]x, b[ s)]. +Proof. +move=> p a b x s lxs hxs. +have hx: x \in `]a, b[ by rewrite (roots_on_in hxs) ?mem_head. +rewrite hx (roots_on_root hxs) ?mem_head //. +split=> // y; move: (hxs y); rewrite ?in_nil ?in_cons /=. + case hy: (y \in `]a, x[)=> //=. + rewrite (subitvPr _ hy) //= ?(itvP hx) //= => ->. + rewrite ltr_eqF ?(itvP hy) //=; apply/negP. + by move/allP: lxs=> lxs /lxs; rewrite ltrNge ?(itvP hy). +move/allP:lxs=>lxs; case eyx: (y == _)=> /=. + case/andP=> hy _; rewrite (eqP eyx). + rewrite boundl_in_itv /=; symmetry. + by apply/negP; move/lxs; rewrite ltrr. +case py0: root; rewrite !(andbT, andbF) //. +case ys: (y \in s); first by move/lxs:ys; rewrite ?inE => ->; case/andP. +move/negP; move/negP=> nhy; apply: negbTE; apply: contra nhy. +by apply: subitvPl; rewrite //= ?(itvP hx). +Qed. + +Lemma max_roots_on : forall p a b x s, + all (< x) s -> roots_on p `]a, b[ (x :: s) + -> [/\ x \in `]a, b[, (roots_on p `]x, b[ [::]), + (root p x) & (roots_on p `]a, x[ s)]. +Proof. +move=> p a b x s; move/allP=> lsx; move/roots_on_comp=> /=. +move/min_roots_on; case. + apply/allP=> y; rewrite -[y]opprK mem_map. + by move/lsx; rewrite ltr_oppr opprK. + exact: (inv_inj (@opprK _)). +rewrite oppr_itv root_comp !hornerE !opprK=> -> rxb -> rax. +by split=> //; apply/roots_on_comp. +Qed. + +Lemma roots_on_cons : forall p a b r s, + sorted <%R (r :: s) -> roots_on p `]a, b[ (r :: s) -> roots_on p `]r, b[ s. +Proof. +move=> p a b r s /= hrs hr. +have:= (order_path_min (@ltr_trans _) hrs)=> allrs. +by case: (min_roots_on allrs hr). +Qed. +(* move=> p a b r s hp hr x; apply/andP/idP. *) +(* have:= (order_path_min (@ltr_trans _) hp) => /=; case/andP=> ar1 _. *) +(* case; move/ooitvP=> rxb rpx; move: (hr x); rewrite in_cons rpx andbT. *) +(* by rewrite rxb andbT (ltr_trans ar1) 1?eq_sym ?ltr_eqF ?rxb. *) +(* move=> spx. *) +(* have xrsp: x \in r :: s by rewrite in_cons spx orbT. *) +(* rewrite (roots_on_root hr) //. *) +(* rewrite (roots_on_in hr xrsp); move: hp => /=; case/andP=> _. *) +(* by move/(order_path_min (@ltr_trans _)); move/allP; move/(_ _ spx)->. *) +(* Qed. *) + +Lemma roots_on_rcons : forall p a b r s, + sorted <%R (rcons s r) -> roots_on p `]a, b[ (rcons s r) + -> roots_on p `]a, r[ s. +Proof. +move=> p a b r s; rewrite -{1}[s]revK -!rev_cons rev_sorted /=. +move=> hrs hr. +have := (order_path_min (rev_trans (@ltr_trans _)) hrs)=> allrrs. +have allrs: (all (< r) s). + by apply/allP=> x hx; move/allP:allrrs; apply; rewrite mem_rev. +move/(@roots_on_same _ _ _ _ (r::s)):hr=>hr. +case: (max_roots_on allrs (hr _))=> //. +by move=> x; rewrite mem_rcons. +Qed. + + +(* move=> p a b r s; rewrite -{1}[s]revK -!rev_cons rev_sorted. *) +(* rewrite [r :: _]lock /=; unlock; move=> hp hr x; apply/andP/idP. *) +(* have:= (order_path_min (rev_trans (@ltr_trans _)) hp) => /=. *) +(* case/andP=> ar1 _; case; move/ooitvP=> axr rpx. *) +(* move: (hr x); rewrite mem_rcons in_cons rpx andbT axr andTb. *) +(* by rewrite ((rev_trans (@ltr_trans _) ar1)) ?ltr_eqF ?axr. *) +(* move=> spx. *) +(* have xrsp: x \in rcons s r by rewrite mem_rcons in_cons spx orbT. *) +(* rewrite (roots_on_root hr) //. *) +(* rewrite (roots_on_in hr xrsp); move: hp => /=; case/andP=> _. *) +(* move/(order_path_min (rev_trans (@ltr_trans _))); move/allP. *) +(* by move/(_ x)=> -> //; rewrite mem_rev. *) +(* Qed. *) + +Lemma no_roots_on : forall (p : {poly R}) a b, + {in `]a, b[, noroot p} -> roots_on p `]a, b[ [::]. +Proof. +move=> p a b hr x; rewrite in_nil; case hx: (x \in _) => //=. +by apply: negPf; apply: hr hx. +Qed. + +Lemma monotonic_rootN : forall (p : {poly R}) (a b : R), + {in `]a, b[, noroot p^`()} -> + ((roots_on p `]a, b[ [::]) + ({r : R | roots_on p `]a, b[ [:: r]}))%type. +Proof. +move=> p a b hp'; case: (ltrP a b); last first => leab. + by left => x; rewrite in_nil itv_gte. +wlog {hp'} hp'sg: p / forall x, x \in `]a, b[ -> sgr (p^`()).[x] = 1. + move=> hwlog. have := (polyrN0_itv hp'). + move: (mid_in_itvoo leab)=> hm /(_ _ _ hm). + case: (sgrP _.[mid a b])=> hpm. + - by move=> norm; move: (hp' _ hm); rewrite rootE hpm eqxx. + - by move/(hwlog p). + - move=> hp'N; case: (hwlog (-p))=> [x|h|[r hr]]. + * by rewrite derivE hornerN sgrN=> /hp'N->; rewrite opprK. + * by left; apply: roots_on_opp. + * by right; exists r; apply: roots_on_opp. +have hp'pos: forall x, x \in `]a, b[ -> (p^`()).[x] > 0. + by move=> x; move/hp'sg; move/eqP; rewrite sgr_cp0. +case: (lerP 0 p.[a]) => ha. +- left; apply: no_roots_on => x axb. + by rewrite rootE gtr_eqF // (@derp0r _ a b) // (subitvPr _ axb) /=. +- case: (lerP p.[b] 0) => hb. + + left => x; rewrite in_nil; apply: negbTE; case axb: (x \in `]a, b[) => //=. + by rewrite rootE ltr_eqF // (@derp0l _ a b) // (subitvPl _ axb) /=. + + case: (derp_root hp'pos (ltrW leab) _). + by rewrite ?inE; apply/andP. + move=> r [h1 h2 h3] h4; right. + exists r => x; rewrite in_cons in_nil (itv_splitU2 h3). + case exr: (x == r); rewrite ?(andbT, orbT, andbF, orbF) /=. + by rewrite rootE (eqP exr) h2 eqxx. + case px0: root; rewrite (andbT, andbF) //. + move/eqP: px0=> px0; apply/negP; case/orP=> hx. + by move: (h1 x); rewrite (subitvPl _ hx) //= px0 ltrr; move/implyP. + by move: (h4 x); rewrite (subitvPr _ hx) //= px0 ltrr; move/implyP. +Qed. + +(* Inductive polN0 : Type := PolN0 : forall p : {poly R}, p != 0 -> polN0. *) + +(* Coercion pol_of_polN0 i := let: PolN0 p _ := i in p. *) + +(* Canonical Structure polN0_subType := [subType for pol_of_polN0]. *) +(* Definition polN0_eqMixin := Eval hnf in [eqMixin of polN0 by <:]. *) +(* Canonical Structure polN0_eqType := *) +(* Eval hnf in EqType polN0 polN0_eqMixin. *) +(* Definition polN0_choiceMixin := [choiceMixin of polN0 by <:]. *) +(* Canonical Structure polN0_choiceType := *) +(* Eval hnf in ChoiceType polN0 polN0_choiceMixin. *) + +(* Todo : Lemmas about operations of intervall : + itversection, restriction and splitting *) +Lemma cat_roots_on : forall (p : {poly R}) a b x, + x \in `]a, b[ -> ~~ (root p x) + -> forall s s', + sorted <%R s -> sorted <%R s' + -> roots_on p `]a, x[ s -> roots_on p `]x, b[ s' + -> roots_on p `]a, b[ (s ++ s'). +Proof. +move=> p a b x hx /= npx0 s. +elim: s a hx => [|y s ihs] a hx s' //= ss ss'. + move/roots_on_nil=> hax hs' y. + rewrite -hs'; case py0: root; rewrite ?(andbT, andbF) //. + rewrite (itv_splitU2 hx); case: (y \in `]x, b[); rewrite ?orbF ?orbT //=. + apply/negP; case/orP; first by move/hax; rewrite py0. + by move/eqP=> exy; rewrite -exy py0 in npx0. +move/min_roots_on; rewrite order_path_min //; last exact: ltr_trans. +case=> // hy hay py0 hs hs' z. +rewrite in_cons; case ezy: (z == y)=> /=. + by rewrite (eqP ezy) py0 andbT (subitvPr _ hy) //= ?(itvP hx). +rewrite -(ihs y) //; last exact: path_sorted ss; last first. + by rewrite inE /= (itvP hx) (itvP hy). +case pz0: root; rewrite ?(andbT, andbF) //. +rewrite (@itv_splitU2 _ y); last by rewrite (subitvPr _ hy) //= (itvP hx). +rewrite ezy /=; case: (z \in `]y, b[); rewrite ?orbF ?orbT //. +by apply/negP=> hz; move: (hay z); rewrite hz pz0 in_nil. +Qed. + +CoInductive roots_spec (p : {poly R}) (i : pred R) (s : seq R) : + {poly R} -> bool -> seq R -> Type := +| Roots0 of p = 0 :> {poly R} & s = [::] : roots_spec p i s 0 true [::] +| Roots of p != 0 & roots_on p i s + & sorted <%R s : roots_spec p i s p false s. + +(* still much too long *) +Lemma itv_roots : forall (p :{poly R}) (a b : R), + {s : seq R & roots_spec p (topred `]a, b[) s p (p == 0) s}. +Proof. +move=> p a b; case p0: (_ == 0). + by rewrite (eqP p0); exists [::]; constructor. +elim: (size p) {-2}p (leqnn (size p)) p0 a b => {p} [| n ihn] p sp p0 a b. + by exists [::]; move: p0; rewrite -size_poly_eq0 -leqn0 sp. +move/negbT: (p0)=> np0. +case p'0 : (p^`() == 0). + move: p'0; rewrite -derivn1 -derivn_poly0; move/size1_polyC => pC. + exists [::]; constructor=> // x; rewrite in_nil pC rootC; apply: negPf. + by rewrite negb_and -polyC_eq0 -pC p0 orbT. +move/negbT: (p'0) => np'0. +have sizep' : (size p^`() <= n)%N. + rewrite -ltnS; apply: leq_trans sp; rewrite size_deriv prednK // lt0n. + by rewrite size_poly_eq0 p0. +case: (ihn _ sizep' p'0 a b) => sp' ih {ihn}. +case ltab : (a < b); last first. + exists [::]; constructor=> // x; rewrite in_nil. + case axb : (x \in _) => //=. + by case/andP: axb => ax xb; move: ltab; rewrite (ltr_trans ax xb). +elim: sp' a b ltab ih => [|r1 sp' hsp'] a b ltab hp'. + case: hp' np'0; rewrite ?eqxx // => np'0 hroots' _ _. + move/roots_on_nil : hroots' => hroots'. + case: (monotonic_rootN hroots') => [h| [r rh]]. + by exists [::]; constructor. + by exists [:: r]; constructor=> //=; rewrite andbT. +case: hp' np'0; rewrite ?eqxx // => np'0 hroots' /= hpath' _. +case: (min_roots_on _ hroots'). + by rewrite order_path_min //; apply: ltr_trans. +move=> hr1 har1 p'r10 hr1b. +case: (hsp' r1 b); first by rewrite (itvP hr1). + by constructor=> //; rewrite (path_sorted hpath'). +move=> s spec_s. +case: spec_s np0; rewrite ?eqxx //. +move=> np0 hroot hsort _. +move: (roots_on_nil har1). +case pr1 : (root p r1); case/monotonic_rootN => hrootsl; last 2 first. +- exists s; constructor=> //. + by rewrite -[s]cat0s; apply: (cat_roots_on hr1)=> //; rewrite pr1. +- case:hrootsl=> r hr; exists (r::s); constructor=> //=. + by rewrite -cat1s; apply: (cat_roots_on hr1)=> //; rewrite pr1. + rewrite path_min_sorted // => y; rewrite -hroot; case/andP=> hy _. + rewrite (@ltr_trans _ r1) ?(itvP hy) //. + by rewrite (itvP (roots_on_in hr (mem_head _ _))). +- exists (r1::s); constructor=> //=; last first. + rewrite path_min_sorted=> // y; rewrite -hroot. + by case/andP; move/itvP->. + move=> x; rewrite in_cons; case exr1: (x == r1)=> /=. + by rewrite (eqP exr1) pr1 andbT. + rewrite -hroot; case px: root; rewrite ?(andbT, andbF) //. + rewrite (itv_splitU2 hr1) exr1 /=. + case: (_ \in `]r1, _[); rewrite ?(orbT, orbF) //. + by apply/negP=> hx; move: (hrootsl x); rewrite hx px in_nil. +- case: hrootsl => r0 hrootsl. + move/min_roots_on:hrootsl; case=> // hr0 har0 pr0 hr0r1. + exists [:: r0, r1 & s]; constructor=> //=; last first. + rewrite (itvP hr0) /= path_min_sorted // => y. + by rewrite -hroot; case/andP; move/itvP->. + move=> y; rewrite !in_cons (itv_splitU2 hr1) (itv_splitU2 hr0). + case eyr0: (y == r0); rewrite ?(orbT, orbF, orTb, orFb). + by rewrite (eqP eyr0) pr0. + case eyr1: (y == r1); rewrite ?(orbT, orbF, orTb, orFb). + by rewrite (eqP eyr1) pr1. + rewrite -hroot; case py0: root; rewrite ?(andbF, andbT) //. + case: (_ \in `]r1, _[); rewrite ?(orbT, orbF) //. + apply/negP; case/orP=> hy; first by move: (har0 y); rewrite hy py0 in_nil. + by move: (hr0r1 y); rewrite hy py0 in_nil. +Qed. + +Definition roots (p : {poly R}) a b := projT1 (itv_roots p a b). + +Lemma rootsP : forall p a b, + roots_spec p (topred `]a, b[) (roots p a b) p (p == 0) (roots p a b). +Proof. by move=> p a b; rewrite /roots; case hp: itv_roots. Qed. + +Lemma roots0 : forall a b, roots 0 a b = [::]. +Proof. by move=> a b; case: rootsP=> //=; rewrite eqxx. Qed. + +Lemma roots_on_roots : forall p a b, p != 0 -> + roots_on p `]a, b[ (roots p a b). +Proof. by move=> a b p; case:rootsP. Qed. +Hint Resolve roots_on_roots. + +Lemma sorted_roots : forall a b p, sorted <%R (roots p a b). +Proof. by move=> p a b; case: rootsP. Qed. +Hint Resolve sorted_roots. + +Lemma path_roots : forall p a b, path <%R a (roots p a b). +Proof. +move=> p a b; case: rootsP=> //= p0 hp sp; rewrite path_min_sorted //. +by move=> y; rewrite -hp; case/andP; move/itvP->. +Qed. +Hint Resolve path_roots. + +Lemma root_is_roots : + forall (p : {poly R}) (a b : R), p != 0 -> + forall x, x \in `]a, b[ -> root p x = (x \in roots p a b). +Proof. +by move=> p a b; case: rootsP=> // p0 hs ps _ y hy /=; rewrite -hs hy. +Qed. + +Lemma root_in_roots : forall (p : {poly R}) a b, p != 0 -> + forall x, x \in `]a, b[ -> root p x -> x \in (roots p a b). +Proof. by move=> p a b p0 x axb rpx; rewrite -root_is_roots. Qed. + +Lemma root_roots : forall p a b x, x \in roots p a b -> root p x. +Proof. by move=> p a b x; case: rootsP=> // p0 <- _; case/andP. Qed. + +Lemma roots_nil : forall p a b, p != 0 -> + roots p a b = [::] -> {in `]a, b[, noroot p}. +Proof. +move=> p a b; case: rootsP=> // p0 hs ps _ s0 x axb. +by move: (hs x); rewrite s0 in_nil !axb /= => ->. +Qed. + +Lemma roots_in p a b x : x \in roots p a b -> x \in `]a, b[. +Proof. by case: rootsP=> //= np0 ron_p *; exact: (roots_on_in ron_p). Qed. + +Lemma rootsEba : forall p a b, b <= a -> roots p a b = [::]. +Proof. +move=> p a b; case: rootsP=> // p0; case: (roots _ _ _)=> [|x s] hs ps ba //; +by move: (hs x); rewrite itv_gte //= mem_head. +Qed. + +Lemma roots_on_uniq : forall p a b s1 s2, + sorted <%R s1 -> sorted <%R s2 -> + roots_on p `]a, b[ s1 -> roots_on p `]a, b[ s2 -> s1 = s2. +Proof. +move=> p a b s1. +elim: s1 p a b => [| r1 s1 ih] p a b [| r2 s2] ps1 ps2 rs1 rs2 //. +- have rpr2 : root p r2 by apply: (roots_on_root rs2); rewrite mem_head. + have abr2 : r2 \in `]a, b[ by apply: (roots_on_in rs2); rewrite mem_head. + by have:= (rs1 r2); rewrite rpr2 !abr2 in_nil. +- have rpr1 : root p r1 by apply: (roots_on_root rs1); rewrite mem_head. + have abr1 : r1 \in `]a, b[ by apply: (roots_on_in rs1); rewrite mem_head. + by have:= (rs2 r1); rewrite rpr1 !abr1 in_nil. +- have er1r2 : r1 = r2. + move: (rs1 r2); rewrite (roots_on_root rs2) ?mem_head //. + rewrite !(roots_on_in rs2) ?mem_head //= in_cons. + move/(@sym_eq _ true); case/orP => hr2; first by rewrite (eqP hr2). + move: ps1=> /=; move/(order_path_min (@ltr_trans R)); move/allP. + move/(_ r2 hr2) => h1. + move: (rs2 r1); rewrite (roots_on_root rs1) ?mem_head //. + rewrite !(roots_on_in rs1) ?mem_head //= in_cons. + move/(@sym_eq _ true); case/orP => hr1; first by rewrite (eqP hr1). + move: ps2=> /=; move/(order_path_min (@ltr_trans R)); move/allP. + by move/(_ r1 hr1); rewrite ltrNge ltrW. +congr (_ :: _) => //; rewrite er1r2 in ps1 rs1. +have h3 := (roots_on_cons ps1 rs1). +have h4 := (roots_on_cons ps2 rs2). +move: ps1 ps2=> /=; move/path_sorted=> hs1; move/path_sorted=> hs2. +exact: (ih p _ b _ hs1 hs2 h3 h4). +Qed. + +Lemma roots_eq : forall (p q : {poly R}) (a b : R), + p != 0 -> q != 0 -> + ({in `]a, b[, root p =1 root q} + <-> roots p a b = roots q a b). +Proof. +move=> p q a b p0 q0. +case hab : (a < b); last first. + split; first by rewrite !rootsEba // lerNgt hab. + move=> _ x. rewrite !inE; case/andP=> ax xb. + by move: hab; rewrite (@ltr_trans _ x) /=. +split=> hpq. + apply: (@roots_on_uniq p a b); rewrite ?path_roots ?p0 ?q0 //. + by apply: roots_on_roots. + rewrite /roots_on => x; case hx: (_ \in _). + by rewrite -hx hpq //; apply: roots_on_roots. + by rewrite /= -(andFb (q.[x] == 0)) -hx; apply: roots_on_roots. +move=> x axb /=. +by rewrite (@root_is_roots q a b) // (@root_is_roots p a b) // hpq. +Qed. + +Lemma roots_opp : forall p, roots (- p) =2 roots p. +Proof. +move=> p a b; case p0 : (p == 0); first by rewrite (eqP p0) oppr0. +by apply/roots_eq=> [||x]; rewrite ?oppr_eq0 ?p0 ?rootN. +Qed. + +Lemma no_root_roots : forall (p : {poly R}) a b, + {in `]a, b[ , noroot p} -> roots p a b = [::]. +Proof. +move=> p a b hr; case: rootsP=> // p0 hs ps. +apply: (@roots_on_uniq p a b)=> // x; rewrite in_nil. +by apply/negP; case/andP; move/hr; move/negPf->. +Qed. + +Lemma head_roots_on_ge : forall p a b s, a < b -> + roots_on p `]a, b[ s -> a < head b s. +Proof. +move=> p a b [|x s] ab //; move/(_ x). +by rewrite in_cons eqxx; case/andP; case/andP. +Qed. + +Lemma head_roots_ge : forall p a b, a < b -> a < head b (roots p a b). +Proof. +by move=> p a b; case: rootsP=> // *; apply: head_roots_on_ge. +Qed. + +Lemma last_roots_on_le : forall p a b s, a < b -> + roots_on p `]a, b[ s -> last a s < b. +Proof. +move=> p a b [|x s] ab rs //. +by rewrite (itvP (roots_on_in rs _)) //= mem_last. +Qed. + +Lemma last_roots_le : forall p a b, a < b -> last a (roots p a b) < b. +Proof. +by move=> p a b; case: rootsP=> // *; apply: last_roots_on_le. +Qed. + +Lemma roots_uniq : forall p a b s, p != 0 -> + roots_on p `]a, b[ s -> sorted <%R s -> s = roots p a b. +Proof. +move=> p a b s; case: rootsP=> // p0 hs' ps' _ hs ss. +exact: (@roots_on_uniq p a b)=> //. +Qed. + +Lemma roots_cons : forall p a b x s, + (roots p a b == x :: s) + = [&& p != 0, x \in `]a, b[, + (roots p a x == [::]), + (root p x) & (roots p x b == s)]. +Proof. +move=> p a b x s; case: rootsP=> // p0 hs' ps' /=. +apply/idP/idP. + move/eqP=> es'; move: ps' hs'; rewrite es' /= => sxs. + case/min_roots_on; first by apply: order_path_min=> //; apply: ltr_trans. + move=> -> rax px0 rxb. + rewrite px0 (@roots_uniq p a x [::]) // (@roots_uniq p x b s) ?eqxx //=. + by move/path_sorted:sxs. +case: rootsP p0=> // p0 rax sax _. +case/and3P=> hx hax; rewrite (eqP hax) in rax sax. +case: rootsP p0=> // p0 rxb sxb _. +case/andP=> px0 hxb; rewrite (eqP hxb) in rxb sxb. +rewrite [_ :: _](@roots_uniq p a b) //; last first. + rewrite /= path_min_sorted // => y. + by rewrite -(eqP hxb); move/roots_in; move/itvP->. +move=> y; rewrite (itv_splitU2 hx) !andb_orl in_cons. +case hy: (y == x); first by rewrite (eqP hy) px0 orbT. +by rewrite andFb orFb rax rxb in_nil. +Qed. + +Lemma roots_rcons : forall p a b x s, + (roots p a b == rcons s x) + = [&& p != 0, x \in `]a , b[, + (roots p x b == [::]), + (root p x) & (roots p a x == s)]. +Proof. +move=> p a b x s; case: rootsP; first by case: s. +move=> // p0 hs' ps' /=. +apply/idP/idP. + move/eqP=> es'; move: ps' hs'; rewrite es' /= => sxs. + have hsx: rcons s x =i x :: rev s. + by move=> y; rewrite mem_rcons !in_cons mem_rev. + move/(roots_on_same _ _ hsx). + case/max_roots_on. + move: sxs; rewrite -[rcons _ _]revK rev_sorted rev_rcons. + by apply: order_path_min=> u v w /=; move/(ltr_trans _); apply. + move=> -> rax px0 rxb. + move/(@roots_on_same _ s): rxb; move/(_ (mem_rev _))=> rxb. + rewrite px0 (@roots_uniq p x b [::]) // (@roots_uniq p a x s) ?eqxx //=. + move: sxs; rewrite -[rcons _ _]revK rev_sorted rev_rcons. + by move/path_sorted; rewrite -rev_sorted revK. +case: rootsP p0=> // p0 rax sax _. +case/and3P=> hx hax; rewrite (eqP hax) in rax sax. +case: rootsP p0=> // p0 rxb sxb _. +case/andP=> px0 hxb; rewrite (eqP hxb) in rxb sxb. +rewrite [rcons _ _](@roots_uniq p a b) //; last first. + rewrite -[rcons _ _]revK rev_sorted rev_rcons /= path_min_sorted. + by rewrite -rev_sorted revK. + move=> y; rewrite mem_rev; rewrite -(eqP hxb). + by move/roots_in; move/itvP->. +move=> y; rewrite (itv_splitU2 hx) mem_rcons in_cons !andb_orl. +case hy: (y == x); first by rewrite (eqP hy) px0 orbT. +by rewrite rxb rax in_nil !orbF. +Qed. + +Section NeighborHood. + +Implicit Types a b : R. + +Implicit Types p : {poly R}. + +Definition next_root (p : {poly R}) x b := if p == 0 then x else head (maxr b x) (roots p x b). + +Lemma next_root0 : forall a b, next_root 0 a b = a. +Proof. by move=> *; rewrite /next_root eqxx. Qed. + +CoInductive next_root_spec (p : {poly R}) x b : bool -> R -> Type := +| NextRootSpec0 of p = 0 : next_root_spec p x b true x +| NextRootSpecRoot y of p != 0 & p.[y] = 0 & y \in `]x, b[ + & {in `]x, y[, forall z, ~~(root p z)} : next_root_spec p x b true y +| NextRootSpecNoRoot c of p != 0 & c = maxr b x + & {in `]x, b[, forall z, ~~(root p z)} : next_root_spec p x b (p.[c] == 0) c. + +Lemma next_rootP : forall (p : {poly R}) a b, next_root_spec p a b (p.[next_root p a b] == 0) (next_root p a b). +Proof. +move=> p a b; rewrite /next_root /=. +case hs: roots=> [|x s] /=. + case: (altP (p =P 0))=> p0. + by rewrite {2}p0 hornerC eqxx; constructor; rewrite p0. + by constructor=> // y hy; apply: (roots_nil p0 hs). +move/eqP: hs; rewrite roots_cons; case/and5P=> p0 hx; move/eqP=> rap rpx rx. +rewrite (negPf p0) (rootPt rpx); constructor=> //; first by move/eqP: rpx. +by move=> y hy /=; move/(roots_nil p0): (rap); apply. +Qed. + +Lemma next_root_in : forall p a b, next_root p a b \in `[a, maxr b a]. +Proof. +move=> p a b; case: next_rootP=> [p0|y np0 py0 hy _|c np0 hc _]. +* by rewrite bound_in_itv /= ler_maxr lerr orbT. +* by apply: subitvP hy=> /=; rewrite ler_maxr !lerr. +* by rewrite hc bound_in_itv /= ler_maxr lerr orbT. +Qed. + +Lemma next_root_gt : forall p a b, a < b -> p != 0 -> next_root p a b > a. +Proof. +move=> p a b ab np0; case: next_rootP=> [p0|y _ py0 hy _|c _ -> _]. +* by rewrite p0 eqxx in np0. +* by rewrite (itvP hy). +* by rewrite maxr_l // ltrW. +Qed. + +Lemma next_noroot : forall p a b, {in `]a, (next_root p a b)[, noroot p}. +Proof. +move=> p a b z; case: next_rootP; first by rewrite itv_xx. + by move=> y np0 py0 hy hp hz; rewrite (negPf (hp _ _)). +move=> c p0 -> hp hz; rewrite (negPf (hp _ _)) //. +by case: maxrP hz; last by rewrite itv_xx. +Qed. + +Lemma is_next_root : forall p a b x, next_root_spec p a b (root p x) x -> x = next_root p a b. +Proof. +move=> p a b x []; first by move->; rewrite /next_root eqxx. + move=> y; case: next_rootP; first by move->; rewrite eqxx. + move=> y' np0 py'0 hy' hp' _ py0 hy hp. + wlog: y y' hy' hy hp' hp py0 py'0 / y <= y'. + by case/orP: (ler_total y y')=> lyy' hw; [|symmetry]; apply: hw. + case: ltrgtP=> // hyy' _; move: (hp' y). + by rewrite rootE py0 eqxx inE /= (itvP hy) hyy'; move/(_ isT). + move=> c p0 ->; case: maxrP=> hab; last by rewrite itv_gte //= ltrW. + by move=> hpz _ py0 hy; move/hpz:hy; rewrite rootE py0 eqxx. +case: next_rootP=> //; first by move->; rewrite eqxx. + by move=> y np0 py0 hy _ c _ _; move/(_ _ hy); rewrite rootE py0 eqxx. +by move=> c _ -> _ c' _ ->. +Qed. + +Definition prev_root (p : {poly R}) a x := if p == 0 then x else last (minr a x) (roots p a x). + +Lemma prev_root0 : forall a b, prev_root 0 a b = b. +Proof. by move=> *; rewrite /prev_root eqxx. Qed. + +CoInductive prev_root_spec (p : {poly R}) a x : bool -> R -> Type := +| PrevRootSpec0 of p = 0 : prev_root_spec p a x true x +| PrevRootSpecRoot y of p != 0 & p.[y] = 0 & y \in`]a, x[ + & {in `]y, x[, forall z, ~~(root p z)} : prev_root_spec p a x true y +| PrevRootSpecNoRoot c of p != 0 & c = minr a x + & {in `]a, x[, forall z, ~~(root p z)} : prev_root_spec p a x (p.[c] == 0) c. + +Lemma prev_rootP : forall (p : {poly R}) a b, prev_root_spec p a b (p.[prev_root p a b] == 0) (prev_root p a b). +Proof. +move=> p a b; rewrite /prev_root /=. +move hs: (roots _ _ _)=> s. +case: (lastP s) hs=> {s} [|s x] hs /=. + case: (altP (p =P 0))=> p0. + by rewrite {2}p0 hornerC eqxx; constructor; rewrite p0. + by constructor=> // y hy; apply: (roots_nil p0 hs). +rewrite last_rcons; move/eqP: hs. +rewrite roots_rcons; case/and5P=> p0 hx; move/eqP=> rap rpx rx. +rewrite (negPf p0) (rootPt rpx); constructor=> //; first by move/eqP: rpx. +by move=> y hy /=; move/(roots_nil p0): (rap); apply. +Qed. + +Lemma prev_root_in : forall p a b, prev_root p a b \in `[minr a b, b]. +Proof. +move=> p a b; case: prev_rootP=> [p0|y np0 py0 hy _|c np0 hc _]. +* by rewrite bound_in_itv /= ler_minl lerr orbT. +* by apply: subitvP hy=> /=; rewrite ler_minl !lerr. +* by rewrite hc bound_in_itv /= ler_minl lerr orbT. +Qed. + +Lemma prev_noroot : forall p a b, {in `](prev_root p a b), b[, noroot p}. +Proof. +move=> p a b z; case: prev_rootP; first by rewrite itv_xx. + by move=> y np0 py0 hy hp hz; rewrite (negPf (hp _ _)). +move=> c np0 ->; case: minrP=> hab; last by rewrite itv_xx. +by move=> hp hz; rewrite (negPf (hp _ _)). +Qed. + +Lemma prev_root_lt : forall p a b, a < b -> p != 0 -> prev_root p a b < b. +Proof. +move=> p a b ab np0; case: prev_rootP=> [p0|y _ py0 hy _|c _ -> _]. +* by rewrite p0 eqxx in np0. +* by rewrite (itvP hy). +* by rewrite minr_l // ltrW. +Qed. + +Lemma is_prev_root : forall p a b x, prev_root_spec p a b (root p x) x -> x = prev_root p a b. +Proof. +move=> p a b x []; first by move->; rewrite /prev_root eqxx. + move=> y; case: prev_rootP; first by move->; rewrite eqxx. + move=> y' np0 py'0 hy' hp' _ py0 hy hp. + wlog: y y' hy' hy hp' hp py0 py'0 / y <= y'. + by case/orP: (ler_total y y')=> lyy' hw; [|symmetry]; apply: hw. + case: ltrgtP=> // hyy' _; move/implyP: (hp y'). + by rewrite rootE py'0 eqxx inE /= (itvP hy') hyy'. + by move=> c _ _ hpz _ py0 hy; move/hpz:hy; rewrite rootE py0 eqxx. +case: prev_rootP=> //; first by move->; rewrite eqxx. + move=> y ? py0 hy _ c _ ->; case: minrP hy=> hab; last first. + by rewrite itv_gte //= ltrW. + by move=> hy; move/(_ _ hy); rewrite rootE py0 eqxx. +by move=> c _ -> _ c' _ ->. +Qed. + +Definition neighpr p a b := `]a, (next_root p a b)[. + +Definition neighpl p a b := `](prev_root p a b), b[. + +Lemma neighpl_root : forall p a x, {in neighpl p a x, noroot p}. +Proof. exact: prev_noroot. Qed. + +Lemma sgr_neighplN : forall p a x, ~~root p x -> + {in neighpl p a x, forall y, (sgr p.[y] = sgr p.[x])}. +Proof. +rewrite /neighpl=> p a x nrpx /= y hy. +apply: (@polyrN0_itv `[y, x]); do ?by rewrite bound_in_itv /= (itvP hy). +move=> z; rewrite (@itv_splitU _ x false) ?itv_xx /=; last first. +(* Todo : Lemma itv_splitP *) + by rewrite bound_in_itv /= (itvP hy). +rewrite orbC => /predU1P[-> // | hz]. +rewrite (@prev_noroot _ a x) //. +by apply: subitvPl hz; rewrite /= (itvP hy). +Qed. + +Lemma sgr_neighpl_same : forall p a x, + {in neighpl p a x &, forall y z, (sgr p.[y] = sgr p.[z])}. +Proof. +by rewrite /neighpl=> p x b y z *; apply: (polyrN0_itv (@prev_noroot p x b)). +Qed. + +Lemma neighpr_root : forall p x b, {in neighpr p x b, noroot p}. +Proof. exact: next_noroot. Qed. + +Lemma sgr_neighprN : forall p x b, p.[x] != 0 -> + {in neighpr p x b, forall y, (sgr p.[y] = sgr p.[x])}. +Proof. +rewrite /neighpr=> p x b nrpx /= y hy; symmetry. +apply: (@polyrN0_itv `[x, y]); do ?by rewrite bound_in_itv /= (itvP hy). +move=> z; rewrite (@itv_splitU _ x true) ?itv_xx /=; last first. +(* Todo : Lemma itv_splitP *) + by rewrite bound_in_itv /= (itvP hy). +case/orP=> [|hz]; first by rewrite inE /=; move/eqP->. +rewrite (@next_noroot _ x b) //. +by apply: subitvPr hz; rewrite /= (itvP hy). +Qed. + +Lemma sgr_neighpr_same : forall p x b, + {in neighpr p x b &, forall y z, (sgr p.[y] = sgr p.[z])}. +Proof. +by rewrite /neighpl=> p x b y z *; apply: (polyrN0_itv (@next_noroot p x b)). +Qed. + +Lemma uniq_roots : forall a b p, uniq (roots p a b). +Proof. +move=> a b p; case p0: (p == 0); first by rewrite (eqP p0) roots0. +by apply: (@sorted_uniq _ <%R); [exact: ltr_trans | exact: ltrr|]. +Qed. + +Hint Resolve uniq_roots. + +Lemma in_roots : forall p a b, forall x : R, + (x \in roots p a b) = [&& root p x, x \in `]a, b[ & p != 0]. +Proof. +move=> p a b x; case: rootsP=> //=; first by rewrite in_nil !andbF. +by move=> p0 hr sr; rewrite andbT -hr andbC. +Qed. + +(* Todo : move to polyorder => need char 0 *) +Lemma gdcop_eq0 : forall p q, (gdcop p q == 0) = (q == 0) && (p != 0). +Proof. +move=> p q; case: (eqVneq q 0) => [-> | q0]. + rewrite gdcop0 /= eqxx /=. + by case: (eqVneq p 0) => [-> | pn0]; rewrite ?(negPf pn0) eqxx ?oner_eq0. +rewrite /gdcop; move: {-1}(size q) (leqnn (size q))=> k hk. +case: (eqVneq p 0) => [-> | p0]. + rewrite eqxx andbF; apply: negPf. + elim: k q q0 {hk} => [|k ihk] q q0 /=; first by rewrite eqxx oner_eq0. + case: ifP=> _ //. + apply: ihk; rewrite gcdp0 divpp ?q0 // polyC_eq0; exact: lc_expn_scalp_neq0. +rewrite p0 (negPf q0) /=; apply: negPf. +elim: k q q0 hk => [|k ihk] /= q q0 hk. + by move: hk q0; rewrite leqn0 size_poly_eq0; move->. +case: ifP=> cpq; first by rewrite (negPf q0). +apply: ihk. + rewrite divpN0; last by rewrite gcdp_eq0 negb_and q0. + by rewrite dvdp_leq // dvdp_gcdl. +rewrite -ltnS; apply: leq_trans hk; move: (dvdp_gcdl q p); rewrite dvdp_eq. +move/eqP=> eqq; move/(f_equal (fun x : {poly R} => size x)): (eqq). +rewrite size_scale; last exact: lc_expn_scalp_neq0. +have gcdn0 : gcdp q p != 0 by rewrite gcdp_eq0 negb_and q0. +have qqn0 : q %/ gcdp q p != 0. + apply: contraTneq q0; rewrite negbK => e. + move: (scaler_eq0 (lead_coef (gcdp q p) ^+ scalp q (gcdp q p)) q). + by rewrite (negPf (lc_expn_scalp_neq0 _ _)) /=; move<-; rewrite eqq e mul0r. +move->; rewrite size_mul //; case sgcd: (size (gcdp q p)) => [|n]. + by move/eqP: sgcd gcdn0; rewrite size_poly_eq0; move->. +case: n sgcd => [|n]; first by move/eqP; rewrite size_poly_eq1 gcdp_eqp1 cpq. +by rewrite addnS /= -{1}[size (_ %/ _)]addn0 ltn_add2l. +Qed. + +Lemma roots_mul : forall a b, a < b -> forall p q, + p != 0 -> q != 0 -> perm_eq (roots (p*q) a b) + (roots p a b ++ roots ((gdcop p q)) a b). +Proof. +move=> a b hab p q np0 nq0. +apply: uniq_perm_eq; first exact: uniq_roots. + rewrite cat_uniq ?uniq_roots andbT /=; apply/hasPn=> x /=. + move/root_roots; rewrite root_gdco //; case/andP=> _. + by rewrite in_roots !negb_and=> ->. +move=> x; rewrite mem_cat !in_roots root_gdco //. +rewrite rootM mulf_eq0 gdcop_eq0 negb_and. +case: (x \in `]_, _[); last by rewrite !andbF. +by rewrite negb_or !np0 !nq0 !andbT /=; do 2?case: root=> //=. +Qed. + +Lemma roots_mul_coprime : forall a b, a < b -> forall p q, + p != 0 -> q != 0 -> coprimep p q -> + perm_eq (roots (p * q) a b) + (roots p a b ++ roots q a b). +Proof. +move=> a b hab p q np0 nq0 cpq. +rewrite (perm_eq_trans (roots_mul hab np0 nq0)) //. +suff ->: roots (gdcop p q) a b = roots q a b by apply: perm_eq_refl. +case: gdcopP=> r rq hrp; move/(_ q (dvdpp _)). +rewrite coprimep_sym; move/(_ cpq)=> qr. +have erq : r %= q by rewrite /eqp rq qr. +(* Todo : relate eqp with roots *) +apply/roots_eq=> // [|x hx]; last exact: eqp_root. +by rewrite -size_poly_eq0 (eqp_size erq) size_poly_eq0. +Qed. + + +Lemma next_rootM : forall a b (p q : {poly R}), + next_root (p * q) a b = minr (next_root p a b) (next_root q a b). +Proof. +move=> a b p q; symmetry; apply: is_next_root. +wlog: p q / next_root p a b <= next_root q a b. + case: minrP=> hpq; first by move/(_ _ _ hpq); case: minrP hpq. + by move/(_ _ _ (ltrW hpq)); rewrite mulrC minrC; case: minrP hpq. +case: minrP=> //; case: next_rootP=> [|y np0 py0 hy|c np0 ->] hp hpq _. +* by rewrite hp mul0r root0; constructor. +* rewrite rootM; move/rootP:(py0)->; constructor=> //. + - by rewrite mulf_neq0 //; case: next_rootP hpq; rewrite // (itvP hy). + - by rewrite hornerM py0 mul0r. + - move=> z hz /=; rewrite rootM negb_or ?hp //. + by rewrite (@next_noroot _ a b) //; apply: subitvPr hz. +* case: (altP (q =P 0))=> q0. + move: hpq; rewrite q0 mulr0 root0 next_root0 ler_maxl lerr andbT. + by move=> hba; rewrite maxr_r //; constructor. + constructor=> //; first by rewrite mulf_neq0. + move=> z hz /=; rewrite rootM negb_or ?hp //. + rewrite (@next_noroot _ a b) //; apply: subitvPr hz=> /=. + by move: hpq; rewrite ler_maxl; case/andP. +Qed. + +Lemma neighpr_mul : forall a b p q, + (neighpr (p * q) a b) =i [predI (neighpr p a b) & (neighpr q a b)]. +Proof. +move=> a b p q x; rewrite inE /= !inE /= next_rootM. +by case: (a < x); rewrite // ltr_minr. +Qed. + +Lemma prev_rootM : forall a b (p q : {poly R}), + prev_root (p * q) a b = maxr (prev_root p a b) (prev_root q a b). +Proof. +move=> a b p q; symmetry; apply: is_prev_root. +wlog: p q / prev_root p a b >= prev_root q a b. + case: maxrP=> hpq; first by move/(_ _ _ hpq); case: maxrP hpq. + by move/(_ _ _ (ltrW hpq)); rewrite mulrC maxrC; case: maxrP hpq. +case: maxrP=> //; case: (@prev_rootP p)=> [|y np0 py0 hy|c np0 ->] hp hpq _. +* by rewrite hp mul0r root0; constructor. +* rewrite rootM; move/rootP:(py0)->; constructor=> //. + - by rewrite mulf_neq0 //; case: prev_rootP hpq; rewrite // (itvP hy). + - by rewrite hornerM py0 mul0r. + - move=> z hz /=; rewrite rootM negb_or ?hp //. + by rewrite (@prev_noroot _ a b) //; apply: subitvPl hz. +* case: (altP (q =P 0))=> q0. + move: hpq; rewrite q0 mulr0 root0 prev_root0 ler_minr lerr andbT. + by move=> hba; rewrite minr_r //; constructor. + constructor=> //; first by rewrite mulf_neq0. + move=> z hz /=; rewrite rootM negb_or ?hp //. + rewrite (@prev_noroot _ a b) //; apply: subitvPl hz=> /=. + by move: hpq; rewrite ler_minr; case/andP. +Qed. + +Lemma neighpl_mul : forall a b p q, + (neighpl (p * q) a b) =i [predI (neighpl p a b) & (neighpl q a b)]. +Proof. +move=> a b p q x; rewrite !inE /= prev_rootM. +by case: (x < b); rewrite // ltr_maxl !(andbT, andbF). +Qed. + +Lemma neighpr_wit : forall p x b, x < b -> p != 0 -> {y | y \in neighpr p x b}. +Proof. +move=> p x b xb; exists (mid x (next_root p x b)). +by rewrite mid_in_itv //= next_root_gt. +Qed. + +Lemma neighpl_wit : forall p a x, a < x -> p != 0 -> {y | y \in neighpl p a x}. +Proof. +move=> p a x xb; exists (mid (prev_root p a x) x). +by rewrite mid_in_itv //= prev_root_lt. +Qed. + +End NeighborHood. + +Section SignRight. + +Definition sgp_right (p : {poly R}) x := + let fix aux (p : {poly R}) n := + if n is n'.+1 + then if ~~ root p x + then sgr p.[x] + else aux p^`() n' + else 0 + in aux p (size p). + +Lemma sgp_right0 : forall x, sgp_right 0 x = 0. +Proof. by move=> x; rewrite /sgp_right size_poly0. Qed. + +Lemma sgr_neighpr : forall b p x, + {in neighpr p x b, forall y, (sgr p.[y] = sgp_right p x)}. +Proof. +move=> b p x. +elim: (size p) {-2}p (leqnn (size p))=> [|n ihn] {p} p. + rewrite leqn0 size_poly_eq0 /neighpr; move/eqP=> -> /=. + by move=>y; rewrite next_root0 itv_xx. +rewrite leq_eqVlt ltnS; case/orP; last exact: ihn. +move/eqP=> sp; rewrite /sgp_right sp /=. +case px0: root=> /=; last first. + move=> y; rewrite/neighpr => hy /=; symmetry. + apply: (@polyrN0_itv `[x, y]); do ?by rewrite bound_in_itv /= (itvP hy). + move=> z; rewrite (@itv_splitU _ x true) ?bound_in_itv /= ?(itvP hy) //. + rewrite itv_xx /=; case/predU1P=> hz; first by rewrite hz px0. + rewrite (@next_noroot p x b) //. + by apply: subitvPr hz=> /=; rewrite (itvP hy). +have <-: size p^`() = n by rewrite size_deriv sp. +rewrite -/(sgp_right p^`() x). +move=> y; rewrite /neighpr=> hy /=. +case: (@neighpr_wit (p * p^`()) x b)=> [||m hm]. +* case: next_rootP hy; first by rewrite itv_xx. + by move=> ? ? ?; move/itvP->. + by move=> c p0 -> _; case: maxrP=> _; rewrite ?itv_xx //; move/itvP->. +* rewrite mulf_neq0 //. + by move/eqP:sp; apply: contraTneq=> ->; rewrite size_poly0. + (* Todo : a lemma for this *) + move: (size_deriv p); rewrite sp /=; move/eqP; apply: contraTneq=> ->. + rewrite size_poly0; apply: contraTneq px0=> hn; rewrite -hn in sp. + by move/eqP: sp; case/size_poly1P=> c nc0 ->; rewrite rootC. +* move: hm; rewrite neighpr_mul /neighpr inE /=; case/andP=> hmp hmp'. + rewrite (polyrN0_itv _ hmp) //; last exact: next_noroot. + rewrite (@ders0r p x m (mid x m)) ?(eqP px0) ?mid_in_itv ?bound_in_itv //; + rewrite /= ?(itvP hmp) //; last first. + move=> u hu /=; rewrite (@next_noroot _ x b) //. + by apply: subitvPr hu; rewrite /= (itvP hmp'). + rewrite ihn ?size_deriv ?sp /neighpr //. + by rewrite (subitvP _ (@mid_in_itv _ true true _ _ _)) //= ?lerr (itvP hmp'). +Qed. + +Lemma sgr_neighpl : forall a p x, + {in neighpl p a x, forall y, + (sgr p.[y] = (-1) ^+ (odd (\mu_x p)) * sgp_right p x) + }. +Proof. +move=> a p x. +elim: (size p) {-2}p (leqnn (size p))=> [|n ihn] {p} p. + rewrite leqn0 size_poly_eq0 /neighpl; move/eqP=> -> /=. + by move=>y; rewrite prev_root0 itv_xx. +rewrite leq_eqVlt ltnS; case/orP; last exact: ihn. +move/eqP=> sp; rewrite /sgp_right sp /=. +case px0: root=> /=; last first. + move=> y; rewrite/neighpl => hy /=; symmetry. + move: (negbT px0); rewrite -mu_gt0; last first. + by apply: contraFN px0; move/eqP->; rewrite rootC. + rewrite -leqNgt leqn0; move/eqP=> -> /=; rewrite expr0 mul1r. + symmetry; apply: (@polyrN0_itv `[y, x]); + do ?by rewrite bound_in_itv /= (itvP hy). + move=> z; rewrite (@itv_splitU _ x false) ?bound_in_itv /= ?(itvP hy) //. + rewrite itv_xx /= orbC; case/predU1P=> hz; first by rewrite hz px0. + rewrite (@prev_noroot p a x) //. + by apply: subitvPl hz=> /=; rewrite (itvP hy). +have <-: size p^`() = n by rewrite size_deriv sp. +rewrite -/(sgp_right p^`() x). +move=> y; rewrite /neighpl=> hy /=. +case: (@neighpl_wit (p * p^`()) a x)=> [||m hm]. +* case: prev_rootP hy; first by rewrite itv_xx. + by move=> ? ? ?; move/itvP->. + by move=> c p0 -> _; case: minrP=> _; rewrite ?itv_xx //; move/itvP->. +* rewrite mulf_neq0 //. + by move/eqP:sp; apply: contraTneq=> ->; rewrite size_poly0. + (* Todo : a lemma for this *) + move: (size_deriv p); rewrite sp /=; move/eqP; apply: contraTneq=> ->. + rewrite size_poly0; apply: contraTneq px0=> hn; rewrite -hn in sp. + by move/eqP: sp; case/size_poly1P=> c nc0 ->; rewrite rootC. +* move: hm; rewrite neighpl_mul /neighpl inE /=; case/andP=> hmp hmp'. + rewrite (polyrN0_itv _ hmp) //; last exact: prev_noroot. + rewrite (@ders0l p m x (mid m x)) ?(eqP px0) ?mid_in_itv ?bound_in_itv //; + rewrite /= ?(itvP hmp) //; last first. + move=> u hu /=; rewrite (@prev_noroot _ a x) //. + by apply: subitvPl hu; rewrite /= (itvP hmp'). + rewrite ihn ?size_deriv ?sp /neighpl //; last first. + by rewrite (subitvP _ (@mid_in_itv _ true true _ _ _)) //= ?lerr (itvP hmp'). + rewrite mu_deriv // odd_sub ?mu_gt0 //=; last by rewrite -size_poly_eq0 sp. + by rewrite signr_addb /= mulrN1 mulNr opprK. +Qed. + +Lemma sgp_right_deriv : forall (p : {poly R}) x, root p x -> + sgp_right p x = sgp_right (p^`()) x. +Proof. +move=> p; elim: (size p) {-2}p (erefl (size p)) => {p} [p|sp hp p hsp x]. + by move/eqP; rewrite size_poly_eq0; move/eqP=> -> x _; rewrite derivC. +by rewrite /sgp_right size_deriv hsp /= => ->. +Qed. + +Lemma sgp_rightNroot : forall (p : {poly R}) x, + ~~ root p x -> sgp_right p x = sgr p.[x]. +Proof. +move=> p x nrpx; rewrite /sgp_right; case hsp: (size _)=> [|sp]. + by move/eqP:hsp; rewrite size_poly_eq0; move/eqP->; rewrite hornerC sgr0. +by rewrite nrpx. +Qed. + +Lemma sgp_right_mul : forall p q x, + sgp_right (p * q) x = sgp_right p x * sgp_right q x. +Proof. +move=> p q x. +case: (altP (q =P 0))=> q0; first by rewrite q0 /sgp_right !(size_poly0,mulr0). +case: (altP (p =P 0))=> p0; first by rewrite p0 /sgp_right !(size_poly0,mul0r). +case: (@neighpr_wit (p * q) x (1 + x))=> [||m hpq]; do ?by rewrite mulf_neq0. + by rewrite ltr_spaddl ?ltr01. +rewrite -(@sgr_neighpr (1 + x) _ _ m) //. +move: hpq; rewrite neighpr_mul inE /=; case/andP=> hp hq. +by rewrite hornerM sgrM !(@sgr_neighpr (1 + x) _ x) /neighpr. +Qed. + +Lemma sgp_right_scale c p x : sgp_right (c *: p) x = sgr c * sgp_right p x. +Proof. +case c0: (c == 0); first by rewrite (eqP c0) scale0r sgr0 mul0r sgp_right0. +by rewrite -mul_polyC sgp_right_mul sgp_rightNroot ?hornerC ?rootC ?c0. +Qed. + +Lemma sgp_right_square : forall p x, p != 0 -> sgp_right p x * sgp_right p x = 1. +Proof. +move=> p x np0; case: (@neighpr_wit p x (1 + x))=> [||m hpq] //. + by rewrite ltr_spaddl ?ltr01. +rewrite -(@sgr_neighpr (1 + x) _ _ m) //. +by rewrite -expr2 sqr_sg (@next_noroot _ x (1 + x)). +Qed. + +Lemma sgp_right_rec p x : sgp_right p x = + if p == 0 then 0 else + if ~~ root p x then sgr p.[x] + else sgp_right p^`() x. +Proof. +rewrite /sgp_right; case hs: size=> [|s]; rewrite -size_poly_eq0 hs //=. +by rewrite size_deriv hs. +Qed. + +Lemma sgp_right_addp0 : forall (p q : {poly R}) x, q != 0 -> + (\mu_x p > \mu_x q)%N -> sgp_right (p + q) x = sgp_right q x. +Proof. +move=> p q x nq0; move hm: (\mu_x q)=> m. +elim: m p q nq0 hm => [|mq ihmq] p q nq0 hmq; case hmp: (\mu_x p)=> // [mp]; + do[ + rewrite ltnS=> hm; + rewrite sgp_right_rec {1}addrC; + rewrite GRing.Theory.addr_eq0]. (* Todo : fix this ! *) + case: (altP (_ =P _))=> hqp. + move: (nq0); rewrite {1}hqp oppr_eq0=> np0. + rewrite sgp_right_rec (negPf nq0) -mu_gt0 // hmq /=. + apply/eqP; rewrite eq_sym hqp hornerN sgrN. + by rewrite oppr_eq0 sgr_eq0 -[_ == _]mu_gt0 ?hmp. + rewrite rootE hornerD. + have ->: p.[x] = 0. + apply/eqP; rewrite -[_ == _]mu_gt0 ?hmp //. + by move/eqP: hmp; apply: contraTneq=> ->; rewrite mu0. + symmetry; rewrite sgp_right_rec (negPf nq0) add0r. + by rewrite -/(root _ _) -mu_gt0 // hmq. +case: (altP (_ =P _))=> hqp. + by move: hm; rewrite -ltnS -hmq -hmp hqp mu_opp ltnn. +have px0: p.[x] = 0. + apply/rootP; rewrite -mu_gt0 ?hmp //. + by move/eqP: hmp; apply: contraTneq=> ->; rewrite mu0. +have qx0: q.[x] = 0 by apply/rootP; rewrite -mu_gt0 ?hmq //. +rewrite rootE hornerD px0 qx0 add0r eqxx /=; symmetry. +rewrite sgp_right_rec rootE (negPf nq0) qx0 eqxx /=. +rewrite derivD ihmq // ?mu_deriv ?rootE ?px0 ?qx0 ?hmp ?hmq ?subn1 //. +apply: contra nq0; rewrite -size_poly_eq0 size_deriv. +case hsq: size=> [|sq] /=. + by move/eqP: hsq; rewrite size_poly_eq0. +move/eqP=> sq0; move/eqP: hsq qx0; rewrite sq0; case/size_poly1P=> c c0 ->. +by rewrite hornerC; move/eqP; rewrite (negPf c0). +Qed. + +End SignRight. + +(* redistribute some of what follows with in the file *) +Section PolyRCFPdiv. +Import Pdiv.Ring Pdiv.ComRing. + +Lemma sgp_rightc (x c : R) : sgp_right c%:P x = sgr c. +Proof. +rewrite /sgp_right size_polyC. +case cn0: (_ == 0)=> /=; first by rewrite (eqP cn0) sgr0. +by rewrite rootC hornerC cn0. +Qed. + +Lemma sgp_right_eq0 (x : R) p : (sgp_right p x == 0) = (p == 0). +Proof. +case: (altP (p =P 0))=> p0; first by rewrite p0 sgp_rightc sgr0 eqxx. +rewrite /sgp_right. +elim: (size p) {-2}p (erefl (size p)) p0=> {p} [|sp ihsp] p esp p0. + by move/eqP:esp; rewrite size_poly_eq0 (negPf p0). +rewrite esp /=; case px0: root=> //=; rewrite ?sgr_cp0 ?px0//. +have hsp: sp = size p^`() by rewrite size_deriv esp. +rewrite hsp ihsp // -size_poly_eq0 -hsp; apply/negP; move/eqP=> sp0. +move: px0; rewrite root_factor_theorem. +by move=> /rdvdp_leq // /(_ p0); rewrite size_XsubC esp sp0. +Qed. + +(* :TODO: backport to polydiv *) +Lemma lc_expn_rscalp_neq0 (p q : {poly R}): lead_coef q ^+ rscalp p q != 0. +Proof. +case: (eqVneq q 0) => [->|nzq]; last by rewrite expf_neq0 ?lead_coef_eq0. +by rewrite /rscalp unlock /= eqxx /= expr0 oner_neq0. +Qed. +Notation lcn_neq0 := lc_expn_rscalp_neq0. + +Lemma sgp_right_mod : forall p q x, (\mu_x p < \mu_x q)%N -> + sgp_right (rmodp p q) x = (sgr (lead_coef q)) ^+ (rscalp p q) * sgp_right p x. +Proof. +move=> p q x mupq; case p0: (p == 0). + by rewrite (eqP p0) rmod0p !sgp_right0 mulr0. +have qn0 : q != 0. + by apply/negP; move/eqP=> q0; rewrite q0 mu0 ltn0 in mupq. +move/eqP: (rdivp_eq q p). +rewrite eq_sym (can2_eq (addKr _ ) (addNKr _)); move/eqP->. +case qpq0: ((rdivp p q) == 0). + by rewrite (eqP qpq0) mul0r oppr0 add0r sgp_right_scale // sgrX. +rewrite sgp_right_addp0 ?sgp_right_scale ?sgrX //. + by rewrite scaler_eq0 negb_or p0 lcn_neq0. +rewrite mu_mulC ?lcn_neq0 // mu_opp mu_mul ?mulf_neq0 ?qpq0 //. +by rewrite ltn_addl. +Qed. + +Lemma rootsC (a b c : R) : roots c%:P a b = [::]. +Proof. +case: (altP (c =P 0))=> hc; first by rewrite hc roots0. +by apply: no_root_roots=> x hx; rewrite rootC. +Qed. + +Lemma rootsZ a b c p : c != 0 -> roots (c *: p) a b = roots p a b. +Proof. +have [->|p_neq0 c_neq0] := eqVneq p 0; first by rewrite scaler0. +by apply/roots_eq => [||x axb]; rewrite ?scaler_eq0 ?(negPf c_neq0) ?rootZ. +Qed. + +Lemma root_bigrgcd (x : R) (ps : seq {poly R}) : + root (\big[(@rgcdp _)/0]_(p <- ps) p) x = all (root^~ x) ps. +Proof. +elim: ps; first by rewrite big_nil root0. +move=> p ps ihp; rewrite big_cons /=. +by rewrite (eqp_root (eqp_rgcd_gcd _ _)) root_gcd ihp. +Qed. + +Definition rootsR p := roots p (- cauchy_bound p) (cauchy_bound p). + +Lemma roots_on_rootsR p : p != 0 -> roots_on p `]-oo, +oo[ (rootsR p). +Proof. +rewrite /rootsR => p_neq0 x /=; rewrite -roots_on_roots // andbC. +by have [/(cauchy_boundP p_neq0) /=|//] := altP rootP; rewrite ltr_norml. +Qed. + +Lemma rootsR0 : rootsR 0 = [::]. Proof. exact: roots0. Qed. + +Lemma rootsRC c : rootsR c%:P = [::]. Proof. exact: rootsC. Qed. + +Lemma rootsRP p a b : + {in `]-oo, a], noroot p} -> {in `[b , +oo[, noroot p} -> + roots p a b = rootsR p. +Proof. +move=> rpa rpb. +have [->|p_neq0] := eqVneq p 0; first by rewrite rootsR0 roots0. +apply: (eq_sorted_irr (@ltr_trans _)); rewrite ?sorted_roots // => x. +rewrite -roots_on_rootsR -?roots_on_roots //=. +have [rpx|] := boolP (root _ _); rewrite ?(andbT, andbF) //. +apply: contraLR rpx; rewrite inE negb_and -!lerNgt. +by move=> /orP[/rpa //|xb]; rewrite rpb // inE andbT. +Qed. + +Lemma sgp_pinftyP x (p : {poly R}) : {in `[x , +oo[, noroot p} -> + {in `[x, +oo[, forall y, sgr p.[y] = sgp_pinfty p}. +Proof. +rewrite /sgp_pinfty; wlog lp_gt0 : x p / lead_coef p > 0 => [hwlog|rpx y Hy]. + have [|/(hwlog x p) //|/eqP] := ltrgtP (lead_coef p) 0; last first. + by rewrite lead_coef_eq0 => /eqP -> ? ? ?; rewrite lead_coef0 horner0. + rewrite -[p]opprK lead_coef_opp oppr_cp0 => /(hwlog x _) Hp HNp y Hy. + by rewrite hornerN !sgrN Hp => // z /HNp; rewrite rootN. +have [z Hz] := poly_pinfty_gt_lc lp_gt0. +have {Hz} Hz u : u \in `[z, +oo[ -> Num.sg p.[u] = 1. + by rewrite inE andbT => /Hz pu_ge1; rewrite gtr0_sg // (ltr_le_trans lp_gt0). +rewrite (@polyrN0_itv _ _ rpx (maxr y z)) ?inE ?ler_maxr ?(itvP Hy) //. +by rewrite Hz ?gtr0_sg // inE ler_maxr lerr orbT. +Qed. + +Lemma sgp_minftyP x (p : {poly R}) : {in `]-oo, x], noroot p} -> + {in `]-oo, x], forall y, sgr p.[y] = sgp_minfty p}. +Proof. +move=> rpx y Hy; rewrite -sgp_pinfty_sym. +have -> : p.[y] = (p \Po -'X).[-y] by rewrite horner_comp !hornerE opprK. +apply: (@sgp_pinftyP (- x)); last by rewrite inE ler_opp2 (itvP Hy). +by move=> z Hz /=; rewrite root_comp !hornerE rpx // inE ler_oppl (itvP Hz). +Qed. + +Lemma odd_poly_root (p : {poly R}) : ~~ odd (size p) -> {x | root p x}. +Proof. +move=> size_p_even. +have [->|p_neq0] := altP (p =P 0); first by exists 0; rewrite root0. +pose b := cauchy_bound p. +have [] := @ivt_sign p (-b) b; last by move=> x _; exists x. + by rewrite ge0_cp // ?cauchy_bound_ge0. +rewrite (sgp_minftyP (le_cauchy_bound p_neq0)) ?bound_in_itv //. +rewrite (sgp_pinftyP (ge_cauchy_bound p_neq0)) ?bound_in_itv //. +move: size_p_even; rewrite polySpred //= negbK /sgp_minfty -signr_odd => ->. +by rewrite expr1 mulN1r sgrN mulNr -expr2 sqr_sg lead_coef_eq0 p_neq0. +Qed. +End PolyRCFPdiv. + +End PolyRCF. diff --git a/mathcomp/real_closed/qe_rcf.v b/mathcomp/real_closed/qe_rcf.v new file mode 100644 index 0000000..1791aca --- /dev/null +++ b/mathcomp/real_closed/qe_rcf.v @@ -0,0 +1,1008 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype. +Require Import finfun path matrix. +Require Import bigop ssralg poly polydiv ssrnum zmodp div ssrint. +Require Import polyorder polyrcf interval polyXY. +Require Import qe_rcf_th ordered_qelim mxtens. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GRing.Theory Num.Theory. + +Local Open Scope nat_scope. +Local Open Scope ring_scope. + +Import ord. + +Section QF. + +Variable R : Type. + +Inductive term : Type := +| Var of nat +| Const of R +| NatConst of nat +| Add of term & term +| Opp of term +| NatMul of term & nat +| Mul of term & term +| Exp of term & nat. + +Inductive formula : Type := +| Bool of bool +| Equal of term & term +| Lt of term & term +| Le of term & term +| And of formula & formula +| Or of formula & formula +| Implies of formula & formula +| Not of formula. + +Coercion rterm_to_term := fix loop (t : term) : GRing.term R := + match t with + | Var x => GRing.Var _ x + | Const x => GRing.Const x + | NatConst n => GRing.NatConst _ n + | Add u v => GRing.Add (loop u) (loop v) + | Opp u => GRing.Opp (loop u) + | NatMul u n => GRing.NatMul (loop u) n + | Mul u v => GRing.Mul (loop u) (loop v) + | Exp u n => GRing.Exp (loop u) n + end. + +Coercion qfr_to_formula := fix loop (f : formula) : ord.formula R := + match f with + | Bool b => ord.Bool b + | Equal x y => ord.Equal x y + | Lt x y => ord.Lt x y + | Le x y => ord.Le x y + | And f g => ord.And (loop f) (loop g) + | Or f g => ord.Or (loop f) (loop g) + | Implies f g => ord.Implies (loop f) (loop g) + | Not f => ord.Not (loop f) + end. + +Definition to_rterm := fix loop (t : GRing.term R) : term := + match t with + | GRing.Var x => Var x + | GRing.Const x => Const x + | GRing.NatConst n => NatConst n + | GRing.Add u v => Add (loop u) (loop v) + | GRing.Opp u => Opp (loop u) + | GRing.NatMul u n => NatMul (loop u) n + | GRing.Mul u v => Mul (loop u) (loop v) + | GRing.Exp u n => Exp (loop u) n + | _ => NatConst 0 + end. + +End QF. + +Bind Scope qf_scope with term. +Bind Scope qf_scope with formula. +Arguments Scope Add [_ qf_scope qf_scope]. +Arguments Scope Opp [_ qf_scope]. +Arguments Scope NatMul [_ qf_scope nat_scope]. +Arguments Scope Mul [_ qf_scope qf_scope]. +Arguments Scope Mul [_ qf_scope qf_scope]. +Arguments Scope Exp [_ qf_scope nat_scope]. +Arguments Scope Equal [_ qf_scope qf_scope]. +Arguments Scope And [_ qf_scope qf_scope]. +Arguments Scope Or [_ qf_scope qf_scope]. +Arguments Scope Implies [_ qf_scope qf_scope]. +Arguments Scope Not [_ qf_scope]. + +Implicit Arguments Bool [R]. +Prenex Implicits Const Add Opp NatMul Mul Exp Bool Unit And Or Implies Not Lt. +Prenex Implicits to_rterm. + +Notation True := (Bool true). +Notation False := (Bool false). + +Delimit Scope qf_scope with qfT. +Notation "''X_' i" := (Var _ i) : qf_scope. +Notation "n %:R" := (NatConst _ n) : qf_scope. +Notation "x %:T" := (Const x) : qf_scope. +Notation "0" := 0%:R%qfT : qf_scope. +Notation "1" := 1%:R%qfT : qf_scope. +Infix "+" := Add : qf_scope. +Notation "- t" := (Opp t) : qf_scope. +Notation "t - u" := (Add t (- u)) : qf_scope. +Infix "*" := Mul : qf_scope. +Infix "*+" := NatMul : qf_scope. +Infix "^+" := Exp : qf_scope. +Notation "t ^- n" := (t^-1 ^+ n)%qfT : qf_scope. +Infix "==" := Equal : qf_scope. +Infix "<%" := Lt : qf_scope. +Infix "<=%" := Le : qf_scope. +Infix "/\" := And : qf_scope. +Infix "\/" := Or : qf_scope. +Infix "==>" := Implies : qf_scope. +Notation "~ f" := (Not f) : qf_scope. +Notation "x != y" := (Not (x == y)) : qf_scope. + +Section evaluation. + +Variable R : realDomainType. + +Fixpoint eval (e : seq R) (t : term R) {struct t} : R := + match t with + | ('X_i)%qfT => e`_i + | (x%:T)%qfT => x + | (n%:R)%qfT => n%:R + | (t1 + t2)%qfT => eval e t1 + eval e t2 + | (- t1)%qfT => - eval e t1 + | (t1 *+ n)%qfT => eval e t1 *+ n + | (t1 * t2)%qfT => eval e t1 * eval e t2 + | (t1 ^+ n)%qfT => eval e t1 ^+ n + end. + +Lemma evalE (e : seq R) (t : term R) : eval e t = GRing.eval e t. +Proof. by elim: t=> /=; do ?[move->|move=>?]. Qed. + +Definition qf_eval e := fix loop (f : formula R) : bool := + match f with + | Bool b => b + | t1 == t2 => (eval e t1 == eval e t2)%bool + | t1 <% t2 => (eval e t1 < eval e t2)%bool + | t1 <=% t2 => (eval e t1 <= eval e t2)%bool + | f1 /\ f2 => loop f1 && loop f2 + | f1 \/ f2 => loop f1 || loop f2 + | f1 ==> f2 => (loop f1 ==> loop f2)%bool + | ~ f1 => ~~ loop f1 + end%qfT. + +Lemma qf_evalE (e : seq R) (f : formula R) : qf_eval e f = ord.qf_eval e f. +Proof. by elim: f=> /=; do ?[rewrite evalE|move->|move=>?]. Qed. + +Lemma to_rtermE (t : GRing.term R) : + GRing.rterm t -> to_rterm t = t :> GRing.term _. +Proof. +elim: t=> //=; do ? + [ by move=> u hu v hv /andP[ru rv]; rewrite hu ?hv + | by move=> u hu *; rewrite hu]. +Qed. + +End evaluation. + +Import Pdiv.Ring. + +Definition bind_def T1 T2 T3 (f : (T1 -> T2) -> T3) (k : T1 -> T2) := f k. +Notation "'bind' x <- y ; z" := + (bind_def y (fun x => z)) (at level 99, x at level 0, y at level 0, + format "'[hv' 'bind' x <- y ; '/' z ']'"). + +Section ProjDef. + +Variable F : realFieldType. + +Notation fF := (formula F). +Notation tF := (term F). +Definition polyF := seq tF. + +Lemma qf_formF (f : fF) : qf_form f. +Proof. by elim: f=> // *; apply/andP; split. Qed. + +Lemma rtermF (t : tF) : GRing.rterm t. +Proof. by elim: t=> //=; do ?[move->|move=>?]. Qed. + +Lemma rformulaF (f : fF) : rformula f. +Proof. by elim: f=> /=; do ?[rewrite rtermF|move->|move=>?]. Qed. + +Section If. + +Implicit Types (pf tf ef : formula F). + +Definition If pf tf ef := (pf /\ tf \/ ~ pf /\ ef)%qfT. + +End If. + +Notation "'If' c1 'Then' c2 'Else' c3" := (If c1 c2 c3) + (at level 200, right associativity, format +"'[hv ' 'If' c1 '/' '[' 'Then' c2 ']' '/' '[' 'Else' c3 ']' ']'"). + +Notation cps T := ((T -> fF) -> fF). + +Section Pick. + +Variables (I : finType) (pred_f then_f : I -> fF) (else_f : fF). + +Definition Pick := + \big[Or/False]_(p : {ffun pred I}) + ((\big[And/True]_i (if p i then pred_f i else ~ pred_f i)) + /\ (if pick p is Some i then then_f i else else_f))%qfT. + +Lemma eval_Pick e (qev := qf_eval e) : + let P i := qev (pred_f i) in + qev Pick = (if pick P is Some i then qev (then_f i) else qev else_f). +Proof. +move=> P; rewrite ((big_morph qev) false orb) //= big_orE /=. +apply/existsP/idP=> [[p] | true_at_P]. + rewrite ((big_morph qev) true andb) //= big_andE /=. + case/andP=> /forallP eq_p_P. + rewrite (@eq_pick _ _ P) => [|i]; first by case: pick. + by move/(_ i): eq_p_P => /=; case: (p i) => //=; move/negbTE. +exists [ffun i => P i] => /=; apply/andP; split. + rewrite ((big_morph qev) true andb) //= big_andE /=. + by apply/forallP=> i; rewrite /= ffunE; case Pi: (P i) => //=; apply: negbT. +rewrite (@eq_pick _ _ P) => [|i]; first by case: pick true_at_P. +by rewrite ffunE. +Qed. + +End Pick. + +Fixpoint eval_poly (e : seq F) pf := + if pf is c :: qf then (eval_poly e qf) * 'X + (eval e c)%:P else 0. + +Lemma eval_polyP e p : eval_poly e p = Poly (map (eval e) p). +Proof. by elim: p=> // a p /= ->; rewrite cons_poly_def. Qed. + +Fixpoint Size (p : polyF) : cps nat := fun k => + if p is c :: q then + bind n <- Size q; + if n is m.+1 then k m.+2 + else If c == 0 Then k 0%N Else k 1%N + else k 0%N. + +Definition Isnull (p : polyF) : cps bool := fun k => + bind n <- Size p; k (n == 0%N). + +Definition LtSize (p q : polyF) : cps bool := fun k => + bind n <- Size p; bind m <- Size q; k (n < m)%N. + +Fixpoint LeadCoef p : cps tF := fun k => + if p is c :: q then + bind l <- LeadCoef q; If l == 0 Then k c Else k l + else k (Const 0). + +Fixpoint AmulXn (a : tF) (n : nat) : polyF:= + if n is n'.+1 then (Const 0) :: (AmulXn a n') else [::a]. + +Fixpoint AddPoly (p q : polyF) := + if p is a::p' then + if q is b::q' then (a + b)%qfT :: (AddPoly p' q') + else p + else q. +Local Infix "++" := AddPoly : qf_scope. + +Definition ScalPoly (c : tF) (p : polyF) : polyF := map (Mul c) p. +Local Infix "*:" := ScalPoly : qf_scope. + +Fixpoint MulPoly (p q : polyF) := if p is a :: p' + then (a *: q ++ (0 :: (MulPoly p' q)))%qfT else [::]. +Local Infix "**" := MulPoly (at level 40) : qf_scope. + +Lemma map_poly0 (R R' : ringType) (f : R -> R') : map_poly f 0 = 0. +Proof. by rewrite map_polyE polyseq0. Qed. + +Definition ExpPoly p n := iterop n MulPoly p [::1%qfT]. +Local Infix "^^+" := ExpPoly (at level 29) : qf_scope. + +Definition OppPoly := ScalPoly (@Const F (-1)). +Local Notation "-- p" := (OppPoly p) (at level 35) : qf_scope. +Local Notation "p -- q" := (p ++ (-- q))%qfT (at level 50) : qf_scope. + +Definition NatMulPoly n := ScalPoly (NatConst F n). +Local Infix "+**" := NatMulPoly (at level 40) : qf_scope. + +Fixpoint Horner (p : polyF) (x : tF) : tF := + if p is a :: p then (Horner p x * x + a)%qfT else 0%qfT. + +Fixpoint Deriv (p : polyF) : polyF := + if p is a :: q then (q ++ (0 :: Deriv q))%qfT else [::]. + +Fixpoint Rediv_rec_loop (q : polyF) sq cq + (c : nat) (qq r : polyF) (n : nat) {struct n} : + cps (nat * polyF * polyF) := fun k => + bind sr <- Size r; + if (sr < sq)%N then k (c, qq, r) else + bind lr <- LeadCoef r; + let m := AmulXn lr (sr - sq) in + let qq1 := (qq ** [::cq] ++ m)%qfT in + let r1 := (r ** [::cq] -- m ** q)%qfT in + if n is n1.+1 then Rediv_rec_loop q sq cq c.+1 qq1 r1 n1 k + else k (c.+1, qq1, r1). + + Definition Rediv (p : polyF) (q : polyF) : cps (nat * polyF * polyF) := + fun k => + bind b <- Isnull q; + if b then k (0%N, [::Const 0], p) + else bind sq <- Size q; + bind sp <- Size p; + bind lq <- LeadCoef q; + Rediv_rec_loop q sq lq 0 [::Const 0] p sp k. + +Definition Rmod (p : polyF) (q : polyF) (k : polyF -> fF) : fF := + Rediv p q (fun d => k d.2)%PAIR. +Definition Rdiv (p : polyF) (q : polyF) (k : polyF -> fF) : fF := + Rediv p q (fun d => k d.1.2)%PAIR. +Definition Rscal (p : polyF) (q : polyF) (k : nat -> fF) : fF := + Rediv p q (fun d => k d.1.1)%PAIR. +Definition Rdvd (p : polyF) (q : polyF) (k : bool -> fF) : fF := + bind r <- Rmod p q; bind r_null <- Isnull r; k r_null. + +Fixpoint rgcdp_loop n (pp qq : {poly F}) {struct n} := + if rmodp pp qq == 0 then qq + else if n is n1.+1 then rgcdp_loop n1 qq (rmodp pp qq) + else rmodp pp qq. + +Fixpoint Rgcd_loop n pp qq k {struct n} := + bind r <- Rmod pp qq; bind b <- Isnull r; + if b then (k qq) + else if n is n1.+1 then Rgcd_loop n1 qq r k else k r. + +Definition Rgcd (p : polyF) (q : polyF) : cps polyF := fun k => + let aux p1 q1 k := (bind b <- Isnull p1; + if b then k q1 else bind n <- Size p1; Rgcd_loop n p1 q1 k) in + bind b <- LtSize p q; + if b then aux q p k else aux p q k. + +Fixpoint BigRgcd (ps : seq polyF) : cps (seq tF) := fun k => + if ps is p :: pr then bind r <- BigRgcd pr; Rgcd p r k else k [::Const 0]. + +Fixpoint Changes (s : seq tF) : cps nat := fun k => + if s is a :: q then + bind v <- Changes q; + If (Lt (a * head 0 q) 0)%qfT Then k (1 + v)%N Else k v + else k 0%N. + +Fixpoint SeqPInfty (ps : seq polyF) : cps (seq tF) := fun k => + if ps is p :: ps then + bind lp <- LeadCoef p; + bind lps <- SeqPInfty ps; + k (lp :: lps) + else k [::]. + +Fixpoint SeqMInfty (ps : seq polyF) : cps (seq tF) := fun k => + if ps is p :: ps then + bind lp <- LeadCoef p; + bind sp <- Size p; + bind lps <- SeqMInfty ps; + k ((-1)%:T ^+ (~~ odd sp) * lp :: lps)%qfT + else k [::]. + +Definition ChangesPoly ps : cps int := fun k => + bind mps <- SeqMInfty ps; + bind pps <- SeqPInfty ps; + bind vm <- Changes mps; bind vp <- Changes pps; k (vm%:Z - vp%:Z). + +Definition NextMod (p q : polyF) : cps polyF := fun k => + bind lq <- LeadCoef q; + bind spq <- Rscal p q; + bind rpq <- Rmod p q; k (- lq ^+ spq *: rpq)%qfT. + +Fixpoint ModsAux (p q : polyF) n : cps (seq polyF) := fun k => + if n is m.+1 + then + bind p_eq0 <- Isnull p; + if p_eq0 then k [::] + else + bind npq <- NextMod p q; + bind ps <- ModsAux q npq m; + k (p :: ps) + else k [::]. + +Definition Mods (p q : polyF) : cps (seq polyF) := fun k => + bind sp <- Size p; bind sq <- Size q; + ModsAux p q (maxn sp sq.+1) k. + +Definition PolyComb (sq : seq polyF) (sc : seq int) := + reducebig [::1%qfT] (iota 0 (size sq)) + (fun i => BigBody i MulPoly true (nth [::] sq i ^^+ comb_exp sc`_i)%qfT). + +Definition Pcq sq i := (nth [::] (map (PolyComb sq) (sg_tab (size sq))) i). + +Definition TaqR (p : polyF) (q : polyF) : cps int := fun k => + bind r <- Mods p (Deriv p ** q)%qfT; ChangesPoly r k. + +Definition TaqsR (p : polyF) (sq : seq polyF) (i : nat) : cps tF := + fun k => bind n <- TaqR p (Pcq sq i); k ((n%:~R) %:T)%qfT. + +Fixpoint ProdPoly T (s : seq T) (f : T -> cps polyF) : cps polyF := fun k => + if s is a :: s then + bind fa <- f a; + bind fs <- ProdPoly s f; + k (fa ** fs)%qfT + else k [::1%qfT]. + +Definition BoundingPoly (sq : seq polyF) : polyF := + Deriv (reducebig [::1%qfT] sq (fun i => BigBody i MulPoly true i)). + +Definition Coefs (n i : nat) : tF := + Const (match n with + | 0 => (i == 0%N)%:R + | 1 => [:: 2%:R^-1; 2%:R^-1; 0]`_i + | n => coefs _ n i + end). + +Definition CcountWeak (p : polyF) (sq : seq polyF) : cps tF := fun k => + let fix aux s (i : nat) k := if i is i'.+1 + then bind x <- TaqsR p sq i'; + aux (x * (Coefs (size sq) i') + s)%qfT i' k + else k s in + aux 0%qfT (3 ^ size sq)%N k. + +Definition CcountGt0 (sp sq : seq polyF) : fF := + bind p <- BigRgcd sp; bind p0 <- Isnull p; + if ~~ p0 then + bind c <- CcountWeak p sq; + Lt 0%qfT c + else + let bq := BoundingPoly sq in + bind cw <- CcountWeak bq sq; + ((reducebig True sq (fun q => + BigBody q And true (LeadCoef q (fun lq => Lt 0 lq)))) + \/ ((reducebig True sq (fun q => + BigBody q And true + (bind sq <- Size q; + bind lq <- LeadCoef q; + Lt 0 ((Opp 1) ^+ (sq).-1 * lq) + ))) \/ Lt 0 cw))%qfT. + + +Fixpoint abstrX (i : nat) (t : tF) : polyF := + (match t with + | 'X_n => if n == i then [::0; 1] else [::t] + | - x => -- abstrX i x + | x + y => abstrX i x ++ abstrX i y + | x * y => abstrX i x ** abstrX i y + | x *+ n => n +** abstrX i x + | x ^+ n => abstrX i x ^^+ n + | _ => [::t] + end)%qfT. + +Definition wproj (n : nat) (s : seq (GRing.term F) * seq (GRing.term F)) : + formula F := + let sp := map (abstrX n \o to_rterm) s.1%PAIR in + let sq := map (abstrX n \o to_rterm) s.2%PAIR in + CcountGt0 sp sq. + +Definition rcf_sat := proj_sat wproj. + +End ProjDef. + +Section ProjCorrect. + +Variable F : rcfType. +Implicit Types (e : seq F). + +Notation fF := (formula F). +Notation tF := (term F). +Notation polyF := (polyF F). + +Notation "'If' c1 'Then' c2 'Else' c3" := (If c1 c2 c3) + (at level 200, right associativity, format +"'[hv ' 'If' c1 '/' '[' 'Then' c2 ']' '/' '[' 'Else' c3 ']' ']'"). + +Notation cps T := ((T -> fF) -> fF). + +Local Infix "**" := MulPoly (at level 40) : qf_scope. +Local Infix "+**" := NatMulPoly (at level 40) : qf_scope. +Local Notation "-- p" := (OppPoly p) (at level 35) : qf_scope. +Local Notation "p -- q" := (p ++ (-- q))%qfT (at level 50) : qf_scope. +Local Infix "^^+" := ExpPoly (at level 29) : qf_scope. +Local Infix "**" := MulPoly (at level 40) : qf_scope. +Local Infix "*:" := ScalPoly : qf_scope. +Local Infix "++" := AddPoly : qf_scope. + +Lemma eval_If e pf tf ef (ev := qf_eval e) : + ev (If pf Then tf Else ef) = (if ev pf then ev tf else ev ef). +Proof. by unlock (If _ Then _ Else _)=> /=; case: ifP => _; rewrite ?orbF. Qed. + +Lemma eval_Size k p e : + qf_eval e (Size p k) = qf_eval e (k (size (eval_poly e p))). +Proof. +elim: p e k=> [|c p ihp] e k; first by rewrite size_poly0. +rewrite ihp /= size_MXaddC -size_poly_eq0; case: size=> //. +by rewrite eval_If /=; case: (_ == _). +Qed. + +Lemma eval_Isnull k p e : qf_eval e (Isnull p k) + = qf_eval e (k (eval_poly e p == 0)). +Proof. by rewrite eval_Size size_poly_eq0. Qed. + +Lemma eval_LeadCoef e p k k' : + (forall x, qf_eval e (k x) = (k' (eval e x))) -> + qf_eval e (LeadCoef p k) = k' (lead_coef (eval_poly e p)). +Proof. +move=> Pk; elim: p k k' Pk=> [|a p ihp] k k' Pk //=. + by rewrite lead_coef0 Pk. +rewrite (ihp _ (fun l => if l == 0 then qf_eval e (k a) else (k' l))); last first. + by move=> x; rewrite eval_If /= !Pk. +rewrite lead_coef_eq0; have [->|p_neq0] := altP (_ =P 0). + by rewrite mul0r add0r lead_coefC. +rewrite lead_coefDl ?lead_coefMX ?size_mulX // ltnS size_polyC. +by rewrite (leq_trans (leq_b1 _)) // size_poly_gt0. +Qed. + +Implicit Arguments eval_LeadCoef [e p k]. +Prenex Implicits eval_LeadCoef. + +Lemma eval_AmulXn a n e : eval_poly e (AmulXn a n) = (eval e a)%:P * 'X^n. +Proof. +elim: n=> [|n] /=; first by rewrite expr0 mulr1 mul0r add0r. +by move->; rewrite addr0 -mulrA -exprSr. +Qed. + +Lemma eval_AddPoly p q e : + eval_poly e (p ++ q)%qfT = (eval_poly e p) + (eval_poly e q). +Proof. +elim: p q => [|a p Hp] q /=; first by rewrite add0r. +case: q => [|b q] /=; first by rewrite addr0. +by rewrite Hp mulrDl rmorphD /= !addrA [X in _ = X + _]addrAC. +Qed. + +Lemma eval_ScalPoly e t p : + eval_poly e (ScalPoly t p) = (eval e t) *: (eval_poly e p). +Proof. +elim: p=> [|a p ihp] /=; first by rewrite scaler0. +by rewrite ihp scalerDr scalerAl -!mul_polyC rmorphM. +Qed. + +Lemma eval_MulPoly e p q : + eval_poly e (p ** q)%qfT = (eval_poly e p) * (eval_poly e q). +Proof. +elim: p q=> [|a p Hp] q /=; first by rewrite mul0r. +rewrite eval_AddPoly /= eval_ScalPoly Hp. +by rewrite addr0 mulrDl addrC mulrAC mul_polyC. +Qed. + +Lemma eval_ExpPoly e p n : eval_poly e (p ^^+ n)%qfT = (eval_poly e p) ^+ n. +Proof. +case: n=> [|n]; first by rewrite /= expr0 mul0r add0r. +rewrite /ExpPoly iteropS exprSr; elim: n=> [|n ihn] //=. + by rewrite expr0 mul1r. +by rewrite eval_MulPoly ihn exprS mulrA. +Qed. + +Lemma eval_NatMulPoly p n e : + eval_poly e (n +** p)%qfT = (eval_poly e p) *+ n. +Proof. +elim: p; rewrite //= ?mul0rn // => c p ->. +rewrite mulrnDl mulr_natl polyC_muln; congr (_+_). +by rewrite -mulr_natl mulrAC -mulrA mulr_natl mulrC. +Qed. + +Lemma eval_OppPoly p e : eval_poly e (-- p)%qfT = - eval_poly e p. +Proof. +elim: p; rewrite //= ?oppr0 // => t ts ->. +by rewrite !mulNr !opprD polyC_opp mul1r. +Qed. + +Lemma eval_Horner e p x : eval e (Horner p x) = (eval_poly e p).[eval e x]. +Proof. by elim: p => /= [|a p ihp]; rewrite !(horner0, hornerE) // ihp. Qed. + +Lemma eval_ConstPoly e c : eval_poly e [::c] = (eval e c)%:P. +Proof. by rewrite /= mul0r add0r. Qed. + +Lemma eval_Deriv e p : eval_poly e (Deriv p) = (eval_poly e p)^`(). +Proof. +elim: p=> [|a p ihp] /=; first by rewrite deriv0. +by rewrite eval_AddPoly /= addr0 ihp !derivE. +Qed. + +Definition eval_OpPoly := + (eval_MulPoly, eval_AmulXn, eval_AddPoly, eval_OppPoly, eval_NatMulPoly, + eval_ConstPoly, eval_Horner, eval_ExpPoly, eval_Deriv, eval_ScalPoly). + +Lemma eval_Changes e s k : qf_eval e (Changes s k) + = qf_eval e (k (changes (map (eval e) s))). +Proof. +elim: s k=> //= a q ihq k; rewrite ihq eval_If /= -nth0. +by case: q {ihq}=> /= [|b q]; [rewrite /= mulr0 ltrr add0n | case: ltrP]. +Qed. + +Lemma eval_SeqPInfty e ps k k' : + (forall xs, qf_eval e (k xs) = k' (map (eval e) xs)) -> + qf_eval e (SeqPInfty ps k) + = k' (map lead_coef (map (eval_poly e) ps)). +Proof. +elim: ps k k' => [|p ps ihps] k k' Pk /=; first by rewrite Pk. +rewrite (eval_LeadCoef (fun lp => + k' (lp :: [seq lead_coef i |i <- [seq eval_poly e i | i <- ps]]))) => // lp. +rewrite (ihps _ (fun ps => k' (eval e lp :: ps))) => //= lps. +by rewrite Pk. +Qed. + +Implicit Arguments eval_SeqPInfty [e ps k]. +Prenex Implicits eval_SeqPInfty. + +Lemma eval_SeqMInfty e ps k k' : + (forall xs, qf_eval e (k xs) = k' (map (eval e) xs)) -> + qf_eval e (SeqMInfty ps k) + = k' (map (fun p : {poly F} => (-1) ^+ (~~ odd (size p)) * lead_coef p) + (map (eval_poly e) ps)). +Proof. +elim: ps k k' => [|p ps ihps] k k' Pk /=; first by rewrite Pk. +rewrite (eval_LeadCoef (fun lp => + k' ((-1) ^+ (~~ odd (size (eval_poly e p))) * lp + :: [seq (-1) ^+ (~~ odd (size p)) * lead_coef p + | p : {poly _} <- [seq eval_poly e i | i <- ps]]))) => // lp. +rewrite eval_Size /= (ihps _ (fun ps => + k' (((-1) ^+ (~~ odd (size (eval_poly e p))) * eval e lp) :: ps))) => //= lps. +by rewrite Pk. +Qed. + +Implicit Arguments eval_SeqMInfty [e ps k]. +Prenex Implicits eval_SeqMInfty. + +Lemma eval_ChangesPoly e ps k : qf_eval e (ChangesPoly ps k) = + qf_eval e (k (changes_poly (map (eval_poly e) ps))). +Proof. +rewrite (eval_SeqMInfty (fun mps => + qf_eval e (k ((changes mps)%:Z - + (changes_pinfty [seq eval_poly e i | i <- ps])%:Z)))) => // mps. +rewrite (eval_SeqPInfty (fun pps => + qf_eval e (k ((changes (map (eval e) mps))%:Z - (changes pps)%:Z)))) => // pps. +by rewrite !eval_Changes. +Qed. + +Fixpoint redivp_rec_loop (q : {poly F}) sq cq + (k : nat) (qq r : {poly F})(n : nat) {struct n} := + if (size r < sq)%N then (k, qq, r) else + let m := (lead_coef r) *: 'X^(size r - sq) in + let qq1 := qq * cq%:P + m in + let r1 := r * cq%:P - m * q in + if n is n1.+1 then redivp_rec_loop q sq cq k.+1 qq1 r1 n1 else (k.+1, qq1, r1). + +Lemma redivp_rec_loopP q c qq r n : redivp_rec q c qq r n + = redivp_rec_loop q (size q) (lead_coef q) c qq r n. +Proof. by elim: n c qq r => [| n Pn] c qq r //=; rewrite Pn. Qed. + +Lemma eval_Rediv_rec_loop e q sq cq c qq r n k k' + (d := redivp_rec_loop (eval_poly e q) sq (eval e cq) + c (eval_poly e qq) (eval_poly e r) n) : + (forall c qq r, qf_eval e (k (c, qq, r)) + = k' (c, eval_poly e qq, eval_poly e r)) -> + qf_eval e (Rediv_rec_loop q sq cq c qq r n k) = k' d. +Proof. +move=> Pk; elim: n c qq r k Pk @d=> [|n ihn] c qq r k Pk /=. + rewrite eval_Size /=; have [//=|gtq] := ltnP. + rewrite (eval_LeadCoef (fun lr => + let m := lr *: 'X^(size (eval_poly e r) - sq) in + let qq1 := (eval_poly e qq) * (eval e cq)%:P + m in + let r1 := (eval_poly e r) * (eval e cq)%:P - m * (eval_poly e q) in + k' (c.+1, qq1, r1))) //. + by move=> x /=; rewrite Pk /= !eval_OpPoly /= !mul_polyC. +rewrite eval_Size /=; have [//=|gtq] := ltnP. +rewrite (eval_LeadCoef (fun lr => + let m := lr *: 'X^(size (eval_poly e r) - sq) in + let qq1 := (eval_poly e qq) * (eval e cq)%:P + m in + let r1 := (eval_poly e r) * (eval e cq)%:P - m * (eval_poly e q) in + k' (redivp_rec_loop (eval_poly e q) sq (eval e cq) c.+1 qq1 r1 n))) //=. +by move=> x; rewrite ihn // !eval_OpPoly /= !mul_polyC. +Qed. + +Implicit Arguments eval_Rediv_rec_loop [e q sq cq c qq r n k]. +Prenex Implicits eval_Rediv_rec_loop. + +Lemma eval_Rediv e p q k k' (d := (redivp (eval_poly e p) (eval_poly e q))) : + (forall c qq r, qf_eval e (k (c, qq, r)) = k' (c, eval_poly e qq, eval_poly e r)) -> + qf_eval e (Rediv p q k) = k' d. +Proof. +move=> Pk; rewrite eval_Isnull /d unlock. +have [_|p_neq0] /= := boolP (_ == _); first by rewrite Pk /= mul0r add0r. +rewrite !eval_Size; set p' := eval_poly e p; set q' := eval_poly e q. +rewrite (eval_LeadCoef (fun lq => + k' (redivp_rec_loop q' (size q') lq 0 0 p' (size p')))) /=; last first. + by move=> x; rewrite (eval_Rediv_rec_loop k') //= mul0r add0r. +by rewrite redivp_rec_loopP. +Qed. + +Implicit Arguments eval_Rediv [e p q k]. +Prenex Implicits eval_Rediv. + +Lemma eval_NextMod e p q k k' : + (forall p, qf_eval e (k p) = k' (eval_poly e p)) -> + qf_eval e (NextMod p q k) = + k' (next_mod (eval_poly e p) (eval_poly e q)). +Proof. +move=> Pk; set p' := eval_poly e p; set q' := eval_poly e q. +rewrite (eval_LeadCoef (fun lq => + k' (- lq ^+ rscalp p' q' *: rmodp p' q'))) => // lq. +rewrite (eval_Rediv (fun spq => + k' (- eval e lq ^+ spq.1.1%PAIR *: rmodp p' q'))) => //= spq _ _. +rewrite (eval_Rediv (fun mpq => + k' (- eval e lq ^+ spq *: mpq.2%PAIR))) => //= _ _ mpq. +by rewrite Pk !eval_OpPoly. +Qed. + +Implicit Arguments eval_NextMod [e p q k]. +Prenex Implicits eval_NextMod. + +Lemma eval_Rgcd_loop e n p q k k' : + (forall p, qf_eval e (k p) = k' (eval_poly e p)) + -> qf_eval e (Rgcd_loop n p q k) = + k' (rgcdp_loop n (eval_poly e p) (eval_poly e q)). +Proof. +elim: n p q k k'=> [|n ihn] p q k k' Pk /=. + rewrite (eval_Rediv (fun r => + if r.2%PAIR == 0 then k' (eval_poly e q) else k' r.2%PAIR)) /=. + by case: eqP. + by move=> _ _ r; rewrite eval_Isnull; case: eqP. +pose q' := eval_poly e q. +rewrite (eval_Rediv (fun r => + if r.2%PAIR == 0 then k' q' else k' (rgcdp_loop n q' r.2%PAIR))) /=. + by case: eqP. +move=> _ _ r; rewrite eval_Isnull; case: eqP; first by rewrite Pk. +by rewrite (ihn _ _ _ k'). +Qed. + +Lemma eval_Rgcd e p q k k' : + (forall p, qf_eval e (k p) = k' (eval_poly e p)) -> + qf_eval e (Rgcd p q k) = + k' (rgcdp (eval_poly e p) (eval_poly e q)). +Proof. +move=> Pk; rewrite /Rgcd /LtSize !eval_Size /rgcdp. +case: ltnP=> _; rewrite !eval_Isnull; case: eqP=> // _; +by rewrite eval_Size; apply: eval_Rgcd_loop. +Qed. + + +Lemma eval_BigRgcd e ps k k' : + (forall p, qf_eval e (k p) = k' (eval_poly e p)) -> + qf_eval e (BigRgcd ps k) = + k' (\big[@rgcdp _/0%:P]_(i <- ps) (eval_poly e i)). +Proof. +elim: ps k k'=> [|p sp ihsp] k k' Pk /=. + by rewrite big_nil Pk /= mul0r add0r. +rewrite big_cons (ihsp _ (fun r => k' (rgcdp (eval_poly e p) r))) //. +by move=> r; apply: eval_Rgcd. +Qed. + +Implicit Arguments eval_Rgcd [e p q k]. +Prenex Implicits eval_Rgcd. + + +Fixpoint mods_aux (p q : {poly F}) (n : nat) : seq {poly F} := + if n is m.+1 + then if p == 0 then [::] + else p :: (mods_aux q (next_mod p q) m) + else [::]. + +Lemma eval_ModsAux e p q n k k' : + (forall sp, qf_eval e (k sp) = k' (map (eval_poly e) sp)) -> + qf_eval e (ModsAux p q n k) = + k' (mods_aux (eval_poly e p) (eval_poly e q) n). +Proof. +elim: n p q k k'=> [|n ihn] p q k k' Pk; first by rewrite /= Pk. +rewrite /= eval_Isnull; have [|ep_neq0] := altP (_ =P _); first by rewrite Pk. +set q' := eval_poly e q; set p' := eval_poly e p. +rewrite (eval_NextMod (fun npq => k' (p' :: mods_aux q' npq n))) => // npq. +by rewrite (ihn _ _ _ (fun ps => k' (p' :: ps))) => // ps; rewrite Pk. +Qed. + +Implicit Arguments eval_ModsAux [e p q n k]. +Prenex Implicits eval_ModsAux. + +Lemma eval_Mods e p q k k' : + (forall sp, qf_eval e (k sp) = k' (map (eval_poly e) sp)) -> + qf_eval e (Mods p q k) = k' (mods (eval_poly e p) (eval_poly e q)). +Proof. by move=> Pk; rewrite !eval_Size; apply: eval_ModsAux. Qed. + +Implicit Arguments eval_Mods [e p q k]. +Prenex Implicits eval_Mods. + +Lemma eval_TaqR e p q k : + qf_eval e (TaqR p q k) = + qf_eval e (k (taqR (eval_poly e p) (eval_poly e q))). +Proof. +rewrite (eval_Mods (fun r => qf_eval e (k (changes_poly r)))). + by rewrite !eval_OpPoly. +by move=> sp; rewrite !eval_ChangesPoly. +Qed. + +Lemma eval_PolyComb e sq sc : + eval_poly e (PolyComb sq sc) = poly_comb (map (eval_poly e) sq) sc. +Proof. +rewrite /PolyComb /poly_comb size_map. +rewrite -BigOp.bigopE -val_enum_ord -filter_index_enum !big_map. +apply: (big_ind2 (fun u v => eval_poly e u = v)). ++ by rewrite /= mul0r add0r. ++ by move=> x x' y y'; rewrite eval_MulPoly=> -> ->. +by move=> i _; rewrite eval_ExpPoly /= (nth_map [::]). +Qed. + +Definition pcq (sq : seq {poly F}) i := + (map (poly_comb sq) (sg_tab (size sq)))`_i. + +Lemma eval_Pcq e sq i : + eval_poly e (Pcq sq i) = pcq (map (eval_poly e) sq) i. +Proof. +rewrite /Pcq /pcq size_map; move: (sg_tab _)=> s. +have [ge_is|lt_is] := leqP (size s) i. + by rewrite !nth_default ?size_map // /=. +rewrite -(nth_map _ 0) ?size_map //; congr _`_i; rewrite -map_comp. +by apply: eq_map=> x /=; rewrite eval_PolyComb. +Qed. + +Lemma eval_TaqsR e p sq i k k' : + (forall x, qf_eval e (k x) = k' (eval e x)) -> + qf_eval e (TaqsR p sq i k) = + k' (taqsR (eval_poly e p) (map (eval_poly e) sq) i). +Proof. by move=> Pk; rewrite /TaqsR /taqsR eval_TaqR Pk /= eval_Pcq. Qed. + +Implicit Arguments eval_TaqsR [e p sq i k]. +Prenex Implicits eval_TaqsR. + +Fact invmx_ctmat1 : invmx (map_mx (intr : int -> F) ctmat1) = + \matrix_(i, j) + (nth [::] [:: [:: 2%:R^-1; - 2%:R^-1; 0]; + [:: 2%:R^-1; 2%:R^-1; -1]; + [:: 0; 0; 1]] i)`_j :> 'M[F]_3. +Proof. +rewrite -[lhs in lhs = _]mul1r; apply: (canLR (mulrK _)). + exact: ctmat1_unit. +symmetry; rewrite /ctmat1. +apply/matrixP => i j; rewrite !(big_ord_recl, big_ord0, mxE) /=. +have halfP (K : numFieldType) : 2%:R^-1 + 2%:R^-1 = 1 :> K. + by rewrite -mulr2n -[_ *+ 2]mulr_natl mulfV // pnatr_eq0. +move: i; do ?[case => //=]; move: j; do ?[case => //=] => _ _; +rewrite !(mulr1, mul1r, mulrN1, mulN1r, mulr0, mul0r, opprK); +by rewrite !(addr0, add0r, oppr0, subrr, addrA, halfP). +Qed. + +Lemma eval_Coefs e n i : eval e (Coefs F n i) = coefs F n i. +Proof. +case: n => [|[|n]] //=; rewrite /coefs /=. + case: i => [|i]; last first. + by rewrite nth_default // size_map size_enum_ord expn0. + rewrite (nth_map 0) ?size_enum_ord //. + set O := _`_0; rewrite (_ : O = ord0). + by rewrite ?castmxE ?cast_ord_id map_mx1 invmx1 mxE. + by apply: val_inj => /=; rewrite nth_enum_ord. +have [lt_i3|le_3i] := ltnP i 3; last first. + by rewrite !nth_default // size_map size_enum_ord. +rewrite /ctmat /= ?ntensmx1 invmx_ctmat1 /=. +rewrite (nth_map 0) ?size_enum_ord // castmxE /=. +rewrite !mxE !cast_ord_id //= nth_enum_ord //=. +by move: i lt_i3; do 3?case. +Qed. + +Lemma eval_CcountWeak e p sq k k' : + (forall x, qf_eval e (k x) = k' (eval e x)) -> + qf_eval e (CcountWeak p sq k) = + k' (ccount_weak (eval_poly e p) (map (eval_poly e) sq)). +Proof. +move=> Pk; rewrite /CcountWeak /ccount_weak. +set Aux := (fix Aux s i k := match i with 0 => _ | _ => _ end). +set aux := (fix aux s i := match i with 0 => _ | _ => _ end). +rewrite size_map -[0]/(eval e 0%qfT); move: 0%qfT=> x. +elim: (_ ^ _)%N k k' Pk x=> /= [|n ihn] k k' Pk x. + by rewrite Pk. +rewrite (eval_TaqsR + (fun y => k' (aux (y * (coefs F (size sq) n) + eval e x) n))). + by rewrite size_map. +by move=> y; rewrite (ihn _ k') // -(eval_Coefs e). +Qed. + +Implicit Arguments eval_CcountWeak [e p sq k]. +Prenex Implicits eval_CcountWeak. + +Lemma eval_ProdPoly e T s f k f' k' : + (forall x k k', (forall p, (qf_eval e (k p) = k' (eval_poly e p))) -> + qf_eval e (f x k) = k' (f' x)) -> + (forall p, qf_eval e (k p) = k' (eval_poly e p)) -> + qf_eval e (@ProdPoly _ T s f k) = k' (\prod_(x <- s) f' x). +Proof. +move=> Pf; elim: s k k'=> [|a s ihs] k k' Pk /=. + by rewrite big_nil Pk /= !(mul0r, add0r). +rewrite (Pf _ _ (fun fa => k' (fa * \prod_(x <- s) f' x))). + by rewrite big_cons. +move=> fa; rewrite (ihs _ (fun fs => k' (eval_poly e fa * fs))) //. +by move=> fs; rewrite Pk eval_OpPoly. +Qed. + +Implicit Arguments eval_ProdPoly [e T s f k]. +Prenex Implicits eval_ProdPoly. + +Lemma eval_BoundingPoly e sq : + eval_poly e (BoundingPoly sq) = bounding_poly (map (eval_poly e) sq). +Proof. +rewrite eval_Deriv -BigOp.bigopE; congr _^`(); rewrite big_map. +by apply: big_morph => [p q | ]/=; rewrite ?eval_MulPoly // mul0r add0r. +Qed. + +Lemma eval_CcountGt0 e sp sq : qf_eval e (CcountGt0 sp sq) = + ccount_gt0 (map (eval_poly e) sp) (map (eval_poly e) sq). +Proof. +pose sq' := map (eval_poly e) sq; rewrite /ccount_gt0. +rewrite (@eval_BigRgcd _ _ _ (fun p => if p != 0 + then 0 < ccount_weak p sq' + else let bq := bounding_poly sq' in + [|| \big[andb/true]_(q <- sq') (0 < lead_coef q), + \big[andb/true]_(q <- sq') (0 < (-1) ^+ (size q).-1 * lead_coef q) + | 0 < ccount_weak bq sq'])). + by rewrite !big_map. +move=> p; rewrite eval_Isnull; case: eqP=> _ /=; last first. + by rewrite (eval_CcountWeak (> 0)). +rewrite (eval_CcountWeak (fun n => + [|| \big[andb/true]_(q <- sq') (0 < lead_coef q), + \big[andb/true]_(q <- sq') (0 < (-1) ^+ (size q).-1 * lead_coef q) + | 0 < n ])). + by rewrite eval_BoundingPoly. +move=> n /=; rewrite -!BigOp.bigopE !big_map; congr [|| _, _| _]. + apply: (big_ind2 (fun u v => qf_eval e u = v))=> //=. + by move=> u v u' v' -> ->. + by move=> i _; rewrite (eval_LeadCoef (> 0)). +apply: (big_ind2 (fun u v => qf_eval e u = v))=> //=. + by move=> u v u' v' -> ->. +by move=> i _; rewrite eval_Size (eval_LeadCoef (fun lq => + (0 < (-1) ^+ (size (eval_poly e i)).-1 * lq))). +Qed. + +Lemma abstrXP e i t x : + (eval_poly e (abstrX i t)).[x] = eval (set_nth 0 e i x) t. +Proof. +elim: t. +- move=> n /=; case ni: (_ == _); + rewrite //= ?(mul0r,add0r,addr0,polyC1,mul1r,hornerX,hornerC); + by rewrite // nth_set_nth /= ni. +- by move=> r; rewrite /= mul0r add0r hornerC. +- by move=> r; rewrite /= mul0r add0r hornerC. +- by move=> t tP s sP; rewrite /= eval_AddPoly hornerD tP ?sP. +- by move=> t tP; rewrite /= eval_OppPoly hornerN tP. +- by move=> t tP n; rewrite /= eval_NatMulPoly hornerMn tP. +- by move=> t tP s sP; rewrite /= eval_MulPoly hornerM tP ?sP. +- by move=> t tP n; rewrite /= eval_ExpPoly horner_exp tP. +Qed. + +Lemma wf_QE_wproj i bc (bc_i := @wproj F i bc) : + dnf_rterm (w_to_oclause bc) -> qf_form bc_i && rformula bc_i. +Proof. +case: bc @bc_i=> sp sq /=; rewrite /dnf_rterm /= /wproj andbT=> /andP[rsp rsq]. +by rewrite qf_formF rformulaF. +Qed. + +Lemma valid_QE_wproj i bc (bc' := w_to_oclause bc) + (ex_i_bc := ('exists 'X_i, odnf_to_oform [:: bc'])%oT) e : + dnf_rterm bc' -> reflect (holds e ex_i_bc) (ord.qf_eval e (wproj i bc)). +Proof. +case: bc @bc' @ex_i_bc=> sp sq /=; rewrite /dnf_rterm /wproj /= andbT. +move=> /andP[rsp rsq]; rewrite -qf_evalE. +rewrite eval_CcountGt0 /=; apply: (equivP (ccount_gt0P _ _)). +set P1 := (fun x => _); set P2 := (fun x => _). +suff: forall x, P1 x <-> P2 x. + by move=> hP; split=> [] [x Px]; exists x; rewrite (hP, =^~ hP). +move=> x; rewrite /P1 /P2 {P1 P2} !big_map !(big_seq_cond xpredT) /=. +rewrite (eq_bigr (fun t => GRing.eval (set_nth 0 e i x) t == 0)); last first. + by move=> t /andP[t_in_sp _]; rewrite abstrXP evalE to_rtermE ?(allP rsp). +rewrite [X in _ && X](eq_bigr (fun t => 0 < GRing.eval (set_nth 0 e i x) t)); + last by move=> t /andP[tsq _]; rewrite abstrXP evalE to_rtermE ?(allP rsq). +rewrite -!big_seq_cond !(rwP (qf_evalP _ _)); first last. ++ elim: sp rsp => //= p sp ihsp /andP[rp rsp]; first by rewrite ihsp. ++ elim: sq rsq => //= q sq ihsq /andP[rq rsq]; first by rewrite ihsq. +rewrite !(rwP andP) (rwP orP) orbF !andbT /=. +have unfoldr P s : foldr (fun t => ord.And (P t)) ord.True s = + \big[ord.And/ord.True]_(t <- s) P t by rewrite unlock /reducebig. +rewrite !unfoldr; set e' := set_nth _ _ _ _. +by rewrite !(@big_morph _ _ (ord.qf_eval _) true andb). +Qed. + +Lemma rcf_satP e f : reflect (holds e f) (rcf_sat e f). +Proof. exact: (proj_satP wf_QE_wproj valid_QE_wproj). Qed. + +End ProjCorrect. + +(* Section Example. *) +(* no chances it computes *) + +(* Require Import rat. *) + +(* Eval vm_compute in (54%:R / 289%:R + 2%:R^-1 :rat). *) + +(* Local Open Scope qf_scope. *) + +(* Notation polyF := (polyF [realFieldType of rat]). *) +(* Definition p : polyF := [::'X_2; 'X_1; 'X_0]. *) +(* Definition q : polyF := [:: 0; 1]. *) +(* Definition sq := [::q]. *) + +(* Eval vm_compute in MulPoly p q. *) + +(* Eval vm_compute in Rediv ([:: 1] : polyF) [::1]. *) + +(* Definition fpq := Eval vm_compute in (CcountWeak p [::q]). *) + +(* End Example. *) diff --git a/mathcomp/real_closed/qe_rcf_th.v b/mathcomp/real_closed/qe_rcf_th.v new file mode 100644 index 0000000..f1e5a61 --- /dev/null +++ b/mathcomp/real_closed/qe_rcf_th.v @@ -0,0 +1,1293 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice path fintype. +Require Import div bigop ssralg poly polydiv ssrnum perm zmodp ssrint. +Require Import polyorder polyrcf interval matrix mxtens. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GRing.Theory Num.Theory Num.Def Pdiv.Ring Pdiv.ComRing. + +Local Open Scope nat_scope. +Local Open Scope ring_scope. + +Section extra. + +Variable R : rcfType. +Implicit Types (p q : {poly R}). + + +(* Proof. *) +(* move=> sq; rewrite comp_polyE; case hp: (size p) => [|n]. *) +(* move/eqP: hp; rewrite size_poly_eq0 => /eqP ->. *) +(* by rewrite !big_ord0 mulr1 lead_coef0. *) +(* rewrite big_ord_recr /= addrC lead_coefDl. *) +(* by rewrite lead_coefZ lead_coef_exp // !lead_coefE hp. *) +(* rewrite (leq_ltn_trans (size_sum _ _ _)) // size_scale; last first. *) +(* rewrite -[n]/(n.+1.-1) -hp -lead_coefE ?lead_coef_eq0 //. *) +(* by rewrite -size_poly_eq0 hp. *) +(* rewrite polySpred ?ltnS ?expf_eq0; last first. *) +(* by rewrite andbC -size_poly_eq0 gtn_eqF // ltnW. *) +(* apply/bigmax_leqP => i _; rewrite size_exp. *) +(* have [->|/size_scale->] := eqVneq p`_i 0; first by rewrite scale0r size_poly0. *) +(* by rewrite (leq_trans (size_exp_leq _ _)) // ltn_mul2l -subn1 subn_gt0 sq /=. *) +(* Qed. *) + + +Lemma mul2n n : (2 * n = n + n)%N. Proof. by rewrite mulSn mul1n. Qed. +Lemma mul3n n : (3 * n = n + (n + n))%N. Proof. by rewrite !mulSn addn0. Qed. +Lemma exp3n n : (3 ^ n)%N = (3 ^ n).-1.+1. +Proof. by elim: n => // n IHn; rewrite expnS IHn. Qed. + +Definition exp3S n : (3 ^ n.+1 = 3 ^ n + (3 ^ n + 3 ^ n))%N + := etrans (expnS 3 n) (mul3n (3 ^ n)). + +Lemma tens_I3_mx (cR : comRingType) m n (M : 'M[cR]_(m,n)) : + 1%:M *t M = castmx (esym (mul3n _ ), esym (mul3n _ )) + (block_mx M 0 + 0 (block_mx M 0 + 0 M : 'M_(m+m,n+n)%N)). +Proof. +rewrite [1%:M : 'M_(1+2)%N]scalar_mx_block. +rewrite [1%:M : 'M_(1+1)%N]scalar_mx_block. +rewrite !tens_block_mx. +apply/eqP; rewrite -(can2_eq (castmxKV _ _) (castmxK _ _)); apply/eqP. +rewrite castmx_comp !tens_scalar_mx !tens0mx !scale1r. +rewrite (castmx_block (mul1n _) (mul1n _) (mul2n _) (mul2n _)). +rewrite !castmx_comp /= !castmx_id. +rewrite (castmx_block (mul1n _) (mul1n _) (mul1n _) (mul1n _)). +by rewrite !castmx_comp /= !castmx_id !castmx_const /=. +Qed. + +Lemma mul_1tensmx (cR : comRingType) (m n p: nat) + (e3n : (n + (n + n) = 3 * n)%N) + (A B C : 'M[cR]_(m, n)) (M : 'M[cR]_(n, p)) : + castmx (erefl _, e3n) + (row_mx A (row_mx B C)) *m (1%:M *t M) + = castmx (erefl _, esym (mul3n _)) + (row_mx (A *m M) (row_mx (B *m M) (C *m M))). +Proof. +apply/eqP; rewrite -(can2_eq (castmxKV _ _) (castmxK _ _)); apply/eqP. +rewrite tens_I3_mx mulmx_cast castmx_mul !castmx_comp /= !castmx_id /=. +by rewrite !mul_row_block /= !mulmx0 !addr0 !add0r. +Qed. + +(* :TODO: backport to polydiv *) +Lemma coprimep_rdiv_gcd p q : (p != 0) || (q != 0) -> + coprimep (rdivp p (gcdp p q)) (rdivp q (gcdp p q)). +Proof. +move=> hpq. +have gpq0: gcdp p q != 0 by rewrite gcdp_eq0 negb_and. +rewrite -gcdp_eqp1 -(@eqp_mul2r _ (gcdp p q)) // mul1r. +have: gcdp p q %| p by rewrite dvdp_gcdl. +have: gcdp p q %| q by rewrite dvdp_gcdr. +rewrite !dvdpE !rdvdp_eq eq_sym; move/eqP=> hq; rewrite eq_sym; move/eqP=> hp. +rewrite (eqp_ltrans (mulp_gcdl _ _ _)) hq hp. +have lcn0 k : (lead_coef (gcdp p q)) ^+ k != 0. + by rewrite expf_neq0 ?lead_coef_eq0. +by apply: eqp_gcd; rewrite ?eqp_scale. +Qed. + +(* :TODO: generalize to non idomainTypes and backport to polydiv *) +Lemma rgcdp_eq0 p q : rgcdp p q == 0 = (p == 0) && (q == 0). +Proof. by rewrite -eqp0 (eqp_ltrans (eqp_rgcd_gcd _ _)) eqp0 gcdp_eq0. Qed. + +(* :TODO: : move in polyorder *) +Lemma mu_eq0 : forall p x, p != 0 -> (\mu_x p == 0%N) = (~~ root p x). +Proof. by move=> p x p0; rewrite -mu_gt0 // -leqNgt leqn0. Qed. + +Notation lcn_neq0 := lc_expn_rscalp_neq0. + +(* :TODO: : move to polyorder *) +Lemma mu_mod p q x : (\mu_x p < \mu_x q)%N -> + \mu_x (rmodp p q) = \mu_x p. +Proof. +move=> mupq; have [->|p0] := eqVneq p 0; first by rewrite rmod0p. +have qn0 : q != 0 by apply: contraTneq mupq => ->; rewrite mu0 ltn0. +have /(canLR (addKr _)) <- := (rdivp_eq q p). +have [->|divpq_eq0] := eqVneq (rdivp p q) 0. + by rewrite mul0r oppr0 add0r mu_mulC ?lcn_neq0. +rewrite mu_addl ?mu_mulC ?scaler_eq0 ?negb_or ?mulf_neq0 ?lcn_neq0 //. +by rewrite mu_opp mu_mul ?ltn_addl // ?mulf_neq0. +Qed. + +(* :TODO: : move to polyorder *) +Lemma mu_add p q x : p + q != 0 -> + (minn (\mu_x p) (\mu_x q) <= \mu_x (p + q)%R)%N . +Proof. +have [->|p0] := eqVneq p 0; first by rewrite mu0 min0n add0r. +have [->|q0] := eqVneq q 0; first by rewrite mu0 minn0 addr0. +have [Hpq|Hpq|Hpq] := (ltngtP (\mu_x p) (\mu_x q)). ++ by rewrite mu_addr ?geq_minl. ++ by rewrite mu_addl ?geq_minr. +have [//|p' nrp'x hp] := (@mu_spec _ p x). +have [//|q' nrq'x hq] := (@mu_spec _ q x). +rewrite Hpq minnn hp {1 3}hq Hpq -mulrDl => pq0. +by rewrite mu_mul // mu_exp mu_XsubC mul1n leq_addl. +Qed. + +(* :TODO: : move to polydiv *) +Lemma mu_mod_leq : forall p q x, ~~ (q %| p) -> + (\mu_x q <= \mu_x p)%N -> + (\mu_x q <= \mu_x (rmodp p q)%R)%N. +Proof. +move=> p q x; rewrite dvdpE /rdvdp=> rn0 mupq. +case q0: (q == 0); first by rewrite (eqP q0) mu0 leq0n. +move/eqP: (rdivp_eq q p). +rewrite eq_sym (can2_eq (addKr _ ) (addNKr _)); move/eqP=> hr. +rewrite hr; case qpq0: (rdivp p q == 0). + by rewrite (eqP qpq0) mul0r oppr0 add0r mu_mulC // lcn_neq0. +rewrite (leq_trans _ (mu_add _ _)) // -?hr //. +rewrite leq_min mu_opp mu_mul ?mulf_neq0 ?qpq0 ?q0 // leq_addl. +by rewrite mu_mulC // lcn_neq0. +Qed. + +(* Lemma sgp_right0 : forall (x : R), sgp_right 0 x = 0. *) +(* Proof. by move=> x; rewrite /sgp_right size_poly0. Qed. *) + +End extra. + +Section ctmat. + +Variable R : numFieldType. + +Definition ctmat1 := \matrix_(i < 3, j < 3) + (nth [::] [:: [:: 1%:Z ; 1 ; 1 ] + ; [:: -1 ; 1 ; 1 ] + ; [:: 0 ; 0 ; 1 ] ] i)`_j. + +Lemma det_ctmat1 : \det ctmat1 = 2. +Proof. +(* Developpement direct ? *) +by do ?[rewrite (expand_det_row _ ord0) //=; + rewrite ?(big_ord_recl,big_ord0) //= ?mxE //=; + rewrite /cofactor /= ?(addn0, add0n, expr0, exprS); + rewrite ?(mul1r,mulr1,mulN1r,mul0r,mul1r,addr0) /=; + do ?rewrite [row' _ _]mx11_scalar det_scalar1 !mxE /=]. +Qed. + +Notation zmxR := ((map_mx ((intmul 1) : int -> R)) _ _). + +Lemma ctmat1_unit : zmxR ctmat1 \in unitmx. +Proof. +rewrite /mem /in_mem /= /unitmx det_map_mx //. +by rewrite det_ctmat1 unitfE intr_eq0. +Qed. + +Definition ctmat n := (ctmat1 ^t n). + +Lemma ctmat_unit : forall n, zmxR (ctmat n) \in unitmx. +Proof. +case=> [|n] /=; first by rewrite map_mx1 ?unitmx1//; apply: zinjR_morph. +elim:n=> [|n ihn] /=; first by apply: ctmat1_unit. +rewrite map_mxT //. +apply: tensmx_unit=> //; last exact: ctmat1_unit. +by elim: n {ihn}=> // n ihn; rewrite muln_eq0. +Qed. + +Lemma ctmat1_blocks : ctmat1 = (block_mx + 1 (row_mx 1 1) + (col_mx (-1) 0) (block_mx 1 1 0 1 : 'M_(1+1)%N)). +Proof. +apply/matrixP=> i j; rewrite !mxE. +by do 4?[case: splitP => ?; rewrite !mxE ?ord1=> ->]. +Qed. + +Lemma tvec_sub n : (3 * (3 ^ n).-1.+1 = 3 ^ (n.+1) )%N. +Proof. by rewrite -exp3n expnS. Qed. + +Lemma tens_ctmat1_mx n (M : 'M_n) : + ctmat1 *t M = castmx (esym (mul3n _ ), esym (mul3n _ )) + (block_mx M (row_mx M M) + (col_mx (-M) 0) (block_mx M M + 0 M : 'M_(n+n)%N)). +Proof. +rewrite ctmat1_blocks !tens_block_mx !tens_row_mx !tens_col_mx. +rewrite [-1]mx11_scalar !mxE /= !tens_scalar_mx !tens0mx scaleNr !scale1r. +apply/eqP; rewrite -(can2_eq (castmxKV _ _) (castmxK _ _)); apply/eqP. +rewrite !castmx_comp !esymK /=. +rewrite !(castmx_block (mul1n _) (mul1n _) (mul2n _) (mul2n _)). +rewrite !castmx_comp !castmx_id /=. +rewrite !(castmx_row (mul1n _) (mul1n _)). +rewrite !(castmx_block (mul1n _) (mul1n _) (mul1n _) (mul1n _)) /=. +rewrite !(castmx_col (mul1n _) (mul1n _)) !castmx_comp !castmx_id /=. +by rewrite !castmx_const. +Qed. + +Definition coefs n i := + [seq (castmx (erefl _, exp3n _) (invmx (zmxR (ctmat n)))) i ord0 + | i <- enum 'I__]`_i. + +End ctmat. + +Section QeRcfTh. + +Variable R : rcfType. +Implicit Types a b : R. +Implicit Types p q : {poly R}. + +Notation zmxR := ((map_mx ((intmul 1) : int -> R)) _ _). +Notation midf a b := ((a + b) / 2%:~R). + +(* Constraints and Tarski queries *) + +Local Notation sgp_is q s := (fun x => (sgr q.[x] == s)). + +Definition constraints (z : seq R) (sq : seq {poly R}) (sigma : seq int) := + (\sum_(x <- z) \prod_(i < size sq) (sgz (sq`_i).[x] == sigma`_i))%N. + +Definition taq (z : seq R) (q : {poly R}) : int := \sum_(x <- z) (sgz q.[x]). + +Lemma taq_constraint1 z q : + taq z q = (constraints z [::q] [::1])%:~R - (constraints z [::q] [::-1])%:~R. +Proof. +rewrite /constraints /taq !sumMz -sumrB /=; apply: congr_big=> // x _. +by rewrite !big_ord_recl big_ord0 !muln1 /=; case: sgzP. +Qed. + +Lemma taq_constraint0 z q : + taq z 1 = (constraints z [::q] [:: 0])%:~R + + (constraints z [::q] [:: 1])%:~R + + (constraints z [::q] [::-1])%:~R. +Proof. +rewrite /constraints /taq !sumMz //= -!big_split /=; apply: congr_big=> // x _. +by rewrite hornerC sgz1 !big_ord_recl big_ord0 !muln1 /=; case: sgzP. +Qed. + +Lemma taq_no_constraint z : taq z 1 = (constraints z [::] [::])%:~R. +Proof. +rewrite /constraints /taq !sumMz; apply: congr_big=> // x _. +by rewrite hornerC sgz1 big_ord0. +Qed. + +Lemma taq_constraint2 z q : + taq z (q ^+ 2) = (constraints z [::q] [:: 1])%:~R + + (constraints z [::q] [::-1])%:~R. +Proof. +rewrite /constraints /taq !sumMz -big_split /=; apply: congr_big=> // x _. +rewrite !big_ord_recl big_ord0 !muln1 /= horner_exp sgzX. +by case: (sgzP q.[x])=> _. +Qed. + +Fixpoint sg_tab n : seq (seq int) := + if n is m.+1 + then flatten (map (fun x => map (fun l => x :: l) (sg_tab m)) [::1;-1;0]) + else [::[::]]. + +Lemma sg_tab_nil n : (sg_tab n == [::]) = false. +Proof. by elim: n => //= n; case: sg_tab. Qed. + +Lemma size_sg_tab n : size (sg_tab n) = (3 ^ n)%N. +Proof. +by elim: n => [|n] // ihn; rewrite !size_cat !size_map ihn addn0 exp3S. +Qed. + +Lemma size_sg_tab_neq0 n : size (sg_tab n) != 0%N. +Proof. by rewrite size_sg_tab exp3n. Qed. + + +Definition comb_exp (R : realDomainType) (s : R) := + match sgz s with Posz 1 => 1%N | Negz 0 => 2 | _ => 0%N end. + +Definition poly_comb (sq : seq {poly R}) (sc : seq int) : {poly R} := + \prod_(i < size sq) ((sq`_i) ^+ (comb_exp sc`_i)). + +(* Eval compute in sg_tab 4. *) + +Definition cvec z sq := let sg_tab := sg_tab (size sq) in + \row_(i < 3 ^ size sq) ((constraints z sq (nth [::] sg_tab i))%:~R : int). +Definition tvec z sq := let sg_tab := sg_tab (size sq) in + \row_(i < 3 ^ size sq) (taq z (map (poly_comb sq) sg_tab)`_i). + + +Lemma tvec_cvec1 z q : tvec z [::q] = (cvec z [::q]) *m ctmat1. +Proof. +apply/rowP => j. +rewrite /tvec !mxE /poly_comb /= !big_ord_recl !big_ord0 //=. +rewrite !(expr0,expr1,mulr1) /=. +case: j=> [] [|[|[|j]]] hj //. +* by rewrite !mxE /= mulr0 add0r mulr1 mulrN1 addr0 taq_constraint1. +* by rewrite !mxE /= mulr0 !mulr1 add0r addr0 taq_constraint2. +* by rewrite !mxE /= addrA (@taq_constraint0 _ q) !mulr1 addr0 -addrA addrC. +Qed. + +Lemma cvec_rec z q sq : + cvec z (q :: sq) = castmx (erefl _, esym (exp3S _)) + (row_mx (cvec (filter (sgp_is q 1) z) (sq)) + (row_mx (cvec (filter (sgp_is q (-1)) z) (sq)) + (cvec (filter (sgp_is q 0) z) (sq)))). +Proof. +apply/eqP; rewrite -(can2_eq (castmxKV _ _) (castmxK _ _)); apply/eqP. +apply/rowP=> [] i; rewrite !(mxE, castmxE, esymK, cast_ord_id) /=. +symmetry; case: splitP=> j hj /=; rewrite !mxE hj. + case hst: sg_tab (sg_tab_nil (size sq))=> [|l st] // _. + have sst: (size st).+1 = (3 ^ size sq)%N. + transitivity (size (sg_tab (size sq))); first by rewrite hst //. + by rewrite size_sg_tab. + rewrite /constraints big_filter big_mkcond !sumMz; apply: congr_big=> // x _. + rewrite nth_cat size_map ![size (_::_)]/= sst ltn_ord. + rewrite (nth_map [::]) /= ?sst ?ltn_ord // big_ord_recl /=. + by rewrite sgr_cp0 sgz_cp0; case: (_ < _); first by rewrite mul1n. +case: splitP=> k hk; rewrite !mxE /= hk. + case hst: sg_tab (sg_tab_nil (size sq))=> [|l st] // _. + have sst: (size st).+1 = (3 ^ size sq)%N. + transitivity (size (sg_tab (size sq))); first by rewrite hst //. + by rewrite size_sg_tab. + rewrite /constraints big_filter big_mkcond !sumMz; apply: congr_big=> // x _. + rewrite nth_cat nth_cat !size_map ![size (_ :: _)]/= sst ltnNge leq_addr. + rewrite (@nth_map _ [::] _ _ [eta cons (-1)] _ (l::st)) /= ?sst addKn ltn_ord //. + rewrite big_ord_recl /= sgr_cp0 sgz_cp0. + by case: (_ < _); first by rewrite mul1n. +case hst: sg_tab (sg_tab_nil (size sq))=> [|l st] // _. +have sst: (size st).+1 = (3 ^ size sq)%N. + transitivity (size (sg_tab (size sq))); first by rewrite hst //. + by rewrite size_sg_tab. +rewrite /constraints big_filter big_mkcond !sumMz; apply: congr_big=> // x _. +rewrite nth_cat nth_cat nth_cat !size_map ![size (_ :: _)]/= sst. +rewrite (@nth_map _ [::] _ _ [eta cons 0] _ (l::st)) /=; last first. + by rewrite !addKn sst ltn_ord. +rewrite ltnNge leq_addr /= !addKn ltnNge leq_addr /= ltn_ord. +rewrite big_ord_recl /= sgr_cp0 sgz_cp0. +by case: (_ == _); first by rewrite mul1n. +Qed. + + +Lemma poly_comb_cons q sq s ss : + poly_comb (q :: sq) (s :: ss) = (q ^ (comb_exp s)) * poly_comb sq ss. +Proof. by rewrite /poly_comb /= big_ord_recl /=. Qed. + +Lemma comb_expE (rR : realDomainType): + (comb_exp (1 : rR) = 1%N) * (comb_exp (-1 : rR) = 2%N) * (comb_exp (0 : rR) = 0%N). +Proof. by rewrite /comb_exp sgzN sgz1 sgz0. Qed. + +Lemma tvec_rec z q sq : + tvec z (q :: sq) = + castmx (erefl _, esym (exp3S _)) ( + (row_mx (tvec (filter (sgp_is q 1) z) (sq)) + (row_mx (tvec (filter (sgp_is q (-1)) z) (sq)) + (tvec (filter (sgp_is q 0) z) (sq)))) *m + (castmx (mul3n _, mul3n _) (ctmat1 *t 1%:M))). +Proof. +rewrite tens_ctmat1_mx !castmx_comp !castmx_id /=. +rewrite !(mul_row_block, mul_row_col, mul_mx_row) !(mulmx1, mulmx0, mulmxN, addr0) /=. +apply/eqP; rewrite -(can2_eq (castmxKV _ _) (castmxK _ _)); apply/eqP. +apply/matrixP=> i j; rewrite !(castmxE, mxE) /=. +symmetry; case: splitP=> l hl; rewrite !mxE hl. + case hst: sg_tab (sg_tab_nil (size sq))=> [|s st] // _. + have sst: (size st).+1 = (3 ^ size sq)%N. + transitivity (size (sg_tab (size sq))); first by rewrite hst //. + by rewrite size_sg_tab. + rewrite /taq !big_filter !(big_mkcond (sgp_is _ _)) -sumrB. + apply: congr_big=> // x _. + rewrite cats0 !map_cat nth_cat !size_map /= sst ltn_ord /=. + rewrite !poly_comb_cons /= !comb_expE expr1z. + rewrite -!(nth_map _ 0 (fun p => p.[_])) /= ?size_map ?sst ?ltn_ord //. + rewrite -!map_comp /= hornerM. + set f := _ \o _; set g := _ \o _. + set h := fun sc => q.[x] * (poly_comb sq sc).[x]. + have hg : g =1 h. + by move=> sx; rewrite /g /h /= poly_comb_cons comb_expE expr1z hornerM. + rewrite -/(h _) -hg -[g _ :: _]/(map g (_ ::_)). + rewrite (nth_map [::]) /= ?sst ?ltn_ord // hg /h sgzM. + rewrite -![(poly_comb _ _).[_]]/(f _) -[f _ :: _]/(map f (_ ::_)). + rewrite (nth_map [::]) /= ?sst ?ltn_ord // !sgr_cp0. + by case: (sgzP q.[x]); rewrite ?(mul0r, mul1r, mulN1r, subr0, sub0r). +case: splitP=> k hk /=; rewrite !mxE hk. + case hst: sg_tab (sg_tab_nil (size sq))=> [|s st] // _. + have sst: (size st).+1 = (3 ^ size sq)%N. + transitivity (size (sg_tab (size sq))); first by rewrite hst //. + by rewrite size_sg_tab. + rewrite /taq !big_filter !(big_mkcond (sgp_is _ _)) -big_split. + apply: congr_big=> // x _. + rewrite cats0 !map_cat !nth_cat !size_map /= sst. + rewrite ltnNge leq_addr /= addKn ltn_ord /=. + rewrite !poly_comb_cons /= !comb_expE. + rewrite -!(nth_map _ 0 (fun p => p.[_])) /= ?size_map ?sst ?ltn_ord //. + rewrite -!map_comp /= hornerM. + set f := _ \o _; set g := _ \o _. + set h := fun sc => (q ^ 2).[x] * (poly_comb sq sc).[x]. + have hg : g =1 h. + by move=> sx; rewrite /g /h /= poly_comb_cons comb_expE hornerM. + rewrite -/(h _) -hg -[g _ :: _]/(map g (_ ::_)). + rewrite (nth_map [::]) /= ?sst ?ltn_ord // hg /h sgzM. + rewrite -![(poly_comb _ _).[_]]/(f _) -[f _ :: _]/(map f (_ ::_)). + rewrite (nth_map [::]) /= ?sst ?ltn_ord //. + rewrite hornerM sgzM !sgr_cp0. + by case: (sgzP q.[x]); rewrite ?(mul0r, mul1r, mulN1r, addr0, add0r). +case hst: sg_tab (sg_tab_nil (size sq))=> [|s st] // _. +have sst: (size st).+1 = (3 ^ size sq)%N. + transitivity (size (sg_tab (size sq))); first by rewrite hst //. + by rewrite size_sg_tab. +rewrite /taq !big_filter !(big_mkcond (sgp_is _ _)) -!big_split. +apply: congr_big=> // x _. +rewrite cats0 !map_cat !nth_cat !size_map /= sst. +rewrite !addKn 2!ltnNge !leq_addr /=. +rewrite !poly_comb_cons /= !comb_expE expr0z mul1r. +rewrite -!(nth_map _ 0 (fun p => p.[_])) /= ?size_map ?sst ?ltn_ord //. +rewrite -!map_comp /=. +set f := _ \o _; set g := _ \o _. +have hg : g =1 f. + by move=> sx; rewrite /g /f /= poly_comb_cons comb_expE expr0z mul1r. +rewrite -[(poly_comb _ _).[_]]/(f _) -{4}hg. +rewrite -[g s :: _]/(map _ (_ ::_)) (eq_map hg) !sgr_cp0. +by case: (sgzP q.[x])=> _; rewrite ?(addr0, add0r). +Qed. + +Lemma tvec_cvec z sq : + tvec z sq = (cvec z sq) *m (ctmat (size sq)). +Proof. +elim: sq z => [|q sq ihsq] z /=. + rewrite mulmx1; apply/rowP=> [] [i hi] /=; rewrite !mxE /=. + move: hi; rewrite expn0 ltnS leqn0; move/eqP=> -> /=. + rewrite /poly_comb big_ord0 /taq /constraints /=. + rewrite sumMz; apply: (congr_big)=> //= x _. + by rewrite hornerC sgz1 big_ord0. +rewrite /ctmat /ntensmx /=. (* simpl in trunk is "weaker" here *) +case: sq ihsq=> /= [|q' sq] ihsq; first by apply: tvec_cvec1. +rewrite cvec_rec tensmx_decl mulmxA tvec_rec. +apply/eqP; rewrite (can2_eq (castmxK _ _) (castmxKV _ _)); apply/eqP. +rewrite !castmx_mul !castmx_id [row_mx _ _ *m _]mulmx_cast. +congr (_ *m _); last by congr (castmx (_, _) _); apply: nat_irrelevance. +rewrite /=; have->: forall n, exp3S n.+1 = mul3n (3^n.+1)%N. + by move=> n; apply: nat_irrelevance. +by rewrite mul_1tensmx !ihsq. +Qed. + +Lemma cvec_tvec z sq : + zmxR (cvec z (sq)) = (zmxR (tvec z (sq))) *m (invmx (zmxR (ctmat (size (sq))))). +Proof. +apply/eqP; set A := zmxR (ctmat _). +rewrite -(@can2_eq _ _ (fun (x : 'rV_(_)) => x *m A) (fun x => x *m (invmx A))). +* by rewrite /A -map_mxM ?tvec_cvec//; apply: zinjR_morph. +* by apply: mulmxK; rewrite /A ctmat_unit. +* by apply: mulmxKV; rewrite /A ctmat_unit. +Qed. + +Lemma constraints1_tvec : forall z sq, + (constraints z (sq) (nseq (size (sq)) 1))%:~R = (castmx (erefl _, exp3n _) + (zmxR (tvec z (sq)) *m (invmx (zmxR (ctmat (size (sq))))))) ord0 ord0. +Proof. +move=> z sq. +rewrite -cvec_tvec castmxE /= cast_ord_id /= /cvec !mxE //= intz. +congr ((constraints _ _ _)%:~R); elim: sq=> //= _ s -> /=. +set l := sg_tab _; suff: size l != 0%N by case: l. +exact: size_sg_tab_neq0. +Qed. + +(* Cauchy Index, relation with Tarski query*) + +Local Notation seq_mids a s b := (pairmap (fun x y => midf x y) a (rcons s b)). +Local Notation noroot p := (forall x, ~~ root p x). +Notation lcn_neq0 := lc_expn_rscalp_neq0. + +Definition jump q p x: int := + let non_null := (q != 0) && odd (\mu_x p - \mu_x q) in + let sign := (sgp_right (q * p) x < 0)%R in + (-1) ^+ sign *+ non_null. + +Definition cindex (a b : R) (q p : {poly R}) : int := + \sum_(x <- roots p a b) jump q p x. + +Definition cindexR q p := \sum_(x <- rootsR p) jump q p x. + +Definition sjump p x : int := + ((-1) ^+ (sgp_right p x < 0)%R) *+ odd (\mu_x p). + +Definition variation (x y : R) : int := (sgz y) * (x * y < 0). + +Definition cross p a b := variation p.[a] p.[b]. + +Definition crossR p := variation (sgp_minfty p) (sgp_pinfty p). + +Definition sum_var (s : seq R) := \sum_(n <- pairmap variation 0 s) n. + +Lemma cindexEba a b : b <= a -> forall p q, cindex a b p q = 0. +Proof. by move=> le_ba p q; rewrite /cindex rootsEba ?big_nil. Qed. + +Lemma jump0p q x : jump 0 q x = 0. Proof. by rewrite /jump eqxx mulr0n. Qed. + +Lemma taq_cindex a b p q : taq (roots p a b) q = cindex a b (p^`() * q) p. +Proof. +have [lt_ab|?] := ltrP a b; last by rewrite rootsEba ?cindexEba /taq ?big_nil. +rewrite /taq /cindex !big_seq; apply: eq_bigr => x. +have [->|p_neq0 /root_roots rpx] := eqVneq p 0; first by rewrite roots0 in_nil. +have [->|q_neq0] := eqVneq q 0; first by rewrite mulr0 jump0p horner0 sgz0. +have [p'0|p'_neq0] := eqVneq p^`() 0. + move/(root_size_gt1 p_neq0): rpx. + by rewrite -subn_gt0 subn1 -size_deriv p'0 size_poly0. +have p'q0: p^`() * q != 0 by rewrite mulf_neq0. +move:(p'q0); rewrite mulf_eq0 negb_or; case/andP=> p'0 q0. +have p0: p != 0 by move: p'0; apply: contra; move/eqP->; rewrite derivC. +rewrite /jump mu_mul// {1}(@mu_deriv_root _ _ p)// addn1 p'q0 /=. +case emq: (\mu_(_) q)=> [|m]. + move/eqP: emq; rewrite -leqn0 leqNgt mu_gt0// => qxn0. + rewrite addn0 subSnn mulr1n. + rewrite !sgp_right_mul// (sgp_right_deriv rpx) mulrAC. + rewrite sgp_right_square// mul1r sgp_rightNroot//. + rewrite sgr_lt0 -sgz_cp0. + by move: qxn0; rewrite -[root q x]sgz_cp0; case: sgzP. +rewrite addnS subSS -{1}[\mu_(_) _]addn0 subnDl sub0n mulr0n. +by apply/eqP; rewrite sgz_cp0 -[_ == 0]mu_gt0// emq. +Qed. + +Lemma sum_varP s : 0 \notin s -> sum_var s = variation (head 0 s) (last 0 s). +Proof. +rewrite /sum_var /variation. +case: s => /= [_|a s]; first by rewrite big_nil sgz0 mul0r. +rewrite in_cons big_cons mul0r ltrr mulr0 add0r. +elim: s a => [|b s IHs] a; first by rewrite big_nil ler_gtF ?mulr0 ?sqr_ge0. +move=> /norP [neq_0a Hbs]; move: (Hbs); rewrite in_cons => /norP[neq_0b Hs]. +rewrite /= big_cons IHs ?negb_or ?neq_0b // -!sgz_cp0 !sgzM. +have: (last b s) != 0 by apply: contra Hbs => /eqP <-; rewrite mem_last. +by move: neq_0a neq_0b; do 3?case: sgzP => ? //. +Qed. + +Lemma jump_coprime p q : p != 0 -> coprimep p q + -> forall x, root p x -> jump q p x = sjump (q * p) x. +Proof. +move=> pn0 cpq x rpx; rewrite /jump /sjump. +have q_neq0 : q != 0; last rewrite q_neq0 /=. + apply: contraTneq cpq => ->; rewrite coprimep0. + by apply: contraL rpx => /eqp_root ->; rewrite rootC oner_eq0. +have := coprimep_root cpq rpx; rewrite -rootE -mu_eq0 => // /eqP muxq_eq0. +by rewrite mu_mul ?mulf_neq0 ?muxq_eq0 ?subn0 ?add0n. +Qed. + +Lemma sjump_neigh a b p x : p != 0 -> + {in neighpl p a x & neighpr p x b, + forall yl yr, sjump p x = cross p yl yr}. +Proof. +move=> pn0 yl yr yln yrn; rewrite /cross /variation. +rewrite -sgr_cp0 sgrM /sjump (sgr_neighpl yln) -!(sgr_neighpr yrn). +rewrite -mulrA -expr2 sqr_sg (rootPf (neighpr_root yrn)) mulr1. +rewrite sgrEz ltrz0 -[in rhs in _ = rhs]intr_sign -[X in _ == X]mulrN1z eqr_int. +by have /rootPf := neighpr_root yrn; case: sgzP; case: odd. +Qed. + +Lemma jump_neigh a b p q x : q * p != 0 -> + {in neighpl (q * p) a x & neighpr (q * p) x b, forall yl yr, + jump q p x = cross (q * p) yl yr *+ ((q != 0) && (\mu_x p > \mu_x q)%N)}. +Proof. +move=> pqn0 yl yr hyl hyr; rewrite -(sjump_neigh pqn0 hyl hyr). +rewrite /jump /sjump -mulrnA mulnb andbCA. +have [muqp|/eqnP ->] := ltnP; rewrite (andbF, andbT) //. +by rewrite mu_mul // odd_add addbC odd_sub // ltnW. +Qed. + +Lemma jump_mul2l (p q r : {poly R}) : + p != 0 -> jump (p * q) (p * r) =1 jump q r. +Proof. +move=> p0 x; rewrite /jump. +case q0: (q == 0); first by rewrite (eqP q0) mulr0 eqxx. +have ->: p * q != 0 by rewrite mulf_neq0 ?p0 ?q0. +case r0: (r == 0); first by rewrite (eqP r0) !mulr0 mu0 !sub0n. +rewrite !mu_mul ?mulf_neq0 ?andbT ?q0 ?r0 //; rewrite subnDl. +rewrite mulrAC mulrA -mulrA. +rewrite (@sgp_right_mul _ (p * p)) // sgp_right_mul // sgp_right_square //. +by rewrite mul1r mulrC /=. +Qed. + +Lemma jump_mul2r (p q r : {poly R}) : + p != 0 -> jump (q * p) (r * p) =1 jump q r. +Proof. by move=> p0 x; rewrite ![_ * p]mulrC jump_mul2l. Qed. + +Lemma jumppc p c x : jump p c%:P x = 0. +Proof. by rewrite /jump mu_polyC sub0n !andbF. Qed. + +Lemma noroot_jump q p x : ~~ root p x -> jump q p x = 0. +Proof. +have [->|p_neq0] := eqVneq p 0; first by rewrite jumppc. +by rewrite -mu_gt0 // lt0n negbK /jump => /eqP ->; rewrite andbF mulr0n. +Qed. + +Lemma jump_mulCp c p q x : jump (c *: p) q x = (sgz c) * jump p q x. +Proof. +have [->|c0] := eqVneq c 0; first by rewrite sgz0 scale0r jump0p mul0r. +have [->|p0] := eqVneq p 0; first by rewrite scaler0 jump0p mulr0. +have [->|q0] := eqVneq q 0; first by rewrite !jumppc mulr0. +(* :TODO: : rename mu_mulC *) +rewrite /jump scale_poly_eq0 mu_mulC ?negb_or ?c0 ?p0 ?andTb //. +rewrite -scalerAl sgp_right_scale //. +case: sgzP c0 => // _ _; rewrite !(mul1r, mulN1r, =^~ mulNrn) //. +by rewrite ?oppr_cp0 lt0r sgp_right_eq0 ?mulf_neq0 // andTb lerNgt signrN. +Qed. + +Lemma jump_pmulC c p q x : jump p (c *: q) x = (sgz c) * jump p q x. +Proof. +have [->|c0] := eqVneq c 0; first by rewrite sgz0 scale0r mul0r jumppc. +have [->|p0] := eqVneq p 0; first by rewrite !jump0p mulr0. +have [->|q0] := eqVneq q 0; first by rewrite scaler0 !jumppc mulr0. +rewrite /jump mu_mulC // -scalerAr sgp_right_scale //. +case: sgzP c0 => // _ _; rewrite !(mul1r, mulN1r, =^~ mulNrn) //. +by rewrite ?oppr_cp0 lt0r sgp_right_eq0 ?mulf_neq0 // andTb lerNgt signrN. +Qed. + +Lemma jump_mod p q x : + jump p q x = sgz (lead_coef q) ^+ (rscalp p q) * jump (rmodp p q) q x. +Proof. +case p0: (p == 0); first by rewrite (eqP p0) rmod0p jump0p mulr0. +case q0: (q == 0); first by rewrite (eqP q0) rmodp0 jumppc mulr0. +rewrite -sgzX; set s := sgz _. +apply: (@mulfI _ s); first by rewrite /s sgz_eq0 lcn_neq0. +rewrite mulrA mulz_sg lcn_neq0 mul1r -jump_mulCp rdivp_eq. +have [->|rpq_eq0] := altP (rmodp p q =P 0). + by rewrite addr0 jump0p -[X in jump _ X]mul1r jump_mul2r ?q0 // jumppc. +rewrite /jump. set r := _ * q + _. +have muxp : \mu_x p = \mu_x r by rewrite /r -rdivp_eq mu_mulC ?lcn_neq0. +have r_neq0 : r != 0 by rewrite /r -rdivp_eq scaler_eq0 p0 orbF lcn_neq0. +have [hpq|hpq] := leqP (\mu_x q) (\mu_x r). + rewrite 2!(_ : _ - _ = 0)%N ?andbF //; apply/eqP; rewrite -/(_ <= _)%N //. + by rewrite mu_mod_leq ?dvdpE // muxp. +rewrite mu_mod ?muxp // rpq_eq0 (negPf r_neq0); congr (_ ^+ _ *+ _). +rewrite !sgp_right_mul sgp_right_mod ?muxp // /r -rdivp_eq. +by rewrite -mul_polyC sgp_right_mul sgp_rightc sgrX. +Qed. + +Lemma cindexRP q p a b : + {in `]-oo, a], noroot p} -> {in `[b , +oo[, noroot p} -> + cindex a b q p = cindexR q p. +Proof. by rewrite /cindex => rpa rpb; rewrite rootsRP. Qed. + +Lemma cindex0p a b q : cindex a b 0 q = 0. +Proof. +have [lt_ab|le_ba] := ltrP a b; last by rewrite cindexEba. +by apply: big1_seq=> x; rewrite /jump eqxx mulr0n. +Qed. + +Lemma cindexR0p p : cindexR 0 p = 0. +Proof. by rewrite /cindexR big1 // => q _; rewrite jump0p. Qed. + +Lemma cindexpC a b p c : cindex a b p (c%:P) = 0. +Proof. +have [lt_ab|le_ba] := ltrP a b; last by rewrite cindexEba. +by rewrite /cindex /jump rootsC big_nil. +Qed. + +Lemma cindexRpC q c : cindexR q c%:P = 0. +Proof. by rewrite /cindexR rootsRC big_nil. Qed. + +Lemma cindex_mul2r a b p q r : r != 0 -> + cindex a b (p * r) (q * r) = cindex a b p q. +Proof. +have [lt_ab r0|le_ba] := ltrP a b; last by rewrite !cindexEba. +have [->|p0] := eqVneq p 0; first by rewrite mul0r !cindex0p. +have [->|q0] := eqVneq q 0; first by rewrite mul0r !cindexpC. +rewrite /cindex (eq_big_perm _ (roots_mul _ _ _))//= big_cat/=. +rewrite -[\sum_(x <- _) jump p _ _]addr0; congr (_+_). + by rewrite !big_seq; apply: congr_big => // x hx; rewrite jump_mul2r. +rewrite big1_seq//= => x hx; rewrite jump_mul2r // /jump. +suff ->: \mu_x q = 0%N by rewrite andbF. +apply/eqP; rewrite -leqn0 leqNgt mu_gt0 //. +apply/negP; rewrite root_factor_theorem => rqx; move/root_roots:hx. +case: gdcopP=> g hg; rewrite (negPf r0) orbF => cgq hdg. +rewrite root_factor_theorem=> rgx. +move/coprimepP:cgq rqx rgx=> cgq; rewrite -!dvdpE=> /cgq hgq /hgq. +by rewrite -size_poly_eq1 size_XsubC. +Qed. + +Lemma cindex_mulCp a b p q c : + cindex a b (c *: p) q = (sgz c) * cindex a b p q. +Proof. +have [lt_ab|le_ba] := ltrP a b; last by rewrite !cindexEba ?mulr0. +have [->|p0] := eqVneq p 0; first by rewrite !(cindex0p, scaler0, mulr0). +have [->|q0] := eqVneq q 0; first by rewrite !(cindexpC, scaler0, mulr0). +by rewrite /cindex big_distrr; apply: congr_big => //= x; rewrite jump_mulCp. +Qed. + +Lemma cindex_pmulC a b p q c : + cindex a b p (c *: q) = (sgz c) * cindex a b p q. +Proof. +have [lt_ab|le_ba] := ltrP a b; last by rewrite !cindexEba ?mulr0. +have [->|p0] := eqVneq p 0; first by rewrite !(cindex0p, scaler0, mulr0). +have [->|q0] := eqVneq q 0; first by rewrite !(cindexpC, scaler0, mulr0). +have [->|c0] := eqVneq c 0; first by rewrite scale0r sgz0 mul0r cindexpC. +rewrite /cindex big_distrr rootsZ //. +by apply: congr_big => // x _; rewrite jump_pmulC. +Qed. + +Lemma cindex_mod a b p q : + cindex a b p q = + (sgz (lead_coef q) ^+ rscalp p q) * cindex a b (rmodp p q) q. +Proof. +have [lt_ab|le_ba] := ltrP a b; last by rewrite !cindexEba ?mulr0. +by rewrite /cindex big_distrr; apply: congr_big => // x; rewrite jump_mod. +Qed. + +Lemma variation0r b : variation 0 b = 0. +Proof. by rewrite /variation mul0r ltrr mulr0. Qed. + +Lemma variationC a b : variation a b = - variation b a. +Proof. by rewrite /variation -!sgz_cp0 !sgzM; do 2?case: sgzP => _ //. Qed. + +Lemma variationr0 a : variation a 0 = 0. +Proof. by rewrite variationC variation0r oppr0. Qed. + +Lemma variation_pmull a b c : c > 0 -> variation (a * c) (b) = variation a b. +Proof. by move=> c_gt0; rewrite /variation mulrAC pmulr_llt0. Qed. + +Lemma variation_pmulr a b c : c > 0 -> variation a (b * c) = variation a b. +Proof. by move=> c_gt0; rewrite variationC variation_pmull // -variationC. Qed. + +Lemma congr_variation a b a' b' : sgz a = sgz a' -> sgz b = sgz b' -> + variation a b = variation a' b'. +Proof. by rewrite /variation -!sgz_cp0 !sgzM => -> ->. Qed. + +Lemma crossRP p a b : + {in `]-oo, a], noroot p} -> {in `[b , +oo[, noroot p} -> + cross p a b = crossR p. +Proof. +move=> rpa rpb; rewrite /crossR /cross. +rewrite -(@sgp_minftyP _ _ _ rpa a) ?boundr_in_itv //. +rewrite -(@sgp_pinftyP _ _ _ rpb b) ?boundl_in_itv //. +by rewrite /variation -sgrM sgr_lt0 sgz_sgr. +Qed. + +Lemma noroot_cross p a b : a <= b -> + {in `]a, b[, noroot p} -> cross p a b = 0. +Proof. +move=> le_ab noroot_ab; rewrite /cross /variation. +have [] := ltrP; last by rewrite mulr0. +rewrite mulr1 -sgr_cp0 sgrM => /eqP. +by move=> /(ivt_sign le_ab) [x /noroot_ab /negPf->]. +Qed. + +Lemma cross_pmul p q a b : q.[a] > 0 -> q.[b] > 0 -> + cross (p * q) a b = cross p a b. +Proof. +by move=> qa0 qb0; rewrite /cross !hornerM variation_pmull ?variation_pmulr. +Qed. + +Lemma cross0 a b : cross 0 a b = 0. +Proof. by rewrite /cross !horner0 variation0r. Qed. + +Lemma crossR0 : crossR 0 = 0. +Proof. +by rewrite /crossR /sgp_minfty /sgp_pinfty lead_coef0 mulr0 sgr0 variationr0. +Qed. + +Lemma cindex_seq_mids a b : a < b -> + forall p q, p != 0 -> q != 0 -> coprimep p q -> + cindex a b q p + cindex a b p q = + sum_var (map (horner (p * q)) (seq_mids a (roots (p * q) a b) b)). +Proof. +move=> hab p q p0 q0 cpq; rewrite /cindex /sum_var 2!big_seq. +have pq_neq0 : p * q != 0 by rewrite mulf_neq0. +have pq_eq0 := negPf pq_neq0. +have jumpP : forall (p q : {poly R}), p != 0 -> coprimep p q -> + forall x, x \in roots p a b -> jump q p x = sjump (q * p) x. + by move=> ? ? ? ? ?; move/root_roots=> ?; rewrite jump_coprime. +rewrite !(eq_bigr _ (jumpP _ _ _ _))// 1?coprimep_sym// => {jumpP}. +have sjumpC x : sjump (q * p) x = sjump (p * q) x by rewrite mulrC. +rewrite -!big_seq (eq_bigr _ (fun x _ => sjumpC x)). +rewrite -big_cat /= -(eq_big_perm _ (roots_mul_coprime _ _ _ _)) //=. +move: {1 2 5}a hab (erefl (roots (p * q) a b)) => //=. +elim: roots => {a} [|x s /= ihs] a hab /eqP. + by rewrite big_cons !big_nil variation0r. +rewrite roots_cons; case/and5P => _ xab /eqP hax hx /eqP hs. +rewrite !big_cons variation0r add0r (ihs _ _ hs) ?(itvP xab) // => {ihs}. +pose y := (head b s); pose ax := midf a x; pose xy := midf x y. +rewrite (@sjump_neigh a b _ _ _ ax xy) ?inE ?midf_lte//=; last 2 first. ++ by rewrite /prev_root pq_eq0 hax minr_l ?(itvP xab, midf_lte). ++ have hy: y \in `]x, b]. + rewrite /y; case: s hs {y xy} => /= [|u s] hu. + by rewrite boundr_in_itv /= ?(itvP xab). + have /roots_in: u \in roots (p * q) x b by rewrite hu mem_head. + by apply: subitvP; rewrite /= !lerr. + by rewrite /next_root pq_eq0 hs maxr_l ?(itvP hy, midf_lte). +move: @y @xy {hs}; rewrite /cross. +by case: s => /= [|y l]; rewrite ?(big_cons, big_nil, variation0r, add0r). +Qed. + +Lemma cindex_inv a b : a < b -> forall p q, + ~~ root (p * q) a -> ~~ root (p * q) b -> + cindex a b q p + cindex a b p q = cross (p * q) a b. +Proof. +move=> hab p q hpqa hpqb. +have hlab: a <= b by apply: ltrW. +wlog cpq: p q hpqa hpqb / coprimep p q => [hwlog|]. + have p0: p != 0 by apply: contraNneq hpqa => ->; rewrite mul0r rootC. + have q0: q != 0 by apply: contraNneq hpqa => ->; rewrite mulr0 rootC. + set p' := p; rewrite -(divpK (dvdp_gcdr p q)) -[p'](divpK (dvdp_gcdl p q)). + rewrite !cindex_mul2r ?gcdp_eq0 ?(negPf p0) //. + have ga0 : (gcdp p q).[a] != 0. + apply: contra hpqa; rewrite -rootE -!dvdp_XsubCl => /dvdp_trans -> //. + by rewrite dvdp_mulr ?dvdp_gcdl. + have gb0 : (gcdp p q).[b] != 0. + apply: contra hpqb; rewrite -rootE -!dvdp_XsubCl => /dvdp_trans -> //. + by rewrite dvdp_mulr ?dvdp_gcdl. + rewrite mulrACA -expr2 cross_pmul ?horner_exp ?exprn_even_gt0 ?ga0 ?gb0 //. + apply: hwlog; rewrite ?coprimep_div_gcd ?p0 // rootM. + + apply: contra hpqa; rewrite -!dvdp_XsubCl => /orP. + case=> /dvdp_trans-> //; rewrite (dvdp_trans (divp_dvd _)); + by rewrite ?(dvdp_gcdl, dvdp_gcdr) ?(dvdp_mulIl, dvdp_mulIr). + + apply: contra hpqb; rewrite -!dvdp_XsubCl => /orP. + case=> /dvdp_trans-> //; rewrite (dvdp_trans (divp_dvd _)); + by rewrite ?(dvdp_gcdl, dvdp_gcdr) ?(dvdp_mulIl, dvdp_mulIr). +have p0: p != 0 by apply: contraNneq hpqa => ->; rewrite mul0r rootC. +have q0: q != 0 by apply: contraNneq hpqa => ->; rewrite mulr0 rootC. +have pq0 : p * q != 0 by rewrite mulf_neq0. +rewrite cindex_seq_mids // sum_varP /cross. + apply: congr_variation; apply: (mulrIz (oner_neq0 R)); rewrite -!sgrEz. + case hr: roots => [|c s] /=; apply: (@sgr_neighprN _ _ a b) => //; + rewrite /neighpr /next_root ?(negPf pq0) maxr_l // hr mid_in_itv //=. + by move/eqP: hr; rewrite roots_cons => /and5P [_ /itvP ->]. + rewrite -cats1 pairmap_cat /= cats1 map_rcons last_rcons. + apply: (@sgr_neighplN _ _ a b) => //. + rewrite /neighpl /prev_root (negPf pq0) minr_l //. + by rewrite mid_in_itv //= last_roots_le. +elim: roots {-2 6}a (erefl (roots (p * q) a b)) + {hpqa hpqb} hab hlab => {a} [|c s IHs] a Hs hab hlab /=. + rewrite in_cons orbF eq_sym. (* ; set x := (X in _.[X]). *) + by rewrite -rootE (@roots_nil _ _ a b) // mid_in_itv. +move/eqP: Hs; rewrite roots_cons => /and5P [_ cab /eqP rac rc /eqP rcb]. +rewrite in_cons eq_sym -rootE negb_or (roots_nil _ rac) //=; last first. + by rewrite mid_in_itv //= (itvP cab). +by rewrite IHs // (itvP cab). +Qed. + +Definition next_mod p q := - (lead_coef q ^+ rscalp p q) *: rmodp p q. + +Lemma next_mod0p q : next_mod 0 q = 0. +Proof. by rewrite /next_mod rmod0p scaler0. Qed. + +Lemma cindex_rec a b : a < b -> forall p q, + ~~ root (p * q) a -> ~~ root (p * q) b -> + cindex a b q p = cross (p * q) a b + cindex a b (next_mod p q) q. +Proof. +move=> lt_ab p q rpqa rpqb; have [->|p0] := eqVneq p 0. + by rewrite cindexpC next_mod0p cindex0p mul0r cross0 add0r. +have [->|q0] := eqVneq q 0. + by rewrite cindex0p cindexpC mulr0 cross0 add0r. +have /(canRL (addrK _)) -> := cindex_inv lt_ab rpqa rpqb. +by rewrite cindex_mulCp cindex_mod sgzN mulNr sgzX. +Qed. + +Lemma cindexR_rec p q : + cindexR q p = crossR (p * q) + cindexR (next_mod p q) q. +Proof. +have [->|p_neq0] := eqVneq p 0. + by rewrite cindexRpC mul0r next_mod0p cindexR0p crossR0. +have [->|q_neq0] := eqVneq q 0. + by rewrite cindexR0p mulr0 crossR0 cindexRpC. +have pq_neq0 : p * q != 0 by rewrite mulf_neq0. +pose b := cauchy_bound (p * q). +have [lecb gecb] := pair (le_cauchy_bound pq_neq0) (ge_cauchy_bound pq_neq0). +rewrite -?(@cindexRP _ _ (-b) b); do ? + by [move=> x Hx /=; have: ~~ root (p * q) x by [apply: lecb|apply: gecb]; + rewrite rootM => /norP []]. +rewrite -(@crossRP _ (-b) b) 1?cindex_rec ?gt0_cp ?cauchy_bound_gt0 //. + by rewrite lecb // boundr_in_itv. +by rewrite gecb // boundl_in_itv. +Qed. + +(* Computation of cindex through changes_mods *) + +Definition mods p q := + let fix aux p q n := + if n is m.+1 + then if p == 0 then [::] else p :: (aux q (next_mod p q) m) + else [::] in aux p q (maxn (size p) (size q).+1). + +Lemma mods_rec p q : mods p q = + if p == 0 then [::] else p :: (mods q (next_mod p q)). +Proof. +rewrite /mods; set aux := fix aux _ _ n := if n is _.+1 then _ else _. +have aux0 u n : aux 0 u n = [::] by case: n => [//|n] /=; rewrite eqxx. +pose m p q := maxn (size p) (size q).+1; rewrite -!/(m _ _). +suff {p q} Hnext p q : q != 0 -> (m q (next_mod p q) < m p q)%N; last first. + rewrite /m -maxnSS leq_max !geq_max !ltnS leqnn /= /next_mod. + rewrite size_scale ?oppr_eq0 ?lcn_neq0 //=. + by move=> q_neq0; rewrite ltn_rmodp ?q_neq0 ?orbT. +suff {p q} m_gt0 p q : (0 < m p q)%N; last by rewrite leq_max orbT. +rewrite -[m p q]prednK //=; have [//|p_neq0] := altP (p =P 0). +have [->|q_neq0] := altP (q =P 0); first by rewrite !aux0. +congr (_ :: _); suff {p q p_neq0 q_neq0} Haux p q n n' : + (m p q <= n)%N -> (m p q <= n')%N -> aux p q n = aux p q n'. + by apply: Haux => //; rewrite -ltnS prednK // Hnext. +elim: n p q n' => [p q|n IHn p q n' Hn]; first by rewrite geq_max ltn0 andbF. +case: n' => [|n' Hn' /=]; first by rewrite geq_max ltn0 andbF. +have [//|p_neq0] := altP eqP; congr (_ :: _). +have [->|q_neq0] := altP (q =P 0); first by rewrite !aux0. +by apply: IHn; rewrite -ltnS (leq_trans _ Hn, leq_trans _ Hn') ?Hnext. +Qed. + +Lemma mods_eq0 p q : (mods p q == [::]) = (p == 0). +Proof. by rewrite mods_rec; have [] := altP (p =P 0). Qed. + +Lemma neq0_mods_rec p q : p != 0 -> mods p q = p :: mods q (next_mod p q). +Proof. by rewrite mods_rec => /negPf ->. Qed. + +Lemma mods0p q : mods 0 q = [::]. +Proof. by apply/eqP; rewrite mods_eq0. Qed. + +Lemma modsp0 p : mods p 0 = if p == 0 then [::] else [::p]. +Proof. by rewrite mods_rec mods0p. Qed. + +Fixpoint changes (s : seq R) : nat := + (if s is a :: q then (a * (head 0 q) < 0)%R + changes q else 0)%N. + +Definition changes_pinfty (p : seq {poly R}) := changes (map lead_coef p). +Definition changes_minfty (p : seq {poly R}) := + changes (map (fun p : {poly _} => (-1) ^+ (~~ odd (size p)) * lead_coef p) p). + +Definition changes_poly (p : seq {poly R}) := + (changes_minfty p)%:Z - (changes_pinfty p)%:Z. +Definition changes_mods p q := changes_poly (mods p q). + +Lemma changes_mods0p q : changes_mods 0 q = 0. +Proof. by rewrite /changes_mods /changes_poly mods0p. Qed. + +Lemma changes_modsp0 p : changes_mods p 0 = 0. +Proof. +rewrite /changes_mods /changes_poly modsp0; have [//|p_neq0] := altP eqP. +by rewrite /changes_minfty /changes_pinfty /= !mulr0 ltrr. +Qed. + +Lemma changes_mods_rec p q : + changes_mods p q = crossR (p * q) + changes_mods q (next_mod p q). +Proof. +have [->|p0] := eqVneq p 0. + by rewrite changes_mods0p mul0r crossR0 next_mod0p changes_modsp0. +have [->|q0] := eqVneq q 0. + by rewrite changes_modsp0 mulr0 crossR0 changes_mods0p. +rewrite /changes_mods /changes_poly neq0_mods_rec //=. +rewrite !PoszD opprD addrACA; congr (_ + _); rewrite neq0_mods_rec //=. +rewrite /crossR /variation /sgp_pinfty /sgp_minfty. +rewrite mulr_signM size_mul // !lead_coefM. +rewrite polySpred // addSn [size q]polySpred // addnS /= !negbK. +rewrite -odd_add signr_odd; set s := _ ^+ _. +rewrite -!sgz_cp0 !(sgz_sgr, sgzM). +have: s != 0 by rewrite signr_eq0. +by move: p0 q0; rewrite -!lead_coef_eq0; do 3!case: sgzP=> _. +Qed. + +Lemma changes_mods_cindex p q : changes_mods p q = cindexR q p. +Proof. +elim: mods {-2}p {-2}q (erefl (mods p q)) => [|r s IHs] {p q} p q hrpq. + move/eqP: hrpq; rewrite mods_eq0 => /eqP ->. + by rewrite changes_mods0p cindexRpC. +rewrite changes_mods_rec cindexR_rec IHs //. +by move: hrpq IHs; rewrite mods_rec; case: (p == 0) => // [] []. +Qed. + +Definition taqR p q := changes_mods p (p^`() * q). + +Lemma taq_taqR p q : taq (rootsR p) q = taqR p q. +Proof. by rewrite /taqR changes_mods_cindex taq_cindex. Qed. + +Section ChangesItvMod_USELESS. +(* Not used anymore, but the content of this section is *) +(* used in the LMCS 2012 paper and in Cyril's thesis *) + +Definition changes_horner (p : seq {poly R}) x := + changes (map (fun p => p.[x]) p). +Definition changes_itv_poly a b (p : seq {poly R}) := + (changes_horner p a)%:Z - (changes_horner p b)%:Z. + +Definition changes_itv_mods a b p q := changes_itv_poly a b (mods p q). + +Lemma changes_itv_mods0p a b q : changes_itv_mods a b 0 q = 0. +Proof. +by rewrite /changes_itv_mods /changes_itv_poly mods0p /changes_horner /= subrr. +Qed. + +Lemma changes_itv_modsp0 a b p : changes_itv_mods a b p 0 = 0. +Proof. +rewrite /changes_itv_mods /changes_itv_poly modsp0 /changes_horner /=. +by have [//|p_neq0 /=] := altP eqP; rewrite !mulr0 ltrr. +Qed. + +Lemma changes_itv_mods_rec a b : a < b -> forall p q, + ~~ root (p * q) a -> ~~ root (p * q) b -> + changes_itv_mods a b p q = cross (p * q) a b + + changes_itv_mods a b q (next_mod p q). +Proof. +move=> lt_ab p q rpqa rpqb. +have [->|p0] := eqVneq p 0. + by rewrite changes_itv_mods0p mul0r next_mod0p changes_itv_modsp0 cross0. +have [->|q0] := eqVneq q 0. + by rewrite changes_itv_modsp0 mulr0 cross0 changes_itv_mods0p. +rewrite /changes_itv_mods /changes_itv_poly /changes_horner neq0_mods_rec //=. +rewrite !PoszD opprD addrACA; congr (_ + _); rewrite neq0_mods_rec //=. +move: rpqa rpqb; rewrite -!hornerM !rootE; move: (p * q) => r {p q p0 q0}. +by rewrite /cross /variation -![_ < _]sgz_cp0 sgzM; do 2!case: sgzP => _. +Qed. + +Lemma changes_itv_mods_cindex a b : a < b -> forall p q, + all (fun p => ~~ root p a) (mods p q) -> + all (fun p => ~~ root p b) (mods p q) -> + changes_itv_mods a b p q = cindex a b q p. +Proof. +move=> hab p q. +elim: mods {-2}p {-2}q (erefl (mods p q)) => [|r s IHs] {p q} p q hrpq. + move/eqP: hrpq; rewrite mods_eq0 => /eqP ->. + by rewrite changes_itv_mods0p cindexpC. +have p_neq0 : p != 0 by rewrite -(mods_eq0 p q) hrpq. +move: hrpq IHs; rewrite neq0_mods_rec //. +move=> [_ <-] IHs /= /andP[rpa Ha] /andP[rpb Hb]. +move=> /(_ _ _ (erefl _) Ha Hb) in IHs. +have [->|q_neq0] := eqVneq q 0; first by rewrite changes_itv_modsp0 cindex0p. +move: Ha Hb; rewrite neq0_mods_rec //= => /andP[rqa _] /andP[rqb _]. +rewrite cindex_rec 1?changes_itv_mods_rec; +by rewrite ?rootM ?negb_or ?rpa ?rpb ?rqa ?rqb // IHs. +Qed. + +Definition taq_itv a b p q := changes_itv_mods a b p (p^`() * q). + +Lemma taq_taq_itv a b : a < b -> forall p q, + all (fun p => p.[a] != 0) (mods p (p^`() * q)) -> + all (fun p => p.[b] != 0) (mods p (p^`() * q)) -> + taq (roots p a b) q = taq_itv a b p q. +Proof. by move=> *; rewrite /taq_itv changes_itv_mods_cindex // taq_cindex. Qed. + +End ChangesItvMod_USELESS. + +Definition tvecR p sq := let sg_tab := sg_tab (size sq) in + \row_(i < 3^size sq) (taqR p (map (poly_comb sq) sg_tab)`_i). + +Lemma tvec_tvecR sq p : tvec (rootsR p) sq = tvecR p sq. +Proof. +by rewrite /tvec /tvecR; apply/matrixP=> i j; rewrite !mxE taq_taqR. +Qed. + +Lemma all_prodn_gt0 : forall (I : finType) r (P : pred I) (F : I -> nat), + (\prod_(i <- r | P i) F i > 0)%N -> + forall i, i \in r -> P i -> (F i > 0)%N. +Proof. +move=> I r P F; elim: r => [_|a r hr] //. +rewrite big_cons; case hPa: (P a). + rewrite muln_gt0; case/andP=> Fa0; move/hr=> hF x. + by rewrite in_cons; case/orP; [move/eqP-> | move/hF]. +move/hr=> hF x; rewrite in_cons; case/orP; last by move/hF. +by move/eqP->; rewrite hPa. +Qed. + +Definition taqsR p sq i : R := + (taqR p (map (poly_comb sq) (sg_tab (size sq)))`_i)%:~R. + +Definition ccount_weak p sq : R := + let fix aux s (i : nat) := if i is i'.+1 + then aux (taqsR p sq i' * coefs R (size sq) i' + s) i' + else s in aux 0 (3 ^ size sq)%N. + +Lemma constraints1P (p : {poly R}) (sq : seq {poly R}) : + (constraints (rootsR p) (sq) (nseq (size (sq)) 1))%:~R + = ccount_weak p sq. +Proof. +rewrite constraints1_tvec; symmetry. +rewrite castmxE mxE /= /ccount_weak. +transitivity (\sum_(0 <= i < 3 ^ size sq) taqsR p sq i * coefs R (size sq) i). + rewrite unlock /reducebig /= -foldr_map /= /index_iota subn0 foldr_map. + elim: (3 ^ size sq)%N 0%R => [|n ihn] u //. + by rewrite -[X in iota _ X]addn1 iota_add add0n /= foldr_cat ihn. +rewrite big_mkord; apply: congr_big=> // i _. +rewrite /taqsR /coefs /tvecR /=. +have o : 'I_(3 ^ size sq) by rewrite exp3n; apply: ord0. +rewrite (@nth_map _ o); last by rewrite size_enum_ord. +by rewrite !castmxE !cast_ord_id !mxE /= nth_ord_enum taq_taqR. +Qed. + +Lemma ccount_weakP p sq : p != 0 -> + reflect (exists x, (p.[x] == 0) && \big[andb/true]_(q <- sq) (q.[x] > 0)) + (ccount_weak p sq > 0). +Proof. +move=> p_neq0; rewrite -constraints1P /constraints ltr0n lt0n. +rewrite -(@pnatr_eq0 [numDomainType of int]) natr_sum psumr_eq0 //. +rewrite -has_predC /=. +apply: (iffP hasP) => [[x rpx /= prod_neq0]|[x /andP[rpx]]]. + exists x; rewrite -rootE [root _ _]roots_on_rootsR // rpx /=. + rewrite big_seq big1 => // q Hq. + move: prod_neq0; rewrite pnatr_eq0 -lt0n => /all_prodn_gt0. + have := index_mem q sq; rewrite Hq => Hoq. + pose oq := Ordinal Hoq => /(_ oq). + rewrite mem_index_enum => /(_ isT isT) /=. + by rewrite nth_nseq index_mem Hq nth_index // lt0b sgz_cp0. +rewrite big_all => /allP Hsq. +exists x => /=; first by rewrite -roots_on_rootsR. +rewrite pnatr_eq0 -lt0n prodn_gt0 => // i; rewrite nth_nseq ltn_ord lt0b. +by rewrite sgz_cp0 Hsq // mem_nth. +Qed. + +Lemma myprodf_eq0 (S : idomainType)(I : eqType) (r : seq I) P (F : I -> S) : + reflect (exists2 i, ((i \in r) && (P i)) & (F i == 0)) + (\prod_(i <- r| P i) F i == 0). +Proof. +apply: (iffP idP) => [|[i Pi /eqP Fi0]]; last first. + by case/andP: Pi => ri Pi; rewrite (big_rem _ ri) /= Pi Fi0 mul0r. +elim: r => [|i r IHr]; first by rewrite big_nil oner_eq0. +rewrite big_cons /=; have [Pi | ?] := ifP. + rewrite mulf_eq0; case/orP=> [Fi0|]; first by exists i => //; rewrite mem_head. + by case/IHr=> j /andP [rj Pj] Fj; exists j; rewrite // in_cons rj orbT. +by case/IHr=> j /andP [rj Pj] Fj; exists j; rewrite // in_cons rj orbT. +Qed. + +Definition bounding_poly (sq : seq {poly R}) := (\prod_(q <- sq) q)^`(). + +Lemma bounding_polyP (sq : seq {poly R}) : + [\/ \big[andb/true]_(q <- sq) (lead_coef q > 0), + \big[andb/true]_(q <- sq) ((-1)^+(size q).-1 * (lead_coef q) > 0) | + exists x, + ((bounding_poly sq).[x] == 0) && \big[andb/true]_(q <- sq) (q.[x] > 0)] + <-> exists x, \big[andb/true]_(q <- sq) (q.[x] > 0). +Proof. +split=> [|[x]]. + case; last by move=> [x /andP [? h]]; exists x; rewrite h. + rewrite big_all => /allP hsq. + have sqn0 : {in sq, forall q, q != 0}. + by move=> q' /= /hsq; apply: contraL=> /eqP->; rewrite lead_coef0 ltrr. + pose qq := \prod_(q <- sq) q. + have pn0 : qq != 0. + by apply/negP=> /myprodf_eq0 [] q; rewrite andbT => /sqn0 /negPf ->. + pose b := cauchy_bound qq; exists b. + rewrite big_all; apply/allP=> r hr; have:= hsq r hr. + rewrite -!sgr_cp0=> /eqP <-; apply/eqP. + apply: (@sgp_pinftyP _ b); last by rewrite boundl_in_itv. + move=> z Hz /=; have: ~~ root qq z by rewrite ge_cauchy_bound. + by rewrite /root /qq horner_prod prodf_seq_neq0 => /allP /(_ _ hr). + rewrite big_all => /allP hsq. + have sqn0 : {in sq, forall q, q != 0}. + move=> q' /= /hsq; apply: contraL=> /eqP->. + by rewrite lead_coef0 mulr0 ltrr. + pose qq := \prod_(q <- sq) q. + have pn0 : qq != 0. + by apply/negP=> /myprodf_eq0 [] q; rewrite andbT => /sqn0 /negPf ->. + pose b := - cauchy_bound qq; exists b. + rewrite big_all; apply/allP=> r hr; have:= hsq r hr. + rewrite -!sgr_cp0=> /eqP <-; apply/eqP. + apply: (@sgp_minftyP _ b); last by rewrite boundr_in_itv. + move=> z Hz /=; have: ~~ root qq z by rewrite le_cauchy_bound. + by rewrite /root /qq horner_prod prodf_seq_neq0 => /allP /(_ _ hr). +rewrite /bounding_poly; set q := \prod_(q <- _) _. +rewrite big_all => /allP hsq; set bnd := cauchy_bound q. +have sqn0 : {in sq, forall q, q != 0}. + by move=> q' /= /hsq; apply: contraL=> /eqP->; rewrite horner0 ltrr. +have [/eqP|q_neq0] := eqVneq q 0. + by rewrite prodf_seq_eq0=> /hasP [q' /= /sqn0 /negPf->]. +have genroot y : {in sq, forall r, ~~ root q y -> ~~ root r y}. + rewrite /root /q => r r_sq. + by rewrite horner_prod prodf_seq_neq0 => /allP /(_ _ r_sq). +case: (next_rootP q x bnd) q_neq0; [by move->; rewrite eqxx| |]; last first. + move=> _ q_neq0 _ Hq _. + suff -> : \big[andb/true]_(q1 <- sq) (0 < lead_coef q1) by constructor. + rewrite big_all; apply/allP=> r hr; have rxp := hsq r hr. + rewrite -sgr_cp0 -/(sgp_pinfty _). + rewrite -(@sgp_pinftyP _ x _ _ x) ?boundl_in_itv ?sgr_cp0 //. + move=> z; rewrite (@itv_splitU _ x true) /= ?boundl_in_itv //. + rewrite itv_xx /= inE => /orP [/eqP->|]; first by rewrite /root gtr_eqF. + have [x_b|b_x] := ltrP x bnd. + rewrite (@itv_splitU _ bnd false) /=; last by rewrite inE x_b. + move=> /orP [] Hz; rewrite genroot //; + by [rewrite Hq|rewrite ge_cauchy_bound]. + by move=> Hz; rewrite genroot // ge_cauchy_bound // (subitvP _ Hz) //= b_x. +move=> y1 _ rqy1 hy1xb hy1. +case: (prev_rootP q (- bnd) x); [by move->; rewrite eqxx| |]; last first. + move=> _ q_neq0 _ Hq _. (* assia : what is the use of c ? *) + suff -> : \big[andb/true]_(q1 <- sq) (0 < (-1) ^+ (size q1).-1 * lead_coef q1). + by constructor 2. + rewrite big_all; apply/allP=> r hr; have rxp := hsq r hr. + rewrite -sgr_cp0 -/(sgp_minfty _). + rewrite -(@sgp_minftyP _ x _ _ x) ?boundr_in_itv ?sgr_cp0 //. + move=> z; rewrite (@itv_splitU _ x false) /= ?boundr_in_itv //. + rewrite itv_xx => /orP [/=|/eqP->]; last by rewrite /root gtr_eqF. + have [b_x|x_b] := ltrP (- bnd) x. + rewrite (@itv_splitU _ (- bnd) true) /=; last by rewrite inE b_x. + move=> /orP [] Hz; rewrite genroot //; + by [rewrite Hq|rewrite le_cauchy_bound]. + by move=> Hz; rewrite genroot // le_cauchy_bound // (subitvP _ Hz) //= x_b. +move=> y2 _ rqy2 hy2xb hy2 q_neq0. +have lty12 : y2 < y1. + by apply: (@ltr_trans _ x); rewrite 1?(itvP hy1xb) 1?(itvP hy2xb). +have : q.[y2] = q.[y1] by rewrite rqy1 rqy2. +case/(rolle lty12) => z hz rz; constructor 3; exists z. +rewrite rz eqxx /= big_all; apply/allP => r r_sq. +have xy : x \in `]y2, y1[ by rewrite inE 1?(itvP hy1xb) 1?(itvP hy2xb). +rewrite -sgr_cp0 (@polyrN0_itv _ `]y2, y1[ _ _ x) ?sgr_cp0 ?hsq // => t. +rewrite (@itv_splitU2 _ x) // => /or3P [/hy2|/eqP->|/hy1]; do ?exact: genroot. +by rewrite rootE gtr_eqF ?hsq. +Qed. + +Lemma size_prod_eq1 (sq : seq {poly R}) : + reflect (forall q, q \in sq -> size q = 1%N) (size (\prod_(q0 <- sq) q0) == 1%N). +Proof. +apply: (iffP idP). + elim: sq => [| q sq ih]; first by move=> _ q; rewrite in_nil. + rewrite big_cons; case: (altP (q =P 0)) => [-> | qn0]. + by rewrite mul0r size_poly0. + case: (altP ((\prod_(j <- sq) j) =P 0)) => [-> | pn0]. + by rewrite mulr0 size_poly0. + rewrite size_mul //; case: (ltngtP (size q) 1). + - by rewrite ltnS leqn0 size_poly_eq0 (negPf qn0). + - case: (size q) => [|n] //; case: n => [|n] // _; rewrite !addSn /= eqSS. + by rewrite addn_eq0 size_poly_eq0 (negPf pn0) andbF. + - move=> sq1; case: (ltngtP (size (\prod_(j <- sq) j)) 1). + + by rewrite ltnS leqn0 size_poly_eq0 (negPf pn0). + + case: (size (\prod_(j <- sq) j)) => [|n] //; case: n => [|n] // _. + by rewrite !addnS /= eqSS addn_eq0 size_poly_eq0 (negPf qn0). + move=> sp1 _ p; rewrite in_cons; case/orP => [/eqP -> |] //; apply: ih. + by apply/eqP. +elim: sq => [| q sq ih] hs; first by rewrite big_nil size_poly1 eqxx. +case: (altP (q =P 0)) => [ | qn0]. + by move/eqP; rewrite -size_poly_eq0 hs ?mem_head. +case: (altP ((\prod_(q0 <- sq) q0) =P 0)) => [ | pn0]. + move/eqP; rewrite -size_poly_eq0 (eqP (ih _)) // => t ht; apply: hs. + by rewrite in_cons ht orbT. +rewrite big_cons size_mul // (eqP (ih _)) //; last first. + by move=> t ht; apply: hs; rewrite in_cons ht orbT. +rewrite addnS addn0; apply/eqP; apply: hs; exact: mem_head. +Qed. + +Definition ccount_gt0 (sp sq : seq {poly R}) := + let p := \big[@rgcdp _/0%R]_(p <- sp) p in + if p != 0 then 0 < ccount_weak p sq + else let bq := bounding_poly sq in + [|| \big[andb/true]_(q <- sq)(lead_coef q > 0) , + \big[andb/true]_(q <- sq)((-1)^+(size q).-1 *(lead_coef q) > 0) | + 0 < ccount_weak bq sq]. + +Lemma ccount_gt0P (sp sq : seq {poly R}) : + reflect (exists x, \big[andb/true]_(p <- sp) (p.[x] == 0) + && \big[andb/true]_(q <- sq) (q.[x] > 0)) + (ccount_gt0 sp sq). +Proof. +rewrite /ccount_gt0; case: (boolP (_ == 0))=> hsp /=; last first. + apply: (iffP (ccount_weakP _ _)) => // [] [x Hx]; exists x; + by move: Hx; rewrite -rootE root_bigrgcd -big_all. +apply: (@equivP (exists x, \big[andb/true]_(q <- sq) (0 < q.[x]))); last first. + split=> [] [x Hx]; exists x; rewrite ?Hx ?andbT; do ?by case/andP: Hx. + move: hsp; rewrite (big_morph _ (@rgcdp_eq0 _) (eqxx _)) !big_all. + by move=> /allP Hsp; apply/allP => p /Hsp /eqP ->; rewrite horner0. +have [|bq_neq0] := boolP (bounding_poly sq == 0). + rewrite /bounding_poly -derivn1 -derivn_poly0 => ssq_le1. + rewrite -constraints1P (size1_polyC ssq_le1) derivnC /= rootsRC. + rewrite /constraints big_nil ltrr orbF. + move: ssq_le1; rewrite leq_eqVlt ltnS leqn0 orbC. + have [|_ /=] := boolP (_ == _). + rewrite size_poly_eq0 => /eqP sq_eq0; move/eqP: (sq_eq0). + rewrite prodf_seq_eq0 => /hasP /sig2W [q /= q_sq] /eqP q_eq0. + move: q_sq; rewrite q_eq0 => sq0 _ {q q_eq0}. + set f := _ || _; suff -> : f = false; move: @f => /=. + constructor => [] [x]; rewrite big_all. + by move=> /allP /(_ _ sq0); rewrite horner0 ltrr. + apply: negbTE; rewrite !negb_or !big_all -!has_predC. + apply/andP; split; apply/hasP; + by exists 0; rewrite //= ?lead_coef0 ?mulr0 ltrr. + move=> /size_prod_eq1 Hsq. + have {Hsq} Hsq q : q \in sq -> q = (lead_coef q)%:P. + by move=> /Hsq sq1; rewrite [q]size1_polyC ?sq1 // lead_coefC. + apply: (@equivP (\big[andb/true]_(q <- sq) (0 < lead_coef q))); last first. + split; [move=> sq0; exists 0; move: sq0|move=> [x]]; + rewrite !big_all => /allP H; apply/allP => q q_sq; have:= H _ q_sq; + by rewrite [q]Hsq ?lead_coefC ?hornerC. + have [] := boolP (\big[andb/true]_(q <- _) (0 < lead_coef q)). + by constructor. + rewrite !big_all -has_predC => /hasP sq0; apply: (iffP allP) => //=. + move: sq0 => [q q_sq /= lq_gt0 /(_ _ q_sq)]. + rewrite [q]Hsq ?size_polyC ?lead_coefC //. + by case: (_ != 0); rewrite /= expr0 mul1r ?(negPf lq_gt0). +apply: (iffP or3P); rewrite -bounding_polyP; +case; do ?by [constructor 1|constructor 2]; +by move/(ccount_weakP _ bq_neq0); constructor 3. +Qed. + +End QeRcfTh. diff --git a/mathcomp/real_closed/realalg.v b/mathcomp/real_closed/realalg.v new file mode 100644 index 0000000..88d656a --- /dev/null +++ b/mathcomp/real_closed/realalg.v @@ -0,0 +1,1530 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype. +Require Import bigop ssralg ssrnum ssrint rat poly polydiv polyorder. +Require Import perm matrix mxpoly polyXY binomial generic_quotient. +Require Import cauchyreals separable zmodp bigenough. + +(*************************************************************************) +(* This files constructs the real closure of an archimedian field in the *) +(* way described in Cyril Cohen. Construction of real algebraic numbers *) +(* in Coq. In Lennart Beringer and Amy Felty, editors, ITP - 3rd *) +(* International Conference on Interactive Theorem Proving - 2012, *) +(* Princeton, United States, August 2012. Springer *) +(* *) +(* The only definition one may want to use in this file is the operator *) +(* {realclosure R} which constructs the real closure of the archimedian *) +(* field R (for which rat is a prefect candidate) *) +(*************************************************************************) + +Import GRing.Theory Num.Theory BigEnough. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Reserved Notation "{ 'realclosure' T }" + (at level 0, format "{ 'realclosure' T }"). +Reserved Notation "{ 'alg' T }" (at level 0, format "{ 'alg' T }"). + +Section extras. + +Local Open Scope ring_scope. +Local Notation "p ^ f" := (map_poly f p) : ring_scope. + +Lemma map_comp_poly (aR : fieldType) (rR : idomainType) + (f : {rmorphism aR -> rR}) + (p q : {poly aR}) : (p \Po q) ^ f = (p ^ f) \Po (q ^ f). +Proof. +rewrite !comp_polyE size_map_poly; apply: (big_ind2 (fun x y => x ^ f = y)). ++ by rewrite rmorph0. ++ by move=> u u' v v' /=; rewrite rmorphD /= => -> ->. +move=> /= i _; rewrite -mul_polyC rmorphM /= map_polyC mul_polyC. +by rewrite coef_map rmorphX. +Qed. + +End extras. + +Module RealAlg. + +Local Open Scope ring_scope. +Local Notation eval := horner_eval. + +Section RealAlg. + +Variable F : archiFieldType. +Local Notation m0 := (fun _ => 0%N). + +(*********************************************************************) +(* Construction of algebraic Cauchy reals : Cauchy real + polynomial *) +(*********************************************************************) + +CoInductive algcreal := AlgCReal { + creal_of_alg :> creal F; + annul_creal : {poly F}; + _ : annul_creal \is monic; + _ : (annul_creal.[creal_of_alg] == 0)%CR +}. + +Lemma monic_annul_creal x : annul_creal x \is monic. +Proof. by case: x. Qed. +Hint Resolve monic_annul_creal. + +Lemma annul_creal_eq0 x : (annul_creal x == 0) = false. +Proof. by rewrite (negPf (monic_neq0 _)). Qed. + +Lemma root_annul_creal x : ((annul_creal x).[x] == 0)%CR. +Proof. by case: x. Qed. +Hint Resolve root_annul_creal. + +Definition cst_algcreal (x : F) := + AlgCReal (monicXsubC _) (@root_cst_creal _ x). + +Local Notation zero_algcreal := (cst_algcreal 0). +Local Notation one_algcreal := (cst_algcreal 1). + +Lemma size_annul_creal_gt1 (x : algcreal) : + (1 < size (annul_creal x))%N. +Proof. +apply: (@has_root_creal_size_gt1 _ x). + by rewrite monic_neq0 // monic_annul_creal. +exact: root_annul_creal. +Qed. + +Lemma is_root_annul_creal (x : algcreal) (y : creal F) : + (x == y)%CR -> ((annul_creal x).[y] == 0)%CR. +Proof. by move <-. Qed. + +Definition AlgCRealOf (p : {poly F}) (x : creal F) + (p_neq0 : p != 0) (px_eq0 : (p.[x] == 0)%CR) := + AlgCReal (monic_monic_from_neq0 p_neq0) (root_monic_from_neq0 px_eq0). + +Lemma sub_annihilant_algcreal_neq0 (x y : algcreal) : + sub_annihilant (annul_creal x) (annul_creal y) != 0. +Proof. by rewrite sub_annihilant_neq0 ?monic_neq0. Qed. + +Lemma root_sub_algcreal (x y : algcreal) : + ((sub_annihilant (annul_creal x) (annul_creal y)).[x - y] == 0)%CR. +Proof. by rewrite root_sub_annihilant_creal ?root_annul_creal ?monic_neq0. Qed. + +Definition sub_algcreal (x y : algcreal) : algcreal := + AlgCRealOf (sub_annihilant_algcreal_neq0 x y) (@root_sub_algcreal x y). + +Lemma root_opp_algcreal (x : algcreal) : + ((annul_creal (sub_algcreal (cst_algcreal 0) x)).[- x] == 0)%CR. +Proof. by apply: is_root_annul_creal; rewrite /= add_0creal. Qed. + +Definition opp_algcreal (x : algcreal) : algcreal := + AlgCReal (@monic_annul_creal _) (@root_opp_algcreal x). + +Lemma root_add_algcreal (x y : algcreal) : + ((annul_creal (sub_algcreal x (opp_algcreal y))).[x + y] == 0)%CR. +Proof. +apply: is_root_annul_creal; apply: eq_crealP. +by exists m0=> * /=; rewrite opprK subrr normr0. +Qed. + +Definition add_algcreal (x y : algcreal) : algcreal := + AlgCReal (@monic_annul_creal _) (@root_add_algcreal x y). + +Lemma div_annihilant_algcreal_neq0 (x y : algcreal) : + (annul_creal y).[0] != 0 -> + div_annihilant (annul_creal x) (annul_creal y) != 0. +Proof. by move=> ?; rewrite div_annihilant_neq0 ?monic_neq0. Qed. + +Hint Resolve eq_creal_refl. +Hint Resolve le_creal_refl. + +Lemma simplify_algcreal (x : algcreal) (x_neq0 : (x != 0)%CR) : + {y | ((annul_creal y).[0] != 0) & ((y != 0)%CR * (x == y)%CR)%type}. +Proof. +elim: size {-3}x x_neq0 (leqnn (size (annul_creal x))) => + {x} [|n ihn] x x_neq0 hx. + by move: hx; rewrite leqn0 size_poly_eq0 annul_creal_eq0. +have [dvdX|ndvdX] := boolP ('X %| annul_creal x); last first. + by exists x=> //; rewrite -rootE -dvdp_XsubCl subr0. +have monic_p: @annul_creal x %/ 'X \is monic. + by rewrite -(monicMr _ (@monicX _)) divpK //. +have root_p: ((@annul_creal x %/ 'X).[x] == 0)%CR. + have := @eq_creal_refl _ ((annul_creal x).[x])%CR. + rewrite -{1}(divpK dvdX) horner_crealM // root_annul_creal. + by case/poly_mul_creal_eq0=> //; rewrite horner_crealX. +have [//|/=|y *] := ihn (AlgCReal monic_p root_p); last by exists y. +by rewrite size_divp ?size_polyX ?polyX_eq0 ?leq_subLR ?add1n. +Qed. + +(* Decidability of equality to 0 *) +Lemma algcreal_eq0_dec (x : algcreal) : {(x == 0)%CR} + {(x != 0)%CR}. +Proof. +pose p := annul_creal x; move: {2}(size _)%N (leqnn (size p))=> n. +elim: n x @p => [x p|n ihn x p le_sp_Sn]. + by rewrite leqn0 size_poly_eq0 /p annul_creal_eq0. +move: le_sp_Sn; rewrite leq_eqVlt; have [|//|eq_sp_Sn _] := ltngtP. + by rewrite ltnS=> /ihn ihnp _; apply: ihnp. +have px0 : (p.[x] == 0)%CR by apply: root_annul_creal. +have [cpX|ncpX] := boolP (coprimep p 'X). + by right; move: (cpX)=> /coprimep_root /(_ px0); rewrite horner_crealX. +have [eq_pX|] := altP (p =P 'X). + by left; move: px0; rewrite eq_pX horner_crealX. +rewrite -eqp_monic /p ?monicX // negb_and orbC. +have:= ncpX; rewrite coprimepX -dvdp_XsubCl subr0 => /negPf-> /= ndiv_pX. +have [r] := smaller_factor (monic_annul_creal _) px0 ndiv_pX ncpX. +rewrite eq_sp_Sn ltnS => /andP[le_r_n monic_r] rx_eq0. +exact: (ihn (AlgCReal monic_r rx_eq0)). +Qed. + +Lemma eq_algcreal_dec (x y : algcreal) : {(x == y)%CR} + {(x != y)%CR}. +Proof. +have /= [d_eq0|d_neq0] := algcreal_eq0_dec (sub_algcreal x y); [left|right]. + apply: eq_crealP; exists_big_modulus m F. + by move=> e i e_gt0 hi; rewrite (@eq0_modP _ _ d_eq0). + by close. +pose_big_enough i. + apply: (@neq_crealP _ (lbound d_neq0) i i); do ?by rewrite ?lbound_gt0. + by rewrite (@lbound0P _ _ d_neq0). +by close. +Qed. + +Definition eq_algcreal : rel algcreal := eq_algcreal_dec. + +Lemma eq_algcrealP (x y : algcreal) : reflect (x == y)%CR (eq_algcreal x y). +Proof. by rewrite /eq_algcreal; case: eq_algcreal_dec=> /=; constructor. Qed. +Implicit Arguments eq_algcrealP [x y]. + +Lemma neq_algcrealP (x y : algcreal) : reflect (x != y)%CR (~~ eq_algcreal x y). +Proof. by rewrite /eq_algcreal; case: eq_algcreal_dec=> /=; constructor. Qed. +Implicit Arguments neq_algcrealP [x y]. +Prenex Implicits eq_algcrealP neq_algcrealP. + +Fact eq_algcreal_is_equiv : equiv_class_of eq_algcreal. +Proof. +split=> [x|x y|y x z]; first by apply/eq_algcrealP. + by apply/eq_algcrealP/eq_algcrealP; symmetry. +by move=> /eq_algcrealP /eq_creal_trans h /eq_algcrealP /h /eq_algcrealP. +Qed. + +Canonical eq_algcreal_rel := EquivRelPack eq_algcreal_is_equiv. + +Lemma root_div_algcreal (x y : algcreal) (y_neq0 : (y != 0)%CR) : + (annul_creal y).[0] != 0 -> + ((div_annihilant (annul_creal x) (annul_creal y)).[x / y_neq0] == 0)%CR. +Proof. by move=> hx; rewrite root_div_annihilant_creal ?monic_neq0. Qed. + +Definition div_algcreal (x y : algcreal) := + match eq_algcreal_dec y (cst_algcreal 0) with + | left y_eq0 => cst_algcreal 0 + | right y_neq0 => + let: exist2 y' py'0_neq0 (y'_neq0, _) := simplify_algcreal y_neq0 in + AlgCRealOf (div_annihilant_algcreal_neq0 x py'0_neq0) + (@root_div_algcreal x y' y'_neq0 py'0_neq0) + end. + +Lemma root_inv_algcreal (x : algcreal) (x_neq0 : (x != 0)%CR) : + ((annul_creal (div_algcreal (cst_algcreal 1) x)).[x_neq0^-1] == 0)%CR. +Proof. +rewrite /div_algcreal; case: eq_algcreal_dec=> [/(_ x_neq0)|x_neq0'] //=. +case: simplify_algcreal=> x' px'0_neq0 [x'_neq0 eq_xx']. +apply: is_root_annul_creal;rewrite /= -(@eq_creal_inv _ _ _ x_neq0) //. +by apply: eq_crealP; exists m0=> * /=; rewrite div1r subrr normr0. +Qed. + +Definition inv_algcreal (x : algcreal) := + match eq_algcreal_dec x (cst_algcreal 0) with + | left x_eq0 => cst_algcreal 0 + | right x_neq0 => + AlgCReal (@monic_annul_creal _) (@root_inv_algcreal _ x_neq0) + end. + +Lemma div_creal_creal (y : creal F) (y_neq0 : (y != 0)%CR) : + (y / y_neq0 == 1%:CR)%CR. +Proof. +apply: eq_crealP; exists_big_modulus m F. + move=> e i e_gt0 hi; rewrite /= divff ?subrr ?normr0 //. + by rewrite (@creal_neq_always _ _ 0%CR). +by close. +Qed. + +Lemma root_mul_algcreal (x y : algcreal) : + ((annul_creal (div_algcreal x (inv_algcreal y))).[x * y] == 0)%CR. +Proof. +rewrite /div_algcreal /inv_algcreal. +case: (eq_algcreal_dec y)=> [->|y_neq0]; apply: is_root_annul_creal. + rewrite mul_creal0; case: eq_algcreal_dec=> // neq_00. + by move: (eq_creal_refl neq_00). +case: eq_algcreal_dec=> /= [yV_eq0|yV_neq0]. + have: (y * y_neq0^-1 == 0)%CR by rewrite yV_eq0 mul_creal0. + by rewrite div_creal_creal=> /eq_creal_cst; rewrite oner_eq0. +case: simplify_algcreal=> y' py'0_neq0 [y'_neq0 /= eq_yy']. +rewrite -(@eq_creal_inv _ _ _ yV_neq0) //. +by apply: eq_crealP; exists m0=> * /=; rewrite invrK subrr normr0. +Qed. + +Definition mul_algcreal (x y : algcreal) := + AlgCReal (@monic_annul_creal _) (@root_mul_algcreal x y). + +Lemma le_creal_neqVlt (x y : algcreal) : (x <= y)%CR -> {(x == y)%CR} + {(x < y)%CR}. +Proof. +case: (eq_algcreal_dec x y); first by left. +by move=> /neq_creal_ltVgt [|h /(_ h) //]; right. +Qed. + +Lemma ltVge_algcreal_dec (x y : algcreal) : {(x < y)%CR} + {(y <= x)%CR}. +Proof. +have [eq_xy|/neq_creal_ltVgt [lt_xy|lt_yx]] := eq_algcreal_dec x y; +by [right; rewrite eq_xy | left | right; apply: lt_crealW]. +Qed. + +Definition lt_algcreal : rel algcreal := ltVge_algcreal_dec. +Definition le_algcreal : rel algcreal := fun x y => ~~ ltVge_algcreal_dec y x. + +Lemma lt_algcrealP (x y : algcreal) : reflect (x < y)%CR (lt_algcreal x y). +Proof. by rewrite /lt_algcreal; case: ltVge_algcreal_dec; constructor. Qed. +Implicit Arguments lt_algcrealP [x y]. + +Lemma le_algcrealP (x y : algcreal) : reflect (x <= y)%CR (le_algcreal x y). +Proof. by rewrite /le_algcreal; case: ltVge_algcreal_dec; constructor. Qed. +Implicit Arguments le_algcrealP [x y]. +Prenex Implicits lt_algcrealP le_algcrealP. + +Definition exp_algcreal x n := iterop n mul_algcreal x one_algcreal. + +Lemma exp_algcrealE x n : (exp_algcreal x n == x ^+ n)%CR. +Proof. +case: n=> // n; rewrite /exp_algcreal /exp_creal !iteropS. +by elim: n=> //= n ->. +Qed. + +Definition horner_algcreal (p : {poly F}) x : algcreal := + \big[add_algcreal/zero_algcreal]_(i < size p) + mul_algcreal (cst_algcreal p`_i) (exp_algcreal x i). + +Lemma horner_algcrealE p x : (horner_algcreal p x == p.[x])%CR. +Proof. +rewrite horner_coef_creal. +apply: (big_ind2 (fun (u : algcreal) v => u == v)%CR)=> //. + by move=> u u' v v' /= -> ->. +by move=> i _ /=; rewrite exp_algcrealE. +Qed. + +Definition norm_algcreal (x : algcreal) := + if le_algcreal zero_algcreal x then x else opp_algcreal x. + +Lemma norm_algcrealE (x : algcreal) : (norm_algcreal x == `| x |)%CR. +Proof. +rewrite /norm_algcreal /le_algcreal; case: ltVge_algcreal_dec => /=. + move=> x_lt0; apply: eq_crealP; exists_big_modulus m F. + move=> e i e_gt0 hi /=; rewrite [`|x i|]ler0_norm ?subrr ?normr0 //. + by rewrite ltrW // [_ < 0%CR i]creal_lt_always. + by close. +move=> /(@le_creal_neqVlt zero_algcreal) /= []. + by move<-; apply: eq_crealP; exists m0=> * /=; rewrite !(normr0, subrr). +move=> x_gt0; apply: eq_crealP; exists_big_modulus m F. + move=> e i e_gt0 hi /=; rewrite [`|x i|]ger0_norm ?subrr ?normr0 //. + by rewrite ltrW // creal_gt0_always. +by close. +Qed. + +(**********************************************************************) +(* Theory of the "domain" of algebraic numbers: polynomial + interval *) +(**********************************************************************) +CoInductive algdom := AlgDom { + annul_algdom : {poly F}; + center_alg : F; + radius_alg : F; + _ : annul_algdom \is monic; + _ : radius_alg >= 0; + _ : annul_algdom.[center_alg - radius_alg] + * annul_algdom.[center_alg + radius_alg] <= 0 +}. + +Lemma radius_alg_ge0 x : 0 <= radius_alg x. Proof. by case: x. Qed. + +Lemma monic_annul_algdom x : annul_algdom x \is monic. Proof. by case: x. Qed. +Hint Resolve monic_annul_algdom. + +Lemma annul_algdom_eq0 x : (annul_algdom x == 0) = false. +Proof. by rewrite (negPf (monic_neq0 _)). Qed. + +Lemma algdomP x : (annul_algdom x).[center_alg x - radius_alg x] + * (annul_algdom x).[center_alg x + radius_alg x] <= 0. +Proof. by case: x. Qed. + +Definition algdom' := seq F. + +Definition encode_algdom (x : algdom) : algdom' := + [:: center_alg x, radius_alg x & (annul_algdom x)]. + +Definition decode_algdom (x : algdom') : option algdom := + if x is [::c, r & p'] + then let p := Poly p' in + if ((p \is monic) =P true, (r >= 0) =P true, + (p.[c - r] * p.[c + r] <= 0) =P true) + is (ReflectT monic_p, ReflectT r_gt0, ReflectT hp) + then Some (AlgDom monic_p r_gt0 hp) + else None + else None. + +Lemma encode_algdomK : pcancel encode_algdom decode_algdom. +Proof. +case=> p c r monic_p r_ge0 hp /=; rewrite polyseqK. +do 3?[case: eqP; rewrite ?monic_p ?r_ge0 ?monic_p //] => monic_p' r_ge0' hp'. +by congr (Some (AlgDom _ _ _)); apply: bool_irrelevance. +Qed. + +Definition algdom_EqMixin := PcanEqMixin encode_algdomK. +Canonical algdom_eqType := EqType algdom algdom_EqMixin. + +Definition algdom_ChoiceMixin := PcanChoiceMixin encode_algdomK. +Canonical algdom_choiceType := ChoiceType algdom algdom_ChoiceMixin. + +Fixpoint to_algcreal_of (p : {poly F}) (c r : F) (i : nat) : F := + match i with + | 0 => c + | i.+1 => + let c' := to_algcreal_of p c r i in + if p.[c' - r / 2%:R ^+ i] * p.[c'] <= 0 + then c' - r / 2%:R ^+ i.+1 + else c' + r / 2%:R ^+ i.+1 + end. + + +Lemma to_algcreal_of_recP p c r i : 0 <= r -> + `|to_algcreal_of p c r i.+1 - to_algcreal_of p c r i| <= r * 2%:R ^- i.+1. +Proof. +move=> r_ge0 /=; case: ifP=> _; rewrite addrAC subrr add0r ?normrN ger0_norm //; +by rewrite mulr_ge0 ?invr_ge0 ?exprn_ge0 ?ler0n. +Qed. + +Lemma to_algcreal_ofP p c r i j : 0 <= r -> (i <= j)%N -> + `|to_algcreal_of p c r j - to_algcreal_of p c r i| <= r * 2%:R ^- i. +Proof. +move=> r_ge0 leij; pose r' := r * 2%:R ^- j * (2%:R ^+ (j - i) - 1). +rewrite (@ler_trans _ r') //; last first. + rewrite /r' -mulrA ler_wpmul2l // ler_pdivr_mull ?exprn_gt0 ?ltr0n //. + rewrite -{2}(subnK leij) exprD mulfK ?gtr_eqF ?exprn_gt0 ?ltr0n //. + by rewrite ger_addl lerN10. +rewrite /r' subrX1 addrK mul1r -{1 2}(subnK leij); set f := _ c r. +elim: (_ - _)%N=> [|k ihk]; first by rewrite subrr normr0 big_ord0 mulr0 lerr. +rewrite addSn big_ord_recl /= mulrDr. +rewrite (ler_trans (ler_dist_add (f (k + i)%N) _ _)) //. +rewrite ler_add ?expr0 ?mulr1 ?to_algcreal_of_recP // (ler_trans ihk) //. +rewrite exprSr invfM -!mulrA !ler_wpmul2l ?invr_ge0 ?exprn_ge0 ?ler0n //. +by rewrite mulr_sumr ler_sum // => l _ /=; rewrite exprS mulKf ?pnatr_eq0. +Qed. + +Lemma alg_to_crealP (x : algdom) : + creal_axiom (to_algcreal_of (annul_algdom x) (center_alg x) (radius_alg x)). +Proof. +pose_big_modulus m F. + exists m=> e i j e_gt0 hi hj. + wlog leij : i j {hi} hj / (j <= i)%N. + move=> hwlog; case/orP: (leq_total i j)=> /hwlog; last exact. + by rewrite distrC; apply. + rewrite (ler_lt_trans (to_algcreal_ofP _ _ _ _)) ?radius_alg_ge0 //. + rewrite ltr_pdivr_mulr ?gtr0E // -ltr_pdivr_mull //. + by rewrite upper_nthrootP. +by close. +Qed. + +Definition alg_to_creal x := CReal (alg_to_crealP x). + +Lemma exp2k_crealP : @creal_axiom F (fun i => 2%:R ^- i). +Proof. +pose_big_modulus m F. + exists m=> e i j e_gt0 hi hj. + wlog leij : i j {hj} hi / (i <= j)%N. + move=> hwlog; case/orP: (leq_total i j)=> /hwlog; first exact. + by rewrite distrC; apply. + rewrite ger0_norm ?subr_ge0; last first. + by rewrite ?lef_pinv -?topredE /= ?gtr0E // ler_eexpn2l ?ltr1n. + rewrite -(@ltr_pmul2l _ (2%:R ^+ i )) ?gtr0E //. + rewrite mulrBr mulfV ?gtr_eqF ?gtr0E //. + rewrite (@ler_lt_trans _ 1) // ?ger_addl ?oppr_le0 ?mulr_ge0 ?ger0E //. + by rewrite -ltr_pdivr_mulr // mul1r upper_nthrootP. +by close. +Qed. +Definition exp2k_creal := CReal exp2k_crealP. + +Lemma exp2k_creal_eq0 : (exp2k_creal == 0)%CR. +Proof. +apply: eq_crealP; exists_big_modulus m F. + move=> e i e_gt0 hi /=. + rewrite subr0 gtr0_norm ?gtr0E // -ltf_pinv -?topredE /= ?gtr0E //. + by rewrite invrK upper_nthrootP. +by close. +Qed. + +Notation lbound0_of p := (@lbound0P _ _ p _ _ _). + +Lemma to_algcrealP (x : algdom) : ((annul_algdom x).[alg_to_creal x] == 0)%CR. +Proof. +set u := alg_to_creal _; set p := annul_algdom _. +pose r := radius_alg x; pose cr := cst_creal r. +have: ((p).[u - cr * exp2k_creal] * (p).[u + cr * exp2k_creal] <= 0)%CR. + apply: (@le_crealP _ 0%N)=> i _ /=. + rewrite -/p -/r; set c := center_alg _. + elim: i=> /= [|i]. + by rewrite !expr0 divr1 algdomP. + set c' := to_algcreal_of _ _ _=> ihi. + have [] := lerP (_ * p.[c' i]). + rewrite addrNK -addrA -opprD -mulr2n -[_ / _ *+ _]mulr_natr. + by rewrite -mulrA exprSr invfM mulfVK ?pnatr_eq0. + rewrite addrK -addrA -mulr2n -[_ / _ *+ _]mulr_natr. + rewrite -mulrA exprSr invfM mulfVK ?pnatr_eq0 // => /ler_pmul2l<-. + rewrite mulr0 mulrCA !mulrA [X in X * _]mulrAC -mulrA. + by rewrite mulr_ge0_le0 // -expr2 exprn_even_ge0. +rewrite exp2k_creal_eq0 mul_creal0 opp_creal0 add_creal0. +move=> hu pu0; apply: hu; pose e := (lbound pu0). +pose_big_enough i. + apply: (@lt_crealP _ (e * e) i i) => //. + by rewrite !pmulr_rgt0 ?invr_gt0 ?ltr0n ?lbound_gt0. + rewrite add0r [u]lock /= -!expr2. + rewrite -[_.[_] ^+ _]ger0_norm ?exprn_even_ge0 // normrX. + rewrite ler_pexpn2r -?topredE /= ?lbound_ge0 ?normr_ge0 //. + by rewrite -lock (ler_trans _ (lbound0_of pu0)). +by close. +Qed. + +Definition to_algcreal_rec (x : algdom) := + AlgCReal (monic_annul_algdom x) (@to_algcrealP x). +(* "Encoding" function from algdom to algcreal *) +Definition to_algcreal := locked to_algcreal_rec. + +(* "Decoding" function, constructed interactively *) +Lemma to_algdom_exists (x : algcreal) : + { y : algdom | (to_algcreal y == x)%CR }. +Proof. +pose p := annul_creal x. +move: {2}(size p) (leqnn (size p))=> n. +elim: n x @p=> [x p|n ihn x p le_sp_Sn]. + by rewrite leqn0 size_poly_eq0 /p annul_creal_eq0. +move: le_sp_Sn; rewrite leq_eqVlt. +have [|//|eq_sp_Sn _] := ltngtP. + by rewrite ltnS=> /ihn ihnp _; apply: ihnp. +have px0 := @root_annul_creal x; rewrite -/p -/root in px0. +have [|ncop] := boolP (coprimep p p^`()). + move/coprimep_root => /(_ _ px0) /deriv_neq0_mono [r r_gt0 [i ir sm]]. + have p_chg_sign : p.[x i - r] * p.[x i + r] <= 0. + have [/accr_pos_incr hp|/accr_neg_decr hp] := sm. + have hpxj : forall j, (i <= j)%N -> + (p.[x i - r] <= p.[x j]) * (p.[x j] <= p.[x i + r]). + move=> j hj. + suff: p.[x i - r] <= p.[x j] <= p.[x i + r] by case/andP=> -> ->. + rewrite !hp 1?addrAC ?subrr ?add0r ?normrN; + rewrite ?(gtr0_norm r_gt0) //; + do ?by rewrite ltrW ?cauchymodP ?(leq_trans _ hj). + by rewrite -ler_distl ltrW ?cauchymodP ?(leq_trans _ hj). + rewrite mulr_le0_ge0 //; apply/le_creal_cst; rewrite -px0; + by apply: (@le_crealP _ i)=> h hj /=; rewrite hpxj. + have hpxj : forall j, (i <= j)%N -> + (p.[x i + r] <= p.[x j]) * (p.[x j] <= p.[x i - r]). + move=> j hj. + suff: p.[x i + r] <= p.[x j] <= p.[x i - r] by case/andP=> -> ->. + rewrite !hp 1?addrAC ?subrr ?add0r ?normrN; + rewrite ?(gtr0_norm r_gt0) //; + do ?by rewrite ltrW ?cauchymodP ?(leq_trans _ hj). + by rewrite andbC -ler_distl ltrW ?cauchymodP ?(leq_trans _ hj). + rewrite mulr_ge0_le0 //; apply/le_creal_cst; rewrite -px0; + by apply: (@le_crealP _ i)=> h hj /=; rewrite hpxj. + pose y := (AlgDom (monic_annul_creal x) (ltrW r_gt0) p_chg_sign). + have eq_py_px: (p.[to_algcreal y] == p.[x])%CR. + rewrite /to_algcreal -lock. + by have := @to_algcrealP y; rewrite /= -/p=> ->; apply: eq_creal_sym. + exists y. + move: sm=> /strong_mono_bound [k k_gt0 hk]. + rewrite -/p; apply: eq_crealP. + exists_big_modulus m F. + move=> e j e_gt0 hj; rewrite (ler_lt_trans (hk _ _ _ _)) //. + + rewrite /to_algcreal -lock. + rewrite (ler_trans (to_algcreal_ofP _ _ _ (leq0n _))) ?(ltrW r_gt0) //. + by rewrite expr0 divr1. + + by rewrite ltrW // cauchymodP. + rewrite -ltr_pdivl_mull //. + by rewrite (@eq_modP _ _ _ eq_py_px) // ?pmulr_rgt0 ?invr_gt0. + by close. +case: (@smaller_factor _ p p^`() x); rewrite ?monic_annul_creal //. + rewrite gtNdvdp // -?size_poly_eq0 size_deriv eq_sp_Sn //=. + apply: contra ncop=> /eqP n_eq0; move: eq_sp_Sn; rewrite n_eq0. + by move=> /eqP /size_poly1P [c c_neq0 ->]; rewrite derivC coprimep0 polyC_eqp1. +move=> r /andP [hsr monic_r rx_eq0]. +apply: (ihn (AlgCReal monic_r rx_eq0))=> /=. +by rewrite -ltnS -eq_sp_Sn. +Qed. + +Definition to_algdom x := projT1 (to_algdom_exists x). + +Lemma to_algdomK x : (to_algcreal (to_algdom x) == x)%CR. +Proof. by rewrite /to_algdom; case: to_algdom_exists. Qed. + +Lemma eq_algcreal_to_algdom x : eq_algcreal (to_algcreal (to_algdom x)) x. +Proof. by apply/eq_algcrealP; apply: to_algdomK. Qed. + +(* Explicit encoding to a choice type *) +Canonical eq_algcreal_encModRel := EncModRel eq_algcreal eq_algcreal_to_algdom. + +Local Open Scope quotient_scope. + +(***************************************************************************) +(* Algebraic numbers are the quotient of algcreal by their setoid equality *) +(***************************************************************************) +Definition alg := {eq_quot eq_algcreal}. + +Definition alg_of of (phant F) := alg. +Identity Coercion type_alg_of : alg_of >-> alg. + +Notation "{ 'alg' F }" := (alg_of (Phant F)). + +(* A lot of structure is inherited *) +Canonical alg_eqType := [eqType of alg]. +Canonical alg_choiceType := [choiceType of alg]. +Canonical alg_quotType := [quotType of alg]. +Canonical alg_eqQuotType := [eqQuotType eq_algcreal of alg]. +Canonical alg_of_eqType := [eqType of {alg F}]. +Canonical alg_of_choiceType := [choiceType of {alg F}]. +Canonical alg_of_quotType := [quotType of {alg F}]. +Canonical alg_of_eqQuotType := [eqQuotType eq_algcreal of {alg F}]. + +Definition to_alg_def (phF : phant F) : F -> {alg F} := + lift_embed {alg F} cst_algcreal. +Notation to_alg := (@to_alg_def (Phant F)). +Notation "x %:RA" := (to_alg x) + (at level 2, left associativity, format "x %:RA"). +Local Notation "p ^ f" := (map_poly f p) : ring_scope. + +Canonical to_alg_pi_morph := PiEmbed to_alg. + +Local Notation zero_alg := 0%:RA. +Local Notation one_alg := 1%:RA. + +Lemma equiv_alg (x y : algcreal) : (x == y)%CR <-> (x = y %[mod {alg F}]). +Proof. +split; first by move=> /eq_algcrealP /eqquotP ->. +by move=> /eqquotP /eq_algcrealP. +Qed. + +Lemma nequiv_alg (x y : algcreal) : reflect (x != y)%CR (x != y %[mod {alg F}]). +Proof. by rewrite eqquotE; apply: neq_algcrealP. Qed. +Implicit Arguments nequiv_alg [x y]. +Prenex Implicits nequiv_alg. + +Lemma pi_algK (x : algcreal) : (repr (\pi_{alg F} x) == x)%CR. +Proof. by apply/equiv_alg; rewrite reprK. Qed. + +Definition add_alg := lift_op2 {alg F} add_algcreal. + +Lemma pi_add : {morph \pi_{alg F} : x y / add_algcreal x y >-> add_alg x y}. +Proof. by unlock add_alg=> x y; rewrite -equiv_alg /= !pi_algK. Qed. + +Canonical add_pi_morph := PiMorph2 pi_add. + +Definition opp_alg := lift_op1 {alg F} opp_algcreal. + +Lemma pi_opp : {morph \pi_{alg F} : x / opp_algcreal x >-> opp_alg x}. +Proof. by unlock opp_alg=> x; rewrite -equiv_alg /= !pi_algK. Qed. + +Canonical opp_pi_morph := PiMorph1 pi_opp. + +Definition mul_alg := lift_op2 {alg F} mul_algcreal. + +Lemma pi_mul : {morph \pi_{alg F} : x y / mul_algcreal x y >-> mul_alg x y}. +Proof. by unlock mul_alg=> x y; rewrite -equiv_alg /= !pi_algK. Qed. + +Canonical mul_pi_morph := PiMorph2 pi_mul. + +Definition inv_alg := lift_op1 {alg F} inv_algcreal. + +Lemma pi_inv : {morph \pi_{alg F} : x / inv_algcreal x >-> inv_alg x}. +Proof. +unlock inv_alg=> x; symmetry; rewrite -equiv_alg /= /inv_algcreal. +case: eq_algcreal_dec=> /= [|x'_neq0]. + by rewrite pi_algK; case: eq_algcreal_dec. +move: x'_neq0 (x'_neq0); rewrite {1}pi_algK. +case: eq_algcreal_dec=> // x'_neq0' x_neq0 x'_neq0 /=. +by apply: eq_creal_inv; rewrite pi_algK. +Qed. + +Canonical inv_pi_morph := PiMorph1 pi_inv. + +Lemma add_algA : associative add_alg. +Proof. +elim/quotW=> x; elim/quotW=> y; elim/quotW=> z; rewrite !piE -equiv_alg. +by apply: eq_crealP; exists m0=> * /=; rewrite addrA subrr normr0. +Qed. + +Lemma add_algC : commutative add_alg. +Proof. +elim/quotW=> x; elim/quotW=> y; rewrite !piE -equiv_alg /=. +by apply: eq_crealP; exists m0=> * /=; rewrite [X in _ - X]addrC subrr normr0. +Qed. + +Lemma add_0alg : left_id zero_alg add_alg. +Proof. by elim/quotW=> x; rewrite !piE -equiv_alg /= add_0creal. Qed. + +Lemma add_Nalg : left_inverse zero_alg opp_alg add_alg. +Proof. +elim/quotW=> x; rewrite !piE -equiv_alg /=. +by apply: eq_crealP; exists m0=> *; rewrite /= addNr subr0 normr0. +Qed. + +Definition alg_zmodMixin := ZmodMixin add_algA add_algC add_0alg add_Nalg. +Canonical alg_zmodType := Eval hnf in ZmodType alg alg_zmodMixin. +Canonical alg_of_zmodType := Eval hnf in ZmodType {alg F} alg_zmodMixin. + + +Lemma add_pi x y : \pi_{alg F} x + \pi_{alg F} y + = \pi_{alg F} (add_algcreal x y). +Proof. by rewrite [_ + _]piE. Qed. + +Lemma opp_pi x : - \pi_{alg F} x = \pi_{alg F} (opp_algcreal x). +Proof. by rewrite [- _]piE. Qed. + +Lemma zeroE : 0 = \pi_{alg F} zero_algcreal. +Proof. by rewrite [0]piE. Qed. + +Lemma sub_pi x y : \pi_{alg F} x - \pi_{alg F} y + = \pi_{alg F} (add_algcreal x (opp_algcreal y)). +Proof. by rewrite [_ - _]piE. Qed. + +Lemma mul_algC : commutative mul_alg. +Proof. +elim/quotW=> x; elim/quotW=> y; rewrite !piE -equiv_alg /=. +by apply: eq_crealP; exists m0=> * /=; rewrite mulrC subrr normr0. +Qed. + +Lemma mul_algA : associative mul_alg. +Proof. +elim/quotW=> x; elim/quotW=> y; elim/quotW=> z; rewrite !piE -equiv_alg /=. +by apply: eq_crealP; exists m0=> * /=; rewrite mulrA subrr normr0. +Qed. + +Lemma mul_1alg : left_id one_alg mul_alg. +Proof. by elim/quotW=> x; rewrite piE -equiv_alg /= mul_1creal. Qed. + +Lemma mul_alg_addl : left_distributive mul_alg add_alg. +Proof. +elim/quotW=> x; elim/quotW=> y; elim/quotW=> z; rewrite !piE -equiv_alg /=. +by apply: eq_crealP; exists m0=> * /=; rewrite mulrDl subrr normr0. +Qed. + +Implicit Arguments neq_creal_cst [F x y]. +Prenex Implicits neq_creal_cst. + +Lemma nonzero1_alg : one_alg != zero_alg. +Proof. by rewrite piE -(rwP neq_algcrealP) (rwP neq_creal_cst) oner_eq0. Qed. + +Definition alg_comRingMixin := + ComRingMixin mul_algA mul_algC mul_1alg mul_alg_addl nonzero1_alg. +Canonical alg_Ring := Eval hnf in RingType alg alg_comRingMixin. +Canonical alg_comRing := Eval hnf in ComRingType alg mul_algC. +Canonical alg_of_Ring := Eval hnf in RingType {alg F} alg_comRingMixin. +Canonical alg_of_comRing := Eval hnf in ComRingType {alg F} mul_algC. + +Lemma mul_pi x y : \pi_{alg F} x * \pi_{alg F} y + = \pi_{alg F} (mul_algcreal x y). +Proof. by rewrite [_ * _]piE. Qed. + +Lemma oneE : 1 = \pi_{alg F} one_algcreal. +Proof. by rewrite [1]piE. Qed. + +Lemma mul_Valg (x : alg) : x != zero_alg -> mul_alg (inv_alg x) x = one_alg. +Proof. +elim/quotW: x=> x; rewrite piE -(rwP neq_algcrealP) /= => x_neq0. +apply/eqP; rewrite piE; apply/eq_algcrealP; rewrite /= /inv_algcreal. +case: eq_algcreal_dec=> [/(_ x_neq0) //|/= x_neq0']. +apply: eq_crealP; exists_big_modulus m F. + by move=> * /=; rewrite mulVf ?subrr ?normr0 ?creal_neq0_always. +by close. +Qed. + +Lemma inv_alg0 : inv_alg zero_alg = zero_alg. +Proof. +rewrite !piE -equiv_alg /= /inv_algcreal. +by case: eq_algcreal_dec=> //= zero_neq0; move: (eq_creal_refl zero_neq0). +Qed. + +Lemma to_alg_additive : additive to_alg. +Proof. +move=> x y /=; rewrite !piE sub_pi -equiv_alg /=. +by apply: eq_crealP; exists m0=> * /=; rewrite subrr normr0. +Qed. + +Canonical to_alg_is_additive := Additive to_alg_additive. + +Lemma to_alg_multiplicative : multiplicative to_alg. +Proof. +split=> [x y |] //; rewrite !piE mul_pi -equiv_alg. +by apply: eq_crealP; exists m0=> * /=; rewrite subrr normr0. +Qed. + +Canonical to_alg_is_rmorphism := AddRMorphism to_alg_multiplicative. + +Lemma expn_pi (x : algcreal) (n : nat) : + (\pi_{alg F} x) ^+ n = \pi (exp_algcreal x n). +Proof. +rewrite /exp_algcreal; case: n=> [|n]; first by rewrite expr0 oneE. +rewrite exprS iteropS; elim: n=> /= [|n ihn]; rewrite ?expr0 ?mulr1 //. +by rewrite exprS ihn mul_pi. +Qed. + +Lemma horner_pi (p : {poly F}) (x : algcreal) : + (p ^ to_alg).[\pi_alg x] = \pi (horner_algcreal p x). +Proof. +rewrite horner_coef /horner_algcreal size_map_poly. +apply: (big_ind2 (fun x y => x = \pi_alg y)). ++ by rewrite zeroE. ++ by move=> u u' v v' -> ->; rewrite [_ + _]piE. +by move=> i /= _; rewrite expn_pi coef_map /= [_ * _]piE. +Qed. + +(* Defining annihilating polynomials for algebraics *) +Definition annul_alg : {alg F} -> {poly F} := locked (annul_creal \o repr). + +Lemma root_annul_algcreal (x : algcreal) : ((annul_alg (\pi x)).[x] == 0)%CR. +Proof. by unlock annul_alg; rewrite /= -pi_algK root_annul_creal. Qed. + +Lemma root_annul_alg (x : {alg F}) : root ((annul_alg x) ^ to_alg) x. +Proof. +apply/rootP; rewrite -[x]reprK horner_pi /= zeroE -equiv_alg. +by rewrite horner_algcrealE root_annul_algcreal. +Qed. + +Lemma monic_annul_alg (x : {alg F}) : annul_alg x \is monic. +Proof. by unlock annul_alg; rewrite monic_annul_creal. Qed. + +Lemma annul_alg_neq0 (x : {alg F}) : annul_alg x != 0. +Proof. by rewrite monic_neq0 ?monic_annul_alg. Qed. + +Definition AlgFieldUnitMixin := FieldUnitMixin mul_Valg inv_alg0. +Canonical alg_unitRing := + Eval hnf in UnitRingType alg AlgFieldUnitMixin. +Canonical alg_comUnitRing := Eval hnf in [comUnitRingType of alg]. +Canonical alg_of_unitRing := + Eval hnf in UnitRingType {alg F} AlgFieldUnitMixin. +Canonical alg_of_comUnitRing := Eval hnf in [comUnitRingType of {alg F}]. + +Lemma field_axiom : GRing.Field.mixin_of alg_unitRing. Proof. exact. Qed. + +Definition AlgFieldIdomainMixin := (FieldIdomainMixin field_axiom). +Canonical alg_iDomain := + Eval hnf in IdomainType alg (FieldIdomainMixin field_axiom). +Canonical alg_fieldType := FieldType alg field_axiom. +Canonical alg_of_iDomain := + Eval hnf in IdomainType {alg F} (FieldIdomainMixin field_axiom). +Canonical alg_of_fieldType := FieldType {alg F} field_axiom. + +Lemma inv_pi x : (\pi_{alg F} x)^-1 = \pi_{alg F} (inv_algcreal x). +Proof. by rewrite [_^-1]piE. Qed. + +Lemma div_pi x y : \pi_{alg F} x / \pi_{alg F} y + = \pi_{alg F} (mul_algcreal x (inv_algcreal y)). +Proof. by rewrite [_ / _]piE. Qed. + +Definition lt_alg := lift_fun2 {alg F} lt_algcreal. +Definition le_alg := lift_fun2 {alg F} le_algcreal. + +Lemma lt_alg_pi : {mono \pi_{alg F} : x y / lt_algcreal x y >-> lt_alg x y}. +Proof. +move=> x y; unlock lt_alg; rewrite /lt_algcreal. +by do 2!case: ltVge_algcreal_dec=> //=; rewrite !pi_algK. +Qed. + +Canonical lt_alg_pi_mono := PiMono2 lt_alg_pi. + +Lemma le_alg_pi : {mono \pi_{alg F} : x y / le_algcreal x y >-> le_alg x y}. +Proof. +move=> x y; unlock le_alg; rewrite /le_algcreal. +by do 2!case: ltVge_algcreal_dec=> //=; rewrite !pi_algK. +Qed. + +Canonical le_alg_pi_mono := PiMono2 le_alg_pi. + +Definition norm_alg := lift_op1 {alg F} norm_algcreal. + +Lemma norm_alg_pi : {morph \pi_{alg F} : x / norm_algcreal x >-> norm_alg x}. +Proof. +move=> x; unlock norm_alg; rewrite /norm_algcreal /le_algcreal. +by do 2!case: ltVge_algcreal_dec=> //=; rewrite !(pi_opp, pi_algK, reprK). +Qed. + +Canonical norm_alg_pi_morph := PiMorph1 norm_alg_pi. + +(* begin hide *) +(* Lemma norm_pi (x : algcreal) : `|\pi_{alg F} x| = \pi (norm_algcreal x). *) +(* Proof. by rewrite /norm_algcreal -lt_pi -zeroE -lerNgt fun_if -opp_pi. Qed. *) +(* end hide *) + +Lemma add_alg_gt0 x y : lt_alg zero_alg x -> lt_alg zero_alg y -> + lt_alg zero_alg (x + y). +Proof. +rewrite -[x]reprK -[y]reprK !piE -!(rwP lt_algcrealP). +move=> x_gt0 y_gt0; pose_big_enough i. + apply: (@lt_crealP _ (diff x_gt0 + diff y_gt0) i i) => //. + by rewrite addr_gt0 ?diff_gt0. + by rewrite /= add0r ler_add // ?diff0P. +by close. +Qed. + +Lemma mul_alg_gt0 x y : lt_alg zero_alg x -> lt_alg zero_alg y -> + lt_alg zero_alg (x * y). +Proof. +rewrite -[x]reprK -[y]reprK !piE -!(rwP lt_algcrealP). +move=> x_gt0 y_gt0; pose_big_enough i. + apply: (@lt_crealP _ (diff x_gt0 * diff y_gt0) i i) => //. + by rewrite pmulr_rgt0 ?diff_gt0. + rewrite /= add0r (@ler_trans _ (diff x_gt0 * (repr y) i)) //. + by rewrite ler_wpmul2l ?(ltrW (diff_gt0 _)) // diff0P. + by rewrite ler_wpmul2r ?diff0P ?ltrW ?creal_gt0_always. +by close. +Qed. + +Lemma gt0_alg_nlt0 x : lt_alg zero_alg x -> ~~ lt_alg x zero_alg. +Proof. +rewrite -[x]reprK !piE -!(rwP lt_algcrealP, rwP le_algcrealP). +move=> hx; pose_big_enough i. + apply: (@le_crealP _ i)=> j /= hj. + by rewrite ltrW // creal_gt0_always. +by close. +Qed. + +Lemma sub_alg_gt0 x y : lt_alg zero_alg (y - x) = lt_alg x y. +Proof. +rewrite -[x]reprK -[y]reprK !piE; apply/lt_algcrealP/lt_algcrealP=> /= hxy. + pose_big_enough i. + apply: (@lt_crealP _ (diff hxy) i i); rewrite ?diff_gt0 //. + by rewrite (monoLR (addNKr _) (ler_add2l _)) addrC diff0P. + by close. +pose_big_enough i. + apply: (@lt_crealP _ (diff hxy) i i); rewrite ?diff_gt0 //. + by rewrite (monoRL (addrK _) (ler_add2r _)) add0r addrC diffP. +by close. +Qed. + +Lemma lt0_alg_total (x : alg) : x != zero_alg -> + lt_alg zero_alg x || lt_alg x zero_alg. +Proof. +rewrite -[x]reprK !piE => /neq_algcrealP /= x_neq0. +apply/orP; rewrite -!(rwP lt_algcrealP). +case/neq_creal_ltVgt: x_neq0=> /= [lt_x0|lt_0x]; [right|by left]. +pose_big_enough i. + by apply: (@lt_crealP _ (diff lt_x0) i i); rewrite ?diff_gt0 ?diffP. +by close. +Qed. + +Lemma norm_algN x : norm_alg (- x) = norm_alg x. +Proof. +rewrite -[x]reprK !piE /= -equiv_alg !norm_algcrealE; apply: eq_crealP. +exists_big_modulus m F=> [e i e_gt0 hi /=|]. + by rewrite normrN subrr normr0. +by close. +Qed. + +Lemma ge0_norm_alg x : le_alg 0 x -> norm_alg x = x. +Proof. by rewrite -[x]reprK !piE /= /norm_algcreal => ->. Qed. + +Lemma lt_alg0N (x : alg) : lt_alg 0 (- x) = lt_alg x 0. +Proof. by rewrite -sub0r sub_alg_gt0. Qed. + +Lemma lt_alg00 : lt_alg zero_alg zero_alg = false. +Proof. by have /implyP := @gt0_alg_nlt0 0; case: lt_alg. Qed. + +Lemma le_alg_def x y : le_alg x y = (y == x) || lt_alg x y. +Proof. +rewrite -[x]reprK -[y]reprK eq_sym piE [lt_alg _ _]piE; apply/le_algcrealP/orP. + move=> /le_creal_neqVlt [/eq_algcrealP/eqquotP/eqP-> //|lt_xy]; first by left. + by right; apply/lt_algcrealP. +by move=> [/eqP/eqquotP/eq_algcrealP-> //| /lt_algcrealP /lt_crealW]. +Qed. + +Definition AlgNumFieldMixin := RealLtMixin add_alg_gt0 mul_alg_gt0 + gt0_alg_nlt0 sub_alg_gt0 lt0_alg_total norm_algN ge0_norm_alg le_alg_def. +Canonical alg_numDomainType := NumDomainType alg AlgNumFieldMixin. +Canonical alg_numFieldType := [numFieldType of alg]. +Canonical alg_of_numDomainType := [numDomainType of {alg F}]. +Canonical alg_of_numFieldType := [numFieldType of {alg F}]. + +Definition AlgRealFieldMixin := RealLeAxiom alg. +Canonical alg_realDomainType := RealDomainType alg AlgRealFieldMixin. +Canonical alg_realFieldType := [realFieldType of alg]. +Canonical alg_of_realDomainType := [realDomainType of {alg F}]. +Canonical alg_of_realFieldType := [realFieldType of {alg F}]. + +Lemma lt_pi x y : \pi_{alg F} x < \pi y = lt_algcreal x y. +Proof. by rewrite [_ < _]lt_alg_pi. Qed. + +Lemma le_pi x y : \pi_{alg F} x <= \pi y = le_algcreal x y. +Proof. by rewrite [_ <= _]le_alg_pi. Qed. + +Lemma norm_pi (x : algcreal) : `|\pi_{alg F} x| = \pi (norm_algcreal x). +Proof. by rewrite [`|_|]piE. Qed. + +Lemma lt_algP (x y : algcreal) : reflect (x < y)%CR (\pi_{alg F} x < \pi y). +Proof. by rewrite lt_pi; apply: lt_algcrealP. Qed. +Implicit Arguments lt_algP [x y]. + +Lemma le_algP (x y : algcreal) : reflect (x <= y)%CR (\pi_{alg F} x <= \pi y). +Proof. by rewrite le_pi; apply: le_algcrealP. Qed. +Implicit Arguments le_algP [x y]. +Prenex Implicits lt_algP le_algP. + +Lemma ler_to_alg : {mono to_alg : x y / x <= y}. +Proof. +apply: homo_mono=> x y lt_xy; rewrite !piE -(rwP lt_algP). +by apply/lt_creal_cst; rewrite lt_xy. +Qed. + +Lemma ltr_to_alg : {mono to_alg : x y / x < y}. +Proof. by apply: lerW_mono; apply: ler_to_alg. Qed. + +Lemma normr_to_alg : { morph to_alg : x / `|x| }. +Proof. +move=> x /=; have [] := ger0P; have [] := ger0P x%:RA; + rewrite ?rmorph0 ?rmorphN ?oppr0 //=. + by rewrite ltr_to_alg lerNgt => ->. +by rewrite ler_to_alg ltrNge => ->. +Qed. + +Lemma inf_alg_proof x : {d | 0 < d & 0 < x -> (d%:RA < x)}. +Proof. +have [|] := lerP; first by exists 1. +elim/quotW: x=> x; rewrite zeroE=> /lt_algP /= x_gt0. +exists (diff x_gt0 / 2%:R); first by rewrite pmulr_rgt0 ?gtr0E ?diff_gt0. +rewrite piE -(rwP lt_algP) /= => _; pose_big_enough i. + apply: (@lt_crealP _ (diff x_gt0 / 2%:R) i i) => //. + by rewrite pmulr_rgt0 ?gtr0E ?diff_gt0. + by rewrite -[_ + _](splitf 2) diff0P. +by close. +Qed. + +Definition inf_alg (x : {alg F}) : F := + let: exist2 d _ _ := inf_alg_proof x in d. + +Lemma inf_alg_gt0 x : 0 < inf_alg x. +Proof. by rewrite /inf_alg; case: inf_alg_proof. Qed. + +Lemma inf_lt_alg x : 0 < x -> (inf_alg x)%:RA < x. +Proof. by rewrite /inf_alg=> x_gt0; case: inf_alg_proof=> d _ /(_ x_gt0). Qed. + +Lemma approx_proof x e : {y | 0 < e -> `|x - y%:RA| < e}. +Proof. +elim/quotW:x => x; pose_big_enough i. + exists (x i)=> e_gt0; rewrite (ltr_trans _ (inf_lt_alg _)) //. + rewrite !piE sub_pi norm_pi -(rwP lt_algP) /= norm_algcrealE /=. + pose_big_enough j. + apply: (@lt_crealP _ (inf_alg e / 2%:R) j j) => //. + by rewrite pmulr_rgt0 ?gtr0E ?inf_alg_gt0. + rewrite /= {2}[inf_alg e](splitf 2) /= ler_add2r. + by rewrite ltrW // cauchymodP ?pmulr_rgt0 ?gtr0E ?inf_alg_gt0. + by close. +by close. +Qed. + +Definition approx := locked + (fun (x : alg) (e : alg) => projT1 (approx_proof x e) : F). + +Lemma approxP (x e e': alg) : 0 < e -> e <= e' -> `|x - (approx x e)%:RA| < e'. +Proof. +by unlock approx; case: approx_proof=> /= y hy /hy /ltr_le_trans hy' /hy'. +Qed. + +Lemma alg_archi : Num.archimedean_axiom alg_of_numDomainType. +Proof. +move=> x; move: {x}`|x| (normr_ge0 x) => x x_ge0. +pose a := approx x 1%:RA; exists (Num.bound (a + 1)). +have := @archi_boundP _ (a + 1); rewrite -ltr_to_alg rmorph_nat. +have := @approxP x _ _ ltr01 (lerr _); rewrite ltr_distl -/a => /andP [_ hxa]. +rewrite -ler_to_alg rmorphD /= (ler_trans _ (ltrW hxa)) //. +by move=> /(_ isT) /(ltr_trans _)->. +Qed. + +Canonical alg_archiFieldType := ArchiFieldType alg alg_archi. +Canonical alg_of_archiFieldType := [archiFieldType of {alg F}]. + +(**************************************************************************) +(* At this stage, algebraics form an archimedian field. We now build the *) +(* material to prove the intermediate value theorem. We first prove a *) +(* "weak version", which expresses that the extension {alg F} indeed *) +(* contains solutions of the intermediate value probelem in F *) +(**************************************************************************) + +Notation "'Y" := 'X%:P. + +Lemma weak_ivt (p : {poly F}) (a b : F) : a <= b -> p.[a] <= 0 <= p.[b] -> + { x : alg | a%:RA <= x <= b%:RA & root (p ^ to_alg) x }. +Proof. +move=> le_ab; have [-> _|p_neq0] := eqVneq p 0. + by exists a%:RA; rewrite ?lerr ?ler_to_alg // rmorph0 root0. +move=> /andP[pa_le0 pb_ge0]; apply/sig2W. +have hpab: p.[a] * p.[b] <= 0 by rewrite mulr_le0_ge0. +move=> {pa_le0 pb_ge0}; wlog monic_p : p hpab p_neq0 / p \is monic. + set q := (lead_coef p) ^-1 *: p => /(_ q). + rewrite !hornerZ mulrCA !mulrA -mulrA mulr_ge0_le0 //; last first. + by rewrite (@exprn_even_ge0 _ 2). + have mq: q \is monic by rewrite monicE lead_coefZ mulVf ?lead_coef_eq0. + rewrite monic_neq0 ?mq=> // [] [] // x hx hqx; exists x=> //. + move: hqx; rewrite /q -mul_polyC rmorphM /= rootM map_polyC rootC. + by rewrite fmorph_eq0 invr_eq0 lead_coef_eq0 (negPf p_neq0). +pose c := (a + b) / 2%:R; pose r := (b - a) / 2%:R. +have r_ge0 : 0 <= r by rewrite mulr_ge0 ?ger0E // subr_ge0. +have hab: ((c - r = a)%R * (c + r = b)%R)%type. + rewrite -mulrDl -mulrBl opprD addrA addrK opprK. + rewrite addrAC addrA [a + _ + _]addrAC subrr add0r. + by rewrite !mulrDl -![_ + _](splitf 2). +have hp: p.[c - r] * p.[c + r] <= 0 by rewrite !hab. +pose x := AlgDom monic_p r_ge0 hp; exists (\pi_alg (to_algcreal x)). + rewrite !piE; apply/andP; rewrite -!(rwP le_algP) /=. + split; + by do [ unlock to_algcreal=> /=; apply: (@le_crealP _ 0%N)=> /= j _; + have := @to_algcreal_ofP p c r 0%N j r_ge0 isT; + rewrite ler_distl /= expr0 divr1 !hab=> /andP []]. +apply/rootP; rewrite horner_pi zeroE -equiv_alg horner_algcrealE /=. +by rewrite -(@to_algcrealP x); unlock to_algcreal. +Qed. + +(* any sequence of algebraic can be expressed as a sequence of +polynomials in a unique algebraic *) +Lemma pet_alg_proof (s : seq alg) : + { ap : {alg F} * seq {poly F} | + [forall i : 'I_(size s), (ap.2`_i ^ to_alg).[ap.1] == s`_i] + & size ap.2 = size s }. +Proof. +apply: sig2_eqW; elim: s; first by exists (0,[::])=> //; apply/forallP=> [] []. +move=> x s [[a sp] /forallP /= hs hsize]. +have:= char0_PET _ (root_annul_alg a) _ (root_annul_alg x). +rewrite !annul_alg_neq0 => /(_ isT isT (char_num _)) /= [n [[p hp] [q hq]]]. +exists (x *+ n - a, q :: [seq r \Po p | r <- sp]); last first. + by rewrite /= size_map hsize. +apply/forallP=> /=; rewrite -add1n=> i; apply/eqP. +have [k->|l->] := splitP i; first by rewrite !ord1. +rewrite add1n /= (nth_map 0) ?hsize // map_comp_poly /=. +by rewrite horner_comp hp; apply/eqP. +Qed. + +(****************************************************************************) +(* Given a sequence s of algebraics (seq {alg F}) *) +(* pet_alg == primitive algebraic *) +(* pet_alg_poly == sequence of polynomials such that when instanciated in *) +(* pet_alg gives back the sequence s (cf. pet_algK) *) +(* *) +(* Given a polynomial p on algebraic {poly {alg F}} *) +(* pet_ground == bivariate polynomial such that when the inner *) +(* variable ('Y) is instanciated in pet_alg gives back *) +(* the polynomial p. *) +(****************************************************************************) + +Definition pet_alg s : {alg F} := + let: exist2 (a, _) _ _ := pet_alg_proof s in a. +Definition pet_alg_poly s : seq {poly F}:= + let: exist2 (_, sp) _ _ := pet_alg_proof s in sp. + +Lemma size_pet_alg_poly s : size (pet_alg_poly s) = size s. +Proof. by unlock pet_alg_poly; case: pet_alg_proof. Qed. + +Lemma pet_algK s i : + ((pet_alg_poly s)`_i ^ to_alg).[pet_alg s] = s`_i. +Proof. +rewrite /pet_alg /pet_alg_poly; case: pet_alg_proof. +move=> [a sp] /= /forallP hs hsize; have [lt_is|le_si] := ltnP i (size s). + by rewrite -[i]/(val (Ordinal lt_is)); apply/eqP; apply: hs. +by rewrite !nth_default ?hsize // rmorph0 horner0. +Qed. + +Definition poly_ground := locked (fun (p : {poly {alg F}}) => + swapXY (Poly (pet_alg_poly p)) : {poly {poly F}}). + +Lemma sizeY_poly_ground p : sizeY (poly_ground p) = size p. +Proof. +unlock poly_ground; rewrite sizeYE swapXYK; have [->|p_neq0] := eqVneq p 0. + apply/eqP; rewrite size_poly0 eqn_leq leq0n (leq_trans (size_Poly _)) //. + by rewrite size_pet_alg_poly size_poly0. +rewrite (@PolyK _ 0) -?nth_last ?size_pet_alg_poly //. +have /eqP := (pet_algK p (size p).-1); apply: contraL=> /eqP->. +by rewrite rmorph0 horner0 -lead_coefE eq_sym lead_coef_eq0. +Qed. + +Lemma poly_ground_eq0 p : (poly_ground p == 0) = (p == 0). +Proof. by rewrite -sizeY_eq0 sizeY_poly_ground size_poly_eq0. Qed. + +Lemma poly_ground0 : poly_ground 0 = 0. +Proof. by apply/eqP; rewrite poly_ground_eq0. Qed. + +Lemma poly_groundK p : + ((poly_ground p) ^ (map_poly to_alg)).[(pet_alg p)%:P] = p. +Proof. +have [->|p_neq0] := eqVneq p 0; first by rewrite poly_ground0 rmorph0 horner0. +unlock poly_ground; rewrite horner_polyC /eval /= swapXY_map swapXYK. +apply/polyP=> i /=; rewrite coef_map_id0 ?horner0 // coef_map /=. +by rewrite coef_Poly pet_algK. +Qed. + +Lemma annul_from_alg_proof (p : {poly alg}) (q : {poly F}) : + p != 0 -> q != 0 -> root (q ^ to_alg) (pet_alg p) + -> {r | resultant (poly_ground p) (r ^ polyC) != 0 + & (r != 0) && (root (r ^ to_alg) (pet_alg p))}. +Proof. +move=> p_neq0; elim: (size q) {-2}q (leqnn (size q))=> {q} [|n ihn] q. + by rewrite size_poly_leq0=> ->. +move=> size_q q_neq0 hq; apply/sig2_eqW. +have [|apq_neq0] := + eqVneq (resultant (poly_ground p) (q ^ polyC)) 0; last first. + by exists q=> //; rewrite q_neq0. +move/eqP; rewrite resultant_eq0 ltn_neqAle eq_sym -coprimep_def. +move=> /andP[] /(Bezout_coprimepPn _ _) []. ++ by rewrite poly_ground_eq0. ++ by rewrite map_polyC_eq0. +move=> [u v] /and3P [] /andP [u_neq0 ltn_uq] v_neq0 ltn_vp hpq. +rewrite ?size_map_polyC in ltn_uq ltn_vp. +rewrite ?size_poly_gt0 in u_neq0 v_neq0. +pose a := pet_alg p. +have := erefl (size ((u * poly_ground p) ^ (map_poly to_alg)).[a%:P]). +rewrite {2}hpq !{1}rmorphM /= !{1}hornerM poly_groundK -map_poly_comp /=. +have /eq_map_poly-> : (map_poly to_alg) \o polyC =1 polyC \o to_alg. + by move=> r /=; rewrite map_polyC. +rewrite map_poly_comp horner_map (rootP hq) mulr0 size_poly0. +move/eqP; rewrite size_poly_eq0 mulf_eq0 (negPf p_neq0) orbF. +pose u' : {poly F} := lead_coef (swapXY u). +have [/rootP u'a_eq0|u'a_neq0] := eqVneq (u' ^ to_alg).[a] 0; last first. + rewrite horner_polyC -lead_coef_eq0 lead_coef_map_eq /=; + by do ?rewrite swapXY_map /= lead_coef_map_eq /= + ?map_poly_eq0 ?lead_coef_eq0 ?swapXY_eq0 ?(negPf u'a_neq0). +have u'_neq0 : u' != 0 by rewrite lead_coef_eq0 swapXY_eq0. +have size_u' : (size u' < size q)%N. + by rewrite /u' (leq_ltn_trans (max_size_lead_coefXY _)) // sizeYE swapXYK. +move: u'a_eq0=> /ihn [] //; first by rewrite -ltnS (leq_trans size_u'). +by move=> r; exists r. +Qed. + +Definition annul_pet_alg (p : {poly {alg F}}) : {poly F} := + if (p != 0) =P true is ReflectT p_neq0 then + let: exist2 r _ _ := + annul_from_alg_proof p_neq0 (annul_alg_neq0 _) (root_annul_alg _) in r + else 0. + +Lemma root_annul_pet_alg p : root (annul_pet_alg p ^ to_alg) (pet_alg p). +Proof. +rewrite /annul_pet_alg; case: eqP=> /=; last by rewrite ?rmorph0 ?root0. +by move=> p_neq0; case: annul_from_alg_proof=> ? ? /andP[]. +Qed. + +Definition annul_from_alg p := + if (size (poly_ground p) == 1)%N then lead_coef (poly_ground p) + else resultant (poly_ground p) (annul_pet_alg p ^ polyC). + +Lemma annul_from_alg_neq0 p : p != 0 -> annul_from_alg p != 0. +Proof. +move=> p_neq0; rewrite /annul_from_alg. +case: ifP; first by rewrite lead_coef_eq0 poly_ground_eq0. +rewrite /annul_pet_alg; case: eqP p_neq0=> //= p_neq0 _. +by case: annul_from_alg_proof. +Qed. + +Lemma annul_pet_alg_neq0 p : p != 0 -> annul_pet_alg p != 0. +Proof. +rewrite /annul_pet_alg; case: eqP=> /=; last by rewrite ?rmorph0 ?root0. +by move=> p_neq0; case: annul_from_alg_proof=> ? ? /andP[]. +Qed. + +End RealAlg. + +Notation to_alg F := (@to_alg_def _ (Phant F)). +Notation "x %:RA" := (to_alg _ x) + (at level 2, left associativity, format "x %:RA"). + +Lemma upper_nthrootVP (F : archiFieldType) (x : F) (i : nat) : + 0 < x -> (Num.bound (x ^-1) <= i)%N -> 2%:R ^- i < x. +Proof. +move=> x_gt0 hx; rewrite -ltf_pinv -?topredE //= ?gtr0E //. +by rewrite invrK upper_nthrootP. +Qed. + +Notation "{ 'alg' F }" := (alg_of (Phant F)). + +Section AlgAlg. + +Variable F : archiFieldType. + +Local Open Scope ring_scope. + +Local Notation "p ^ f" := (map_poly f p) : ring_scope. +Local Notation "'Y" := 'X%:P. +Local Notation m0 := (fun _ => 0%N). + +Definition approx2 (x : {alg {alg F}}) i := + approx (approx x (2%:R ^- i)) (2%:R ^- i). + +Lemma asympt_approx2 x : { asympt e : i / `|(approx2 x i)%:RA%:RA - x| < e }. +Proof. +exists_big_modulus m {alg {alg F}}. + move=> e i e_gt0 hi; rewrite distrC /approx2. + rewrite (@split_dist_add _ (approx x (2%:R ^- i))%:RA) //. + rewrite approxP ?gtr0E // ltrW //. + by rewrite upper_nthrootVP ?divrn_gt0 ?ltr_to_alg. + rewrite (ltr_trans _ (inf_lt_alg _)) ?divrn_gt0 //. + rewrite -rmorphB -normr_to_alg ltr_to_alg approxP ?gtr0E // ltrW //. + by rewrite upper_nthrootVP ?divrn_gt0 ?inf_alg_gt0 ?ltr_to_alg. +by close. +Qed. + +Lemma from_alg_crealP (x : {alg {alg F}}) : creal_axiom (approx2 x). +Proof. +exists_big_modulus m F. + move=> e i j e_gt0 hi hj; rewrite -2!ltr_to_alg !normr_to_alg !rmorphB /=. + rewrite (@split_dist_add _ x) // ?[`|_ - _%:RA|]distrC; + by rewrite (@asympt1modP _ _ (asympt_approx2 x)) ?divrn_gt0 ?ltr_to_alg. +by close. +Qed. + +Definition from_alg_creal := locked (fun x => CReal (from_alg_crealP x)). + +Lemma to_alg_crealP (x : creal F) : creal_axiom (fun i => to_alg F (x i)). +Proof. +exists_big_modulus m (alg F). + move=> e i j e_gt0 hi hj. + rewrite -rmorphB -normr_to_alg (ltr_trans _ (inf_lt_alg _)) //. + by rewrite ltr_to_alg cauchymodP ?inf_alg_gt0. +by close. +Qed. +Definition to_alg_creal x := CReal (to_alg_crealP x). + +Lemma horner_to_alg_creal p x : + ((p ^ to_alg F).[to_alg_creal x] == to_alg_creal p.[x])%CR. +Proof. +by apply: eq_crealP; exists m0=> * /=; rewrite horner_map subrr normr0. +Qed. + +Lemma neq_to_alg_creal x y : + (to_alg_creal x != to_alg_creal y)%CR <-> (x != y)%CR. +Proof. +split=> neq_xy. + pose_big_enough i. + apply: (@neq_crealP _ (inf_alg (lbound neq_xy)) i i) => //. + by rewrite inf_alg_gt0. + rewrite -ler_to_alg normr_to_alg rmorphB /= ltrW //. + by rewrite (ltr_le_trans (inf_lt_alg _)) ?lbound_gt0 ?lboundP. + by close. +pose_big_enough i. + apply: (@neq_crealP _ (lbound neq_xy)%:RA i i) => //. + by rewrite ltr_to_alg lbound_gt0. + by rewrite -rmorphB -normr_to_alg ler_to_alg lboundP. +by close. +Qed. + +Lemma eq_to_alg_creal x y : + (to_alg_creal x == to_alg_creal y)%CR -> (x == y)%CR. +Proof. by move=> hxy /neq_to_alg_creal. Qed. + +Lemma to_alg_creal0 : (to_alg_creal 0 == 0)%CR. +Proof. by apply: eq_crealP; exists m0=> * /=; rewrite subrr normr0. Qed. + +Import Setoid. + +Add Morphism to_alg_creal + with signature (@eq_creal _) ==> (@eq_creal _) as to_alg_creal_morph. +Proof. by move=> x y hxy /neq_to_alg_creal. Qed. +Global Existing Instance to_alg_creal_morph_Proper. + +Lemma to_alg_creal_repr (x : {alg F}) : (to_alg_creal (repr x) == x%:CR)%CR. +Proof. +apply: eq_crealP; exists_big_modulus m {alg F}. + move=> e i e_gt0 hi /=; rewrite (ler_lt_trans _ (inf_lt_alg _)) //. + rewrite -{2}[x]reprK !piE sub_pi norm_pi. + rewrite -(rwP (le_algP _ _)) norm_algcrealE /=; pose_big_enough j. + apply: (@le_crealP _ j)=> k hk /=. + by rewrite ltrW // cauchymodP ?inf_alg_gt0. + by close. +by close. +Qed. + +Local Open Scope quotient_scope. + +Lemma cst_pi (x : algcreal F) : ((\pi_{alg F} x)%:CR == to_alg_creal x)%CR. +Proof. +apply: eq_crealP; exists_big_modulus m {alg F}. + move=> e i e_gt0 hi /=; rewrite (ltr_trans _ (inf_lt_alg _)) //. + rewrite !piE sub_pi norm_pi /= -(rwP (lt_algP _ _)) norm_algcrealE /=. + pose_big_enough j. + apply: (@lt_crealP _ (inf_alg e / 2%:R) j j) => //. + by rewrite ?divrn_gt0 ?inf_alg_gt0. + rewrite /= {2}[inf_alg _](splitf 2) ler_add2r ltrW // distrC. + by rewrite cauchymodP ?divrn_gt0 ?inf_alg_gt0. + by close. +by close. +Qed. + +End AlgAlg. + +Section AlgAlgAlg. + +Variable F : archiFieldType. + +Local Open Scope ring_scope. + +Local Notation "p ^ f" := (map_poly f p) : ring_scope. +Local Notation "'Y" := 'X%:P. + +Lemma from_alg_crealK (x : {alg {alg F}}) : + (to_alg_creal (to_alg_creal (from_alg_creal x)) == x%:CR)%CR. +Proof. +apply: eq_crealP; exists_big_modulus m {alg {alg F}}. + move=> e i e_gt0 hi; unlock from_alg_creal=> /=. + by rewrite (@asympt1modP _ _ (asympt_approx2 x)). +by close. +Qed. + +Lemma root_annul_from_alg_creal (x : {alg {alg F}}) : + ((annul_from_alg (annul_alg x)).[from_alg_creal x] == 0)%CR. +Proof. +do 2!apply: eq_to_alg_creal. +rewrite -!horner_to_alg_creal from_alg_crealK !to_alg_creal0. +rewrite horner_creal_cst; apply/eq_creal_cst; rewrite -rootE. +rewrite /annul_from_alg; have [/size_poly1P [c c_neq0 hc]|sp_neq1] := boolP (_ == _). + set p := _ ^ _; suff ->: p = (annul_alg x) ^ to_alg _ by apply: root_annul_alg. + congr (_ ^ _); rewrite -{2}[annul_alg x]poly_groundK /=. + by rewrite !hc lead_coefC map_polyC /= hornerC. +have [||[u v] /= [hu hv] hpq] := @resultant_in_ideal _ + (poly_ground (annul_alg x)) (annul_pet_alg (annul_alg x) ^ polyC). ++ rewrite ltn_neqAle eq_sym sp_neq1 //= lt0n size_poly_eq0. + by rewrite poly_ground_eq0 annul_alg_neq0. ++ rewrite size_map_polyC -(size_map_poly [rmorphism of to_alg _]) /=. + rewrite (root_size_gt1 _ (root_annul_pet_alg _)) //. + by rewrite map_poly_eq0 annul_pet_alg_neq0 ?annul_alg_neq0. +move: hpq=> /(f_equal (map_poly (map_poly (to_alg _)))). +rewrite map_polyC /= => /(f_equal (eval (pet_alg (annul_alg x))%:P)). +rewrite {1}/eval hornerC !rmorphD !{1}rmorphM /= /eval /= => ->. +rewrite -map_poly_comp /=. +have /eq_map_poly->: (map_poly (@to_alg F)) \o polyC =1 polyC \o (@to_alg F). + by move=> r /=; rewrite map_polyC. +rewrite map_poly_comp horner_map /= (rootP (root_annul_pet_alg _)) mulr0 addr0. +by rewrite rmorphM /= rootM orbC poly_groundK root_annul_alg. +Qed. + +Lemma annul_alg_from_alg_creal_neq0 (x : {alg {alg F}}) : + annul_from_alg (annul_alg x) != 0. +Proof. by rewrite annul_from_alg_neq0 ?annul_alg_neq0. Qed. + +Definition from_alg_algcreal x := + AlgCRealOf (@annul_alg_from_alg_creal_neq0 x) (@root_annul_from_alg_creal x). + +Definition from_alg : {alg {alg F}} -> {alg F} := + locked (\pi%qT \o from_alg_algcreal). + +Lemma from_algK : cancel from_alg (to_alg _). +Proof. +move=> x; unlock from_alg; rewrite -{2}[x]reprK piE -equiv_alg /= cst_pi. +by apply: eq_to_alg_creal; rewrite from_alg_crealK to_alg_creal_repr. +Qed. + +Lemma ivt (p : {poly (alg F)}) (a b : alg F) : a <= b -> + p.[a] <= 0 <= p.[b] -> exists2 x : alg F, a <= x <= b & root p x. +Proof. +move=> le_ab hp; have [x /andP [hax hxb]] := @weak_ivt _ _ _ _ le_ab hp. +rewrite -[x]from_algK fmorph_root=> rpx; exists (from_alg x)=> //. +by rewrite -ler_to_alg from_algK hax -ler_to_alg from_algK. +Qed. + +Canonical alg_rcfType := RcfType (alg F) ivt. +Canonical alg_of_rcfType := [rcfType of {alg F}]. + +End AlgAlgAlg. +End RealAlg. + +Notation "{ 'realclosure' F }" := (RealAlg.alg_of (Phant F)). + +Notation annul_realalg := RealAlg.annul_alg. +Notation realalg_of F := (@RealAlg.to_alg_def _ (Phant F)). +Notation "x %:RA" := (realalg_of x) + (at level 2, left associativity, format "x %:RA"). + +Canonical RealAlg.alg_eqType. +Canonical RealAlg.alg_choiceType. +Canonical RealAlg.alg_zmodType. +Canonical RealAlg.alg_Ring. +Canonical RealAlg.alg_comRing. +Canonical RealAlg.alg_unitRing. +Canonical RealAlg.alg_comUnitRing. +Canonical RealAlg.alg_iDomain. +Canonical RealAlg.alg_fieldType. +Canonical RealAlg.alg_numDomainType. +Canonical RealAlg.alg_numFieldType. +Canonical RealAlg.alg_realDomainType. +Canonical RealAlg.alg_realFieldType. +Canonical RealAlg.alg_archiFieldType. +Canonical RealAlg.alg_rcfType. + +Canonical RealAlg.alg_of_eqType. +Canonical RealAlg.alg_of_choiceType. +Canonical RealAlg.alg_of_zmodType. +Canonical RealAlg.alg_of_Ring. +Canonical RealAlg.alg_of_comRing. +Canonical RealAlg.alg_of_unitRing. +Canonical RealAlg.alg_of_comUnitRing. +Canonical RealAlg.alg_of_iDomain. +Canonical RealAlg.alg_of_fieldType. +Canonical RealAlg.alg_of_numDomainType. +Canonical RealAlg.alg_of_numFieldType. +Canonical RealAlg.alg_of_realDomainType. +Canonical RealAlg.alg_of_realFieldType. +Canonical RealAlg.alg_of_archiFieldType. +Canonical RealAlg.alg_of_rcfType. + +Canonical RealAlg.to_alg_is_rmorphism. +Canonical RealAlg.to_alg_is_additive. + +Section RealClosureTheory. + +Variable F : archiFieldType. +Notation R := {realclosure F}. + +Local Notation "p ^ f" := (map_poly f p) : ring_scope. + +Lemma root_annul_realalg (x : R) : root ((annul_realalg x) ^ realalg_of _) x. +Proof. exact: RealAlg.root_annul_alg. Qed. +Hint Resolve root_annul_realalg. + +Lemma monic_annul_realalg (x : R) : annul_realalg x \is monic. +Proof. exact: RealAlg.monic_annul_alg. Qed. +Hint Resolve monic_annul_realalg. + +Lemma annul_realalg_neq0 (x : R) : annul_realalg x != 0%R. +Proof. exact: RealAlg.annul_alg_neq0. Qed. +Hint Resolve annul_realalg_neq0. + +Lemma realalg_algebraic : integralRange (realalg_of F). +Proof. by move=> x; exists (annul_realalg x). Qed. + +End RealClosureTheory. + +Definition realalg := {realclosure rat}. +Canonical realalg_eqType := [eqType of realalg]. +Canonical realalg_choiceType := [choiceType of realalg]. +Canonical realalg_zmodType := [zmodType of realalg]. +Canonical realalg_ringType := [ringType of realalg]. +Canonical realalg_comRingType := [comRingType of realalg]. +Canonical realalg_unitRingType := [unitRingType of realalg]. +Canonical realalg_comUnitRingType := [comUnitRingType of realalg]. +Canonical realalg_idomainType := [idomainType of realalg]. +Canonical realalg_fieldTypeType := [fieldType of realalg]. +Canonical realalg_numDomainType := [numDomainType of realalg]. +Canonical realalg_numFieldType := [numFieldType of realalg]. +Canonical realalg_realDomainType := [realDomainType of realalg]. +Canonical realalg_realFieldType := [realFieldType of realalg]. +Canonical realalg_archiFieldType := [archiFieldType of realalg]. +Canonical realalg_rcfType := [rcfType of realalg]. + +Module RatRealAlg. +Canonical RealAlg.algdom_choiceType. +Definition realalgdom_CountMixin := + PcanCountMixin (@RealAlg.encode_algdomK [archiFieldType of rat]). +Canonical realalgdom_countType := + CountType (RealAlg.algdom [archiFieldType of rat]) realalgdom_CountMixin. +Definition realalg_countType := [countType of realalg]. +End RatRealAlg. + +Canonical RatRealAlg.realalg_countType. + +(* Require Import countalg. *) +(* Canonical realalg_countZmodType := [countZmodType of realalg]. *) +(* Canonical realalg_countRingType := [countRingType of realalg]. *) +(* Canonical realalg_countComRingType := [countComRingType of realalg]. *) +(* Canonical realalg_countUnitRingType := [countUnitRingType of realalg]. *) +(* Canonical realalg_countComUnitRingType := [countComUnitRingType of realalg]. *) +(* Canonical realalg_countIdomainType := [countIdomainType of realalg]. *) +(* Canonical realalg_countFieldTypeType := [countFieldType of realalg]. *) diff --git a/mathcomp/solvable/abelian.v b/mathcomp/solvable/abelian.v new file mode 100644 index 0000000..8c412dc --- /dev/null +++ b/mathcomp/solvable/abelian.v @@ -0,0 +1,2161 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div fintype. +Require Import finfun bigop finset prime binomial fingroup morphism perm. +Require Import automorphism action quotient gfunctor gproduct zmodp cyclic. +Require Import pgroup gseries nilpotent sylow. + +(******************************************************************************) +(* Constructions based on abelian groups and their structure, with some *) +(* emphasis on elementary abelian p-groups. *) +(* 'Ldiv_n() == the set of all x that satisfy x ^+ n = 1, or, *) +(* equivalently the set of x whose order divides n. *) +(* 'Ldiv_n(G) == the set of x in G that satisfy x ^+ n = 1. *) +(* := G :&: 'Ldiv_n() (pure Notation) *) +(* exponent G == the exponent of G: the least e such that x ^+ e = 1 *) +(* for all x in G (the LCM of the orders of x \in G). *) +(* If G is nilpotent its exponent is reached. Note that *) +(* `exponent G %| m' reads as `G has exponent m'. *) +(* 'm(G) == the generator rank of G: the size of a smallest *) +(* generating set for G (this is a basis for G if G *) +(* abelian). *) +(* abelian_type G == the abelian type of G : if G is abelian, a lexico- *) +(* graphically maximal sequence of the orders of the *) +(* elements of a minimal basis of G (if G is a p-group *) +(* this is the sequence of orders for any basis of G, *) +(* sorted in decending order). *) +(* homocyclic G == G is the direct product of cycles of equal order, *) +(* i.e., G is abelian with constant abelian type. *) +(* p.-abelem G == G is an elementary abelian p-group, i.e., it is *) +(* an abelian p-group of exponent p, and thus of order *) +(* p ^ 'm(G) and rank (logn p #|G|). *) +(* is_abelem G == G is an elementary abelian p-group for some prime p. *) +(* 'E_p(G) == the set of elementary abelian p-subgroups of G. *) +(* := [set E : {group _} | p.-abelem E & E \subset G] *) +(* 'E_p^n(G) == the set of elementary abelian p-subgroups of G of *) +(* order p ^ n (or, equivalently, of rank n). *) +(* := [set E in 'E_p(G) | logn p #|E| == n] *) +(* := [set E in 'E_p(G) | #|E| == p ^ n]%N if p is prime *) +(* 'E*_p(G) == the set of maximal elementary abelian p-subgroups *) +(* of G. *) +(* := [set E | [max E | E \in 'E_p(G)]] *) +(* 'E^n(G) == the set of elementary abelian subgroups of G that *) +(* have gerank n (i.e., p-rank n for some prime p). *) +(* := \bigcup_(0 <= p < #|G|.+1) 'E_p^n(G) *) +(* 'r_p(G) == the p-rank of G: the maximal rank of an elementary *) +(* subgroup of G. *) +(* := \max_(E in 'E_p(G)) logn p #|E|. *) +(* 'r(G) == the rank of G. *) +(* := \max_(0 <= p < #|G|.+1) 'm_p(G). *) +(* Note that 'r(G) coincides with 'r_p(G) if G is a p-group, and with 'm(G) *) +(* if G is abelian, but is much more useful than 'm(G) in the proof of the *) +(* Odd Order Theorem. *) +(* 'Ohm_n(G) == the group generated by the x in G with order p ^ m *) +(* for some prime p and some m <= n. Usually, G will be *) +(* a p-group, so 'Ohm_n(G) will be generated by *) +(* 'Ldiv_(p ^ n)(G), set of elements of G of order at *) +(* most p ^ n. If G is also abelian then 'Ohm_n(G) *) +(* consists exactly of those element, and the abelian *) +(* type of G can be computed from the orders of the *) +(* 'Ohm_n(G) subgroups. *) +(* 'Mho^n(G) == the group generated by the x ^+ (p ^ n) for x a *) +(* p-element of G for some prime p. Usually G is a *) +(* p-group, and 'Mho^n(G) is generated by all such *) +(* x ^+ (p ^ n); it consists of exactly these if G is *) +(* also abelian. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section AbelianDefs. + +(* We defer the definition of the functors ('Omh_n(G), 'Mho^n(G)) because *) +(* they must quantify over the finGroupType explicitly. *) + +Variable gT : finGroupType. +Implicit Types (x : gT) (A B : {set gT}) (pi : nat_pred) (p n : nat). + +Definition Ldiv n := [set x : gT | x ^+ n == 1]. + +Definition exponent A := \big[lcmn/1%N]_(x in A) #[x]. + +Definition abelem p A := [&& p.-group A, abelian A & exponent A %| p]. + +Definition is_abelem A := abelem (pdiv #|A|) A. + +Definition pElem p A := [set E : {group gT} | E \subset A & abelem p E]. + +Definition pnElem p n A := [set E in pElem p A | logn p #|E| == n]. + +Definition nElem n A := \bigcup_(0 <= p < #|A|.+1) pnElem p n A. + +Definition pmaxElem p A := [set E | [max E | E \in pElem p A]]. + +Definition p_rank p A := \max_(E in pElem p A) logn p #|E|. + +Definition rank A := \max_(0 <= p < #|A|.+1) p_rank p A. + +Definition gen_rank A := #|[arg min_(B < A | <> == A) #|B|]|. + +(* The definition of abelian_type depends on an existence lemma. *) +(* The definition of homocyclic depends on abelian_type. *) + +End AbelianDefs. + +Arguments Scope exponent [_ group_scope]. +Arguments Scope abelem [_ nat_scope group_scope]. +Arguments Scope is_abelem [_ group_scope]. +Arguments Scope pElem [_ nat_scope group_scope]. +Arguments Scope pnElem [_ nat_scope nat_scope group_scope]. +Arguments Scope nElem [_ nat_scope group_scope]. +Arguments Scope pmaxElem [_ nat_scope group_scope]. +Arguments Scope p_rank [_ nat_scope group_scope]. +Arguments Scope rank [_ group_scope]. +Arguments Scope gen_rank [_ group_scope]. + +Notation "''Ldiv_' n ()" := (Ldiv _ n) + (at level 8, n at level 2, format "''Ldiv_' n ()") : group_scope. + +Notation "''Ldiv_' n ( G )" := (G :&: 'Ldiv_n()) + (at level 8, n at level 2, format "''Ldiv_' n ( G )") : group_scope. + +Prenex Implicits exponent. + +Notation "p .-abelem" := (abelem p) + (at level 2, format "p .-abelem") : group_scope. + +Notation "''E_' p ( G )" := (pElem p G) + (at level 8, p at level 2, format "''E_' p ( G )") : group_scope. + +Notation "''E_' p ^ n ( G )" := (pnElem p n G) + (at level 8, p, n at level 2, format "''E_' p ^ n ( G )") : group_scope. + +Notation "''E' ^ n ( G )" := (nElem n G) + (at level 8, n at level 2, format "''E' ^ n ( G )") : group_scope. + +Notation "''E*_' p ( G )" := (pmaxElem p G) + (at level 8, p at level 2, format "''E*_' p ( G )") : group_scope. + +Notation "''m' ( A )" := (gen_rank A) + (at level 8, format "''m' ( A )") : group_scope. + +Notation "''r' ( A )" := (rank A) + (at level 8, format "''r' ( A )") : group_scope. + +Notation "''r_' p ( A )" := (p_rank p A) + (at level 8, p at level 2, format "''r_' p ( A )") : group_scope. + +Section Functors. + +(* A functor needs to quantify over the finGroupType just beore the set. *) + +Variables (n : nat) (gT : finGroupType) (A : {set gT}). + +Definition Ohm := <<[set x in A | x ^+ (pdiv #[x] ^ n) == 1]>>. + +Definition Mho := <<[set x ^+ (pdiv #[x] ^ n) | x in A & (pdiv #[x]).-elt x]>>. + +Canonical Ohm_group : {group gT} := Eval hnf in [group of Ohm]. +Canonical Mho_group : {group gT} := Eval hnf in [group of Mho]. + +Lemma pdiv_p_elt (p : nat) (x : gT) : p.-elt x -> x != 1 -> pdiv #[x] = p. +Proof. +move=> p_x; rewrite /order -cycle_eq1. +by case/(pgroup_pdiv p_x)=> p_pr _ [k ->]; rewrite pdiv_pfactor. +Qed. + +Lemma OhmPredP (x : gT) : + reflect (exists2 p, prime p & x ^+ (p ^ n) = 1) (x ^+ (pdiv #[x] ^ n) == 1). +Proof. +have [-> | nt_x] := eqVneq x 1. + by rewrite expg1n eqxx; left; exists 2; rewrite ?expg1n. +apply: (iffP idP) => [/eqP | [p p_pr /eqP x_pn]]. + by exists (pdiv #[x]); rewrite ?pdiv_prime ?order_gt1. +rewrite (@pdiv_p_elt p) //; rewrite -order_dvdn in x_pn. +by rewrite [p_elt _ _](pnat_dvd x_pn) // pnat_exp pnat_id. +Qed. + +Lemma Mho_p_elt (p : nat) x : x \in A -> p.-elt x -> x ^+ (p ^ n) \in Mho. +Proof. +move=> Ax p_x; case: (eqVneq x 1) => [-> | ntx]; first by rewrite groupX. +by apply: mem_gen; apply/imsetP; exists x; rewrite ?inE ?Ax (pdiv_p_elt p_x). +Qed. + +End Functors. + +Arguments Scope Ohm [nat_scope _ group_scope]. +Arguments Scope Ohm_group [nat_scope _ group_scope]. +Arguments Scope Mho [nat_scope _ group_scope]. +Arguments Scope Mho_group [nat_scope _ group_scope]. +Implicit Arguments OhmPredP [n gT x]. + +Notation "''Ohm_' n ( G )" := (Ohm n G) + (at level 8, n at level 2, format "''Ohm_' n ( G )") : group_scope. +Notation "''Ohm_' n ( G )" := (Ohm_group n G) : Group_scope. + +Notation "''Mho^' n ( G )" := (Mho n G) + (at level 8, n at level 2, format "''Mho^' n ( G )") : group_scope. +Notation "''Mho^' n ( G )" := (Mho_group n G) : Group_scope. + +Section ExponentAbelem. + +Variable gT : finGroupType. +Implicit Types (p n : nat) (pi : nat_pred) (x : gT) (A B C : {set gT}). +Implicit Types E G H K P X Y : {group gT}. + +Lemma LdivP A n x : reflect (x \in A /\ x ^+ n = 1) (x \in 'Ldiv_n(A)). +Proof. by rewrite !inE; apply: (iffP andP) => [] [-> /eqP]. Qed. + +Lemma dvdn_exponent x A : x \in A -> #[x] %| exponent A. +Proof. by move=> Ax; rewrite (biglcmn_sup x). Qed. + +Lemma expg_exponent x A : x \in A -> x ^+ exponent A = 1. +Proof. by move=> Ax; apply/eqP; rewrite -order_dvdn dvdn_exponent. Qed. + +Lemma exponentS A B : A \subset B -> exponent A %| exponent B. +Proof. +by move=> sAB; apply/dvdn_biglcmP=> x Ax; rewrite dvdn_exponent ?(subsetP sAB). +Qed. + +Lemma exponentP A n : + reflect (forall x, x \in A -> x ^+ n = 1) (exponent A %| n). +Proof. +apply: (iffP (dvdn_biglcmP _ _ _)) => eAn x Ax. + by apply/eqP; rewrite -order_dvdn eAn. +by rewrite order_dvdn eAn. +Qed. +Implicit Arguments exponentP [A n]. + +Lemma trivg_exponent G : (G :==: 1) = (exponent G %| 1). +Proof. +rewrite -subG1. +by apply/subsetP/exponentP=> trG x /trG; rewrite expg1 => /set1P. +Qed. + +Lemma exponent1 : exponent [1 gT] = 1%N. +Proof. by apply/eqP; rewrite -dvdn1 -trivg_exponent eqxx. Qed. + +Lemma exponent_dvdn G : exponent G %| #|G|. +Proof. by apply/dvdn_biglcmP=> x Gx; exact: order_dvdG. Qed. + +Lemma exponent_gt0 G : 0 < exponent G. +Proof. exact: dvdn_gt0 (exponent_dvdn G). Qed. +Hint Resolve exponent_gt0. + +Lemma pnat_exponent pi G : pi.-nat (exponent G) = pi.-group G. +Proof. +congr (_ && _); first by rewrite cardG_gt0 exponent_gt0. +apply: eq_all_r => p; rewrite !mem_primes cardG_gt0 exponent_gt0 /=. +apply: andb_id2l => p_pr; apply/idP/idP=> pG. + exact: dvdn_trans pG (exponent_dvdn G). +by case/Cauchy: pG => // x Gx <-; exact: dvdn_exponent. +Qed. + +Lemma exponentJ A x : exponent (A :^ x) = exponent A. +Proof. +rewrite /exponent (reindex_inj (conjg_inj x)). +by apply: eq_big => [y | y _]; rewrite ?orderJ ?memJ_conjg. +Qed. + +Lemma exponent_witness G : nilpotent G -> {x | x \in G & exponent G = #[x]}. +Proof. +move=> nilG; have [//=| /= x Gx max_x] := @arg_maxP _ 1 (mem G) order. +exists x => //; apply/eqP; rewrite eqn_dvd dvdn_exponent // andbT. +apply/dvdn_biglcmP=> y Gy; apply/dvdn_partP=> //= p. +rewrite mem_primes => /andP[p_pr _]; have p_gt1: p > 1 := prime_gt1 p_pr. +rewrite p_part pfactor_dvdn // -(leq_exp2l _ _ p_gt1) -!p_part. +rewrite -(leq_pmul2r (part_gt0 p^' #[x])) partnC // -!order_constt. +rewrite -orderM ?order_constt ?coprime_partC // ?max_x ?groupM ?groupX //. +case/dprodP: (nilpotent_pcoreC p nilG) => _ _ cGpGp' _. +have inGp := mem_normal_Hall (nilpotent_pcore_Hall _ nilG) (pcore_normal _ _). +by red; rewrite -(centsP cGpGp') // inGp ?p_elt_constt ?groupX. +Qed. + +Lemma exponent_cycle x : exponent <[x]> = #[x]. +Proof. by apply/eqP; rewrite eqn_dvd exponent_dvdn dvdn_exponent ?cycle_id. Qed. + +Lemma exponent_cyclic X : cyclic X -> exponent X = #|X|. +Proof. by case/cyclicP=> x ->; exact: exponent_cycle. Qed. + +Lemma primes_exponent G : primes (exponent G) = primes (#|G|). +Proof. +apply/eq_primes => p; rewrite !mem_primes exponent_gt0 cardG_gt0 /=. +by apply: andb_id2l => p_pr; apply: negb_inj; rewrite -!p'natE // pnat_exponent. +Qed. + +Lemma pi_of_exponent G : \pi(exponent G) = \pi(G). +Proof. by rewrite /pi_of primes_exponent. Qed. + +Lemma partn_exponentS pi H G : + H \subset G -> #|G|`_pi %| #|H| -> (exponent H)`_pi = (exponent G)`_pi. +Proof. +move=> sHG Gpi_dvd_H; apply/eqP; rewrite eqn_dvd. +rewrite partn_dvd ?exponentS ?exponent_gt0 //=; apply/dvdn_partP=> // p. +rewrite pi_of_part ?exponent_gt0 // => /andP[_ /= pi_p]. +have sppi: {subset (p : nat_pred) <= pi} by move=> q /eqnP->. +have [P sylP] := Sylow_exists p H; have sPH := pHall_sub sylP. +have{sylP} sylP: p.-Sylow(G) P. + rewrite pHallE (subset_trans sPH) //= (card_Hall sylP) eqn_dvd andbC. + by rewrite -{1}(partn_part _ sppi) !partn_dvd ?cardSg ?cardG_gt0. +rewrite partn_part ?partn_biglcm //. +apply: (@big_ind _ (dvdn^~ _)) => [|m n|x Gx]; first exact: dvd1n. + by rewrite dvdn_lcm => ->. +rewrite -order_constt; have p_y := p_elt_constt p x; set y := x.`_p in p_y *. +have sYG: <[y]> \subset G by rewrite cycle_subG groupX. +have [z _ Pyz] := Sylow_Jsub sylP sYG p_y. +rewrite (bigD1 (y ^ z)) ?(subsetP sPH) -?cycle_subG ?cycleJ //=. +by rewrite orderJ part_pnat_id ?dvdn_lcml // (pi_pnat p_y). +Qed. + +Lemma exponent_Hall pi G H : pi.-Hall(G) H -> exponent H = (exponent G)`_pi. +Proof. +move=> hallH; have [sHG piH _] := and3P hallH. +rewrite -(partn_exponentS sHG) -?(card_Hall hallH) ?part_pnat_id //. +by apply: pnat_dvd piH; exact: exponent_dvdn. +Qed. + +Lemma exponent_Zgroup G : Zgroup G -> exponent G = #|G|. +Proof. +move/forall_inP=> ZgG; apply/eqP; rewrite eqn_dvd exponent_dvdn. +apply/(dvdn_partP _ (cardG_gt0 _)) => p _. +have [S sylS] := Sylow_exists p G; rewrite -(card_Hall sylS). +have /cyclicP[x defS]: cyclic S by rewrite ZgG ?(p_Sylow sylS). +by rewrite defS dvdn_exponent // -cycle_subG -defS (pHall_sub sylS). +Qed. + +Lemma cprod_exponent A B G : + A \* B = G -> lcmn (exponent A) (exponent B) = (exponent G). +Proof. +case/cprodP=> [[K H -> ->{A B}] <- cKH]. +apply/eqP; rewrite eqn_dvd dvdn_lcm !exponentS ?mulG_subl ?mulG_subr //=. +apply/exponentP=> _ /imset2P[x y Kx Hy ->]. +rewrite -[1]mulg1 expgMn; last by red; rewrite -(centsP cKH). +congr (_ * _); apply/eqP; rewrite -order_dvdn. + by rewrite (dvdn_trans (dvdn_exponent Kx)) ?dvdn_lcml. +by rewrite (dvdn_trans (dvdn_exponent Hy)) ?dvdn_lcmr. +Qed. + +Lemma dprod_exponent A B G : + A \x B = G -> lcmn (exponent A) (exponent B) = (exponent G). +Proof. +case/dprodP=> [[K H -> ->{A B}] defG cKH _]. +by apply: cprod_exponent; rewrite cprodE. +Qed. + +Lemma sub_LdivT A n : (A \subset 'Ldiv_n()) = (exponent A %| n). +Proof. by apply/subsetP/exponentP=> eAn x /eAn; rewrite inE => /eqP. Qed. + +Lemma LdivT_J n x : 'Ldiv_n() :^ x = 'Ldiv_n(). +Proof. +apply/setP=> y; rewrite !inE mem_conjg inE -conjXg. +by rewrite (canF_eq (conjgKV x)) conj1g. +Qed. + +Lemma LdivJ n A x : 'Ldiv_n(A :^ x) = 'Ldiv_n(A) :^ x. +Proof. by rewrite conjIg LdivT_J. Qed. + +Lemma sub_Ldiv A n : (A \subset 'Ldiv_n(A)) = (exponent A %| n). +Proof. by rewrite subsetI subxx sub_LdivT. Qed. + +Lemma group_Ldiv G n : abelian G -> group_set 'Ldiv_n(G). +Proof. +move=> cGG; apply/group_setP. +split=> [|x y]; rewrite !inE ?group1 ?expg1n //=. +case/andP=> Gx /eqP xn /andP[Gy /eqP yn]. +rewrite groupM //= expgMn ?xn ?yn ?mulg1 //; exact: (centsP cGG). +Qed. + +Lemma abelian_exponent_gen A : abelian A -> exponent <> = exponent A. +Proof. +rewrite -abelian_gen; set n := exponent A; set G := <> => cGG. +apply/eqP; rewrite eqn_dvd andbC exponentS ?subset_gen //= -sub_Ldiv. +rewrite -(gen_set_id (group_Ldiv n cGG)) genS // subsetI subset_gen /=. +by rewrite sub_LdivT. +Qed. + +Lemma abelem_pgroup p A : p.-abelem A -> p.-group A. +Proof. by case/andP. Qed. + +Lemma abelem_abelian p A : p.-abelem A -> abelian A. +Proof. by case/and3P. Qed. + +Lemma abelem1 p : p.-abelem [1 gT]. +Proof. by rewrite /abelem pgroup1 abelian1 exponent1 dvd1n. Qed. + +Lemma abelemE p G : prime p -> p.-abelem G = abelian G && (exponent G %| p). +Proof. +move=> p_pr; rewrite /abelem -pnat_exponent andbA -!(andbC (_ %| _)). +by case: (dvdn_pfactor _ 1 p_pr) => // [[k _ ->]]; rewrite pnat_exp pnat_id. +Qed. + +Lemma abelemP p G : + prime p -> + reflect (abelian G /\ forall x, x \in G -> x ^+ p = 1) (p.-abelem G). +Proof. +by move=> p_pr; rewrite abelemE //; apply: (iffP andP) => [] [-> /exponentP]. +Qed. + +Lemma abelem_order_p p G x : p.-abelem G -> x \in G -> x != 1 -> #[x] = p. +Proof. +case/and3P=> pG _ eG Gx; rewrite -cycle_eq1 => ntX. +have{ntX} [p_pr p_x _] := pgroup_pdiv (mem_p_elt pG Gx) ntX. +by apply/eqP; rewrite eqn_dvd p_x andbT order_dvdn (exponentP eG). +Qed. + +Lemma cyclic_abelem_prime p X : p.-abelem X -> cyclic X -> X :!=: 1 -> #|X| = p. +Proof. +move=> abelX cycX; case/cyclicP: cycX => x -> in abelX *. +by rewrite cycle_eq1; exact: abelem_order_p abelX (cycle_id x). +Qed. + +Lemma cycle_abelem p x : p.-elt x || prime p -> p.-abelem <[x]> = (#[x] %| p). +Proof. +move=> p_xVpr; rewrite /abelem cycle_abelian /=. +apply/andP/idP=> [[_ xp1] | x_dvd_p]. + by rewrite order_dvdn (exponentP xp1) ?cycle_id. +split; last exact: dvdn_trans (exponent_dvdn _) x_dvd_p. +by case/orP: p_xVpr => // /pnat_id; exact: pnat_dvd. +Qed. + +Lemma exponent2_abelem G : exponent G %| 2 -> 2.-abelem G. +Proof. +move/exponentP=> expG; apply/abelemP=> //; split=> //. +apply/centsP=> x Gx y Gy; apply: (mulIg x); apply: (mulgI y). +by rewrite -!mulgA !(mulgA y) -!(expgS _ 1) !expG ?mulg1 ?groupM. +Qed. + +Lemma prime_abelem p G : prime p -> #|G| = p -> p.-abelem G. +Proof. +move=> p_pr oG; rewrite /abelem -oG exponent_dvdn. +by rewrite /pgroup cyclic_abelian ?prime_cyclic ?oG ?pnat_id. +Qed. + +Lemma abelem_cyclic p G : p.-abelem G -> cyclic G = (logn p #|G| <= 1). +Proof. +move=> abelG; have [pG _ expGp] := and3P abelG. +case: (eqsVneq G 1) => [-> | ntG]; first by rewrite cyclic1 cards1 logn1. +have [p_pr _ [e oG]] := pgroup_pdiv pG ntG; apply/idP/idP. + case/cyclicP=> x defG; rewrite -(pfactorK 1 p_pr) dvdn_leq_log ?prime_gt0 //. + by rewrite defG order_dvdn (exponentP expGp) // defG cycle_id. +by rewrite oG pfactorK // ltnS leqn0 => e0; rewrite prime_cyclic // oG (eqP e0). +Qed. + +Lemma abelemS p H G : H \subset G -> p.-abelem G -> p.-abelem H. +Proof. +move=> sHG /and3P[cGG pG Gp1]; rewrite /abelem. +by rewrite (pgroupS sHG) // (abelianS sHG) // (dvdn_trans (exponentS sHG)). +Qed. + +Lemma abelemJ p G x : p.-abelem (G :^ x) = p.-abelem G. +Proof. by rewrite /abelem pgroupJ abelianJ exponentJ. Qed. + +Lemma cprod_abelem p A B G : + A \* B = G -> p.-abelem G = p.-abelem A && p.-abelem B. +Proof. +case/cprodP=> [[H K -> ->{A B}] defG cHK]. +apply/idP/andP=> [abelG | []]. + by rewrite !(abelemS _ abelG) // -defG (mulG_subl, mulG_subr). +case/and3P=> pH cHH expHp; case/and3P=> pK cKK expKp. +rewrite -defG /abelem pgroupM pH pK abelianM cHH cKK cHK /=. +apply/exponentP=> _ /imset2P[x y Hx Ky ->]. +rewrite expgMn; last by red; rewrite -(centsP cHK). +by rewrite (exponentP expHp) // (exponentP expKp) // mul1g. +Qed. + +Lemma dprod_abelem p A B G : + A \x B = G -> p.-abelem G = p.-abelem A && p.-abelem B. +Proof. +move=> defG; case/dprodP: (defG) => _ _ _ tiHK. +by apply: cprod_abelem; rewrite -dprodEcp. +Qed. + +Lemma is_abelem_pgroup p G : p.-group G -> is_abelem G = p.-abelem G. +Proof. +rewrite /is_abelem => pG. +case: (eqsVneq G 1) => [-> | ntG]; first by rewrite !abelem1. +by have [p_pr _ [k ->]] := pgroup_pdiv pG ntG; rewrite pdiv_pfactor. +Qed. + +Lemma is_abelemP G : reflect (exists2 p, prime p & p.-abelem G) (is_abelem G). +Proof. +apply: (iffP idP) => [abelG | [p p_pr abelG]]. + case: (eqsVneq G 1) => [-> | ntG]; first by exists 2; rewrite ?abelem1. + by exists (pdiv #|G|); rewrite ?pdiv_prime // ltnNge -trivg_card_le1. +by rewrite (is_abelem_pgroup (abelem_pgroup abelG)). +Qed. + +Lemma pElemP p A E : reflect (E \subset A /\ p.-abelem E) (E \in 'E_p(A)). +Proof. by rewrite inE; exact: andP. Qed. +Implicit Arguments pElemP [p A E]. + +Lemma pElemS p A B : A \subset B -> 'E_p(A) \subset 'E_p(B). +Proof. +by move=> sAB; apply/subsetP=> E; rewrite !inE => /andP[/subset_trans->]. +Qed. + +Lemma pElemI p A B : 'E_p(A :&: B) = 'E_p(A) :&: subgroups B. +Proof. by apply/setP=> E; rewrite !inE subsetI andbAC. Qed. + +Lemma pElemJ x p A E : ((E :^ x)%G \in 'E_p(A :^ x)) = (E \in 'E_p(A)). +Proof. by rewrite !inE conjSg abelemJ. Qed. + +Lemma pnElemP p n A E : + reflect [/\ E \subset A, p.-abelem E & logn p #|E| = n] (E \in 'E_p^n(A)). +Proof. by rewrite !inE -andbA; apply: (iffP and3P) => [] [-> -> /eqP]. Qed. +Implicit Arguments pnElemP [p n A E]. + +Lemma pnElemPcard p n A E : + E \in 'E_p^n(A) -> [/\ E \subset A, p.-abelem E & #|E| = p ^ n]%N. +Proof. +by case/pnElemP=> -> abelE <-; rewrite -card_pgroup // abelem_pgroup. +Qed. + +Lemma card_pnElem p n A E : E \in 'E_p^n(A) -> #|E| = (p ^ n)%N. +Proof. by case/pnElemPcard. Qed. + +Lemma pnElem0 p G : 'E_p^0(G) = [set 1%G]. +Proof. +apply/setP=> E; rewrite !inE -andbA; apply/and3P/idP=> [[_ pE] | /eqP->]. + apply: contraLR; case/(pgroup_pdiv (abelem_pgroup pE)) => p_pr _ [k ->]. + by rewrite pfactorK. +by rewrite sub1G abelem1 cards1 logn1. +Qed. + +Lemma pnElem_prime p n A E : E \in 'E_p^n.+1(A) -> prime p. +Proof. by case/pnElemP=> _ _; rewrite lognE; case: prime. Qed. + +Lemma pnElemE p n A : + prime p -> 'E_p^n(A) = [set E in 'E_p(A) | #|E| == (p ^ n)%N]. +Proof. +move/pfactorK=> pnK; apply/setP=> E; rewrite 3!inE. +case: (@andP (E \subset A)) => //= [[_]] /andP[/p_natP[k ->] _]. +by rewrite pnK (can_eq pnK). +Qed. + +Lemma pnElemS p n A B : A \subset B -> 'E_p^n(A) \subset 'E_p^n(B). +Proof. +move=> sAB; apply/subsetP=> E. +by rewrite !inE -!andbA => /andP[/subset_trans->]. +Qed. + +Lemma pnElemI p n A B : 'E_p^n(A :&: B) = 'E_p^n(A) :&: subgroups B. +Proof. by apply/setP=> E; rewrite !inE subsetI -!andbA; do !bool_congr. Qed. + +Lemma pnElemJ x p n A E : ((E :^ x)%G \in 'E_p^n(A :^ x)) = (E \in 'E_p^n(A)). +Proof. by rewrite inE pElemJ cardJg !inE. Qed. + +Lemma abelem_pnElem p n G : + p.-abelem G -> n <= logn p #|G| -> exists E, E \in 'E_p^n(G). +Proof. +case: n => [|n] abelG lt_nG; first by exists 1%G; rewrite pnElem0 set11. +have p_pr: prime p by move: lt_nG; rewrite lognE; case: prime. +case/(normal_pgroup (abelem_pgroup abelG)): lt_nG => // E [sEG _ oE]. +by exists E; rewrite pnElemE // !inE oE sEG (abelemS sEG) /=. +Qed. + +Lemma card_p1Elem p A X : X \in 'E_p^1(A) -> #|X| = p. +Proof. exact: card_pnElem. Qed. + +Lemma p1ElemE p A : prime p -> 'E_p^1(A) = [set X in subgroups A | #|X| == p]. +Proof. +move=> p_pr; apply/setP=> X; rewrite pnElemE // !inE -andbA; congr (_ && _). +by apply: andb_idl => /eqP oX; rewrite prime_abelem ?oX. +Qed. + +Lemma TIp1ElemP p A X Y : + X \in 'E_p^1(A) -> Y \in 'E_p^1(A) -> reflect (X :&: Y = 1) (X :!=: Y). +Proof. +move=> EpX EpY; have p_pr := pnElem_prime EpX. +have [oX oY] := (card_p1Elem EpX, card_p1Elem EpY). +have [<- |] := altP eqP. + by right=> X1; rewrite -oX -(setIid X) X1 cards1 in p_pr. +by rewrite eqEcard oX oY leqnn andbT; left; rewrite prime_TIg ?oX. +Qed. + +Lemma card_p1Elem_pnElem p n A E : + E \in 'E_p^n(A) -> #|'E_p^1(E)| = (\sum_(i < n) p ^ i)%N. +Proof. +case/pnElemP=> _ {A} abelE dimE; have [pE cEE _] := and3P abelE. +have [E1 | ntE] := eqsVneq E 1. + rewrite -dimE E1 cards1 logn1 big_ord0 eq_card0 // => X. + by rewrite !inE subG1 trivg_card1; case: eqP => // ->; rewrite logn1 andbF. +have [p_pr _ _] := pgroup_pdiv pE ntE; have p_gt1 := prime_gt1 p_pr. +apply/eqP; rewrite -(@eqn_pmul2l (p - 1)) ?subn_gt0 // subn1 -predn_exp. +have groupD1_inj: injective (fun X => (gval X)^#). + apply: can_inj (@generated_group _) _ => X. + by apply: val_inj; rewrite /= genD1 ?group1 ?genGid. +rewrite -dimE -card_pgroup // (cardsD1 1 E) group1 /= mulnC. +rewrite -(card_imset _ groupD1_inj) eq_sym. +apply/eqP; apply: card_uniform_partition => [X'|]. + case/imsetP=> X; rewrite pnElemE // expn1 => /setIdP[_ /eqP <-] ->. + by rewrite (cardsD1 1 X) group1. +apply/and3P; split; last 1 first. +- apply/imsetP=> [[X /card_p1Elem oX X'0]]. + by rewrite -oX (cardsD1 1) -X'0 group1 cards0 in p_pr. +- rewrite eqEsubset; apply/andP; split. + by apply/bigcupsP=> _ /imsetP[X /pnElemP[sXE _ _] ->]; exact: setSD. + apply/subsetP=> x /setD1P[ntx Ex]. + apply/bigcupP; exists <[x]>^#; last by rewrite !inE ntx cycle_id. + apply/imsetP; exists <[x]>%G; rewrite ?p1ElemE // !inE cycle_subG Ex /=. + by rewrite -orderE (abelem_order_p abelE). +apply/trivIsetP=> _ _ /imsetP[X EpX ->] /imsetP[Y EpY ->]; apply/implyP. +rewrite (inj_eq groupD1_inj) -setI_eq0 -setDIl setD_eq0 subG1. +by rewrite (sameP eqP (TIp1ElemP EpX EpY)) implybb. +Qed. + +Lemma card_p1Elem_p2Elem p A E : E \in 'E_p^2(A) -> #|'E_p^1(E)| = p.+1. +Proof. by move/card_p1Elem_pnElem->; rewrite big_ord_recl big_ord1. Qed. + +Lemma p2Elem_dprodP p A E X Y : + E \in 'E_p^2(A) -> X \in 'E_p^1(E) -> Y \in 'E_p^1(E) -> + reflect (X \x Y = E) (X :!=: Y). +Proof. +move=> Ep2E EpX EpY; have [_ abelE oE] := pnElemPcard Ep2E. +apply: (iffP (TIp1ElemP EpX EpY)) => [tiXY|]; last by case/dprodP. +have [[sXE _ oX] [sYE _ oY]] := (pnElemPcard EpX, pnElemPcard EpY). +rewrite dprodE ?(sub_abelian_cent2 (abelem_abelian abelE)) //. +by apply/eqP; rewrite eqEcard mul_subG //= TI_cardMg // oX oY oE. +Qed. + +Lemma nElemP n G E : reflect (exists p, E \in 'E_p^n(G)) (E \in 'E^n(G)). +Proof. +rewrite ['E^n(G)]big_mkord. +apply: (iffP bigcupP) => [[[p /= _] _] | [p]]; first by exists p. +case: n => [|n EpnE]; first by rewrite pnElem0; exists ord0; rewrite ?pnElem0. +suffices lepG: p < #|G|.+1 by exists (Ordinal lepG). +have:= EpnE; rewrite pnElemE ?(pnElem_prime EpnE) // !inE -andbA ltnS. +case/and3P=> sEG _ oE; rewrite dvdn_leq // (dvdn_trans _ (cardSg sEG)) //. +by rewrite (eqP oE) dvdn_exp. +Qed. +Implicit Arguments nElemP [n G E]. + +Lemma nElem0 G : 'E^0(G) = [set 1%G]. +Proof. +apply/setP=> E; apply/nElemP/idP=> [[p] |]; first by rewrite pnElem0. +by exists 2; rewrite pnElem0. +Qed. + +Lemma nElem1P G E : + reflect (E \subset G /\ exists2 p, prime p & #|E| = p) (E \in 'E^1(G)). +Proof. +apply: (iffP nElemP) => [[p pE] | [sEG [p p_pr oE]]]. + have p_pr := pnElem_prime pE; rewrite pnElemE // !inE -andbA in pE. + by case/and3P: pE => -> _ /eqP; split; last exists p. +exists p; rewrite pnElemE // !inE sEG oE eqxx abelemE // -oE exponent_dvdn. +by rewrite cyclic_abelian // prime_cyclic // oE. +Qed. + +Lemma nElemS n G H : G \subset H -> 'E^n(G) \subset 'E^n(H). +Proof. +move=> sGH; apply/subsetP=> E /nElemP[p EpnG_E]. +by apply/nElemP; exists p; rewrite // (subsetP (pnElemS _ _ sGH)). +Qed. + +Lemma nElemI n G H : 'E^n(G :&: H) = 'E^n(G) :&: subgroups H. +Proof. +apply/setP=> E; apply/nElemP/setIP=> [[p] | []]. + by rewrite pnElemI; case/setIP; split=> //; apply/nElemP; exists p. +by case/nElemP=> p EpnG_E sHE; exists p; rewrite pnElemI inE EpnG_E. +Qed. + +Lemma def_pnElem p n G : 'E_p^n(G) = 'E_p(G) :&: 'E^n(G). +Proof. +apply/setP=> E; rewrite inE in_setI; apply: andb_id2l => /pElemP[sEG abelE]. +apply/idP/nElemP=> [|[q]]; first by exists p; rewrite !inE sEG abelE. +rewrite !inE -2!andbA => /and4P[_ /pgroupP qE _]. +case: (eqVneq E 1%G) => [-> | ]; first by rewrite cards1 !logn1. +case/(pgroup_pdiv (abelem_pgroup abelE)) => p_pr pE _. +by rewrite (eqnP (qE p p_pr pE)). +Qed. + +Lemma pmaxElemP p A E : + reflect (E \in 'E_p(A) /\ forall H, H \in 'E_p(A) -> E \subset H -> H :=: E) + (E \in 'E*_p(A)). +Proof. by rewrite [E \in 'E*_p(A)]inE; exact: (iffP maxgroupP). Qed. + +Lemma pmaxElem_exists p A D : + D \in 'E_p(A) -> {E | E \in 'E*_p(A) & D \subset E}. +Proof. +move=> EpD; have [E maxE sDE] := maxgroup_exists (EpD : mem 'E_p(A) D). +by exists E; rewrite // inE. +Qed. + +Lemma pmaxElem_LdivP p G E : + prime p -> reflect ('Ldiv_p('C_G(E)) = E) (E \in 'E*_p(G)). +Proof. +move=> p_pr; apply: (iffP (pmaxElemP p G E)) => [[] | defE]. + case/pElemP=> sEG abelE maxE; have [_ cEE eE] := and3P abelE. + apply/setP=> x; rewrite !inE -andbA; apply/and3P/idP=> [[Gx cEx xp] | Ex]. + rewrite -(maxE (<[x]> <*> E)%G) ?joing_subr //. + by rewrite -cycle_subG joing_subl. + rewrite inE join_subG cycle_subG Gx sEG /=. + rewrite (cprod_abelem _ (cprodEY _)); last by rewrite centsC cycle_subG. + by rewrite cycle_abelem ?p_pr ?orbT // order_dvdn xp. + by rewrite (subsetP sEG) // (subsetP cEE) // (exponentP eE). +split=> [|H]; last first. + case/pElemP=> sHG /abelemP[// | cHH Hp1] sEH. + apply/eqP; rewrite eqEsubset sEH andbC /= -defE; apply/subsetP=> x Hx. + by rewrite 3!inE (subsetP sHG) // Hp1 ?(subsetP (centsS _ cHH)) /=. +apply/pElemP; split; first by rewrite -defE -setIA subsetIl. +apply/abelemP=> //; rewrite /abelian -{1 3}defE setIAC subsetIr. +by split=> //; apply/exponentP; rewrite -sub_LdivT setIAC subsetIr. +Qed. + +Lemma pmaxElemS p A B : + A \subset B -> 'E*_p(B) :&: subgroups A \subset 'E*_p(A). +Proof. +move=> sAB; apply/subsetP=> E; rewrite !inE. +case/andP=> /maxgroupP[/pElemP[_ abelE] maxE] sEA. +apply/maxgroupP; rewrite inE sEA; split=> // D EpD. +by apply: maxE; apply: subsetP EpD; exact: pElemS. +Qed. + +Lemma pmaxElemJ p A E x : ((E :^ x)%G \in 'E*_p(A :^ x)) = (E \in 'E*_p(A)). +Proof. +apply/pmaxElemP/pmaxElemP=> [] [EpE maxE]. + rewrite pElemJ in EpE; split=> //= H EpH sEH; apply: (act_inj 'Js x). + by apply: maxE; rewrite ?conjSg ?pElemJ. +rewrite pElemJ; split=> // H; rewrite -(actKV 'JG x H) pElemJ conjSg => EpHx'. +by move/maxE=> /= ->. +Qed. + +Lemma grank_min B : 'm(<>) <= #|B|. +Proof. +by rewrite /gen_rank; case: arg_minP => [|_ _ -> //]; rewrite genGid. +Qed. + +Lemma grank_witness G : {B | <> = G & #|B| = 'm(G)}. +Proof. +rewrite /gen_rank; case: arg_minP => [|B defG _]; first by rewrite genGid. +by exists B; first exact/eqP. +Qed. + +Lemma p_rank_witness p G : {E | E \in 'E_p^('r_p(G))(G)}. +Proof. +have [E EG_E mE]: {E | E \in 'E_p(G) & 'r_p(G) = logn p #|E| }. + by apply: eq_bigmax_cond; rewrite (cardD1 1%G) inE sub1G abelem1. +by exists E; rewrite inE EG_E -mE /=. +Qed. + +Lemma p_rank_geP p n G : reflect (exists E, E \in 'E_p^n(G)) (n <= 'r_p(G)). +Proof. +apply: (iffP idP) => [|[E]]; last first. + by rewrite inE => /andP[Ep_E /eqP <-]; rewrite (bigmax_sup E). +have [D /pnElemP[sDG abelD <-]] := p_rank_witness p G. +by case/abelem_pnElem=> // E; exists E; exact: (subsetP (pnElemS _ _ sDG)). +Qed. + +Lemma p_rank_gt0 p H : ('r_p(H) > 0) = (p \in \pi(H)). +Proof. +rewrite mem_primes cardG_gt0 /=; apply/p_rank_geP/andP=> [[E] | [p_pr]]. + case/pnElemP=> sEG _; rewrite lognE; case: and3P => // [[-> _ pE] _]. + by rewrite (dvdn_trans _ (cardSg sEG)). +case/Cauchy=> // x Hx ox; exists <[x]>%G; rewrite 2!inE [#|_|]ox cycle_subG. +by rewrite Hx (pfactorK 1) ?abelemE // cycle_abelian -ox exponent_dvdn. +Qed. + +Lemma p_rank1 p : 'r_p([1 gT]) = 0. +Proof. by apply/eqP; rewrite eqn0Ngt p_rank_gt0 /= cards1. Qed. + +Lemma logn_le_p_rank p A E : E \in 'E_p(A) -> logn p #|E| <= 'r_p(A). +Proof. by move=> EpA_E; rewrite (bigmax_sup E). Qed. + +Lemma p_rank_le_logn p G : 'r_p(G) <= logn p #|G|. +Proof. +have [E EpE] := p_rank_witness p G. +by have [sEG _ <-] := pnElemP EpE; exact: lognSg. +Qed. + +Lemma p_rank_abelem p G : p.-abelem G -> 'r_p(G) = logn p #|G|. +Proof. +move=> abelG; apply/eqP; rewrite eqn_leq andbC (bigmax_sup G) //. + by apply/bigmax_leqP=> E; rewrite inE => /andP[/lognSg->]. +by rewrite inE subxx. +Qed. + +Lemma p_rankS p A B : A \subset B -> 'r_p(A) <= 'r_p(B). +Proof. +move=> sAB; apply/bigmax_leqP=> E /(subsetP (pElemS p sAB)) EpB_E. +by rewrite (bigmax_sup E). +Qed. + +Lemma p_rankElem_max p A : 'E_p^('r_p(A))(A) \subset 'E*_p(A). +Proof. +apply/subsetP=> E /setIdP[EpE dimE]. +apply/pmaxElemP; split=> // F EpF sEF; apply/eqP. +have pF: p.-group F by case/pElemP: EpF => _ /and3P[]. +have pE: p.-group E by case/pElemP: EpE => _ /and3P[]. +rewrite eq_sym eqEcard sEF dvdn_leq // (card_pgroup pE) (card_pgroup pF). +by rewrite (eqP dimE) dvdn_exp2l // logn_le_p_rank. +Qed. + +Lemma p_rankJ p A x : 'r_p(A :^ x) = 'r_p(A). +Proof. +rewrite /p_rank (reindex_inj (act_inj 'JG x)). +by apply: eq_big => [E | E _]; rewrite ?cardJg ?pElemJ. +Qed. + +Lemma p_rank_Sylow p G H : p.-Sylow(G) H -> 'r_p(H) = 'r_p(G). +Proof. +move=> sylH; apply/eqP; rewrite eqn_leq (p_rankS _ (pHall_sub sylH)) /=. +apply/bigmax_leqP=> E; rewrite inE => /andP[sEG abelE]. +have [P sylP sEP] := Sylow_superset sEG (abelem_pgroup abelE). +have [x _ ->] := Sylow_trans sylP sylH. +by rewrite p_rankJ -(p_rank_abelem abelE) (p_rankS _ sEP). +Qed. + +Lemma p_rank_Hall pi p G H : pi.-Hall(G) H -> p \in pi -> 'r_p(H) = 'r_p(G). +Proof. +move=> hallH pi_p; have [P sylP] := Sylow_exists p H. +by rewrite -(p_rank_Sylow sylP) (p_rank_Sylow (subHall_Sylow hallH pi_p sylP)). +Qed. + +Lemma p_rank_pmaxElem_exists p r G : + 'r_p(G) >= r -> exists2 E, E \in 'E*_p(G) & 'r_p(E) >= r. +Proof. +case/p_rank_geP=> D /setIdP[EpD /eqP <- {r}]. +have [E EpE sDE] := pmaxElem_exists EpD; exists E => //. +case/pmaxElemP: EpE => /setIdP[_ abelE] _. +by rewrite (p_rank_abelem abelE) lognSg. +Qed. + +Lemma rank1 : 'r([1 gT]) = 0. +Proof. by rewrite ['r(1)]big1_seq // => p _; rewrite p_rank1. Qed. + +Lemma p_rank_le_rank p G : 'r_p(G) <= 'r(G). +Proof. +case: (posnP 'r_p(G)) => [-> //|]; rewrite p_rank_gt0 mem_primes. +case/and3P=> p_pr _ pG; have lepg: p < #|G|.+1 by rewrite ltnS dvdn_leq. +by rewrite ['r(G)]big_mkord (bigmax_sup (Ordinal lepg)). +Qed. + +Lemma rank_gt0 G : ('r(G) > 0) = (G :!=: 1). +Proof. +case: (eqsVneq G 1) => [-> |]; first by rewrite rank1 eqxx. +case: (trivgVpdiv G) => [-> | [p p_pr]]; first by case/eqP. +case/Cauchy=> // x Gx oxp ->; apply: leq_trans (p_rank_le_rank p G). +have EpGx: <[x]>%G \in 'E_p(G). + by rewrite inE cycle_subG Gx abelemE // cycle_abelian -oxp exponent_dvdn. +by apply: leq_trans (logn_le_p_rank EpGx); rewrite -orderE oxp logn_prime ?eqxx. +Qed. + +Lemma rank_witness G : {p | prime p & 'r(G) = 'r_p(G)}. +Proof. +have [p _ defmG]: {p : 'I_(#|G|.+1) | true & 'r(G) = 'r_p(G)}. + by rewrite ['r(G)]big_mkord; apply: eq_bigmax_cond; rewrite card_ord. +case: (eqsVneq G 1) => [-> | ]; first by exists 2; rewrite // rank1 p_rank1. +by rewrite -rank_gt0 defmG p_rank_gt0 mem_primes; case/andP; exists p. +Qed. + +Lemma rank_pgroup p G : p.-group G -> 'r(G) = 'r_p(G). +Proof. +move=> pG; apply/eqP; rewrite eqn_leq p_rank_le_rank andbT. +rewrite ['r(G)]big_mkord; apply/bigmax_leqP=> [[q /= _] _]. +case: (posnP 'r_q(G)) => [-> // |]; rewrite p_rank_gt0 mem_primes. +by case/and3P=> q_pr _ qG; rewrite (eqnP (pgroupP pG q q_pr qG)). +Qed. + +Lemma rank_Sylow p G P : p.-Sylow(G) P -> 'r(P) = 'r_p(G). +Proof. +move=> sylP; have pP := pHall_pgroup sylP. +by rewrite -(p_rank_Sylow sylP) -(rank_pgroup pP). +Qed. + +Lemma rank_abelem p G : p.-abelem G -> 'r(G) = logn p #|G|. +Proof. +by move=> abelG; rewrite (rank_pgroup (abelem_pgroup abelG)) p_rank_abelem. +Qed. + +Lemma nt_pnElem p n E A : E \in 'E_p^n(A) -> n > 0 -> E :!=: 1. +Proof. by case/pnElemP=> _ /rank_abelem <- <-; rewrite rank_gt0. Qed. + +Lemma rankJ A x : 'r(A :^ x) = 'r(A). +Proof. by rewrite /rank cardJg; apply: eq_bigr => p _; rewrite p_rankJ. Qed. + +Lemma rankS A B : A \subset B -> 'r(A) <= 'r(B). +Proof. +move=> sAB; rewrite /rank !big_mkord; apply/bigmax_leqP=> p _. +have leAB: #|A| < #|B|.+1 by rewrite ltnS subset_leq_card. +by rewrite (bigmax_sup (widen_ord leAB p)) // p_rankS. +Qed. + +Lemma rank_geP n G : reflect (exists E, E \in 'E^n(G)) (n <= 'r(G)). +Proof. +apply: (iffP idP) => [|[E]]. + have [p _ ->] := rank_witness G; case/p_rank_geP=> E. + by rewrite def_pnElem; case/setIP; exists E. +case/nElemP=> p; rewrite inE => /andP[EpG_E /eqP <-]. +by rewrite (leq_trans (logn_le_p_rank EpG_E)) ?p_rank_le_rank. +Qed. + +End ExponentAbelem. + +Implicit Arguments LdivP [gT A n x]. +Implicit Arguments exponentP [gT A n]. +Implicit Arguments abelemP [gT p G]. +Implicit Arguments is_abelemP [gT G]. +Implicit Arguments pElemP [gT p A E]. +Implicit Arguments pnElemP [gT p n A E]. +Implicit Arguments nElemP [gT n G E]. +Implicit Arguments nElem1P [gT G E]. +Implicit Arguments pmaxElemP [gT p A E]. +Implicit Arguments pmaxElem_LdivP [gT p G E]. +Implicit Arguments p_rank_geP [gT p n G]. +Implicit Arguments rank_geP [gT n G]. + +Section MorphAbelem. + +Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}). +Implicit Types (G H E : {group aT}) (A B : {set aT}). + +Lemma exponent_morphim G : exponent (f @* G) %| exponent G. +Proof. +apply/exponentP=> _ /morphimP[x Dx Gx ->]. +by rewrite -morphX // expg_exponent // morph1. +Qed. + +Lemma morphim_LdivT n : f @* 'Ldiv_n() \subset 'Ldiv_n(). +Proof. +apply/subsetP=> _ /morphimP[x Dx xn ->]; rewrite inE in xn. +by rewrite inE -morphX // (eqP xn) morph1. +Qed. + +Lemma morphim_Ldiv n A : f @* 'Ldiv_n(A) \subset 'Ldiv_n(f @* A). +Proof. +by apply: subset_trans (morphimI f A _) (setIS _ _); exact: morphim_LdivT. +Qed. + +Lemma morphim_abelem p G : p.-abelem G -> p.-abelem (f @* G). +Proof. +case: (eqsVneq G 1) => [-> | ntG] abelG; first by rewrite morphim1 abelem1. +have [p_pr _ _] := pgroup_pdiv (abelem_pgroup abelG) ntG. +case/abelemP: abelG => // abG elemG; apply/abelemP; rewrite ?morphim_abelian //. +by split=> // _ /morphimP[x Dx Gx ->]; rewrite -morphX // elemG ?morph1. +Qed. + +Lemma morphim_pElem p G E : E \in 'E_p(G) -> (f @* E)%G \in 'E_p(f @* G). +Proof. +by rewrite !inE => /andP[sEG abelE]; rewrite morphimS // morphim_abelem. +Qed. + +Lemma morphim_pnElem p n G E : + E \in 'E_p^n(G) -> {m | m <= n & (f @* E)%G \in 'E_p^m(f @* G)}. +Proof. +rewrite inE => /andP[EpE /eqP <-]. +by exists (logn p #|f @* E|); rewrite ?logn_morphim // inE morphim_pElem /=. +Qed. + +Lemma morphim_grank G : G \subset D -> 'm(f @* G) <= 'm(G). +Proof. +have [B defG <-] := grank_witness G; rewrite -defG gen_subG => sBD. +by rewrite morphim_gen ?morphimEsub ?(leq_trans (grank_min _)) ?leq_imset_card. +Qed. + +(* There are no general morphism relations for the p-rank. We later prove *) +(* some relations for the p-rank of a quotient in the QuotientAbelem section. *) + +End MorphAbelem. + +Section InjmAbelem. + +Variables (aT rT : finGroupType) (D G : {group aT}) (f : {morphism D >-> rT}). +Hypotheses (injf : 'injm f) (sGD : G \subset D). +Let defG : invm injf @* (f @* G) = G := morphim_invm injf sGD. + +Lemma exponent_injm : exponent (f @* G) = exponent G. +Proof. by apply/eqP; rewrite eqn_dvd -{3}defG !exponent_morphim. Qed. + +Lemma injm_Ldiv n A : f @* 'Ldiv_n(A) = 'Ldiv_n(f @* A). +Proof. +apply/eqP; rewrite eqEsubset morphim_Ldiv. +rewrite -[f @* 'Ldiv_n(A)](morphpre_invm injf). +rewrite -sub_morphim_pre; last by rewrite subIset ?morphim_sub. +rewrite injmI ?injm_invm // setISS ?morphim_LdivT //. +by rewrite sub_morphim_pre ?morphim_sub // morphpre_invm. +Qed. + +Lemma injm_abelem p : p.-abelem (f @* G) = p.-abelem G. +Proof. by apply/idP/idP; first rewrite -{2}defG; exact: morphim_abelem. Qed. + +Lemma injm_pElem p (E : {group aT}) : + E \subset D -> ((f @* E)%G \in 'E_p(f @* G)) = (E \in 'E_p(G)). +Proof. +move=> sED; apply/idP/idP=> EpE; last exact: morphim_pElem. +by rewrite -defG -(group_inj (morphim_invm injf sED)) morphim_pElem. +Qed. + +Lemma injm_pnElem p n (E : {group aT}) : + E \subset D -> ((f @* E)%G \in 'E_p^n(f @* G)) = (E \in 'E_p^n(G)). +Proof. by move=> sED; rewrite inE injm_pElem // card_injm ?inE. Qed. + +Lemma injm_nElem n (E : {group aT}) : + E \subset D -> ((f @* E)%G \in 'E^n(f @* G)) = (E \in 'E^n(G)). +Proof. +move=> sED; apply/nElemP/nElemP=> [] [p EpE]; + by exists p; rewrite injm_pnElem in EpE *. +Qed. + +Lemma injm_pmaxElem p (E : {group aT}) : + E \subset D -> ((f @* E)%G \in 'E*_p(f @* G)) = (E \in 'E*_p(G)). +Proof. +move=> sED; have defE := morphim_invm injf sED. +apply/pmaxElemP/pmaxElemP=> [] [EpE maxE]. + split=> [|H EpH sEH]; first by rewrite injm_pElem in EpE. + have sHD: H \subset D by apply: subset_trans (sGD); case/pElemP: EpH. + by rewrite -(morphim_invm injf sHD) [f @* H]maxE ?morphimS ?injm_pElem. +rewrite injm_pElem //; split=> // fH Ep_fH sfEH; have [sfHG _] := pElemP Ep_fH. +have sfHD : fH \subset f @* D by rewrite (subset_trans sfHG) ?morphimS. +rewrite -(morphpreK sfHD); congr (f @* _). +rewrite [_ @*^-1 fH]maxE -?sub_morphim_pre //. +by rewrite -injm_pElem ?subsetIl // (group_inj (morphpreK sfHD)). +Qed. + +Lemma injm_grank : 'm(f @* G) = 'm(G). +Proof. by apply/eqP; rewrite eqn_leq -{3}defG !morphim_grank ?morphimS. Qed. + +Lemma injm_p_rank p : 'r_p(f @* G) = 'r_p(G). +Proof. +apply/eqP; rewrite eqn_leq; apply/andP; split. + have [fE] := p_rank_witness p (f @* G); move: 'r_p(_) => n Ep_fE. + apply/p_rank_geP; exists (f @*^-1 fE)%G. + rewrite -injm_pnElem ?subsetIl ?(group_inj (morphpreK _)) //. + by case/pnElemP: Ep_fE => sfEG _ _; rewrite (subset_trans sfEG) ?morphimS. +have [E] := p_rank_witness p G; move: 'r_p(_) => n EpE. +apply/p_rank_geP; exists (f @* E)%G; rewrite injm_pnElem //. +by case/pnElemP: EpE => sEG _ _; rewrite (subset_trans sEG). +Qed. + +Lemma injm_rank : 'r(f @* G) = 'r(G). +Proof. +apply/eqP; rewrite eqn_leq; apply/andP; split. + by have [p _ ->] := rank_witness (f @* G); rewrite injm_p_rank p_rank_le_rank. +by have [p _ ->] := rank_witness G; rewrite -injm_p_rank p_rank_le_rank. +Qed. + +End InjmAbelem. + +Section IsogAbelem. + +Variables (aT rT : finGroupType) (G : {group aT}) (H : {group rT}). +Hypothesis isoGH : G \isog H. + +Lemma exponent_isog : exponent G = exponent H. +Proof. by case/isogP: isoGH => f injf <-; rewrite exponent_injm. Qed. + +Lemma isog_abelem p : p.-abelem G = p.-abelem H. +Proof. by case/isogP: isoGH => f injf <-; rewrite injm_abelem. Qed. + +Lemma isog_grank : 'm(G) = 'm(H). +Proof. by case/isogP: isoGH => f injf <-; rewrite injm_grank. Qed. + +Lemma isog_p_rank p : 'r_p(G) = 'r_p(H). +Proof. by case/isogP: isoGH => f injf <-; rewrite injm_p_rank. Qed. + +Lemma isog_rank : 'r(G) = 'r(H). +Proof. by case/isogP: isoGH => f injf <-; rewrite injm_rank. Qed. + +End IsogAbelem. + +Section QuotientAbelem. + +Variables (gT : finGroupType) (p : nat). +Implicit Types E G K H : {group gT}. + +Lemma exponent_quotient G H : exponent (G / H) %| exponent G. +Proof. exact: exponent_morphim. Qed. + +Lemma quotient_LdivT n H : 'Ldiv_n() / H \subset 'Ldiv_n(). +Proof. exact: morphim_LdivT. Qed. + +Lemma quotient_Ldiv n A H : 'Ldiv_n(A) / H \subset 'Ldiv_n(A / H). +Proof. exact: morphim_Ldiv. Qed. + +Lemma quotient_abelem G H : p.-abelem G -> p.-abelem (G / H). +Proof. exact: morphim_abelem. Qed. + +Lemma quotient_pElem G H E : E \in 'E_p(G) -> (E / H)%G \in 'E_p(G / H). +Proof. exact: morphim_pElem. Qed. + +Lemma logn_quotient G H : logn p #|G / H| <= logn p #|G|. +Proof. exact: logn_morphim. Qed. + +Lemma quotient_pnElem G H n E : + E \in 'E_p^n(G) -> {m | m <= n & (E / H)%G \in 'E_p^m(G / H)}. +Proof. exact: morphim_pnElem. Qed. + +Lemma quotient_grank G H : G \subset 'N(H) -> 'm(G / H) <= 'm(G). +Proof. exact: morphim_grank. Qed. + +Lemma p_rank_quotient G H : G \subset 'N(H) -> 'r_p(G) - 'r_p(H) <= 'r_p(G / H). +Proof. +move=> nHG; rewrite leq_subLR. +have [E EpE] := p_rank_witness p G; have{EpE} [sEG abelE <-] := pnElemP EpE. +rewrite -(LagrangeI E H) lognM ?cardG_gt0 //. +rewrite -card_quotient ?(subset_trans sEG) // leq_add ?logn_le_p_rank // !inE. + by rewrite subsetIr (abelemS (subsetIl E H)). +by rewrite quotientS ?quotient_abelem. +Qed. + +Lemma p_rank_dprod K H G : K \x H = G -> 'r_p(K) + 'r_p(H) = 'r_p(G). +Proof. +move=> defG; apply/eqP; rewrite eqn_leq -leq_subLR andbC. +have [_ defKH cKH tiKH] := dprodP defG; have nKH := cents_norm cKH. +rewrite {1}(isog_p_rank (quotient_isog nKH tiKH)) /= -quotientMidl defKH. +rewrite p_rank_quotient; last by rewrite -defKH mul_subG ?normG. +have [[E EpE] [F EpF]] := (p_rank_witness p K, p_rank_witness p H). +have [[sEK abelE <-] [sFH abelF <-]] := (pnElemP EpE, pnElemP EpF). +have defEF: E \x F = E <*> F. + by rewrite dprodEY ?(centSS sFH sEK) //; apply/trivgP; rewrite -tiKH setISS. +apply/p_rank_geP; exists (E <*> F)%G; rewrite !inE (dprod_abelem p defEF). +rewrite -lognM ?cargG_gt0 // (dprod_card defEF) abelE abelF eqxx. +by rewrite -(genGid G) -defKH genM_join genS ?setUSS. +Qed. + +Lemma p_rank_p'quotient G H : + (p : nat)^'.-group H -> G \subset 'N(H) -> 'r_p(G / H) = 'r_p(G). +Proof. +move=> p'H nHG; have [P sylP] := Sylow_exists p G. +have [sPG pP _] := and3P sylP; have nHP := subset_trans sPG nHG. +have tiHP: H :&: P = 1 := coprime_TIg (p'nat_coprime p'H pP). +rewrite -(p_rank_Sylow sylP) -(p_rank_Sylow (quotient_pHall nHP sylP)). +by rewrite (isog_p_rank (quotient_isog nHP tiHP)). +Qed. + +End QuotientAbelem. + +Section OhmProps. + +Section Generic. + +Variables (n : nat) (gT : finGroupType). +Implicit Types (p : nat) (x : gT) (rT : finGroupType). +Implicit Types (A B : {set gT}) (D G H : {group gT}). + +Lemma Ohm_sub G : 'Ohm_n(G) \subset G. +Proof. by rewrite gen_subG; apply/subsetP=> x /setIdP[]. Qed. + +Lemma Ohm1 : 'Ohm_n([1 gT]) = 1. Proof. exact: (trivgP (Ohm_sub _)). Qed. + +Lemma Ohm_id G : 'Ohm_n('Ohm_n(G)) = 'Ohm_n(G). +Proof. +apply/eqP; rewrite eqEsubset Ohm_sub genS //. +by apply/subsetP=> x /setIdP[Gx oxn]; rewrite inE mem_gen // inE Gx. +Qed. + +Lemma Ohm_cont rT G (f : {morphism G >-> rT}) : + f @* 'Ohm_n(G) \subset 'Ohm_n(f @* G). +Proof. +rewrite morphim_gen ?genS //; last by rewrite -gen_subG Ohm_sub. +apply/subsetP=> fx /morphimP[x Gx]; rewrite inE Gx /=. +case/OhmPredP=> p p_pr xpn_1 -> {fx}. +rewrite inE morphimEdom mem_imset //=; apply/OhmPredP; exists p => //. +by rewrite -morphX // xpn_1 morph1. +Qed. + +Lemma OhmS H G : H \subset G -> 'Ohm_n(H) \subset 'Ohm_n(G). +Proof. +move=> sHG; apply: genS; apply/subsetP=> x; rewrite !inE => /andP[Hx ->]. +by rewrite (subsetP sHG). +Qed. + +Lemma OhmE p G : p.-group G -> 'Ohm_n(G) = <<'Ldiv_(p ^ n)(G)>>. +Proof. +move=> pG; congr <<_>>; apply/setP=> x; rewrite !inE; apply: andb_id2l => Gx. +case: (eqVneq x 1) => [-> | ntx]; first by rewrite !expg1n. +by rewrite (pdiv_p_elt (mem_p_elt pG Gx)). +Qed. + +Lemma OhmEabelian p G : + p.-group G -> abelian 'Ohm_n(G) -> 'Ohm_n(G) = 'Ldiv_(p ^ n)(G). +Proof. +move=> pG; rewrite (OhmE pG) abelian_gen => cGGn; rewrite gen_set_id //. +rewrite -(setIidPr (subset_gen 'Ldiv_(p ^ n)(G))) setIA. +by rewrite [_ :&: G](setIidPl _) ?gen_subG ?subsetIl // group_Ldiv ?abelian_gen. +Qed. + +Lemma Ohm_p_cycle p x : + p.-elt x -> 'Ohm_n(<[x]>) = <[x ^+ (p ^ (logn p #[x] - n))]>. +Proof. +move=> p_x; apply/eqP; rewrite (OhmE p_x) eqEsubset cycle_subG mem_gen. + rewrite gen_subG andbT; apply/subsetP=> y /LdivP[x_y ypn]. + case: (leqP (logn p #[x]) n) => [|lt_n_x]. + by rewrite -subn_eq0 => /eqP->. + have p_pr: prime p by move: lt_n_x; rewrite lognE; case: (prime p). + have def_y: <[y]> = <[x ^+ (#[x] %/ #[y])]>. + apply: congr_group; apply/set1P. + by rewrite -cycle_sub_group ?cardSg ?inE ?cycle_subG ?x_y /=. + rewrite -cycle_subG def_y cycle_subG -{1}(part_pnat_id p_x) p_part. + rewrite -{1}(subnK (ltnW lt_n_x)) expnD -muln_divA ?order_dvdn ?ypn //. + by rewrite expgM mem_cycle. +rewrite !inE mem_cycle -expgM -expnD addnC -maxnE -order_dvdn. +by rewrite -{1}(part_pnat_id p_x) p_part dvdn_exp2l ?leq_maxr. +Qed. + +Lemma Ohm_dprod A B G : A \x B = G -> 'Ohm_n(A) \x 'Ohm_n(B) = 'Ohm_n(G). +Proof. +case/dprodP => [[H K -> ->{A B}]] <- cHK tiHK. +rewrite dprodEY //; last first. +- by apply/trivgP; rewrite -tiHK setISS ?Ohm_sub. +- by rewrite (subset_trans (subset_trans _ cHK)) ?centS ?Ohm_sub. +apply/eqP; rewrite -(cent_joinEr cHK) eqEsubset join_subG /=. +rewrite !OhmS ?joing_subl ?joing_subr //= cent_joinEr //= -genM_join genS //. +apply/subsetP=> _ /setIdP[/imset2P[x y Hx Ky ->] /OhmPredP[p p_pr /eqP]]. +have cxy: commute x y by red; rewrite -(centsP cHK). +rewrite ?expgMn // -eq_invg_mul => /eqP def_x. +have ypn1: y ^+ (p ^ n) = 1. + by apply/set1P; rewrite -[[set 1]]tiHK inE -{1}def_x groupV !groupX. +have xpn1: x ^+ (p ^ n) = 1 by rewrite -[x ^+ _]invgK def_x ypn1 invg1. +by rewrite mem_mulg ?mem_gen // inE (Hx, Ky); apply/OhmPredP; exists p. +Qed. + +Lemma Mho_sub G : 'Mho^n(G) \subset G. +Proof. +rewrite gen_subG; apply/subsetP=> _ /imsetP[x /setIdP[Gx _] ->]. +exact: groupX. +Qed. + +Lemma Mho1 : 'Mho^n([1 gT]) = 1. Proof. exact: (trivgP (Mho_sub _)). Qed. + +Lemma morphim_Mho rT D G (f : {morphism D >-> rT}) : + G \subset D -> f @* 'Mho^n(G) = 'Mho^n(f @* G). +Proof. +move=> sGD; have sGnD := subset_trans (Mho_sub G) sGD. +apply/eqP; rewrite eqEsubset {1}morphim_gen -1?gen_subG // !gen_subG. +apply/andP; split; apply/subsetP=> y. + case/morphimP=> xpn _ /imsetP[x /setIdP[Gx]]. + set p := pdiv _ => p_x -> -> {xpn y}; have Dx := subsetP sGD x Gx. + by rewrite morphX // Mho_p_elt ?morph_p_elt ?mem_morphim. +case/imsetP=> _ /setIdP[/morphimP[x Dx Gx ->]]. +set p := pdiv _ => p_fx ->{y}; rewrite -(constt_p_elt p_fx) -morph_constt //. +by rewrite -morphX ?mem_morphim ?Mho_p_elt ?groupX ?p_elt_constt. +Qed. + +Lemma Mho_cont rT G (f : {morphism G >-> rT}) : + f @* 'Mho^n(G) \subset 'Mho^n(f @* G). +Proof. by rewrite morphim_Mho. Qed. + +Lemma MhoS H G : H \subset G -> 'Mho^n(H) \subset 'Mho^n(G). +Proof. +move=> sHG; apply: genS; apply: imsetS; apply/subsetP=> x. +by rewrite !inE => /andP[Hx]; rewrite (subsetP sHG). +Qed. + +Lemma MhoE p G : p.-group G -> 'Mho^n(G) = <<[set x ^+ (p ^ n) | x in G]>>. +Proof. +move=> pG; apply/eqP; rewrite eqEsubset !gen_subG; apply/andP. +do [split; apply/subsetP=> xpn; case/imsetP=> x] => [|Gx ->]; last first. + by rewrite Mho_p_elt ?(mem_p_elt pG). +case/setIdP=> Gx _ ->; have [-> | ntx] := eqVneq x 1; first by rewrite expg1n. +by rewrite (pdiv_p_elt (mem_p_elt pG Gx) ntx) mem_gen //; exact: mem_imset. +Qed. + +Lemma MhoEabelian p G : + p.-group G -> abelian G -> 'Mho^n(G) = [set x ^+ (p ^ n) | x in G]. +Proof. +move=> pG cGG; rewrite (MhoE pG); rewrite gen_set_id //; apply/group_setP. +split=> [|xn yn]; first by apply/imsetP; exists 1; rewrite ?expg1n. +case/imsetP=> x Gx ->; case/imsetP=> y Gy ->. +by rewrite -expgMn; [apply: mem_imset; rewrite groupM | exact: (centsP cGG)]. +Qed. + +Lemma trivg_Mho G : 'Mho^n(G) == 1 -> 'Ohm_n(G) == G. +Proof. +rewrite -subG1 gen_subG eqEsubset Ohm_sub /= => Gp1. +rewrite -{1}(Sylow_gen G) genS //; apply/bigcupsP=> P. +case/SylowP=> p p_pr /and3P[sPG pP _]; apply/subsetP=> x Px. +have Gx := subsetP sPG x Px; rewrite inE Gx //=. +rewrite (sameP eqP set1P) (subsetP Gp1) ?mem_gen //; apply: mem_imset. +by rewrite inE Gx; exact: pgroup_p (mem_p_elt pP Px). +Qed. + +Lemma Mho_p_cycle p x : p.-elt x -> 'Mho^n(<[x]>) = <[x ^+ (p ^ n)]>. +Proof. +move=> p_x. +apply/eqP; rewrite (MhoE p_x) eqEsubset cycle_subG mem_gen; last first. + by apply: mem_imset; exact: cycle_id. +rewrite gen_subG andbT; apply/subsetP=> _ /imsetP[_ /cycleP[k ->] ->]. +by rewrite -expgM mulnC expgM mem_cycle. +Qed. + +Lemma Mho_cprod A B G : A \* B = G -> 'Mho^n(A) \* 'Mho^n(B) = 'Mho^n(G). +Proof. +case/cprodP => [[H K -> ->{A B}]] <- cHK; rewrite cprodEY //; last first. + by rewrite (subset_trans (subset_trans _ cHK)) ?centS ?Mho_sub. +apply/eqP; rewrite -(cent_joinEr cHK) eqEsubset join_subG /=. +rewrite !MhoS ?joing_subl ?joing_subr //= cent_joinEr // -genM_join. +apply: genS; apply/subsetP=> xypn /imsetP[_ /setIdP[/imset2P[x y Hx Ky ->]]]. +move/constt_p_elt; move: (pdiv _) => p <- ->. +have cxy: commute x y by red; rewrite -(centsP cHK). +rewrite consttM // expgMn; last exact: commuteX2. +by rewrite mem_mulg ?Mho_p_elt ?groupX ?p_elt_constt. +Qed. + +Lemma Mho_dprod A B G : A \x B = G -> 'Mho^n(A) \x 'Mho^n(B) = 'Mho^n(G). +Proof. +case/dprodP => [[H K -> ->{A B}]] defG cHK tiHK. +rewrite dprodEcp; first by apply: Mho_cprod; rewrite cprodE. +by apply/trivgP; rewrite -tiHK setISS ?Mho_sub. +Qed. + +End Generic. + +Canonical Ohm_igFun i := [igFun by Ohm_sub i & Ohm_cont i]. +Canonical Ohm_gFun i := [gFun by Ohm_cont i]. +Canonical Ohm_mgFun i := [mgFun by OhmS i]. + +Canonical Mho_igFun i := [igFun by Mho_sub i & Mho_cont i]. +Canonical Mho_gFun i := [gFun by Mho_cont i]. +Canonical Mho_mgFun i := [mgFun by MhoS i]. + +Section char. + +Variables (n : nat) (gT rT : finGroupType) (D G : {group gT}). + +Lemma Ohm_char : 'Ohm_n(G) \char G. Proof. exact: gFchar. Qed. +Lemma Ohm_normal : 'Ohm_n(G) <| G. Proof. exact: gFnormal. Qed. + +Lemma Mho_char : 'Mho^n(G) \char G. Proof. exact: gFchar. Qed. +Lemma Mho_normal : 'Mho^n(G) <| G. Proof. exact: gFnormal. Qed. + +Lemma morphim_Ohm (f : {morphism D >-> rT}) : + G \subset D -> f @* 'Ohm_n(G) \subset 'Ohm_n(f @* G). +Proof. exact: morphimF. Qed. + +Lemma injm_Ohm (f : {morphism D >-> rT}) : + 'injm f -> G \subset D -> f @* 'Ohm_n(G) = 'Ohm_n(f @* G). +Proof. by move=> injf; exact: injmF. Qed. + +Lemma isog_Ohm (H : {group rT}) : G \isog H -> 'Ohm_n(G) \isog 'Ohm_n(H). +Proof. exact: gFisog. Qed. + +Lemma isog_Mho (H : {group rT}) : G \isog H -> 'Mho^n(G) \isog 'Mho^n(H). +Proof. exact: gFisog. Qed. + +End char. + +Variable gT : finGroupType. +Implicit Types (pi : nat_pred) (p : nat). +Implicit Types (A B C : {set gT}) (D G H E : {group gT}). + +Lemma Ohm0 G : 'Ohm_0(G) = 1. +Proof. +apply/trivgP; rewrite /= gen_subG. +by apply/subsetP=> x /setIdP[_]; rewrite inE. +Qed. + +Lemma Ohm_leq m n G : m <= n -> 'Ohm_m(G) \subset 'Ohm_n(G). +Proof. +move/subnKC <-; rewrite genS //; apply/subsetP=> y. +by rewrite !inE expnD expgM => /andP[-> /eqP->]; rewrite expg1n /=. +Qed. + +Lemma OhmJ n G x : 'Ohm_n(G :^ x) = 'Ohm_n(G) :^ x. +Proof. +rewrite -{1}(setIid G) -(setIidPr (Ohm_sub n G)). +by rewrite -!morphim_conj injm_Ohm ?injm_conj. +Qed. + +Lemma Mho0 G : 'Mho^0(G) = G. +Proof. +apply/eqP; rewrite eqEsubset Mho_sub /=. +apply/subsetP=> x Gx; rewrite -[x]prod_constt group_prod // => p _. +exact: Mho_p_elt (groupX _ Gx) (p_elt_constt _ _). +Qed. + +Lemma Mho_leq m n G : m <= n -> 'Mho^n(G) \subset 'Mho^m(G). +Proof. +move/subnKC <-; rewrite gen_subG //. +apply/subsetP=> _ /imsetP[x /setIdP[Gx p_x] ->]. +by rewrite expnD expgM groupX ?(Mho_p_elt _ _ p_x). +Qed. + +Lemma MhoJ n G x : 'Mho^n(G :^ x) = 'Mho^n(G) :^ x. +Proof. +by rewrite -{1}(setIid G) -(setIidPr (Mho_sub n G)) -!morphim_conj morphim_Mho. +Qed. + +Lemma extend_cyclic_Mho G p x : + p.-group G -> x \in G -> 'Mho^1(G) = <[x ^+ p]> -> + forall k, k > 0 -> 'Mho^k(G) = <[x ^+ (p ^ k)]>. +Proof. +move=> pG Gx defG1 [//|k _]; have pX := mem_p_elt pG Gx. +apply/eqP; rewrite eqEsubset cycle_subG (Mho_p_elt _ Gx pX) andbT. +rewrite (MhoE _ pG) gen_subG; apply/subsetP=> ypk; case/imsetP=> y Gy ->{ypk}. +have: y ^+ p \in <[x ^+ p]> by rewrite -defG1 (Mho_p_elt 1 _ (mem_p_elt pG Gy)). +rewrite !expnS /= !expgM => /cycleP[j ->]. +by rewrite -!expgM mulnCA mulnC expgM mem_cycle. +Qed. + +Lemma Ohm1Eprime G : 'Ohm_1(G) = <<[set x in G | prime #[x]]>>. +Proof. +rewrite -['Ohm_1(G)](genD1 (group1 _)); congr <<_>>. +apply/setP=> x; rewrite !inE andbCA -order_dvdn -order_gt1; congr (_ && _). +apply/andP/idP=> [[p_gt1] | p_pr]; last by rewrite prime_gt1 ?pdiv_id. +set p := pdiv _ => ox_p; have p_pr: prime p by rewrite pdiv_prime. +by have [_ dv_p] := primeP p_pr; case/pred2P: (dv_p _ ox_p) p_gt1 => ->. +Qed. + +Lemma abelem_Ohm1 p G : p.-group G -> p.-abelem 'Ohm_1(G) = abelian 'Ohm_1(G). +Proof. +move=> pG; rewrite /abelem (pgroupS (Ohm_sub 1 G)) //. +case abG1: (abelian _) => //=; apply/exponentP=> x. +by rewrite (OhmEabelian pG abG1); case/LdivP. +Qed. + +Lemma Ohm1_abelem p G : p.-group G -> abelian G -> p.-abelem ('Ohm_1(G)). +Proof. by move=> pG cGG; rewrite abelem_Ohm1 ?(abelianS (Ohm_sub 1 G)). Qed. + +Lemma Ohm1_id p G : p.-abelem G -> 'Ohm_1(G) = G. +Proof. +case/and3P=> pG cGG /exponentP Gp. +apply/eqP; rewrite eqEsubset Ohm_sub (OhmE 1 pG) sub_gen //. +by apply/subsetP=> x Gx; rewrite !inE Gx Gp /=. +Qed. + +Lemma abelem_Ohm1P p G : + abelian G -> p.-group G -> reflect ('Ohm_1(G) = G) (p.-abelem G). +Proof. +move=> cGG pG. +apply: (iffP idP) => [| <-]; [exact: Ohm1_id | exact: Ohm1_abelem]. +Qed. + +Lemma TI_Ohm1 G H : H :&: 'Ohm_1(G) = 1 -> H :&: G = 1. +Proof. +move=> tiHG1; case: (trivgVpdiv (H :&: G)) => // [[p pr_p]]. +case/Cauchy=> // x /setIP[Hx Gx] ox. +suffices x1: x \in [1] by rewrite -ox (set1P x1) order1 in pr_p. +by rewrite -{}tiHG1 inE Hx Ohm1Eprime mem_gen // inE Gx ox. +Qed. + +Lemma Ohm1_eq1 G : ('Ohm_1(G) == 1) = (G :==: 1). +Proof. +apply/idP/idP => [/eqP G1_1 | /eqP->]; last by rewrite -subG1 Ohm_sub. +by rewrite -(setIid G) TI_Ohm1 // G1_1 setIg1. +Qed. + +Lemma meet_Ohm1 G H : G :&: H != 1 -> G :&: 'Ohm_1(H) != 1. +Proof. by apply: contraNneq => /TI_Ohm1->. Qed. + +Lemma Ohm1_cent_max G E p : E \in 'E*_p(G) -> p.-group G -> 'Ohm_1('C_G(E)) = E. +Proof. +move=> EpmE pG; have [G1 | ntG]:= eqsVneq G 1. + case/pmaxElemP: EpmE; case/pElemP; rewrite G1 => /trivgP-> _ _. + by apply/trivgP; rewrite cent1T setIT Ohm_sub. +have [p_pr _ _] := pgroup_pdiv pG ntG. +by rewrite (OhmE 1 (pgroupS (subsetIl G _) pG)) (pmaxElem_LdivP _ _) ?genGid. +Qed. + +Lemma Ohm1_cyclic_pgroup_prime p G : + cyclic G -> p.-group G -> G :!=: 1 -> #|'Ohm_1(G)| = p. +Proof. +move=> cycG pG ntG; set K := 'Ohm_1(G). +have abelK: p.-abelem K by rewrite Ohm1_abelem ?cyclic_abelian. +have sKG: K \subset G := Ohm_sub 1 G. +case/cyclicP: (cyclicS sKG cycG) => x /=; rewrite -/K => defK. +rewrite defK -orderE (abelem_order_p abelK) //= -/K ?defK ?cycle_id //. +rewrite -cycle_eq1 -defK -(setIidPr sKG). +by apply: contraNneq ntG => /TI_Ohm1; rewrite setIid => ->. +Qed. + +Lemma cyclic_pgroup_dprod_trivg p A B C : + p.-group C -> cyclic C -> A \x B = C -> + A = 1 /\ B = C \/ B = 1 /\ A = C. +Proof. +move=> pC cycC; case/cyclicP: cycC pC => x ->{C} pC defC. +case/dprodP: defC => [] [G H -> ->{A B}] defC _ tiGH; rewrite -defC. +case: (eqVneq <[x]> 1) => [|ntC]. + move/trivgP; rewrite -defC mulG_subG => /andP[/trivgP-> _]. + by rewrite mul1g; left. +have [pr_p _ _] := pgroup_pdiv pC ntC; pose K := 'Ohm_1(<[x]>). +have prK : prime #|K| by rewrite (Ohm1_cyclic_pgroup_prime _ pC) ?cycle_cyclic. +case: (prime_subgroupVti G prK) => [sKG |]; last first. + move/TI_Ohm1; rewrite -defC (setIidPl (mulG_subl _ _)) => ->. + by left; rewrite mul1g. +case: (prime_subgroupVti H prK) => [sKH |]; last first. + move/TI_Ohm1; rewrite -defC (setIidPl (mulG_subr _ _)) => ->. + by right; rewrite mulg1. +have K1: K :=: 1 by apply/trivgP; rewrite -tiGH subsetI sKG. +by rewrite K1 cards1 in prK. +Qed. + +Lemma piOhm1 G : \pi('Ohm_1(G)) = \pi(G). +Proof. +apply/eq_piP => p; apply/idP/idP; first exact: (piSg (Ohm_sub 1 G)). +rewrite !mem_primes !cardG_gt0 => /andP[p_pr /Cauchy[] // x Gx oxp]. +by rewrite p_pr -oxp order_dvdG //= Ohm1Eprime mem_gen // inE Gx oxp. +Qed. + +Lemma Ohm1Eexponent p G : + prime p -> exponent 'Ohm_1(G) %| p -> 'Ohm_1(G) = 'Ldiv_p(G). +Proof. +move=> p_pr expG1p; have pG: p.-group G. + apply: sub_in_pnat (pnat_pi (cardG_gt0 G)) => q _. + rewrite -piOhm1 mem_primes; case/and3P=> q_pr _; apply: pgroupP q_pr. + by rewrite -pnat_exponent (pnat_dvd expG1p) ?pnat_id. +apply/eqP; rewrite eqEsubset {2}(OhmE 1 pG) subset_gen subsetI Ohm_sub. +by rewrite sub_LdivT expG1p. +Qed. + +Lemma p_rank_Ohm1 p G : 'r_p('Ohm_1(G)) = 'r_p(G). +Proof. +apply/eqP; rewrite eqn_leq p_rankS ?Ohm_sub //. +apply/bigmax_leqP=> E /setIdP[sEG abelE]. +by rewrite (bigmax_sup E) // inE -{1}(Ohm1_id abelE) OhmS. +Qed. + +Lemma rank_Ohm1 G : 'r('Ohm_1(G)) = 'r(G). +Proof. +apply/eqP; rewrite eqn_leq rankS ?Ohm_sub //. +by have [p _ ->] := rank_witness G; rewrite -p_rank_Ohm1 p_rank_le_rank. +Qed. + +Lemma p_rank_abelian p G : abelian G -> 'r_p(G) = logn p #|'Ohm_1(G)|. +Proof. +move=> cGG; have nilG := abelian_nil cGG; case p_pr: (prime p); last first. + by apply/eqP; rewrite lognE p_pr eqn0Ngt p_rank_gt0 mem_primes p_pr. +case/dprodP: (Ohm_dprod 1 (nilpotent_pcoreC p nilG)) => _ <- _ /TI_cardMg->. +rewrite mulnC logn_Gauss; last first. + rewrite prime_coprime // -p'natE // -/(pgroup _ _). + exact: pgroupS (Ohm_sub _ _) (pcore_pgroup _ _). +rewrite -(p_rank_Sylow (nilpotent_pcore_Hall p nilG)) -p_rank_Ohm1. +rewrite p_rank_abelem // Ohm1_abelem ?pcore_pgroup //. +exact: abelianS (pcore_sub _ _) cGG. +Qed. + +Lemma rank_abelian_pgroup p G : + p.-group G -> abelian G -> 'r(G) = logn p #|'Ohm_1(G)|. +Proof. by move=> pG cGG; rewrite (rank_pgroup pG) p_rank_abelian. Qed. + +End OhmProps. + +Section AbelianStructure. + +Variable gT : finGroupType. +Implicit Types (p : nat) (G H K E : {group gT}). + +Lemma abelian_splits x G : + x \in G -> #[x] = exponent G -> abelian G -> [splits G, over <[x]>]. +Proof. +move=> Gx ox cGG; apply/splitsP; move: {2}_.+1 (ltnSn #|G|) => n. +elim: n gT => // n IHn aT in x G Gx ox cGG *; rewrite ltnS => leGn. +have: <[x]> \subset G by [rewrite cycle_subG]; rewrite subEproper. +case/predU1P=> [<-|]; first by exists 1%G; rewrite inE -subG1 subsetIr mulg1 /=. +case/properP=> sxG [y]; elim: {y}_.+1 {-2}y (ltnSn #[y]) => // m IHm y. +rewrite ltnS => leym Gy x'y; case: (trivgVpdiv <[y]>) => [y1 | [p p_pr p_dv_y]]. + by rewrite -cycle_subG y1 sub1G in x'y. +case x_yp: (y ^+ p \in <[x]>); last first. + apply: IHm (negbT x_yp); rewrite ?groupX ?(leq_trans _ leym) //. + by rewrite orderXdiv // ltn_Pdiv ?prime_gt1. +have{x_yp} xp_yp: (y ^+ p \in <[x ^+ p]>). + have: <[y ^+ p]>%G \in [set <[x ^+ (#[x] %/ #[y ^+ p])]>%G]. + by rewrite -cycle_sub_group ?order_dvdG // inE cycle_subG x_yp eqxx. + rewrite inE -cycle_subG -val_eqE /=; move/eqP->. + rewrite cycle_subG orderXdiv // divnA // mulnC ox. + by rewrite -muln_divA ?dvdn_exponent ?expgM 1?groupX ?cycle_id. +have: p <= #[y] by rewrite dvdn_leq. +rewrite leq_eqVlt; case/predU1P=> [{xp_yp m IHm leym}oy | ltpy]; last first. + case/cycleP: xp_yp => k; rewrite -expgM mulnC expgM => def_yp. + suffices: #[y * x ^- k] < m. + by move/IHm; apply; rewrite groupMr // groupV groupX ?cycle_id. + apply: leq_ltn_trans (leq_trans ltpy leym). + rewrite dvdn_leq ?prime_gt0 // order_dvdn expgMn. + by rewrite expgVn def_yp mulgV. + by apply: (centsP cGG); rewrite ?groupV ?groupX. +pose Y := <[y]>; have nsYG: Y <| G by rewrite -sub_abelian_normal ?cycle_subG. +have [sYG nYG] := andP nsYG; have nYx := subsetP nYG x Gx. +have GxY: coset Y x \in G / Y by rewrite mem_morphim. +have tiYx: Y :&: <[x]> = 1 by rewrite prime_TIg ?indexg1 -?[#|_|]oy ?cycle_subG. +have: #[coset Y x] = exponent (G / Y). + apply/eqP; rewrite eqn_dvd dvdn_exponent //. + apply/exponentP=> _ /morphimP[z Nz Gz ->]. + rewrite -morphX // ((z ^+ _ =P 1) _) ?morph1 //. + rewrite orderE -quotient_cycle ?card_quotient ?cycle_subG // -indexgI /=. + by rewrite setIC tiYx indexg1 -orderE ox -order_dvdn dvdn_exponent. +case/IHn => // [||Hq]; first exact: quotient_abelian. + apply: leq_trans leGn; rewrite ltn_quotient // cycle_eq1. + by apply: contra x'y; move/eqP->; rewrite group1. +case/complP=> /= ti_x_Hq defGq. +have: Hq \subset G / Y by rewrite -defGq mulG_subr. +case/inv_quotientS=> // H defHq sYH sHG; exists H. +have nYX: <[x]> \subset 'N(Y) by rewrite cycle_subG. +rewrite inE -subG1 eqEsubset mul_subG //= -tiYx subsetI subsetIl andbT. +rewrite -{2}(mulSGid sYH) mulgA (normC nYX) -mulgA -quotientSK ?quotientMl //. +rewrite -quotient_sub1 ?(subset_trans (subsetIl _ _)) // quotientIG //= -/Y. +by rewrite -defHq quotient_cycle // ti_x_Hq defGq !subxx. +Qed. + +Lemma abelem_splits p G H : p.-abelem G -> H \subset G -> [splits G, over H]. +Proof. +elim: {G}_.+1 {-2}G H (ltnSn #|G|) => // m IHm G H. +rewrite ltnS => leGm abelG sHG; case: (eqsVneq H 1) => [-> | ]. + by apply/splitsP; exists G; rewrite inE mul1g -subG1 subsetIl /=. +case/trivgPn=> x Hx ntx; have Gx := subsetP sHG x Hx. +have [_ cGG eGp] := and3P abelG. +have ox: #[x] = exponent G. + by apply/eqP; rewrite eqn_dvd dvdn_exponent // (abelem_order_p abelG). +case/splitsP: (abelian_splits Gx ox cGG) => K; case/complP=> tixK defG. +have sKG: K \subset G by rewrite -defG mulG_subr. +have ltKm: #|K| < m. + rewrite (leq_trans _ leGm) ?proper_card //; apply/properP; split=> //. + exists x => //; apply: contra ntx => Kx; rewrite -cycle_eq1 -subG1 -tixK. + by rewrite subsetI subxx cycle_subG. +case/splitsP: (IHm _ _ ltKm (abelemS sKG abelG) (subsetIr H K)) => L. +case/complP=> tiHKL defK; apply/splitsP; exists L; rewrite inE. +rewrite -subG1 -tiHKL -setIA setIS; last by rewrite subsetI -defK mulG_subr /=. +by rewrite -(setIidPr sHG) -defG -group_modl ?cycle_subG //= setIC -mulgA defK. +Qed. + +Fact abelian_type_subproof G : + {H : {group gT} & abelian G -> {x | #[x] = exponent G & <[x]> \x H = G}}. +Proof. +case cGG: (abelian G); last by exists G. +have [x Gx ox] := exponent_witness (abelian_nil cGG). +case/splitsP/ex_mingroup: (abelian_splits Gx (esym ox) cGG) => H. +case/mingroupp/complP=> tixH defG; exists H => _. +exists x; rewrite ?dprodE // (sub_abelian_cent2 cGG) ?cycle_subG //. +by rewrite -defG mulG_subr. +Qed. + +Fixpoint abelian_type_rec n G := + if n is n'.+1 then if abelian G && (G :!=: 1) then + exponent G :: abelian_type_rec n' (tag (abelian_type_subproof G)) + else [::] else [::]. + +Definition abelian_type (A : {set gT}) := abelian_type_rec #|A| <>. + +Lemma abelian_type_dvdn_sorted A : sorted [rel m n | n %| m] (abelian_type A). +Proof. +set R := SimplRel _; pose G := <>%G. +suffices: path R (exponent G) (abelian_type A) by case: (_ A) => // m t /andP[]. +rewrite /abelian_type -/G; elim: {A}#|A| G {2 3}G (subxx G) => // n IHn G M sGM. +simpl; case: ifP => //= /andP[cGG ntG]; rewrite exponentS ?IHn //=. +case: (abelian_type_subproof G) => H /= [//| x _] /dprodP[_ /= <- _ _]. +exact: mulG_subr. +Qed. + +Lemma abelian_type_gt1 A : all [pred m | m > 1] (abelian_type A). +Proof. +rewrite /abelian_type; elim: {A}#|A| <>%G => //= n IHn G. +case: ifP => //= /andP[_ ntG]; rewrite {n}IHn. +by rewrite ltn_neqAle exponent_gt0 eq_sym -dvdn1 -trivg_exponent ntG. +Qed. + +Lemma abelian_type_sorted A : sorted geq (abelian_type A). +Proof. +have:= abelian_type_dvdn_sorted A; have:= abelian_type_gt1 A. +case: (abelian_type A) => //= m t; elim: t m => //= n t IHt m /andP[]. +by move/ltnW=> m_gt0 t_gt1 /andP[n_dv_m /IHt->]; rewrite // dvdn_leq. +Qed. + +Theorem abelian_structure G : + abelian G -> + {b | \big[dprod/1]_(x <- b) <[x]> = G & map order b = abelian_type G}. +Proof. +rewrite /abelian_type genGidG. +elim: {G}#|G| {-2 5}G (leqnn #|G|) => /= [|n IHn] G leGn cGG. + by rewrite leqNgt cardG_gt0 in leGn. +rewrite {1}cGG /=; case: ifP => [ntG|/eqP->]; last first. + by exists [::]; rewrite ?big_nil. +case: (abelian_type_subproof G) => H /= [//|x ox xdefG]; rewrite -ox. +have [_ defG cxH tixH] := dprodP xdefG. +have sHG: H \subset G by rewrite -defG mulG_subr. +case/IHn: (abelianS sHG cGG) => [|b defH <-]. + rewrite -ltnS (leq_trans _ leGn) // -defG TI_cardMg // -orderE. + rewrite ltn_Pmull ?cardG_gt0 // ltn_neqAle order_gt0 eq_sym -dvdn1. + by rewrite ox -trivg_exponent ntG. +by exists (x :: b); rewrite // big_cons defH xdefG. +Qed. + +Lemma count_logn_dprod_cycle p n b G : + \big[dprod/1]_(x <- b) <[x]> = G -> + count [pred x | logn p #[x] > n] b = logn p #|'Ohm_n.+1(G) : 'Ohm_n(G)|. +Proof. +have sOn1 := @Ohm_leq gT _ _ _ (leqnSn n). +pose lnO i (A : {set gT}) := logn p #|'Ohm_i(A)|. +have lnO_le H: lnO n H <= lnO n.+1 H. + by rewrite dvdn_leq_log ?cardG_gt0 // cardSg ?sOn1. +have lnOx i A B H: A \x B = H -> lnO i A + lnO i B = lnO i H. + move=> defH; case/dprodP: defH (defH) => {A B}[[A B -> ->]] _ _ _ defH. + rewrite /lnO; case/dprodP: (Ohm_dprod i defH) => _ <- _ tiOAB. + by rewrite TI_cardMg ?lognM. +rewrite -divgS //= logn_div ?cardSg //= -/(lnO _ _) -/(lnO _ _). +elim: b G => [_ <-|x b IHb G] /=. + by rewrite big_nil /lnO !(trivgP (Ohm_sub _ _)) subnn. +rewrite /= big_cons => defG; rewrite -!(lnOx _ _ _ _ defG) subnDA. +case/dprodP: defG => [[_ H _ defH] _ _ _] {G}; rewrite defH (IHb _ defH). +symmetry; do 2!rewrite addnC -addnBA ?lnO_le //; congr (_ + _). +pose y := x.`_p; have p_y: p.-elt y by rewrite p_elt_constt. +have{lnOx} lnOy i: lnO i <[x]> = lnO i <[y]>. + have cXX := cycle_abelian x. + have co_yx': coprime #[y] #[x.`_p^'] by rewrite !order_constt coprime_partC. + have defX: <[y]> \x <[x.`_p^']> = <[x]>. + rewrite dprodE ?coprime_TIg //. + by rewrite -cycleM ?consttC //; apply: (centsP cXX); exact: mem_cycle. + by apply: (sub_abelian_cent2 cXX); rewrite cycle_subG mem_cycle. + rewrite -(lnOx i _ _ _ defX) addnC {1}/lnO lognE. + case: and3P => // [[p_pr _ /idPn[]]]; rewrite -p'natE //. + exact: pgroupS (Ohm_sub _ _) (p_elt_constt _ _). +rewrite -logn_part -order_constt -/y !{}lnOy /lnO !(Ohm_p_cycle _ p_y). +case: leqP => [| lt_n_y]. + by rewrite -subn_eq0 -addn1 subnDA => /eqP->; rewrite subnn. +rewrite -!orderE -(subSS n) subSn // expnSr expgM. +have p_pr: prime p by move: lt_n_y; rewrite lognE; case: prime. +set m := (p ^ _)%N; have m_gt0: m > 0 by rewrite expn_gt0 prime_gt0. +suffices p_ym: p %| #[y ^+ m]. + rewrite -logn_div ?orderXdvd // (orderXdiv p_ym) divnA // mulKn //. + by rewrite logn_prime ?eqxx. +rewrite orderXdiv ?pfactor_dvdn ?leq_subr // -(dvdn_pmul2r m_gt0). +by rewrite -expnS -subSn // subSS divnK pfactor_dvdn ?leq_subr. +Qed. + +Lemma perm_eq_abelian_type p b G : + p.-group G -> \big[dprod/1]_(x <- b) <[x]> = G -> 1 \notin b -> + perm_eq (map order b) (abelian_type G). +Proof. +move: b => b1 pG defG1 ntb1. +have cGG: abelian G. + elim: (b1) {pG}G defG1 => [_ <-|x b IHb G]; first by rewrite big_nil abelian1. + rewrite big_cons; case/dprodP=> [[_ H _ defH]] <-; rewrite defH => cxH _. + by rewrite abelianM cycle_abelian IHb. +have p_bG b: \big[dprod/1]_(x <- b) <[x]> = G -> all (p_elt p) b. + elim: b {defG1 cGG}G pG => //= x b IHb G pG; rewrite big_cons. + case/dprodP=> [[_ H _ defH]]; rewrite defH andbC => defG _ _. + by rewrite -defG pgroupM in pG; case/andP: pG => p_x /IHb->. +have [b2 defG2 def_t] := abelian_structure cGG. +have ntb2: 1 \notin b2. + apply: contraL (abelian_type_gt1 G) => b2_1. + rewrite -def_t -has_predC has_map. + by apply/hasP; exists 1; rewrite //= order1. +rewrite -{}def_t; apply/allP=> m; rewrite -map_cat => /mapP[x b_x def_m]. +have{ntb1 ntb2} ntx: x != 1. + by apply: contraL b_x; move/eqP->; rewrite mem_cat negb_or ntb1 ntb2. +have p_x: p.-elt x by apply: allP (x) b_x; rewrite all_cat !p_bG. +rewrite -cycle_eq1 in ntx; have [p_pr _ [k ox]] := pgroup_pdiv p_x ntx. +apply/eqnP; rewrite {m}def_m orderE ox !count_map. +pose cnt_p k := count [pred x : gT | logn p #[x] > k]. +have cnt_b b: \big[dprod/1]_(x <- b) <[x]> = G -> + count [pred x | #[x] == p ^ k.+1]%N b = cnt_p k b - cnt_p k.+1 b. +- move/p_bG; elim: b => //= _ b IHb /andP[/p_natP[j ->] /IHb-> {IHb}]. + rewrite eqn_leq !leq_exp2l ?prime_gt1 // -eqn_leq pfactorK // leqNgt. + case: ltngtP => // _ {j}; rewrite subSn // add0n; elim: b => //= y b IHb. + by rewrite leq_add // ltn_neqAle; case: (~~ _). +by rewrite !cnt_b // /cnt_p !(@count_logn_dprod_cycle _ _ _ G). +Qed. + +Lemma size_abelian_type G : abelian G -> size (abelian_type G) = 'r(G). +Proof. +move=> cGG; have [b defG def_t] := abelian_structure cGG. +apply/eqP; rewrite -def_t size_map eqn_leq andbC; apply/andP; split. + have [p p_pr ->] := rank_witness G; rewrite p_rank_abelian //. + by rewrite -indexg1 -(Ohm0 G) -(count_logn_dprod_cycle _ _ defG) count_size. +case/lastP def_b: b => // [b' x]; pose p := pdiv #[x]. +have p_pr: prime p. + have:= abelian_type_gt1 G; rewrite -def_t def_b map_rcons -cats1 all_cat. + by rewrite /= andbT => /andP[_]; exact: pdiv_prime. +suffices: all [pred y | logn p #[y] > 0] b. + rewrite all_count (count_logn_dprod_cycle _ _ defG) -def_b; move/eqP <-. + by rewrite Ohm0 indexg1 -p_rank_abelian ?p_rank_le_rank. +apply/allP=> y; rewrite def_b mem_rcons inE /= => b_y. +rewrite lognE p_pr order_gt0 (dvdn_trans (pdiv_dvd _)) //. +case/predU1P: b_y => [-> // | b'_y]. +have:= abelian_type_dvdn_sorted G; rewrite -def_t def_b. +case/splitPr: b'_y => b1 b2; rewrite -cat_rcons rcons_cat map_cat !map_rcons. +rewrite headI /= cat_path -(last_cons 2) -headI last_rcons. +case/andP=> _ /order_path_min min_y. +apply: (allP (min_y _)) => [? ? ? ? dv|]; first exact: (dvdn_trans dv). +by rewrite mem_rcons mem_head. +Qed. + +Lemma mul_card_Ohm_Mho_abelian n G : + abelian G -> (#|'Ohm_n(G)| * #|'Mho^n(G)|)%N = #|G|. +Proof. +case/abelian_structure => b defG _. +elim: b G defG => [_ <-|x b IHb G]. + by rewrite !big_nil (trivgP (Ohm_sub _ _)) (trivgP (Mho_sub _ _)) !cards1. +rewrite big_cons => defG; rewrite -(dprod_card defG). +rewrite -(dprod_card (Ohm_dprod n defG)) -(dprod_card (Mho_dprod n defG)) /=. +rewrite mulnCA -!mulnA mulnCA mulnA; case/dprodP: defG => [[_ H _ defH] _ _ _]. +rewrite defH {b G defH IHb}(IHb H defH); congr (_ * _)%N => {H}. +elim: {x}_.+1 {-2}x (ltnSn #[x]) => // m IHm x; rewrite ltnS => lexm. +case p_x: (p_group <[x]>); last first. + case: (eqVneq x 1) p_x => [-> |]; first by rewrite cycle1 p_group1. + rewrite -order_gt1 /p_group -orderE; set p := pdiv _ => ntx p'x. + have def_x: <[x.`_p]> \x <[x.`_p^']> = <[x]>. + have ?: coprime #[x.`_p] #[x.`_p^'] by rewrite !order_constt coprime_partC. + have ?: commute x.`_p x.`_p^' by exact: commuteX2. + rewrite dprodE ?coprime_TIg -?cycleM ?consttC //. + by rewrite cent_cycle cycle_subG; exact/cent1P. + rewrite -(dprod_card (Ohm_dprod n def_x)) -(dprod_card (Mho_dprod n def_x)). + rewrite mulnCA -mulnA mulnCA mulnA. + rewrite !{}IHm ?(dprod_card def_x) ?(leq_trans _ lexm) {m lexm}//. + rewrite /order -(dprod_card def_x) -!orderE !order_constt ltn_Pmull //. + rewrite p_part -(expn0 p) ltn_exp2l 1?lognE ?prime_gt1 ?pdiv_prime //. + by rewrite order_gt0 pdiv_dvd. + rewrite proper_card // properEneq cycle_subG mem_cycle andbT. + by apply: contra (negbT p'x); move/eqP <-; exact: p_elt_constt. +case/p_groupP: p_x => p p_pr p_x. +rewrite (Ohm_p_cycle n p_x) (Mho_p_cycle n p_x) -!orderE. +set k := logn p #[x]; have ox: #[x] = (p ^ k)%N by rewrite -card_pgroup. +case: (leqP k n) => [le_k_n | lt_n_k]. + rewrite -(subnKC le_k_n) subnDA subnn expg1 expnD expgM -ox. + by rewrite expg_order expg1n order1 muln1. +rewrite !orderXgcd ox -{-3}(subnKC (ltnW lt_n_k)) expnD. +rewrite gcdnC gcdnMl gcdnC gcdnMr. +by rewrite mulnK ?mulKn ?expn_gt0 ?prime_gt0. +Qed. + +Lemma grank_abelian G : abelian G -> 'm(G) = 'r(G). +Proof. +move=> cGG; apply/eqP; rewrite eqn_leq; apply/andP; split. + rewrite -size_abelian_type //; case/abelian_structure: cGG => b defG <-. + suffices <-: <<[set x in b]>> = G. + by rewrite (leq_trans (grank_min _)) // size_map cardsE card_size. + rewrite -{G defG}(bigdprodWY defG). + elim: b => [|x b IHb]; first by rewrite big_nil gen0. + by rewrite big_cons -joingE -joing_idr -IHb joing_idl joing_idr set_cons. +have [p p_pr ->] := rank_witness G; pose K := 'Mho^1(G). +have ->: 'r_p(G) = logn p #|G / K|. + rewrite p_rank_abelian // card_quotient /= ?gFnorm // -divgS ?Mho_sub //. + by rewrite -(mul_card_Ohm_Mho_abelian 1 cGG) mulnK ?cardG_gt0. +case: (grank_witness G) => B genB <-; rewrite -genB. +have: <> \subset G by rewrite genB. +elim: {B genB}_.+1 {-2}B (ltnSn #|B|) => // m IHm B; rewrite ltnS. +case: (set_0Vmem B) => [-> | [x Bx]]. + by rewrite gen0 quotient1 cards1 logn1. +rewrite (cardsD1 x) Bx -{2 3}(setD1K Bx); set B' := B :\ x => ltB'm. +rewrite -joingE -joing_idl -joing_idr -/<[x]> join_subG => /andP[Gx sB'G]. +rewrite cent_joinEl ?(sub_abelian_cent2 cGG) //. +have nKx: x \in 'N(K) by rewrite -cycle_subG (subset_trans Gx) ?gFnorm. +rewrite quotientMl ?cycle_subG // quotient_cycle //= -/K. +have le_Kxp_1: logn p #[coset K x] <= 1. + rewrite -(dvdn_Pexp2l _ _ (prime_gt1 p_pr)) -p_part -order_constt. + rewrite order_dvdn -morph_constt // -morphX ?groupX //= coset_id //. + by rewrite Mho_p_elt ?p_elt_constt ?groupX -?cycle_subG. +apply: leq_trans (leq_add le_Kxp_1 (IHm _ ltB'm sB'G)). +by rewrite -lognM ?dvdn_leq_log ?muln_gt0 ?cardG_gt0 // mul_cardG dvdn_mulr. +Qed. + +Lemma rank_cycle (x : gT) : 'r(<[x]>) = (x != 1). +Proof. +have [->|ntx] := altP (x =P 1); first by rewrite cycle1 rank1. +apply/eqP; rewrite eqn_leq rank_gt0 cycle_eq1 ntx andbT. +by rewrite -grank_abelian ?cycle_abelian //= -(cards1 x) grank_min. +Qed. + +Lemma abelian_rank1_cyclic G : abelian G -> cyclic G = ('r(G) <= 1). +Proof. +move=> cGG; have [b defG atypG] := abelian_structure cGG. +apply/idP/idP; first by case/cyclicP=> x ->; rewrite rank_cycle leq_b1. +rewrite -size_abelian_type // -{}atypG -{}defG unlock. +by case: b => [|x []] //= _; rewrite ?cyclic1 // dprodg1 cycle_cyclic. +Qed. + +Definition homocyclic A := abelian A && constant (abelian_type A). + +Lemma homocyclic_Ohm_Mho n p G : + p.-group G -> homocyclic G -> 'Ohm_n(G) = 'Mho^(logn p (exponent G) - n)(G). +Proof. +move=> pG /andP[cGG homoG]; set e := exponent G. +have{pG} p_e: p.-nat e by apply: pnat_dvd pG; exact: exponent_dvdn. +have{homoG}: all (pred1 e) (abelian_type G). + move: homoG; rewrite /abelian_type -(prednK (cardG_gt0 G)) /=. + by case: (_ && _) (tag _); rewrite //= genGid eqxx. +have{cGG} [b defG <-] := abelian_structure cGG. +move: e => e in p_e *; elim: b => /= [|x b IHb] in G defG *. + by rewrite -defG big_nil (trivgP (Ohm_sub _ _)) (trivgP (Mho_sub _ _)). +case/andP=> /eqP ox e_b; rewrite big_cons in defG. +rewrite -(Ohm_dprod _ defG) -(Mho_dprod _ defG). +case/dprodP: defG => [[_ H _ defH] _ _ _]; rewrite defH IHb //; congr (_ \x _). +by rewrite -ox in p_e *; rewrite (Ohm_p_cycle _ p_e) (Mho_p_cycle _ p_e). +Qed. + +Lemma Ohm_Mho_homocyclic (n p : nat) G : + abelian G -> p.-group G -> 0 < n < logn p (exponent G) -> + 'Ohm_n(G) = 'Mho^(logn p (exponent G) - n)(G) -> homocyclic G. +Proof. +set e := exponent G => cGG pG /andP[n_gt0 n_lte] eq_Ohm_Mho. +suffices: all (pred1 e) (abelian_type G). + by rewrite /homocyclic cGG; exact: all_pred1_constant. +case/abelian_structure: cGG (abelian_type_gt1 G) => b defG <-. +elim: b {-3}G defG (subxx G) eq_Ohm_Mho => //= x b IHb H. +rewrite big_cons => defG; case/dprodP: defG (defG) => [[_ K _ defK]]. +rewrite defK => defHm cxK; rewrite setIC; move/trivgP=> tiKx defHd. +rewrite -{1}defHm {defHm} mulG_subG cycle_subG ltnNge -trivg_card_le1. +case/andP=> Gx sKG; rewrite -(Mho_dprod _ defHd) => /esym defMho /andP[ntx ntb]. +have{defHd} defOhm := Ohm_dprod n defHd. +apply/andP; split; last first. + apply: (IHb K) => //; have:= dprod_modr defMho (Mho_sub _ _). + rewrite -(dprod_modr defOhm (Ohm_sub _ _)). + rewrite !(trivgP (subset_trans (setIS _ _) tiKx)) ?Ohm_sub ?Mho_sub //. + by rewrite !dprod1g. +have:= dprod_modl defMho (Mho_sub _ _). +rewrite -(dprod_modl defOhm (Ohm_sub _ _)) . +rewrite !(trivgP (subset_trans (setSI _ _) tiKx)) ?Ohm_sub ?Mho_sub //. +move/eqP; rewrite eqEcard => /andP[_]. +have p_x: p.-elt x := mem_p_elt pG Gx. +have [p_pr p_dv_x _] := pgroup_pdiv p_x ntx. +rewrite !dprodg1 (Ohm_p_cycle _ p_x) (Mho_p_cycle _ p_x) -!orderE. +rewrite orderXdiv ?leq_divLR ?pfactor_dvdn ?leq_subr //. +rewrite orderXgcd divn_mulAC ?dvdn_gcdl // leq_divRL ?gcdn_gt0 ?order_gt0 //. +rewrite leq_pmul2l //; apply: contraLR. +rewrite eqn_dvd dvdn_exponent //= -ltnNge => lt_x_e. +rewrite (leq_trans (ltn_Pmull (prime_gt1 p_pr) _)) ?expn_gt0 ?prime_gt0 //. +rewrite -expnS dvdn_leq // ?gcdn_gt0 ?order_gt0 // dvdn_gcd. +rewrite pfactor_dvdn // dvdn_exp2l. + by rewrite -{2}[logn p _]subn0 ltn_sub2l // lognE p_pr order_gt0 p_dv_x. +rewrite ltn_sub2r // ltnNge -(dvdn_Pexp2l _ _ (prime_gt1 p_pr)) -!p_part. +by rewrite !part_pnat_id // (pnat_dvd (exponent_dvdn G)). +Qed. + +Lemma abelem_homocyclic p G : p.-abelem G -> homocyclic G. +Proof. +move=> abelG; have [_ cGG _] := and3P abelG. +rewrite /homocyclic cGG (@all_pred1_constant _ p) //. +case/abelian_structure: cGG (abelian_type_gt1 G) => b defG <- => b_gt1. +apply/allP=> _ /mapP[x b_x ->] /=; rewrite (abelem_order_p abelG) //. + rewrite -cycle_subG -(bigdprodWY defG) ?sub_gen //. + by rewrite bigcup_seq (bigcup_sup x). +by rewrite -order_gt1 [_ > 1](allP b_gt1) ?map_f. +Qed. + +Lemma homocyclic1 : homocyclic [1 gT]. +Proof. exact: abelem_homocyclic (abelem1 _ 2). Qed. + +Lemma Ohm1_homocyclicP p G : p.-group G -> abelian G -> + reflect ('Ohm_1(G) = 'Mho^(logn p (exponent G)).-1(G)) (homocyclic G). +Proof. +move=> pG cGG; set e := logn p (exponent G); rewrite -subn1. +apply: (iffP idP) => [homoG | ]; first exact: homocyclic_Ohm_Mho. +case: (ltnP 1 e) => [lt1e | ]; first exact: Ohm_Mho_homocyclic. +rewrite -subn_eq0 => /eqP->; rewrite Mho0 => <-. +exact: abelem_homocyclic (Ohm1_abelem pG cGG). +Qed. + +Lemma abelian_type_homocyclic G : + homocyclic G -> abelian_type G = nseq 'r(G) (exponent G). +Proof. +case/andP=> cGG; rewrite -size_abelian_type // /abelian_type. +rewrite -(prednK (cardG_gt0 G)) /=; case: andP => //= _; move: (tag _) => H. +by move/all_pred1P->; rewrite genGid size_nseq. +Qed. + +Lemma abelian_type_abelem p G : p.-abelem G -> abelian_type G = nseq 'r(G) p. +Proof. +move=> abelG; rewrite (abelian_type_homocyclic (abelem_homocyclic abelG)). +case: (eqVneq G 1%G) => [-> | ntG]; first by rewrite rank1. +congr nseq; apply/eqP; rewrite eqn_dvd; have [pG _ ->] := and3P abelG. +have [p_pr] := pgroup_pdiv pG ntG; case/Cauchy=> // x Gx <- _. +exact: dvdn_exponent. +Qed. + +Lemma max_card_abelian G : + abelian G -> #|G| <= exponent G ^ 'r(G) ?= iff homocyclic G. +Proof. +move=> cGG; have [b defG def_tG] := abelian_structure cGG. +have Gb: all (mem G) b. + apply/allP=> x b_x; rewrite -(bigdprodWY defG); have [b1 b2] := splitPr b_x. + by rewrite big_cat big_cons /= mem_gen // setUCA inE cycle_id. +have ->: homocyclic G = all (pred1 (exponent G)) (abelian_type G). + rewrite /homocyclic cGG /abelian_type; case: #|G| => //= n. + by move: (_ (tag _)) => t; case: ifP => //= _; rewrite genGid eqxx. +rewrite -size_abelian_type // -{}def_tG -{defG}(bigdprod_card defG) size_map. +rewrite unlock; elim: b Gb => //= x b IHb; case/andP=> Gx Gb. +have eGgt0: exponent G > 0 := exponent_gt0 G. +have le_x_G: #[x] <= exponent G by rewrite dvdn_leq ?dvdn_exponent. +have:= leqif_mul (leqif_eq le_x_G) (IHb Gb). +by rewrite -expnS expn_eq0 eqn0Ngt eGgt0. +Qed. + +Lemma card_homocyclic G : homocyclic G -> #|G| = (exponent G ^ 'r(G))%N. +Proof. +by move=> homG; have [cGG _] := andP homG; apply/eqP; rewrite max_card_abelian. +Qed. + +Lemma abelian_type_dprod_homocyclic p K H G : + K \x H = G -> p.-group G -> homocyclic G -> + abelian_type K = nseq 'r(K) (exponent G) + /\ abelian_type H = nseq 'r(H) (exponent G). +Proof. +move=> defG pG homG; have [cGG _] := andP homG. +have /mulG_sub[sKG sHG]: K * H = G by case/dprodP: defG. +have [cKK cHH] := (abelianS sKG cGG, abelianS sHG cGG). +suffices: all (pred1 (exponent G)) (abelian_type K ++ abelian_type H). + rewrite all_cat => /andP[/all_pred1P-> /all_pred1P->]. + by rewrite !size_abelian_type. +suffices def_atG: abelian_type K ++ abelian_type H =i abelian_type G. + rewrite (eq_all_r def_atG); apply/all_pred1P. + by rewrite size_abelian_type // -abelian_type_homocyclic. +have [bK defK atK] := abelian_structure cKK. +have [bH defH atH] := abelian_structure cHH. +apply: perm_eq_mem; rewrite -atK -atH -map_cat. +apply: (perm_eq_abelian_type pG); first by rewrite big_cat defK defH. +have: all [pred m | m > 1] (map order (bK ++ bH)). + by rewrite map_cat all_cat atK atH !abelian_type_gt1. +by rewrite all_map (eq_all (@order_gt1 _)) all_predC has_pred1. +Qed. + +Lemma dprod_homocyclic p K H G : + K \x H = G -> p.-group G -> homocyclic G -> homocyclic K /\ homocyclic H. +Proof. +move=> defG pG homG; have [cGG _] := andP homG. +have /mulG_sub[sKG sHG]: K * H = G by case/dprodP: defG. +have [abtK abtH] := abelian_type_dprod_homocyclic defG pG homG. +by rewrite /homocyclic !(abelianS _ cGG) // abtK abtH !constant_nseq. +Qed. + +Lemma exponent_dprod_homocyclic p K H G : + K \x H = G -> p.-group G -> homocyclic G -> K :!=: 1 -> + exponent K = exponent G. +Proof. +move=> defG pG homG ntK; have [homK _] := dprod_homocyclic defG pG homG. +have [] := abelian_type_dprod_homocyclic defG pG homG. +by rewrite abelian_type_homocyclic // -['r(K)]prednK ?rank_gt0 => [[]|]. +Qed. + +End AbelianStructure. + +Arguments Scope abelian_type [_ group_scope]. +Arguments Scope homocyclic [_ group_scope]. +Prenex Implicits abelian_type homocyclic. + +Section IsogAbelian. + +Variables aT rT : finGroupType. +Implicit Type (gT : finGroupType) (D G : {group aT}) (H : {group rT}). + +Lemma isog_abelian_type G H : isog G H -> abelian_type G = abelian_type H. +Proof. +pose lnO p n gT (A : {set gT}) := logn p #|'Ohm_n.+1(A) : 'Ohm_n(A)|. +pose lni i p gT (A : {set gT}) := \max_(e < logn p #|A| | i < lnO p e _ A) e.+1. +suffices{G} nth_abty gT (G : {group gT}) i: + abelian G -> i < size (abelian_type G) -> + nth 1%N (abelian_type G) i = (\prod_(p < #|G|.+1) p ^ lni i p _ G)%N. +- move=> isoGH; case cGG: (abelian G); last first. + rewrite /abelian_type -(prednK (cardG_gt0 G)) -(prednK (cardG_gt0 H)) /=. + by rewrite {1}(genGid G) {1}(genGid H) -(isog_abelian isoGH) cGG. + have cHH: abelian H by rewrite -(isog_abelian isoGH). + have eq_sz: size (abelian_type G) = size (abelian_type H). + by rewrite !size_abelian_type ?(isog_rank isoGH). + apply: (@eq_from_nth _ 1%N) => // i lt_i_G; rewrite !nth_abty // -?eq_sz //. + rewrite /lni (card_isog isoGH); apply: eq_bigr => p _; congr (p ^ _)%N. + apply: eq_bigl => e; rewrite /lnO -!divgS ?(Ohm_leq _ (leqnSn _)) //=. + by have:= card_isog (gFisog _ isoGH) => /= eqF; rewrite !eqF. +move=> cGG. +have (p): path leq 0 (map (logn p) (rev (abelian_type G))). + move: (abelian_type_gt1 G) (abelian_type_dvdn_sorted G). + case: abelian_type => //= m t; rewrite rev_cons map_rcons. + elim: t m => //= n t IHt m /andP[/ltnW m_gt0 nt_gt1]. + rewrite -cats1 cat_path rev_cons map_rcons last_rcons /=. + by case/andP=> /dvdn_leq_log-> // /IHt->. +have{cGG} [b defG <- b_sorted] := abelian_structure cGG. +rewrite size_map => ltib; rewrite (nth_map 1 _ _ ltib); set x := nth 1 b i. +have Gx: x \in G. + have: x \in b by rewrite mem_nth. + rewrite -(bigdprodWY defG); case/splitPr=> bl br. + by rewrite mem_gen // big_cat big_cons !inE cycle_id orbT. +have lexG: #[x] <= #|G| by rewrite dvdn_leq ?order_dvdG. +rewrite -[#[x]]partn_pi // (widen_partn _ lexG) big_mkord big_mkcond. +apply: eq_bigr => p _; transitivity (p ^ logn p #[x])%N. + by rewrite -logn_gt0; case: posnP => // ->. +suffices lti_lnO e: (i < lnO p e _ G) = (e < logn p #[x]). + congr (p ^ _)%N; apply/eqP; rewrite eqn_leq andbC; apply/andP; split. + by apply/bigmax_leqP=> e; rewrite lti_lnO. + case: (posnP (logn p #[x])) => [-> // | logx_gt0]. + have lexpG: (logn p #[x]).-1 < logn p #|G|. + by rewrite prednK // dvdn_leq_log ?order_dvdG. + by rewrite (@bigmax_sup _ (Ordinal lexpG)) ?(prednK, lti_lnO). +rewrite /lnO -(count_logn_dprod_cycle _ _ defG). +case: (ltnP e _) (b_sorted p) => [lt_e_x | le_x_e]. + rewrite -(cat_take_drop i.+1 b) -map_rev rev_cat !map_cat cat_path. + case/andP=> _ ordb; rewrite count_cat ((count _ _ =P i.+1) _) ?leq_addr //. + rewrite -{2}(size_takel ltib) -all_count. + move: ordb; rewrite (take_nth 1 ltib) -/x rev_rcons all_rcons /= lt_e_x. + case/andP=> _ /=; move/(order_path_min leq_trans); apply: contraLR. + rewrite -!has_predC !has_map; case/hasP=> y b_y /= le_y_e; apply/hasP. + by exists y; rewrite ?mem_rev //=; apply: contra le_y_e; exact: leq_trans. +rewrite -(cat_take_drop i b) -map_rev rev_cat !map_cat cat_path. +case/andP=> ordb _; rewrite count_cat -{1}(size_takel (ltnW ltib)) ltnNge. +rewrite addnC ((count _ _ =P 0) _) ?count_size //. +rewrite eqn0Ngt -has_count; apply/hasPn=> y b_y /=; rewrite -leqNgt. +apply: leq_trans le_x_e; have ->: x = last x (rev (drop i b)). + by rewrite (drop_nth 1 ltib) rev_cons last_rcons. +rewrite -mem_rev in b_y; case/splitPr: (rev _) / b_y ordb => b1 b2. +rewrite !map_cat cat_path last_cat /=; case/and3P=> _ _. +move/(order_path_min leq_trans); case/lastP: b2 => // b3 x'. +by move/allP; apply; rewrite ?map_f ?last_rcons ?mem_rcons ?mem_head. +Qed. + +Lemma eq_abelian_type_isog G H : + abelian G -> abelian H -> isog G H = (abelian_type G == abelian_type H). +Proof. +move=> cGG cHH; apply/idP/eqP; first exact: isog_abelian_type. +have{cGG} [bG defG <-] := abelian_structure cGG. +have{cHH} [bH defH <-] := abelian_structure cHH. +elim: bG bH G H defG defH => [|x bG IHb] [|y bH] // G H. + rewrite !big_nil => <- <- _. + by rewrite isog_cyclic_card ?cyclic1 ?cards1. +rewrite !big_cons => defG defH /= [eqxy eqb]. +apply: (isog_dprod defG defH). + by rewrite isog_cyclic_card ?cycle_cyclic -?orderE ?eqxy /=. +case/dprodP: defG => [[_ G' _ defG]] _ _ _; rewrite defG. +case/dprodP: defH => [[_ H' _ defH]] _ _ _; rewrite defH. +exact: IHb eqb. +Qed. + +Lemma isog_abelem_card p G H : + p.-abelem G -> isog G H = p.-abelem H && (#|H| == #|G|). +Proof. +move=> abelG; apply/idP/andP=> [isoGH | [abelH eqGH]]. + by rewrite -(isog_abelem isoGH) (card_isog isoGH). +rewrite eq_abelian_type_isog ?(@abelem_abelian _ p) //. +by rewrite !(@abelian_type_abelem _ p) ?(@rank_abelem _ p) // (eqP eqGH). +Qed. + +Variables (D : {group aT}) (f : {morphism D >-> rT}). + +Lemma morphim_rank_abelian G : abelian G -> 'r(f @* G) <= 'r(G). +Proof. +move=> cGG; have sHG := subsetIr D G; apply: leq_trans (rankS sHG). +rewrite -!grank_abelian ?morphim_abelian ?(abelianS sHG) //=. +by rewrite -morphimIdom morphim_grank ?subsetIl. +Qed. + +Lemma morphim_p_rank_abelian p G : abelian G -> 'r_p(f @* G) <= 'r_p(G). +Proof. +move=> cGG; have sHG := subsetIr D G; apply: leq_trans (p_rankS p sHG). +have cHH := abelianS sHG cGG; rewrite -morphimIdom /=; set H := D :&: G. +have sylP := nilpotent_pcore_Hall p (abelian_nil cHH). +have sPH := pHall_sub sylP. +have sPD: 'O_p(H) \subset D by rewrite (subset_trans sPH) ?subsetIl. +rewrite -(p_rank_Sylow (morphim_pHall f sPD sylP)) -(p_rank_Sylow sylP) //. +rewrite -!rank_pgroup ?morphim_pgroup ?pcore_pgroup //. +by rewrite morphim_rank_abelian ?(abelianS sPH). +Qed. + +Lemma isog_homocyclic G H : G \isog H -> homocyclic G = homocyclic H. +Proof. +move=> isoGH. +by rewrite /homocyclic (isog_abelian isoGH) (isog_abelian_type isoGH). +Qed. + +End IsogAbelian. + +Section QuotientRank. + +Variables (gT : finGroupType) (p : nat) (G H : {group gT}). +Hypothesis cGG : abelian G. + +Lemma quotient_rank_abelian : 'r(G / H) <= 'r(G). +Proof. exact: morphim_rank_abelian. Qed. + +Lemma quotient_p_rank_abelian : 'r_p(G / H) <= 'r_p(G). +Proof. exact: morphim_p_rank_abelian. Qed. + +End QuotientRank. + + + + diff --git a/mathcomp/solvable/all.v b/mathcomp/solvable/all.v new file mode 100644 index 0000000..72405c5 --- /dev/null +++ b/mathcomp/solvable/all.v @@ -0,0 +1,19 @@ +Require Export abelian. +Require Export alt. +Require Export burnside_app. +Require Export center. +Require Export commutator. +Require Export extraspecial. +Require Export extremal. +Require Export finmodule. +Require Export frobenius. +Require Export gfunctor. +Require Export gseries. +Require Export hall. +Require Export jordanholder. +Require Export maximal. +Require Export nilpotent. +Require Export pgroup. +Require Export primitive_action. +Require Export sylow. +Require Export wielandt_fixpoint. diff --git a/mathcomp/solvable/alt.v b/mathcomp/solvable/alt.v new file mode 100644 index 0000000..3f12ad7 --- /dev/null +++ b/mathcomp/solvable/alt.v @@ -0,0 +1,528 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +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) addnC; 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. diff --git a/mathcomp/solvable/burnside_app.v b/mathcomp/solvable/burnside_app.v new file mode 100644 index 0000000..8fe0b3f --- /dev/null +++ b/mathcomp/solvable/burnside_app.v @@ -0,0 +1,1305 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype. +Require Import tuple finfun bigop finset fingroup action perm primitive_action. + +(* Application of the Burside formula to count the number of distinct *) +(* colorings of the vertices of a square and a cube. *) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Lemma burnside_formula : forall (gT : finGroupType) s (G : {group gT}), + uniq s -> s =i G -> + forall (sT : finType) (to : {action gT &-> sT}), + (#|orbit to G @: setT| * size s)%N = \sum_(p <- s) #|'Fix_to[p]|. +Proof. +move=> gT s G Us sG sT to. +rewrite big_uniq // -(card_uniqP Us) (eq_card sG) -Frobenius_Cauchy. + by apply: eq_big => // p _; rewrite setTI. +by apply/actsP=> ? _ ?; rewrite !inE. +Qed. + +Implicit Arguments burnside_formula [gT]. + +Section colouring. + +Variable n : nat. +Definition colors := 'I_n. +Canonical colors_eqType := Eval hnf in [eqType of colors]. +Canonical colors_choiceType := Eval hnf in [choiceType of colors]. +Canonical colors_countType := Eval hnf in [countType of colors]. +Canonical colors_finType := Eval hnf in [finType of colors]. + +Section square_colouring. + +Definition square := 'I_4. +Canonical square_eqType := Eval hnf in [eqType of square]. +Canonical square_choiceType := Eval hnf in [choiceType of square]. +Canonical square_countType := Eval hnf in [countType of square]. +Canonical square_finType := Eval hnf in [finType of square]. +Canonical square_subType := Eval hnf in [subType of square]. +Canonical square_subCountType := + Eval hnf in [subCountType of square]. +Canonical square_subFinType := Eval hnf in [subFinType of square]. + +Definition mksquare i : square := Sub (i %% _) (ltn_mod i 4). +Definition c0 := mksquare 0. +Definition c1 := mksquare 1. +Definition c2 := mksquare 2. +Definition c3 := mksquare 3. + +(*rotations*) +Definition R1 (sc : square) : square := tnth [tuple c1; c2; c3; c0] sc. + +Definition R2 (sc : square) : square := tnth [tuple c2; c3; c0; c1] sc. + +Definition R3 (sc : square) : square := tnth [tuple c3; c0; c1; c2] sc. + +Ltac get_inv elt l := + match l with + | (_, (elt, ?x)) => x + | (elt, ?x) => x + | (?x, _) => get_inv elt x + end. + +Definition rot_inv := ((R1, R3), (R2, R2), (R3, R1)). + +Ltac inj_tac := + move: (erefl rot_inv); unfold rot_inv; + match goal with |- ?X = _ -> injective ?Y => + move=> _; let x := get_inv Y X in + apply: (can_inj (g:=x)); move => [val H1] + end. + +Lemma R1_inj : injective R1. +Proof. by inj_tac; repeat (destruct val => //=; first by apply /eqP). Qed. + +Lemma R2_inj : injective R2. +Proof. by inj_tac; repeat (destruct val => //=; first by apply /eqP). Qed. + +Lemma R3_inj : injective R3. +Proof. by inj_tac; repeat (destruct val => //=; first by apply /eqP). Qed. + +Definition r1 := (perm R1_inj). +Definition r2 := (perm R2_inj). +Definition r3 := (perm R3_inj). +Definition id1 := (1 : {perm square}). + +Definition is_rot (r : {perm _}) := (r * r1 == r1 * r). +Definition rot := [set r | is_rot r]. + +Lemma group_set_rot : group_set rot. +Proof. +apply /group_setP;split; first by rewrite /rot inE /is_rot mulg1 mul1g. +move => x1 y; rewrite /rot !inE /= /is_rot; move/eqP => hx1; move/eqP => hy. +by rewrite -mulgA hy !mulgA hx1. +Qed. + +Canonical rot_group := Group group_set_rot. + +Definition rotations := [set id1; r1; r2; r3]. + +Lemma rot_eq_c0 : forall r s : {perm square}, + is_rot r -> is_rot s -> r c0 = s c0 -> r = s. +Proof. +rewrite /is_rot => r s; move/eqP => hr; move/eqP=> hs hrs; apply/permP => a. +have ->: a = (r1 ^+ a) c0 + by apply/eqP; case: a; do 4?case => //=; rewrite ?permM !permE. +by rewrite -!permM -!commuteX // !permM hrs. +Qed. + +Lemma rot_r1 : forall r, is_rot r -> r = r1 ^+ (r c0). +Proof. +move=> r hr;apply: rot_eq_c0 => //;apply/eqP. + by symmetry; exact: commuteX. +by case: (r c0); do 4?case => //=; rewrite ?permM !permE /=. +Qed. + +Lemma rotations_is_rot : forall r, r \in rotations -> is_rot r. +Proof. +move=> r Dr; apply/eqP; apply/permP => a; rewrite !inE -!orbA !permM in Dr *. +by case/or4P: Dr; move/eqP->; rewrite !permE //; case: a; do 4?case. +Qed. + +Lemma rot_is_rot : rot = rotations. +Proof. +apply/setP=> r; apply/idP/idP; last by move/rotations_is_rot; rewrite inE. +rewrite !inE => h. +have -> : r = r1 ^+ (r c0) by apply: rot_eq_c0; rewrite // -rot_r1. +have e2: 2 = r2 c0 by rewrite permE /=. +have e3: 3 = r3 c0 by rewrite permE /=. +case (r c0); do 4?[case] => // ?; rewrite ?(expg1, eqxx, orbT) //. + by rewrite [nat_of_ord _]/= e2 -rot_r1 ?(eqxx, orbT, rotations_is_rot, inE). +by rewrite [nat_of_ord _]/= e3 -rot_r1 ?(eqxx, orbT, rotations_is_rot, inE). +Qed. + +(*symmetries*) +Definition Sh (sc : square) : square := tnth [tuple c1; c0; c3; c2] sc. + +Lemma Sh_inj : injective Sh. +Proof. +by apply:(can_inj (g:= Sh)); case; do 4?case => //=;move=> H;apply /eqP. +Qed. + +Definition sh := (perm Sh_inj). + +Lemma sh_inv : sh^-1 = sh. +Proof. +apply:(mulIg sh);rewrite mulVg ;apply/permP. +by case; do 4?case => //=; move=> H;rewrite !permE /= !permE; apply /eqP. +Qed. + +Definition Sv (sc : square) : square := tnth [tuple c3; c2; c1; c0] sc. + +Lemma Sv_inj : injective Sv. +Proof. +by apply : (can_inj (g:= Sv));case; do 4?case => //=;move => H;apply /eqP. +Qed. + +Definition sv := (perm Sv_inj). + +Lemma sv_inv : sv^-1 = sv. +Proof. +apply:(mulIg sv);rewrite mulVg ;apply/permP. +by case; do 4?case => //=; move=> H; rewrite !permE /= !permE; apply /eqP. +Qed. + +Definition Sd1 (sc : square) : square := tnth [tuple c0; c3; c2; c1] sc. + +Lemma Sd1_inj : injective Sd1. +Proof. +by apply: can_inj Sd1 _; case; do 4?case=> //=; move=> H; apply /eqP. +Qed. + +Definition sd1 := (perm Sd1_inj). + +Lemma sd1_inv : sd1^-1 = sd1. +Proof. +apply: (mulIg sd1); rewrite mulVg; apply/permP. +by case; do 4?case=> //=; move=> H; rewrite !permE /= !permE; apply /eqP. +Qed. + +Definition Sd2 (sc : square) : square := tnth [tuple c2; c1; c0; c3] sc. + +Lemma Sd2_inj : injective Sd2. +Proof. +by apply: can_inj Sd2 _; case; do 4?case=> //=; move=> H; apply /eqP. +Qed. + +Definition sd2 := (perm Sd2_inj). + +Lemma sd2_inv : sd2^-1 = sd2. +Proof. +apply: (mulIg sd2); rewrite mulVg; apply/permP. +by case; do 4?case=> //=; move=> H; rewrite !permE /= !permE; apply/eqP. +Qed. + +Lemma ord_enum4 : enum 'I_4 = [:: c0; c1; c2; c3]. +Proof. by apply: (inj_map val_inj); rewrite val_enum_ord. Qed. + +Lemma diff_id_sh : 1 != sh. +Proof. +by apply/eqP; move/(congr1 (fun p : {perm square} => p c0)); rewrite !permE. +Qed. + +Definition isometries2 := [set 1; sh]. + +Lemma card_iso2 : #|isometries2| = 2. +Proof. by rewrite cards2 diff_id_sh. Qed. + +Lemma group_set_iso2 : group_set isometries2. +Proof. +apply/group_setP; split => [|x y]; rewrite !inE ?eqxx //. +do 2![case/orP; move/eqP->]; gsimpl; rewrite ?(eqxx, orbT) //. +by rewrite -/sh -{1}sh_inv mulVg eqxx. +Qed. +Canonical iso2_group := Group group_set_iso2. + +Definition isometries := + [set p | [|| p == 1, p == r1, p == r2, p == r3, + p == sh, p == sv, p == sd1 | p == sd2 ]]. + +Definition opp (sc : square) := tnth [tuple c2; c3; c0; c1] sc. + +Definition is_iso (p : {perm square}) := forall ci, p (opp ci) = opp (p ci). + +Lemma isometries_iso : forall p, p \in isometries -> is_iso p. +Proof. +move=> p; rewrite inE. +by do ?case/orP; move/eqP=> -> a; rewrite !permE; case: a; do 4?case. +Qed. + +Ltac non_inj p a1 a2 heq1 heq2 := +let h1:= fresh "h1" in +(absurd (p a1 = p a2);first (by red; move=> h1;move:(perm_inj h1)); +by rewrite heq1 heq2;apply/eqP). + +Ltac is_isoPtac p f e0 e1 e2 e3 := + suff ->: p = f by [rewrite inE eqxx ?orbT]; + let e := fresh "e" in apply/permP; + do 5?[case] => // ?; [move: e0 | move: e1 | move: e2 | move: e3] => e; + apply: etrans (congr1 p _) (etrans e _); apply/eqP; rewrite // permE. + +Lemma is_isoP : forall p, reflect (is_iso p) (p \in isometries). +Proof. +move=> p; apply: (iffP idP) => [|iso_p]; first exact: isometries_iso. +move e1: (p c1) (iso_p c1) => k1; move e0: (p c0) (iso_p c0) k1 e1 => k0. +case: k0 e0; do 4?[case] => //= ? e0 e2; do 5?[case] => //= ? e1 e3; + try by [non_inj p c0 c1 e0 e1 | non_inj p c0 c3 e0 e3]. +by is_isoPtac p id1 e0 e1 e2 e3. +by is_isoPtac p sd1 e0 e1 e2 e3. +by is_isoPtac p sh e0 e1 e2 e3. +by is_isoPtac p r1 e0 e1 e2 e3. +by is_isoPtac p sd2 e0 e1 e2 e3. +by is_isoPtac p r2 e0 e1 e2 e3. +by is_isoPtac p r3 e0 e1 e2 e3. +by is_isoPtac p sv e0 e1 e2 e3. +Qed. + + +Lemma group_set_iso : group_set isometries. +Proof. +apply/group_setP; split; first by rewrite inE eqxx /=. +by move=> x y hx hy; apply/is_isoP => ci; rewrite !permM !isometries_iso. +Qed. + +Canonical iso_group := Group group_set_iso. + +Lemma card_rot : #|rot| = 4. +Proof. +rewrite -[4]/(size [:: id1; r1; r2; r3]) -(card_uniqP _). + by apply: eq_card => x; rewrite rot_is_rot !inE -!orbA. +by apply: map_uniq (fun p : {perm square} => p c0) _ _; rewrite /= !permE. +Qed. + +Lemma group_set_rotations : group_set rotations. +Proof. by rewrite -rot_is_rot group_set_rot. Qed. + +Canonical rotations_group := Group group_set_rotations. + +Notation col_squares := {ffun square -> colors}. + +Definition act_f (sc : col_squares) (p : {perm square}) : col_squares := + [ffun z => sc (p^-1 z)]. + +Lemma act_f_1 : forall k, act_f k 1 = k. +Proof. by move=> k; apply/ffunP=> a; rewrite ffunE invg1 permE. Qed. + +Lemma act_f_morph : forall k x y, act_f k (x * y) = act_f (act_f k x) y. +Proof. by move=> k x y; apply/ffunP=> a; rewrite !ffunE invMg permE. Qed. + +Definition to := TotalAction act_f_1 act_f_morph. + +Definition square_coloring_number2 := #|orbit to isometries2 @: setT|. +Definition square_coloring_number4 := #|orbit to rotations @: setT|. +Definition square_coloring_number8 := #|orbit to isometries @: setT|. + +Lemma Fid : 'Fix_to(1) = setT. +Proof. apply/setP=> x /=; rewrite in_setT; apply/afix1P; exact: act1. Qed. + +Lemma card_Fid : #|'Fix_to(1)| = (n ^ 4)%N. +Proof. +rewrite -[4]card_ord -[n]card_ord -card_ffun_on Fid cardsE. +by symmetry; apply: eq_card => f; exact/ffun_onP. +Qed. + +Definition coin0 (sc : col_squares) : colors := sc c0. +Definition coin1 (sc : col_squares) : colors := sc c1. +Definition coin2 (sc : col_squares) : colors := sc c2. +Definition coin3 (sc : col_squares) : colors := sc c3. + +Lemma eqperm_map : forall p1 p2 : col_squares, + (p1 == p2) = all (fun s => p1 s == p2 s) [:: c0; c1; c2; c3]. +Proof. +move=> p1 p2; apply/eqP/allP=> [-> // | Ep12]; apply/ffunP=> x. +by apply/eqP; apply Ep12; case: x; do 4!case=> //. +Qed. + +Lemma F_Sh : + 'Fix_to[sh] = [set x | (coin0 x == coin1 x) && (coin2 x == coin3 x)]. +Proof. +apply/setP=> x; rewrite (sameP afix1P eqP) !inE eqperm_map /=. +rewrite /act_f sh_inv !ffunE !permE /=. +by rewrite eq_sym (eq_sym (x c3)) andbT andbA !andbb. +Qed. + +Lemma F_Sv : + 'Fix_to[sv] = [set x | (coin0 x == coin3 x) && (coin2 x == coin1 x)]. +Proof. +apply/setP=> x; rewrite (sameP afix1P eqP) !inE eqperm_map /=. +rewrite /act_f sv_inv !ffunE !permE /=. +by rewrite eq_sym andbT andbC (eq_sym (x c1)) andbA -andbA !andbb andbC. +Qed. + +Ltac inv_tac := + apply: esym (etrans _ (mul1g _)); apply: canRL (mulgK _) _; + let a := fresh "a" in apply/permP => a; + apply/eqP; rewrite permM !permE; case: a; do 4?case. + +Lemma r1_inv : r1^-1 = r3. +Proof. by inv_tac. Qed. + +Lemma r2_inv : r2^-1 = r2. +Proof. by inv_tac. Qed. + +Lemma r3_inv : r3^-1 = r1. +Proof. by inv_tac. Qed. + +Lemma F_r2 : + 'Fix_to[r2] = [set x | (coin0 x == coin2 x) && (coin1 x == coin3 x)]. +Proof. +apply/setP=> x; rewrite (sameP afix1P eqP) !inE eqperm_map /=. +rewrite /act_f r2_inv !ffunE !permE /=. +by rewrite eq_sym andbT andbCA andbC (eq_sym (x c3)) andbA -andbA !andbb andbC. +Qed. + +Lemma F_r1 : 'Fix_to[r1] = + [set x | (coin0 x == coin1 x)&&(coin1 x == coin2 x)&&(coin2 x == coin3 x)]. +Proof. +apply/setP=> x; rewrite (sameP afix1P eqP) !inE eqperm_map /=. +rewrite /act_f r1_inv !ffunE !permE andbC. +by do 3![case E: {+}(_ == _); rewrite // {E}(eqP E)]; rewrite eqxx. +Qed. + +Lemma F_r3 : 'Fix_to[r3] = + [set x | (coin0 x == coin1 x)&&(coin1 x == coin2 x)&&(coin2 x == coin3 x)]. +Proof. +apply/setP=> x; rewrite (sameP afix1P eqP) !inE eqperm_map /=. +rewrite /act_f r3_inv !ffunE !permE /=. +by do 3![rewrite eq_sym; case E: {+}(_ == _); rewrite // {E}(eqP E)]. +Qed. + +Lemma card_n2 : forall x y z t : square, uniq [:: x; y; z; t] -> + #|[set p : col_squares | (p x == p y) && (p z == p t)]| = (n ^ 2)%N. +Proof. +move=> x y z t Uxt; rewrite -[n]card_ord. +pose f (p : col_squares) := (p x, p z); rewrite -(@card_in_image _ _ f). + rewrite -mulnn -card_prod; apply: eq_card => [] [c d] /=; apply/imageP. + rewrite (cat_uniq [::x; y]) in Uxt; case/and3P: Uxt => _. + rewrite /= !orbF !andbT; case/norP; rewrite !inE => nxzt nyzt _. + exists [ffun i => if pred2 x y i then c else d]. + by rewrite inE !ffunE /= !eqxx orbT (negbTE nxzt) (negbTE nyzt) !eqxx. + by rewrite {}/f !ffunE /= eqxx (negbTE nxzt). +move=> p1 p2; rewrite !inE. +case/andP=> p1y p1t; case/andP=> p2y p2t [px pz]. +have eqp12: all (fun i => p1 i == p2 i) [:: x; y; z; t]. + by rewrite /= -(eqP p1y) -(eqP p1t) -(eqP p2y) -(eqP p2t) px pz !eqxx. +apply/ffunP=> i; apply/eqP; apply: (allP eqp12). +by rewrite (subset_cardP _ (subset_predT _)) // (card_uniqP Uxt) card_ord. +Qed. + +Lemma card_n : + #|[set x | (coin0 x == coin1 x)&&(coin1 x == coin2 x)&& (coin2 x == coin3 x)]| + = n. +Proof. +rewrite -[n]card_ord /coin0 /coin1 /coin2 /coin3. +pose f (p : col_squares) := p c3; rewrite -(@card_in_image _ _ f). + apply: eq_card => c /=; apply/imageP. + exists ([ffun => c] : col_squares); last by rewrite /f ffunE. + by rewrite /= inE !ffunE !eqxx. +move=> p1 p2; rewrite /= !inE /f -!andbA => eqp1 eqp2 eqp12. +apply/eqP; rewrite eqperm_map /= andbT. +case/and3P: eqp1; do 3!move/eqP->; case/and3P: eqp2; do 3!move/eqP->. +by rewrite !andbb eqp12. +Qed. + +Lemma burnside_app2 : (square_coloring_number2 * 2 = n ^ 4 + n ^ 2)%N. +Proof. +rewrite (burnside_formula [:: id1; sh]) => [||p]; last first. +- by rewrite !inE. +- by rewrite /= inE diff_id_sh. +by rewrite 2!big_cons big_nil addn0 {1}card_Fid F_Sh card_n2. +Qed. + +Lemma burnside_app_rot : + (square_coloring_number4 * 4 = n ^ 4 + n ^ 2 + 2 * n)%N. +Proof. +rewrite (burnside_formula [:: id1; r1; r2; r3]) => [||p]; last first. +- by rewrite !inE !orbA. +- by apply: map_uniq (fun p : {perm square} => p c0) _ _; rewrite /= !permE. +rewrite !big_cons big_nil /= addn0 {1}card_Fid F_r1 F_r2 F_r3. +by rewrite card_n card_n2 //=; ring. +Qed. + +Lemma F_Sd1 : 'Fix_to[sd1] = [set x | coin1 x == coin3 x]. +Proof. +apply/setP => x; rewrite (sameP afix1P eqP) !inE eqperm_map /=. +rewrite /act_f sd1_inv !ffunE !permE /=. +by rewrite !eqxx !andbT eq_sym /= andbb. +Qed. + +Lemma card_n3 : forall x y : square, x != y -> + #|[set k : col_squares | k x == k y]| = (n ^ 3)%N. +Proof. +move=> x y nxy; apply/eqP; case: (ltngtP n 0) => // [|n0]; last first. + by rewrite n0; apply/existsP=> [] [p _]; case: (p c0) => i; rewrite n0. +move/eqn_pmul2l <-; rewrite -expnS -card_Fid Fid cardsT. +rewrite -{1}[n]card_ord -cardX. +pose pk k := [ffun i => k (if i == y then x else i) : colors]. +rewrite -(@card_image _ _ (fun k : col_squares => (k y, pk k))). + apply/eqP; apply: eq_card => ck /=; rewrite inE /= [_ \in _]inE. + apply/eqP/imageP; last first. + by case=> k _ -> /=; rewrite !ffunE if_same eqxx. + case: ck => c k /= kxy. + exists [ffun i => if i == y then c else k i]; first by rewrite inE. + rewrite !ffunE eqxx; congr (_, _); apply/ffunP=> i; rewrite !ffunE. + case Eiy: (i == y); last by rewrite Eiy. + by rewrite (negbTE nxy) (eqP Eiy). +move=> k1 k2 [Eky Epk]; apply/ffunP=> i. +have{Epk}: pk k1 i = pk k2 i by rewrite Epk. +by rewrite !ffunE; case: eqP => // ->. +Qed. + +Lemma F_Sd2 : 'Fix_to[sd2] = [set x | coin0 x == coin2 x]. +Proof. +apply/setP => x; rewrite (sameP afix1P eqP) !inE eqperm_map /=. +by rewrite /act_f sd2_inv !ffunE !permE /= !eqxx !andbT eq_sym /= andbb. +Qed. + +Lemma burnside_app_iso : + (square_coloring_number8 * 8 = n ^ 4 + 2 * n ^ 3 + 3 * n ^ 2 + 2 * n)%N. +Proof. +pose iso_list := [:: id1; r1; r2; r3; sh; sv; sd1; sd2]. +rewrite (burnside_formula iso_list) => [||p]; last first. +- by rewrite /= !inE. +- apply: map_uniq (fun p : {perm square} => (p c0, p c1)) _ _. + by rewrite /= !permE. +rewrite !big_cons big_nil {1}card_Fid F_r1 F_r2 F_r3 F_Sh F_Sv F_Sd1 F_Sd2. +by rewrite card_n !card_n3 // !card_n2 //=; ring. +Qed. + +End square_colouring. + +Section cube_colouring. + +Definition cube := 'I_6. +Canonical cube_eqType := Eval hnf in [eqType of cube]. +Canonical cube_choiceType := Eval hnf in [choiceType of cube]. +Canonical cube_countType := Eval hnf in [countType of cube]. +Canonical cube_finType := Eval hnf in [finType of cube]. +Canonical cube_subType := Eval hnf in [subType of cube]. +Canonical cube_subCountType := Eval hnf in [subCountType of cube]. +Canonical cube_subFinType := Eval hnf in [subFinType of cube]. + +Definition mkFcube i : cube := Sub (i %% 6) (ltn_mod i 6). +Definition F0 := mkFcube 0. +Definition F1 := mkFcube 1. +Definition F2 := mkFcube 2. +Definition F3 := mkFcube 3. +Definition F4 := mkFcube 4. +Definition F5 := mkFcube 5. + +(* axial symetries*) +Definition S05 := [:: F0; F4; F3; F2; F1; F5]. +Definition S05f (sc : cube) : cube := tnth [tuple of S05] sc. + + +Definition S14 := [:: F5; F1; F3; F2; F4; F0]. +Definition S14f (sc : cube) : cube := tnth [tuple of S14] sc. + +Definition S23 := [:: F5; F4; F2; F3; F1; F0]. +Definition S23f (sc : cube) : cube := tnth [tuple of S23] sc. + +(* rotations 90 *) +Definition R05 := [:: F0; F2; F4; F1; F3; F5]. +Definition R05f (sc : cube) : cube := tnth [tuple of R05] sc. +Definition R50 := [:: F0; F3; F1; F4; F2; F5]. +Definition R50f (sc : cube) : cube := tnth [tuple of R50] sc. +Definition R14 := [:: F3; F1; F0; F5; F4; F2]. +Definition R14f (sc : cube) : cube := tnth [tuple of R14] sc. +Definition R41 := [:: F2; F1; F5; F0; F4; F3]. +Definition R41f (sc : cube) : cube := tnth [tuple of R41] sc. +Definition R23 := [:: F1; F5; F2; F3; F0; F4]. +Definition R23f (sc : cube) : cube := tnth [tuple of R23] sc. +Definition R32 := [:: F4; F0; F2; F3; F5; F1]. +Definition R32f (sc : cube) : cube := tnth [tuple of R32] sc. +(* rotations 120 *) +Definition R024 := [:: F2; F5; F4; F1; F0; F3]. +Definition R024f (sc : cube) : cube := tnth [tuple of R024] sc. +Definition R042 := [:: F4; F3; F0; F5; F2; F1]. +Definition R042f (sc : cube) : cube := tnth [tuple of R042] sc. +Definition R012 := [:: F1; F2; F0; F5; F3; F4]. +Definition R012f (sc : cube) : cube := tnth [tuple of R012] sc. +Definition R021 := [:: F2; F0; F1; F4; F5; F3]. +Definition R021f (sc : cube) : cube := tnth [tuple of R021] sc. +Definition R031 := [:: F3; F0; F4; F1; F5; F2]. +Definition R031f (sc : cube) : cube := tnth [tuple of R031] sc. +Definition R013 := [:: F1; F3; F5; F0; F2; F4]. +Definition R013f (sc : cube) : cube := tnth [tuple of R013] sc. +Definition R043 := [:: F4; F2; F5; F0; F3; F1]. +Definition R043f (sc : cube) : cube := tnth [tuple of R043] sc. +Definition R034 := [:: F3; F5; F1; F4; F0; F2]. +Definition R034f (sc : cube) : cube := tnth [tuple of R034] sc. +(* last symmetries*) +Definition S1 := [:: F5; F2; F1; F4; F3; F0]. +Definition S1f (sc : cube) : cube := tnth [tuple of S1] sc. +Definition S2 := [:: F5; F3; F4; F1; F2; F0]. +Definition S2f (sc : cube) : cube := tnth [tuple of S2] sc. +Definition S3 := [:: F1; F0; F3; F2; F5; F4]. +Definition S3f (sc : cube) : cube := tnth [tuple of S3] sc. +Definition S4 := [:: F4; F5; F3; F2; F0; F1]. +Definition S4f (sc : cube) : cube := tnth [tuple of S4] sc. +Definition S5 := [:: F2; F4; F0; F5; F1; F3]. +Definition S5f (sc : cube) : cube := tnth [tuple of S5] sc. +Definition S6 := [::F3; F4; F5; F0; F1; F2]. +Definition S6f (sc : cube) : cube := tnth [tuple of S6] sc. + +Lemma S1_inv : involutive S1f. +Proof. by move=> z; apply/eqP; case: z; do 6?case. Qed. + +Lemma S2_inv : involutive S2f. +Proof. by move=> z; apply /eqP; case: z; do 6?case. Qed. + +Lemma S3_inv : involutive S3f. +Proof. by move=> z; apply /eqP; case: z; do 6?case. Qed. + +Lemma S4_inv : involutive S4f. +Proof. by move=> z; apply /eqP; case: z; do 6?case. Qed. + +Lemma S5_inv : involutive S5f. +Proof. by move=> z; apply /eqP; case: z; do 6?case. Qed. + +Lemma S6_inv : involutive S6f. +Proof. by move=> z; apply /eqP; case: z; do 6?case. Qed. + +Lemma S05_inj : injective S05f. +Proof. by apply: can_inj S05f _ => z; apply/eqP; case: z; do 6?case. Qed. + +Lemma S14_inj : injective S14f. +Proof. by apply: can_inj S14f _ => z; apply/eqP; case: z; do 6?case. Qed. + +Lemma S23_inv : involutive S23f. +Proof. by move=> z; apply/eqP; case: z; do 6?case. Qed. + +Lemma R05_inj : injective R05f. +Proof. by apply: can_inj R50f _ => z; apply/eqP; case: z; do 6?case. Qed. + +Lemma R14_inj : injective R14f. +Proof. by apply: can_inj R41f _ => z; apply/eqP; case: z; do 6?case. Qed. + +Lemma R23_inj : injective R23f. +Proof. by apply: can_inj R32f _ => z; apply/eqP; case: z; do 6?case. Qed. + +Lemma R50_inj : injective R50f. +Proof. by apply: can_inj R05f _ => z; apply/eqP; case: z; do 6?case. Qed. + +Lemma R41_inj : injective R41f. +Proof. by apply: can_inj R14f _ => z; apply/eqP; case: z; do 6?case. Qed. + +Lemma R32_inj : injective R32f. +Proof. by apply: can_inj R23f _ => z; apply /eqP; case: z; do 6?case. Qed. + +Lemma R024_inj : injective R024f. +Proof. by apply: can_inj R042f _ => z; apply /eqP; case: z ; do 6?case. Qed. + +Lemma R042_inj : injective R042f. +Proof. by apply: can_inj R024f _ => z; apply/eqP; case: z; do 6?case. Qed. + +Lemma R012_inj : injective R012f. +Proof. by apply: can_inj R021f _ => z; apply/eqP; case: z; do 6?case. Qed. + +Lemma R021_inj : injective R021f. +Proof. by apply: can_inj R012f _ => z; apply/eqP; case: z; do 6?case. Qed. + +Lemma R031_inj : injective R031f. +Proof. by apply: can_inj R013f _ => z; apply/eqP; case: z; do 6?case. Qed. + + +Lemma R013_inj : injective R013f. +Proof. by apply: can_inj R031f _ => z; apply/eqP; case: z; do 6?case. Qed. + +Lemma R043_inj : injective R043f. +Proof. by apply: can_inj R034f _ => z; apply/eqP; case: z; do 6?case. Qed. + +Lemma R034_inj : injective R034f. +Proof. by apply: can_inj R043f _ => z; apply/eqP; case: z; do 6?case. Qed. + +Definition id3 := 1 : {perm cube}. + +Definition s05 := (perm S05_inj). + +Definition s14 : {perm cube}. +Proof. +apply: (@perm _ S14f); apply: can_inj S14f _ => z. +by apply /eqP; case: z; do 6?case. +Defined. + +Definition s23 := (perm (inv_inj S23_inv)). +Definition r05 := (perm R05_inj). +Definition r14 := (perm R14_inj). +Definition r23 := (perm R23_inj). +Definition r50 := (perm R50_inj). +Definition r41 := (perm R41_inj). +Definition r32 := (perm R32_inj). +Definition r024 := (perm R024_inj). +Definition r042 := (perm R042_inj). +Definition r012 := (perm R012_inj). +Definition r021 := (perm R021_inj). +Definition r031 := (perm R031_inj). +Definition r013 := (perm R013_inj). +Definition r043 := (perm R043_inj). +Definition r034 := (perm R034_inj). + +Definition s1 := (perm (inv_inj S1_inv)). +Definition s2 := (perm (inv_inj S2_inv)). +Definition s3 := (perm (inv_inj S3_inv)). +Definition s4 := (perm (inv_inj S4_inv)). +Definition s5 := (perm (inv_inj S5_inv)). +Definition s6 := (perm (inv_inj S6_inv)). + +Definition dir_iso3 := [set p | +[|| id3 == p, s05 == p, s14 == p, s23 == p, r05 == p, r14 == p, r23 == p, + r50 == p, r41 == p, r32 == p, r024 == p, r042 == p, r012 == p, r021 == p, + r031 == p, r013 == p, r043 == p, r034 == p, + s1 == p, s2 == p, s3 == p, s4 == p, s5 == p | s6 == p]]. + +Definition dir_iso3l := [:: id3; s05; s14; s23; r05; r14; r23; r50; r41; + r32; r024; r042; r012; r021; r031; r013; r043 ; r034; + s1 ; s2; s3; s4; s5; s6]. + +Definition S0 := [:: F5; F4; F3; F2; F1; F0]. +Definition S0f (sc : cube) : cube := tnth [tuple of S0] sc. + +Lemma S0_inv : involutive S0f. +Proof. by move=> z; apply/eqP; case: z; do 6?case. Qed. + +Definition s0 := (perm (inv_inj S0_inv)). + +Definition is_iso3 (p : {perm cube}) := forall fi, p (s0 fi) = s0 (p fi). + +Lemma dir_iso_iso3 : forall p, p \in dir_iso3 -> is_iso3 p. +Proof. +move=> p; rewrite inE. +by do ?case/orP; move/eqP=> <- a; rewrite !permE; case: a; do 6?case. +Qed. + +Lemma iso3_ndir : forall p, p \in dir_iso3 -> is_iso3 (s0 * p). +Proof. +move=> p; rewrite inE. +by do ?case/orP; move/eqP=> <- a; rewrite !(permM, permE); case: a; do 6?case. +Qed. + +Definition sop (p : {perm cube}) : seq cube := val (val (val p)). + +Lemma sop_inj : injective sop. +Proof. do 2!apply: (inj_comp val_inj); exact: val_inj. Qed. + +Definition prod_tuple (t1 t2 : seq cube) := + map (fun n : 'I_6 => nth F0 t2 n) t1. + +Lemma sop_spec : forall x (n0 : 'I_6), nth F0 (sop x) n0 = x n0. +Proof. by move=> x n0; rewrite -pvalE unlock enum_rank_ord (tnth_nth F0). Qed. + +Lemma prod_t_correct : forall (x y : {perm cube}) (i : cube), + (x * y) i = nth F0 (prod_tuple (sop x) (sop y)) i. +Proof. +move=> x y i; rewrite permM -!sop_spec (nth_map F0) // size_tuple /=. +by rewrite card_ord ltn_ord. +Qed. + +Lemma sop_morph : {morph sop : x y / x * y >-> prod_tuple x y}. +Proof. +move=> x y; apply: (@eq_from_nth _ F0) => [|/= i]. + by rewrite size_map !size_tuple. +rewrite size_tuple card_ord => lti6. +by rewrite -[i]/(val (Ordinal lti6)) sop_spec -prod_t_correct. +Qed. + +Definition ecubes : seq cube := [:: F0; F1; F2; F3; F4; F5]. + +Lemma ecubes_def : ecubes = enum (@predT cube). +Proof. by apply: (inj_map val_inj); rewrite val_enum_ord. Qed. + +Definition seq_iso_L := [:: + [:: F0; F1; F2; F3; F4; F5]; + S05; S14; S23; R05; R14; R23; R50; R41; R32; + R024; R042; R012; R021; R031; R013; R043; R034; + S1; S2; S3; S4; S5; S6]. + +Lemma seqs1 : forall f injf, sop (@perm _ f injf) = map f ecubes. +Proof. +move=> f ?; rewrite ecubes_def /sop /= -codom_ffun pvalE. +apply: eq_codom; exact: permE. +Qed. + +Lemma Lcorrect : seq_iso_L == map sop [:: id3; s05; s14; s23; r05; r14; r23; + r50; r41; r32; r024; r042; r012; r021; r031; r013; r043 ; r034; + s1 ; s2; s3; s4; s5; s6]. +Proof. by rewrite /= !seqs1. Qed. + +Lemma iso0_1 : dir_iso3 =i dir_iso3l. +Proof. by move=> p; rewrite /= !inE /= -!(eq_sym p). Qed. + +Lemma L_iso : forall p, (p \in dir_iso3) = (sop p \in seq_iso_L). +Proof. +move=> p; rewrite (eqP Lcorrect) mem_map ?iso0_1 //; exact: sop_inj. +Qed. + +Lemma stable : forall x y, + x \in dir_iso3 -> y \in dir_iso3 -> x * y \in dir_iso3. +Proof. +move=> x y; rewrite !L_iso sop_morph => Hx Hy. +by move/sop: y Hy; apply/allP; move/sop: x Hx; apply/allP; vm_compute. +Qed. + +Lemma iso_eq_F0_F1 : forall r s : {perm cube}, r \in dir_iso3 -> + s \in dir_iso3 -> r F0 = s F0 -> r F1 = s F1 -> r = s. +Proof. +move=> r s; rewrite !L_iso => hr hs hrs0 hrs1; apply: sop_inj; apply/eqP. +move/eqP: hrs0; apply/implyP; move/eqP: hrs1; apply/implyP; rewrite -!sop_spec. +by move/sop: r hr; apply/allP; move/sop: s hs; apply/allP; vm_compute. +Qed. + +Lemma ndir_s0p : forall p, p \in dir_iso3 -> s0 * p \notin dir_iso3. +Proof. +move=> p; rewrite !L_iso sop_morph seqs1. +by move/sop: p; apply/allP; vm_compute. +Qed. + +Definition indir_iso3l := map (mulg s0) dir_iso3l. + +Definition iso3l := dir_iso3l ++ indir_iso3l. + +Definition seq_iso3_L := map sop iso3l. + +Lemma eqperm : forall p1 p2 : {perm cube}, + (p1 == p2) = all (fun s => p1 s == p2 s) ecubes. +Proof. +move=> p1 p2; apply/eqP/allP=> [-> // | Ep12]; apply/permP=> x. +by apply/eqP; rewrite Ep12 // ecubes_def mem_enum. +Qed. + +Lemma iso_eq_F0_F1_F2 : forall r s : {perm cube}, is_iso3 r -> + is_iso3 s -> r F0 = s F0 -> r F1 = s F1 -> r F2 = s F2 -> r = s. +Proof. +move=> r s hr hs hrs0 hrs1 hrs2. +have:= hrs0; have:= hrs1; have:= hrs2. +have e23: F2 = s0 F3 by apply/eqP; rewrite permE /S0f (tnth_nth F0). +have e14: F1 = s0 F4 by apply/eqP; rewrite permE /S0f (tnth_nth F0). +have e05: F0 = s0 F5 by apply/eqP; rewrite permE /S0f (tnth_nth F0). +rewrite e23 e14 e05; rewrite !hr !hs. +move/perm_inj=> hrs3; move/perm_inj=> hrs4; move/perm_inj=> hrs5. +by apply/eqP; rewrite eqperm /= hrs0 hrs1 hrs2 hrs3 hrs4 hrs5 !eqxx. +Qed. + +Ltac iso_tac := + let a := fresh "a" in apply/permP => a; + apply/eqP; rewrite !permM !permE; case: a; do 6? case. + +Ltac inv_tac := + apply: esym (etrans _ (mul1g _)); apply: canRL (mulgK _) _; iso_tac. + +Lemma dir_s0p : forall p, (s0 * p) \in dir_iso3 -> p \notin dir_iso3. +Proof. +move => p Hs0p; move: (ndir_s0p Hs0p); rewrite mulgA. +have e: (s0^-1=s0) by inv_tac. +by rewrite -{1}e mulVg mul1g. +Qed. + +Definition is_iso3b p := (p * s0 == s0 * p). +Definition iso3 := [set p | is_iso3b p]. + +Lemma is_iso3P : forall p, reflect (is_iso3 p) (p \in iso3). +Proof. +move => p; apply: (iffP idP); rewrite inE /iso3 /is_iso3b /is_iso3 => e. + by move => fi; rewrite -!permM (eqP e). +by apply/eqP;apply/permP=> z; rewrite !permM (e z). +Qed. + +Lemma group_set_iso3 : group_set iso3. +Proof. +apply /group_setP;split. + by apply/is_iso3P => fi; rewrite -!permM mulg1 mul1g. +move => x1 y; rewrite /iso3 !inE /= /is_iso3. +rewrite /is_iso3b. +rewrite -mulgA. +move/eqP => hx1; move/eqP => hy. +rewrite hy !mulgA. by rewrite -hx1. +Qed. + +Canonical iso_group3 := Group group_set_iso3. + +Lemma group_set_diso3 : group_set dir_iso3. +Proof. +apply/group_setP;split;first by rewrite inE eqxx /=. +by exact:stable. +Qed. +Canonical diso_group3 := Group group_set_diso3. + +Lemma gen_diso3 : dir_iso3 = <<[set r05; r14]>>. +Proof. +apply/setP; apply/subset_eqP;apply/andP; split;first last. + by rewrite gen_subG;apply/subsetP => x; rewrite !inE; + case/orP; move/eqP ->; rewrite eqxx !orbT. +apply/subsetP => x; rewrite !inE. +have -> : s05 = r05 * r05 by iso_tac. +have -> : s14 = r14 * r14 by iso_tac. +have -> : s23 = r14 * r14 * r05 * r05 by iso_tac. +have -> : r23 = r05 * r14 * r05 * r14 * r14 by iso_tac. +have -> : r50 = r05 * r05 * r05 by iso_tac. +have -> : r41 = r14 * r14 * r14 by iso_tac. +have -> : r32 = r14 * r14 * r14 * r05* r14 by iso_tac. +have -> : r024 = r05 * r14 * r14 * r14 by iso_tac. +have -> : r042 = r14 * r05 * r05 * r05 by iso_tac. +have -> : r012 = r14 * r05 by iso_tac. +have -> : r021 = r05 * r14 * r05 * r05 by iso_tac. +have -> : r031 = r05 * r14 by iso_tac. +have -> : r013 = r05 * r05 * r14 * r05 by iso_tac. +have -> : r043 = r14 * r14 * r14 * r05 by iso_tac. +have -> : r034 = r05 * r05 * r05 * r14 by iso_tac. +have -> : s1 = r14 * r14 * r05 by iso_tac. +have -> : s2 = r05 * r14 * r14 by iso_tac. +have -> : s3 = r05 * r14 * r05 by iso_tac. +have -> : s4 = r05 * r14 * r14 * r14 * r05 by iso_tac. +have -> : s5 = r14 * r05 * r05 by iso_tac. +have -> : s6 = r05 * r05 * r14 by iso_tac. +do ?case/predU1P=> [<-|]; first exact: group1; last (move/eqP => <-); + by rewrite ?groupMl ?mem_gen // !inE eqxx ?orbT. +Qed. + +Notation col_cubes := {ffun cube -> colors}. + +Definition act_g (sc : col_cubes) (p : {perm cube}) : col_cubes := + [ffun z => sc (p^-1 z)]. + +Lemma act_g_1 : forall k, act_g k 1 = k. +Proof. by move=> k; apply/ffunP=> a; rewrite ffunE invg1 permE. Qed. + +Lemma act_g_morph : forall k x y, act_g k (x * y) = act_g (act_g k x) y. +Proof. by move=> k x y; apply/ffunP=> a; rewrite !ffunE invMg permE. Qed. + +Definition to_g := TotalAction act_g_1 act_g_morph. + +Definition cube_coloring_number24 := #|orbit to_g diso_group3 @: setT|. + +Lemma Fid3 : 'Fix_to_g[1] = setT. +Proof. by apply/setP=> x /=; rewrite (sameP afix1P eqP) !inE act1 eqxx. Qed. + +Lemma card_Fid3 : #|'Fix_to_g[1]| = (n ^ 6)%N. +Proof. +rewrite -[6]card_ord -[n]card_ord -card_ffun_on Fid3 cardsT. +by symmetry; apply: eq_card => ff; exact/ffun_onP. +Qed. + +Definition col0 (sc : col_cubes) : colors := sc F0. +Definition col1 (sc : col_cubes) : colors := sc F1. +Definition col2 (sc : col_cubes) : colors := sc F2. +Definition col3 (sc : col_cubes) : colors := sc F3. +Definition col4 (sc : col_cubes) : colors := sc F4. +Definition col5 (sc : col_cubes) : colors := sc F5. + +Lemma eqperm_map2 : forall p1 p2 : col_cubes, + (p1 == p2) = all (fun s => p1 s == p2 s) [:: F0; F1; F2; F3; F4; F5]. +Proof. +move=> p1 p2; apply/eqP/allP=> [-> // | Ep12]; apply/ffunP=> x. +by apply/eqP; apply Ep12; case: x; do 6?case. +Qed. + +Notation infE := (sameP afix1P eqP). + +Lemma F_s05 : + 'Fix_to_g[s05] = [set x | (col1 x == col4 x) && (col2 x == col3 x)]. +Proof. +have s05_inv: s05^-1=s05 by inv_tac. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g s05_inv !ffunE !permE /=. +apply sym_equal; rewrite !eqxx /= andbT/col1/col2/col3/col4/col5/col0. +by do 2![rewrite eq_sym; case : {+}(_ == _)=> //= ]. +Qed. + +Lemma F_s14 : + 'Fix_to_g[s14]= [set x | (col0 x == col5 x) && (col2 x == col3 x)]. +Proof. +have s14_inv: s14^-1=s14 by inv_tac. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g s14_inv !ffunE !permE /=. +apply sym_equal; rewrite !eqxx /= andbT/col1/col2/col3/col4/col5/col0. +by do 2![rewrite eq_sym; case : {+}(_ == _)=> //= ]. +Qed. + +Lemma r05_inv : r05^-1 = r50. +Proof. by inv_tac. Qed. + +Lemma r50_inv : r50^-1 = r05. +Proof. by inv_tac. Qed. + +Lemma r14_inv : r14^-1 = r41. +Proof. by inv_tac. Qed. + +Lemma r41_inv : r41^-1 = r14. +Proof. by inv_tac. Qed. + +Lemma s23_inv : s23^-1 = s23. +Proof. by inv_tac. Qed. + +Lemma F_s23 : + 'Fix_to_g[s23] = [set x | (col0 x == col5 x) && (col1 x == col4 x)]. +Proof. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g s23_inv !ffunE !permE /=. +apply sym_equal; rewrite !eqxx /= andbT/col1/col2/col3/col4/col5/col0. +by do 2![rewrite eq_sym; case : {+}(_ == _)=> //=]. +Qed. + +Lemma F_r05 : 'Fix_to_g[r05]= + [set x | (col1 x == col2 x) && (col2 x == col3 x) + && (col3 x == col4 x)]. +Proof. +apply sym_equal. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g r05_inv !ffunE !permE /=. +rewrite !eqxx /= !andbT /col1/col2/col3/col4/col5/col0. +by do 3! [rewrite eq_sym;case E: {+}(_ == _); rewrite ?andbF // {E}(eqP E) ]. +Qed. + +Lemma F_r50 : 'Fix_to_g[r50]= + [set x | (col1 x == col2 x) && (col2 x == col3 x) + && (col3 x == col4 x)]. +Proof. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g r50_inv !ffunE !permE /=. +apply sym_equal;rewrite !eqxx /= !andbT /col1/col2/col3/col4. +by do 3![rewrite eq_sym;case E: {+}(_ == _); rewrite ?andbF // {E}(eqP E) ]. +Qed. + +Lemma F_r23 : 'Fix_to_g[r23] = + [set x | (col0 x == col1 x) && (col1 x == col4 x) + && (col4 x == col5 x)]. +Proof. +have r23_inv: r23^-1 = r32 by inv_tac. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g r23_inv !ffunE !permE /=. +apply sym_equal; rewrite !eqxx /= !andbT /col1/col0/col5/col4. +by do 3![rewrite eq_sym; case E: {+}(_ == _); rewrite ?andbF // {E}(eqP E)]. +Qed. + +Lemma F_r32 : 'Fix_to_g[r32] = + [set x | (col0 x == col1 x) && (col1 x == col4 x) + && (col4 x == col5 x)]. +Proof. +have r32_inv: r32^-1 = r23 by inv_tac. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g r32_inv !ffunE !permE /=. +apply sym_equal; rewrite !eqxx /= !andbT /col1/col0/col5/col4. +by do 3![rewrite eq_sym; case E: {+}(_ == _); rewrite ?andbF // {E}(eqP E)]. +Qed. + +Lemma F_r14 : 'Fix_to_g[r14] = + [set x | (col0 x == col2 x) && (col2 x == col3 x) && (col3 x == col5 x)]. +Proof. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g r14_inv !ffunE !permE /=. +apply sym_equal; rewrite !eqxx /= !andbT /col2/col0/col5/col3. +by do 3![rewrite eq_sym; case E: {+}(_ == _); rewrite ?andbF // {E}(eqP E)]. +Qed. + +Lemma F_r41 : 'Fix_to_g[r41] = + [set x | (col0 x == col2 x) && (col2 x == col3 x) && (col3 x == col5 x)]. +Proof. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g r41_inv !ffunE !permE /=. +apply sym_equal; rewrite !eqxx /= !andbT /col2/col0/col5/col3. +by do 3![rewrite eq_sym; case E: {+}(_ == _); rewrite ?andbF // {E}(eqP E)]. +Qed. + +Lemma F_r024 : 'Fix_to_g[r024] = + [set x | (col0 x == col4 x) && (col4 x == col2 x) && (col1 x == col3 x) + && (col3 x == col5 x) ]. +Proof. +have r024_inv: r024^-1 = r042 by inv_tac. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g r024_inv !ffunE !permE /=. +apply sym_equal; rewrite ?eqxx /= !andbT /col0/col1/col2/col3/col4/col5. +by do 4![rewrite eq_sym; case E: {+}(_ == _); rewrite ?andbF // ?{E}(eqP E)]. +Qed. + +Lemma F_r042 : 'Fix_to_g[r042] = + [set x | (col0 x == col4 x) && (col4 x == col2 x) && (col1 x == col3 x) + && (col3 x == col5 x)]. +Proof. +have r042_inv: r042^-1 = r024 by inv_tac. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g r042_inv !ffunE !permE /=. +apply sym_equal; rewrite ?eqxx /= !andbT /col0/col1/col2/col3/col4/col5. +by do 4![rewrite eq_sym; case E: {+}(_ == _); rewrite ?andbF // ?{E}(eqP E)]. +Qed. + +Lemma F_r012 : 'Fix_to_g[r012] = + [set x | (col0 x == col2 x) && (col2 x == col1 x) && (col3 x == col4 x) + && (col4 x == col5 x)]. +Proof. +have r012_inv: r012^-1 = r021 by inv_tac. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g r012_inv !ffunE !permE /=. +apply sym_equal; rewrite ?eqxx /= !andbT /col0/col1/col2/col3/col4/col5. +by do 4![rewrite eq_sym; case E: {+}(_ == _); rewrite ?andbF // ?{E}(eqP E)]. +Qed. + +Lemma F_r021 : 'Fix_to_g[r021] = + [set x | (col0 x == col2 x) && (col2 x == col1 x) && (col3 x == col4 x) + && (col4 x == col5 x)]. +Proof. +have r021_inv: r021^-1 = r012 by inv_tac. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g r021_inv !ffunE !permE /=. +apply sym_equal; rewrite ?eqxx /= !andbT /col0/col1/col2/col3/col4/col5. +do 4![rewrite eq_sym; case E: {+}(_ == _); rewrite ?andbF // ?{E}(eqP E)]. +Qed. + +Lemma F_r031 : 'Fix_to_g[r031] = + [set x | (col0 x == col3 x) && (col3 x == col1 x) && (col2 x == col4 x) + && (col4 x == col5 x)]. +Proof. +have r031_inv: r031^-1 = r013 by inv_tac. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g r031_inv !ffunE !permE /=. +apply sym_equal; rewrite ?eqxx /= !andbT /col0/col1/col2/col3/col4/col5. +by do 4![rewrite eq_sym; case E: {+}(_ == _); rewrite ?andbF // ?{E}(eqP E)]. +Qed. + +Lemma F_r013 : 'Fix_to_g[r013] = + [set x | (col0 x == col3 x) && (col3 x == col1 x) && (col2 x == col4 x) + && (col4 x == col5 x)]. +Proof. +have r013_inv: r013^-1 = r031 by inv_tac. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g r013_inv !ffunE !permE /=. +apply sym_equal; rewrite ?eqxx /= !andbT /col0/col1/col2/col3/col4/col5. +by do 4![rewrite eq_sym; case E: {+}(_ == _); rewrite ?andbF // ?{E}(eqP E)]. +Qed. + +Lemma F_r043 : 'Fix_to_g[r043] = + [set x | (col0 x == col4 x) && (col4 x == col3 x) && (col1 x == col2 x) + && (col2 x == col5 x)]. +Proof. +have r043_inv: r043^-1 = r034 by inv_tac. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g r043_inv !ffunE !permE /=. +apply sym_equal; rewrite ?eqxx /= !andbT /col0/col1/col2/col3/col4/col5. +by do 4![rewrite eq_sym; case E: {+}(_ == _); rewrite ?andbF // ?{E}(eqP E)]. +Qed. + +Lemma F_r034 : 'Fix_to_g[r034] = + [set x | (col0 x == col4 x) && (col4 x == col3 x) && (col1 x == col2 x) + && (col2 x == col5 x)]. +Proof. +have r034_inv: r034^-1 = r043 by inv_tac. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g r034_inv !ffunE !permE /=. +apply sym_equal; rewrite ?eqxx /= !andbT /col0/col1/col2/col3/col4/col5. +by do 4![rewrite eq_sym; case E: {+}(_ == _); rewrite ?andbF // ?{E}(eqP E)]. +Qed. + +Lemma F_s1 : 'Fix_to_g[s1] = + [set x | (col0 x == col5 x) && (col1 x == col2 x) && (col3 x == col4 x)]. +Proof. +have s1_inv: s1^-1 = s1 by inv_tac. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g s1_inv !ffunE !permE /=. +apply sym_equal; rewrite ?eqxx /= !andbT /col0/col1/col2/col3/col4/col5. +by do 3![rewrite eq_sym; case E: {+}(_ == _); rewrite ?andbF // ?{E}(eqP E)]. +Qed. + +Lemma F_s2 : 'Fix_to_g[s2] = + [set x | (col0 x == col5 x) && (col1 x == col3 x) && (col2 x == col4 x)]. +Proof. +have s2_inv: s2^-1 = s2 by inv_tac. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g s2_inv !ffunE !permE /=. +apply sym_equal; rewrite ?eqxx /= !andbT /col0/col1/col2/col3/col4/col5. +by do 3![rewrite eq_sym; case E: {+}(_ == _); rewrite ?andbF // ?{E}(eqP E)]. +Qed. + +Lemma F_s3 : 'Fix_to_g[s3] = + [set x | (col0 x == col1 x) && (col2 x == col3 x) && (col4 x == col5 x)]. +Proof. +have s3_inv: s3^-1 = s3 by inv_tac. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g s3_inv !ffunE !permE /=. +apply sym_equal; rewrite ?eqxx /= !andbT /col0/col1/col2/col3/col4/col5. +by do 3![rewrite eq_sym; case E: {+}(_ == _); rewrite ?andbF // ?{E}(eqP E)]. +Qed. + +Lemma F_s4 : 'Fix_to_g[s4] = + [set x | (col0 x == col4 x) && (col1 x == col5 x) && (col2 x == col3 x)]. +Proof. +have s4_inv: s4^-1 = s4 by inv_tac. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g s4_inv !ffunE !permE /=. +apply sym_equal; rewrite ?eqxx /= !andbT /col0/col1/col2/col3/col4/col5. +by do 3![rewrite eq_sym; case E: {+}(_ == _); rewrite ?andbF // ?{E}(eqP E)]. +Qed. + +Lemma F_s5 : 'Fix_to_g[s5] = + [set x | (col0 x == col2 x) && (col1 x == col4 x) && (col3 x == col5 x)]. +Proof. +have s5_inv: s5^-1 = s5 by inv_tac. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g s5_inv !ffunE !permE /=. +apply sym_equal; rewrite ?eqxx /= !andbT /col0/col1/col2/col3/col4/col5. +by do 3![rewrite eq_sym; case E: {+}(_ == _); rewrite ?andbF // ?{E}(eqP E)]. +Qed. + +Lemma F_s6 : 'Fix_to_g[s6] = + [set x | (col0 x == col3 x) && (col1 x == col4 x) && (col2 x == col5 x)]. +Proof. +have s6_inv: s6^-1 = s6 by inv_tac. +apply/setP => x; rewrite infE !inE eqperm_map2 /= /act_g s6_inv !ffunE !permE /=. +apply sym_equal; rewrite ?eqxx /= !andbT /col0/col1/col2/col3/col4/col5. +by do 3![rewrite eq_sym; case E: {+}(_ == _); rewrite ?andbF // ?{E}(eqP E)]. +Qed. + +Lemma uniq4_uniq6 : forall x y z t : cube, + uniq [:: x; y; z; t] -> exists u, exists v, uniq [:: x; y; z; t; u; v]. +Proof. +move => x y z t Uxt; move:( cardC (mem [:: x; y; z; t])). +rewrite card_ord (card_uniq_tuple Uxt) => hcard. +have hcard2: #|predC (mem [:: x; y; z; t])| = 2. + by apply:( @addnI 4); rewrite /injective hcard. +have: #|predC (mem [:: x; y; z; t])| != 0 by rewrite hcard2. +case/existsP=> u Hu; exists u. +move: (cardC (mem [:: x; y; z; t; u])); rewrite card_ord => hcard5. +have: #|[predC [:: x; y; z; t; u]]| !=0. + rewrite -lt0n -(ltn_add2l #|[:: x; y; z; t; u]|) hcard5 addn0. + by apply: (leq_ltn_trans (card_size [:: x; y; z; t; u])). +case/existsP=> v; rewrite inE (mem_cat _ [:: _; _; _; _]). +case/norP=> Hv Huv; exists v. +rewrite (cat_uniq [:: x; y; z; t]) Uxt andTb. +by rewrite -rev_uniq /= negb_or Hu orbF Hv Huv. +Qed. + +Lemma card_n4 : forall x y z t : cube, uniq [:: x; y; z; t] -> + #|[set p : col_cubes | (p x == p y) && (p z == p t)]| = (n ^ 4)%N. +Proof. +move=> x y z t Uxt. rewrite -[n]card_ord . +case:(uniq4_uniq6 Uxt) => u; case => v Uxv. +pose ff (p : col_cubes) := (p x, p z, p u , p v). +rewrite -(@card_in_image _ _ ff); first last. + move=> p1 p2; rewrite !inE. + case/andP=> p1y p1t; case/andP=> p2y p2t [px pz] pu pv. + have eqp12: all (fun i => p1 i == p2 i) [:: x; y; z; t; u ; v]. + by rewrite /= -(eqP p1y) -(eqP p1t) -(eqP p2y) -(eqP p2t) px pz pu pv !eqxx. + apply/ffunP=> i; apply/eqP; apply: (allP eqp12). + by rewrite (subset_cardP _ (subset_predT _)) // (card_uniqP Uxv) card_ord. +have ->:forall n, (n ^ 4)%N= (n*n*n*n)%N. + by move => n0;rewrite (expnD n0 2 2) -mulnn mulnA. +rewrite -!card_prod; apply: eq_card => [] [[[c d]e ]g] /=; apply/imageP. +rewrite (cat_uniq [::x; y;z;t]) in Uxv; case/and3P: Uxv => _ hasxt. +rewrite /= !inE andbT. +move/negbTE=> nuv . +rewrite (cat_uniq [::x; y]) in Uxt; case/and3P: Uxt => _. +rewrite /= !andbT orbF; case/norP; rewrite !inE => nxyz nxyt _. +move:hasxt; rewrite /= !orbF; case/norP; rewrite !inE orbA. +case/norP => nxyu nztu. +rewrite orbA;case/norP=> nxyv nztv. +exists [ffun i => if pred2 x y i then c else if pred2 z t i then d + else if u==i then e else g]. + rewrite !inE /= !ffunE //= !eqxx orbT //= !eqxx /= orbT. + by rewrite (negbTE nxyz) (negbTE nxyt). +rewrite {}/ff !ffunE /= !eqxx /=. +rewrite (negbTE nxyz) (negbTE nxyu) (negbTE nztu) (negbTE nxyv) (negbTE nztv). +by rewrite nuv. +Qed. + +Lemma card_n3_3 : forall x y z t: cube, uniq [:: x; y; z;t] -> + #|[set p : col_cubes | (p x == p y) && (p y == p z)&& (p z == p t)]| + = (n ^ 3)%N. +Proof. +move=> x y z t Uxt; rewrite -[n]card_ord . +case:(uniq4_uniq6 Uxt) => u; case => v Uxv. +pose ff (p : col_cubes) := (p x, p u , p v); + rewrite -(@card_in_image _ _ ff); first last. + move=> p1 p2; rewrite !inE. + case/andP ;case/andP => p1xy p1yz p1zt. + case/andP ;case/andP => p2xy p2yz p2zt [px pu] pv. + have eqp12: all (fun i => p1 i == p2 i) [:: x; y; z; t; u ; v]. + by rewrite /= -(eqP p1zt) -(eqP p2zt) -(eqP p1yz) -(eqP p2yz) -(eqP p1xy) + -(eqP p2xy) px pu pv !eqxx. + apply/ffunP=> i; apply/eqP; apply: (allP eqp12). + by rewrite (subset_cardP _ (subset_predT _)) // (card_uniqP Uxv) card_ord. +have ->:forall n, (n ^ 3)%N= (n*n*n)%N. + by move => n0 ; rewrite (expnD n0 2 1) -mulnn expn1. +rewrite -!card_prod; apply: eq_card => [] [[c d]e ] /=; apply/imageP. +rewrite (cat_uniq [::x; y;z;t]) in Uxv; case/and3P: Uxv => _ hasxt. +rewrite /uniq !inE !andbT; move/negbTE=> nuv. +exists + [ffun i => if (i \in [:: x; y; z; t]) then c else if u == i then d else e]. + by rewrite /= !inE !ffunE !inE !eqxx !orbT !eqxx. +rewrite {}/ff !ffunE !inE /= !eqxx /=; move: hasxt; rewrite nuv. +by do 8![case E: ( _ == _ ); rewrite ?(eqP E)/= ?inE ?eqxx //= ?E {E}]. +Qed. + +Lemma card_n2_3 : forall x y z t u v: cube, uniq [:: x; y; z;t; u ; v] -> + #|[set p : col_cubes | (p x == p y) && (p y == p z)&& (p t == p u ) + && (p u== p v)]| = (n ^ 2)%N. +Proof. +move=> x y z t u v Uxv; rewrite -[n]card_ord . +pose ff (p : col_cubes) := (p x, p t); rewrite -(@card_in_image _ _ ff); first last. + move=> p1 p2; rewrite !inE. + case/andP ;case/andP ; case/andP => p1xy p1yz p1tu p1uv. + case/andP ;case/andP; case/andP => p2xy p2yz p2tu p2uv [px pu]. + have eqp12: all (fun i => p1 i == p2 i) [:: x; y; z; t; u ; v]. + by rewrite /= -(eqP p1yz) -(eqP p2yz) -(eqP p1xy) -(eqP p2xy) -(eqP p1uv) + -(eqP p2uv) -(eqP p1tu) -(eqP p2tu) px pu !eqxx. + apply/ffunP=> i; apply/eqP; apply: (allP eqp12). + by rewrite (subset_cardP _ (subset_predT _)) // (card_uniqP Uxv) card_ord. +have ->:forall n, (n ^ 2)%N= (n*n)%N by move => n0 ; rewrite -mulnn . + rewrite -!card_prod; apply: eq_card => [] [c d]/=; apply/imageP. +rewrite (cat_uniq [::x; y;z]) in Uxv; case/and3P: Uxv => Uxt hasxt nuv . +move:hasxt;rewrite /= !orbF; case/norP; rewrite !inE => nxyzt. +case/norP => nxyzu nxyzv. +exists [ffun i => if (i \in [:: x; y; z] ) then c else d]. + rewrite !inE /= !ffunE !inE //= !eqxx !orbT !eqxx //=. + by rewrite (negbTE nxyzt) (negbTE nxyzu)(negbTE nxyzv) !eqxx. +by rewrite {}/ff !ffunE !inE /= !eqxx /= (negbTE nxyzt). +Qed. + +Lemma card_n3s : forall x y z t u v: cube, uniq [:: x; y; z;t; u ; v] -> + #|[set p : col_cubes | (p x == p y) && (p z == p t)&& (p u == p v )]| + = (n ^ 3)%N. +Proof. +move=> x y z t u v Uxv; rewrite -[n]card_ord . +pose ff (p : col_cubes) := (p x, p z, p u). +rewrite -(@card_in_image _ _ ff); first last. + move=> p1 p2; rewrite !inE. + case/andP ;case/andP => p1xy p1zt p1uv. + case/andP ;case/andP => p2xy p2zt p2uv [px pz] pu. + have eqp12: all (fun i => p1 i == p2 i) [:: x; y; z; t; u ; v]. + by rewrite /= -(eqP p1xy) -(eqP p2xy) -(eqP p1zt) -(eqP p2zt) -(eqP p1uv) + -(eqP p2uv) px pz pu !eqxx. + apply/ffunP=> i; apply/eqP; apply: (allP eqp12). + by rewrite (subset_cardP _ (subset_predT _)) // (card_uniqP Uxv) card_ord. +have ->:forall n, (n ^ 3)%N= (n*n*n)%N. + by move => n0 ; rewrite (expnD n0 2 1) -mulnn expn1. +rewrite -!card_prod. apply: eq_card => [] [[c d]e ] /=; apply/imageP. +rewrite (cat_uniq [::x; y;z;t]) in Uxv; case/and3P: Uxv => Uxt hasxt nuv . +rewrite (cat_uniq [::x; y]) in Uxt; case/and3P: Uxt => _. +rewrite /= !orbF !andbT; case/norP ; rewrite !inE => nxyz nxyt _. +move: hasxt; rewrite /= !orbF; case/norP; rewrite !inE orbA. +case/norP => nxyu nztu. +rewrite orbA;case/norP=> nxyv nztv. +exists [ffun i => if (i \in [:: x; y] ) then c else if (i \in [:: z; t] ) + then d else e]. + rewrite !inE /= !ffunE !inE // !eqxx !orbT !eqxx //=. + by rewrite (negbTE nxyz) (negbTE nxyt)(negbTE nxyu) (negbTE nztu) + (negbTE nxyv) (negbTE nztv) !eqxx. +rewrite {}/ff !ffunE !inE /= !eqxx /=. +by rewrite (negbTE nxyz) (negbTE nxyu) (negbTE nztu). +Qed. + +Lemma burnside_app_iso3 : + (cube_coloring_number24 * 24 = + n ^ 6 + 6 * n ^ 3 + 3 * n ^ 4 + 8 * (n ^ 2) + 6 * n ^ 3)%N. +Proof. +pose iso_list :=[::id3; s05; s14; s23; r05; r14; r23; r50; r41; r32; + r024; r042; r012; r021; r031; r013; r043 ; r034; + s1 ; s2; s3; s4; s5; s6]. +rewrite (burnside_formula iso_list) => [||p]; last first. +- by rewrite !inE /= !(eq_sym _ p). +- apply: map_uniq (fun p : {perm cube} => (p F0, p F1)) _ _. + have bsr:(fun p : {perm cube} => (p F0, p F1)) =1 + (fun p => (nth F0 p F0, nth F0 p F1)) \o sop. + by move => x; rewrite /= -2!sop_spec. + by rewrite (eq_map bsr) map_comp -(eqP Lcorrect); vm_compute. +rewrite !big_cons big_nil {1}card_Fid3 /= F_s05 F_s14 F_s23 F_r05 F_r14 F_r23 + F_r50 F_r41 F_r32 F_r024 F_r042 F_r012 F_r021 F_r031 F_r013 F_r043 F_r034 + F_s1 F_s2 F_s3 F_s4 F_s5 F_s6. +by rewrite !card_n4 // !card_n3_3 // !card_n2_3 // !card_n3s //; ring. +Qed. + +End cube_colouring. + +End colouring. + +Corollary burnside_app_iso_3_3col: cube_coloring_number24 3 = 57. +Proof. +by apply/eqP; rewrite -(@eqn_pmul2r 24) // burnside_app_iso3. +Qed. + + +Corollary burnside_app_iso_2_4col: square_coloring_number8 4 = 55. +Proof. by apply/eqP; rewrite -(@eqn_pmul2r 8) // burnside_app_iso. Qed. + + + diff --git a/mathcomp/solvable/center.v b/mathcomp/solvable/center.v new file mode 100644 index 0000000..0ed9200 --- /dev/null +++ b/mathcomp/solvable/center.v @@ -0,0 +1,652 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div fintype bigop. +Require Import finset fingroup morphism perm automorphism quotient action. +Require Import gproduct gfunctor cyclic. + +(******************************************************************************) +(* Definition of the center of a group and of external central products: *) +(* 'Z(G) == the center of the group G, i.e., 'C_G(G). *) +(* cprod_by isoZ == the finGroupType for the central product of H and K *) +(* with centers identified by the isomorphism gz on 'Z(H); *) +(* here isoZ : isom 'Z(H) 'Z(K) gz. Note that the actual *) +(* central product is [set: cprod_by isoZ]. *) +(* cpairg1 isoZ == the isomorphism from H to cprod_by isoZ, isoZ as above. *) +(* cpair1g isoZ == the isomorphism from K to cprod_by isoZ, isoZ as above. *) +(* xcprod H K == the finGroupType for the external central product of H *) +(* and K with identified centers, provided the dynamically *) +(* tested condition 'Z(H) \isog 'Z(K) holds. *) +(* ncprod H n == the finGroupType for the central product of n copies of *) +(* H with their centers identified; [set: ncprod H 0] is *) +(* isomorphic to 'Z(H). *) +(* xcprodm cf eqf == the morphism induced on cprod_by isoZ, where as above *) +(* isoZ : isom 'Z(H) 'Z(K) gz, by fH : {morphism H >-> rT} *) +(* and fK : {morphism K >-> rT}, given both *) +(* cf : fH @* H \subset 'C(fK @* K) and *) +(* eqf : {in 'Z(H), fH =1 fK \o gz}. *) +(* Following Aschbacher, we only provide external central products with *) +(* identified centers, as these are well defined provided the local center *) +(* isomorphism group of one of the subgroups is full. Nevertheless the *) +(* entire construction could be carried out under the weaker assumption that *) +(* gz is an isomorphism between subgroups of 'Z(H) and 'Z(K), and even the *) +(* uniqueness theorem holds under the weaker assumption that gz map 'Z(H) to *) +(* a characteristic subgroup of 'Z(K) not isomorphic to any other subgroup of *) +(* 'Z(K), a condition that holds for example when K is cyclic, as in the *) +(* structure theorem for p-groups of symplectic type. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section Defs. + +Variable gT : finGroupType. + +Definition center (A : {set gT}) := 'C_A(A). + +Canonical center_group (G : {group gT}) : {group gT} := + Eval hnf in [group of center G]. + +End Defs. + +Arguments Scope center [_ group_scope]. +Notation "''Z' ( A )" := (center A) : group_scope. +Notation "''Z' ( H )" := (center_group H) : Group_scope. + +Lemma morphim_center : GFunctor.pcontinuous center. +Proof. move=> gT rT G D f; exact: morphim_subcent. Qed. + +Canonical center_igFun := [igFun by fun _ _ => subsetIl _ _ & morphim_center]. +Canonical center_gFun := [gFun by morphim_center]. +Canonical center_pgFun := [pgFun by morphim_center]. + +Section Center. + +Variables gT : finGroupType. +Implicit Type rT : finGroupType. +Implicit Types (x y : gT) (A B : {set gT}) (G H K D : {group gT}). + +Lemma subcentP A B x : reflect (x \in A /\ centralises x B) (x \in 'C_A(B)). +Proof. +rewrite inE. case: (x \in A); last by right; case. +by apply: (iffP centP) => [|[]]. +Qed. + +Lemma subcent_sub A B : 'C_A(B) \subset 'N_A(B). +Proof. by rewrite setIS ?cent_sub. Qed. + +Lemma subcent_norm G B : 'N_G(B) \subset 'N('C_G(B)). +Proof. by rewrite normsI ?subIset ?normG // orbC cent_norm. Qed. + +Lemma subcent_normal G B : 'C_G(B) <| 'N_G(B). +Proof. by rewrite /normal subcent_sub subcent_norm. Qed. + +Lemma subcent_char G H K : H \char G -> K \char G -> 'C_H(K) \char G. +Proof. +case/charP=> sHG chHG /charP[sKG chKG]; apply/charP. +split=> [|f injf Gf]; first by rewrite subIset ?sHG. +by rewrite injm_subcent ?chHG ?chKG. +Qed. + +Lemma centerP A x : reflect (x \in A /\ centralises x A) (x \in 'Z(A)). +Proof. exact: subcentP. Qed. + +Lemma center_sub A : 'Z(A) \subset A. +Proof. exact: subsetIl. Qed. + +Lemma center1 : 'Z(1) = [1 gT]. +Proof. by apply/eqP; rewrite eqEsubset center_sub sub1G. Qed. + +Lemma centerC A : {in A, centralised 'Z(A)}. +Proof. by apply/centsP; rewrite centsC subsetIr. Qed. + +Lemma center_normal G : 'Z(G) <| G. +Proof. exact: gFnormal. Qed. + +Lemma sub_center_normal H G : H \subset 'Z(G) -> H <| G. +Proof. by rewrite subsetI centsC /normal => /andP[-> /cents_norm]. Qed. + +Lemma center_abelian G : abelian 'Z(G). +Proof. by rewrite /abelian subIset // centsC subIset // subxx orbT. Qed. + +Lemma center_char G : 'Z(G) \char G. +Proof. exact: gFchar. Qed. + +Lemma center_idP A : reflect ('Z(A) = A) (abelian A). +Proof. exact: setIidPl. Qed. + +Lemma center_class_formula G : + #|G| = #|'Z(G)| + \sum_(xG in [set x ^: G | x in G :\: 'C(G)]) #|xG|. +Proof. +by rewrite acts_sum_card_orbit ?cardsID // astabsJ normsD ?norms_cent ?normG. +Qed. + +Lemma subcent1P A x y : reflect (y \in A /\ commute x y) (y \in 'C_A[x]). +Proof. +rewrite inE; case: (y \in A); last by right; case. +by apply: (iffP cent1P) => [|[]]. +Qed. + +Lemma subcent1_id x G : x \in G -> x \in 'C_G[x]. +Proof. move=> Gx; rewrite inE Gx; exact/cent1P. Qed. + +Lemma subcent1_sub x G : 'C_G[x] \subset G. +Proof. exact: subsetIl. Qed. + +Lemma subcent1C x y G : x \in G -> y \in 'C_G[x] -> x \in 'C_G[y]. +Proof. by move=> Gx /subcent1P[_ cxy]; exact/subcent1P. Qed. + +Lemma subcent1_cycle_sub x G : x \in G -> <[x]> \subset 'C_G[x]. +Proof. by move=> Gx; rewrite cycle_subG ?subcent1_id. Qed. + +Lemma subcent1_cycle_norm x G : 'C_G[x] \subset 'N(<[x]>). +Proof. by rewrite cents_norm // cent_gen cent_set1 subsetIr. Qed. + +Lemma subcent1_cycle_normal x G : x \in G -> <[x]> <| 'C_G[x]. +Proof. +by move=> Gx; rewrite /normal subcent1_cycle_norm subcent1_cycle_sub. +Qed. + +(* Gorenstein. 1.3.4 *) +Lemma cyclic_center_factor_abelian G : cyclic (G / 'Z(G)) -> abelian G. +Proof. +case/cyclicP=> a Ga; case: (cosetP a) => /= z Nz def_a. +have G_Zz: G :=: 'Z(G) * <[z]>. + rewrite -quotientK ?cycle_subG ?quotient_cycle //=. + by rewrite -def_a -Ga quotientGK // center_normal. +rewrite G_Zz abelianM cycle_abelian center_abelian centsC /= G_Zz. +by rewrite subIset ?centS ?orbT ?mulG_subr. +Qed. + +Lemma cyclic_factor_abelian H G : + H \subset 'Z(G) -> cyclic (G / H) -> abelian G. +Proof. +move=> sHZ cycGH; apply: cyclic_center_factor_abelian. +have nG: G \subset 'N(_) := normal_norm (sub_center_normal _). +have [f <-]:= homgP (homg_quotientS (nG _ sHZ) (nG _ (subxx _)) sHZ). +exact: morphim_cyclic. +Qed. + +Section Injm. + +Variables (rT : finGroupType) (D : {group gT}) (f : {morphism D >-> rT}). + +Hypothesis injf : 'injm f. + +Lemma injm_center G : G \subset D -> f @* 'Z(G) = 'Z(f @* G). +Proof. exact: injm_subcent. Qed. + +End Injm. + +End Center. + +Implicit Arguments center_idP [gT A]. + +Lemma isog_center (aT rT : finGroupType) (G : {group aT}) (H : {group rT}) : + G \isog H -> 'Z(G) \isog 'Z(H). +Proof. exact: gFisog. Qed. + +Section Product. + +Variable gT : finGroupType. +Implicit Types (A B C : {set gT}) (G H K : {group gT}). + +Lemma center_prod H K : K \subset 'C(H) -> 'Z(H) * 'Z(K) = 'Z(H * K). +Proof. +move=> cHK; apply/setP=> z; rewrite {3}/center centM !inE. +have cKH: H \subset 'C(K) by rewrite centsC. +apply/imset2P/and3P=> [[x y /setIP[Hx cHx] /setIP[Ky cKy] ->{z}]| []]. + by rewrite mem_imset2 ?groupM // ?(subsetP cHK) ?(subsetP cKH). +case/imset2P=> x y Hx Ky ->{z}. +rewrite groupMr => [cHx|]; last exact: subsetP Ky. +rewrite groupMl => [cKy|]; last exact: subsetP Hx. +by exists x y; rewrite ?inE ?Hx ?Ky. +Qed. + +Lemma center_cprod A B G : A \* B = G -> 'Z(A) \* 'Z(B) = 'Z(G). +Proof. +case/cprodP => [[H K -> ->] <- cHK]. +rewrite cprodE ?center_prod //= subIset ?(subset_trans cHK) //. +by rewrite centS ?center_sub. +Qed. + +Lemma center_bigcprod I r P (F : I -> {set gT}) G : + \big[cprod/1]_(i <- r | P i) F i = G -> + \big[cprod/1]_(i <- r | P i) 'Z(F i) = 'Z(G). +Proof. +elim/big_ind2: _ G => [_ <-|A B C D IHA IHB G dG|_ _ G ->]; rewrite ?center1 //. +case/cprodP: dG IHA IHB (dG) => [[H K -> ->] _ _] IHH IHK dG. +by rewrite (IHH H) // (IHK K) // (center_cprod dG). +Qed. + +Lemma cprod_center_id G : G \* 'Z(G) = G. +Proof. by rewrite cprodE ?subsetIr // mulGSid ?center_sub. Qed. + +Lemma center_dprod A B G : A \x B = G -> 'Z(A) \x 'Z(B) = 'Z(G). +Proof. +case/dprodP=> [[H1 H2 -> ->] defG cH12 trH12]. +move: defG; rewrite -cprodE // => /center_cprod/cprodP[_ /= <- cZ12]. +by apply: dprodE; rewrite //= setIAC setIA -setIA trH12 (setIidPl _) ?sub1G. +Qed. + +Lemma center_bigdprod I r P (F: I -> {set gT}) G : + \big[dprod/1]_(i <- r | P i) F i = G -> + \big[dprod/1]_(i <- r | P i) 'Z(F i) = 'Z(G). +Proof. +elim/big_ind2: _ G => [_ <-|A B C D IHA IHB G dG|_ _ G ->]; rewrite ?center1 //. +case/dprodP: dG IHA IHB (dG) => [[H K -> ->] _ _ _] IHH IHK dG. +by rewrite (IHH H) // (IHK K) // (center_dprod dG). +Qed. + +Lemma Aut_cprod_full G H K : + H \* K = G -> 'Z(H) = 'Z(K) -> + Aut_in (Aut H) 'Z(H) \isog Aut 'Z(H) -> + Aut_in (Aut K) 'Z(K) \isog Aut 'Z(K) -> + Aut_in (Aut G) 'Z(G) \isog Aut 'Z(G). +Proof. +move=> defG eqZHK; have [_ defHK cHK] := cprodP defG. +have defZ: 'Z(G) = 'Z(H) by rewrite -defHK -center_prod // eqZHK mulGid. +have ziHK: H :&: K = 'Z(K). + by apply/eqP; rewrite eqEsubset subsetI -{1 2}eqZHK !center_sub setIS. +have AutZP := Aut_sub_fullP (@center_sub gT _). +move/AutZP=> AutZHfull /AutZP AutZKfull; apply/AutZP=> g injg gZ. +have [gH [def_gH ker_gH _ im_gH]] := domP g defZ. +have [gK [def_gK ker_gK _ im_gK]] := domP g (etrans defZ eqZHK). +have [injgH injgK]: 'injm gH /\ 'injm gK by rewrite ker_gH ker_gK. +have [gHH gKK]: gH @* 'Z(H) = 'Z(H) /\ gK @* 'Z(K) = 'Z(K). + by rewrite im_gH im_gK -eqZHK -defZ. +have [|fH [injfH im_fH fHZ]] := AutZHfull gH injgH. + by rewrite im_gH /= -defZ. +have [|fK [injfK im_fK fKZ]] := AutZKfull gK injgK. + by rewrite im_gK /= -eqZHK -defZ. +have cfHK: fK @* K \subset 'C(fH @* H) by rewrite im_fH im_fK. +have eq_fHK: {in H :&: K, fH =1 fK}. + by move=> z; rewrite ziHK => Zz; rewrite fHZ ?fKZ /= ?eqZHK // def_gH def_gK. +exists (cprodm_morphism defG cfHK eq_fHK). +rewrite injm_cprodm injfH injfK im_cprodm im_fH im_fK defHK. +rewrite -morphimIdom ziHK -eqZHK injm_center // im_fH eqxx. +split=> //= z; rewrite {1}defZ => Zz; have [Hz _] := setIP Zz. +by rewrite cprodmEl // fHZ // def_gH. +Qed. + +End Product. + +Section CprodBy. + +Variables gTH gTK : finGroupType. +Variables (H : {group gTH}) (K : {group gTK}) (gz : {morphism 'Z(H) >-> gTK}). + +Definition ker_cprod_by of isom 'Z(H) 'Z(K) gz := + [set xy | let: (x, y) := xy in (x \in 'Z(H)) && (y == (gz x)^-1)]. + +Hypothesis isoZ : isom 'Z(H) 'Z(K) gz. +Let kerHK := ker_cprod_by isoZ. + +Let injgz : 'injm gz. Proof. by case/isomP: isoZ. Qed. +Let gzZ : gz @* 'Z(H) = 'Z(K). Proof. by case/isomP: isoZ. Qed. +Let gzZchar : gz @* 'Z(H) \char 'Z(K). Proof. by rewrite gzZ char_refl. Qed. +Let sgzZZ : gz @* 'Z(H) \subset 'Z(K) := char_sub gzZchar. +Let sZH := center_sub H. +Let sZK := center_sub K. +Let sgzZG : gz @* 'Z(H) \subset K := subset_trans sgzZZ sZK. + +Lemma ker_cprod_by_is_group : group_set kerHK. +Proof. +apply/group_setP; rewrite inE /= group1 morph1 invg1 /=. +split=> // [[x1 y1] [x2 y2]]. +rewrite inE /= => /andP[Zx1 /eqP->]; have [_ cGx1] := setIP Zx1. +rewrite inE /= => /andP[Zx2 /eqP->]; have [Gx2 _] := setIP Zx2. +by rewrite inE /= groupM //= -invMg (centP cGx1) // morphM. +Qed. +Canonical ker_cprod_by_group := Group ker_cprod_by_is_group. + +Lemma ker_cprod_by_central : kerHK \subset 'Z(setX H K). +Proof. +rewrite -(center_dprod (setX_dprod H K)) -morphim_pairg1 -morphim_pair1g. +rewrite -!injm_center ?subsetT ?injm_pair1g ?injm_pairg1 //=. +rewrite morphim_pairg1 morphim_pair1g setX_dprod. +apply/subsetP=> [[x y]]; rewrite inE => /andP[Zx /eqP->]. +by rewrite inE /= Zx groupV (subsetP sgzZZ) ?mem_morphim. +Qed. + +Fact cprod_by_key : unit. Proof. by []. Qed. +Definition cprod_by_def := subFinGroupType [group of setX H K / kerHK]. +Definition cprod_by := locked_with cprod_by_key cprod_by_def. +Local Notation C := [set: FinGroup.arg_sort (FinGroup.base cprod_by)]. + +Definition in_cprod : gTH * gTK -> cprod_by := + let: tt as k := cprod_by_key return _ -> locked_with k cprod_by_def in + subg _ \o coset kerHK. + +Lemma in_cprodM : {in setX H K &, {morph in_cprod : u v / u * v}}. +Proof. +rewrite /in_cprod /cprod_by; case: cprod_by_key => /= u v Gu Gv. +have nkerHKG := normal_norm (sub_center_normal ker_cprod_by_central). +by rewrite -!morphM ?mem_quotient // (subsetP nkerHKG). +Qed. +Canonical in_cprod_morphism := Morphism in_cprodM. + +Lemma ker_in_cprod : 'ker in_cprod = kerHK. +Proof. +transitivity ('ker (subg [group of setX H K / kerHK] \o coset kerHK)). + rewrite /ker /morphpre /= /in_cprod /cprod_by; case: cprod_by_key => /=. + by rewrite ['N(_) :&: _]quotientGK ?sub_center_normal ?ker_cprod_by_central. +by rewrite ker_comp ker_subg -kerE ker_coset. +Qed. + +Lemma cpairg1_dom : H \subset 'dom (in_cprod \o @pairg1 gTH gTK). +Proof. by rewrite -sub_morphim_pre ?subsetT // morphim_pairg1 setXS ?sub1G. Qed. + +Lemma cpair1g_dom : K \subset 'dom (in_cprod \o @pair1g gTH gTK). +Proof. by rewrite -sub_morphim_pre ?subsetT // morphim_pair1g setXS ?sub1G. Qed. + +Definition cpairg1 := tag (restrmP _ cpairg1_dom). +Definition cpair1g := tag (restrmP _ cpair1g_dom). + +Local Notation CH := (mfun cpairg1 @* gval H). +Local Notation CK := (mfun cpair1g @* gval K). + +Lemma injm_cpairg1 : 'injm cpairg1. +Proof. +rewrite /cpairg1; case: restrmP => _ [_ -> _ _]. +rewrite ker_comp ker_in_cprod; apply/subsetP=> x; rewrite 5!inE /=. +by case/and3P=> _ Zx; rewrite inE eq_sym (inv_eq invgK) invg1 morph_injm_eq1. +Qed. +Let injH := injm_cpairg1. + +Lemma injm_cpair1g : 'injm cpair1g. +Proof. +rewrite /cpair1g; case: restrmP => _ [_ -> _ _]. +rewrite ker_comp ker_in_cprod; apply/subsetP=> y; rewrite !inE /= morph1 invg1. +by case/and3P. +Qed. +Let injK := injm_cpair1g. + +Lemma im_cpair_cent : CK \subset 'C(CH). +Proof. +rewrite /cpairg1 /cpair1g; do 2!case: restrmP => _ [_ _ _ -> //]. +rewrite !morphim_comp morphim_cents // morphim_pair1g morphim_pairg1. +by case/dprodP: (setX_dprod H K). +Qed. +Hint Resolve im_cpair_cent. + +Lemma im_cpair : CH * CK = C. +Proof. +rewrite /cpairg1 /cpair1g; do 2!case: restrmP => _ [_ _ _ -> //]. +rewrite !morphim_comp -morphimMl morphim_pairg1 ?setXS ?sub1G //. +rewrite morphim_pair1g setX_prod morphimEdom /= /in_cprod /cprod_by. +by case: cprod_by_key; rewrite /= imset_comp imset_coset -morphimEdom im_subg. +Qed. + +Lemma im_cpair_cprod : CH \* CK = C. Proof. by rewrite cprodE ?im_cpair. Qed. + +Lemma eq_cpairZ : {in 'Z(H), cpairg1 =1 cpair1g \o gz}. +Proof. +rewrite /cpairg1 /cpair1g => z1 Zz1; set z2 := gz z1. +have Zz2: z2 \in 'Z(K) by rewrite (subsetP sgzZZ) ?mem_morphim. +have [[Gz1 _] [/= Gz2 _]]:= (setIP Zz1, setIP Zz2). +do 2![case: restrmP => f /= [df _ _ _]; rewrite {f}df]. +apply/rcoset_kerP; rewrite ?inE ?group1 ?andbT //. +by rewrite ker_in_cprod mem_rcoset inE /= invg1 mulg1 mul1g Zz1 /=. +Qed. + +Lemma setI_im_cpair : CH :&: CK = 'Z(CH). +Proof. +apply/eqP; rewrite eqEsubset setIS //=. +rewrite subsetI center_sub -injm_center //. +rewrite (eq_in_morphim _ eq_cpairZ); first by rewrite morphim_comp morphimS. +by rewrite !(setIidPr _) // -sub_morphim_pre. +Qed. + +Lemma cpair1g_center : cpair1g @* 'Z(K) = 'Z(C). +Proof. +case/cprodP: (center_cprod im_cpair_cprod) => _ <- _. +by rewrite injm_center // -setI_im_cpair mulSGid //= setIC setIS 1?centsC. +Qed. + +(* Uses gzZ. *) +Lemma cpair_center_id : 'Z(CH) = 'Z(CK). +Proof. +rewrite -!injm_center // -gzZ -morphim_comp; apply: eq_in_morphim eq_cpairZ. +by rewrite !(setIidPr _) // -sub_morphim_pre. +Qed. + +(* Uses gzZ. *) +Lemma cpairg1_center : cpairg1 @* 'Z(H) = 'Z(C). +Proof. by rewrite -cpair1g_center !injm_center // cpair_center_id. Qed. + +Section ExtCprodm. + +Variable rT : finGroupType. +Variables (fH : {morphism H >-> rT}) (fK : {morphism K >-> rT}). +Hypothesis cfHK : fK @* K \subset 'C(fH @* H). +Hypothesis eq_fHK : {in 'Z(H), fH =1 fK \o gz}. + +Let gH := ifactm fH injm_cpairg1. +Let gK := ifactm fK injm_cpair1g. + +Lemma xcprodm_cent : gK @* CK \subset 'C(gH @* CH). +Proof. by rewrite !im_ifactm. Qed. + +Lemma xcprodmI : {in CH :&: CK, gH =1 gK}. +Proof. +rewrite setI_im_cpair -injm_center // => fHx; case/morphimP=> x Gx Zx ->{fHx}. +by rewrite {2}eq_cpairZ //= ?ifactmE ?eq_fHK //= (subsetP sgzZG) ?mem_morphim. +Qed. + +Definition xcprodm := cprodm im_cpair_cprod xcprodm_cent xcprodmI. +Canonical xcprod_morphism := [morphism of xcprodm]. + +Lemma xcprodmEl : {in H, forall x, xcprodm (cpairg1 x) = fH x}. +Proof. by move=> x Hx; rewrite /xcprodm cprodmEl ?mem_morphim ?ifactmE. Qed. + +Lemma xcprodmEr : {in K, forall y, xcprodm (cpair1g y) = fK y}. +Proof. by move=> y Ky; rewrite /xcprodm cprodmEr ?mem_morphim ?ifactmE. Qed. + +Lemma xcprodmE : + {in H & K, forall x y, xcprodm (cpairg1 x * cpair1g y) = fH x * fK y}. +Proof. +by move=> x y Hx Ky; rewrite /xcprodm cprodmE ?mem_morphim ?ifactmE. +Qed. + +Lemma im_xcprodm : xcprodm @* C = fH @* H * fK @* K. +Proof. by rewrite -im_cpair morphim_cprodm // !im_ifactm. Qed. + +Lemma im_xcprodml A : xcprodm @* (cpairg1 @* A) = fH @* A. +Proof. +rewrite -!(morphimIdom _ A) morphim_cprodml ?morphimS ?subsetIl //. +by rewrite morphim_ifactm ?subsetIl. +Qed. + +Lemma im_xcprodmr A : xcprodm @* (cpair1g @* A) = fK @* A. +Proof. +rewrite -!(morphimIdom _ A) morphim_cprodmr ?morphimS ?subsetIl //. +by rewrite morphim_ifactm ?subsetIl. +Qed. + +Lemma injm_xcprodm : 'injm xcprodm = 'injm fH && 'injm fK. +Proof. +rewrite injm_cprodm !ker_ifactm !subG1 !morphim_injm_eq1 ?subsetIl // -!subG1. +apply: andb_id2l => /= injfH; apply: andb_idr => _. +rewrite !im_ifactm // -(morphimIdom gH) setI_im_cpair -injm_center //. +rewrite morphim_ifactm // eqEsubset subsetI morphimS //=. +rewrite {1}injm_center // setIS //=. +rewrite (eq_in_morphim _ eq_fHK); first by rewrite morphim_comp morphimS. +by rewrite !(setIidPr _) // -sub_morphim_pre. +Qed. + +End ExtCprodm. + +(* Uses gzZchar. *) +Lemma Aut_cprod_by_full : + Aut_in (Aut H) 'Z(H) \isog Aut 'Z(H) -> + Aut_in (Aut K) 'Z(K) \isog Aut 'Z(K) -> + Aut_in (Aut C) 'Z(C) \isog Aut 'Z(C). +Proof. +move=> AutZinH AutZinK. +have Cfull:= Aut_cprod_full im_cpair_cprod cpair_center_id. +by rewrite Cfull // -injm_center // injm_Aut_full ?center_sub. +Qed. + +Section Isomorphism. + +Let gzZ_lone (Y : {group gTK}) : + Y \subset 'Z(K) -> gz @* 'Z(H) \isog Y -> gz @* 'Z(H) = Y. +Proof. +move=> sYZ isoY; apply/eqP. +by rewrite eq_sym eqEcard (card_isog isoY) gzZ sYZ /=. +Qed. + +Variables (rT : finGroupType) (GH GK G : {group rT}). +Hypotheses (defG : GH \* GK = G) (ziGHK : GH :&: GK = 'Z(GH)). +Hypothesis AutZHfull : Aut_in (Aut H) 'Z(H) \isog Aut 'Z(H). +Hypotheses (isoGH : GH \isog H) (isoGK : GK \isog K). + +(* Uses gzZ_lone *) +Lemma cprod_by_uniq : + exists f : {morphism G >-> cprod_by}, + [/\ isom G C f, f @* GH = CH & f @* GK = CK]. +Proof. +have [_ defGHK cGKH] := cprodP defG. +have AutZinH := Aut_sub_fullP sZH AutZHfull. +have [fH injfH defGH]:= isogP (isog_symr isoGH). +have [fK injfK defGK]:= isogP (isog_symr isoGK). +have sfHZfK: fH @* 'Z(H) \subset fK @* K. + by rewrite injm_center //= defGH defGK -ziGHK subsetIr. +have gzZ_id: gz @* 'Z(H) = invm injfK @* (fH @* 'Z(H)). + apply: gzZ_lone => /=. + rewrite injm_center // defGH -ziGHK sub_morphim_pre /= ?defGK ?subsetIr //. + by rewrite setIC morphpre_invm injm_center // defGK setIS 1?centsC. + rewrite -morphim_comp. + apply: isog_trans (sub_isog _ _); first by rewrite isog_sym sub_isog. + by rewrite -sub_morphim_pre. + by rewrite !injm_comp ?injm_invm. +have: 'dom (invm injfH \o fK \o gz) = 'Z(H). + rewrite /dom /= -(morphpreIdom gz); apply/setIidPl. + by rewrite -2?sub_morphim_pre // gzZ_id morphim_invmE morphpreK ?morphimS. +case/domP=> gzH [def_gzH ker_gzH _ im_gzH]. +have{ker_gzH} injgzH: 'injm gzH by rewrite ker_gzH !injm_comp ?injm_invm. +have{AutZinH} [|gH [injgH gH_H def_gH]] := AutZinH _ injgzH. + by rewrite im_gzH !morphim_comp /= gzZ_id !morphim_invmE morphpreK ?injmK. +have: 'dom (fH \o gH) = H by rewrite /dom /= -{3}gH_H injmK. +case/domP=> gfH [def_gfH ker_gfH _ im_gfH]. +have{im_gfH} gfH_H: gfH @* H = GH by rewrite im_gfH morphim_comp gH_H. +have cgfHfK: fK @* K \subset 'C(gfH @* H) by rewrite gfH_H defGK. +have eq_gfHK: {in 'Z(H), gfH =1 fK \o gz}. + move=> z Zz; rewrite def_gfH /= def_gH //= def_gzH /= invmK //. + have {Zz}: gz z \in gz @* 'Z(H) by rewrite mem_morphim. + rewrite gzZ_id morphim_invmE; case/morphpreP=> _. + exact: (subsetP (morphimS _ _)). +pose f := xcprodm cgfHfK eq_gfHK. +have injf: 'injm f by rewrite injm_xcprodm ker_gfH injm_comp. +have fCH: f @* CH = GH by rewrite im_xcprodml gfH_H. +have fCK: f @* CK = GK by rewrite im_xcprodmr defGK. +have fC: f @* C = G by rewrite im_xcprodm gfH_H defGK defGHK. +have [f' [_ ker_f' _ im_f']] := domP (invm_morphism injf) fC. +exists f'; rewrite -fCH -fCK !{1}im_f' !{1}morphim_invm ?subsetT //. +by split=> //; apply/isomP; rewrite ker_f' injm_invm im_f' -fC im_invm. +Qed. + +Lemma isog_cprod_by : G \isog C. +Proof. by have [f [isoG _ _]] := cprod_by_uniq; exact: isom_isog isoG. Qed. + +End Isomorphism. + +End CprodBy. + +Section ExtCprod. +Import finfun. + +Variables gTH gTK : finGroupType. +Variables (H : {group gTH}) (K : {group gTK}). + +Let gt_ b := if b then gTK else gTH. +Local Notation isob := ('Z(H) \isog 'Z(K)) (only parsing). +Let G_ b := if b as b' return {group gt_ b'} then K else H. + +Lemma xcprod_subproof : + {gz : {morphism 'Z(H) >-> gt_ isob} | isom 'Z(H) 'Z(G_ isob) gz}. +Proof. +case: (pickP [pred f : {ffun _} | misom 'Z(H) 'Z(K) f]) => [f isoZ | no_f]. + rewrite (misom_isog isoZ); case/andP: isoZ => fM isoZ. + by exists [morphism of morphm fM]. +move/pred0P: no_f => not_isoZ; rewrite [isob](congr1 negb not_isoZ). +by exists (idm_morphism _); apply/isomP; rewrite injm_idm im_idm. +Qed. + +Definition xcprod := cprod_by (svalP xcprod_subproof). + +Inductive xcprod_spec : finGroupType -> Prop := + XcprodSpec gz isoZ : xcprod_spec (@cprod_by gTH gTK H K gz isoZ). + +Lemma xcprodP : 'Z(H) \isog 'Z(K) -> xcprod_spec xcprod. +Proof. by rewrite /xcprod => isoZ; move: xcprod_subproof; rewrite isoZ. Qed. + +Lemma isog_xcprod (rT : finGroupType) (GH GK G : {group rT}) : + Aut_in (Aut H) 'Z(H) \isog Aut 'Z(H) -> + GH \isog H -> GK \isog K -> GH \* GK = G -> 'Z(GH) = 'Z(GK) -> + G \isog [set: xcprod]. +Proof. +move=> AutZinH isoGH isoGK defG eqZGHK; have [_ _ cGHK] := cprodP defG. +have [|gz isoZ] := xcprodP. + have [[fH injfH <-] [fK injfK <-]] := (isogP isoGH, isogP isoGK). + rewrite -!injm_center -?(isog_transl _ (sub_isog _ _)) ?center_sub //=. + by rewrite eqZGHK sub_isog ?center_sub. +rewrite (isog_cprod_by _ defG) //. +by apply/eqP; rewrite eqEsubset setIS // subsetI {2}eqZGHK !center_sub. +Qed. + +End ExtCprod. + +Section IterCprod. + +Variables (gT : finGroupType) (G : {group gT}). + +Fixpoint ncprod_def n : finGroupType := + if n is n'.+1 then xcprod G [set: ncprod_def n'] + else [finGroupType of subg_of 'Z(G)]. +Fact ncprod_key : unit. Proof. by []. Qed. +Definition ncprod := locked_with ncprod_key ncprod_def. + +Local Notation G_ n := [set: gsort (ncprod n)]. + +Lemma ncprod0 : G_ 0 \isog 'Z(G). +Proof. by rewrite [ncprod]unlock isog_sym isog_subg. Qed. + +Lemma center_ncprod0 : 'Z(G_ 0) = G_ 0. +Proof. by apply: center_idP; rewrite (isog_abelian ncprod0) center_abelian. Qed. + +Lemma center_ncprod n : 'Z(G_ n) \isog 'Z(G). +Proof. +elim: n => [|n]; first by rewrite center_ncprod0 ncprod0. +rewrite [ncprod]unlock=> /isog_symr/xcprodP[gz isoZ] /=. +by rewrite -cpairg1_center isog_sym sub_isog ?center_sub ?injm_cpairg1. +Qed. + +Lemma ncprodS n : xcprod_spec G [set: ncprod n] (ncprod n.+1). +Proof. +by have:= xcprodP (isog_symr (center_ncprod n)); rewrite [ncprod]unlock. +Qed. + +Lemma ncprod1 : G_ 1 \isog G. +Proof. +case: ncprodS => gz isoZ; rewrite isog_sym /= -im_cpair. +rewrite mulGSid /=; first by rewrite sub_isog ?injm_cpairg1. +rewrite -{3}center_ncprod0 injm_center ?injm_cpair1g //. +by rewrite -cpair_center_id center_sub. +Qed. + +Lemma Aut_ncprod_full n : + Aut_in (Aut G) 'Z(G) \isog Aut 'Z(G) -> + Aut_in (Aut (G_ n)) 'Z(G_ n) \isog Aut 'Z(G_ n). +Proof. +move=> AutZinG; elim: n => [|n IHn]. + by rewrite center_ncprod0; apply/Aut_sub_fullP=> // g injg gG0; exists g. +by case: ncprodS => gz isoZ; exact: Aut_cprod_by_full. +Qed. + +End IterCprod. + + diff --git a/mathcomp/solvable/commutator.v b/mathcomp/solvable/commutator.v new file mode 100644 index 0000000..81be11d --- /dev/null +++ b/mathcomp/solvable/commutator.v @@ -0,0 +1,362 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat fintype bigop finset. +Require Import binomial fingroup morphism automorphism quotient gfunctor. + +(******************************************************************************) +(* This files contains the proofs of several key properties of commutators, *) +(* including the Hall-Witt identity and the Three Subgroup Lemma. *) +(* The definition and notation for both pointwise and set wise commutators *) +(* ([~x, y, ...] and [~: A, B ,...], respectively) are given in fingroup.v *) +(* This file defines the derived group series: *) +(* G^`(0) == G *) +(* G^`(n.+1) == [~: G^`(n), G^`(n)] *) +(* as several classical results involve the (first) derived group G^`(1), *) +(* such as the equivalence H <| G /\ G / H abelian <-> G^`(1) \subset H. The *) +(* connection between the derived series and solvable groups will only be *) +(* established in nilpotent.v, however. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Definition derived_at_rec n (gT : finGroupType) (A : {set gT}) := + iter n (fun B => [~: B, B]) A. + +(* Note: 'nosimpl' MUST be used outside of a section -- the end of section *) +(* "cooking" destroys it. *) +Definition derived_at := nosimpl derived_at_rec. + +Arguments Scope derived_at [nat_scope _ group_scope]. +Notation "G ^` ( n )" := (derived_at n G) : group_scope. + +Section DerivedBasics. + +Variables gT : finGroupType. +Implicit Type A : {set gT}. +Implicit Types G : {group gT}. + +Lemma derg0 A : A^`(0) = A. Proof. by []. Qed. +Lemma derg1 A : A^`(1) = [~: A, A]. Proof. by []. Qed. +Lemma dergSn n A : A^`(n.+1) = [~: A^`(n), A^`(n)]. Proof. by []. Qed. + +Lemma der_group_set G n : group_set G^`(n). +Proof. by case: n => [|n]; exact: groupP. Qed. + +Canonical derived_at_group G n := Group (der_group_set G n). + +End DerivedBasics. + +Notation "G ^` ( n )" := (derived_at_group G n) : Group_scope. + +Section Basic_commutator_properties. + +Variable gT : finGroupType. +Implicit Types x y z : gT. + +Lemma conjg_mulR x y : x ^ y = x * [~ x, y]. +Proof. by rewrite mulKVg. Qed. + +Lemma conjg_Rmul x y : x ^ y = [~ y, x^-1] * x. +Proof. by rewrite commgEr invgK mulgKV. Qed. + +Lemma commMgJ x y z : [~ x * y, z] = [~ x, z] ^ y * [~ y, z]. +Proof. by rewrite !commgEr conjgM mulgA -conjMg mulgK. Qed. + +Lemma commgMJ x y z : [~ x, y * z] = [~ x, z] * [~ x, y] ^ z. +Proof. by rewrite !commgEl conjgM -mulgA -conjMg mulKVg. Qed. + +Lemma commMgR x y z : [~ x * y, z] = [~ x, z] * [~ x, z, y] * [~ y, z]. +Proof. by rewrite commMgJ conjg_mulR. Qed. + +Lemma commgMR x y z : [~ x, y * z] = [~ x, z] * [~ x, y] * [~ x, y, z]. +Proof. by rewrite commgMJ conjg_mulR mulgA. Qed. + +Lemma Hall_Witt_identity x y z : + [~ x, y^-1, z] ^ y * [~ y, z^-1, x] ^ z * [~ z, x^-1, y] ^ x = 1. +Proof. (* gsimpl *) +pose a x y z : gT := x * z * y ^ x. +suffices{x y z} hw_aux x y z: [~ x, y^-1, z] ^ y = (a x y z)^-1 * (a y z x). + by rewrite !hw_aux 2!mulgA !mulgK mulVg. +by rewrite commgEr conjMg -conjgM -conjg_Rmul 2!invMg conjgE !mulgA. +Qed. + +(* the following properties are useful for studying p-groups of class 2 *) + +Section LeftComm. + +Variables (i : nat) (x y : gT). +Hypothesis cxz : commute x [~ x, y]. + +Lemma commVg : [~ x^-1, y] = [~ x, y]^-1. +Proof. +apply/eqP; rewrite commgEl eq_sym eq_invg_mul invgK mulgA -cxz. +by rewrite -conjg_mulR -conjMg mulgV conj1g. +Qed. + +Lemma commXg : [~ x ^+ i, y] = [~ x, y] ^+ i. +Proof. +elim: i => [|i' IHi]; first exact: comm1g. +by rewrite !expgS commMgJ /conjg commuteX // mulKg IHi. +Qed. + +End LeftComm. + +Section RightComm. + +Variables (i : nat) (x y : gT). +Hypothesis cyz : commute y [~ x, y]. +Let cyz' := commuteV cyz. + +Lemma commgV : [~ x, y^-1] = [~ x, y]^-1. +Proof. by rewrite -invg_comm commVg -(invg_comm x y) ?invgK. Qed. + +Lemma commgX : [~ x, y ^+ i] = [~ x, y] ^+ i. +Proof. by rewrite -invg_comm commXg -(invg_comm x y) ?expgVn ?invgK. Qed. + +End RightComm. + +Section LeftRightComm. + +Variables (i j : nat) (x y : gT). +Hypotheses (cxz : commute x [~ x, y]) (cyz : commute y [~ x, y]). + +Lemma commXXg : [~ x ^+ i, y ^+ j] = [~ x, y] ^+ (i * j). +Proof. rewrite expgM commgX commXg //; exact: commuteX. Qed. + +Lemma expMg_Rmul : (y * x) ^+ i = y ^+ i * x ^+ i * [~ x, y] ^+ 'C(i, 2). +Proof. +rewrite -triangular_sum; symmetry. +elim: i => [|k IHk] /=; first by rewrite big_geq ?mulg1. +rewrite big_nat_recr //= addnC expgD !expgS -{}IHk !mulgA; congr (_ * _). +by rewrite -!mulgA commuteX2 // -commgX // [mulg y]lock 3!mulgA -commgC. +Qed. + +End LeftRightComm. + +End Basic_commutator_properties. + +(***** Set theoretic commutators *****) +Section Commutator_properties. + +Variable gT : finGroupType. +Implicit Type (rT : finGroupType) (A B C : {set gT}) (D G H K : {group gT}). + +Lemma commG1 A : [~: A, 1] = 1. +Proof. by apply/commG1P; rewrite centsC sub1G. Qed. + +Lemma comm1G A : [~: 1, A] = 1. +Proof. by rewrite commGC commG1. Qed. + +Lemma commg_sub A B : [~: A, B] \subset A <*> B. +Proof. by rewrite comm_subG // (joing_subl, joing_subr). Qed. + +Lemma commg_norml G A : G \subset 'N([~: G, A]). +Proof. +apply/subsetP=> x Gx; rewrite inE -genJ gen_subG. +apply/subsetP=> _ /imsetP[_ /imset2P[y z Gy Az ->] ->]. +by rewrite -(mulgK [~ x, z] (_ ^ x)) -commMgJ !(mem_commg, groupMl, groupV). +Qed. + +Lemma commg_normr G A : G \subset 'N([~: A, G]). +Proof. by rewrite commGC commg_norml. Qed. + +Lemma commg_norm G H : G <*> H \subset 'N([~: G, H]). +Proof. by rewrite join_subG ?commg_norml ?commg_normr. Qed. + +Lemma commg_normal G H : [~: G, H] <| G <*> H. +Proof. by rewrite /(_ <| _) commg_sub commg_norm. Qed. + +Lemma normsRl A G B : A \subset G -> A \subset 'N([~: G, B]). +Proof. by move=> sAG; exact: subset_trans (commg_norml G B). Qed. + +Lemma normsRr A G B : A \subset G -> A \subset 'N([~: B, G]). +Proof. by move=> sAG; exact: subset_trans (commg_normr G B). Qed. + +Lemma commg_subr G H : ([~: G, H] \subset H) = (G \subset 'N(H)). +Proof. +rewrite gen_subG; apply/subsetP/subsetP=> [sRH x Gx | nGH xy]. + rewrite inE; apply/subsetP=> _ /imsetP[y Ky ->]. + by rewrite conjg_Rmul groupMr // sRH // mem_imset2 ?groupV. +case/imset2P=> x y Gx Hy ->{xy}. +by rewrite commgEr groupMr // memJ_norm (groupV, nGH). +Qed. + +Lemma commg_subl G H : ([~: G, H] \subset G) = (H \subset 'N(G)). +Proof. by rewrite commGC commg_subr. Qed. + +Lemma commg_subI A B G H : + A \subset 'N_G(H) -> B \subset 'N_H(G) -> [~: A, B] \subset G :&: H. +Proof. +rewrite !subsetI -(gen_subG _ 'N(G)) -(gen_subG _ 'N(H)). +rewrite -commg_subr -commg_subl; case/andP=> sAG sRH; case/andP=> sBH sRG. +by rewrite (subset_trans _ sRG) ?(subset_trans _ sRH) ?commgSS ?subset_gen. +Qed. + +Lemma quotient_cents2 A B K : + A \subset 'N(K) -> B \subset 'N(K) -> + (A / K \subset 'C(B / K)) = ([~: A, B] \subset K). +Proof. +move=> nKA nKB. +by rewrite (sameP commG1P trivgP) /= -quotientR // quotient_sub1 // comm_subG. +Qed. + +Lemma quotient_cents2r A B K : + [~: A, B] \subset K -> (A / K) \subset 'C(B / K). +Proof. +move=> sABK; rewrite -2![_ / _]morphimIdom -!quotientE. +by rewrite quotient_cents2 ?subsetIl ?(subset_trans _ sABK) ?commgSS ?subsetIr. +Qed. + +Lemma sub_der1_norm G H : G^`(1) \subset H -> H \subset G -> G \subset 'N(H). +Proof. +by move=> sG'H sHG; rewrite -commg_subr (subset_trans _ sG'H) ?commgS. +Qed. + +Lemma sub_der1_normal G H : G^`(1) \subset H -> H \subset G -> H <| G. +Proof. by move=> sG'H sHG; rewrite /(H <| G) sHG sub_der1_norm. Qed. + +Lemma sub_der1_abelian G H : G^`(1) \subset H -> abelian (G / H). +Proof. by move=> sG'H; exact: quotient_cents2r. Qed. + +Lemma der1_min G H : G \subset 'N(H) -> abelian (G / H) -> G^`(1) \subset H. +Proof. by move=> nHG abGH; rewrite -quotient_cents2. Qed. + +Lemma der_abelian n G : abelian (G^`(n) / G^`(n.+1)). +Proof. by rewrite sub_der1_abelian // der_subS. Qed. + +Lemma commg_normSl G H K : G \subset 'N(H) -> [~: G, H] \subset 'N([~: K, H]). +Proof. by move=> nHG; rewrite normsRr // commg_subr. Qed. + +Lemma commg_normSr G H K : G \subset 'N(H) -> [~: H, G] \subset 'N([~: H, K]). +Proof. by move=> nHG; rewrite !(commGC H) commg_normSl. Qed. + +Lemma commMGr G H K : [~: G, K] * [~: H, K] \subset [~: G * H , K]. +Proof. by rewrite mul_subG ?commSg ?(mulG_subl, mulG_subr). Qed. + +Lemma commMG G H K : + H \subset 'N([~: G, K]) -> [~: G * H , K] = [~: G, K] * [~: H, K]. +Proof. +move=> nRH; apply/eqP; rewrite eqEsubset commMGr andbT. +have nRHK: [~: H, K] \subset 'N([~: G, K]) by rewrite comm_subG ?commg_normr. +have defM := norm_joinEr nRHK; rewrite -defM gen_subG /=. +apply/subsetP=> _ /imset2P[_ z /imset2P[x y Gx Hy ->] Kz ->]. +by rewrite commMgJ {}defM mem_mulg ?memJ_norm ?mem_commg // (subsetP nRH). +Qed. + +Lemma comm3G1P A B C : + reflect {in A & B & C, forall h k l, [~ h, k, l] = 1} ([~: A, B, C] :==: 1). +Proof. +have R_C := sameP trivgP commG1P. +rewrite -subG1 R_C gen_subG -{}R_C gen_subG. +apply: (iffP subsetP) => [cABC x y z Ax By Cz | cABC xyz]. + by apply/set1P; rewrite cABC // !mem_imset2. +by case/imset2P=> _ z /imset2P[x y Ax By ->] Cz ->; rewrite cABC. +Qed. + +Lemma three_subgroup G H K : + [~: G, H, K] :=: 1 -> [~: H, K, G] :=: 1-> [~: K, G, H] :=: 1. +Proof. +move/eqP/comm3G1P=> cGHK /eqP/comm3G1P cHKG. +apply/eqP/comm3G1P=> x y z Kx Gy Hz; symmetry. +rewrite -(conj1g y) -(Hall_Witt_identity y^-1 z x) invgK. +by rewrite cGHK ?groupV // cHKG ?groupV // !conj1g !mul1g conjgKV. +Qed. + +Lemma der1_joing_cycles (x y : gT) : + let XY := <[x]> <*> <[y]> in let xy := [~ x, y] in + xy \in 'C(XY) -> XY^`(1) = <[xy]>. +Proof. +rewrite joing_idl joing_idr /= -sub_cent1 => /norms_gen nRxy. +apply/eqP; rewrite eqEsubset cycle_subG mem_commg ?mem_gen ?set21 ?set22 //. +rewrite der1_min // quotient_gen -1?gen_subG // quotientU abelian_gen. +rewrite /abelian subUset centU !subsetI andbC centsC -andbA -!abelianE. +rewrite !quotient_abelian ?(abelianS (subset_gen _) (cycle_abelian _)) //=. +by rewrite andbb quotient_cents2r ?genS // /commg_set imset2_set1l imset_set1. +Qed. + +Lemma commgAC G x y z : x \in G -> y \in G -> z \in G -> + commute y z -> abelian [~: [set x], G] -> [~ x, y, z] = [~ x, z, y]. +Proof. +move=> Gx Gy Gz cyz /centsP cRxG; pose cx' u := [~ x^-1, u]. +have xR3 u v: [~ x, u, v] = x^-1 * (cx' u * cx' v) * x ^ (u * v). + rewrite mulgA -conjg_mulR conjVg [cx' v]commgEl mulgA -invMg. + by rewrite -mulgA conjgM -conjMg -!commgEl. +suffices RxGcx' u: u \in G -> cx' u \in [~: [set x], G]. + by rewrite !xR3 {}cyz; congr (_ * _ * _); rewrite cRxG ?RxGcx'. +move=> Gu; suffices/groupMl <-: [~ x, u] ^ x^-1 \in [~: [set x], G]. + by rewrite -commMgJ mulgV comm1g group1. +by rewrite memJ_norm ?mem_commg ?set11 // groupV (subsetP (commg_normr _ _)). +Qed. + +(* Aschbacher, exercise 3.6 (used in proofs of Aschbacher 24.7 and B & G 1.10 *) +Lemma comm_norm_cent_cent H G K : + H \subset 'N(G) -> H \subset 'C(K) -> G \subset 'N(K) -> + [~: G, H] \subset 'C(K). +Proof. +move=> nGH /centsP cKH nKG; rewrite commGC gen_subG centsC. +apply/centsP=> x Kx _ /imset2P[y z Hy Gz ->]; red. +rewrite mulgA -[x * _]cKH ?groupV // -!mulgA; congr (_ * _). +rewrite (mulgA x) (conjgC x) (conjgCV z) 3!mulgA; congr (_ * _). +by rewrite -2!mulgA (cKH y) // -mem_conjg (normsP nKG). +Qed. + +Lemma charR H K G : H \char G -> K \char G -> [~: H, K] \char G. +Proof. +case/charP=> sHG chH /charP[sKG chK]; apply/charP. +by split=> [|f infj Gf]; [rewrite comm_subG | rewrite morphimR // chH // chK]. +Qed. + +Lemma der_char n G : G^`(n) \char G. +Proof. by elim: n => [|n IHn]; rewrite ?char_refl // dergSn charR. Qed. + +Lemma der_sub n G : G^`(n) \subset G. +Proof. by rewrite char_sub ?der_char. Qed. + +Lemma der_norm n G : G \subset 'N(G^`(n)). +Proof. by rewrite char_norm ?der_char. Qed. + +Lemma der_normal n G : G^`(n) <| G. +Proof. by rewrite char_normal ?der_char. Qed. + +Lemma der_subS n G : G^`(n.+1) \subset G^`(n). +Proof. by rewrite comm_subG. Qed. + +Lemma der_normalS n G : G^`(n.+1) <| G^`(n). +Proof. by rewrite sub_der1_normal // der_subS. Qed. + +Lemma morphim_der rT D (f : {morphism D >-> rT}) n G : + G \subset D -> f @* G^`(n) = (f @* G)^`(n). +Proof. +move=> sGD; elim: n => // n IHn. +by rewrite !dergSn -IHn morphimR ?(subset_trans (der_sub n G)). +Qed. + +Lemma dergS n G H : G \subset H -> G^`(n) \subset H^`(n). +Proof. by move=> sGH; elim: n => // n IHn; exact: commgSS. Qed. + +Lemma quotient_der n G H : G \subset 'N(H) -> G^`(n) / H = (G / H)^`(n). +Proof. exact: morphim_der. Qed. + +Lemma derJ G n x : (G :^ x)^`(n) = G^`(n) :^ x. +Proof. by elim: n => //= n IHn; rewrite !dergSn IHn -conjsRg. Qed. + +Lemma derG1P G : reflect (G^`(1) = 1) (abelian G). +Proof. exact: commG1P. Qed. + +End Commutator_properties. + +Implicit Arguments derG1P [gT G]. + +Lemma der_cont n : GFunctor.continuous (derived_at n). +Proof. by move=> aT rT G f; rewrite morphim_der. Qed. + +Canonical der_igFun n := [igFun by der_sub^~ n & der_cont n]. +Canonical der_gFun n := [gFun by der_cont n]. +Canonical der_mgFun n := [mgFun by dergS^~ n]. + +Lemma isog_der (aT rT : finGroupType) n (G : {group aT}) (H : {group rT}) : + G \isog H -> G^`(n) \isog H^`(n). +Proof. exact: gFisog. Qed. diff --git a/mathcomp/solvable/extraspecial.v b/mathcomp/solvable/extraspecial.v new file mode 100644 index 0000000..c38d17a --- /dev/null +++ b/mathcomp/solvable/extraspecial.v @@ -0,0 +1,833 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype. +Require Import bigop finset prime binomial fingroup morphism perm automorphism. +Require Import presentation quotient action commutator gproduct gfunctor. +Require Import ssralg finalg zmodp cyclic pgroup center gseries. +Require Import nilpotent sylow abelian finmodule matrix maximal extremal. + +(******************************************************************************) +(* This file contains the fine structure thorems for extraspecial p-groups. *) +(* Together with the material in the maximal and extremal libraries, it *) +(* completes the coverage of Aschbacher, section 23. *) +(* We define canonical representatives for the group classes that cover the *) +(* extremal p-groups (non-abelian p-groups with a cyclic maximal subgroup): *) +(* 'Mod_m == the modular group of order m, for m = p ^ n, p prime and n >= 3. *) +(* 'D_m == the dihedral group of order m, for m = 2n >= 4. *) +(* 'Q_m == the generalized quaternion group of order m, for q = 2 ^ n >= 8. *) +(* 'SD_m == the semi-dihedral group of order m, for m = 2 ^ n >= 16. *) +(* In each case the notation is defined in the %type, %g and %G scopes, where *) +(* it denotes a finGroupType, a full gset and the full group for that type. *) +(* However each notation is only meaningful under the given conditions, in *) +(* We construct and study the following extraspecial groups: *) +(* p^{1+2} == if p is prime, an extraspecial group of order p^3 that has *) +(* exponent p or 4, and p-rank 2: thus p^{1+2} is isomorphic to *) +(* 'D_8 if p - 2, and NOT isomorphic to 'Mod_(p^3) if p is odd. *) +(* p^{1+2*n} == the central product of n copies of p^{1+2}, thus of order *) +(* p^(1+2*n) if p is a prime, and, when n > 0, a representative *) +(* of the (unique) isomorphism class of extraspecial groups of *) +(* order p^(1+2*n), of exponent p or 4, and p-rank n+1. *) +(* 'D^n == an alternative (and preferred) notation for 2^{1+2*n}, which *) +(* is isomorphic to the central product of n copies od 'D_8. *) +(* 'D^n*Q == the central product of 'D^n with 'Q_8, thus isomorphic to *) +(* all extraspecial groups of order 2 ^ (2 * n + 3) that are *) +(* not isomorphic to 'D^n.+1 (or, equivalently, have 2-rank n). *) +(* As in extremal.v, these notations are simultaneously defined in the %type, *) +(* %g and %G scopes -- depending on the syntactic context, they denote either *) +(* a finGroupType, the set, or the group of all its elements. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope ring_scope. +Import GroupScope GRing.Theory. + +Reserved Notation "p ^{1+2}" (at level 2, format "p ^{1+2}"). +Reserved Notation "p ^{1+2* n }" + (at level 2, n at level 2, format "p ^{1+2* n }"). +Reserved Notation "''D^' n" (at level 8, n at level 2, format "''D^' n"). +Reserved Notation "''D^' n * 'Q'" + (at level 8, n at level 2, format "''D^' n * 'Q'"). + +Module Pextraspecial. + +Section Construction. + +Variable p : nat. + +Definition act ij (k : 'Z_p) := let: (i, j) := ij in (i + k * j, j). +Lemma actP : is_action [set: 'Z_p] act. +Proof. +apply: is_total_action=> [] [i j] => [|k1 k2] /=; first by rewrite mul0r addr0. +by rewrite mulrDl addrA. +Qed. +Canonical action := Action actP. + +Lemma gactP : is_groupAction [set: 'Z_p * 'Z_p] action. +Proof. +move=> k _ /=; rewrite inE. +apply/andP; split; first by apply/subsetP=> ij _; rewrite inE. +apply/morphicP=> /= [[i1 j1] [i2 j2] _ _]. +by rewrite !permE /= mulrDr -addrA (addrCA i2) (addrA i1). +Qed. +Definition groupAction := GroupAction gactP. + +Fact gtype_key : unit. Proof. by []. Qed. +Definition gtype := locked_with gtype_key (sdprod_groupType groupAction). + +Definition ngtype := ncprod [set: gtype]. + +End Construction. + +Definition ngtypeQ n := xcprod [set: ngtype 2 n] 'Q_8. + +End Pextraspecial. + +Notation "p ^{1+2}" := (Pextraspecial.gtype p) : type_scope. +Notation "p ^{1+2}" := [set: gsort p^{1+2}] : group_scope. +Notation "p ^{1+2}" := [set: gsort p^{1+2}]%G : Group_scope. + +Notation "p ^{1+2* n }" := (Pextraspecial.ngtype p n) : type_scope. +Notation "p ^{1+2* n }" := [set: gsort p^{1+2*n}] : group_scope. +Notation "p ^{1+2* n }" := [set: gsort p^{1+2*n}]%G : Group_scope. + +Notation "''D^' n" := (Pextraspecial.ngtype 2 n) : type_scope. +Notation "''D^' n" := [set: gsort 'D^n] : group_scope. +Notation "''D^' n" := [set: gsort 'D^n]%G : Group_scope. + +Notation "''D^' n * 'Q'" := (Pextraspecial.ngtypeQ n) : type_scope. +Notation "''D^' n * 'Q'" := [set: gsort 'D^n*Q] : group_scope. +Notation "''D^' n * 'Q'" := [set: gsort 'D^n*Q]%G : Group_scope. + +Section ExponentPextraspecialTheory. + +Variable p : nat. +Hypothesis p_pr : prime p. +Let p_gt1 := prime_gt1 p_pr. +Let p_gt0 := ltnW p_gt1. + +Local Notation gtype := Pextraspecial.gtype. +Local Notation actp := (Pextraspecial.groupAction p). + +Lemma card_pX1p2 : #|p^{1+2}| = (p ^ 3)%N. +Proof. +rewrite [@gtype _]unlock -(sdprod_card (sdprod_sdpair _)). +rewrite !card_injm ?injm_sdpair1 ?injm_sdpair2 // !cardsT card_prod card_ord. +by rewrite -mulnA Zp_cast. +Qed. + +Lemma Grp_pX1p2 : + p^{1+2} \isog Grp (x : y : (x ^+ p, y ^+ p, [~ x, y, x], [~ x, y, y])). +Proof. +rewrite [@gtype _]unlock ; apply: intro_isoGrp => [|rT H]. + apply/existsP; pose x := sdpair1 actp (0, 1)%R; pose y := sdpair2 actp 1%R. + exists (x, y); rewrite /= !xpair_eqE; set z := [~ x, y]; set G := _ <*> _. + have def_z: z = sdpair1 actp (1, 0)%R. + rewrite [z]commgEl -sdpair_act ?inE //=. + rewrite -morphV -?morphM ?inE //=; congr (sdpair1 _ (_, _)) => /=. + by rewrite mulr1 mulKg. + by rewrite mulVg. + have def_xi i: x ^+ i = sdpair1 _ (0, i%:R)%R. + rewrite -morphX ?inE //; congr (sdpair1 _ _). + by apply/eqP; rewrite /eq_op /= !morphX ?inE ?expg1n //=. + have def_yi i: y ^+ i = sdpair2 _ i%:R. + by rewrite -morphX ?inE //. + have def_zi i: z ^+ i = sdpair1 _ (i%:R, 0)%R. + rewrite def_z -morphX ?inE //; congr (sdpair1 _ _). + by apply/eqP; rewrite /eq_op /= !morphX ?inE ?expg1n ?andbT //=. + rewrite def_xi def_yi char_Zp ?morph1 //. + rewrite def_z -morphR ?inE // !commgEl -sdpair_act ?inE //= mulr0 addr0. + rewrite mulVg -[_ * _]/(_ , _) /= !invg1 mulg1 !mul1g mulVg morph1 !andbT. + have Gx: x \in G by rewrite -cycle_subG joing_subl. + have Gy: y \in G by rewrite -cycle_subG joing_subr. + rewrite eqEsubset subsetT -im_sdpair mulG_subG /= -/G; apply/andP; split. + apply/subsetP=> u /morphimP[[i j] _ _ def_u]. + suffices ->: u = z ^+ i * x ^+ j by rewrite groupMl groupX ?groupR. + rewrite def_zi def_xi !natr_Zp -morphM ?inE // def_u. + by congr (sdpair1 _ (_, _)); rewrite ?mulg1 ?mul1g. + apply/subsetP=> v /morphimP[k _ _ def_v]. + suffices ->: v = y ^+ k by rewrite groupX. + by rewrite def_yi natr_Zp. +case/existsP=> [[x y] /=]; set z := [~ x, y]. +case/eqP=> defH xp yp /eqP/commgP czx /eqP/commgP czy. +have zp: z ^+ p = 1 by rewrite -commXg // xp comm1g. +pose f1 (ij : 'Z_p * 'Z_p) := let: (i, j) := ij in z ^+ i * x ^+ j. +have f1M: {in setT &, {morph f1 : u v / u * v}}. + case=> /= [i1 j1] [i2 j2] _ _ /=; rewrite {3 6}Zp_cast // !expg_mod //. + rewrite !expgD !mulgA; congr (_ * _); rewrite -!mulgA; congr (_ * _). + by apply: commuteX2. +pose f2 (k : 'Z_p) := y ^+ k. +have f2M: {in setT &, {morph f2 : u v / u * v}}. + by move=> k1 k2 _ _; rewrite /f2 /= {3}Zp_cast // expg_mod // expgD. +have actf: {in setT & setT, morph_act actp 'J (Morphism f1M) (Morphism f2M)}. + case=> /= i j k _ _; rewrite modnDmr {4}Zp_cast // expg_mod // expgD. + rewrite /f2 conjMg {1}/conjg (commuteX2 i k czy) mulKg -mulgA. + congr (_ * _); rewrite (commuteX2 _ _ czx) mulnC expgM. + by rewrite -commXg // -commgX ?mulKVg // commXg // /commute commuteX. +apply/homgP; exists (xsdprod_morphism actf). +apply/eqP; rewrite eqEsubset -{2}defH -genM_join gen_subG /= im_xsdprodm. +have Hx: x \in H by rewrite -cycle_subG -defH joing_subl. +have Hy: y \in H by rewrite -cycle_subG -defH joing_subr. +rewrite mulG_subG -andbA; apply/and3P; split. +- apply/subsetP=> _ /morphimP[[i j] _ _ -> /=]. + by rewrite groupMl groupX ?groupR. +- by apply/subsetP=> _ /morphimP[k _ _ ->]; rewrite groupX. +rewrite mulgSS ?cycle_subG //= morphimEdom; apply/imsetP. + by exists (0, 1)%R; rewrite ?inE //= mul1g. +by exists 1%R; rewrite ?inE. +Qed. + +Lemma pX1p2_pgroup : p.-group p^{1+2}. +Proof. by rewrite /pgroup card_pX1p2 pnat_exp pnat_id. Qed. + +(* This is part of the existence half of Aschbacher ex. (8.7)(1) *) +Lemma pX1p2_extraspecial : extraspecial p^{1+2}. +Proof. +apply: (p3group_extraspecial pX1p2_pgroup); last first. + by rewrite card_pX1p2 pfactorK. +case/existsP: (isoGrp_hom Grp_pX1p2) card_pX1p2 => [[x y]] /=. +case/eqP=> <- xp yp _ _ oXY. +apply: contraL (dvdn_cardMg <[x]> <[y]>) => cXY_XY. +rewrite -cent_joinEl ?(sub_abelian_cent2 cXY_XY) ?joing_subl ?joing_subr //. +rewrite oXY -!orderE pfactor_dvdn ?muln_gt0 ?order_gt0 // -leqNgt. +rewrite -(pfactorK 2 p_pr) dvdn_leq_log ?expn_gt0 ?p_gt0 //. +by rewrite dvdn_mul ?order_dvdn ?xp ?yp. +Qed. + +(* This is part of the existence half of Aschbacher ex. (8.7)(1) *) +Lemma exponent_pX1p2 : odd p -> exponent p^{1+2} %| p. +Proof. +move=> p_odd; have pG := pX1p2_pgroup. +have ->: p^{1+2} = 'Ohm_1(p^{1+2}). + apply/eqP; rewrite eqEsubset Ohm_sub andbT (OhmE 1 pG). + case/existsP: (isoGrp_hom Grp_pX1p2) => [[x y]] /=. + case/eqP=> <- xp yp _ _; rewrite joing_idl joing_idr genS //. + by rewrite subsetI subset_gen subUset !sub1set !inE xp yp!eqxx. +rewrite exponent_Ohm1_class2 ?card_pX1p2 ?odd_exp // nil_class2. +by have [[_ ->] _ ] := pX1p2_extraspecial. +Qed. + +(* This is the uniqueness half of Aschbacher ex. (8.7)(1) *) +Lemma isog_pX1p2 (gT : finGroupType) (G : {group gT}) : + extraspecial G -> exponent G %| p -> #|G| = (p ^ 3)%N -> G \isog p^{1+2}. +Proof. +move=> esG expGp oG; apply/(isoGrpP _ Grp_pX1p2). +rewrite card_pX1p2; split=> //. +have pG: p.-group G by rewrite /pgroup oG pnat_exp pnat_id. +have oZ := card_center_extraspecial pG esG. +have [x Gx notZx]: exists2 x, x \in G & x \notin 'Z(G). + apply/subsetPn; rewrite proper_subn // properEcard center_sub oZ oG. + by rewrite (ltn_exp2l 1 3). +have ox: #[x] = p. + by apply: nt_prime_order; rewrite ?(exponentP expGp) ?(group1_contra notZx). +have [y Gy not_cxy]: exists2 y, y \in G & y \notin 'C[x]. + by apply/subsetPn; rewrite sub_cent1; rewrite inE Gx in notZx. +apply/existsP; exists (x, y) => /=; set z := [~ x, y]. +have [[defPhiG defG'] _] := esG. +have Zz: z \in 'Z(G) by rewrite -defG' mem_commg. +have [Gz cGz] := setIP Zz; rewrite !xpair_eqE !(exponentP expGp) //. +have [_ nZG] := andP (center_normal G). +rewrite /commg /conjg !(centP cGz) // !mulKg mulVg !eqxx !andbT. +have sXY_G: <[x]> <*> <[y]> \subset G by rewrite join_subG !cycle_subG Gx. +have defZ: <[z]> = 'Z(G). + apply/eqP; rewrite eqEcard cycle_subG Zz oZ /= -orderE. + rewrite (nt_prime_order p_pr) ?(exponentP expGp) //. + by rewrite (sameP commgP cent1P) cent1C. +have sZ_XY: 'Z(G) \subset <[x]> <*> <[y]>. + by rewrite -defZ cycle_subG groupR // mem_gen // inE cycle_id ?orbT. +rewrite eqEcard sXY_G /= oG -(Lagrange sZ_XY) oZ leq_pmul2l //. +rewrite -card_quotient ?(subset_trans sXY_G) //. +rewrite quotientY ?quotient_cycle ?cycle_subG ?(subsetP nZG) //. +have abelGz: p.-abelem (G / 'Z(G)) by rewrite -defPhiG Phi_quotient_abelem. +have [cGzGz expGz] := abelemP p_pr abelGz. +rewrite cent_joinEr ?(sub_abelian_cent2 cGzGz) ?cycle_subG ?mem_quotient //. +have oZx: #|<[coset 'Z(G) x]>| = p. + rewrite -orderE (nt_prime_order p_pr) ?expGz ?mem_quotient //. + by apply: contra notZx; move/eqP=> Zx; rewrite coset_idr ?(subsetP nZG). +rewrite TI_cardMg ?oZx -?orderE ?(nt_prime_order p_pr) ?expGz ?mem_quotient //. + apply: contra not_cxy; move/eqP=> Zy. + rewrite -cent_cycle (subsetP _ y (coset_idr _ Zy)) ?(subsetP nZG) //. + by rewrite subIset ?centS ?orbT ?cycle_subG. +rewrite prime_TIg ?oZx // cycle_subG; apply: contra not_cxy. +case/cycleP=> i; rewrite -morphX ?(subsetP nZG) // => /rcoset_kercosetP. +rewrite groupX ?(subsetP nZG) // cent1C => /(_ isT isT); apply: subsetP. +rewrite mul_subG ?sub1set ?groupX ?cent1id //= -cent_cycle subIset // orbC. +by rewrite centS ?cycle_subG. +Qed. + +End ExponentPextraspecialTheory. + +Section GeneralExponentPextraspecialTheory. + +Variable p : nat. + +Lemma pX1p2id : p^{1+2*1} \isog p^{1+2}. +Proof. exact: ncprod1. Qed. + +Lemma pX1p2S n : xcprod_spec p^{1+2} p^{1+2*n} p^{1+2*n.+1}%type. +Proof. exact: ncprodS. Qed. + +Lemma card_pX1p2n n : prime p -> #|p^{1+2*n}| = (p ^ n.*2.+1)%N. +Proof. +move=> p_pr; have pG := pX1p2_pgroup p_pr. +have oG := card_pX1p2 p_pr; have esG := pX1p2_extraspecial p_pr. +have oZ := card_center_extraspecial pG esG. +elim: n => [|n IHn]; first by rewrite (card_isog (ncprod0 _)) oZ. +case: pX1p2S => gz isoZ; rewrite -im_cpair cardMg_divn setI_im_cpair. +rewrite -injm_center ?{1}card_injm ?injm_cpairg1 ?injm_cpair1g ?center_sub //. +by rewrite oG oZ IHn -expnD mulKn ?prime_gt0. +Qed. + +Lemma pX1p2n_pgroup n : prime p -> p.-group p^{1+2*n}. +Proof. by move=> p_pr; rewrite /pgroup card_pX1p2n // pnat_exp pnat_id. Qed. + +(* This is part of the existence half of Aschbacher (23.13) *) +Lemma exponent_pX1p2n n : prime p -> odd p -> exponent p^{1+2*n} = p. +Proof. +move=> p_pr odd_p; apply: prime_nt_dvdP => //. + rewrite -dvdn1 -trivg_exponent -cardG_gt1 card_pX1p2n //. + by rewrite (ltn_exp2l 0) // prime_gt1. +elim: n => [|n IHn]. + by rewrite (dvdn_trans (exponent_dvdn _)) ?card_pX1p2n. +case: pX1p2S => gz isoZ; rewrite -im_cpair /=. +apply/exponentP=> xy; case/imset2P=> x y C1x C2y ->{xy}. +rewrite expgMn; last by red; rewrite -(centsP (im_cpair_cent isoZ)). +rewrite (exponentP _ y C2y) ?exponent_injm ?injm_cpair1g // mulg1. +by rewrite (exponentP _ x C1x) ?exponent_injm ?injm_cpairg1 // exponent_pX1p2. +Qed. + +(* This is part of the existence half of Aschbacher (23.13) and (23.14) *) +Lemma pX1p2n_extraspecial n : prime p -> n > 0 -> extraspecial p^{1+2*n}. +Proof. +move=> p_pr; elim: n => [//|n IHn _]. +have esG := pX1p2_extraspecial p_pr. +have [n0 | n_gt0] := posnP n. + by apply: isog_extraspecial esG; rewrite isog_sym n0 pX1p2id. +case: pX1p2S (pX1p2n_pgroup n.+1 p_pr) => gz isoZ pGn. +apply: (cprod_extraspecial pGn (im_cpair_cprod isoZ) (setI_im_cpair isoZ)). + by apply: injm_extraspecial esG; rewrite ?injm_cpairg1. +by apply: injm_extraspecial (IHn n_gt0); rewrite ?injm_cpair1g. +Qed. + +(* This is Aschbacher (23.12) *) +Lemma Ohm1_extraspecial_odd (gT : finGroupType) (G : {group gT}) : + p.-group G -> extraspecial G -> odd #|G| -> + let Y := 'Ohm_1(G) in + [/\ exponent Y = p, #|G : Y| %| p + & Y != G -> + exists E : {group gT}, + [/\ #|G : Y| = p, #|E| = p \/ extraspecial E, + exists2 X : {group gT}, #|X| = p & X \x E = Y + & exists M : {group gT}, + [/\ M \isog 'Mod_(p ^ 3), M \* E = G & M :&: E = 'Z(M)]]]. +Proof. +move=> pG esG oddG Y; have [spG _] := esG. +have [defPhiG defG'] := spG; set Z := 'Z(G) in defPhiG defG'. +have{spG} expG: exponent G %| p ^ 2 by exact: exponent_special. +have p_pr := extraspecial_prime pG esG. +have p_gt1 := prime_gt1 p_pr; have p_gt0 := ltnW p_gt1. +have oZ: #|Z| = p := card_center_extraspecial pG esG. +have nsZG: Z <| G := center_normal G; have [sZG nZG] := andP nsZG. +have nsYG: Y <| G := Ohm_normal 1 G; have [sYG nYG] := andP nsYG. +have ntZ: Z != 1 by rewrite -cardG_gt1 oZ. +have sZY: Z \subset Y. + by apply: contraR ntZ => ?; rewrite -(setIidPl sZG) TI_Ohm1 ?prime_TIg ?oZ. +have ntY: Y != 1 by apply: contra ntZ; rewrite -!subG1; exact: subset_trans. +have p_odd: odd p by rewrite -oZ (oddSg sZG). +have expY: exponent Y %| p by rewrite exponent_Ohm1_class2 // nil_class2 defG'. +rewrite (prime_nt_dvdP p_pr _ expY) -?dvdn1 -?trivg_exponent //. +have [-> | neYG] := eqVneq Y G; first by rewrite indexgg dvd1n eqxx; split. +have sG1Z: 'Mho^1(G) \subset Z by rewrite -defPhiG (Phi_joing pG) joing_subr. +have Z_Gp: {in G, forall x, x ^+ p \in Z}. + by move=> x Gx; rewrite /= (subsetP sG1Z) ?(Mho_p_elt 1) ?(mem_p_elt pG). +have{expG} oY': {in G :\: Y, forall u, #[u] = (p ^ 2)%N}. + move=> u /setDP[Gu notYu]; apply/eqP. + have [k ou] := p_natP (mem_p_elt pG Gu). + rewrite eqn_dvd order_dvdn (exponentP expG) // eqxx ou dvdn_Pexp2l // ltnNge. + apply: contra notYu => k_le_1; rewrite [Y](OhmE _ pG) mem_gen // !inE Gu /=. + by rewrite -order_dvdn ou dvdn_exp2l. +have isoMod3 (M : {group gT}): + M \subset G -> ~~ abelian M -> ~~ (M \subset Y) -> #|M| = (p ^ 3)%N -> + M \isog 'Mod_(p ^ 3). +- move=> sMG not_cMM /subsetPn[u Mu notYu oM]. + have pM := pgroupS sMG pG; have sUM: <[u]> \subset M by rewrite cycle_subG. + have Y'u: u \in G :\: Y by rewrite inE notYu (subsetP sMG). + have iUM: #|M : <[u]>| = p by rewrite -divgS // oM expnS -(oY' u) ?mulnK. + have cM := maximal_cycle_extremal pM not_cMM (cycle_cyclic u) sUM iUM. + rewrite (sameP eqP (prime_oddPn p_pr)) p_odd orbF in cM. + rewrite /extremal_class oM pdiv_pfactor // pfactorK //= in cM. + by do 3!case: ifP => // _ in cM. +have iYG: #|G : Y| = p. + have [V maxV sYV]: {V : {group gT} | maximal V G & Y \subset V}. + by apply: maxgroup_exists; rewrite properEneq neYG. + have [sVG [u Gu notVu]] := properP (maxgroupp maxV). + without loss [v Vv notYv]: / exists2 v, v \in V & v \notin Y. + have [->| ] := eqVneq Y V; first by rewrite (p_maximal_index pG). + by rewrite eqEsubset sYV => not_sVY; apply; exact/subsetPn. + pose U := <[u]> <*> <[v]>; have Gv := subsetP sVG v Vv. + have sUG: U \subset G by rewrite join_subG !cycle_subG Gu. + have Uu: u \in U by rewrite -cycle_subG joing_subl. + have Uv: v \in U by rewrite -cycle_subG joing_subr. + have not_sUY: ~~ (U \subset Y) by apply/subsetPn; exists v. + have sU1U: 'Ohm_1(U) \subset U := Ohm_sub 1 _. + have sU1Y: 'Ohm_1(U) \subset Y := OhmS 1 sUG. + suffices defUV: U :&: V = 'Ohm_1(U). + by rewrite (subsetP sU1Y) // -defUV inE Uv in notYv. + suffices iU1U: #|U : 'Ohm_1(U)| = p. + have: maximal 'Ohm_1(U) U by rewrite p_index_maximal ?Ohm_sub ?iU1U. + case/maxgroupP=> _; apply; rewrite /= -/U. + by apply/properP; split; last exists u; rewrite ?subsetIl ?inE ?Uu. + by rewrite subsetI Ohm_sub (subset_trans sU1Y). + apply/prime_nt_dvdP=> //. + by apply: contra not_sUY; rewrite /U; move/eqP; move/(index1g sU1U)=> <-. + have ov: #[v] = (p ^ 2)%N by rewrite oY' // inE notYv. + have sZv: Z \subset <[v]>. + suffices defZ: <[v ^+ p]> == Z by rewrite -(eqP defZ) cycleX. + by rewrite eqEcard cycle_subG Z_Gp //= oZ -orderE (orderXexp 1 ov). + have nvG: G \subset 'N(<[v]>) by rewrite sub_der1_norm ?cycle_subG // defG'. + have [cUU | not_cUU] := orP (orbN (abelian U)). + rewrite -divgS ?Ohm_sub // -(mul_card_Ohm_Mho_abelian 1 cUU) /= -/U. + by rewrite mulKn ?cardG_gt0 //= -oZ cardSg ?(subset_trans (MhoS 1 sUG)). + have oU: #|U| = (p ^ 3)%N. + have nvu := subsetP nvG u Gu; have nvU := subset_trans sUG nvG. + rewrite -(Lagrange (joing_subr _ _)) -orderE ov mulnC; congr (_ * _)%N. + rewrite -card_quotient //= quotientYidr ?cycle_subG //=. + rewrite quotient_cycle // -orderE; apply: nt_prime_order => //. + by rewrite -morphX //= coset_id // (subsetP sZv) // Z_Gp. + have svV: <[v]> \subset V by rewrite cycle_subG. + by apply: contra notVu; move/eqP=> v_u; rewrite (subsetP svV) // coset_idr. + have isoU := isoMod3 _ sUG not_cUU not_sUY oU; rewrite /= -/U in isoU. + have [//|[x y] genU modU] := generators_modular_group p_pr _ isoU. + case/modular_group_structure: genU => // _ _ _ _. + case: eqP (p_odd) => [[-> //] | _ _]; case/(_ 1%N)=> // _ oU1. + by rewrite -divgS // oU oU1 mulnK // muln_gt0 p_gt0. +have iC1U (U : {group gT}) x: + U \subset G -> x \in G :\: 'C(U) -> #|U : 'C_U[x]| = p. +- move=> sUG /setDP[Gx not_cUx]; apply/prime_nt_dvdP=> //. + apply: contra not_cUx; rewrite -sub_cent1 => /eqP sUCx. + by rewrite -(index1g _ sUCx) ?subsetIl ?subsetIr. + rewrite -(@dvdn_pmul2l (#|U| * #|'C_G[x]|)) ?muln_gt0 ?cardG_gt0 //. + have maxCx: maximal 'C_G[x] G. + rewrite cent1_extraspecial_maximal //; apply: contra not_cUx. + by rewrite inE Gx; exact: subsetP (centS sUG) _. + rewrite {1}mul_cardG setIA (setIidPl sUG) -(p_maximal_index pG maxCx) -!mulnA. + rewrite !Lagrange ?subsetIl // mulnC dvdn_pmul2l //. + have [sCxG nCxG] := andP (p_maximal_normal pG maxCx). + by rewrite -norm_joinEl ?cardSg ?join_subG ?(subset_trans sUG). +have oCG (U : {group gT}): + Z \subset U -> U \subset G -> #|'C_G(U)| = (p * #|G : U|)%N. +- elim: {U}_.+1 {-2}U (ltnSn #|U|) => // m IHm U leUm sZU sUG. + have [<- | neZU] := eqVneq Z U. + by rewrite -oZ Lagrange // (setIidPl _) // centsC subsetIr. + have{neZU} [x Gx not_cUx]: exists2 x, x \in G & x \notin 'C(U). + by apply/subsetPn; rewrite eqEsubset sZU subsetI sUG centsC in neZU. + pose W := 'C_U[x]; have iWU: #|U : W| = p by rewrite iC1U // inE not_cUx. + have maxW: maximal W U by rewrite p_index_maximal ?subsetIl ?iWU. + have ltWU: W \proper U by exact: maxgroupp maxW. + have [sWU [u Uu notWu]] := properP ltWU. + have defU: W * <[u]> = U. + have nsWU: W <| U := p_maximal_normal (pgroupS sUG pG) maxW. + by rewrite (mulg_normal_maximal nsWU) ?cycle_subG. + have sWG := subset_trans sWU sUG. + have sZW: Z \subset W. + by rewrite subsetI sZU -cent_set1 subIset ?centS ?orbT ?sub1set. + have iCW_CU: #|'C_G(W) : 'C_G(U)| = p. + rewrite -defU centM cent_cycle setIA /= -/W. + rewrite iC1U ?subsetIl ?setIS ?centS // inE andbC (subsetP sUG) //=. + rewrite -sub_cent1; apply/subsetPn; exists x. + by rewrite inE Gx -sub_cent1 subsetIr. + by rewrite -defU centM cent_cycle inE -sub_cent1 subsetIr in not_cUx. + apply/eqP; rewrite -(eqn_pmul2r p_gt0) -{1}iCW_CU Lagrange ?setIS ?centS //. + rewrite IHm ?(leq_trans (proper_card ltWU)) //= -/W. + by rewrite -(Lagrange_index sUG sWU) iWU mulnA. +have oCY: #|'C_G(Y)| = (p ^ 2)%N by rewrite oCG // iYG. +have [x cYx notZx]: exists2 x, x \in 'C_G(Y) & x \notin Z. + apply/subsetPn; rewrite proper_subn // properEcard setIS ?centS //=. + by rewrite oZ oCY (ltn_exp2l 1 2). +have{cYx} [Gx cYx] := setIP cYx; have nZx := subsetP nZG x Gx. +have defCx: 'C_G[x] = Y. + apply/eqP; rewrite eq_sym eqEcard subsetI sYG sub_cent1 cYx /=. + rewrite -(leq_pmul2r p_gt0) -{2}iYG -(iC1U G x) ?Lagrange ?subsetIl //. + by rewrite !inE Gx ?andbT in notZx *. +have Yx: x \in Y by rewrite -defCx inE Gx cent1id. +have ox: #[x] = p. + by apply: nt_prime_order; rewrite ?(exponentP expY) // (group1_contra notZx). +have defCy: 'C_G(Y) = Z * <[x]>. + apply/eqP; rewrite eq_sym eqEcard mulG_subG setIS ?centS //=. + rewrite cycle_subG inE Gx cYx oCY TI_cardMg ?oZ -?orderE ?ox //=. + by rewrite setIC prime_TIg -?orderE ?ox ?cycle_subG. +have abelYt: p.-abelem (Y / Z). + by rewrite (abelemS (quotientS _ sYG)) //= -/Z -defPhiG Phi_quotient_abelem. +have Yxt: coset Z x \in Y / Z by rewrite mem_quotient. +have{Yxt} [Et [sEtYt oEt defYt]] := p_abelem_split1 abelYt Yxt. +have nsZY: Z <| Y := normalS sZY sYG nsZG. +have [E defEt sZE sEY] := inv_quotientS nsZY sEtYt. +have{defYt} [_ defYt _ tiXEt] := dprodP defYt. +have defY: <[x]> \x E = Y. + have nZX: <[x]> \subset 'N(Z) by rewrite cycle_subG. + have TIxE: <[x]> :&: E = 1. + rewrite prime_TIg -?orderE ?ox // -(quotientSGK _ sZE) ?quotient_cycle //. + rewrite (sameP setIidPl eqP) eq_sym -defEt tiXEt -quotient_cycle //. + by rewrite -subG1 quotient_sub1 // cycle_subG. + rewrite dprodE //; last 1 first. + by rewrite cent_cycle (subset_trans sEY) //= -/Y -defCx subsetIr. + rewrite -[Y](quotientGK nsZY) -defYt cosetpreM -quotient_cycle //. + rewrite quotientK // -(normC nZX) defEt quotientGK ?(normalS _ sEY) //. + by rewrite -mulgA (mulSGid sZE). +have sEG := subset_trans sEY sYG; have nZE := subset_trans sEG nZG. +have defZE: 'Z(E) = Z. + apply/eqP; rewrite eqEsubset andbC subsetI sZE subIset ?centS ?orbT //. + rewrite -quotient_sub1 ?subIset ?nZE //= -tiXEt defEt subsetI andbC. + rewrite quotientS ?center_sub //= -quotient_cycle //. + rewrite -(quotientMidl _ <[x]>) /= -defCy quotientS // /Y. + by case/dprodP: defY => _ <- _ _; rewrite centM setIA cent_cycle defCx setSI. +have pE := pgroupS sEG pG. +rewrite iYG; split=> // _; exists E. +split=> //; first 2 [by exists [group of <[x]>]]. + have:= sZE; rewrite subEproper; case/predU1P=> [<- | ltZE]; [by left | right]. + split; rewrite /special defZE ?oZ // (Phi_joing pE). + have defE': E^`(1) = Z. + have sE'Z: E^`(1) \subset Z by rewrite -defG' dergS. + apply/eqP; rewrite eqEcard sE'Z -(prime_nt_dvdP _ _ (cardSg sE'Z)) ?oZ //=. + rewrite -trivg_card1 (sameP eqP commG1P). + by rewrite /proper sZE /= -/Z -defZE subsetI subxx in ltZE. + split=> //; rewrite -defE'; apply/joing_idPl. + by rewrite /= defE' -defPhiG (Phi_joing pG) joingC sub_gen ?subsetU ?MhoS. +have iEG: #|G : E| = (p ^ 2)%N. + apply/eqP; rewrite -(@eqn_pmul2l #|E|) // Lagrange // -(Lagrange sYG) iYG. + by rewrite -(dprod_card defY) -mulnA mulnCA -orderE ox. +pose M := 'C_G(E); exists [group of M] => /=. +have sMG: M \subset G := subsetIl _ _; have pM: p.-group M := pgroupS sMG pG. +have sZM: Z \subset M by rewrite setIS ?centS. +have oM: #|M| = (p ^ 3)%N by rewrite oCG ?iEG. +have defME: M * E = G. + apply/eqP; rewrite eqEcard mulG_subG sMG sEG /= -(leq_pmul2r p_gt0). + rewrite -{2}oZ -defZE /('Z(E)) -{2}(setIidPr sEG) setIAC -mul_cardG /= -/M. + by rewrite -(Lagrange sEG) mulnAC -mulnA mulnC iEG oM. +have defZM: 'Z(M) = Z. + apply/eqP; rewrite eqEsubset andbC subsetI sZM subIset ?centS ?orbT //=. + by rewrite /Z /('Z(G)) -{2}defME centM setIA setIAC. +rewrite cprodE 1?centsC ?subsetIr //. +rewrite defME setIAC (setIidPr sEG) defZM isoMod3 //. + rewrite abelianE (sameP setIidPl eqP) eqEcard subsetIl /= -/('Z(M)) -/M. + by rewrite defZM oZ oM (leq_exp2l 3 1). +by apply: contra neYG => sMY; rewrite eqEsubset sYG -defME mulG_subG sMY. +Qed. + +(* This is the uniqueness half of Aschbacher (23.13); the proof incorporates *) +(* in part the proof that symplectic spaces are hyperbolic (19.16). *) +Lemma isog_pX1p2n n (gT : finGroupType) (G : {group gT}) : + prime p -> extraspecial G -> #|G| = (p ^ n.*2.+1)%N -> exponent G %| p -> + G \isog p^{1+2*n}. +Proof. +move=> p_pr esG oG expG; have p_gt1 := prime_gt1 p_pr. +have not_le_p3_p: ~~ (p ^ 3 <= p) by rewrite (leq_exp2l 3 1). +have pG: p.-group G by rewrite /pgroup oG pnat_exp pnat_id. +have oZ := card_center_extraspecial pG esG. +have{pG esG} [Es p3Es defG] := extraspecial_structure pG esG. +set Z := 'Z(G) in oZ defG p3Es. +elim: Es {+}G => [|E Es IHs] S in n oG expG p3Es defG *. + rewrite big_nil cprod1g in defG; rewrite -defG. + have ->: n = 0%N. + apply: double_inj; apply/eqP. + by rewrite -eqSS -(eqn_exp2l _ _ p_gt1) -oG -defG oZ. + by rewrite isog_cyclic_card prime_cyclic ?oZ ?card_pX1p2n //=. +rewrite big_cons -cprodA in defG; rewrite /= -andbA in p3Es. +have [[_ T _ defT] defET cTE] := cprodP defG; rewrite defT in defET cTE defG. +case/and3P: p3Es; move/eqP=> oE; move/eqP=> defZE; move/IHs=> {IHs}IHs. +have not_cEE: ~~ abelian E. + by apply: contra not_le_p3_p => cEE; rewrite -oE -oZ -defZE (center_idP _). +have sES: E \subset S by rewrite -defET mulG_subl. +have sTS: T \subset S by rewrite -defET mulG_subr. +have expE: exponent E %| p by exact: dvdn_trans (exponentS sES) expG. +have expT: exponent T %| p by exact: dvdn_trans (exponentS sTS) expG. +have{expE not_cEE} isoE: E \isog p^{1+2}. + apply: isog_pX1p2 => //. + by apply: card_p3group_extraspecial p_pr oE _; rewrite defZE. +have sZT: 'Z(E) \subset T. + by case/cprodP: defT => [[U _ -> _] <- _]; rewrite defZE mulG_subr. +case def_n: n => [|n']. + case/negP: not_le_p3_p; rewrite def_n in oG; rewrite -oE -[p]oG. + exact: subset_leq_card. +have zI_ET: E :&: T = 'Z(E). + by apply/eqP; rewrite eqEsubset subsetI sZT subsetIl setIS // centsC. +have{n def_n oG} oT: #|T| = (p ^ n'.*2.+1)%N. + apply/eqP; rewrite -(eqn_pmul2l (cardG_gt0 E)) mul_cardG zI_ET defET. + by rewrite defZE oE oG oZ -expnSr -expnD def_n. +have{IHs oT expT defT Es} isoT: T \isog p^{1+2*n'} by rewrite IHs. +case: pX1p2S => gz isoZ; rewrite (isog_cprod_by _ defG) //. +exact: Aut_extraspecial_full (pX1p2_pgroup p_pr) (pX1p2_extraspecial p_pr). +Qed. + +End GeneralExponentPextraspecialTheory. + +Lemma isog_2X1p2 : 2^{1+2} \isog 'D_8. +Proof. +have pr2: prime 2 by []; have oG := card_pX1p2 pr2; rewrite -[8]oG. +case/existsP: (isoGrp_hom (Grp_pX1p2 pr2)) => [[x y]] /=. +rewrite -/2^{1+2}; case/eqP=> defG x2 y2 _ _. +have not_oG_2: ~~ (#|2^{1+2}| %| 2) by rewrite oG. +have ox: #[x] = 2. + apply: nt_prime_order => //; apply: contra not_oG_2 => x1. + by rewrite -defG (eqP x1) cycle1 joing1G order_dvdn y2. +have oy: #[y] = 2. + apply: nt_prime_order => //; apply: contra not_oG_2 => y1. + by rewrite -defG (eqP y1) cycle1 joingG1 order_dvdn x2. +rewrite -defG joing_idl joing_idr involutions_gen_dihedral //. +apply: contra not_oG_2 => eq_xy; rewrite -defG (eqP eq_xy) (joing_idPl _) //. +by rewrite -orderE oy. +Qed. + +Lemma Q8_extraspecial : extraspecial 'Q_8. +Proof. +have gt32: 3 > 2 by []; have isoQ: 'Q_8 \isog 'Q_(2 ^ 3) by exact: isog_refl. +have [[x y] genQ _] := generators_quaternion gt32 isoQ. +have [_ [defQ' defPhiQ _ _]] := quaternion_structure gt32 genQ isoQ. +case=> defZ oZ _ _ _ _ _; split; last by rewrite oZ. +by split; rewrite ?defPhiQ defZ. +Qed. + +Lemma DnQ_P n : xcprod_spec 'D^n 'Q_8 ('D^n*Q)%type. +Proof. +have pQ: 2.-group 'Q_(2 ^ 3) by rewrite /pgroup card_quaternion. +have{pQ} oZQ := card_center_extraspecial pQ Q8_extraspecial. +suffices oZDn: #|'Z('D^n)| = 2. + by apply: xcprodP; rewrite isog_cyclic_card ?prime_cyclic ?oZQ ?oZDn. +have [-> | n_gt0] := posnP n; first by rewrite center_ncprod0 card_pX1p2n. +have pr2: prime 2 by []; have pDn := pX1p2n_pgroup n pr2. +exact: card_center_extraspecial (pX1p2n_extraspecial pr2 n_gt0). +Qed. + +Lemma card_DnQ n : #|'D^n*Q| = (2 ^ n.+1.*2.+1)%N. +Proof. +have oQ: #|'Q_(2 ^ 3)| = 8 by rewrite card_quaternion. +have pQ: 2.-group 'Q_8 by rewrite /pgroup oQ. +case: DnQ_P => gz isoZ. +rewrite -im_cpair cardMg_divn setI_im_cpair cpair_center_id. +rewrite -injm_center 3?{1}card_injm ?injm_cpairg1 ?injm_cpair1g ?center_sub //. +rewrite oQ card_pX1p2n // (card_center_extraspecial pQ Q8_extraspecial). +by rewrite -muln_divA // mulnC -(expnD 2 2). +Qed. + +Lemma DnQ_pgroup n : 2.-group 'D^n*Q. +Proof. by rewrite /pgroup card_DnQ pnat_exp. Qed. + +(* Final part of the existence half of Aschbacher (23.14). *) +Lemma DnQ_extraspecial n : extraspecial 'D^n*Q. +Proof. +case: DnQ_P (DnQ_pgroup n) => gz isoZ pDnQ. +have [injDn injQ] := (injm_cpairg1 isoZ, injm_cpair1g isoZ). +have [n0 | n_gt0] := posnP n. + rewrite -im_cpair mulSGid; first exact: injm_extraspecial Q8_extraspecial. + apply/setIidPl; rewrite setI_im_cpair -injm_center //=. + by congr (_ @* _); rewrite n0 center_ncprod0. +apply: (cprod_extraspecial pDnQ (im_cpair_cprod isoZ) (setI_im_cpair _)). + exact: injm_extraspecial (pX1p2n_extraspecial _ _). +exact: injm_extraspecial Q8_extraspecial. +Qed. + +(* A special case of the uniqueness half of Achsbacher (23.14). *) +Lemma card_isog8_extraspecial (gT : finGroupType) (G : {group gT}) : + #|G| = 8 -> extraspecial G -> (G \isog 'D_8) || (G \isog 'Q_8). +Proof. +move=> oG esG; have pG: 2.-group G by rewrite /pgroup oG. +apply/norP=> [[notG_D8 notG_Q8]]. +have not_extG: extremal_class G = NotExtremal. + by rewrite /extremal_class oG andFb (negPf notG_D8) (negPf notG_Q8). +have [x Gx ox] := exponent_witness (pgroup_nil pG). +pose X := <[x]>; have cycX: cyclic X := cycle_cyclic x. +have sXG: X \subset G by rewrite cycle_subG. +have iXG: #|G : X| = 2. + by rewrite -divgS // oG -orderE -ox exponent_2extraspecial. +have not_cGG := extraspecial_nonabelian esG. +have:= maximal_cycle_extremal pG not_cGG cycX sXG iXG. +by rewrite /extremal2 not_extG. +Qed. + +(* The uniqueness half of Achsbacher (23.14). The proof incorporates in part *) +(* the proof that symplectic spces are hyperbolic (Aschbacher (19.16)), and *) +(* the determination of quadratic spaces over 'F_2 (21.2); however we use *) +(* the second part of exercise (8.4) to avoid resorting to Witt's lemma and *) +(* Galois theory as in (20.9) and (21.1). *) +Lemma isog_2extraspecial (gT : finGroupType) (G : {group gT}) n : + #|G| = (2 ^ n.*2.+1)%N -> extraspecial G -> G \isog 'D^n \/ G \isog 'D^n.-1*Q. +Proof. +elim: n G => [|n IHn] G oG esG. + case/negP: (extraspecial_nonabelian esG). + by rewrite cyclic_abelian ?prime_cyclic ?oG. +have pG: 2.-group G by rewrite /pgroup oG pnat_exp. +have oZ:= card_center_extraspecial pG esG. +have: 'Z(G) \subset 'Ohm_1(G). + apply/subsetP=> z Zz; rewrite (OhmE _ pG) mem_gen //. + by rewrite !inE -order_dvdn -oZ order_dvdG ?(subsetP (center_sub G)). +rewrite subEproper; case/predU1P=> [defG1 | ltZG1]. + have [n' n'_gt2 isoG]: exists2 n', n' > 2 & G \isog 'Q_(2 ^ n'). + apply/quaternion_classP; apply/eqP. + have not_cycG: ~~ cyclic G. + by apply: contra (extraspecial_nonabelian esG); exact: cyclic_abelian. + move: oZ; rewrite defG1; move/prime_Ohm1P; rewrite (negPf not_cycG) /=. + by apply=> //; apply: contra not_cycG; move/eqP->; exact: cyclic1. + have [n0 n'3]: n = 0%N /\ n' = 3. + have [[x y] genG _] := generators_quaternion n'_gt2 isoG. + have n'3: n' = 3. + have [_ [_ _ oG' _] _ _ _] := quaternion_structure n'_gt2 genG isoG. + apply/eqP; rewrite -(subnKC (ltnW n'_gt2)) subn2 !eqSS -(@eqn_exp2l 2) //. + by rewrite -oG' -oZ; case: esG => [[_ ->]]. + by move/eqP: oG; have [-> _ _ _] := genG; rewrite n'3 eqn_exp2l //; case n. + right; rewrite (isog_trans isoG) // n'3 n0 /=. + case: DnQ_P => z isoZ; rewrite -im_cpair mulSGid ?sub_isog ?injm_cpair1g //. + apply/setIidPl; rewrite setI_im_cpair -injm_center ?injm_cpairg1 //. + by rewrite center_ncprod0. +case/andP: ltZG1 => _; rewrite (OhmE _ pG) gen_subG. +case/subsetPn=> x; case/LdivP=> Gx x2 notZx. +have ox: #[x] = 2 by exact: nt_prime_order (group1_contra notZx). +have Z'x: x \in G :\: 'Z(G) by rewrite inE notZx. +have [E [R [[oE oR] [defG ziER]]]] := split1_extraspecial pG esG Z'x. +case=> defZE defZR [esE Ex] esR. +have isoE: E \isog 2^{1+2}. + apply: isog_trans (isog_symr isog_2X1p2). + case/orP: (card_isog8_extraspecial oE esE) => // isoE; case/negP: notZx. + have gt32: 3 > 2 by []. + have [[y z] genE _] := generators_quaternion gt32 isoE. + have [_ _ [defZx _ eq_y2 _ _] _ _] := quaternion_structure gt32 genE isoE. + by rewrite (eq_y2 x) // -cycle_subG -defZx defZE. +rewrite oG doubleS 2!expnS divnMl ?mulKn // in oR. +case: ifP esR => [_ defR | _ esR]. + have ->: n = 0%N by move/eqP: oR; rewrite defR oZ (eqn_exp2l 1) //; case n. + left; apply: isog_trans (isog_symr (ncprod1 _)). + by rewrite -defG defR -defZE cprod_center_id. +have AutZin2_1p2: Aut_in (Aut 2^{1+2}) 'Z(2^{1+2}) \isog Aut 'Z(2^{1+2}). + exact: Aut_extraspecial_full (pX1p2_pgroup _) (pX1p2_extraspecial _). +have [isoR | isoR] := IHn R oR esR. + by left; case: pX1p2S => gz isoZ; rewrite (isog_cprod_by _ defG). +have n_gt0: n > 0. + have pR: 2.-group R by rewrite /pgroup oR pnat_exp. + have:= min_card_extraspecial pR esR. + by rewrite oR leq_exp2l // ltnS (leq_double 1). +case: DnQ_P isoR => gR isoZR /=; rewrite isog_sym; case/isogP=> fR injfR im_fR. +have [injDn injQ] := (injm_cpairg1 isoZR, injm_cpair1g isoZR). +pose Dn1 := cpairg1 isoZR @* 'D^n.-1; pose Q := cpair1g isoZR @* 'Q_8. +have defR: fR @* Dn1 \* fR @* Q = R. + rewrite cprodE ?morphim_cents ?im_cpair_cent //. + by rewrite -morphimMl ?subsetT ?im_cpair. +rewrite -defR cprodA in defG. +have [[Dn _ defDn _] _ _] := cprodP defG; rewrite defDn in defG. +have isoDn: Dn \isog 'D^n. + rewrite -(prednK n_gt0); case: pX1p2S => gz isoZ. + rewrite (isog_cprod_by _ defDn) //; last 1 first. + by rewrite isog_sym (isog_trans _ (sub_isog _ _)) ?subsetT // sub_isog. + rewrite /= -morphimIim im_fR setIA ziER; apply/setIidPl. + rewrite defZE -defZR -{1}im_fR -injm_center // morphimS //. + by rewrite -cpairg1_center morphimS // center_sub. +right; case: DnQ_P => gz isoZ; rewrite (isog_cprod_by _ defG) //; first 1 last. +- exact: Aut_extraspecial_full (pX1p2n_pgroup _ _) (pX1p2n_extraspecial _ _). +- by rewrite isog_sym (isog_trans _ (sub_isog _ _)) ?subsetT // sub_isog. +rewrite /= -morphimIim; case/cprodP: defDn => _ defDn cDn1E. +rewrite setICA setIA -defDn -group_modr ?morphimS ?subsetT //. +rewrite /= im_fR (setIC R) ziER -center_prod // defZE -defZR. +rewrite mulSGid /=; last first. + by rewrite -{1}im_fR -injm_center // -cpairg1_center !morphimS ?center_sub. +rewrite -injm_center ?subsetT // -injmI // setI_im_cpair. +by rewrite -injm_center // cpairg1_center injm_center // im_fR mulGid. +Qed. + +(* The first concluding remark of Aschbacher (23.14). *) +Lemma rank_Dn n : 'r_2('D^n) = n.+1. +Proof. +elim: n => [|n IHn]; first by rewrite p_rank_abelem ?prime_abelem ?card_pX1p2n. +have oDDn: #|'D^n.+1| = (2 ^ n.+1.*2.+1)%N by exact: card_pX1p2n. +have esDDn: extraspecial 'D^n.+1 by exact: pX1p2n_extraspecial. +do [case: pX1p2S => gz isoZ; set DDn := [set: _]] in oDDn esDDn *. +have pDDn: 2.-group DDn by rewrite /pgroup oDDn pnat_exp. +apply/eqP; rewrite eqn_leq; apply/andP; split. + have [E EprE]:= p_rank_witness 2 [group of DDn]. + have [sEDDn abelE <-] := pnElemP EprE; have [pE cEE _]:= and3P abelE. + rewrite -(@leq_exp2l 2) // -p_part part_pnat_id // -leq_sqr -expnM -mulnn. + rewrite muln2 doubleS expnS -oDDn -(@leq_pmul2r #|'C_DDn(E)|) ?cardG_gt0 //. + rewrite {1}(card_subcent_extraspecial pDDn) // mulnCA -mulnA Lagrange //=. + rewrite mulnAC mulnA leq_pmul2r ?cardG_gt0 // setTI. + have ->: (2 * #|'C(E)| = #|'Z(DDn)| * #|'C(E)|)%N. + by rewrite (card_center_extraspecial pDDn). + by rewrite leq_mul ?subset_leq_card ?subsetIl. +have [inj1 injn] := (injm_cpairg1 isoZ, injm_cpair1g isoZ). +pose D := cpairg1 isoZ @* 2^{1+2}; pose Dn := cpair1g isoZ @* 'D^n. +have [E EprE] := p_rank_witness 2 [group of Dn]. +rewrite injm_p_rank //= IHn in EprE; have [sEDn abelE dimE]:= pnElemP EprE. +have [x [Dx ox] notDnx]: exists x, [/\ x \in D, #[x] = 2 & x \notin Dn]. + have isoD: D \isog 'D_(2 ^ 3). + by rewrite isog_sym -(isog_transl _ isog_2X1p2) sub_isog. + have [//| [x y] genD [oy _]] := generators_2dihedral _ isoD. + have [_ _ _ X'y] := genD; case/setDP: X'y; rewrite /= -/D => Dy notXy. + exists y; split=> //; apply: contra notXy => Dny. + case/dihedral2_structure: genD => // _ _ _ _ [defZD _ _ _ _]. + by rewrite (subsetP (cycleX x 2)) // -defZD -setI_im_cpair inE Dy. +have def_xE: <[x]> \x E = <[x]> <*> E. + rewrite dprodEY ?prime_TIg -?orderE ?ox //. + by rewrite (centSS sEDn _ (im_cpair_cent _)) ?cycle_subG. + by rewrite cycle_subG (contra (subsetP sEDn x)). +apply/p_rank_geP; exists (<[x]> <*> E)%G. +rewrite 2!inE subsetT (dprod_abelem _ def_xE) abelE -(dprod_card def_xE). +by rewrite prime_abelem -?orderE ?ox //= lognM ?cardG_gt0 ?dimE. +Qed. + +(* The second concluding remark of Aschbacher (23.14). *) +Lemma rank_DnQ n : 'r_2('D^n*Q) = n.+1. +Proof. +have pDnQ: 2.-group 'D^n*Q := DnQ_pgroup n. +have esDnQ: extraspecial 'D^n*Q := DnQ_extraspecial n. +do [case: DnQ_P => gz isoZ; set DnQ := setT] in pDnQ esDnQ *. +suffices [E]: exists2 E, E \in 'E*_2(DnQ) & logn 2 #|E| = n.+1. + by rewrite (pmaxElem_extraspecial pDnQ esDnQ); case/pnElemP=> _ _ <-. +have oZ: #|'Z(DnQ)| = 2 by exact: card_center_extraspecial. +pose Dn := cpairg1 isoZ @* 'D^n; pose Q := cpair1g isoZ @* 'Q_8. +have [injDn injQ] := (injm_cpairg1 isoZ, injm_cpair1g isoZ). +have [E EprE]:= p_rank_witness 2 [group of Dn]. +have [sEDn abelE dimE] := pnElemP EprE; have [pE cEE eE]:= and3P abelE. +rewrite injm_p_rank // rank_Dn in dimE; exists E => //. +have sZE: 'Z(DnQ) \subset E. + have maxE := subsetP (p_rankElem_max _ _) E EprE. + have abelZ: 2.-abelem 'Z(DnQ) by rewrite prime_abelem ?oZ. + rewrite -(Ohm1_id abelZ) (OhmE _ (abelem_pgroup abelZ)) gen_subG. + rewrite -(pmaxElem_LdivP _ maxE) // setSI //=. + by rewrite -cpairg1_center injm_center // setIS ?centS. +have scE: 'C_Dn(E) = E. + apply/eqP; rewrite eq_sym eqEcard subsetI sEDn -abelianE cEE /=. + have [n0 | n_gt0] := posnP n. + rewrite subset_leq_card // subIset // (subset_trans _ sZE) //. + by rewrite -cpairg1_center morphimS // n0 center_ncprod0. + have pDn: 2.-group Dn by rewrite morphim_pgroup ?pX1p2n_pgroup. + have esDn: extraspecial Dn. + exact: injm_extraspecial (pX1p2n_extraspecial _ _). + rewrite dvdn_leq ?cardG_gt0 // (card_subcent_extraspecial pDn) //=. + rewrite -injm_center // cpairg1_center (setIidPl sZE) oZ. + rewrite -(dvdn_pmul2l (cardG_gt0 E)) mulnn mulnCA Lagrange //. + rewrite card_injm ?card_pX1p2n // -expnS pfactor_dvdn ?expn_gt0 ?cardG_gt0 //. + by rewrite lognX dimE mul2n. +apply/pmaxElemP; split=> [|F E2F sEF]; first by rewrite inE subsetT abelE. +have{E2F} [_ abelF] := pElemP E2F; have [pF cFF eF] := and3P abelF. +apply/eqP; rewrite eqEsubset sEF andbT; apply/subsetP=> x Fx. +have DnQx: x \in Dn * Q by rewrite im_cpair inE. +have{DnQx} [y z Dn_y Qz def_x]:= imset2P DnQx. +have{Dn_y} Ey: y \in E. + have cEz: z \in 'C(E). + by rewrite (subsetP (centS sEDn)) // (subsetP (im_cpair_cent _)). + rewrite -scE inE Dn_y -(groupMr _ cEz) -def_x (subsetP (centS sEF)) //. + by rewrite (subsetP cFF). +rewrite def_x groupMl // (subsetP sZE) // -cpair1g_center injm_center //= -/Q. +have: z \in 'Ohm_1(Q). + rewrite (OhmE 1 (pgroupS (subsetT Q) pDnQ)) mem_gen // !inE Qz /=. + rewrite -[z](mulKg y) -def_x (exponentP eF) ?groupM //. + by rewrite groupV (subsetP sEF). +have isoQ: Q \isog 'Q_(2 ^ 3) by rewrite isog_sym sub_isog. +have [//|[u v] genQ _] := generators_quaternion _ isoQ. +by case/quaternion_structure: genQ => // _ _ [-> _ _ [-> _] _] _ _. +Qed. + +(* The final concluding remark of Aschbacher (23.14). *) +Lemma not_isog_Dn_DnQ n : ~~ ('D^n \isog 'D^n.-1*Q). +Proof. +case: n => [|n] /=; first by rewrite isogEcard card_pX1p2n // card_DnQ andbF. +apply: contraL (leqnn n.+1) => isoDn1DnQ. +by rewrite -ltnNge -rank_Dn (isog_p_rank isoDn1DnQ) rank_DnQ. +Qed. diff --git a/mathcomp/solvable/extremal.v b/mathcomp/solvable/extremal.v new file mode 100644 index 0000000..b8cb69d --- /dev/null +++ b/mathcomp/solvable/extremal.v @@ -0,0 +1,2331 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype. +Require Import bigop finset prime binomial fingroup morphism perm automorphism. +Require Import presentation quotient action commutator gproduct gfunctor. +Require Import ssralg finalg zmodp cyclic pgroup center gseries. +Require Import nilpotent sylow abelian finmodule matrix maximal. + +(******************************************************************************) +(* This file contains the definition and properties of extremal p-groups; *) +(* it covers and is mostly based on the beginning of Aschbacher, section 23, *) +(* as well as several exercises of this section. *) +(* We define canonical representatives for the group classes that cover the *) +(* extremal p-groups (non-abelian p-groups with a cyclic maximal subgroup): *) +(* 'Mod_m == the modular group of order m, for m = p ^ n, p prime and n >= 3. *) +(* 'D_m == the dihedral group of order m, for m = 2n >= 4. *) +(* 'Q_m == the generalized quaternion group of order m, for m = 2 ^ n >= 8. *) +(* 'SD_m == the semi-dihedral group of order m, for m = 2 ^ n >= 16. *) +(* In each case the notation is defined in the %type, %g and %G scopes, where *) +(* it denotes a finGroupType, a full gset and the full group for that type. *) +(* However each notation is only meaningful under the given conditions, in *) +(* 'D_m is only an extremal group for m = 2 ^ n >= 8, and 'D_8 = 'Mod_8 (they *) +(* are, in fact, beta-convertible). *) +(* We also define *) +(* extremal_generators G p n (x, y) <-> G has order p ^ n, x in G has order *) +(* p ^ n.-1, and y is in G \ <[x]>: thus <[x]> has index p in G, *) +(* so if p is prime, <[x]> is maximal in G, G is generated by x *) +(* and y, and G is extremal or abelian. *) +(* extremal_class G == the class of extremal groups G belongs to: one of *) +(* ModularGroup, Dihedral, Quaternion, SemiDihedral or NotExtremal. *) +(* extremal2 G <=> extremal_class G is one of Dihedral, Quaternion, or *) +(* SemiDihedral; this allows 'D_4 and 'D_8, but excludes 'Mod_(2^n) *) +(* for n > 3. *) +(* modular_group_generators p n (x, y) <-> y has order p and acts on x via *) +(* x ^ y = x ^+ (p ^ n.-2).+1. This is the complement to *) +(* extremal_generators G p n (x, y) for modular groups. *) +(* We provide cardinality, presentation, generator and structure theorems for *) +(* each class of extremal group. The extremal_generators predicate is used to *) +(* supply structure theorems with all the required data about G; this is *) +(* completed by an isomorphism assumption (e.g., G \isog 'D_(2 ^ n)), and *) +(* sometimes other properties (e.g., #[y] == 2 in the semidihedral case). The *) +(* generators assumption can be deduced generically from the isomorphism *) +(* assumption, or it can be proved manually for a specific choice of x and y. *) +(* The extremal_class function is used to formulate synthetic theorems that *) +(* cover several classes of extremal groups (e.g., Aschbacher ex. 8.3). *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope ring_scope. +Import GroupScope GRing.Theory. + +Reserved Notation "''Mod_' m" (at level 8, m at level 2, format "''Mod_' m"). +Reserved Notation "''D_' m" (at level 8, m at level 2, format "''D_' m"). +Reserved Notation "''SD_' m" (at level 8, m at level 2, format "''SD_' m"). +Reserved Notation "''Q_' m" (at level 8, m at level 2, format "''Q_' m"). + +Module Extremal. + +Section Construction. + +Variables q p e : nat. +(* Construct the semi-direct product of 'Z_q by 'Z_p with 1%R ^ 1%R = e%R, *) +(* if possible, i.e., if p, q > 1 and there is s \in Aut 'Z_p such that *) +(* #[s] %| p and s 1%R = 1%R ^+ e. *) + +Let a : 'Z_p := Zp1. +Let b : 'Z_q := Zp1. +Local Notation B := <[b]>. + +Definition aut_of := + odflt 1 [pick s in Aut B | p > 1 & (#[s] %| p) && (s b == b ^+ e)]. + +Lemma aut_dvdn : #[aut_of] %| #[a]. +Proof. +rewrite order_Zp1 /aut_of; case: pickP => [s | _]; last by rewrite order1. +by case/and4P=> _ p_gt1 p_s _; rewrite Zp_cast. +Qed. + +Definition act_morphism := eltm_morphism aut_dvdn. + +Definition base_act := ([Aut B] \o act_morphism)%gact. + +Lemma act_dom : <[a]> \subset act_dom base_act. +Proof. +rewrite cycle_subG 2!inE cycle_id /= eltm_id /aut_of. +by case: pickP => [op /andP[] | _] //=; rewrite group1. +Qed. + +Definition gact := (base_act \ act_dom)%gact. +Fact gtype_key : unit. Proof. by []. Qed. +Definition gtype := locked_with gtype_key (sdprod_groupType gact). + +Hypotheses (p_gt1 : p > 1) (q_gt1 : q > 1). + +Lemma card : #|[set: gtype]| = (p * q)%N. +Proof. +rewrite [gtype]unlock -(sdprod_card (sdprod_sdpair _)). +rewrite !card_injm ?injm_sdpair1 ?injm_sdpair2 //. +by rewrite mulnC -!orderE !order_Zp1 !Zp_cast. +Qed. + +Lemma Grp : (exists s, [/\ s \in Aut B, #[s] %| p & s b = b ^+ e]) -> + [set: gtype] \isog Grp (x : y : (x ^+ q, y ^+ p, x ^ y = x ^+ e)). +Proof. +rewrite [gtype]unlock => [[s [AutBs dvd_s_p sb]]]. +have memB: _ \in B by move=> c; rewrite -Zp_cycle inE. +have Aa: a \in <[a]> by rewrite !cycle_id. +have [oa ob]: #[a] = p /\ #[b] = q by rewrite !order_Zp1 !Zp_cast. +have def_s: aut_of = s. + rewrite /aut_of; case: pickP => /= [t | ]; last first. + by move/(_ s); case/and4P; rewrite sb. + case/and4P=> AutBt _ _ tb; apply: (eq_Aut AutBt) => // b_i. + case/cycleP=> i ->; rewrite -(autmE AutBt) -(autmE AutBs) !morphX //=. + by rewrite !autmE // sb (eqP tb). +apply: intro_isoGrp => [|gT G]. + apply/existsP; exists (sdpair1 _ b, sdpair2 _ a); rewrite /= !xpair_eqE. + rewrite -!morphim_cycle ?norm_joinEr ?im_sdpair ?im_sdpair_norm ?eqxx //=. + rewrite -!order_dvdn !order_injm ?injm_sdpair1 ?injm_sdpair2 // oa ob !dvdnn. + by rewrite -sdpair_act // [act _ _ _]apermE /= eltm_id -morphX // -sb -def_s. +case/existsP=> -[x y] /= /eqP[defG xq1 yp1 xy]. +have fxP: #[x] %| #[b] by rewrite order_dvdn ob xq1. +have fyP: #[y] %| #[a] by rewrite order_dvdn oa yp1. +have fP: {in <[b]> & <[a]>, morph_act gact 'J (eltm fxP) (eltm fyP)}. + move=> bj ai; case/cycleP=> j ->{bj}; case/cycleP=> i ->{ai}. + rewrite /= !eltmE def_s gactX ?groupX // conjXg morphX //=; congr (_ ^+ j). + rewrite /autact /= apermE; elim: i {j} => /= [|i IHi]. + by rewrite perm1 eltm_id conjg1. + rewrite !expgS permM sb -(autmE (groupX i AutBs)) !morphX //= {}IHi. + by rewrite -conjXg -xy -conjgM. +apply/homgP; exists (xsdprod_morphism fP). +rewrite im_xsdprodm !morphim_cycle //= !eltm_id -norm_joinEr //. +by rewrite norms_cycle xy mem_cycle. +Qed. + +End Construction. + +End Extremal. + +Section SpecializeExtremals. + +Import Extremal. + +Variable m : nat. +Let p := pdiv m. +Let q := m %/ p. + +Definition modular_gtype := gtype q p (q %/ p).+1. +Definition dihedral_gtype := gtype q 2 q.-1. +Definition semidihedral_gtype := gtype q 2 (q %/ p).-1. +Definition quaternion_kernel := + <<[set u | u ^+ 2 == 1] :\: [set u ^+ 2 | u in [set: gtype q 4 q.-1]]>>. +Definition quaternion_gtype := + locked_with gtype_key (coset_groupType quaternion_kernel). + +End SpecializeExtremals. + +Notation "''Mod_' m" := (modular_gtype m) : type_scope. +Notation "''Mod_' m" := [set: gsort 'Mod_m] : group_scope. +Notation "''Mod_' m" := [set: gsort 'Mod_m]%G : Group_scope. + +Notation "''D_' m" := (dihedral_gtype m) : type_scope. +Notation "''D_' m" := [set: gsort 'D_m] : group_scope. +Notation "''D_' m" := [set: gsort 'D_m]%G : Group_scope. + +Notation "''SD_' m" := (semidihedral_gtype m) : type_scope. +Notation "''SD_' m" := [set: gsort 'SD_m] : group_scope. +Notation "''SD_' m" := [set: gsort 'SD_m]%G : Group_scope. + +Notation "''Q_' m" := (quaternion_gtype m) : type_scope. +Notation "''Q_' m" := [set: gsort 'Q_m] : group_scope. +Notation "''Q_' m" := [set: gsort 'Q_m]%G : Group_scope. + +Section ExtremalTheory. + +Implicit Types (gT : finGroupType) (p q m n : nat). + +(* This is Aschbacher (23.3), with the isomorphism made explicit, and a *) +(* slightly reworked case analysis on the prime and exponent; in particular *) +(* the inverting involution is available for all non-trivial p-cycles. *) +Lemma cyclic_pgroup_Aut_structure gT p (G : {group gT}) : + p.-group G -> cyclic G -> G :!=: 1 -> + let q := #|G| in let n := (logn p q).-1 in + let A := Aut G in let P := 'O_p(A) in let F := 'O_p^'(A) in + exists m : {perm gT} -> 'Z_q, + [/\ [/\ {in A & G, forall a x, x ^+ m a = a x}, + m 1 = 1%R /\ {in A &, {morph m : a b / a * b >-> (a * b)%R}}, + {in A &, injective m} /\ image m A =i GRing.unit, + forall k, {in A, {morph m : a / a ^+ k >-> (a ^+ k)%R}} + & {in A, {morph m : a / a^-1 >-> (a^-1)%R}}], + [/\ abelian A, cyclic F, #|F| = p.-1 + & [faithful F, on 'Ohm_1(G) | [Aut G]]] + & if n == 0%N then A = F else + exists t, [/\ t \in A, #[t] = 2, m t = - 1%R + & if odd p then + [/\ cyclic A /\ cyclic P, + exists s, [/\ s \in A, #[s] = (p ^ n)%N, m s = p.+1%:R & P = <[s]>] + & exists s0, [/\ s0 \in A, #[s0] = p, m s0 = (p ^ n).+1%:R + & 'Ohm_1(P) = <[s0]>]] + else if n == 1%N then A = <[t]> + else exists s, + [/\ s \in A, #[s] = (2 ^ n.-1)%N, m s = 5%:R, <[s]> \x <[t]> = A + & exists s0, [/\ s0 \in A, #[s0] = 2, m s0 = (2 ^ n).+1%:R, + m (s0 * t) = (2 ^ n).-1%:R & 'Ohm_1(<[s]>) = <[s0]>]]]]. +Proof. +move=> pG cycG ntG q n0 A P F; have [p_pr p_dvd_G [n oG]] := pgroup_pdiv pG ntG. +have [x0 defG] := cyclicP cycG; have Gx0: x0 \in G by rewrite defG cycle_id. +rewrite {1}/q oG pfactorK //= in n0 *; rewrite {}/n0. +have [p_gt1 min_p] := primeP p_pr; have p_gt0 := ltnW p_gt1. +have q_gt1: q > 1 by rewrite cardG_gt1. +have cAA: abelian A := Aut_cyclic_abelian cycG; have nilA := abelian_nil cAA. +have oA: #|A| = (p.-1 * p ^ n)%N. + by rewrite card_Aut_cyclic // oG totient_pfactor. +have [sylP hallF]: p.-Sylow(A) P /\ p^'.-Hall(A) F. + by rewrite !nilpotent_pcore_Hall. +have [defPF tiPF]: P * F = A /\ P :&: F = 1. + by case/dprodP: (nilpotent_pcoreC p nilA). +have oP: #|P| = (p ^ n)%N. + by rewrite (card_Hall sylP) oA p_part logn_Gauss ?coprimenP ?pfactorK. +have oF: #|F| = p.-1. + apply/eqP; rewrite -(@eqn_pmul2l #|P|) ?cardG_gt0 // -TI_cardMg // defPF. + by rewrite oA oP mulnC. +have [m' [inj_m' defA def_m']]: exists m' : {morphism units_Zp q >-> {perm gT}}, + [/\ 'injm m', m' @* setT = A & {in G, forall x u, m' u x = x ^+ val u}]. +- rewrite /A /q defG; exists (Zp_unit_morphism x0). + by have [->]:= isomP (Zp_unit_isom x0); split=> // y Gy u; rewrite permE Gy. +pose m (a : {perm gT}) : 'Z_q := val (invm inj_m' a). +have{def_m'} def_m: {in A & G, forall a x, x ^+ m a = a x}. + by move=> a x Aa Gx /=; rewrite -{2}[a](invmK inj_m') ?defA ?def_m'. +have m1: m 1 = 1%R by rewrite /m morph1. +have mM: {in A &, {morph m : a b / a * b >-> (a * b)%R}}. + by move=> a b Aa Ab; rewrite /m morphM ?defA. +have mX k: {in A, {morph m : a / a ^+ k >-> (a ^+ k)%R}}. + by elim: k => // k IHk a Aa; rewrite expgS exprS mM ?groupX ?IHk. +have inj_m: {in A &, injective m}. + apply: can_in_inj (fun u => m' (insubd (1 : {unit 'Z_q}) u)) _ => a Aa. + by rewrite valKd invmK ?defA. +have{defA} im_m: image m A =i GRing.unit. + move=> u; apply/imageP/idP=> [[a Aa ->]| Uu]; first exact: valP. + exists (m' (Sub u Uu)) => /=; first by rewrite -defA mem_morphim ?inE. + by rewrite /m invmE ?inE. +have mV: {in A, {morph m : a / a^-1 >-> (a^-1)%R}}. + move=> a Aa /=; rewrite -div1r; apply: canRL (mulrK (valP _)) _. + by rewrite -mM ?groupV ?mulVg. +have inv_m (u : 'Z_q) : coprime q u -> {a | a \in A & m a = u}. + rewrite -?unitZpE // natr_Zp -im_m => m_u. + by exists (iinv m_u); [exact: mem_iinv | rewrite f_iinv]. +have [cycF ffulF]: cyclic F /\ [faithful F, on 'Ohm_1(G) | [Aut G]]. + have Um0 a: ((m a)%:R : 'F_p) \in GRing.unit. + have: m a \in GRing.unit by exact: valP. + by rewrite -{1}[m a]natr_Zp unitFpE ?unitZpE // {1}/q oG coprime_pexpl. + pose fm0 a := FinRing.unit 'F_p (Um0 a). + have natZqp u: (u%:R : 'Z_q)%:R = u %:R :> 'F_p. + by rewrite val_Zp_nat // -Fp_nat_mod // modn_dvdm ?Fp_nat_mod. + have m0M: {in A &, {morph fm0 : a b / a * b}}. + move=> a b Aa Ab; apply: val_inj; rewrite /= -natrM mM //. + by rewrite -[(_ * _)%R]Zp_nat natZqp. + pose m0 : {morphism A >-> {unit 'F_p}} := Morphism m0M. + have im_m0: m0 @* A = [set: {unit 'F_p}]. + apply/setP=> [[/= u Uu]]; rewrite in_setT morphimEdom; apply/imsetP. + have [|a Aa m_a] := inv_m u%:R. + by rewrite {1}[q]oG coprime_pexpl // -unitFpE // natZqp natr_Zp. + by exists a => //; apply: val_inj; rewrite /= m_a natZqp natr_Zp. + have [x1 defG1]: exists x1, 'Ohm_1(G) = <[x1]>. + by apply/cyclicP; exact: cyclicS (Ohm_sub _ _) cycG. + have ox1: #[x1] = p by rewrite orderE -defG1 (Ohm1_cyclic_pgroup_prime _ pG). + have Gx1: x1 \in G by rewrite -cycle_subG -defG1 Ohm_sub. + have ker_m0: 'ker m0 = 'C('Ohm_1(G) | [Aut G]). + apply/setP=> a; rewrite inE in_setI; apply: andb_id2l => Aa. + rewrite 3!inE /= -2!val_eqE /= val_Fp_nat // [1 %% _]modn_small // defG1. + apply/idP/subsetP=> [ma1 x1i | ma1]. + case/cycleP=> i ->{x1i}; rewrite inE gactX // -[_ a]def_m //. + by rewrite -(expg_mod_order x1) ox1 (eqP ma1). + have:= ma1 x1 (cycle_id x1); rewrite inE -[_ a]def_m //. + by rewrite (eq_expg_mod_order x1 _ 1) ox1 (modn_small p_gt1). + have card_units_Fp: #|[set: {unit 'F_p}]| = p.-1. + by rewrite card_units_Zp // pdiv_id // (@totient_pfactor p 1) ?muln1. + have ker_m0_P: 'ker m0 = P. + apply: nilpotent_Hall_pcore nilA _. + rewrite pHallE -(card_Hall sylP) oP subsetIl /=. + rewrite -(@eqn_pmul2r #|m0 @* A|) ?cardG_gt0 //; apply/eqP. + rewrite -{1}(card_isog (first_isog _)) card_quotient ?ker_norm //. + by rewrite Lagrange ?subsetIl // oA im_m0 mulnC card_units_Fp. + have inj_m0: 'ker_F m0 \subset [1] by rewrite setIC ker_m0_P tiPF. + split; last by rewrite /faithful -ker_m0. + have isogF: F \isog [set: {unit 'F_p}]. + have sFA: F \subset A by exact: pcore_sub. + apply/isogP; exists (restrm_morphism sFA m0); first by rewrite ker_restrm. + apply/eqP; rewrite eqEcard subsetT card_injm ?ker_restrm //= oF. + by rewrite card_units_Fp. + rewrite (isog_cyclic isogF) pdiv_id // -ox1 (isog_cyclic (Zp_unit_isog x1)). + by rewrite Aut_prime_cyclic // -orderE ox1. +exists m; split=> {im_m mV}//; have [n0 | n_gt0] := posnP n. + by apply/eqP; rewrite eq_sym eqEcard pcore_sub oF oA n0 muln1 /=. +have [t At mt]: {t | t \in A & m t = -1}. + apply: inv_m; rewrite /= Zp_cast // coprime_modr modn_small // subn1. + by rewrite coprimenP // ltnW. +have ot: #[t] = 2. + apply/eqP; rewrite eqn_leq order_gt1 dvdn_leq ?order_dvdn //=. + apply/eqP; move/(congr1 m); apply/eqP; rewrite mt m1 eq_sym -subr_eq0. + rewrite opprK -val_eqE /= Zp_cast ?modn_small // /q oG ltnW //. + by rewrite (leq_trans (_ : 2 ^ 2 <= p ^ 2)) ?leq_sqr ?leq_exp2l. + by apply/eqP; apply: inj_m; rewrite ?groupX ?group1 ?mX // mt -signr_odd. +exists t; split=> //. +case G4: (~~ odd p && (n == 1%N)). + case: (even_prime p_pr) G4 => [p2 | -> //]; rewrite p2 /=; move/eqP=> n1. + rewrite n1 /=; apply/eqP; rewrite eq_sym eqEcard cycle_subG At /=. + by rewrite -orderE oA ot p2 n1. +pose e0 : nat := ~~ odd p. +have{inv_m} [s As ms]: {s | s \in A & m s = (p ^ e0.+1).+1%:R}. + apply: inv_m; rewrite val_Zp_nat // coprime_modr /q oG coprime_pexpl //. + by rewrite -(@coprime_pexpl e0.+1) // coprimenS. +have lt_e0_n: e0 < n. + by rewrite /e0; case: (~~ _) G4 => //=; rewrite ltn_neqAle eq_sym => ->. +pose s0 := s ^+ (p ^ (n - e0.+1)). +have [ms0 os0]: m s0 = (p ^ n).+1%:R /\ #[s0] = p. + have m_se e: + exists2 k, k = 1 %[mod p] & m (s ^+ (p ^ e)) = (k * p ^ (e + e0.+1)).+1%:R. + - elim: e => [|e [k k1 IHe]]; first by exists 1%N; rewrite ?mul1n. + rewrite expnSr expgM mX ?groupX // {}IHe -natrX -(add1n (k * _)). + rewrite expnDn -(prednK p_gt0) 2!big_ord_recl /= prednK // !exp1n bin1. + rewrite bin0 muln1 mul1n mulnCA -expnS (addSn e). + set f := (e + _)%N; set sum := (\sum_i _)%N. + exists (sum %/ p ^ f.+2 * p + k)%N; first by rewrite modnMDl. + rewrite -(addnC k) mulnDl -mulnA -expnS divnK // {}/sum. + apply big_ind => [||[i _] /= _]; [exact: dvdn0 | exact: dvdn_add |]. + rewrite exp1n mul1n /bump !add1n expnMn mulnCA dvdn_mull // -expnM. + case: (ltnP f.+1 (f * i.+2)) => [le_f_fi|]. + by rewrite dvdn_mull ?dvdn_exp2l. + rewrite {1}mulnS -(addn1 f) leq_add2l {}/f addnS /e0. + case: i e => [] // [] //; case odd_p: (odd p) => //= _. + by rewrite bin2odd // mulnAC dvdn_mulr. + have [[|d]] := m_se (n - e0.+1)%N; first by rewrite mod0n modn_small. + move/eqP; rewrite -/s0 eqn_mod_dvd ?subn1 //=; case/dvdnP=> f -> {d}. + rewrite subnK // mulSn -mulnA -expnS -addSn natrD natrM -oG char_Zp //. + rewrite mulr0 addr0 => m_s0; split => //. + have [d _] := m_se (n - e0)%N; rewrite -subnSK // expnSr expgM -/s0. + rewrite addSn subnK // -oG mulrS natrM char_Zp // {d}mulr0 addr0. + move/eqP; rewrite -m1 (inj_in_eq inj_m) ?group1 ?groupX // -order_dvdn. + move/min_p; rewrite order_eq1; case/predU1P=> [s0_1 | ]; last by move/eqP. + move/eqP: m_s0; rewrite eq_sym s0_1 m1 -subr_eq0 mulrSr addrK -val_eqE /=. + have pf_gt0: p ^ _ > 0 by move=> e; rewrite expn_gt0 p_gt0. + by rewrite val_Zp_nat // /q oG [_ == _]pfactor_dvdn // pfactorK ?ltnn. +have os: #[s] = (p ^ (n - e0))%N. + have: #[s] %| p ^ (n - e0). + by rewrite order_dvdn -subnSK // expnSr expgM -order_dvdn os0. + case/dvdn_pfactor=> // d; rewrite leq_eqVlt. + case/predU1P=> [-> // | lt_d os]; case/idPn: (p_gt1); rewrite -os0. + by rewrite order_gt1 negbK -order_dvdn os dvdn_exp2l // -ltnS -subSn. +have p_s: p.-elt s by rewrite /p_elt os pnat_exp ?pnat_id. +have defS1: 'Ohm_1(<[s]>) = <[s0]>. + apply/eqP; rewrite eq_sym eqEcard cycle_subG -orderE os0. + rewrite (Ohm1_cyclic_pgroup_prime _ p_s) ?cycle_cyclic ?leqnn ?cycle_eq1 //=. + rewrite (OhmE _ p_s) mem_gen ?groupX //= !inE mem_cycle //. + by rewrite -order_dvdn os0 ?dvdnn. + by apply/eqP=> s1; rewrite -os0 /s0 s1 expg1n order1 in p_gt1. +case: (even_prime p_pr) => [p2 | oddp]; last first. + rewrite {+}/e0 oddp subn0 in s0 os0 ms0 os ms defS1 *. + have [f defF] := cyclicP cycF; have defP: P = <[s]>. + apply/eqP; rewrite eq_sym eqEcard -orderE oP os leqnn andbT. + by rewrite cycle_subG (mem_normal_Hall sylP) ?pcore_normal. + rewrite defP; split; last 1 [by exists s | by exists s0; rewrite ?groupX]. + rewrite -defPF defP defF -cycleM ?cycle_cyclic // /order. + by red; rewrite (centsP cAA) // -cycle_subG -defF pcore_sub. + by rewrite -defF -defP (pnat_coprime (pcore_pgroup _ _) (pcore_pgroup _ _)). +rewrite {+}/e0 p2 subn1 /= in s0 os0 ms0 os ms G4 defS1 lt_e0_n *. +rewrite G4; exists s; split=> //; last first. + exists s0; split; rewrite ?groupX //; apply/eqP; rewrite mM ?groupX //. + rewrite ms0 mt eq_sym mulrN1 -subr_eq0 opprK -natrD -addSnnS. + by rewrite prednK ?expn_gt0 // addnn -mul2n -expnS -p2 -oG char_Zp. +suffices TIst: <[s]> :&: <[t]> = 1. + rewrite dprodE //; last by rewrite (sub_abelian_cent2 cAA) ?cycle_subG. + apply/eqP; rewrite eqEcard mulG_subG !cycle_subG As At oA. + by rewrite TI_cardMg // -!orderE os ot p2 mul1n /= -expnSr prednK. +rewrite setIC; apply: prime_TIg; first by rewrite -orderE ot. +rewrite cycle_subG; apply/negP=> St. +have: t \in <[s0]>. + by rewrite -defS1 (OhmE _ p_s) mem_gen // !inE St -order_dvdn ot p2. +have ->: <[s0]> = [set 1; s0]. + apply/eqP; rewrite eq_sym eqEcard subUset !sub1set group1 cycle_id /=. + by rewrite -orderE cards2 eq_sym -order_gt1 os0. +rewrite !inE -order_eq1 ot /=; move/eqP; move/(congr1 m); move/eqP. +rewrite mt ms0 eq_sym -subr_eq0 opprK -mulrSr. +rewrite -val_eqE [val _]val_Zp_nat //= /q oG p2 modn_small //. +by rewrite -addn3 expnS mul2n -addnn leq_add2l (ltn_exp2l 1). +Qed. + +Definition extremal_generators gT (A : {set gT}) p n xy := + let: (x, y) := xy in + [/\ #|A| = (p ^ n)%N, x \in A, #[x] = (p ^ n.-1)%N & y \in A :\: <[x]>]. + +Lemma extremal_generators_facts gT (G : {group gT}) p n x y : + prime p -> extremal_generators G p n (x, y) -> + [/\ p.-group G, maximal <[x]> G, <[x]> <| G, + <[x]> * <[y]> = G & <[y]> \subset 'N(<[x]>)]. +Proof. +move=> p_pr [oG Gx ox] /setDP[Gy notXy]. +have pG: p.-group G by rewrite /pgroup oG pnat_exp pnat_id. +have maxX: maximal <[x]> G. + rewrite p_index_maximal -?divgS ?cycle_subG // -orderE oG ox. + case: (n) oG => [|n' _]; last by rewrite -expnB ?subSnn ?leqnSn ?prime_gt0. + move/eqP; rewrite -trivg_card1; case/trivgPn. + by exists y; rewrite // (group1_contra notXy). +have nsXG := p_maximal_normal pG maxX; split=> //. + by apply: mulg_normal_maximal; rewrite ?cycle_subG. +by rewrite cycle_subG (subsetP (normal_norm nsXG)). +Qed. + +Section ModularGroup. + +Variables p n : nat. +Let m := (p ^ n)%N. +Let q := (p ^ n.-1)%N. +Let r := (p ^ n.-2)%N. + +Hypotheses (p_pr : prime p) (n_gt2 : n > 2). +Let p_gt1 := prime_gt1 p_pr. +Let p_gt0 := ltnW p_gt1. +Let def_n := esym (subnKC n_gt2). +Let def_p : pdiv m = p. Proof. by rewrite /m def_n pdiv_pfactor. Qed. +Let def_q : m %/ p = q. Proof. by rewrite /m /q def_n expnS mulKn. Qed. +Let def_r : q %/ p = r. Proof. by rewrite /r /q def_n expnS mulKn. Qed. +Let ltqm : q < m. Proof. by rewrite ltn_exp2l // def_n. Qed. +Let ltrq : r < q. Proof. by rewrite ltn_exp2l // def_n. Qed. +Let r_gt0 : 0 < r. Proof. by rewrite expn_gt0 ?p_gt0. Qed. +Let q_gt1 : q > 1. Proof. exact: leq_ltn_trans r_gt0 ltrq. Qed. + +Lemma card_modular_group : #|'Mod_(p ^ n)| = (p ^ n)%N. +Proof. by rewrite Extremal.card def_p ?def_q // -expnS def_n. Qed. + +Lemma Grp_modular_group : + 'Mod_(p ^ n) \isog Grp (x : y : (x ^+ q, y ^+ p, x ^ y = x ^+ r.+1)). +Proof. +rewrite /modular_gtype def_p def_q def_r; apply: Extremal.Grp => //. +set B := <[_]>; have Bb: Zp1 \in B by exact: cycle_id. +have oB: #|B| = q by rewrite -orderE order_Zp1 Zp_cast. +have cycB: cyclic B by rewrite cycle_cyclic. +have pB: p.-group B by rewrite /pgroup oB pnat_exp ?pnat_id. +have ntB: B != 1 by rewrite -cardG_gt1 oB. +have [] := cyclic_pgroup_Aut_structure pB cycB ntB. +rewrite oB pfactorK //= -/B -(expg_znat r.+1 Bb) oB => mB [[def_mB _ _ _ _] _]. +rewrite {1}def_n /= => [[t [At ot mBt]]]. +have [p2 | ->] := even_prime p_pr; last first. + by case=> _ _ [s [As os mBs _]]; exists s; rewrite os -mBs def_mB. +rewrite {1}p2 /= -2!eqSS -addn2 -2!{1}subn1 -subnDA subnK 1?ltnW //. +case: eqP => [n3 _ | _ [_ [_ _ _ _ [s [As os mBs _ _]{t At ot mBt}]]]]. + by exists t; rewrite At ot -def_mB // mBt /q /r p2 n3. +by exists s; rewrite As os -def_mB // mBs /r p2. +Qed. + +Definition modular_group_generators gT (xy : gT * gT) := + let: (x, y) := xy in #[y] = p /\ x ^ y = x ^+ r.+1. + +Lemma generators_modular_group gT (G : {group gT}) : + G \isog 'Mod_m -> + exists2 xy, extremal_generators G p n xy & modular_group_generators xy. +Proof. +case/(isoGrpP _ Grp_modular_group); rewrite card_modular_group // -/m => oG. +case/existsP=> -[x y] /= /eqP[defG xq yp xy]. +rewrite norm_joinEr ?norms_cycle ?xy ?mem_cycle // in defG. +have [Gx Gy]: x \in G /\ y \in G. + by apply/andP; rewrite -!cycle_subG -mulG_subG defG. +have notXy: y \notin <[x]>. + apply: contraL ltqm; rewrite -cycle_subG -oG -defG; move/mulGidPl->. + by rewrite -leqNgt dvdn_leq ?(ltnW q_gt1) // order_dvdn xq. +have oy: #[y] = p by exact: nt_prime_order (group1_contra notXy). +exists (x, y) => //=; split; rewrite ?inE ?notXy //. +apply/eqP; rewrite -(eqn_pmul2r p_gt0) -expnSr -{1}oy (ltn_predK n_gt2) -/m. +by rewrite -TI_cardMg ?defG ?oG // setIC prime_TIg ?cycle_subG // -orderE oy. +Qed. + +(* This is an adaptation of Aschbacher, exercise 8.2: *) +(* - We allow an alternative to the #[x] = p ^ n.-1 condition that meshes *) +(* better with the modular_Grp lemma above. *) +(* - We state explicitly some "obvious" properties of G, namely that G is *) +(* the non-abelian semi-direct product <[x]> ><| <[y]> and that y ^+ j *) +(* acts on <[x]> via z |-> z ^+ (j * p ^ n.-2).+1 *) +(* - We also give the values of the 'Mho^k(G). *) +(* - We corrected a pair of typos. *) +Lemma modular_group_structure gT (G : {group gT}) x y : + extremal_generators G p n (x, y) -> + G \isog 'Mod_m -> modular_group_generators (x, y) -> + let X := <[x]> in + [/\ [/\ X ><| <[y]> = G, ~~ abelian G + & {in X, forall z j, z ^ (y ^+ j) = z ^+ (j * r).+1}], + [/\ 'Z(G) = <[x ^+ p]>, 'Phi(G) = 'Z(G) & #|'Z(G)| = r], + [/\ G^`(1) = <[x ^+ r]>, #|G^`(1)| = p & nil_class G = 2], + forall k, k > 0 -> 'Mho^k(G) = <[x ^+ (p ^ k)]> + & if (p, n) == (2, 3) then 'Ohm_1(G) = G else + forall k, 0 < k < n.-1 -> + <[x ^+ (p ^ (n - k.+1))]> \x <[y]> = 'Ohm_k(G) + /\ #|'Ohm_k(G)| = (p ^ k.+1)%N]. +Proof. +move=> genG isoG [oy xy] X. +have [oG Gx ox /setDP[Gy notXy]] := genG; rewrite -/m -/q in ox oG. +have [pG _ nsXG defXY nXY] := extremal_generators_facts p_pr genG. +have [sXG nXG] := andP nsXG; have sYG: <[y]> \subset G by rewrite cycle_subG. +have n1_gt1: n.-1 > 1 by [rewrite def_n]; have n1_gt0 := ltnW n1_gt1. +have def_n1 := prednK n1_gt0. +have def_m: (q * p)%N = m by rewrite -expnSr /m def_n. +have notcxy: y \notin 'C[x]. + apply: contraL (introT eqP xy); move/cent1P=> cxy. + rewrite /conjg -cxy // eq_mulVg1 expgS !mulKg -order_dvdn ox. + by rewrite pfactor_dvdn ?expn_gt0 ?p_gt0 // pfactorK // -ltnNge prednK. +have tiXY: <[x]> :&: <[y]> = 1. + rewrite setIC prime_TIg -?orderE ?oy //; apply: contra notcxy. + by rewrite cycle_subG; apply: subsetP; rewrite cycle_subG cent1id. +have notcGG: ~~ abelian G. + by rewrite -defXY abelianM !cycle_abelian cent_cycle cycle_subG. +have cXpY: <[y]> \subset 'C(<[x ^+ p]>). + rewrite cent_cycle cycle_subG cent1C (sameP cent1P commgP) /commg conjXg xy. + by rewrite -expgM mulSn expgD mulKg -expnSr def_n1 -/q -ox expg_order. +have oxp: #[x ^+ p] = r by rewrite orderXdiv ox ?dvdn_exp //. +have [sZG nZG] := andP (center_normal G). +have defZ: 'Z(G) = <[x ^+ p]>. + apply/eqP; rewrite eq_sym eqEcard subsetI -{2}defXY centM subsetI cent_cycle. + rewrite 2!cycle_subG !groupX ?cent1id //= centsC cXpY /= -orderE oxp leqNgt. + apply: contra notcGG => gtZr; apply: cyclic_center_factor_abelian. + rewrite (dvdn_prime_cyclic p_pr) // card_quotient //. + rewrite -(dvdn_pmul2l (cardG_gt0 'Z(G))) Lagrange // oG -def_m dvdn_pmul2r //. + case/p_natP: (pgroupS sZG pG) gtZr => k ->. + by rewrite ltn_exp2l // def_n1; exact: dvdn_exp2l. +have Zxr: x ^+ r \in 'Z(G) by rewrite /r def_n expnS expgM defZ mem_cycle. +have rxy: [~ x, y] = x ^+ r by rewrite /commg xy expgS mulKg. +have defG': G^`(1) = <[x ^+ r]>. + case/setIP: Zxr => _; rewrite -rxy -defXY -(norm_joinEr nXY). + exact: der1_joing_cycles. +have oG': #|G^`(1)| = p. + by rewrite defG' -orderE orderXdiv ox /q -def_n1 ?dvdn_exp2l // expnS mulnK. +have sG'Z: G^`(1) \subset 'Z(G) by rewrite defG' cycle_subG. +have nil2_G: nil_class G = 2. + by apply/eqP; rewrite eqn_leq andbC ltnNge nil_class1 notcGG nil_class2. +have XYp: {in X & <[y]>, forall z t, + (z * t) ^+ p \in z ^+ p *: <[x ^+ r ^+ 'C(p, 2)]>}. +- move=> z t Xz Yt; have Gz := subsetP sXG z Xz; have Gt := subsetP sYG t Yt. + have Rtz: [~ t, z] \in G^`(1) by exact: mem_commg. + have cGtz: [~ t, z] \in 'C(G) by case/setIP: (subsetP sG'Z _ Rtz). + rewrite expMg_Rmul /commute ?(centP cGtz) //. + have ->: t ^+ p = 1 by apply/eqP; rewrite -order_dvdn -oy order_dvdG. + rewrite defG' in Rtz; case/cycleP: Rtz => i ->. + by rewrite mem_lcoset mulg1 mulKg expgAC mem_cycle. +have defMho: 'Mho^1(G) = <[x ^+ p]>. + apply/eqP; rewrite eqEsubset cycle_subG (Mho_p_elt 1) ?(mem_p_elt pG) //. + rewrite andbT (MhoE 1 pG) gen_subG -defXY; apply/subsetP=> ztp. + case/imsetP=> zt; case/imset2P=> z t Xz Yt -> -> {zt ztp}. + apply: subsetP (XYp z t Xz Yt); case/cycleP: Xz => i ->. + by rewrite expgAC mul_subG ?sub1set ?mem_cycle //= -defZ cycle_subG groupX. +split=> //; try exact: extend_cyclic_Mho. +- rewrite sdprodE //; split=> // z; case/cycleP=> i ->{z} j. + rewrite conjXg -expgM mulnC expgM actX; congr (_ ^+ i). + elim: j {i} => //= j ->; rewrite conjXg xy -!expgM mulnS mulSn addSn. + rewrite addnA -mulSn -addSn expgD mulnCA (mulnC j). + rewrite {3}/r def_n expnS mulnA -expnSr def_n1 -/q -ox -mulnA expgM. + by rewrite expg_order expg1n mulg1. +- by rewrite (Phi_joing pG) defMho -defZ (joing_idPr _) ?defZ. +have G1y: y \in 'Ohm_1(G). + by rewrite (OhmE _ pG) mem_gen // !inE Gy -order_dvdn oy /=. +case: eqP => [[p2 n3] | notG8 k]; last case/andP=> k_gt0 lt_k_n1. + apply/eqP; rewrite eqEsubset Ohm_sub -{1}defXY mulG_subG !cycle_subG. + rewrite G1y -(groupMr _ G1y) /= (OhmE _ pG) mem_gen // !inE groupM //. + rewrite /q /r p2 n3 in oy ox xy *. + by rewrite expgS -mulgA -{1}(invg2id oy) -conjgE xy -expgS -order_dvdn ox. +have le_k_n2: k <= n.-2 by rewrite -def_n1 in lt_k_n1. +suffices{lt_k_n1} defGk: <[x ^+ (p ^ (n - k.+1))]> \x <[y]> = 'Ohm_k(G). + split=> //; case/dprodP: defGk => _ <- _ tiXkY; rewrite expnSr TI_cardMg //. + rewrite -!orderE oy (subnDA 1) subn1 orderXdiv ox ?dvdn_exp2l ?leq_subr //. + by rewrite /q -{1}(subnK (ltnW lt_k_n1)) expnD mulKn // expn_gt0 p_gt0. +suffices{k k_gt0 le_k_n2} defGn2: <[x ^+ p]> \x <[y]> = 'Ohm_(n.-2)(G). + have:= Ohm_dprod k defGn2; have p_xp := mem_p_elt pG (groupX p Gx). + rewrite (Ohm_p_cycle _ p_xp) (Ohm_p_cycle _ (mem_p_elt pG Gy)) oxp oy. + rewrite pfactorK ?(pfactorK 1) // (eqnP k_gt0) expg1 -expgM -expnS. + rewrite -subSn // -subSS def_n1 def_n => -> /=; rewrite subnSK // subn2. + by apply/eqP; rewrite eqEsubset OhmS ?Ohm_sub //= -{1}Ohm_id OhmS ?Ohm_leq. +rewrite dprodEY //=; last by apply/trivgP; rewrite -tiXY setSI ?cycleX. +apply/eqP; rewrite eqEsubset join_subG !cycle_subG /= {-2}(OhmE _ pG) -/r. +rewrite def_n (subsetP (Ohm_leq G (ltn0Sn _))) // mem_gen /=; last first. + by rewrite !inE -order_dvdn oxp groupX /=. +rewrite gen_subG /= cent_joinEr // -defXY; apply/subsetP=> uv; case/setIP. +case/imset2P=> u v Xu Yv ->{uv}; rewrite /r inE def_n expnS expgM. +case/lcosetP: (XYp u v Xu Yv) => _ /cycleP[j ->] ->. +case/cycleP: Xu => i ->{u}; rewrite -!(expgM, expgD) -order_dvdn ox. +rewrite (mulnC r) /r {1}def_n expnSr mulnA -mulnDl -mulnA -expnS. +rewrite subnSK // subn2 /q -def_n1 expnS dvdn_pmul2r // dvdn_addl. + by case/dvdnP=> k ->; rewrite mulnC expgM mem_mulg ?mem_cycle. +case: (ltngtP n 3) => [|n_gt3|n3]; first by rewrite ltnNge n_gt2. + by rewrite -subnSK // expnSr mulnA dvdn_mull. +case: (even_prime p_pr) notG8 => [-> | oddp _]; first by rewrite n3. +by rewrite bin2odd // -!mulnA dvdn_mulr. +Qed. + +End ModularGroup. + +(* Basic properties of dihedral groups; these will be refined for dihedral *) +(* 2-groups in the section on extremal 2-groups. *) +Section DihedralGroup. + +Variable q : nat. +Hypothesis q_gt1 : q > 1. +Let m := q.*2. + +Let def2 : pdiv m = 2. +Proof. +apply/eqP; rewrite /m -mul2n eqn_leq pdiv_min_dvd ?dvdn_mulr //. +by rewrite prime_gt1 // pdiv_prime // (@leq_pmul2l 2 1) ltnW. +Qed. + +Let def_q : m %/ pdiv m = q. Proof. by rewrite def2 divn2 half_double. Qed. + +Section Dihedral_extension. + +Variable p : nat. +Hypotheses (p_gt1 : p > 1) (even_p : 2 %| p). +Local Notation ED := [set: gsort (Extremal.gtype q p q.-1)]. + +Lemma card_ext_dihedral : #|ED| = (p./2 * m)%N. +Proof. by rewrite Extremal.card // /m -mul2n -divn2 mulnA divnK. Qed. + +Lemma Grp_ext_dihedral : ED \isog Grp (x : y : (x ^+ q, y ^+ p, x ^ y = x^-1)). +Proof. +suffices isoED: ED \isog Grp (x : y : (x ^+ q, y ^+ p, x ^ y = x ^+ q.-1)). + move=> gT G; rewrite isoED. + apply: eq_existsb => [[x y]] /=; rewrite !xpair_eqE. + congr (_ && _); apply: andb_id2l; move/eqP=> xq1; congr (_ && (_ == _)). + by apply/eqP; rewrite eq_sym eq_invg_mul -expgS (ltn_predK q_gt1) xq1. +have unitrN1 : - 1 \in GRing.unit by move=> R; rewrite unitrN unitr1. +pose uN1 := FinRing.unit ('Z_#[Zp1 : 'Z_q]) (unitrN1 _). +apply: Extremal.Grp => //; exists (Zp_unitm uN1). +rewrite Aut_aut order_injm ?injm_Zp_unitm ?in_setT //; split=> //. + by rewrite (dvdn_trans _ even_p) // order_dvdn -val_eqE /= mulrNN. +apply/eqP; rewrite autE ?cycle_id // eq_expg_mod_order /=. +by rewrite order_Zp1 !Zp_cast // !modn_mod (modn_small q_gt1) subn1. +Qed. + +End Dihedral_extension. + +Lemma card_dihedral : #|'D_m| = m. +Proof. by rewrite /('D_m)%type def_q card_ext_dihedral ?mul1n. Qed. + +Lemma Grp_dihedral : 'D_m \isog Grp (x : y : (x ^+ q, y ^+ 2, x ^ y = x^-1)). +Proof. by rewrite /('D_m)%type def_q; exact: Grp_ext_dihedral. Qed. + +Lemma Grp'_dihedral : 'D_m \isog Grp (x : y : (x ^+ 2, y ^+ 2, (x * y) ^+ q)). +Proof. +move=> gT G; rewrite Grp_dihedral; apply/existsP/existsP=> [] [[x y]] /=. + case/eqP=> <- xq1 y2 xy; exists (x * y, y); rewrite !xpair_eqE /= eqEsubset. + rewrite !join_subG !joing_subr !cycle_subG -{3}(mulgK y x) /=. + rewrite 2?groupM ?groupV ?mem_gen ?inE ?cycle_id ?orbT //= -mulgA expgS. + by rewrite {1}(conjgC x) xy -mulgA mulKg -(expgS y 1) y2 mulg1 xq1 !eqxx. +case/eqP=> <- x2 y2 xyq; exists (x * y, y); rewrite !xpair_eqE /= eqEsubset. +rewrite !join_subG !joing_subr !cycle_subG -{3}(mulgK y x) /=. +rewrite 2?groupM ?groupV ?mem_gen ?inE ?cycle_id ?orbT //= xyq y2 !eqxx /=. +by rewrite eq_sym eq_invg_mul !mulgA mulgK -mulgA -!(expgS _ 1) x2 y2 mulg1. +Qed. + +End DihedralGroup. + +Lemma involutions_gen_dihedral gT (x y : gT) : + let G := <<[set x; y]>> in + #[x] = 2 -> #[y] = 2 -> x != y -> G \isog 'D_#|G|. +Proof. +move=> G ox oy ne_x_y; pose q := #[x * y]. +have q_gt1: q > 1 by rewrite order_gt1 -eq_invg_mul invg_expg ox. +have homG: G \homg 'D_q.*2. + rewrite Grp'_dihedral //; apply/existsP; exists (x, y); rewrite /= !xpair_eqE. + by rewrite joing_idl joing_idr -{1}ox -oy !expg_order !eqxx. +suff oG: #|G| = q.*2 by rewrite oG isogEcard oG card_dihedral ?leqnn ?andbT. +have: #|G| %| q.*2 by rewrite -card_dihedral ?card_homg. +have Gxy: <[x * y]> \subset G. + by rewrite cycle_subG groupM ?mem_gen ?set21 ?set22. +have[k oG]: exists k, #|G| = (k * q)%N by apply/dvdnP; rewrite cardSg. +rewrite oG -mul2n dvdn_pmul2r ?order_gt0 ?dvdn_divisors // !inE /=. +case/pred2P=> [k1 | -> //]; case/negP: ne_x_y. +have cycG: cyclic G. + apply/cyclicP; exists (x * y); apply/eqP. + by rewrite eq_sym eqEcard Gxy oG k1 mul1n leqnn. +have: <[x]> == <[y]>. + by rewrite (eq_subG_cyclic cycG) ?genS ?subsetUl ?subsetUr -?orderE ?ox ?oy. +by rewrite eqEcard cycle_subG /= cycle2g // !inE -order_eq1 ox; case/andP. +Qed. + +Lemma Grp_2dihedral n : n > 1 -> + 'D_(2 ^ n) \isog Grp (x : y : (x ^+ (2 ^ n.-1), y ^+ 2, x ^ y = x^-1)). +Proof. +move=> n_gt1; rewrite -(ltn_predK n_gt1) expnS mul2n /=. +by apply: Grp_dihedral; rewrite (ltn_exp2l 0) // -(subnKC n_gt1). +Qed. + +Lemma card_2dihedral n : n > 1 -> #|'D_(2 ^ n)| = (2 ^ n)%N. +Proof. +move=> n_gt1; rewrite -(ltn_predK n_gt1) expnS mul2n /= card_dihedral //. +by rewrite (ltn_exp2l 0) // -(subnKC n_gt1). +Qed. + +Lemma card_semidihedral n : n > 3 -> #|'SD_(2 ^ n)| = (2 ^ n)%N. +Proof. +move=> n_gt3. +rewrite /('SD__)%type -(subnKC (ltnW (ltnW n_gt3))) pdiv_pfactor //. +by rewrite // !expnS !mulKn -?expnS ?Extremal.card //= (ltn_exp2l 0). +Qed. + +Lemma Grp_semidihedral n : n > 3 -> + 'SD_(2 ^ n) \isog + Grp (x : y : (x ^+ (2 ^ n.-1), y ^+ 2, x ^ y = x ^+ (2 ^ n.-2).-1)). +Proof. +move=> n_gt3. +rewrite /('SD__)%type -(subnKC (ltnW (ltnW n_gt3))) pdiv_pfactor //. +rewrite !expnS !mulKn // -!expnS /=; set q := (2 ^ _)%N. +have q_gt1: q > 1 by rewrite (ltn_exp2l 0). +apply: Extremal.Grp => //; set B := <[_]>. +have oB: #|B| = q by rewrite -orderE order_Zp1 Zp_cast. +have pB: 2.-group B by rewrite /pgroup oB pnat_exp. +have ntB: B != 1 by rewrite -cardG_gt1 oB. +have [] := cyclic_pgroup_Aut_structure pB (cycle_cyclic _) ntB. +rewrite oB /= pfactorK //= -/B => m [[def_m _ _ _ _] _]. +rewrite -{1 2}(subnKC n_gt3) => [[t [At ot _ [s [_ _ _ defA]]]]]. +case/dprodP: defA => _ defA cst _. +have{cst defA} cAt: t \in 'C(Aut B). + rewrite -defA centM inE -sub_cent1 -cent_cycle centsC cst /=. + by rewrite cent_cycle cent1id. +case=> s0 [As0 os0 _ def_s0t _]; exists (s0 * t). +rewrite -def_m ?groupM ?cycle_id // def_s0t !Zp_expg !mul1n valZpK Zp_nat. +rewrite order_dvdn expgMn /commute 1?(centP cAt) // -{1}os0 -{1}ot. +by rewrite !expg_order mul1g. +Qed. + +Section Quaternion. + +Variable n : nat. +Hypothesis n_gt2 : n > 2. +Let m := (2 ^ n)%N. +Let q := (2 ^ n.-1)%N. +Let r := (2 ^ n.-2)%N. +Let GrpQ := 'Q_m \isog Grp (x : y : (x ^+ q, y ^+ 2 = x ^+ r, x ^ y = x^-1)). +Let defQ : #|'Q_m| = m /\ GrpQ. +Proof. +have q_gt1 : q > 1 by rewrite (ltn_exp2l 0) // -(subnKC n_gt2). +have def_m : (2 * q)%N = m by rewrite -expnS (ltn_predK n_gt2). +have def_q : m %/ pdiv m = q + by rewrite /m -(ltn_predK n_gt2) pdiv_pfactor // expnS mulKn. +have r_gt1 : r > 1 by rewrite (ltn_exp2l 0) // -(subnKC n_gt2). +have def2r : (2 * r)%N = q by rewrite -expnS /q -(subnKC n_gt2). +rewrite /GrpQ [@quaternion_gtype _]unlock /quaternion_kernel {}def_q. +set B := [set: _]; have: B \homg Grp (u : v : (u ^+ q, v ^+ 4, u ^ v = u^-1)). + by rewrite -Grp_ext_dihedral ?homg_refl. +have: #|B| = (q * 4)%N by rewrite card_ext_dihedral // mulnC -muln2 -mulnA. +rewrite {}/B; move: (Extremal.gtype q 4 _) => gT. +set B := [set: gT] => oB; set K := _ :\: _. +case/existsP=> -[u v] /= /eqP[defB uq v4 uv]. +have nUV: <[v]> \subset 'N(<[u]>) by rewrite norms_cycle uv groupV cycle_id. +rewrite norm_joinEr // in defB. +have le_ou: #[u] <= q by rewrite dvdn_leq ?expn_gt0 // order_dvdn uq. +have le_ov: #[v] <= 4 by rewrite dvdn_leq // order_dvdn v4. +have tiUV: <[u]> :&: <[v]> = 1 by rewrite cardMg_TI // defB oB leq_mul. +have{le_ou le_ov} [ou ov]: #[u] = q /\ #[v] = 4. + have:= esym (leqif_mul (leqif_eq le_ou) (leqif_eq le_ov)).2. + by rewrite -TI_cardMg // defB -oB eqxx eqn0Ngt cardG_gt0; do 2!case: eqP=> //. +have sdB: <[u]> ><| <[v]> = B by rewrite sdprodE. +have uvj j: u ^ (v ^+ j) = (if odd j then u^-1 else u). + elim: j => [|j IHj]; first by rewrite conjg1. + by rewrite expgS conjgM uv conjVg IHj (fun_if invg) invgK if_neg. +have sqrB i j: (u ^+ i * v ^+ j) ^+ 2 = (if odd j then v ^+ 2 else u ^+ i.*2). + rewrite expgS; case: ifP => odd_j. + rewrite {1}(conjgC (u ^+ i)) conjXg uvj odd_j expgVn -mulgA mulKg. + rewrite -expgD addnn -(odd_double_half j) odd_j doubleD addnC /=. + by rewrite -(expg_mod _ v4) -!muln2 -mulnA modnMDl. + rewrite {2}(conjgC (u ^+ i)) conjXg uvj odd_j mulgA -(mulgA (u ^+ i)). + rewrite -expgD addnn -(odd_double_half j) odd_j -2!mul2n mulnA. + by rewrite expgM v4 expg1n mulg1 -expgD addnn. +pose w := u ^+ r * v ^+ 2. +have Kw: w \in K. + rewrite !inE sqrB /= -mul2n def2r uq eqxx andbT -defB. + apply/imsetP=> [[_]] /imset2P[_ _ /cycleP[i ->] /cycleP[j ->] ->]. + apply/eqP; rewrite sqrB; case: ifP => _. + rewrite eq_mulgV1 mulgK -order_dvdn ou pfactor_dvdn ?expn_gt0 ?pfactorK //. + by rewrite -ltnNge -(subnKC n_gt2). + rewrite (canF_eq (mulKg _)); apply/eqP=> def_v2. + suffices: v ^+ 2 \in <[u]> :&: <[v]> by rewrite tiUV inE -order_dvdn ov. + by rewrite inE {1}def_v2 groupM ?groupV !mem_cycle. +have ow: #[w] = 2. + case/setDP: Kw; rewrite inE -order_dvdn dvdn_divisors // !inE /= order_eq1. + by case/orP=> /eqP-> // /imsetP[]; exists 1; rewrite ?inE ?expg1n. +have defK: K = [set w]. + apply/eqP; rewrite eqEsubset sub1set Kw andbT subDset setUC. + apply/subsetP=> uivj; have: uivj \in B by rewrite inE. + rewrite -{1}defB => /imset2P[_ _ /cycleP[i ->] /cycleP[j ->] ->] {uivj}. + rewrite !inE sqrB -{-1}[j]odd_double_half. + case: (odd j); rewrite -order_dvdn ?ov // ou -def2r -mul2n dvdn_pmul2l //. + case/dvdnP=> k ->{i}; apply/orP. + rewrite add0n -[j./2]odd_double_half addnC doubleD -!muln2 -mulnA. + rewrite -(expg_mod_order v) ov modnMDl; case: (odd _); last first. + right; rewrite mulg1 /r -(subnKC n_gt2) expnSr mulnA expgM. + by apply: mem_imset; rewrite inE. + rewrite (inj_eq (mulIg _)) -expg_mod_order ou -[k]odd_double_half. + rewrite addnC -muln2 mulnDl -mulnA def2r modnMDl -ou expg_mod_order. + case: (odd k); [left | right]; rewrite ?mul1n ?mul1g //. + by apply/imsetP; exists v; rewrite ?inE. +have nKB: 'N(<>) = B. + apply/setP=> b; rewrite !inE -genJ genS // {1}defK conjg_set1 sub1set. + have:= Kw; rewrite !inE -!order_dvdn orderJ ow !andbT; apply: contra. + case/imsetP=> z _ def_wb; apply/imsetP; exists (z ^ b^-1); rewrite ?inE //. + by rewrite -conjXg -def_wb conjgK. +rewrite -im_quotient card_quotient // nKB -divgS ?subsetT //. +split; first by rewrite oB defK -orderE ow (mulnA q 2 2) mulnK // mulnC. +apply: intro_isoGrp => [|rT H]. + apply/existsP; exists (coset _ u, coset _ v); rewrite /= !xpair_eqE. + rewrite -!morphX -?morphJ -?morphV /= ?nKB ?in_setT // uq uv morph1 !eqxx. + rewrite -/B -defB -norm_joinEr // quotientY ?nKB ?subsetT //= andbT. + rewrite !quotient_cycle /= ?nKB ?in_setT ?eqxx //=. + by rewrite -(coset_kerl _ (mem_gen Kw)) -mulgA -expgD v4 mulg1. +case/existsP=> -[x y] /= /eqP[defH xq y2 xy]. +have ox: #[x] %| #[u] by rewrite ou order_dvdn xq. +have oy: #[y] %| #[v]. + by rewrite ov order_dvdn (expgM y 2 2) y2 -expgM mulnC def2r xq. +have actB: {in <[u]> & <[v]>, morph_act 'J 'J (eltm ox) (eltm oy)}. + move=> _ _ /cycleP[i ->] /cycleP[j ->] /=. + rewrite conjXg uvj fun_if if_arg fun_if expgVn morphV ?mem_cycle //= !eltmE. + rewrite -expgVn -if_arg -fun_if conjXg; congr (_ ^+ i). + rewrite -{2}[j]odd_double_half addnC expgD -mul2n expgM y2. + rewrite -expgM conjgM (conjgE x) commuteX // mulKg. + by case: (odd j); rewrite ?conjg1. +pose f := sdprodm sdB actB. +have Kf: 'ker (coset <>) \subset 'ker f. + rewrite ker_coset defK cycle_subG /= ker_sdprodm. + apply/imset2P; exists (u ^+ r) (v ^+ 2); first exact: mem_cycle. + by rewrite inE mem_cycle /= !eltmE y2. + by apply: canRL (mulgK _) _; rewrite -mulgA -expgD v4 mulg1. +have Df: 'dom f \subset 'dom (coset <>) by rewrite /dom nKB subsetT. +apply/homgP; exists (factm_morphism Kf Df); rewrite morphim_factm /= -/B. +rewrite -{2}defB morphim_sdprodm // !morphim_cycle ?cycle_id //= !eltm_id. +by rewrite -norm_joinEr // norms_cycle xy groupV cycle_id. +Qed. + +Lemma card_quaternion : #|'Q_m| = m. Proof. by case defQ. Qed. +Lemma Grp_quaternion : GrpQ. Proof. by case defQ. Qed. + +End Quaternion. + +Lemma eq_Mod8_D8 : 'Mod_8 = 'D_8. Proof. by []. Qed. + +Section ExtremalStructure. + +Variables (gT : finGroupType) (G : {group gT}) (n : nat). +Implicit Type H : {group gT}. + +Let m := (2 ^ n)%N. +Let q := (2 ^ n.-1)%N. +Let q_gt0: q > 0. Proof. by rewrite expn_gt0. Qed. +Let r := (2 ^ n.-2)%N. +Let r_gt0: r > 0. Proof. by rewrite expn_gt0. Qed. + +Let def2qr : n > 1 -> [/\ 2 * q = m, 2 * r = q, q < m & r < q]%N. +Proof. by rewrite /q /m /r; move/subnKC=> <-; rewrite !ltn_exp2l ?expnS. Qed. + +Lemma generators_2dihedral : + n > 1 -> G \isog 'D_m -> + exists2 xy, extremal_generators G 2 n xy + & let: (x, y) := xy in #[y] = 2 /\ x ^ y = x^-1. +Proof. +move=> n_gt1; have [def2q _ ltqm _] := def2qr n_gt1. +case/(isoGrpP _ (Grp_2dihedral n_gt1)); rewrite card_2dihedral // -/ m => oG. +case/existsP=> -[x y] /=; rewrite -/q => /eqP[defG xq y2 xy]. +have{defG} defG: <[x]> * <[y]> = G. + by rewrite -norm_joinEr // norms_cycle xy groupV cycle_id. +have notXy: y \notin <[x]>. + apply: contraL ltqm => Xy; rewrite -leqNgt -oG -defG mulGSid ?cycle_subG //. + by rewrite dvdn_leq // order_dvdn xq. +have oy: #[y] = 2 by exact: nt_prime_order (group1_contra notXy). +have ox: #[x] = q. + apply: double_inj; rewrite -muln2 -oy -mul2n def2q -oG -defG TI_cardMg //. + by rewrite setIC prime_TIg ?cycle_subG // -orderE oy. +exists (x, y) => //=. +by rewrite oG ox !inE notXy -!cycle_subG /= -defG mulG_subl mulG_subr. +Qed. + +Lemma generators_semidihedral : + n > 3 -> G \isog 'SD_m -> + exists2 xy, extremal_generators G 2 n xy + & let: (x, y) := xy in #[y] = 2 /\ x ^ y = x ^+ r.-1. +Proof. +move=> n_gt3; have [def2q _ ltqm _] := def2qr (ltnW (ltnW n_gt3)). +case/(isoGrpP _ (Grp_semidihedral n_gt3)). +rewrite card_semidihedral // -/m => oG. +case/existsP=> -[x y] /=; rewrite -/q -/r => /eqP[defG xq y2 xy]. +have{defG} defG: <[x]> * <[y]> = G. + by rewrite -norm_joinEr // norms_cycle xy mem_cycle. +have notXy: y \notin <[x]>. + apply: contraL ltqm => Xy; rewrite -leqNgt -oG -defG mulGSid ?cycle_subG //. + by rewrite dvdn_leq // order_dvdn xq. +have oy: #[y] = 2 by exact: nt_prime_order (group1_contra notXy). +have ox: #[x] = q. + apply: double_inj; rewrite -muln2 -oy -mul2n def2q -oG -defG TI_cardMg //. + by rewrite setIC prime_TIg ?cycle_subG // -orderE oy. +exists (x, y) => //=. +by rewrite oG ox !inE notXy -!cycle_subG /= -defG mulG_subl mulG_subr. +Qed. + +Lemma generators_quaternion : + n > 2 -> G \isog 'Q_m -> + exists2 xy, extremal_generators G 2 n xy + & let: (x, y) := xy in [/\ #[y] = 4, y ^+ 2 = x ^+ r & x ^ y = x^-1]. +Proof. +move=> n_gt2; have [def2q def2r ltqm _] := def2qr (ltnW n_gt2). +case/(isoGrpP _ (Grp_quaternion n_gt2)); rewrite card_quaternion // -/m => oG. +case/existsP=> -[x y] /=; rewrite -/q -/r => /eqP[defG xq y2 xy]. +have{defG} defG: <[x]> * <[y]> = G. + by rewrite -norm_joinEr // norms_cycle xy groupV cycle_id. +have notXy: y \notin <[x]>. + apply: contraL ltqm => Xy; rewrite -leqNgt -oG -defG mulGSid ?cycle_subG //. + by rewrite dvdn_leq // order_dvdn xq. +have ox: #[x] = q. + apply/eqP; rewrite eqn_leq dvdn_leq ?order_dvdn ?xq //=. + rewrite -(leq_pmul2r (order_gt0 y)) mul_cardG defG oG -def2q mulnAC mulnC. + rewrite leq_pmul2r // dvdn_leq ?muln_gt0 ?cardG_gt0 // order_dvdn expgM. + by rewrite -order_dvdn order_dvdG //= inE {1}y2 !mem_cycle. +have oy2: #[y ^+ 2] = 2 by rewrite y2 orderXdiv ox -def2r ?dvdn_mull ?mulnK. +exists (x, y) => /=; last by rewrite (orderXprime oy2). +by rewrite oG !inE notXy -!cycle_subG /= -defG mulG_subl mulG_subr. +Qed. + +Variables x y : gT. +Implicit Type M : {group gT}. + +Let X := <[x]>. +Let Y := <[y]>. +Let yG := y ^: G. +Let xyG := (x * y) ^: G. +Let My := <>. +Let Mxy := <>. + + +Theorem dihedral2_structure : + n > 1 -> extremal_generators G 2 n (x, y) -> G \isog 'D_m -> + [/\ [/\ X ><| Y = G, {in G :\: X, forall t, #[t] = 2} + & {in X & G :\: X, forall z t, z ^ t = z^-1}], + [/\ G ^`(1) = <[x ^+ 2]>, 'Phi(G) = G ^`(1), #|G^`(1)| = r + & nil_class G = n.-1], + 'Ohm_1(G) = G /\ (forall k, k > 0 -> 'Mho^k(G) = <[x ^+ (2 ^ k)]>), + [/\ yG :|: xyG = G :\: X, [disjoint yG & xyG] + & forall M, maximal M G = pred3 X My Mxy M] + & if n == 2 then (2.-abelem G : Prop) else + [/\ 'Z(G) = <[x ^+ r]>, #|'Z(G)| = 2, + My \isog 'D_q, Mxy \isog 'D_q + & forall U, cyclic U -> U \subset G -> #|G : U| = 2 -> U = X]]. +Proof. +move=> n_gt1 genG isoG; have [def2q def2r ltqm ltrq] := def2qr n_gt1. +have [oG Gx ox X'y] := genG; rewrite -/m -/q -/X in oG ox X'y. +case/extremal_generators_facts: genG; rewrite -/X // => pG maxX nsXG defXY nXY. +have [sXG nXG]:= andP nsXG; have [Gy notXy]:= setDP X'y. +have ox2: #[x ^+ 2] = r by rewrite orderXdiv ox -def2r ?dvdn_mulr ?mulKn. +have oxr: #[x ^+ r] = 2 by rewrite orderXdiv ox -def2r ?dvdn_mull ?mulnK. +have [[u v] [_ Gu ou U'v] [ov uv]] := generators_2dihedral n_gt1 isoG. +have defUv: <[u]> :* v = G :\: <[u]>. + apply: rcoset_index2; rewrite -?divgS ?cycle_subG //. + by rewrite oG -orderE ou -def2q mulnK. +have invUV: {in <[u]> & <[u]> :* v, forall z t, z ^ t = z^-1}. + move=> z t; case/cycleP=> i ->; case/rcosetP=> z'; case/cycleP=> j -> ->{z t}. + by rewrite conjgM {2}/conjg commuteX2 // mulKg conjXg uv expgVn. +have oU': {in <[u]> :* v, forall t, #[t] = 2}. + move=> t Uvt; apply: nt_prime_order => //; last first. + by case: eqP Uvt => // ->; rewrite defUv !inE group1. + case/rcosetP: Uvt => z Uz ->{t}; rewrite expgS {1}(conjgC z) -mulgA. + by rewrite invUV ?rcoset_refl // mulKg -(expgS v 1) -ov expg_order. +have defU: n > 2 -> {in G, forall z, #[z] = q -> <[z]> = <[u]>}. + move=> n_gt2 z Gz oz; apply/eqP; rewrite eqEcard -!orderE oz cycle_subG. + apply: contraLR n_gt2; rewrite ou leqnn andbT -(ltn_predK n_gt1) => notUz. + by rewrite ltnS -(@ltn_exp2l 2) // -/q -oz oU' // defUv inE notUz. +have n2_abelG: (n > 2) || 2.-abelem G. + rewrite ltn_neqAle eq_sym n_gt1; case: eqP => //= n2. + apply/abelemP=> //; split=> [|z Gz]. + by apply: (p2group_abelian pG); rewrite oG pfactorK ?n2. + case Uz: (z \in <[u]>); last by rewrite -expg_mod_order oU' // defUv inE Uz. + apply/eqP; rewrite -order_dvdn (dvdn_trans (order_dvdG Uz)) // -orderE. + by rewrite ou /q n2. +have{oU'} oX': {in G :\: X, forall t, #[t] = 2}. + have [n_gt2 | abelG] := orP n2_abelG; first by rewrite [X]defU // -defUv. + move=> t /setDP[Gt notXt]; apply: nt_prime_order (group1_contra notXt) => //. + by case/abelemP: abelG => // _ ->. +have{invUV} invXX': {in X & G :\: X, forall z t, z ^ t = z^-1}. + have [n_gt2 | abelG] := orP n2_abelG; first by rewrite [X]defU // -defUv. + have [//|cGG oG2] := abelemP _ abelG. + move=> t z Xt /setDP[Gz _]; apply/eqP; rewrite eq_sym eq_invg_mul. + by rewrite /conjg -(centsP cGG z) // ?mulKg ?[t * t]oG2 ?(subsetP sXG). +have nXiG k: G \subset 'N(<[x ^+ k]>). + apply: char_norm_trans nXG. + by rewrite cycle_subgroup_char // cycle_subG mem_cycle. +have memL i: x ^+ (2 ^ i) \in 'L_i.+1(G). + elim: i => // i IHi; rewrite -groupV expnSr expgM invMg. + by rewrite -{2}(invXX' _ y) ?mem_cycle ?cycle_id ?mem_commg. +have defG': G^`(1) = <[x ^+ 2]>. + apply/eqP; rewrite eqEsubset cycle_subG (memL 1%N) ?der1_min //=. + rewrite (p2group_abelian (quotient_pgroup _ pG)) ?card_quotient //=. + rewrite -divgS ?cycle_subG ?groupX // oG -orderE ox2. + by rewrite -def2q -def2r mulnA mulnK. +have defG1: 'Mho^1(G) = <[x ^+ 2]>. + apply/eqP; rewrite (MhoE _ pG) eqEsubset !gen_subG sub1set andbC. + rewrite mem_gen; last exact: mem_imset. + apply/subsetP=> z2; case/imsetP=> z Gz ->{z2}. + case Xz: (z \in X); last by rewrite -{1}(oX' z) ?expg_order ?group1 // inE Xz. + by case/cycleP: Xz => i ->; rewrite expgAC mem_cycle. +have defPhi: 'Phi(G) = <[x ^+ 2]>. + by rewrite (Phi_joing pG) defG' defG1 (joing_idPl _). +have def_tG: {in G :\: X, forall t, t ^: G = <[x ^+ 2]> :* t}. + move=> t X't; have [Gt notXt] := setDP X't. + have defJt: {in X, forall z, t ^ z = z ^- 2 * t}. + move=> z Xz; rewrite /= invMg -mulgA (conjgC _ t). + by rewrite (invXX' _ t) ?groupV ?invgK. + have defGt: X * <[t]> = G by rewrite (mulg_normal_maximal nsXG) ?cycle_subG. + apply/setP=> tz; apply/imsetP/rcosetP=> [[t'z] | [z]]. + rewrite -defGt -normC ?cycle_subG ?(subsetP nXG) //. + case/imset2P=> _ z /cycleP[j ->] Xz -> -> {tz t'z}. + exists (z ^- 2); last by rewrite conjgM {2}/conjg commuteX // mulKg defJt. + case/cycleP: Xz => i ->{z}. + by rewrite groupV -expgM mulnC expgM mem_cycle. + case/cycleP=> i -> -> {z tz}; exists (x ^- i); first by rewrite groupV groupX. + by rewrite defJt ?groupV ?mem_cycle // expgVn invgK expgAC. +have defMt: {in G :\: X, forall t, <[x ^+ 2]> ><| <[t]> = <>}. + move=> t X't; have [Gt notXt] := setDP X't. + rewrite sdprodEY ?cycle_subG ?(subsetP (nXiG 2)) //; first 1 last. + rewrite setIC prime_TIg -?orderE ?oX' // cycle_subG. + by apply: contra notXt; apply: subsetP; rewrite cycleX. + apply/eqP; have: t \in <> by rewrite mem_gen ?class_refl. + rewrite def_tG // eqEsubset join_subG !cycle_subG !gen_subG => tGt. + rewrite tGt -(groupMr _ tGt) mem_gen ?mem_mulg ?cycle_id ?set11 //=. + by rewrite mul_subG ?joing_subl // -gen_subG joing_subr. +have oMt: {in G :\: X, forall t, #|<>| = q}. + move=> t X't /=; rewrite -(sdprod_card (defMt t X't)) -!orderE ox2 oX' //. + by rewrite mulnC. +have sMtG: {in G :\: X, forall t, <> \subset G}. + by move=> t; case/setDP=> Gt _; rewrite gen_subG class_subG. +have maxMt: {in G :\: X, forall t, maximal <> G}. + move=> t X't /=; rewrite p_index_maximal -?divgS ?sMtG ?oMt //. + by rewrite oG -def2q mulnK. +have X'xy: x * y \in G :\: X by rewrite !inE !groupMl ?cycle_id ?notXy. +have ti_yG_xyG: [disjoint yG & xyG]. + apply/pred0P=> t; rewrite /= /yG /xyG !def_tG //; apply/andP=> [[yGt]]. + rewrite rcoset_sym (rcoset_transl yGt) mem_rcoset mulgK; move/order_dvdG. + by rewrite -orderE ox2 ox gtnNdvd. +have s_tG_X': {in G :\: X, forall t, t ^: G \subset G :\: X}. + by move=> t X't /=; rewrite class_sub_norm // normsD ?normG. +have defX': yG :|: xyG = G :\: X. + apply/eqP; rewrite eqEcard subUset !s_tG_X' //= -(leq_add2l q) -{1}ox orderE. + rewrite -/X -{1}(setIidPr sXG) cardsID oG -def2q mul2n -addnn leq_add2l. + rewrite -(leq_add2r #|yG :&: xyG|) cardsUI disjoint_setI0 // cards0 addn0. + by rewrite /yG /xyG !def_tG // !card_rcoset addnn -mul2n -orderE ox2 def2r. +split. +- by rewrite ?sdprodE // setIC // prime_TIg ?cycle_subG // -orderE ?oX'. +- rewrite defG'; split=> //. + apply/eqP; rewrite eqn_leq (leq_trans (nil_class_pgroup pG)); last first. + by rewrite oG pfactorK // geq_max leqnn -(subnKC n_gt1). + rewrite -(subnKC n_gt1) subn2 ltnNge. + rewrite (sameP (lcn_nil_classP _ (pgroup_nil pG)) eqP). + by apply/trivgPn; exists (x ^+ r); rewrite ?memL // -order_gt1 oxr. +- split; last exact: extend_cyclic_Mho. + have sX'G1: {subset G :\: X <= 'Ohm_1(G)}. + move=> t X't; have [Gt _] := setDP X't. + by rewrite (OhmE 1 pG) mem_gen // !inE Gt -(oX' t) //= expg_order. + apply/eqP; rewrite eqEsubset Ohm_sub -{1}defXY mulG_subG !cycle_subG. + by rewrite -(groupMr _ (sX'G1 y X'y)) !sX'G1. +- split=> //= H; apply/idP/idP=> [maxH |]; last first. + by case/or3P; move/eqP->; rewrite ?maxMt. + have [sHG nHG]:= andP (p_maximal_normal pG maxH). + have oH: #|H| = q. + apply: double_inj; rewrite -muln2 -(p_maximal_index pG maxH) Lagrange //. + by rewrite oG -mul2n. + rewrite !(eq_sym (gval H)) -eq_sym !eqEcard oH -orderE ox !oMt // !leqnn. + case sHX: (H \subset X) => //=; case/subsetPn: sHX => t Ht notXt. + have: t \in yG :|: xyG by rewrite defX' inE notXt (subsetP sHG). + rewrite !andbT !gen_subG /yG /xyG. + by case/setUP; move/class_transr <-; rewrite !class_sub_norm ?Ht ?orbT. +rewrite eqn_leq n_gt1; case: leqP n2_abelG => //= n_gt2 _. +have ->: 'Z(G) = <[x ^+ r]>. + apply/eqP; rewrite eqEcard andbC -orderE oxr -{1}(setIidPr (center_sub G)). + rewrite cardG_gt1 /= meet_center_nil ?(pgroup_nil pG) //; last first. + by rewrite -cardG_gt1 oG (leq_trans _ ltqm). + apply/subsetP=> t; case/setIP=> Gt cGt. + case X't: (t \in G :\: X). + move/eqP: (invXX' _ _ (cycle_id x) X't). + rewrite /conjg -(centP cGt) // mulKg eq_sym eq_invg_mul -order_eq1 ox2. + by rewrite (eqn_exp2l _ 0) // -(subnKC n_gt2). + move/idPn: X't; rewrite inE Gt andbT negbK => Xt. + have:= Ohm_p_cycle 1 (mem_p_elt pG Gx); rewrite ox pfactorK // subn1 => <-. + rewrite (OhmE _ (pgroupS sXG pG)) mem_gen // !inE Xt /=. + by rewrite -eq_invg_mul -(invXX' _ y) // /conjg (centP cGt) // mulKg. +have isoMt: {in G :\: X, forall t, <> \isog 'D_q}. + have n1_gt1: n.-1 > 1 by rewrite -(subnKC n_gt2). + move=> t X't /=; rewrite isogEcard card_2dihedral ?oMt // leqnn andbT. + rewrite Grp_2dihedral //; apply/existsP; exists (x ^+ 2, t) => /=. + have [_ <- nX2T _] := sdprodP (defMt t X't); rewrite norm_joinEr //. + rewrite -/q -/r !xpair_eqE eqxx -expgM def2r -ox -{1}(oX' t X't). + by rewrite !expg_order !eqxx /= invXX' ?mem_cycle. +rewrite !isoMt //; split=> // C; case/cyclicP=> z ->{C} sCG iCG. +rewrite [X]defU // defU -?cycle_subG //. +by apply: double_inj; rewrite -muln2 -iCG Lagrange // oG -mul2n. +Qed. + +Theorem quaternion_structure : + n > 2 -> extremal_generators G 2 n (x, y) -> G \isog 'Q_m -> + [/\ [/\ pprod X Y = G, {in G :\: X, forall t, #[t] = 4} + & {in X & G :\: X, forall z t, z ^ t = z^-1}], + [/\ G ^`(1) = <[x ^+ 2]>, 'Phi(G) = G ^`(1), #|G^`(1)| = r + & nil_class G = n.-1], + [/\ 'Z(G) = <[x ^+ r]>, #|'Z(G)| = 2, + forall u, u \in G -> #[u] = 2 -> u = x ^+ r, + 'Ohm_1(G) = <[x ^+ r]> /\ 'Ohm_2(G) = G + & forall k, k > 0 -> 'Mho^k(G) = <[x ^+ (2 ^ k)]>], + [/\ yG :|: xyG = G :\: X /\ [disjoint yG & xyG] + & forall M, maximal M G = pred3 X My Mxy M] + & n > 3 -> + [/\ My \isog 'Q_q, Mxy \isog 'Q_q + & forall U, cyclic U -> U \subset G -> #|G : U| = 2 -> U = X]]. +Proof. +move=> n_gt2 genG isoG; have [def2q def2r ltqm ltrq] := def2qr (ltnW n_gt2). +have [oG Gx ox X'y] := genG; rewrite -/m -/q -/X in oG ox X'y. +case/extremal_generators_facts: genG; rewrite -/X // => pG maxX nsXG defXY nXY. +have [sXG nXG]:= andP nsXG; have [Gy notXy]:= setDP X'y. +have oxr: #[x ^+ r] = 2 by rewrite orderXdiv ox -def2r ?dvdn_mull ?mulnK. +have ox2: #[x ^+ 2] = r by rewrite orderXdiv ox -def2r ?dvdn_mulr ?mulKn. +have [[u v] [_ Gu ou U'v] [ov v2 uv]] := generators_quaternion n_gt2 isoG. +have defUv: <[u]> :* v = G :\: <[u]>. + apply: rcoset_index2; rewrite -?divgS ?cycle_subG //. + by rewrite oG -orderE ou -def2q mulnK. +have invUV: {in <[u]> & <[u]> :* v, forall z t, z ^ t = z^-1}. + move=> z t; case/cycleP=> i ->; case/rcosetP=> ?; case/cycleP=> j -> ->{z t}. + by rewrite conjgM {2}/conjg commuteX2 // mulKg conjXg uv expgVn. +have U'2: {in <[u]> :* v, forall t, t ^+ 2 = u ^+ r}. + move=> t; case/rcosetP=> z Uz ->; rewrite expgS {1}(conjgC z) -mulgA. + by rewrite invUV ?rcoset_refl // mulKg -(expgS v 1) v2. +have our: #[u ^+ r] = 2 by rewrite orderXdiv ou -/q -def2r ?dvdn_mull ?mulnK. +have def_ur: {in G, forall t, #[t] = 2 -> t = u ^+ r}. + move=> t Gt /= ot; case Ut: (t \in <[u]>); last first. + move/eqP: ot; rewrite eqn_dvd order_dvdn -order_eq1 U'2 ?our //. + by rewrite defUv inE Ut. + have p2u: 2.-elt u by rewrite /p_elt ou pnat_exp. + have: t \in 'Ohm_1(<[u]>). + by rewrite (OhmE _ p2u) mem_gen // !inE Ut -order_dvdn ot. + rewrite (Ohm_p_cycle _ p2u) ou pfactorK // subn1 -/r cycle_traject our !inE. + by rewrite -order_eq1 ot /= mulg1; move/eqP. +have defU: n > 3 -> {in G, forall z, #[z] = q -> <[z]> = <[u]>}. + move=> n_gt3 z Gz oz; apply/eqP; rewrite eqEcard -!orderE oz cycle_subG. + rewrite ou leqnn andbT; apply: contraLR n_gt3 => notUz. + rewrite -(ltn_predK n_gt2) ltnS -(@ltn_exp2l 2) // -/q -oz. + by rewrite (@orderXprime _ 2 2) // U'2 // defUv inE notUz. +have def_xr: x ^+ r = u ^+ r by apply: def_ur; rewrite ?groupX. +have X'2: {in G :\: X, forall t, t ^+ 2 = u ^+ r}. + case: (ltngtP n 3) => [|n_gt3|n3 t]; first by rewrite ltnNge n_gt2. + by rewrite /X defU // -defUv. + case/setDP=> Gt notXt. + case Ut: (t \in <[u]>); last by rewrite U'2 // defUv inE Ut. + rewrite [t ^+ 2]def_ur ?groupX //. + have:= order_dvdG Ut; rewrite -orderE ou /q n3 dvdn_divisors ?inE //=. + rewrite order_eq1 (negbTE (group1_contra notXt)) /=. + case/pred2P=> oz; last by rewrite orderXdiv oz. + by rewrite [t]def_ur // -def_xr mem_cycle in notXt. +have oX': {in G :\: X, forall z, #[z] = 4}. + by move=> t X't /=; rewrite (@orderXprime _ 2 2) // X'2. +have defZ: 'Z(G) = <[x ^+ r]>. + apply/eqP; rewrite eqEcard andbC -orderE oxr -{1}(setIidPr (center_sub G)). + rewrite cardG_gt1 /= meet_center_nil ?(pgroup_nil pG) //; last first. + by rewrite -cardG_gt1 oG (leq_trans _ ltqm). + apply/subsetP=> z; case/setIP=> Gz cGz; have [Gv _]:= setDP U'v. + case Uvz: (z \in <[u]> :* v). + move/eqP: (invUV _ _ (cycle_id u) Uvz). + rewrite /conjg -(centP cGz) // mulKg eq_sym eq_invg_mul -(order_dvdn _ 2). + by rewrite ou pfactor_dvdn // -(subnKC n_gt2). + move/idPn: Uvz; rewrite defUv inE Gz andbT negbK def_xr => Uz. + have p_u: 2.-elt u := mem_p_elt pG Gu. + suff: z \in 'Ohm_1(<[u]>) by rewrite (Ohm_p_cycle 1 p_u) ou pfactorK // subn1. + rewrite (OhmE _ p_u) mem_gen // !inE Uz /= -eq_invg_mul. + by rewrite -(invUV _ v) ?rcoset_refl // /conjg (centP cGz) ?mulKg. +have{invUV} invXX': {in X & G :\: X, forall z t, z ^ t = z^-1}. + case: (ltngtP n 3) => [|n_gt3|n3 t z Xt]; first by rewrite ltnNge n_gt2. + by rewrite /X defU // -defUv. + case/setDP=> Gz notXz; rewrite /q /r n3 /= in oxr ox. + suff xz: x ^ z = x^-1 by case/cycleP: Xt => i ->; rewrite conjXg xz expgVn. + have: x ^ z \in X by rewrite memJ_norm ?cycle_id ?(subsetP nXG). + rewrite invg_expg /X cycle_traject ox !inE /= !mulg1 -order_eq1 orderJ ox /=. + case/or3P; move/eqP=> //; last by move/(congr1 order); rewrite orderJ ox oxr. + move/conjg_fixP; rewrite (sameP commgP cent1P) cent1C -cent_cycle -/X => cXz. + have defXz: X * <[z]> = G by rewrite (mulg_normal_maximal nsXG) ?cycle_subG. + have: z \in 'Z(G) by rewrite inE Gz -defXz centM inE cXz cent_cycle cent1id. + by rewrite defZ => Xr_z; rewrite (subsetP (cycleX x r)) in notXz. +have nXiG k: G \subset 'N(<[x ^+ k]>). + apply: char_norm_trans nXG. + by rewrite cycle_subgroup_char // cycle_subG mem_cycle. +have memL i: x ^+ (2 ^ i) \in 'L_i.+1(G). + elim: i => // i IHi; rewrite -groupV expnSr expgM invMg. + by rewrite -{2}(invXX' _ y) ?mem_cycle ?cycle_id ?mem_commg. +have defG': G^`(1) = <[x ^+ 2]>. + apply/eqP; rewrite eqEsubset cycle_subG (memL 1%N) ?der1_min //=. + rewrite (p2group_abelian (quotient_pgroup _ pG)) ?card_quotient //=. + rewrite -divgS ?cycle_subG ?groupX // oG -orderE ox2. + by rewrite -def2q -def2r mulnA mulnK. +have defG1: 'Mho^1(G) = <[x ^+ 2]>. + apply/eqP; rewrite (MhoE _ pG) eqEsubset !gen_subG sub1set andbC. + rewrite mem_gen; last exact: mem_imset. + apply/subsetP=> z2; case/imsetP=> z Gz ->{z2}. + case Xz: (z \in X). + by case/cycleP: Xz => i ->; rewrite -expgM mulnC expgM mem_cycle. + rewrite (X'2 z) ?inE ?Xz // -def_xr. + by rewrite /r -(subnKC n_gt2) expnS expgM mem_cycle. +have defPhi: 'Phi(G) = <[x ^+ 2]>. + by rewrite (Phi_joing pG) defG' defG1 (joing_idPl _). +have def_tG: {in G :\: X, forall t, t ^: G = <[x ^+ 2]> :* t}. + move=> t X't; have [Gt notXt] := setDP X't. + have defJt: {in X, forall z, t ^ z = z ^- 2 * t}. + move=> z Xz; rewrite /= invMg -mulgA (conjgC _ t). + by rewrite (invXX' _ t) ?groupV ?invgK. + have defGt: X * <[t]> = G by rewrite (mulg_normal_maximal nsXG) ?cycle_subG. + apply/setP=> tz; apply/imsetP/rcosetP=> [[t'z] | [z]]. + rewrite -defGt -normC ?cycle_subG ?(subsetP nXG) //. + case/imset2P=> t' z; case/cycleP=> j -> Xz -> -> {tz t'z t'}. + exists (z ^- 2); last by rewrite conjgM {2}/conjg commuteX // mulKg defJt. + case/cycleP: Xz => i ->{z}. + by rewrite groupV -expgM mulnC expgM mem_cycle. + case/cycleP=> i -> -> {z tz}; exists (x ^- i); first by rewrite groupV groupX. + by rewrite defJt ?groupV ?mem_cycle // expgVn invgK -!expgM mulnC. +have defMt: {in G :\: X, forall t, <[x ^+ 2]> <*> <[t]> = <>}. + move=> t X't; have [Gt notXt] := setDP X't. + apply/eqP; have: t \in <> by rewrite mem_gen ?class_refl. + rewrite def_tG // eqEsubset join_subG !cycle_subG !gen_subG => tGt. + rewrite tGt -(groupMr _ tGt) mem_gen ?mem_mulg ?cycle_id ?set11 //=. + by rewrite mul_subG ?joing_subl // -gen_subG joing_subr. +have sMtG: {in G :\: X, forall t, <> \subset G}. + by move=> t; case/setDP=> Gt _; rewrite gen_subG class_subG. +have oMt: {in G :\: X, forall t, #|<>| = q}. + move=> t X't; have [Gt notXt] := setDP X't. + rewrite -defMt // -(Lagrange (joing_subl _ _)) -orderE ox2 -def2r mulnC. + congr (_ * r)%N; rewrite -card_quotient /=; last first. + by rewrite defMt // (subset_trans _ (nXiG 2)) ?sMtG. + rewrite joingC quotientYidr ?(subset_trans _ (nXiG 2)) ?cycle_subG //. + rewrite quotient_cycle ?(subsetP (nXiG 2)) //= -defPhi. + rewrite -orderE (abelem_order_p (Phi_quotient_abelem pG)) ?mem_quotient //. + apply: contraNneq notXt; move/coset_idr; move/implyP=> /=. + by rewrite defPhi ?(subsetP (nXiG 2)) //; apply: subsetP; exact: cycleX. +have maxMt: {in G :\: X, forall t, maximal <> G}. + move=> t X't; rewrite /= p_index_maximal -?divgS ?sMtG ?oMt //. + by rewrite oG -def2q mulnK. +have X'xy: x * y \in G :\: X by rewrite !inE !groupMl ?cycle_id ?notXy. +have ti_yG_xyG: [disjoint yG & xyG]. + apply/pred0P=> t; rewrite /= /yG /xyG !def_tG //; apply/andP=> [[yGt]]. + rewrite rcoset_sym (rcoset_transl yGt) mem_rcoset mulgK; move/order_dvdG. + by rewrite -orderE ox2 ox gtnNdvd. +have s_tG_X': {in G :\: X, forall t, t ^: G \subset G :\: X}. + by move=> t X't /=; rewrite class_sub_norm // normsD ?normG. +have defX': yG :|: xyG = G :\: X. + apply/eqP; rewrite eqEcard subUset !s_tG_X' //= -(leq_add2l q) -{1}ox orderE. + rewrite -/X -{1}(setIidPr sXG) cardsID oG -def2q mul2n -addnn leq_add2l. + rewrite -(leq_add2r #|yG :&: xyG|) cardsUI disjoint_setI0 // cards0 addn0. + by rewrite /yG /xyG !def_tG // !card_rcoset addnn -mul2n -orderE ox2 def2r. +rewrite pprodE //; split=> // [|||n_gt3]. +- rewrite defG'; split=> //; apply/eqP; rewrite eqn_leq. + rewrite (leq_trans (nil_class_pgroup pG)); last first. + by rewrite oG pfactorK // -(subnKC n_gt2). + rewrite -(subnKC (ltnW n_gt2)) subn2 ltnNge. + rewrite (sameP (lcn_nil_classP _ (pgroup_nil pG)) eqP). + by apply/trivgPn; exists (x ^+ r); rewrite ?memL // -order_gt1 oxr. +- rewrite {2}def_xr defZ; split=> //; last exact: extend_cyclic_Mho. + split; apply/eqP; last first. + have sX'G2: {subset G :\: X <= 'Ohm_2(G)}. + move=> z X'z; have [Gz _] := setDP X'z. + by rewrite (OhmE 2 pG) mem_gen // !inE Gz -order_dvdn oX'. + rewrite eqEsubset Ohm_sub -{1}defXY mulG_subG !cycle_subG. + by rewrite -(groupMr _ (sX'G2 y X'y)) !sX'G2. + rewrite eqEsubset (OhmE 1 pG) cycle_subG gen_subG andbC. + rewrite mem_gen ?inE ?groupX -?order_dvdn ?oxr //=. + apply/subsetP=> t; case/setIP=> Gt; rewrite inE -order_dvdn /=. + rewrite dvdn_divisors ?inE //= order_eq1. + case/pred2P=> [->|]; first exact: group1. + by move/def_ur=> -> //; rewrite def_xr cycle_id. +- split=> //= H; apply/idP/idP=> [maxH |]; last first. + by case/or3P=> /eqP->; rewrite ?maxMt. + have [sHG nHG]:= andP (p_maximal_normal pG maxH). + have oH: #|H| = q. + apply: double_inj; rewrite -muln2 -(p_maximal_index pG maxH) Lagrange //. + by rewrite oG -mul2n. + rewrite !(eq_sym (gval H)) -eq_sym !eqEcard oH -orderE ox !oMt // !leqnn. + case sHX: (H \subset X) => //=; case/subsetPn: sHX => z Hz notXz. + have: z \in yG :|: xyG by rewrite defX' inE notXz (subsetP sHG). + rewrite !andbT !gen_subG /yG /xyG. + by case/setUP=> /class_transr <-; rewrite !class_sub_norm ?Hz ?orbT. +have isoMt: {in G :\: X, forall z, <> \isog 'Q_q}. + have n1_gt2: n.-1 > 2 by rewrite -(subnKC n_gt3). + move=> z X'z /=; rewrite isogEcard card_quaternion ?oMt // leqnn andbT. + rewrite Grp_quaternion //; apply/existsP; exists (x ^+ 2, z) => /=. + rewrite defMt // -/q -/r !xpair_eqE -!expgM def2r -order_dvdn ox dvdnn. + rewrite -expnS prednK; last by rewrite -subn2 subn_gt0. + by rewrite X'2 // def_xr !eqxx /= invXX' ?mem_cycle. +rewrite !isoMt //; split=> // C; case/cyclicP=> z ->{C} sCG iCG. +rewrite [X]defU // defU -?cycle_subG //. +by apply: double_inj; rewrite -muln2 -iCG Lagrange // oG -mul2n. +Qed. + +Theorem semidihedral_structure : + n > 3 -> extremal_generators G 2 n (x, y) -> G \isog 'SD_m -> #[y] = 2 -> + [/\ [/\ X ><| Y = G, #[x * y] = 4 + & {in X & G :\: X, forall z t, z ^ t = z ^+ r.-1}], + [/\ G ^`(1) = <[x ^+ 2]>, 'Phi(G) = G ^`(1), #|G^`(1)| = r + & nil_class G = n.-1], + [/\ 'Z(G) = <[x ^+ r]>, #|'Z(G)| = 2, + 'Ohm_1(G) = My /\ 'Ohm_2(G) = G + & forall k, k > 0 -> 'Mho^k(G) = <[x ^+ (2 ^ k)]>], + [/\ yG :|: xyG = G :\: X /\ [disjoint yG & xyG] + & forall H, maximal H G = pred3 X My Mxy H] + & [/\ My \isog 'D_q, Mxy \isog 'Q_q + & forall U, cyclic U -> U \subset G -> #|G : U| = 2 -> U = X]]. +Proof. +move=> n_gt3 genG isoG oy. +have [def2q def2r ltqm ltrq] := def2qr (ltnW (ltnW n_gt3)). +have [oG Gx ox X'y] := genG; rewrite -/m -/q -/X in oG ox X'y. +case/extremal_generators_facts: genG; rewrite -/X // => pG maxX nsXG defXY nXY. +have [sXG nXG]:= andP nsXG; have [Gy notXy]:= setDP X'y. +have ox2: #[x ^+ 2] = r by rewrite orderXdiv ox -def2r ?dvdn_mulr ?mulKn. +have oxr: #[x ^+ r] = 2 by rewrite orderXdiv ox -def2r ?dvdn_mull ?mulnK. +have [[u v] [_ Gu ou U'v] [ov uv]] := generators_semidihedral n_gt3 isoG. +have defUv: <[u]> :* v = G :\: <[u]>. + apply: rcoset_index2; rewrite -?divgS ?cycle_subG //. + by rewrite oG -orderE ou -def2q mulnK. +have invUV: {in <[u]> & <[u]> :* v, forall z t, z ^ t = z ^+ r.-1}. + move=> z t; case/cycleP=> i ->; case/rcosetP=> ?; case/cycleP=> j -> ->{z t}. + by rewrite conjgM {2}/conjg commuteX2 // mulKg conjXg uv -!expgM mulnC. +have [vV yV]: v^-1 = v /\ y^-1 = y by rewrite !invg_expg ov oy. +have defU: {in G, forall z, #[z] = q -> <[z]> = <[u]>}. + move=> z Gz /= oz; apply/eqP; rewrite eqEcard -!orderE oz ou leqnn andbT. + apply: contraLR (n_gt3) => notUz; rewrite -leqNgt -(ltn_predK n_gt3) ltnS. + rewrite -(@dvdn_Pexp2l 2) // -/q -{}oz order_dvdn expgM (expgS z). + have{Gz notUz} [z' Uz' ->{z}]: exists2 z', z' \in <[u]> & z = z' * v. + by apply/rcosetP; rewrite defUv inE -cycle_subG notUz Gz. + rewrite {2}(conjgC z') invUV ?rcoset_refl // mulgA -{2}vV mulgK -expgS. + by rewrite prednK // -expgM mulnC def2r -order_dvdn /q -ou order_dvdG. +have{invUV} invXX': {in X & G :\: X, forall z t, z ^ t = z ^+ r.-1}. + by rewrite /X defU -?defUv. +have xy2: (x * y) ^+ 2 = x ^+ r. + rewrite expgS {2}(conjgC x) invXX' ?cycle_id // mulgA -{2}yV mulgK -expgS. + by rewrite prednK. +have oxy: #[x * y] = 4 by rewrite (@orderXprime _ 2 2) ?xy2. +have r_gt2: r > 2 by rewrite (ltn_exp2l 1) // -(subnKC n_gt3). +have coXr1: coprime #[x] (2 ^ (n - 3)).-1. + rewrite ox coprime_expl // -(@coprime_pexpl (n - 3)) ?coprimenP ?subn_gt0 //. + by rewrite expn_gt0. +have def2r1: (2 * (2 ^ (n - 3)).-1).+1 = r.-1. + rewrite -!subn1 mulnBr -expnS [_.+1]subnSK ?(ltn_exp2l 0) //. + by rewrite /r -(subnKC n_gt3). +have defZ: 'Z(G) = <[x ^+ r]>. + apply/eqP; rewrite eqEcard andbC -orderE oxr -{1}(setIidPr (center_sub G)). + rewrite cardG_gt1 /= meet_center_nil ?(pgroup_nil pG) //; last first. + by rewrite -cardG_gt1 oG (leq_trans _ ltqm). + apply/subsetP=> z /setIP[Gz cGz]. + case X'z: (z \in G :\: X). + move/eqP: (invXX' _ _ (cycle_id x) X'z). + rewrite /conjg -(centP cGz) // mulKg -def2r1 eq_mulVg1 expgS mulKg mulnC. + rewrite -order_dvdn Gauss_dvdr // order_dvdn -order_eq1. + by rewrite ox2 -(subnKC r_gt2). + move/idPn: X'z; rewrite inE Gz andbT negbK => Xz. + have:= Ohm_p_cycle 1 (mem_p_elt pG Gx); rewrite ox pfactorK // subn1 => <-. + rewrite (OhmE _ (mem_p_elt pG Gx)) mem_gen // !inE Xz /=. + rewrite -(expgK coXr1 Xz) -!expgM mulnCA -order_dvdn dvdn_mull //. + rewrite mulnC order_dvdn -(inj_eq (mulgI z)) -expgS mulg1 def2r1. + by rewrite -(invXX' z y) // /conjg (centP cGz) ?mulKg. +have nXiG k: G \subset 'N(<[x ^+ k]>). + apply: char_norm_trans nXG. + by rewrite cycle_subgroup_char // cycle_subG mem_cycle. +have memL i: x ^+ (2 ^ i) \in 'L_i.+1(G). + elim: i => // i IHi; rewrite -(expgK coXr1 (mem_cycle _ _)) groupX //. + rewrite -expgM expnSr -mulnA expgM -(mulKg (x ^+ (2 ^ i)) (_ ^+ _)). + by rewrite -expgS def2r1 -(invXX' _ y) ?mem_cycle ?mem_commg. +have defG': G^`(1) = <[x ^+ 2]>. + apply/eqP; rewrite eqEsubset cycle_subG (memL 1%N) ?der1_min //=. + rewrite (p2group_abelian (quotient_pgroup _ pG)) ?card_quotient //=. + rewrite -divgS ?cycle_subG ?groupX // oG -orderE ox2. + by rewrite -def2q -def2r mulnA mulnK. +have defG1: 'Mho^1(G) = <[x ^+ 2]>. + apply/eqP; rewrite (MhoE _ pG) eqEsubset !gen_subG sub1set andbC. + rewrite mem_gen; last exact: mem_imset. + apply/subsetP=> z2; case/imsetP=> z Gz ->{z2}. + case Xz: (z \in X). + by case/cycleP: Xz => i ->; rewrite -expgM mulnC expgM mem_cycle. + have{Xz Gz} [xi Xxi ->{z}]: exists2 xi, xi \in X & z = xi * y. + have Uvy: y \in <[u]> :* v by rewrite defUv -(defU x). + apply/rcosetP; rewrite /X defU // (rcoset_transl Uvy) defUv. + by rewrite inE -(defU x) ?Xz. + rewrite expn1 expgS {2}(conjgC xi) -{2}[y]/(y ^+ 2.-1) -{1}oy -invg_expg. + rewrite mulgA mulgK invXX' // -expgS prednK // /r -(subnKC n_gt3) expnS. + by case/cycleP: Xxi => i ->; rewrite -expgM mulnCA expgM mem_cycle. +have defPhi: 'Phi(G) = <[x ^+ 2]>. + by rewrite (Phi_joing pG) defG' defG1 (joing_idPl _). +have def_tG: {in G :\: X, forall t, t ^: G = <[x ^+ 2]> :* t}. + move=> t X't; have [Gt notXt] := setDP X't. + have defJt: {in X, forall z, t ^ z = z ^+ r.-2 * t}. + move=> z Xz /=; rewrite -(mulKg z (z ^+ _)) -expgS -subn2. + have X'tV: t^-1 \in G :\: X by rewrite inE !groupV notXt. + by rewrite subnSK 1?ltnW // subn1 -(invXX' _ t^-1) // -mulgA -conjgCV. + have defGt: X * <[t]> = G by rewrite (mulg_normal_maximal nsXG) ?cycle_subG. + apply/setP=> tz; apply/imsetP/rcosetP=> [[t'z] | [z]]. + rewrite -defGt -normC ?cycle_subG ?(subsetP nXG) //. + case/imset2P=> t' z; case/cycleP=> j -> Xz -> -> {t' t'z tz}. + exists (z ^+ r.-2); last first. + by rewrite conjgM {2}/conjg commuteX // mulKg defJt. + case/cycleP: Xz => i ->{z}. + by rewrite -def2r1 -expgM mulnCA expgM mem_cycle. + case/cycleP=> i -> -> {z tz}. + exists (x ^+ (i * expg_invn X (2 ^ (n - 3)).-1)); first by rewrite groupX. + rewrite defJt ?mem_cycle // -def2r1 -!expgM. + by rewrite mulnAC mulnA mulnC muln2 !expgM expgK ?mem_cycle. +have defMt: {in G :\: X, forall t, <[x ^+ 2]> <*> <[t]> = <>}. + move=> t X't; have [Gt notXt] := setDP X't. + apply/eqP; have: t \in <> by rewrite mem_gen ?class_refl. + rewrite def_tG // eqEsubset join_subG !cycle_subG !gen_subG => tGt. + rewrite tGt -(groupMr _ tGt) mem_gen ?mem_mulg ?cycle_id ?set11 //=. + by rewrite mul_subG ?joing_subl // -gen_subG joing_subr. +have sMtG: {in G :\: X, forall t, <> \subset G}. + by move=> t; case/setDP=> Gt _; rewrite gen_subG class_subG. +have oMt: {in G :\: X, forall t, #|<>| = q}. + move=> t X't; have [Gt notXt] := setDP X't. + rewrite -defMt // -(Lagrange (joing_subl _ _)) -orderE ox2 -def2r mulnC. + congr (_ * r)%N; rewrite -card_quotient /=; last first. + by rewrite defMt // (subset_trans _ (nXiG 2)) ?sMtG. + rewrite joingC quotientYidr ?(subset_trans _ (nXiG 2)) ?cycle_subG //. + rewrite quotient_cycle ?(subsetP (nXiG 2)) //= -defPhi -orderE. + rewrite (abelem_order_p (Phi_quotient_abelem pG)) ?mem_quotient //. + apply: contraNneq notXt; move/coset_idr; move/implyP=> /=. + by rewrite /= defPhi (subsetP (nXiG 2)) //; apply: subsetP; exact: cycleX. +have maxMt: {in G :\: X, forall t, maximal <> G}. + move=> t X't /=; rewrite p_index_maximal -?divgS ?sMtG ?oMt //. + by rewrite oG -def2q mulnK. +have X'xy: x * y \in G :\: X by rewrite !inE !groupMl ?cycle_id ?notXy. +have ti_yG_xyG: [disjoint yG & xyG]. + apply/pred0P=> t; rewrite /= /yG /xyG !def_tG //; apply/andP=> [[yGt]]. + rewrite rcoset_sym (rcoset_transl yGt) mem_rcoset mulgK; move/order_dvdG. + by rewrite -orderE ox2 ox gtnNdvd. +have s_tG_X': {in G :\: X, forall t, t ^: G \subset G :\: X}. + by move=> t X't /=; rewrite class_sub_norm // normsD ?normG. +have defX': yG :|: xyG = G :\: X. + apply/eqP; rewrite eqEcard subUset !s_tG_X' //= -(leq_add2l q) -{1}ox orderE. + rewrite -/X -{1}(setIidPr sXG) cardsID oG -def2q mul2n -addnn leq_add2l. + rewrite -(leq_add2r #|yG :&: xyG|) cardsUI disjoint_setI0 // cards0 addn0. + by rewrite /yG /xyG !def_tG // !card_rcoset addnn -mul2n -orderE ox2 def2r. +split. +- by rewrite sdprodE // setIC prime_TIg ?cycle_subG // -orderE oy. +- rewrite defG'; split=> //. + apply/eqP; rewrite eqn_leq (leq_trans (nil_class_pgroup pG)); last first. + by rewrite oG pfactorK // -(subnKC n_gt3). + rewrite -(subnKC (ltnW (ltnW n_gt3))) subn2 ltnNge. + rewrite (sameP (lcn_nil_classP _ (pgroup_nil pG)) eqP). + by apply/trivgPn; exists (x ^+ r); rewrite ?memL // -order_gt1 oxr. +- rewrite defZ; split=> //; last exact: extend_cyclic_Mho. + split; apply/eqP; last first. + have sX'G2: {subset G :\: X <= 'Ohm_2(G)}. + move=> t X't; have [Gt _] := setDP X't; rewrite -defX' in X't. + rewrite (OhmE 2 pG) mem_gen // !inE Gt -order_dvdn. + by case/setUP: X't; case/imsetP=> z _ ->; rewrite orderJ ?oy ?oxy. + rewrite eqEsubset Ohm_sub -{1}defXY mulG_subG !cycle_subG. + by rewrite -(groupMr _ (sX'G2 y X'y)) !sX'G2. + rewrite eqEsubset andbC gen_subG class_sub_norm ?gFnorm //. + rewrite (OhmE 1 pG) mem_gen ?inE ?Gy -?order_dvdn ?oy // gen_subG /= -/My. + apply/subsetP=> t; rewrite !inE; case/andP=> Gt t2. + have pX := pgroupS sXG pG. + case Xt: (t \in X). + have: t \in 'Ohm_1(X) by rewrite (OhmE 1 pX) mem_gen // !inE Xt. + apply: subsetP; rewrite (Ohm_p_cycle 1 pX) ox pfactorK //. + rewrite -(subnKC n_gt3) expgM (subset_trans (cycleX _ _)) //. + by rewrite /My -defMt ?joing_subl. + have{Xt}: t \in yG :|: xyG by rewrite defX' inE Xt. + case/setUP; first exact: mem_gen. + by case/imsetP=> z _ def_t; rewrite -order_dvdn def_t orderJ oxy in t2. +- split=> //= H; apply/idP/idP=> [maxH |]; last first. + by case/or3P=> /eqP->; rewrite ?maxMt. + have [sHG nHG]:= andP (p_maximal_normal pG maxH). + have oH: #|H| = q. + apply: double_inj; rewrite -muln2 -(p_maximal_index pG maxH) Lagrange //. + by rewrite oG -mul2n. + rewrite !(eq_sym (gval H)) -eq_sym !eqEcard oH -orderE ox !oMt // !leqnn. + case sHX: (H \subset X) => //=; case/subsetPn: sHX => t Ht notXt. + have: t \in yG :|: xyG by rewrite defX' inE notXt (subsetP sHG). + rewrite !andbT !gen_subG /yG /xyG. + by case/setUP=> /class_transr <-; rewrite !class_sub_norm ?Ht ?orbT. +have n1_gt2: n.-1 > 2 by [rewrite -(subnKC n_gt3)]; have n1_gt1 := ltnW n1_gt2. +rewrite !isogEcard card_2dihedral ?card_quaternion ?oMt // leqnn !andbT. +have invX2X': {in G :\: X, forall t, x ^+ 2 ^ t == x ^- 2}. + move=> t X't; rewrite /= invXX' ?mem_cycle // eq_sym eq_invg_mul -expgS. + by rewrite prednK // -order_dvdn ox2. + rewrite Grp_2dihedral ?Grp_quaternion //; split=> [||C]. +- apply/existsP; exists (x ^+ 2, y); rewrite /= defMt // !xpair_eqE. + by rewrite -!expgM def2r -!order_dvdn ox oy dvdnn eqxx /= invX2X'. +- apply/existsP; exists (x ^+ 2, x * y); rewrite /= defMt // !xpair_eqE. + rewrite -!expgM def2r -order_dvdn ox xy2 dvdnn eqxx invX2X' //=. + by rewrite andbT /r -(subnKC n_gt3). +case/cyclicP=> z ->{C} sCG iCG; rewrite [X]defU // defU -?cycle_subG //. +by apply: double_inj; rewrite -muln2 -iCG Lagrange // oG -mul2n. +Qed. + +End ExtremalStructure. + +Section ExtremalClass. + +Variables (gT : finGroupType) (G : {group gT}). + +Inductive extremal_group_type := + ModularGroup | Dihedral | SemiDihedral | Quaternion | NotExtremal. + +Definition index_extremal_group_type c := + match c with + | ModularGroup => 0 + | Dihedral => 1 + | SemiDihedral => 2 + | Quaternion => 3 + | NotExtremal => 4 + end%N. + +Definition enum_extremal_groups := + [:: ModularGroup; Dihedral; SemiDihedral; Quaternion]. + +Lemma cancel_index_extremal_groups : + cancel index_extremal_group_type (nth NotExtremal enum_extremal_groups). +Proof. by case. Qed. +Local Notation extgK := cancel_index_extremal_groups. + +Import choice. + +Definition extremal_group_eqMixin := CanEqMixin extgK. +Canonical extremal_group_eqType := EqType _ extremal_group_eqMixin. +Definition extremal_group_choiceMixin := CanChoiceMixin extgK. +Canonical extremal_group_choiceType := ChoiceType _ extremal_group_choiceMixin. +Definition extremal_group_countMixin := CanCountMixin extgK. +Canonical extremal_group_countType := CountType _ extremal_group_countMixin. +Lemma bound_extremal_groups (c : extremal_group_type) : pickle c < 6. +Proof. by case: c. Qed. +Definition extremal_group_finMixin := Finite.CountMixin bound_extremal_groups. +Canonical extremal_group_finType := FinType _ extremal_group_finMixin. + +Definition extremal_class (A : {set gT}) := + let m := #|A| in let p := pdiv m in let n := logn p m in + if (n > 1) && (A \isog 'D_(2 ^ n)) then Dihedral else + if (n > 2) && (A \isog 'Q_(2 ^ n)) then Quaternion else + if (n > 3) && (A \isog 'SD_(2 ^ n)) then SemiDihedral else + if (n > 2) && (A \isog 'Mod_(p ^ n)) then ModularGroup else + NotExtremal. + +Definition extremal2 A := extremal_class A \in behead enum_extremal_groups. + +Lemma dihedral_classP : + extremal_class G = Dihedral <-> (exists2 n, n > 1 & G \isog 'D_(2 ^ n)). +Proof. +rewrite /extremal_class; split=> [ | [n n_gt1 isoG]]. + by move: (logn _ _) => n; do 4?case: ifP => //; case/andP; exists n. +rewrite (card_isog isoG) card_2dihedral // -(ltn_predK n_gt1) pdiv_pfactor //. +by rewrite pfactorK // (ltn_predK n_gt1) n_gt1 isoG. +Qed. + +Lemma quaternion_classP : + extremal_class G = Quaternion <-> (exists2 n, n > 2 & G \isog 'Q_(2 ^ n)). +Proof. +rewrite /extremal_class; split=> [ | [n n_gt2 isoG]]. + by move: (logn _ _) => n; do 4?case: ifP => //; case/andP; exists n. +rewrite (card_isog isoG) card_quaternion // -(ltn_predK n_gt2) pdiv_pfactor //. +rewrite pfactorK // (ltn_predK n_gt2) n_gt2 isoG. +case: andP => // [[n_gt1 isoGD]]. +have [[x y] genG [oy _ _]]:= generators_quaternion n_gt2 isoG. +have [_ _ _ X'y] := genG. +by case/dihedral2_structure: genG oy => // [[_ ->]]. +Qed. + +Lemma semidihedral_classP : + extremal_class G = SemiDihedral <-> (exists2 n, n > 3 & G \isog 'SD_(2 ^ n)). +Proof. +rewrite /extremal_class; split=> [ | [n n_gt3 isoG]]. + by move: (logn _ _) => n; do 4?case: ifP => //; case/andP; exists n. +rewrite (card_isog isoG) card_semidihedral //. +rewrite -(ltn_predK n_gt3) pdiv_pfactor // pfactorK // (ltn_predK n_gt3) n_gt3. +have [[x y] genG [oy _]]:= generators_semidihedral n_gt3 isoG. +have [_ Gx _ X'y]:= genG. +case: andP => [[n_gt1 isoGD]|_]. + have [[_ oxy _ _] _ _ _]:= semidihedral_structure n_gt3 genG isoG oy. + case: (dihedral2_structure n_gt1 genG isoGD) oxy => [[_ ->]] //. + by rewrite !inE !groupMl ?cycle_id in X'y *. +case: andP => // [[n_gt2 isoGQ]|]; last by rewrite isoG. +by case: (quaternion_structure n_gt2 genG isoGQ) oy => [[_ ->]]. +Qed. + +Lemma odd_not_extremal2 : odd #|G| -> ~~ extremal2 G. +Proof. +rewrite /extremal2 /extremal_class; case: logn => // n'. +case: andP => [[n_gt1 isoG] | _]. + by rewrite (card_isog isoG) card_2dihedral ?odd_exp. +case: andP => [[n_gt2 isoG] | _]. + by rewrite (card_isog isoG) card_quaternion ?odd_exp. +case: andP => [[n_gt3 isoG] | _]. + by rewrite (card_isog isoG) card_semidihedral ?odd_exp. +by case: ifP. +Qed. + +Lemma modular_group_classP : + extremal_class G = ModularGroup + <-> (exists2 p, prime p & + exists2 n, n >= (p == 2) + 3 & G \isog 'Mod_(p ^ n)). +Proof. +rewrite /extremal_class; split=> [ | [p p_pr [n n_gt23 isoG]]]. + move: (pdiv _) => p; set n := logn p _; do 4?case: ifP => //. + case/andP=> n_gt2 isoG _ _; rewrite ltnW //= => not_isoG _. + exists p; first by move: n_gt2; rewrite /n lognE; case (prime p). + exists n => //; case: eqP => // p2; rewrite ltn_neqAle; case: eqP => // n3. + by case/idP: not_isoG; rewrite p2 -n3 in isoG *. +have n_gt2 := leq_trans (leq_addl _ _) n_gt23; have n_gt1 := ltnW n_gt2. +have n_gt0 := ltnW n_gt1; have def_n := prednK n_gt0. +have [[x y] genG mod_xy] := generators_modular_group p_pr n_gt2 isoG. +case/modular_group_structure: (genG) => // _ _ [_ _ nil2G] _ _. +have [oG _ _ _] := genG; have [oy _] := mod_xy. +rewrite oG -def_n pdiv_pfactor // def_n pfactorK // n_gt1 n_gt2 {}isoG /=. +case: (ltngtP p 2) => [|p_gt2|p2]; first by rewrite ltnNge prime_gt1. + rewrite !(isog_sym G) !isogEcard card_2dihedral ?card_quaternion //= oG. + rewrite leq_exp2r // leqNgt p_gt2 !andbF; case: and3P=> // [[n_gt3 _]]. + by rewrite card_semidihedral // leq_exp2r // leqNgt p_gt2. +rewrite p2 in genG oy n_gt23; rewrite n_gt23. +have: nil_class G <> n.-1. + by apply/eqP; rewrite neq_ltn -ltnS nil2G def_n n_gt23. +case: ifP => [isoG | _]; first by case/dihedral2_structure: genG => // _ []. +case: ifP => [isoG | _]; first by case/quaternion_structure: genG => // _ []. +by case: ifP => // isoG; case/semidihedral_structure: genG => // _ []. +Qed. + +End ExtremalClass. + +Theorem extremal2_structure (gT : finGroupType) (G : {group gT}) n x y : + let cG := extremal_class G in + let m := (2 ^ n)%N in let q := (2 ^ n.-1)%N in let r := (2 ^ n.-2)%N in + let X := <[x]> in let yG := y ^: G in let xyG := (x * y) ^: G in + let My := <> in let Mxy := <> in + extremal_generators G 2 n (x, y) -> + extremal2 G -> (cG == SemiDihedral) ==> (#[y] == 2) -> + [/\ [/\ (if cG == Quaternion then pprod X <[y]> else X ><| <[y]>) = G, + if cG == SemiDihedral then #[x * y] = 4 else + {in G :\: X, forall z, #[z] = (if cG == Dihedral then 2 else 4)}, + if cG != Quaternion then True else + {in G, forall z, #[z] = 2 -> z = x ^+ r} + & {in X & G :\: X, forall t z, + t ^ z = (if cG == SemiDihedral then t ^+ r.-1 else t^-1)}], + [/\ G ^`(1) = <[x ^+ 2]>, 'Phi(G) = G ^`(1), #|G^`(1)| = r + & nil_class G = n.-1], + [/\ if n > 2 then 'Z(G) = <[x ^+ r]> /\ #|'Z(G)| = 2 else 2.-abelem G, + 'Ohm_1(G) = (if cG == Quaternion then <[x ^+ r]> else + if cG == SemiDihedral then My else G), + 'Ohm_2(G) = G + & forall k, k > 0 -> 'Mho^k(G) = <[x ^+ (2 ^ k)]>], + [/\ yG :|: xyG = G :\: X, [disjoint yG & xyG] + & forall H : {group gT}, maximal H G = (gval H \in pred3 X My Mxy)] + & if n <= (cG == Quaternion) + 2 then True else + [/\ forall U, cyclic U -> U \subset G -> #|G : U| = 2 -> U = X, + if cG == Quaternion then My \isog 'Q_q else My \isog 'D_q, + extremal_class My = (if cG == Quaternion then cG else Dihedral), + if cG == Dihedral then Mxy \isog 'D_q else Mxy \isog 'Q_q + & extremal_class Mxy = (if cG == Dihedral then cG else Quaternion)]]. +Proof. +move=> cG m q r X yG xyG My Mxy genG; have [oG _ _ _] := genG. +have logG: logn (pdiv #|G|) #|G| = n by rewrite oG pfactorKpdiv. +rewrite /extremal2 -/cG; do [rewrite {1}/extremal_class /= {}logG] in cG *. +case: ifP => [isoG | _] in cG * => [_ _ /=|]. + case/andP: isoG => n_gt1 isoG. + have:= dihedral2_structure n_gt1 genG isoG; rewrite -/X -/q -/r -/yG -/xyG. + case=> [[defG oX' invXX'] nilG [defOhm defMho] maxG defZ]. + rewrite eqn_leq n_gt1 andbT add0n in defZ *; split=> //. + split=> //; first by case: leqP defZ => // _ []. + by apply/eqP; rewrite eqEsubset Ohm_sub -{1}defOhm Ohm_leq. + case: leqP defZ => // n_gt2 [_ _ isoMy isoMxy defX]. + have n1_gt1: n.-1 > 1 by rewrite -(subnKC n_gt2). + by split=> //; apply/dihedral_classP; exists n.-1. +case: ifP => [isoG | _] in cG * => [_ _ /=|]. + case/andP: isoG => n_gt2 isoG; rewrite n_gt2 add1n. + have:= quaternion_structure n_gt2 genG isoG; rewrite -/X -/q -/r -/yG -/xyG. + case=> [[defG oX' invXX'] nilG [defZ oZ def2 [-> ->] defMho]]. + case=> [[-> ->] maxG] isoM; split=> //. + case: leqP isoM => // n_gt3 [//|isoMy isoMxy defX]. + have n1_gt2: n.-1 > 2 by rewrite -(subnKC n_gt3). + by split=> //; apply/quaternion_classP; exists n.-1. +do [case: ifP => [isoG | _]; last by case: ifP] in cG * => /= _; move/eqnP=> oy. +case/andP: isoG => n_gt3 isoG; rewrite (leqNgt n) (ltnW n_gt3) /=. +have n1_gt2: n.-1 > 2 by rewrite -(subnKC n_gt3). +have:= semidihedral_structure n_gt3 genG isoG oy. +rewrite -/X -/q -/r -/yG -/xyG -/My -/Mxy. +case=> [[defG oxy invXX'] nilG [defZ oZ [-> ->] defMho] [[defX' tiX'] maxG]]. +case=> isoMy isoMxy defX; do 2!split=> //. + by apply/dihedral_classP; exists n.-1; first exact: ltnW. +by apply/quaternion_classP; exists n.-1. +Qed. + +(* This is Aschbacher (23.4). *) +Lemma maximal_cycle_extremal gT p (G X : {group gT}) : + p.-group G -> ~~ abelian G -> cyclic X -> X \subset G -> #|G : X| = p -> + (extremal_class G == ModularGroup) || (p == 2) && extremal2 G. +Proof. +move=> pG not_cGG cycX sXG iXG; rewrite /extremal2; set cG := extremal_class G. +have [|p_pr _ _] := pgroup_pdiv pG. + by case: eqP not_cGG => // ->; rewrite abelian1. +have p_gt1 := prime_gt1 p_pr; have p_gt0 := ltnW p_gt1. +have [n oG] := p_natP pG; have n_gt2: n > 2. + apply: contraR not_cGG; rewrite -leqNgt => n_le2. + by rewrite (p2group_abelian pG) // oG pfactorK. +have def_n := subnKC n_gt2; have n_gt1 := ltnW n_gt2; have n_gt0 := ltnW n_gt1. +pose q := (p ^ n.-1)%N; pose r := (p ^ n.-2)%N. +have q_gt1: q > 1 by rewrite (ltn_exp2l 0) // -(subnKC n_gt2). +have r_gt0: r > 0 by rewrite expn_gt0 p_gt0. +have def_pr: (p * r)%N = q by rewrite /q /r -def_n. +have oX: #|X| = q by rewrite -(divg_indexS sXG) oG iXG /q -def_n mulKn. +have ntX: X :!=: 1 by rewrite -cardG_gt1 oX. +have maxX: maximal X G by rewrite p_index_maximal ?iXG. +have nsXG: X <| G := p_maximal_normal pG maxX; have [_ nXG] := andP nsXG. +have cXX: abelian X := cyclic_abelian cycX. +have scXG: 'C_G(X) = X. + apply/eqP; rewrite eqEsubset subsetI sXG -abelianE cXX !andbT. + apply: contraR not_cGG; case/subsetPn=> y; case/setIP=> Gy cXy notXy. + rewrite -!cycle_subG in Gy notXy; rewrite -(mulg_normal_maximal nsXG _ Gy) //. + by rewrite abelianM cycle_abelian cyclic_abelian ?cycle_subG. +have [x defX] := cyclicP cycX; have pX := pgroupS sXG pG. +have Xx: x \in X by [rewrite defX cycle_id]; have Gx := subsetP sXG x Xx. +have [ox p_x]: #[x] = q /\ p.-elt x by rewrite defX in pX oX. +pose Z := <[x ^+ r]>. +have defZ: Z = 'Ohm_1(X) by rewrite defX (Ohm_p_cycle _ p_x) ox subn1 pfactorK. +have oZ: #|Z| = p by rewrite -orderE orderXdiv ox -def_pr ?dvdn_mull ?mulnK. +have cGZ: Z \subset 'C(G). + have nsZG: Z <| G by rewrite defZ (char_normal_trans (Ohm_char 1 _)). + move/implyP: (meet_center_nil (pgroup_nil pG) nsZG). + rewrite -cardG_gt1 oZ p_gt1 setIA (setIidPl (normal_sub nsZG)). + by apply: contraR; move/prime_TIg=> -> //; rewrite oZ. +have X_Gp y: y \in G -> y ^+ p \in X. + move=> Gy; have nXy: y \in 'N(X) := subsetP nXG y Gy. + rewrite coset_idr ?groupX // morphX //; apply/eqP. + by rewrite -order_dvdn -iXG -card_quotient // order_dvdG ?mem_quotient. +have [y X'y]: exists2 y, y \in G :\: X & + (p == 2) + 3 <= n /\ x ^ y = x ^+ r.+1 \/ p = 2 /\ x * x ^ y \in Z. +- have [y Gy notXy]: exists2 y, y \in G & y \notin X. + by apply/subsetPn; rewrite proper_subn ?(maxgroupp maxX). + have nXy: y \in 'N(X) := subsetP nXG y Gy; pose ay := conj_aut X y. + have oay: #[ay] = p. + apply: nt_prime_order => //. + by rewrite -morphX // mker // ker_conj_aut (subsetP cXX) ?X_Gp. + rewrite (sameP eqP (kerP _ nXy)) ker_conj_aut. + by apply: contra notXy => cXy; rewrite -scXG inE Gy. + have [m []]:= cyclic_pgroup_Aut_structure pX cycX ntX. + set Ap := 'O_p(_); case=> def_m [m1 _] [m_inj _] _ _ _. + have sylAp: p.-Sylow(Aut X) Ap. + by rewrite nilpotent_pcore_Hall // abelian_nil // Aut_cyclic_abelian. + have Ap1ay: ay \in 'Ohm_1(Ap). + rewrite (OhmE _ (pcore_pgroup _ _)) mem_gen // !inE -order_dvdn oay dvdnn. + rewrite (mem_normal_Hall sylAp) ?pcore_normal ?Aut_aut //. + by rewrite /p_elt oay pnat_id. + rewrite {1}oX pfactorK // -{1}def_n /=. + have [p2 | odd_p] := even_prime p_pr; last first. + rewrite (sameP eqP (prime_oddPn p_pr)) odd_p n_gt2. + case=> _ [_ _ _] [_ _ [s [As os m_s defAp1]]]. + have [j def_s]: exists j, s = ay ^+ j. + apply/cycleP; rewrite -cycle_subG subEproper eq_sym eqEcard -!orderE. + by rewrite -defAp1 cycle_subG Ap1ay oay os leqnn . + exists (y ^+ j); last first. + left; rewrite -(norm_conj_autE _ Xx) ?groupX // morphX // -def_s. + by rewrite -def_m // m_s expg_znat // oX pfactorK ?eqxx. + rewrite -scXG !inE groupX //= andbT -ker_conj_aut !inE morphX // -def_s. + rewrite andbC -(inj_in_eq m_inj) ?group1 // m_s m1 oX pfactorK // -/r. + rewrite mulrSr -subr_eq0 addrK -val_eqE /= val_Zp_nat //. + by rewrite [_ == 0%N]dvdn_Pexp2l // -def_n ltnn. + rewrite {1}p2 /= => [[t [At ot m_t]]]; rewrite {1}oX pfactorK // -{1}def_n. + rewrite eqSS subn_eq0 => defA; exists y; rewrite ?inE ?notXy //. + rewrite p2 -(norm_conj_autE _ Xx) //= -/ay -def_m ?Aut_aut //. + case Tay: (ay \in <[t]>). + rewrite cycle2g // !inE -order_eq1 oay p2 /= in Tay. + by right; rewrite (eqP Tay) m_t expg_zneg // mulgV group1. + case: leqP defA => [_ defA|le3n [a [Aa _ _ defA [s [As os m_s m_st defA1]]]]]. + by rewrite -defA Aut_aut in Tay. + have: ay \in [set s; s * t]. + have: ay \in 'Ohm_1(Aut X) := subsetP (OhmS 1 (pcore_sub _ _)) ay Ap1ay. + case/dprodP: (Ohm_dprod 1 defA) => _ <- _ _. + rewrite defA1 (@Ohm_p_cycle _ _ 2) /p_elt ot //= expg1 cycle2g //. + by rewrite mulUg mul1g inE Tay cycle2g // mulgU mulg1 mulg_set1. + case/set2P=> ->; [left | right]. + by rewrite ?le3n m_s expg_znat // oX pfactorK // -p2. + by rewrite m_st expg_znat // oX pfactorK // -p2 -/r -expgS prednK ?cycle_id. +have [Gy notXy] := setDP X'y; have nXy := subsetP nXG y Gy. +have defG j: <[x]> <*> <[x ^+ j * y]> = G. + rewrite -defX -genM_join. + by rewrite (mulg_normal_maximal nsXG) ?cycle_subG ?groupMl ?groupX ?genGid. +have[i def_yp]: exists i, y ^- p = x ^+ i. + by apply/cycleP; rewrite -defX groupV X_Gp. +have p_i: p %| i. + apply: contraR notXy; rewrite -prime_coprime // => co_p_j. + have genX: generator X (y ^- p). + by rewrite def_yp defX generator_coprime ox coprime_expl. + rewrite -scXG (setIidPl _) // centsC ((X :=P: _) genX) cycle_subG groupV. + rewrite /= -(defG 0%N) mul1g centY inE -defX (subsetP cXX) ?X_Gp //. + by rewrite (subsetP (cycle_abelian y)) ?mem_cycle. +case=> [[n_gt23 xy] | [p2 Z_xxy]]. + suffices ->: cG = ModularGroup by []; apply/modular_group_classP. + exists p => //; exists n => //; rewrite isogEcard card_modular_group //. + rewrite oG leqnn andbT Grp_modular_group // -/q -/r. + have{i def_yp p_i} [i def_yp]: exists i, y ^- p = x ^+ i ^+ p. + by case/dvdnP: p_i => j def_i; exists j; rewrite -expgM -def_i. + have Zyx: [~ y, x] \in Z. + by rewrite -groupV invg_comm commgEl xy expgS mulKg cycle_id. + have def_yxj j: [~ y, x ^+ j] = [~ y, x] ^+ j. + by rewrite commgX /commute ?(centsP cGZ _ Zyx). + have Zyxj j: [~ y, x ^+ j] \in Z by rewrite def_yxj groupX. + have x_xjy j: x ^ (x ^+ j * y) = x ^+ r.+1. + by rewrite conjgM {2}/conjg commuteX //= mulKg. + have [cyxi | not_cyxi] := eqVneq ([~ y, x ^+ i] ^+ 'C(p, 2)) 1. + apply/existsP; exists (x, x ^+ i * y); rewrite /= !xpair_eqE. + rewrite defG x_xjy -order_dvdn ox dvdnn !eqxx andbT /=. + rewrite expMg_Rmul /commute ?(centsP cGZ _ (Zyxj _)) ?groupX // cyxi. + by rewrite -def_yp -mulgA mulKg. + have [p2 | odd_p] := even_prime p_pr; last first. + by rewrite -order_dvdn bin2odd ?dvdn_mulr // -oZ order_dvdG in not_cyxi. + have def_yxi: [~ y, x ^+ i] = x ^+ r. + have:= Zyxj i; rewrite /Z cycle_traject orderE oZ p2 !inE mulg1. + by case/pred2P=> // cyxi; rewrite cyxi p2 eqxx in not_cyxi. + apply/existsP; exists (x, x ^+ (i + r %/ 2) * y); rewrite /= !xpair_eqE. + rewrite defG x_xjy -order_dvdn ox dvdnn !eqxx andbT /=. + rewrite expMg_Rmul /commute ?(centsP cGZ _ (Zyxj _)) ?groupX // def_yxj. + rewrite -expgM mulnDl addnC !expgD (expgM x i) -def_yp mulgKV. + rewrite -def_yxj def_yxi p2 mulgA -expgD in n_gt23 *. + rewrite -expg_mod_order ox /q /r p2 -(subnKC n_gt23) mulnC !expnS mulKn //. + rewrite addnn -mul2n modnn mul1g -order_dvdn dvdn_mulr //. + by rewrite -p2 -oZ order_dvdG. +have{i def_yp p_i} Zy2: y ^+ 2 \in Z. + rewrite defZ (OhmE _ pX) -groupV -p2 def_yp mem_gen // !inE groupX //= p2. + rewrite expgS -{2}def_yp -(mulKg y y) -conjgE -conjXg -conjVg def_yp conjXg. + rewrite -expgMn //; last by apply: (centsP cXX); rewrite ?memJ_norm. + by rewrite -order_dvdn (dvdn_trans (order_dvdG Z_xxy)) ?oZ. +rewrite !cycle_traject !orderE oZ p2 !inE !mulg1 /= in Z_xxy Zy2 *. +rewrite -eq_invg_mul eq_sym -[r]prednK // expgS (inj_eq (mulgI _)) in Z_xxy. +case/pred2P: Z_xxy => xy; last first. + suffices ->: cG = SemiDihedral by []; apply/semidihedral_classP. + have n_gt3: n > 3. + case: ltngtP notXy => // [|n3]; first by rewrite ltnNge n_gt2. + rewrite -scXG inE Gy defX cent_cycle; case/cent1P; red. + by rewrite (conjgC x) xy /r p2 n3. + exists n => //; rewrite isogEcard card_semidihedral // oG p2 leqnn andbT. + rewrite Grp_semidihedral //; apply/existsP=> /=. + case/pred2P: Zy2 => y2; [exists (x, y) | exists (x, x * y)]. + by rewrite /= -{1}[y]mul1g (defG 0%N) y2 xy -p2 -/q -ox expg_order. + rewrite /= (defG 1%N) conjgM {2}/conjg mulKg -p2 -/q -ox expg_order -xy. + rewrite !xpair_eqE !eqxx /= andbT p2 expgS {2}(conjgC x) xy mulgA -(mulgA x). + rewrite [y * y]y2 -expgS -expgD addSnnS prednK // addnn -mul2n -p2 def_pr. + by rewrite -ox expg_order. +case/pred2P: Zy2 => y2. + suffices ->: cG = Dihedral by []; apply/dihedral_classP. + exists n => //; rewrite isogEcard card_2dihedral // oG p2 leqnn andbT. + rewrite Grp_2dihedral //; apply/existsP; exists (x, y) => /=. + by rewrite /= -{1}[y]mul1g (defG 0%N) y2 xy -p2 -/q -ox expg_order. +suffices ->: cG = Quaternion by []; apply/quaternion_classP. +exists n => //; rewrite isogEcard card_quaternion // oG p2 leqnn andbT. +rewrite Grp_quaternion //; apply/existsP; exists (x, y) => /=. +by rewrite /= -{1}[y]mul1g (defG 0%N) y2 xy -p2 -/q -ox expg_order. +Qed. + +(* This is Aschbacher (23.5) *) +Lemma cyclic_SCN gT p (G U : {group gT}) : + p.-group G -> U \in 'SCN(G) -> ~~ abelian G -> cyclic U -> + [/\ p = 2, #|G : U| = 2 & extremal2 G] +\/ exists M : {group gT}, + [/\ M :=: 'C_G('Mho^1(U)), #|M : U| = p, extremal_class M = ModularGroup, + 'Ohm_1(M)%G \in 'E_p^2(G) & 'Ohm_1(M) \char G]. +Proof. +move=> pG /SCN_P[nsUG scUG] not_cGG cycU; have [sUG nUG] := andP nsUG. +have [cUU pU] := (cyclic_abelian cycU, pgroupS sUG pG). +have ltUG: ~~ (G \subset U). + by apply: contra not_cGG => sGU; exact: abelianS cUU. +have ntU: U :!=: 1. + by apply: contra ltUG; move/eqP=> U1; rewrite -(setIidPl (cents1 G)) -U1 scUG. +have [p_pr _ [n oU]] := pgroup_pdiv pU ntU. +have p_gt1 := prime_gt1 p_pr; have p_gt0 := ltnW p_gt1. +have [u defU] := cyclicP cycU; have Uu: u \in U by rewrite defU cycle_id. +have Gu := subsetP sUG u Uu; have p_u := mem_p_elt pG Gu. +have defU1: 'Mho^1(U) = <[u ^+ p]> by rewrite defU (Mho_p_cycle _ p_u). +have modM1 (M : {group gT}): + [/\ U \subset M, #|M : U| = p & extremal_class M = ModularGroup] -> + M :=: 'C_M('Mho^1(U)) /\ 'Ohm_1(M)%G \in 'E_p^2(M). +- case=> sUM iUM /modular_group_classP[q q_pr {n oU}[n n_gt23 isoM]]. + have n_gt2: n > 2 by exact: leq_trans (leq_addl _ _) n_gt23. + have def_n: n = (n - 3).+3 by rewrite -{1}(subnKC n_gt2). + have oM: #|M| = (q ^ n)%N by rewrite (card_isog isoM) card_modular_group. + have pM: q.-group M by rewrite /pgroup oM pnat_exp pnat_id. + have def_q: q = p; last rewrite {q q_pr}def_q in oM pM isoM n_gt23. + by apply/eqP; rewrite eq_sym [p == q](pgroupP pM) // -iUM dvdn_indexg. + have [[x y] genM modM] := generators_modular_group p_pr n_gt2 isoM. + case/modular_group_structure: genM => // _ [defZ _ oZ] _ defMho. + have ->: 'Mho^1(U) = 'Z(M). + apply/eqP; rewrite eqEcard oZ defZ -(defMho 1%N) ?MhoS //= defU1 -orderE. + suff ou: #[u] = (p * p ^ n.-2)%N by rewrite orderXdiv ou ?dvdn_mulr ?mulKn. + by rewrite orderE -defU -(divg_indexS sUM) iUM oM def_n mulKn. + case: eqP => [[p2 n3] | _ defOhm]; first by rewrite p2 n3 in n_gt23. + have{defOhm} [|defM1 oM1] := defOhm 1%N; first by rewrite def_n. + split; rewrite ?(setIidPl _) //; first by rewrite centsC subsetIr. + rewrite inE oM1 pfactorK // andbT inE Ohm_sub abelem_Ohm1 //. + exact: (card_p2group_abelian p_pr oM1). +have ou: #[u] = (p ^ n.+1)%N by rewrite defU in oU. +pose Gs := G / U; have pGs: p.-group Gs by rewrite quotient_pgroup. +have ntGs: Gs != 1 by rewrite -subG1 quotient_sub1. +have [_ _ [[|k] oGs]] := pgroup_pdiv pGs ntGs. + have iUG: #|G : U| = p by rewrite -card_quotient ?oGs. + case: (predU1P (maximal_cycle_extremal _ _ _ _ iUG)) => // [modG | ext2G]. + by right; exists G; case: (modM1 G) => // <- ->; rewrite Ohm_char. + by left; case: eqP ext2G => // <-. +pose M := 'C_G('Mho^1(U)); right; exists [group of M]. +have sMG: M \subset G by exact: subsetIl. +have [pM nUM] := (pgroupS sMG pG, subset_trans sMG nUG). +have sUM: U \subset M by rewrite subsetI sUG sub_abelian_cent ?Mho_sub. +pose A := Aut U; have cAA: abelian A by rewrite Aut_cyclic_abelian. +have sylAp: p.-Sylow(A) 'O_p(A) by rewrite nilpotent_pcore_Hall ?abelian_nil. +have [f [injf sfGsA fG]]: exists f : {morphism Gs >-> {perm gT}}, + [/\ 'injm f, f @* Gs \subset A & {in G, forall y, f (coset U y) u = u ^ y}]. +- have [] := first_isom_loc [morphism of conj_aut U] nUG. + rewrite ker_conj_aut scUG /= -/Gs => f injf im_f. + exists f; rewrite im_f ?Aut_conj_aut //. + split=> // y Gy; have nUy := subsetP nUG y Gy. + suffices ->: f (coset U y) = conj_aut U y by rewrite norm_conj_autE. + by apply: set1_inj; rewrite -!morphim_set1 ?mem_quotient // im_f ?sub1set. +have cGsGs: abelian Gs by rewrite -(injm_abelian injf) // (abelianS sfGsA). +have p_fGs: p.-group (f @* Gs) by rewrite morphim_pgroup. +have sfGsAp: f @* Gs \subset 'O_p(A) by rewrite (sub_Hall_pcore sylAp). +have [a [fGa oa au n_gt01 cycGs]]: exists a, + [/\ a \in f @* Gs, #[a] = p, a u = u ^+ (p ^ n).+1, (p == 2) + 1 <= n + & cyclic Gs \/ p = 2 /\ (exists2 c, c \in f @* Gs & c u = u^-1)]. +- have [m [[def_m _ _ _ _] _]] := cyclic_pgroup_Aut_structure pU cycU ntU. + have ->: logn p #|U| = n.+1 by rewrite oU pfactorK. + rewrite /= -/A; case: posnP => [_ defA | n_gt0 [c [Ac oc m_c defA]]]. + have:= cardSg sfGsAp; rewrite (card_Hall sylAp) /= -/A defA card_injm //. + by rewrite oGs (part_p'nat (pcore_pgroup _ _)) pfactor_dvdn // logn1. + have [p2 | odd_p] := even_prime p_pr; last first. + case: eqP => [-> // | _] in odd_p *; rewrite odd_p in defA. + have [[cycA _] _ [a [Aa oa m_a defA1]]] := defA. + exists a; rewrite -def_m // oa m_a expg_znat //. + split=> //; last by left; rewrite -(injm_cyclic injf) ?(cyclicS sfGsA). + have: f @* Gs != 1 by rewrite morphim_injm_eq1. + rewrite -cycle_subG; apply: contraR => not_sfGs_a. + by rewrite -(setIidPl sfGsAp) TI_Ohm1 // defA1 setIC prime_TIg -?orderE ?oa. + do [rewrite {1}p2 /= eqn_leq n_gt0; case: leqP => /= [_ | n_gt1]] in defA. + have:= cardSg sfGsAp; rewrite (card_Hall sylAp) /= -/A defA -orderE oc p2. + by rewrite card_injm // oGs p2 pfactor_dvdn // p_part. + have{defA} [s [As os _ defA [a [Aa oa m_a _ defA1]]]] := defA; exists a. + have fGs_a: a \in f @* Gs. + suffices: f @* Gs :&: <[s]> != 1. + apply: contraR => not_fGs_a; rewrite TI_Ohm1 // defA1 setIC. + by rewrite prime_TIg -?orderE ?oa // cycle_subG. + have: (f @* Gs) * <[s]> \subset A by rewrite mulG_subG cycle_subG sfGsA. + move/subset_leq_card; apply: contraL; move/eqP; move/TI_cardMg->. + rewrite -(dprod_card defA) -ltnNge mulnC -!orderE ltn_pmul2r // oc. + by rewrite card_injm // oGs p2 (ltn_exp2l 1%N). + rewrite -def_m // oa m_a expg_znat // p2; split=> //. + rewrite abelian_rank1_cyclic // (rank_pgroup pGs) //. + rewrite -(injm_p_rank injf) // p_rank_abelian 1?morphim_abelian //= p2 -/Gs. + case: leqP => [|fGs1_gt1]; [by left | right]. + split=> //; exists c; last by rewrite -def_m // m_c expg_zneg. + have{defA1} defA1: <[a]> \x <[c]> = 'Ohm_1(Aut U). + by rewrite -(Ohm_dprod 1 defA) defA1 (@Ohm_p_cycle 1 _ 2) /p_elt oc. + have def_fGs1: 'Ohm_1(f @* Gs) = 'Ohm_1(A). + apply/eqP; rewrite eqEcard OhmS // -(dprod_card defA1) -!orderE oa oc. + by rewrite dvdn_leq ?(@pfactor_dvdn 2 2) ?cardG_gt0. + rewrite (subsetP (Ohm_sub 1 _)) // def_fGs1 -cycle_subG. + by case/dprodP: defA1 => _ <- _ _; rewrite mulG_subr. +have n_gt0: n > 0 := leq_trans (leq_addl _ _) n_gt01. +have [ys Gys _ def_a] := morphimP fGa. +have oys: #[ys] = p by rewrite -(order_injm injf) // -def_a oa. +have defMs: M / U = <[ys]>. + apply/eqP; rewrite eq_sym eqEcard -orderE oys cycle_subG; apply/andP; split. + have [y nUy Gy /= def_ys] := morphimP Gys. + rewrite def_ys mem_quotient //= inE Gy defU1 cent_cycle cent1C. + rewrite (sameP cent1P commgP) commgEl conjXg -fG //= -def_ys -def_a au. + by rewrite -expgM mulSn expgD mulKg -expnSr -ou expg_order. + rewrite card_quotient // -(setIidPr sUM) -scUG setIA (setIidPl sMG). + rewrite defU cent_cycle index_cent1 -(card_imset _ (mulgI u^-1)) -imset_comp. + have <-: #|'Ohm_1(U)| = p. + rewrite defU (Ohm_p_cycle 1 p_u) -orderE (orderXexp _ ou) ou pfactorK //. + by rewrite subKn. + rewrite (OhmE 1 pU) subset_leq_card ?sub_gen //. + apply/subsetP=> _ /imsetP[z /setIP[/(subsetP nUG) nUz cU1z] ->]. + have Uv' := groupVr Uu; have Uuz: u ^ z \in U by rewrite memJ_norm. + rewrite !inE groupM // expgMn /commute 1?(centsP cUU u^-1) //= expgVn -conjXg. + by rewrite (sameP commgP cent1P) cent1C -cent_cycle -defU1. +have iUM: #|M : U| = p by rewrite -card_quotient ?defMs. +have not_cMM: ~~ abelian M. + apply: contraL p_pr => cMM; rewrite -iUM -indexgI /= -/M. + by rewrite (setIidPl _) ?indexgg // -scUG subsetI sMG sub_abelian_cent. +have modM: extremal_class M = ModularGroup. + have sU1Z: 'Mho^1(U) \subset 'Z(M). + by rewrite subsetI (subset_trans (Mho_sub 1 U)) // centsC subsetIr. + case: (predU1P (maximal_cycle_extremal _ _ _ _ iUM)) => //=; rewrite -/M. + case/andP; move/eqP=> p2 ext2M; rewrite p2 add1n in n_gt01. + suffices{sU1Z}: #|'Z(M)| = 2. + move/eqP; rewrite eqn_leq leqNgt (leq_trans _ (subset_leq_card sU1Z)) //. + by rewrite defU1 -orderE (orderXexp 1 ou) subn1 p2 (ltn_exp2l 1). + move: ext2M; rewrite /extremal2 !inE orbC -orbA; case/or3P; move/eqP. + - case/semidihedral_classP=> m m_gt3 isoM. + have [[x z] genM [oz _]] := generators_semidihedral m_gt3 isoM. + by case/semidihedral_structure: genM => // _ _ []. + - case/quaternion_classP=> m m_gt2 isoM. + have [[x z] genM _] := generators_quaternion m_gt2 isoM. + by case/quaternion_structure: genM => // _ _ []. + case/dihedral_classP=> m m_gt1 isoM. + have [[x z] genM _] := generators_2dihedral m_gt1 isoM. + case/dihedral2_structure: genM not_cMM => // _ _ _ _. + by case: (m == 2) => [|[]//]; move/abelem_abelian->. +split=> //. + have [//|_] := modM1 [group of M]; rewrite !inE -andbA /=. + by case/andP; move/subset_trans->. +have{cycGs} [cycGs | [p2 [c fGs_c u_c]]] := cycGs. + suffices ->: 'Ohm_1(M) = 'Ohm_1(G) by exact: Ohm_char. + suffices sG1M: 'Ohm_1(G) \subset M. + by apply/eqP; rewrite eqEsubset -{2}(Ohm_id 1 G) !OhmS. + rewrite -(quotientSGK _ sUM) ?(subset_trans (Ohm_sub _ G)) //= defMs. + suffices ->: <[ys]> = 'Ohm_1(Gs) by rewrite morphim_Ohm. + apply/eqP; rewrite eqEcard -orderE cycle_subG /= {1}(OhmE 1 pGs) /=. + rewrite mem_gen ?inE ?Gys -?order_dvdn oys //=. + rewrite -(part_pnat_id (pgroupS (Ohm_sub _ _) pGs)) p_part (leq_exp2l _ 1) //. + by rewrite -p_rank_abelian -?rank_pgroup -?abelian_rank1_cyclic. +suffices charU1: 'Mho^1(U) \char G^`(1). + rewrite (char_trans (Ohm_char _ _)) // subcent_char ?char_refl //. + exact: char_trans (der_char 1 G). +suffices sUiG': 'Mho^1(U) \subset G^`(1). + have cycG': cyclic G^`(1) by rewrite (cyclicS _ cycU) // der1_min. + by case/cyclicP: cycG' sUiG' => zs ->; exact: cycle_subgroup_char. +rewrite defU1 cycle_subG p2 -groupV invMg -{2}u_c. +by case/morphimP: fGs_c => _ _ /morphimP[z _ Gz ->] ->; rewrite fG ?mem_commg. +Qed. + +(* This is Aschbacher, exercise (8.4) *) +Lemma normal_rank1_structure gT p (G : {group gT}) : + p.-group G -> (forall X : {group gT}, X <| G -> abelian X -> cyclic X) -> + cyclic G \/ [&& p == 2, extremal2 G & (#|G| >= 16) || (G \isog 'Q_8)]. +Proof. +move=> pG dn_G_1. +have [cGG | not_cGG] := boolP (abelian G); first by left; rewrite dn_G_1. +have [X maxX]: {X | [max X | X <| G & abelian X]}. + by apply: ex_maxgroup; exists 1%G; rewrite normal1 abelian1. +have cycX: cyclic X by rewrite dn_G_1; case/andP: (maxgroupp maxX). +have scX: X \in 'SCN(G) := max_SCN pG maxX. +have [[p2 _ cG] | [M [_ _ _]]] := cyclic_SCN pG scX not_cGG cycX; last first. + rewrite 2!inE -andbA; case/and3P=> sEG abelE dimE_2 charE. + have:= dn_G_1 _ (char_normal charE) (abelem_abelian abelE). + by rewrite (abelem_cyclic abelE) (eqP dimE_2). +have [n oG] := p_natP pG; right; rewrite p2 cG /= in oG *. +rewrite oG (@leq_exp2l 2 4) //. +rewrite /extremal2 /extremal_class oG pfactorKpdiv // in cG. +case: andP cG => [[n_gt1 isoG] _ | _]; last first. + by rewrite leq_eqVlt; case: (3 < n); case: eqP => //= <-; do 2?case: ifP. +have [[x y] genG _] := generators_2dihedral n_gt1 isoG. +have [_ _ _ [_ _ maxG]] := dihedral2_structure n_gt1 genG isoG. +rewrite 2!ltn_neqAle n_gt1 !(eq_sym _ n). +case: eqP => [_ abelG| _]; first by rewrite (abelem_abelian abelG) in not_cGG. +case: eqP => // -> [_ _ isoY _ _]; set Y := <<_>> in isoY. +have nxYG: Y <| G by rewrite (p_maximal_normal pG) // maxG !inE eqxx orbT. +have [// | [u v] genY _] := generators_2dihedral _ isoY. +case/dihedral2_structure: (genY) => //= _ _ _ _ abelY. +have:= dn_G_1 _ nxYG (abelem_abelian abelY). +by rewrite (abelem_cyclic abelY); case: genY => ->. +Qed. + +(* Replacement for Section 4 proof. *) +Lemma odd_pgroup_rank1_cyclic gT p (G : {group gT}) : + p.-group G -> odd #|G| -> cyclic G = ('r_p(G) <= 1). +Proof. +move=> pG oddG; rewrite -rank_pgroup //; apply/idP/idP=> [cycG | dimG1]. + by rewrite -abelian_rank1_cyclic ?cyclic_abelian. +have [X nsXG cXX|//|] := normal_rank1_structure pG; last first. + by rewrite (negPf (odd_not_extremal2 oddG)) andbF. +by rewrite abelian_rank1_cyclic // (leq_trans (rankS (normal_sub nsXG))). +Qed. + +(* This is the second part of Aschbacher, exercise (8.4). *) +Lemma prime_Ohm1P gT p (G : {group gT}) : + p.-group G -> G :!=: 1 -> + reflect (#|'Ohm_1(G)| = p) + (cyclic G || (p == 2) && (extremal_class G == Quaternion)). +Proof. +move=> pG ntG; have [p_pr p_dvd_G _] := pgroup_pdiv pG ntG. +apply: (iffP idP) => [|oG1p]. + case/orP=> [cycG|]; first exact: Ohm1_cyclic_pgroup_prime. + case/andP=> /eqP p2 /eqP/quaternion_classP[n n_gt2 isoG]. + rewrite p2; have [[x y]] := generators_quaternion n_gt2 isoG. + by case/quaternion_structure=> // _ _ [<- oZ _ [->]]. +have [X nsXG cXX|-> //|]:= normal_rank1_structure pG. + have [sXG _] := andP nsXG; have pX := pgroupS sXG pG. + rewrite abelian_rank1_cyclic // (rank_pgroup pX) p_rank_abelian //. + rewrite -{2}(pfactorK 1 p_pr) -{3}oG1p dvdn_leq_log ?cardG_gt0 //. + by rewrite cardSg ?OhmS. +case/and3P=> /eqP p2; rewrite p2 (orbC (cyclic G)) /extremal2. +case cG: (extremal_class G) => //; case: notF. + case/dihedral_classP: cG => n n_gt1 isoG. + have [[x y] genG _] := generators_2dihedral n_gt1 isoG. + have [oG _ _ _] := genG; case/dihedral2_structure: genG => // _ _ [defG1 _] _. + by case/idPn: n_gt1; rewrite -(@ltn_exp2l 2) // -oG -defG1 oG1p p2. +case/semidihedral_classP: cG => n n_gt3 isoG. +have [[x y] genG [oy _]] := generators_semidihedral n_gt3 isoG. +case/semidihedral_structure: genG => // _ _ [_ _ [defG1 _] _] _ [isoG1 _ _]. +case/idPn: (n_gt3); rewrite -(ltn_predK n_gt3) ltnS -leqNgt -(@leq_exp2l 2) //. +rewrite -card_2dihedral //; last by rewrite -(subnKC n_gt3). +by rewrite -(card_isog isoG1) /= -defG1 oG1p p2. +Qed. + +(* This is Aschbacher (23.9) *) +Theorem symplectic_type_group_structure gT p (G : {group gT}) : + p.-group G -> (forall X : {group gT}, X \char G -> abelian X -> cyclic X) -> + exists2 E : {group gT}, E :=: 1 \/ extraspecial E + & exists R : {group gT}, + [/\ cyclic R \/ [/\ p = 2, extremal2 R & #|R| >= 16], + E \* R = G + & E :&: R = 'Z(E)]. +Proof. +move=> pG sympG; have [H [charH]] := Thompson_critical pG. +have sHG := char_sub charH; have pH := pgroupS sHG pG. +set U := 'Z(H) => sPhiH_U sHG_U defU; set Z := 'Ohm_1(U). +have sZU: Z \subset U by rewrite Ohm_sub. +have charU: U \char G := char_trans (center_char H) charH. +have cUU: abelian U := center_abelian H. +have cycU: cyclic U by exact: sympG. +have pU: p.-group U := pgroupS (char_sub charU) pG. +have cHU: U \subset 'C(H) by rewrite subsetIr. +have cHsHs: abelian (H / Z). + rewrite sub_der1_abelian //= (OhmE _ pU) genS //= -/U. + apply/subsetP=> _ /imset2P[h k Hh Hk ->]. + have Uhk: [~ h, k] \in U by rewrite (subsetP sHG_U) ?mem_commg ?(subsetP sHG). + rewrite inE Uhk inE -commXg; last by red; rewrite -(centsP cHU). + apply/commgP; red; rewrite (centsP cHU) // (subsetP sPhiH_U) //. + by rewrite (Phi_joing pH) mem_gen // inE orbC (Mho_p_elt 1) ?(mem_p_elt pH). +have nsZH: Z <| H by rewrite sub_center_normal. +have [K /=] := inv_quotientS nsZH (Ohm_sub 1 (H / Z)); fold Z => defKs sZK sKH. +have nsZK: Z <| K := normalS sZK sKH nsZH; have [_ nZK] := andP nsZK. +have abelKs: p.-abelem (K / Z) by rewrite -defKs Ohm1_abelem ?quotient_pgroup. +have charK: K \char G. + have charZ: Z \char H := char_trans (Ohm_char _ _) (center_char H). + rewrite (char_trans _ charH) // (char_from_quotient nsZK) //. + by rewrite -defKs Ohm_char. +have cycZK: cyclic 'Z(K). + by rewrite sympG ?center_abelian ?(char_trans (center_char _)). +have [cKK | not_cKK] := orP (orbN (abelian K)). + have defH: U = H. + apply: center_idP; apply: cyclic_factor_abelian (Ohm_sub 1 _) _. + rewrite /= -/Z abelian_rank1_cyclic //. + have cKsKs: abelian (K / Z) by rewrite -defKs (abelianS (Ohm_sub 1 _)). + have cycK: cyclic K by rewrite -(center_idP cKK). + by rewrite -rank_Ohm1 defKs -abelian_rank1_cyclic ?quotient_cyclic. + have scH: H \in 'SCN(G) by apply/SCN_P; rewrite defU char_normal. + have [cGG | not_cGG] := orP (orbN (abelian G)). + exists 1%G; [by left | exists G; rewrite cprod1g (setIidPl _) ?sub1G //]. + by split; first left; rewrite ?center1 // sympG ?char_refl. + have cycH: cyclic H by rewrite -{}defH. + have [[p2 _ cG2]|[M [_ _ _]]] := cyclic_SCN pG scH not_cGG cycH; last first. + do 2![case/setIdP] => _ abelE dimE_2 charE. + have:= sympG _ charE (abelem_abelian abelE). + by rewrite (abelem_cyclic abelE) (eqP dimE_2). + have [n oG] := p_natP pG; rewrite p2 in oG. + have [n_gt3 | n_le3] := ltnP 3 n. + exists 1%G; [by left | exists G; rewrite cprod1g (setIidPl _) ?sub1G //]. + by split; first right; rewrite ?center1 // oG (@leq_exp2l 2 4). + have esG: extraspecial G. + by apply: (p3group_extraspecial pG); rewrite // p2 oG pfactorK. + exists G; [by right | exists ('Z(G))%G; rewrite cprod_center_id setIA setIid]. + by split=> //; left; rewrite prime_cyclic; case: esG. +have ntK: K :!=: 1 by apply: contra not_cKK; move/eqP->; exact: abelian1. +have [p_pr _ _] := pgroup_pdiv (pgroupS sKH pH) ntK. +have p_gt1 := prime_gt1 p_pr; have p_gt0 := ltnW p_gt1. +have oZ: #|Z| = p. + apply: Ohm1_cyclic_pgroup_prime => //=; apply: contra ntK; move/eqP. + by move/(trivg_center_pgroup pH)=> GH; rewrite -subG1 -GH. +have sZ_ZK: Z \subset 'Z(K). + by rewrite subsetI sZK (subset_trans (Ohm_sub _ _ )) // subIset ?centS ?orbT. +have sZsKs: 'Z(K) / Z \subset K / Z by rewrite quotientS ?center_sub. +have [Es /= splitKs] := abelem_split_dprod abelKs sZsKs. +have [_ /= defEsZs cEsZs tiEsZs] := dprodP splitKs. +have sEsKs: Es \subset K / Z by rewrite -defEsZs mulG_subr. +have [E defEs sZE sEK] := inv_quotientS nsZK sEsKs; rewrite /= -/Z in defEs sZE. +have [nZE nZ_ZK] := (subset_trans sEK nZK, subset_trans (center_sub K) nZK). +have defK: 'Z(K) * E = K. + rewrite -(mulSGid sZ_ZK) -mulgA -quotientK ?mul_subG ?quotientMl //. + by rewrite -defEs defEsZs quotientGK. +have defZE: 'Z(E) = Z. + have cEZK: 'Z(K) \subset 'C(E) by rewrite subIset // orbC centS. + have cE_Z: E \subset 'C(Z) by rewrite centsC (subset_trans sZ_ZK). + apply/eqP; rewrite eqEsubset andbC subsetI sZE centsC cE_Z /=. + rewrite -quotient_sub1 ?subIset ?nZE //= -/Z -tiEsZs subsetI defEs. + rewrite !quotientS ?center_sub //= subsetI subIset ?sEK //=. + by rewrite -defK centM setSI // centsC. +have sEH := subset_trans sEK sKH; have pE := pgroupS sEH pH. +have esE: extraspecial E. + split; last by rewrite defZE oZ. + have sPhiZ: 'Phi(E) \subset Z. + rewrite -quotient_sub1 ?(subset_trans (Phi_sub _)) ?(quotient_Phi pE) //. + rewrite subG1 (trivg_Phi (quotient_pgroup _ pE)) /= -defEs. + by rewrite (abelemS sEsKs) //= -defKs Ohm1_abelem ?quotient_pgroup. + have sE'Phi: E^`(1) \subset 'Phi(E) by rewrite (Phi_joing pE) joing_subl. + have ntE': E^`(1) != 1. + rewrite (sameP eqP commG1P) -abelianE; apply: contra not_cKK => cEE. + by rewrite -defK mulGSid ?center_abelian // -(center_idP cEE) defZE. + have defE': E^`(1) = Z. + apply/eqP; rewrite eqEcard (subset_trans sE'Phi) //= oZ. + have [_ _ [n ->]] := pgroup_pdiv (pgroupS (der_sub _ _) pE) ntE'. + by rewrite (leq_exp2l 1) ?prime_gt1. + by split; rewrite defZE //; apply/eqP; rewrite eqEsubset sPhiZ -defE'. +have [spE _] := esE; have [defPhiE defE'] := spE. +have{defE'} sEG_E': [~: E, G] \subset E^`(1). + rewrite defE' defZE /Z (OhmE _ pU) commGC genS //. + apply/subsetP=> _ /imset2P[g e Gg Ee ->]. + have He: e \in H by rewrite (subsetP sKH) ?(subsetP sEK). + have Uge: [~ g, e] \in U by rewrite (subsetP sHG_U) ?mem_commg. + rewrite inE Uge inE -commgX; last by red; rewrite -(centsP cHU). + have sZ_ZG: Z \subset 'Z(G). + have charZ: Z \char G := char_trans (Ohm_char _ _) charU. + move/implyP: (meet_center_nil (pgroup_nil pG) (char_normal charZ)). + rewrite -cardG_gt1 oZ prime_gt1 //=; apply: contraR => not_sZ_ZG. + by rewrite prime_TIg ?oZ. + have: e ^+ p \in 'Z(G). + rewrite (subsetP sZ_ZG) // -defZE -defPhiE (Phi_joing pE) mem_gen //. + by rewrite inE orbC (Mho_p_elt 1) ?(mem_p_elt pE). + by case/setIP=> _ /centP cGep; apply/commgP; red; rewrite cGep. +have sEG: E \subset G := subset_trans sEK (char_sub charK). +set R := 'C_G(E). +have{sEG_E'} defG: E \* R = G by exact: (critical_extraspecial pG). +have [_ defER cRE] := cprodP defG. +have defH: E \* 'C_H(E) = H by rewrite -(setIidPr sHG) setIAC (cprod_modl defG). +have{defH} [_ defH cRH_E] := cprodP defH. +have cRH_RH: abelian 'C_H(E). + have sZ_ZRH: Z \subset 'Z('C_H(E)). + rewrite subsetI -{1}defZE setSI //= (subset_trans sZU) // centsC. + by rewrite subIset // centsC cHU. + rewrite (cyclic_factor_abelian sZ_ZRH) //= -/Z. + have defHs: Es \x ('C_H(E) / Z) = H / Z. + rewrite defEs dprodE ?quotient_cents // -?quotientMl ?defH -?quotientGI //=. + by rewrite setIA (setIidPl sEH) ['C_E(E)]defZE trivg_quotient. + have:= Ohm_dprod 1 defHs; rewrite /= defKs (Ohm1_id (abelemS sEsKs abelKs)). + rewrite dprodC; case/dprodP=> _ defEsRHs1 cRHs1Es tiRHs1Es. + have sRHsHs: 'C_H(E) / Z \subset H / Z by rewrite quotientS ?subsetIl. + have cRHsRHs: abelian ('C_H(E) / Z) by exact: abelianS cHsHs. + have pHs: p.-group (H / Z) by rewrite quotient_pgroup. + rewrite abelian_rank1_cyclic // (rank_pgroup (pgroupS sRHsHs pHs)). + rewrite p_rank_abelian // -(leq_add2r (logn p #|Es|)) -lognM ?cardG_gt0 //. + rewrite -TI_cardMg // defEsRHs1 /= -defEsZs TI_cardMg ?lognM ?cardG_gt0 //. + by rewrite leq_add2r -abelem_cyclic ?(abelemS sZsKs) // quotient_cyclic. +have{cRH_RH} defRH: 'C_H(E) = U. + apply/eqP; rewrite eqEsubset andbC setIS ?centS // subsetI subsetIl /=. + by rewrite -{2}defH centM subsetI subsetIr. +have scUR: 'C_R(U) = U by rewrite -setIA -{1}defRH -centM defH. +have sUR: U \subset R by rewrite -defRH setSI. +have tiER: E :&: R = 'Z(E) by rewrite setIA (setIidPl (subset_trans sEH sHG)). +have [cRR | not_cRR] := boolP (abelian R). + exists E; [by right | exists [group of R]; split=> //; left]. + by rewrite /= -(setIidPl (sub_abelian_cent cRR sUR)) scUR. +have{scUR} scUR: [group of U] \in 'SCN(R). + by apply/SCN_P; rewrite (normalS sUR (subsetIl _ _)) // char_normal. +have pR: p.-group R := pgroupS (subsetIl _ _) pG. +have [R_le_3 | R_gt_3] := leqP (logn p #|R|) 3. + have esR: extraspecial R := p3group_extraspecial pR not_cRR R_le_3. + have esG: extraspecial G := cprod_extraspecial pG defG tiER esE esR. + exists G; [by right | exists ('Z(G))%G; rewrite cprod_center_id setIA setIid]. + by split=> //; left; rewrite prime_cyclic; case: esG. +have [[p2 _ ext2R] | [M []]] := cyclic_SCN pR scUR not_cRR cycU. + exists E; [by right | exists [group of R]; split=> //; right]. + by rewrite dvdn_leq ?(@pfactor_dvdn 2 4) ?cardG_gt0 // -{2}p2. +rewrite /= -/R => defM iUM modM _ _; pose N := 'C_G('Mho^1(U)). +have charZN2: 'Z('Ohm_2(N)) \char G. + rewrite (char_trans (center_char _)) // (char_trans (Ohm_char _ _)) //. + by rewrite subcent_char ?char_refl // (char_trans (Mho_char _ _)). +have:= sympG _ charZN2 (center_abelian _). +rewrite abelian_rank1_cyclic ?center_abelian // leqNgt; case/negP. +have defN: E \* M = N. + rewrite defM (cprod_modl defG) // centsC (subset_trans (Mho_sub 1 _)) //. + by rewrite /= -/U -defRH subsetIr. +case/modular_group_classP: modM => q q_pr [n n_gt23 isoM]. +have{n_gt23} n_gt2 := leq_trans (leq_addl _ _) n_gt23. +have n_gt1 := ltnW n_gt2; have n_gt0 := ltnW n_gt1. +have [[x y] genM modM] := generators_modular_group q_pr n_gt2 isoM. +have{q_pr} defq: q = p; last rewrite {q}defq in genM modM isoM. + have: p %| #|M| by rewrite -iUM dvdn_indexg. + by have [-> _ _ _] := genM; rewrite Euclid_dvdX // dvdn_prime2 //; case: eqP. +have [oM Mx ox X'y] := genM; have [My _] := setDP X'y; have [oy _] := modM. +have [sUM sMR]: U \subset M /\ M \subset R. + by rewrite defM subsetI sUR subsetIl centsC (subset_trans (Mho_sub _ _)). +have oU1: #|'Mho^1(U)| = (p ^ n.-2)%N. + have oU: #|U| = (p ^ n.-1)%N. + by rewrite -(divg_indexS sUM) iUM oM -subn1 expnB. + case/cyclicP: cycU pU oU => u -> p_u ou. + by rewrite (Mho_p_cycle 1 p_u) -orderE (orderXexp 1 ou) subn1. +have sZU1: Z \subset 'Mho^1(U). + rewrite -(cardSg_cyclic cycU) ?Ohm_sub ?Mho_sub // oZ oU1. + by rewrite -(subnKC n_gt2) expnS dvdn_mulr. +case/modular_group_structure: genM => // _ [defZM _ oZM] _ _. +have:= n_gt2; rewrite leq_eqVlt eq_sym !xpair_eqE andbC. +case: eqP => [n3 _ _ | _ /= n_gt3 defOhmM]. + have eqZU1: Z = 'Mho^1(U) by apply/eqP; rewrite eqEcard sZU1 oZ oU1 n3 /=. + rewrite (setIidPl _) in defM; first by rewrite -defM oM n3 pfactorK in R_gt_3. + by rewrite -eqZU1 subIset ?centS ?orbT. +have{defOhmM} [|defM2 _] := defOhmM 2; first by rewrite -subn1 ltn_subRL. +do [set xpn3 := x ^+ _; set X2 := <[_]>] in defM2. +have oX2: #|X2| = (p ^ 2)%N. + by rewrite -orderE (orderXexp _ ox) -{1}(subnKC n_gt2) addSn addnK. +have sZX2: Z \subset X2. + have cycXp: cyclic <[x ^+ p]> := cycle_cyclic _. + rewrite -(cardSg_cyclic cycXp) /=; first by rewrite oZ oX2 dvdn_mull. + rewrite -defZM subsetI (subset_trans (Ohm_sub _ _)) //=. + by rewrite (subset_trans sZU1) // centsC defM subsetIr. + by rewrite /xpn3 -subnSK //expnS expgM cycleX. +have{defM2} [_ /= defM2 cYX2 tiX2Y] := dprodP defM2. +have{defN} [_ defN cME] := cprodP defN. +have cEM2: E \subset 'C('Ohm_2(M)). + by rewrite centsC (subset_trans _ cME) ?centS ?Ohm_sub. +have [cEX2 cYE]: X2 \subset 'C(E) /\ E \subset 'C(<[y]>). + by apply/andP; rewrite centsC -subsetI -centM defM2. +have pN: p.-group N := pgroupS (subsetIl _ _) pG. +have defN2: (E <*> X2) \x <[y]> = 'Ohm_2(N). + rewrite dprodE ?centY ?subsetI 1?centsC ?cYE //=; last first. + rewrite -cycle_subG in My; rewrite joingC cent_joinEl //= -/X2. + rewrite -(setIidPr My) setIA -group_modl ?cycle_subG ?groupX //. + by rewrite mulGSid // (subset_trans _ sZX2) // -defZE -tiER setIS. + apply/eqP; rewrite cent_joinEr // -mulgA defM2 eqEsubset mulG_subG. + rewrite OhmS ?andbT; last by rewrite -defN mulG_subr. + have expE: exponent E %| p ^ 2 by rewrite exponent_special ?(pgroupS sEG). + rewrite /= (OhmE 2 pN) sub_gen /=; last 1 first. + by rewrite subsetI -defN mulG_subl sub_LdivT expE. + rewrite -cent_joinEl // -genM_join genS // -defN. + apply/subsetP=> ez; case/setIP; case/imset2P=> e z Ee Mz ->{ez}. + rewrite inE expgMn; last by red; rewrite -(centsP cME). + rewrite (exponentP expE) // mul1g => zp2; rewrite mem_mulg //=. + by rewrite (OhmE 2 (pgroupS sMR pR)) mem_gen // !inE Mz. +have{defN2} defZN2: X2 \x <[y]> = 'Z('Ohm_2(N)). + rewrite -[X2](mulSGid sZX2) /= -/Z -defZE -(center_dprod defN2). + do 2!rewrite -{1}(center_idP (cycle_abelian _)) -/X2; congr (_ \x _). + by case/cprodP: (center_cprod (cprodEY cEX2)). +have{defZN2} strZN2: \big[dprod/1]_(z <- [:: xpn3; y]) <[z]> = 'Z('Ohm_2(N)). + by rewrite unlock /= dprodg1. +rewrite -size_abelian_type ?center_abelian //. +have pZN2: p.-group 'Z('Ohm_2(N)) by rewrite (pgroupS _ pN) // subIset ?Ohm_sub. +rewrite -(perm_eq_size (perm_eq_abelian_type pZN2 strZN2 _)) //= !inE. +rewrite !(eq_sym 1) -!order_eq1 oy orderE oX2. +by rewrite (eqn_exp2l 2 0) // (eqn_exp2l 1 0). +Qed. + +End ExtremalTheory. diff --git a/mathcomp/solvable/finmodule.v b/mathcomp/solvable/finmodule.v new file mode 100644 index 0000000..e2eae84 --- /dev/null +++ b/mathcomp/solvable/finmodule.v @@ -0,0 +1,596 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +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. diff --git a/mathcomp/solvable/frobenius.v b/mathcomp/solvable/frobenius.v new file mode 100644 index 0000000..492c802 --- /dev/null +++ b/mathcomp/solvable/frobenius.v @@ -0,0 +1,794 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat div fintype bigop prime. +Require Import finset fingroup morphism perm action quotient gproduct. +Require Import cyclic center pgroup nilpotent sylow hall abelian. + +(******************************************************************************) +(* Definition of Frobenius groups, some basic results, and the Frobenius *) +(* theorem on the number of solutions of x ^+ n = 1. *) +(* semiregular K H <-> *) +(* the internal action of H on K is semiregular, i.e., no nontrivial *) +(* elements of H and K commute; note that this is actually a symmetric *) +(* condition. *) +(* semiprime K H <-> *) +(* the internal action of H on K is "prime", i.e., an element of K that *) +(* centralises a nontrivial element of H must actually centralise all *) +(* of H. *) +(* normedTI A G L <=> *) +(* A is nonempty, strictly disjoint from its conjugates in G, and has *) +(* normaliser L in G. *) +(* [Frobenius G = K ><| H] <=> *) +(* G is (isomorphic to) a Frobenius group with kernel K and complement *) +(* H. This is an effective predicate (in bool), which tests the *) +(* equality with the semidirect product, and then the fact that H is a *) +(* proper self-normalizing TI-subgroup of G. *) +(* [Frobenius G with kernel H] <=> *) +(* G is (isomorphic to) a Frobenius group with kernel K; same as above, *) +(* but without the semi-direct product. *) +(* [Frobenius G with complement H] <=> *) +(* G is (isomorphic to) a Frobenius group with complement H; same as *) +(* above, but without the semi-direct product. The proof that this form *) +(* is equivalent to the above (i.e., the existence of Frobenius *) +(* kernels) requires chareacter theory and will only be proved in the *) +(* vcharacter module. *) +(* [Frobenius G] <=> G is a Frobenius group. *) +(* Frobenius_action G H S to <-> *) +(* The action to of G on S defines an isomorphism of G with a *) +(* (permutation) Frobenius group, i.e., to is faithful and transitive *) +(* on S, no nontrivial element of G fixes more than one point in S, and *) +(* H is the stabilizer of some element of S, and non-trivial. Thus, *) +(* Frobenius_action G H S 'P *) +(* asserts that G is a Frobenius group in the classic sense. *) +(* has_Frobenius_action G H <-> *) +(* Frobenius_action G H S to holds for some sT : finType, S : {set st} *) +(* and to : {action gT &-> sT}. This is a predicate in Prop, but is *) +(* exactly reflected by [Frobenius G with complement H] : bool. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section Definitions. + +Variable gT : finGroupType. +Implicit Types A G K H L : {set gT}. + +(* Corresponds to "H acts on K in a regular manner" in B & G. *) +Definition semiregular K H := {in H^#, forall x, 'C_K[x] = 1}. + +(* Corresponds to "H acts on K in a prime manner" in B & G. *) +Definition semiprime K H := {in H^#, forall x, 'C_K[x] = 'C_K(H)}. + +Definition normedTI A G L := [&& A != set0, trivIset (A :^: G) & 'N_G(A) == L]. + +Definition Frobenius_group_with_complement G H := (H != G) && normedTI H^# G H. + +Definition Frobenius_group G := + [exists H : {group gT}, Frobenius_group_with_complement G H]. + +Definition Frobenius_group_with_kernel_and_complement G K H := + (K ><| H == G) && Frobenius_group_with_complement G H. + +Definition Frobenius_group_with_kernel G K := + [exists H : {group gT}, Frobenius_group_with_kernel_and_complement G K H]. + +Section FrobeniusAction. + +Variables G H : {set gT}. +Variables (sT : finType) (S : {set sT}) (to : {action gT &-> sT}). + +Definition Frobenius_action := + [/\ [faithful G, on S | to], + [transitive G, on S | to], + {in G^#, forall x, #|'Fix_(S | to)[x]| <= 1}, + H != 1 + & exists2 u, u \in S & H = 'C_G[u | to]]. + +End FrobeniusAction. + +CoInductive has_Frobenius_action G H : Prop := + HasFrobeniusAction sT S to of @Frobenius_action G H sT S to. + +End Definitions. + +Arguments Scope semiregular [_ group_scope group_scope]. +Arguments Scope semiprime [_ group_scope group_scope]. +Arguments Scope normedTI [_ group_scope group_scope group_scope]. +Arguments Scope Frobenius_group_with_complement [_ group_scope group_scope]. +Arguments Scope Frobenius_group [_ group_scope]. +Arguments Scope Frobenius_group_with_kernel [_ group_scope group_scope]. +Arguments Scope Frobenius_group_with_kernel_and_complement + [_ group_scope group_scope group_scope]. +Arguments Scope Frobenius_action + [_ group_scope group_scope _ group_scope action_scope]. +Arguments Scope has_Frobenius_action [_ group_scope group_scope]. + +Notation "[ 'Frobenius' G 'with' 'complement' H ]" := + (Frobenius_group_with_complement G H) + (at level 0, G at level 50, H at level 35, + format "[ 'Frobenius' G 'with' 'complement' H ]") : group_scope. + +Notation "[ 'Frobenius' G 'with' 'kernel' K ]" := + (Frobenius_group_with_kernel G K) + (at level 0, G at level 50, K at level 35, + format "[ 'Frobenius' G 'with' 'kernel' K ]") : group_scope. + +Notation "[ 'Frobenius' G ]" := + (Frobenius_group G) + (at level 0, G at level 50, + format "[ 'Frobenius' G ]") : group_scope. + +Notation "[ 'Frobenius' G = K ><| H ]" := + (Frobenius_group_with_kernel_and_complement G K H) + (at level 0, G at level 50, K, H at level 35, + format "[ 'Frobenius' G = K ><| H ]") : group_scope. + +Section FrobeniusBasics. + +Variable gT : finGroupType. +Implicit Types (A B : {set gT}) (G H K L R X : {group gT}). + +Lemma semiregular1l H : semiregular 1 H. +Proof. by move=> x _ /=; rewrite setI1g. Qed. + +Lemma semiregular1r K : semiregular K 1. +Proof. by move=> x; rewrite setDv inE. Qed. + +Lemma semiregular_sym H K : semiregular K H -> semiregular H K. +Proof. +move=> regH x /setD1P[ntx Kx]; apply: contraNeq ntx. +rewrite -subG1 -setD_eq0 -setIDAC => /set0Pn[y /setIP[Hy cxy]]. +by rewrite (sameP eqP set1gP) -(regH y Hy) inE Kx cent1C. +Qed. + +Lemma semiregularS K1 K2 A1 A2 : + K1 \subset K2 -> A1 \subset A2 -> semiregular K2 A2 -> semiregular K1 A1. +Proof. +move=> sK12 sA12 regKA2 x /setD1P[ntx /(subsetP sA12)A2x]. +by apply/trivgP; rewrite -(regKA2 x) ?inE ?ntx ?setSI. +Qed. + +Lemma semiregular_prime H K : semiregular K H -> semiprime K H. +Proof. +move=> regH x Hx; apply/eqP; rewrite eqEsubset {1}regH // sub1G. +by rewrite -cent_set1 setIS ?centS // sub1set; case/setD1P: Hx. +Qed. + +Lemma semiprime_regular H K : semiprime K H -> 'C_K(H) = 1 -> semiregular K H. +Proof. by move=> prKH tiKcH x Hx; rewrite prKH. Qed. + +Lemma semiprimeS K1 K2 A1 A2 : + K1 \subset K2 -> A1 \subset A2 -> semiprime K2 A2 -> semiprime K1 A1. +Proof. +move=> sK12 sA12 prKA2 x /setD1P[ntx A1x]. +apply/eqP; rewrite eqEsubset andbC -{1}cent_set1 setIS ?centS ?sub1set //=. +rewrite -(setIidPl sK12) -!setIA prKA2 ?setIS ?centS //. +by rewrite !inE ntx (subsetP sA12). +Qed. + +Lemma cent_semiprime H K X : + semiprime K H -> X \subset H -> X :!=: 1 -> 'C_K(X) = 'C_K(H). +Proof. +move=> prKH sXH /trivgPn[x Xx ntx]; apply/eqP. +rewrite eqEsubset -{1}(prKH x) ?inE ?(subsetP sXH) ?ntx //=. +by rewrite -cent_cycle !setIS ?centS ?cycle_subG. +Qed. + +Lemma stab_semiprime H K X : + semiprime K H -> X \subset K -> 'C_H(X) != 1 -> 'C_H(X) = H. +Proof. +move=> prKH sXK ntCHX; apply/setIidPl; rewrite centsC -subsetIidl. +rewrite -{2}(setIidPl sXK) -setIA -(cent_semiprime prKH _ ntCHX) ?subsetIl //. +by rewrite !subsetI subxx sXK centsC subsetIr. +Qed. + +Lemma cent_semiregular H K X : + semiregular K H -> X \subset H -> X :!=: 1 -> 'C_K(X) = 1. +Proof. +move=> regKH sXH /trivgPn[x Xx ntx]; apply/trivgP. +rewrite -(regKH x) ?inE ?(subsetP sXH) ?ntx ?setIS //=. +by rewrite -cent_cycle centS ?cycle_subG. +Qed. + +Lemma regular_norm_dvd_pred K H : + H \subset 'N(K) -> semiregular K H -> #|H| %| #|K|.-1. +Proof. +move=> nKH regH; have actsH: [acts H, on K^# | 'J] by rewrite astabsJ normD1. +rewrite (cardsD1 1 K) group1 -(acts_sum_card_orbit actsH) /=. +rewrite (eq_bigr (fun _ => #|H|)) ?sum_nat_const ?dvdn_mull //. +move=> _ /imsetP[x /setIdP[ntx Kx] ->]; rewrite card_orbit astab1J. +rewrite ['C_H[x]](trivgP _) ?indexg1 //=. +apply/subsetP=> y /setIP[Hy cxy]; apply: contraR ntx => nty. +by rewrite -[[set 1]](regH y) inE ?nty // Kx cent1C. + +Qed. + +Lemma regular_norm_coprime K H : + H \subset 'N(K) -> semiregular K H -> coprime #|K| #|H|. +Proof. +move=> nKH regH. +by rewrite (coprime_dvdr (regular_norm_dvd_pred nKH regH)) ?coprimenP. +Qed. + +Lemma semiregularJ K H x : semiregular K H -> semiregular (K :^ x) (H :^ x). +Proof. +move=> regH yx; rewrite -conjD1g => /imsetP[y Hy ->]. +by rewrite cent1J -conjIg regH ?conjs1g. +Qed. + +Lemma semiprimeJ K H x : semiprime K H -> semiprime (K :^ x) (H :^ x). +Proof. +move=> prH yx; rewrite -conjD1g => /imsetP[y Hy ->]. +by rewrite cent1J centJ -!conjIg prH. +Qed. + +Lemma normedTI_P A G L : + reflect [/\ A != set0, L \subset 'N_G(A) + & {in G, forall g, ~~ [disjoint A & A :^ g] -> g \in L}] + (normedTI A G L). +Proof. +apply: (iffP and3P) => [[nzA /trivIsetP tiAG /eqP <-] | [nzA sLN tiAG]]. + split=> // g Gg; rewrite inE Gg (sameP normP eqP) /= eq_sym; apply: contraR. + by apply: tiAG; rewrite ?mem_orbit ?orbit_refl. +have [/set0Pn[a Aa] /subsetIP[_ nAL]] := (nzA, sLN); split=> //; last first. + rewrite eqEsubset sLN andbT; apply/subsetP=> x /setIP[Gx nAx]. + by apply/tiAG/pred0Pn=> //; exists a; rewrite /= (normP nAx) Aa. +apply/trivIsetP=> _ _ /imsetP[x Gx ->] /imsetP[y Gy ->]; apply: contraR. +rewrite -setI_eq0 -(mulgKV x y) conjsgM; set g := (y * x^-1)%g. +have Gg: g \in G by rewrite groupMl ?groupV. +rewrite -conjIg (inj_eq (act_inj 'Js x)) (eq_sym A) (sameP eqP normP). +by rewrite -cards_eq0 cardJg cards_eq0 setI_eq0 => /tiAG/(subsetP nAL)->. +Qed. +Implicit Arguments normedTI_P [A G L]. + +Lemma normedTI_memJ_P A G L : + reflect [/\ A != set0, L \subset G + & {in A & G, forall a g, (a ^ g \in A) = (g \in L)}] + (normedTI A G L). +Proof. +apply: (iffP normedTI_P) => [[-> /subsetIP[sLG nAL] tiAG] | [-> sLG tiAG]]. + split=> // a g Aa Gg; apply/idP/idP=> [Aag | Lg]; last first. + by rewrite memJ_norm ?(subsetP nAL). + by apply/tiAG/pred0Pn=> //; exists (a ^ g)%g; rewrite /= Aag memJ_conjg. +split=> // [ | g Gg /pred0Pn[ag /=]]; last first. + by rewrite andbC => /andP[/imsetP[a Aa ->]]; rewrite tiAG. +apply/subsetP=> g Lg; have Gg := subsetP sLG g Lg. +by rewrite !inE Gg; apply/subsetP=> _ /imsetP[a Aa ->]; rewrite tiAG. +Qed. + +Lemma partition_class_support A G : + A != set0 -> trivIset (A :^: G) -> partition (A :^: G) (class_support A G). +Proof. +rewrite /partition cover_imset -class_supportEr eqxx => nzA ->. +by apply: contra nzA => /imsetP[x _ /eqP]; rewrite eq_sym -!cards_eq0 cardJg. +Qed. + +Lemma partition_normedTI A G L : + normedTI A G L -> partition (A :^: G) (class_support A G). +Proof. by case/and3P=> ntA tiAG _; apply: partition_class_support. Qed. + +Lemma card_support_normedTI A G L : + normedTI A G L -> #|class_support A G| = (#|A| * #|G : L|)%N. +Proof. +case/and3P=> ntA tiAG /eqP <-; rewrite -card_conjugates mulnC. +apply: card_uniform_partition (partition_class_support ntA tiAG). +by move=> _ /imsetP[y _ ->]; rewrite cardJg. +Qed. + +Lemma normedTI_S A B G L : + A != set0 -> L \subset 'N(A) -> A \subset B -> normedTI B G L -> + normedTI A G L. +Proof. +move=> nzA /subsetP nAL /subsetP sAB /normedTI_memJ_P[nzB sLG tiB]. +apply/normedTI_memJ_P; split=> // a x Aa Gx. +by apply/idP/idP => [Aax | /nAL/memJ_norm-> //]; rewrite -(tiB a) ?sAB. +Qed. + +Lemma cent1_normedTI A G L : + normedTI A G L -> {in A, forall x, 'C_G[x] \subset L}. +Proof. +case/normedTI_memJ_P=> [_ _ tiAG] x Ax; apply/subsetP=> y /setIP[Gy cxy]. +by rewrite -(tiAG x) // /(x ^ y) -(cent1P cxy) mulKg. +Qed. + +Lemma Frobenius_actionP G H : + reflect (has_Frobenius_action G H) [Frobenius G with complement H]. +Proof. +apply: (iffP andP) => [[neqHG] | [sT S to [ffulG transG regG ntH [u Su defH]]]]. + case/normedTI_P=> nzH /subsetIP[sHG _] tiHG. + suffices: Frobenius_action G H (rcosets H G) 'Rs by exact: HasFrobeniusAction. + pose Hfix x := 'Fix_(rcosets H G | 'Rs)[x]. + have regG: {in G^#, forall x, #|Hfix x| <= 1}. + move=> x /setD1P[ntx Gx]. + apply: wlog_neg; rewrite -ltnNge => /ltnW/card_gt0P/=[Hy]. + rewrite -(cards1 Hy) => /setIP[/imsetP[y Gy ->{Hy}] cHyx]. + apply/subset_leq_card/subsetP=> _ /setIP[/imsetP[z Gz ->] cHzx]. + rewrite -!sub_astab1 !astab1_act !sub1set astab1Rs in cHyx cHzx *. + rewrite !rcosetE; apply/set1P/rcoset_transl; rewrite mem_rcoset. + apply: tiHG; [by rewrite !in_group | apply/pred0Pn; exists (x ^ y^-1)]. + by rewrite conjD1g !inE conjg_eq1 ntx -mem_conjg cHyx conjsgM memJ_conjg. + have ntH: H :!=: 1 by rewrite -subG1 -setD_eq0. + split=> //; first 1 last; first exact: transRs_rcosets. + by exists (H : {set gT}); rewrite ?orbit_refl // astab1Rs (setIidPr sHG). + apply/subsetP=> y /setIP[Gy cHy]; apply: contraR neqHG => nt_y. + rewrite (index1g sHG) //; apply/eqP; rewrite eqn_leq indexg_gt0 andbT. + apply: leq_trans (regG y _); last by rewrite setDE 2!inE Gy nt_y /=. + by rewrite /Hfix (setIidPl _) -1?astabC ?sub1set. +have sHG: H \subset G by rewrite defH subsetIl. +split. + apply: contraNneq ntH => /= defG. + suffices defS: S = [set u] by rewrite -(trivgP ffulG) /= defS defH. + apply/eqP; rewrite eq_sym eqEcard sub1set Su. + by rewrite -(atransP transG u Su) card_orbit -defH defG indexgg cards1. +apply/normedTI_P; rewrite setD_eq0 subG1 normD1 subsetI sHG normG. +split=> // x Gx; rewrite -setI_eq0 conjD1g defH inE Gx conjIg conjGid //. +rewrite -setDIl -setIIr -astab1_act setDIl => /set0Pn[y /setIP[Gy /setD1P[_]]]. +case/setIP; rewrite 2!(sameP astab1P afix1P) => cuy cuxy; apply/astab1P. +apply: contraTeq (regG y Gy) => cu'x. +rewrite (cardD1 u) (cardD1 (to u x)) inE Su cuy inE /= inE cu'x cuxy. +by rewrite (actsP (atrans_acts transG)) ?Su. +Qed. + +Section FrobeniusProperties. + +Variables G H K : {group gT}. +Hypothesis frobG : [Frobenius G = K ><| H]. + +Lemma FrobeniusWker : [Frobenius G with kernel K]. +Proof. by apply/existsP; exists H. Qed. + +Lemma FrobeniusWcompl : [Frobenius G with complement H]. +Proof. by case/andP: frobG. Qed. + +Lemma FrobeniusW : [Frobenius G]. +Proof. by apply/existsP; exists H; exact: FrobeniusWcompl. Qed. + +Lemma Frobenius_context : + [/\ K ><| H = G, K :!=: 1, H :!=: 1, K \proper G & H \proper G]. +Proof. +have [/eqP defG neqHG ntH _] := and4P frobG; rewrite setD_eq0 subG1 in ntH. +have ntK: K :!=: 1 by apply: contraNneq neqHG => K1; rewrite -defG K1 sdprod1g. +rewrite properEcard properEneq neqHG; have /mulG_sub[-> ->] := sdprodW defG. +by rewrite -(sdprod_card defG) ltn_Pmulr ?cardG_gt1. +Qed. + +Lemma Frobenius_partition : partition (gval K |: (H^# :^: K)) G. +Proof. +have [/eqP defG _ tiHG] := and3P frobG; have [_ tiH1G /eqP defN] := and3P tiHG. +have [[_ /mulG_sub[sKG sHG] nKH tiKH] mulHK] := (sdprodP defG, sdprodWC defG). +set HG := H^# :^: K; set KHG := _ |: _. +have defHG: HG = H^# :^: G. + have: 'C_G[H^# | 'Js] * K = G by rewrite astab1Js defN mulHK. + move/subgroup_transitiveP/atransP. + by apply; rewrite ?atrans_orbit ?orbit_refl. +have /and3P[defHK _ nzHG] := partition_normedTI tiHG. +rewrite -defHG in defHK nzHG tiH1G. +have [tiKHG HG'K]: trivIset KHG /\ gval K \notin HG. + apply: trivIsetU1 => // _ /imsetP[x Kx ->]; rewrite -setI_eq0. + by rewrite -(conjGid Kx) -conjIg setIDA tiKH setDv conj0g. +rewrite /partition andbC tiKHG !inE negb_or nzHG eq_sym -card_gt0 cardG_gt0 /=. +rewrite eqEcard; apply/andP; split. + rewrite /cover big_setU1 //= subUset sKG -/(cover HG) (eqP defHK). + by rewrite class_support_subG // (subset_trans _ sHG) ?subD1set. +rewrite -(eqnP tiKHG) big_setU1 //= (eqnP tiH1G) (eqP defHK). +rewrite (card_support_normedTI tiHG) -(Lagrange sHG) (cardsD1 1) group1 mulSn. +by rewrite leq_add2r -mulHK indexMg -indexgI tiKH indexg1. +Qed. + +Lemma Frobenius_cent1_ker : {in K^#, forall x, 'C_G[x] \subset K}. +Proof. +have [/eqP defG _ /normedTI_memJ_P[_ _ tiHG]] := and3P frobG. +move=> x /setD1P[ntx Kx]; have [_ /mulG_sub[sKG _] _ tiKH] := sdprodP defG. +have [/eqP <- _ _] := and3P Frobenius_partition; rewrite big_distrl /=. +apply/bigcupsP=> _ /setU1P[|/imsetP[y Ky]] ->; first exact: subsetIl. +apply: contraR ntx => /subsetPn[z]; rewrite inE mem_conjg => /andP[Hzy cxz] _. +rewrite -(conjg_eq1 x y^-1) -in_set1 -set1gE -tiKH inE andbC. +rewrite -(tiHG _ _ Hzy) ?(subsetP sKG) ?in_group // Ky andbT -conjJg. +by rewrite /(z ^ x) (cent1P cxz) mulKg. +Qed. + +Lemma Frobenius_reg_ker : semiregular K H. +Proof. +move=> x /setD1P[ntx Hx]. +apply/trivgP/subsetP=> y /setIP[Ky cxy]; apply: contraR ntx => nty. +have K1y: y \in K^# by rewrite inE nty. +have [/eqP/sdprod_context[_ sHG _ _ tiKH] _] := andP frobG. +suffices: x \in K :&: H by rewrite tiKH inE. +by rewrite inE (subsetP (Frobenius_cent1_ker K1y)) // inE cent1C (subsetP sHG). +Qed. + +Lemma Frobenius_reg_compl : semiregular H K. +Proof. by apply: semiregular_sym; exact: Frobenius_reg_ker. Qed. + +Lemma Frobenius_dvd_ker1 : #|H| %| #|K|.-1. +Proof. +apply: regular_norm_dvd_pred Frobenius_reg_ker. +by have[/sdprodP[]] := Frobenius_context. +Qed. + +Lemma ltn_odd_Frobenius_ker : odd #|G| -> #|H|.*2 < #|K|. +Proof. +move/oddSg=> oddG. +have [/sdprodW/mulG_sub[sKG sHG] ntK _ _ _] := Frobenius_context. +by rewrite dvdn_double_ltn ?oddG ?cardG_gt1 ?Frobenius_dvd_ker1. +Qed. + +Lemma Frobenius_index_dvd_ker1 : #|G : K| %| #|K|.-1. +Proof. +have[defG _ _ /andP[sKG _] _] := Frobenius_context. +by rewrite -divgS // -(sdprod_card defG) mulKn ?Frobenius_dvd_ker1. +Qed. + +Lemma Frobenius_coprime : coprime #|K| #|H|. +Proof. by rewrite (coprime_dvdr Frobenius_dvd_ker1) ?coprimenP. Qed. + +Lemma Frobenius_trivg_cent : 'C_K(H) = 1. +Proof. +by apply: (cent_semiregular Frobenius_reg_ker); case: Frobenius_context. +Qed. + +Lemma Frobenius_index_coprime : coprime #|K| #|G : K|. +Proof. by rewrite (coprime_dvdr Frobenius_index_dvd_ker1) ?coprimenP. Qed. + +Lemma Frobenius_ker_Hall : Hall G K. +Proof. +have [_ _ _ /andP[sKG _] _] := Frobenius_context. +by rewrite /Hall sKG Frobenius_index_coprime. +Qed. + +Lemma Frobenius_compl_Hall : Hall G H. +Proof. +have [defG _ _ _ _] := Frobenius_context. +by rewrite -(sdprod_Hall defG) Frobenius_ker_Hall. +Qed. + +End FrobeniusProperties. + +Lemma normedTI_J x A G L : normedTI (A :^ x) (G :^ x) (L :^ x) = normedTI A G L. +Proof. +rewrite {1}/normedTI normJ -conjIg -(conj0g x) !(can_eq (conjsgK x)). +congr [&& _, _ == _ & _]; rewrite /cover (reindex_inj (@conjsg_inj _ x)). + by apply: eq_big => Hy; rewrite ?orbit_conjsg ?cardJg. +by rewrite bigcupJ cardJg (eq_bigl _ _ (orbit_conjsg _ _ _ _)). +Qed. + +Lemma FrobeniusJcompl x G H : + [Frobenius G :^ x with complement H :^ x] = [Frobenius G with complement H]. +Proof. +by congr (_ && _); rewrite ?(can_eq (conjsgK x)) // -conjD1g normedTI_J. +Qed. + +Lemma FrobeniusJ x G K H : + [Frobenius G :^ x = K :^ x ><| H :^ x] = [Frobenius G = K ><| H]. +Proof. +by congr (_ && _); rewrite ?FrobeniusJcompl // -sdprodJ (can_eq (conjsgK x)). +Qed. + +Lemma FrobeniusJker x G K : + [Frobenius G :^ x with kernel K :^ x] = [Frobenius G with kernel K]. +Proof. +apply/existsP/existsP=> [] [H]; last by exists (H :^ x)%G; rewrite FrobeniusJ. +by rewrite -(conjsgKV x H) FrobeniusJ; exists (H :^ x^-1)%G. +Qed. + +Lemma FrobeniusJgroup x G : [Frobenius G :^ x] = [Frobenius G]. +Proof. +apply/existsP/existsP=> [] [H]. + by rewrite -(conjsgKV x H) FrobeniusJcompl; exists (H :^ x^-1)%G. +by exists (H :^ x)%G; rewrite FrobeniusJcompl. +Qed. + +Lemma Frobenius_ker_dvd_ker1 G K : + [Frobenius G with kernel K] -> #|G : K| %| #|K|.-1. +Proof. case/existsP=> H; exact: Frobenius_index_dvd_ker1. Qed. + +Lemma Frobenius_ker_coprime G K : + [Frobenius G with kernel K] -> coprime #|K| #|G : K|. +Proof. case/existsP=> H; exact: Frobenius_index_coprime. Qed. + +Lemma Frobenius_semiregularP G K H : + K ><| H = G -> K :!=: 1 -> H :!=: 1 -> + reflect (semiregular K H) [Frobenius G = K ><| H]. +Proof. +move=> defG ntK ntH. +apply: (iffP idP) => [|regG]; first exact: Frobenius_reg_ker. +have [nsKG sHG defKH nKH tiKH]:= sdprod_context defG; have [sKG _]:= andP nsKG. +apply/and3P; split; first by rewrite defG. + by rewrite eqEcard sHG -(sdprod_card defG) -ltnNge ltn_Pmull ?cardG_gt1. +apply/normedTI_memJ_P; rewrite setD_eq0 subG1 sHG -defKH -(normC nKH). +split=> // z _ /setD1P[ntz Hz] /mulsgP[y x Hy Kx ->]; rewrite groupMl // !inE. +rewrite conjg_eq1 ntz; apply/idP/idP=> [Hzxy | Hx]; last by rewrite !in_group. +apply: (subsetP (sub1G H)); have Hzy: z ^ y \in H by apply: groupJ. +rewrite -(regG (z ^ y)); last by apply/setD1P; rewrite conjg_eq1. +rewrite inE Kx cent1C (sameP cent1P commgP) -in_set1 -[[set 1]]tiKH inE /=. +rewrite andbC groupM ?groupV -?conjgM //= commgEr groupMr //. +by rewrite memJ_norm ?(subsetP nKH) ?groupV. +Qed. + +Lemma prime_FrobeniusP G K H : + K :!=: 1 -> prime #|H| -> + reflect (K ><| H = G /\ 'C_K(H) = 1) [Frobenius G = K ><| H]. +Proof. +move=> ntK H_pr; have ntH: H :!=: 1 by rewrite -cardG_gt1 prime_gt1. +have [defG | not_sdG] := eqVneq (K ><| H) G; last first. + by apply: (iffP andP) => [] [defG]; rewrite defG ?eqxx in not_sdG. +apply: (iffP (Frobenius_semiregularP defG ntK ntH)) => [regH | [_ regH x]]. + split=> //; have [x defH] := cyclicP (prime_cyclic H_pr). + by rewrite defH cent_cycle regH // !inE defH cycle_id andbT -cycle_eq1 -defH. +case/setD1P=> nt_x Hx; apply/trivgP; rewrite -regH setIS //= -cent_cycle. +by rewrite centS // prime_meetG // (setIidPr _) ?cycle_eq1 ?cycle_subG. +Qed. + +Lemma Frobenius_subl G K K1 H : + K1 :!=: 1 -> K1 \subset K -> H \subset 'N(K1) -> [Frobenius G = K ><| H] -> + [Frobenius K1 <*> H = K1 ><| H]. +Proof. +move=> ntK1 sK1K nK1H frobG; have [_ _ ntH _ _] := Frobenius_context frobG. +apply/Frobenius_semiregularP=> //. + by rewrite sdprodEY ?coprime_TIg ?(coprimeSg sK1K) ?(Frobenius_coprime frobG). +by move=> x /(Frobenius_reg_ker frobG) cKx1; apply/trivgP; rewrite -cKx1 setSI. +Qed. + +Lemma Frobenius_subr G K H H1 : + H1 :!=: 1 -> H1 \subset H -> [Frobenius G = K ><| H] -> + [Frobenius K <*> H1 = K ><| H1]. +Proof. +move=> ntH1 sH1H frobG; have [defG ntK _ _ _] := Frobenius_context frobG. +apply/Frobenius_semiregularP=> //. + have [_ _ /(subset_trans sH1H) nH1K tiHK] := sdprodP defG. + by rewrite sdprodEY //; apply/trivgP; rewrite -tiHK setIS. +by apply: sub_in1 (Frobenius_reg_ker frobG); exact/subsetP/setSD. +Qed. + +Lemma Frobenius_kerP G K : + reflect [/\ K :!=: 1, K \proper G, K <| G + & {in K^#, forall x, 'C_G[x] \subset K}] + [Frobenius G with kernel K]. +Proof. +apply: (iffP existsP) => [[H frobG] | [ntK ltKG nsKG regK]]. + have [/sdprod_context[nsKG _ _ _ _] ntK _ ltKG _] := Frobenius_context frobG. + by split=> //; exact: Frobenius_cent1_ker frobG. +have /andP[sKG nKG] := nsKG. +have hallK: Hall G K. + rewrite /Hall sKG //= coprime_sym coprime_pi' //. + apply: sub_pgroup (pgroup_pi K) => p; have [P sylP] := Sylow_exists p G. + have [[sPG pP p'GiP] sylPK] := (and3P sylP, Hall_setI_normal nsKG sylP). + rewrite -p_rank_gt0 -(rank_Sylow sylPK) rank_gt0 => ntPK. + rewrite inE /= -p'natEpi // (pnat_dvd _ p'GiP) ?indexgS //. + have /trivgPn[z]: P :&: K :&: 'Z(P) != 1. + by rewrite meet_center_nil ?(pgroup_nil pP) ?(normalGI sPG nsKG). + rewrite !inE -andbA -sub_cent1=> /and4P[_ Kz _ cPz] ntz. + by apply: subset_trans (regK z _); [exact/subsetIP | exact/setD1P]. +have /splitsP[H /complP[tiKH defG]] := SchurZassenhaus_split hallK nsKG. +have [_ sHG] := mulG_sub defG; have nKH := subset_trans sHG nKG. +exists H; apply/Frobenius_semiregularP; rewrite ?sdprodE //. + by apply: contraNneq (proper_subn ltKG) => H1; rewrite -defG H1 mulg1. +apply: semiregular_sym => x Kx; apply/trivgP; rewrite -tiKH. +by rewrite subsetI subsetIl (subset_trans _ (regK x _)) ?setSI. +Qed. + +Lemma set_Frobenius_compl G K H : + K ><| H = G -> [Frobenius G with kernel K] -> [Frobenius G = K ><| H]. +Proof. +move=> defG /Frobenius_kerP[ntK ltKG _ regKG]. +apply/Frobenius_semiregularP=> //. + by apply: contraTneq ltKG => H_1; rewrite -defG H_1 sdprodg1 properxx. +apply: semiregular_sym => y /regKG sCyK. +have [_ sHG _ _ tiKH] := sdprod_context defG. +by apply/trivgP; rewrite /= -(setIidPr sHG) setIAC -tiKH setSI. +Qed. + +Lemma Frobenius_kerS G K G1 : + G1 \subset G -> K \proper G1 -> + [Frobenius G with kernel K] -> [Frobenius G1 with kernel K]. +Proof. +move=> sG1G ltKG1 /Frobenius_kerP[ntK _ /andP[_ nKG] regKG]. +apply/Frobenius_kerP; rewrite /normal proper_sub // (subset_trans sG1G) //. +by split=> // x /regKG; apply: subset_trans; rewrite setSI. +Qed. + +Lemma Frobenius_action_kernel_def G H K sT S to : + K ><| H = G -> @Frobenius_action _ G H sT S to -> + K :=: 1 :|: [set x in G | 'Fix_(S | to)[x] == set0]. +Proof. +move=> defG FrobG. +have partG: partition (gval K |: (H^# :^: K)) G. + apply: Frobenius_partition; apply/andP; rewrite defG; split=> //. + by apply/Frobenius_actionP; exact: HasFrobeniusAction FrobG. +have{FrobG} [ffulG transG regG ntH [u Su defH]]:= FrobG. +apply/setP=> x; rewrite !inE; have [-> | ntx] := altP eqP; first exact: group1. +rewrite /= -(cover_partition partG) /cover. +have neKHy y: gval K <> H^# :^ y. + by move/setP/(_ 1); rewrite group1 conjD1g setD11. +rewrite big_setU1 /= ?inE; last by apply/imsetP=> [[y _ /neKHy]]. +have [nsKG sHG _ _ tiKH] := sdprod_context defG; have [sKG nKG]:= andP nsKG. +symmetry; case Kx: (x \in K) => /=. + apply/set0Pn=> [[v /setIP[Sv]]]; have [y Gy ->] := atransP2 transG Su Sv. + rewrite -sub1set -astabC sub1set astab1_act mem_conjg => Hxy. + case/negP: ntx; rewrite -in_set1 -(conjgKV y x) -mem_conjgV conjs1g -tiKH. + by rewrite defH setIA inE -mem_conjg (setIidPl sKG) (normsP nKG) ?Kx. +apply/andP=> [[/bigcupP[_ /imsetP[y Ky ->] Hyx] /set0Pn[]]]; exists (to u y). +rewrite inE (actsP (atrans_acts transG)) ?(subsetP sKG) // Su. +rewrite -sub1set -astabC sub1set astab1_act. +by rewrite conjD1g defH conjIg !inE in Hyx; case/and3P: Hyx. +Qed. + +End FrobeniusBasics. + +Implicit Arguments normedTI_P [gT A G L]. +Implicit Arguments normedTI_memJ_P [gT A G L]. +Implicit Arguments Frobenius_kerP [gT G K]. + +Lemma Frobenius_coprime_quotient (gT : finGroupType) (G K H N : {group gT}) : + K ><| H = G -> N <| G -> coprime #|K| #|H| /\ H :!=: 1%g -> + N \proper K /\ {in H^#, forall x, 'C_K[x] \subset N} -> + [Frobenius G / N = (K / N) ><| (H / N)]%g. +Proof. +move=> defG nsNG [coKH ntH] [ltNK regH]. +have [[sNK _] [_ /mulG_sub[sKG sHG] _ _]] := (andP ltNK, sdprodP defG). +have [_ nNG] := andP nsNG; have nNH := subset_trans sHG nNG. +apply/Frobenius_semiregularP; first exact: quotient_coprime_sdprod. +- by rewrite quotient_neq1 ?(normalS _ sKG). +- by rewrite -(isog_eq1 (quotient_isog _ _)) ?coprime_TIg ?(coprimeSg sNK). +move=> _ /(subsetP (quotientD1 _ _))/morphimP[x nNx H1x ->]. +rewrite -cent_cycle -quotient_cycle //=. +rewrite -strongest_coprime_quotient_cent ?cycle_subG //. +- by rewrite cent_cycle quotientS1 ?regH. +- by rewrite subIset ?sNK. +- rewrite (coprimeSg (subsetIl N _)) ?(coprimeSg sNK) ?(coprimegS _ coKH) //. + by rewrite cycle_subG; case/setD1P: H1x. +by rewrite orbC abelian_sol ?cycle_abelian. +Qed. + +Section InjmFrobenius. + +Variables (gT rT : finGroupType) (D G : {group gT}) (f : {morphism D >-> rT}). +Implicit Types (H K : {group gT}) (sGD : G \subset D) (injf : 'injm f). + +Lemma injm_Frobenius_compl H sGD injf : + [Frobenius G with complement H] -> [Frobenius f @* G with complement f @* H]. +Proof. +case/andP=> neqGH /normedTI_P[nzH /subsetIP[sHG _] tiHG]. +have sHD := subset_trans sHG sGD; have sH1D := subset_trans (subD1set H 1) sHD. +apply/andP; rewrite (can_in_eq (injmK injf)) //; split=> //. +apply/normedTI_P; rewrite normD1 -injmD1 // -!cards_eq0 card_injm // in nzH *. +rewrite subsetI normG morphimS //; split=> // _ /morphimP[x Dx Gx ->] ti'fHx. +rewrite mem_morphim ?tiHG //; apply: contra ti'fHx; rewrite -!setI_eq0 => tiHx. +by rewrite -morphimJ // -injmI ?conj_subG // (eqP tiHx) morphim0. +Qed. + +Lemma injm_Frobenius H K sGD injf : + [Frobenius G = K ><| H] -> [Frobenius f @* G = f @* K ><| f @* H]. +Proof. +case/andP=> /eqP defG frobG. +by apply/andP; rewrite (injm_sdprod _ injf defG) // eqxx injm_Frobenius_compl. +Qed. + +Lemma injm_Frobenius_ker K sGD injf : + [Frobenius G with kernel K] -> [Frobenius f @* G with kernel f @* K]. +Proof. +case/existsP=> H frobG; apply/existsP; exists (f @* H)%G; exact: injm_Frobenius. +Qed. + +Lemma injm_Frobenius_group sGD injf : [Frobenius G] -> [Frobenius f @* G]. +Proof. +case/existsP=> H frobG; apply/existsP; exists (f @* H)%G. +exact: injm_Frobenius_compl. +Qed. + +End InjmFrobenius. + +Theorem Frobenius_Ldiv (gT : finGroupType) (G : {group gT}) n : + n %| #|G| -> n %| #|'Ldiv_n(G)|. +Proof. +move=> nG; move: {2}_.+1 (ltnSn (#|G| %/ n)) => mq. +elim: mq => // mq IHm in gT G n nG *; case/dvdnP: nG => q oG. +have [q_gt0 n_gt0] : 0 < q /\ 0 < n by apply/andP; rewrite -muln_gt0 -oG. +rewrite ltnS oG mulnK // => leqm. +have:= q_gt0; rewrite leq_eqVlt => /predU1P[q1 | lt1q]. + rewrite -(mul1n n) q1 -oG (setIidPl _) //. + by apply/subsetP=> x Gx; rewrite inE -order_dvdn order_dvdG. +pose p := pdiv q; have pr_p: prime p by exact: pdiv_prime. +have lt1p: 1 < p := prime_gt1 pr_p; have p_gt0 := ltnW lt1p. +have{leqm} lt_qp_mq: q %/ p < mq by apply: leq_trans leqm; rewrite ltn_Pdiv. +have: n %| #|'Ldiv_(p * n)(G)|. + have: p * n %| #|G| by rewrite oG dvdn_pmul2r ?pdiv_dvd. + move/IHm=> IH; apply: dvdn_trans (IH _); first exact: dvdn_mull. + by rewrite oG divnMr. +rewrite -(cardsID 'Ldiv_n()) dvdn_addl. + rewrite -setIA ['Ldiv_n(_)](setIidPr _) //. + by apply/subsetP=> x; rewrite !inE -!order_dvdn; apply: dvdn_mull. +rewrite -setIDA; set A := _ :\: _. +have pA x: x \in A -> #[x]`_p = (n`_p * p)%N. + rewrite !inE -!order_dvdn => /andP[xn xnp]. + rewrite !p_part // -expnSr; congr (p ^ _)%N; apply/eqP. + rewrite eqn_leq -{1}addn1 -(pfactorK 1 pr_p) -lognM ?expn1 // mulnC. + rewrite dvdn_leq_log ?muln_gt0 ?p_gt0 //= ltnNge; apply: contra xn => xn. + move: xnp; rewrite -[#[x]](partnC p) //. + rewrite !Gauss_dvd ?coprime_partC //; case/andP=> _. + rewrite p_part ?pfactor_dvdn // xn Gauss_dvdr // coprime_sym. + exact: pnat_coprime (pnat_id _) (part_pnat _ _). +rewrite -(partnC p n_gt0) Gauss_dvd ?coprime_partC //; apply/andP; split. + rewrite -sum1_card (partition_big_imset (@cycle _)) /=. + apply: dvdn_sum => _ /imsetP[x /setIP[Gx Ax] ->]. + rewrite (eq_bigl (generator <[x]>)) => [|y]. + rewrite sum1dep_card -totient_gen -[#[x]](partnC p) //. + rewrite totient_coprime ?coprime_partC // dvdn_mulr // . + by rewrite (pA x Ax) p_part // -expnSr totient_pfactor // dvdn_mull. + rewrite /generator eq_sym andbC; case xy: {+}(_ == _) => //. + rewrite !inE -!order_dvdn in Ax *. + by rewrite -cycle_subG /order -(eqP xy) cycle_subG Gx. +rewrite -sum1_card (partition_big_imset (fun x => x.`_p ^: G)) /=. +apply: dvdn_sum => _ /imsetP[x /setIP[Gx Ax] ->]. +set y := x.`_p; have oy: #[y] = (n`_p * p)%N by rewrite order_constt pA. +rewrite (partition_big (fun x => x.`_p) (mem (y ^: G))) /= => [|z]; last first. + by case/andP=> _ /eqP <-; rewrite /= class_refl. +pose G' := ('C_G[y] / <[y]>)%G; pose n' := gcdn #|G'| n`_p^'. +have n'_gt0: 0 < n' by rewrite gcdn_gt0 cardG_gt0. +rewrite (eq_bigr (fun _ => #|'Ldiv_n'(G')|)) => [|_ /imsetP[a Ga ->]]. + rewrite sum_nat_const -index_cent1 indexgI. + rewrite -(dvdn_pmul2l (cardG_gt0 'C_G[y])) mulnA LagrangeI. + have oCy: #|'C_G[y]| = (#[y] * #|G'|)%N. + rewrite card_quotient ?subcent1_cycle_norm // Lagrange //. + by rewrite subcent1_cycle_sub ?groupX. + rewrite oCy -mulnA -(muln_lcm_gcd #|G'|) -/n' mulnA dvdn_mul //. + rewrite muln_lcmr -oCy order_constt pA // mulnAC partnC // dvdn_lcm. + by rewrite cardSg ?subsetIl // mulnC oG dvdn_pmul2r ?pdiv_dvd. + apply: IHm; [exact: dvdn_gcdl | apply: leq_ltn_trans lt_qp_mq]. + rewrite -(@divnMr n`_p^') // -muln_lcm_gcd mulnC divnMl //. + rewrite leq_divRL // divn_mulAC ?leq_divLR ?dvdn_mulr ?dvdn_lcmr //. + rewrite dvdn_leq ?muln_gt0 ?q_gt0 //= mulnC muln_lcmr dvdn_lcm. + rewrite -(@dvdn_pmul2l n`_p) // mulnA -oy -oCy mulnCA partnC // -oG. + by rewrite cardSg ?subsetIl // dvdn_mul ?pdiv_dvd. +pose h := [fun z => coset <[y]> (z ^ a^-1)]. +pose h' := [fun Z : coset_of <[y]> => (y * (repr Z).`_p^') ^ a]. +rewrite -sum1_card (reindex_onto h h') /= => [|Z]; last first. + rewrite conjgK coset_kerl ?cycle_id ?morph_constt ?repr_coset_norm //. + rewrite /= coset_reprK 2!inE -order_dvdn dvdn_gcd => /and3P[_ _ p'Z]. + by apply: constt_p_elt (pnat_dvd p'Z _); apply: part_pnat. +apply: eq_bigl => z; apply/andP/andP=> [[]|[]]. + rewrite inE -andbA => /and3P[Gz Az _] /eqP zp_ya. + have czy: z ^ a^-1 \in 'C[y]. + rewrite -mem_conjg -normJ conjg_set1 -zp_ya. + by apply/cent1P; apply: commuteX. + have Nz: z ^ a^-1 \in 'N(<[y]>) by apply: subsetP czy; apply: norm_gen. + have G'z: h z \in G' by rewrite mem_morphim //= inE groupJ // groupV. + rewrite inE G'z inE -order_dvdn dvdn_gcd order_dvdG //=. + rewrite /order -morphim_cycle // -quotientE card_quotient ?cycle_subG //. + rewrite -(@dvdn_pmul2l #[y]) // Lagrange; last first. + by rewrite /= cycleJ cycle_subG mem_conjgV -zp_ya mem_cycle. + rewrite oy mulnAC partnC // [#|_|]orderJ; split. + by rewrite !inE -!order_dvdn mulnC in Az; case/andP: Az. + set Z := coset _ _; have NZ := repr_coset_norm Z; have:= coset_reprK Z. + case/kercoset_rcoset=> {NZ}// _ /cycleP[i ->] ->{Z}. + rewrite consttM; last exact/commute_sym/commuteX/cent1P. + rewrite (constt1P _) ?p_eltNK 1?p_eltX ?p_elt_constt // mul1g. + by rewrite conjMg consttJ conjgKV -zp_ya consttC. +rewrite 2!inE -order_dvdn; set Z := coset _ _ => /andP[Cz n'Z] /eqP def_z. +have Nz: z ^ a^-1 \in 'N(<[y]>). + rewrite -def_z conjgK groupMr; first by rewrite -(cycle_subG y) normG. + by rewrite groupX ?repr_coset_norm. +have{Cz} /setIP[Gz Cz]: z ^ a^-1 \in 'C_G[y]. + case/morphimP: Cz => u Nu Cu /kercoset_rcoset[] // _ /cycleP[i ->] ->. + by rewrite groupMr // groupX // inE groupX //; apply/cent1P. +have{def_z} zp_ya: z.`_p = y ^ a. + rewrite -def_z consttJ consttM. + rewrite constt_p_elt ?p_elt_constt //. + by rewrite (constt1P _) ?p_eltNK ?p_elt_constt ?mulg1. + apply: commute_sym; apply/cent1P. + by rewrite -def_z conjgK groupMl // in Cz; apply/cent1P. +have ozp: #[z ^ a^-1]`_p = #[y] by rewrite -order_constt consttJ zp_ya conjgK. +split; rewrite zp_ya // -class_lcoset lcoset_id // eqxx andbT. +rewrite -(conjgKV a z) !inE groupJ //= -!order_dvdn orderJ; apply/andP; split. + apply: contra (partn_dvd p n_gt0) _. + by rewrite ozp -(muln1 n`_p) oy dvdn_pmul2l // dvdn1 neq_ltn lt1p orbT. +rewrite -(partnC p n_gt0) mulnCA mulnA -oy -(@partnC p #[_]) // ozp. +apply dvdn_mul => //; apply: dvdn_trans (dvdn_trans n'Z (dvdn_gcdr _ _)). +rewrite {2}/order -morphim_cycle // -quotientE card_quotient ?cycle_subG //. +rewrite -(@dvdn_pmul2l #|<[z ^ a^-1]> :&: <[y]>|) ?cardG_gt0 // LagrangeI. +rewrite -[#|<[_]>|](partnC p) ?order_gt0 // dvdn_pmul2r // ozp. +by rewrite cardSg ?subsetIr. +Qed. diff --git a/mathcomp/solvable/gfunctor.v b/mathcomp/solvable/gfunctor.v new file mode 100644 index 0000000..a338999 --- /dev/null +++ b/mathcomp/solvable/gfunctor.v @@ -0,0 +1,484 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +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. + diff --git a/mathcomp/solvable/gseries.v b/mathcomp/solvable/gseries.v new file mode 100644 index 0000000..4e299e3 --- /dev/null +++ b/mathcomp/solvable/gseries.v @@ -0,0 +1,546 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path fintype bigop. +Require Import finset fingroup morphism automorphism quotient action. +Require Import commutator center. +(******************************************************************************) +(* H <|<| G <=> H is subnormal in G, i.e., H <| ... <| G. *) +(* invariant_factor A H G <=> A normalises both H and G, and H <| G. *) +(* A.-invariant <=> the (invariant_factor A) relation, in the context *) +(* of the g_rel.-series notation. *) +(* g_rel.-series H s <=> H :: s is a sequence of groups whose projection *) +(* to sets satisfies relation g_rel pairwise; for *) +(* example H <|<| G iff G = last H s for some s such *) +(* that normal.-series H s. *) +(* stable_factor A H G == H <| G and A centralises G / H. *) +(* A.-stable == the stable_factor relation, in the scope of the *) +(* r.-series notation. *) +(* G.-central == the central_factor relation, in the scope of the *) +(* r.-series notation. *) +(* maximal M G == M is a maximal proper subgroup of G. *) +(* maximal_eq M G == (M == G) or (maximal M G). *) +(* maxnormal M G N == M is a maximal subgroup of G normalized by N. *) +(* minnormal M N == M is a minimal nontrivial group normalized by N. *) +(* simple G == G is a (nontrivial) simple group. *) +(* := minnormal G G *) +(* G.-chief == the chief_factor relation, in the scope of the *) +(* r.-series notation. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section GroupDefs. + +Variable gT : finGroupType. +Implicit Types A B U V : {set gT}. + +Notation Local groupT := (group_of (Phant gT)). + +Definition subnormal A B := + (A \subset B) && (iter #|B| (fun N => generated (class_support A N)) B == A). + +Definition invariant_factor A B C := + [&& A \subset 'N(B), A \subset 'N(C) & B <| C]. + +Definition group_rel_of (r : rel {set gT}) := [rel H G : groupT | r H G]. + +Definition stable_factor A V U := + ([~: U, A] \subset V) && (V <| U). (* this orders allows and3P to be used *) + +Definition central_factor A V U := + [&& [~: U, A] \subset V, V \subset U & U \subset A]. + +Definition maximal A B := [max A of G | G \proper B]. + +Definition maximal_eq A B := (A == B) || maximal A B. + +Definition maxnormal A B U := [max A of G | G \proper B & U \subset 'N(G)]. + +Definition minnormal A B := [min A of G | G :!=: 1 & B \subset 'N(G)]. + +Definition simple A := minnormal A A. + +Definition chief_factor A V U := maxnormal V U A && (U <| A). +End GroupDefs. + +Arguments Scope subnormal [_ group_scope group_scope]. +Arguments Scope invariant_factor [_ group_scope group_scope group_scope]. +Arguments Scope stable_factor [_ group_scope group_scope group_scope]. +Arguments Scope central_factor [_ group_scope group_scope group_scope]. +Arguments Scope maximal [_ group_scope group_scope]. +Arguments Scope maximal_eq [_ group_scope group_scope]. +Arguments Scope maxnormal [_ group_scope group_scope group_scope]. +Arguments Scope minnormal [_ group_scope group_scope]. +Arguments Scope simple [_ group_scope]. +Arguments Scope chief_factor [_ group_scope group_scope group_scope]. +Prenex Implicits subnormal maximal simple. + +Notation "H <|<| G" := (subnormal H G) + (at level 70, no associativity) : group_scope. + +Notation "A .-invariant" := (invariant_factor A) + (at level 2, format "A .-invariant") : group_rel_scope. +Notation "A .-stable" := (stable_factor A) + (at level 2, format "A .-stable") : group_rel_scope. +Notation "A .-central" := (central_factor A) + (at level 2, format "A .-central") : group_rel_scope. +Notation "G .-chief" := (chief_factor G) + (at level 2, format "G .-chief") : group_rel_scope. + +Arguments Scope group_rel_of [_ group_rel_scope Group_scope Group_scope]. + +Notation "r .-series" := (path (rel_of_simpl_rel (group_rel_of r))) + (at level 2, format "r .-series") : group_scope. + +Section Subnormal. + +Variable gT : finGroupType. +Implicit Types (A B C D : {set gT}) (G H K : {group gT}). + +Let setIgr H G := (G :&: H)%G. +Let sub_setIgr G H : G \subset H -> G = setIgr H G. +Proof. by move/setIidPl/group_inj. Qed. + +Let path_setIgr H G s : + normal.-series H s -> normal.-series (setIgr G H) (map (setIgr G) s). +Proof. +elim: s H => //= K s IHs H /andP[/andP[sHK nHK] Ksn]. +by rewrite /normal setSI ?normsIG ?IHs. +Qed. + +Lemma subnormalP H G : + reflect (exists2 s, normal.-series H s & last H s = G) (H <|<| G). +Proof. +apply: (iffP andP) => [[sHG snHG] | [s Hsn <-{G}]]. + elim: {G}#|G| {-2}G sHG snHG => [|m IHm] G sHG. + by exists [::]; last by apply/eqP; rewrite eq_sym. + rewrite iterSr => /IHm[|s Hsn defG]. + by rewrite sub_gen // class_supportEr (bigD1 1) //= conjsg1 subsetUl. + exists (rcons s G); rewrite ?last_rcons // -cats1 cat_path Hsn defG /=. + rewrite /normal gen_subG class_support_subG //=. + by rewrite norms_gen ?class_support_norm. +set f := fun _ => <<_>>; have idf: iter _ f H == H. + by elim=> //= m IHm; rewrite (eqP IHm) /f class_support_id genGid. +elim: {s}(size s) {-2}s (eqxx (size s)) Hsn => [[] //= | m IHm s]. +case/lastP: s => // s G; rewrite size_rcons last_rcons -cats1 cat_path /=. +set K := last H s => def_m /and3P[Hsn /andP[sKG nKG] _]. +have:= sKG; rewrite subEproper; case/predU1P=> [<-|prKG]; first exact: IHm. +pose L := [group of f G]. +have sHK: H \subset K by case/IHm: Hsn. +have sLK: L \subset K by rewrite gen_subG class_support_sub_norm. +rewrite -(subnK (proper_card (sub_proper_trans sLK prKG))) iter_add iterSr. +have defH: H = setIgr L H by rewrite -sub_setIgr ?sub_gen ?sub_class_support. +have: normal.-series H (map (setIgr L) s) by rewrite defH path_setIgr. +case/IHm=> [|_]; first by rewrite size_map. +by rewrite {1 2}defH last_map (subset_trans sHK) //= (setIidPr sLK) => /eqP->. +Qed. + +Lemma subnormal_refl G : G <|<| G. +Proof. by apply/subnormalP; exists [::]. Qed. + +Lemma subnormal_trans K H G : H <|<| K -> K <|<| G -> H <|<| G. +Proof. +case/subnormalP=> [s1 Hs1 <-] /subnormalP[s2 Hs12 <-]. +by apply/subnormalP; exists (s1 ++ s2); rewrite ?last_cat // cat_path Hs1. +Qed. + +Lemma normal_subnormal H G : H <| G -> H <|<| G. +Proof. by move=> nsHG; apply/subnormalP; exists [:: G]; rewrite //= nsHG. Qed. + +Lemma setI_subnormal G H K : K \subset G -> H <|<| G -> H :&: K <|<| K. +Proof. +move=> sKG /subnormalP[s Hs defG]; apply/subnormalP. +exists (map (setIgr K) s); first exact: path_setIgr. +rewrite (last_map (setIgr K)) defG. +by apply: val_inj; rewrite /= (setIidPr sKG). +Qed. + +Lemma subnormal_sub G H : H <|<| G -> H \subset G. +Proof. by case/andP. Qed. + +Lemma invariant_subnormal A G H : + A \subset 'N(G) -> A \subset 'N(H) -> H <|<| G -> + exists2 s, (A.-invariant).-series H s & last H s = G. +Proof. +move=> nGA nHA /andP[]; move: #|G| => m. +elim: m => [|m IHm] in G nGA * => sHG. + by rewrite eq_sym; exists [::]; last exact/eqP. +rewrite iterSr; set K := <<_>>. +have nKA: A \subset 'N(K) by rewrite norms_gen ?norms_class_support. +have sHK: H \subset K by rewrite sub_gen ?sub_class_support. +case/IHm=> // s Hsn defK; exists (rcons s G); last by rewrite last_rcons. +rewrite rcons_path Hsn !andbA defK nGA nKA /= -/K. +by rewrite gen_subG class_support_subG ?norms_gen ?class_support_norm. +Qed. + +Lemma subnormalEsupport G H : + H <|<| G -> H :=: G \/ <> \proper G. +Proof. +case/andP=> sHG; set K := <<_>> => /eqP <-. +have: K \subset G by rewrite gen_subG class_support_subG. +rewrite subEproper; case/predU1P=> [defK|]; [left | by right]. +by elim: #|G| => //= _ ->. +Qed. + +Lemma subnormalEr G H : H <|<| G -> + H :=: G \/ (exists K : {group gT}, [/\ H <|<| K, K <| G & K \proper G]). +Proof. +case/subnormalP=> s Hs <-{G}. +elim/last_ind: s Hs => [|s G IHs]; first by left. +rewrite last_rcons -cats1 cat_path /= andbT; set K := last H s. +case/andP=> Hs nsKG; have:= normal_sub nsKG; rewrite subEproper. +case/predU1P=> [<- | prKG]; [exact: IHs | right; exists K; split=> //]. +by apply/subnormalP; exists s. +Qed. + +Lemma subnormalEl G H : H <|<| G -> + H :=: G \/ (exists K : {group gT}, [/\ H <| K, K <|<| G & H \proper K]). +Proof. +case/subnormalP=> s Hs <-{G}; elim: s H Hs => /= [|K s IHs] H; first by left. +case/andP=> nsHK Ks; have:= normal_sub nsHK; rewrite subEproper. +case/predU1P=> [-> | prHK]; [exact: IHs | right; exists K; split=> //]. +by apply/subnormalP; exists s. +Qed. + +End Subnormal. + +Implicit Arguments subnormalP [gT G H]. +Prenex Implicits subnormalP. + +Section MorphSubNormal. + +Variable gT : finGroupType. +Implicit Type G H K : {group gT}. + +Lemma morphim_subnormal (rT : finGroupType) G (f : {morphism G >-> rT}) H K : + H <|<| K -> f @* H <|<| f @* K. +Proof. +case/subnormalP => s Hs <-{K}; apply/subnormalP. +elim: s H Hs => [|K s IHs] H /=; first by exists [::]. +case/andP=> nsHK /IHs[fs Hfs <-]. +by exists ([group of f @* K] :: fs); rewrite /= ?morphim_normal. +Qed. + +Lemma quotient_subnormal H G K : G <|<| K -> G / H <|<| K / H. +Proof. exact: morphim_subnormal. Qed. + +End MorphSubNormal. + +Section MaxProps. + +Variable gT : finGroupType. +Implicit Types G H M : {group gT}. + +Lemma maximal_eqP M G : + reflect (M \subset G /\ + forall H, M \subset H -> H \subset G -> H :=: M \/ H :=: G) + (maximal_eq M G). +Proof. +rewrite subEproper /maximal_eq; case: eqP => [->|_]; first left. + by split=> // H sGH sHG; right; apply/eqP; rewrite eqEsubset sHG. +apply: (iffP maxgroupP) => [] [sMG maxM]; split=> // H. + by move/maxM=> maxMH; rewrite subEproper; case/predU1P; auto. +by rewrite properEneq => /andP[/eqP neHG sHG] /maxM[]. +Qed. + +Lemma maximal_exists H G : + H \subset G -> + H :=: G \/ (exists2 M : {group gT}, maximal M G & H \subset M). +Proof. +rewrite subEproper; case/predU1P=> sHG; first by left. +suff [M *]: {M : {group gT} | maximal M G & H \subset M} by right; exists M. +exact: maxgroup_exists. +Qed. + +Lemma mulg_normal_maximal G M H : + M <| G -> maximal M G -> H \subset G -> ~~ (H \subset M) -> (M * H = G)%g. +Proof. +case/andP=> sMG nMG /maxgroupP[_ maxM] sHG not_sHM. +apply/eqP; rewrite eqEproper mul_subG // -norm_joinEr ?(subset_trans sHG) //. +by apply: contra not_sHM => /maxM <-; rewrite ?joing_subl ?joing_subr. +Qed. + +End MaxProps. + +Section MinProps. + +Variable gT : finGroupType. +Implicit Types G H M : {group gT}. + +Lemma minnormal_exists G H : H :!=: 1 -> G \subset 'N(H) -> + {M : {group gT} | minnormal M G & M \subset H}. +Proof. by move=> ntH nHG; apply: mingroup_exists (H) _; rewrite ntH. Qed. + +End MinProps. + +Section MorphPreMax. + +Variables (gT rT : finGroupType) (D : {group gT}) (f : {morphism D >-> rT}). +Variables (M G : {group rT}). +Hypotheses (dM : M \subset f @* D) (dG : G \subset f @* D). + +Lemma morphpre_maximal : maximal (f @*^-1 M) (f @*^-1 G) = maximal M G. +Proof. +apply/maxgroupP/maxgroupP; rewrite morphpre_proper //= => [] [ltMG maxM]. + split=> // H ltHG sMH; have dH := subset_trans (proper_sub ltHG) dG. + rewrite -(morphpreK dH) [f @*^-1 H]maxM ?morphpreK ?morphpreSK //. + by rewrite morphpre_proper. +split=> // H ltHG sMH. +have dH: H \subset D := subset_trans (proper_sub ltHG) (subsetIl D _). +have defH: f @*^-1 (f @* H) = H. + by apply: morphimGK dH; apply: subset_trans sMH; exact: ker_sub_pre. +rewrite -defH morphpre_proper ?morphimS // in ltHG. +by rewrite -defH [f @* H]maxM // -(morphpreK dM) morphimS. +Qed. + +Lemma morphpre_maximal_eq : maximal_eq (f @*^-1 M) (f @*^-1 G) = maximal_eq M G. +Proof. by rewrite /maximal_eq morphpre_maximal !eqEsubset !morphpreSK. Qed. + +End MorphPreMax. + +Section InjmMax. + +Variables (gT rT : finGroupType) (D : {group gT}) (f : {morphism D >-> rT}). +Variables M G L : {group gT}. + +Hypothesis injf : 'injm f. +Hypotheses (dM : M \subset D) (dG : G \subset D) (dL : L \subset D). + +Lemma injm_maximal : maximal (f @* M) (f @* G) = maximal M G. +Proof. +rewrite -(morphpre_invm injf) -(morphpre_invm injf G). +by rewrite morphpre_maximal ?morphim_invm. +Qed. + +Lemma injm_maximal_eq : maximal_eq (f @* M) (f @* G) = maximal_eq M G. +Proof. by rewrite /maximal_eq injm_maximal // injm_eq. Qed. + +Lemma injm_maxnormal : maxnormal (f @* M) (f @* G) (f @* L) = maxnormal M G L. +Proof. +pose injfm := (injm_proper injf, injm_norms, injmSK injf, subsetIl). +apply/maxgroupP/maxgroupP; rewrite !injfm // => [[nML maxM]]. + split=> // H nHL sMH; have [/proper_sub sHG _] := andP nHL. + have dH := subset_trans sHG dG; apply: (injm_morphim_inj injf) => //. + by apply: maxM; rewrite !injfm. +split=> // fH nHL sMH; have [/proper_sub sfHG _] := andP nHL. +have{sfHG} dfH: fH \subset f @* D := subset_trans sfHG (morphim_sub f G). +by rewrite -(morphpreK dfH) !injfm // in nHL sMH *; rewrite (maxM _ nHL). +Qed. + +Lemma injm_minnormal : minnormal (f @* M) (f @* G) = minnormal M G. +Proof. +pose injfm := (morphim_injm_eq1 injf, injm_norms, injmSK injf, subsetIl). +apply/mingroupP/mingroupP; rewrite !injfm // => [[nML minM]]. + split=> // H nHG sHM; have dH := subset_trans sHM dM. + by apply: (injm_morphim_inj injf) => //; apply: minM; rewrite !injfm. +split=> // fH nHG sHM; have dfH := subset_trans sHM (morphim_sub f M). +by rewrite -(morphpreK dfH) !injfm // in nHG sHM *; rewrite (minM _ nHG). +Qed. + +End InjmMax. + +Section QuoMax. + +Variables (gT : finGroupType) (K G H : {group gT}). + +Lemma cosetpre_maximal (Q R : {group coset_of K}) : + maximal (coset K @*^-1 Q) (coset K @*^-1 R) = maximal Q R. +Proof. by rewrite morphpre_maximal ?sub_im_coset. Qed. + +Lemma cosetpre_maximal_eq (Q R : {group coset_of K}) : + maximal_eq (coset K @*^-1 Q) (coset K @*^-1 R) = maximal_eq Q R. +Proof. by rewrite /maximal_eq !eqEsubset !cosetpreSK cosetpre_maximal. Qed. + +Lemma quotient_maximal : + K <| G -> K <| H -> maximal (G / K) (H / K) = maximal G H. +Proof. by move=> nKG nKH; rewrite -cosetpre_maximal ?quotientGK. Qed. + +Lemma quotient_maximal_eq : + K <| G -> K <| H -> maximal_eq (G / K) (H / K) = maximal_eq G H. +Proof. by move=> nKG nKH; rewrite -cosetpre_maximal_eq ?quotientGK. Qed. + +Lemma maximalJ x : maximal (G :^ x) (H :^ x) = maximal G H. +Proof. +rewrite -{1}(setTI G) -{1}(setTI H) -!morphim_conj. +by rewrite injm_maximal ?subsetT ?injm_conj. +Qed. + +Lemma maximal_eqJ x : maximal_eq (G :^ x) (H :^ x) = maximal_eq G H. +Proof. by rewrite /maximal_eq !eqEsubset !conjSg maximalJ. Qed. + +End QuoMax. + +Section MaxNormalProps. + +Variables (gT : finGroupType). +Implicit Types (A B C : {set gT}) (G H K L M : {group gT}). + +Lemma maxnormal_normal A B : maxnormal A B B -> A <| B. +Proof. +by case/maxsetP=> /and3P[/gen_set_id /= -> pAB nAB]; rewrite /normal proper_sub. +Qed. + +Lemma maxnormal_proper A B C : maxnormal A B C -> A \proper B. +Proof. +by case/maxsetP=> /and3P[gA pAB _] _; exact: (sub_proper_trans (subset_gen A)). +Qed. + +Lemma maxnormal_sub A B C : maxnormal A B C -> A \subset B. +Proof. +by move=> maxA; rewrite proper_sub //; exact: (maxnormal_proper maxA). +Qed. + +Lemma ex_maxnormal_ntrivg G : G :!=: 1-> {N : {group gT} | maxnormal N G G}. +Proof. +move=> ntG; apply: ex_maxgroup; exists [1 gT]%G; rewrite norm1 proper1G. +by rewrite subsetT ntG. +Qed. + +Lemma maxnormalM G H K : + maxnormal H G G -> maxnormal K G G -> H :<>: K -> H * K = G. +Proof. +move=> maxH maxK /eqP; apply: contraNeq => ltHK_G. +have [nsHG nsKG] := (maxnormal_normal maxH, maxnormal_normal maxK). +have cHK: commute H K. + exact: normC (subset_trans (normal_sub nsHG) (normal_norm nsKG)). +wlog suffices: H K {maxH} maxK nsHG nsKG cHK ltHK_G / H \subset K. + by move=> IH; rewrite eqEsubset !IH // -cHK. +have{maxK} /maxgroupP[_ maxK] := maxK. +apply/joing_idPr/maxK; rewrite ?joing_subr //= comm_joingE //. +by rewrite properEneq ltHK_G; exact: normalM. +Qed. + +Lemma maxnormal_minnormal G L M : + G \subset 'N(M) -> L \subset 'N(G) -> maxnormal M G L -> + minnormal (G / M) (L / M). +Proof. +move=> nMG nGL /maxgroupP[/andP[/andP[sMG ltMG] nML] maxM]; apply/mingroupP. +rewrite -subG1 quotient_sub1 ?ltMG ?quotient_norms //. +split=> // Hb /andP[ntHb nHbL]; have nsMG: M <| G by exact/andP. +case/inv_quotientS=> // H defHb sMH sHG; rewrite defHb; congr (_ / M). +apply/eqP; rewrite eqEproper sHG /=; apply: contra ntHb => ltHG. +have nsMH: M <| H := normalS sMH sHG nsMG. +rewrite defHb quotientS1 // (maxM H) // ltHG /= -(quotientGK nsMH) -defHb. +exact: norm_quotient_pre. +Qed. + +Lemma minnormal_maxnormal G L M : + M <| G -> L \subset 'N(M) -> minnormal (G / M) (L / M) -> maxnormal M G L. +Proof. +case/andP=> sMG nMG nML /mingroupP[/andP[/= ntGM _] minGM]; apply/maxgroupP. +split=> [|H /andP[/andP[sHG ltHG] nHL] sMH]. + by rewrite /proper sMG nML andbT; apply: contra ntGM => /quotientS1 ->. +apply/eqP; rewrite eqEsubset sMH andbT -quotient_sub1 ?(subset_trans sHG) //. +rewrite subG1; apply: contraR ltHG => ntHM; rewrite -(quotientSGK nMG) //. +by rewrite (minGM (H / M)%G) ?quotientS // ntHM quotient_norms. +Qed. + +End MaxNormalProps. + +Section Simple. + +Implicit Types gT rT : finGroupType. + +Lemma simpleP gT (G : {group gT}) : + reflect (G :!=: 1 /\ forall H : {group gT}, H <| G -> H :=: 1 \/ H :=: G) + (simple G). +Proof. +apply: (iffP mingroupP); rewrite normG andbT => [[ntG simG]]. + split=> // N /andP[sNG nNG]. + by case: (eqsVneq N 1) => [|ntN]; [left | right; apply: simG; rewrite ?ntN]. +split=> // N /andP[ntN nNG] sNG. +by case: (simG N) ntN => // [|->]; [exact/andP | case/eqP]. +Qed. + +Lemma quotient_simple gT (G H : {group gT}) : + H <| G -> simple (G / H) = maxnormal H G G. +Proof. +move=> nsHG; have nGH := normal_norm nsHG. +by apply/idP/idP; [exact: minnormal_maxnormal | exact: maxnormal_minnormal]. +Qed. + +Lemma isog_simple gT rT (G : {group gT}) (M : {group rT}) : + G \isog M -> simple G = simple M. +Proof. +move=> eqGM; wlog suffices: gT rT G M eqGM / simple M -> simple G. + by move=> IH; apply/idP/idP; apply: IH; rewrite // isog_sym. +case/isogP: eqGM => f injf <- /simpleP[ntGf simGf]. +apply/simpleP; split=> [|N nsNG]; first by rewrite -(morphim_injm_eq1 injf). +rewrite -(morphim_invm injf (normal_sub nsNG)). +have: f @* N <| f @* G by rewrite morphim_normal. +by case/simGf=> /= ->; [left | right]; rewrite (morphim1, morphim_invm). +Qed. + +Lemma simple_maxnormal gT (G : {group gT}) : simple G = maxnormal 1 G G. +Proof. +by rewrite -quotient_simple ?normal1 // -(isog_simple (quotient1_isog G)). +Qed. + +End Simple. + +Section Chiefs. + +Variable gT : finGroupType. +Implicit Types G H U V : {group gT}. + +Lemma chief_factor_minnormal G V U : + chief_factor G V U -> minnormal (U / V) (G / V). +Proof. +case/andP=> maxV /andP[sUG nUG]; apply: maxnormal_minnormal => //. +by have /andP[_ nVG] := maxgroupp maxV; exact: subset_trans sUG nVG. +Qed. + +Lemma acts_irrQ G U V : + G \subset 'N(V) -> V <| U -> + acts_irreducibly G (U / V) 'Q = minnormal (U / V) (G / V). +Proof. +move=> nVG nsVU; apply/mingroupP/mingroupP; case=> /andP[->] /=. + rewrite astabsQ // subsetI nVG /= => nUG minUV. + rewrite quotient_norms //; split=> // H /andP[ntH nHG] sHU. + by apply: minUV (sHU); rewrite ntH -(cosetpreK H) actsQ // norm_quotient_pre. +rewrite sub_quotient_pre // => nUG minU; rewrite astabsQ //. +rewrite (subset_trans nUG); last first. + by rewrite subsetI subsetIl /= -{2}(quotientGK nsVU) morphpre_norm. +split=> // H /andP[ntH nHG] sHU. +rewrite -{1}(cosetpreK H) astabsQ ?normal_cosetpre ?subsetI ?nVG //= in nHG. +apply: minU sHU; rewrite ntH; apply: subset_trans (quotientS _ nHG) _. +by rewrite -{2}(cosetpreK H) quotient_norm. +Qed. + +Lemma chief_series_exists H G : + H <| G -> {s | (G.-chief).-series 1%G s & last 1%G s = H}. +Proof. +elim: {H}_.+1 {-2}H (ltnSn #|H|) => // m IHm U leUm nsUG. +have [-> | ntU] := eqVneq U 1%G; first by exists [::]. +have [V maxV]: {V : {group gT} | maxnormal V U G}. + by apply: ex_maxgroup; exists 1%G; rewrite proper1G ntU norms1. +have /andP[ltVU nVG] := maxgroupp maxV. +have [||s ch_s defV] := IHm V; first exact: leq_trans (proper_card ltVU) _. + by rewrite /normal (subset_trans (proper_sub ltVU) (normal_sub nsUG)). +exists (rcons s U); last by rewrite last_rcons. +by rewrite rcons_path defV /= ch_s /chief_factor; exact/and3P. +Qed. + +End Chiefs. + +Section Central. + +Variables (gT : finGroupType) (G : {group gT}). +Implicit Types H K : {group gT}. + +Lemma central_factor_central H K : + central_factor G H K -> (K / H) \subset 'Z(G / H). +Proof. by case/and3P=> /quotient_cents2r *; rewrite subsetI quotientS. Qed. + + +Lemma central_central_factor H K : + (K / H) \subset 'Z(G / H) -> H <| K -> H <| G -> central_factor G H K. +Proof. +case/subsetIP=> sKGb cGKb /andP[sHK nHK] /andP[sHG nHG]. +by rewrite /central_factor -quotient_cents2 // cGKb sHK -(quotientSGK nHK). +Qed. + +End Central. diff --git a/mathcomp/solvable/hall.v b/mathcomp/solvable/hall.v new file mode 100644 index 0000000..e097765 --- /dev/null +++ b/mathcomp/solvable/hall.v @@ -0,0 +1,895 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div fintype finset. +Require Import prime fingroup morphism automorphism quotient action gproduct. +Require Import commutator center pgroup finmodule nilpotent sylow. +Require Import abelian maximal. + +(*****************************************************************************) +(* In this files we prove the Schur-Zassenhaus splitting and transitivity *) +(* theorems (under solvability assumptions), then derive P. Hall's *) +(* generalization of Sylow's theorem to solvable groups and its corollaries, *) +(* in particular the theory of coprime action. We develop both the theory of *) +(* coprime action of a solvable group on Sylow subgroups (as in Aschbacher *) +(* 18.7), and that of coprime action on Hall subgroups of a solvable group *) +(* as per B & G, Proposition 1.5; however we only support external group *) +(* action (as opposed to internal action by conjugation) for the latter case *) +(* because it is much harder to apply in practice. *) +(*****************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section Hall. + +Implicit Type gT : finGroupType. + +Theorem SchurZassenhaus_split gT (G H : {group gT}) : + Hall G H -> H <| G -> [splits G, over H]. +Proof. +move: {2}_.+1 (ltnSn #|G|) => n; elim: n => // n IHn in gT G H *. +rewrite ltnS => Gn hallH nsHG; have [sHG nHG] := andP nsHG. +have [-> | [p pr_p pH]] := trivgVpdiv H. + by apply/splitsP; exists G; rewrite inE -subG1 subsetIl mul1g eqxx. +have [P sylP] := Sylow_exists p H. +case nPG: (P <| G); last first. + pose N := ('N_G(P))%G; have sNG: N \subset G by rewrite subsetIl. + have eqHN_G: H * N = G by exact: Frattini_arg sylP. + pose H' := (H :&: N)%G. + have nsH'N: H' <| N. + by rewrite /normal subsetIr normsI ?normG ?(subset_trans sNG). + have eq_iH: #|G : H| = #|N| %/ #|H'|. + rewrite -divgS // -(divnMl (cardG_gt0 H')) mulnC -eqHN_G. + by rewrite -mul_cardG (mulnC #|H'|) divnMl // cardG_gt0. + have hallH': Hall N H'. + rewrite /Hall -divgS subsetIr //= -eq_iH. + by case/andP: hallH => _; apply: coprimeSg; exact: subsetIl. + have: [splits N, over H']. + apply: IHn hallH' nsH'N; apply: {n}leq_trans Gn. + rewrite proper_card // properEneq sNG andbT; apply/eqP=> eqNG. + by rewrite -eqNG normal_subnorm (subset_trans (pHall_sub sylP)) in nPG. + case/splitsP=> K /complP[tiKN eqH'K]. + have sKN: K \subset N by rewrite -(mul1g K) -eqH'K mulSg ?sub1set. + apply/splitsP; exists K; rewrite inE -subG1; apply/andP; split. + by rewrite /= -(setIidPr sKN) setIA tiKN. + by rewrite eqEsubset -eqHN_G mulgS // -eqH'K mulGS mulSg ?subsetIl. +pose Z := 'Z(P); pose Gbar := G / Z; pose Hbar := H / Z. +have sZP: Z \subset P by exact: center_sub. +have sZH: Z \subset H by exact: subset_trans (pHall_sub sylP). +have sZG: Z \subset G by exact: subset_trans sHG. +have nZG: Z <| G by apply: char_normal_trans nPG; exact: center_char. +have nZH: Z <| H by exact: normalS nZG. +have nHGbar: Hbar <| Gbar by exact: morphim_normal. +have hallHbar: Hall Gbar Hbar by apply: morphim_Hall (normal_norm _) _. +have: [splits Gbar, over Hbar]. + apply: IHn => //; apply: {n}leq_trans Gn; rewrite ltn_quotient //. + apply/eqP=> /(trivg_center_pgroup (pHall_pgroup sylP))/eqP. + rewrite trivg_card1 (card_Hall sylP) p_part -(expn0 p). + by rewrite eqn_exp2l ?prime_gt1 // lognE pH pr_p cardG_gt0. +case/splitsP=> Kbar /complP[tiHKbar eqHKbar]. +have: Kbar \subset Gbar by rewrite -eqHKbar mulG_subr. +case/inv_quotientS=> //= ZK quoZK sZZK sZKG. +have nZZK: Z <| ZK by exact: normalS nZG. +have cardZK: #|ZK| = (#|Z| * #|G : H|)%N. + rewrite -(Lagrange sZZK); congr (_ * _)%N. + rewrite -card_quotient -?quoZK; last by case/andP: nZZK. + rewrite -(divgS sHG) -(Lagrange sZG) -(Lagrange sZH) divnMl //. + rewrite -!card_quotient ?normal_norm //= -/Gbar -/Hbar. + by rewrite -eqHKbar (TI_cardMg tiHKbar) mulKn. +have: [splits ZK, over Z]. + rewrite (Gaschutz_split nZZK _ sZZK) ?center_abelian //; last first. + rewrite -divgS // cardZK mulKn ?cardG_gt0 //. + by case/andP: hallH => _; exact: coprimeSg. + by apply/splitsP; exists 1%G; rewrite inE -subG1 subsetIr mulg1 eqxx. +case/splitsP=> K /complP[tiZK eqZK]. +have sKZK: K \subset ZK by rewrite -(mul1g K) -eqZK mulSg ?sub1G. +have tiHK: H :&: K = 1. + apply/trivgP; rewrite /= -(setIidPr sKZK) setIA -tiZK setSI //. + rewrite -quotient_sub1; last by rewrite subIset 1?normal_norm. + by rewrite /= quotientGI //= -quoZK tiHKbar. +apply/splitsP; exists K; rewrite inE tiHK ?eqEcard subxx leqnn /=. +rewrite mul_subG ?(subset_trans sKZK) //= TI_cardMg //. +rewrite -(@mulKn #|K| #|Z|) ?cardG_gt0 // -TI_cardMg // eqZK. +by rewrite cardZK mulKn ?cardG_gt0 // Lagrange. +Qed. + +Theorem SchurZassenhaus_trans_sol gT (H K K1 : {group gT}) : + solvable H -> K \subset 'N(H) -> K1 \subset H * K -> + coprime #|H| #|K| -> #|K1| = #|K| -> + exists2 x, x \in H & K1 :=: K :^ x. +Proof. +move: {2}_.+1 (ltnSn #|H|) => n; elim: n => // n IHn in gT H K K1 *. +rewrite ltnS => leHn solH nHK; have [-> | ] := eqsVneq H 1. + rewrite mul1g => sK1K _ eqK1K; exists 1; first exact: set11. + by apply/eqP; rewrite conjsg1 eqEcard sK1K eqK1K /=. +pose G := (H <*> K)%G. +have defG: G :=: H * K by rewrite -normC // -norm_joinEl // joingC. +have sHG: H \subset G by exact: joing_subl. +have sKG: K \subset G by exact: joing_subr. +have nsHG: H <| G by rewrite /(H <| G) sHG join_subG normG. +case/(solvable_norm_abelem solH nsHG)=> M [sMH nsMG ntM] /and3P[_ abelM _]. +have [sMG nMG] := andP nsMG; rewrite -defG => sK1G coHK oK1K. +have nMsG (L : {set gT}): L \subset G -> L \subset 'N(M). + by move/subset_trans->. +have [coKM coHMK]: coprime #|M| #|K| /\ coprime #|H / M| #|K|. + by apply/andP; rewrite -coprime_mull card_quotient ?nMsG ?Lagrange. +have oKM (K' : {group gT}): K' \subset G -> #|K'| = #|K| -> #|K' / M| = #|K|. + move=> sK'G oK'. + rewrite -quotientMidr -?norm_joinEl ?card_quotient ?nMsG //; last first. + by rewrite gen_subG subUset sK'G. + rewrite -divgS /=; last by rewrite -gen_subG genS ?subsetUr. + by rewrite norm_joinEl ?nMsG // coprime_cardMg ?mulnK // oK' coprime_sym. +have [xb]: exists2 xb, xb \in H / M & K1 / M = (K / M) :^ xb. + apply: IHn; try by rewrite (quotient_sol, morphim_norms, oKM K) ?(oKM K1). + by apply: leq_trans leHn; rewrite ltn_quotient. + by rewrite -morphimMl ?nMsG // -defG morphimS. +case/morphimP=> x nMx Hx ->{xb} eqK1Kx; pose K2 := (K :^ x)%G. +have{eqK1Kx} eqK12: K1 / M = K2 / M by rewrite quotientJ. +suff [y My ->]: exists2 y, y \in M & K1 :=: K2 :^ y. + by exists (x * y); [rewrite groupMl // (subsetP sMH) | rewrite conjsgM]. +have nMK1: K1 \subset 'N(M) by exact: nMsG. +have defMK: M * K1 = M <*> K1 by rewrite -normC // -norm_joinEl // joingC. +have sMKM: M \subset M <*> K1 by rewrite joing_subl. +have nMKM: M <| M <*> K1 by rewrite normalYl. +have trMK1: M :&: K1 = 1 by rewrite coprime_TIg ?oK1K. +have trMK2: M :&: K2 = 1 by rewrite coprime_TIg ?cardJg ?oK1K. +apply: (Gaschutz_transitive nMKM _ sMKM) => //=; last 2 first. +- by rewrite inE trMK1 defMK !eqxx. +- by rewrite -!(setIC M) trMK1. +- by rewrite -divgS //= -defMK coprime_cardMg oK1K // mulKn. +rewrite inE trMK2 eqxx eq_sym eqEcard /= -defMK andbC. +by rewrite !coprime_cardMg ?cardJg ?oK1K ?leqnn //= mulGS -quotientSK -?eqK12. +Qed. + +Lemma SchurZassenhaus_trans_actsol gT (G A B : {group gT}) : + solvable A -> A \subset 'N(G) -> B \subset A <*> G -> + coprime #|G| #|A| -> #|A| = #|B| -> + exists2 x, x \in G & B :=: A :^ x. +Proof. +set AG := A <*> G; move: {2}_.+1 (ltnSn #|AG|) => n. +elim: n => // n IHn in gT A B G AG *. +rewrite ltnS => leAn solA nGA sB_AG coGA oAB. +have [A1 | ntA] := eqsVneq A 1. + by exists 1; rewrite // conjsg1 A1 (@card1_trivg _ B) // -oAB A1 cards1. +have [M [sMA nsMA ntM]] := solvable_norm_abelem solA (normal_refl A) ntA. +case/is_abelemP=> q q_pr /abelem_pgroup qM; have nMA := normal_norm nsMA. +have defAG: AG = A * G := norm_joinEl nGA. +have sA_AG: A \subset AG := joing_subl _ _. +have sG_AG: G \subset AG := joing_subr _ _. +have sM_AG := subset_trans sMA sA_AG. +have oAG: #|AG| = (#|A| * #|G|)%N by rewrite defAG coprime_cardMg 1?coprime_sym. +have q'G: #|G|`_q = 1%N. + rewrite part_p'nat ?p'natE -?prime_coprime // coprime_sym. + have [_ _ [k oM]] := pgroup_pdiv qM ntM. + by rewrite -(@coprime_pexpr k.+1) // -oM (coprimegS sMA). +have coBG: coprime #|B| #|G| by rewrite -oAB coprime_sym. +have defBG: B * G = AG. + by apply/eqP; rewrite eqEcard mul_subG ?sG_AG //= oAG oAB coprime_cardMg. +case nMG: (G \subset 'N(M)). + have nsM_AG: M <| AG by rewrite /normal sM_AG join_subG nMA. + have nMB: B \subset 'N(M) := subset_trans sB_AG (normal_norm nsM_AG). + have sMB: M \subset B. + have [Q sylQ]:= Sylow_exists q B; have sQB := pHall_sub sylQ. + apply: subset_trans (normal_sub_max_pgroup (Hall_max _) qM nsM_AG) (sQB). + rewrite pHallE (subset_trans sQB) //= oAG partnM // q'G muln1 oAB. + by rewrite (card_Hall sylQ). + have defAGq: AG / M = (A / M) <*> (G / M). + by rewrite quotient_gen ?quotientU ?subUset ?nMA. + have: B / M \subset (A / M) <*> (G / M) by rewrite -defAGq quotientS. + case/IHn; rewrite ?morphim_sol ?quotient_norms ?coprime_morph //. + - by rewrite -defAGq (leq_trans _ leAn) ?ltn_quotient. + - by rewrite !card_quotient // -!divgS // oAB. + move=> Mx; case/morphimP=> x Nx Gx ->{Mx} //; rewrite -quotientJ //= => defBq. + exists x => //; apply: quotient_inj defBq; first by rewrite /normal sMB. + by rewrite -(normsP nMG x Gx) /normal normJ !conjSg. +pose K := M <*> G; pose R := K :&: B; pose N := 'N_G(M). +have defK: K = M * G by rewrite -norm_joinEl ?(subset_trans sMA). +have oK: #|K| = (#|M| * #|G|)%N. + by rewrite defK coprime_cardMg // coprime_sym (coprimegS sMA). +have sylM: q.-Sylow(K) M. + by rewrite pHallE joing_subl /= oK partnM // q'G muln1 part_pnat_id. +have sylR: q.-Sylow(K) R. + rewrite pHallE subsetIl /= -(card_Hall sylM) -(@eqn_pmul2r #|G|) // -oK. + rewrite -coprime_cardMg ?(coprimeSg _ coBG) ?subsetIr //=. + by rewrite group_modr ?joing_subr ?(setIidPl _) // defBG join_subG sM_AG. +have [mx] := Sylow_trans sylM sylR. +rewrite /= -/K defK; case/imset2P=> m x Mm Gx ->{mx}. +rewrite conjsgM conjGid {m Mm}// => defR. +have sNG: N \subset G := subsetIl _ _. +have pNG: N \proper G by rewrite /proper sNG subsetI subxx nMG. +have nNA: A \subset 'N(N) by rewrite normsI ?norms_norm. +have: B :^ x^-1 \subset A <*> N. + rewrite norm_joinEl ?group_modl // -defAG subsetI !sub_conjgV -normJ -defR. + rewrite conjGid ?(subsetP sG_AG) // normsI ?normsG // (subset_trans sB_AG) //. + by rewrite join_subG normsM // -defK normsG ?joing_subr. +do [case/IHn; rewrite ?cardJg ?(coprimeSg _ coGA) //= -/N] => [|y Ny defB]. + rewrite joingC norm_joinEr // coprime_cardMg ?(coprimeSg sNG) //. + by rewrite (leq_trans _ leAn) // oAG mulnC ltn_pmul2l // proper_card. +exists (y * x); first by rewrite groupM // (subsetP sNG). +by rewrite conjsgM -defB conjsgKV. +Qed. + +Lemma Hall_exists_subJ pi gT (G : {group gT}) : + solvable G -> exists2 H : {group gT}, pi.-Hall(G) H + & forall K : {group gT}, K \subset G -> pi.-group K -> + exists2 x, x \in G & K \subset H :^ x. +Proof. +move: {2}_.+1 (ltnSn #|G|) => n. +elim: n gT G => // n IHn gT G; rewrite ltnS => leGn solG. +have [-> | ntG] := eqsVneq G 1. + exists 1%G => [|_ /trivGP-> _]; last by exists 1; rewrite ?set11 ?sub1G. + by rewrite pHallE sub1G cards1 part_p'nat. +case: (solvable_norm_abelem solG (normal_refl _)) => // M [sMG nsMG ntM]. +case/is_abelemP=> p pr_p /and3P[pM cMM _]. +pose Gb := (G / M)%G; case: (IHn _ Gb) => [||Hb]; try exact: quotient_sol. + by rewrite (leq_trans (ltn_quotient _ _)). +case/and3P=> [sHbGb piHb pi'Hb'] transHb. +case: (inv_quotientS nsMG sHbGb) => H def_H sMH sHG. +have nMG := normal_norm nsMG; have nMH := subset_trans sHG nMG. +have{transHb} transH (K : {group gT}): + K \subset G -> pi.-group K -> exists2 x, x \in G & K \subset H :^ x. +- move=> sKG piK; have nMK := subset_trans sKG nMG. + case: (transHb (K / M)%G) => [||xb Gxb sKHxb]; first exact: morphimS. + exact: morphim_pgroup. + case/morphimP: Gxb => x Nx Gx /= def_x; exists x => //. + apply/subsetP=> y Ky. + have: y \in coset M y by rewrite val_coset (subsetP nMK, rcoset_refl). + have: coset M y \in (H :^ x) / M. + rewrite /quotient morphimJ //=. + rewrite def_x def_H in sKHxb; apply: (subsetP sKHxb); exact: mem_quotient. + case/morphimP=> z Nz Hxz ->. + rewrite val_coset //; case/rcosetP=> t Mt ->; rewrite groupMl //. + by rewrite mem_conjg (subsetP sMH) // -mem_conjg (normP Nx). +have{pi'Hb'} pi'H': pi^'.-nat #|G : H|. + move: pi'Hb'; rewrite -!divgS // def_H !card_quotient //. + by rewrite -(divnMl (cardG_gt0 M)) !Lagrange. +have [pi_p | pi'p] := boolP (p \in pi). + exists H => //; apply/and3P; split=> //; rewrite /pgroup. + by rewrite -(Lagrange sMH) -card_quotient // pnat_mul -def_H (pi_pnat pM). +have [ltHG | leGH {n IHn leGn transH}] := ltnP #|H| #|G|. + case: (IHn _ H (leq_trans ltHG leGn)) => [|H1]; first exact: solvableS solG. + case/and3P=> sH1H piH1 pi'H1' transH1. + have sH1G: H1 \subset G by exact: subset_trans sHG. + exists H1 => [|K sKG piK]. + apply/and3P; split => //. + rewrite -divgS // -(Lagrange sHG) -(Lagrange sH1H) -mulnA. + by rewrite mulKn // pnat_mul pi'H1'. + case: (transH K sKG piK) => x Gx def_K. + case: (transH1 (K :^ x^-1)%G) => [||y Hy def_K1]. + - by rewrite sub_conjgV. + - by rewrite /pgroup cardJg. + exists (y * x); first by rewrite groupMr // (subsetP sHG). + by rewrite -(conjsgKV x K) conjsgM conjSg. +have{leGH Gb sHbGb sHG sMH pi'H'} eqHG: H = G. + by apply/eqP; rewrite -val_eqE eqEcard sHG. +have{H Hb def_H eqHG piHb nMH} hallM: pi^'.-Hall(G) M. + rewrite /pHall /pgroup sMG pnatNK -card_quotient //=. + by rewrite -eqHG -def_H (pi_pnat pM). +case/splitsP: (SchurZassenhaus_split (pHall_Hall hallM) nsMG) => H. +case/complP=> trMH defG. +have sHG: H \subset G by rewrite -defG mulG_subr. +exists H => [|K sKG piK]. + apply: etrans hallM; rewrite /pHall sMG sHG /= -!divgS // -defG andbC. + by rewrite (TI_cardMg trMH) mulKn ?mulnK // pnatNK. +pose G1 := (K <*> M)%G; pose K1 := (H :&: G1)%G. +have nMK: K \subset 'N(M) by apply: subset_trans sKG nMG. +have defG1: M * K = G1 by rewrite -normC -?norm_joinEl. +have sK1G1: K1 \subset M * K by rewrite defG1 subsetIr. +have coMK: coprime #|M| #|K|. + by rewrite coprime_sym (pnat_coprime piK) //; exact: (pHall_pgroup hallM). +case: (SchurZassenhaus_trans_sol _ nMK sK1G1 coMK) => [||x Mx defK1]. +- exact: solvableS solG. +- apply/eqP; rewrite -(eqn_pmul2l (cardG_gt0 M)) -TI_cardMg //; last first. + by apply/trivgP; rewrite -trMH /= setIA subsetIl. + rewrite -coprime_cardMg // defG1; apply/eqP; congr #|(_ : {set _})|. + rewrite group_modl; last by rewrite -defG1 mulG_subl. + by apply/setIidPr; rewrite defG gen_subG subUset sKG. +exists x^-1; first by rewrite groupV (subsetP sMG). +by rewrite -(_ : K1 :^ x^-1 = K) ?(conjSg, subsetIl) // defK1 conjsgK. +Qed. + +End Hall. + +Section HallCorollaries. + +Variable gT : finGroupType. + +Corollary Hall_exists pi (G : {group gT}) : + solvable G -> exists H : {group gT}, pi.-Hall(G) H. +Proof. by case/(Hall_exists_subJ pi) => H; exists H. Qed. + +Corollary Hall_trans pi (G H1 H2 : {group gT}) : + solvable G -> pi.-Hall(G) H1 -> pi.-Hall(G) H2 -> + exists2 x, x \in G & H1 :=: H2 :^ x. +Proof. +move=> solG; have [H hallH transH] := Hall_exists_subJ pi solG. +have conjH (K : {group gT}): + pi.-Hall(G) K -> exists2 x, x \in G & K = (H :^ x)%G. +- move=> hallK; have [sKG piK _] := and3P hallK. + case: (transH K sKG piK) => x Gx sKH; exists x => //. + apply/eqP; rewrite -val_eqE eqEcard sKH cardJg. + by rewrite (card_Hall hallH) (card_Hall hallK) /=. +case/conjH=> x1 Gx1 ->{H1}; case/conjH=> x2 Gx2 ->{H2}. +exists (x2^-1 * x1); first by rewrite groupMl ?groupV. +by apply: val_inj; rewrite /= conjsgM conjsgK. +Qed. + +Corollary Hall_superset pi (G K : {group gT}) : + solvable G -> K \subset G -> pi.-group K -> + exists2 H : {group gT}, pi.-Hall(G) H & K \subset H. +Proof. +move=> solG sKG; have [H hallH transH] := Hall_exists_subJ pi solG. +by case/transH=> // x Gx sKHx; exists (H :^ x)%G; rewrite ?pHallJ. +Qed. + +Corollary Hall_subJ pi (G H K : {group gT}) : + solvable G -> pi.-Hall(G) H -> K \subset G -> pi.-group K -> + exists2 x, x \in G & K \subset H :^ x. +Proof. +move=> solG HallH sKG piK; have [M HallM sKM]:= Hall_superset solG sKG piK. +have [x Gx defM] := Hall_trans solG HallM HallH. +by exists x; rewrite // -defM. +Qed. + +Corollary Hall_Jsub pi (G H K : {group gT}) : + solvable G -> pi.-Hall(G) H -> K \subset G -> pi.-group K -> + exists2 x, x \in G & K :^ x \subset H. +Proof. +move=> solG HallH sKG piK; have [x Gx sKHx] := Hall_subJ solG HallH sKG piK. +by exists x^-1; rewrite ?groupV // sub_conjgV. +Qed. + +Lemma Hall_Frattini_arg pi (G K H : {group gT}) : + solvable K -> K <| G -> pi.-Hall(K) H -> K * 'N_G(H) = G. +Proof. +move=> solK /andP[sKG nKG] hallH. +have sHG: H \subset G by apply: subset_trans sKG; case/andP: hallH. +rewrite setIC group_modl //; apply/setIidPr/subsetP=> x Gx. +pose H1 := (H :^ x^-1)%G. +have hallH1: pi.-Hall(K) H1 by rewrite pHallJnorm // groupV (subsetP nKG). +case: (Hall_trans solK hallH hallH1) => y Ky defH. +rewrite -(mulKVg y x) mem_mulg //; apply/normP. +by rewrite conjsgM {1}defH conjsgK conjsgKV. +Qed. + +End HallCorollaries. + +Section InternalAction. + +Variables (pi : nat_pred) (gT : finGroupType). +Implicit Types G H K A X : {group gT}. + +(* Part of Aschbacher (18.7.4). *) +Lemma coprime_norm_cent A G : + A \subset 'N(G) -> coprime #|G| #|A| -> 'N_G(A) = 'C_G(A). +Proof. +move=> nGA coGA; apply/eqP; rewrite eqEsubset andbC setIS ?cent_sub //=. +rewrite subsetI subsetIl /= (sameP commG1P trivgP) -(coprime_TIg coGA). +rewrite subsetI commg_subr subsetIr andbT. +move: nGA; rewrite -commg_subl; apply: subset_trans. +by rewrite commSg ?subsetIl. +Qed. + +(* This is B & G, Proposition 1.5(a) *) +Proposition coprime_Hall_exists A G : + A \subset 'N(G) -> coprime #|G| #|A| -> solvable G -> + exists2 H : {group gT}, pi.-Hall(G) H & A \subset 'N(H). +Proof. +move=> nGA coGA solG; have [H hallH] := Hall_exists pi solG. +have sG_AG: G \subset A <*> G by rewrite joing_subr. +have nG_AG: A <*> G \subset 'N(G) by rewrite join_subG nGA normG. +pose N := 'N_(A <*> G)(H)%G. +have nGN: N \subset 'N(G) by rewrite subIset ?nG_AG. +have nGN_N: G :&: N <| N by rewrite /(_ <| N) subsetIr normsI ?normG. +have NG_AG: G * N = A <*> G. + by apply: Hall_Frattini_arg hallH => //; exact/andP. +have iGN_A: #|N| %/ #|G :&: N| = #|A|. + rewrite setIC divgI -card_quotient // -quotientMidl NG_AG. + rewrite card_quotient -?divgS //= norm_joinEl //. + by rewrite coprime_cardMg 1?coprime_sym // mulnK. +have hallGN: Hall N (G :&: N). + by rewrite /Hall -divgS subsetIr //= iGN_A (coprimeSg _ coGA) ?subsetIl. +case/splitsP: {hallGN nGN_N}(SchurZassenhaus_split hallGN nGN_N) => B. +case/complP=> trBGN defN. +have{trBGN iGN_A} oBA: #|B| = #|A|. + by rewrite -iGN_A -{1}defN (TI_cardMg trBGN) mulKn. +have sBN: B \subset N by rewrite -defN mulG_subr. +case: (SchurZassenhaus_trans_sol solG nGA _ coGA oBA) => [|x Gx defB]. + by rewrite -(normC nGA) -norm_joinEl // -NG_AG -(mul1g B) mulgSS ?sub1G. +exists (H :^ x^-1)%G; first by rewrite pHallJ ?groupV. +apply/subsetP=> y Ay; have: y ^ x \in B by rewrite defB memJ_conjg. +move/(subsetP sBN)=> /setIP[_ /normP nHyx]. +by apply/normP; rewrite -conjsgM conjgCV invgK conjsgM nHyx. +Qed. + +(* This is B & G, Proposition 1.5(c) *) +Proposition coprime_Hall_trans A G H1 H2 : + A \subset 'N(G) -> coprime #|G| #|A| -> solvable G -> + pi.-Hall(G) H1 -> A \subset 'N(H1) -> + pi.-Hall(G) H2 -> A \subset 'N(H2) -> + exists2 x, x \in 'C_G(A) & H1 :=: H2 :^ x. +Proof. +move: H1 => H nGA coGA solG hallH nHA hallH2. +have{H2 hallH2} [x Gx -> nH1xA] := Hall_trans solG hallH2 hallH. +have sG_AG: G \subset A <*> G by rewrite -{1}genGid genS ?subsetUr. +have nG_AG: A <*> G \subset 'N(G) by rewrite gen_subG subUset nGA normG. +pose N := 'N_(A <*> G)(H)%G. +have nGN: N \subset 'N(G) by rewrite subIset ?nG_AG. +have nGN_N: G :&: N <| N. + apply/normalP; rewrite subsetIr; split=> // y Ny. + by rewrite conjIg (normP _) // (subsetP nGN, conjGid). +have NG_AG : G * N = A <*> G. + by apply: Hall_Frattini_arg hallH => //; exact/andP. +have iGN_A: #|N : G :&: N| = #|A|. + rewrite -card_quotient //; last by case/andP: nGN_N. + rewrite (card_isog (second_isog nGN)) /= -quotientMidr (normC nGN) NG_AG. + rewrite card_quotient // -divgS //= joingC norm_joinEr //. + by rewrite coprime_cardMg // mulnC mulnK. +have solGN: solvable (G :&: N) by apply: solvableS solG; exact: subsetIl. +have oAxA: #|A :^ x^-1| = #|A| by exact: cardJg. +have sAN: A \subset N by rewrite subsetI -{1}genGid genS // subsetUl. +have nGNA: A \subset 'N(G :&: N). + by apply/normsP=> y ?; rewrite conjIg (normsP nGA) ?(conjGid, subsetP sAN). +have coGNA: coprime #|G :&: N| #|A| := coprimeSg (subsetIl _ _) coGA. +case: (SchurZassenhaus_trans_sol solGN nGNA _ coGNA oAxA) => [|y GNy defAx]. + have ->: (G :&: N) * A = N. + apply/eqP; rewrite eqEcard -{2}(mulGid N) mulgSS ?subsetIr //=. + by rewrite coprime_cardMg // -iGN_A Lagrange ?subsetIr. + rewrite sub_conjgV conjIg -normJ subsetI conjGid ?joing_subl //. + by rewrite mem_gen // inE Gx orbT. +case/setIP: GNy => Gy; case/setIP=> _; move/normP=> nHy. +exists (y * x)^-1. + rewrite -coprime_norm_cent // groupV inE groupM //=; apply/normP. + by rewrite conjsgM -defAx conjsgKV. +by apply: val_inj; rewrite /= -{2}nHy -(conjsgM _ y) conjsgK. +Qed. + +(* A complement to the above: 'C(A) acts on 'Nby(A) *) +Lemma norm_conj_cent A G x : x \in 'C(A) -> + (A \subset 'N(G :^ x)) = (A \subset 'N(G)). +Proof. by move=> cAx; rewrite norm_conj_norm ?(subsetP (cent_sub A)). Qed. + +(* Strongest version of the centraliser lemma -- not found in textbooks! *) +(* Obviously, the solvability condition could be removed once we have the *) +(* Odd Order Theorem. *) +Lemma strongest_coprime_quotient_cent A G H : + let R := H :&: [~: G, A] in + A \subset 'N(H) -> R \subset G -> coprime #|R| #|A| -> + solvable R || solvable A -> + 'C_G(A) / H = 'C_(G / H)(A / H). +Proof. +move=> R nHA sRG coRA solRA. +have nRA: A \subset 'N(R) by rewrite normsI ?commg_normr. +apply/eqP; rewrite eqEsubset subsetI morphimS ?subsetIl //=. +rewrite (subset_trans _ (morphim_cent _ _)) ?morphimS ?subsetIr //=. +apply/subsetP=> _ /setIP[/morphimP[x Nx Gx ->] cAHx]. +have{cAHx} cAxR y: y \in A -> [~ x, y] \in R. + move=> Ay; have Ny: y \in 'N(H) by exact: subsetP Ay. + rewrite inE mem_commg // andbT coset_idr ?groupR // morphR //=. + by apply/eqP; apply/commgP; apply: (centP cAHx); rewrite mem_quotient. +have AxRA: A :^ x \subset R * A. + apply/subsetP=> _ /imsetP[y Ay ->]. + rewrite -normC // -(mulKVg y (y ^ x)) -commgEl mem_mulg //. + by rewrite -groupV invg_comm cAxR. +have [y Ry def_Ax]: exists2 y, y \in R & A :^ x = A :^ y. + have oAx: #|A :^ x| = #|A| by rewrite cardJg. + have [solR | solA] := orP solRA; first exact: SchurZassenhaus_trans_sol. + by apply: SchurZassenhaus_trans_actsol; rewrite // joingC norm_joinEr. +rewrite -imset_coset; apply/imsetP; exists (x * y^-1); last first. + by rewrite conjgCV mkerl // ker_coset memJ_norm groupV; case/setIP: Ry. +rewrite /= inE groupMl // ?(groupV, subsetP sRG) //=. +apply/centP=> z Az; apply/commgP/eqP/set1P. +rewrite -[[set 1]](coprime_TIg coRA) inE {1}commgEl commgEr /= -/R. +rewrite invMg -mulgA invgK groupMl // conjMg mulgA -commgEl. +rewrite groupMl ?cAxR // memJ_norm ?(groupV, subsetP nRA) // Ry /=. +by rewrite groupMr // conjVg groupV conjgM -mem_conjg -def_Ax memJ_conjg. +Qed. + +(* A weaker but more practical version, still stronger than the usual form *) +(* (viz. Aschbacher 18.7.4), similar to the one needed in Aschbacher's *) +(* proof of Thompson factorization. Note that the coprime and solvability *) +(* assumptions could be further weakened to H :&: G (and hence become *) +(* trivial if H and G are TI). However, the assumption that A act on G is *) +(* needed in this case. *) +Lemma coprime_norm_quotient_cent A G H : + A \subset 'N(G) -> A \subset 'N(H) -> coprime #|H| #|A| -> solvable H -> + 'C_G(A) / H = 'C_(G / H)(A / H). +Proof. +move=> nGA nHA coHA solH; have sRH := subsetIl H [~: G, A]. +rewrite strongest_coprime_quotient_cent ?(coprimeSg sRH) 1?(solvableS sRH) //. +by rewrite subIset // commg_subl nGA orbT. +Qed. + +(* A useful consequence (similar to Ex. 6.1 in Aschbacher) of the stronger *) +(* theorem. *) +Lemma coprime_cent_mulG A G H : + A \subset 'N(G) -> A \subset 'N(H) -> G \subset 'N(H) -> + coprime #|H| #|A| -> solvable H -> + 'C_(H * G)(A) = 'C_H(A) * 'C_G(A). +Proof. +move=> nHA nGA nHG coHA solH; rewrite -norm_joinEr //. +have nsHG: H <| H <*> G by rewrite /normal joing_subl join_subG normG. +rewrite -{2}(setIidPr (normal_sub nsHG)) setIAC. +rewrite group_modr ?setSI ?joing_subr //=; symmetry; apply/setIidPl. +rewrite -quotientSK ?subIset 1?normal_norm //. +by rewrite !coprime_norm_quotient_cent ?normsY //= norm_joinEr ?quotientMidl. +Qed. + +(* Another special case of the strong coprime quotient lemma; not found in *) +(* textbooks, but nevertheless used implicitly throughout B & G, sometimes *) +(* justified by switching to external action. *) +Lemma quotient_TI_subcent K G H : + G \subset 'N(K) -> G \subset 'N(H) -> K :&: H = 1 -> + 'C_K(G) / H = 'C_(K / H)(G / H). +Proof. +move=> nGK nGH tiKH. +have tiHR: H :&: [~: K, G] = 1. + by apply/trivgP; rewrite /= setIC -tiKH setSI ?commg_subl. +apply: strongest_coprime_quotient_cent; rewrite ?tiHR ?sub1G ?solvable1 //. +by rewrite cards1 coprime1n. +Qed. + +(* This is B & G, Proposition 1.5(d): the more traditional form of the lemma *) +(* above, with the assumption H <| G weakened to H \subset G. The stronger *) +(* coprime and solvability assumptions are easier to satisfy in practice. *) +Proposition coprime_quotient_cent A G H : + H \subset G -> A \subset 'N(H) -> coprime #|G| #|A| -> solvable G -> + 'C_G(A) / H = 'C_(G / H)(A / H). +Proof. +move=> sHG nHA coGA solG. +have sRG: H :&: [~: G, A] \subset G by rewrite subIset ?sHG. +by rewrite strongest_coprime_quotient_cent ?(coprimeSg sRG) 1?(solvableS sRG). +Qed. + +(* This is B & G, Proposition 1.5(e). *) +Proposition coprime_comm_pcore A G K : + A \subset 'N(G) -> coprime #|G| #|A| -> solvable G -> + pi^'.-Hall(G) K -> K \subset 'C_G(A) -> + [~: G, A] \subset 'O_pi(G). +Proof. +move=> nGA coGA solG hallK cKA. +case: (coprime_Hall_exists nGA) => // H hallH nHA. +have sHG: H \subset G by case/andP: hallH. +have sKG: K \subset G by case/andP: hallK. +have coKH: coprime #|K| #|H|. + case/and3P: hallH=> _ piH _; case/and3P: hallK => _ pi'K _. + by rewrite coprime_sym (pnat_coprime piH pi'K). +have defG: G :=: K * H. + apply/eqP; rewrite eq_sym eqEcard coprime_cardMg //. + rewrite -{1}(mulGid G) mulgSS //= (card_Hall hallH) (card_Hall hallK). + by rewrite mulnC partnC. +have sGA_H: [~: G, A] \subset H. + rewrite gen_subG defG; apply/subsetP=> xya; case/imset2P=> xy a. + case/imset2P=> x y Kx Hy -> Aa -> {xya xy}. + rewrite commMgJ (([~ x, a] =P 1) _) ?(conj1g, mul1g). + by rewrite groupMl ?groupV // memJ_norm ?(subsetP nHA). + rewrite subsetI sKG in cKA; apply/commgP; exact: (centsP cKA). +apply: pcore_max; last first. + by rewrite /(_ <| G) /= commg_norml commGC commg_subr nGA. +by case/and3P: hallH => _ piH _; apply: pgroupS piH. +Qed. + +End InternalAction. + +(* This is B & G, Proposition 1.5(b). *) +Proposition coprime_Hall_subset pi (gT : finGroupType) (A G X : {group gT}) : + A \subset 'N(G) -> coprime #|G| #|A| -> solvable G -> + X \subset G -> pi.-group X -> A \subset 'N(X) -> + exists H : {group gT}, [/\ pi.-Hall(G) H, A \subset 'N(H) & X \subset H]. +Proof. +move: {2}_.+1 (ltnSn #|G|) => n. +elim: n => // n IHn in gT A G X * => leGn nGA coGA solG sXG piX nXA. +have [G1 | ntG] := eqsVneq G 1. + case: (coprime_Hall_exists pi nGA) => // H hallH nHA. + by exists H; split; rewrite // (subset_trans sXG) // G1 sub1G. +have sG_AG: G \subset A <*> G by rewrite joing_subr. +have sA_AG: A \subset A <*> G by rewrite joing_subl. +have nG_AG: A <*> G \subset 'N(G) by rewrite join_subG nGA normG. +have nsG_AG: G <| A <*> G by exact/andP. +case: (solvable_norm_abelem solG nsG_AG) => // M [sMG nsMAG ntM]. +have{nsMAG} [nMA nMG]: A \subset 'N(M) /\ G \subset 'N(M). + by apply/andP; rewrite -join_subG normal_norm. +have nMX: X \subset 'N(M) by exact: subset_trans nMG. +case/is_abelemP=> p pr_p; case/and3P=> pM cMM _. +have: #|G / M| < n by rewrite (leq_trans (ltn_quotient _ _)). +move/(IHn _ (A / M)%G _ (X / M)%G); rewrite !(quotient_norms, quotientS) //. +rewrite !(coprime_morph, quotient_sol, morphim_pgroup) //. +case=> //= Hq []; case/and3P=> sHGq piHq pi'Hq' nHAq sXHq. +case/inv_quotientS: (sHGq) => [|HM defHM sMHM sHMG]; first exact/andP. +have nMHM := subset_trans sHMG nMG. +have{sXHq} sXHM: X \subset HM by rewrite -(quotientSGK nMX) -?defHM. +have{pi'Hq' sHGq} pi'HM': pi^'.-nat #|G : HM|. + move: pi'Hq'; rewrite -!divgS // defHM !card_quotient //. + by rewrite -(divnMl (cardG_gt0 M)) !Lagrange. +have{nHAq} nHMA: A \subset 'N(HM). + by rewrite -(quotientSGK nMA) ?normsG ?quotient_normG -?defHM //; exact/andP. +case/orP: (orbN (p \in pi)) => pi_p. + exists HM; split=> //; apply/and3P; split; rewrite /pgroup //. + by rewrite -(Lagrange sMHM) pnat_mul -card_quotient // -defHM (pi_pnat pM). +case: (ltnP #|HM| #|G|) => [ltHG | leGHM {n IHn leGn}]. + case: (IHn _ A HM X (leq_trans ltHG leGn)) => // [||H [hallH nHA sXH]]. + - exact: coprimeSg coGA. + - exact: solvableS solG. + case/and3P: hallH => sHHM piH pi'H'. + have sHG: H \subset G by exact: subset_trans sHMG. + exists H; split=> //; apply/and3P; split=> //. + rewrite -divgS // -(Lagrange sHMG) -(Lagrange sHHM) -mulnA mulKn //. + by rewrite pnat_mul pi'H'. +have{leGHM nHMA sHMG sMHM sXHM pi'HM'} eqHMG: HM = G. + by apply/eqP; rewrite -val_eqE eqEcard sHMG. +have pi'M: pi^'.-group M by rewrite /pgroup (pi_pnat pM). +have{HM Hq nMHM defHM eqHMG piHq} hallM: pi^'.-Hall(G) M. + apply/and3P; split; rewrite // /pgroup pnatNK. + by rewrite -card_quotient // -eqHMG -defHM. +case: (coprime_Hall_exists pi nGA) => // H hallH nHA. +pose XM := (X <*> M)%G; pose Y := (H :&: XM)%G. +case/and3P: (hallH) => sHG piH _. +have sXXM: X \subset XM by rewrite joing_subl. +have co_pi_M (B : {group gT}): pi.-group B -> coprime #|B| #|M|. + by move=> piB; rewrite (pnat_coprime piB). +have hallX: pi.-Hall(XM) X. + rewrite /pHall piX sXXM -divgS //= norm_joinEl //. + by rewrite coprime_cardMg ?co_pi_M // mulKn. +have sXMG: XM \subset G by rewrite join_subG sXG. +have hallY: pi.-Hall(XM) Y. + have sYXM: Y \subset XM by rewrite subsetIr. + have piY: pi.-group Y by apply: pgroupS piH; exact: subsetIl. + rewrite /pHall sYXM piY -divgS // -(_ : Y * M = XM). + by rewrite coprime_cardMg ?co_pi_M // mulKn //. + rewrite /= setIC group_modr ?joing_subr //=; apply/setIidPl. + rewrite ((H * M =P G) _) // eqEcard mul_subG //= coprime_cardMg ?co_pi_M //. + by rewrite (card_Hall hallM) (card_Hall hallH) partnC. +have nXMA: A \subset 'N(XM) by rewrite normsY. +have:= coprime_Hall_trans nXMA _ _ hallX nXA hallY. +rewrite !(coprimeSg sXMG, solvableS sXMG, normsI) //. +case=> // x /setIP[XMx cAx] ->. +exists (H :^ x)%G; split; first by rewrite pHallJ ?(subsetP sXMG). + by rewrite norm_conj_cent. +by rewrite conjSg subsetIl. +Qed. + +Section ExternalAction. + +Variables (pi : nat_pred) (aT gT : finGroupType). +Variables (A : {group aT}) (G : {group gT}) (to : groupAction A G). + +Section FullExtension. + +Local Notation inA := (sdpair2 to). +Local Notation inG := (sdpair1 to). +Local Notation A' := (inA @* gval A). +Local Notation G' := (inG @* gval G). +Let injG : 'injm inG := injm_sdpair1 _. +Let injA : 'injm inA := injm_sdpair2 _. + +Hypotheses (coGA : coprime #|G| #|A|) (solG : solvable G). + +Lemma external_action_im_coprime : coprime #|G'| #|A'|. +Proof. by rewrite !card_injm. Qed. + +Let coGA' := external_action_im_coprime. + +Let solG' : solvable G' := morphim_sol _ solG. + +Let nGA' := im_sdpair_norm to. + +Lemma ext_coprime_Hall_exists : + exists2 H : {group gT}, pi.-Hall(G) H & [acts A, on H | to]. +Proof. +have [H' hallH' nHA'] := coprime_Hall_exists pi nGA' coGA' solG'. +have sHG' := pHall_sub hallH'. +exists (inG @*^-1 H')%G => /=. + by rewrite -(morphim_invmE injG) -{1}(im_invm injG) morphim_pHall. +by rewrite actsEsd ?morphpreK // subsetIl. +Qed. + +Lemma ext_coprime_Hall_trans (H1 H2 : {group gT}) : + pi.-Hall(G) H1 -> [acts A, on H1 | to] -> + pi.-Hall(G) H2 -> [acts A, on H2 | to] -> + exists2 x, x \in 'C_(G | to)(A) & H1 :=: H2 :^ x. +Proof. +move=> hallH1 nH1A hallH2 nH2A. +have sH1G := pHall_sub hallH1; have sH2G := pHall_sub hallH2. +rewrite !actsEsd // in nH1A nH2A. +have hallH1': pi.-Hall(G') (inG @* H1) by rewrite morphim_pHall. +have hallH2': pi.-Hall(G') (inG @* H2) by rewrite morphim_pHall. +have [x'] := coprime_Hall_trans nGA' coGA' solG' hallH1' nH1A hallH2' nH2A. +case/setIP=> /= Gx' cAx' /eqP defH1; pose x := invm injG x'. +have Gx: x \in G by rewrite -(im_invm injG) mem_morphim. +have def_x': x' = inG x by rewrite invmK. +exists x; first by rewrite inE Gx gacentEsd mem_morphpre /= -?def_x'. +apply/eqP; move: defH1; rewrite def_x' /= -morphimJ //=. +by rewrite !eqEsubset !injmSK // conj_subG. +Qed. + +Lemma ext_norm_conj_cent (H : {group gT}) x : + H \subset G -> x \in 'C_(G | to)(A) -> + [acts A, on H :^ x | to] = [acts A, on H | to]. +Proof. +move=> sHG /setIP[Gx]. +rewrite gacentEsd !actsEsd ?conj_subG ?morphimJ // 2!inE Gx /=. +exact: norm_conj_cent. +Qed. + +Lemma ext_coprime_Hall_subset (X : {group gT}) : + X \subset G -> pi.-group X -> [acts A, on X | to] -> + exists H : {group gT}, + [/\ pi.-Hall(G) H, [acts A, on H | to] & X \subset H]. +Proof. +move=> sXG piX; rewrite actsEsd // => nXA'. +case: (coprime_Hall_subset nGA' coGA' solG' _ (morphim_pgroup _ piX) nXA'). + exact: morphimS. +move=> H' /= [piH' nHA' sXH']; have sHG' := pHall_sub piH'. +exists (inG @*^-1 H')%G; rewrite actsEsd ?subsetIl ?morphpreK // nHA'. +rewrite -sub_morphim_pre //= sXH'; split=> //. +by rewrite -(morphim_invmE injG) -{1}(im_invm injG) morphim_pHall. +Qed. + +End FullExtension. + +(* We only prove a weaker form of the coprime group action centraliser *) +(* lemma, because it is more convenient in practice to make G the range *) +(* of the action, whence G both contains H and is stable under A. *) +(* However we do restrict the coprime/solvable assumptions to H, and *) +(* we do not require that G normalize H. *) +Lemma ext_coprime_quotient_cent (H : {group gT}) : + H \subset G -> [acts A, on H | to] -> coprime #|H| #|A| -> solvable H -> + 'C_(|to)(A) / H = 'C_(|to / H)(A). +Proof. +move=> sHG nHA coHA solH; pose N := 'N_G(H). +have nsHN: H <| N by rewrite normal_subnorm. +have [sHN nHn] := andP nsHN. +have sNG: N \subset G by exact: subsetIl. +have nNA: {acts A, on group N | to}. + split; rewrite // actsEsd // injm_subnorm ?injm_sdpair1 //=. + by rewrite normsI ?norms_norm ?im_sdpair_norm -?actsEsd. +rewrite -!(gacentIdom _ A) -quotientInorm -gacentIim setIAC. +rewrite -(gacent_actby nNA) gacentEsd -morphpreIim /= -/N. +have:= (injm_sdpair1 <[nNA]>, injm_sdpair2 <[nNA]>). +set inG := sdpair1 _; set inA := sdpair2 _ => [[injG injA]]. +set G' := inG @* N; set A' := inA @* A; pose H' := inG @* H. +have defN: 'N(H | to) = A by apply/eqP; rewrite eqEsubset subsetIl. +have def_Dq: qact_dom to H = A by rewrite qact_domE. +have sAq: A \subset qact_dom to H by rewrite def_Dq. +rewrite {2}def_Dq -(gacent_ract _ sAq); set to_q := (_ \ _)%gact. +have:= And3 (sdprod_sdpair to_q) (injm_sdpair1 to_q) (injm_sdpair2 to_q). +rewrite gacentEsd; set inAq := sdpair2 _; set inGq := sdpair1 _ => /=. +set Gq := inGq @* _; set Aq := inAq @* _ => [[q_d iGq iAq]]. +have nH': 'N(H') = setT. + apply/eqP; rewrite -subTset -im_sdpair mulG_subG morphim_norms //=. + by rewrite -actsEsd // acts_actby subxx /= (setIidPr sHN). +have: 'dom (coset H' \o inA \o invm iAq) = Aq. + by rewrite ['dom _]morphpre_invm /= nH' morphpreT. +case/domP=> qA [def_qA ker_qA _ im_qA]. +have{coHA} coHA': coprime #|H'| #|A'| by rewrite !card_injm. +have{ker_qA} injAq: 'injm qA. + rewrite {}ker_qA !ker_comp ker_coset morphpre_invm -morphpreIim /= setIC. + by rewrite coprime_TIg // -kerE (trivgP injA) morphim1. +have{im_qA} im_Aq : qA @* Aq = A' / H'. + by rewrite {}im_qA !morphim_comp im_invm. +have: 'dom (quotm (sdpair1_morphism <[nNA]>) nsHN \o invm iGq) = Gq. + by rewrite ['dom _]morphpre_invm /= quotientInorm. +case/domP=> qG [def_qG ker_qG _ im_qG]. +have{ker_qG} injGq: 'injm qG. + rewrite {}ker_qG ker_comp ker_quotm morphpre_invm (trivgP injG). + by rewrite quotient1 morphim1. +have im_Gq: qG @* Gq = G' / H'. + rewrite {}im_qG morphim_comp im_invm morphim_quotm //= -/inG -/H'. + by rewrite -morphimIdom setIAC setIid. +have{def_qA def_qG} q_J : {in Gq & Aq, morph_act 'J 'J qG qA}. + move=> x' a'; case/morphimP=> Hx; case/morphimP=> x nHx Gx -> GHx ->{Hx x'}. + case/morphimP=> a _ Aa ->{a'} /=; rewrite -/inAq -/inGq. + rewrite !{}def_qG {}def_qA /= !invmE // -sdpair_act //= -/inG -/inA. + have Nx: x \in N by rewrite inE Gx. + have Nxa: to x a \in N by case: (nNA); move/acts_act->. + have [Gxa nHxa] := setIP Nxa. + rewrite invmE qactE ?quotmE ?mem_morphim ?def_Dq //=. + by rewrite -morphJ /= ?nH' ?inE // -sdpair_act //= actbyE. +pose q := sdprodm q_d q_J. +have{injAq injGq} injq: 'injm q. + rewrite injm_sdprodm injAq injGq /= {}im_Aq {}im_Gq -/Aq . + by rewrite -quotientGI ?im_sdpair_TI ?morphimS //= quotient1. +rewrite -[inGq @*^-1 _]morphpreIim -/Gq. +have sC'G: inG @*^-1 'C_G'(A') \subset G by rewrite !subIset ?subxx. +rewrite -[_ / _](injmK iGq) ?quotientS //= -/inGq; congr (_ @*^-1 _). +apply: (injm_morphim_inj injq); rewrite 1?injm_subcent ?subsetT //= -/q. +rewrite 2?morphim_sdprodml ?morphimS //= im_Gq. +rewrite morphim_sdprodmr ?morphimS //= im_Aq. +rewrite {}im_qG morphim_comp morphim_invm ?morphimS //. +rewrite morphim_quotm morphpreK ?subsetIl //= -/H'. +rewrite coprime_norm_quotient_cent ?im_sdpair_norm ?nH' ?subsetT //=. +exact: morphim_sol. +Qed. + +End ExternalAction. + +Section SylowSolvableAct. + +Variables (gT : finGroupType) (p : nat). +Implicit Types A B G X : {group gT}. + +Lemma sol_coprime_Sylow_exists A G : + solvable A -> A \subset 'N(G) -> coprime #|G| #|A| -> + exists2 P : {group gT}, p.-Sylow(G) P & A \subset 'N(P). +Proof. +move=> solA nGA coGA; pose AG := A <*> G. +have nsG_AG: G <| AG by rewrite /normal joing_subr join_subG nGA normG. +have [sG_AG nG_AG]:= andP nsG_AG. +have [P sylP] := Sylow_exists p G; pose N := 'N_AG(P); pose NG := G :&: N. +have nGN: N \subset 'N(G) by rewrite subIset ?nG_AG. +have sNG_G: NG \subset G := subsetIl G N. +have nsNG_N: NG <| N by rewrite /normal subsetIr normsI ?normG. +have defAG: G * N = AG := Frattini_arg nsG_AG sylP. +have oA : #|A| = #|N| %/ #|NG|. + rewrite /NG setIC divgI -card_quotient // -quotientMidl defAG. + rewrite card_quotient -?divgS //= norm_joinEl //. + by rewrite coprime_cardMg 1?coprime_sym // mulnK. +have: [splits N, over NG]. + rewrite SchurZassenhaus_split // /Hall -divgS subsetIr //. + by rewrite -oA (coprimeSg sNG_G). +case/splitsP=> B; case/complP=> tNG_B defN. +have [nPB]: B \subset 'N(P) /\ B \subset AG. + by apply/andP; rewrite andbC -subsetI -/N -defN mulG_subr. +case/SchurZassenhaus_trans_actsol => // [|x Gx defB]. + by rewrite oA -defN TI_cardMg // mulKn. +exists (P :^ x^-1)%G; first by rewrite pHallJ ?groupV. +by rewrite normJ -sub_conjg -defB. +Qed. + +Lemma sol_coprime_Sylow_trans A G : + solvable A -> A \subset 'N(G) -> coprime #|G| #|A| -> + [transitive 'C_G(A), on [set P in 'Syl_p(G) | A \subset 'N(P)] | 'JG]. +Proof. +move=> solA nGA coGA; pose AG := A <*> G; set FpA := finset _. +have nG_AG: AG \subset 'N(G) by rewrite join_subG nGA normG. +have [P sylP nPA] := sol_coprime_Sylow_exists solA nGA coGA. +pose N := 'N_AG(P); have sAN: A \subset N by rewrite subsetI joing_subl. +have trNPA: A :^: AG ::&: N = A :^: N. + pose NG := 'N_G(P); have sNG_G : NG \subset G := subsetIl _ _. + have nNGA: A \subset 'N(NG) by rewrite normsI ?norms_norm. + apply/setP=> Ax; apply/setIdP/imsetP=> [[]|[x Nx ->{Ax}]]; last first. + by rewrite conj_subG //; case/setIP: Nx => AGx; rewrite mem_imset. + have ->: N = A <*> NG by rewrite /N /AG !norm_joinEl // -group_modl. + have coNG_A := coprimeSg sNG_G coGA; case/imsetP=> x AGx ->{Ax}. + case/SchurZassenhaus_trans_actsol; rewrite ?cardJg // => y Ny /= ->. + by exists y; rewrite // mem_gen 1?inE ?Ny ?orbT. +have{trNPA}: [transitive 'N_AG(A), on FpA | 'JG]. + have ->: FpA = 'Fix_('Syl_p(G) | 'JG)(A). + by apply/setP=> Q; rewrite 4!inE afixJG. + have SylP : P \in 'Syl_p(G) by rewrite inE. + apply/(trans_subnorm_fixP _ SylP); rewrite ?astab1JG //. + rewrite (atrans_supgroup _ (Syl_trans _ _)) ?joing_subr //= -/AG. + by apply/actsP=> x /= AGx Q /=; rewrite !inE -{1}(normsP nG_AG x) ?pHallJ2. +rewrite {1}/AG norm_joinEl // -group_modl ?normG ?coprime_norm_cent //=. +rewrite -cent_joinEr ?subsetIr // => trC_FpA. +have FpA_P: P \in FpA by rewrite !inE sylP. +apply/(subgroup_transitiveP FpA_P _ trC_FpA); rewrite ?joing_subr //=. +rewrite astab1JG cent_joinEr ?subsetIr // -group_modl // -mulgA. +by congr (_ * _); rewrite mulSGid ?subsetIl. +Qed. + +Lemma sol_coprime_Sylow_subset A G X : + A \subset 'N(G) -> coprime #|G| #|A| -> solvable A -> + X \subset G -> p.-group X -> A \subset 'N(X) -> + exists P : {group gT}, [/\ p.-Sylow(G) P, A \subset 'N(P) & X \subset P]. +Proof. +move=> nGA coGA solA sXG pX nXA. +pose nAp (Q : {group gT}) := [&& p.-group Q, Q \subset G & A \subset 'N(Q)]. +have: nAp X by exact/and3P. +case/maxgroup_exists=> R; case/maxgroupP; case/and3P=> pR sRG nRA maxR sXR. +have [P sylP sRP]:= Sylow_superset sRG pR. +suffices defP: P :=: R by exists P; rewrite sylP defP. +case/and3P: sylP => sPG pP _; apply: (nilpotent_sub_norm (pgroup_nil pP)) => //. +pose N := 'N_G(R); have{sPG} sPN_N: 'N_P(R) \subset N by exact: setSI. +apply: norm_sub_max_pgroup (pgroupS (subsetIl _ _) pP) sPN_N (subsetIr _ _). +have nNA: A \subset 'N(N) by rewrite normsI ?norms_norm. +have coNA: coprime #|N| #|A| by apply: coprimeSg coGA; rewrite subsetIl. +have{solA coNA} [Q sylQ nQA] := sol_coprime_Sylow_exists solA nNA coNA. +suffices defQ: Q :=: R by rewrite max_pgroup_Sylow -{2}defQ. +apply: maxR; first by apply/and3P; case/and3P: sylQ; rewrite subsetI; case/andP. +by apply: normal_sub_max_pgroup (Hall_max sylQ) pR _; rewrite normal_subnorm. +Qed. + +End SylowSolvableAct. diff --git a/mathcomp/solvable/jordanholder.v b/mathcomp/solvable/jordanholder.v new file mode 100644 index 0000000..bc7bec2 --- /dev/null +++ b/mathcomp/solvable/jordanholder.v @@ -0,0 +1,681 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path choice fintype. +Require Import bigop finset fingroup morphism automorphism quotient action. +Require Import gseries. + +(******************************************************************************) +(* This files establishes Jordan-Holder theorems for finite groups. These *) +(* theorems state the uniqueness up to permutation and isomorphism for the *) +(* series of quotient built from the successive elements of any composition *) +(* series of the same group. These quotients are also called factors of the *) +(* composition series. To avoid the heavy use of highly polymorphic lists *) +(* describing these quotient series, we introduce sections. *) +(* This library defines: *) +(* (G1 / G2)%sec == alias for the pair (G1, G2) of groups in the same *) +(* finGroupType, coerced to the actual quotient group*) +(* group G1 / G2. We call this pseudo-quotient a *) +(* section of G1 and G2. *) +(* section_isog s1 s2 == s1 and s2 respectively coerce to isomorphic *) +(* quotient groups. *) +(* section_repr s == canonical representative of the isomorphism class *) +(* of the section s. *) +(* mksrepr G1 G2 == canonical representative of the isomorphism class *) +(* of (G1 / G2)%sec. *) +(* mkfactors G s == if s is [:: s1, s2, ..., sn], constructs the list *) +(* [:: mksrepr G s1, mksrepr s1 s2, ..., mksrepr sn-1 sn] *) +(* comps G s == s is a composition series for G i.e. s is a *) +(* decreasing sequence of subgroups of G *) +(* in which two adjacent elements are maxnormal one *) +(* in the other and the last element of s is 1. *) +(* Given aT and rT two finGroupTypes, (D : {group rT}), (A : {group aT}) and *) +(* (to : groupAction A D) an external action. *) +(* maxainv to B C == C is a maximal proper normal subgroup of B *) +(* invariant by (the external action of A via) to. *) +(* asimple to B == the maximal proper normal subgroup of B invariant *) +(* by the external action to is trivial. *) +(* acomps to G s == s is a composition series for G invariant by to, *) +(* i.e. s is a decreasing sequence of subgroups of G *) +(* in which two adjacent elements are maximally *) +(* invariant by to one in the other and the *) +(* last element of s is 1. *) +(* We prove two versions of the result: *) +(* - JordanHolderUniqueness establishes the uniqueness up to permutation *) +(* and isomorphism of the lists of factors in composition series of a *) +(* given group. *) +(* - StrongJordanHolderUniqueness extends the result to composition series *) +(* invariant by an external group action. *) +(* See also "The Rooster and the Butterflies", proceedings of Calculemus 2013,*) +(* by Assia Mahboubi. *) +(******************************************************************************) + + +Import GroupScope. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Inductive section (gT : finGroupType) := GSection of {group gT} * {group gT}. + +Delimit Scope section_scope with sec. +Bind Scope section_scope with section. + +Definition mkSec (gT : finGroupType) (G1 G2 : {group gT}) := GSection (G1, G2). + +Infix "/" := mkSec : section_scope. + +Coercion pair_of_section gT (s : section gT) := let: GSection u := s in u. + +Coercion quotient_of_section gT (s : section gT) : GroupSet.sort _ := s.1 / s.2. + +Coercion section_group gT (s : section gT) : {group (coset_of s.2)} := + Eval hnf in [group of s]. + +Section Sections. + +Variables (gT : finGroupType). +Implicit Types (G : {group gT}) (s : section gT). + +Canonical section_subType := Eval hnf in [newType for @pair_of_section gT]. +Definition section_eqMixin := Eval hnf in [eqMixin of section gT by <:]. +Canonical section_eqType := Eval hnf in EqType (section gT) section_eqMixin. +Definition section_choiceMixin := [choiceMixin of section gT by <:]. +Canonical section_choiceType := + Eval hnf in ChoiceType (section gT) section_choiceMixin. +Definition section_countMixin := [countMixin of section gT by <:]. +Canonical section_countType := + Eval hnf in CountType (section gT) section_countMixin. +Canonical section_subCountType := Eval hnf in [subCountType of section gT]. +Definition section_finMixin := [finMixin of section gT by <:]. +Canonical section_finType := Eval hnf in FinType (section gT) section_finMixin. +Canonical section_subFinType := Eval hnf in [subFinType of section gT]. +Canonical section_group. + +(* Isomorphic sections *) + +Definition section_isog := [rel x y : section gT | x \isog y]. + +(* A witness of the isomorphism class of a section *) +Definition section_repr s := odflt (1 / 1)%sec (pick (section_isog ^~ s)). + +Definition mksrepr G1 G2 := section_repr (mkSec G1 G2). + +Lemma section_reprP s : section_repr s \isog s. +Proof. +by rewrite /section_repr; case: pickP => //= /(_ s); rewrite isog_refl. +Qed. + +Lemma section_repr_isog s1 s2 : + s1 \isog s2 -> section_repr s1 = section_repr s2. +Proof. +by move=> iso12; congr (odflt _ _); apply: eq_pick => s; exact: isog_transr. +Qed. + +Definition mkfactors (G : {group gT}) (s : seq {group gT}) := + map section_repr (pairmap (@mkSec _) G s). + +End Sections. + +Section CompositionSeries. + +Variable gT : finGroupType. +Local Notation gTg := {group gT}. +Implicit Types (G : gTg) (s : seq gTg). + +Local Notation compo := [rel x y : {set gT} | maxnormal y x x]. + +Definition comps G s := ((last G s) == 1%G) && compo.-series G s. + +Lemma compsP G s : + reflect (last G s = 1%G /\ path [rel x y : gTg | maxnormal y x x] G s) + (comps G s). +Proof. by apply: (iffP andP) => [] [/eqP]. Qed. + +Lemma trivg_comps G s : comps G s -> (G :==: 1) = (s == [::]). +Proof. +case/andP=> ls cs; apply/eqP/eqP=> [G1 | s1]; last first. + by rewrite s1 /= in ls; apply/eqP. +by case: s {ls} cs => //= H s /andP[/maxgroupp]; rewrite G1 /proper sub1G andbF. +Qed. + +Lemma comps_cons G H s : comps G (H :: s) -> comps H s. +Proof. by case/andP => /= ls /andP[_]; rewrite /comps ls. Qed. + +Lemma simple_compsP G s : comps G s -> reflect (s = [:: 1%G]) (simple G). +Proof. +move=> cs; apply: (iffP idP) => [|s1]; last first. + by rewrite s1 /comps eqxx /= andbT -simple_maxnormal in cs. +case: s cs => [/trivg_comps/eqP-> | H s]; first by case/simpleP; rewrite eqxx. +rewrite [comps _ _]andbCA /= => /andP[/maxgroupp maxH /trivg_comps/esym nil_s]. +rewrite simple_maxnormal => /maxgroupP[_ simG]. +have H1: H = 1%G by apply/val_inj/simG; rewrite // sub1G. +by move: nil_s; rewrite H1 eqxx => /eqP->. +Qed. + +Lemma exists_comps (G : gTg) : exists s, comps G s. +Proof. +elim: {G} #|G| {1 3}G (leqnn #|G|) => [G | n IHn G cG]. + by rewrite leqNgt cardG_gt0. +have [sG | nsG] := boolP (simple G). + by exists [:: 1%G]; rewrite /comps eqxx /= -simple_maxnormal andbT. +have [-> | ntG] := eqVneq G 1%G; first by exists [::]; rewrite /comps eqxx. +have [N maxN] := ex_maxnormal_ntrivg ntG. +have [|s /andP[ls cs]] := IHn N. + by rewrite -ltnS (leq_trans _ cG) // proper_card // (maxnormal_proper maxN). +by exists (N :: s); exact/and3P. +Qed. + +(******************************************************************************) +(* The factors associated to two composition series of the same group are *) +(* the same up to isomorphism and permutation *) +(******************************************************************************) + +Lemma JordanHolderUniqueness (G : gTg) (s1 s2 : seq gTg) : + comps G s1 -> comps G s2 -> perm_eq (mkfactors G s1) (mkfactors G s2). +Proof. +elim: {G}#|G| {-2}G (leqnn #|G|) => [|n Hi] G cG in s1 s2 * => cs1 cs2. + by rewrite leqNgt cardG_gt0 in cG. +have [G1 | ntG] := boolP (G :==: 1). + have -> : s1 = [::] by apply/eqP; rewrite -(trivg_comps cs1). + have -> : s2 = [::] by apply/eqP; rewrite -(trivg_comps cs2). + by rewrite /= perm_eq_refl. +have [sG | nsG] := boolP (simple G). + by rewrite (simple_compsP cs1 sG) (simple_compsP cs2 sG) perm_eq_refl. +case es1: s1 cs1 => [|N1 st1] cs1. + by move: (trivg_comps cs1); rewrite eqxx; move/negP:ntG. +case es2: s2 cs2 => [|N2 st2] cs2 {s1 es1}. + by move: (trivg_comps cs2); rewrite eqxx; move/negP:ntG. +case/andP: cs1 => /= lst1; case/andP=> maxN_1 pst1. +case/andP: cs2 => /= lst2; case/andP=> maxN_2 pst2. +have cN1 : #|N1| <= n. + by rewrite -ltnS (leq_trans _ cG) ?proper_card ?(maxnormal_proper maxN_1). +have cN2 : #|N2| <= n. + by rewrite -ltnS (leq_trans _ cG) ?proper_card ?(maxnormal_proper maxN_2). +case: (N1 =P N2) {s2 es2} => [eN12 |]. + by rewrite eN12 /= perm_cons Hi // /comps ?lst2 //= -eN12 lst1. +move/eqP; rewrite -val_eqE /=; move/eqP=> neN12. +have nN1G : N1 <| G by apply: maxnormal_normal. +have nN2G : N2 <| G by apply: maxnormal_normal. +pose N := (N1 :&: N2)%G. +have nNG : N <| G. + by rewrite /normal subIset ?(normal_sub nN1G) //= normsI ?normal_norm. +have iso1 : (G / N1)%G \isog (N2 / N)%G. + rewrite isog_sym /= -(maxnormalM maxN_1 maxN_2) //. + rewrite (@normC _ N1 N2) ?(subset_trans (normal_sub nN1G)) ?normal_norm //. + by rewrite weak_second_isog ?(subset_trans (normal_sub nN2G)) ?normal_norm. +have iso2 : (G / N2)%G \isog (N1 / N)%G. + rewrite isog_sym /= -(maxnormalM maxN_1 maxN_2) // setIC. + by rewrite weak_second_isog ?(subset_trans (normal_sub nN1G)) ?normal_norm. +have [sN /andP[lsN csN]] := exists_comps N. +have i1 : perm_eq (mksrepr G N1 :: mkfactors N1 st1) + [:: mksrepr G N1, mksrepr N1 N & mkfactors N sN]. + rewrite perm_cons -[mksrepr _ _ :: _]/(mkfactors N1 [:: N & sN]). + apply: Hi=> //; rewrite /comps ?lst1 //= lsN csN andbT /=. + rewrite -quotient_simple. + by rewrite -(isog_simple iso2) quotient_simple. + by rewrite (normalS (subsetIl N1 N2) (normal_sub nN1G)). +have i2 : perm_eq (mksrepr G N2 :: mkfactors N2 st2) + [:: mksrepr G N2, mksrepr N2 N & mkfactors N sN]. + rewrite perm_cons -[mksrepr _ _ :: _]/(mkfactors N2 [:: N & sN]). + apply: Hi=> //; rewrite /comps ?lst2 //= lsN csN andbT /=. + rewrite -quotient_simple. + by rewrite -(isog_simple iso1) quotient_simple. + by rewrite (normalS (subsetIr N1 N2) (normal_sub nN2G)). +pose fG1 := [:: mksrepr G N1, mksrepr N1 N & mkfactors N sN]. +pose fG2 := [:: mksrepr G N2, mksrepr N2 N & mkfactors N sN]. +have i3 : perm_eq fG1 fG2. + rewrite (@perm_catCA _ [::_] [::_]) /mksrepr. + rewrite (@section_repr_isog _ (mkSec _ _) (mkSec _ _) iso1). + rewrite -(@section_repr_isog _ (mkSec _ _) (mkSec _ _) iso2). + exact: perm_eq_refl. +apply: (perm_eq_trans i1); apply: (perm_eq_trans i3); rewrite perm_eq_sym. +apply: perm_eq_trans i2; exact: perm_eq_refl. +Qed. + +End CompositionSeries. + +(******************************************************************************) +(* Helper lemmas for group actions. *) +(******************************************************************************) + +Section MoreGroupAction. + +Variables (aT rT : finGroupType). +Variables (A : {group aT}) (D : {group rT}). +Variable to : groupAction A D. + +Lemma gactsP (G : {set rT}) : reflect {acts A, on G | to} [acts A, on G | to]. +Proof. +apply: (iffP idP) => [nGA x|nGA]; first exact: acts_act. +apply/subsetP=> a Aa; rewrite !inE; rewrite Aa. +by apply/subsetP=> x; rewrite inE nGA. +Qed. + +Lemma gactsM (N1 N2 : {set rT}) : + N1 \subset D -> N2 \subset D -> + [acts A, on N1 | to] -> [acts A, on N2 | to] -> [acts A, on N1 * N2 | to]. +Proof. +move=> sN1D sN2D aAN1 aAN2; apply/gactsP=> x Ax y. +apply/idP/idP; case/mulsgP=> y1 y2 N1y1 N2y2 e. + move: (actKin to Ax y); rewrite e; move<-. + rewrite gactM ?groupV ?(subsetP sN1D y1) ?(subsetP sN2D) //. + by apply: mem_mulg; rewrite ?(gactsP _ aAN1) ?(gactsP _ aAN2) // groupV. +rewrite e gactM // ?(subsetP sN1D y1) ?(subsetP sN2D) //. +by apply: mem_mulg; rewrite ?(gactsP _ aAN1) // ?(gactsP _ aAN2). +Qed. + +Lemma gactsI (N1 N2 : {set rT}) : + [acts A, on N1 | to] -> [acts A, on N2 | to] -> [acts A, on N1 :&: N2 | to]. +Proof. +move=> aAN1 aAN2. +apply/subsetP=> x Ax; rewrite !inE Ax /=; apply/subsetP=> y Ny; rewrite inE. +case/setIP: Ny=> N1y N2y; rewrite inE ?astabs_act ?N1y ?N2y //. +- by move/subsetP: aAN2; move/(_ x Ax). +- by move/subsetP: aAN1; move/(_ x Ax). +Qed. + +Lemma gastabsP (S : {set rT}) (a : aT) : + a \in A -> reflect (forall x, (to x a \in S) = (x \in S)) (a \in 'N(S | to)). +Proof. +move=> Aa; apply: (iffP idP) => [nSa x|nSa]; first exact: astabs_act. +by rewrite !inE Aa; apply/subsetP=> x; rewrite inE nSa. +Qed. + +End MoreGroupAction. + +(******************************************************************************) +(* Helper lemmas for quotient actions. *) +(******************************************************************************) + +Section MoreQuotientAction. + +Variables (aT rT : finGroupType). +Variables (A : {group aT})(D : {group rT}). +Variable to : groupAction A D. + +Lemma qact_dom_doms (H : {group rT}) : H \subset D -> qact_dom to H \subset A. +Proof. +by move=> sHD; apply/subsetP=> x; rewrite qact_domE // inE; case/andP. +Qed. + +Lemma acts_qact_doms (H : {group rT}) : + H \subset D -> [acts A, on H | to] -> qact_dom to H :=: A. +Proof. +move=> sHD aH; apply/eqP; rewrite eqEsubset; apply/andP. +split; first exact: qact_dom_doms. +apply/subsetP=> x Ax; rewrite qact_domE //; apply/gastabsP=> //. +by move/gactsP: aH; move/(_ x Ax). +Qed. + +Lemma qacts_cosetpre (H : {group rT}) (K' : {group coset_of H}) : + H \subset D -> [acts A, on H | to] -> + [acts qact_dom to H, on K' | to / H] -> + [acts A, on coset H @*^-1 K' | to]. +Proof. +move=> sHD aH aK'; apply/subsetP=> x Ax; move: (Ax) (subsetP aK'). +rewrite -{1}(acts_qact_doms sHD aH) => qdx; move/(_ x qdx) => nx. +rewrite !inE Ax; apply/subsetP=> y; case/morphpreP=> Ny /= K'Hy; rewrite inE. +apply/morphpreP; split; first by rewrite acts_qact_dom_norm. +by move/gastabsP: nx; move/(_ qdx (coset H y)); rewrite K'Hy qactE. +Qed. + +Lemma qacts_coset (H K : {group rT}) : + H \subset D -> [acts A, on K | to] -> + [acts qact_dom to H, on (coset H) @* K | to / H]. +Proof. +move=> sHD aK. +apply/subsetP=> x qdx; rewrite inE qdx inE; apply/subsetP=> y. +case/morphimP=> z Nz Kz /= e; rewrite e inE qactE // mem_imset // inE. +move/gactsP: aK; move/(_ x (subsetP (qact_dom_doms sHD) _ qdx) z); rewrite Kz. +move->; move/acts_act: (acts_qact_dom to H); move/(_ x qdx z). +by rewrite Nz andbT. +Qed. + +End MoreQuotientAction. + +Section StableCompositionSeries. + +Variables (aT rT : finGroupType). +Variables (D : {group rT})(A : {group aT}). +Variable to : groupAction A D. + +Definition maxainv (B C : {set rT}) := + [max C of H | + [&& (H <| B), ~~ (B \subset H) & [acts A, on H | to]]]. + +Section MaxAinvProps. + +Variables K N : {group rT}. + +Lemma maxainv_norm : maxainv K N -> N <| K. +Proof. by move/maxgroupp; case/andP. Qed. + +Lemma maxainv_proper : maxainv K N -> N \proper K. +Proof. +by move/maxgroupp; case/andP; rewrite properE; move/normal_sub->; case/andP. +Qed. + +Lemma maxainv_sub : maxainv K N -> N \subset K. +Proof. move=> h; apply: proper_sub; exact: maxainv_proper. Qed. + +Lemma maxainv_ainvar : maxainv K N -> A \subset 'N(N | to). +Proof. by move/maxgroupp; case/and3P. Qed. + +Lemma maxainvS : maxainv K N -> N \subset K. +Proof. by move=> pNN; rewrite proper_sub // maxainv_proper. Qed. + +Lemma maxainv_exists : K :!=: 1 -> {N : {group rT} | maxainv K N}. +Proof. +move=> nt; apply: ex_maxgroup. exists [1 rT]%G. +rewrite /= normal1 subG1 nt /=. +apply/subsetP=> a Da; rewrite !inE Da /= sub1set !inE. +by rewrite /= -actmE // morph1 eqxx. +Qed. + +End MaxAinvProps. + +Lemma maxainvM (G H K : {group rT}) : + H \subset D -> K \subset D -> maxainv G H -> maxainv G K -> + H :<>: K -> H * K = G. +Proof. +move: H K => N1 N2 sN1D sN2D pmN1 pmN2 neN12. +have cN12 : commute N1 N2. + apply: normC; apply: (subset_trans (maxainv_sub pmN1)). + by rewrite normal_norm ?maxainv_norm. +wlog nsN21 : G N1 N2 sN1D sN2D pmN1 pmN2 neN12 cN12/ ~~(N1 \subset N2). + move/eqP: (neN12); rewrite eqEsubset negb_and; case/orP=> ns; first by apply. + by rewrite cN12; apply=> //; apply: sym_not_eq. +have nP : N1 * N2 <| G by rewrite normalM ?maxainv_norm. +have sN2P : N2 \subset N1 * N2 by rewrite mulg_subr ?group1. +case/maxgroupP: (pmN1); case/andP=> nN1G pN1G mN1. +case/maxgroupP: (pmN2); case/andP=> nN2G pN2G mN2. +case/andP: pN1G=> nsGN1 ha1; case/andP: pN2G=> nsGN2 ha2. +case e : (G \subset N1 * N2). + by apply/eqP; rewrite eqEsubset e mulG_subG !normal_sub. +have: N1 <*> N2 = N2 by apply: mN2; rewrite /= ?comm_joingE // nP e /= gactsM. +by rewrite comm_joingE // => h; move: nsN21; rewrite -h mulg_subl. +Qed. + +Definition asimple (K : {set rT}) := maxainv K 1. + +Implicit Types (H K : {group rT}) (s : seq {group rT}). + +Lemma asimpleP K : + reflect [/\ K :!=: 1 + & forall H, H <| K -> [acts A, on H | to] -> H :=: 1 \/ H :=: K] + (asimple K). +Proof. +apply: (iffP idP). + case/maxgroupP; rewrite normal1 /=; case/andP=> nsK1 aK H1. + rewrite eqEsubset negb_and nsK1 /=; split => // H nHK ha. + case eHK : (H :==: K); first by right; apply/eqP. + left; apply: H1; rewrite ?sub1G // nHK; move/negbT: eHK. + by rewrite eqEsubset negb_and normal_sub //=; move->. +case=> ntK h; apply/maxgroupP; split. + move: ntK; rewrite eqEsubset sub1G andbT normal1; move->. + apply/subsetP=> a Da; rewrite !inE Da /= sub1set !inE. + by rewrite /= -actmE // morph1 eqxx. +move=> H /andP[nHK /andP[nsKH ha]] _. +case: (h _ nHK ha)=> // /eqP; rewrite eqEsubset. +by rewrite (negbTE nsKH) andbF. +Qed. + +Definition acomps K s := + ((last K s) == 1%G) && path [rel x y : {group rT} | maxainv x y] K s. + +Lemma acompsP K s : + reflect (last K s = 1%G /\ path [rel x y : {group rT} | maxainv x y] K s) + (acomps K s). +Proof. by apply: (iffP andP); case; move/eqP. Qed. + +Lemma trivg_acomps K s : acomps K s -> (K :==: 1) = (s == [::]). +Proof. +case/andP=> ls cs; apply/eqP/eqP; last first. + by move=> se; rewrite se /= in ls; apply/eqP. +move=> G1; case: s ls cs => // H s _ /=; case/andP; case/maxgroupP. +by rewrite G1 sub1G andbF. +Qed. + +Lemma acomps_cons K H s : acomps K (H :: s) -> acomps H s. +Proof. by case/andP => /= ls; case/andP=> _ p; rewrite /acomps ls. Qed. + +Lemma asimple_acompsP K s : acomps K s -> reflect (s = [:: 1%G]) (asimple K). +Proof. +move=> cs; apply: (iffP idP); last first. + by move=> se; move: cs; rewrite se /=; case/andP=> /=; rewrite andbT. +case: s cs. + by rewrite /acomps /= andbT; move/eqP->; case/asimpleP; rewrite eqxx. +move=> H s cs sG; apply/eqP. +rewrite eqseq_cons -(trivg_acomps (acomps_cons cs)) andbC andbb. +case/acompsP: cs => /= ls; case/andP=> mH ps. +case/maxgroupP: sG; case/and3P => _ ntG _ ->; rewrite ?sub1G //. +rewrite (maxainv_norm mH); case/andP: (maxainv_proper mH)=> _ ->. +exact: (maxainv_ainvar mH). +Qed. + +Lemma exists_acomps K : exists s, acomps K s. +Proof. +elim: {K} #|K| {1 3}K (leqnn #|K|) => [K | n Hi K cK]. + by rewrite leqNgt cardG_gt0. +case/orP: (orbN (asimple K)) => [sK | nsK]. + by exists [:: (1%G : {group rT})]; rewrite /acomps eqxx /= andbT. +case/orP: (orbN (K :==: 1))=> [tK | ntK]. + by exists (Nil _); rewrite /acomps /= andbT. +case: (maxainv_exists ntK)=> N pmN. +have cN: #|N| <= n. + by rewrite -ltnS (leq_trans _ cK) // proper_card // (maxainv_proper pmN). +case: (Hi _ cN)=> s; case/andP=> lasts ps; exists [:: N & s]; rewrite /acomps. +by rewrite last_cons lasts /= pmN. +Qed. + +End StableCompositionSeries. + +Arguments Scope maxainv + [_ _ Group_scope Group_scope groupAction_scope group_scope group_scope]. +Arguments Scope asimple + [_ _ Group_scope Group_scope groupAction_scope group_scope]. + +Section StrongJordanHolder. + +Section AuxiliaryLemmas. + +Variables aT rT : finGroupType. +Variables (A : {group aT}) (D : {group rT}) (to : groupAction A D). + +Lemma maxainv_asimple_quo (G H : {group rT}) : + H \subset D -> maxainv to G H -> asimple (to / H) (G / H). +Proof. +move=> sHD /maxgroupP[/and3P[nHG pHG aH] Hmax]. +apply/asimpleP; split; first by rewrite -subG1 quotient_sub1 ?normal_norm. +move=> K' nK'Q aK'. +have: (K' \proper (G / H)) || (G / H == K'). + by rewrite properE eqEsubset andbC (normal_sub nK'Q) !andbT orbC orbN. +case/orP=> [ pHQ | eQH]; last by right; apply sym_eq; apply/eqP. +left; pose K := ((coset H) @*^-1 K')%G. +have eK'I : K' \subset (coset H) @* 'N(H). + by rewrite (subset_trans (normal_sub nK'Q)) ?morphimS ?normal_norm. +have eKK' : K' :=: K / H by rewrite /(K / H) morphpreK //=. +suff eKH : K :=: H by rewrite -trivg_quotient eKK' eKH. +have sHK : H \subset K by rewrite -ker_coset kerE morphpreS // sub1set group1. +apply: Hmax => //; apply/and3P; split; last exact: qacts_cosetpre. + by rewrite -(quotientGK nHG) cosetpre_normal. +by move: (proper_subn pHQ); rewrite sub_morphim_pre ?normal_norm. +Qed. + + +Lemma asimple_quo_maxainv (G H : {group rT}) : + H \subset D -> G \subset D -> [acts A, on G | to] -> [acts A, on H | to] -> + H <| G -> asimple (to / H) (G / H) -> + maxainv to G H. +Proof. +move=> sHD sGD aG aH nHG /asimpleP[ntQ maxQ]; apply/maxgroupP; split. + by rewrite nHG -quotient_sub1 ?normal_norm // subG1 ntQ. +move=> K /and3P[nKG nsGK aK] sHK. +pose K' := (K / H)%G. +have K'dQ : K' <| (G / H)%G by apply: morphim_normal. +have nKH : H <| K by rewrite (normalS _ _ nHG) // normal_sub. +have: K' :=: 1%G \/ K' :=: (G / H). + apply: (maxQ K' K'dQ) => /=. + apply/subsetP=> x Adx. rewrite inE Adx /= inE. apply/subsetP=> y. + rewrite quotientE; case/morphimP=> z Nz Kz ->; rewrite /= !inE qactE //. + have ntoyx : to z x \in 'N(H) by rewrite (acts_qact_dom_norm Adx). + apply/morphimP; exists (to z x) => //. + suff h: qact_dom to H \subset A. + by rewrite astabs_act // (subsetP aK) //; apply: (subsetP h). + by apply/subsetP=> t; rewrite qact_domE // inE; case/ andP. +case; last first. + move/quotient_injG; rewrite !inE /=; move/(_ nKH nHG)=> c; move: nsGK. + by rewrite c subxx. +rewrite /= -trivg_quotient; move=> tK'; apply:(congr1 (@gval _)); move: tK'. +by apply: (@quotient_injG _ H); rewrite ?inE /= ?normal_refl. +Qed. + +Lemma asimpleI (N1 N2 : {group rT}) : + N2 \subset 'N(N1) -> N1 \subset D -> + [acts A, on N1 | to] -> [acts A, on N2 | to] -> + asimple (to / N1) (N2 / N1) -> + asimple (to / (N2 :&: N1)) (N2 / (N2 :&: N1)). +Proof. +move=> nN21 sN1D aN1 aN2 /asimpleP[ntQ1 max1]. +have [f1 [f1e f1ker f1pre f1im]] := restrmP (coset_morphism N1) nN21. +have hf2' : N2 \subset 'N(N2 :&: N1) by apply: normsI => //; rewrite normG. +have hf2'' : 'ker (coset (N2 :&: N1)) \subset 'ker f1. + by rewrite f1ker !ker_coset. +pose f2 := factm_morphism hf2'' hf2'. +apply/asimpleP; split. + rewrite /= setIC; apply/negP; move: (second_isog nN21); move/isog_eq1->. + by apply/negP. +move=> H nHQ2 aH; pose K := f2 @* H. +have nKQ1 : K <| N2 / N1. + rewrite (_ : N2 / N1 = f2 @* (N2 / (N2 :&: N1))) ?morphim_normal //. + by rewrite morphim_factm f1im. +have sqA : qact_dom to N1 \subset A. + by apply/subsetP=> t; rewrite qact_domE // inE; case/andP. +have nNN2 : (N2 :&: N1) <| N2. + rewrite /normal subsetIl; apply: normsI => //; exact: normG. +have aKQ1 : [acts qact_dom to N1, on K | to / N1]. + pose H':= coset (N2 :&: N1)@*^-1 H. + have eHH' : H :=: H' / (N2 :&: N1) by rewrite cosetpreK. + have -> : K :=: f1 @* H' by rewrite /K eHH' morphim_factm. + have sH'N2 : H' \subset N2. + rewrite /H' eHH' quotientGK ?normal_cosetpre //=. + by rewrite sub_cosetpre_quo ?normal_sub. + have -> : f1 @* H' = coset N1 @* H' by rewrite f1im //=. + apply: qacts_coset => //; apply: qacts_cosetpre => //; last exact: gactsI. + by apply: (subset_trans (subsetIr _ _)). +have injf2 : 'injm f2. + by rewrite ker_factm f1ker /= ker_coset /= subG1 /= -quotientE trivg_quotient. +have iHK : H \isog K. + apply/isogP; pose f3 := restrm_morphism (normal_sub nHQ2) f2. + by exists f3; rewrite 1?injm_restrm // morphim_restrm setIid. +case: (max1 _ nKQ1 aKQ1). + by move/eqP; rewrite -(isog_eq1 iHK); move/eqP->; left. +move=> he /=; right; apply/eqP; rewrite eqEcard normal_sub //=. +move: (second_isog nN21); rewrite setIC; move/card_isog->; rewrite -he. +by move/card_isog: iHK=> <-; rewrite leqnn. +Qed. + +End AuxiliaryLemmas. + +Variables (aT rT : finGroupType). +Variables (A : {group aT}) (D : {group rT}) (to : groupAction A D). + +(******************************************************************************) +(* The factors associated to two A-stable composition series of the same *) +(* group are the same up to isomorphism and permutation *) +(******************************************************************************) + +Lemma StrongJordanHolderUniqueness (G : {group rT}) (s1 s2 : seq {group rT}) : + G \subset D -> acomps to G s1 -> acomps to G s2 -> + perm_eq (mkfactors G s1) (mkfactors G s2). +Proof. +elim: {G} #|G| {-2}G (leqnn #|G|) => [|n Hi] G cG in s1 s2 * => hsD cs1 cs2. + by rewrite leqNgt cardG_gt0 in cG. +case/orP: (orbN (G :==: 1)) => [tG | ntG]. + have -> : s1 = [::] by apply/eqP; rewrite -(trivg_acomps cs1). + have -> : s2 = [::] by apply/eqP; rewrite -(trivg_acomps cs2). + by rewrite /= perm_eq_refl. +case/orP: (orbN (asimple to G))=> [sG | nsG]. + have -> : s1 = [:: 1%G ] by apply/(asimple_acompsP cs1). + have -> : s2 = [:: 1%G ] by apply/(asimple_acompsP cs2). + by rewrite /= perm_eq_refl. +case es1: s1 cs1 => [|N1 st1] cs1. + by move: (trivg_comps cs1); rewrite eqxx; move/negP:ntG. +case es2: s2 cs2 => [|N2 st2] cs2 {s1 es1}. + by move: (trivg_comps cs2); rewrite eqxx; move/negP:ntG. +case/andP: cs1 => /= lst1; case/andP=> maxN_1 pst1. +case/andP: cs2 => /= lst2; case/andP=> maxN_2 pst2. +have sN1D : N1 \subset D. + by apply: subset_trans hsD; apply: maxainv_sub maxN_1. +have sN2D : N2 \subset D. + by apply: subset_trans hsD; apply: maxainv_sub maxN_2. +have cN1 : #|N1| <= n. + by rewrite -ltnS (leq_trans _ cG) ?proper_card ?(maxainv_proper maxN_1). +have cN2 : #|N2| <= n. + by rewrite -ltnS (leq_trans _ cG) ?proper_card ?(maxainv_proper maxN_2). +case: (N1 =P N2) {s2 es2} => [eN12 |]. + by rewrite eN12 /= perm_cons Hi // /acomps ?lst2 //= -eN12 lst1. +move/eqP; rewrite -val_eqE /=; move/eqP=> neN12. +have nN1G : N1 <| G by apply: (maxainv_norm maxN_1). +have nN2G : N2 <| G by apply: (maxainv_norm maxN_2). +pose N := (N1 :&: N2)%G. +have nNG : N <| G. + by rewrite /normal subIset ?(normal_sub nN1G) //= normsI ?normal_norm. +have iso1 : (G / N1)%G \isog (N2 / N)%G. + rewrite isog_sym /= -(maxainvM _ _ maxN_1 maxN_2) //. + rewrite (@normC _ N1 N2) ?(subset_trans (normal_sub nN1G)) ?normal_norm //. + by rewrite weak_second_isog ?(subset_trans (normal_sub nN2G)) ?normal_norm. +have iso2 : (G / N2)%G \isog (N1 / N)%G. + rewrite isog_sym /= -(maxainvM _ _ maxN_1 maxN_2) // setIC. + by rewrite weak_second_isog ?(subset_trans (normal_sub nN1G)) ?normal_norm. +case: (exists_acomps to N)=> sN; case/andP=> lsN csN. +have aN1 : [acts A, on N1 | to]. + by case/maxgroupP: maxN_1; case/and3P. +have aN2 : [acts A, on N2 | to]. + by case/maxgroupP: maxN_2; case/and3P. +have nNN1 : N <| N1. + by apply: (normalS _ _ nNG); rewrite ?subsetIl ?normal_sub. +have nNN2 : N <| N2. + by apply: (normalS _ _ nNG); rewrite ?subsetIr ?normal_sub. +have aN : [ acts A, on N1 :&: N2 | to]. + apply/subsetP=> x Ax; rewrite !inE Ax /=; apply/subsetP=> y Ny; rewrite inE. + case/setIP: Ny=> N1y N2y. rewrite inE ?astabs_act ?N1y ?N2y //. + by move/subsetP: aN2; move/(_ x Ax). + by move/subsetP: aN1; move/(_ x Ax). +have i1 : perm_eq (mksrepr G N1 :: mkfactors N1 st1) + [:: mksrepr G N1, mksrepr N1 N & mkfactors N sN]. + rewrite perm_cons -[mksrepr _ _ :: _]/(mkfactors N1 [:: N & sN]). + apply: Hi=> //; rewrite /acomps ?lst1 //= lsN csN andbT /=. + apply: asimple_quo_maxainv=> //; first by apply: subIset; rewrite sN1D. + apply: asimpleI => //. + apply: subset_trans (normal_norm nN2G); exact: normal_sub. + rewrite -quotientMidl (maxainvM _ _ maxN_2) //. + by apply: maxainv_asimple_quo. + by move=> e; apply: neN12. +have i2 : perm_eq (mksrepr G N2 :: mkfactors N2 st2) + [:: mksrepr G N2, mksrepr N2 N & mkfactors N sN]. + rewrite perm_cons -[mksrepr _ _ :: _]/(mkfactors N2 [:: N & sN]). + apply: Hi=> //; rewrite /acomps ?lst2 //= lsN csN andbT /=. + apply: asimple_quo_maxainv=> //; first by apply: subIset; rewrite sN1D. + have e : N1 :&: N2 :=: N2 :&: N1 by rewrite setIC. + rewrite (group_inj (setIC N1 N2)); apply: asimpleI => //. + apply: subset_trans (normal_norm nN1G); exact: normal_sub. + rewrite -quotientMidl (maxainvM _ _ maxN_1) //. + exact: maxainv_asimple_quo. +pose fG1 := [:: mksrepr G N1, mksrepr N1 N & mkfactors N sN]. +pose fG2 := [:: mksrepr G N2, mksrepr N2 N & mkfactors N sN]. +have i3 : perm_eq fG1 fG2. + rewrite (@perm_catCA _ [::_] [::_]) /mksrepr. + rewrite (@section_repr_isog _ (mkSec _ _) (mkSec _ _) iso1). + rewrite -(@section_repr_isog _ (mkSec _ _) (mkSec _ _) iso2). + exact: perm_eq_refl. +apply: (perm_eq_trans i1); apply: (perm_eq_trans i3); rewrite perm_eq_sym. +apply: perm_eq_trans i2; exact: perm_eq_refl. +Qed. + +End StrongJordanHolder. + + + + + diff --git a/mathcomp/solvable/maximal.v b/mathcomp/solvable/maximal.v new file mode 100644 index 0000000..7b50dc9 --- /dev/null +++ b/mathcomp/solvable/maximal.v @@ -0,0 +1,1656 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +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]. \ No newline at end of file diff --git a/mathcomp/solvable/nilpotent.v b/mathcomp/solvable/nilpotent.v new file mode 100644 index 0000000..5b271de --- /dev/null +++ b/mathcomp/solvable/nilpotent.v @@ -0,0 +1,755 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path fintype div. +Require Import bigop prime finset fingroup morphism automorphism quotient. +Require Import commutator gproduct gfunctor center gseries cyclic. + +(******************************************************************************) +(* This file defines nilpotent and solvable groups, and give some of their *) +(* elementary properties; more will be added later (e.g., the nilpotence of *) +(* p-groups in sylow.v, or the fact that minimal normal subgroups of solvable *) +(* groups are elementary abelian in maximal.v). This file defines: *) +(* nilpotent G == G is nilpotent, i.e., [~: H, G] is a proper subgroup of H *) +(* for all nontrivial H <| G. *) +(* solvable G == G is solvable, i.e., H^`(1) is a proper subgroup of H for *) +(* all nontrivial subgroups H of G. *) +(* 'L_n(G) == the nth term of the lower central series, namely *) +(* [~: G, ..., G] (n Gs) if n > 0, with 'L_0(G) = G. *) +(* G is nilpotent iff 'L_n(G) = 1 for some n. *) +(* 'Z_n(G) == the nth term of the upper central series, i.e., *) +(* with 'Z_0(G) = 1, 'Z_n.+1(G) / 'Z_n(G) = 'Z(G / 'Z_n(G)). *) +(* nil_class G == the nilpotence class of G, i.e., the least n such that *) +(* 'L_n.+1(G) = 1 (or, equivalently, 'Z_n(G) = G), if G is *) +(* nilpotent; we take nil_class G = #|G| when G is not *) +(* nilpotent, so nil_class G < #|G| iff G is nilpotent. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section SeriesDefs. + +Variables (n : nat) (gT : finGroupType) (A : {set gT}). + +Definition lower_central_at_rec := iter n (fun B => [~: B, A]) A. + +Definition upper_central_at_rec := iter n (fun B => coset B @*^-1 'Z(A / B)) 1. + +End SeriesDefs. + +(* By convention, the lower central series starts at 1 while the upper series *) +(* starts at 0 (sic). *) +Definition lower_central_at n := lower_central_at_rec n.-1. + +(* Note: 'nosimpl' MUST be used outside of a section -- the end of section *) +(* "cooking" destroys it. *) +Definition upper_central_at := nosimpl upper_central_at_rec. + +Arguments Scope lower_central_at [nat_scope _ group_scope]. +Arguments Scope upper_central_at [nat_scope _ group_scope]. + +Notation "''L_' n ( G )" := (lower_central_at n G) + (at level 8, n at level 2, format "''L_' n ( G )") : group_scope. + +Notation "''Z_' n ( G )" := (upper_central_at n G) + (at level 8, n at level 2, format "''Z_' n ( G )") : group_scope. + +Section PropertiesDefs. + +Variables (gT : finGroupType) (A : {set gT}). + +Definition nilpotent := + [forall (G : {group gT} | G \subset A :&: [~: G, A]), G :==: 1]. + +Definition nil_class := index 1 (mkseq (fun n => 'L_n.+1(A)) #|A|). + +Definition solvable := + [forall (G : {group gT} | G \subset A :&: [~: G, G]), G :==: 1]. + +End PropertiesDefs. + +Arguments Scope nilpotent [_ group_scope]. +Arguments Scope nil_class [_ group_scope]. +Arguments Scope solvable [_ group_scope]. +Prenex Implicits nil_class nilpotent solvable. + +Section NilpotentProps. + +Variable gT: finGroupType. +Implicit Types (A B : {set gT}) (G H : {group gT}). + +Lemma nilpotent1 : nilpotent [1 gT]. +Proof. by apply/forall_inP=> H; rewrite commG1 setIid -subG1. Qed. + +Lemma nilpotentS A B : B \subset A -> nilpotent A -> nilpotent B. +Proof. +move=> sBA nilA; apply/forall_inP=> H sHR. +have:= forallP nilA H; rewrite (subset_trans sHR) //. +by apply: subset_trans (setIS _ _) (setSI _ _); rewrite ?commgS. +Qed. + +Lemma nil_comm_properl G H A : + nilpotent G -> H \subset G -> H :!=: 1 -> A \subset 'N_G(H) -> + [~: H, A] \proper H. +Proof. +move=> nilG sHG ntH; rewrite subsetI properE; case/andP=> sAG nHA. +rewrite (subset_trans (commgS H (subset_gen A))) ?commg_subl ?gen_subG //. +apply: contra ntH => sHR; have:= forallP nilG H; rewrite subsetI sHG. +by rewrite (subset_trans sHR) ?commgS. +Qed. + +Lemma nil_comm_properr G A H : + nilpotent G -> H \subset G -> H :!=: 1 -> A \subset 'N_G(H) -> + [~: A, H] \proper H. +Proof. by rewrite commGC; apply: nil_comm_properl. Qed. + +Lemma centrals_nil (s : seq {group gT}) G : + G.-central.-series 1%G s -> last 1%G s = G -> nilpotent G. +Proof. +move=> cGs defG; apply/forall_inP=> H /subsetIP[sHG sHR]. +move: sHG; rewrite -{}defG -subG1 -[1]/(gval 1%G). +elim: s 1%G cGs => //= L s IHs K /andP[/and3P[sRK sKL sLG] /IHs sHL] sHs. +exact: subset_trans sHR (subset_trans (commSg _ (sHL sHs)) sRK). +Qed. + +End NilpotentProps. + +Section LowerCentral. + +Variable gT : finGroupType. +Implicit Types (A B : {set gT}) (G H : {group gT}). + +Lemma lcn0 A : 'L_0(A) = A. Proof. by []. Qed. +Lemma lcn1 A : 'L_1(A) = A. Proof. by []. Qed. +Lemma lcnSn n A : 'L_n.+2(A) = [~: 'L_n.+1(A), A]. Proof. by []. Qed. +Lemma lcnSnS n G : [~: 'L_n(G), G] \subset 'L_n.+1(G). +Proof. by case: n => //; exact: der1_subG. Qed. +Lemma lcnE n A : 'L_n.+1(A) = lower_central_at_rec n A. +Proof. by []. Qed. +Lemma lcn2 A : 'L_2(A) = A^`(1). Proof. by []. Qed. + +Lemma lcn_group_set n G : group_set 'L_n(G). +Proof. by case: n => [|[|n]]; exact: groupP. Qed. + +Canonical lower_central_at_group n G := Group (lcn_group_set n G). + +Lemma lcn_char n G : 'L_n(G) \char G. +Proof. +by case: n => [|n]; last elim: n => [|n IHn]; rewrite ?lcnSn ?charR ?char_refl. +Qed. + +Lemma lcn_normal n G : 'L_n(G) <| G. +Proof. by apply: char_normal; exact: lcn_char. Qed. + +Lemma lcn_sub n G : 'L_n(G) \subset G. +Proof. by case/andP: (lcn_normal n G). Qed. + +Lemma lcn_norm n G : G \subset 'N('L_n(G)). +Proof. by case/andP: (lcn_normal n G). Qed. + +Lemma lcn_subS n G : 'L_n.+1(G) \subset 'L_n(G). +Proof. +case: n => // n; rewrite lcnSn commGC commg_subr. +by case/andP: (lcn_normal n.+1 G). +Qed. + +Lemma lcn_normalS n G : 'L_n.+1(G) <| 'L_n(G). +Proof. by apply: normalS (lcn_normal _ _); rewrite (lcn_subS, lcn_sub). Qed. + +Lemma lcn_central n G : 'L_n(G) / 'L_n.+1(G) \subset 'Z(G / 'L_n.+1(G)). +Proof. +case: n => [|n]; first by rewrite trivg_quotient sub1G. +by rewrite subsetI quotientS ?lcn_sub ?quotient_cents2r. +Qed. + +Lemma lcn_sub_leq m n G : n <= m -> 'L_m(G) \subset 'L_n(G). +Proof. +by move/subnK <-; elim: {m}(m - n) => // m; exact: subset_trans (lcn_subS _ _). +Qed. + +Lemma lcnS n A B : A \subset B -> 'L_n(A) \subset 'L_n(B). +Proof. +by case: n => // n sAB; elim: n => // n IHn; rewrite !lcnSn genS ?imset2S. +Qed. + +Lemma lcn_cprod n A B G : A \* B = G -> 'L_n(A) \* 'L_n(B) = 'L_n(G). +Proof. +case: n => // n /cprodP[[H K -> ->{A B}] defG cHK]. +have sL := subset_trans (lcn_sub _ _); rewrite cprodE ?(centSS _ _ cHK) ?sL //. +symmetry; elim: n => // n; rewrite lcnSn => ->; rewrite commMG /=; last first. + by apply: subset_trans (commg_normr _ _); rewrite sL // -defG mulG_subr. +rewrite -!(commGC G) -defG -{1}(centC cHK). +rewrite !commMG ?normsR ?lcn_norm ?cents_norm // 1?centsC //. +by rewrite -!(commGC 'L__(_)) -!lcnSn !(commG1P _) ?mul1g ?sL // centsC. +Qed. + +Lemma lcn_dprod n A B G : A \x B = G -> 'L_n(A) \x 'L_n(B) = 'L_n(G). +Proof. +move=> defG; have [[K H defA defB] _ _ tiAB] := dprodP defG. +rewrite !dprodEcp // in defG *; first exact: lcn_cprod. +by rewrite defA defB; apply/trivgP; rewrite -tiAB defA defB setISS ?lcn_sub. +Qed. + +Lemma der_cprod n A B G : A \* B = G -> A^`(n) \* B^`(n) = G^`(n). +Proof. by move=> defG; elim: n => {defG}// n; apply: (lcn_cprod 2). Qed. + +Lemma der_dprod n A B G : A \x B = G -> A^`(n) \x B^`(n) = G^`(n). +Proof. by move=> defG; elim: n => {defG}// n; apply: (lcn_dprod 2). Qed. + +Lemma lcn_bigcprod n I r P (F : I -> {set gT}) G : + \big[cprod/1]_(i <- r | P i) F i = G -> + \big[cprod/1]_(i <- r | P i) 'L_n(F i) = 'L_n(G). +Proof. +elim/big_rec2: _ G => [_ <- | i A Z _ IH G dG]; first exact/esym/trivgP/lcn_sub. +by rewrite -(lcn_cprod n dG); have [[_ H _ dH]] := cprodP dG; rewrite dH (IH H). +Qed. + +Lemma lcn_bigdprod n I r P (F : I -> {set gT}) G : + \big[dprod/1]_(i <- r | P i) F i = G -> + \big[dprod/1]_(i <- r | P i) 'L_n(F i) = 'L_n(G). +Proof. +elim/big_rec2: _ G => [_ <- | i A Z _ IH G dG]; first exact/esym/trivgP/lcn_sub. +by rewrite -(lcn_dprod n dG); have [[_ H _ dH]] := dprodP dG; rewrite dH (IH H). +Qed. + +Lemma der_bigcprod n I r P (F : I -> {set gT}) G : + \big[cprod/1]_(i <- r | P i) F i = G -> + \big[cprod/1]_(i <- r | P i) (F i)^`(n) = G^`(n). +Proof. +elim/big_rec2: _ G => [_ <- | i A Z _ IH G dG]; first by rewrite gF1. +by rewrite -(der_cprod n dG); have [[_ H _ dH]] := cprodP dG; rewrite dH (IH H). +Qed. + +Lemma der_bigdprod n I r P (F : I -> {set gT}) G : + \big[dprod/1]_(i <- r | P i) F i = G -> + \big[dprod/1]_(i <- r | P i) (F i)^`(n) = G^`(n). +Proof. +elim/big_rec2: _ G => [_ <- | i A Z _ IH G dG]; first by rewrite gF1. +by rewrite -(der_dprod n dG); have [[_ H _ dH]] := dprodP dG; rewrite dH (IH H). +Qed. + +Lemma nilpotent_class G : nilpotent G = (nil_class G < #|G|). +Proof. +rewrite /nil_class; set s := mkseq _ _. +transitivity (1 \in s); last by rewrite -index_mem size_mkseq. +apply/idP/mapP=> {s}/= [nilG | [n _ Ln1]]; last first. + apply/forall_inP=> H /subsetIP[sHG sHR]. + rewrite -subG1 {}Ln1; elim: n => // n IHn. + by rewrite (subset_trans sHR) ?commSg. +pose m := #|G|.-1; exists m; first by rewrite mem_iota /= prednK. +rewrite ['L__(G)]card_le1_trivg //= -(subnn m). +elim: {-2}m => [|n]; [by rewrite subn0 prednK | rewrite lcnSn subnS]. +case: (eqsVneq 'L_n.+1(G) 1) => [-> | ntLn]; first by rewrite comm1G cards1. +case: (m - n) => [|m' /= IHn]; first by rewrite leqNgt cardG_gt1 ntLn. +rewrite -ltnS (leq_trans (proper_card _) IHn) //. +by rewrite (nil_comm_properl nilG) ?lcn_sub // subsetI subxx lcn_norm. +Qed. + +Lemma lcn_nil_classP n G : + nilpotent G -> reflect ('L_n.+1(G) = 1) (nil_class G <= n). +Proof. +rewrite nilpotent_class /nil_class; set s := mkseq _ _. +set c := index 1 s => lt_c_G; case: leqP => [le_c_n | lt_n_c]. + have Lc1: nth 1 s c = 1 by rewrite nth_index // -index_mem size_mkseq. + by left; apply/trivgP; rewrite -Lc1 nth_mkseq ?lcn_sub_leq. +right; apply/eqP/negPf; rewrite -(before_find 1 lt_n_c) nth_mkseq //. +exact: ltn_trans lt_n_c lt_c_G. +Qed. + +Lemma lcnP G : reflect (exists n, 'L_n.+1(G) = 1) (nilpotent G). +Proof. +apply: (iffP idP) => [nilG | [n Ln1]]. + by exists (nil_class G); exact/lcn_nil_classP. +apply/forall_inP=> H /subsetIP[sHG sHR]; rewrite -subG1 -{}Ln1. +by elim: n => // n IHn; rewrite (subset_trans sHR) ?commSg. +Qed. + +Lemma abelian_nil G : abelian G -> nilpotent G. +Proof. by move=> abG; apply/lcnP; exists 1%N; exact/commG1P. Qed. + +Lemma nil_class0 G : (nil_class G == 0) = (G :==: 1). +Proof. +apply/idP/eqP=> [nilG | ->]. + by apply/(lcn_nil_classP 0); rewrite ?nilpotent_class (eqP nilG) ?cardG_gt0. +by rewrite -leqn0; apply/(lcn_nil_classP 0); rewrite ?nilpotent1. +Qed. + +Lemma nil_class1 G : (nil_class G <= 1) = abelian G. +Proof. +have [-> | ntG] := eqsVneq G 1. + by rewrite abelian1 leq_eqVlt ltnS leqn0 nil_class0 eqxx orbT. +apply/idP/idP=> cGG. + apply/commG1P; apply/(lcn_nil_classP 1); rewrite // nilpotent_class. + by rewrite (leq_ltn_trans cGG) // cardG_gt1. +by apply/(lcn_nil_classP 1); rewrite ?abelian_nil //; apply/commG1P. +Qed. + +Lemma cprod_nil A B G : A \* B = G -> nilpotent G = nilpotent A && nilpotent B. +Proof. +move=> defG; case/cprodP: defG (defG) => [[H K -> ->{A B}] defG _] defGc. +apply/idP/andP=> [nilG | [/lcnP[m LmH1] /lcnP[n LnK1]]]. + by rewrite !(nilpotentS _ nilG) // -defG (mulG_subr, mulG_subl). +apply/lcnP; exists (m + n.+1); apply/trivgP. +case/cprodP: (lcn_cprod (m.+1 + n.+1) defGc) => _ <- _. +by rewrite mulG_subG /= -{1}LmH1 -LnK1 !lcn_sub_leq ?leq_addl ?leq_addr. +Qed. + +Lemma mulg_nil G H : + H \subset 'C(G) -> nilpotent (G * H) = nilpotent G && nilpotent H. +Proof. by move=> cGH; rewrite -(cprod_nil (cprodEY cGH)) /= cent_joinEr. Qed. + +Lemma dprod_nil A B G : A \x B = G -> nilpotent G = nilpotent A && nilpotent B. +Proof. by case/dprodP=> [[H K -> ->] <- cHK _]; rewrite mulg_nil. +Qed. + +Lemma bigdprod_nil I r (P : pred I) (A_ : I -> {set gT}) G : + \big[dprod/1]_(i <- r | P i) A_ i = G + -> (forall i, P i -> nilpotent (A_ i)) -> nilpotent G. +Proof. +move=> defG nilA; elim/big_rec: _ => [|i B Pi nilB] in G defG *. + by rewrite -defG nilpotent1. +have [[_ H _ defB] _ _ _] := dprodP defG. +by rewrite (dprod_nil defG) nilA //= defB nilB. +Qed. + +End LowerCentral. + +Notation "''L_' n ( G )" := (lower_central_at_group n G) : Group_scope. + +Lemma lcn_cont n : GFunctor.continuous (lower_central_at n). +Proof. +case: n => //; elim=> // n IHn g0T h0T H phi. +by rewrite !lcnSn morphimR ?lcn_sub // commSg ?IHn. +Qed. + +Canonical lcn_igFun n := [igFun by lcn_sub^~ n & lcn_cont n]. +Canonical lcn_gFun n := [gFun by lcn_cont n]. +Canonical lcn_mgFun n := [mgFun by fun _ G H => @lcnS _ n G H]. + +Section UpperCentralFunctor. + +Variable n : nat. +Implicit Type gT : finGroupType. + +Lemma ucn_pmap : exists hZ : GFunctor.pmap, @upper_central_at n = hZ. +Proof. +elim: n => [|n' [hZ defZ]]; first by exists trivGfun_pgFun. +by exists [pgFun of center %% hZ]; rewrite /= -defZ. +Qed. + +(* Now extract all the intermediate facts of the last proof. *) + +Lemma ucn_group_set gT (G : {group gT}) : group_set 'Z_n(G). +Proof. by have [hZ ->] := ucn_pmap; exact: groupP. Qed. + +Canonical upper_central_at_group gT G := Group (@ucn_group_set gT G). + +Lemma ucn_sub gT (G : {group gT}) : 'Z_n(G) \subset G. +Proof. by have [hZ ->] := ucn_pmap; exact: gFsub. Qed. + +Lemma morphim_ucn : GFunctor.pcontinuous (upper_central_at n). +Proof. by have [hZ ->] := ucn_pmap; exact: pmorphimF. Qed. + +Canonical ucn_igFun := [igFun by ucn_sub & morphim_ucn]. +Canonical ucn_gFun := [gFun by morphim_ucn]. +Canonical ucn_pgFun := [pgFun by morphim_ucn]. + +Variable (gT : finGroupType) (G : {group gT}). + +Lemma ucn_char : 'Z_n(G) \char G. Proof. exact: gFchar. Qed. +Lemma ucn_norm : G \subset 'N('Z_n(G)). Proof. exact: gFnorm. Qed. +Lemma ucn_normal : 'Z_n(G) <| G. Proof. exact: gFnormal. Qed. + +End UpperCentralFunctor. + +Notation "''Z_' n ( G )" := (upper_central_at_group n G) : Group_scope. + +Section UpperCentral. + +Variable gT : finGroupType. +Implicit Types (A B : {set gT}) (G H : {group gT}). + +Lemma ucn0 A : 'Z_0(A) = 1. +Proof. by []. Qed. + +Lemma ucnSn n A : 'Z_n.+1(A) = coset 'Z_n(A) @*^-1 'Z(A / 'Z_n(A)). +Proof. by []. Qed. + +Lemma ucnE n A : 'Z_n(A) = upper_central_at_rec n A. +Proof. by []. Qed. + +Lemma ucn_subS n G : 'Z_n(G) \subset 'Z_n.+1(G). +Proof. by rewrite -{1}['Z_n(G)]ker_coset morphpreS ?sub1G. Qed. + +Lemma ucn_sub_geq m n G : n >= m -> 'Z_m(G) \subset 'Z_n(G). +Proof. +move/subnK <-; elim: {n}(n - m) => // n IHn. +exact: subset_trans (ucn_subS _ _). +Qed. + +Lemma ucn_central n G : 'Z_n.+1(G) / 'Z_n(G) = 'Z(G / 'Z_n(G)). +Proof. by rewrite ucnSn cosetpreK. Qed. + +Lemma ucn_normalS n G : 'Z_n(G) <| 'Z_n.+1(G). +Proof. by rewrite (normalS _ _ (ucn_normal n G)) ?ucn_subS ?ucn_sub. Qed. + +Lemma ucn_comm n G : [~: 'Z_n.+1(G), G] \subset 'Z_n(G). +Proof. +rewrite -quotient_cents2 ?normal_norm ?ucn_normal ?ucn_normalS //. +by rewrite ucn_central subsetIr. +Qed. + +Lemma ucn1 G : 'Z_1(G) = 'Z(G). +Proof. +apply: (quotient_inj (normal1 _) (normal1 _)). +by rewrite /= (ucn_central 0) -injmF ?norms1 ?coset1_injm. +Qed. + +Lemma ucnSnR n G : 'Z_n.+1(G) = [set x in G | [~: [set x], G] \subset 'Z_n(G)]. +Proof. +apply/setP=> x; rewrite inE -(setIidPr (ucn_sub n.+1 G)) inE ucnSn. +case Gx: (x \in G) => //=; have nZG := ucn_norm n G. +rewrite -sub1set -sub_quotient_pre -?quotient_cents2 ?sub1set ?(subsetP nZG) //. +by rewrite subsetI quotientS ?sub1set. +Qed. + +Lemma ucn_cprod n A B G : A \* B = G -> 'Z_n(A) \* 'Z_n(B) = 'Z_n(G). +Proof. +case/cprodP=> [[H K -> ->{A B}] mulHK cHK]. +elim: n => [|n /cprodP[_ /= defZ cZn]]; first exact: cprod1g. +set Z := 'Z_n(G) in defZ cZn; rewrite (ucnSn n G) /= -/Z. +have /mulGsubP[nZH nZK]: H * K \subset 'N(Z) by rewrite mulHK gFnorm. +have <-: 'Z(H / Z) * 'Z(K / Z) = 'Z(G / Z). + by rewrite -mulHK quotientMl // center_prod ?quotient_cents. +have ZquoZ (B A : {group gT}): + B \subset 'C(A) -> 'Z_n(A) * 'Z_n(B) = Z -> 'Z(A / Z) = 'Z_n.+1(A) / Z. +- move=> cAB {defZ}defZ; have cAZnB := subset_trans (ucn_sub n B) cAB. + have /second_isom[/=]: A \subset 'N(Z). + by rewrite -defZ normsM ?gFnorm ?cents_norm // centsC. + suffices ->: Z :&: A = 'Z_n(A). + by move=> f inj_f im_f; rewrite -!im_f ?gFsub // ucn_central injm_center. + rewrite -defZ -group_modl ?gFsub //; apply/mulGidPl. + have [-> | n_gt0] := posnP n; first exact: subsetIl. + by apply: subset_trans (ucn_sub_geq A n_gt0); rewrite /= setIC ucn1 setIS. +rewrite (ZquoZ H K) 1?centsC 1?(centC cZn) // {ZquoZ}(ZquoZ K H) //. +have cZn1: 'Z_n.+1(K) \subset 'C('Z_n.+1(H)) by apply: centSS cHK; apply: gFsub. +rewrite -quotientMl ?quotientK ?mul_subG ?(subset_trans (gFsub _ _)) //=. +rewrite cprodE // -cent_joinEr ?mulSGid //= cent_joinEr //= -/Z. +by rewrite -defZ mulgSS ?ucn_subS. +Qed. + +Lemma ucn_dprod n A B G : A \x B = G -> 'Z_n(A) \x 'Z_n(B) = 'Z_n(G). +Proof. +move=> defG; have [[K H defA defB] _ _ tiAB] := dprodP defG. +rewrite !dprodEcp // in defG *; first exact: ucn_cprod. +by rewrite defA defB; apply/trivgP; rewrite -tiAB defA defB setISS ?ucn_sub. +Qed. + +Lemma ucn_bigcprod n I r P (F : I -> {set gT}) G : + \big[cprod/1]_(i <- r | P i) F i = G -> + \big[cprod/1]_(i <- r | P i) 'Z_n(F i) = 'Z_n(G). +Proof. +elim/big_rec2: _ G => [_ <- | i A Z _ IH G dG]; first by rewrite gF1. +by rewrite -(ucn_cprod n dG); have [[_ H _ dH]] := cprodP dG; rewrite dH (IH H). +Qed. + +Lemma ucn_bigdprod n I r P (F : I -> {set gT}) G : + \big[dprod/1]_(i <- r | P i) F i = G -> + \big[dprod/1]_(i <- r | P i) 'Z_n(F i) = 'Z_n(G). +Proof. +elim/big_rec2: _ G => [_ <- | i A Z _ IH G dG]; first by rewrite gF1. +by rewrite -(ucn_dprod n dG); have [[_ H _ dH]] := dprodP dG; rewrite dH (IH H). +Qed. + +Lemma ucn_lcnP n G : ('L_n.+1(G) == 1) = ('Z_n(G) == G). +Proof. +rewrite !eqEsubset sub1G ucn_sub /= andbT -(ucn0 G). +elim: {1 3}n 0 (addn0 n) => [j <- //|i IHi j]. +rewrite addSnnS => /IHi <- {IHi}; rewrite ucnSn lcnSn. +have nZG := normal_norm (ucn_normal j G). +have nZL := subset_trans (lcn_sub _ _) nZG. +by rewrite -sub_morphim_pre // subsetI morphimS ?lcn_sub // quotient_cents2. +Qed. + +Lemma ucnP G : reflect (exists n, 'Z_n(G) = G) (nilpotent G). +Proof. +apply: (iffP (lcnP G)) => [] [n /eqP clGn]; + by exists n; apply/eqP; rewrite ucn_lcnP in clGn *. +Qed. + +Lemma ucn_nil_classP n G : + nilpotent G -> reflect ('Z_n(G) = G) (nil_class G <= n). +Proof. +move=> nilG; rewrite (sameP (lcn_nil_classP n nilG) eqP) ucn_lcnP; exact: eqP. +Qed. + +Lemma ucn_id n G : 'Z_n('Z_n(G)) = 'Z_n(G). +Proof. by rewrite -{2}['Z_n(G)]gFid. Qed. + +Lemma ucn_nilpotent n G : nilpotent 'Z_n(G). +Proof. by apply/ucnP; exists n; rewrite ucn_id. Qed. + +Lemma nil_class_ucn n G : nil_class 'Z_n(G) <= n. +Proof. by apply/ucn_nil_classP; rewrite ?ucn_nilpotent ?ucn_id. Qed. + +End UpperCentral. + +Section MorphNil. + +Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}). +Implicit Type G : {group aT}. + +Lemma morphim_lcn n G : G \subset D -> f @* 'L_n(G) = 'L_n(f @* G). +Proof. +move=> sHG; case: n => //; elim=> // n IHn. +by rewrite !lcnSn -IHn morphimR // (subset_trans _ sHG) // lcn_sub. +Qed. + +Lemma injm_ucn n G : 'injm f -> G \subset D -> f @* 'Z_n(G) = 'Z_n(f @* G). +Proof. exact: injmF. Qed. + +Lemma morphim_nil G : nilpotent G -> nilpotent (f @* G). +Proof. +case/ucnP=> n ZnG; apply/ucnP; exists n; apply/eqP. +by rewrite eqEsubset ucn_sub /= -{1}ZnG morphim_ucn. +Qed. + +Lemma injm_nil G : 'injm f -> G \subset D -> nilpotent (f @* G) = nilpotent G. +Proof. +move=> injf sGD; apply/idP/idP; last exact: morphim_nil. +case/ucnP=> n; rewrite -injm_ucn // => /injm_morphim_inj defZ. +by apply/ucnP; exists n; rewrite defZ ?(subset_trans (ucn_sub n G)). +Qed. + +Lemma nil_class_morphim G : nilpotent G -> nil_class (f @* G) <= nil_class G. +Proof. +move=> nilG; rewrite (sameP (ucn_nil_classP _ (morphim_nil nilG)) eqP) /=. +by rewrite eqEsubset ucn_sub -{1}(ucn_nil_classP _ nilG (leqnn _)) morphim_ucn. +Qed. + +Lemma nil_class_injm G : + 'injm f -> G \subset D -> nil_class (f @* G) = nil_class G. +Proof. +move=> injf sGD; case nilG: (nilpotent G). + apply/eqP; rewrite eqn_leq nil_class_morphim //. + rewrite (sameP (lcn_nil_classP _ nilG) eqP) -subG1. + rewrite -(injmSK injf) ?(subset_trans (lcn_sub _ _)) // morphim1. + by rewrite morphim_lcn // (lcn_nil_classP _ _ (leqnn _)) //= injm_nil. +transitivity #|G|; apply/eqP; rewrite eqn_leq. + rewrite -(card_injm injf sGD) (leq_trans (index_size _ _)) ?size_mkseq //. + by rewrite leqNgt -nilpotent_class injm_nil ?nilG. +rewrite (leq_trans (index_size _ _)) ?size_mkseq // leqNgt -nilpotent_class. +by rewrite nilG. +Qed. + +End MorphNil. + +Section QuotientNil. + +Variables gT : finGroupType. +Implicit Types (rT : finGroupType) (G H : {group gT}). + +Lemma quotient_ucn_add m n G : 'Z_(m + n)(G) / 'Z_n(G) = 'Z_m(G / 'Z_n(G)). +Proof. +elim: m => [|m IHm]; first exact: trivg_quotient. +apply/setP=> Zx; have [x Nx ->{Zx}] := cosetP Zx. +have [sZG nZG] := andP (ucn_normal n G). +rewrite (ucnSnR m) inE -!sub1set -morphim_set1 //= -quotientR ?sub1set // -IHm. +rewrite !quotientSGK ?(ucn_sub_geq, leq_addl, comm_subG _ nZG, sub1set) //=. +by rewrite addSn /= ucnSnR inE. +Qed. + +Lemma isog_nil rT G (L : {group rT}) : G \isog L -> nilpotent G = nilpotent L. +Proof. by case/isogP=> f injf <-; rewrite injm_nil. Qed. + +Lemma isog_nil_class rT G (L : {group rT}) : + G \isog L -> nil_class G = nil_class L. +Proof. by case/isogP=> f injf <-; rewrite nil_class_injm. Qed. + +Lemma quotient_nil G H : nilpotent G -> nilpotent (G / H). +Proof. exact: morphim_nil. Qed. + +Lemma quotient_center_nil G : nilpotent (G / 'Z(G)) = nilpotent G. +Proof. +rewrite -ucn1; apply/idP/idP; last exact: quotient_nil. +case/ucnP=> c nilGq; apply/ucnP; exists c.+1; have nsZ1G := ucn_normal 1 G. +apply: (quotient_inj _ nsZ1G); last by rewrite /= -(addn1 c) quotient_ucn_add. +by rewrite (normalS _ _ nsZ1G) ?ucn_sub ?ucn_sub_geq. +Qed. + +Lemma nil_class_quotient_center G : + nilpotent (G) -> nil_class (G / 'Z(G)) = (nil_class G).-1. +Proof. +move=> nilG; have nsZ1G := ucn_normal 1 G. +apply/eqP; rewrite -ucn1 eqn_leq; apply/andP; split. + apply/ucn_nil_classP; rewrite ?quotient_nil //= -quotient_ucn_add ucn1. + by rewrite (ucn_nil_classP _ _ _) ?addn1 ?leqSpred. +rewrite -subn1 leq_subLR addnC; apply/ucn_nil_classP => //=. +apply: (quotient_inj _ nsZ1G) => /=. + by apply: normalS (ucn_sub _ _) nsZ1G; rewrite /= addnS ucn_sub_geq. +by rewrite quotient_ucn_add; apply/ucn_nil_classP; rewrite //= quotient_nil. +Qed. + +Lemma nilpotent_sub_norm G H : + nilpotent G -> H \subset G -> 'N_G(H) \subset H -> G :=: H. +Proof. +move=> nilG sHG sNH; apply/eqP; rewrite eqEsubset sHG andbT; apply/negP=> nsGH. +have{nsGH} [i sZH []]: exists2 i, 'Z_i(G) \subset H & ~ 'Z_i.+1(G) \subset H. + case/ucnP: nilG => n ZnG; rewrite -{}ZnG in nsGH. + elim: n => [|i IHi] in nsGH *; first by rewrite sub1G in nsGH. + by case sZH: ('Z_i(G) \subset H); [exists i | apply: IHi; rewrite sZH]. +apply: subset_trans sNH; rewrite subsetI ucn_sub -commg_subr. +by apply: subset_trans sZH; apply: subset_trans (ucn_comm i G); exact: commgS. +Qed. + +Lemma nilpotent_proper_norm G H : + nilpotent G -> H \proper G -> H \proper 'N_G(H). +Proof. +move=> nilG; rewrite properEneq properE subsetI normG => /andP[neHG sHG]. +by rewrite sHG; apply: contra neHG; move/(nilpotent_sub_norm nilG)->. +Qed. + +Lemma nilpotent_subnormal G H : nilpotent G -> H \subset G -> H <|<| G. +Proof. +move=> nilG; elim: {H}_.+1 {-2}H (ltnSn (#|G| - #|H|)) => // m IHm H. +rewrite ltnS => leGHm sHG; have:= sHG; rewrite subEproper. +case/predU1P=> [->|]; first exact: subnormal_refl. +move/(nilpotent_proper_norm nilG); set K := 'N_G(H) => prHK. +have snHK: H <|<| K by rewrite normal_subnormal ?normalSG. +have sKG: K \subset G by rewrite subsetIl. +apply: subnormal_trans snHK (IHm _ (leq_trans _ leGHm) sKG). +by rewrite ltn_sub2l ?proper_card ?(proper_sub_trans prHK). +Qed. + +Lemma TI_center_nil G H : nilpotent G -> H <| G -> H :&: 'Z(G) = 1 -> H :=: 1. +Proof. +move=> nilG /andP[sHG nHG] tiHZ. +rewrite -{1}(setIidPl sHG); have{nilG} /ucnP[n <-] := nilG. +elim: n => [|n IHn]; apply/trivgP; rewrite ?subsetIr // -tiHZ. +rewrite [H :&: 'Z(G)]setIA subsetI setIS ?ucn_sub //= (sameP commG1P trivgP). +rewrite -commg_subr commGC in nHG. +rewrite -IHn subsetI (subset_trans _ nHG) ?commSg ?subsetIl //=. +by rewrite (subset_trans _ (ucn_comm n G)) ?commSg ?subsetIr. +Qed. + +Lemma meet_center_nil G H : + nilpotent G -> H <| G -> H :!=: 1 -> H :&: 'Z(G) != 1. +Proof. by move=> nilG nsHG; apply: contraNneq => /TI_center_nil->. Qed. + +Lemma center_nil_eq1 G : nilpotent G -> ('Z(G) == 1) = (G :==: 1). +Proof. +move=> nilG; apply/eqP/eqP=> [Z1 | ->]; last exact: center1. +by rewrite (TI_center_nil nilG) // (setIidPr (center_sub G)). +Qed. + +Lemma cyclic_nilpotent_quo_der1_cyclic G : + nilpotent G -> cyclic (G / G^`(1)) -> cyclic G. +Proof. +move=> nG; rewrite (isog_cyclic (quotient1_isog G)). +have [-> // | ntG' cGG'] := (eqVneq G^`(1) 1)%g. +suffices: 'L_2(G) \subset G :&: 'L_3(G) by move/(eqfun_inP nG)=> <-. +rewrite subsetI lcn_sub /= -quotient_cents2 ?lcn_norm //. +apply: cyclic_factor_abelian (lcn_central 2 G) _. +by rewrite (isog_cyclic (third_isog _ _ _)) ?lcn_normal // lcn_subS. +Qed. + +End QuotientNil. + +Section Solvable. + +Variable gT : finGroupType. +Implicit Types G H : {group gT}. + +Lemma nilpotent_sol G : nilpotent G -> solvable G. +Proof. +move=> nilG; apply/forall_inP=> H /subsetIP[sHG sHH']. +by rewrite (forall_inP nilG) // subsetI sHG (subset_trans sHH') ?commgS. +Qed. + +Lemma abelian_sol G : abelian G -> solvable G. +Proof. by move/abelian_nil; exact: nilpotent_sol. Qed. + +Lemma solvable1 : solvable [1 gT]. Proof. exact: abelian_sol (abelian1 gT). Qed. + +Lemma solvableS G H : H \subset G -> solvable G -> solvable H. +Proof. +move=> sHG solG; apply/forall_inP=> K /subsetIP[sKH sKK']. +by rewrite (forall_inP solG) // subsetI (subset_trans sKH). +Qed. + +Lemma sol_der1_proper G H : + solvable G -> H \subset G -> H :!=: 1 -> H^`(1) \proper H. +Proof. +move=> solG sHG ntH; rewrite properE comm_subG //; apply: implyP ntH. +by have:= forallP solG H; rewrite subsetI sHG implybNN. +Qed. + +Lemma derivedP G : reflect (exists n, G^`(n) = 1) (solvable G). +Proof. +apply: (iffP idP) => [solG | [n solGn]]; last first. + apply/forall_inP=> H /subsetIP[sHG sHH']. + rewrite -subG1 -{}solGn; elim: n => // n IHn. + exact: subset_trans sHH' (commgSS _ _). +suffices IHn n: #|G^`(n)| <= (#|G|.-1 - n).+1. + by exists #|G|.-1; rewrite [G^`(_)]card_le1_trivg ?(leq_trans (IHn _)) ?subnn. +elim: n => [|n IHn]; first by rewrite subn0 prednK. +rewrite dergSn subnS -ltnS. +have [-> | ntGn] := eqVneq G^`(n) 1; first by rewrite commG1 cards1. +case: (_ - _) IHn => [|n']; first by rewrite leqNgt cardG_gt1 ntGn. +by apply: leq_trans (proper_card _); exact: sol_der1_proper (der_sub _ _) _. +Qed. + +End Solvable. + +Section MorphSol. + +Variables (gT rT : finGroupType) (D : {group gT}) (f : {morphism D >-> rT}). +Variable G : {group gT}. + +Lemma morphim_sol : solvable G -> solvable (f @* G). +Proof. +move/(solvableS (subsetIr D G)); case/derivedP=> n Gn1; apply/derivedP. +by exists n; rewrite /= -morphimIdom -morphim_der ?subsetIl // Gn1 morphim1. +Qed. + +Lemma injm_sol : 'injm f -> G \subset D -> solvable (f @* G) = solvable G. +Proof. +move=> injf sGD; apply/idP/idP; last exact: morphim_sol. +case/derivedP=> n Gn1; apply/derivedP; exists n; apply/trivgP. +rewrite -(injmSK injf) ?(subset_trans (der_sub _ _)) ?morphim_der //. +by rewrite Gn1 morphim1. +Qed. + +End MorphSol. + +Section QuotientSol. + +Variables gT rT : finGroupType. +Implicit Types G H K : {group gT}. + +Lemma isog_sol G (L : {group rT}) : G \isog L -> solvable G = solvable L. +Proof. by case/isogP=> f injf <-; rewrite injm_sol. Qed. + +Lemma quotient_sol G H : solvable G -> solvable (G / H). +Proof. exact: morphim_sol. Qed. + +Lemma series_sol G H : H <| G -> solvable G = solvable H && solvable (G / H). +Proof. +case/andP=> sHG nHG; apply/idP/andP=> [solG | [solH solGH]]. + by rewrite quotient_sol // (solvableS sHG). +apply/forall_inP=> K /subsetIP[sKG sK'K]. +suffices sKH: K \subset H by rewrite (forall_inP solH) // subsetI sKH. +have nHK := subset_trans sKG nHG. +rewrite -quotient_sub1 // subG1 (forall_inP solGH) //. +by rewrite subsetI -morphimR ?morphimS. +Qed. + +Lemma metacyclic_sol G : metacyclic G -> solvable G. +Proof. +case/metacyclicP=> K [cycK nsKG cycGq]. +by rewrite (series_sol nsKG) !abelian_sol ?cyclic_abelian. +Qed. + +End QuotientSol. diff --git a/mathcomp/solvable/pgroup.v b/mathcomp/solvable/pgroup.v new file mode 100644 index 0000000..c6db976 --- /dev/null +++ b/mathcomp/solvable/pgroup.v @@ -0,0 +1,1355 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div. +Require Import fintype bigop finset prime fingroup morphism. +Require Import gfunctor automorphism quotient action gproduct cyclic. + +(******************************************************************************) +(* Standard group notions and constructions based on the prime decomposition *) +(* of the order of the group or its elements: *) +(* pi.-group G <=> G is a pi-group, i.e., pi.-nat #|G|. *) +(* -> Recall that here and in the sequel pi can be a single prime p. *) +(* pi.-subgroup(H) G <=> H is a pi-subgroup of G. *) +(* := (H \subset G) && pi.-group H. *) +(* -> This is provided mostly as a shorhand, with few associated lemmas. *) +(* However, we do establish some results on maximal pi-subgroups. *) +(* pi.-elt x <=> x is a pi-element. *) +(* := pi.-nat #[x] or pi.-group <[x]>. *) +(* x.`_pi == the pi-constituent of x: the (unique) pi-element *) +(* y \in <[x]> such that x * y^-1 is a pi'-element. *) +(* pi.-Hall(G) H <=> H is a Hall pi-subgroup of G. *) +(* := [&& H \subset G, pi.-group H & pi^'.-nat #|G : H|]. *) +(* -> This is also eqivalent to H \subset G /\ #|H| = #|G|`_pi. *) +(* p.-Sylow(G) P <=> P is a Sylow p-subgroup of G. *) +(* -> This is the display and preferred input notation for p.-Hall(G) P. *) +(* 'Syl_p(G) == the set of the p-Sylow subgroups of G. *) +(* := [set P : {group _} | p.-Sylow(G) P]. *) +(* p_group P <=> P is a p-group for some prime p. *) +(* Hall G H <=> H is a Hall pi-subgroup of G for some pi. *) +(* := coprime #|H| #|G : H| && (H \subset G). *) +(* Sylow G P <=> P is a Sylow p-subgroup of G for some p. *) +(* := p_group P && Hall G P. *) +(* 'O_pi(G) == the pi-core (largest normal pi-subgroup) of G. *) +(* pcore_mod pi G H == the pi-core of G mod H. *) +(* := G :&: (coset H @*^-1 'O_pi(G / H)). *) +(* 'O_{pi2, pi1}(G) == the pi1,pi2-core of G. *) +(* := the pi1-core of G mod 'O_pi2(G). *) +(* -> We have 'O_{pi2, pi1}(G) / 'O_pi2(G) = 'O_pi1(G / 'O_pi2(G)) *) +(* with 'O_pi2(G) <| 'O_{pi2, pi1}(G) <| G. *) +(* 'O_{pn, ..., p1}(G) == the p1, ..., pn-core of G. *) +(* := the p1-core of G mod 'O_{pn, ..., p2}(G). *) +(* Note that notions are always defined on sets even though their name *) +(* indicates "group" properties; the actual definition of the notion never *) +(* tests for the group property, since this property will always be provided *) +(* by a (canonical) group structure. Similarly, p-group properties assume *) +(* without test that p is a prime. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section PgroupDefs. + +(* We defer the definition of the functors ('0_p(G), etc) because they need *) +(* to quantify over the finGroupType explicitly. *) + +Variable gT : finGroupType. +Implicit Type (x : gT) (A B : {set gT}) (pi : nat_pred) (p n : nat). + +Definition pgroup pi A := pi.-nat #|A|. + +Definition psubgroup pi A B := (B \subset A) && pgroup pi B. + +Definition p_group A := pgroup (pdiv #|A|) A. + +Definition p_elt pi x := pi.-nat #[x]. + +Definition constt x pi := x ^+ (chinese #[x]`_pi #[x]`_pi^' 1 0). + +Definition Hall A B := (B \subset A) && coprime #|B| #|A : B|. + +Definition pHall pi A B := [&& B \subset A, pgroup pi B & pi^'.-nat #|A : B|]. + +Definition Syl p A := [set P : {group gT} | pHall p A P]. + +Definition Sylow A B := p_group B && Hall A B. + +End PgroupDefs. + +Arguments Scope pgroup [_ nat_scope group_scope]. +Arguments Scope psubgroup [_ nat_scope group_scope group_scope]. +Arguments Scope p_group [_ group_scope]. +Arguments Scope p_elt [_ nat_scope]. +Arguments Scope constt [_ group_scope nat_scope]. +Arguments Scope Hall [_ group_scope group_scope]. +Arguments Scope pHall [_ nat_scope group_scope group_scope]. +Arguments Scope Syl [_ nat_scope group_scope]. +Arguments Scope Sylow [_ group_scope group_scope]. +Prenex Implicits p_group Hall Sylow. + +Notation "pi .-group" := (pgroup pi) + (at level 2, format "pi .-group") : group_scope. + +Notation "pi .-subgroup ( A )" := (psubgroup pi A) + (at level 8, format "pi .-subgroup ( A )") : group_scope. + +Notation "pi .-elt" := (p_elt pi) + (at level 2, format "pi .-elt") : group_scope. + +Notation "x .`_ pi" := (constt x pi) + (at level 3, format "x .`_ pi") : group_scope. + +Notation "pi .-Hall ( G )" := (pHall pi G) + (at level 8, format "pi .-Hall ( G )") : group_scope. + +Notation "p .-Sylow ( G )" := (nat_pred_of_nat p).-Hall(G) + (at level 8, format "p .-Sylow ( G )") : group_scope. + +Notation "''Syl_' p ( G )" := (Syl p G) + (at level 8, p at level 2, format "''Syl_' p ( G )") : group_scope. + +Section PgroupProps. + +Variable gT : finGroupType. +Implicit Types (pi rho : nat_pred) (p : nat). +Implicit Types (x y z : gT) (A B C D : {set gT}) (G H K P Q R : {group gT}). + +Lemma trivgVpdiv G : G :=: 1 \/ (exists2 p, prime p & p %| #|G|). +Proof. +have [leG1|lt1G] := leqP #|G| 1; first by left; exact: card_le1_trivg. +by right; exists (pdiv #|G|); rewrite ?pdiv_dvd ?pdiv_prime. +Qed. + +Lemma prime_subgroupVti G H : prime #|G| -> G \subset H \/ H :&: G = 1. +Proof. +move=> prG; have [|[p p_pr pG]] := trivgVpdiv (H :&: G); first by right. +left; rewrite (sameP setIidPr eqP) eqEcard subsetIr. +suffices <-: p = #|G| by rewrite dvdn_leq ?cardG_gt0. +by apply/eqP; rewrite -dvdn_prime2 // -(LagrangeI G H) setIC dvdn_mulr. +Qed. + +Lemma pgroupE pi A : pi.-group A = pi.-nat #|A|. Proof. by []. Qed. + +Lemma sub_pgroup pi rho A : {subset pi <= rho} -> pi.-group A -> rho.-group A. +Proof. by move=> pi_sub_rho; exact: sub_in_pnat (in1W pi_sub_rho). Qed. + +Lemma eq_pgroup pi rho A : pi =i rho -> pi.-group A = rho.-group A. +Proof. exact: eq_pnat. Qed. + +Lemma eq_p'group pi rho A : pi =i rho -> pi^'.-group A = rho^'.-group A. +Proof. by move/eq_negn; exact: eq_pnat. Qed. + +Lemma pgroupNK pi A : pi^'^'.-group A = pi.-group A. +Proof. exact: pnatNK. Qed. + +Lemma pi_pgroup p pi A : p.-group A -> p \in pi -> pi.-group A. +Proof. exact: pi_pnat. Qed. + +Lemma pi_p'group p pi A : pi.-group A -> p \in pi^' -> p^'.-group A. +Proof. exact: pi_p'nat. Qed. + +Lemma pi'_p'group p pi A : pi^'.-group A -> p \in pi -> p^'.-group A. +Proof. exact: pi'_p'nat. Qed. + +Lemma p'groupEpi p G : p^'.-group G = (p \notin \pi(G)). +Proof. exact: p'natEpi (cardG_gt0 G). Qed. + +Lemma pgroup_pi G : \pi(G).-group G. +Proof. by rewrite /=; exact: pnat_pi. Qed. + +Lemma partG_eq1 pi G : (#|G|`_pi == 1%N) = pi^'.-group G. +Proof. exact: partn_eq1 (cardG_gt0 G). Qed. + +Lemma pgroupP pi G : + reflect (forall p, prime p -> p %| #|G| -> p \in pi) (pi.-group G). +Proof. exact: pnatP. Qed. +Implicit Arguments pgroupP [pi G]. + +Lemma pgroup1 pi : pi.-group [1 gT]. +Proof. by rewrite /pgroup cards1. Qed. + +Lemma pgroupS pi G H : H \subset G -> pi.-group G -> pi.-group H. +Proof. by move=> sHG; exact: pnat_dvd (cardSg sHG). Qed. + +Lemma oddSg G H : H \subset G -> odd #|G| -> odd #|H|. +Proof. by rewrite !odd_2'nat; exact: pgroupS. Qed. + +Lemma odd_pgroup_odd p G : odd p -> p.-group G -> odd #|G|. +Proof. +move=> p_odd pG; rewrite odd_2'nat (pi_pnat pG) // !inE. +by case: eqP p_odd => // ->. +Qed. + +Lemma card_pgroup p G : p.-group G -> #|G| = (p ^ logn p #|G|)%N. +Proof. by move=> pG; rewrite -p_part part_pnat_id. Qed. + +Lemma properG_ltn_log p G H : + p.-group G -> H \proper G -> logn p #|H| < logn p #|G|. +Proof. +move=> pG; rewrite properEneq eqEcard andbC ltnNge => /andP[sHG]. +rewrite sHG /= {1}(card_pgroup pG) {1}(card_pgroup (pgroupS sHG pG)). +by apply: contra; case: p {pG} => [|p] leHG; rewrite ?logn0 // leq_pexp2l. +Qed. + +Lemma pgroupM pi G H : pi.-group (G * H) = pi.-group G && pi.-group H. +Proof. +have GH_gt0: 0 < #|G :&: H| := cardG_gt0 _. +rewrite /pgroup -(mulnK #|_| GH_gt0) -mul_cardG -(LagrangeI G H) -mulnA. +by rewrite mulKn // -(LagrangeI H G) setIC !pnat_mul andbCA; case: (pnat _). +Qed. + +Lemma pgroupJ pi G x : pi.-group (G :^ x) = pi.-group G. +Proof. by rewrite /pgroup cardJg. Qed. + +Lemma pgroup_p p P : p.-group P -> p_group P. +Proof. +case: (leqP #|P| 1); first by move=> /card_le1_trivg-> _; exact: pgroup1. +move/pdiv_prime=> pr_q pgP; have:= pgroupP pgP _ pr_q (pdiv_dvd _). +by rewrite /p_group => /eqnP->. +Qed. + +Lemma p_groupP P : p_group P -> exists2 p, prime p & p.-group P. +Proof. +case: (ltnP 1 #|P|); first by move/pdiv_prime; exists (pdiv #|P|). +move/card_le1_trivg=> -> _; exists 2 => //; exact: pgroup1. +Qed. + +Lemma pgroup_pdiv p G : + p.-group G -> G :!=: 1 -> + [/\ prime p, p %| #|G| & exists m, #|G| = p ^ m.+1]%N. +Proof. +move=> pG; rewrite trivg_card1; case/p_groupP: (pgroup_p pG) => q q_pr qG. +move/implyP: (pgroupP pG q q_pr); case/p_natP: qG => // [[|m] ->] //. +by rewrite dvdn_exp // => /eqnP <- _; split; rewrite ?dvdn_exp //; exists m. +Qed. + +Lemma coprime_p'group p K R : + coprime #|K| #|R| -> p.-group R -> R :!=: 1 -> p^'.-group K. +Proof. +move=> coKR pR ntR; have [p_pr _ [e oK]] := pgroup_pdiv pR ntR. +by rewrite oK coprime_sym coprime_pexpl // prime_coprime // -p'natE in coKR. +Qed. + +Lemma card_Hall pi G H : pi.-Hall(G) H -> #|H| = #|G|`_pi. +Proof. +case/and3P=> sHG piH pi'H; rewrite -(Lagrange sHG). +by rewrite partnM ?Lagrange // part_pnat_id ?part_p'nat ?muln1. +Qed. + +Lemma pHall_sub pi A B : pi.-Hall(A) B -> B \subset A. +Proof. by case/andP. Qed. + +Lemma pHall_pgroup pi A B : pi.-Hall(A) B -> pi.-group B. +Proof. by case/and3P. Qed. + +Lemma pHallP pi G H : reflect (H \subset G /\ #|H| = #|G|`_pi) (pi.-Hall(G) H). +Proof. +apply: (iffP idP) => [piH | [sHG oH]]. + split; [exact: pHall_sub piH | exact: card_Hall]. +rewrite /pHall sHG -divgS // /pgroup oH. +by rewrite -{2}(@partnC pi #|G|) ?mulKn ?part_pnat. +Qed. + +Lemma pHallE pi G H : pi.-Hall(G) H = (H \subset G) && (#|H| == #|G|`_pi). +Proof. by apply/pHallP/andP=> [] [->] /eqP. Qed. + +Lemma coprime_mulpG_Hall pi G K R : + K * R = G -> pi.-group K -> pi^'.-group R -> + pi.-Hall(G) K /\ pi^'.-Hall(G) R. +Proof. +move=> defG piK pi'R; apply/andP. +rewrite /pHall piK -!divgS /= -defG ?mulG_subl ?mulg_subr //= pnatNK. +by rewrite coprime_cardMg ?(pnat_coprime piK) // mulKn ?mulnK //; exact/and3P. +Qed. + +Lemma coprime_mulGp_Hall pi G K R : + K * R = G -> pi^'.-group K -> pi.-group R -> + pi^'.-Hall(G) K /\ pi.-Hall(G) R. +Proof. +move=> defG pi'K piR; apply/andP; rewrite andbC; apply/andP. +by apply: coprime_mulpG_Hall => //; rewrite -(comm_group_setP _) defG ?groupP. +Qed. + +Lemma eq_in_pHall pi rho G H : + {in \pi(G), pi =i rho} -> pi.-Hall(G) H = rho.-Hall(G) H. +Proof. +move=> eq_pi_rho; apply: andb_id2l => sHG. +congr (_ && _); apply: eq_in_pnat => p piHp. + by apply: eq_pi_rho; exact: (piSg sHG). +by congr (~~ _); apply: eq_pi_rho; apply: (pi_of_dvd (dvdn_indexg G H)). +Qed. + +Lemma eq_pHall pi rho G H : pi =i rho -> pi.-Hall(G) H = rho.-Hall(G) H. +Proof. by move=> eq_pi_rho; exact: eq_in_pHall (in1W eq_pi_rho). Qed. + +Lemma eq_p'Hall pi rho G H : pi =i rho -> pi^'.-Hall(G) H = rho^'.-Hall(G) H. +Proof. by move=> eq_pi_rho; exact: eq_pHall (eq_negn _). Qed. + +Lemma pHallNK pi G H : pi^'^'.-Hall(G) H = pi.-Hall(G) H. +Proof. exact: eq_pHall (negnK _). Qed. + +Lemma subHall_Hall pi rho G H K : + rho.-Hall(G) H -> {subset pi <= rho} -> pi.-Hall(H) K -> pi.-Hall(G) K. +Proof. +move=> hallH pi_sub_rho hallK. +rewrite pHallE (subset_trans (pHall_sub hallK) (pHall_sub hallH)) /=. +by rewrite (card_Hall hallK) (card_Hall hallH) partn_part. +Qed. + +Lemma subHall_Sylow pi p G H P : + pi.-Hall(G) H -> p \in pi -> p.-Sylow(H) P -> p.-Sylow(G) P. +Proof. +move=> hallH pi_p sylP; have [sHG piH _] := and3P hallH. +rewrite pHallE (subset_trans (pHall_sub sylP) sHG) /=. +by rewrite (card_Hall sylP) (card_Hall hallH) partn_part // => q; move/eqnP->. +Qed. + +Lemma pHall_Hall pi A B : pi.-Hall(A) B -> Hall A B. +Proof. by case/and3P=> sBA piB pi'B; rewrite /Hall sBA (pnat_coprime piB). Qed. + +Lemma Hall_pi G H : Hall G H -> \pi(H).-Hall(G) H. +Proof. +by case/andP=> sHG coHG /=; rewrite /pHall sHG /pgroup pnat_pi -?coprime_pi'. +Qed. + +Lemma HallP G H : Hall G H -> exists pi, pi.-Hall(G) H. +Proof. by exists \pi(H); exact: Hall_pi. Qed. + +Lemma sdprod_Hall G K H : K ><| H = G -> Hall G K = Hall G H. +Proof. +case/sdprod_context=> /andP[sKG _] sHG defG _ tiKH. +by rewrite /Hall sKG sHG -!divgS // -defG TI_cardMg // coprime_sym mulKn ?mulnK. +Qed. + +Lemma coprime_sdprod_Hall_l G K H : K ><| H = G -> coprime #|K| #|H| = Hall G K. +Proof. +case/sdprod_context=> /andP[sKG _] _ defG _ tiKH. +by rewrite /Hall sKG -divgS // -defG TI_cardMg ?mulKn. +Qed. + +Lemma coprime_sdprod_Hall_r G K H : K ><| H = G -> coprime #|K| #|H| = Hall G H. +Proof. +by move=> defG; rewrite (coprime_sdprod_Hall_l defG) (sdprod_Hall defG). +Qed. + +Lemma compl_pHall pi K H G : + pi.-Hall(G) K -> (H \in [complements to K in G]) = pi^'.-Hall(G) H. +Proof. +move=> hallK; apply/complP/idP=> [[tiKH mulKH] | hallH]. + have [_] := andP hallK; rewrite /pHall pnatNK -{3}(invGid G) -mulKH mulG_subr. + by rewrite invMG !indexMg -indexgI andbC -indexgI setIC tiKH !indexg1. +have [[sKG piK _] [sHG pi'H _]] := (and3P hallK, and3P hallH). +have tiKH: K :&: H = 1 := coprime_TIg (pnat_coprime piK pi'H). +split=> //; apply/eqP; rewrite eqEcard mul_subG //= TI_cardMg //. +by rewrite (card_Hall hallK) (card_Hall hallH) partnC. +Qed. + +Lemma compl_p'Hall pi K H G : + pi^'.-Hall(G) K -> (H \in [complements to K in G]) = pi.-Hall(G) H. +Proof. by move/compl_pHall->; exact: eq_pHall (negnK pi). Qed. + +Lemma sdprod_normal_p'HallP pi K H G : + K <| G -> pi^'.-Hall(G) H -> reflect (K ><| H = G) (pi.-Hall(G) K). +Proof. +move=> nsKG hallH; rewrite -(compl_p'Hall K hallH). +exact: sdprod_normal_complP. +Qed. + +Lemma sdprod_normal_pHallP pi K H G : + K <| G -> pi.-Hall(G) H -> reflect (K ><| H = G) (pi^'.-Hall(G) K). +Proof. +by move=> nsKG hallH; apply: sdprod_normal_p'HallP; rewrite ?pHallNK. +Qed. + +Lemma pHallJ2 pi G H x : pi.-Hall(G :^ x) (H :^ x) = pi.-Hall(G) H. +Proof. by rewrite !pHallE conjSg !cardJg. Qed. + +Lemma pHallJnorm pi G H x : x \in 'N(G) -> pi.-Hall(G) (H :^ x) = pi.-Hall(G) H. +Proof. by move=> Nx; rewrite -{1}(normP Nx) pHallJ2. Qed. + +Lemma pHallJ pi G H x : x \in G -> pi.-Hall(G) (H :^ x) = pi.-Hall(G) H. +Proof. by move=> Gx; rewrite -{1}(conjGid Gx) pHallJ2. Qed. + +Lemma HallJ G H x : x \in G -> Hall G (H :^ x) = Hall G H. +Proof. +by move=> Gx; rewrite /Hall -!divgI -{1 3}(conjGid Gx) conjSg -conjIg !cardJg. +Qed. + +Lemma psubgroupJ pi G H x : + x \in G -> pi.-subgroup(G) (H :^ x) = pi.-subgroup(G) H. +Proof. by move=> Gx; rewrite /psubgroup pgroupJ -{1}(conjGid Gx) conjSg. Qed. + +Lemma p_groupJ P x : p_group (P :^ x) = p_group P. +Proof. by rewrite /p_group cardJg pgroupJ. Qed. + +Lemma SylowJ G P x : x \in G -> Sylow G (P :^ x) = Sylow G P. +Proof. by move=> Gx; rewrite /Sylow p_groupJ HallJ. Qed. + +Lemma p_Sylow p G P : p.-Sylow(G) P -> Sylow G P. +Proof. +by move=> pP; rewrite /Sylow (pgroup_p (pHall_pgroup pP)) (pHall_Hall pP). +Qed. + +Lemma pHall_subl pi G K H : + H \subset K -> K \subset G -> pi.-Hall(G) H -> pi.-Hall(K) H. +Proof. +move=> sHK sKG; rewrite /pHall sHK; case/and3P=> _ ->. +by apply: pnat_dvd; exact: indexSg. +Qed. + +Lemma Hall1 G : Hall G 1. +Proof. by rewrite /Hall sub1G cards1 coprime1n. Qed. + +Lemma p_group1 : @p_group gT 1. +Proof. by rewrite (@pgroup_p 2) ?pgroup1. Qed. + +Lemma Sylow1 G : Sylow G 1. +Proof. by rewrite /Sylow p_group1 Hall1. Qed. + +Lemma SylowP G P : reflect (exists2 p, prime p & p.-Sylow(G) P) (Sylow G P). +Proof. +apply: (iffP idP) => [| [p _]]; last exact: p_Sylow. +case/andP=> /p_groupP[p p_pr] /p_natP[[P1 _ | n oP /Hall_pi]]; last first. + by rewrite /= oP pi_of_exp // (eq_pHall _ _ (pi_of_prime _)) //; exists p. +have{p p_pr P1} ->: P :=: 1 by apply: card1_trivg; rewrite P1. +pose p := pdiv #|G|.+1; have p_pr: prime p by rewrite pdiv_prime ?ltnS. +exists p; rewrite // pHallE sub1G cards1 part_p'nat //. +apply/pgroupP=> q pr_q qG; apply/eqnP=> def_q. +have: p %| #|G| + 1 by rewrite addn1 pdiv_dvd. +by rewrite dvdn_addr -def_q // Euclid_dvd1. +Qed. + +Lemma p_elt_exp pi x m : pi.-elt (x ^+ m) = (#[x]`_pi^' %| m). +Proof. +apply/idP/idP=> [pi_xm | /dvdnP[q ->{m}]]; last first. + rewrite mulnC; apply: pnat_dvd (part_pnat pi #[x]). + by rewrite order_dvdn -expgM mulnC mulnA partnC // -order_dvdn dvdn_mulr. +rewrite -(@Gauss_dvdr _ #[x ^+ m]); last first. + by rewrite coprime_sym (pnat_coprime pi_xm) ?part_pnat. +apply: (@dvdn_trans #[x]); first by rewrite -{2}[#[x]](partnC pi) ?dvdn_mull. +by rewrite order_dvdn mulnC expgM expg_order. +Qed. + +Lemma mem_p_elt pi x G : pi.-group G -> x \in G -> pi.-elt x. +Proof. by move=> piG Gx; apply: pgroupS piG; rewrite cycle_subG. Qed. + +Lemma p_eltM_norm pi x y : + x \in 'N(<[y]>) -> pi.-elt x -> pi.-elt y -> pi.-elt (x * y). +Proof. +move=> nyx pi_x pi_y; apply: (@mem_p_elt pi _ (<[x]> <*> <[y]>)%G). + by rewrite /= norm_joinEl ?cycle_subG // pgroupM; exact/andP. +by rewrite groupM // mem_gen // inE cycle_id ?orbT. +Qed. + +Lemma p_eltM pi x y : commute x y -> pi.-elt x -> pi.-elt y -> pi.-elt (x * y). +Proof. +move=> cxy; apply: p_eltM_norm; apply: (subsetP (cent_sub _)). +by rewrite cent_gen cent_set1; exact/cent1P. +Qed. + +Lemma p_elt1 pi : pi.-elt (1 : gT). +Proof. by rewrite /p_elt order1. Qed. + +Lemma p_eltV pi x : pi.-elt x^-1 = pi.-elt x. +Proof. by rewrite /p_elt orderV. Qed. + +Lemma p_eltX pi x n : pi.-elt x -> pi.-elt (x ^+ n). +Proof. by rewrite -{1}[x]expg1 !p_elt_exp dvdn1 => /eqnP->. Qed. + +Lemma p_eltJ pi x y : pi.-elt (x ^ y) = pi.-elt x. +Proof. by congr pnat; rewrite orderJ. Qed. + +Lemma sub_p_elt pi1 pi2 x : {subset pi1 <= pi2} -> pi1.-elt x -> pi2.-elt x. +Proof. by move=> pi12; apply: sub_in_pnat => q _; exact: pi12. Qed. + +Lemma eq_p_elt pi1 pi2 x : pi1 =i pi2 -> pi1.-elt x = pi2.-elt x. +Proof. by move=> pi12; exact: eq_pnat. Qed. + +Lemma p_eltNK pi x : pi^'^'.-elt x = pi.-elt x. +Proof. exact: pnatNK. Qed. + +Lemma eq_constt pi1 pi2 x : pi1 =i pi2 -> x.`_pi1 = x.`_pi2. +Proof. +move=> pi12; congr (x ^+ (chinese _ _ 1 0)); apply: eq_partn => // a. +by congr (~~ _); exact: pi12. +Qed. + +Lemma consttNK pi x : x.`_pi^'^' = x.`_pi. +Proof. by rewrite /constt !partnNK. Qed. + +Lemma cycle_constt pi x : x.`_pi \in <[x]>. +Proof. exact: mem_cycle. Qed. + +Lemma consttV pi x : (x^-1).`_pi = (x.`_pi)^-1. +Proof. by rewrite /constt expgVn orderV. Qed. + +Lemma constt1 pi : 1.`_pi = 1 :> gT. +Proof. exact: expg1n. Qed. + +Lemma consttJ pi x y : (x ^ y).`_pi = x.`_pi ^ y. +Proof. by rewrite /constt orderJ conjXg. Qed. + +Lemma p_elt_constt pi x : pi.-elt x.`_pi. +Proof. by rewrite p_elt_exp /chinese addn0 mul1n dvdn_mulr. Qed. + +Lemma consttC pi x : x.`_pi * x.`_pi^' = x. +Proof. +apply/eqP; rewrite -{3}[x]expg1 -expgD eq_expg_mod_order. +rewrite partnNK -{5 6}(@partnC pi #[x]) // /chinese !addn0. +by rewrite chinese_remainder ?chinese_modl ?chinese_modr ?coprime_partC ?eqxx. +Qed. + +Lemma p'_elt_constt pi x : pi^'.-elt (x * (x.`_pi)^-1). +Proof. by rewrite -{1}(consttC pi^' x) consttNK mulgK p_elt_constt. Qed. + +Lemma order_constt pi (x : gT) : #[x.`_pi] = #[x]`_pi. +Proof. +rewrite -{2}(consttC pi x) orderM; [|exact: commuteX2|]; last first. + by apply: (@pnat_coprime pi); exact: p_elt_constt. +by rewrite partnM // part_pnat_id ?part_p'nat ?muln1 //; exact: p_elt_constt. +Qed. + +Lemma consttM pi x y : commute x y -> (x * y).`_pi = x.`_pi * y.`_pi. +Proof. +move=> cxy; pose m := #|<<[set x; y]>>|; have m_gt0: 0 < m := cardG_gt0 _. +pose k := chinese m`_pi m`_pi^' 1 0. +suffices kXpi z: z \in <<[set x; y]>> -> z.`_pi = z ^+ k. + by rewrite !kXpi ?expgMn // ?groupM ?mem_gen // !inE eqxx ?orbT. +move=> xyz; have{xyz} zm: #[z] %| m by rewrite cardSg ?cycle_subG. +apply/eqP; rewrite eq_expg_mod_order -{3 4}[#[z]](partnC pi) //. +rewrite chinese_remainder ?chinese_modl ?chinese_modr ?coprime_partC //. +rewrite -!(modn_dvdm k (partn_dvd _ m_gt0 zm)). +rewrite chinese_modl ?chinese_modr ?coprime_partC //. +by rewrite !modn_dvdm ?partn_dvd ?eqxx. +Qed. + +Lemma consttX pi x n : (x ^+ n).`_pi = x.`_pi ^+ n. +Proof. +elim: n => [|n IHn]; first exact: constt1. +rewrite !expgS consttM ?IHn //; exact: commuteX. +Qed. + +Lemma constt1P pi x : reflect (x.`_pi = 1) (pi^'.-elt x). +Proof. +rewrite -{2}[x]expg1 p_elt_exp -order_constt consttNK order_dvdn expg1. +exact: eqP. +Qed. + +Lemma constt_p_elt pi x : pi.-elt x -> x.`_pi = x. +Proof. +by rewrite -p_eltNK -{3}(consttC pi x) => /constt1P->; rewrite mulg1. +Qed. + +Lemma sub_in_constt pi1 pi2 x : + {in \pi(#[x]), {subset pi1 <= pi2}} -> x.`_pi2.`_pi1 = x.`_pi1. +Proof. +move=> pi12; rewrite -{2}(consttC pi2 x) consttM; last exact: commuteX2. +rewrite (constt1P _ x.`_pi2^' _) ?mulg1 //. +apply: sub_in_pnat (p_elt_constt _ x) => p; rewrite order_constt => pi_p. +apply: contra; apply: pi12. +by rewrite -[#[x]](partnC pi2^') // primes_mul // pi_p. +Qed. + +Lemma prod_constt x : \prod_(0 <= p < #[x].+1) x.`_p = x. +Proof. +pose lp n := [pred p | p < n]. +have: (lp #[x].+1).-elt x by apply/pnatP=> // p _; exact: dvdn_leq. +move/constt_p_elt=> def_x; symmetry; rewrite -{1}def_x {def_x}. +elim: _.+1 => [|p IHp]. + by rewrite big_nil; apply/constt1P; exact/pgroupP. +rewrite big_nat_recr //= -{}IHp -(consttC (lp p) x.`__); congr (_ * _). + rewrite sub_in_constt // => q _; exact: leqW. +set y := _.`__; rewrite -(consttC p y) (constt1P p^' _ _) ?mulg1. + by rewrite 2?sub_in_constt // => q _; move/eqnP->; rewrite !inE ?ltnn. +rewrite /p_elt pnatNK !order_constt -partnI. +apply: sub_in_pnat (part_pnat _ _) => q _. +by rewrite !inE ltnS -leqNgt -eqn_leq. +Qed. + +Lemma max_pgroupJ pi M G x : + x \in G -> [max M | pi.-subgroup(G) M] -> + [max M :^ x of M | pi.-subgroup(G) M]. +Proof. +move=> Gx /maxgroupP[piM maxM]; apply/maxgroupP. +split=> [|H piH]; first by rewrite psubgroupJ. +by rewrite -(conjsgKV x H) conjSg => /maxM/=-> //; rewrite psubgroupJ ?groupV. +Qed. + +Lemma comm_sub_max_pgroup pi H M G : + [max M | pi.-subgroup(G) M] -> pi.-group H -> H \subset G -> + commute H M -> H \subset M. +Proof. +case/maxgroupP=> /andP[sMG piM] maxM piH sHG cHM. +rewrite -(maxM (H <*> M)%G) /= comm_joingE ?(mulG_subl, mulG_subr) //. +by rewrite /psubgroup pgroupM piM piH mul_subG. +Qed. + +Lemma normal_sub_max_pgroup pi H M G : + [max M | pi.-subgroup(G) M] -> pi.-group H -> H <| G -> H \subset M. +Proof. +move=> maxM piH /andP[sHG nHG]. +apply: comm_sub_max_pgroup piH sHG _ => //; apply: commute_sym; apply: normC. +by apply: subset_trans nHG; case/andP: (maxgroupp maxM). +Qed. + +Lemma norm_sub_max_pgroup pi H M G : + [max M | pi.-subgroup(G) M] -> pi.-group H -> H \subset G -> + H \subset 'N(M) -> H \subset M. +Proof. by move=> maxM piH sHG /normC; exact: comm_sub_max_pgroup piH sHG. Qed. + +Lemma sub_pHall pi H G K : + pi.-Hall(G) H -> pi.-group K -> H \subset K -> K \subset G -> K :=: H. +Proof. +move=> hallH piK sHK sKG; apply/eqP; rewrite eq_sym eqEcard sHK. +by rewrite (card_Hall hallH) -(part_pnat_id piK) dvdn_leq ?partn_dvd ?cardSg. +Qed. + +Lemma Hall_max pi H G : pi.-Hall(G) H -> [max H | pi.-subgroup(G) H]. +Proof. +move=> hallH; apply/maxgroupP; split=> [|K]. + by rewrite /psubgroup; case/and3P: hallH => ->. +case/andP=> sKG piK sHK; exact: (sub_pHall hallH). +Qed. + +Lemma pHall_id pi H G : pi.-Hall(G) H -> pi.-group G -> H :=: G. +Proof. +by move=> hallH piG; rewrite (sub_pHall hallH piG) ?(pHall_sub hallH). +Qed. + +Lemma psubgroup1 pi G : pi.-subgroup(G) 1. +Proof. by rewrite /psubgroup sub1G pgroup1. Qed. + +Lemma Cauchy p G : prime p -> p %| #|G| -> {x | x \in G & #[x] = p}. +Proof. +move=> p_pr; elim: {G}_.+1 {-2}G (ltnSn #|G|) => // n IHn G. +rewrite ltnS => leGn pG; pose xpG := [pred x in G | #[x] == p]. +have [x /andP[Gx /eqP] | no_x] := pickP xpG; first by exists x. +have{pG n leGn IHn} pZ: p %| #|'C_G(G)|. + suffices /dvdn_addl <-: p %| #|G :\: 'C(G)| by rewrite cardsID. + have /acts_sum_card_orbit <-: [acts G, on G :\: 'C(G) | 'J]. + by apply/actsP=> x Gx y; rewrite !inE -!mem_conjgV -centJ conjGid ?groupV. + elim/big_rec: _ => // _ _ /imsetP[x /setDP[Gx nCx] ->] /dvdn_addl->. + have ltCx: 'C_G[x] \proper G by rewrite properE subsetIl subsetIidl sub_cent1. + have /negP: ~ p %| #|'C_G[x]|. + case/(IHn _ (leq_trans (proper_card ltCx) leGn))=> y /setIP[Gy _] /eqP-oy. + by have /andP[] := no_x y. + by apply/implyP; rewrite -index_cent1 indexgI implyNb -Euclid_dvdM ?LagrangeI. +have [Q maxQ _]: {Q | [max Q | p^'.-subgroup('C_G(G)) Q] & 1%G \subset Q}. + apply: maxgroup_exists; exact: psubgroup1. +case/andP: (maxgroupp maxQ) => sQC; rewrite /pgroup p'natE // => /negP[]. +apply: dvdn_trans pZ (cardSg _); apply/subsetP=> x /setIP[Gx Cx]. +rewrite -sub1set -gen_subG (normal_sub_max_pgroup maxQ) //; last first. + rewrite /normal subsetI !cycle_subG ?Gx ?cents_norm ?subIset ?andbT //=. + by rewrite centsC cycle_subG Cx. +rewrite /pgroup p'natE //= -[#|_|]/#[x]; apply/dvdnP=> [[m oxm]]. +have m_gt0: 0 < m by apply: dvdn_gt0 (order_gt0 x) _; rewrite oxm dvdn_mulr. +case/idP: (no_x (x ^+ m)); rewrite /= groupX //= orderXgcd //= oxm. +by rewrite gcdnC gcdnMr mulKn. +Qed. + +(* These lemmas actually hold for maximal pi-groups, but below we'll *) +(* derive from the Cauchy lemma that a normal max pi-group is Hall. *) + +Lemma sub_normal_Hall pi G H K : + pi.-Hall(G) H -> H <| G -> K \subset G -> (K \subset H) = pi.-group K. +Proof. +move=> hallH nsHG sKG; apply/idP/idP=> [sKH | piK]. + by rewrite (pgroupS sKH) ?(pHall_pgroup hallH). +apply: norm_sub_max_pgroup (Hall_max hallH) piK _ _ => //. +exact: subset_trans sKG (normal_norm nsHG). +Qed. + +Lemma mem_normal_Hall pi H G x : + pi.-Hall(G) H -> H <| G -> x \in G -> (x \in H) = pi.-elt x. +Proof. by rewrite -!cycle_subG; exact: sub_normal_Hall. Qed. + +Lemma uniq_normal_Hall pi H G K : + pi.-Hall(G) H -> H <| G -> [max K | pi.-subgroup(G) K] -> K :=: H. +Proof. +move=> hallH nHG /maxgroupP[/andP[sKG piK] /(_ H) -> //]. + exact: (maxgroupp (Hall_max hallH)). +by rewrite (sub_normal_Hall hallH). +Qed. + +End PgroupProps. + +Implicit Arguments pgroupP [gT pi G]. +Implicit Arguments constt1P [gT pi x]. +Prenex Implicits pgroupP constt1P. + +Section NormalHall. + +Variables (gT : finGroupType) (pi : nat_pred). +Implicit Types G H K : {group gT}. + +Lemma normal_max_pgroup_Hall G H : + [max H | pi.-subgroup(G) H] -> H <| G -> pi.-Hall(G) H. +Proof. +case/maxgroupP=> /andP[sHG piH] maxH nsHG; have [_ nHG] := andP nsHG. +rewrite /pHall sHG piH; apply/pnatP=> // p p_pr. +rewrite inE /= -pnatE // -card_quotient //. +case/Cauchy=> //= Hx; rewrite -sub1set -gen_subG -/<[Hx]> /order. +case/inv_quotientS=> //= K -> sHK sKG {Hx}. +rewrite card_quotient ?(subset_trans sKG) // => iKH; apply/negP=> pi_p. +rewrite -iKH -divgS // (maxH K) ?divnn ?cardG_gt0 // in p_pr. +by rewrite /psubgroup sKG /pgroup -(Lagrange sHK) mulnC pnat_mul iKH pi_p. +Qed. + +Lemma setI_normal_Hall G H K : + H <| G -> pi.-Hall(G) H -> K \subset G -> pi.-Hall(K) (H :&: K). +Proof. +move=> nsHG hallH sKG; apply: normal_max_pgroup_Hall; last first. + by rewrite /= setIC (normalGI sKG nsHG). +apply/maxgroupP; split=> [|M /andP[sMK piM] sHK_M]. + by rewrite /psubgroup subsetIr (pgroupS (subsetIl _ _) (pHall_pgroup hallH)). +apply/eqP; rewrite eqEsubset sHK_M subsetI sMK !andbT. +by rewrite (sub_normal_Hall hallH) // (subset_trans sMK). +Qed. + +End NormalHall. + +Section Morphim. + +Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}). +Implicit Types (pi : nat_pred) (G H P : {group aT}). + +Lemma morphim_pgroup pi G : pi.-group G -> pi.-group (f @* G). +Proof. by apply: pnat_dvd; exact: dvdn_morphim. Qed. + +Lemma morphim_odd G : odd #|G| -> odd #|f @* G|. +Proof. by rewrite !odd_2'nat; exact: morphim_pgroup. Qed. + +Lemma pmorphim_pgroup pi G : + pi.-group ('ker f) -> G \subset D -> pi.-group (f @* G) = pi.-group G. +Proof. +move=> piker sGD; apply/idP/idP=> [pifG|]; last exact: morphim_pgroup. +apply: (@pgroupS _ _ (f @*^-1 (f @* G))); first by rewrite -sub_morphim_pre. +by rewrite /pgroup card_morphpre ?morphimS // pnat_mul; exact/andP. +Qed. + +Lemma morphim_p_index pi G H : + H \subset D -> pi.-nat #|G : H| -> pi.-nat #|f @* G : f @* H|. +Proof. +by move=> sHD; apply: pnat_dvd; rewrite index_morphim ?subIset // sHD orbT. +Qed. + +Lemma morphim_pHall pi G H : + H \subset D -> pi.-Hall(G) H -> pi.-Hall(f @* G) (f @* H). +Proof. +move=> sHD /and3P[sHG piH pi'GH]. +by rewrite /pHall morphimS // morphim_pgroup // morphim_p_index. +Qed. + +Lemma pmorphim_pHall pi G H : + G \subset D -> H \subset D -> pi.-subgroup(H :&: G) ('ker f) -> + pi.-Hall(f @* G) (f @* H) = pi.-Hall(G) H. +Proof. +move=> sGD sHD /andP[/subsetIP[sKH sKG] piK]; rewrite !pHallE morphimSGK //. +apply: andb_id2l => sHG; rewrite -(Lagrange sKH) -(Lagrange sKG) partnM //. +by rewrite (part_pnat_id piK) !card_morphim !(setIidPr _) // eqn_pmul2l. +Qed. + +Lemma morphim_Hall G H : H \subset D -> Hall G H -> Hall (f @* G) (f @* H). +Proof. +by move=> sHD /HallP[pi piH]; apply: (@pHall_Hall _ pi); exact: morphim_pHall. +Qed. + +Lemma morphim_pSylow p G P : + P \subset D -> p.-Sylow(G) P -> p.-Sylow(f @* G) (f @* P). +Proof. exact: morphim_pHall. Qed. + +Lemma morphim_p_group P : p_group P -> p_group (f @* P). +Proof. by move/morphim_pgroup; exact: pgroup_p. Qed. + +Lemma morphim_Sylow G P : P \subset D -> Sylow G P -> Sylow (f @* G) (f @* P). +Proof. +by move=> sPD /andP[pP hallP]; rewrite /Sylow morphim_p_group // morphim_Hall. +Qed. + +Lemma morph_p_elt pi x : x \in D -> pi.-elt x -> pi.-elt (f x). +Proof. by move=> Dx; apply: pnat_dvd; exact: morph_order. Qed. + +Lemma morph_constt pi x : x \in D -> f x.`_pi = (f x).`_pi. +Proof. +move=> Dx; rewrite -{2}(consttC pi x) morphM ?groupX //. +rewrite consttM; last by rewrite !morphX //; exact: commuteX2. +have: pi.-elt (f x.`_pi) by rewrite morph_p_elt ?groupX ?p_elt_constt //. +have: pi^'.-elt (f x.`_pi^') by rewrite morph_p_elt ?groupX ?p_elt_constt //. +by move/constt1P->; move/constt_p_elt->; rewrite mulg1. +Qed. + +End Morphim. + +Section Pquotient. + +Variables (pi : nat_pred) (gT : finGroupType) (p : nat) (G H K : {group gT}). +Hypothesis piK : pi.-group K. + +Lemma quotient_pgroup : pi.-group (K / H). Proof. exact: morphim_pgroup. Qed. + +Lemma quotient_pHall : + K \subset 'N(H) -> pi.-Hall(G) K -> pi.-Hall(G / H) (K / H). +Proof. exact: morphim_pHall. Qed. + +Lemma quotient_odd : odd #|K| -> odd #|K / H|. Proof. exact: morphim_odd. Qed. + +Lemma pquotient_pgroup : G \subset 'N(K) -> pi.-group (G / K) = pi.-group G. +Proof. by move=> nKG; rewrite pmorphim_pgroup ?ker_coset. Qed. + +Lemma pquotient_pHall : + K <| G -> K <| H -> pi.-Hall(G / K) (H / K) = pi.-Hall(G) H. +Proof. +case/andP=> sKG nKG; case/andP=> sKH nKH. +by rewrite pmorphim_pHall // ker_coset /psubgroup subsetI sKH sKG. +Qed. + +Lemma ltn_log_quotient : + p.-group G -> H :!=: 1 -> H \subset G -> logn p #|G / H| < logn p #|G|. +Proof. +move=> pG ntH sHG; apply: contraLR (ltn_quotient ntH sHG); rewrite -!leqNgt. +rewrite {2}(card_pgroup pG) {2}(card_pgroup (morphim_pgroup _ pG)). +by case: (posnP p) => [-> //|]; exact: leq_pexp2l. +Qed. + +End Pquotient. + +(* Application of card_Aut_cyclic to internal faithful action on cyclic *) +(* p-subgroups. *) +Section InnerAutCyclicPgroup. + +Variables (gT : finGroupType) (p : nat) (G C : {group gT}). +Hypothesis nCG : G \subset 'N(C). + +Lemma logn_quotient_cent_cyclic_pgroup : + p.-group C -> cyclic C -> logn p #|G / 'C_G(C)| <= (logn p #|C|).-1. +Proof. +move=> pC cycC; have [-> | ntC] := eqsVneq C 1. + by rewrite cent1T setIT trivg_quotient cards1 logn1. +have [p_pr _ [e oC]] := pgroup_pdiv pC ntC. +rewrite -ker_conj_aut (card_isog (first_isog_loc _ _)) //. +apply: leq_trans (dvdn_leq_log _ _ (cardSg (Aut_conj_aut _ _))) _ => //. +rewrite card_Aut_cyclic // oC totient_pfactor //= logn_Gauss ?pfactorK //. +by rewrite prime_coprime // gtnNdvd // -(subnKC (prime_gt1 p_pr)). +Qed. + +Lemma p'group_quotient_cent_prime : + prime p -> #|C| %| p -> p^'.-group (G / 'C_G(C)). +Proof. +move=> p_pr pC; have pgC: p.-group C := pnat_dvd pC (pnat_id p_pr). +have [_ dv_p] := primeP p_pr; case/pred2P: {dv_p pC}(dv_p _ pC) => [|pC]. + by move/card1_trivg->; rewrite cent1T setIT trivg_quotient pgroup1. +have le_oGC := logn_quotient_cent_cyclic_pgroup pgC. +rewrite /pgroup -partn_eq1 ?cardG_gt0 // -dvdn1 p_part pfactor_dvdn // logn1. +by rewrite (leq_trans (le_oGC _)) ?prime_cyclic // pC ?(pfactorK 1). +Qed. + +End InnerAutCyclicPgroup. + +Section PcoreDef. + +(* A functor needs to quantify over the finGroupType just beore the set. *) + +Variables (pi : nat_pred) (gT : finGroupType) (A : {set gT}). + +Definition pcore := \bigcap_(G | [max G | pi.-subgroup(A) G]) G. + +Canonical pcore_group : {group gT} := Eval hnf in [group of pcore]. + +End PcoreDef. + +Arguments Scope pcore [_ nat_scope group_scope]. +Arguments Scope pcore_group [_ nat_scope Group_scope]. +Notation "''O_' pi ( G )" := (pcore pi G) + (at level 8, pi at level 2, format "''O_' pi ( G )") : group_scope. +Notation "''O_' pi ( G )" := (pcore_group pi G) : Group_scope. + +Section PseriesDefs. + +Variables (pis : seq nat_pred) (gT : finGroupType) (A : {set gT}). + +Definition pcore_mod pi B := coset B @*^-1 'O_pi(A / B). +Canonical pcore_mod_group pi B : {group gT} := + Eval hnf in [group of pcore_mod pi B]. + +Definition pseries := foldr pcore_mod 1 (rev pis). + +Lemma pseries_group_set : group_set pseries. +Proof. rewrite /pseries; case: rev => [|pi1 pi1']; exact: groupP. Qed. + +Canonical pseries_group : {group gT} := group pseries_group_set. + +End PseriesDefs. + +Arguments Scope pseries [_ seq_scope group_scope]. +Local Notation ConsPred p := (@Cons nat_pred p%N) (only parsing). +Notation "''O_{' p1 , .. , pn } ( A )" := + (pseries (ConsPred p1 .. (ConsPred pn [::]) ..) A) + (at level 8, format "''O_{' p1 , .. , pn } ( A )") : group_scope. +Notation "''O_{' p1 , .. , pn } ( A )" := + (pseries_group (ConsPred p1 .. (ConsPred pn [::]) ..) A) : Group_scope. + +Section PCoreProps. + +Variables (pi : nat_pred) (gT : finGroupType). +Implicit Types (A : {set gT}) (G H M K : {group gT}). + +Lemma pcore_psubgroup G : pi.-subgroup(G) 'O_pi(G). +Proof. +have [M maxM _]: {M | [max M | pi.-subgroup(G) M] & 1%G \subset M}. + by apply: maxgroup_exists; rewrite /psubgroup sub1G pgroup1. +have sOM: 'O_pi(G) \subset M by exact: bigcap_inf. +have /andP[piM sMG] := maxgroupp maxM. +by rewrite /psubgroup (pgroupS sOM) // (subset_trans sOM). +Qed. + +Lemma pcore_pgroup G : pi.-group 'O_pi(G). +Proof. by case/andP: (pcore_psubgroup G). Qed. + +Lemma pcore_sub G : 'O_pi(G) \subset G. +Proof. by case/andP: (pcore_psubgroup G). Qed. + +Lemma pcore_sub_Hall G H : pi.-Hall(G) H -> 'O_pi(G) \subset H. +Proof. by move/Hall_max=> maxH; exact: bigcap_inf. Qed. + +Lemma pcore_max G H : pi.-group H -> H <| G -> H \subset 'O_pi(G). +Proof. +move=> piH nHG; apply/bigcapsP=> M maxM. +exact: normal_sub_max_pgroup piH nHG. +Qed. + +Lemma pcore_pgroup_id G : pi.-group G -> 'O_pi(G) = G. +Proof. by move=> piG; apply/eqP; rewrite eqEsubset pcore_sub pcore_max. Qed. + +Lemma pcore_normal G : 'O_pi(G) <| G. +Proof. +rewrite /(_ <| G) pcore_sub; apply/subsetP=> x Gx. +rewrite inE; apply/bigcapsP=> M maxM; rewrite sub_conjg. +by apply: bigcap_inf; apply: max_pgroupJ; rewrite ?groupV. +Qed. + +Lemma normal_Hall_pcore H G : pi.-Hall(G) H -> H <| G -> 'O_pi(G) = H. +Proof. +move=> hallH nHG; apply/eqP. +rewrite eqEsubset (sub_normal_Hall hallH) ?pcore_sub ?pcore_pgroup //=. +by rewrite pcore_max //= (pHall_pgroup hallH). +Qed. + +Lemma eq_Hall_pcore G H : + pi.-Hall(G) 'O_pi(G) -> pi.-Hall(G) H -> H :=: 'O_pi(G). +Proof. +move=> hallGpi hallH. +exact: uniq_normal_Hall (pcore_normal G) (Hall_max hallH). +Qed. + +Lemma sub_Hall_pcore G K : + pi.-Hall(G) 'O_pi(G) -> K \subset G -> (K \subset 'O_pi(G)) = pi.-group K. +Proof. by move=> hallGpi; exact: sub_normal_Hall (pcore_normal G). Qed. + +Lemma mem_Hall_pcore G x : + pi.-Hall(G) 'O_pi(G) -> x \in G -> (x \in 'O_pi(G)) = pi.-elt x. +Proof. move=> hallGpi; exact: mem_normal_Hall (pcore_normal G). Qed. + +Lemma sdprod_Hall_pcoreP H G : + pi.-Hall(G) 'O_pi(G) -> reflect ('O_pi(G) ><| H = G) (pi^'.-Hall(G) H). +Proof. +move=> hallGpi; rewrite -(compl_pHall H hallGpi) complgC. +exact: sdprod_normal_complP (pcore_normal G). +Qed. + +Lemma sdprod_pcore_HallP H G : + pi^'.-Hall(G) H -> reflect ('O_pi(G) ><| H = G) (pi.-Hall(G) 'O_pi(G)). +Proof. exact: sdprod_normal_p'HallP (pcore_normal G). Qed. + +Lemma pcoreJ G x : 'O_pi(G :^ x) = 'O_pi(G) :^ x. +Proof. +apply/eqP; rewrite eqEsubset -sub_conjgV. +rewrite !pcore_max ?pgroupJ ?pcore_pgroup ?normalJ ?pcore_normal //. +by rewrite -(normalJ _ _ x) conjsgKV pcore_normal. +Qed. + +End PCoreProps. + +Section MorphPcore. + +Implicit Types (pi : nat_pred) (gT rT : finGroupType). + +Lemma morphim_pcore pi : GFunctor.pcontinuous (pcore pi). +Proof. +move=> gT rT D G f; apply/bigcapsP=> M /normal_sub_max_pgroup; apply. + by rewrite morphim_pgroup ?pcore_pgroup. +apply: morphim_normal; exact: pcore_normal. +Qed. + +Lemma pcoreS pi gT (G H : {group gT}) : + H \subset G -> H :&: 'O_pi(G) \subset 'O_pi(H). +Proof. +move=> sHG; rewrite -{2}(setIidPl sHG). +do 2!rewrite -(morphim_idm (subsetIl H _)) morphimIdom; exact: morphim_pcore. +Qed. + +Canonical pcore_igFun pi := [igFun by pcore_sub pi & morphim_pcore pi]. +Canonical pcore_gFun pi := [gFun by morphim_pcore pi]. +Canonical pcore_pgFun pi := [pgFun by morphim_pcore pi]. + +Lemma pcore_char pi gT (G : {group gT}) : 'O_pi(G) \char G. +Proof. exact: gFchar. Qed. + +Section PcoreMod. + +Variable F : GFunctor.pmap. + +Lemma pcore_mod_sub pi gT (G : {group gT}) : pcore_mod G pi (F _ G) \subset G. +Proof. +have nFD := gFnorm F G; rewrite sub_morphpre_im ?pcore_sub //=. + by rewrite ker_coset_prim subIset // gen_subG gFsub. +by apply: subset_trans (pcore_sub _ _) _; apply: morphimS. +Qed. + +Lemma quotient_pcore_mod pi gT (G : {group gT}) (B : {set gT}) : + pcore_mod G pi B / B = 'O_pi(G / B). +Proof. +apply: morphpreK; apply: subset_trans (pcore_sub _ _) _. +by rewrite /= /quotient -morphimIdom morphimS ?subsetIl. +Qed. + +Lemma morphim_pcore_mod pi gT rT (D G : {group gT}) (f : {morphism D >-> rT}) : + f @* pcore_mod G pi (F _ G) \subset pcore_mod (f @* G) pi (F _ (f @* G)). +Proof. +have sDF: D :&: G \subset 'dom (coset (F _ G)). + by rewrite setIC subIset ?gFnorm. +have sDFf: D :&: G \subset 'dom (coset (F _ (f @* G)) \o f). + by rewrite -sub_morphim_pre ?subsetIl // morphimIdom gFnorm. +pose K := 'ker (restrm sDFf (coset (F _ (f @* G)) \o f)). +have sFK: 'ker (restrm sDF (coset (F _ G))) \subset K. + rewrite /K !ker_restrm ker_comp /= subsetI subsetIl /= -setIA. + rewrite -sub_morphim_pre ?subsetIl //. + by rewrite morphimIdom !ker_coset (setIidPr _) ?pmorphimF ?gFsub. +have sOF := pcore_sub pi (G / F _ G); have sDD: D :&: G \subset D :&: G by []. +rewrite -sub_morphim_pre -?quotientE; last first. + by apply: subset_trans (gFnorm F _); rewrite morphimS ?pcore_mod_sub. +suffices im_fact (H : {group gT}) : F _ G \subset H -> H \subset G -> + factm sFK sDD @* (H / F _ G) = f @* H / F _ (f @* G). +- rewrite -2?im_fact ?pcore_mod_sub ?gFsub //; + try by rewrite -{1}[F _ G]ker_coset morphpreS ?sub1G. + by rewrite quotient_pcore_mod morphim_pcore. +move=> sFH sHG; rewrite -(morphimIdom _ (H / _)) /= {2}morphim_restrm setIid. +rewrite -morphimIG ?ker_coset //. +rewrite -(morphim_restrm sDF) morphim_factm morphim_restrm. +by rewrite morphim_comp -quotientE -setIA morphimIdom (setIidPr _). +Qed. + +Lemma pcore_mod_res pi gT rT (D : {group gT}) (f : {morphism D >-> rT}) : + f @* pcore_mod D pi (F _ D) \subset pcore_mod (f @* D) pi (F _ (f @* D)). +Proof. exact: morphim_pcore_mod. Qed. + +Lemma pcore_mod1 pi gT (G : {group gT}) : pcore_mod G pi 1 = 'O_pi(G). +Proof. +rewrite /pcore_mod; have inj1 := coset1_injm gT; rewrite -injmF ?norms1 //. +by rewrite -(morphim_invmE inj1) morphim_invm ?norms1. +Qed. + +End PcoreMod. + +Lemma pseries_rcons pi pis gT (A : {set gT}) : + pseries (rcons pis pi) A = pcore_mod A pi (pseries pis A). +Proof. by rewrite /pseries rev_rcons. Qed. + +Lemma pseries_subfun pis : + GFunctor.closed (pseries pis) /\ GFunctor.pcontinuous (pseries pis). +Proof. +elim/last_ind: pis => [|pis pi [sFpi fFpi]]. + by split=> [gT G | gT rT D G f]; rewrite (sub1G, morphim1). +pose fF := [gFun by fFpi : GFunctor.continuous [igFun by sFpi & fFpi]]. +pose F := [pgFun by fFpi : GFunctor.hereditary fF]. +split=> [gT G | gT rT D G f]; rewrite !pseries_rcons ?(pcore_mod_sub F) //. +exact: (morphim_pcore_mod F). +Qed. + +Lemma pseries_sub pis : GFunctor.closed (pseries pis). +Proof. by case: (pseries_subfun pis). Qed. + +Lemma morphim_pseries pis : GFunctor.pcontinuous (pseries pis). +Proof. by case: (pseries_subfun pis). Qed. + +Lemma pseriesS pis : GFunctor.hereditary (pseries pis). +Proof. exact: (morphim_pseries pis). Qed. + +Canonical pseries_igFun pis := [igFun by pseries_sub pis & morphim_pseries pis]. +Canonical pseries_gFun pis := [gFun by morphim_pseries pis]. +Canonical pseries_pgFun pis := [pgFun by morphim_pseries pis]. + +Lemma pseries_char pis gT (G : {group gT}) : pseries pis G \char G. +Proof. exact: gFchar. Qed. + +Lemma pseries_normal pis gT (G : {group gT}) : pseries pis G <| G. +Proof. exact: gFnormal. Qed. + +Lemma pseriesJ pis gT (G : {group gT}) x : + pseries pis (G :^ x) = pseries pis G :^ x. +Proof. +rewrite -{1}(setIid G) -morphim_conj -(injmF _ (injm_conj G x)) //=. +by rewrite morphim_conj (setIidPr (pseries_sub _ _)). +Qed. + +Lemma pseries1 pi gT (G : {group gT}) : 'O_{pi}(G) = 'O_pi(G). +Proof. exact: pcore_mod1. Qed. + +Lemma pseries_pop pi pis gT (G : {group gT}) : + 'O_pi(G) = 1 -> pseries (pi :: pis) G = pseries pis G. +Proof. +by move=> OG1; rewrite /pseries rev_cons -cats1 foldr_cat /= pcore_mod1 OG1. +Qed. + +Lemma pseries_pop2 pi1 pi2 gT (G : {group gT}) : + 'O_pi1(G) = 1 -> 'O_{pi1, pi2}(G) = 'O_pi2(G). +Proof. by move/pseries_pop->; exact: pseries1. Qed. + +Lemma pseries_sub_catl pi1s pi2s gT (G : {group gT}) : + pseries pi1s G \subset pseries (pi1s ++ pi2s) G. +Proof. +elim/last_ind: pi2s => [|pi pis IHpi]; rewrite ?cats0 // -rcons_cat. +by rewrite pseries_rcons; apply: subset_trans IHpi _; rewrite sub_cosetpre. +Qed. + +Lemma quotient_pseries pis pi gT (G : {group gT}) : + pseries (rcons pis pi) G / pseries pis G = 'O_pi(G / pseries pis G). +Proof. by rewrite pseries_rcons quotient_pcore_mod. Qed. + +Lemma pseries_norm2 pi1s pi2s gT (G : {group gT}) : + pseries pi2s G \subset 'N(pseries pi1s G). +Proof. +apply: subset_trans (normal_norm (pseries_normal pi1s G)); exact: pseries_sub. +Qed. + +Lemma pseries_sub_catr pi1s pi2s gT (G : {group gT}) : + pseries pi2s G \subset pseries (pi1s ++ pi2s) G. +Proof. +elim: pi1s => //= pi1 pi1s /subset_trans; apply. +elim/last_ind: {pi1s pi2s}(_ ++ _) => [|pis pi IHpi]; first exact: sub1G. +rewrite -rcons_cons (pseries_rcons _ (pi1 :: pis)). +rewrite -sub_morphim_pre ?pseries_norm2 //. +apply: pcore_max; last by rewrite morphim_normal ?pseries_normal. +have: pi.-group (pseries (rcons pis pi) G / pseries pis G). + by rewrite quotient_pseries pcore_pgroup. +by apply: pnat_dvd; rewrite !card_quotient ?pseries_norm2 // indexgS. +Qed. + +Lemma quotient_pseries2 pi1 pi2 gT (G : {group gT}) : + 'O_{pi1, pi2}(G) / 'O_pi1(G) = 'O_pi2(G / 'O_pi1(G)). +Proof. by rewrite -pseries1 -quotient_pseries. Qed. + +Lemma quotient_pseries_cat pi1s pi2s gT (G : {group gT}) : + pseries (pi1s ++ pi2s) G / pseries pi1s G + = pseries pi2s (G / pseries pi1s G). +Proof. +elim/last_ind: pi2s => [|pi2s pi IHpi]; first by rewrite cats0 trivg_quotient. +have psN := pseries_normal _ G; set K := pseries _ G. +case: (third_isom (pseries_sub_catl pi1s pi2s G) (psN _)) => //= f inj_f im_f. +have nH2H: pseries pi2s (G / K) <| pseries (pi1s ++ rcons pi2s pi) G / K. + rewrite -IHpi morphim_normal // -cats1 catA. + by apply/andP; rewrite pseries_sub_catl pseries_norm2. +apply: (quotient_inj nH2H). + by apply/andP; rewrite /= -cats1 pseries_sub_catl pseries_norm2. +rewrite /= quotient_pseries /= -IHpi -rcons_cat. +rewrite -[G / _ / _](morphim_invm inj_f) //= {2}im_f //. +rewrite -(@injmF [igFun of pcore pi]) /= ?injm_invm ?im_f // -quotient_pseries. +by rewrite -im_f ?morphim_invm ?morphimS ?normal_sub. +Qed. + +Lemma pseries_catl_id pi1s pi2s gT (G : {group gT}) : + pseries pi1s (pseries (pi1s ++ pi2s) G) = pseries pi1s G. +Proof. +elim/last_ind: pi1s => [//|pi1s pi IHpi] in pi2s *. +apply: (@quotient_inj _ (pseries_group pi1s G)). +- rewrite /= -(IHpi (pi :: pi2s)) cat_rcons /(_ <| _) pseries_norm2. + by rewrite -cats1 pseries_sub_catl. +- by rewrite /= /(_ <| _) pseries_norm2 -cats1 pseries_sub_catl. +rewrite /= cat_rcons -(IHpi (pi :: pi2s)) {1}quotient_pseries IHpi. +apply/eqP; rewrite quotient_pseries eqEsubset !pcore_max ?pcore_pgroup //=. + rewrite -quotient_pseries morphim_normal // /(_ <| _) pseries_norm2. + by rewrite -cat_rcons pseries_sub_catl. +by rewrite (char_normal_trans (pcore_char _ _)) ?quotient_normal ?gFnormal. +Qed. + +Lemma pseries_char_catl pi1s pi2s gT (G : {group gT}) : + pseries pi1s G \char pseries (pi1s ++ pi2s) G. +Proof. by rewrite -(pseries_catl_id pi1s pi2s G) pseries_char. Qed. + +Lemma pseries_catr_id pi1s pi2s gT (G : {group gT}) : + pseries pi2s (pseries (pi1s ++ pi2s) G) = pseries pi2s G. +Proof. +elim/last_ind: pi2s => [//|pi2s pi IHpi] in G *. +have Epis: pseries pi2s (pseries (pi1s ++ rcons pi2s pi) G) = pseries pi2s G. + by rewrite -cats1 catA -2!IHpi pseries_catl_id. +apply: (@quotient_inj _ (pseries_group pi2s G)). +- by rewrite /= -Epis /(_ <| _) pseries_norm2 -cats1 pseries_sub_catl. +- by rewrite /= /(_ <| _) pseries_norm2 -cats1 pseries_sub_catl. +rewrite /= -Epis {1}quotient_pseries Epis quotient_pseries. +apply/eqP; rewrite eqEsubset !pcore_max ?pcore_pgroup //=. + rewrite -quotient_pseries morphim_normal // /(_ <| _) pseries_norm2. + by rewrite pseries_sub_catr. +apply: char_normal_trans (pcore_char pi _) (morphim_normal _ _). +exact: pseries_normal. +Qed. + +Lemma pseries_char_catr pi1s pi2s gT (G : {group gT}) : + pseries pi2s G \char pseries (pi1s ++ pi2s) G. +Proof. by rewrite -(pseries_catr_id pi1s pi2s G) pseries_char. Qed. + +Lemma pcore_modp pi gT (G H : {group gT}) : + H <| G -> pi.-group H -> pcore_mod G pi H = 'O_pi(G). +Proof. +move=> nsHG piH; apply/eqP; rewrite eqEsubset andbC. +have nHG := normal_norm nsHG; have sOG := subset_trans (pcore_sub pi _). +rewrite -sub_morphim_pre ?(sOG, morphim_pcore) // pcore_max //. + rewrite -(pquotient_pgroup piH) ?subsetIl //. + by rewrite quotient_pcore_mod pcore_pgroup. +by rewrite -{2}(quotientGK nsHG) morphpre_normal ?pcore_normal ?sOG ?morphimS. +Qed. + +Lemma pquotient_pcore pi gT (G H : {group gT}) : + H <| G -> pi.-group H -> 'O_pi(G / H) = 'O_pi(G) / H. +Proof. by move=> nsHG piH; rewrite -quotient_pcore_mod pcore_modp. Qed. + +Lemma trivg_pcore_quotient pi gT (G : {group gT}) : 'O_pi(G / 'O_pi(G)) = 1. +Proof. +by rewrite pquotient_pcore ?pcore_normal ?pcore_pgroup // trivg_quotient. +Qed. + +Lemma pseries_rcons_id pis pi gT (G : {group gT}) : + pseries (rcons (rcons pis pi) pi) G = pseries (rcons pis pi) G. +Proof. +apply/eqP; rewrite -!cats1 eqEsubset pseries_sub_catl andbT -catA. +rewrite -(quotientSGK _ (pseries_sub_catl _ _ _)) ?pseries_norm2 //. +rewrite !quotient_pseries_cat -quotient_sub1 ?pseries_norm2 //. +by rewrite quotient_pseries_cat /= !pseries1 trivg_pcore_quotient. +Qed. + +End MorphPcore. + +Section EqPcore. + +Variables gT : finGroupType. +Implicit Types (pi rho : nat_pred) (G H : {group gT}). + +Lemma sub_in_pcore pi rho G : + {in \pi(G), {subset pi <= rho}} -> 'O_pi(G) \subset 'O_rho(G). +Proof. +move=> pi_sub_rho; rewrite pcore_max ?pcore_normal //. +apply: sub_in_pnat (pcore_pgroup _ _) => p. +move/(piSg (pcore_sub _ _)); exact: pi_sub_rho. +Qed. + +Lemma sub_pcore pi rho G : {subset pi <= rho} -> 'O_pi(G) \subset 'O_rho(G). +Proof. by move=> pi_sub_rho; exact: sub_in_pcore (in1W pi_sub_rho). Qed. + +Lemma eq_in_pcore pi rho G : {in \pi(G), pi =i rho} -> 'O_pi(G) = 'O_rho(G). +Proof. +move=> eq_pi_rho; apply/eqP; rewrite eqEsubset. +by rewrite !sub_in_pcore // => p /eq_pi_rho->. +Qed. + +Lemma eq_pcore pi rho G : pi =i rho -> 'O_pi(G) = 'O_rho(G). +Proof. by move=> eq_pi_rho; exact: eq_in_pcore (in1W eq_pi_rho). Qed. + +Lemma pcoreNK pi G : 'O_pi^'^'(G) = 'O_pi(G). +Proof. by apply: eq_pcore; exact: negnK. Qed. + +Lemma eq_p'core pi rho G : pi =i rho -> 'O_pi^'(G) = 'O_rho^'(G). +Proof. by move/eq_negn; exact: eq_pcore. Qed. + +Lemma sdprod_Hall_p'coreP pi H G : + pi^'.-Hall(G) 'O_pi^'(G) -> reflect ('O_pi^'(G) ><| H = G) (pi.-Hall(G) H). +Proof. by rewrite -(pHallNK pi G H); exact: sdprod_Hall_pcoreP. Qed. + +Lemma sdprod_p'core_HallP pi H G : + pi.-Hall(G) H -> reflect ('O_pi^'(G) ><| H = G) (pi^'.-Hall(G) 'O_pi^'(G)). +Proof. by rewrite -(pHallNK pi G H); exact: sdprod_pcore_HallP. Qed. + +Lemma pcoreI pi rho G : 'O_[predI pi & rho](G) = 'O_pi('O_rho(G)). +Proof. +apply/eqP; rewrite eqEsubset !pcore_max //. +- rewrite /pgroup pnatI [pnat _ _]pcore_pgroup. + exact: pgroupS (pcore_sub _ _) (pcore_pgroup _ _). +- exact: char_normal_trans (pcore_char _ _) (pcore_normal _ _). +- by apply: sub_in_pnat (pcore_pgroup _ _) => p _ /andP[]. +apply/andP; split; first by apply: sub_pcore => p /andP[]. +by rewrite (subset_trans (pcore_sub _ _)) ?gFnorm. +Qed. + +Lemma bigcap_p'core pi G : + G :&: \bigcap_(p < #|G|.+1 | (p : nat) \in pi) 'O_p^'(G) = 'O_pi^'(G). +Proof. +apply/eqP; rewrite eqEsubset subsetI pcore_sub pcore_max /=. +- by apply/bigcapsP=> p pi_p; apply: sub_pcore => r; apply: contraNneq => ->. +- apply/pgroupP=> q q_pr qGpi'; apply: contraL (eqxx q) => /= pi_q. + apply: (pgroupP (pcore_pgroup q^' G)) => //. + have qG: q %| #|G| by rewrite (dvdn_trans qGpi') // cardSg ?subsetIl. + have ltqG: q < #|G|.+1 by rewrite ltnS dvdn_leq. + rewrite (dvdn_trans qGpi') ?cardSg ?subIset //= orbC. + by rewrite (bigcap_inf (Ordinal ltqG)). +rewrite /normal subsetIl normsI ?normG // norms_bigcap //. +by apply/bigcapsP => p _; exact: gFnorm. +Qed. + +Lemma coprime_pcoreC (rT : finGroupType) pi G (R : {group rT}) : + coprime #|'O_pi(G)| #|'O_pi^'(R)|. +Proof. exact: pnat_coprime (pcore_pgroup _ _) (pcore_pgroup _ _). Qed. + +Lemma TI_pcoreC pi G H : 'O_pi(G) :&: 'O_pi^'(H) = 1. +Proof. by rewrite coprime_TIg ?coprime_pcoreC. Qed. + +Lemma pcore_setI_normal pi G H : H <| G -> 'O_pi(G) :&: H = 'O_pi(H). +Proof. +move=> nsHG; apply/eqP; rewrite eqEsubset subsetI pcore_sub. +rewrite !pcore_max ?(pgroupS (subsetIl _ H)) ?pcore_pgroup //=. + exact: char_normal_trans (pcore_char pi H) nsHG. +by rewrite setIC (normalGI (normal_sub nsHG)) ?pcore_normal. +Qed. + +End EqPcore. + +Implicit Arguments sdprod_Hall_pcoreP [gT pi G H]. +Implicit Arguments sdprod_Hall_p'coreP [gT pi G H]. + +Section Injm. + +Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}). +Hypothesis injf : 'injm f. +Implicit Types (A : {set aT}) (G H : {group aT}). + +Lemma injm_pgroup pi A : A \subset D -> pi.-group (f @* A) = pi.-group A. +Proof. by move=> sAD; rewrite /pgroup card_injm. Qed. + +Lemma injm_pelt pi x : x \in D -> pi.-elt (f x) = pi.-elt x. +Proof. by move=> Dx; rewrite /p_elt order_injm. Qed. + +Lemma injm_pHall pi G H : + G \subset D -> H \subset D -> pi.-Hall(f @* G) (f @* H) = pi.-Hall(G) H. +Proof. by move=> sGD sGH; rewrite !pHallE injmSK ?card_injm. Qed. + +Lemma injm_pcore pi G : G \subset D -> f @* 'O_pi(G) = 'O_pi(f @* G). +Proof. exact: injmF. Qed. + +Lemma injm_pseries pis G : + G \subset D -> f @* pseries pis G = pseries pis (f @* G). +Proof. exact: injmF. Qed. + +End Injm. + +Section Isog. + +Variables (aT rT : finGroupType) (G : {group aT}) (H : {group rT}). + +Lemma isog_pgroup pi : G \isog H -> pi.-group G = pi.-group H. +Proof. by move=> isoGH; rewrite /pgroup (card_isog isoGH). Qed. + +Lemma isog_pcore pi : G \isog H -> 'O_pi(G) \isog 'O_pi(H). +Proof. exact: gFisog. Qed. + +Lemma isog_pseries pis : G \isog H -> pseries pis G \isog pseries pis H. +Proof. exact: gFisog. Qed. + +End Isog. diff --git a/mathcomp/solvable/primitive_action.v b/mathcomp/solvable/primitive_action.v new file mode 100644 index 0000000..7e2075d --- /dev/null +++ b/mathcomp/solvable/primitive_action.v @@ -0,0 +1,347 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat. +Require Import div seq fintype tuple finset. +Require Import fingroup action gseries. + +(******************************************************************************) +(* n-transitive and primitive actions: *) +(* [primitive A, on S | to] <=> *) +(* A acts on S in a primitive manner, i.e., A is transitive on S and *) +(* A does not act on any nontrivial partition of S. *) +(* imprimitivity_system A to S Q <=> *) +(* Q is a non-trivial primitivity system for the action of A on S via *) +(* to, i.e., Q is a non-trivial partiiton of S on which A acts. *) +(* to * n == in the %act scope, the total action induced by the total *) +(* action to on n.-tuples. via n_act to n. *) +(* n.-dtuple S == the set of n-tuples with distinct values in S. *) +(* [transitive^n A, on S | to] <=> *) +(* A is n-transitive on S, i.e., A is transitive on n.-dtuple S *) +(* == the set of n-tuples with distinct values in S. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +Section PrimitiveDef. + +Variables (aT : finGroupType) (sT : finType). +Variables (A : {set aT}) (S : {set sT}) (to : {action aT &-> sT}). + +Definition imprimitivity_system Q := + [&& partition Q S, [acts A, on Q | to^*] & 1 < #|Q| < #|S|]. + +Definition primitive := + [transitive A, on S | to] && ~~ [exists Q, imprimitivity_system Q]. + +End PrimitiveDef. + +Arguments Scope imprimitivity_system + [_ _ group_scope group_scope action_scope group_scope]. +Arguments Scope primitive [_ _ group_scope group_scope action_scope]. + +Notation "[ 'primitive' A , 'on' S | to ]" := (primitive A S to) + (at level 0, format "[ 'primitive' A , 'on' S | to ]") : form_scope. + +Prenex Implicits imprimitivity_system. + +Section Primitive. + +Variables (aT : finGroupType) (sT : finType). +Variables (G : {group aT}) (to : {action aT &-> sT}) (S : {set sT}). + +Lemma trans_prim_astab x : + x \in S -> [transitive G, on S | to] -> + [primitive G, on S | to] = maximal_eq 'C_G[x | to] G. +Proof. +move=> Sx trG; rewrite /primitive trG negb_exists. +apply/forallP/maximal_eqP=> /= [primG | [_ maxCx] Q]. + split=> [|H sCH sHG]; first exact: subsetIl. + pose X := orbit to H x; pose Q := orbit (to^*)%act G X. + have Xx: x \in X by exact: orbit_refl. + have defH: 'N_(G)(X | to) = H. + have trH: [transitive H, on X | to] by apply/imsetP; exists x. + have sHN: H \subset 'N_G(X | to) by rewrite subsetI sHG atrans_acts. + move/(subgroup_transitiveP Xx sHN): (trH) => /= <-. + by rewrite mulSGid //= setIAC subIset ?sCH. + apply/imsetP; exists x => //; apply/eqP. + by rewrite eqEsubset imsetS // acts_sub_orbit ?subsetIr. + have [|/proper_card oCH] := eqVproper sCH; [by left | right]. + apply/eqP; rewrite eqEcard sHG leqNgt. + apply: contra {primG}(primG Q) => oHG; apply/and3P; split; last first. + - rewrite card_orbit astab1_set defH -(@ltn_pmul2l #|H|) ?Lagrange // muln1. + rewrite oHG -(@ltn_pmul2l #|H|) ?Lagrange // -(card_orbit_stab to G x). + by rewrite -(atransP trG x Sx) mulnC card_orbit ltn_pmul2r. + - by apply/actsP=> a Ga Y; apply: orbit_transr; exact: mem_orbit. + apply/and3P; split; last 1 first. + - rewrite orbit_sym; apply/imsetP=> [[a _]] /= defX. + by rewrite defX /setact imset0 inE in Xx. + - apply/eqP/setP=> y; apply/bigcupP/idP=> [[_ /imsetP[a Ga ->]] | Sy]. + case/imsetP=> _ /imsetP[b Hb ->] ->. + by rewrite !(actsP (atrans_acts trG)) //; exact: subsetP Hb. + case: (atransP2 trG Sx Sy) => a Ga ->. + by exists ((to^*)%act X a); apply: mem_imset; rewrite // orbit_refl. + apply/trivIsetP=> _ _ /imsetP[a Ga ->] /imsetP[b Gb ->]. + apply: contraR => /exists_inP[_ /imsetP[_ /imsetP[a1 Ha1 ->] ->]]. + case/imsetP=> _ /imsetP[b1 Hb1 ->] /(canLR (actK _ _)) /(canLR (actK _ _)). + rewrite -(canF_eq (actKV _ _)) -!actM (sameP eqP astab1P) => /astab1P Cab. + rewrite astab1_set (subsetP (subsetIr G _)) //= defH. + rewrite -(groupMr _ (groupVr Hb1)) -mulgA -(groupMl _ Ha1). + by rewrite (subsetP sCH) // inE Cab !groupM ?groupV // (subsetP sHG). +apply/and3P=> [[/and3P[/eqP defS tIQ ntQ]]]; set sto := (to^*)%act => actQ. +rewrite !ltnNge -negb_or => /orP[]. +pose X := pblock Q x; have Xx: x \in X by rewrite mem_pblock defS. +have QX: X \in Q by rewrite pblock_mem ?defS. +have toX Y a: Y \in Q -> a \in G -> to x a \in Y -> sto X a = Y. + move=> QY Ga Yxa; rewrite -(contraNeq (trivIsetP tIQ Y (sto X a) _ _)) //. + by rewrite (actsP actQ). + by apply/existsP; exists (to x a); rewrite /= Yxa; apply: mem_imset. +have defQ: Q = orbit (to^*)%act G X. + apply/eqP; rewrite eqEsubset andbC acts_sub_orbit // QX. + apply/subsetP=> Y QY. + have /set0Pn[y Yy]: Y != set0 by apply: contraNneq ntQ => <-. + have Sy: y \in S by rewrite -defS; apply/bigcupP; exists Y. + have [a Ga def_y] := atransP2 trG Sx Sy. + by apply/imsetP; exists a; rewrite // (toX Y) // -def_y. +rewrite defQ card_orbit; case: (maxCx 'C_G[X | sto]%G) => /= [||->|->]. +- apply/subsetP=> a /setIP[Ga cxa]; rewrite inE Ga /=. + by apply/astab1P; rewrite (toX X) // (astab1P cxa). +- exact: subsetIl. +- by right; rewrite -card_orbit (atransP trG). +by left; rewrite indexgg. +Qed. + +Lemma prim_trans_norm (H : {group aT}) : + [primitive G, on S | to] -> H <| G -> + H \subset 'C_G(S | to) \/ [transitive H, on S | to]. +Proof. +move=> primG /andP[sHG nHG]; rewrite subsetI sHG. +have [trG _] := andP primG; have [x Sx defS] := imsetP trG. +move: primG; rewrite (trans_prim_astab Sx) // => /maximal_eqP[_]. +case/(_ ('C_G[x | to] <*> H)%G) => /= [||cxH|]; first exact: joing_subl. +- by rewrite join_subG subsetIl. +- have{cxH} cxH: H \subset 'C_G[x | to] by rewrite -cxH joing_subr. + rewrite subsetI sHG /= in cxH; left; apply/subsetP=> a Ha. + apply/astabP=> y Sy; have [b Gb ->] := atransP2 trG Sx Sy. + rewrite actCJV [to x (a ^ _)](astab1P _) ?(subsetP cxH) //. + by rewrite -mem_conjg (normsP nHG). +rewrite norm_joinEl 1?subIset ?nHG //. +by move/(subgroup_transitiveP Sx sHG trG); right. +Qed. + +End Primitive. + +Section NactionDef. + +Variables (gT : finGroupType) (sT : finType). +Variables (to : {action gT &-> sT}) (n : nat). + +Definition n_act (t : n.-tuple sT) a := [tuple of map (to^~ a) t]. + +Fact n_act_is_action : is_action setT n_act. +Proof. +by apply: is_total_action => [t|t a b]; apply: eq_from_tnth => i; + rewrite !tnth_map ?act1 ?actM. +Qed. + +Canonical n_act_action := Action n_act_is_action. + +End NactionDef. + +Notation "to * n" := (n_act_action to n) : action_scope. + +Section NTransitive. + +Variables (gT : finGroupType) (sT : finType). +Variables (n : nat) (A : {set gT}) (S : {set sT}) (to : {action gT &-> sT}). + +Definition dtuple_on := [set t : n.-tuple sT | uniq t & t \subset S]. +Definition ntransitive := [transitive A, on dtuple_on | to * n]. + +Lemma dtuple_onP t : + reflect (injective (tnth t) /\ forall i, tnth t i \in S) (t \in dtuple_on). +Proof. +rewrite inE subset_all -map_tnth_enum. +case: (uniq _) / (injectiveP (tnth t)) => f_inj; last by right; case. +rewrite -[all _ _]negbK -has_predC has_map has_predC negbK /=. +by apply: (iffP allP) => [Sf|[]//]; split=> // i; rewrite Sf ?mem_enum. +Qed. + +Lemma n_act_dtuple t a : + a \in 'N(S | to) -> t \in dtuple_on -> n_act to t a \in dtuple_on. +Proof. +move/astabsP=> toSa /dtuple_onP[t_inj St]; apply/dtuple_onP. +split=> [i j | i]; rewrite !tnth_map ?[_ \in S]toSa //. +by move/act_inj; exact: t_inj. +Qed. + +End NTransitive. + +Arguments Scope dtuple_on [_ nat_scope group_scope]. +Arguments Scope ntransitive + [_ _ nat_scope group_scope group_scope action_scope]. +Implicit Arguments n_act [gT sT n]. + +Notation "n .-dtuple ( S )" := (dtuple_on n S) + (at level 8, format "n .-dtuple ( S )") : set_scope. + +Notation "[ 'transitive' ^ n A , 'on' S | to ]" := (ntransitive n A S to) + (at level 0, n at level 8, + format "[ 'transitive' ^ n A , 'on' S | to ]") : form_scope. + +Section NTransitveProp. + +Variables (gT : finGroupType) (sT : finType). +Variables (to : {action gT &-> sT}) (G : {group gT}) (S : {set sT}). + +Lemma card_uniq_tuple n (t : n.-tuple sT) : uniq t -> #|t| = n. +Proof. by move/card_uniqP->; exact: size_tuple. Qed. + +Lemma n_act0 (t : 0.-tuple sT) a : n_act to t a = [tuple]. +Proof. exact: tuple0. Qed. + +Lemma dtuple_on_add n x (t : n.-tuple sT) : + ([tuple of x :: t] \in n.+1.-dtuple(S)) = + [&& x \in S, x \notin t & t \in n.-dtuple(S)]. +Proof. by rewrite !inE memtE !subset_all -!andbA; do !bool_congr. Qed. + +Lemma dtuple_on_add_D1 n x (t : n.-tuple sT) : + ([tuple of x :: t] \in n.+1.-dtuple(S)) + = (x \in S) && (t \in n.-dtuple(S :\ x)). +Proof. +rewrite dtuple_on_add !inE (andbCA (~~ _)); do 2!congr (_ && _). +rewrite -!(eq_subset (in_set (mem t))) setDE setIC subsetI; congr (_ && _). +by rewrite -setCS setCK sub1set !inE. +Qed. + +Lemma dtuple_on_subset n (S1 S2 : {set sT}) t : + S1 \subset S2 -> t \in n.-dtuple(S1) -> t \in n.-dtuple(S2). +Proof. by move=> sS12; rewrite !inE => /andP[-> /subset_trans]; exact. Qed. + +Lemma n_act_add n x (t : n.-tuple sT) a : + n_act to [tuple of x :: t] a = [tuple of to x a :: n_act to t a]. +Proof. exact: val_inj. Qed. + +Lemma ntransitive0 : [transitive^0 G, on S | to]. +Proof. +have dt0: [tuple] \in 0.-dtuple(S) by rewrite inE memtE subset_all. +apply/imsetP; exists [tuple of Nil sT] => //. +by apply/setP=> x; rewrite [x]tuple0 orbit_refl. +Qed. + +Lemma ntransitive_weak k m : + k <= m -> [transitive^m G, on S | to] -> [transitive^k G, on S | to]. +Proof. +move/subnKC <-; rewrite addnC; elim: {m}(m - k) => // m IHm. +rewrite addSn => tr_m1; apply: IHm; move: {m k}(m + k) tr_m1 => m tr_m1. +have ext_t t: t \in dtuple_on m S -> + exists x, [tuple of x :: t] \in m.+1.-dtuple(S). +- move=> dt. + have [sSt | /subsetPn[x Sx ntx]] := boolP (S \subset t); last first. + by exists x; rewrite dtuple_on_add andbA /= Sx ntx. + case/imsetP: tr_m1 dt => t1; rewrite !inE => /andP[Ut1 St1] _ /andP[Ut _]. + have /subset_leq_card := subset_trans St1 sSt. + by rewrite !card_uniq_tuple // ltnn. +case/imsetP: (tr_m1); case/tupleP=> [x t]; rewrite dtuple_on_add. +case/and3P=> Sx ntx dt; set xt := [tuple of _] => tr_xt. +apply/imsetP; exists t => //. +apply/setP=> u; apply/idP/imsetP=> [du | [a Ga ->{u}]]. + case: (ext_t u du) => y; rewrite tr_xt. + by case/imsetP=> a Ga [_ def_u]; exists a => //; exact: val_inj. +have: n_act to xt a \in dtuple_on _ S by rewrite tr_xt mem_imset. +by rewrite n_act_add dtuple_on_add; case/and3P. +Qed. + +Lemma ntransitive1 m : + 0 < m -> [transitive^m G, on S | to] -> [transitive G, on S | to]. +Proof. +have trdom1 x: ([tuple x] \in 1.-dtuple(S)) = (x \in S). + by rewrite dtuple_on_add !inE memtE subset_all andbT. +move=> m_gt0 /(ntransitive_weak m_gt0) {m m_gt0}. +case/imsetP; case/tupleP=> x t0; rewrite {t0}(tuple0 t0) trdom1 => Sx trx. +apply/imsetP; exists x => //; apply/setP=> y; rewrite -trdom1 trx. +apply/imsetP/imsetP=> [[a ? [->]]|[a ? ->]]; exists a => //; exact: val_inj. +Qed. + +Lemma ntransitive_primitive m : + 1 < m -> [transitive^m G, on S | to] -> [primitive G, on S | to]. +Proof. +move=> lt1m /(ntransitive_weak lt1m) {m lt1m}tr2G. +have trG: [transitive G, on S | to] by exact: ntransitive1 tr2G. +have [x Sx _]:= imsetP trG; rewrite (trans_prim_astab Sx trG). +apply/maximal_eqP; split=> [|H]; first exact: subsetIl; rewrite subEproper. +case/predU1P; first by [left]; case/andP=> sCH /subsetPn[a Ha nCa] sHG. +right; rewrite -(subgroup_transitiveP Sx sHG trG _) ?mulSGid //. +have actH := subset_trans sHG (atrans_acts trG). +pose y := to x a; have Sy: y \in S by rewrite (actsP actH). +have{nCa} yx: y != x by rewrite inE (sameP astab1P eqP) (subsetP sHG) in nCa. +apply/imsetP; exists y => //; apply/eqP. +rewrite eqEsubset acts_sub_orbit // Sy andbT; apply/subsetP=> z Sz. +have [-> | zx] := eqVneq z x; first by rewrite orbit_sym mem_orbit. +pose ty := [tuple y; x]; pose tz := [tuple z; x]. +have [Sty Stz]: ty \in 2.-dtuple(S) /\ tz \in 2.-dtuple(S). + rewrite !inE !memtE !subset_all /= !mem_seq1 !andbT; split; exact/and3P. +case: (atransP2 tr2G Sty Stz) => b Gb [->] /esym/astab1P cxb. +by rewrite mem_orbit // (subsetP sCH) // inE Gb. +Qed. + +End NTransitveProp. + +Section NTransitveProp1. + +Variables (gT : finGroupType) (sT : finType). +Variables (to : {action gT &-> sT}) (G : {group gT}) (S : {set sT}). + +(* This is the forward implication of Aschbacher (15.12).1 *) +Theorem stab_ntransitive m x : + 0 < m -> x \in S -> [transitive^m.+1 G, on S | to] -> + [transitive^m 'C_G[x | to], on S :\ x | to]. +Proof. +move=> m_gt0 Sx Gtr; have sSxS: S :\ x \subset S by rewrite subsetDl. +case: (imsetP Gtr); case/tupleP=> x1 t1; rewrite dtuple_on_add. +case/and3P=> Sx1 nt1x1 dt1 trt1; have Gtr1 := ntransitive1 (ltn0Sn _) Gtr. +case: (atransP2 Gtr1 Sx1 Sx) => // a Ga x1ax. +pose t := n_act to t1 a. +have dxt: [tuple of x :: t] \in m.+1.-dtuple(S). + rewrite trt1 x1ax; apply/imsetP; exists a => //; exact: val_inj. +apply/imsetP; exists t; first by rewrite dtuple_on_add_D1 Sx in dxt. +apply/setP=> t2; apply/idP/imsetP => [dt2|[b]]. + have: [tuple of x :: t2] \in dtuple_on _ S by rewrite dtuple_on_add_D1 Sx. + case/(atransP2 Gtr dxt)=> b Gb [xbx tbt2]. + exists b; [rewrite inE Gb; exact/astab1P | exact: val_inj]. +case/setIP=> Gb /astab1P xbx ->{t2}. +rewrite n_act_dtuple //; last by rewrite dtuple_on_add_D1 Sx in dxt. +apply/astabsP=> y; rewrite !inE -{1}xbx (inj_eq (act_inj _ _)). +by rewrite (actsP (atrans_acts Gtr1)). +Qed. + +(* This is the converse implication of Aschbacher (15.12).1 *) +Theorem stab_ntransitiveI m x : + x \in S -> [transitive G, on S | to] -> + [transitive^m 'C_G[x | to], on S :\ x | to] -> + [transitive^m.+1 G, on S | to]. +Proof. +move=> Sx Gtr Gntr. +have t_to_x t: t \in m.+1.-dtuple(S) -> + exists2 a, a \in G & exists2 t', t' \in m.-dtuple(S :\ x) + & t = n_act to [tuple of x :: t'] a. +- case/tupleP: t => y t St. + have Sy: y \in S by rewrite dtuple_on_add_D1 in St; case/andP: St. + rewrite -(atransP Gtr _ Sy) in Sx; case/imsetP: Sx => a Ga toya. + exists a^-1; first exact: groupVr. + exists (n_act to t a); last by rewrite n_act_add toya !actK. + move/(n_act_dtuple (subsetP (atrans_acts Gtr) a Ga)): St. + by rewrite n_act_add -toya dtuple_on_add_D1 => /andP[]. +case: (imsetP Gntr) => t dt S_tG; pose xt := [tuple of x :: t]. +have dxt: xt \in m.+1.-dtuple(S) by rewrite dtuple_on_add_D1 Sx. +apply/imsetP; exists xt => //; apply/setP=> t2. +apply/esym; apply/imsetP/idP=> [[a Ga ->] | ]. + by apply: n_act_dtuple; rewrite // (subsetP (atrans_acts Gtr)). +case/t_to_x=> a2 Ga2 [t2']; rewrite S_tG. +case/imsetP=> a /setIP[Ga /astab1P toxa] -> -> {t2 t2'}. +by exists (a * a2); rewrite (groupM, actM) //= !n_act_add toxa. +Qed. + +End NTransitveProp1. diff --git a/mathcomp/solvable/sylow.v b/mathcomp/solvable/sylow.v new file mode 100644 index 0000000..02ab37a --- /dev/null +++ b/mathcomp/solvable/sylow.v @@ -0,0 +1,661 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div fintype prime. +Require Import bigop finset fingroup morphism automorphism quotient action. +Require Import cyclic gproduct commutator pgroup center nilpotent. + +(******************************************************************************) +(* The Sylow theorem and its consequences, including the Frattini argument, *) +(* the nilpotence of p-groups, and the Baer-Suzuki theorem. *) +(* This file also defines: *) +(* Zgroup G == G is a Z-group, i.e., has only cyclic Sylow p-subgroups. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GroupScope. + +(* The mod p lemma for the action of p-groups. *) +Section ModP. + +Variable (aT : finGroupType) (sT : finType) (D : {group aT}). +Variable to : action D sT. + +Lemma pgroup_fix_mod (p : nat) (G : {group aT}) (S : {set sT}) : + p.-group G -> [acts G, on S | to] -> #|S| = #|'Fix_(S | to)(G)| %[mod p]. +Proof. +move=> pG nSG; have sGD: G \subset D := acts_dom nSG. +apply/eqP; rewrite -(cardsID 'Fix_to(G)) eqn_mod_dvd (leq_addr, addKn) //. +have: [acts G, on S :\: 'Fix_to(G) | to]; last move/acts_sum_card_orbit <-. + rewrite actsD // -(setIidPr sGD); apply: subset_trans (acts_subnorm_fix _ _). + by rewrite setIS ?normG. +apply: dvdn_sum => _ /imsetP[x /setDP[_ nfx] ->]. +have [k oGx]: {k | #|orbit to G x| = (p ^ k)%N}. + by apply: p_natP; apply: pnat_dvd pG; rewrite card_orbit_in ?dvdn_indexg. +case: k oGx => [/card_orbit1 fix_x | k ->]; last by rewrite expnS dvdn_mulr. +by case/afixP: nfx => a Ga; apply/set1P; rewrite -fix_x mem_orbit. +Qed. + +End ModP. + +Section ModularGroupAction. + +Variables (aT rT : finGroupType) (D : {group aT}) (R : {group rT}). +Variables (to : groupAction D R) (p : nat). +Implicit Types (G H : {group aT}) (M : {group rT}). + +Lemma nontrivial_gacent_pgroup G M : + p.-group G -> p.-group M -> {acts G, on group M | to} -> + M :!=: 1 -> 'C_(M | to)(G) :!=: 1. +Proof. +move=> pG pM [nMG sMR] ntM; have [p_pr p_dv_M _] := pgroup_pdiv pM ntM. +rewrite -cardG_gt1 (leq_trans (prime_gt1 p_pr)) 1?dvdn_leq ?cardG_gt0 //= /dvdn. +by rewrite gacentE ?(acts_dom nMG) // setIA (setIidPl sMR) -pgroup_fix_mod. +Qed. + +Lemma pcore_sub_astab_irr G M : + p.-group M -> M \subset R -> acts_irreducibly G M to -> + 'O_p(G) \subset 'C_G(M | to). +Proof. +move=> pM sMR /mingroupP[/andP[ntM nMG] minM]. +have [sGpG nGpG]:= andP (pcore_normal p G). +have sGD := acts_dom nMG; have sGpD := subset_trans sGpG sGD. +rewrite subsetI sGpG -gacentC //=; apply/setIidPl; apply: minM (subsetIl _ _). +rewrite nontrivial_gacent_pgroup ?pcore_pgroup //=; last first. + by split; rewrite ?(subset_trans sGpG). +by apply: subset_trans (acts_subnorm_subgacent sGpD nMG); rewrite subsetI subxx. +Qed. + +Lemma pcore_faithful_irr_act G M : + p.-group M -> M \subset R -> acts_irreducibly G M to -> + [faithful G, on M | to] -> + 'O_p(G) = 1. +Proof. +move=> pM sMR irrG ffulG; apply/trivgP; apply: subset_trans ffulG. +exact: pcore_sub_astab_irr. +Qed. + +End ModularGroupAction. + +Section Sylow. + +Variables (p : nat) (gT : finGroupType) (G : {group gT}). +Implicit Types P Q H K : {group gT}. + +Theorem Sylow's_theorem : + [/\ forall P, [max P | p.-subgroup(G) P] = p.-Sylow(G) P, + [transitive G, on 'Syl_p(G) | 'JG], + forall P, p.-Sylow(G) P -> #|'Syl_p(G)| = #|G : 'N_G(P)| + & prime p -> #|'Syl_p(G)| %% p = 1%N]. +Proof. +pose maxp A P := [max P | p.-subgroup(A) P]; pose S := [set P | maxp G P]. +pose oG := orbit 'JG%act G. +have actS: [acts G, on S | 'JG]. + apply/subsetP=> x Gx; rewrite 3!inE; apply/subsetP=> P; rewrite 3!inE. + exact: max_pgroupJ. +have S_pG P: P \in S -> P \subset G /\ p.-group P. + by rewrite inE => /maxgroupp/andP[]. +have SmaxN P Q: Q \in S -> Q \subset 'N(P) -> maxp 'N_G(P) Q. + rewrite inE => /maxgroupP[/andP[sQG pQ] maxQ] nPQ. + apply/maxgroupP; rewrite /psubgroup subsetI sQG nPQ. + by split=> // R; rewrite subsetI -andbA andbCA => /andP[_]; exact: maxQ. +have nrmG P: P \subset G -> P <| 'N_G(P). + by move=> sPG; rewrite /normal subsetIr subsetI sPG normG. +have sylS P: P \in S -> p.-Sylow('N_G(P)) P. + move=> S_P; have [sPG pP] := S_pG P S_P. + by rewrite normal_max_pgroup_Hall ?nrmG //; apply: SmaxN; rewrite ?normG. +have{SmaxN} defCS P: P \in S -> 'Fix_(S |'JG)(P) = [set P]. + move=> S_P; apply/setP=> Q; rewrite {1}in_setI {1}afixJG. + apply/andP/set1P=> [[S_Q nQP]|->{Q}]; last by rewrite normG. + apply/esym/val_inj; case: (S_pG Q) => //= sQG _. + by apply: uniq_normal_Hall (SmaxN Q _ _ _) => //=; rewrite ?sylS ?nrmG. +have{defCS} oG_mod: {in S &, forall P Q, #|oG P| = (Q \in oG P) %[mod p]}. + move=> P Q S_P S_Q; have [sQG pQ] := S_pG _ S_Q. + have soP_S: oG P \subset S by rewrite acts_sub_orbit. + have /pgroup_fix_mod-> //: [acts Q, on oG P | 'JG]. + apply/actsP=> x /(subsetP sQG) Gx R; apply: orbit_transr. + exact: mem_orbit. + rewrite -{1}(setIidPl soP_S) -setIA defCS // (cardsD1 Q) setDE. + by rewrite -setIA setICr setI0 cards0 addn0 inE set11 andbT. +have [P S_P]: exists P, P \in S. + have: p.-subgroup(G) 1 by rewrite /psubgroup sub1G pgroup1. + by case/(@maxgroup_exists _ (p.-subgroup(G))) => P; exists P; rewrite inE. +have trS: [transitive G, on S | 'JG]. + apply/imsetP; exists P => //; apply/eqP. + rewrite eqEsubset andbC acts_sub_orbit // S_P; apply/subsetP=> Q S_Q. + have:= S_P; rewrite inE => /maxgroupP[/andP[_ pP]]. + have [-> max1 | ntP _] := eqVneq P 1%G. + move/andP/max1: (S_pG _ S_Q) => Q1. + by rewrite (group_inj (Q1 (sub1G Q))) orbit_refl. + have:= oG_mod _ _ S_P S_P; rewrite (oG_mod _ Q) // orbit_refl. + have p_gt1: p > 1 by apply: prime_gt1; case/pgroup_pdiv: pP. + by case: (Q \in oG P) => //; rewrite mod0n modn_small. +have oS1: prime p -> #|S| %% p = 1%N. + move/prime_gt1 => p_gt1. + by rewrite -(atransP trS P S_P) (oG_mod P P) // orbit_refl modn_small. +have oSiN Q: Q \in S -> #|S| = #|G : 'N_G(Q)|. + by move=> S_Q; rewrite -(atransP trS Q S_Q) card_orbit astab1JG. +have sylP: p.-Sylow(G) P. + rewrite pHallE; case: (S_pG P) => // -> /= pP. + case p_pr: (prime p); last first. + rewrite p_part lognE p_pr /= -trivg_card1; apply/idPn=> ntP. + by case/pgroup_pdiv: pP p_pr => // ->. + rewrite -(LagrangeI G 'N(P)) /= mulnC partnM ?cardG_gt0 // part_p'nat. + by rewrite mul1n (card_Hall (sylS P S_P)). + by rewrite p'natE // -indexgI -oSiN // /dvdn oS1. +have eqS Q: maxp G Q = p.-Sylow(G) Q. + apply/idP/idP=> [S_Q|]; last exact: Hall_max. + have{S_Q} S_Q: Q \in S by rewrite inE. + rewrite pHallE -(card_Hall sylP); case: (S_pG Q) => // -> _ /=. + by case: (atransP2 trS S_P S_Q) => x _ ->; rewrite cardJg. +have ->: 'Syl_p(G) = S by apply/setP=> Q; rewrite 2!inE. +by split=> // Q sylQ; rewrite -oSiN ?inE ?eqS. +Qed. + +Lemma max_pgroup_Sylow P : [max P | p.-subgroup(G) P] = p.-Sylow(G) P. +Proof. by case Sylow's_theorem. Qed. + +Lemma Sylow_superset Q : + Q \subset G -> p.-group Q -> {P : {group gT} | p.-Sylow(G) P & Q \subset P}. +Proof. +move=> sQG pQ. +have [|P] := @maxgroup_exists _ (p.-subgroup(G)) Q; first exact/andP. +by rewrite max_pgroup_Sylow; exists P. +Qed. + +Lemma Sylow_exists : {P : {group gT} | p.-Sylow(G) P}. +Proof. by case: (Sylow_superset (sub1G G) (pgroup1 _ p)) => P; exists P. Qed. + +Lemma Syl_trans : [transitive G, on 'Syl_p(G) | 'JG]. +Proof. by case Sylow's_theorem. Qed. + +Lemma Sylow_trans P Q : + p.-Sylow(G) P -> p.-Sylow(G) Q -> exists2 x, x \in G & Q :=: P :^ x. +Proof. +move=> sylP sylQ; have:= (atransP2 Syl_trans) P Q; rewrite !inE. +by case=> // x Gx ->; exists x. +Qed. + +Lemma Sylow_subJ P Q : + p.-Sylow(G) P -> Q \subset G -> p.-group Q -> + exists2 x, x \in G & Q \subset P :^ x. +Proof. +move=> sylP sQG pQ; have [Px sylPx] := Sylow_superset sQG pQ. +by have [x Gx ->] := Sylow_trans sylP sylPx; exists x. +Qed. + +Lemma Sylow_Jsub P Q : + p.-Sylow(G) P -> Q \subset G -> p.-group Q -> + exists2 x, x \in G & Q :^ x \subset P. +Proof. +move=> sylP sQG pQ; have [x Gx] := Sylow_subJ sylP sQG pQ. +by exists x^-1; rewrite (groupV, sub_conjgV). +Qed. + +Lemma card_Syl P : p.-Sylow(G) P -> #|'Syl_p(G)| = #|G : 'N_G(P)|. +Proof. by case: Sylow's_theorem P. Qed. + +Lemma card_Syl_dvd : #|'Syl_p(G)| %| #|G|. +Proof. by case Sylow_exists => P /card_Syl->; exact: dvdn_indexg. Qed. + +Lemma card_Syl_mod : prime p -> #|'Syl_p(G)| %% p = 1%N. +Proof. by case Sylow's_theorem. Qed. + +Lemma Frattini_arg H P : G <| H -> p.-Sylow(G) P -> G * 'N_H(P) = H. +Proof. +case/andP=> sGH nGH sylP; rewrite -normC ?subIset ?nGH ?orbT // -astab1JG. +move/subgroup_transitiveP: Syl_trans => ->; rewrite ?inE //. +apply/imsetP; exists P; rewrite ?inE //. +apply/eqP; rewrite eqEsubset -{1}((atransP Syl_trans) P) ?inE // imsetS //=. +by apply/subsetP=> _ /imsetP[x Hx ->]; rewrite inE -(normsP nGH x Hx) pHallJ2. +Qed. + +End Sylow. + +Section MoreSylow. + +Variables (gT : finGroupType) (p : nat). +Implicit Types G H P : {group gT}. + +Lemma Sylow_setI_normal G H P : + G <| H -> p.-Sylow(H) P -> p.-Sylow(G) (G :&: P). +Proof. +case/normalP=> sGH nGH sylP; have [Q sylQ] := Sylow_exists p G. +have /maxgroupP[/andP[sQG pQ] maxQ] := Hall_max sylQ. +have [R sylR sQR] := Sylow_superset (subset_trans sQG sGH) pQ. +have [[x Hx ->] pR] := (Sylow_trans sylR sylP, pHall_pgroup sylR). +rewrite -(nGH x Hx) -conjIg pHallJ2. +have /maxQ-> //: Q \subset G :&: R by rewrite subsetI sQG. +by rewrite /psubgroup subsetIl (pgroupS _ pR) ?subsetIr. +Qed. + +Lemma normal_sylowP G : + reflect (exists2 P : {group gT}, p.-Sylow(G) P & P <| G) + (#|'Syl_p(G)| == 1%N). +Proof. +apply: (iffP idP) => [syl1 | [P sylP nPG]]; last first. + by rewrite (card_Syl sylP) (setIidPl _) (indexgg, normal_norm). +have [P sylP] := Sylow_exists p G; exists P => //. +rewrite /normal (pHall_sub sylP); apply/setIidPl; apply/eqP. +rewrite eqEcard subsetIl -(LagrangeI G 'N(P)) -indexgI /=. +by rewrite -(card_Syl sylP) (eqP syl1) muln1. +Qed. + +Lemma trivg_center_pgroup P : p.-group P -> 'Z(P) = 1 -> P :=: 1. +Proof. +move=> pP Z1; apply/eqP/idPn=> ntP. +have{ntP} [p_pr p_dv_P _] := pgroup_pdiv pP ntP. +suff: p %| #|'Z(P)| by rewrite Z1 cards1 gtnNdvd ?prime_gt1. +by rewrite /center /dvdn -afixJ -pgroup_fix_mod // astabsJ normG. +Qed. + +Lemma p2group_abelian P : p.-group P -> logn p #|P| <= 2 -> abelian P. +Proof. +move=> pP lePp2; pose Z := 'Z(P); have sZP: Z \subset P := center_sub P. +case: (eqVneq Z 1); first by move/(trivg_center_pgroup pP)->; exact: abelian1. +case/(pgroup_pdiv (pgroupS sZP pP)) => p_pr _ [k oZ]. +apply: cyclic_center_factor_abelian. +case: (eqVneq (P / Z) 1) => [-> |]; first exact: cyclic1. +have pPq := quotient_pgroup 'Z(P) pP; case/(pgroup_pdiv pPq) => _ _ [j oPq]. +rewrite prime_cyclic // oPq; case: j oPq lePp2 => //= j. +rewrite card_quotient ?gfunctor.gFnorm //. +by rewrite -(Lagrange sZP) lognM // => ->; rewrite oZ !pfactorK ?addnS. +Qed. + +Lemma card_p2group_abelian P : prime p -> #|P| = (p ^ 2)%N -> abelian P. +Proof. +move=> primep oP; have pP: p.-group P by rewrite /pgroup oP pnat_exp pnat_id. +by rewrite (p2group_abelian pP) // oP pfactorK. +Qed. + +Lemma Sylow_transversal_gen (T : {set {group gT}}) G : + (forall P, P \in T -> P \subset G) -> + (forall p, p \in \pi(G) -> exists2 P, P \in T & p.-Sylow(G) P) -> + << \bigcup_(P in T) P >> = G. +Proof. +move=> G_T T_G; apply/eqP; rewrite eqEcard gen_subG. +apply/andP; split; first exact/bigcupsP. +apply: dvdn_leq (cardG_gt0 _) _; apply/dvdn_partP=> // q /T_G[P T_P sylP]. +by rewrite -(card_Hall sylP); apply: cardSg; rewrite sub_gen // bigcup_sup. +Qed. + +Lemma Sylow_gen G : <<\bigcup_(P : {group gT} | Sylow G P) P>> = G. +Proof. +set T := [set P : {group gT} | Sylow G P]. +rewrite -{2}(@Sylow_transversal_gen T G) => [|P | q _]. +- by congr <<_>>; apply: eq_bigl => P; rewrite inE. +- by rewrite inE => /and3P[]. +by case: (Sylow_exists q G) => P sylP; exists P; rewrite // inE (p_Sylow sylP). +Qed. + +End MoreSylow. + +Section SomeHall. + +Variable gT : finGroupType. +Implicit Types (p : nat) (pi : nat_pred) (G H K P R : {group gT}). + +Lemma Hall_pJsub p pi G H P : + pi.-Hall(G) H -> p \in pi -> P \subset G -> p.-group P -> + exists2 x, x \in G & P :^ x \subset H. +Proof. +move=> hallH pi_p sPG pP. +have [S sylS] := Sylow_exists p H; have sylS_G := subHall_Sylow hallH pi_p sylS. +have [x Gx sPxS] := Sylow_Jsub sylS_G sPG pP; exists x => //. +exact: subset_trans sPxS (pHall_sub sylS). +Qed. + +Lemma Hall_psubJ p pi G H P : + pi.-Hall(G) H -> p \in pi -> P \subset G -> p.-group P -> + exists2 x, x \in G & P \subset H :^ x. +Proof. +move=> hallH pi_p sPG pP; have [x Gx sPxH] := Hall_pJsub hallH pi_p sPG pP. +by exists x^-1; rewrite ?groupV -?sub_conjg. +Qed. + +Lemma Hall_setI_normal pi G K H : + K <| G -> pi.-Hall(G) H -> pi.-Hall(K) (H :&: K). +Proof. +move=> nsKG hallH; have [sHG piH _] := and3P hallH. +have [sHK_H sHK_K] := (subsetIl H K, subsetIr H K). +rewrite pHallE sHK_K /= -(part_pnat_id (pgroupS sHK_H piH)); apply/eqP. +rewrite (widen_partn _ (subset_leq_card sHK_K)); apply: eq_bigr => p pi_p. +have [P sylP] := Sylow_exists p H. +have sylPK := Sylow_setI_normal nsKG (subHall_Sylow hallH pi_p sylP). +rewrite -!p_part -(card_Hall sylPK); symmetry; apply: card_Hall. +by rewrite (pHall_subl _ sHK_K) //= setIC setSI ?(pHall_sub sylP). +Qed. + +Lemma coprime_mulG_setI_norm H G K R : + K * R = G -> G \subset 'N(H) -> coprime #|K| #|R| -> + (K :&: H) * (R :&: H) = G :&: H. +Proof. +move=> defG nHG coKR; apply/eqP; rewrite eqEcard mulG_subG /= -defG. +rewrite !setSI ?mulG_subl ?mulG_subr //=. +rewrite coprime_cardMg ?(coKR, coprimeSg (subsetIl _ _), coprime_sym) //=. +pose pi := \pi(K); have piK: pi.-group K by exact: pgroup_pi. +have pi'R: pi^'.-group R by rewrite /pgroup -coprime_pi' /=. +have [hallK hallR] := coprime_mulpG_Hall defG piK pi'R. +have nsHG: H :&: G <| G by rewrite /normal subsetIr normsI ?normG. +rewrite -!(setIC H) defG -(partnC pi (cardG_gt0 _)). +rewrite -(card_Hall (Hall_setI_normal nsHG hallR)) /= setICA. +rewrite -(card_Hall (Hall_setI_normal nsHG hallK)) /= setICA. +by rewrite -defG (setIidPl (mulG_subl _ _)) (setIidPl (mulG_subr _ _)). +Qed. + +End SomeHall. + +Section Nilpotent. + +Variable gT : finGroupType. +Implicit Types (G H K P L : {group gT}) (p q : nat). + +Lemma pgroup_nil p P : p.-group P -> nilpotent P. +Proof. +move: {2}_.+1 (ltnSn #|P|) => n. +elim: n gT P => // n IHn pT P; rewrite ltnS=> lePn pP. +have [Z1 | ntZ] := eqVneq 'Z(P) 1. + by rewrite (trivg_center_pgroup pP Z1) nilpotent1. +rewrite -quotient_center_nil IHn ?morphim_pgroup // (leq_trans _ lePn) //. +rewrite card_quotient ?normal_norm ?center_normal // -divgS ?subsetIl //. +by rewrite ltn_Pdiv // ltnNge -trivg_card_le1. +Qed. + +Lemma pgroup_sol p P : p.-group P -> solvable P. +Proof. by move/pgroup_nil; exact: nilpotent_sol. Qed. + +Lemma small_nil_class G : nil_class G <= 5 -> nilpotent G. +Proof. +move=> leK5; case: (ltnP 5 #|G|) => [lt5G | leG5 {leK5}]. + by rewrite nilpotent_class (leq_ltn_trans leK5). +apply: pgroup_nil (pdiv #|G|) _ _; apply/andP; split=> //. +by case: #|G| leG5 => //; do 5!case=> //. +Qed. + +Lemma nil_class2 G : (nil_class G <= 2) = (G^`(1) \subset 'Z(G)). +Proof. +rewrite subsetI der_sub; apply/idP/commG1P=> [clG2 | L3G1]. + by apply/(lcn_nil_classP 2); rewrite ?small_nil_class ?(leq_trans clG2). +by apply/(lcn_nil_classP 2) => //; apply/lcnP; exists 2. +Qed. + +Lemma nil_class3 G : (nil_class G <= 3) = ('L_3(G) \subset 'Z(G)). +Proof. +rewrite subsetI lcn_sub; apply/idP/commG1P=> [clG3 | L4G1]. + by apply/(lcn_nil_classP 3); rewrite ?small_nil_class ?(leq_trans clG3). +by apply/(lcn_nil_classP 3) => //; apply/lcnP; exists 3. +Qed. + +Lemma nilpotent_maxp_normal pi G H : + nilpotent G -> [max H | pi.-subgroup(G) H] -> H <| G. +Proof. +move=> nilG /maxgroupP[/andP[sHG piH] maxH]. +have nHN: H <| 'N_G(H) by rewrite normal_subnorm. +have{maxH} hallH: pi.-Hall('N_G(H)) H. + apply: normal_max_pgroup_Hall => //; apply/maxgroupP. + rewrite /psubgroup normal_sub // piH; split=> // K. + by rewrite subsetI -andbA andbCA => /andP[_]; exact: maxH. +rewrite /normal sHG; apply/setIidPl; symmetry. +apply: nilpotent_sub_norm; rewrite ?subsetIl ?setIS //=. +by rewrite char_norms // -{1}(normal_Hall_pcore hallH) // pcore_char. +Qed. + +Lemma nilpotent_Hall_pcore pi G H : + nilpotent G -> pi.-Hall(G) H -> H :=: 'O_pi(G). +Proof. +move=> nilG hallH; have maxH := Hall_max hallH; apply/eqP. +rewrite eqEsubset pcore_max ?(pHall_pgroup hallH) //. + by rewrite (normal_sub_max_pgroup maxH) ?pcore_pgroup ?pcore_normal. +exact: nilpotent_maxp_normal maxH. +Qed. + +Lemma nilpotent_pcore_Hall pi G : nilpotent G -> pi.-Hall(G) 'O_pi(G). +Proof. +move=> nilG; case: (@maxgroup_exists _ (psubgroup pi G) 1) => [|H maxH _]. + by rewrite /psubgroup sub1G pgroup1. +have hallH := normal_max_pgroup_Hall maxH (nilpotent_maxp_normal nilG maxH). +by rewrite -(nilpotent_Hall_pcore nilG hallH). +Qed. + +Lemma nilpotent_pcoreC pi G : nilpotent G -> 'O_pi(G) \x 'O_pi^'(G) = G. +Proof. +move=> nilG; have trO: 'O_pi(G) :&: 'O_pi^'(G) = 1. + by apply: coprime_TIg; apply: (@pnat_coprime pi); exact: pcore_pgroup. +rewrite dprodE //. + apply/eqP; rewrite eqEcard mul_subG ?pcore_sub // (TI_cardMg trO). + by rewrite !(card_Hall (nilpotent_pcore_Hall _ _)) // partnC ?leqnn. +rewrite (sameP commG1P trivgP) -trO subsetI commg_subl commg_subr. +by rewrite !(subset_trans (pcore_sub _ _)) ?normal_norm ?pcore_normal. +Qed. + +Lemma sub_nilpotent_cent2 H K G : + nilpotent G -> K \subset G -> H \subset G -> coprime #|K| #|H| -> + H \subset 'C(K). +Proof. +move=> nilG sKG sHG; rewrite coprime_pi' // => p'H. +have sub_Gp := sub_Hall_pcore (nilpotent_pcore_Hall _ nilG). +have [_ _ cGpp' _] := dprodP (nilpotent_pcoreC \pi(K) nilG). +by apply: centSS cGpp'; rewrite sub_Gp ?pgroup_pi. +Qed. + +Lemma pi_center_nilpotent G : nilpotent G -> \pi('Z(G)) = \pi(G). +Proof. +move=> nilG; apply/eq_piP => /= p. +apply/idP/idP=> [|pG]; first exact: (piSg (center_sub _)). +move: (pG); rewrite !mem_primes !cardG_gt0; case/andP=> p_pr _. +pose Z := 'O_p(G) :&: 'Z(G); have ntZ: Z != 1. + rewrite meet_center_nil ?pcore_normal // trivg_card_le1 -ltnNge. + rewrite (card_Hall (nilpotent_pcore_Hall p nilG)) p_part. + by rewrite (ltn_exp2l 0 _ (prime_gt1 p_pr)) logn_gt0. +have pZ: p.-group Z := pgroupS (subsetIl _ _) (pcore_pgroup _ _). +have{ntZ pZ} [_ pZ _] := pgroup_pdiv pZ ntZ. +by rewrite p_pr (dvdn_trans pZ) // cardSg ?subsetIr. +Qed. + +Lemma Sylow_subnorm p G P : p.-Sylow('N_G(P)) P = p.-Sylow(G) P. +Proof. +apply/idP/idP=> sylP; last first. + apply: pHall_subl (subsetIl _ _) (sylP). + by rewrite subsetI normG (pHall_sub sylP). +have [/subsetIP[sPG sPN] pP _] := and3P sylP. +have [Q sylQ sPQ] := Sylow_superset sPG pP; have [sQG pQ _] := and3P sylQ. +rewrite -(nilpotent_sub_norm (pgroup_nil pQ) sPQ) {sylQ}//. +rewrite subEproper eq_sym eqEcard subsetI sPQ sPN dvdn_leq //. +rewrite -(part_pnat_id (pgroupS (subsetIl _ _) pQ)) (card_Hall sylP). +by rewrite partn_dvd // cardSg ?setSI. +Qed. + +End Nilpotent. + +Lemma nil_class_pgroup (gT : finGroupType) (p : nat) (P : {group gT}) : + p.-group P -> nil_class P <= maxn 1 (logn p #|P|).-1. +Proof. +move=> pP; move def_c: (nil_class P) => c. +elim: c => // c IHc in gT P def_c pP *; set e := logn p _. +have nilP := pgroup_nil pP; have sZP := center_sub P. +have [e_le2 | e_gt2] := leqP e 2. + by rewrite -def_c leq_max nil_class1 (p2group_abelian pP). +have pPq: p.-group (P / 'Z(P)) by exact: quotient_pgroup. +rewrite -(subnKC e_gt2) ltnS (leq_trans (IHc _ _ _ pPq)) //. + by rewrite nil_class_quotient_center ?def_c. +rewrite geq_max /= -add1n -leq_subLR -subn1 -subnDA -subSS leq_sub2r //. +rewrite ltn_log_quotient //= -(setIidPr sZP) meet_center_nil //. +by rewrite -nil_class0 def_c. +Qed. + +Definition Zgroup (gT : finGroupType) (A : {set gT}) := + [forall (V : {group gT} | Sylow A V), cyclic V]. + +Section Zgroups. + +Variables (gT rT : finGroupType) (D : {group gT}) (f : {morphism D >-> rT}). +Implicit Types G H K : {group gT}. + +Lemma ZgroupS G H : H \subset G -> Zgroup G -> Zgroup H. +Proof. +move=> sHG /forallP zgG; apply/forall_inP=> V /SylowP[p p_pr /and3P[sVH]]. +case/(Sylow_superset (subset_trans sVH sHG))=> P sylP sVP _. +by have:= zgG P; rewrite (p_Sylow sylP); apply: cyclicS. +Qed. + +Lemma morphim_Zgroup G : Zgroup G -> Zgroup (f @* G). +Proof. +move=> zgG; wlog sGD: G zgG / G \subset D. + by rewrite -morphimIdom; apply; rewrite (ZgroupS _ zgG, subsetIl) ?subsetIr. +apply/forall_inP=> fV /SylowP[p pr_p sylfV]. +have [P sylP] := Sylow_exists p G. +have [|z _ ->] := @Sylow_trans p _ _ (f @* P)%G _ _ sylfV. + by apply: morphim_pHall (sylP); apply: subset_trans (pHall_sub sylP) sGD. +by rewrite cyclicJ morphim_cyclic ?(forall_inP zgG) //; apply/SylowP; exists p. +Qed. + +Lemma nil_Zgroup_cyclic G : Zgroup G -> nilpotent G -> cyclic G. +Proof. +elim: {G}_.+1 {-2}G (ltnSn #|G|) => // n IHn G; rewrite ltnS => leGn ZgG nilG. +have [->|[p pr_p pG]] := trivgVpdiv G; first by rewrite -cycle1 cycle_cyclic. +have /dprodP[_ defG Cpp' _] := nilpotent_pcoreC p nilG. +have /cyclicP[x def_p]: cyclic 'O_p(G). + have:= forallP ZgG 'O_p(G)%G. + by rewrite (p_Sylow (nilpotent_pcore_Hall p nilG)). +have /cyclicP[x' def_p']: cyclic 'O_p^'(G). + have sp'G := pcore_sub p^' G. + apply: IHn (leq_trans _ leGn) (ZgroupS sp'G _) (nilpotentS sp'G _) => //. + rewrite proper_card // properEneq sp'G andbT; case: eqP => //= def_p'. + by have:= pcore_pgroup p^' G; rewrite def_p' /pgroup p'natE ?pG. +apply/cyclicP; exists (x * x'); rewrite -{}defG def_p def_p' cycleM //. + by red; rewrite -(centsP Cpp') // (def_p, def_p') cycle_id. +rewrite /order -def_p -def_p' (@pnat_coprime p) //; exact: pcore_pgroup. +Qed. + +End Zgroups. + +Arguments Scope Zgroup [_ group_scope]. +Prenex Implicits Zgroup. + +Section NilPGroups. + +Variables (p : nat) (gT : finGroupType). +Implicit Type G P N : {group gT}. + +(* B & G 1.22 p.9 *) +Lemma normal_pgroup r P N : + p.-group P -> N <| P -> r <= logn p #|N| -> + exists Q : {group gT}, [/\ Q \subset N, Q <| P & #|Q| = (p ^ r)%N]. +Proof. +elim: r gT P N => [|r IHr] gTr P N pP nNP le_r. + by exists (1%G : {group gTr}); rewrite sub1G normal1 cards1. +have [NZ_1 | ntNZ] := eqVneq (N :&: 'Z(P)) 1. + by rewrite (TI_center_nil (pgroup_nil pP)) // cards1 logn1 in le_r. +have: p.-group (N :&: 'Z(P)) by apply: pgroupS pP; rewrite /= setICA subsetIl. +case/pgroup_pdiv=> // p_pr /Cauchy[// | z]. +rewrite -cycle_subG !subsetI => /and3P[szN szP cPz] ozp _. +have{cPz} nzP: P \subset 'N(<[z]>) by rewrite cents_norm // centsC. +have: N / <[z]> <| P / <[z]> by rewrite morphim_normal. +case/IHr=> [||Qb [sQNb nQPb]]; first exact: morphim_pgroup. + rewrite card_quotient ?(subset_trans (normal_sub nNP)) // -ltnS. + apply: (leq_trans le_r); rewrite -(Lagrange szN) [#|_|]ozp. + by rewrite lognM // ?prime_gt0 // logn_prime ?eqxx. +case/(inv_quotientN _): nQPb sQNb => [|Q -> szQ nQP]; first exact/andP. +have nzQ := subset_trans (normal_sub nQP) nzP. +rewrite quotientSGK // card_quotient // => sQN izQ. +by exists Q; split=> //; rewrite expnS -izQ -ozp Lagrange. +Qed. + +Theorem Baer_Suzuki x G : + x \in G -> (forall y, y \in G -> p.-group <<[set x; x ^ y]>>) -> + x \in 'O_p(G). +Proof. +elim: {G}_.+1 {-2}G x (ltnSn #|G|) => // n IHn G x; rewrite ltnS. +set E := x ^: G => leGn Gx pE. +have{pE} pE: {in E &, forall x1 x2, p.-group <<[set x1; x2]>>}. + move=> _ _ /imsetP[y1 Gy1 ->] /imsetP[y2 Gy2 ->]. + rewrite -(mulgKV y1 y2) conjgM -2!conjg_set1 -conjUg genJ pgroupJ. + by rewrite pE // groupMl ?groupV. +have sEG: <> \subset G by rewrite gen_subG class_subG. +have nEG: G \subset 'N(E) by exact: class_norm. +have Ex: x \in E by exact: class_refl. +have [P Px sylP]: exists2 P : {group gT}, x \in P & p.-Sylow(<>) P. + have sxxE: <<[set x; x]>> \subset <> by rewrite genS // setUid sub1set. + have{sxxE} [P sylP sxxP] := Sylow_superset sxxE (pE _ _ Ex Ex). + by exists P => //; rewrite (subsetP sxxP) ?mem_gen ?setU11. +case sEP: (E \subset P). + apply: subsetP Ex; rewrite -gen_subG; apply: pcore_max. + by apply: pgroupS (pHall_pgroup sylP); rewrite gen_subG. + by rewrite /normal gen_subG class_subG // norms_gen. +pose P_yD D := [pred y in E :\: P | p.-group <>]. +pose P_D := [pred D : {set gT} | D \subset P :&: E & [exists y, P_yD D y]]. +have{Ex Px}: P_D [set x]. + rewrite /= sub1set inE Px Ex; apply/existsP=> /=. + by case/subsetPn: sEP => y Ey Py; exists y; rewrite inE Ey Py pE. +case/(@maxset_exists _ P_D)=> D /maxsetP[]; rewrite {P_yD P_D}/=. +rewrite subsetI sub1set -andbA => /and3P[sDP sDE /existsP[y0]]. +set B := _ |: D; rewrite inE -andbA => /and3P[Py0 Ey0 pB] maxD Dx. +have sDgE: D \subset <> by exact: sub_gen. +have sDG: D \subset G by exact: subset_trans sEG. +have sBE: B \subset E by rewrite subUset sub1set Ey0. +have sBG: <> \subset G by exact: subset_trans (genS _) sEG. +have sDB: D \subset B by rewrite subsetUr. +have defD: D :=: P :&: <> :&: E. + apply/eqP; rewrite eqEsubset ?subsetI sDP sDE sub_gen //=. + apply/setUidPl; apply: maxD; last exact: subsetUl. + rewrite subUset subsetI sDP sDE setIAC subsetIl. + apply/existsP; exists y0; rewrite inE Py0 Ey0 /= setUA -/B. + by rewrite -[<<_>>]joing_idl joingE setKI genGid. +have nDD: D \subset 'N(D). + apply/subsetP=> z Dz; rewrite inE defD. + apply/subsetP=> _ /imsetP[y /setIP[PBy Ey] ->]. + rewrite inE groupJ // ?inE ?(subsetP sDP) ?mem_gen ?setU1r //= memJ_norm //. + exact: (subsetP (subset_trans sDG nEG)). +case nDG: (G \subset 'N(D)). + apply: subsetP Dx; rewrite -gen_subG pcore_max ?(pgroupS (genS _) pB) //. + by rewrite /normal gen_subG sDG norms_gen. +have{n leGn IHn nDG} pN: p.-group <<'N_E(D)>>. + apply: pgroupS (pcore_pgroup p 'N_G(D)); rewrite gen_subG /=. + apply/subsetP=> x1 /setIP[Ex1 Nx1]; apply: IHn => [||y Ny]. + - apply: leq_trans leGn; rewrite proper_card // /proper subsetIl. + by rewrite subsetI nDG andbF. + - by rewrite inE Nx1 (subsetP sEG) ?mem_gen. + have Ex1y: x1 ^ y \in E. + by rewrite -mem_conjgV (normsP nEG) // groupV; case/setIP: Ny. + apply: pgroupS (genS _) (pE _ _ Ex1 Ex1y). + by apply/subsetP=> u; rewrite !inE. +have [y1 Ny1 Py1]: exists2 y1, y1 \in 'N_E(D) & y1 \notin P. + case sNN: ('N_<>('N_<>(D)) \subset 'N_<>(D)). + exists y0 => //; have By0: y0 \in <> by rewrite mem_gen ?setU11. + rewrite inE Ey0 -By0 -in_setI. + by rewrite -['N__(D)](nilpotent_sub_norm (pgroup_nil pB)) ?subsetIl. + case/subsetPn: sNN => z /setIP[Bz NNz]; rewrite inE Bz inE. + case/subsetPn=> y; rewrite mem_conjg => Dzy Dy. + have:= Dzy; rewrite {1}defD; do 2![case/setIP]=> _ Bzy Ezy. + have Ey: y \in E by rewrite -(normsP nEG _ (subsetP sBG z Bz)) mem_conjg. + have /setIP[By Ny]: y \in 'N_<>(D). + by rewrite -(normP NNz) mem_conjg inE Bzy ?(subsetP nDD). + exists y; first by rewrite inE Ey. + by rewrite defD 2!inE Ey By !andbT in Dy. +have [y2 Ny2 Dy2]: exists2 y2, y2 \in 'N_(P :&: E)(D) & y2 \notin D. + case sNN: ('N_P('N_P(D)) \subset 'N_P(D)). + have [z /= Ez sEzP] := Sylow_Jsub sylP (genS sBE) pB. + have Gz: z \in G by exact: subsetP Ez. + have /subsetPn[y Bzy Dy]: ~~ (B :^ z \subset D). + apply/negP; move/subset_leq_card; rewrite cardJg cardsU1. + by rewrite {1}defD 2!inE (negPf Py0) ltnn. + exists y => //; apply: subsetP Bzy. + rewrite -setIA setICA subsetI sub_conjg (normsP nEG) ?groupV // sBE. + have nilP := pgroup_nil (pHall_pgroup sylP). + by rewrite -['N__(_)](nilpotent_sub_norm nilP) ?subsetIl // -gen_subG genJ. + case/subsetPn: sNN => z /setIP[Pz NNz]; rewrite 2!inE Pz. + case/subsetPn=> y Dzy Dy; exists y => //; apply: subsetP Dzy. + rewrite -setIA setICA subsetI sub_conjg (normsP nEG) ?groupV //. + by rewrite sDE -(normP NNz); rewrite conjSg subsetI sDP. + apply: subsetP Pz; exact: (subset_trans (pHall_sub sylP)). +suff{Dy2} Dy2D: y2 |: D = D by rewrite -Dy2D setU11 in Dy2. +apply: maxD; last by rewrite subsetUr. +case/setIP: Ny2 => PEy2 Ny2; case/setIP: Ny1 => Ey1 Ny1. +rewrite subUset sub1set PEy2 subsetI sDP sDE. +apply/existsP; exists y1; rewrite inE Ey1 Py1; apply: pgroupS pN. +rewrite genS // !subUset !sub1set !in_setI Ey1 Ny1. +by case/setIP: PEy2 => _ ->; rewrite Ny2 subsetI sDE. +Qed. + +End NilPGroups. diff --git a/mathcomp/solvable/wielandt_fixpoint.v b/mathcomp/solvable/wielandt_fixpoint.v new file mode 100644 index 0000000..beebc3d --- /dev/null +++ b/mathcomp/solvable/wielandt_fixpoint.v @@ -0,0 +1,651 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div. +Require Import fintype bigop prime binomial finset ssralg fingroup finalg. +Require Import morphism perm automorphism quotient action commutator gproduct. +Require Import zmodp cyclic center pgroup gseries nilpotent sylow finalg. +Require Import finmodule abelian frobenius maximal extremal hall finmodule. +Require Import matrix mxalgebra mxrepresentation mxabelem BGsection1. + +(******************************************************************************) +(* This file provides the proof of the Wielandt fixpoint order formula, *) +(* which is a prerequisite for B & G, Section 3 and Peterfalvi, Section 9. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope ring_scope. +Import GroupScope GRing.Theory. +Import FinRing.Theory. + +Implicit Types (gT wT : finGroupType) (m n p q : nat). + +Lemma coprime_act_abelian_pgroup_structure gT p (A X : {group gT}) : + abelian A -> p.-group A -> p^'.-group X -> X \subset 'N(A) -> + exists2 s : {set {group gT}}, + \big[dprod/1]_(B in s) B = A + & {in s, forall B : {group gT}, + [/\ homocyclic B, X \subset 'N(B) + & acts_irreducibly X (B / 'Phi(B)) 'Q]}. +Proof. +move: {2}_.+1 (ltnSn #|A|) => m. +elim: m => // m IHm in gT A X *; rewrite ltnS => leAm cAA pA p'X nAX. +have [n1 eA]: {n | exponent A = p ^ n}%N by apply p_natP; rewrite pnat_exponent. +have [-> | ntA] := eqsVneq A 1. + by exists set0 => [|B]; rewrite ?big_set0 ?inE. +have [p_pr _ _] := pgroup_pdiv pA ntA; have p_gt1 := prime_gt1 p_pr. +case: n1 => [|n] in eA; first by rewrite trivg_exponent eA in ntA. +have nA1X: X \subset 'N('Ohm_1(A)) := char_norm_trans (Ohm_char 1 A) nAX. +have sAnA1: 'Mho^n(A) \subset 'Ohm_1(A). + rewrite (MhoE n pA) (OhmE 1 pA) genS //. + apply/subsetP=> xpn; case/imsetP=> x Ax ->{xpn}; rewrite !inE groupX //. + by rewrite -expgM -expnSr -eA -order_dvdn dvdn_exponent. +have nAnX: X \subset 'N('Mho^n(A)) := char_norm_trans (Mho_char n A) nAX. +have [B minB sBAn]: {B : {group gT} | minnormal B X & B \subset 'Mho^n(A)}. + apply: mingroup_exists; rewrite nAnX andbT; apply/trivgPn. + have [x Ax ox] := exponent_witness (abelian_nil cAA). + exists (x ^+ (p ^ n)); first by rewrite Mho_p_elt ?(mem_p_elt pA). + by rewrite -order_dvdn -ox eA dvdn_Pexp2l ?ltnn. +have abelA1: p.-abelem 'Ohm_1(A) by rewrite Ohm1_abelem. +have sBA1: B \subset 'Ohm_1(A) := subset_trans sBAn sAnA1. +case/mingroupP: minB; case/andP=> ntB nBX minB. +have{nBX sBA1} [U defA1 nUX] := Maschke_abelem abelA1 p'X sBA1 nA1X nBX. +have [_ mulBU _ tiBU] := dprodP defA1; have{mulBU} [_ sUA1] := mulG_sub mulBU. +have sUA: U \subset A := subset_trans sUA1 (Ohm_sub 1 _). +have [U1 | {defA1 minB}ntU] := eqsVneq U 1. + rewrite U1 dprodg1 /= in defA1. + have homoA: homocyclic A. + apply/(Ohm1_homocyclicP pA cAA); rewrite eA pfactorK //=. + by apply/eqP; rewrite eqEsubset sAnA1 -defA1 sBAn. + exists [set A]; rewrite ?big_set1 // => G; move/set1P->; split=> //. + have OhmMho: forall k, 'Ohm_k(A) = 'Mho^(n.+1 - k)(A). + by move=> k; rewrite (homocyclic_Ohm_Mho k pA) // eA pfactorK. + have fM: {in A &, {morph (fun x => x ^+ (p ^ n)) : x y / x * y >-> x * y}}. + by move=> x y Ax Ay /=; rewrite expgMn // /commute -(centsP cAA). + pose f := Morphism fM; have ker_f: 'ker f = 'Phi(A). + apply/setP=> z; rewrite (Phi_Mho pA cAA) -(subSnn n) -OhmMho. + by rewrite (OhmEabelian pA) ?(abelianS (Ohm_sub n A)) ?inE. + have [g injg def_g] := first_isom f; rewrite /= {}ker_f in g injg def_g. + have{f def_g} def_g: forall H, gval H \subset A -> g @* (H / _) = 'Mho^n(H). + move=> H sHA; rewrite def_g morphimEsub //. + by rewrite (MhoEabelian n (pgroupS sHA pA) (abelianS sHA cAA)). + have im_g: g @* (A / 'Phi(A)) = B by rewrite def_g // defA1 OhmMho subn1. + have defAb: A / 'Phi(A) = g @*^-1 B by rewrite -im_g injmK. + have nsPhiA: 'Phi(A) <| A := Phi_normal A. + have nPhiX: X \subset 'N('Phi(A)) := char_norm_trans (Phi_char A) nAX. + rewrite defAb; apply/mingroupP; split=> [|Hb]. + by rewrite -(morphim_injm_eq1 injg) ?morphpreK /= -?defAb ?im_g ?ntB ?actsQ. + case/andP=> ntHb actsXHb /= sgHbB; have [sHbA _] := subsetIP sgHbB. + rewrite -sub_morphim_pre // in sgHbB; rewrite -(minB _ _ sgHbB) ?injmK //. + rewrite morphim_injm_eq1 // {}ntHb {actsXHb}(subset_trans actsXHb) //=. + have{sHbA} [H defHb sPhiH sHA] := inv_quotientS nsPhiA sHbA. + rewrite defHb def_g // (char_norm_trans (Mho_char n H)) //. + by rewrite astabsQ ?subsetIr ?(normalS sPhiH sHA). +have nsUA: U <| A by rewrite -sub_abelian_normal. +have nUA: A \subset 'N(U) by case/andP: nsUA. +have Au_lt_m: #|A / U| < m := leq_trans (ltn_quotient ntU sUA) leAm. +have cAuAu: abelian (A / U) := quotient_abelian _ cAA. +have pAu: p.-group (A / U) := quotient_pgroup _ pA. +have p'Xu: p^'.-group (X / U) := quotient_pgroup _ p'X. +have nXAu: X / U \subset 'N(A / U) := quotient_norms _ nAX. +have{Au_lt_m p'Xu nXAu} [S defAu simS] := IHm _ _ _ Au_lt_m cAuAu pAu p'Xu nXAu. +have sSAu: forall Ku, Ku \in S -> Ku \subset A / U. + by move=> Ku S_Ku; rewrite -(bigdprodWY defAu) sub_gen // (bigcup_max Ku). +have{B ntB sBAn tiBU} [Ku S_Ku eKu]: exists2 Ku, Ku \in S & exponent Ku == (p ^ n.+1)%N. + apply/exists_inP; apply: contraR ntB; rewrite negb_exists_in -subG1 -tiBU. + move/forall_inP=> expSpn; apply/subsetP=> x Ux; rewrite inE Ux coset_idr //. + by rewrite (subsetP nUA) // (subsetP (Mho_sub n A)) // (subsetP sBAn). + have [y Ay ->]: exists2 y, y \in A & x = y ^+ (p ^ n). + by apply/imsetP; rewrite -MhoEabelian ?(subsetP sBAn). + rewrite morphX ?(subsetP nUA) // (exponentP _ _ (mem_quotient _ Ay)) //. + rewrite -sub_Ldiv -OhmEabelian ?(abelianS (Ohm_sub n _)) //=. + rewrite (OhmE n pAu) /= -(bigdprodWY defAu) genS // subsetI sub_gen //=. + apply/bigcupsP=> Ku S_Ku; rewrite sub_LdivT. + have: exponent Ku %| p ^ n.+1. + by rewrite (dvdn_trans (exponentS (sSAu _ S_Ku))) // -eA exponent_quotient. + case/dvdn_pfactor=> // k le_k_n1 expKu; rewrite expKu dvdn_exp2l //. + by rewrite -ltnS ltn_neqAle le_k_n1 -(eqn_exp2l _ _ p_gt1) -expKu expSpn. +have{sSAu} [sKuA [homoKu nKuX minKu]] := (sSAu Ku S_Ku, simS Ku S_Ku). +have [K defKu sUK sKA] := inv_quotientS nsUA sKuA. +have [cKK cKuKu] := (abelianS sKA cAA, abelianS sKuA cAuAu). +have [pK pKu] := (pgroupS sKA pA, pgroupS sKuA pAu). +have nsUK: U <| K := normalS sUK sKA nsUA; have [_ nUK] := andP nsUK. +have nKX: X \subset 'N(K). + by rewrite -(quotientSGK nUX) ?normsG ?quotient_normG // -defKu. +pose K1 := 'Mho^1(K); have nsK1K: K1 <| K := Mho_normal 1 K. +have nXKb: X / K1 \subset 'N(K / K1) by exact: quotient_norms. +pose K'u := \big[dprod/1]_(Bu in S :\ Ku) Bu. +have{S_Ku} defAu_K: K / U \x K'u = A / U by rewrite -defKu -big_setD1. +have [[_ Pu _ defK'u]] := dprodP defAu_K; rewrite defK'u => mulKPu _ tiKPu. +have [_ sPuA] := mulG_sub mulKPu. +have [P defPu sUP sPA] := inv_quotientS nsUA sPuA. +have{simS defK'u} nPX: X \subset 'N(P). + rewrite -(quotientSGK nUX) ?normsG // quotient_normG ?(normalS sUP sPA) //. + rewrite -defPu -(bigdprodWY defK'u) norms_gen ?norms_bigcup //. + by apply/bigcapsP=> Bu; case/setD1P=> _; case/simS. +have abelKb: p.-abelem (K / K1). + by rewrite -[K1](Phi_Mho pK) ?Phi_quotient_abelem. +have p'Xb: p^'.-group (X / K1) := quotient_pgroup _ p'X. +have sUKb: U / K1 \subset K / K1 := quotientS _ sUK. +have nUXb: X / K1 \subset 'N(U / K1) := quotient_norms _ nUX. +have tiUK1: U :&: K1 = 1. + apply/trivgP; apply/subsetP=> xp; case/setIP=> Uxp K1xp. + have{K1xp} [x Kx def_xp]: exists2 x, x \in K & xp = x ^+ p. + by apply/imsetP; rewrite -(MhoEabelian 1). + suffices A1x: x \in 'Ohm_1(A). + by rewrite def_xp inE; case/abelemP: abelA1 => // _ ->. + have nUx: x \in 'N(U) := subsetP nUK x Kx. + rewrite -sub1set -(quotientSGK _ sUA1) ?quotient_set1 ?sub1set //. + apply: (subsetP (quotientS U (subset_trans (MhoS n sKA) sAnA1))). + rewrite quotientE morphim_Mho //= -quotientE -defKu. + have ->: 'Mho^n(Ku) = 'Ohm_1(Ku). + by rewrite (homocyclic_Ohm_Mho 1 pKu) // (eqP eKu) pfactorK ?subn1. + rewrite (OhmE 1 pKu) ?mem_gen // !inE defKu mem_quotient //=. + by rewrite -morphX //= -def_xp coset_id. +have [Db defKb nDXb] := Maschke_abelem abelKb p'Xb sUKb nXKb nUXb. +have [_ mulUDb _ tiUDb] := dprodP defKb; have [_ sDKb] := mulG_sub mulUDb. +have [D defDb sK1D sDK] := inv_quotientS (Mho_normal 1 K) sDKb. +have nK1X: X \subset 'N(K1) := char_norm_trans (Mho_char 1 K) nKX. +have [cDU [sK1K nK1K]] := (centSS sUK sDK cKK, andP nsK1K). +have nDX: X \subset 'N(D). + rewrite -(quotientSGK nK1X) ?normsG // quotient_normG ?(normalS _ sDK) //. + by rewrite -defDb. +have{mulUDb} mulUD: U * D = K. + rewrite (centC cDU) -(mulSGid sK1D) -mulgA -(centC cDU). + rewrite -quotientK ?quotientMr ?(subset_trans _ nK1K) ?mul_subG // -defDb. + by rewrite mulUDb quotientGK. +have cKP: P \subset 'C(K) := centSS sPA sKA cAA. +have mulKP: K * P = A. + rewrite -(mulSGid sUK) -mulgA -(quotientGK nsUA) -mulKPu defPu. + by rewrite -quotientK ?quotientMr ?mul_subG ?(subset_trans _ nUA). +have defKP: K :&: P = U. + apply/eqP; rewrite eqEsubset subsetI sUK sUP !andbT. + by rewrite -quotient_sub1 ?subIset ?nUK // -tiKPu defPu quotientI. +have tiUD: U :&: D = 1. + apply/trivgP; rewrite -tiUK1 subsetI subsetIl. + rewrite -quotient_sub1; last by rewrite subIset ?(subset_trans sUK). + by rewrite -tiUDb defDb quotientI. +have tiDP: D :&: P = 1 by rewrite -(setIidPl sDK) -setIA defKP setIC. +have mulDP: D * P = A by rewrite -(mulSGid sUP) mulgA -(centC cDU) mulUD. +have sDA := subset_trans sDK sKA. +have defA: D \x P = A by rewrite dprodE // (centSS sPA sDA). +have ntD: D :!=: 1. + apply: contraNneq ntA => D1; rewrite trivg_exponent eA -(eqP eKu). + rewrite -trivg_exponent -subG1 -tiKPu defKu subsetIidl defPu quotientS //. + by rewrite -(mul1g P) -D1 mulDP. +have ltPm: #|P| < m. + by rewrite (leq_trans _ leAm) // -(dprod_card defA) ltn_Pmull ?cardG_gt1. +have [cPP pP] := (abelianS sPA cAA, pgroupS sPA pA). +have{S defAu K'u defAu_K} [S defP simS] := IHm _ _ _ ltPm cPP pP p'X nPX. +exists (D |: S) => [ | {defP}B]. + rewrite big_setU1 ?defP //=; apply: contra ntD => S_D. + by rewrite -subG1 -tiDP subsetIidl -(bigdprodWY defP) sub_gen ?(bigcup_max D). +case/setU1P=> [-> {B S simS} | ]; last exact: simS. +have [[pD cDD] nUD] := (pgroupS sDA pA, abelianS sDA cAA, subset_trans sDA nUA). +have isoD: D \isog Ku by rewrite defKu -mulUD quotientMidl quotient_isog. +rewrite {isoD}(isog_homocyclic isoD); split=> //. +have nPhiDX: X \subset 'N('Phi(D)) := char_norm_trans (Phi_char D) nDX. +have [f [injf im_f act_f]]: + exists f : {morphism D / 'Phi(D) >-> coset_of 'Phi(Ku)}, + [/\ 'injm f, f @* (D / 'Phi(D)) = Ku / 'Phi(Ku) + & {in D / 'Phi(D) & X, morph_act 'Q 'Q f (coset U)}]. +- have [/= injf im_f] := isomP (quotient_isom nUD tiUD). + set f := restrm nUD (coset U) in injf im_f. + rewrite -quotientMidl mulUD -defKu in im_f. + have fPhiD: f @* 'Phi(D) = 'Phi(Ku) by rewrite -im_f (morphim_Phi _ pD). + rewrite -['Phi(Ku)]/(gval 'Phi(Ku)%G) -(group_inj fPhiD). + exists (quotm_morphism [morphism of f] (Phi_normal _)). + rewrite (injm_quotm _ injf) morphim_quotm /= -/f im_f. + split=> // yb x; case/morphimP=> y Ny Dy ->{yb} Xx. + have [nPhiDx nUx] := (subsetP nPhiDX x Xx, subsetP nUX x Xx). + have Dyx: y ^ x \in D by rewrite memJ_norm // (subsetP nDX). + rewrite quotmE // !qactE ?qact_domE ?subsetT ?astabsJ ?quotmE //=. + - by congr (coset _ _); rewrite /f /restrm morphJ // (subsetP nUD). + - by rewrite (subsetP (morphim_norm _ _)) ?mem_morphim. + rewrite morphim_restrm (setIidPr (Phi_sub _)). + by rewrite (subsetP (morphim_norm _ _)) ?mem_quotient. +apply/mingroupP; split=> [|Y]. + rewrite -subG1 quotient_sub1 ?(normal_norm (Phi_normal _)) //. + by rewrite proper_subn ?Phi_proper // actsQ. +case/andP=> ntY actsXY sYD; have{minKu} [_ minKu] := mingroupP minKu. +apply: (injm_morphim_inj injf); rewrite // im_f. +apply: minKu; last by rewrite /= -im_f morphimS. +rewrite morphim_injm_eq1 // ntY. +apply/subsetP=> xb; case/morphimP=> x Nx Xx ->{xb}. +rewrite 2!inE /= qact_domE ?subsetT // astabsJ. +rewrite (subsetP (char_norm_trans (Phi_char _) nKuX)) ?mem_quotient //=. +apply/subsetP=> fy; case/morphimP=> y Dy Yy ->{fy}. +by rewrite inE /= -act_f // morphimEsub // mem_imset // (acts_act actsXY). +Qed. + +CoInductive is_iso_quotient_homocyclic_sdprod gT (V G : {group gT}) m : Prop := + IsoQuotientHomocyclicSdprod wT (W D G1 : {group wT}) (f : {morphism D >-> gT}) + of homocyclic W & #|W| = (#|V| ^ m)%N + & 'ker f = 'Mho^1(W) & f @* W = V & f @* G1 = G & W ><| G1 = D. + +Lemma iso_quotient_homocyclic_sdprod gT (V G : {group gT}) p m : + minnormal V G -> coprime p #|G| -> p.-abelem V -> m > 0 -> + is_iso_quotient_homocyclic_sdprod V G m. +Proof. +move=> minV copG abelV m_gt0; pose q := (p ^ m)%N. +have [ntV nVG] := andP (mingroupp minV). +have [p_pr pVdvdn [n Vpexpn]] := pgroup_pdiv (abelem_pgroup abelV) ntV. +move/(abelem_mx_irrP abelV ntV nVG): (minV) => mx_irrV. +have dim_lt0 : 'dim V > 0 by rewrite (dim_abelemE abelV) // Vpexpn pfactorK. +have q_gt1: q > 1 by rewrite (ltn_exp2l 0) // prime_gt1. +have p_q: p.-nat q by rewrite pnat_exp pnat_id. +have p_dv_q: p %| q := dvdn_exp2l p m_gt0. +pose rG := regular_repr [comUnitRingType of 'Z_q] G; pose MR_G := ('MR rG)%gact. +have [wT [fL injL [fX injX fJ]]]: exists wT : finGroupType, + exists2 fL : {morphism setT >-> wT}, 'injm fL & + exists2 fX : {morphism G >-> wT}, 'injm fX & + {in setT & G, morph_act MR_G 'J fL fX}. +- exists (sdprod_groupType MR_G). + exists (sdpair1_morphism MR_G); first exact: injm_sdpair1. + by exists (sdpair2_morphism MR_G); [exact: injm_sdpair2 | exact: sdpair_act]. +move imfL: (fL @* [set: _])%G => L; move imfX: (fX @* G)%G => X. +have cLL: abelian L by rewrite -imfL morphim_abelian // zmod_abelian. +have pL: p.-group L. + by rewrite -imfL morphim_pgroup -?pnat_exponent ?exponent_mx_group. +have tiVG: V :&: G = 1 by rewrite coprime_TIg // Vpexpn coprime_pexpl. +have{copG} p'G: p^'.-group G by rewrite /pgroup p'natE // -prime_coprime. +have p'X: p^'.-group X by rewrite -imfX morphim_pgroup. +have nXL: X \subset 'N(L). + rewrite -imfX -imfL; apply/subsetP=> _ /morphimP[x Gx _ ->]; rewrite inE. + apply/subsetP=> _ /imsetP[_ /morphimP[v rVv _ ->] ->]. + by rewrite -fJ // mem_morphim ?in_setT. +have [/= S defL im_S] := coprime_act_abelian_pgroup_structure cLL pL p'X nXL. +pose gi (z : 'Z_q) := z%:R : 'F_p. +have giM: rmorphism gi. + split=> [z1 z2|]; last split=> // z1 z2. + apply: canRL (addrK _) _; apply: val_inj. + by rewrite -{2}(subrK z2 z1) -natrD /= !val_Fp_nat ?modn_dvdm // Zp_cast. + by apply: val_inj; rewrite -natrM /= !val_Fp_nat ?modn_dvdm // Zp_cast. +have [gL [DgL _ _ _]] := domP (invm_morphism injL) (congr_group imfL). +pose g u := map_mx (RMorphism giM) (gL u). +have gM: {in L &, {morph g : u v / u * v}}. + by move=> u v Lu Lv /=; rewrite {1}/g morphM // map_mxD. +have kerg: 'ker (Morphism gM) = 'Phi(L). + rewrite (Phi_Mho pL cLL) (MhoEabelian 1 pL cLL). + apply/setP=> u; apply/idP/imsetP=> [ | [v Lv ->{u}]]; last first. + rewrite !inE groupX //=; apply/eqP/rowP=> i; apply: val_inj. + rewrite !mxE morphX // mulmxnE Zp_mulrn /= val_Fp_nat //=. + by move: {i}(_ i); rewrite Zp_cast // => vi; rewrite modn_dvdm // modnMl. + case/morphpreP; rewrite -{1}imfL => /morphimP[v rVv _ ->{u}] /set1P /=. + rewrite /g DgL /= invmE // => /rowP vp0. + pose x := fL (map_mx (fun t : 'Z_q => (t %/ p)%:R) v). + exists x; first by rewrite -imfL mem_morphim ?inE. + rewrite -morphX ?in_setT //; congr (fL _); apply/rowP=> i. + rewrite mulmxnE -{1}(natr_Zp (v 0 i)) {1}(divn_eq (v 0 i) p) addnC. + by have:= congr1 val (vp0 i); rewrite !mxE -mulrnA /= val_Fp_nat // => ->. +have [gX [DgX KgX _ imgX]] := domP (invm_morphism injX) (congr_group imfX). +pose aG := regular_repr [fieldType of 'F_p] G. +have GgX: {in X, forall x, gX x \in G}. + by rewrite DgX -imfX => _ /morphimP[x Gx _ ->]; rewrite /= invmE. +have XfX: {in G, forall x, fX x \in X}. + by move=> x Gx; rewrite -imfX mem_morphim. +have gJ: {in L & X, forall u x, g (u ^ x) = g u *m aG (gX x)}. + rewrite -{1}imfL -{1}imfX => _ _ /morphimP[u rVu _ ->] /morphimP[x Gx _ ->]. + rewrite -fJ // /g DgL DgX /= !invmE // mx_repr_actE ?inE //. + by rewrite (map_mxM (RMorphism giM)) map_regular_mx. +pose gMx U := rowg_mx (Morphism gM @* U). +have simS: forall U, U \in S -> mxsimple aG (gMx U). + move=> U S_U; have [_ nUX irrU] := im_S U S_U. + have{irrU} [modU irrU] := mingroupP irrU; have{modU} [ntU _] := andP modU. + have sUL: U \subset L by rewrite -(bigdprodWY defL) sub_gen // (bigcup_max U). + split=> [||U2 modU2]. + - rewrite (eqmx_module _ (genmxE _)); apply/mxmoduleP=> x Gx. + apply/row_subP=> i; rewrite row_mul rowK. + have [u Lu Uu def_u] := morphimP (enum_valP i). + rewrite -(invmE injX Gx) -DgX def_u -gJ ?XfX //. + set ux := u ^ _; apply: eq_row_sub (gring_index _ (g ux)) _. + have Uux: ux \in U by rewrite memJ_norm // (subsetP nUX) ?XfX. + by rewrite rowK gring_indexK //; apply: mem_morphim; rewrite ?(subsetP sUL). + - apply: contra ntU; rewrite rowg_mx_eq0. + rewrite -subG1 sub_morphim_pre // -kerE kerg => sU_Phi. + rewrite /= quotientS1 //=; rewrite (big_setD1 U) //= in defL. + have{defL} [[_ U' _ ->] defUU' cUU' tiUU'] := dprodP defL. + have defL: U \* U' = L by rewrite cprodE. + have:= cprod_modl (Phi_cprod pL defL) (Phi_sub U). + rewrite -(setIidPl (Phi_sub U')) setIAC -setIA tiUU' setIg1 cprodg1 => ->. + by rewrite subsetIidr. + rewrite -!rowgS stable_rowg_mxK /= => [sU2gU nzU2|]; last first. + apply/subsetP=> z _; rewrite !inE /=; apply/subsetP=> u gUu. + by rewrite inE /= /scale_act -[val z]natr_Zp scaler_nat groupX. + rewrite sub_morphim_pre // -subsetIidl. + rewrite -(quotientSGK (normal_norm (Phi_normal U))) //=; last first. + rewrite subsetI Phi_sub (subset_trans (PhiS pL sUL)) //. + by rewrite -kerg ker_sub_pre. + rewrite [(U :&: _) / _]irrU //; last by rewrite quotientS ?subsetIl. + rewrite (contra _ nzU2) /=; last first. + rewrite -subG1 quotient_sub1; last first. + by rewrite subIset // normal_norm // Phi_normal. + rewrite /= -(morphpre_restrm sUL). + move/(morphimS (restrm_morphism sUL (Morphism gM))). + rewrite morphpreK ?im_restrm // morphim_restrm => s_U2_1. + rewrite -trivg_rowg -subG1 (subset_trans s_U2_1) //. + rewrite -(morphim_ker (Morphism gM)) morphimS // kerg. + by rewrite subIset ?(PhiS pL) ?orbT. + rewrite actsQ //; first by rewrite (char_norm_trans (Phi_char U)). + rewrite normsI //; apply/subsetP=> x Xx; rewrite inE. + apply/subsetP=> _ /imsetP[u g'U2u ->]. + have [Lu U2gu] := morphpreP g'U2u; rewrite mem_rowg in U2gu. + rewrite inE memJ_norm ?(subsetP nXL) // Lu /= inE gJ //. + by rewrite mem_rowg (mxmodule_trans modU2) ?GgX. +have im_g: Morphism gM @* L = [set: 'rV_#|G|]. + apply/eqP; rewrite eqEcard subsetT cardsT card_matrix card_Fp //= mul1n. + rewrite card_morphim kerg setIid (Phi_Mho pL cLL) -divgS ?Mho_sub //. + rewrite -(mul_card_Ohm_Mho_abelian 1 cLL) mulnK ?cardG_gt0 //. + rewrite (card_pgroup (pgroupS (Ohm_sub 1 L) pL)) -rank_abelian_pgroup //. + by rewrite -imfL (injm_rank injL) //= rank_mx_group mul1n. +have sumS: (\sum_(U in S) gMx U :=: 1%:M)%MS. + apply/eqmxP; rewrite submx1; apply/rV_subP=> v _. + have: v \in Morphism gM @* L by rewrite im_g inE. + case/morphimP=> u Lu _ ->{v}. + rewrite -mem_rowg -sub1set -morphim_set1 // sub_morphim_pre ?sub1set //. + have [c [Uc -> _]] := mem_bigdprod defL Lu; rewrite group_prod //= => U S_U. + have sUL: U \subset L by rewrite -(bigdprodWY defL) sub_gen // (bigcup_max U). + rewrite inE (subsetP sUL) ?Uc // inE mem_rowg (sumsmx_sup U) // -mem_rowg. + by rewrite (subsetP (sub_rowg_mx _)) // mem_morphim ?(subsetP sUL) ?Uc. +have Fp'G: [char 'F_p]^'.-group G. + by rewrite (eq_p'group _ (charf_eq (char_Fp p_pr))). +have [VK [modVK defVK]] := rsim_regular_submod mx_irrV Fp'G. +have [U S_U isoUV]: {U | U \in S & mx_iso (regular_repr _ G) (gMx U) VK}. + apply: hom_mxsemisimple_iso (scalar_mx_hom _ 1 _) _ => [|U S_U _|]; auto. + by apply/(submod_mx_irr modVK); exact: (mx_rsim_irr defVK). + by rewrite mulmx1 sumS submx1. +have simU := simS U S_U; have [modU _ _] := simU. +pose rV := abelem_repr abelV ntV nVG. +have{VK modVK defVK isoUV} [h dimU h_free hJ]: mx_rsim (submod_repr modU) rV. + by apply: mx_rsim_trans (mx_rsim_sym defVK); exact/mx_rsim_iso. +have sUL : U \subset L. + by move: defL; rewrite (big_setD1 U) //= => /dprodP[[_ U1 _ ->] /mulG_sub[]]. +pose W := [set: 'rV['Z_(p ^ m)](V)]%G. +have [homU nUX _] := im_S U S_U; have [cUU _] := andP homU. +have atypeU: abelian_type U == nseq ('dim V) (p ^ m)%N. + rewrite (big_setD1 U) //= in defL. + have [[_ U' _ defU'] defUU' _ tiUU'] := dprodP defL. + rewrite defU' in defL defUU' tiUU'. + have ->: 'dim V = 'r(U). + apply/eqP; rewrite -dimU -(eqn_exp2l _ _ (prime_gt1 p_pr)). + rewrite (rank_abelian_pgroup (pgroupS sUL pL) cUU). + rewrite -(card_pgroup (pgroupS (Ohm_sub 1 U) (pgroupS sUL pL))). + rewrite -{1}(card_Fp p_pr) -card_rowg stable_rowg_mxK; last first. + apply/subsetP=> z _; rewrite !inE; apply/subsetP=> v gUv. + by rewrite inE /= /scale_act -(natr_Zp (val z)) scaler_nat groupX. + rewrite card_morphim kerg (Phi_Mho pL cLL) (setIidPr sUL) -divgI setIC. + rewrite -(dprod_modl (Mho_dprod 1 defL) (Mho_sub 1 U)). + rewrite [_ :&: _](trivgP _); last by rewrite -tiUU' setIC setSI ?Mho_sub. + by rewrite dprodg1 -(mul_card_Ohm_Mho_abelian 1 cUU) mulnK ?cardG_gt0. + have isoL: isog L [set: 'rV['Z_q]_#|G|] by rewrite -imfL isog_sym sub_isog. + have homL: homocyclic L by rewrite (isog_homocyclic isoL) mx_group_homocyclic. + have [-> _] := abelian_type_dprod_homocyclic defL pL homL. + by rewrite (exponent_isog isoL) // exponent_mx_group. +have pU: p.-group U by rewrite (pgroupS sUL). +have isoWU: isog U W. + by rewrite eq_abelian_type_isog ?zmod_abelian // abelian_type_mx_group ?mul1n. +have {cUU atypeU} cardU : #|U| = (#|V| ^ m)%N. + rewrite card_homocyclic // (exponent_isog isoWU) exponent_mx_group //. + rewrite -size_abelian_type // (eqP atypeU) size_nseq. + by rewrite (dim_abelemE abelV) // Vpexpn pfactorK // expnAC. +pose f3 w := rVabelem abelV ntV (in_submod _ (g w) *m h). +have f3M: {in U &, {morph f3: w1 w2 / w1 * w2}}. + move=> w1 w2 Uw1 Uw2 /=; rewrite {1}/f3. + rewrite gM ?(subsetP sUL) // linearD mulmxDl. + by rewrite morphM ?mem_im_abelem_rV. +have Ugw w : w \in U -> (g w <= gMx U)%MS. + move=> Uw; rewrite -mem_rowg (subsetP (sub_rowg_mx _)) //. + by rewrite (mem_morphim (Morphism gM)) ?(subsetP sUL). +have KgU: 'ker_U (Morphism gM) = 'Mho^1(U). + rewrite kerg (Phi_Mho pL cLL); rewrite (big_setD1 U) //= in defL. + have [[_ U' _ defU'] _ _ tiUU'] := dprodP defL; rewrite defU' in defL tiUU'. + rewrite setIC -(dprod_modl (Mho_dprod 1 defL) (Mho_sub 1 U)). + by rewrite [_ :&: _](trivgP _) ?dprodg1 // -tiUU' setIC setSI ?Mho_sub. +have{KgU} Kf3: 'ker (Morphism f3M) = 'Mho^1(U). + apply/setP=> w; rewrite !inE /=. + rewrite morph_injm_eq1 ?rVabelem_injm ?mem_im_abelem_rV //=. + rewrite -[1](mul0mx _ h) (inj_eq (row_free_inj h_free)) in_submod_eq0. + case Uw: (w \in U) => /=; last first. + by apply/sym_eq; apply: contraFF Uw; apply: (subsetP (Mho_sub _ _)). + rewrite -[(_ <= _)%MS]andTb -(Ugw _ Uw) -sub_capmx capmx_compl submx0. + by rewrite -KgU !inE Uw (subsetP sUL). +have cUU: abelian U := abelianS sUL cLL. +have im_f3: Morphism f3M @* U = V. + apply/eqP; rewrite eqEcard card_morphim setIid Kf3; apply/andP; split. + by apply/subsetP=> _ /morphimP[w _ _ ->]; apply: mem_rVabelem. + rewrite -divgS ?Mho_sub // -(mul_card_Ohm_Mho_abelian 1 cUU). + rewrite mulnK ?cardG_gt0 // (card_pgroup (pgroupS (Ohm_sub 1 U) pU)). + rewrite -rank_abelian_pgroup // (isog_rank isoWU) /W. + by rewrite (dim_abelemE abelV) // rank_mx_group mul1n Vpexpn pfactorK. +have f3J: {in U & X, morph_act 'J 'J (Morphism f3M) gX}. + move=> u x Uu Xx; rewrite /f3 /= gJ ?(subsetP sUL) // in_submodJ ?Ugw //. + by rewrite -mulmxA hJ ?GgX // mulmxA rVabelemJ ?GgX. +have defUX: U ><| X = U <*> X. + rewrite norm_joinEr; last by case: (im_S _ S_U). + by rewrite sdprodE ?coprime_TIg ?(pnat_coprime pU). +pose f := sdprodm defUX f3J. +have{im_f3} fU_V: f @* U = V by rewrite morphim_sdprodml. +have fX_G: f @* X = G by rewrite morphim_sdprodmr // imgX -imfX im_invm. +suffices: 'ker f = 'Mho^1(U) by exists wT U (U <*> X)%G X [morphism of f]. +rewrite -Kf3; apply/setP=> y; apply/idP/idP; last first. + move=> /morphpreP[/= Uy /set1P f3y]. + by rewrite !inE /= sdprodmEl //= f3y (subsetP (joing_subl _ X)) /=. +rewrite ker_sdprodm => /imset2P[u t Uu /setIdP[Xt /eqP/= fu] ->{y}]. +have: f3 u \in V :&: G. + by rewrite inE -fU_V morphim_sdprodml //= mem_imset ?setIid // fu GgX. +rewrite tiVG in_set1 fu morph_injm_eq1 ?KgX ?injm_invm // => /eqP t1. +by rewrite t1 invg1 mulg1 !inE Uu /= fu t1 morph1. +Qed. + +Theorem solvable_Wielandt_fixpoint (I : finType) gT (A : I -> {group gT}) + (n m : I -> nat) (G V : {group gT}) : + (forall i, m i + n i > 0 -> A i \subset G) -> + G \subset 'N(V) -> coprime #|V| #|G| -> solvable V -> + {in G, forall a, \sum_(i | a \in A i) m i = \sum_(i | a \in A i) n i}%N -> + (\prod_i #|'C_V(A i)| ^ (m i * #|A i|) + = \prod_i #|'C_V(A i)| ^ (n i * #|A i|))%N. +Proof. +move: {2}_.+1 (ltnSn #|V|) => c leVc sA_G nVG coVG solV partG; move: leVc. +pose nz_k i := (0 < m i + n i)%N; rewrite !(bigID nz_k xpredT) /= {2 4}/nz_k. +rewrite !(big1 _ (predC _)) /= => [|i|i]; try by case: (m i) (n i) => [[]|]. +pose sum_k A_ a k := (\sum_(i | (a \in (A_ i : {set _})) && nz_k i) k i)%N. +have{partG} partG: {in G, forall a, sum_k _ A a m = sum_k _ A a n}. + move=> a /partG; rewrite !(bigID nz_k (fun i => a \in _)) -!/(sum_k _ A a _). + by rewrite /= !big1 ?addn0 /nz_k // => i /andP[_]; case: (m i) (n i) => [[]|]. +rewrite !muln1; elim: c => // c IHc in gT G A V nVG coVG solV partG sA_G *. +rewrite ltnS => leVc; have [-> | ntV] := eqsVneq V 1. + by rewrite !big1 // => i _; rewrite setI1g cards1 exp1n. +have nsVVG: V <| V <*> G by rewrite normalYl. +without loss{c leVc IHc} minV: / minnormal V (V <*> G). + have [B minB sBV]: {B : {group gT} | minnormal B (V <*> G) & B \subset V}. + by apply: mingroup_exists; rewrite ntV normal_norm. + have [nBVG ntB abB] := minnormal_solvable minB sBV solV. + have [nBV nBG] := joing_subP nBVG; have solB := solvableS sBV solV. + have [{1}<- -> // | ltBV _] := eqVproper sBV. + have ltBc: #|B| < c := leq_trans (proper_card ltBV) leVc. + have coBG: coprime #|B| #|G| := coprimeSg sBV coVG. + have factorCA_B k i: nz_k i -> + (#|'C_B(A i)| ^ (k i * #|A i|) * #|'C_(V / B)(A i / B)| ^ (k i * #|A i / B|) + = #|'C_V(A i)| ^ (k i * #|A i|))%N. + - move/sA_G => sAiG; have nBAi := subset_trans sAiG nBG. + have [coVAi coBAi] := (coprimegS sAiG coVG, coprimegS sAiG coBG). + rewrite -(card_isog (quotient_isog _ _)) ?(coprime_TIg coBAi) // -expnMn. + rewrite -coprime_quotient_cent // -{1}(setIidPr sBV) setIAC. + by rewrite card_quotient ?LagrangeI // subIset ?nBV. + rewrite -!{1}(eq_bigr _ (factorCA_B _)) {factorCA_B} !big_split /=. + pose A_B i := A i / B; congr (_ * _)%N; first exact: (IHc _ G). + have: #|V / B| < c by apply: leq_trans leVc; rewrite ltn_quotient. + have (i): nz_k i -> A i / B \subset G / B by move/sA_G/quotientS->. + apply: IHc; rewrite ?morphim_sol ?coprime_morph ?quotient_norms //. + move=> _ /morphimP[a Na Ga ->]. + suffices eqAB: sum_k _ A_B (coset B a) =1 sum_k _ A a by rewrite !eqAB partG. + move=> k; apply: eq_bigl => i; apply: andb_id2r => /sA_G sAiG. + rewrite -sub1set -quotient_set1 // quotientSK ?sub1set //. + by rewrite -{2}(mul1g (A i)) -(coprime_TIg coBG) setIC group_modr // inE Ga. +have /is_abelemP[p p_pr abelV] := minnormal_solvable_abelem minV solV. +have [p_gt1 [pV cVV _]] := (prime_gt1 p_pr, and3P abelV). +have{minV} minV: minnormal V G. + apply/mingroupP; split=> [|B nBG sBV]; first by rewrite ntV nVG. + by case/mingroupP: minV => _ -> //; rewrite join_subG (sub_abelian_norm cVV). +have co_pG: coprime p #|G|. + by have [_ _ [e oV]] := pgroup_pdiv pV ntV; rewrite oV coprime_pexpl in coVG. +have p'G: p^'.-group G by rewrite pgroupE p'natE -?prime_coprime. +pose rC i := logn p #|'C_V(A i)|. +have ErC k i: (#|'C_V(A i)| ^ (k i * #|A i|) = p ^ (rC i * k i * #|A i|))%N. + suffices /card_pgroup->: p.-group 'C_V(A i) by rewrite -expnM mulnA. + by rewrite (pgroupS (subsetIl _ _)). +rewrite !{1}(eq_bigr _ (fun i _ => ErC _ i)) {ErC} -!expn_sum; congr (_ ^ _)%N. +have eqmodX x y: (forall e, x = y %[mod p ^ e]) -> x = y. + pose e := maxn x y; move/(_ e); have:= ltn_expl e p_gt1. + by rewrite gtn_max /= => /andP[x_ltq y_ltq]; rewrite !modn_small. +apply: eqmodX => e; have [-> | e_gt0] := posnP e; first by rewrite !modn1. +set q := (p ^ e)%N; have q_gt1: q > 1 by rewrite -(exp1n e) ltn_exp2r. +have{e_gt0 co_pG} [wT W D G1 f homoW oW kerf imfW imfG1 defD] := + iso_quotient_homocyclic_sdprod minV co_pG abelV e_gt0. +have [[cWW _] [_ /mulG_sub[sWD sG1D] nWG1 tiWG1]] := (andP homoW, sdprodP defD). +have pW: p.-group W by rewrite /pgroup oW pnat_exp [p.-nat _]pV. +have rW_V: 'r(W) = 'dim V. + rewrite (rank_abelian_pgroup pW cWW) -(mulnK #|_| (cardG_gt0 'Mho^1(W))). + rewrite mul_card_Ohm_Mho_abelian // divg_normal ?Mho_normal //=. + rewrite -(setIidPr (Mho_sub 1 W)) -kerf. + by rewrite (card_isog (first_isog_loc _ _)) //= imfW (dim_abelemE abelV). +have expW: exponent W = q. + apply/eqP; rewrite -(@eqn_exp2r _ _ ('dim V)) // -{1}rW_V -expnM mulnC expnM. + by rewrite (dim_abelemE abelV) -?card_pgroup // -oW eq_sym max_card_abelian. +have{rW_V} /isogP[fW injfW im_fW]: [set: 'rV['Z_q](V)] \isog W. + rewrite eq_abelian_type_isog ?zmod_abelian // abelian_type_mx_group ?mul1n //. + by rewrite abelian_type_homocyclic // rW_V expW. +have WfW u: fW u \in W by rewrite -im_fW mem_morphim ?inE. +have [fW' [DfW' KfW' _ _]] := domP (invm_morphism injfW) im_fW. +have{KfW'} injfW': 'injm fW' by rewrite KfW' injm_invm. +have fW'K: {in W, cancel fW' fW} by move=> w Ww; rewrite DfW' invmK //= im_fW. +have toWlin a1: linear (fun u => fW' (fW u ^ val (subg G1 a1))). + move=> z /= x y; rewrite (morphM fW) /= ?in_setT // conjMg /=. + rewrite morphM ?memJ_norm ?(subsetP nWG1) ?subgP //=; congr (_ * _). + rewrite -(natr_Zp z) !scaler_nat morphX ?in_setT // conjXg morphX //. + by rewrite memJ_norm // (subsetP nWG1) ?subgP. +pose rW a1 := lin1_mx (Linear (toWlin a1)). +pose fG := restrm sG1D f; have im_fG : fG @* G1 = G by rewrite im_restrm. +have injfG: 'injm fG by rewrite -tiWG1 setIC ker_restrm kerf setIS ?Mho_sub. +pose fG' := invm injfG; have im_fG': fG' @* G = G1 by rewrite -im_fG im_invm. +pose gamma i := \sum_(a in A i) rW (fG' a). +suffices{sum_k partG} tr_rW_Ai i: nz_k i -> \tr (gamma i) = (rC i * #|A i|)%:R. + have Dtr k i: nz_k i -> (rC i * k i * #|A i|)%:R = \tr (gamma i *+ k i). + by rewrite mulnAC natrM raddfMn mulr_natr /= => /tr_rW_Ai->. + rewrite -!val_Zp_nat // !natr_sum !{1}(eq_bigr _ (Dtr _)){Dtr}; congr (val _). + rewrite -!raddf_sum -!(eq_bigr _ (fun i _ => sumrMnl _ _ _ _)); congr (\tr _). + have sA_GP i a nz_i := subsetP (sA_G i nz_i) a. + rewrite !(exchange_big_dep (mem G)) {sA_GP}//=; apply: eq_bigr => a Ga. + by rewrite !sumrMnr !(big_andbC _ _ _ nz_k) -!/(sum_k _ A a _) partG. +move/sA_G=> {sA_G} sAiG; pose Ai1 := fG' @* A i; pose rR := 'r([~: W, Ai1]). +have sAiG1: Ai1 \subset G1 by rewrite -im_fG' morphimS. +have AfG' a: a \in A i -> fG' a \in Ai1. + by move=> Aa; rewrite mem_morphim //= im_restrm imfG1 ?(subsetP sAiG). +have coWAi1: coprime #|W| #|Ai1|. + by rewrite coprime_morphr ?(coprimegS sAiG) ?(pnat_coprime pW). +suffices [Pl [Pr [Pu [Pd [PlrudK ErC ErR]]]]]: + exists Pl, exists Pr, exists Pu, exists Pd, + [/\ row_mx Pl Pr *m col_mx Pu Pd = 1%R, + {in A i, forall a, Pd *m (rW (fG' a) *m Pr) = 1%:M :> 'M_(rC i)} + & \sum_(a in A i) Pu *m (rW (fG' a) *m Pl) = 0 :> 'M_rR]. +- rewrite -(mulmx1 (gamma i)) idmxE -PlrudK mulmxA mxtrace_mulC mul_mx_row. + rewrite mul_col_row mxtrace_block !mulmx_suml !mulmx_sumr ErR mxtrace0 add0r. + by rewrite (eq_bigr _ ErC) sumr_const raddfMn /= mxtrace1 natrM mulr_natr. +have defW: [~: W, Ai1] \x 'C_W(Ai1) = W. + by rewrite coprime_abelian_cent_dprod ?(subset_trans sAiG1). +have [_ mulRCW _ tiRCW] := dprodP defW; have [sRW sCW] := mulG_sub mulRCW. +have [homoRW homoCW] := dprod_homocyclic defW pW homoW. +have [] := abelian_type_dprod_homocyclic defW pW homoW. +rewrite expW -/rR => atypeRW atypeCW. +have [[cRR _] [cCC _]] := (andP homoRW, andP homoCW). +have{cRR atypeRW} /isogP[hR injhR im_hR]: [~: W, Ai1] \isog [set: 'rV['Z_q]_rR]. + rewrite eq_abelian_type_isog ?zmod_abelian ?atypeRW //. + by rewrite abelian_type_mx_group // mul1n eqxx. +have{tiRCW} rCW : 'r('C_W(Ai1)) = rC i. + rewrite -['r(_)]rank_Ohm1; have /rank_abelem ->: p.-abelem 'Ohm_1('C_W(Ai1)). + by rewrite Ohm1_abelem ?(pgroupS (subsetIl _ _)). + congr (logn p _); transitivity #|'C_W(Ai1) : 'Mho^1('C_W(Ai1))|. + by rewrite -divgS ?Mho_sub // -(mul_card_Ohm_Mho_abelian 1 cCC) mulnK. + transitivity #|'C_W(Ai1) : 'Mho^1(W)|. + symmetry; have /dprodP[_ /= defW1 _ _] := Mho_dprod 1 defW. + rewrite -indexgI; congr #|_ : _|; rewrite /= -defW1 -group_modr ?Mho_sub //. + by rewrite [_ :&: _](trivgP _) ?mul1g //= setIC -tiRCW setSI ?Mho_sub. + suffices /card_isog ->: 'C_V(A i) \isog 'C_W(Ai1) / 'Mho^1(W). + by rewrite card_quotient // subIset // normal_norm ?Mho_normal. + rewrite coprime_quotient_cent ?Mho_sub ?abelian_sol //= -/Ai1; last first. + by rewrite (subset_trans sAiG1) // (char_norm_trans _ nWG1) ?Mho_char. + have ->: A i :=: fG @* Ai1. + by rewrite /Ai1 morphim_invmE morphpreK // im_restrm imfG1. + rewrite -imfW morphim_restrm (setIidPr sAiG1). + have [f1 injf1 im_f1] := first_isom f. + rewrite -!im_f1 -injm_subcent ?quotientS ?(subset_trans sAiG1) //. + by rewrite -kerf isog_sym sub_isog // subIset ?quotientS. +have{atypeCW} /isogP[hC injhC im_hC]: 'C_W(Ai1) \isog [set: 'rV['Z_q]_(rC i)]. + rewrite eq_abelian_type_isog ?zmod_abelian // atypeCW rCW. + by rewrite abelian_type_mx_group ?mul1n. +have mkMx m1 m2 (U : {group 'rV['Z_q]_m1}) (g : {morphism U >-> 'rV['Z_q]_m2}): + setT \subset 'dom g -> {Mg | mulmx^~ Mg =1 g}. +- move/subsetP=> allU; suffices lin_g: linear g. + by exists (lin1_mx (Linear lin_g)) => u; rewrite mul_rV_lin1. + move=> z u v; rewrite morphM ?allU ?in_setT //. + by rewrite -(natr_Zp z) !scaler_nat -zmodXgE morphX ?allU ?in_setT. +have /mkMx[Pu defPu]: setT \subset 'dom (invm injfW \o invm injhR). + by rewrite -sub_morphim_pre -im_hR // im_invm //= im_fW. +have /mkMx[Pd defPd]: setT \subset 'dom (invm injfW \o invm injhC). + by rewrite -sub_morphim_pre -im_hC //= im_fW im_invm subsetIl. +pose fUl := pairg1 [finGroupType of 'rV['Z_q]_(rC i)] \o hR. +pose fUr := @pair1g [finGroupType of 'rV['Z_q]_rR] _ \o hC. +have cRCW: fUr @* 'C_W(Ai1) \subset 'C(fUl @* [~: W, Ai1]). + rewrite !morphim_comp morphim_pair1g morphim_pairg1. + set UR := hR @* _; set UC := hC @* _. + by have/dprodP[] : _ = setX UR UC := setX_dprod _ _. +have /domP[fUr' [DfUr' _ _ im_fUr']]: 'dom fUr = 'C_W(Ai1). + by rewrite /dom -im_hC injmK. +have /domP[fUl' [DfUl' _ _ im_fUl']]: 'dom fUl = [~: W, Ai1]. + by rewrite /dom -im_hR injmK. +rewrite -{}im_fUr' -{}im_fUl' in cRCW; pose hW := dprodm defW cRCW. +pose fPl := @fst _ _ \o (hW \o fW); pose fPr := @snd _ _ \o (hW \o fW). +have /mkMx[/= Pl defPl]: setT \subset 'dom fPl. + by rewrite -!sub_morphim_pre ?subsetT ?im_fW. +have /mkMx[/= Pr defPr]: setT \subset 'dom fPr. + by rewrite -!sub_morphim_pre ?subsetT ?im_fW. +exists Pl, Pr, Pu, Pd; split. +- apply/row_matrixP=> j; rewrite rowE -row1 mul_row_col mulmxDr !mulmxA. + apply: (injmP injfW); rewrite ?in_setT // morphM ?in_setT //. + rewrite defPl defPr defPu defPd -/hW [hW]lock /= -lock. + have /(mem_dprod defW)[jR [jC [RjR CjC -> _]]]:= WfW (row j 1). + rewrite [hW _]dprodmE // DfUl' DfUr' /= mulg1 mul1g !invmE // -DfW'. + by rewrite !fW'K ?(subsetP sRW jR) ?(subsetP sCW). +- move=> a Aa; apply/row_matrixP=> j; pose jC := invm injhC (row j 1%:M). + rewrite rowE -row1 !mulmxA defPd defPr -/hW [hW]lock /= mul_rV_lin1 /= -lock. + have CjC: jC \in 'C_W(Ai1). + by rewrite -(im_invm injhC) mem_morphim /= ?im_hC ?inE. + have [[/fW'K id_jC /centP cA1jC] A1a] := (setIP CjC, AfG' a Aa). + rewrite -DfW' id_jC subgK ?(subsetP sAiG1) // /conjg cA1jC // mulKg id_jC. + by rewrite [hW _]dprodmEr ?DfUr' //= invmK ?im_hC ?inE. +apply/row_matrixP=> j; pose jR := invm injhR (row j 1%:M). +have RjR: jR \in [~: W, Ai1]. + by rewrite -(im_invm injhR) mem_morphim /= ?im_hR ?inE. +rewrite rowE -row1 mulmx_sumr raddf0 -/jR. +have /subsetP nRA1: Ai1 \subset 'N([~: W, Ai1]) by rewrite commg_normr. +transitivity (\sum_(a1 in Ai1) hR (jR ^ a1)). + rewrite {1}[Ai1 in rhs in _ = rhs]morphimEsub /= ?im_restrm ?imfG1 //. + rewrite big_imset /=; last first. + apply: sub_in2 (injmP (injm_invm injfG)); apply/subsetP. + by rewrite /= im_restrm imfG1. + apply: eq_bigr => a /AfG' A1a. + have RjRa: jR ^ fG' a \in [~: W, Ai1] by rewrite memJ_norm ?nRA1. + rewrite !mulmxA defPu defPl mul_rV_lin1 -/hW [hW]lock /= -lock. + rewrite subgK ?(subsetP sAiG1) // -DfW' !fW'K ?(subsetP sRW) //. + by rewrite [hW _]dprodmEl // DfUl'. +have [nf [fj Rfj ->]] := gen_prodgP RjR. +transitivity (\sum_(a1 in Ai1) (\prod_i1 hR (fj i1 ^ a1))%g). + apply: eq_bigr => a1 Aa1; rewrite conjg_prod morph_prod // => i1 _. + by rewrite memJ_norm ?mem_gen ?nRA1. +rewrite exchange_big big1 //= => i1 _; have /imset2P[w a1 Ww Aa1 ->] := Rfj i1. +apply: (addrI (\sum_(a2 in Ai1) hR [~ w, a2])). +rewrite addr0 {2}(reindex_inj (mulgI a1)) -big_split /=. +apply: eq_big => [a2 | a2 Aa2]; first by rewrite groupMl. +by rewrite commgMJ [rhs in _ = rhs]morphM ?memJ_norm ?nRA1 ?mem_commg ?groupM. +Qed. diff --git a/mathcomp/ssreflect/Make b/mathcomp/ssreflect/Make new file mode 100644 index 0000000..9e7c5db --- /dev/null +++ b/mathcomp/ssreflect/Make @@ -0,0 +1,8 @@ +all.v +eqtype.v +seq.v +ssrbool.v +ssreflect.v +ssrfun.v +ssrmatching.v +ssrnat.v diff --git a/mathcomp/ssreflect/Makefile b/mathcomp/ssreflect/Makefile new file mode 100644 index 0000000..46a2d69 --- /dev/null +++ b/mathcomp/ssreflect/Makefile @@ -0,0 +1,33 @@ +ifeq "$(COQBIN)" "" +COQBIN=$(dir $(shell which coqtop))/ +endif + + +ifeq "$(shell $(COQBIN)/coqtop -v | head -1 | grep trunk | wc -l)" "1" +V=trunk +else +V=$(shell $(COQBIN)/coqtop -v | head -1 | \ + sed 's/.*version \([0-9]\.[0-9]\)[^ ]* .*/v\1/') +endif + +OLD_MAKEFLAGS:=$(MAKEFLAGS) +MAKEFLAGS+=-B + +%: + @[ -e Makefile.coq ] || $(call coqmakefile) + @[ Make -ot Makefile.coq ] || $(call coqmakefile) + @MAKEFLAGS=$(OLD_MAKEFLAGS) $(MAKE) --no-print-directory \ + -f Makefile.coq $* + +define coqmakefile + (echo "Generating Makefile.coq for Coq $(V) with COQBIN=$(COQBIN)";\ + cp Make Make.coq;\ + echo -I plugin/$(V)/src >> Make.coq;\ + echo plugin/$(V)/src/ssreflect.mllib >> Make.coq;\ + echo plugin/$(V)/src/ssrmatching.mli >> Make.coq;\ + echo plugin/$(V)/src/ssrmatching.ml4 >> Make.coq;\ + echo plugin/$(V)/src/ssreflect.ml4 >> Make.coq;\ + $(COQBIN)/coq_makefile -f Make.coq -o Makefile.coq) +endef + + diff --git a/mathcomp/ssreflect/all.v b/mathcomp/ssreflect/all.v new file mode 100644 index 0000000..c441810 --- /dev/null +++ b/mathcomp/ssreflect/all.v @@ -0,0 +1,7 @@ +Require Export eqtype. +Require Export seq. +Require Export ssrbool. +Require Export ssreflect. +Require Export ssrfun. +Require Export ssrmatching. +Require Export ssrnat. diff --git a/mathcomp/ssreflect/eqtype.v b/mathcomp/ssreflect/eqtype.v new file mode 100644 index 0000000..01b0f5e --- /dev/null +++ b/mathcomp/ssreflect/eqtype.v @@ -0,0 +1,860 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool. + +(******************************************************************************) +(* This file defines two "base" combinatorial interfaces: *) +(* eqType == the structure for types with a decidable equality. *) +(* Equality mixins can be made Canonical to allow generic *) +(* folding of equality predicates. *) +(* subType p == the structure for types isomorphic to {x : T | p x} with *) +(* p : pred T for some type T. *) +(* The eqType interface supports the following operations: *) +(* x == y <=> x compares equal to y (this is a boolean test). *) +(* x == y :> T <=> x == y at type T. *) +(* x != y <=> x and y compare unequal. *) +(* x != y :> T <=> " " " " at type T. *) +(* x =P y :: a proof of reflect (x = y) (x == y); this coerces *) +(* to x == y -> x = y. *) +(* comparable T <-> equality on T is decidable *) +(* := forall x y : T, decidable (x = y) *) +(* comparableClass compT == eqType mixin/class for compT : comparable T. *) +(* pred1 a == the singleton predicate [pred x | x == a]. *) +(* pred2, pred3, pred4 == pair, triple, quad predicates. *) +(* predC1 a == [pred x | x != a]. *) +(* [predU1 a & A] == [pred x | (x == a) || (x \in A)]. *) +(* [predD1 A & a] == [pred x | x != a & x \in A]. *) +(* predU1 a P, predD1 P a == applicative versions of the above. *) +(* frel f == the relation associated with f : T -> T. *) +(* := [rel x y | f x == y]. *) +(* invariant k f == elements of T whose k-class is f-invariant. *) +(* := [pred x | k (f x) == k x] with f : T -> T. *) +(* [fun x : T => e0 with a1 |-> e1, .., a_n |-> e_n] *) +(* [eta f with a1 |-> e1, .., a_n |-> e_n] == *) +(* the auto-expanding function that maps x = a_i to e_i, and other values *) +(* of x to e0 (resp. f x). In the first form the `: T' is optional and x *) +(* can occur in a_i or e_i. *) +(* Equality on an eqType is proof-irrelevant (lemma eq_irrelevance). *) +(* The eqType interface is implemented for most standard datatypes: *) +(* bool, unit, void, option, prod (denoted A * B), sum (denoted A + B), *) +(* sig (denoted {x | P}), sigT (denoted {i : I & T}). We also define *) +(* tagged_as u v == v cast as T_(tag u) if tag v == tag u, else u. *) +(* -> We have u == v <=> (tag u == tag v) && (tagged u == tagged_as u v). *) +(* The subType interface supports the following operations: *) +(* val == the generic injection from a subType S of T into T. *) +(* For example, if u : {x : T | P}, then val u : T. *) +(* val is injective because P is proof-irrelevant (P is in bool, *) +(* and the is_true coercion expands to P = true). *) +(* valP == the generic proof of P (val u) for u : subType P. *) +(* Sub x Px == the generic constructor for a subType P; Px is a proof of P x *) +(* and P should be inferred from the expected return type. *) +(* insub x == the generic partial projection of T into a subType S of T. *) +(* This returns an option S; if S : subType P then *) +(* insub x = Some u with val u = x if P x, *) +(* None if ~~ P x *) +(* The insubP lemma encapsulates this dichotomy. *) +(* P should be infered from the expected return type. *) +(* innew x == total (non-option) variant of insub when P = predT. *) +(* {? x | P} == option {x | P} (syntax for casting insub x). *) +(* insubd u0 x == the generic projection with default value u0. *) +(* := odflt u0 (insub x). *) +(* insigd A0 x == special case of insubd for S == {x | x \in A}, where A0 is *) +(* a proof of x0 \in A. *) +(* insub_eq x == transparent version of insub x that expands to Some/None *) +(* when P x can evaluate. *) +(* The subType P interface is most often implemented using one of: *) +(* [subType for S_val] *) +(* where S_val : S -> T is the first projection of a type S isomorphic to *) +(* {x : T | P}. *) +(* [newType for S_val] *) +(* where S_val : S -> T is the projection of a type S isomorphic to *) +(* wrapped T; in this case P must be predT. *) +(* [subType for S_val by Srect], [newType for S_val by Srect] *) +(* variants of the above where the eliminator is explicitly provided. *) +(* Here S no longer needs to be syntactically identical to {x | P x} or *) +(* wrapped T, but it must have a derived constructor S_Sub statisfying an *) +(* eliminator Srect identical to the one the Coq Inductive command would *) +(* have generated, and S_val (S_Sub x Px) (resp. S_val (S_sub x) for the *) +(* newType form) must be convertible to x. *) +(* variant of the above when S is a wrapper type for T (so P = predT). *) +(* [subType of S], [subType of S for S_val] *) +(* clones the canonical subType structure for S; if S_val is specified, *) +(* then it replaces the inferred projector. *) +(* Subtypes inherit the eqType structure of their base types; the generic *) +(* structure should be explicitly instantiated using the *) +(* [eqMixin of S by <:] *) +(* construct to declare the Equality mixin; this pattern is repeated for all *) +(* the combinatorial interfaces (Choice, Countable, Finite). *) +(* More generally, the eqType structure can be transfered by (partial) *) +(* injections, using: *) +(* InjEqMixin injf == an Equality mixin for T, using an f : T -> eT where *) +(* eT has an eqType structure and injf : injective f. *) +(* PcanEqMixin fK == an Equality mixin similarly derived from f and a left *) +(* inverse partial function g and fK : pcancel f g. *) +(* CanEqMixin fK == an Equality mixin similarly derived from f and a left *) +(* inverse function g and fK : cancel f g. *) +(* We add the following to the standard suffixes documented in ssrbool.v: *) +(* 1, 2, 3, 4 -- explicit enumeration predicate for 1 (singleton), 2, 3, or *) +(* 4 values. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Module Equality. + +Definition axiom T (e : rel T) := forall x y, reflect (x = y) (e x y). + +Structure mixin_of T := Mixin {op : rel T; _ : axiom op}. +Notation class_of := mixin_of (only parsing). + +Section ClassDef. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variables (T : Type) (cT : type). + +Definition class := let: Pack _ c _ := cT return class_of cT in c. + +Definition pack c := @Pack T c T. +Definition clone := fun c & cT -> T & phant_id (pack c) cT => pack c. + +End ClassDef. + +Module Exports. +Coercion sort : type >-> Sortclass. +Notation eqType := type. +Notation EqMixin := Mixin. +Notation EqType T m := (@pack T m). +Notation "[ 'eqMixin' 'of' T ]" := (class _ : mixin_of T) + (at level 0, format "[ 'eqMixin' 'of' T ]") : form_scope. +Notation "[ 'eqType' 'of' T 'for' C ]" := (@clone T C _ idfun id) + (at level 0, format "[ 'eqType' 'of' T 'for' C ]") : form_scope. +Notation "[ 'eqType' 'of' T ]" := (@clone T _ _ id id) + (at level 0, format "[ 'eqType' 'of' T ]") : form_scope. +End Exports. + +End Equality. +Export Equality.Exports. + +Definition eq_op T := Equality.op (Equality.class T). + +Lemma eqE T x : eq_op x = Equality.op (Equality.class T) x. +Proof. by []. Qed. + +Lemma eqP T : Equality.axiom (@eq_op T). +Proof. by case: T => ? []. Qed. +Implicit Arguments eqP [T x y]. + +Delimit Scope eq_scope with EQ. +Open Scope eq_scope. + +Notation "x == y" := (eq_op x y) + (at level 70, no associativity) : bool_scope. +Notation "x == y :> T" := ((x : T) == (y : T)) + (at level 70, y at next level) : bool_scope. +Notation "x != y" := (~~ (x == y)) + (at level 70, no associativity) : bool_scope. +Notation "x != y :> T" := (~~ (x == y :> T)) + (at level 70, y at next level) : bool_scope. +Notation "x =P y" := (eqP : reflect (x = y) (x == y)) + (at level 70, no associativity) : eq_scope. +Notation "x =P y :> T" := (eqP : reflect (x = y :> T) (x == y :> T)) + (at level 70, y at next level, no associativity) : eq_scope. + +Prenex Implicits eq_op eqP. + +Lemma eq_refl (T : eqType) (x : T) : x == x. Proof. exact/eqP. Qed. +Notation eqxx := eq_refl. + +Lemma eq_sym (T : eqType) (x y : T) : (x == y) = (y == x). +Proof. exact/eqP/eqP. Qed. + +Hint Resolve eq_refl eq_sym. + +Section Contrapositives. + +Variable T : eqType. +Implicit Types (A : pred T) (b : bool) (x : T). + +Lemma contraTeq b x y : (x != y -> ~~ b) -> b -> x = y. +Proof. by move=> imp hyp; apply/eqP; apply: contraTT hyp. Qed. + +Lemma contraNeq b x y : (x != y -> b) -> ~~ b -> x = y. +Proof. by move=> imp hyp; apply/eqP; apply: contraNT hyp. Qed. + +Lemma contraFeq b x y : (x != y -> b) -> b = false -> x = y. +Proof. by move=> imp /negbT; apply: contraNeq. Qed. + +Lemma contraTneq b x y : (x = y -> ~~ b) -> b -> x != y. +Proof. by move=> imp; apply: contraTN => /eqP. Qed. + +Lemma contraNneq b x y : (x = y -> b) -> ~~ b -> x != y. +Proof. by move=> imp; apply: contraNN => /eqP. Qed. + +Lemma contraFneq b x y : (x = y -> b) -> b = false -> x != y. +Proof. by move=> imp /negbT; apply: contraNneq. Qed. + +Lemma contra_eqN b x y : (b -> x != y) -> x = y -> ~~ b. +Proof. by move=> imp /eqP; apply: contraL. Qed. + +Lemma contra_eqF b x y : (b -> x != y) -> x = y -> b = false. +Proof. by move=> imp /eqP; apply: contraTF. Qed. + +Lemma contra_eqT b x y : (~~ b -> x != y) -> x = y -> b. +Proof. by move=> imp /eqP; apply: contraLR. Qed. + +Lemma contra_eq x1 y1 x2 y2 : (x2 != y2 -> x1 != y1) -> x1 = y1 -> x2 = y2. +Proof. by move=> imp /eqP; apply: contraTeq. Qed. + +Lemma contra_neq x1 y1 x2 y2 : (x2 = y2 -> x1 = y1) -> x1 != y1 -> x2 != y2. +Proof. by move=> imp; apply: contraNneq => /imp->. Qed. + +Lemma memPn A x : reflect {in A, forall y, y != x} (x \notin A). +Proof. +apply: (iffP idP) => [notDx y | notDx]; first by apply: contraTneq => ->. +exact: contraL (notDx x) _. +Qed. + +Lemma memPnC A x : reflect {in A, forall y, x != y} (x \notin A). +Proof. by apply: (iffP (memPn A x)) => A'x y /A'x; rewrite eq_sym. Qed. + +Lemma ifN_eq R x y vT vF : x != y -> (if x == y then vT else vF) = vF :> R. +Proof. exact: ifN. Qed. + +Lemma ifN_eqC R x y vT vF : x != y -> (if y == x then vT else vF) = vF :> R. +Proof. by rewrite eq_sym; apply: ifN. Qed. + +End Contrapositives. + +Implicit Arguments memPn [T A x]. +Implicit Arguments memPnC [T A x]. + +Theorem eq_irrelevance (T : eqType) x y : forall e1 e2 : x = y :> T, e1 = e2. +Proof. +pose proj z e := if x =P z is ReflectT e0 then e0 else e. +suff: injective (proj y) by rewrite /proj => injp e e'; apply: injp; case: eqP. +pose join (e : x = _) := etrans (esym e). +apply: can_inj (join x y (proj x (erefl x))) _. +by case: y /; case: _ / (proj x _). +Qed. + +Corollary eq_axiomK (T : eqType) (x : T) : all_equal_to (erefl x). +Proof. move=> eq_x_x; exact: eq_irrelevance. Qed. + +(* We use the module system to circumvent a silly limitation that *) +(* forbids using the same constant to coerce to different targets. *) +Module Type EqTypePredSig. +Parameter sort : eqType -> predArgType. +End EqTypePredSig. +Module MakeEqTypePred (eqmod : EqTypePredSig). +Coercion eqmod.sort : eqType >-> predArgType. +End MakeEqTypePred. +Module Export EqTypePred := MakeEqTypePred Equality. + +Lemma unit_eqP : Equality.axiom (fun _ _ : unit => true). +Proof. by do 2!case; left. Qed. + +Definition unit_eqMixin := EqMixin unit_eqP. +Canonical unit_eqType := Eval hnf in EqType unit unit_eqMixin. + +(* Comparison for booleans. *) + +(* This is extensionally equal, but not convertible to Bool.eqb. *) +Definition eqb b := addb (~~ b). + +Lemma eqbP : Equality.axiom eqb. +Proof. by do 2!case; constructor. Qed. + +Canonical bool_eqMixin := EqMixin eqbP. +Canonical bool_eqType := Eval hnf in EqType bool bool_eqMixin. + +Lemma eqbE : eqb = eq_op. Proof. by []. Qed. + +Lemma bool_irrelevance (x y : bool) (E E' : x = y) : E = E'. +Proof. exact: eq_irrelevance. Qed. + +Lemma negb_add b1 b2 : ~~ (b1 (+) b2) = (b1 == b2). +Proof. by rewrite -addNb. Qed. + +Lemma negb_eqb b1 b2 : (b1 != b2) = b1 (+) b2. +Proof. by rewrite -addNb negbK. Qed. + +Lemma eqb_id b : (b == true) = b. +Proof. by case: b. Qed. + +Lemma eqbF_neg b : (b == false) = ~~ b. +Proof. by case: b. Qed. + +Lemma eqb_negLR b1 b2 : (~~ b1 == b2) = (b1 == ~~ b2). +Proof. by case: b1; case: b2. Qed. + +(* Equality-based predicates. *) + +Notation xpred1 := (fun a1 x => x == a1). +Notation xpred2 := (fun a1 a2 x => (x == a1) || (x == a2)). +Notation xpred3 := (fun a1 a2 a3 x => [|| x == a1, x == a2 | x == a3]). +Notation xpred4 := + (fun a1 a2 a3 a4 x => [|| x == a1, x == a2, x == a3 | x == a4]). +Notation xpredU1 := (fun a1 (p : pred _) x => (x == a1) || p x). +Notation xpredC1 := (fun a1 x => x != a1). +Notation xpredD1 := (fun (p : pred _) a1 x => (x != a1) && p x). + +Section EqPred. + +Variable T : eqType. + +Definition pred1 (a1 : T) := SimplPred (xpred1 a1). +Definition pred2 (a1 a2 : T) := SimplPred (xpred2 a1 a2). +Definition pred3 (a1 a2 a3 : T) := SimplPred (xpred3 a1 a2 a3). +Definition pred4 (a1 a2 a3 a4 : T) := SimplPred (xpred4 a1 a2 a3 a4). +Definition predU1 (a1 : T) p := SimplPred (xpredU1 a1 p). +Definition predC1 (a1 : T) := SimplPred (xpredC1 a1). +Definition predD1 p (a1 : T) := SimplPred (xpredD1 p a1). + +Lemma pred1E : pred1 =2 eq_op. Proof. move=> x y; exact: eq_sym. Qed. + +Variables (T2 : eqType) (x y : T) (z u : T2) (b : bool). + +Lemma predU1P : reflect (x = y \/ b) ((x == y) || b). +Proof. apply: (iffP orP) => [] []; by [right | move/eqP; left]. Qed. + +Lemma pred2P : reflect (x = y \/ z = u) ((x == y) || (z == u)). +Proof. by apply: (iffP orP) => [] [] /eqP; by [left | right]. Qed. + +Lemma predD1P : reflect (x <> y /\ b) ((x != y) && b). +Proof. by apply: (iffP andP)=> [] [] // /eqP. Qed. + +Lemma predU1l : x = y -> (x == y) || b. +Proof. by move->; rewrite eqxx. Qed. + +Lemma predU1r : b -> (x == y) || b. +Proof. by move->; rewrite orbT. Qed. + +Lemma eqVneq : {x = y} + {x != y}. +Proof. by case: eqP; [left | right]. Qed. + +End EqPred. + +Implicit Arguments predU1P [T x y b]. +Implicit Arguments pred2P [T T2 x y z u]. +Implicit Arguments predD1P [T x y b]. +Prenex Implicits pred1 pred2 pred3 pred4 predU1 predC1 predD1 predU1P. + +Notation "[ 'predU1' x & A ]" := (predU1 x [mem A]) + (at level 0, format "[ 'predU1' x & A ]") : fun_scope. +Notation "[ 'predD1' A & x ]" := (predD1 [mem A] x) + (at level 0, format "[ 'predD1' A & x ]") : fun_scope. + +(* Lemmas for reflected equality and functions. *) + +Section EqFun. + +Section Exo. + +Variables (aT rT : eqType) (D : pred aT) (f : aT -> rT) (g : rT -> aT). + +Lemma inj_eq : injective f -> forall x y, (f x == f y) = (x == y). +Proof. by move=> inj_f x y; apply/eqP/eqP=> [|-> //]; exact: inj_f. Qed. + +Lemma can_eq : cancel f g -> forall x y, (f x == f y) = (x == y). +Proof. move/can_inj; exact: inj_eq. Qed. + +Lemma bij_eq : bijective f -> forall x y, (f x == f y) = (x == y). +Proof. move/bij_inj; apply: inj_eq. Qed. + +Lemma can2_eq : cancel f g -> cancel g f -> forall x y, (f x == y) = (x == g y). +Proof. by move=> fK gK x y; rewrite -{1}[y]gK; exact: can_eq. Qed. + +Lemma inj_in_eq : + {in D &, injective f} -> {in D &, forall x y, (f x == f y) = (x == y)}. +Proof. by move=> inj_f x y Dx Dy; apply/eqP/eqP=> [|-> //]; exact: inj_f. Qed. + +Lemma can_in_eq : + {in D, cancel f g} -> {in D &, forall x y, (f x == f y) = (x == y)}. +Proof. by move/can_in_inj; exact: inj_in_eq. Qed. + +End Exo. + +Section Endo. + +Variable T : eqType. + +Definition frel f := [rel x y : T | f x == y]. + +Lemma inv_eq f : involutive f -> forall x y : T, (f x == y) = (x == f y). +Proof. by move=> fK; exact: can2_eq. Qed. + +Lemma eq_frel f f' : f =1 f' -> frel f =2 frel f'. +Proof. by move=> eq_f x y; rewrite /= eq_f. Qed. + +End Endo. + +Variable aT : Type. + +(* The invariant of an function f wrt a projection k is the pred of points *) +(* that have the same projection as their image. *) + +Definition invariant (rT : eqType) f (k : aT -> rT) := + [pred x | k (f x) == k x]. + +Variables (rT1 rT2 : eqType) (f : aT -> aT) (h : rT1 -> rT2) (k : aT -> rT1). + +Lemma invariant_comp : subpred (invariant f k) (invariant f (h \o k)). +Proof. by move=> x eq_kfx; rewrite /= (eqP eq_kfx). Qed. + +Lemma invariant_inj : injective h -> invariant f (h \o k) =1 invariant f k. +Proof. move=> inj_h x; exact: (inj_eq inj_h). Qed. + +End EqFun. + +Prenex Implicits frel. + +(* The coercion to rel must be explicit for derived Notations to unparse. *) +Notation coerced_frel f := (rel_of_simpl_rel (frel f)) (only parsing). + +Section FunWith. + +Variables (aT : eqType) (rT : Type). + +CoInductive fun_delta : Type := FunDelta of aT & rT. + +Definition fwith x y (f : aT -> rT) := [fun z => if z == x then y else f z]. + +Definition app_fdelta df f z := + let: FunDelta x y := df in if z == x then y else f z. + +End FunWith. + +Prenex Implicits fwith. + +Notation "x |-> y" := (FunDelta x y) + (at level 190, no associativity, + format "'[hv' x '/ ' |-> y ']'") : fun_delta_scope. + +Delimit Scope fun_delta_scope with FUN_DELTA. +Arguments Scope app_fdelta [_ type_scope fun_delta_scope _ _]. + +Notation "[ 'fun' z : T => F 'with' d1 , .. , dn ]" := + (SimplFunDelta (fun z : T => + app_fdelta d1%FUN_DELTA .. (app_fdelta dn%FUN_DELTA (fun _ => F)) ..)) + (at level 0, z ident, only parsing) : fun_scope. + +Notation "[ 'fun' z => F 'with' d1 , .. , dn ]" := + (SimplFunDelta (fun z => + app_fdelta d1%FUN_DELTA .. (app_fdelta dn%FUN_DELTA (fun _ => F)) ..)) + (at level 0, z ident, format + "'[hv' [ '[' 'fun' z => '/ ' F ']' '/' 'with' '[' d1 , '/' .. , '/' dn ']' ] ']'" + ) : fun_scope. + +Notation "[ 'eta' f 'with' d1 , .. , dn ]" := + (SimplFunDelta (fun _ => + app_fdelta d1%FUN_DELTA .. (app_fdelta dn%FUN_DELTA f) ..)) + (at level 0, format + "'[hv' [ '[' 'eta' '/ ' f ']' '/' 'with' '[' d1 , '/' .. , '/' dn ']' ] ']'" + ) : fun_scope. + +(* Various EqType constructions. *) + +Section ComparableType. + +Variable T : Type. + +Definition comparable := forall x y : T, decidable (x = y). + +Hypothesis Hcompare : comparable. + +Definition compareb x y : bool := Hcompare x y. + +Lemma compareP : Equality.axiom compareb. +Proof. by move=> x y; exact: sumboolP. Qed. + +Definition comparableClass := EqMixin compareP. + +End ComparableType. + +Definition eq_comparable (T : eqType) : comparable T := + fun x y => decP (x =P y). + +Section SubType. + +Variables (T : Type) (P : pred T). + +Structure subType : Type := SubType { + sub_sort :> Type; + val : sub_sort -> T; + Sub : forall x, P x -> sub_sort; + _ : forall K (_ : forall x Px, K (@Sub x Px)) u, K u; + _ : forall x Px, val (@Sub x Px) = x +}. + +Implicit Arguments Sub [s]. +Lemma vrefl : forall x, P x -> x = x. Proof. by []. Qed. +Definition vrefl_rect := vrefl. + +Definition clone_subType U v := + fun sT & sub_sort sT -> U => + fun c Urec cK (sT' := @SubType U v c Urec cK) & phant_id sT' sT => sT'. + +Variable sT : subType. + +CoInductive Sub_spec : sT -> Type := SubSpec x Px : Sub_spec (Sub x Px). + +Lemma SubP u : Sub_spec u. +Proof. by case: sT Sub_spec SubSpec u => T' _ C rec /= _. Qed. + +Lemma SubK x Px : @val sT (Sub x Px) = x. +Proof. by case: sT. Qed. + +Definition insub x := + if @idP (P x) is ReflectT Px then @Some sT (Sub x Px) else None. + +Definition insubd u0 x := odflt u0 (insub x). + +CoInductive insub_spec x : option sT -> Type := + | InsubSome u of P x & val u = x : insub_spec x (Some u) + | InsubNone of ~~ P x : insub_spec x None. + +Lemma insubP x : insub_spec x (insub x). +Proof. +by rewrite /insub; case: {-}_ / idP; [left; rewrite ?SubK | right; exact/negP]. +Qed. + +Lemma insubT x Px : insub x = Some (Sub x Px). +Proof. +case: insubP; last by case/negP. +case/SubP=> y Py _ def_x; rewrite -def_x SubK in Px *. +congr (Some (Sub _ _)); exact: bool_irrelevance. +Qed. + +Lemma insubF x : P x = false -> insub x = None. +Proof. by move/idP; case: insubP. Qed. + +Lemma insubN x : ~~ P x -> insub x = None. +Proof. by move/negPf/insubF. Qed. + +Lemma isSome_insub : ([eta insub] : pred T) =1 P. +Proof. by apply: fsym => x; case: insubP => // /negPf. Qed. + +Lemma insubK : ocancel insub (@val _). +Proof. by move=> x; case: insubP. Qed. + +Lemma valP (u : sT) : P (val u). +Proof. by case/SubP: u => x Px; rewrite SubK. Qed. + +Lemma valK : pcancel (@val _) insub. +Proof. case/SubP=> x Px; rewrite SubK; exact: insubT. Qed. + +Lemma val_inj : injective (@val sT). +Proof. exact: pcan_inj valK. Qed. + +Lemma valKd u0 : cancel (@val _) (insubd u0). +Proof. by move=> u; rewrite /insubd valK. Qed. + +Lemma val_insubd u0 x : val (insubd u0 x) = if P x then x else val u0. +Proof. by rewrite /insubd; case: insubP => [u -> | /negPf->]. Qed. + +Lemma insubdK u0 : {in P, cancel (insubd u0) (@val _)}. +Proof. by move=> x Px; rewrite /= val_insubd [P x]Px. Qed. + +Definition insub_eq x := + let Some_sub Px := Some (Sub x Px : sT) in + let None_sub _ := None in + (if P x as Px return P x = Px -> _ then Some_sub else None_sub) (erefl _). + +Lemma insub_eqE : insub_eq =1 insub. +Proof. +rewrite /insub_eq /insub => x; case: {2 3}_ / idP (erefl _) => // Px Px'. +by congr (Some _); apply: val_inj; rewrite !SubK. +Qed. + +End SubType. + +Implicit Arguments SubType [T P]. +Implicit Arguments Sub [T P s]. +Implicit Arguments vrefl [T P]. +Implicit Arguments vrefl_rect [T P]. +Implicit Arguments clone_subType [T P sT c Urec cK]. +Implicit Arguments insub [T P sT]. +Implicit Arguments insubT [T sT x]. +Implicit Arguments val_inj [T P sT]. +Prenex Implicits val Sub vrefl vrefl_rect insub insubd val_inj. + +Local Notation inlined_sub_rect := + (fun K K_S u => let (x, Px) as u return K u := u in K_S x Px). + +Local Notation inlined_new_rect := + (fun K K_S u => let (x) as u return K u := u in K_S x). + +Notation "[ 'subType' 'for' v ]" := (SubType _ v _ inlined_sub_rect vrefl_rect) + (at level 0, only parsing) : form_scope. + +Notation "[ 'sub' 'Type' 'for' v ]" := (SubType _ v _ _ vrefl_rect) + (at level 0, format "[ 'sub' 'Type' 'for' v ]") : form_scope. + +Notation "[ 'subType' 'for' v 'by' rec ]" := (SubType _ v _ rec vrefl) + (at level 0, format "[ 'subType' 'for' v 'by' rec ]") : form_scope. + +Notation "[ 'subType' 'of' U 'for' v ]" := (clone_subType U v id idfun) + (at level 0, format "[ 'subType' 'of' U 'for' v ]") : form_scope. + +(* +Notation "[ 'subType' 'for' v ]" := (clone_subType _ v id idfun) + (at level 0, format "[ 'subType' 'for' v ]") : form_scope. +*) +Notation "[ 'subType' 'of' U ]" := (clone_subType U _ id id) + (at level 0, format "[ 'subType' 'of' U ]") : form_scope. + +Definition NewType T U v c Urec := + let Urec' P IH := Urec P (fun x : T => IH x isT : P _) in + SubType U v (fun x _ => c x) Urec'. +Implicit Arguments NewType [T U]. + +Notation "[ 'newType' 'for' v ]" := (NewType v _ inlined_new_rect vrefl_rect) + (at level 0, only parsing) : form_scope. + +Notation "[ 'new' 'Type' 'for' v ]" := (NewType v _ _ vrefl_rect) + (at level 0, format "[ 'new' 'Type' 'for' v ]") : form_scope. + +Notation "[ 'newType' 'for' v 'by' rec ]" := (NewType v _ rec vrefl) + (at level 0, format "[ 'newType' 'for' v 'by' rec ]") : form_scope. + +Definition innew T nT x := @Sub T predT nT x (erefl true). +Implicit Arguments innew [T nT]. +Prenex Implicits innew. + +Lemma innew_val T nT : cancel val (@innew T nT). +Proof. by move=> u; apply: val_inj; exact: SubK. Qed. + +(* Prenex Implicits and renaming. *) +Notation sval := (@proj1_sig _ _). +Notation "@ 'sval'" := (@proj1_sig) (at level 10, format "@ 'sval'"). + +Section SigProj. + +Variables (T : Type) (P Q : T -> Prop). + +Lemma svalP : forall u : sig P, P (sval u). Proof. by case. Qed. + +Definition s2val (u : sig2 P Q) := let: exist2 x _ _ := u in x. + +Lemma s2valP u : P (s2val u). Proof. by case: u. Qed. + +Lemma s2valP' u : Q (s2val u). Proof. by case: u. Qed. + +End SigProj. + +Prenex Implicits svalP s2val s2valP s2valP'. + +Canonical sig_subType T (P : pred T) : subType [eta P] := + Eval hnf in [subType for @sval T [eta [eta P]]]. + +(* Shorthand for sigma types over collective predicates. *) +Notation "{ x 'in' A }" := {x | x \in A} + (at level 0, x at level 99, format "{ x 'in' A }") : type_scope. +Notation "{ x 'in' A | P }" := {x | (x \in A) && P} + (at level 0, x at level 99, format "{ x 'in' A | P }") : type_scope. + +(* Shorthand for the return type of insub. *) +Notation "{ ? x : T | P }" := (option {x : T | is_true P}) + (at level 0, x at level 99, only parsing) : type_scope. +Notation "{ ? x | P }" := {? x : _ | P} + (at level 0, x at level 99, format "{ ? x | P }") : type_scope. +Notation "{ ? x 'in' A }" := {? x | x \in A} + (at level 0, x at level 99, format "{ ? x 'in' A }") : type_scope. +Notation "{ ? x 'in' A | P }" := {? x | (x \in A) && P} + (at level 0, x at level 99, format "{ ? x 'in' A | P }") : type_scope. + +(* A variant of injection with default that infers a collective predicate *) +(* from the membership proof for the default value. *) +Definition insigd T (A : mem_pred T) x (Ax : in_mem x A) := + insubd (exist [eta A] x Ax). + +(* There should be a rel definition for the subType equality op, but this *) +(* seems to cause the simpl tactic to diverge on expressions involving == *) +(* on 4+ nested subTypes in a "strict" position (e.g., after ~~). *) +(* Definition feq f := [rel x y | f x == f y]. *) + +Section TransferEqType. + +Variables (T : Type) (eT : eqType) (f : T -> eT). + +Lemma inj_eqAxiom : injective f -> Equality.axiom (fun x y => f x == f y). +Proof. by move=> f_inj x y; apply: (iffP eqP) => [|-> //]; exact: f_inj. Qed. + +Definition InjEqMixin f_inj := EqMixin (inj_eqAxiom f_inj). + +Definition PcanEqMixin g (fK : pcancel f g) := InjEqMixin (pcan_inj fK). + +Definition CanEqMixin g (fK : cancel f g) := InjEqMixin (can_inj fK). + +End TransferEqType. + +Section SubEqType. + +Variables (T : eqType) (P : pred T) (sT : subType P). + +Notation Local ev_ax := (fun T v => @Equality.axiom T (fun x y => v x == v y)). +Lemma val_eqP : ev_ax sT val. Proof. exact: inj_eqAxiom val_inj. Qed. + +Definition sub_eqMixin := EqMixin val_eqP. +Canonical sub_eqType := Eval hnf in EqType sT sub_eqMixin. + +Definition SubEqMixin := + (let: SubType _ v _ _ _ as sT' := sT + return ev_ax sT' val -> Equality.class_of sT' in + fun vP : ev_ax _ v => EqMixin vP + ) val_eqP. + +Lemma val_eqE (u v : sT) : (val u == val v) = (u == v). +Proof. by []. Qed. + +End SubEqType. + +Implicit Arguments val_eqP [T P sT x y]. +Prenex Implicits val_eqP. + +Notation "[ 'eqMixin' 'of' T 'by' <: ]" := (SubEqMixin _ : Equality.class_of T) + (at level 0, format "[ 'eqMixin' 'of' T 'by' <: ]") : form_scope. + +Section SigEqType. + +Variables (T : eqType) (P : pred T). + +Definition sig_eqMixin := Eval hnf in [eqMixin of {x | P x} by <:]. +Canonical sig_eqType := Eval hnf in EqType {x | P x} sig_eqMixin. + +End SigEqType. + +Section ProdEqType. + +Variable T1 T2 : eqType. + +Definition pair_eq := [rel u v : T1 * T2 | (u.1 == v.1) && (u.2 == v.2)]. + +Lemma pair_eqP : Equality.axiom pair_eq. +Proof. +move=> [x1 x2] [y1 y2] /=; apply: (iffP andP) => [[]|[<- <-]] //=. +by do 2!move/eqP->. +Qed. + +Definition prod_eqMixin := EqMixin pair_eqP. +Canonical prod_eqType := Eval hnf in EqType (T1 * T2) prod_eqMixin. + +Lemma pair_eqE : pair_eq = eq_op :> rel _. Proof. by []. Qed. + +Lemma xpair_eqE (x1 y1 : T1) (x2 y2 : T2) : + ((x1, x2) == (y1, y2)) = ((x1 == y1) && (x2 == y2)). +Proof. by []. Qed. + +Lemma pair_eq1 (u v : T1 * T2) : u == v -> u.1 == v.1. +Proof. by case/andP. Qed. + +Lemma pair_eq2 (u v : T1 * T2) : u == v -> u.2 == v.2. +Proof. by case/andP. Qed. + +End ProdEqType. + +Implicit Arguments pair_eqP [T1 T2]. + +Prenex Implicits pair_eqP. + +Definition predX T1 T2 (p1 : pred T1) (p2 : pred T2) := + [pred z | p1 z.1 & p2 z.2]. + +Notation "[ 'predX' A1 & A2 ]" := (predX [mem A1] [mem A2]) + (at level 0, format "[ 'predX' A1 & A2 ]") : fun_scope. + +Section OptionEqType. + +Variable T : eqType. + +Definition opt_eq (u v : option T) : bool := + oapp (fun x => oapp (eq_op x) false v) (~~ v) u. + +Lemma opt_eqP : Equality.axiom opt_eq. +Proof. +case=> [x|] [y|] /=; by [constructor | apply: (iffP eqP) => [|[]] ->]. +Qed. + +Canonical option_eqMixin := EqMixin opt_eqP. +Canonical option_eqType := Eval hnf in EqType (option T) option_eqMixin. + +End OptionEqType. + +Definition tag := projS1. +Definition tagged I T_ : forall u, T_(tag u) := @projS2 I [eta T_]. +Definition Tagged I i T_ x := @existS I [eta T_] i x. +Implicit Arguments Tagged [I i]. +Prenex Implicits tag tagged Tagged. + +Section TaggedAs. + +Variables (I : eqType) (T_ : I -> Type). +Implicit Types u v : {i : I & T_ i}. + +Definition tagged_as u v := + if tag u =P tag v is ReflectT eq_uv then + eq_rect_r T_ (tagged v) eq_uv + else tagged u. + +Lemma tagged_asE u x : tagged_as u (Tagged T_ x) = x. +Proof. +by rewrite /tagged_as /=; case: eqP => // eq_uu; rewrite [eq_uu]eq_axiomK. +Qed. + +End TaggedAs. + +Section TagEqType. + +Variables (I : eqType) (T_ : I -> eqType). +Implicit Types u v : {i : I & T_ i}. + +Definition tag_eq u v := (tag u == tag v) && (tagged u == tagged_as u v). + +Lemma tag_eqP : Equality.axiom tag_eq. +Proof. +rewrite /tag_eq => [] [i x] [j] /=. +case: eqP => [<-|Hij] y; last by right; case. +by apply: (iffP eqP) => [->|<-]; rewrite tagged_asE. +Qed. + +Canonical tag_eqMixin := EqMixin tag_eqP. +Canonical tag_eqType := Eval hnf in EqType {i : I & T_ i} tag_eqMixin. + +Lemma tag_eqE : tag_eq = eq_op. Proof. by []. Qed. + +Lemma eq_tag u v : u == v -> tag u = tag v. +Proof. by move/eqP->. Qed. + +Lemma eq_Tagged u x :(u == Tagged _ x) = (tagged u == x). +Proof. by rewrite -tag_eqE /tag_eq eqxx tagged_asE. Qed. + +End TagEqType. + +Implicit Arguments tag_eqP [I T_ x y]. +Prenex Implicits tag_eqP. + +Section SumEqType. + +Variables T1 T2 : eqType. +Implicit Types u v : T1 + T2. + +Definition sum_eq u v := + match u, v with + | inl x, inl y | inr x, inr y => x == y + | _, _ => false + end. + +Lemma sum_eqP : Equality.axiom sum_eq. +Proof. case=> x [] y /=; by [right | apply: (iffP eqP) => [->|[->]]]. Qed. + +Canonical sum_eqMixin := EqMixin sum_eqP. +Canonical sum_eqType := Eval hnf in EqType (T1 + T2) sum_eqMixin. + +Lemma sum_eqE : sum_eq = eq_op. Proof. by []. Qed. + +End SumEqType. + +Implicit Arguments sum_eqP [T1 T2 x y]. +Prenex Implicits sum_eqP. diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 new file mode 100644 index 0000000..931570d --- /dev/null +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.ml4 @@ -0,0 +1,6138 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) + +(* This line is read by the Makefile's dist target: do not remove. *) +DECLARE PLUGIN "ssreflect" +let ssrversion = "1.5";; +let ssrAstVersion = 1;; +let () = Mltop.add_known_plugin (fun () -> + if Flags.is_verbose () && not !Flags.batch_mode then begin + Printf.printf "\nSmall Scale Reflection version %s loaded.\n" ssrversion; + Printf.printf "Copyright 2005-2014 Microsoft Corporation and INRIA.\n"; + Printf.printf "Distributed under the terms of the CeCILL-B license.\n\n" + end; + (* Disable any semantics associated with bullets *) + Goptions.set_string_option_value_gen + (Some false) ["Bullet";"Behavior"] "None") + "ssreflect" +;; + +(* Defining grammar rules with "xx" in it automatically declares keywords too, + * we thus save the lexer to restore it at the end of the file *) +let frozen_lexer = Lexer.freeze () ;; + +(*i camlp4use: "pa_extend.cmo" i*) +(*i camlp4deps: "grammar/grammar.cma" i*) + +open Names +open Pp +open Pcoq +open Genarg +open Stdarg +open Constrarg +open Term +open Vars +open Context +open Topconstr +open Libnames +open Tactics +open Tacticals +open Termops +open Namegen +open Recordops +open Tacmach +open Coqlib +open Glob_term +open Util +open Evd +open Extend +open Goptions +open Tacexpr +open Tacinterp +open Pretyping +open Constr +open Tactic +open Extraargs +open Ppconstr +open Printer + +open Globnames +open Misctypes +open Decl_kinds +open Evar_kinds +open Constrexpr +open Constrexpr_ops +open Notation_term +open Notation_ops +open Locus +open Locusops + +open Ssrmatching + + +(* Tentative patch from util.ml *) + +let array_fold_right_from n f v a = + let rec fold n = + if n >= Array.length v then a else f v.(n) (fold (succ n)) + in + fold n + +let array_app_tl v l = + if Array.length v = 0 then invalid_arg "array_app_tl"; + array_fold_right_from 1 (fun e l -> e::l) v l + +let array_list_of_tl v = + if Array.length v = 0 then invalid_arg "array_list_of_tl"; + array_fold_right_from 1 (fun e l -> e::l) v [] + +(* end patch *) + +module Intset = Evar.Set + +type loc = Loc.t +let dummy_loc = Loc.ghost +let errorstrm = Errors.errorlabstrm "ssreflect" +let loc_error loc msg = Errors.user_err_loc (loc, msg, str msg) +let anomaly s = Errors.anomaly (str s) + +(** look up a name in the ssreflect internals module *) +let ssrdirpath = make_dirpath [id_of_string "ssreflect"] +let ssrqid name = make_qualid ssrdirpath (id_of_string name) +let ssrtopqid name = make_short_qualid (id_of_string name) +let locate_reference qid = + Smartlocate.global_of_extended_global (Nametab.locate_extended qid) +let mkSsrRef name = + try locate_reference (ssrqid name) with Not_found -> + try locate_reference (ssrtopqid name) with Not_found -> + Errors.error "Small scale reflection library not loaded" +let mkSsrRRef name = GRef (dummy_loc, mkSsrRef name,None), None +let mkSsrConst name env sigma = + Evd.fresh_global env sigma (mkSsrRef name) +let pf_mkSsrConst name gl = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma, t = mkSsrConst name env sigma in + t, re_sig it sigma +let pf_fresh_global name gl = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma,t = Evd.fresh_global env sigma name in + t, re_sig it sigma + +(** Ssreflect load check. *) + +(* To allow ssrcoq to be fully compatible with the "plain" Coq, we only *) +(* turn on its incompatible features (the new rewrite syntax, and the *) +(* reserved identifiers) when the theory library (ssreflect.v) has *) +(* has actually been required, or is being defined. Because this check *) +(* needs to be done often (for each identifier lookup), we implement *) +(* some caching, repeating the test only when the environment changes. *) +(* We check for protect_term because it is the first constant loaded; *) +(* ssr_have would ultimately be a better choice. *) +let ssr_loaded = Summary.ref ~name:"SSR:loaded" false +let is_ssr_loaded () = + !ssr_loaded || + (if Lexer.is_keyword "SsrSyntax_is_Imported" then ssr_loaded:=true; + !ssr_loaded) + +(* 0 cost pp function. Active only if env variable SSRDEBUG is set *) +(* or if SsrDebug is Set *) +let pp_ref = ref (fun _ -> ()) +let ssr_pp s = pperrnl (str"SSR: "++Lazy.force s) +let _ = try ignore(Sys.getenv "SSRDEBUG"); pp_ref := ssr_pp with Not_found -> () +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssreflect debugging"; + Goptions.optkey = ["SsrDebug"]; + Goptions.optdepr = false; + Goptions.optread = (fun _ -> !pp_ref == ssr_pp); + Goptions.optwrite = (fun b -> + Ssrmatching.debug b; + if b then pp_ref := ssr_pp else pp_ref := fun _ -> ()) } +let pp s = !pp_ref s + +(** Utils {{{ *****************************************************************) +let env_size env = List.length (Environ.named_context env) +let safeDestApp c = + match kind_of_term c with App (f, a) -> f, a | _ -> c, [| |] +let get_index = function ArgArg i -> i | _ -> + anomaly "Uninterpreted index" +(* Toplevel constr must be globalized twice ! *) +let glob_constr ist genv = function + | _, Some ce -> + let vars = Id.Map.fold (fun x _ accu -> Id.Set.add x accu) ist.lfun Id.Set.empty in + let ltacvars = { + Constrintern.empty_ltac_sign with Constrintern.ltac_vars = vars } in + Constrintern.intern_gen WithoutTypeConstraint ~ltacvars genv ce + | rc, None -> rc + +(* Term printing utilities functions for deciding bracketing. *) +let pr_paren prx x = hov 1 (str "(" ++ prx x ++ str ")") +(* String lexing utilities *) +let skip_wschars s = + let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop +let skip_numchars s = + let rec loop i = match s.[i] with '0'..'9' -> loop (i + 1) | _ -> i in loop +(* We also guard characters that might interfere with the ssreflect *) +(* tactic syntax. *) +let guard_term ch1 s i = match s.[i] with + | '(' -> false + | '{' | '/' | '=' -> true + | _ -> ch1 = '(' +(* The call 'guard s i' should return true if the contents of s *) +(* starting at i need bracketing to avoid ambiguities. *) +let pr_guarded guard prc c = + msg_with Format.str_formatter (prc c); + let s = Format.flush_str_formatter () ^ "$" in + if guard s (skip_wschars s 0) then pr_paren prc c else prc c +(* More sensible names for constr printers *) +let prl_constr = pr_lconstr +let pr_constr = pr_constr +let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c +let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c +let prl_constr_expr = pr_lconstr_expr +let pr_constr_expr = pr_constr_expr +let prl_glob_constr_and_expr = function + | _, Some c -> prl_constr_expr c + | c, None -> prl_glob_constr c +let pr_glob_constr_and_expr = function + | _, Some c -> pr_constr_expr c + | c, None -> pr_glob_constr c +let pr_term (k, c) = pr_guarded (guard_term k) pr_glob_constr_and_expr c +let prl_term (k, c) = pr_guarded (guard_term k) prl_glob_constr_and_expr c + +(** Adding a new uninterpreted generic argument type *) +let add_genarg tag pr = + let wit = Genarg.make0 None tag in + let glob ist x = (ist, x) in + let subst _ x = x in + let interp ist gl x = (gl.Evd.sigma, x) in + let gen_pr _ _ _ = pr in + let () = Genintern.register_intern0 wit glob in + let () = Genintern.register_subst0 wit subst in + let () = Geninterp.register_interp0 wit interp in + Pptactic.declare_extra_genarg_pprule wit gen_pr gen_pr gen_pr; + wit + +(** Constructors for cast type *) +let dC t = CastConv t + +(** Constructors for constr_expr *) +let mkCProp loc = CSort (loc, GProp) +let mkCType loc = CSort (loc, GType []) +let mkCVar loc id = CRef (Ident (loc, id),None) +let isCVar = function CRef (Ident _,_) -> true | _ -> false +let destCVar = function CRef (Ident (_, id),_) -> id | _ -> + anomaly "not a CRef" +let rec mkCHoles loc n = + if n <= 0 then [] else CHole (loc, None, IntroAnonymous, None) :: mkCHoles loc (n - 1) +let mkCHole loc = CHole (loc, None, IntroAnonymous, None) +let rec isCHoles = function CHole _ :: cl -> isCHoles cl | cl -> cl = [] +let mkCExplVar loc id n = + CAppExpl (loc, (None, Ident (loc, id), None), mkCHoles loc n) +let mkCLambda loc name ty t = + CLambdaN (loc, [[loc, name], Default Explicit, ty], t) +let mkCLetIn loc name bo t = + CLetIn (loc, (loc, name), bo, t) +let mkCArrow loc ty t = + CProdN (loc, [[dummy_loc,Anonymous], Default Explicit, ty], t) +let mkCCast loc t ty = CCast (loc,t, dC ty) +(** Constructors for rawconstr *) +let mkRHole = GHole (dummy_loc, InternalHole, IntroAnonymous, None) +let rec mkRHoles n = if n > 0 then mkRHole :: mkRHoles (n - 1) else [] +let rec isRHoles = function GHole _ :: cl -> isRHoles cl | cl -> cl = [] +let mkRApp f args = if args = [] then f else GApp (dummy_loc, f, args) +let mkRVar id = GRef (dummy_loc, VarRef id,None) +let mkRltacVar id = GVar (dummy_loc, id) +let mkRCast rc rt = GCast (dummy_loc, rc, dC rt) +let mkRType = GSort (dummy_loc, GType []) +let mkRProp = GSort (dummy_loc, GProp) +let mkRArrow rt1 rt2 = GProd (dummy_loc, Anonymous, Explicit, rt1, rt2) +let mkRConstruct c = GRef (dummy_loc, ConstructRef c,None) +let mkRInd mind = GRef (dummy_loc, IndRef mind,None) +let mkRLambda n s t = GLambda (dummy_loc, n, Explicit, s, t) + +(** Constructors for constr *) +let pf_e_type_of gl t = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma, ty = Typing.e_type_of env sigma t in + re_sig it sigma, ty + +let mkAppRed f c = match kind_of_term f with +| Lambda (_, _, b) -> subst1 c b +| _ -> mkApp (f, [|c|]) + +let mkProt t c gl = + let prot, gl = pf_mkSsrConst "protect_term" gl in + mkApp (prot, [|t; c|]), gl + +let mkRefl t c gl = + let refl, gl = pf_fresh_global (build_coq_eq_data()).refl gl in + mkApp (refl, [|t; c|]), gl + + +(* Application to a sequence of n rels (for building eta-expansions). *) +(* The rel indices decrease down to imin (inclusive), unless n < 0, *) +(* in which case they're incresing (from imin). *) +let mkEtaApp c n imin = + if n = 0 then c else + let nargs, mkarg = + if n < 0 then -n, (fun i -> mkRel (imin + i)) else + let imax = imin + n - 1 in n, (fun i -> mkRel (imax - i)) in + mkApp (c, Array.init nargs mkarg) +(* Same, but optimizing head beta redexes *) +let rec whdEtaApp c n = + if n = 0 then c else match kind_of_term c with + | Lambda (_, _, c') -> whdEtaApp c' (n - 1) + | _ -> mkEtaApp (lift n c) n 1 +let mkType () = Universes.new_Type (Lib.cwd ()) + +(* ssrterm conbinators *) +let combineCG t1 t2 f g = match t1, t2 with + | (x, (t1, None)), (_, (t2, None)) -> x, (g t1 t2, None) + | (x, (_, Some t1)), (_, (_, Some t2)) -> x, (mkRHole, Some (f t1 t2)) + | _, (_, (_, None)) -> anomaly "have: mixed C-G constr" + | _ -> anomaly "have: mixed G-C constr" +let loc_ofCG = function + | (_, (s, None)) -> Glob_ops.loc_of_glob_constr s + | (_, (_, Some s)) -> Constrexpr_ops.constr_loc s + +let mk_term k c = k, (mkRHole, Some c) +let mk_lterm c = mk_term ' ' c + +let map_fold_constr g f ctx acc cstr = + let array_f ctx acc x = let x, acc = f ctx acc x in acc, x in + match kind_of_term cstr with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> + cstr, acc + | Proj (x,c) -> + let c', acc = f ctx acc c in + (if c == c' then cstr else mkProj (x,c')), acc + | Cast (c,k, t) -> + let c', acc = f ctx acc c in + let t', acc = f ctx acc t in + (if c==c' && t==t' then cstr else mkCast (c', k, t')), acc + | Prod (na,t,c) -> + let t', acc = f ctx acc t in + let c', acc = f (g (na,None,t) ctx) acc c in + (if t==t' && c==c' then cstr else mkProd (na, t', c')), acc + | Lambda (na,t,c) -> + let t', acc = f ctx acc t in + let c', acc = f (g (na,None,t) ctx) acc c in + (if t==t' && c==c' then cstr else mkLambda (na, t', c')), acc + | LetIn (na,b,t,c) -> + let b', acc = f ctx acc b in + let t', acc = f ctx acc t in + let c', acc = f (g (na,Some b,t) ctx) acc c in + (if b==b' && t==t' && c==c' then cstr else mkLetIn (na, b', t', c')), acc + | App (c,al) -> + let c', acc = f ctx acc c in + let acc, al' = CArray.smartfoldmap (array_f ctx) acc al in + (if c==c' && Array.for_all2 (==) al al' then cstr else mkApp (c', al')), + acc + | Evar (e,al) -> + let acc, al' = CArray.smartfoldmap (array_f ctx) acc al in + (if Array.for_all2 (==) al al' then cstr else mkEvar (e, al')), acc + | Case (ci,p,c,bl) -> + let p', acc = f ctx acc p in + let c', acc = f ctx acc c in + let acc, bl' = CArray.smartfoldmap (array_f ctx) acc bl in + (if p==p' && c==c' && Array.for_all2 (==) bl bl' then cstr else + mkCase (ci, p', c', bl')), + acc + | Fix (ln,(lna,tl,bl)) -> + let acc, tl' = CArray.smartfoldmap (array_f ctx) acc tl in + let ctx' = Array.fold_left2 (fun l na t -> g (na,None,t) l) ctx lna tl in + let acc, bl' = CArray.smartfoldmap (array_f ctx') acc bl in + (if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' + then cstr + else mkFix (ln,(lna,tl',bl'))), acc + | CoFix(ln,(lna,tl,bl)) -> + let acc, tl' = CArray.smartfoldmap (array_f ctx) acc tl in + let ctx' = Array.fold_left2 (fun l na t -> g (na,None,t) l) ctx lna tl in + let acc,bl' = CArray.smartfoldmap (array_f ctx') acc bl in + (if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' + then cstr + else mkCoFix (ln,(lna,tl',bl'))), acc + +let pf_merge_uc_of sigma gl = + let ucst = Evd.evar_universe_context sigma in + pf_merge_uc ucst gl + +(* }}} *) + +(** Profiling {{{ *************************************************************) +type profiler = { + profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; + reset : unit -> unit; + print : unit -> unit } +let profile_now = ref false +let something_profiled = ref false +let profilers = ref [] +let add_profiler f = profilers := f :: !profilers;; +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssreflect profiling"; + Goptions.optkey = ["SsrProfiling"]; + Goptions.optread = (fun _ -> !profile_now); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> + Ssrmatching.profile b; + profile_now := b; + if b then List.iter (fun f -> f.reset ()) !profilers; + if not b then List.iter (fun f -> f.print ()) !profilers) } +let () = + let prof_total = + let init = ref 0.0 in { + profile = (fun f x -> assert false); + reset = (fun () -> init := Unix.gettimeofday ()); + print = (fun () -> if !something_profiled then + prerr_endline + (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" + "total" 0 (Unix.gettimeofday() -. !init) 0.0 0.0)) } in + let prof_legenda = { + profile = (fun f x -> assert false); + reset = (fun () -> ()); + print = (fun () -> if !something_profiled then begin + prerr_endline + (Printf.sprintf "!! %39s ---------- --------- --------- ---------" + (String.make 39 '-')); + prerr_endline + (Printf.sprintf "!! %-39s %10s %9s %9s %9s" + "function" "#calls" "total" "max" "average") end) } in + add_profiler prof_legenda; + add_profiler prof_total +;; + +let mk_profiler s = + let total, calls, max = ref 0.0, ref 0, ref 0.0 in + let reset () = total := 0.0; calls := 0; max := 0.0 in + let profile f x = + if not !profile_now then f x else + let before = Unix.gettimeofday () in + try + incr calls; + let res = f x in + let after = Unix.gettimeofday () in + let delta = after -. before in + total := !total +. delta; + if delta > !max then max := delta; + res + with exc -> + let after = Unix.gettimeofday () in + let delta = after -. before in + total := !total +. delta; + if delta > !max then max := delta; + raise exc in + let print () = + if !calls <> 0 then begin + something_profiled := true; + prerr_endline + (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" + s !calls !total !max (!total /. (float_of_int !calls))) end in + let prof = { profile = profile; reset = reset; print = print } in + add_profiler prof; + prof +;; +(* }}} *) + +let inVersion = Libobject.declare_object { + (Libobject.default_object "SSRASTVERSION") with + Libobject.load_function = (fun _ (_,v) -> + if v <> ssrAstVersion then Errors.error "Please recompile your .vo files"); + Libobject.classify_function = (fun v -> Libobject.Keep v); +} + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssreflect version"; + Goptions.optkey = ["SsrAstVersion"]; + Goptions.optread = (fun _ -> true); + Goptions.optdepr = false; + Goptions.optwrite = (fun _ -> + Lib.add_anonymous_leaf (inVersion ssrAstVersion)) } + +let tactic_expr = Tactic.tactic_expr +let gallina_ext = Vernac_.gallina_ext +let sprintf = Printf.sprintf +let tactic_mode = G_vernac.tactic_mode + +(** 1. Utilities *) + + +let ssroldreworder = Summary.ref ~name:"SSR:oldreworder" true +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssreflect 1.3 compatibility flag"; + Goptions.optkey = ["SsrOldRewriteGoalsOrder"]; + Goptions.optread = (fun _ -> !ssroldreworder); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> ssroldreworder := b) } + +let ssrhaveNOtcresolution = ref false + +let inHaveTCResolution = Libobject.declare_object { + (Libobject.default_object "SSRHAVETCRESOLUTION") with + Libobject.cache_function = (fun (_,v) -> ssrhaveNOtcresolution := v); + Libobject.load_function = (fun _ (_,v) -> ssrhaveNOtcresolution := v); + Libobject.classify_function = (fun v -> Libobject.Keep v); +} + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "have type classes"; + Goptions.optkey = ["SsrHave";"NoTCResolution"]; + Goptions.optread = (fun _ -> !ssrhaveNOtcresolution); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> + Lib.add_anonymous_leaf (inHaveTCResolution b)) } + + +(** Primitive parsing to avoid syntax conflicts with basic tactics. *) + +let accept_before_syms syms strm = + match Compat.get_tok (stream_nth 1 strm) with + | Tok.KEYWORD sym when List.mem sym syms -> () + | _ -> raise Stream.Failure + +let accept_before_syms_or_any_id syms strm = + match Compat.get_tok (stream_nth 1 strm) with + | Tok.KEYWORD sym when List.mem sym syms -> () + | Tok.IDENT _ -> () + | _ -> raise Stream.Failure + +let accept_before_syms_or_ids syms ids strm = + match Compat.get_tok (stream_nth 1 strm) with + | Tok.KEYWORD sym when List.mem sym syms -> () + | Tok.IDENT id when List.mem id ids -> () + | _ -> raise Stream.Failure + +(** Pretty-printing utilities *) + +let pr_id = Ppconstr.pr_id +let pr_name = function Name id -> pr_id id | Anonymous -> str "_" +let pr_spc () = str " " +let pr_bar () = Pp.cut() ++ str "|" +let pr_list = prlist_with_sep + +let tacltop = (5,Ppextend.E) + +(** Tactic-level diagnosis *) + +let pf_pr_constr gl = pr_constr_env (pf_env gl) + +let pf_pr_glob_constr gl = pr_glob_constr_env (pf_env gl) + +(* debug *) + +let pf_msg gl = + let ppgl = pr_lconstr_env (pf_env gl) (project gl) (pf_concl gl) in + msgnl (str "goal is " ++ ppgl) + +let msgtac gl = pf_msg gl; tclIDTAC gl + +(** Tactic utilities *) + +let last_goal gls = let sigma, gll = Refiner.unpackage gls in + Refiner.repackage sigma (List.nth gll (List.length gll - 1)) + +let pf_type_id gl t = id_of_string (hdchar (pf_env gl) t) + +let not_section_id id = not (is_section_variable id) + +let is_pf_var c = isVar c && not_section_id (destVar c) + +let pf_ids_of_proof_hyps gl = + let add_hyp (id, _, _) ids = if not_section_id id then id :: ids else ids in + Context.fold_named_context add_hyp (pf_hyps gl) ~init:[] + +let pf_nf_evar gl e = Reductionops.nf_evar (project gl) e + +let pf_partial_solution gl t evl = + let sigma, g = project gl, sig_it gl in + let sigma = Goal.V82.partial_solution sigma g t in + re_sig (List.map (fun x -> (fst (destEvar x))) evl) sigma + +let pf_new_evar gl ty = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma, extra = Evarutil.new_evar env sigma ty in + re_sig it sigma, extra + +(* Basic tactics *) + +let convert_concl_no_check t = convert_concl_no_check t DEFAULTcast +let convert_concl t = convert_concl t DEFAULTcast +let reduct_in_concl t = reduct_in_concl (t, DEFAULTcast) +let havetac id c = Proofview.V82.of_tactic (pose_proof (Name id) c) +let settac id c = letin_tac None (Name id) c None +let posetac id cl = Proofview.V82.of_tactic (settac id cl nowhere) +let basecuttac name c gl = + let hd, gl = pf_mkSsrConst name gl in + let t = mkApp (hd, [|c|]) in + let gl, _ = pf_e_type_of gl t in + Proofview.V82.of_tactic (apply t) gl + +(* we reduce head beta redexes *) +let betared env = + Closure.create_clos_infos + (Closure.RedFlags.mkflags [Closure.RedFlags.fBETA]) + env +;; +let introid name = tclTHEN (fun gl -> + let g, env = pf_concl gl, pf_env gl in + match kind_of_term g with + | App (hd, _) when isLambda hd -> + let g = Closure.whd_val (betared env) (Closure.inject g) in + Proofview.V82.of_tactic (convert_concl_no_check g) gl + | _ -> tclIDTAC gl) + (Proofview.V82.of_tactic (intro_mustbe_force name)) +;; + + +(** Name generation {{{ *******************************************************) + +(* Since Coq now does repeated internal checks of its external lexical *) +(* rules, we now need to carve ssreflect reserved identifiers out of *) +(* out of the user namespace. We use identifiers of the form _id_ for *) +(* this purpose, e.g., we "anonymize" an identifier id as _id_, adding *) +(* an extra leading _ if this might clash with an internal identifier. *) +(* We check for ssreflect identifiers in the ident grammar rule; *) +(* when the ssreflect Module is present this is normally an error, *) +(* but we provide a compatibility flag to reduce this to a warning. *) + +let ssr_reserved_ids = Summary.ref ~name:"SSR:idents" true + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optname = "ssreflect identifiers"; + Goptions.optkey = ["SsrIdents"]; + Goptions.optdepr = false; + Goptions.optread = (fun _ -> !ssr_reserved_ids); + Goptions.optwrite = (fun b -> ssr_reserved_ids := b) + } + +let is_ssr_reserved s = + let n = String.length s in n > 2 && s.[0] = '_' && s.[n - 1] = '_' + +let internal_names = ref [] +let add_internal_name pt = internal_names := pt :: !internal_names +let is_internal_name s = List.exists (fun p -> p s) !internal_names + +let ssr_id_of_string loc s = + if is_ssr_reserved s && is_ssr_loaded () then begin + if !ssr_reserved_ids then + loc_error loc ("The identifier " ^ s ^ " is reserved.") + else if is_internal_name s then + msg_warning (str ("Conflict between " ^ s ^ " and ssreflect internal names.")) + else msg_warning (str ( + "The name " ^ s ^ " fits the _xxx_ format used for anonymous variables.\n" + ^ "Scripts with explicit references to anonymous variables are fragile.")) + end; id_of_string s + +let ssr_null_entry = Gram.Entry.of_parser "ssr_null" (fun _ -> ()) + +let (!@) = Compat.to_coqloc + +GEXTEND Gram + GLOBAL: Prim.ident; + Prim.ident: [[ s = IDENT; ssr_null_entry -> ssr_id_of_string !@loc s ]]; +END + +let mk_internal_id s = + let s' = sprintf "_%s_" s in + for i = 1 to String.length s do if s'.[i] = ' ' then s'.[i] <- '_' done; + add_internal_name ((=) s'); id_of_string s' + +let same_prefix s t n = + let rec loop i = i = n || s.[i] = t.[i] && loop (i + 1) in loop 0 + +let skip_digits s = + let n = String.length s in + let rec loop i = if i < n && is_digit s.[i] then loop (i + 1) else i in loop + +let mk_tagged_id t i = id_of_string (sprintf "%s%d_" t i) +let is_tagged t s = + let n = String.length s - 1 and m = String.length t in + m < n && s.[n] = '_' && same_prefix s t m && skip_digits s m = n + +let perm_tag = "_perm_Hyp_" +let _ = add_internal_name (is_tagged perm_tag) +let mk_perm_id = + let salt = ref 1 in + fun () -> salt := !salt mod 10000 + 1; mk_tagged_id perm_tag !salt + +let evar_tag = "_evar_" +let _ = add_internal_name (is_tagged evar_tag) +let mk_evar_name n = Name (mk_tagged_id evar_tag n) +let nb_evar_deps = function + | Name id -> + let s = string_of_id id in + if not (is_tagged evar_tag s) then 0 else + let m = String.length evar_tag in + (try int_of_string (String.sub s m (String.length s - 1 - m)) with _ -> 0) + | _ -> 0 + +let discharged_tag = "_discharged_" +let mk_discharged_id id = + id_of_string (sprintf "%s%s_" discharged_tag (string_of_id id)) +let has_discharged_tag s = + let m = String.length discharged_tag and n = String.length s - 1 in + m < n && s.[n] = '_' && same_prefix s discharged_tag m +let _ = add_internal_name has_discharged_tag +let is_discharged_id id = has_discharged_tag (string_of_id id) + +let wildcard_tag = "_the_" +let wildcard_post = "_wildcard_" +let mk_wildcard_id i = + id_of_string (sprintf "%s%s%s" wildcard_tag (String.ordinal i) wildcard_post) +let has_wildcard_tag s = + let n = String.length s in let m = String.length wildcard_tag in + let m' = String.length wildcard_post in + n < m + m' + 2 && same_prefix s wildcard_tag m && + String.sub s (n - m') m' = wildcard_post && + skip_digits s m = n - m' - 2 +let _ = add_internal_name has_wildcard_tag + +let max_suffix m (t, j0 as tj0) id = + let s = string_of_id id in let n = String.length s - 1 in + let dn = String.length t - 1 - n in let i0 = j0 - dn in + if not (i0 >= m && s.[n] = '_' && same_prefix s t m) then tj0 else + let rec loop i = + if i < i0 && s.[i] = '0' then loop (i + 1) else + if (if i < i0 then skip_digits s i = n else le_s_t i) then s, i else tj0 + and le_s_t i = + let ds = s.[i] and dt = t.[i + dn] in + if ds = dt then i = n || le_s_t (i + 1) else + dt < ds && skip_digits s i = n in + loop m + +let mk_anon_id t gl = + let m, si0, id0 = + let s = ref (sprintf "_%s_" t) in + if is_internal_name !s then s := "_" ^ !s; + let n = String.length !s - 1 in + let rec loop i j = + let d = !s.[i] in if not (is_digit d) then i + 1, j else + loop (i - 1) (if d = '0' then j else i) in + let m, j = loop (n - 1) n in m, (!s, j), id_of_string !s in + let gl_ids = pf_ids_of_hyps gl in + if not (List.mem id0 gl_ids) then id0 else + let s, i = List.fold_left (max_suffix m) si0 gl_ids in + let n = String.length s - 1 in + let rec loop i = + if s.[i] = '9' then (s.[i] <- '0'; loop (i - 1)) else + if i < m then (s.[n] <- '0'; s.[m] <- '1'; s ^ "_") else + (s.[i] <- Char.chr (Char.code s.[i] + 1); s) in + id_of_string (loop (n - 1)) + +(* We must not anonymize context names discharged by the "in" tactical. *) + +let ssr_anon_hyp = "Hyp" + +let anontac (x, _, _) gl = + let id = match x with + | Name id -> + if is_discharged_id id then id else mk_anon_id (string_of_id id) gl + | _ -> mk_anon_id ssr_anon_hyp gl in + introid id gl + +let rec constr_name c = match kind_of_term c with + | Var id -> Name id + | Cast (c', _, _) -> constr_name c' + | Const (cn,_) -> Name (id_of_label (con_label cn)) + | App (c', _) -> constr_name c' + | _ -> Anonymous + +(* }}} *) + +(** Open term to lambda-term coercion {{{ ************************************) + +(* This operation takes a goal gl and an open term (sigma, t), and *) +(* returns a term t' where all the new evars in sigma are abstracted *) +(* with the mkAbs argument, i.e., for mkAbs = mkLambda then there is *) +(* some duplicate-free array args of evars of sigma such that the *) +(* term mkApp (t', args) is convertible to t. *) +(* This makes a useful shorthand for local definitions in proofs, *) +(* i.e., pose succ := _ + 1 means pose succ := fun n : nat => n + 1, *) +(* and, in context of the the 4CT library, pose mid := maps id means *) +(* pose mid := fun d : detaSet => @maps d d (@id (datum d)) *) +(* Note that this facility does not extend to set, which tries *) +(* instead to fill holes by matching a goal subterm. *) +(* The argument to "have" et al. uses product abstraction, e.g. *) +(* have Hmid: forall s, (maps id s) = s. *) +(* stands for *) +(* have Hmid: forall (d : dataSet) (s : seq d), (maps id s) = s. *) +(* We also use this feature for rewrite rules, so that, e.g., *) +(* rewrite: (plus_assoc _ 3). *) +(* will execute as *) +(* rewrite (fun n => plus_assoc n 3) *) +(* i.e., it will rewrite some subterm .. + (3 + ..) to .. + 3 + ... *) +(* The convention is also used for the argument of the congr tactic, *) +(* e.g., congr (x + _ * 1). *) + +(* Replace new evars with lambda variables, retaining local dependencies *) +(* but stripping global ones. We use the variable names to encode the *) +(* the number of dependencies, so that the transformation is reversible. *) + +let pf_abs_evars gl (sigma, c0) = + let sigma0, ucst = project gl, Evd.evar_universe_context sigma in + let nenv = env_size (pf_env gl) in + let abs_evar n k = + let evi = Evd.find sigma k in + let dc = List.firstn n (evar_filtered_context evi) in + let abs_dc c = function + | x, Some b, t -> mkNamedLetIn x b t (mkArrow t c) + | x, None, t -> mkNamedProd x t c in + let t = Context.fold_named_context_reverse abs_dc ~init:evi.evar_concl dc in + Evarutil.nf_evar sigma t in + let rec put evlist c = match kind_of_term c with + | Evar (k, a) -> + if List.mem_assoc k evlist || Evd.mem sigma0 k then evlist else + let n = max 0 (Array.length a - nenv) in + let t = abs_evar n k in (k, (n, t)) :: put evlist t + | _ -> fold_constr put evlist c in + let evlist = put [] c0 in + if evlist = [] then 0, c0,[], ucst else + let rec lookup k i = function + | [] -> 0, 0 + | (k', (n, _)) :: evl -> if k = k' then i, n else lookup k (i + 1) evl in + let rec get i c = match kind_of_term c with + | Evar (ev, a) -> + let j, n = lookup ev i evlist in + if j = 0 then map_constr (get i) c else if n = 0 then mkRel j else + mkApp (mkRel j, Array.init n (fun k -> get i a.(n - 1 - k))) + | _ -> map_constr_with_binders ((+) 1) get i c in + let rec loop c i = function + | (_, (n, t)) :: evl -> + loop (mkLambda (mk_evar_name n, get (i - 1) t, c)) (i - 1) evl + | [] -> c in + List.length evlist, loop (get 1 c0) 1 evlist, List.map fst evlist, ucst + + + +(* As before but if (?i : T(?j)) and (?j : P : Prop), then the lambda for i + * looks like (fun evar_i : (forall pi : P. T(pi))) thanks to "loopP" and all + * occurrences of evar_i are replaced by (evar_i evar_j) thanks to "app". + * + * If P can be solved by ssrautoprop (that defaults to trivial), then + * the corresponding lambda looks like (fun evar_i : T(c)) where c is + * the solution found by ssrautoprop. + *) +let ssrautoprop_tac = ref (fun gl -> assert false) + +(* Thanks to Arnaud Spiwack for this snippet *) +let call_on_evar tac e s = + let { it = gs ; sigma = s } = + tac { it = e ; sigma = s; } in + gs, s + +let pf_abs_evars_pirrel gl (sigma, c0) = + pp(lazy(str"==PF_ABS_EVARS_PIRREL==")); + pp(lazy(str"c0= " ++ pr_constr c0)); + let sigma0 = project gl in + let c0 = Evarutil.nf_evar sigma0 (Evarutil.nf_evar sigma c0) in + let nenv = env_size (pf_env gl) in + let abs_evar n k = + let evi = Evd.find sigma k in + let dc = List.firstn n (evar_filtered_context evi) in + let abs_dc c = function + | x, Some b, t -> mkNamedLetIn x b t (mkArrow t c) + | x, None, t -> mkNamedProd x t c in + let t = Context.fold_named_context_reverse abs_dc ~init:evi.evar_concl dc in + Evarutil.nf_evar sigma0 (Evarutil.nf_evar sigma t) in + let rec put evlist c = match kind_of_term c with + | Evar (k, a) -> + if List.mem_assoc k evlist || Evd.mem sigma0 k then evlist else + let n = max 0 (Array.length a - nenv) in + let k_ty = + Retyping.get_sort_family_of + (pf_env gl) sigma (Evd.evar_concl (Evd.find sigma k)) in + let is_prop = k_ty = InProp in + let t = abs_evar n k in (k, (n, t, is_prop)) :: put evlist t + | _ -> fold_constr put evlist c in + let evlist = put [] c0 in + if evlist = [] then 0, c0 else + let pr_constr t = pr_constr (Reductionops.nf_beta (project gl) t) in + pp(lazy(str"evlist=" ++ pr_list (fun () -> str";") + (fun (k,_) -> str(Evd.string_of_existential k)) evlist)); + let evplist = + let depev = List.fold_left (fun evs (_,(_,t,_)) -> + Intset.union evs (Evarutil.undefined_evars_of_term sigma t)) Intset.empty evlist in + List.filter (fun i,(_,_,b) -> b && Intset.mem i depev) evlist in + let evlist, evplist, sigma = + if evplist = [] then evlist, [], sigma else + List.fold_left (fun (ev, evp, sigma) (i, (_,t,_) as p) -> + try + let ng, sigma = call_on_evar !ssrautoprop_tac i sigma in + if (ng <> []) then errorstrm (str "Should we tell the user?"); + List.filter (fun (j,_) -> j <> i) ev, evp, sigma + with _ -> ev, p::evp, sigma) (evlist, [], sigma) (List.rev evplist) in + let c0 = Evarutil.nf_evar sigma c0 in + let evlist = + List.map (fun (x,(y,t,z)) -> x,(y,Evarutil.nf_evar sigma t,z)) evlist in + let evplist = + List.map (fun (x,(y,t,z)) -> x,(y,Evarutil.nf_evar sigma t,z)) evplist in + pp(lazy(str"c0= " ++ pr_constr c0)); + let rec lookup k i = function + | [] -> 0, 0 + | (k', (n,_,_)) :: evl -> if k = k' then i,n else lookup k (i + 1) evl in + let rec get evlist i c = match kind_of_term c with + | Evar (ev, a) -> + let j, n = lookup ev i evlist in + if j = 0 then map_constr (get evlist i) c else if n = 0 then mkRel j else + mkApp (mkRel j, Array.init n (fun k -> get evlist i a.(n - 1 - k))) + | _ -> map_constr_with_binders ((+) 1) (get evlist) i c in + let rec app extra_args i c = match decompose_app c with + | hd, args when isRel hd && destRel hd = i -> + let j = destRel hd in + mkApp (mkRel j, Array.of_list (List.map (lift (i-1)) extra_args @ args)) + | _ -> map_constr_with_binders ((+) 1) (app extra_args) i c in + let rec loopP evlist c i = function + | (_, (n, t, _)) :: evl -> + let t = get evlist (i - 1) t in + let n = Name (id_of_string (ssr_anon_hyp ^ string_of_int n)) in + loopP evlist (mkProd (n, t, c)) (i - 1) evl + | [] -> c in + let rec loop c i = function + | (_, (n, t, _)) :: evl -> + let evs = Evarutil.undefined_evars_of_term sigma t in + let t_evplist = List.filter (fun (k,_) -> Intset.mem k evs) evplist in + let t = loopP t_evplist (get t_evplist 1 t) 1 t_evplist in + let t = get evlist (i - 1) t in + let extra_args = + List.map (fun (k,_) -> mkRel (fst (lookup k i evlist))) + (List.rev t_evplist) in + let c = if extra_args = [] then c else app extra_args 1 c in + loop (mkLambda (mk_evar_name n, t, c)) (i - 1) evl + | [] -> c in + let res = loop (get evlist 1 c0) 1 evlist in + pp(lazy(str"res= " ++ pr_constr res)); + List.length evlist, res + +(* Strip all non-essential dependencies from an abstracted term, generating *) +(* standard names for the abstracted holes. *) + +let pf_abs_cterm gl n c0 = + if n <= 0 then c0 else + let noargs = [|0|] in + let eva = Array.make n noargs in + let rec strip i c = match kind_of_term c with + | App (f, a) when isRel f -> + let j = i - destRel f in + if j >= n || eva.(j) = noargs then mkApp (f, Array.map (strip i) a) else + let dp = eva.(j) in + let nd = Array.length dp - 1 in + let mkarg k = strip i a.(if k < nd then dp.(k + 1) - j else k + dp.(0)) in + mkApp (f, Array.init (Array.length a - dp.(0)) mkarg) + | _ -> map_constr_with_binders ((+) 1) strip i c in + let rec strip_ndeps j i c = match kind_of_term c with + | Prod (x, t, c1) when i < j -> + let dl, c2 = strip_ndeps j (i + 1) c1 in + if noccurn 1 c2 then dl, lift (-1) c2 else + i :: dl, mkProd (x, strip i t, c2) + | LetIn (x, b, t, c1) when i < j -> + let _, _, c1' = destProd c1 in + let dl, c2 = strip_ndeps j (i + 1) c1' in + if noccurn 1 c2 then dl, lift (-1) c2 else + i :: dl, mkLetIn (x, strip i b, strip i t, c2) + | _ -> [], strip i c in + let rec strip_evars i c = match kind_of_term c with + | Lambda (x, t1, c1) when i < n -> + let na = nb_evar_deps x in + let dl, t2 = strip_ndeps (i + na) i t1 in + let na' = List.length dl in + eva.(i) <- Array.of_list (na - na' :: dl); + let x' = + if na' = 0 then Name (pf_type_id gl t2) else mk_evar_name na' in + mkLambda (x', t2, strip_evars (i + 1) c1) +(* if noccurn 1 c2 then lift (-1) c2 else + mkLambda (Name (pf_type_id gl t2), t2, c2) *) + | _ -> strip i c in + strip_evars 0 c0 + +(* Undo the evar abstractions. Also works for non-evar variables. *) + +let pf_unabs_evars gl ise n c0 = + if n = 0 then c0 else + let evv = Array.make n mkProp in + let nev = ref 0 in + let env0 = pf_env gl in + let nenv0 = env_size env0 in + let rec unabs i c = match kind_of_term c with + | Rel j when i - j < !nev -> evv.(i - j) + | App (f, a0) when isRel f -> + let a = Array.map (unabs i) a0 in + let j = i - destRel f in + if j >= !nev then mkApp (f, a) else + let ev, eva = destEvar evv.(j) in + let nd = Array.length eva - nenv0 in + if nd = 0 then mkApp (evv.(j), a) else + let evarg k = if k < nd then a.(nd - 1 - k) else eva.(k) in + let c' = mkEvar (ev, Array.init (nd + nenv0) evarg) in + let na = Array.length a - nd in + if na = 0 then c' else mkApp (c', Array.sub a nd na) + | _ -> map_constr_with_binders ((+) 1) unabs i c in + let push_rel = Environ.push_rel in + let rec mk_evar j env i c = match kind_of_term c with + | Prod (x, t, c1) when i < j -> + mk_evar j (push_rel (x, None, unabs i t) env) (i + 1) c1 + | LetIn (x, b, t, c1) when i < j -> + let _, _, c2 = destProd c1 in + mk_evar j (push_rel (x, Some (unabs i b), unabs i t) env) (i + 1) c2 + | _ -> Evarutil.e_new_evar env ise (unabs i c) in + let rec unabs_evars c = + if !nev = n then unabs n c else match kind_of_term c with + | Lambda (x, t, c1) when !nev < n -> + let i = !nev in + evv.(i) <- mk_evar (i + nb_evar_deps x) env0 i t; + incr nev; unabs_evars c1 + | _ -> unabs !nev c in + unabs_evars c0 + +(* }}} *) + +(** Tactical extensions. {{{ **************************************************) + +(* The TACTIC EXTEND facility can't be used for defining new user *) +(* tacticals, because: *) +(* - the concrete syntax must start with a fixed string *) +(* We use the following workaround: *) +(* - We use the (unparsable) "YouShouldNotTypeThis" token for tacticals that *) +(* don't start with a token, then redefine the grammar and *) +(* printer using GEXTEND and set_pr_ssrtac, respectively. *) + +type ssrargfmt = ArgSsr of string | ArgCoq of argument_type | ArgSep of string + +let ssrtac_name name = { + mltac_plugin = "ssreflect"; + mltac_tactic = "ssr" ^ name; +} + +let ssrtac_entry name n = { + mltac_name = ssrtac_name name; + mltac_index = n; +} + +let set_pr_ssrtac name prec afmt = + let fmt = List.map (function ArgSep s -> Some s | _ -> None) afmt in + let rec mk_akey = function + | ArgSsr s :: afmt' -> ExtraArgType ("ssr" ^ s) :: mk_akey afmt' + | ArgCoq a :: afmt' -> a :: mk_akey afmt' + | ArgSep _ :: afmt' -> mk_akey afmt' + | [] -> [] in + let tacname = ssrtac_name name in + Pptactic.declare_ml_tactic_pprule tacname [| + { Pptactic.pptac_args = mk_akey afmt; + Pptactic.pptac_prods = (prec, fmt) } + |] + +let ssrtac_atom loc name args = TacML (loc, ssrtac_entry name 0, args) +let ssrtac_expr = ssrtac_atom + + +let ssrevaltac ist gtac = + let debug = match TacStore.get ist.extra f_debug with + | None -> Tactic_debug.DebugOff | Some level -> level + in + Proofview.V82.of_tactic (interp_tac_gen ist.lfun [] debug (globTacticIn (fun _ -> gtac))) + +(* fun gl -> let lfun = [tacarg_id, val_interp ist gl gtac] in + interp_tac_gen lfun [] ist.debug tacarg_expr gl *) + +(** Generic argument-based globbing/typing utilities *) + + +let interp_wit wit ist gl x = + let globarg = in_gen (glbwit wit) x in + let sigma, arg = interp_genarg ist (pf_env gl) (project gl) (pf_concl gl) gl.Evd.it globarg in + sigma, out_gen (topwit wit) arg + +let interp_intro_pattern = interp_wit wit_intro_pattern + +let interp_constr = interp_wit wit_constr + +let interp_open_constr ist gl gc = + interp_wit wit_open_constr ist gl ((), gc) + +let interp_refine ist gl rc = + let constrvars = extract_ltac_constr_values ist (pf_env gl) in + let vars = { Pretyping.empty_lvar with + Pretyping.ltac_constrs = constrvars; ltac_genargs = ist.lfun + } in + let kind = OfType (pf_concl gl) in + let flags = { + use_typeclasses = true; + use_unif_heuristics = true; + use_hook = None; + fail_evar = false; + expand_evars = true } + in + let sigma, c = understand_ltac flags (pf_env gl) (project gl) vars kind rc in +(* pp(lazy(str"sigma@interp_refine=" ++ pr_evar_map None sigma)); *) + pp(lazy(str"c@interp_refine=" ++ pr_constr c)); + (sigma, (sigma, c)) + +let pf_match = pf_apply (fun e s c t -> understand_tcc e s ~expected_type:t c) + +(* Estimate a bound on the number of arguments of a raw constr. *) +(* This is not perfect, because the unifier may fail to *) +(* typecheck the partial application, so we use a minimum of 5. *) +(* Also, we don't handle delayed or iterated coercions to *) +(* FUNCLASS, which is probably just as well since these can *) +(* lead to infinite arities. *) + +let splay_open_constr gl (sigma, c) = + let env = pf_env gl in let t = Retyping.get_type_of env sigma c in + Reductionops.splay_prod env sigma t + +let nbargs_open_constr gl oc = + let pl, _ = splay_open_constr gl oc in List.length pl + +let interp_nbargs ist gl rc = + try + let rc6 = mkRApp rc (mkRHoles 6) in + let sigma, t = interp_open_constr ist gl (rc6, None) in + let si = sig_it gl in + let gl = re_sig si sigma in + 6 + nbargs_open_constr gl t + with _ -> 5 + +let pf_nbargs gl c = nbargs_open_constr gl (project gl, c) + +let isAppInd gl c = + try ignore (pf_reduce_to_atomic_ind gl c); true with _ -> false + +let interp_view_nbimps ist gl rc = + try + let sigma, t = interp_open_constr ist gl (rc, None) in + let si = sig_it gl in + let gl = re_sig si sigma in + let pl, c = splay_open_constr gl t in + if isAppInd gl c then List.length pl else ~-(List.length pl) + with _ -> 0 + +(* }}} *) + +(** Vernacular commands: Prenex Implicits and Search {{{ **********************) + +(* This should really be implemented as an extension to the implicit *) +(* arguments feature, but unfortuately that API is sealed. The current *) +(* workaround uses a combination of notations that works reasonably, *) +(* with the following caveats: *) +(* - The pretty-printing always elides prenex implicits, even when *) +(* they are obviously needed. *) +(* - Prenex Implicits are NEVER exported from a module, because this *) +(* would lead to faulty pretty-printing and scoping errors. *) +(* - The command "Import Prenex Implicits" can be used to reassert *) +(* Prenex Implicits for all the visible constants that had been *) +(* declared as Prenex Implicits. *) + +let declare_one_prenex_implicit locality f = + let fref = + try Smartlocate.global_with_alias f + with _ -> errorstrm (pr_reference f ++ str " is not declared") in + let rec loop = function + | a :: args' when Impargs.is_status_implicit a -> + (ExplByName (Impargs.name_of_implicit a), (true, true, true)) :: loop args' + | args' when List.exists Impargs.is_status_implicit args' -> + errorstrm (str "Expected prenex implicits for " ++ pr_reference f) + | _ -> [] in + let impls = + match Impargs.implicits_of_global fref with + | [cond,impls] -> impls + | [] -> errorstrm (str "Expected some implicits for " ++ pr_reference f) + | _ -> errorstrm (str "Multiple implicits not supported") in + match loop impls with + | [] -> + errorstrm (str "Expected some implicits for " ++ pr_reference f) + | impls -> + Impargs.declare_manual_implicits locality fref ~enriching:false [impls] + +VERNAC COMMAND EXTEND Ssrpreneximplicits CLASSIFIED AS SIDEFF + | [ "Prenex" "Implicits" ne_global_list(fl) ] + -> [ let locality = + Locality.make_section_locality (Locality.LocalityFixme.consume ()) in + List.iter (declare_one_prenex_implicit locality) fl ] +END + +(* Vernac grammar visibility patch *) + +GEXTEND Gram + GLOBAL: gallina_ext; + gallina_ext: + [ [ IDENT "Import"; IDENT "Prenex"; IDENT "Implicits" -> + Vernacexpr.VernacUnsetOption (["Printing"; "Implicit"; "Defensive"]) + ] ] + ; +END + +(** Extend Search to subsume SearchAbout, also adding hidden Type coercions. *) + +(* Main prefilter *) + +type raw_glob_search_about_item = + | RGlobSearchSubPattern of constr_expr + | RGlobSearchString of Loc.t * string * string option + +let pr_search_item = function + | RGlobSearchString (_,s,_) -> str s + | RGlobSearchSubPattern p -> pr_constr_expr p + +let wit_ssr_searchitem = add_genarg "ssr_searchitem" pr_search_item + +let interp_search_notation loc s opt_scope = + try + let interp = Notation.interp_notation_as_global_reference loc in + let ref = interp (fun _ -> true) s opt_scope in + Search.GlobSearchSubPattern (Pattern.PRef ref) + with _ -> + let diagnosis = + try + let ntns = Notation.locate_notation pr_glob_constr s opt_scope in + let ambig = "This string refers to a complex or ambiguous notation." in + str ambig ++ str "\nTry searching with one of\n" ++ ntns + with _ -> str "This string is not part of an identifier or notation." in + Errors.user_err_loc (loc, "interp_search_notation", diagnosis) + +let pr_ssr_search_item _ _ _ = pr_search_item + +(* Workaround the notation API that can only print notations *) + +let is_ident s = try Lexer.check_ident s; true with _ -> false + +let is_ident_part s = is_ident ("H" ^ s) + +let interp_search_notation loc tag okey = + let err msg = Errors.user_err_loc (loc, "interp_search_notation", msg) in + let mk_pntn s for_key = + let n = String.length s in + let s' = String.make (n + 2) ' ' in + let rec loop i i' = + if i >= n then s', i' - 2 else if s.[i] = ' ' then loop (i + 1) i' else + let j = try String.index_from s (i + 1) ' ' with _ -> n in + let m = j - i in + if s.[i] = '\'' && i < j - 2 && s.[j - 1] = '\'' then + (String.blit s (i + 1) s' i' (m - 2); loop (j + 1) (i' + m - 1)) + else if for_key && is_ident (String.sub s i m) then + (s'.[i'] <- '_'; loop (j + 1) (i' + 2)) + else (String.blit s i s' i' m; loop (j + 1) (i' + m + 1)) in + loop 0 1 in + let trim_ntn (pntn, m) = String.sub pntn 1 (max 0 m) in + let pr_ntn ntn = str "(" ++ str ntn ++ str ")" in + let pr_and_list pr = function + | [x] -> pr x + | x :: lx -> pr_list pr_comma pr lx ++ pr_comma () ++ str "and " ++ pr x + | [] -> mt () in + let pr_sc sc = str (if sc = "" then "independently" else sc) in + let pr_scs = function + | [""] -> pr_sc "" + | scs -> str "in " ++ pr_and_list pr_sc scs in + let generator, pr_tag_sc = + let ign _ = mt () in match okey with + | Some key -> + let sc = Notation.find_delimiters_scope loc key in + let pr_sc s_in = str s_in ++ spc() ++ str sc ++ pr_comma() in + Notation.pr_scope ign sc, pr_sc + | None -> Notation.pr_scopes ign, ign in + let qtag s_in = pr_tag_sc s_in ++ qstring tag ++ spc()in + let ptag, ttag = + let ptag, m = mk_pntn tag false in + if m <= 0 then err (str "empty notation fragment"); + ptag, trim_ntn (ptag, m) in + let last = ref "" and last_sc = ref "" in + let scs = ref [] and ntns = ref [] in + let push_sc sc = match !scs with + | "" :: scs' -> scs := "" :: sc :: scs' + | scs' -> scs := sc :: scs' in + let get s _ _ = match !last with + | "Scope " -> last_sc := s; last := "" + | "Lonely notation" -> last_sc := ""; last := "" + | "\"" -> + let pntn, m = mk_pntn s true in + if String.string_contains pntn ptag then begin + let ntn = trim_ntn (pntn, m) in + match !ntns with + | [] -> ntns := [ntn]; scs := [!last_sc] + | ntn' :: _ when ntn' = ntn -> push_sc !last_sc + | _ when ntn = ttag -> ntns := ntn :: !ntns; scs := [!last_sc] + | _ :: ntns' when List.mem ntn ntns' -> () + | ntn' :: ntns' -> ntns := ntn' :: ntn :: ntns' + end; + last := "" + | _ -> last := s in + pp_with (Format.make_formatter get (fun _ -> ())) generator; + let ntn = match !ntns with + | [] -> + err (hov 0 (qtag "in" ++ str "does not occur in any notation")) + | ntn :: ntns' when ntn = ttag -> + if ntns' <> [] then begin + let pr_ntns' = pr_and_list pr_ntn ntns' in + msg_warning (hov 4 (qtag "In" ++ str "also occurs in " ++ pr_ntns')) + end; ntn + | [ntn] -> + msgnl (hov 4 (qtag "In" ++ str "is part of notation " ++ pr_ntn ntn)); ntn + | ntns' -> + let e = str "occurs in" ++ spc() ++ pr_and_list pr_ntn ntns' in + err (hov 4 (str "ambiguous: " ++ qtag "in" ++ e)) in + let (nvars, body), ((_, pat), osc) = match !scs with + | [sc] -> Notation.interp_notation loc ntn (None, [sc]) + | scs' -> + try Notation.interp_notation loc ntn (None, []) with _ -> + let e = pr_ntn ntn ++ spc() ++ str "is defined " ++ pr_scs scs' in + err (hov 4 (str "ambiguous: " ++ pr_tag_sc "in" ++ e)) in + let sc = Option.default "" osc in + let _ = + let m_sc = + if osc <> None then str "In " ++ str sc ++ pr_comma() else mt() in + let ntn_pat = trim_ntn (mk_pntn pat false) in + let rbody = glob_constr_of_notation_constr loc body in + let m_body = hov 0 (Constrextern.without_symbols prl_glob_constr rbody) in + let m = m_sc ++ pr_ntn ntn_pat ++ spc () ++ str "denotes " ++ m_body in + msgnl (hov 0 m) in + if List.length !scs > 1 then + let scs' = List.remove (=) sc !scs in + let w = pr_ntn ntn ++ str " is also defined " ++ pr_scs scs' in + msg_warning (hov 4 w) + else if String.string_contains ntn " .. " then + err (pr_ntn ntn ++ str " is an n-ary notation"); + let nvars = List.filter (fun (_,(_,typ)) -> typ = NtnTypeConstr) nvars in + let rec sub () = function + | NVar x when List.mem_assoc x nvars -> GPatVar (loc, (false, x)) + | c -> + glob_constr_of_notation_constr_with_binders loc (fun _ x -> (), x) sub () c in + let _, npat = Patternops.pattern_of_glob_constr (sub () body) in + Search.GlobSearchSubPattern npat + +ARGUMENT EXTEND ssr_search_item TYPED AS ssr_searchitem + PRINTED BY pr_ssr_search_item + | [ string(s) ] -> [ RGlobSearchString (loc,s,None) ] + | [ string(s) "%" preident(key) ] -> [ RGlobSearchString (loc,s,Some key) ] + | [ constr_pattern(p) ] -> [ RGlobSearchSubPattern p ] +END + +let pr_ssr_search_arg _ _ _ = + let pr_item (b, p) = str (if b then "-" else "") ++ pr_search_item p in + pr_list spc pr_item + +ARGUMENT EXTEND ssr_search_arg TYPED AS (bool * ssr_searchitem) list + PRINTED BY pr_ssr_search_arg + | [ "-" ssr_search_item(p) ssr_search_arg(a) ] -> [ (false, p) :: a ] + | [ ssr_search_item(p) ssr_search_arg(a) ] -> [ (true, p) :: a ] + | [ ] -> [ [] ] +END + +(* Main type conclusion pattern filter *) + +let rec splay_search_pattern na = function + | Pattern.PApp (fp, args) -> splay_search_pattern (na + Array.length args) fp + | Pattern.PLetIn (_, _, bp) -> splay_search_pattern na bp + | Pattern.PRef hr -> hr, na + | _ -> Errors.error "no head constant in head search pattern" + +let coerce_search_pattern_to_sort hpat = + let env = Global.env () and sigma = Evd.empty in + let mkPApp fp n_imps args = + let args' = Array.append (Array.make n_imps (Pattern.PMeta None)) args in + Pattern.PApp (fp, args') in + let hr, na = splay_search_pattern 0 hpat in + let dc, ht = + Reductionops.splay_prod env sigma (Universes.unsafe_type_of_global hr) in + let np = List.length dc in + if np < na then Errors.error "too many arguments in head search pattern" else + let hpat' = if np = na then hpat else mkPApp hpat (np - na) [||] in + let warn () = + msg_warning (str "Listing only lemmas with conclusion matching " ++ + pr_constr_pattern hpat') in + if isSort ht then begin warn (); true, hpat' end else + let filter_head, coe_path = + try + let _, cp = + Classops.lookup_path_to_sort_from (push_rels_assum dc env) sigma ht in + warn (); + true, cp + with _ -> false, [] in + let coerce hp coe_index = + let coe = Classops.get_coercion_value coe_index in + try + let coe_ref = reference_of_constr coe in + let n_imps = Option.get (Classops.hide_coercion coe_ref) in + mkPApp (Pattern.PRef coe_ref) n_imps [|hp|] + with _ -> + errorstrm (str "need explicit coercion " ++ pr_constr coe ++ spc () + ++ str "to interpret head search pattern as type") in + filter_head, List.fold_left coerce hpat' coe_path + +let rec interp_head_pat hpat = + let filter_head, p = coerce_search_pattern_to_sort hpat in + let rec loop c = match kind_of_term c with + | Cast (c', _, _) -> loop c' + | Prod (_, _, c') -> loop c' + | LetIn (_, _, _, c') -> loop c' + | _ -> Constr_matching.is_matching (Global.env()) Evd.empty p c in + filter_head, loop + +let all_true _ = true + +let rec interp_search_about args accu = match args with +| [] -> accu +| (flag, arg) :: rem -> + fun gr env typ -> + let ans = Search.search_about_filter arg gr env typ in + (if flag then ans else not ans) && interp_search_about rem accu gr env typ + +let interp_search_arg arg = + let arg = List.map (fun (x,arg) -> x, match arg with + | RGlobSearchString (loc,s,key) -> + if is_ident_part s then Search.GlobSearchString s else + interp_search_notation loc s key + | RGlobSearchSubPattern p -> + try + let intern = Constrintern.intern_constr_pattern in + Search.GlobSearchSubPattern (snd (intern (Global.env()) p)) + with e -> let e = Errors.push e in iraise (Cerrors.process_vernac_interp_error e)) arg in + let hpat, a1 = match arg with + | (_, Search.GlobSearchSubPattern (Pattern.PMeta _)) :: a' -> all_true, a' + | (true, Search.GlobSearchSubPattern p) :: a' -> + let filter_head, p = interp_head_pat p in + if filter_head then p, a' else all_true, arg + | _ -> all_true, arg in + let is_string = + function (_, Search.GlobSearchString _) -> true | _ -> false in + let a2, a3 = List.partition is_string a1 in + interp_search_about (a2 @ a3) (fun gr env typ -> hpat typ) + +(* Module path postfilter *) + +let pr_modloc (b, m) = if b then str "-" ++ pr_reference m else pr_reference m + +let wit_ssrmodloc = add_genarg "ssrmodloc" pr_modloc + +let pr_ssr_modlocs _ _ _ ml = + if ml = [] then str "" else spc () ++ str "in " ++ pr_list spc pr_modloc ml + +ARGUMENT EXTEND ssr_modlocs TYPED AS ssrmodloc list PRINTED BY pr_ssr_modlocs + | [ ] -> [ [] ] +END + +GEXTEND Gram + GLOBAL: ssr_modlocs; + modloc: [[ "-"; m = global -> true, m | m = global -> false, m]]; + ssr_modlocs: [[ "in"; ml = LIST1 modloc -> ml ]]; +END + +let interp_modloc mr = + let interp_mod (_, mr) = + let (loc, qid) = qualid_of_reference mr in + try Nametab.full_name_module qid with Not_found -> + Errors.user_err_loc (loc, "interp_modloc", str "No Module " ++ pr_qualid qid) in + let mr_out, mr_in = List.partition fst mr in + let interp_bmod b = function + | [] -> fun _ _ _ -> true + | rmods -> Search.module_filter (List.map interp_mod rmods, b) in + let is_in = interp_bmod false mr_in and is_out = interp_bmod true mr_out in + fun gr env typ -> is_in gr env typ && is_out gr env typ + +(* The unified, extended vernacular "Search" command *) + +let ssrdisplaysearch gr env t = + let pr_res = pr_global gr ++ spc () ++ str " " ++ pr_lconstr_env env Evd.empty t in + msg (hov 2 pr_res ++ fnl ()) + +VERNAC COMMAND EXTEND SsrSearchPattern CLASSIFIED AS QUERY +| [ "Search" ssr_search_arg(a) ssr_modlocs(mr) ] -> + [ let hpat = interp_search_arg a in + let in_mod = interp_modloc mr in + let post_filter gr env typ = in_mod gr env typ && hpat gr env typ in + let display gr env typ = + if post_filter gr env typ then ssrdisplaysearch gr env typ + in + Search.generic_search None display ] +END + +(* }}} *) + +(** Alternative notations for "match" and anonymous arguments. {{{ ************) + +(* Syntax: *) +(* if is then ... else ... *) +(* if is [in ..] return ... then ... else ... *) +(* let: := in ... *) +(* let: [in ...] := return ... in ... *) +(* The scope of a top-level 'as' in the pattern extends over the *) +(* 'return' type (dependent if/let). *) +(* Note that the optional "in ..." appears next to the *) +(* rather than the in then "let:" syntax. The alternative *) +(* would lead to ambiguities in, e.g., *) +(* let: p1 := (*v---INNER LET:---v *) *) +(* let: p2 := let: p3 := e3 in k return t in k2 in k1 return t' *) +(* in b (*^--ALTERNATIVE INNER LET--------^ *) *) + +(* Caveat : There is no pretty-printing support, since this would *) +(* require a modification to the Coq kernel (adding a new match *) +(* display style -- why aren't these strings?); also, the v8.1 *) +(* pretty-printer only allows extension hooks for printing *) +(* integer or string literals. *) +(* Also note that in the v8 grammar "is" needs to be a keyword; *) +(* as this can't be done from an ML extension file, the new *) +(* syntax will only work when ssreflect.v is imported. *) + +let no_ct = None, None and no_rt = None in +let aliasvar = function + | [_, [CPatAlias (loc, _, id)]] -> Some (loc,Name id) + | _ -> None in +let mk_cnotype mp = aliasvar mp, None in +let mk_ctype mp t = aliasvar mp, Some t in +let mk_rtype t = Some t in +let mk_dthen loc (mp, ct, rt) c = (loc, mp, c), ct, rt in +let mk_let loc rt ct mp c1 = + CCases (loc, LetPatternStyle, rt, ct, [loc, mp, c1]) in +GEXTEND Gram + GLOBAL: binder_constr; + ssr_rtype: [[ "return"; t = operconstr LEVEL "100" -> mk_rtype t ]]; + ssr_mpat: [[ p = pattern -> [!@loc, [p]] ]]; + ssr_dpat: [ + [ mp = ssr_mpat; "in"; t = pattern; rt = ssr_rtype -> mp, mk_ctype mp t, rt + | mp = ssr_mpat; rt = ssr_rtype -> mp, mk_cnotype mp, rt + | mp = ssr_mpat -> mp, no_ct, no_rt + ] ]; + ssr_dthen: [[ dp = ssr_dpat; "then"; c = lconstr -> mk_dthen !@loc dp c ]]; + ssr_elsepat: [[ "else" -> [!@loc, [CPatAtom (!@loc, None)]] ]]; + ssr_else: [[ mp = ssr_elsepat; c = lconstr -> !@loc, mp, c ]]; + binder_constr: [ + [ "if"; c = operconstr LEVEL "200"; "is"; db1 = ssr_dthen; b2 = ssr_else -> + let b1, ct, rt = db1 in CCases (!@loc, MatchStyle, rt, [c, ct], [b1; b2]) + | "if"; c = operconstr LEVEL "200";"isn't";db1 = ssr_dthen; b2 = ssr_else -> + let b1, ct, rt = db1 in + let b1, b2 = + let (l1, p1, r1), (l2, p2, r2) = b1, b2 in (l1, p1, r2), (l2, p2, r1) in + CCases (!@loc, MatchStyle, rt, [c, ct], [b1; b2]) + | "let"; ":"; mp = ssr_mpat; ":="; c = lconstr; "in"; c1 = lconstr -> + mk_let (!@loc) no_rt [c, no_ct] mp c1 + | "let"; ":"; mp = ssr_mpat; ":="; c = lconstr; + rt = ssr_rtype; "in"; c1 = lconstr -> + mk_let (!@loc) rt [c, mk_cnotype mp] mp c1 + | "let"; ":"; mp = ssr_mpat; "in"; t = pattern; ":="; c = lconstr; + rt = ssr_rtype; "in"; c1 = lconstr -> + mk_let (!@loc) rt [c, mk_ctype mp t] mp c1 + ] ]; +END + +GEXTEND Gram + GLOBAL: closed_binder; + closed_binder: [ + [ ["of" | "&"]; c = operconstr LEVEL "99" -> + [LocalRawAssum ([!@loc, Anonymous], Default Explicit, c)] + ] ]; +END +(* }}} *) + +(** Tacticals (+, -, *, done, by, do, =>, first, and last). {{{ ***************) + +(** Bracketing tactical *) + +(* The tactic pretty-printer doesn't know that some extended tactics *) +(* are actually tacticals. To prevent it from improperly removing *) +(* parentheses we override the parsing rule for bracketed tactic *) +(* expressions so that the pretty-print always reflects the input. *) +(* (Removing user-specified parentheses is dubious anyway). *) + +GEXTEND Gram + GLOBAL: tactic_expr; + ssrparentacarg: [[ "("; tac = tactic_expr; ")" -> !@loc, Tacexp tac ]]; + tactic_expr: LEVEL "0" [[ arg = ssrparentacarg -> TacArg arg ]]; +END + +(** The internal "done" and "ssrautoprop" tactics. *) + +(* For additional flexibility, "done" and "ssrautoprop" are *) +(* defined in Ltac. *) +(* Although we provide a default definition in ssreflect, *) +(* we look up the definition dynamically at each call point, *) +(* to allow for user extensions. "ssrautoprop" defaults to *) +(* trivial. *) + +let donetac gl = + let tacname = + try Nametab.locate_tactic (qualid_of_ident (id_of_string "done")) + with Not_found -> try Nametab.locate_tactic (ssrqid "done") + with Not_found -> Errors.error "The ssreflect library was not loaded" in + let tacexpr = dummy_loc, Tacexpr.Reference (ArgArg (dummy_loc, tacname)) in + Proofview.V82.of_tactic (eval_tactic (Tacexpr.TacArg tacexpr)) gl + +let prof_donetac = mk_profiler "donetac";; +let donetac gl = prof_donetac.profile donetac gl;; + +let ssrautoprop gl = + try + let tacname = + try Nametab.locate_tactic (qualid_of_ident (id_of_string "ssrautoprop")) + with Not_found -> Nametab.locate_tactic (ssrqid "ssrautoprop") in + let tacexpr = dummy_loc, Tacexpr.Reference (ArgArg (dummy_loc, tacname)) in + Proofview.V82.of_tactic (eval_tactic (Tacexpr.TacArg tacexpr)) gl + with Not_found -> Proofview.V82.of_tactic (Auto.full_trivial []) gl + +let () = ssrautoprop_tac := ssrautoprop + +let tclBY tac = tclTHEN tac donetac + +(** Tactical arguments. *) + +(* We have four kinds: simple tactics, [|]-bracketed lists, hints, and swaps *) +(* The latter two are used in forward-chaining tactics (have, suffice, wlog) *) +(* and subgoal reordering tacticals (; first & ; last), respectively. *) + +(* Force use of the tactic_expr parsing entry, to rule out tick marks. *) +let pr_ssrtacarg _ _ prt = prt tacltop +ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY pr_ssrtacarg +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END +GEXTEND Gram + GLOBAL: ssrtacarg; + ssrtacarg: [[ tac = tactic_expr LEVEL "5" -> tac ]]; +END + +(* Lexically closed tactic for tacticals. *) +let pr_ssrtclarg _ _ prt tac = prt tacltop tac +ARGUMENT EXTEND ssrtclarg TYPED AS ssrtacarg + PRINTED BY pr_ssrtclarg +| [ ssrtacarg(tac) ] -> [ tac ] +END +let eval_tclarg ist tac = ssrevaltac ist tac + +let pr_ortacs prt = + let rec pr_rec = function + | [None] -> spc() ++ str "|" ++ spc() + | None :: tacs -> spc() ++ str "|" ++ pr_rec tacs + | Some tac :: tacs -> spc() ++ str "| " ++ prt tacltop tac ++ pr_rec tacs + | [] -> mt() in + function + | [None] -> spc() + | None :: tacs -> pr_rec tacs + | Some tac :: tacs -> prt tacltop tac ++ pr_rec tacs + | [] -> mt() +let pr_ssrortacs _ _ = pr_ortacs + +ARGUMENT EXTEND ssrortacs TYPED AS tactic option list PRINTED BY pr_ssrortacs +| [ ssrtacarg(tac) "|" ssrortacs(tacs) ] -> [ Some tac :: tacs ] +| [ ssrtacarg(tac) "|" ] -> [ [Some tac; None] ] +| [ ssrtacarg(tac) ] -> [ [Some tac] ] +| [ "|" ssrortacs(tacs) ] -> [ None :: tacs ] +| [ "|" ] -> [ [None; None] ] +END + +let pr_hintarg prt = function + | true, tacs -> hv 0 (str "[ " ++ pr_ortacs prt tacs ++ str " ]") + | false, [Some tac] -> prt tacltop tac + | _, _ -> mt() + +let pr_ssrhintarg _ _ = pr_hintarg + +let mk_hint tac = false, [Some tac] +let mk_orhint tacs = true, tacs +let nullhint = true, [] +let nohint = false, [] + +ARGUMENT EXTEND ssrhintarg TYPED AS bool * ssrortacs PRINTED BY pr_ssrhintarg +| [ "[" "]" ] -> [ nullhint ] +| [ "[" ssrortacs(tacs) "]" ] -> [ mk_orhint tacs ] +| [ ssrtacarg(arg) ] -> [ mk_hint arg ] +END + +ARGUMENT EXTEND ssrortacarg TYPED AS ssrhintarg PRINTED BY pr_ssrhintarg +| [ "[" ssrortacs(tacs) "]" ] -> [ mk_orhint tacs ] +END + +let hinttac ist is_by (is_or, atacs) = + let dtac = if is_by then donetac else tclIDTAC in + let mktac = function + | Some atac -> tclTHEN (ssrevaltac ist atac) dtac + | _ -> dtac in + match List.map mktac atacs with + | [] -> if is_or then dtac else tclIDTAC + | [tac] -> tac + | tacs -> tclFIRST tacs + +(** The "-"/"+"/"*" tacticals. *) + +(* These are just visual cues to flag the beginning of the script for *) +(* new subgoals, when indentation is not appropriate (typically after *) +(* tactics that generate more than two subgoals). *) + +TACTIC EXTEND ssrtclplus +| [ "YouShouldNotTypeThis" "+" ssrtclarg(arg) ] -> [ Proofview.V82.tactic (eval_tclarg ist arg) ] +END +set_pr_ssrtac "tclplus" 5 [ArgSep "+ "; ArgSsr "tclarg"] + +TACTIC EXTEND ssrtclminus +| [ "YouShouldNotTypeThis" "-" ssrtclarg(arg) ] -> [ Proofview.V82.tactic (eval_tclarg ist arg) ] +END +set_pr_ssrtac "tclminus" 5 [ArgSep "- "; ArgSsr "tclarg"] + +TACTIC EXTEND ssrtclstar +| [ "YouShouldNotTypeThis" "*" ssrtclarg(arg) ] -> [ Proofview.V82.tactic (eval_tclarg ist arg) ] +END +set_pr_ssrtac "tclstar" 5 [ArgSep "- "; ArgSsr "tclarg"] + +let gen_tclarg = in_gen (rawwit wit_ssrtclarg) + +GEXTEND Gram + GLOBAL: tactic tactic_mode; + tactic: [ + [ "+"; tac = ssrtclarg -> ssrtac_expr !@loc "tclplus" [gen_tclarg tac] + | "-"; tac = ssrtclarg -> ssrtac_expr !@loc "tclminus" [gen_tclarg tac] + | "*"; tac = ssrtclarg -> ssrtac_expr !@loc "tclstar" [gen_tclarg tac] + ] ]; + tactic_mode: [ + [ "+"; tac = G_vernac.subgoal_command -> tac None + | "-"; tac = G_vernac.subgoal_command -> tac None + | "*"; tac = G_vernac.subgoal_command -> tac None + ] ]; +END + +(** The "by" tactical. *) + +let pr_hint prt arg = + if arg = nohint then mt() else str "by " ++ pr_hintarg prt arg +let pr_ssrhint _ _ = pr_hint + +ARGUMENT EXTEND ssrhint TYPED AS ssrhintarg PRINTED BY pr_ssrhint +| [ ] -> [ nohint ] +END + +TACTIC EXTEND ssrtclby +| [ "YouShouldNotTypeThis" ssrhint(tac) ] -> [ Proofview.V82.tactic (hinttac ist true tac) ] +END +set_pr_ssrtac "tclby" 0 [ArgSsr "hint"] + +(* We can't parse "by" in ARGUMENT EXTEND because it will only be made *) +(* into a keyword in ssreflect.v; so we anticipate this in GEXTEND. *) + +GEXTEND Gram + GLOBAL: ssrhint simple_tactic; + ssrhint: [[ "by"; arg = ssrhintarg -> arg ]]; + simple_tactic: [ + [ "by"; arg = ssrhintarg -> + let garg = in_gen (rawwit wit_ssrhint) arg in + ssrtac_atom !@loc "tclby" [garg] + ] ]; +END +(* }}} *) + +(** Bound assumption argument *) + +(* The Ltac API does have a type for assumptions but it is level-dependent *) +(* and therefore impratical to use for complex arguments, so we substitute *) +(* our own to have a uniform representation. Also, we refuse to intern *) +(* idents that match global/section constants, since this would lead to *) +(* fragile Ltac scripts. *) + +type ssrhyp = SsrHyp of loc * identifier + +let hyp_id (SsrHyp (_, id)) = id +let pr_hyp (SsrHyp (_, id)) = pr_id id +let pr_ssrhyp _ _ _ = pr_hyp + +let wit_ssrhyprep = add_genarg "ssrhyprep" pr_hyp + +let hyp_err loc msg id = + Errors.user_err_loc (loc, "ssrhyp", str msg ++ pr_id id) + +let intern_hyp ist (SsrHyp (loc, id) as hyp) = + let _ = Tacintern.intern_genarg ist (in_gen (rawwit wit_var) (loc, id)) in + if not_section_id id then hyp else + hyp_err loc "Can't clear section hypothesis " id + +let interp_hyp ist gl (SsrHyp (loc, id)) = + let s, id' = interp_wit wit_var ist gl (loc, id) in + if not_section_id id' then s, SsrHyp (loc, id') else + hyp_err loc "Can't clear section hypothesis " id' + +ARGUMENT EXTEND ssrhyp TYPED AS ssrhyprep PRINTED BY pr_ssrhyp + INTERPRETED BY interp_hyp + GLOBALIZED BY intern_hyp + | [ ident(id) ] -> [ SsrHyp (loc, id) ] +END + +type ssrhyp_or_id = Hyp of ssrhyp | Id of ssrhyp + +let hoik f = function Hyp x -> f x | Id x -> f x +let hoi_id = hoik hyp_id +let pr_hoi = hoik pr_hyp +let pr_ssrhoi _ _ _ = pr_hoi + +let wit_ssrhoirep = add_genarg "ssrhoirep" pr_hoi + +let intern_ssrhoi ist = function + | Hyp h -> Hyp (intern_hyp ist h) + | Id (SsrHyp (_, id)) as hyp -> + let _ = Tacintern.intern_genarg ist (in_gen (rawwit wit_ident) id) in + hyp + +let interp_ssrhoi ist gl = function + | Hyp h -> let s, h' = interp_hyp ist gl h in s, Hyp h' + | Id (SsrHyp (loc, id)) -> + let s, id' = interp_wit wit_ident ist gl id in + s, Id (SsrHyp (loc, id')) + +ARGUMENT EXTEND ssrhoi_hyp TYPED AS ssrhoirep PRINTED BY pr_ssrhoi + INTERPRETED BY interp_ssrhoi + GLOBALIZED BY intern_ssrhoi + | [ ident(id) ] -> [ Hyp (SsrHyp(loc, id)) ] +END +ARGUMENT EXTEND ssrhoi_id TYPED AS ssrhoirep PRINTED BY pr_ssrhoi + INTERPRETED BY interp_ssrhoi + GLOBALIZED BY intern_ssrhoi + | [ ident(id) ] -> [ Id (SsrHyp(loc, id)) ] +END + +type ssrhyps = ssrhyp list + +let pr_hyps = pr_list pr_spc pr_hyp +let pr_ssrhyps _ _ _ = pr_hyps +let hyps_ids = List.map hyp_id + +let rec check_hyps_uniq ids = function + | SsrHyp (loc, id) :: _ when List.mem id ids -> + hyp_err loc "Duplicate assumption " id + | SsrHyp (_, id) :: hyps -> check_hyps_uniq (id :: ids) hyps + | [] -> () + +let check_hyp_exists hyps (SsrHyp(_, id)) = + try ignore(Context.lookup_named id hyps) + with Not_found -> errorstrm (str"No assumption is named " ++ pr_id id) + +let interp_hyps ist gl ghyps = + let hyps = List.map snd (List.map (interp_hyp ist gl) ghyps) in + check_hyps_uniq [] hyps; Tacmach.project gl, hyps + +ARGUMENT EXTEND ssrhyps TYPED AS ssrhyp list PRINTED BY pr_ssrhyps + INTERPRETED BY interp_hyps + | [ ssrhyp_list(hyps) ] -> [ check_hyps_uniq [] hyps; hyps ] +END + +(** Terms parsing. {{{ ********************************************************) + +(* Because we allow wildcards in term references, we need to stage the *) +(* interpretation of terms so that it occurs at the right time during *) +(* the execution of the tactic (e.g., so that we don't report an error *) +(* for a term that isn't actually used in the execution). *) +(* The term representation tracks whether the concrete initial term *) +(* started with an opening paren, which might avoid a conflict between *) +(* the ssrreflect term syntax and Gallina notation. *) + +(* kinds of terms *) + +type ssrtermkind = char (* print flag *) + +let input_ssrtermkind strm = match Compat.get_tok (stream_nth 0 strm) with + | Tok.KEYWORD "(" -> '(' + | Tok.KEYWORD "@" -> '@' + | _ -> ' ' + +let ssrtermkind = Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind + +let id_of_Cterm t = match id_of_cpattern t with + | Some x -> x + | None -> loc_error (loc_of_cpattern t) "Only identifiers are allowed here" +let ssrhyp_of_ssrterm = function + | k, (_, Some c) as o -> + SsrHyp (constr_loc c, id_of_Cterm (cpattern_of_term o)), String.make 1 k + | _, (_, None) -> assert false + +(* terms *) +let pr_ssrterm _ _ _ = pr_term +let pf_intern_term ist gl (_, c) = glob_constr ist (pf_env gl) c +let intern_term ist sigma env (_, c) = glob_constr ist env c +let interp_term ist gl (_, c) = snd (interp_open_constr ist gl c) +let force_term ist gl (_, c) = interp_constr ist gl c +let glob_ssrterm gs = function + | k, (_, Some c) -> k, Tacintern.intern_constr gs c + | ct -> ct +let subst_ssrterm s (k, c) = k, Tacsubst.subst_glob_constr_and_expr s c +let interp_ssrterm _ gl t = Tacmach.project gl, t + +ARGUMENT EXTEND ssrterm + PRINTED BY pr_ssrterm + INTERPRETED BY interp_ssrterm + GLOBALIZED BY glob_ssrterm SUBSTITUTED BY subst_ssrterm + RAW_TYPED AS cpattern RAW_PRINTED BY pr_ssrterm + GLOB_TYPED AS cpattern GLOB_PRINTED BY pr_ssrterm +| [ "YouShouldNotTypeThis" constr(c) ] -> [ mk_lterm c ] +END + +GEXTEND Gram + GLOBAL: ssrterm; + ssrterm: [[ k = ssrtermkind; c = constr -> mk_term k c ]]; +END +(* }}} *) + +(** The "in" pseudo-tactical {{{ **********************************************) + +(* We can't make "in" into a general tactical because this would create a *) +(* crippling conflict with the ltac let .. in construct. Hence, we add *) +(* explicitly an "in" suffix to all the extended tactics for which it is *) +(* relevant (including move, case, elim) and to the extended do tactical *) +(* below, which yields a general-purpose "in" of the form do [...] in ... *) + +(* This tactical needs to come before the intro tactics because the latter *) +(* must take precautions in order not to interfere with the discharged *) +(* assumptions. This is especially difficult for discharged "let"s, which *) +(* the default simpl and unfold tactics would erase blindly. *) + +(** Clear switch *) + +type ssrclear = ssrhyps + +let pr_clear_ne clr = str "{" ++ pr_hyps clr ++ str "}" +let pr_clear sep clr = if clr = [] then mt () else sep () ++ pr_clear_ne clr + +let pr_ssrclear _ _ _ = pr_clear mt + +ARGUMENT EXTEND ssrclear_ne TYPED AS ssrhyps PRINTED BY pr_ssrclear +| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ check_hyps_uniq [] clr; clr ] +END + +ARGUMENT EXTEND ssrclear TYPED AS ssrclear_ne PRINTED BY pr_ssrclear +| [ ssrclear_ne(clr) ] -> [ clr ] +| [ ] -> [ [] ] +END + +let cleartac clr = check_hyps_uniq [] clr; clear (hyps_ids clr) + +(* type ssrwgen = ssrclear * ssrhyp * string *) + +let pr_wgen = function + | (clr, Some((id,k),None)) -> spc() ++ pr_clear mt clr ++ str k ++ pr_hoi id + | (clr, Some((id,k),Some p)) -> + spc() ++ pr_clear mt clr ++ str"(" ++ str k ++ pr_hoi id ++ str ":=" ++ + pr_cpattern p ++ str ")" + | (clr, None) -> spc () ++ pr_clear mt clr +let pr_ssrwgen _ _ _ = pr_wgen + +(* no globwith for char *) +ARGUMENT EXTEND ssrwgen + TYPED AS ssrclear * ((ssrhoi_hyp * string) * cpattern option) option + PRINTED BY pr_ssrwgen +| [ ssrclear_ne(clr) ] -> [ clr, None ] +| [ ssrhoi_hyp(hyp) ] -> [ [], Some((hyp, " "), None) ] +| [ "@" ssrhoi_hyp(hyp) ] -> [ [], Some((hyp, "@"), None) ] +| [ "(" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> + [ [], Some ((id," "),Some p) ] +| [ "(" ssrhoi_id(id) ")" ] -> [ [], Some ((id,"("), None) ] +| [ "(@" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> + [ [], Some ((id,"@"),Some p) ] +| [ "(" "@" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> + [ [], Some ((id,"@"),Some p) ] +END + +type ssrclseq = InGoal | InHyps + | InHypsGoal | InHypsSeqGoal | InSeqGoal | InHypsSeq | InAll | InAllHyps + +let pr_clseq = function + | InGoal | InHyps -> mt () + | InSeqGoal -> str "|- *" + | InHypsSeqGoal -> str " |- *" + | InHypsGoal -> str " *" + | InAll -> str "*" + | InHypsSeq -> str " |-" + | InAllHyps -> str "* |-" + +let wit_ssrclseq = add_genarg "ssrclseq" pr_clseq +let pr_clausehyps = pr_list pr_spc pr_wgen +let pr_ssrclausehyps _ _ _ = pr_clausehyps + +ARGUMENT EXTEND ssrclausehyps +TYPED AS ssrwgen list PRINTED BY pr_ssrclausehyps +| [ ssrwgen(hyp) "," ssrclausehyps(hyps) ] -> [ hyp :: hyps ] +| [ ssrwgen(hyp) ssrclausehyps(hyps) ] -> [ hyp :: hyps ] +| [ ssrwgen(hyp) ] -> [ [hyp] ] +END + +(* type ssrclauses = ssrahyps * ssrclseq *) + +let pr_clauses (hyps, clseq) = + if clseq = InGoal then mt () + else str "in " ++ pr_clausehyps hyps ++ pr_clseq clseq +let pr_ssrclauses _ _ _ = pr_clauses + +ARGUMENT EXTEND ssrclauses TYPED AS ssrwgen list * ssrclseq + PRINTED BY pr_ssrclauses + | [ "in" ssrclausehyps(hyps) "|-" "*" ] -> [ hyps, InHypsSeqGoal ] + | [ "in" ssrclausehyps(hyps) "|-" ] -> [ hyps, InHypsSeq ] + | [ "in" ssrclausehyps(hyps) "*" ] -> [ hyps, InHypsGoal ] + | [ "in" ssrclausehyps(hyps) ] -> [ hyps, InHyps ] + | [ "in" "|-" "*" ] -> [ [], InSeqGoal ] + | [ "in" "*" ] -> [ [], InAll ] + | [ "in" "*" "|-" ] -> [ [], InAllHyps ] + | [ ] -> [ [], InGoal ] +END + +let nohide = mkRel 0 +let hidden_goal_tag = "the_hidden_goal" + +(* Reduction that preserves the Prod/Let spine of the "in" tactical. *) + +let inc_safe n = if n = 0 then n else n + 1 +let rec safe_depth c = match kind_of_term c with +| LetIn (Name x, _, _, c') when is_discharged_id x -> safe_depth c' + 1 +| LetIn (_, _, _, c') | Prod (_, _, c') -> inc_safe (safe_depth c') +| _ -> 0 + +let red_safe r e s c0 = + let rec red_to e c n = match kind_of_term c with + | Prod (x, t, c') when n > 0 -> + let t' = r e s t in let e' = Environ.push_rel (x, None, t') e in + mkProd (x, t', red_to e' c' (n - 1)) + | LetIn (x, b, t, c') when n > 0 -> + let t' = r e s t in let e' = Environ.push_rel (x, None, t') e in + mkLetIn (x, r e s b, t', red_to e' c' (n - 1)) + | _ -> r e s c in + red_to e c0 (safe_depth c0) + +let check_wgen_uniq gens = + let clears = List.flatten (List.map fst gens) in + check_hyps_uniq [] clears; + let ids = CList.map_filter + (function (_,Some ((id,_),_)) -> Some (hoi_id id) | _ -> None) gens in + let rec check ids = function + | id :: _ when List.mem id ids -> + errorstrm (str"Duplicate generalization " ++ pr_id id) + | id :: hyps -> check (id :: ids) hyps + | [] -> () in + check [] ids + +let pf_clauseids gl gens clseq = + let keep_clears = List.map (fun x, _ -> x, None) in + if gens <> [] then (check_wgen_uniq gens; gens) else + if clseq <> InAll && clseq <> InAllHyps then keep_clears gens else + Errors.error "assumptions should be named explicitly" + +let hidden_clseq = function InHyps | InHypsSeq | InAllHyps -> true | _ -> false + +let hidetacs clseq idhide cl0 = + if not (hidden_clseq clseq) then [] else + [posetac idhide cl0; + Proofview.V82.of_tactic (convert_concl_no_check (mkVar idhide))] + +let discharge_hyp (id', (id, mode)) gl = + let cl' = subst_var id (pf_concl gl) in + match pf_get_hyp gl id, mode with + | (_, None, t), _ | (_, Some _, t), "(" -> + apply_type (mkProd (Name id', t, cl')) [mkVar id] gl + | (_, Some v, t), _ -> + Proofview.V82.of_tactic (convert_concl (mkLetIn (Name id', v, t, cl'))) gl + +let endclausestac id_map clseq gl_id cl0 gl = + let not_hyp' id = not (List.mem_assoc id id_map) in + let orig_id id = try List.assoc id id_map with _ -> id in + let dc, c = Term.decompose_prod_assum (pf_concl gl) in + let hide_goal = hidden_clseq clseq in + let c_hidden = hide_goal && c = mkVar gl_id in + let rec fits forced = function + | (id, _) :: ids, (Name id', _, _) :: dc' when id' = id -> + fits true (ids, dc') + | ids, dc' -> + forced && ids = [] && (not hide_goal || dc' = [] && c_hidden) in + let rec unmark c = match kind_of_term c with + | Var id when hidden_clseq clseq && id = gl_id -> cl0 + | Prod (Name id, t, c') when List.mem_assoc id id_map -> + mkProd (Name (orig_id id), unmark t, unmark c') + | LetIn (Name id, v, t, c') when List.mem_assoc id id_map -> + mkLetIn (Name (orig_id id), unmark v, unmark t, unmark c') + | _ -> map_constr unmark c in + let utac hyp = + Proofview.V82.of_tactic + (convert_hyp_no_check (map_named_declaration unmark hyp)) in + let utacs = List.map utac (pf_hyps gl) in + let ugtac gl' = + Proofview.V82.of_tactic + (convert_concl_no_check (unmark (pf_concl gl'))) gl' in + let ctacs = if hide_goal then [clear [gl_id]] else [] in + let mktac itacs = tclTHENLIST (itacs @ utacs @ ugtac :: ctacs) in + let itac (_, id) = Proofview.V82.of_tactic (introduction id) in + if fits false (id_map, List.rev dc) then mktac (List.map itac id_map) gl else + let all_ids = ids_of_rel_context dc @ pf_ids_of_hyps gl in + if List.for_all not_hyp' all_ids && not c_hidden then mktac [] gl else + Errors.error "tampering with discharged assumptions of \"in\" tactical" + +let is_id_constr c = match kind_of_term c with + | Lambda(_,_,c) when isRel c -> 1 = destRel c + | _ -> false + +let red_product_skip_id env sigma c = match kind_of_term c with + | App(hd,args) when Array.length args = 1 && is_id_constr hd -> args.(0) + | _ -> try Tacred.red_product env sigma c with _ -> c + +let abs_wgen keep_let ist f gen (gl,args,c) = + let sigma, env = project gl, pf_env gl in + let evar_closed t p = + if occur_existential t then + Errors.user_err_loc (loc_of_cpattern p,"ssreflect", + pr_constr_pat t ++ + str" contains holes and matches no subterm of the goal") in + match gen with + | _, Some ((x, mode), None) when mode = "@" || (mode = " " && keep_let) -> + let x = hoi_id x in + let _, bo, ty = pf_get_hyp gl x in + gl, + (if bo <> None then args else mkVar x :: args), + mkProd_or_LetIn (Name (f x),bo,ty) (subst_var x c) + | _, Some ((x, _), None) -> + let x = hoi_id x in + gl, mkVar x :: args, mkProd (Name (f x), pf_get_hyp_typ gl x, subst_var x c) + | _, Some ((x, "@"), Some p) -> + let x = hoi_id x in + let cp = interp_cpattern ist gl p None in + let (t, ucst), c = + try fill_occ_pattern ~raise_NoMatch:true env sigma c cp None 1 + with NoMatch -> redex_of_pattern env cp, c in + evar_closed t p; + let ut = red_product_skip_id env sigma t in + pf_merge_uc ucst gl, args, mkLetIn(Name (f x), ut, pf_type_of gl t, c) + | _, Some ((x, _), Some p) -> + let x = hoi_id x in + let cp = interp_cpattern ist gl p None in + let (t, ucst), c = + try fill_occ_pattern ~raise_NoMatch:true env sigma c cp None 1 + with NoMatch -> redex_of_pattern env cp, c in + evar_closed t p; + pf_merge_uc ucst gl, t :: args, mkProd(Name (f x), pf_type_of gl t, c) + | _ -> gl, args, c + +let clr_of_wgen gen clrs = match gen with + | clr, Some ((x, _), None) -> + let x = hoi_id x in + cleartac clr :: cleartac [SsrHyp(Loc.ghost,x)] :: clrs + | clr, _ -> cleartac clr :: clrs + +let tclCLAUSES ist tac (gens, clseq) gl = + if clseq = InGoal || clseq = InSeqGoal then tac gl else + let clr_gens = pf_clauseids gl gens clseq in + let clear = tclTHENLIST (List.rev(List.fold_right clr_of_wgen clr_gens [])) in + let gl_id = mk_anon_id hidden_goal_tag gl in + let cl0 = pf_concl gl in + let dtac gl = + let c = pf_concl gl in + let gl, args, c = + List.fold_right (abs_wgen true ist mk_discharged_id) gens (gl,[], c) in + apply_type c args gl in + let endtac = + let id_map = CList.map_filter (function + | _, Some ((x,_),_) -> let id = hoi_id x in Some (mk_discharged_id id, id) + | _, None -> None) gens in + endclausestac id_map clseq gl_id cl0 in + tclTHENLIST (hidetacs clseq gl_id cl0 @ [dtac; clear; tac; endtac]) gl +(* }}} *) + +(** Simpl switch *) + +type ssrsimpl = Simpl | Cut | SimplCut | Nop + +let pr_simpl = function + | Simpl -> str "/=" + | Cut -> str "//" + | SimplCut -> str "//=" + | Nop -> mt () + +let pr_ssrsimpl _ _ _ = pr_simpl + +let wit_ssrsimplrep = add_genarg "ssrsimplrep" pr_simpl + +ARGUMENT EXTEND ssrsimpl_ne TYPED AS ssrsimplrep PRINTED BY pr_ssrsimpl +| [ "/=" ] -> [ Simpl ] +| [ "//" ] -> [ Cut ] +| [ "//=" ] -> [ SimplCut ] +END + +ARGUMENT EXTEND ssrsimpl TYPED AS ssrsimplrep PRINTED BY pr_ssrsimpl +| [ ssrsimpl_ne(sim) ] -> [ sim ] +| [ ] -> [ Nop ] +END + +(* We must avoid zeta-converting any "let"s created by the "in" tactical. *) + +let safe_simpltac gl = + let cl' = red_safe Tacred.simpl (pf_env gl) (project gl) (pf_concl gl) in + Proofview.V82.of_tactic (convert_concl_no_check cl') gl + +let simpltac = function + | Simpl -> safe_simpltac + | Cut -> tclTRY donetac + | SimplCut -> tclTHEN safe_simpltac (tclTRY donetac) + | Nop -> tclIDTAC + +(** Rewriting direction *) + +let pr_dir = function L2R -> str "->" | R2L -> str "<-" +let pr_rwdir = function L2R -> mt() | R2L -> str "-" + +let rewritetac dir c = + (* Due to the new optional arg ?tac, application shouldn't be too partial *) + Proofview.V82.of_tactic begin + Equality.general_rewrite (dir = L2R) AllOccurrences true false c + end + +let wit_ssrdir = add_genarg "ssrdir" pr_dir + +let dir_org = function L2R -> 1 | R2L -> 2 + +(** Indexes *) + +(* Since SSR indexes are always positive numbers, we use the 0 value *) +(* to encode an omitted index. We reuse the in or_var type, but we *) +(* supply our own interpretation function, which checks for non *) +(* positive values, and allows the use of constr numerals, so that *) +(* e.g., "let n := eval compute in (1 + 3) in (do n!clear)" works. *) + +type ssrindex = int or_var + +let pr_index = function + | ArgVar (_, id) -> pr_id id + | ArgArg n when n > 0 -> int n + | _ -> mt () +let pr_ssrindex _ _ _ = pr_index + +let noindex = ArgArg 0 +let allocc = Some(false,[]) + +let check_index loc i = + if i > 0 then i else loc_error loc "Index not positive" +let mk_index loc = function ArgArg i -> ArgArg (check_index loc i) | iv -> iv + +let interp_index ist gl idx = + Tacmach.project gl, + match idx with + | ArgArg _ -> idx + | ArgVar (loc, id) -> + let i = + try + let v = Id.Map.find id ist.lfun in + begin match Value.to_int v with + | Some i -> i + | None -> + begin match Value.to_constr v with + | Some c -> + let rc = Detyping.detype false [] (pf_env gl) (project gl) c in + begin match Notation.uninterp_prim_token rc with + | _, Numeral bigi -> int_of_string (Bigint.to_string bigi) + | _ -> raise Not_found + end + | None -> raise Not_found + end end + with _ -> loc_error loc "Index not a number" in + ArgArg (check_index loc i) + +ARGUMENT EXTEND ssrindex TYPED AS int_or_var PRINTED BY pr_ssrindex + INTERPRETED BY interp_index +| [ int_or_var(i) ] -> [ mk_index loc i ] +END + +(** Occurrence switch *) + +(* The standard syntax of complemented occurrence lists involves a single *) +(* initial "-", e.g., {-1 3 5}. An initial *) +(* "+" may be used to indicate positive occurrences (the default). The *) +(* "+" is optional, except if the list of occurrences starts with a *) +(* variable or is empty (to avoid confusion with a clear switch). The *) +(* empty positive switch "{+}" selects no occurrences, while the empty *) +(* negative switch "{-}" selects all occurrences explicitly; this is the *) +(* default, but "{-}" prevents the implicit clear, and can be used to *) +(* force dependent elimination -- see ndefectelimtac below. *) + +type ssrocc = occ + +let pr_occ = function + | Some (true, occ) -> str "{-" ++ pr_list pr_spc int occ ++ str "}" + | Some (false, occ) -> str "{+" ++ pr_list pr_spc int occ ++ str "}" + | None -> str "{}" + +let pr_ssrocc _ _ _ = pr_occ + +ARGUMENT EXTEND ssrocc TYPED AS (bool * int list) option PRINTED BY pr_ssrocc +| [ natural(n) natural_list(occ) ] -> [ + Some (false, List.map (check_index loc) (n::occ)) ] +| [ "-" natural_list(occ) ] -> [ Some (true, occ) ] +| [ "+" natural_list(occ) ] -> [ Some (false, occ) ] +END + +let pf_mkprod gl c ?(name=constr_name c) cl = + let t = pf_type_of gl c in + if name <> Anonymous || noccurn 1 cl then mkProd (name, t, cl) else + mkProd (Name (pf_type_id gl t), t, cl) + +let pf_abs_prod name gl c cl = pf_mkprod gl c ~name (subst_term c cl) + +(** Discharge occ switch (combined occurrence / clear switch *) + +type ssrdocc = ssrclear option * ssrocc option + +let mkocc occ = None, occ +let noclr = mkocc None +let mkclr clr = Some clr, None +let nodocc = mkclr [] + +let pr_docc = function + | None, occ -> pr_occ occ + | Some clr, _ -> pr_clear mt clr + +let pr_ssrdocc _ _ _ = pr_docc + +ARGUMENT EXTEND ssrdocc TYPED AS ssrclear option * ssrocc PRINTED BY pr_ssrdocc +| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ mkclr clr ] +| [ "{" ssrocc(occ) "}" ] -> [ mkocc occ ] +END + +(** View hint database and View application. {{{ ******************************) + +(* There are three databases of lemmas used to mediate the application *) +(* of reflection lemmas: one for forward chaining, one for backward *) +(* chaining, and one for secondary backward chaining. *) + +(* View hints *) + +let rec isCxHoles = function (CHole _, None) :: ch -> isCxHoles ch | _ -> false + +let pr_raw_ssrhintref prc _ _ = function + | CAppExpl (_, (None, r,x), args) when isCHoles args -> + prc (CRef (r,x)) ++ str "|" ++ int (List.length args) + | CApp (_, (_, CRef _), _) as c -> prc c + | CApp (_, (_, c), args) when isCxHoles args -> + prc c ++ str "|" ++ int (List.length args) + | c -> prc c + +let pr_rawhintref = function + | GApp (_, f, args) when isRHoles args -> + pr_glob_constr f ++ str "|" ++ int (List.length args) + | c -> pr_glob_constr c + +let pr_glob_ssrhintref _ _ _ (c, _) = pr_rawhintref c + +let pr_ssrhintref prc _ _ = prc + +let mkhintref loc c n = match c with + | CRef (r,x) -> CAppExpl (loc, (None, r, x), mkCHoles loc n) + | _ -> mkAppC (c, mkCHoles loc n) + +ARGUMENT EXTEND ssrhintref + PRINTED BY pr_ssrhintref + RAW_TYPED AS constr RAW_PRINTED BY pr_raw_ssrhintref + GLOB_TYPED AS constr GLOB_PRINTED BY pr_glob_ssrhintref + | [ constr(c) ] -> [ c ] + | [ constr(c) "|" natural(n) ] -> [ mkhintref loc c n ] +END + +(* View purpose *) + +let pr_viewpos = function + | 0 -> str " for move/" + | 1 -> str " for apply/" + | 2 -> str " for apply//" + | _ -> mt () + +let pr_ssrviewpos _ _ _ = pr_viewpos + +ARGUMENT EXTEND ssrviewpos TYPED AS int PRINTED BY pr_ssrviewpos + | [ "for" "move" "/" ] -> [ 0 ] + | [ "for" "apply" "/" ] -> [ 1 ] + | [ "for" "apply" "/" "/" ] -> [ 2 ] + | [ "for" "apply" "//" ] -> [ 2 ] + | [ ] -> [ 3 ] +END + +let pr_ssrviewposspc _ _ _ i = pr_viewpos i ++ spc () + +ARGUMENT EXTEND ssrviewposspc TYPED AS ssrviewpos PRINTED BY pr_ssrviewposspc + | [ ssrviewpos(i) ] -> [ i ] +END + +(* The table and its display command *) + +let viewtab : glob_constr list array = Array.make 3 [] + +let _ = + let init () = Array.fill viewtab 0 3 [] in + let freeze _ = Array.copy viewtab in + let unfreeze vt = Array.blit vt 0 viewtab 0 3 in + Summary.declare_summary "ssrview" + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = init } + +let mapviewpos f n k = if n < 3 then f n else for i = 0 to k - 1 do f i done + +let print_view_hints i = + let pp_viewname = str "Hint View" ++ pr_viewpos i ++ str " " in + let pp_hints = pr_list spc pr_rawhintref viewtab.(i) in + ppnl (pp_viewname ++ hov 0 pp_hints ++ Pp.cut ()) + +VERNAC COMMAND EXTEND PrintView CLASSIFIED AS QUERY +| [ "Print" "Hint" "View" ssrviewpos(i) ] -> [ mapviewpos print_view_hints i 3 ] +END + +(* Populating the table *) + +let cache_viewhint (_, (i, lvh)) = + let mem_raw h = List.exists (Notation_ops.eq_glob_constr h) in + let add_hint h hdb = if mem_raw h hdb then hdb else h :: hdb in + viewtab.(i) <- List.fold_right add_hint lvh viewtab.(i) + +let subst_viewhint ( subst, (i, lvh as ilvh)) = + let lvh' = List.smartmap (Detyping.subst_glob_constr subst) lvh in + if lvh' == lvh then ilvh else i, lvh' + +let classify_viewhint x = Libobject.Substitute x + +let in_viewhint = + Libobject.declare_object {(Libobject.default_object "VIEW_HINTS") with + Libobject.open_function = (fun i o -> if i = 1 then cache_viewhint o); + Libobject.cache_function = cache_viewhint; + Libobject.subst_function = subst_viewhint; + Libobject.classify_function = classify_viewhint } + +let glob_view_hints lvh = + List.map (Constrintern.intern_constr (Global.env ())) lvh + +let add_view_hints lvh i = Lib.add_anonymous_leaf (in_viewhint (i, lvh)) + +VERNAC COMMAND EXTEND HintView CLASSIFIED AS QUERY + | [ "Hint" "View" ssrviewposspc(n) ne_ssrhintref_list(lvh) ] -> + [ mapviewpos (add_view_hints (glob_view_hints lvh)) n 2 ] +END + +(** Views *) + +(* Views for the "move" and "case" commands are actually open *) +(* terms, but this is handled by interp_view, which is called *) +(* by interp_casearg. We use lists, to support the *) +(* "double-view" feature of the apply command. *) + +(* type ssrview = ssrterm list *) + +let pr_view = pr_list mt (fun c -> str "/" ++ pr_term c) + +let pr_ssrview _ _ _ = pr_view + +ARGUMENT EXTEND ssrview TYPED AS ssrterm list + PRINTED BY pr_ssrview +| [ "/" constr(c) ] -> [ [mk_term ' ' c] ] +| [ "/" constr(c) ssrview(w) ] -> [ (mk_term ' ' c) :: w ] +END + +(* There are two ways of "applying" a view to term: *) +(* 1- using a view hint if the view is an instance of some *) +(* (reflection) inductive predicate. *) +(* 2- applying the view if it coerces to a function, adding *) +(* implicit arguments. *) +(* They require guessing the view hints and the number of *) +(* implicits, respectively, which we do by brute force. *) + +let view_error s gv = + errorstrm (str ("Cannot " ^ s ^ " view ") ++ pr_term gv) + +let interp_view ist si env sigma gv rid = + match intern_term ist sigma env gv with + | GApp (loc, GHole _, rargs) -> + let rv = GApp (loc, rid, rargs) in + snd (interp_open_constr ist (re_sig si sigma) (rv, None)) + | rv -> + let interp rc rargs = + interp_open_constr ist (re_sig si sigma) (mkRApp rc rargs, None) in + let rec simple_view rargs n = + if n < 0 then view_error "use" gv else + try interp rv rargs with _ -> simple_view (mkRHole :: rargs) (n - 1) in + let view_nbimps = interp_view_nbimps ist (re_sig si sigma) rv in + let view_args = [mkRApp rv (mkRHoles view_nbimps); rid] in + let rec view_with = function + | [] -> simple_view [rid] (interp_nbargs ist (re_sig si sigma) rv) + | hint :: hints -> try interp hint view_args with _ -> view_with hints in + snd (view_with (if view_nbimps < 0 then [] else viewtab.(0))) + +let top_id = mk_internal_id "top assumption" + +let with_view ist si env gl0 c name cl prune = + let c2r ist x = { ist with lfun = + Id.Map.add top_id (Value.of_constr x) ist.lfun } in + let rec loop (sigma, c') = function + | f :: view -> + let rid, ist = match kind_of_term c' with + | Var id -> mkRVar id, ist + | _ -> mkRltacVar top_id, c2r ist c' in + loop (interp_view ist si env sigma f rid) view + | [] -> + let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in + let c' = Reductionops.nf_evar sigma c' in + let n, c', _, ucst = pf_abs_evars gl0 (sigma, c') in + let c' = if not prune then c' else pf_abs_cterm gl0 n c' in + let gl0 = pf_merge_uc ucst gl0 in + pf_abs_prod name gl0 c' (prod_applist cl [c]), c', pf_merge_uc_of sigma gl0 + in loop + +let pf_with_view ist gl (prune, view) cl c = + let env, sigma, si = pf_env gl, project gl, sig_it gl in + with_view ist si env gl c (constr_name c) cl prune (sigma, c) view +(* }}} *) + +(** Extended intro patterns {{{ ***********************************************) + +type ssrtermrep = char * glob_constr_and_expr +type ssripat = + | IpatSimpl of ssrclear * ssrsimpl + | IpatId of identifier + | IpatWild + | IpatCase of ssripats list + | IpatRw of ssrocc * ssrdir + | IpatAll + | IpatAnon + | IpatView of ssrtermrep list + | IpatNoop + | IpatNewHidden of identifier list +and ssripats = ssripat list + +let remove_loc = snd + +let rec ipat_of_intro_pattern = function + | IntroNaming (IntroIdentifier id) -> IpatId id + | IntroAction IntroWildcard -> IpatWild + | IntroAction (IntroOrAndPattern iorpat) -> + IpatCase + (List.map (List.map ipat_of_intro_pattern) + (List.map (List.map remove_loc) iorpat)) + | IntroNaming IntroAnonymous -> IpatAnon + | IntroAction (IntroRewrite b) -> IpatRw (allocc, if b then L2R else R2L) + | IntroNaming (IntroFresh id) -> IpatAnon + | IntroAction (IntroApplyOn _) -> (* to do *) Errors.error "TO DO" + | IntroAction (IntroInjection ips) -> + IpatCase [List.map ipat_of_intro_pattern (List.map remove_loc ips)] + | IntroForthcoming _ -> (* Unable to determine which kind of ipat interp_introid could return [HH] *) + assert false + +let rec pr_ipat = function + | IpatId id -> pr_id id + | IpatSimpl (clr, sim) -> pr_clear mt clr ++ pr_simpl sim + | IpatCase iorpat -> hov 1 (str "[" ++ pr_iorpat iorpat ++ str "]") + | IpatRw (occ, dir) -> pr_occ occ ++ pr_dir dir + | IpatAll -> str "*" + | IpatWild -> str "_" + | IpatAnon -> str "?" + | IpatView v -> pr_view v + | IpatNoop -> str "-" + | IpatNewHidden l -> str "[:" ++ pr_list spc pr_id l ++ str "]" +and pr_iorpat iorpat = pr_list pr_bar pr_ipats iorpat +and pr_ipats ipats = pr_list spc pr_ipat ipats + +let wit_ssripatrep = add_genarg "ssripatrep" pr_ipat + +let pr_ssripat _ _ _ = pr_ipat +let pr_ssripats _ _ _ = pr_ipats +let pr_ssriorpat _ _ _ = pr_iorpat + +let intern_ipat ist ipat = + let rec check_pat = function + | IpatSimpl (clr, _) -> ignore (List.map (intern_hyp ist) clr) + | IpatCase iorpat -> List.iter (List.iter check_pat) iorpat + | _ -> () in + check_pat ipat; ipat + +let intern_ipats ist = List.map (intern_ipat ist) + +let interp_introid ist gl id = + try IntroNaming (IntroIdentifier (hyp_id (snd (interp_hyp ist gl (SsrHyp (dummy_loc, id)))))) + with _ -> snd(snd (interp_intro_pattern ist gl (dummy_loc,IntroNaming (IntroIdentifier id)))) + +let rec add_intro_pattern_hyps (loc, ipat) hyps = match ipat with + | IntroNaming (IntroIdentifier id) -> + if not_section_id id then SsrHyp (loc, id) :: hyps else + hyp_err loc "Can't delete section hypothesis " id + | IntroAction IntroWildcard -> hyps + | IntroAction (IntroOrAndPattern iorpat) -> + List.fold_right (List.fold_right add_intro_pattern_hyps) iorpat hyps + | IntroNaming IntroAnonymous -> [] + | IntroNaming (IntroFresh _) -> [] + | IntroAction (IntroRewrite _) -> hyps + | IntroAction (IntroInjection ips) -> List.fold_right add_intro_pattern_hyps ips hyps + | IntroAction (IntroApplyOn (c,pat)) -> add_intro_pattern_hyps pat hyps + | IntroForthcoming _ -> + (* As in ipat_of_intro_pattern, was unable to determine which kind + of ipat interp_introid could return [HH] *) assert false + +let rec interp_ipat ist gl = + let ltacvar id = Id.Map.mem id ist.lfun in + let rec interp = function + | IpatId id when ltacvar id -> + ipat_of_intro_pattern (interp_introid ist gl id) + | IpatSimpl (clr, sim) -> + let add_hyps (SsrHyp (loc, id) as hyp) hyps = + if not (ltacvar id) then hyp :: hyps else + add_intro_pattern_hyps (loc, (interp_introid ist gl id)) hyps in + let clr' = List.fold_right add_hyps clr [] in + check_hyps_uniq [] clr'; IpatSimpl (clr', sim) + | IpatCase iorpat -> IpatCase (List.map (List.map interp) iorpat) + | IpatNewHidden l -> + IpatNewHidden + (List.map (function + | IntroNaming (IntroIdentifier id) -> id + | _ -> assert false) + (List.map (interp_introid ist gl) l)) + | ipat -> ipat in + interp + +let interp_ipats ist gl l = project gl, List.map (interp_ipat ist gl) l + +let pushIpatRw = function + | pats :: orpat -> (IpatRw (allocc, L2R) :: pats) :: orpat + | [] -> [] + +let pushIpatNoop = function + | pats :: orpat -> (IpatNoop :: pats) :: orpat + | [] -> [] + +ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY pr_ssripats + INTERPRETED BY interp_ipats + GLOBALIZED BY intern_ipats + | [ "_" ] -> [ [IpatWild] ] + | [ "*" ] -> [ [IpatAll] ] + | [ ident(id) ] -> [ [IpatId id] ] + | [ "?" ] -> [ [IpatAnon] ] + | [ ssrsimpl_ne(sim) ] -> [ [IpatSimpl ([], sim)] ] + | [ ssrdocc(occ) "->" ] -> [ match occ with + | None, occ -> [IpatRw (occ, L2R)] + | Some clr, _ -> [IpatSimpl (clr, Nop); IpatRw (allocc, L2R)]] + | [ ssrdocc(occ) "<-" ] -> [ match occ with + | None, occ -> [IpatRw (occ, R2L)] + | Some clr, _ -> [IpatSimpl (clr, Nop); IpatRw (allocc, R2L)]] + | [ ssrdocc(occ) ] -> [ match occ with + | Some cl, _ -> check_hyps_uniq [] cl; [IpatSimpl (cl, Nop)] + | _ -> loc_error loc "Only identifiers are allowed here"] + | [ "->" ] -> [ [IpatRw (allocc, L2R)] ] + | [ "<-" ] -> [ [IpatRw (allocc, R2L)] ] + | [ "-" ] -> [ [IpatNoop] ] + | [ "-/" "=" ] -> [ [IpatNoop;IpatSimpl([],Simpl)] ] + | [ "-/=" ] -> [ [IpatNoop;IpatSimpl([],Simpl)] ] + | [ "-/" "/" ] -> [ [IpatNoop;IpatSimpl([],Cut)] ] + | [ "-//" ] -> [ [IpatNoop;IpatSimpl([],Cut)] ] + | [ "-/" "/=" ] -> [ [IpatNoop;IpatSimpl([],SimplCut)] ] + | [ "-//" "=" ] -> [ [IpatNoop;IpatSimpl([],SimplCut)] ] + | [ "-//=" ] -> [ [IpatNoop;IpatSimpl([],SimplCut)] ] + | [ ssrview(v) ] -> [ [IpatView v] ] + | [ "[" ":" ident_list(idl) "]" ] -> [ [IpatNewHidden idl] ] +END + +ARGUMENT EXTEND ssripats TYPED AS ssripat PRINTED BY pr_ssripats + | [ ssripat(i) ssripats(tl) ] -> [ i @ tl ] + | [ ] -> [ [] ] +END + +ARGUMENT EXTEND ssriorpat TYPED AS ssripat list PRINTED BY pr_ssriorpat +| [ ssripats(pats) "|" ssriorpat(orpat) ] -> [ pats :: orpat ] +| [ ssripats(pats) "|-" ">" ssriorpat(orpat) ] -> [ pats :: pushIpatRw orpat ] +| [ ssripats(pats) "|-" ssriorpat(orpat) ] -> [ pats :: pushIpatNoop orpat ] +| [ ssripats(pats) "|->" ssriorpat(orpat) ] -> [ pats :: pushIpatRw orpat ] +| [ ssripats(pats) "||" ssriorpat(orpat) ] -> [ pats :: [] :: orpat ] +| [ ssripats(pats) "|||" ssriorpat(orpat) ] -> [ pats :: [] :: [] :: orpat ] +| [ ssripats(pats) "||||" ssriorpat(orpat) ] -> [ [pats; []; []; []] @ orpat ] +| [ ssripats(pats) ] -> [ [pats] ] +END + +let reject_ssrhid strm = + match Compat.get_tok (stream_nth 0 strm) with + | Tok.KEYWORD "[" -> + (match Compat.get_tok (stream_nth 0 strm) with + | Tok.KEYWORD ":" -> raise Stream.Failure + | _ -> ()) + | _ -> () + +let test_nohidden = Gram.Entry.of_parser "test_ssrhid" reject_ssrhid + +ARGUMENT EXTEND ssrcpat TYPED AS ssripatrep PRINTED BY pr_ssripat + | [ "YouShouldNotTypeThis" ssriorpat(x) ] -> [ IpatCase x ] +END + +GEXTEND Gram + GLOBAL: ssrcpat; + ssrcpat: [[ test_nohidden; "["; iorpat = ssriorpat; "]" -> IpatCase iorpat ]]; +END + +GEXTEND Gram + GLOBAL: ssripat; + ssripat: [[ pat = ssrcpat -> [pat] ]]; +END + +ARGUMENT EXTEND ssripats_ne TYPED AS ssripat PRINTED BY pr_ssripats + | [ ssripat(i) ssripats(tl) ] -> [ i @ tl ] +END + +(* subsets of patterns *) +let check_ssrhpats loc w_binders ipats = + let err_loc s = Errors.user_err_loc (loc, "ssreflect", s) in + let clr, ipats = + let rec aux clr = function + | IpatSimpl (cl, Nop) :: tl -> aux (clr @ cl) tl + | IpatSimpl (cl, sim) :: tl -> clr @ cl, IpatSimpl ([], sim) :: tl + | tl -> clr, tl + in aux [] ipats in + let simpl, ipats = + match List.rev ipats with + | IpatSimpl ([],_) as s :: tl -> [s], List.rev tl + | _ -> [], ipats in + if simpl <> [] && not w_binders then + err_loc (str "No s-item allowed here: " ++ pr_ipats simpl); + let ipat, binders = + let rec loop ipat = function + | [] -> ipat, [] + | ( IpatId _| IpatAnon| IpatCase _| IpatRw _ as i) :: tl -> + if w_binders then + if simpl <> [] && tl <> [] then + err_loc(str"binders XOR s-item allowed here: "++pr_ipats(tl@simpl)) + else if not (List.for_all (function IpatId _ -> true | _ -> false) tl) + then err_loc (str "Only binders allowed here: " ++ pr_ipats tl) + else ipat @ [i], tl + else + if tl = [] then ipat @ [i], [] + else err_loc (str "No binder or s-item allowed here: " ++ pr_ipats tl) + | hd :: tl -> loop (ipat @ [hd]) tl + in loop [] ipats in + ((clr, ipat), binders), simpl + +let single loc = + function [x] -> x | _ -> loc_error loc "Only one intro pattern is allowed" + +let pr_hpats (((clr, ipat), binders), simpl) = + pr_clear mt clr ++ pr_ipats ipat ++ pr_ipats binders ++ pr_ipats simpl +let pr_ssrhpats _ _ _ = pr_hpats +let pr_ssrhpats_wtransp _ _ _ (_, x) = pr_hpats x + +ARGUMENT EXTEND ssrhpats TYPED AS ((ssrclear * ssripat) * ssripat) * ssripat +PRINTED BY pr_ssrhpats + | [ ssripats(i) ] -> [ check_ssrhpats loc true i ] +END + +ARGUMENT EXTEND ssrhpats_wtransp + TYPED AS bool * (((ssrclear * ssripat) * ssripat) * ssripat) + PRINTED BY pr_ssrhpats_wtransp + | [ ssripats(i) ] -> [ false,check_ssrhpats loc true i ] + | [ ssripats(i) "@" ssripats(j) ] -> [ true,check_ssrhpats loc true (i @ j) ] +END + +ARGUMENT EXTEND ssrhpats_nobs +TYPED AS ((ssrclear * ssripat) * ssripat) * ssripat PRINTED BY pr_ssrhpats + | [ ssripats(i) ] -> [ check_ssrhpats loc false i ] +END + +ARGUMENT EXTEND ssrrpat TYPED AS ssripatrep PRINTED BY pr_ssripat + | [ "->" ] -> [ IpatRw (allocc, L2R) ] + | [ "<-" ] -> [ IpatRw (allocc, R2L) ] +END + +type ssrintros = ssripats + +let pr_intros sep intrs = + if intrs = [] then mt() else sep () ++ str "=> " ++ pr_ipats intrs +let pr_ssrintros _ _ _ = pr_intros mt + +ARGUMENT EXTEND ssrintros_ne TYPED AS ssripat + PRINTED BY pr_ssrintros + | [ "=>" ssripats_ne(pats) ] -> [ pats ] +END + +ARGUMENT EXTEND ssrintros TYPED AS ssrintros_ne PRINTED BY pr_ssrintros + | [ ssrintros_ne(intrs) ] -> [ intrs ] + | [ ] -> [ [] ] +END + +let injecteq_id = mk_internal_id "injection equation" + +let pf_nb_prod gl = nb_prod (pf_concl gl) + +let rev_id = mk_internal_id "rev concl" + +let revtoptac n0 gl = + let n = pf_nb_prod gl - n0 in + let dc, cl = decompose_prod_n n (pf_concl gl) in + let dc' = dc @ [Name rev_id, compose_prod (List.rev dc) cl] in + let f = compose_lam dc' (mkEtaApp (mkRel (n + 1)) (-n) 1) in + refine (mkApp (f, [|Evarutil.mk_new_meta ()|])) gl + +let equality_inj l b id c gl = + let msg = ref "" in + try Proofview.V82.of_tactic (Equality.inj l b None c) gl + with + | Compat.Exc_located(_,Errors.UserError (_,s)) + | Errors.UserError (_,s) + when msg := Pp.string_of_ppcmds s; + !msg = "Not a projectable equality but a discriminable one." || + !msg = "Nothing to inject." -> + msg_warning (str !msg); + discharge_hyp (id, (id, "")) gl + +let injectidl2rtac id c gl = + tclTHEN (equality_inj None true id c) (revtoptac (pf_nb_prod gl)) gl + +let injectl2rtac c = match kind_of_term c with +| Var id -> injectidl2rtac id (mkVar id, NoBindings) +| _ -> + let id = injecteq_id in + tclTHENLIST [havetac id c; injectidl2rtac id (mkVar id, NoBindings); clear [id]] + +let is_injection_case c gl = + let (mind,_), _ = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in + eq_gr (IndRef mind) (build_coq_eq ()) + +let perform_injection c gl = + let mind, t = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in + let dc, eqt = decompose_prod t in + if dc = [] then injectl2rtac c gl else + if not (closed0 eqt) then + Errors.error "can't decompose a quantified equality" else + let cl = pf_concl gl in let n = List.length dc in + let c_eq = mkEtaApp c n 2 in + let cl1 = mkLambda (Anonymous, mkArrow eqt cl, mkApp (mkRel 1, [|c_eq|])) in + let id = injecteq_id in + let id_with_ebind = (mkVar id, NoBindings) in + let injtac = tclTHEN (introid id) (injectidl2rtac id id_with_ebind) in + tclTHENLAST (Proofview.V82.of_tactic (apply (compose_lam dc cl1))) injtac gl + +let simplest_newcase_ref = ref (fun t gl -> assert false) +let simplest_newcase x gl = !simplest_newcase_ref x gl + +let ssrscasetac c gl = + if is_injection_case c gl then perform_injection c gl + else simplest_newcase c gl + +let intro_all gl = + let dc, _ = Term.decompose_prod_assum (pf_concl gl) in + tclTHENLIST (List.map anontac (List.rev dc)) gl + +let rec intro_anon gl = + try anontac (List.hd (fst (Term.decompose_prod_n_assum 1 (pf_concl gl)))) gl + with err0 -> try tclTHEN red_in_concl intro_anon gl with _ -> raise err0 + (* with _ -> Errors.error "No product even after reduction" *) + +let with_top tac = + tclTHENLIST [introid top_id; tac (mkVar top_id); clear [top_id]] + +let rec mapLR f = function [] -> [] | x :: s -> let y = f x in y :: mapLR f s + +let wild_ids = ref [] + +let new_wild_id () = + let i = 1 + List.length !wild_ids in + let id = mk_wildcard_id i in + wild_ids := id :: !wild_ids; + id + +let clear_wilds wilds gl = + clear (List.filter (fun id -> List.mem id wilds) (pf_ids_of_hyps gl)) gl + +let clear_with_wilds wilds clr0 gl = + let extend_clr clr (id, _, _ as nd) = + if List.mem id clr || not (List.mem id wilds) then clr else + let vars = global_vars_set_of_decl (pf_env gl) nd in + let occurs id' = Idset.mem id' vars in + if List.exists occurs clr then id :: clr else clr in + clear (Context.fold_named_context_reverse extend_clr ~init:clr0 (pf_hyps gl)) gl + +let tclTHENS_nonstrict tac tacl taclname gl = + let tacres = tac gl in + let n_gls = List.length (sig_it tacres) in + let n_tac = List.length tacl in + if n_gls = n_tac then tclTHENS (fun _ -> tacres) tacl gl else + if n_gls = 0 then tacres else + let pr_only n1 n2 = if n1 < n2 then str "only " else mt () in + let pr_nb n1 n2 name = + pr_only n1 n2 ++ int n1 ++ str (" " ^ String.plural n1 name) in + errorstrm (pr_nb n_tac n_gls taclname ++ spc () + ++ str "for " ++ pr_nb n_gls n_tac "subgoal") + +(* Forward reference to extended rewrite *) +let ipat_rewritetac = ref (fun _ -> rewritetac) + +let rec is_name_in_ipats name = function + | IpatSimpl(clr,_) :: tl -> + List.exists (function SsrHyp(_,id) -> id = name) clr + || is_name_in_ipats name tl + | IpatId id :: tl -> id = name || is_name_in_ipats name tl + | IpatCase l :: tl -> is_name_in_ipats name (List.flatten l @ tl) + | _ :: tl -> is_name_in_ipats name tl + | [] -> false + +let move_top_with_view = ref (fun _ -> assert false) + +let rec nat_of_n n = + if n = 0 then mkConstruct path_of_O + else mkApp (mkConstruct path_of_S, [|nat_of_n (n-1)|]) + +let ssr_abstract_id = Summary.ref "~name:SSR:abstractid" 0 + +let mk_abstract_id () = incr ssr_abstract_id; nat_of_n !ssr_abstract_id + +let ssrmkabs id gl = + let env, concl = pf_env gl, pf_concl gl in + let step sigma = + let sigma, abstract_proof, abstract_ty = + let sigma, (ty, _) = + Evarutil.new_type_evar env sigma Evd.univ_flexible_alg in + let sigma, ablock = mkSsrConst "abstract_lock" env sigma in + let sigma, lock = Evarutil.new_evar env sigma ablock in + let sigma, abstract = mkSsrConst "abstract" env sigma in + let abstract_ty = mkApp(abstract, [|ty;mk_abstract_id ();lock|]) in + let sigma, m = Evarutil.new_evar env sigma abstract_ty in + sigma, m, abstract_ty in + let sigma, kont = + let rd = Name id, None, abstract_ty in + Evarutil.new_evar (Environ.push_rel rd env) sigma concl in + pp(lazy(pr_constr concl)); + let term = mkApp (mkLambda(Name id,abstract_ty,kont) ,[|abstract_proof|]) in + let sigma, _ = Typing.e_type_of env sigma term in + sigma, term in + Proofview.V82.of_tactic + (Proofview.tclTHEN + (Tactics.New.refine step) + (Proofview.tclFOCUS 1 3 Proofview.shelve)) gl + +let ssrmkabstac ids = + List.fold_right (fun id tac -> tclTHENFIRST (ssrmkabs id) tac) ids tclIDTAC + +(* introstac: for "move" and "clear", tclEQINTROS: for "case" and "elim" *) +(* This block hides the spaghetti-code needed to implement the only two *) +(* tactics that should be used to process intro patters. *) +(* The difficulty is that we don't want to always rename, but we can *) +(* compute needeed renamings only at runtime, so we theread a tree like *) +(* imperativestructure so that outer renamigs are inherited by inner *) +(* ipts and that the cler performed at the end of ipatstac clears hyps *) +(* eventually renamed at runtime. *) +(* TODO: hide wild_ids in this block too *) +let introstac, tclEQINTROS = + let rec map_acc_k f k = function + | [] -> (* tricky: we save wilds now, we get to_cler (aka k) later *) + let clear_ww = clear_with_wilds !wild_ids in + [fun gl -> clear_ww (hyps_ids (List.flatten (List.map (!) k))) gl] + | x :: xs -> let k, x = f k xs x in x :: map_acc_k f k xs in + let rename force to_clr rest clr gl = + let hyps = pf_hyps gl in + pp(lazy(str"rename " ++ pr_clear spc clr)); + let () = if not force then List.iter (check_hyp_exists hyps) clr in + if List.exists (fun x -> force || is_name_in_ipats (hyp_id x) rest) clr then + let ren_clr, ren = + List.split (List.map (fun x -> let x = hyp_id x in + let x' = mk_anon_id (string_of_id x) gl in + SsrHyp (dummy_loc, x'), (x, x')) clr) in + let () = to_clr := ren_clr in + Proofview.V82.of_tactic (rename_hyp ren) gl + else + let () = to_clr := clr in + tclIDTAC gl in + let rec ipattac ?ist k rest = function + | IpatWild -> k, introid (new_wild_id ()) + | IpatCase iorpat -> k, tclIORPAT ?ist k (with_top ssrscasetac) iorpat + | IpatRw (occ, dir) -> k, with_top (!ipat_rewritetac occ dir) + | IpatId id -> k, introid id + | IpatNewHidden idl -> k, ssrmkabstac idl + | IpatSimpl (clr, sim) -> + let to_clr = ref [] in + to_clr :: k, tclTHEN (rename false to_clr rest clr) (simpltac sim) + | IpatAll -> k, intro_all + | IpatAnon -> k, intro_anon + | IpatNoop -> k, tclIDTAC + | IpatView v -> match ist with + | None -> anomaly "ipattac with no ist but view" + | Some ist -> match rest with + | (IpatCase _ | IpatRw _)::_ -> + let to_clr = ref [] in let top_id = ref top_id in + to_clr :: k, + tclTHEN + (!move_top_with_view false top_id (false,v) ist) + (fun gl -> + rename true to_clr rest [SsrHyp (dummy_loc, !top_id)]gl) + | _ -> k, !move_top_with_view true (ref top_id) (true,v) ist + and tclIORPAT ?ist k tac = function + | [[]] -> tac + | orp -> + tclTHENS_nonstrict tac (mapLR (ipatstac ?ist k) orp) "intro pattern" + and ipatstac ?ist k ipats = + tclTHENLIST (map_acc_k (ipattac ?ist) k ipats) in + let introstac ?ist ipats = + wild_ids := []; + let tac = ipatstac ?ist [] ipats in + tclTHENLIST [tac; clear_wilds !wild_ids] in + let tclEQINTROS ?ist tac eqtac ipats = + wild_ids := []; + let rec split_itacs to_clr tac' = function + | (IpatSimpl _ as spat) :: ipats' -> + let to_clr, tac = ipattac ?ist to_clr ipats' spat in + split_itacs to_clr (tclTHEN tac' tac) ipats' + | IpatCase iorpat :: ipats' -> + to_clr, tclIORPAT ?ist to_clr tac' iorpat, ipats' + | ipats' -> to_clr, tac', ipats' in + let to_clr, tac1, ipats' = split_itacs [] tac ipats in + let tac2 = ipatstac ?ist to_clr ipats' in + tclTHENLIST [tac1; eqtac; tac2; clear_wilds !wild_ids] in + introstac, tclEQINTROS +;; + +let rec eqmoveipats eqpat = function + | (IpatSimpl _ as ipat) :: ipats -> ipat :: eqmoveipats eqpat ipats + | (IpatAll :: _ | []) as ipats -> IpatAnon :: eqpat :: ipats + | ipat :: ipats -> ipat :: eqpat :: ipats + +(* General case *) +let tclINTROS ist tac ipats = + tclEQINTROS ~ist (tac ist) tclIDTAC ipats + +(** The "=>" tactical *) + +let ssrintros_sep = + let atom_sep = function + | TacSplit (_, [NoBindings]) -> mt + (* | TacExtend (_, "ssrapply", []) -> mt *) + | _ -> spc in + function + | TacId [] -> mt + | TacArg (_, Tacexp _) -> mt + | TacArg (_, Reference _) -> mt + | TacAtom (_, atom) -> atom_sep atom + | _ -> spc + +let pr_ssrintrosarg _ _ prt (tac, ipats) = + prt tacltop tac ++ pr_intros (ssrintros_sep tac) ipats + +ARGUMENT EXTEND ssrintrosarg TYPED AS tactic * ssrintros + PRINTED BY pr_ssrintrosarg +| [ "YouShouldNotTypeThis" ssrtacarg(arg) ssrintros_ne(ipats) ] -> [ arg, ipats ] +END + +TACTIC EXTEND ssrtclintros +| [ "YouShouldNotTypeThis" ssrintrosarg(arg) ] -> + [ let tac, intros = arg in + Proofview.V82.tactic (tclINTROS ist (fun ist -> ssrevaltac ist tac) intros) ] +END +set_pr_ssrtac "tclintros" 0 [ArgSsr "introsarg"] + +let tclintros_expr loc tac ipats = + let args = [in_gen (rawwit wit_ssrintrosarg) (tac, ipats)] in + ssrtac_expr loc "tclintros" args + +GEXTEND Gram + GLOBAL: tactic_expr; + tactic_expr: LEVEL "1" [ RIGHTA + [ tac = tactic_expr; intros = ssrintros_ne -> tclintros_expr !@loc tac intros + ] ]; +END +(* }}} *) + +(** Multipliers {{{ ***********************************************************) + +(* modality *) + +type ssrmmod = May | Must | Once + +let pr_mmod = function May -> str "?" | Must -> str "!" | Once -> mt () + +let wit_ssrmmod = add_genarg "ssrmmod" pr_mmod +let ssrmmod = Pcoq.create_generic_entry "ssrmmod" (Genarg.rawwit wit_ssrmmod) +GEXTEND Gram + GLOBAL: ssrmmod; + ssrmmod: [[ "!" -> Must | LEFTQMARK -> May | "?" -> May]]; +END + +(* tactical *) + +let tclID tac = tac + +let tclDOTRY n tac = + if n <= 0 then tclIDTAC else + let rec loop i gl = + if i = n then tclTRY tac gl else + tclTRY (tclTHEN tac (loop (i + 1))) gl in + loop 1 + +let tclDO n tac = + let prefix i = str"At iteration " ++ int i ++ str": " in + let tac_err_at i gl = + try tac gl + with + | Errors.UserError (l, s) as e -> + let _, info = Errors.push e in + let e' = Errors.UserError (l, prefix i ++ s) in + Util.iraise (e', info) + | Compat.Exc_located(loc, Errors.UserError (l, s)) -> + raise (Compat.Exc_located(loc, Errors.UserError (l, prefix i ++ s))) in + let rec loop i gl = + if i = n then tac_err_at i gl else + (tclTHEN (tac_err_at i) (loop (i + 1))) gl in + loop 1 + +let tclMULT = function + | 0, May -> tclREPEAT + | 1, May -> tclTRY + | n, May -> tclDOTRY n + | 0, Must -> tclAT_LEAST_ONCE + | n, Must when n > 1 -> tclDO n + | _ -> tclID + +(** The "do" tactical. ********************************************************) + +(* +type ssrdoarg = ((ssrindex * ssrmmod) * ssrhint) * ssrclauses +*) + +let pr_ssrdoarg prc _ prt (((n, m), tac), clauses) = + pr_index n ++ pr_mmod m ++ pr_hintarg prt tac ++ pr_clauses clauses + +ARGUMENT EXTEND ssrdoarg + TYPED AS ((ssrindex * ssrmmod) * ssrhintarg) * ssrclauses + PRINTED BY pr_ssrdoarg +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let ssrdotac ist (((n, m), tac), clauses) = + let mul = get_index n, m in + tclCLAUSES ist (tclMULT mul (hinttac ist false tac)) clauses + +TACTIC EXTEND ssrtcldo +| [ "YouShouldNotTypeThis" "do" ssrdoarg(arg) ] -> [ Proofview.V82.tactic (ssrdotac ist arg) ] +END +set_pr_ssrtac "tcldo" 3 [ArgSep "do "; ArgSsr "doarg"] + +let ssrdotac_expr loc n m tac clauses = + let arg = ((n, m), tac), clauses in + ssrtac_expr loc "tcldo" [in_gen (rawwit wit_ssrdoarg) arg] + +GEXTEND Gram + GLOBAL: tactic_expr; + ssrdotac: [ + [ tac = tactic_expr LEVEL "3" -> mk_hint tac + | tacs = ssrortacarg -> tacs + ] ]; + tactic_expr: LEVEL "3" [ RIGHTA + [ IDENT "do"; m = ssrmmod; tac = ssrdotac; clauses = ssrclauses -> + ssrdotac_expr !@loc noindex m tac clauses + | IDENT "do"; tac = ssrortacarg; clauses = ssrclauses -> + ssrdotac_expr !@loc noindex Once tac clauses + | IDENT "do"; n = int_or_var; m = ssrmmod; + tac = ssrdotac; clauses = ssrclauses -> + ssrdotac_expr !@loc (mk_index !@loc n) m tac clauses + ] ]; +END +(* }}} *) + +(** The "first" and "last" tacticals. {{{ *************************************) + +(* type ssrseqarg = ssrindex * (ssrtacarg * ssrtac option) *) + +let pr_seqtacarg prt = function + | (is_first, []), _ -> str (if is_first then "first" else "last") + | tac, Some dtac -> + hv 0 (pr_hintarg prt tac ++ spc() ++ str "|| " ++ prt tacltop dtac) + | tac, _ -> pr_hintarg prt tac + +let pr_ssrseqarg _ _ prt = function + | ArgArg 0, tac -> pr_seqtacarg prt tac + | i, tac -> pr_index i ++ str " " ++ pr_seqtacarg prt tac + +(* We must parse the index separately to resolve the conflict with *) +(* an unindexed tactic. *) +ARGUMENT EXTEND ssrseqarg TYPED AS ssrindex * (ssrhintarg * tactic option) + PRINTED BY pr_ssrseqarg +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let sq_brace_tacnames = + ["first"; "solve"; "do"; "rewrite"; "have"; "suffices"; "wlog"] + (* "by" is a keyword *) +let accept_ssrseqvar strm = + match Compat.get_tok (stream_nth 0 strm) with + | Tok.IDENT id when not (List.mem id sq_brace_tacnames) -> + accept_before_syms_or_ids ["["] ["first";"last"] strm + | _ -> raise Stream.Failure + +let test_ssrseqvar = Gram.Entry.of_parser "test_ssrseqvar" accept_ssrseqvar + +let swaptacarg (loc, b) = (b, []), Some (TacId []) + +let check_seqtacarg dir arg = match snd arg, dir with + | ((true, []), Some (TacAtom (loc, _))), L2R -> + loc_error loc "expected \"last\"" + | ((false, []), Some (TacAtom (loc, _))), R2L -> + loc_error loc "expected \"first\"" + | _, _ -> arg + +let ssrorelse = Gram.Entry.create "ssrorelse" +GEXTEND Gram + GLOBAL: ssrorelse ssrseqarg; + ssrseqidx: [ + [ test_ssrseqvar; id = Prim.ident -> ArgVar (!@loc, id) + | n = Prim.natural -> ArgArg (check_index !@loc n) + ] ]; + ssrswap: [[ IDENT "first" -> !@loc, true | IDENT "last" -> !@loc, false ]]; + ssrorelse: [[ "||"; tac = tactic_expr LEVEL "2" -> tac ]]; + ssrseqarg: [ + [ arg = ssrswap -> noindex, swaptacarg arg + | i = ssrseqidx; tac = ssrortacarg; def = OPT ssrorelse -> i, (tac, def) + | i = ssrseqidx; arg = ssrswap -> i, swaptacarg arg + | tac = tactic_expr LEVEL "3" -> noindex, (mk_hint tac, None) + ] ]; +END + +let tclPERM perm tac gls = + let subgls = tac gls in + let sigma, subgll = Refiner.unpackage subgls in + let subgll' = perm subgll in + Refiner.repackage sigma subgll' +(* +let tclPERM perm tac gls = + let mkpft n g r = + {Proof_type.open_subgoals = n; Proof_type.goal = g; Proof_type.ref = r} in + let mkleaf g = mkpft 0 g None in + let mkprpft n g pr a = mkpft n g (Some (Proof_type.Prim pr, a)) in + let mkrpft n g c = mkprpft n g (Proof_type.Refine c) in + let mkipft n g = + let mki pft (id, _, _ as d) = + let g' = {g with evar_concl = mkNamedProd_or_LetIn d g.evar_concl} in + mkprpft n g' (Proof_type.Intro id) [pft] in + List.fold_left mki in + let gl = Refiner.sig_it gls in + let mkhyp subgl = + let rec chop_section = function + | (x, _, _ as d) :: e when not_section_id x -> d :: chop_section e + | _ -> [] in + let lhyps = Environ.named_context_of_val subgl.evar_hyps in + mk_perm_id (), subgl, chop_section lhyps in + let mkpfvar (hyp, subgl, lhyps) = + let mkarg args (lhyp, body, _) = + if body = None then mkVar lhyp :: args else args in + mkrpft 0 subgl (applist (mkVar hyp, List.fold_left mkarg [] lhyps)) [] in + let mkpfleaf (_, subgl, lhyps) = mkipft 1 gl (mkleaf subgl) lhyps in + let mkmeta _ = Evarutil.mk_new_meta () in + let mkhypdecl (hyp, subgl, lhyps) = + hyp, None, it_mkNamedProd_or_LetIn subgl.evar_concl lhyps in + let subgls, v as res0 = tac gls in + let sigma, subgll = Refiner.unpackage subgls in + let n = List.length subgll in if n = 0 then res0 else + let hyps = List.map mkhyp subgll in + let hyp_decls = List.map mkhypdecl (List.rev (perm hyps)) in + let c = applist (mkmeta (), List.map mkmeta subgll) in + let pft0 = mkipft 0 gl (v (List.map mkpfvar hyps)) hyp_decls in + let pft1 = mkrpft n gl c (pft0 :: List.map mkpfleaf (perm hyps)) in + let subgll', v' = Refiner.frontier pft1 in + Refiner.repackage sigma subgll', v' +*) + +let tclREV tac gl = tclPERM List.rev tac gl + +let rot_hyps dir i hyps = + let n = List.length hyps in + if i = 0 then List.rev hyps else + if i > n then Errors.error "Not enough subgoals" else + let rec rot i l_hyps = function + | hyp :: hyps' when i > 0 -> rot (i - 1) (hyp :: l_hyps) hyps' + | hyps' -> hyps' @ (List.rev l_hyps) in + rot (match dir with L2R -> i | R2L -> n - i) [] hyps + +let tclSEQAT ist atac1 dir (ivar, ((_, atacs2), atac3)) = + let i = get_index ivar in + let evtac = ssrevaltac ist in + let tac1 = evtac atac1 in + if atacs2 = [] && atac3 <> None then tclPERM (rot_hyps dir i) tac1 else + let evotac = function Some atac -> evtac atac | _ -> tclIDTAC in + let tac3 = evotac atac3 in + let rec mk_pad n = if n > 0 then tac3 :: mk_pad (n - 1) else [] in + match dir, mk_pad (i - 1), List.map evotac atacs2 with + | L2R, [], [tac2] when atac3 = None -> tclTHENFIRST tac1 tac2 + | L2R, [], [tac2] when atac3 = None -> tclTHENLAST tac1 tac2 + | L2R, pad, tacs2 -> tclTHENSFIRSTn tac1 (Array.of_list (pad @ tacs2)) tac3 + | R2L, pad, tacs2 -> tclTHENSLASTn tac1 tac3 (Array.of_list (tacs2 @ pad)) + +(* We can't actually parse the direction separately because this *) +(* would introduce conflicts with the basic ltac syntax. *) +let pr_ssrseqdir _ _ _ = function + | L2R -> str ";" ++ spc () ++ str "first " + | R2L -> str ";" ++ spc () ++ str "last " + +ARGUMENT EXTEND ssrseqdir TYPED AS ssrdir PRINTED BY pr_ssrseqdir +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +TACTIC EXTEND ssrtclseq +| [ "YouShouldNotTypeThis" ssrtclarg(tac) ssrseqdir(dir) ssrseqarg(arg) ] -> + [ Proofview.V82.tactic (tclSEQAT ist tac dir arg) ] +END +set_pr_ssrtac "tclseq" 5 [ArgSsr "tclarg"; ArgSsr "seqdir"; ArgSsr "seqarg"] + +let tclseq_expr loc tac dir arg = + let arg1 = in_gen (rawwit wit_ssrtclarg) tac in + let arg2 = in_gen (rawwit wit_ssrseqdir) dir in + let arg3 = in_gen (rawwit wit_ssrseqarg) (check_seqtacarg dir arg) in + ssrtac_expr loc "tclseq" [arg1; arg2; arg3] + +GEXTEND Gram + GLOBAL: tactic_expr; + ssr_first: [ + [ tac = ssr_first; ipats = ssrintros_ne -> tclintros_expr !@loc tac ipats + | "["; tacl = LIST0 tactic_expr SEP "|"; "]" -> TacFirst tacl + ] ]; + ssr_first_else: [ + [ tac1 = ssr_first; tac2 = ssrorelse -> TacOrelse (tac1, tac2) + | tac = ssr_first -> tac ]]; + tactic_expr: LEVEL "4" [ LEFTA + [ tac1 = tactic_expr; ";"; IDENT "first"; tac2 = ssr_first_else -> + TacThen (tac1, tac2) + | tac = tactic_expr; ";"; IDENT "first"; arg = ssrseqarg -> + tclseq_expr !@loc tac L2R arg + | tac = tactic_expr; ";"; IDENT "last"; arg = ssrseqarg -> + tclseq_expr !@loc tac R2L arg + ] ]; +END +(* }}} *) + +(** 5. Bookkeeping tactics (clear, move, case, elim) *) + +(* post-interpretation of terms *) +let all_ok _ _ = true + +let pf_abs_ssrterm ?(resolve_typeclasses=false) ist gl t = + let sigma, ct as t = interp_term ist gl t in + let sigma, _ as t = + let env = pf_env gl in + if not resolve_typeclasses then t + else + let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in + sigma, Evarutil.nf_evar sigma ct in + let n, c, abstracted_away, ucst = pf_abs_evars gl t in + List.fold_left Evd.remove sigma abstracted_away, pf_abs_cterm gl n c, ucst + +let pf_interp_ty ?(resolve_typeclasses=false) ist gl ty = + let n_binders = ref 0 in + let ty = match ty with + | a, (t, None) -> + let rec force_type = function + | GProd (l, x, k, s, t) -> incr n_binders; GProd (l, x, k, s, force_type t) + | GLetIn (l, x, v, t) -> incr n_binders; GLetIn (l, x, v, force_type t) + | ty -> mkRCast ty mkRType in + a, (force_type t, None) + | _, (_, Some ty) -> + let rec force_type = function + | CProdN (l, abs, t) -> + n_binders := !n_binders + List.length (List.flatten (List.map pi1 abs)); + CProdN (l, abs, force_type t) + | CLetIn (l, n, v, t) -> incr n_binders; CLetIn (l, n, v, force_type t) + | ty -> mkCCast dummy_loc ty (mkCType dummy_loc) in + mk_term ' ' (force_type ty) in + let strip_cast (sigma, t) = + let rec aux t = match kind_of_type t with + | CastType (t, ty) when !n_binders = 0 && isSort ty -> t + | ProdType(n,s,t) -> decr n_binders; mkProd (n, s, aux t) + | LetInType(n,v,ty,t) -> decr n_binders; mkLetIn (n, v, ty, aux t) + | _ -> anomaly "pf_interp_ty: ssr Type cast deleted by typecheck" in + sigma, aux t in + let sigma, cty as ty = strip_cast (interp_term ist gl ty) in + let ty = + let env = pf_env gl in + if not resolve_typeclasses then ty + else + let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in + sigma, Evarutil.nf_evar sigma cty in + let n, c, _, ucst = pf_abs_evars gl ty in + let lam_c = pf_abs_cterm gl n c in + let ctx, c = decompose_lam_n n lam_c in + n, compose_prod ctx c, lam_c, ucst +;; + +let whd_app f args = Reductionops.whd_betaiota Evd.empty (mkApp (f, args)) + +let pr_cargs a = + str "[" ++ pr_list pr_spc pr_constr (Array.to_list a) ++ str "]" + +let pp_term gl t = + let t = Reductionops.nf_evar (project gl) t in pr_constr t +let pp_concat hd ?(sep=str", ") = function [] -> hd | x :: xs -> + hd ++ List.fold_left (fun acc x -> acc ++ sep ++ x) x xs + +let fake_pmatcher_end () = + mkProp, L2R, (Evd.empty, Evd.empty_evar_universe_context, mkProp) + +(* TASSI: given (c : ty), generates (c ??? : ty[???/...]) with m evars *) +exception NotEnoughProducts +let prof_saturate_whd = mk_profiler "saturate.whd";; +let saturate ?(beta=false) ?(bi_types=false) env sigma c ?(ty=Retyping.get_type_of env sigma c) m += + let rec loop ty args sigma n = + if n = 0 then + let args = List.rev args in + (if beta then Reductionops.whd_beta sigma else fun x -> x) + (mkApp (c, Array.of_list (List.map snd args))), ty, args, sigma + else match kind_of_type ty with + | ProdType (_, src, tgt) -> + let sigma, x = + Evarutil.new_evar env (create_evar_defs sigma) + (if bi_types then Reductionops.nf_betaiota sigma src else src) in + loop (subst1 x tgt) ((m - n,x) :: args) sigma (n-1) + | CastType (t, _) -> loop t args sigma n + | LetInType (_, v, _, t) -> loop (subst1 v t) args sigma n + | SortType _ -> assert false + | AtomicType _ -> + let ty = + prof_saturate_whd.profile + (Reductionops.whd_betadeltaiota env sigma) ty in + match kind_of_type ty with + | ProdType _ -> loop ty args sigma n + | _ -> anomaly "saturate did not find enough products" + in + loop ty [] sigma m + +let pf_saturate ?beta ?bi_types gl c ?ty m = + let env, sigma, si = pf_env gl, project gl, sig_it gl in + let t, ty, args, sigma = saturate ?beta ?bi_types env sigma c ?ty m in + t, ty, args, re_sig si sigma + +(** Rewrite redex switch *) + +(** Generalization (discharge) item *) + +(* An item is a switch + term pair. *) + +(* type ssrgen = ssrdocc * ssrterm *) + +let pr_gen (docc, dt) = pr_docc docc ++ pr_cpattern dt + +let pr_ssrgen _ _ _ = pr_gen + +ARGUMENT EXTEND ssrgen TYPED AS ssrdocc * cpattern PRINTED BY pr_ssrgen +| [ ssrdocc(docc) cpattern(dt) ] -> [ docc, dt ] +| [ cpattern(dt) ] -> [ nodocc, dt ] +END + +let has_occ ((_, occ), _) = occ <> None +let hyp_of_var v = SsrHyp (dummy_loc, destVar v) + +let interp_clr = function +| Some clr, (k, c) + when (k = ' ' || k = '@') && is_pf_var c -> hyp_of_var c :: clr +| Some clr, _ -> clr +| None, _ -> [] + +(* XXX the k of the redex should percolate out *) +let pf_interp_gen_aux ist gl to_ind ((oclr, occ), t) = + let pat = interp_cpattern ist gl t None in (* UGLY API *) + let cl, env, sigma = pf_concl gl, pf_env gl, project gl in + let (c, ucst), cl = + try fill_occ_pattern ~raise_NoMatch:true env sigma cl pat occ 1 + with NoMatch -> redex_of_pattern env pat, cl in + let clr = interp_clr (oclr, (tag_of_cpattern t, c)) in + if not(occur_existential c) then + if tag_of_cpattern t = '@' then + if not (isVar c) then + errorstrm (str "@ can be used with variables only") + else match pf_get_hyp gl (destVar c) with + | _, None, _ -> errorstrm (str "@ can be used with let-ins only") + | name, Some bo, ty -> true, pat, mkLetIn (Name name,bo,ty,cl),c,clr,ucst + else false, pat, pf_mkprod gl c cl, c, clr,ucst + else if to_ind && occ = None then + let nv, p, _, ucst' = pf_abs_evars gl (fst pat, c) in + let ucst = Evd.union_evar_universe_context ucst ucst' in + if nv = 0 then anomaly "occur_existential but no evars" else + false, pat, mkProd (constr_name c, pf_type_of gl p, pf_concl gl), p, clr,ucst + else loc_error (loc_of_cpattern t) "generalized term didn't match" + +let genclrtac cl cs clr = + let tclmyORELSE tac1 tac2 gl = + try tac1 gl + with e when Errors.noncritical e -> tac2 e gl in + (* apply_type may give a type error, but the useful message is + * the one of clear. You type "move: x" and you get + * "x is used in hyp H" instead of + * "The term H has type T x but is expected to have type T x0". *) + tclTHEN + (tclmyORELSE + (apply_type cl cs) + (fun type_err gl -> + tclTHEN + (tclTHEN (Proofview.V82.of_tactic (elim_type (build_coq_False ()))) (cleartac clr)) + (fun gl -> raise type_err) + gl)) + (cleartac clr) + +let gentac ist gen gl = +(* pp(lazy(str"sigma@gentac=" ++ pr_evar_map None (project gl))); *) + let conv, _, cl, c, clr, ucst = pf_interp_gen_aux ist gl false gen in + pp(lazy(str"c@gentac=" ++ pr_constr c)); + let gl = pf_merge_uc ucst gl in + if conv + then tclTHEN (Proofview.V82.of_tactic (convert_concl cl)) (cleartac clr) gl + else genclrtac cl [c] clr gl + +let pf_interp_gen ist gl to_ind gen = + let _, _, a, b, c, ucst = pf_interp_gen_aux ist gl to_ind gen in + a, b ,c, pf_merge_uc ucst gl + +(** Generalization (discharge) sequence *) + +(* A discharge sequence is represented as a list of up to two *) +(* lists of d-items, plus an ident list set (the possibly empty *) +(* final clear switch). The main list is empty iff the command *) +(* is defective, and has length two if there is a sequence of *) +(* dependent terms (and in that case it is the first of the two *) +(* lists). Thus, the first of the two lists is never empty. *) + +(* type ssrgens = ssrgen list *) +(* type ssrdgens = ssrgens list * ssrclear *) + +let gens_sep = function [], [] -> mt | _ -> spc + +let pr_dgens pr_gen (gensl, clr) = + let prgens s gens = str s ++ pr_list spc pr_gen gens in + let prdeps deps = prgens ": " deps ++ spc () ++ str "/" in + match gensl with + | [deps; []] -> prdeps deps ++ pr_clear pr_spc clr + | [deps; gens] -> prdeps deps ++ prgens " " gens ++ pr_clear spc clr + | [gens] -> prgens ": " gens ++ pr_clear spc clr + | _ -> pr_clear pr_spc clr + +let pr_ssrdgens _ _ _ = pr_dgens pr_gen + +let cons_gen gen = function + | gens :: gensl, clr -> (gen :: gens) :: gensl, clr + | _ -> anomaly "missing gen list" + +let cons_dep (gensl, clr) = + if List.length gensl = 1 then ([] :: gensl, clr) else + Errors.error "multiple dependents switches '/'" + +ARGUMENT EXTEND ssrdgens_tl TYPED AS ssrgen list list * ssrclear + PRINTED BY pr_ssrdgens +| [ "{" ne_ssrhyp_list(clr) "}" cpattern(dt) ssrdgens_tl(dgens) ] -> + [ cons_gen (mkclr clr, dt) dgens ] +| [ "{" ne_ssrhyp_list(clr) "}" ] -> + [ [[]], clr ] +| [ "{" ssrocc(occ) "}" cpattern(dt) ssrdgens_tl(dgens) ] -> + [ cons_gen (mkocc occ, dt) dgens ] +| [ "/" ssrdgens_tl(dgens) ] -> + [ cons_dep dgens ] +| [ cpattern(dt) ssrdgens_tl(dgens) ] -> + [ cons_gen (nodocc, dt) dgens ] +| [ ] -> + [ [[]], [] ] +END + +ARGUMENT EXTEND ssrdgens TYPED AS ssrdgens_tl PRINTED BY pr_ssrdgens +| [ ":" ssrgen(gen) ssrdgens_tl(dgens) ] -> [ cons_gen gen dgens ] +END + +let genstac (gens, clr) ist = + tclTHENLIST (cleartac clr :: List.rev_map (gentac ist) gens) + +(* Common code to handle generalization lists along with the defective case *) + +let with_defective maintac deps clr ist gl = + let top_id = + match kind_of_type (pf_concl gl) with + | ProdType (Name id, _, _) + when has_discharged_tag (string_of_id id) -> id + | _ -> top_id in + let top_gen = mkclr clr, cpattern_of_id top_id in + tclTHEN (introid top_id) (maintac deps top_gen ist) gl + +let with_dgens (gensl, clr) maintac ist = match gensl with + | [deps; []] -> with_defective maintac deps clr ist + | [deps; gen :: gens] -> + tclTHEN (genstac (gens, clr) ist) (maintac deps gen ist) + | [gen :: gens] -> tclTHEN (genstac (gens, clr) ist) (maintac [] gen ist) + | _ -> with_defective maintac [] clr ist + +let first_goal gls = + let gl = gls.Evd.it and sig_0 = gls.Evd.sigma in + if List.is_empty gl then Errors.error "first_goal"; + { Evd.it = List.hd gl; Evd.sigma = sig_0; } + +let with_deps deps0 maintac cl0 cs0 clr0 ist gl0 = + let rec loop gl cl cs clr args clrs = function + | [] -> + let n = List.length args in + maintac (if n > 0 then applist (to_lambda n cl, args) else cl) clrs ist gl0 + | dep :: deps -> + let gl' = first_goal (genclrtac cl cs clr gl) in + let cl', c', clr',gl' = pf_interp_gen ist gl' false dep in + loop gl' cl' [c'] clr' (c' :: args) (clr' :: clrs) deps in + loop gl0 cl0 cs0 clr0 cs0 [clr0] (List.rev deps0) + +(** Equations *) + +(* argument *) + +type ssreqid = ssripat option + +let pr_eqid = function Some pat -> str " " ++ pr_ipat pat | None -> mt () +let pr_ssreqid _ _ _ = pr_eqid + +(* We must use primitive parsing here to avoid conflicts with the *) +(* basic move, case, and elim tactics. *) +ARGUMENT EXTEND ssreqid TYPED AS ssripatrep option PRINTED BY pr_ssreqid +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let accept_ssreqid strm = + match Compat.get_tok (Util.stream_nth 0 strm) with + | Tok.IDENT _ -> accept_before_syms [":"] strm + | Tok.KEYWORD ":" -> () + | Tok.KEYWORD pat when List.mem pat ["_"; "?"; "->"; "<-"] -> + accept_before_syms [":"] strm + | _ -> raise Stream.Failure + +let test_ssreqid = Gram.Entry.of_parser "test_ssreqid" accept_ssreqid + +GEXTEND Gram + GLOBAL: ssreqid; + ssreqpat: [ + [ id = Prim.ident -> IpatId id + | "_" -> IpatWild + | "?" -> IpatAnon + | occ = ssrdocc; "->" -> (match occ with + | None, occ -> IpatRw (occ, L2R) + | _ -> loc_error !@loc "Only occurrences are allowed here") + | occ = ssrdocc; "<-" -> (match occ with + | None, occ -> IpatRw (occ, R2L) + | _ -> loc_error !@loc "Only occurrences are allowed here") + | "->" -> IpatRw (allocc, L2R) + | "<-" -> IpatRw (allocc, R2L) + ]]; + ssreqid: [ + [ test_ssreqid; pat = ssreqpat -> Some pat + | test_ssreqid -> None + ]]; +END + +(* creation *) + +let mkEq dir cl c t n gl = + let eqargs = [|t; c; c|] in eqargs.(dir_org dir) <- mkRel n; + let eq, gl = pf_fresh_global (build_coq_eq()) gl in + let refl, gl = mkRefl t c gl in + mkArrow (mkApp (eq, eqargs)) (lift 1 cl), refl, gl + +let pushmoveeqtac cl c gl = + let x, t, cl1 = destProd cl in + let cl2, eqc, gl = mkEq R2L cl1 c t 1 gl in + apply_type (mkProd (x, t, cl2)) [c; eqc] gl + +let pushcaseeqtac cl gl = + let cl1, args = destApplication cl in + let n = Array.length args in + let dc, cl2 = decompose_lam_n n cl1 in + let _, t = List.nth dc (n - 1) in + let cl3, eqc, gl = mkEq R2L cl2 args.(0) t n gl in + let prot, gl = mkProt (pf_type_of gl cl) cl3 gl in + let cl4 = mkApp (compose_lam dc prot, args) in + let gl, _ = pf_e_type_of gl cl4 in + tclTHEN (apply_type cl4 [eqc]) + (Proofview.V82.of_tactic (convert_concl cl4)) gl + +let pushelimeqtac gl = + let _, args = destApplication (pf_concl gl) in + let x, t, _ = destLambda args.(1) in + let cl1 = mkApp (args.(1), Array.sub args 2 (Array.length args - 2)) in + let cl2, eqc, gl = mkEq L2R cl1 args.(2) t 1 gl in + tclTHEN (apply_type (mkProd (x, t, cl2)) [args.(2); eqc]) + (Proofview.V82.of_tactic intro) gl + +(** Bookkeeping (discharge-intro) argument *) + +(* Since all bookkeeping ssr commands have the same discharge-intro *) +(* argument format we use a single grammar entry point to parse them. *) +(* the entry point parses only non-empty arguments to avoid conflicts *) +(* with the basic Coq tactics. *) + +(* type ssrarg = ssrview * (ssreqid * (ssrdgens * ssripats)) *) + +let pr_ssrarg _ _ _ (view, (eqid, (dgens, ipats))) = + let pri = pr_intros (gens_sep dgens) in + pr_view view ++ pr_eqid eqid ++ pr_dgens pr_gen dgens ++ pri ipats + +ARGUMENT EXTEND ssrarg TYPED AS ssrview * (ssreqid * (ssrdgens * ssrintros)) + PRINTED BY pr_ssrarg +| [ ssrview(view) ssreqid(eqid) ssrdgens(dgens) ssrintros(ipats) ] -> + [ view, (eqid, (dgens, ipats)) ] +| [ ssrview(view) ssrclear(clr) ssrintros(ipats) ] -> + [ view, (None, (([], clr), ipats)) ] +| [ ssreqid(eqid) ssrdgens(dgens) ssrintros(ipats) ] -> + [ [], (eqid, (dgens, ipats)) ] +| [ ssrclear_ne(clr) ssrintros(ipats) ] -> + [ [], (None, (([], clr), ipats)) ] +| [ ssrintros_ne(ipats) ] -> + [ [], (None, (([], []), ipats)) ] +END + +(** The "clear" tactic *) + +(* We just add a numeric version that clears the n top assumptions. *) + +let poptac ist n = introstac ~ist (List.init n (fun _ -> IpatWild)) + +TACTIC EXTEND ssrclear + | [ "clear" natural(n) ] -> [ Proofview.V82.tactic (poptac ist n) ] +END + +(** The "move" tactic *) + +let rec improper_intros = function + | IpatSimpl _ :: ipats -> improper_intros ipats + | (IpatId _ | IpatAnon | IpatCase _ | IpatAll) :: _ -> false + | _ -> true + +let check_movearg = function + | view, (eqid, _) when view <> [] && eqid <> None -> + Errors.error "incompatible view and equation in move tactic" + | view, (_, (([gen :: _], _), _)) when view <> [] && has_occ gen -> + Errors.error "incompatible view and occurrence switch in move tactic" + | _, (_, ((dgens, _), _)) when List.length dgens > 1 -> + Errors.error "dependents switch `/' in move tactic" + | _, (eqid, (_, ipats)) when eqid <> None && improper_intros ipats -> + Errors.error "no proper intro pattern for equation in move tactic" + | arg -> arg + +ARGUMENT EXTEND ssrmovearg TYPED AS ssrarg PRINTED BY pr_ssrarg +| [ ssrarg(arg) ] -> [ check_movearg arg ] +END + +let viewmovetac_aux clear name_ref (_, vl as v) _ gen ist gl = + let cl, c, clr, gl = pf_interp_gen ist gl false gen in + let cl, c, gl = if vl = [] then cl, c, gl else pf_with_view ist gl v cl c in + let clr = if clear then clr else [] in + name_ref := (match id_of_cpattern (snd gen) with Some id -> id | _ -> top_id); + genclrtac cl [c] clr gl + +let () = move_top_with_view := + (fun c r v -> with_defective (viewmovetac_aux c r v) [] []) + +let viewmovetac v deps gen ist gl = + viewmovetac_aux true (ref top_id) v deps gen ist gl + +let eqmovetac _ gen ist gl = + let cl, c, _, gl = pf_interp_gen ist gl false gen in pushmoveeqtac cl c gl + +let movehnftac gl = match kind_of_term (pf_concl gl) with + | Prod _ | LetIn _ -> tclIDTAC gl + | _ -> hnf_in_concl gl + +let ssrmovetac ist = function + | _::_ as view, (_, (dgens, ipats)) -> + let dgentac = with_dgens dgens (viewmovetac (true, view)) ist in + tclTHEN dgentac (introstac ~ist ipats) + | _, (Some pat, (dgens, ipats)) -> + let dgentac = with_dgens dgens eqmovetac ist in + tclTHEN dgentac (introstac ~ist (eqmoveipats pat ipats)) + | _, (_, (([gens], clr), ipats)) -> + let gentac = genstac (gens, clr) ist in + tclTHEN gentac (introstac ~ist ipats) + | _, (_, ((_, clr), ipats)) -> + tclTHENLIST [movehnftac; cleartac clr; introstac ~ist ipats] + +TACTIC EXTEND ssrmove +| [ "move" ssrmovearg(arg) ssrrpat(pat) ] -> + [ Proofview.V82.tactic (tclTHEN (ssrmovetac ist arg) (introstac ~ist [pat])) ] +| [ "move" ssrmovearg(arg) ssrclauses(clauses) ] -> + [ Proofview.V82.tactic (tclCLAUSES ist (ssrmovetac ist arg) clauses) ] +| [ "move" ssrrpat(pat) ] -> [ Proofview.V82.tactic (introstac ~ist [pat]) ] +| [ "move" ] -> [ Proofview.V82.tactic (movehnftac) ] +END + +(* TASSI: given the type of an elimination principle, it finds the higher order + * argument (index), it computes it's arity and the arity of the eliminator and + * checks if the eliminator is recursive or not *) +let analyze_eliminator elimty env sigma = + let rec loop ctx t = match kind_of_type t with + | AtomicType (hd, args) when isRel hd -> + ctx, destRel hd, not (noccurn 1 t), Array.length args + | CastType (t, _) -> loop ctx t + | ProdType (x, ty, t) -> loop ((x,None,ty) :: ctx) t + | LetInType (x,b,ty,t) -> loop ((x,Some b,ty) :: ctx) (subst1 b t) + | _ -> + let env' = Environ.push_rel_context ctx env in + let t' = Reductionops.whd_betadeltaiota env' sigma t in + if not (Term.eq_constr t t') then loop ctx t' else + errorstrm (str"The eliminator has the wrong shape."++spc()++ + str"A (applied) bound variable was expected as the conclusion of "++ + str"the eliminator's"++Pp.cut()++str"type:"++spc()++pr_constr elimty) in + let ctx, pred_id, elim_is_dep, n_pred_args = loop [] elimty in + let n_elim_args = rel_context_nhyps ctx in + let is_rec_elim = + let count_occurn n term = + let count = ref 0 in + let rec occur_rec n c = match kind_of_term c with + | Rel m -> if m = n then incr count + | _ -> iter_constr_with_binders succ occur_rec n c + in + occur_rec n term; !count in + let occurr2 n t = count_occurn n t > 1 in + not (List.for_all_i + (fun i (_,rd) -> pred_id <= i || not (occurr2 (pred_id - i) rd)) + 1 (assums_of_rel_context ctx)) + in + n_elim_args - pred_id, n_elim_args, is_rec_elim, elim_is_dep, n_pred_args + +(* TASSI: This version of unprotects inlines the unfold tactic definition, + * since we don't want to wipe out let-ins, and it seems there is no flag + * to change that behaviour in the standard unfold code *) +let unprotecttac gl = + let c, gl = pf_mkSsrConst "protect_term" gl in + let prot, _ = destConst c in + onClause (fun idopt -> + let hyploc = Option.map (fun id -> id, InHyp) idopt in + reduct_option + (Reductionops.clos_norm_flags + (Closure.RedFlags.mkflags + [Closure.RedFlags.fBETA; + Closure.RedFlags.fCONST prot; + Closure.RedFlags.fIOTA]), DEFAULTcast) hyploc) + allHypsAndConcl gl + +let dependent_apply_error = + try Errors.error "Could not fill dependent hole in \"apply\"" with err -> err + +(* TASSI: Sometimes Coq's apply fails. According to my experience it may be + * related to goals that are products and with beta redexes. In that case it + * guesses the wrong number of implicit arguments for your lemma. What follows + * is just like apply, but with a user-provided number n of implicits. + * + * Refine.refine function that handles type classes and evars but fails to + * handle "dependently typed higher order evars". + * + * Refiner.refiner that does not handle metas with a non ground type but works + * with dependently typed higher order metas. *) +let applyn ~with_evars ?beta ?(with_shelve=false) n t gl = + if with_evars then + let refine gl = + let t, ty, args, gl = pf_saturate ?beta ~bi_types:true gl t n in +(* pp(lazy(str"sigma@saturate=" ++ pr_evar_map None (project gl))); *) + let gl = pf_unify_HO gl ty (pf_concl gl) in + let gs = CList.map_filter (fun (_, e) -> + if isEvar (pf_nf_evar gl e) then Some e else None) + args in + pf_partial_solution gl t gs + in + Proofview.(V82.of_tactic + (tclTHEN (V82.tactic refine) + (if with_shelve then shelve_unifiable else tclUNIT ()))) gl + else + let t, gl = if n = 0 then t, gl else + let sigma, si = project gl, sig_it gl in + let rec loop sigma bo args = function (* saturate with metas *) + | 0 -> mkApp (t, Array.of_list (List.rev args)), re_sig si sigma + | n -> match kind_of_term bo with + | Lambda (_, ty, bo) -> + if not (closed0 ty) then raise dependent_apply_error; + let m = Evarutil.new_meta () in + loop (meta_declare m ty sigma) bo ((mkMeta m)::args) (n-1) + | _ -> assert false + in loop sigma t [] n in + pp(lazy(str"Refiner.refiner " ++ pr_constr t)); + Refiner.refiner (Proof_type.Refine t) gl + +let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl = + let rec mkRels = function 1 -> [] | n -> mkRel n :: mkRels (n-1) in + let uct = Evd.evar_universe_context (fst oc) in + let n, oc = pf_abs_evars_pirrel gl oc in + let gl = pf_merge_uc uct gl in + let oc = if not first_goes_last || n <= 1 then oc else + let l, c = decompose_lam oc in + if not (List.for_all_i (fun i (_,t) -> closedn ~-i t) (1-n) l) then oc else + compose_lam (let xs,y = List.chop (n-1) l in y @ xs) + (mkApp (compose_lam l c, Array.of_list (mkRel 1 :: mkRels n))) + in + pp(lazy(str"after: " ++ pr_constr oc)); + try applyn ~with_evars ~with_shelve:true ?beta n oc gl with _ -> raise dependent_apply_error + +let pf_fresh_inductive_instance ind gl = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma, indu = Evd.fresh_inductive_instance env sigma ind in + indu, re_sig it sigma + +(** The "case" and "elim" tactic *) + +(* A case without explicit dependent terms but with both a view and an *) +(* occurrence switch and/or an equation is treated as dependent, with the *) +(* viewed term as the dependent term (the occurrence switch would be *) +(* meaningless otherwise). When both a view and explicit dependents are *) +(* present, it is forbidden to put a (meaningless) occurrence switch on *) +(* the viewed term. *) + +(* This is both elim and case (defaulting to the former). If ~elim is omitted + * the standard eliminator is chosen. The code is made of 4 parts: + * 1. find the eliminator if not given as ~elim and analyze it + * 2. build the patterns to be matched against the conclusion, looking at + * (occ, c), deps and the pattern inferred from the type of the eliminator + * 3. build the new predicate matching the patterns, and the tactic to + * generalize the equality in case eqid is not None + * 4. build the tactic handle intructions and clears as required in ipats and + * by eqid *) +let ssrelim ?(is_case=false) ?ist deps what ?elim eqid ipats gl = + (* some sanity checks *) + let oc, orig_clr, occ, c_gen, gl = match what with + | `EConstr(_,_,t) when isEvar t -> + anomaly "elim called on a constr evar" + | `EGen _ when ist = None -> + anomaly "no ist and non simple elimination" + | `EGen (_, g) when elim = None && is_wildcard g -> + errorstrm(str"Indeterminate pattern and no eliminator") + | `EGen ((Some clr,occ), g) when is_wildcard g -> + None, clr, occ, None, gl + | `EGen ((None, occ), g) when is_wildcard g -> None,[],occ,None,gl + | `EGen ((_, occ), p as gen) -> + let _, c, clr,gl = pf_interp_gen (Option.get ist) gl true gen in + Some c, clr, occ, Some p,gl + | `EConstr (clr, occ, c) -> Some c, clr, occ, None,gl in + let orig_gl, concl, env = gl, pf_concl gl, pf_env gl in + pp(lazy(str(if is_case then "==CASE==" else "==ELIM=="))); + (* Utils of local interest only *) + let iD s ?t gl = let t = match t with None -> pf_concl gl | Some x -> x in + pp(lazy(str s ++ pr_constr t)); tclIDTAC gl in + let eq, gl = pf_fresh_global (build_coq_eq ()) gl in + let protectC, gl = pf_mkSsrConst "protect_term" gl in + let fire_subst gl t = Reductionops.nf_evar (project gl) t in + let fire_sigma sigma t = Reductionops.nf_evar sigma t in + let is_undef_pat = function + | sigma, T t -> + (match kind_of_term (fire_sigma sigma t) with Evar _ -> true | _ -> false) + | _ -> false in + let match_pat env p occ h cl = + let sigma0 = project orig_gl in + pp(lazy(str"matching: " ++ pp_pattern p)); + let (c,ucst), cl = + fill_occ_pattern ~raise_NoMatch:true env sigma0 cl p occ h in + pp(lazy(str" got: " ++ pr_constr c)); + c, cl, ucst in + let mkTpat gl t = (* takes a term, refreshes it and makes a T pattern *) + let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in + let t, _, _, sigma = saturate ~beta:true env (project gl) t n in + Evd.merge_universe_context sigma ucst, T t in + let unif_redex gl (sigma, r as p) t = (* t is a hint for the redex of p *) + let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in + let t, _, _, sigma = saturate ~beta:true env sigma t n in + let sigma = Evd.merge_universe_context sigma ucst in + match r with + | X_In_T (e, p) -> sigma, E_As_X_In_T (t, e, p) + | _ -> + try unify_HO env sigma t (fst (redex_of_pattern env p)), r + with e when Errors.noncritical e -> p in + (* finds the eliminator applies it to evars and c saturated as needed *) + (* obtaining "elim ??? (c ???)". pred is the higher order evar *) + let cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl = + match elim with + | Some elim -> + let gl, elimty = pf_e_type_of gl elim in + let pred_id, n_elim_args, is_rec, elim_is_dep, n_pred_args = + analyze_eliminator elimty env (project gl) in + let elim, elimty, elim_args, gl = + pf_saturate ~beta:is_case gl elim ~ty:elimty n_elim_args in + let pred = List.assoc pred_id elim_args in + let elimty = Reductionops.whd_betadeltaiota env (project gl) elimty in + None, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl + | None -> + let c = Option.get oc in let c_ty = pf_type_of gl c in + let ((kn, i) as ind, _ as indu), unfolded_c_ty = + pf_reduce_to_quantified_ind gl c_ty in + let sort = elimination_sort_of_goal gl in + let gl, elim = + if not is_case then + let t, gl = pf_fresh_global (Indrec.lookup_eliminator ind sort) gl in + gl, t + else + pf_eapply (fun env sigma -> + Indrec.build_case_analysis_scheme env sigma indu true) gl sort in + let elimty = pf_type_of gl elim in + let pred_id,n_elim_args,is_rec,elim_is_dep,n_pred_args = + analyze_eliminator elimty env (project gl) in + let rctx = fst (decompose_prod_assum unfolded_c_ty) in + let n_c_args = rel_context_length rctx in + let c, c_ty, t_args, gl = pf_saturate gl c ~ty:c_ty n_c_args in + let elim, elimty, elim_args, gl = + pf_saturate ~beta:is_case gl elim ~ty:elimty n_elim_args in + let pred = List.assoc pred_id elim_args in + let pc = match n_c_args, c_gen with + | 0, Some p -> interp_cpattern (Option.get ist) orig_gl p None + | _ -> mkTpat gl c in + let cty = Some (c, c_ty, pc) in + let elimty = Reductionops.whd_betadeltaiota env (project gl) elimty in + cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl + in + pp(lazy(str"elim= "++ pr_constr_pat elim)); + pp(lazy(str"elimty= "++ pr_constr elimty)); + let inf_deps_r = match kind_of_type elimty with + | AtomicType (_, args) -> List.rev (Array.to_list args) + | _ -> assert false in + let saturate_until gl c c_ty f = + let rec loop n = try + let c, c_ty, _, gl = pf_saturate gl c ~ty:c_ty n in + let gl' = f c c_ty gl in + Some (c, c_ty, gl, gl') + with NotEnoughProducts -> None | _ -> loop (n+1) in loop 0 in + let elim_is_dep, gl = match cty with + | None -> true, gl + | Some (c, c_ty, _) -> + let res = + if elim_is_dep then None else + let arg = List.assoc (n_elim_args - 1) elim_args in + let arg_ty = pf_type_of gl arg in + match saturate_until gl c c_ty (fun c c_ty gl -> + pf_unify_HO (pf_unify_HO gl c_ty arg_ty) arg c) with + | Some (c, _, _, gl) -> Some (false, gl) + | None -> None in + match res with + | Some x -> x + | None -> + let inf_arg = List.hd inf_deps_r in + let inf_arg_ty = pf_type_of gl inf_arg in + match saturate_until gl c c_ty (fun _ c_ty gl -> + pf_unify_HO gl c_ty inf_arg_ty) with + | Some (c, _, _,gl) -> true, gl + | None -> + errorstrm (str"Unable to apply the eliminator to the term"++ + spc()++pr_constr c++spc()++str"or to unify it's type with"++ + pr_constr inf_arg_ty) in + pp(lazy(str"elim_is_dep= " ++ bool elim_is_dep)); + let predty = pf_type_of gl pred in + (* Patterns for the inductive types indexes to be bound in pred are computed + * looking at the ones provided by the user and the inferred ones looking at + * the type of the elimination principle *) + let pp_pat (_,p,_,_) = pp_pattern p in + let pp_inf_pat gl (_,_,t,_) = pr_constr_pat (fire_subst gl t) in + let patterns, clr, gl = + let rec loop patterns clr i = function + | [],[] -> patterns, clr, gl + | ((oclr, occ), t):: deps, inf_t :: inf_deps -> + let ist = match ist with Some x -> x | None -> assert false in + let p = interp_cpattern ist orig_gl t None in + let clr_t = + interp_clr (oclr,(tag_of_cpattern t,fst (redex_of_pattern env p)))in + (* if we are the index for the equation we do not clear *) + let clr_t = if deps = [] && eqid <> None then [] else clr_t in + let p = if is_undef_pat p then mkTpat gl inf_t else p in + loop (patterns @ [i, p, inf_t, occ]) + (clr_t @ clr) (i+1) (deps, inf_deps) + | [], c :: inf_deps -> + pp(lazy(str"adding inferred pattern " ++ pr_constr_pat c)); + loop (patterns @ [i, mkTpat gl c, c, allocc]) + clr (i+1) ([], inf_deps) + | _::_, [] -> errorstrm (str "Too many dependent abstractions") in + let deps, head_p, inf_deps_r = match what, elim_is_dep, cty with + | `EConstr _, _, None -> anomaly "Simple welim with no term" + | _, false, _ -> deps, [], inf_deps_r + | `EGen gen, true, None -> deps @ [gen], [], inf_deps_r + | _, true, Some (c, _, pc) -> + let occ = if occ = None then allocc else occ in + let inf_p, inf_deps_r = List.hd inf_deps_r, List.tl inf_deps_r in + deps, [1, pc, inf_p, occ], inf_deps_r in + let patterns, clr, gl = + loop [] orig_clr (List.length head_p+1) (List.rev deps, inf_deps_r) in + head_p @ patterns, Util.List.uniquize clr, gl + in + pp(lazy(pp_concat (str"patterns=") (List.map pp_pat patterns))); + pp(lazy(pp_concat (str"inf. patterns=") (List.map (pp_inf_pat gl) patterns))); + (* Predicate generation, and (if necessary) tactic to generalize the + * equation asked by the user *) + let elim_pred, gen_eq_tac, clr, gl = + let error gl t inf_t = errorstrm (str"The given pattern matches the term"++ + spc()++pp_term gl t++spc()++str"while the inferred pattern"++ + spc()++pr_constr_pat (fire_subst gl inf_t)++spc()++ str"doesn't") in + let match_or_postpone (cl, gl, post) (h, p, inf_t, occ) = + let p = unif_redex gl p inf_t in + if is_undef_pat p then + let () = pp(lazy(str"postponing " ++ pp_pattern p)) in + cl, gl, post @ [h, p, inf_t, occ] + else try + let c, cl, ucst = match_pat env p occ h cl in + let gl = pf_merge_uc ucst gl in + let gl = try pf_unify_HO gl inf_t c with _ -> error gl c inf_t in + cl, gl, post + with + | NoMatch | NoProgress -> + let e, ucst = redex_of_pattern env p in + let gl = pf_merge_uc ucst gl in + let n, e, _, _ucst = pf_abs_evars gl (fst p, e) in + let e, _, _, gl = pf_saturate ~beta:true gl e n in + let gl = try pf_unify_HO gl inf_t e with _ -> error gl e inf_t in + cl, gl, post + in + let rec match_all concl gl patterns = + let concl, gl, postponed = + List.fold_left match_or_postpone (concl, gl, []) patterns in + if postponed = [] then concl, gl + else if List.length postponed = List.length patterns then + errorstrm (str "Some patterns are undefined even after all"++spc()++ + str"the defined ones matched") + else match_all concl gl postponed in + let concl, gl = match_all concl gl patterns in + let pred_rctx, _ = decompose_prod_assum (fire_subst gl predty) in + let concl, gen_eq_tac, clr, gl = match eqid with + | Some (IpatId _) when not is_rec -> + let k = List.length deps in + let c = fire_subst gl (List.assoc (n_elim_args - k - 1) elim_args) in + let t = pf_type_of gl c in + let gen_eq_tac, gl = + let refl = mkApp (eq, [|t; c; c|]) in + let new_concl = mkArrow refl (lift 1 (pf_concl orig_gl)) in + let new_concl = fire_subst gl new_concl in + let erefl, gl = mkRefl t c gl in + let erefl = fire_subst gl erefl in + apply_type new_concl [erefl], gl in + let rel = k + if elim_is_dep then 1 else 0 in + let src, gl = mkProt mkProp (mkApp (eq,[|t; c; mkRel rel|])) gl in + let concl = mkArrow src (lift 1 concl) in + let clr = if deps <> [] then clr else [] in + concl, gen_eq_tac, clr, gl + | _ -> concl, tclIDTAC, clr, gl in + let mk_lam t r = mkLambda_or_LetIn r t in + let concl = List.fold_left mk_lam concl pred_rctx in + let gl, concl = + if eqid <> None && is_rec then + let concl, gl = mkProt (pf_type_of gl concl) concl gl in + let gl, _ = pf_e_type_of gl concl in + gl, concl + else gl, concl in + concl, gen_eq_tac, clr, gl in + let gl, pty = pf_e_type_of gl elim_pred in + pp(lazy(str"elim_pred=" ++ pp_term gl elim_pred)); + pp(lazy(str"elim_pred_ty=" ++ pp_term gl pty)); + let gl = pf_unify_HO gl pred elim_pred in + let elim = fire_subst gl elim in + let gl, _ = pf_e_type_of gl elim in + (* check that the patterns do not contain non instantiated dependent metas *) + let () = + let evars_of_term = Evarutil.undefined_evars_of_term (project gl) in + let patterns = List.map (fun (_,_,t,_) -> fire_subst gl t) patterns in + let patterns_ev = List.map evars_of_term patterns in + let ev = List.fold_left Intset.union Intset.empty patterns_ev in + let ty_ev = Intset.fold (fun i e -> + let ex = i in + let i_ty = Evd.evar_concl (Evd.find (project gl) ex) in + Intset.union e (evars_of_term i_ty)) + ev Intset.empty in + let inter = Intset.inter ev ty_ev in + if not (Intset.is_empty inter) then begin + let i = Intset.choose inter in + let pat = List.find (fun t -> Intset.mem i (evars_of_term t)) patterns in + errorstrm(str"Pattern"++spc()++pr_constr_pat pat++spc()++ + str"was not completely instantiated and one of its variables"++spc()++ + str"occurs in the type of another non instantieted pattern variable"); + end + in + (* the elim tactic, with the eliminator and the predicated we computed *) + let elim = project gl, elim in + let elim_tac gl = + tclTHENLIST [refine_with ~with_evars:false elim; cleartac clr] gl in + (* handling of following intro patterns and equation introduction if any *) + let elim_intro_tac gl = + let intro_eq = + match eqid with + | Some (IpatId ipat) when not is_rec -> + let rec intro_eq gl = match kind_of_type (pf_concl gl) with + | ProdType (_, src, tgt) -> + (match kind_of_type src with + | AtomicType (hd, _) when Term.eq_constr hd protectC -> + tclTHENLIST [unprotecttac; introid ipat] gl + | _ -> tclTHENLIST [ iD "IA"; introstac [IpatAnon]; intro_eq] gl) + |_ -> errorstrm (str "Too many names in intro pattern") in + intro_eq + | Some (IpatId ipat) -> + let name gl = mk_anon_id "K" gl in + let intro_lhs gl = + let elim_name = match orig_clr, what with + | [SsrHyp(_, x)], _ -> x + | _, `EConstr(_,_,t) when isVar t -> destVar t + | _ -> name gl in + if is_name_in_ipats elim_name ipats then introid (name gl) gl + else introid elim_name gl + in + let rec gen_eq_tac gl = + let concl = pf_concl gl in + let ctx, last = decompose_prod_assum concl in + let args = match kind_of_type last with + | AtomicType (hd, args) -> assert(Term.eq_constr hd protectC); args + | _ -> assert false in + let case = args.(Array.length args-1) in + if not(closed0 case) then tclTHEN (introstac [IpatAnon]) gen_eq_tac gl + else + let case_ty = pf_type_of gl case in + let refl = mkApp (eq, [|lift 1 case_ty; mkRel 1; lift 1 case|]) in + let new_concl = fire_subst gl + (mkProd (Name (name gl), case_ty, mkArrow refl (lift 2 concl))) in + let erefl, gl = mkRefl case_ty case gl in + let erefl = fire_subst gl erefl in + apply_type new_concl [case;erefl] gl in + tclTHENLIST [gen_eq_tac; intro_lhs; introid ipat] + | _ -> tclIDTAC in + let unprot = if eqid <> None && is_rec then unprotecttac else tclIDTAC in + tclEQINTROS ?ist elim_tac (tclTHENLIST [intro_eq; unprot]) ipats gl + in + tclTHENLIST [gen_eq_tac; elim_intro_tac] orig_gl +;; + +let simplest_newelim x= ssrelim ~is_case:false [] (`EConstr ([],None,x)) None [] +let simplest_newcase x= ssrelim ~is_case:true [] (`EConstr ([],None,x)) None [] +let _ = simplest_newcase_ref := simplest_newcase + +let check_casearg = function +| view, (_, (([_; gen :: _], _), _)) when view <> [] && has_occ gen -> + Errors.error "incompatible view and occurrence switch in dependent case tactic" +| arg -> arg + +ARGUMENT EXTEND ssrcasearg TYPED AS ssrarg PRINTED BY pr_ssrarg +| [ ssrarg(arg) ] -> [ check_casearg arg ] +END + +let ssrcasetac ist (view, (eqid, (dgens, ipats))) = + let ndefectcasetac view eqid ipats deps ((_, occ), _ as gen) ist gl = + let simple = (eqid = None && deps = [] && occ = None) in + let cl, c, clr, gl = pf_interp_gen ist gl true gen in + let _, vc, gl = + if view = [] then c, c, gl else pf_with_view ist gl (false, view) cl c in + if simple && is_injection_case vc gl then + tclTHENLIST [perform_injection vc; cleartac clr; introstac ~ist ipats] gl + else + (* macro for "case/v E: x" ---> "case E: x / (v x)" *) + let deps, clr, occ = + if view <> [] && eqid <> None && deps = [] then [gen], [], None + else deps, clr, occ in + ssrelim ~is_case:true ~ist deps (`EConstr (clr,occ, vc)) eqid ipats gl + in + with_dgens dgens (ndefectcasetac view eqid ipats) ist + +TACTIC EXTEND ssrcase +| [ "case" ssrcasearg(arg) ssrclauses(clauses) ] -> + [ Proofview.V82.tactic (tclCLAUSES ist (ssrcasetac ist arg) clauses) ] +| [ "case" ] -> [ Proofview.V82.tactic (with_top ssrscasetac) ] +END + +(** The "elim" tactic *) + +(* Elim views are elimination lemmas, so the eliminated term is not addded *) +(* to the dependent terms as for "case", unless it actually occurs in the *) +(* goal, the "all occurrences" {+} switch is used, or the equation switch *) +(* is used and there are no dependents. *) + +let ssrelimtac ist (view, (eqid, (dgens, ipats))) = + let ndefectelimtac view eqid ipats deps gen ist gl = + let elim = match view with [v] -> Some (snd(force_term ist gl v)) | _ -> None in + ssrelim ~ist deps (`EGen gen) ?elim eqid ipats gl + in + with_dgens dgens (ndefectelimtac view eqid ipats) ist + +TACTIC EXTEND ssrelim +| [ "elim" ssrarg(arg) ssrclauses(clauses) ] -> + [ Proofview.V82.tactic (tclCLAUSES ist (ssrelimtac ist arg) clauses) ] +| [ "elim" ] -> [ Proofview.V82.tactic (with_top simplest_newelim) ] +END + +(** 6. Backward chaining tactics: apply, exact, congr. *) + +(** The "apply" tactic *) + +let pr_agen (docc, dt) = pr_docc docc ++ pr_term dt +let pr_ssragen _ _ _ = pr_agen +let pr_ssragens _ _ _ = pr_dgens pr_agen + +ARGUMENT EXTEND ssragen TYPED AS ssrdocc * ssrterm PRINTED BY pr_ssragen +| [ "{" ne_ssrhyp_list(clr) "}" ssrterm(dt) ] -> [ mkclr clr, dt ] +| [ ssrterm(dt) ] -> [ nodocc, dt ] +END + +ARGUMENT EXTEND ssragens TYPED AS ssragen list list * ssrclear +PRINTED BY pr_ssragens +| [ "{" ne_ssrhyp_list(clr) "}" ssrterm(dt) ssragens(agens) ] -> + [ cons_gen (mkclr clr, dt) agens ] +| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ [[]], clr] +| [ ssrterm(dt) ssragens(agens) ] -> + [ cons_gen (nodocc, dt) agens ] +| [ ] -> [ [[]], [] ] +END + +let mk_applyarg views agens intros = views, (None, (agens, intros)) + +let pr_ssraarg _ _ _ (view, (eqid, (dgens, ipats))) = + let pri = pr_intros (gens_sep dgens) in + pr_view view ++ pr_eqid eqid ++ pr_dgens pr_agen dgens ++ pri ipats + +ARGUMENT EXTEND ssrapplyarg +TYPED AS ssrview * (ssreqid * (ssragens * ssrintros)) +PRINTED BY pr_ssraarg +| [ ":" ssragen(gen) ssragens(dgens) ssrintros(intros) ] -> + [ mk_applyarg [] (cons_gen gen dgens) intros ] +| [ ssrclear_ne(clr) ssrintros(intros) ] -> + [ mk_applyarg [] ([], clr) intros ] +| [ ssrintros_ne(intros) ] -> + [ mk_applyarg [] ([], []) intros ] +| [ ssrview(view) ":" ssragen(gen) ssragens(dgens) ssrintros(intros) ] -> + [ mk_applyarg view (cons_gen gen dgens) intros ] +| [ ssrview(view) ssrclear(clr) ssrintros(intros) ] -> + [ mk_applyarg view ([], clr) intros ] +END + +let interp_agen ist gl ((goclr, _), (k, gc)) (clr, rcs) = +(* pp(lazy(str"sigma@interp_agen=" ++ pr_evar_map None (project gl))); *) + let rc = glob_constr ist (pf_env gl) gc in + let rcs' = rc :: rcs in + match goclr with + | None -> clr, rcs' + | Some ghyps -> + let clr' = snd (interp_hyps ist gl ghyps) @ clr in + if k <> ' ' then clr', rcs' else + match rc with + | GVar (loc, id) when not_section_id id -> SsrHyp (loc, id) :: clr', rcs' + | GRef (loc, VarRef id, _) when not_section_id id -> + SsrHyp (loc, id) :: clr', rcs' + | _ -> clr', rcs' + +let interp_agens ist gl gagens = + match List.fold_right (interp_agen ist gl) gagens ([], []) with + | clr, rlemma :: args -> + let n = interp_nbargs ist gl rlemma - List.length args in + let rec loop i = + if i > n then + errorstrm (str "Cannot apply lemma " ++ pf_pr_glob_constr gl rlemma) + else + try interp_refine ist gl (mkRApp rlemma (mkRHoles i @ args)) + with _ -> loop (i + 1) in + clr, loop 0 + | _ -> assert false + +let apply_rconstr ?ist t gl = +(* pp(lazy(str"sigma@apply_rconstr=" ++ pr_evar_map None (project gl))); *) + let n = match ist, t with + | None, (GVar (_, id) | GRef (_, VarRef id,_)) -> pf_nbargs gl (mkVar id) + | Some ist, _ -> interp_nbargs ist gl t + | _ -> anomaly "apply_rconstr without ist and not RVar" in + let mkRlemma i = mkRApp t (mkRHoles i) in + let cl = pf_concl gl in + let rec loop i = + if i > n then + errorstrm (str"Cannot apply lemma "++pf_pr_glob_constr gl t) + else try pf_match gl (mkRlemma i) (OfType cl) with _ -> loop (i + 1) in + refine_with (loop 0) gl + +let mkRAppView ist gl rv gv = + let nb_view_imps = interp_view_nbimps ist gl rv in + mkRApp rv (mkRHoles (abs nb_view_imps)) + +let prof_apply_interp_with = mk_profiler "ssrapplytac.interp_with";; + +let refine_interp_apply_view i ist gl gv = + let pair i = List.map (fun x -> i, x) in + let rv = pf_intern_term ist gl gv in + let v = mkRAppView ist gl rv gv in + let interp_with (i, hint) = + interp_refine ist gl (mkRApp hint (v :: mkRHoles i)) in + let interp_with x = prof_apply_interp_with.profile interp_with x in + let rec loop = function + | [] -> (try apply_rconstr ~ist rv gl with _ -> view_error "apply" gv) + | h :: hs -> (try refine_with (snd (interp_with h)) gl with _ -> loop hs) in + loop (pair i viewtab.(i) @ if i = 2 then pair 1 viewtab.(1) else []) + +let apply_top_tac gl = + tclTHENLIST [introid top_id; apply_rconstr (mkRVar top_id); clear [top_id]] gl + +let inner_ssrapplytac gviews ggenl gclr ist gl = + let _, clr = interp_hyps ist gl gclr in + let vtac gv i gl' = refine_interp_apply_view i ist gl' gv in + let ggenl, tclGENTAC = + if gviews <> [] && ggenl <> [] then + let ggenl= List.map (fun (x,g) -> x, cpattern_of_term g) (List.hd ggenl) in + [], tclTHEN (genstac (ggenl,[]) ist) + else ggenl, tclTHEN tclIDTAC in + tclGENTAC (fun gl -> + match gviews, ggenl with + | v :: tl, [] -> + let dbl = if List.length tl = 1 then 2 else 1 in + tclTHEN + (List.fold_left (fun acc v -> tclTHENLAST acc (vtac v dbl)) (vtac v 1) tl) + (cleartac clr) gl + | [], [agens] -> + let clr', (sigma, lemma) = interp_agens ist gl agens in + let gl = pf_merge_uc_of sigma gl in + tclTHENLIST [cleartac clr; refine_with ~beta:true lemma; cleartac clr'] gl + | _, _ -> tclTHEN apply_top_tac (cleartac clr) gl) gl + +let ssrapplytac ist (views, (_, ((gens, clr), intros))) = + tclINTROS ist (inner_ssrapplytac views gens clr) intros + +TACTIC EXTEND ssrapply +| [ "apply" ssrapplyarg(arg) ] -> [ Proofview.V82.tactic (ssrapplytac ist arg) ] +| [ "apply" ] -> [ Proofview.V82.tactic apply_top_tac ] +END + +(** The "exact" tactic *) + +let mk_exactarg views dgens = mk_applyarg views dgens [] + +ARGUMENT EXTEND ssrexactarg TYPED AS ssrapplyarg PRINTED BY pr_ssraarg +| [ ":" ssragen(gen) ssragens(dgens) ] -> + [ mk_exactarg [] (cons_gen gen dgens) ] +| [ ssrview(view) ssrclear(clr) ] -> + [ mk_exactarg view ([], clr) ] +| [ ssrclear_ne(clr) ] -> + [ mk_exactarg [] ([], clr) ] +END + +let vmexacttac pf gl = exact_no_check (mkCast (pf, VMcast, pf_concl gl)) gl + +TACTIC EXTEND ssrexact +| [ "exact" ssrexactarg(arg) ] -> [ Proofview.V82.tactic (tclBY (ssrapplytac ist arg)) ] +| [ "exact" ] -> [ Proofview.V82.tactic (tclORELSE donetac (tclBY apply_top_tac)) ] +| [ "exact" "<:" lconstr(pf) ] -> [ Proofview.V82.tactic (vmexacttac pf) ] +END + +(** The "congr" tactic *) + +(* type ssrcongrarg = open_constr * (int * constr) *) + +let pr_ssrcongrarg _ _ _ ((n, f), dgens) = + (if n <= 0 then mt () else str " " ++ int n) ++ + str " " ++ pr_term f ++ pr_dgens pr_gen dgens + +ARGUMENT EXTEND ssrcongrarg TYPED AS (int * ssrterm) * ssrdgens + PRINTED BY pr_ssrcongrarg +| [ natural(n) constr(c) ssrdgens(dgens) ] -> [ (n, mk_term ' ' c), dgens ] +| [ natural(n) constr(c) ] -> [ (n, mk_term ' ' c),([[]],[]) ] +| [ constr(c) ssrdgens(dgens) ] -> [ (0, mk_term ' ' c), dgens ] +| [ constr(c) ] -> [ (0, mk_term ' ' c), ([[]],[]) ] +END + +let rec mkRnat n = + if n <= 0 then GRef (dummy_loc, glob_O, None) else + mkRApp (GRef (dummy_loc, glob_S, None)) [mkRnat (n - 1)] + +let interp_congrarg_at ist gl n rf ty m = + pp(lazy(str"===interp_congrarg_at===")); + let congrn, _ = mkSsrRRef "nary_congruence" in + let args1 = mkRnat n :: mkRHoles n @ [ty] in + let args2 = mkRHoles (3 * n) in + let rec loop i = + if i + n > m then None else + try + let rt = mkRApp congrn (args1 @ mkRApp rf (mkRHoles i) :: args2) in + pp(lazy(str"rt=" ++ pr_glob_constr rt)); + Some (interp_refine ist gl rt) + with _ -> loop (i + 1) in + loop 0 + +let pattern_id = mk_internal_id "pattern value" + +let congrtac ((n, t), ty) ist gl = + pp(lazy(str"===congr===")); + pp(lazy(str"concl=" ++ pr_constr (pf_concl gl))); + let sigma, _ as it = interp_term ist gl t in + let gl = pf_merge_uc_of sigma gl in + let _, f, _, _ucst = pf_abs_evars gl it in + let ist' = {ist with lfun = + Id.Map.add pattern_id (Value.of_constr f) Id.Map.empty } in + let rf = mkRltacVar pattern_id in + let m = pf_nbargs gl f in + let _, cf = if n > 0 then + match interp_congrarg_at ist' gl n rf ty m with + | Some cf -> cf + | None -> errorstrm (str "No " ++ int n ++ str "-congruence with " + ++ pr_term t) + else let rec loop i = + if i > m then errorstrm (str "No congruence with " ++ pr_term t) + else match interp_congrarg_at ist' gl i rf ty m with + | Some cf -> cf + | None -> loop (i + 1) in + loop 1 in + tclTHEN (refine_with cf) (tclTRY (Proofview.V82.of_tactic reflexivity)) gl + +let newssrcongrtac arg ist gl = + pp(lazy(str"===newcongr===")); + pp(lazy(str"concl=" ++ pr_constr (pf_concl gl))); + (* utils *) + let fs gl t = Reductionops.nf_evar (project gl) t in + let tclMATCH_GOAL (c, gl_c) proj t_ok t_fail gl = + match try Some (pf_unify_HO gl_c (pf_concl gl) c) with _ -> None with + | Some gl_c -> + tclTHEN (Proofview.V82.of_tactic (convert_concl (fs gl_c c))) + (t_ok (proj gl_c)) gl + | None -> t_fail () gl in + let mk_evar gl ty = + let env, sigma, si = pf_env gl, project gl, sig_it gl in + let sigma, x = Evarutil.new_evar env (create_evar_defs sigma) ty in + x, re_sig si sigma in + let arr, gl = pf_mkSsrConst "ssr_congr_arrow" gl in + let ssr_congr lr = mkApp (arr, lr) in + (* here thw two cases: simple equality or arrow *) + let equality, _, eq_args, gl' = + let eq, gl = pf_fresh_global (build_coq_eq ()) gl in + pf_saturate gl eq 3 in + tclMATCH_GOAL (equality, gl') (fun gl' -> fs gl' (List.assoc 0 eq_args)) + (fun ty -> congrtac (arg, Detyping.detype false [] (pf_env gl) (project gl) ty) ist) + (fun () -> + let lhs, gl' = mk_evar gl mkProp in let rhs, gl' = mk_evar gl' mkProp in + let arrow = mkArrow lhs (lift 1 rhs) in + tclMATCH_GOAL (arrow, gl') (fun gl' -> [|fs gl' lhs;fs gl' rhs|]) + (fun lr -> tclTHEN (Proofview.V82.of_tactic (apply (ssr_congr lr))) (congrtac (arg, mkRType) ist)) + (fun _ _ -> errorstrm (str"Conclusion is not an equality nor an arrow"))) + gl +;; + +TACTIC EXTEND ssrcongr +| [ "congr" ssrcongrarg(arg) ] -> +[ let arg, dgens = arg in + Proofview.V82.tactic begin + match dgens with + | [gens], clr -> tclTHEN (genstac (gens,clr) ist) (newssrcongrtac arg ist) + | _ -> errorstrm (str"Dependent family abstractions not allowed in congr") + end] +END + +(** 7. Rewriting tactics (rewrite, unlock) *) + +(** Coq rewrite compatibility flag *) + +let ssr_strict_match = ref false + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optname = "strict redex matching"; + Goptions.optkey = ["Match"; "Strict"]; + Goptions.optread = (fun () -> !ssr_strict_match); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> ssr_strict_match := b) } + +(** Rewrite multiplier *) + +type ssrmult = int * ssrmmod + +let notimes = 0 +let nomult = 1, Once + +let pr_mult (n, m) = + if n > 0 && m <> Once then int n ++ pr_mmod m else pr_mmod m + +let pr_ssrmult _ _ _ = pr_mult + +ARGUMENT EXTEND ssrmult_ne TYPED AS int * ssrmmod PRINTED BY pr_ssrmult + | [ natural(n) ssrmmod(m) ] -> [ check_index loc n, m ] + | [ ssrmmod(m) ] -> [ notimes, m ] +END + +ARGUMENT EXTEND ssrmult TYPED AS ssrmult_ne PRINTED BY pr_ssrmult + | [ ssrmult_ne(m) ] -> [ m ] + | [ ] -> [ nomult ] +END + +(** Rewrite clear/occ switches *) + +let pr_rwocc = function + | None, None -> mt () + | None, occ -> pr_occ occ + | Some clr, _ -> pr_clear_ne clr + +let pr_ssrrwocc _ _ _ = pr_rwocc + +ARGUMENT EXTEND ssrrwocc TYPED AS ssrdocc PRINTED BY pr_ssrrwocc +| [ "{" ssrhyp_list(clr) "}" ] -> [ mkclr clr ] +| [ "{" ssrocc(occ) "}" ] -> [ mkocc occ ] +| [ ] -> [ noclr ] +END + +(** Rewrite rules *) + +type ssrwkind = RWred of ssrsimpl | RWdef | RWeq +(* type ssrrule = ssrwkind * ssrterm *) + +let pr_rwkind = function + | RWred s -> pr_simpl s + | RWdef -> str "/" + | RWeq -> mt () + +let wit_ssrrwkind = add_genarg "ssrrwkind" pr_rwkind + +let pr_rule = function + | RWred s, _ -> pr_simpl s + | RWdef, r-> str "/" ++ pr_term r + | RWeq, r -> pr_term r + +let pr_ssrrule _ _ _ = pr_rule + +let noruleterm loc = mk_term ' ' (mkCProp loc) + +ARGUMENT EXTEND ssrrule_ne TYPED AS ssrrwkind * ssrterm PRINTED BY pr_ssrrule + | [ ssrsimpl_ne(s) ] -> [ RWred s, noruleterm loc ] + | [ "/" ssrterm(t) ] -> [ RWdef, t ] + | [ ssrterm(t) ] -> [ RWeq, t ] +END + +ARGUMENT EXTEND ssrrule TYPED AS ssrrule_ne PRINTED BY pr_ssrrule + | [ ssrrule_ne(r) ] -> [ r ] + | [ ] -> [ RWred Nop, noruleterm loc ] +END + +(** Rewrite arguments *) + +(* type ssrrwarg = (ssrdir * ssrmult) * ((ssrdocc * ssrpattern) * ssrrule) *) + +let pr_option f = function None -> mt() | Some x -> f x +let pr_pattern_squarep= pr_option (fun r -> str "[" ++ pr_rpattern r ++ str "]") +let pr_ssrpattern_squarep _ _ _ = pr_pattern_squarep +let pr_rwarg ((d, m), ((docc, rx), r)) = + pr_rwdir d ++ pr_mult m ++ pr_rwocc docc ++ pr_pattern_squarep rx ++ pr_rule r + +let pr_ssrrwarg _ _ _ = pr_rwarg + +let mk_rwarg (d, (n, _ as m)) ((clr, occ as docc), rx) (rt, _ as r) = + if rt <> RWeq then begin + if rt = RWred Nop && not (m = nomult && occ = None && rx = None) + && (clr = None || clr = Some []) then + anomaly "Improper rewrite clear switch"; + if d = R2L && rt <> RWdef then + Errors.error "Right-to-left switch on simplification"; + if n <> 1 && rt = RWred Cut then + Errors.error "Bad or useless multiplier"; + if occ <> None && rx = None && rt <> RWdef then + Errors.error "Missing redex for simplification occurrence" + end; (d, m), ((docc, rx), r) + +let norwmult = L2R, nomult +let norwocc = noclr, None + +(* +let pattern_ident = Prim.pattern_ident in +GEXTEND Gram +GLOBAL: pattern_ident; +pattern_ident: +[[c = pattern_ident -> (CRef (Ident (loc,c)), NoBindings)]]; +END +*) + +ARGUMENT EXTEND ssrpattern_squarep +TYPED AS rpattern option PRINTED BY pr_ssrpattern_squarep + | [ "[" rpattern(rdx) "]" ] -> [ Some rdx ] + | [ ] -> [ None ] +END + +ARGUMENT EXTEND ssrpattern_ne_squarep +TYPED AS rpattern option PRINTED BY pr_ssrpattern_squarep + | [ "[" rpattern(rdx) "]" ] -> [ Some rdx ] +END + + +ARGUMENT EXTEND ssrrwarg + TYPED AS (ssrdir * ssrmult) * ((ssrdocc * rpattern option) * ssrrule) + PRINTED BY pr_ssrrwarg + | [ "-" ssrmult(m) ssrrwocc(docc) ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg (R2L, m) (docc, rx) r ] + | [ "-/" ssrterm(t) ] -> (* just in case '-/' should become a token *) + [ mk_rwarg (R2L, nomult) norwocc (RWdef, t) ] + | [ ssrmult_ne(m) ssrrwocc(docc) ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg (L2R, m) (docc, rx) r ] + | [ "{" ne_ssrhyp_list(clr) "}" ssrpattern_ne_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (mkclr clr, rx) r ] + | [ "{" ne_ssrhyp_list(clr) "}" ssrrule(r) ] -> + [ mk_rwarg norwmult (mkclr clr, None) r ] + | [ "{" ssrocc(occ) "}" ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (mkocc occ, rx) r ] + | [ "{" "}" ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (nodocc, rx) r ] + | [ ssrpattern_ne_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (noclr, rx) r ] + | [ ssrrule_ne(r) ] -> + [ mk_rwarg norwmult norwocc r ] +END + +let simplintac occ rdx sim gl = + let simptac gl = + let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let simp env c _ = red_safe Tacred.simpl env sigma0 c in + Proofview.V82.of_tactic + (convert_concl_no_check (eval_pattern env0 sigma0 concl0 rdx occ simp)) + gl in + match sim with + | Simpl -> simptac gl + | SimplCut -> tclTHEN simptac (tclTRY donetac) gl + | _ -> simpltac sim gl + +let rec get_evalref c = match kind_of_term c with + | Var id -> EvalVarRef id + | Const (k,_) -> EvalConstRef k + | App (c', _) -> get_evalref c' + | Cast (c', _, _) -> get_evalref c' + | _ -> errorstrm (str "The term " ++ pr_constr c ++ str " is not unfoldable") + +(* Strip a pattern generated by a prenex implicit to its constant. *) +let strip_unfold_term ((sigma, t) as p) kt = match kind_of_term t with + | App (f, a) when kt = ' ' && Array.for_all isEvar a && isConst f -> + (sigma, f), true + | Const _ | Var _ -> p, true + | _ -> p, false + +let unfoldintac occ rdx t (kt,_) gl = + let fs sigma x = Reductionops.nf_evar sigma x in + let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let (sigma, t), const = strip_unfold_term t kt in + let body env t c = + Tacred.unfoldn [OnlyOccurrences [1], get_evalref t] env sigma0 c in + let easy = occ = None && rdx = None in + let red_flags = if easy then Closure.betaiotazeta else Closure.betaiota in + let beta env = Reductionops.clos_norm_flags red_flags env sigma0 in + let unfold, conclude = match rdx with + | Some (_, (In_T _ | In_X_In_T _)) | None -> + let ise = create_evar_defs sigma in + let ise, u = mk_tpattern env0 sigma0 (ise,t) all_ok L2R t in + let find_T, end_T = + mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[u]) in + (fun env c h -> + try find_T env c h (fun env c _ -> body env t c) + with NoMatch when easy -> c + | NoMatch | NoProgress -> errorstrm (str"No occurrence of " + ++ pr_constr_pat t ++ spc() ++ str "in " ++ pr_constr c)), + (fun () -> try end_T () with + | NoMatch when easy -> fake_pmatcher_end () + | NoMatch -> anomaly "unfoldintac") + | _ -> + (fun env (c as orig_c) h -> + if const then + let rec aux c = + match kind_of_term c with + | Const _ when Term.eq_constr c t -> body env t t + | App (f,a) when Term.eq_constr f t -> mkApp (body env f f,a) + | _ -> let c = Reductionops.whd_betaiotazeta sigma0 c in + match kind_of_term c with + | Const _ when Term.eq_constr c t -> body env t t + | App (f,a) when Term.eq_constr f t -> mkApp (body env f f,a) + | Const f -> aux (body env c c) + | App (f, a) -> aux (mkApp (body env f f, a)) + | _ -> errorstrm (str "The term "++pr_constr orig_c++ + str" contains no " ++ pr_constr t ++ str" even after unfolding") + in aux c + else + try body env t (fs (unify_HO env sigma c t) t) + with _ -> errorstrm (str "The term " ++ + pr_constr c ++spc()++ str "does not unify with " ++ pr_constr_pat t)), + fake_pmatcher_end in + let concl = + try beta env0 (eval_pattern env0 sigma0 concl0 rdx occ unfold) + with Option.IsNone -> errorstrm (str"Failed to unfold " ++ pr_constr_pat t) in + let _ = conclude () in + Proofview.V82.of_tactic (convert_concl concl) gl +;; + +let foldtac occ rdx ft gl = + let fs sigma x = Reductionops.nf_evar sigma x in + let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let sigma, t = ft in + let fold, conclude = match rdx with + | Some (_, (In_T _ | In_X_In_T _)) | None -> + let ise = create_evar_defs sigma in + let ut = red_product_skip_id env0 sigma t in + let ise, ut = mk_tpattern env0 sigma0 (ise,t) all_ok L2R ut in + let find_T, end_T = + mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[ut]) in + (fun env c h -> try find_T env c h (fun env t _ -> t) with NoMatch -> c), + (fun () -> try end_T () with NoMatch -> fake_pmatcher_end ()) + | _ -> + (fun env c h -> try let sigma = unify_HO env sigma c t in fs sigma t + with _ -> errorstrm (str "fold pattern " ++ pr_constr_pat t ++ spc () + ++ str "does not match redex " ++ pr_constr_pat c)), + fake_pmatcher_end in + let concl = eval_pattern env0 sigma0 concl0 rdx occ fold in + let _ = conclude () in + Proofview.V82.of_tactic (convert_concl concl) gl +;; + +let converse_dir = function L2R -> R2L | R2L -> L2R + +let rw_progress rhs lhs ise = not (Term.eq_constr lhs (Evarutil.nf_evar ise rhs)) + +(* Coq has a more general form of "equation" (any type with a single *) +(* constructor with no arguments with_rect_r elimination lemmas). *) +(* However there is no clear way of determining the LHS and RHS of *) +(* such a generic Leibnitz equation -- short of inspecting the type *) +(* of the elimination lemmas. *) + +let rec strip_prod_assum c = match kind_of_term c with + | Prod (_, _, c') -> strip_prod_assum c' + | LetIn (_, v, _, c') -> strip_prod_assum (subst1 v c) + | Cast (c', _, _) -> strip_prod_assum c' + | _ -> c + +let rule_id = mk_internal_id "rewrite rule" + +exception PRtype_error +exception PRindetermined_rhs of constr + +let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = +(* pp(lazy(str"sigma@pirrel_rewrite=" ++ pr_evar_map None sigma)); *) + let env = pf_env gl in + let beta = Reductionops.clos_norm_flags Closure.beta env sigma in + let sigma, p = + let sigma = create_evar_defs sigma in + Evarutil.new_evar env sigma (beta (subst1 new_rdx pred)) in + let pred = mkNamedLambda pattern_id rdx_ty pred in + let elim, gl = + let ((kn, i) as ind, _), unfolded_c_ty = pf_reduce_to_quantified_ind gl c_ty in + let sort = elimination_sort_of_goal gl in + let elim, gl = pf_fresh_global (Indrec.lookup_eliminator ind sort) gl in + if dir = R2L then elim, gl else (* taken from Coq's rewrite *) + let elim, _ = destConst elim in + let mp,dp,l = repr_con (constant_of_kn (canonical_con elim)) in + let l' = label_of_id (Nameops.add_suffix (id_of_label l) "_r") in + let c1' = Global.constant_of_delta_kn (canonical_con (make_con mp dp l')) in + mkConst c1', gl in + let proof = mkApp (elim, [| rdx_ty; new_rdx; pred; p; rdx; c |]) in + (* We check the proof is well typed *) + let sigma, proof_ty = + try Typing.e_type_of env sigma proof with _ -> raise PRtype_error in + pp(lazy(str"pirrel_rewrite proof term of type: " ++ pr_constr proof_ty)); + try refine_with + ~first_goes_last:(not !ssroldreworder) ~with_evars:false (sigma, proof) gl + with _ -> + (* we generate a msg like: "Unable to find an instance for the variable" *) + let c = Reductionops.nf_evar sigma c in + let hd_ty, miss = match kind_of_term c with + | App (hd, args) -> + let hd_ty = Retyping.get_type_of env sigma hd in + let names = let rec aux t = function 0 -> [] | n -> + let t = Reductionops.whd_betadeltaiota env sigma t in + match kind_of_type t with + | ProdType (name, _, t) -> name :: aux t (n-1) + | _ -> assert false in aux hd_ty (Array.length args) in + hd_ty, Util.List.map_filter (fun (t, name) -> + let evs = Intset.elements (Evarutil.undefined_evars_of_term sigma t) in + let open_evs = List.filter (fun k -> + InProp <> Retyping.get_sort_family_of + env sigma (Evd.evar_concl (Evd.find sigma k))) + evs in + if open_evs <> [] then Some name else None) + (List.combine (Array.to_list args) names) + | _ -> anomaly "rewrite rule not an application" in + errorstrm (Himsg.explain_refiner_error (Logic.UnresolvedBindings miss)++ + (Pp.fnl()++str"Rule's type:" ++ spc() ++ pr_constr hd_ty)) +;; + +let is_const_ref c r = isConst c && eq_gr (ConstRef (fst(destConst c))) r +let is_construct_ref c r = + isConstruct c && eq_gr (ConstructRef (fst(destConstruct c))) r +let is_ind_ref c r = isInd c && eq_gr (IndRef (fst(destInd c))) r + +let rwcltac cl rdx dir sr gl = + let n, r_n,_, ucst = pf_abs_evars gl sr in + let r_n' = pf_abs_cterm gl n r_n in + let r' = subst_var pattern_id r_n' in + let gl = pf_merge_uc ucst gl in + let rdxt = Retyping.get_type_of (pf_env gl) (fst sr) rdx in +(* pp(lazy(str"sigma@rwcltac=" ++ pr_evar_map None (fst sr))); *) + pp(lazy(str"r@rwcltac=" ++ pr_constr (snd sr))); + let cvtac, rwtac, gl = + if closed0 r' then + let env, sigma, c, c_eq = pf_env gl, fst sr, snd sr, build_coq_eq () in + let sigma, c_ty = Typing.e_type_of env sigma c in + pp(lazy(str"c_ty@rwcltac=" ++ pr_constr c_ty)); + match kind_of_type (Reductionops.whd_betadeltaiota env sigma c_ty) with + | AtomicType(e, a) when is_ind_ref e c_eq -> + let new_rdx = if dir = L2R then a.(2) else a.(1) in + pirrel_rewrite cl rdx rdxt new_rdx dir (sigma,c) c_ty, tclIDTAC, gl + | _ -> + let cl' = mkApp (mkNamedLambda pattern_id rdxt cl, [|rdx|]) in + let sigma, _ = Typing.e_type_of env sigma cl' in + let gl = pf_merge_uc_of sigma gl in + Proofview.V82.of_tactic (convert_concl cl'), rewritetac dir r', gl + else + let dc, r2 = decompose_lam_n n r' in + let r3, _, r3t = + try destCast r2 with _ -> + errorstrm (str "no cast from " ++ pr_constr_pat (snd sr) + ++ str " to " ++ pr_constr r2) in + let cl' = mkNamedProd rule_id (compose_prod dc r3t) (lift 1 cl) in + let cl'' = mkNamedProd pattern_id rdxt cl' in + let itacs = [introid pattern_id; introid rule_id] in + let cltac = clear [pattern_id; rule_id] in + let rwtacs = [rewritetac dir (mkVar rule_id); cltac] in + apply_type cl'' [rdx; compose_lam dc r3], tclTHENLIST (itacs @ rwtacs), gl + in + let cvtac' _ = + try cvtac gl with + | PRtype_error -> + if occur_existential (pf_concl gl) + then errorstrm (str "Rewriting impacts evars") + else errorstrm (str "Dependent type error in rewrite of " + ++ pf_pr_constr gl (project gl) (mkNamedLambda pattern_id rdxt cl)) + | Errors.UserError _ as e -> raise e + | e -> anomaly ("cvtac's exception: " ^ Printexc.to_string e); + in + tclTHEN cvtac' rwtac gl + +let prof_rwcltac = mk_profiler "rwrxtac.rwcltac";; +let rwcltac cl rdx dir sr gl = + prof_rwcltac.profile (rwcltac cl rdx dir sr) gl +;; + + +let lz_coq_prod = + let prod = lazy (build_prod ()) in fun () -> Lazy.force prod + +let lz_setoid_relation = + let sdir = ["Classes"; "RelationClasses"] in + let last_srel = ref (Environ.empty_env, None) in + fun env -> match !last_srel with + | env', srel when env' == env -> srel + | _ -> + let srel = + try Some (coq_constant "Class_setoid" sdir "RewriteRelation") + with _ -> None in + last_srel := (env, srel); srel + +let ssr_is_setoid env = + match lz_setoid_relation env with + | None -> fun _ _ _ -> false + | Some srel -> + fun sigma r args -> + Rewrite.is_applied_rewrite_relation env + sigma [] (mkApp (r, args)) <> None + +let prof_rwxrtac_find_rule = mk_profiler "rwrxtac.find_rule";; + +let closed0_check cl p gl = + if closed0 cl then + errorstrm (str"No occurrence of redex "++pf_pr_constr gl (project gl) p) + +let rwrxtac occ rdx_pat dir rule gl = + let env = pf_env gl in + let coq_prod = lz_coq_prod () in + let is_setoid = ssr_is_setoid env in + let r_sigma, rules = + let rec loop d sigma r t0 rs red = + let t = + if red = 1 then Tacred.hnf_constr env sigma t0 + else Reductionops.whd_betaiotazeta sigma t0 in + pp(lazy(str"rewrule="++pr_constr t)); + match kind_of_term t with + | Prod (_, xt, at) -> + let ise, x = Evarutil.new_evar env (create_evar_defs sigma) xt in + loop d ise (mkApp (r, [|x|])) (subst1 x at) rs 0 + | App (pr, a) when is_ind_ref pr coq_prod.Coqlib.typ -> + let sr sigma = match kind_of_term (Tacred.hnf_constr env sigma r) with + | App (c, ra) when is_construct_ref c coq_prod.Coqlib.intro -> + fun i -> ra.(i + 1), sigma + | _ -> let ra = Array.append a [|r|] in + function 1 -> + let sigma, pi1 = Evd.fresh_global env sigma coq_prod.Coqlib.proj1 in + mkApp (pi1, ra), sigma + | _ -> + let sigma, pi2 = Evd.fresh_global env sigma coq_prod.Coqlib.proj2 in + mkApp (pi2, ra), sigma in + if Term.eq_constr a.(0) (build_coq_True ()) then + let s, sigma = sr sigma 2 in + loop (converse_dir d) sigma s a.(1) rs 0 + else + let s, sigma = sr sigma 2 in + let sigma, rs2 = loop d sigma s a.(1) rs 0 in + let s, sigma = sr sigma 1 in + loop d sigma s a.(0) rs2 0 + | App (r_eq, a) when Hipattern.match_with_equality_type t != None -> + let indu = destInd r_eq and rhs = Array.last a in + let np = Inductiveops.inductive_nparamdecls (fst indu) in + let ind_ct = Inductiveops.type_of_constructors env indu in + let lhs0 = last_arg (strip_prod_assum ind_ct.(0)) in + let rdesc = match kind_of_term lhs0 with + | Rel i -> + let lhs = a.(np - i) in + let lhs, rhs = if d = L2R then lhs, rhs else rhs, lhs in +(* msgnl (str "RW: " ++ pr_rwdir d ++ str " " ++ pr_constr_pat r ++ str " : " + ++ pr_constr_pat lhs ++ str " ~> " ++ pr_constr_pat rhs); *) + d, r, lhs, rhs +(* + let l_i, r_i = if d = L2R then i, 1 - ndep else 1 - ndep, i in + let lhs = a.(np - l_i) and rhs = a.(np - r_i) in + let a' = Array.copy a in let _ = a'.(np - l_i) <- mkVar pattern_id in + let r' = mkCast (r, DEFAULTcast, mkApp (r_eq, a')) in + (d, r', lhs, rhs) +*) + | _ -> + let lhs = substl (array_list_of_tl (Array.sub a 0 np)) lhs0 in + let lhs, rhs = if d = R2L then lhs, rhs else rhs, lhs in + let d' = if Array.length a = 1 then d else converse_dir d in + d', r, lhs, rhs in + sigma, rdesc :: rs + | App (s_eq, a) when is_setoid sigma s_eq a -> + let np = Array.length a and i = 3 - dir_org d in + let lhs = a.(np - i) and rhs = a.(np + i - 3) in + let a' = Array.copy a in let _ = a'.(np - i) <- mkVar pattern_id in + let r' = mkCast (r, DEFAULTcast, mkApp (s_eq, a')) in + sigma, (d, r', lhs, rhs) :: rs + | _ -> + if red = 0 then loop d sigma r t rs 1 + else errorstrm (str "not a rewritable relation: " ++ pr_constr_pat t + ++ spc() ++ str "in rule " ++ pr_constr_pat (snd rule)) + in + let sigma, r = rule in + let t = Retyping.get_type_of env sigma r in + loop dir sigma r t [] 0 in + let find_rule rdx = + let rec rwtac = function + | [] -> + errorstrm (str "pattern " ++ pr_constr_pat rdx ++ + str " does not match " ++ pr_dir_side dir ++ + str " of " ++ pr_constr_pat (snd rule)) + | (d, r, lhs, rhs) :: rs -> + try + let ise = unify_HO env (create_evar_defs r_sigma) lhs rdx in + if not (rw_progress rhs rdx ise) then raise NoMatch else + d, (ise, Evd.evar_universe_context ise, Reductionops.nf_evar ise r) + with _ -> rwtac rs in + rwtac rules in + let find_rule rdx = prof_rwxrtac_find_rule.profile find_rule rdx in + let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in + let find_R, conclude = match rdx_pat with + | Some (_, (In_T _ | In_X_In_T _)) | None -> + let upats_origin = dir, snd rule in + let rpat env sigma0 (sigma, pats) (d, r, lhs, rhs) = + let sigma, pat = + mk_tpattern env sigma0 (sigma,r) (rw_progress rhs) d lhs in + sigma, pats @ [pat] in + let rpats = List.fold_left (rpat env0 sigma0) (r_sigma,[]) rules in + let find_R, end_R = mk_tpattern_matcher sigma0 occ ~upats_origin rpats in + find_R ~k:(fun _ _ h -> mkRel h), + fun cl -> let rdx,d,r = end_R () in closed0_check cl rdx gl; (d,r),rdx + | Some(_, (T e | X_In_T (_,e) | E_As_X_In_T (e,_,_) | E_In_X_In_T (e,_,_))) -> + let r = ref None in + (fun env c h -> do_once r (fun () -> find_rule c, c); mkRel h), + (fun concl -> closed0_check concl e gl; assert_done r) in + let concl = eval_pattern env0 sigma0 concl0 rdx_pat occ find_R in + let (d, r), rdx = conclude concl in + let r = Evd.merge_universe_context (pi1 r) (pi2 r), pi3 r in + rwcltac concl rdx d r gl +;; + +let prof_rwxrtac = mk_profiler "rwrxtac";; +let rwrxtac occ rdx_pat dir rule gl = + prof_rwxrtac.profile (rwrxtac occ rdx_pat dir rule) gl +;; + + +(* Resolve forward reference *) +let _ = + ipat_rewritetac := fun occ dir c gl -> rwrxtac occ None dir (project gl, c) gl + +let rwargtac ist ((dir, mult), (((oclr, occ), grx), (kind, gt))) gl = + let fail = ref false in + let interp_rpattern ist gl gc = + try interp_rpattern ist gl gc + with _ when snd mult = May -> fail := true; project gl, T mkProp in + let interp gc gl = + try interp_term ist gl gc + with _ when snd mult = May -> fail := true; (project gl, mkProp) in + let rwtac gl = + let rx = Option.map (interp_rpattern ist gl) grx in + let t = interp gt gl in + (match kind with + | RWred sim -> simplintac occ rx sim + | RWdef -> if dir = R2L then foldtac occ rx t else unfoldintac occ rx t gt + | RWeq -> rwrxtac occ rx dir t) gl in + let ctac = cleartac (interp_clr (oclr, (fst gt, snd (interp gt gl)))) in + if !fail then ctac gl else tclTHEN (tclMULT mult rwtac) ctac gl + +(** Rewrite argument sequence *) + +(* type ssrrwargs = ssrrwarg list *) + +let pr_ssrrwargs _ _ _ rwargs = pr_list spc pr_rwarg rwargs + +ARGUMENT EXTEND ssrrwargs TYPED AS ssrrwarg list PRINTED BY pr_ssrrwargs + | [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let ssr_rw_syntax = Summary.ref ~name:"SSR:rewrite" true + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optname = "ssreflect rewrite"; + Goptions.optkey = ["SsrRewrite"]; + Goptions.optread = (fun _ -> !ssr_rw_syntax); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> ssr_rw_syntax := b) } + +let test_ssr_rw_syntax = + let test strm = + if not !ssr_rw_syntax then raise Stream.Failure else + if is_ssr_loaded () then () else + match Compat.get_tok (Util.stream_nth 0 strm) with + | Tok.KEYWORD key when List.mem key.[0] ['{'; '['; '/'] -> () + | _ -> raise Stream.Failure in + Gram.Entry.of_parser "test_ssr_rw_syntax" test + +GEXTEND Gram + GLOBAL: ssrrwargs; + ssrrwargs: [[ test_ssr_rw_syntax; a = LIST1 ssrrwarg -> a ]]; +END + +(** The "rewrite" tactic *) + +let ssrrewritetac ist rwargs = + tclTHENLIST (List.map (rwargtac ist) rwargs) + +TACTIC EXTEND ssrrewrite + | [ "rewrite" ssrrwargs(args) ssrclauses(clauses) ] -> + [ Proofview.V82.tactic (tclCLAUSES ist (ssrrewritetac ist args) clauses) ] +END + +(** The "unlock" tactic *) + +let pr_unlockarg (occ, t) = pr_occ occ ++ pr_term t +let pr_ssrunlockarg _ _ _ = pr_unlockarg + +ARGUMENT EXTEND ssrunlockarg TYPED AS ssrocc * ssrterm + PRINTED BY pr_ssrunlockarg + | [ "{" ssrocc(occ) "}" ssrterm(t) ] -> [ occ, t ] + | [ ssrterm(t) ] -> [ None, t ] +END + +let pr_ssrunlockargs _ _ _ args = pr_list spc pr_unlockarg args + +ARGUMENT EXTEND ssrunlockargs TYPED AS ssrunlockarg list + PRINTED BY pr_ssrunlockargs + | [ ssrunlockarg_list(args) ] -> [ args ] +END + +let unfoldtac occ ko t kt gl = + let cl, c = pf_fill_occ_term gl occ (fst (strip_unfold_term t kt)) in + let cl' = subst1 (pf_unfoldn [OnlyOccurrences [1], get_evalref c] gl c) cl in + let f = if ko = None then Closure.betaiotazeta else Closure.betaiota in + Proofview.V82.of_tactic + (convert_concl (pf_reduce (Reductionops.clos_norm_flags f) gl cl')) gl + +let unlocktac ist args gl = + let utac (occ, gt) gl = + unfoldtac occ occ (interp_term ist gl gt) (fst gt) gl in + let locked, gl = pf_mkSsrConst "locked" gl in + let key, gl = pf_mkSsrConst "master_key" gl in + let ktacs = [ + (fun gl -> unfoldtac None None (project gl,locked) '(' gl); + simplest_newcase key ] in + tclTHENLIST (List.map utac args @ ktacs) gl + +TACTIC EXTEND ssrunlock + | [ "unlock" ssrunlockargs(args) ssrclauses(clauses) ] -> +[ Proofview.V82.tactic (tclCLAUSES ist (unlocktac ist args) clauses) ] +END + +(** 8. Forward chaining tactics (pose, set, have, suffice, wlog) *) + +(** Defined identifier *) + +type ssrfwdid = identifier + +let pr_ssrfwdid _ _ _ id = pr_spc () ++ pr_id id + +(* We use a primitive parser for the head identifier of forward *) +(* tactis to avoid syntactic conflicts with basic Coq tactics. *) +ARGUMENT EXTEND ssrfwdid TYPED AS ident PRINTED BY pr_ssrfwdid + | [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let accept_ssrfwdid strm = + match Compat.get_tok (stream_nth 0 strm) with + | Tok.IDENT id -> accept_before_syms_or_any_id [":"; ":="; "("] strm + | _ -> raise Stream.Failure + + +let test_ssrfwdid = Gram.Entry.of_parser "test_ssrfwdid" accept_ssrfwdid + +GEXTEND Gram + GLOBAL: ssrfwdid; + ssrfwdid: [[ test_ssrfwdid; id = Prim.ident -> id ]]; + END + + + +(** Definition value formatting *) + +(* We use an intermediate structure to correctly render the binder list *) +(* abbreviations. We use a list of hints to extract the binders and *) +(* base term from a term, for the two first levels of representation of *) +(* of constr terms. *) + +type 'term ssrbind = + | Bvar of name + | Bdecl of name list * 'term + | Bdef of name * 'term option * 'term + | Bstruct of name + | Bcast of 'term + +let pr_binder prl = function + | Bvar x -> + pr_name x + | Bdecl (xs, t) -> + str "(" ++ pr_list pr_spc pr_name xs ++ str " : " ++ prl t ++ str ")" + | Bdef (x, None, v) -> + str "(" ++ pr_name x ++ str " := " ++ prl v ++ str ")" + | Bdef (x, Some t, v) -> + str "(" ++ pr_name x ++ str " : " ++ prl t ++ + str " := " ++ prl v ++ str ")" + | Bstruct x -> + str "{struct " ++ pr_name x ++ str "}" + | Bcast t -> + str ": " ++ prl t + +type 'term ssrbindval = 'term ssrbind list * 'term + +type ssrbindfmt = + | BFvar + | BFdecl of int (* #xs *) + | BFcast (* final cast *) + | BFdef of bool (* has cast? *) + | BFrec of bool * bool (* has struct? * has cast? *) + +let rec mkBstruct i = function + | Bvar x :: b -> + if i = 0 then [Bstruct x] else mkBstruct (i - 1) b + | Bdecl (xs, _) :: b -> + let i' = i - List.length xs in + if i' < 0 then [Bstruct (List.nth xs i)] else mkBstruct i' b + | _ :: b -> mkBstruct i b + | [] -> [] + +let rec format_local_binders h0 bl0 = match h0, bl0 with + | BFvar :: h, LocalRawAssum ([_, x], _, _) :: bl -> + Bvar x :: format_local_binders h bl + | BFdecl _ :: h, LocalRawAssum (lxs, _, t) :: bl -> + Bdecl (List.map snd lxs, t) :: format_local_binders h bl + | BFdef false :: h, LocalRawDef ((_, x), v) :: bl -> + Bdef (x, None, v) :: format_local_binders h bl + | BFdef true :: h, + LocalRawDef ((_, x), CCast (_, v, CastConv t)) :: bl -> + Bdef (x, Some t, v) :: format_local_binders h bl + | _ -> [] + +let rec format_constr_expr h0 c0 = match h0, c0 with + | BFvar :: h, CLambdaN (_, [[_, x], _, _], c) -> + let bs, c' = format_constr_expr h c in + Bvar x :: bs, c' + | BFdecl _:: h, CLambdaN (_, [lxs, _, t], c) -> + let bs, c' = format_constr_expr h c in + Bdecl (List.map snd lxs, t) :: bs, c' + | BFdef false :: h, CLetIn(_, (_, x), v, c) -> + let bs, c' = format_constr_expr h c in + Bdef (x, None, v) :: bs, c' + | BFdef true :: h, CLetIn(_, (_, x), CCast (_, v, CastConv t), c) -> + let bs, c' = format_constr_expr h c in + Bdef (x, Some t, v) :: bs, c' + | [BFcast], CCast (_, c, CastConv t) -> + [Bcast t], c + | BFrec (has_str, has_cast) :: h, + CFix (_, _, [_, (Some locn, CStructRec), bl, t, c]) -> + let bs = format_local_binders h bl in + let bstr = if has_str then [Bstruct (Name (snd locn))] else [] in + bs @ bstr @ (if has_cast then [Bcast t] else []), c + | BFrec (_, has_cast) :: h, CCoFix (_, _, [_, bl, t, c]) -> + format_local_binders h bl @ (if has_cast then [Bcast t] else []), c + | _, c -> + [], c + +let rec format_glob_decl h0 d0 = match h0, d0 with + | BFvar :: h, (x, _, None, _) :: d -> + Bvar x :: format_glob_decl h d + | BFdecl 1 :: h, (x, _, None, t) :: d -> + Bdecl ([x], t) :: format_glob_decl h d + | BFdecl n :: h, (x, _, None, t) :: d when n > 1 -> + begin match format_glob_decl (BFdecl (n - 1) :: h) d with + | Bdecl (xs, _) :: bs -> Bdecl (x :: xs, t) :: bs + | bs -> Bdecl ([x], t) :: bs + end + | BFdef false :: h, (x, _, Some v, _) :: d -> + Bdef (x, None, v) :: format_glob_decl h d + | BFdef true:: h, (x, _, Some (GCast (_, v, CastConv t)), _) :: d -> + Bdef (x, Some t, v) :: format_glob_decl h d + | _, (x, _, None, t) :: d -> + Bdecl ([x], t) :: format_glob_decl [] d + | _, (x, _, Some v, _) :: d -> + Bdef (x, None, v) :: format_glob_decl [] d + | _, [] -> [] + +let rec format_glob_constr h0 c0 = match h0, c0 with + | BFvar :: h, GLambda (_, x, _, _, c) -> + let bs, c' = format_glob_constr h c in + Bvar x :: bs, c' + | BFdecl 1 :: h, GLambda (_, x, _, t, c) -> + let bs, c' = format_glob_constr h c in + Bdecl ([x], t) :: bs, c' + | BFdecl n :: h, GLambda (_, x, _, t, c) when n > 1 -> + begin match format_glob_constr (BFdecl (n - 1) :: h) c with + | Bdecl (xs, _) :: bs, c' -> Bdecl (x :: xs, t) :: bs, c' + | _ -> [Bdecl ([x], t)], c + end + | BFdef false :: h, GLetIn(_, x, v, c) -> + let bs, c' = format_glob_constr h c in + Bdef (x, None, v) :: bs, c' + | BFdef true :: h, GLetIn(_, x, GCast (_, v, CastConv t), c) -> + let bs, c' = format_glob_constr h c in + Bdef (x, Some t, v) :: bs, c' + | [BFcast], GCast (_, c, CastConv t) -> + [Bcast t], c + | BFrec (has_str, has_cast) :: h, GRec (_, f, _, bl, t, c) + when Array.length c = 1 -> + let bs = format_glob_decl h bl.(0) in + let bstr = match has_str, f with + | true, GFix ([|Some i, GStructRec|], _) -> mkBstruct i bs + | _ -> [] in + bs @ bstr @ (if has_cast then [Bcast t.(0)] else []), c.(0) + | _, c -> + [], c + +(** Forward chaining argument *) + +(* There are three kinds of forward definitions: *) +(* - Hint: type only, cast to Type, may have proof hint. *) +(* - Have: type option + value, no space before type *) +(* - Pose: binders + value, space before binders. *) + +type ssrfwdkind = FwdHint of string * bool | FwdHave | FwdPose + +type ssrfwdfmt = ssrfwdkind * ssrbindfmt list + +let pr_fwdkind = function + | FwdHint (s,_) -> str (s ^ " ") | _ -> str " :=" ++ spc () +let pr_fwdfmt (fk, _ : ssrfwdfmt) = pr_fwdkind fk + +let wit_ssrfwdfmt = add_genarg "ssrfwdfmt" pr_fwdfmt + +(* type ssrfwd = ssrfwdfmt * ssrterm *) + +let mkFwdVal fk c = ((fk, []), mk_term ' ' c) +let mkssrFwdVal fk c = ((fk, []), (c,None)) + +let mkFwdCast fk loc t c = ((fk, [BFcast]), mk_term ' ' (CCast (loc, c, dC t))) +let mkssrFwdCast fk loc t c = ((fk, [BFcast]), (c, Some t)) + +let mkFwdHint s t = + let loc = constr_loc t in + mkFwdCast (FwdHint (s,false)) loc t (mkCHole loc) +let mkFwdHintNoTC s t = + let loc = constr_loc t in + mkFwdCast (FwdHint (s,true)) loc t (mkCHole loc) + +let pr_gen_fwd prval prc prlc fk (bs, c) = + let prc s = str s ++ spc () ++ prval prc prlc c in + match fk, bs with + | FwdHint (s,_), [Bcast t] -> str s ++ spc () ++ prlc t + | FwdHint (s,_), _ -> prc (s ^ "(* typeof *)") + | FwdHave, [Bcast t] -> str ":" ++ spc () ++ prlc t ++ prc " :=" + | _, [] -> prc " :=" + | _, _ -> spc () ++ pr_list spc (pr_binder prlc) bs ++ prc " :=" + +let pr_fwd_guarded prval prval' = function +| (fk, h), (_, (_, Some c)) -> + pr_gen_fwd prval pr_constr_expr prl_constr_expr fk (format_constr_expr h c) +| (fk, h), (_, (c, None)) -> + pr_gen_fwd prval' pr_glob_constr prl_glob_constr fk (format_glob_constr h c) + +let pr_unguarded prc prlc = prlc + +let pr_fwd = pr_fwd_guarded pr_unguarded pr_unguarded +let pr_ssrfwd _ _ _ = pr_fwd + +ARGUMENT EXTEND ssrfwd TYPED AS (ssrfwdfmt * ssrterm) PRINTED BY pr_ssrfwd + | [ ":=" lconstr(c) ] -> [ mkFwdVal FwdPose c ] + | [ ":" lconstr (t) ":=" lconstr(c) ] -> [ mkFwdCast FwdPose loc t c ] +END + +(** Independent parsing for binders *) + +(* The pose, pose fix, and pose cofix tactics use these internally to *) +(* parse argument fragments. *) + +let pr_ssrbvar prc _ _ v = prc v + +ARGUMENT EXTEND ssrbvar TYPED AS constr PRINTED BY pr_ssrbvar +| [ ident(id) ] -> [ mkCVar loc id ] +| [ "_" ] -> [ mkCHole loc ] +END + +let bvar_lname = function + | CRef (Ident (loc, id), _) -> loc, Name id + | c -> constr_loc c, Anonymous + +let pr_ssrbinder prc _ _ (_, c) = prc c + +ARGUMENT EXTEND ssrbinder TYPED AS ssrfwdfmt * constr PRINTED BY pr_ssrbinder + | [ ssrbvar(bv) ] -> + [ let xloc, _ as x = bvar_lname bv in + (FwdPose, [BFvar]), + CLambdaN (loc,[[x],Default Explicit,mkCHole xloc],mkCHole loc) ] + | [ "(" ssrbvar(bv) ")" ] -> + [ let xloc, _ as x = bvar_lname bv in + (FwdPose, [BFvar]), + CLambdaN (loc,[[x],Default Explicit,mkCHole xloc],mkCHole loc) ] + | [ "(" ssrbvar(bv) ":" lconstr(t) ")" ] -> + [ let x = bvar_lname bv in + (FwdPose, [BFdecl 1]), + CLambdaN (loc, [[x], Default Explicit, t], mkCHole loc) ] + | [ "(" ssrbvar(bv) ne_ssrbvar_list(bvs) ":" lconstr(t) ")" ] -> + [ let xs = List.map bvar_lname (bv :: bvs) in + let n = List.length xs in + (FwdPose, [BFdecl n]), + CLambdaN (loc, [xs, Default Explicit, t], mkCHole loc) ] + | [ "(" ssrbvar(id) ":" lconstr(t) ":=" lconstr(v) ")" ] -> + [ let loc' = Loc.join_loc (constr_loc t) (constr_loc v) in + let v' = CCast (loc', v, dC t) in + (FwdPose,[BFdef true]), CLetIn (loc,bvar_lname id, v',mkCHole loc) ] + | [ "(" ssrbvar(id) ":=" lconstr(v) ")" ] -> + [ (FwdPose,[BFdef false]), CLetIn (loc,bvar_lname id, v,mkCHole loc) ] +END + +GEXTEND Gram + GLOBAL: ssrbinder; + ssrbinder: [ + [ ["of" | "&"]; c = operconstr LEVEL "99" -> + let loc = !@loc in + (FwdPose, [BFvar]), + CLambdaN (loc,[[loc,Anonymous],Default Explicit,c],mkCHole loc) ] + ]; +END + +let rec binders_fmts = function + | ((_, h), _) :: bs -> h @ binders_fmts bs + | _ -> [] + +let push_binders c2 bs = + let loc2 = constr_loc c2 in let mkloc loc1 = Loc.join_loc loc1 loc2 in + let rec loop ty c = function + | (_, CLambdaN (loc1, b, _)) :: bs when ty -> + CProdN (mkloc loc1, b, loop ty c bs) + | (_, CLambdaN (loc1, b, _)) :: bs -> + CLambdaN (mkloc loc1, b, loop ty c bs) + | (_, CLetIn (loc1, x, v, _)) :: bs -> + CLetIn (mkloc loc1, x, v, loop ty c bs) + | [] -> c + | _ -> anomaly "binder not a lambda nor a let in" in + match c2 with + | CCast (x, ct, CastConv cty) -> + (CCast (x, loop false ct bs, CastConv (loop true cty bs))) + | ct -> loop false ct bs + +let rec fix_binders = function + | (_, CLambdaN (_, [xs, _, t], _)) :: bs -> + LocalRawAssum (xs, Default Explicit, t) :: fix_binders bs + | (_, CLetIn (_, x, v, _)) :: bs -> + LocalRawDef (x, v) :: fix_binders bs + | _ -> [] + +let pr_ssrstruct _ _ _ = function + | Some id -> str "{struct " ++ pr_id id ++ str "}" + | None -> mt () + +ARGUMENT EXTEND ssrstruct TYPED AS ident option PRINTED BY pr_ssrstruct +| [ "{" "struct" ident(id) "}" ] -> [ Some id ] +| [ ] -> [ None ] +END + +(** The "pose" tactic *) + +(* The plain pose form. *) + +let bind_fwd bs = function + | (fk, h), (ck, (rc, Some c)) -> + (fk,binders_fmts bs @ h), (ck,(rc,Some (push_binders c bs))) + | fwd -> fwd + +ARGUMENT EXTEND ssrposefwd TYPED AS ssrfwd PRINTED BY pr_ssrfwd + | [ ssrbinder_list(bs) ssrfwd(fwd) ] -> [ bind_fwd bs fwd ] +END + +(* The pose fix form. *) + +let pr_ssrfixfwd _ _ _ (id, fwd) = str " fix " ++ pr_id id ++ pr_fwd fwd + +let bvar_locid = function + | CRef (Ident (loc, id), _) -> loc, id + | _ -> Errors.error "Missing identifier after \"(co)fix\"" + + +ARGUMENT EXTEND ssrfixfwd TYPED AS ident * ssrfwd PRINTED BY pr_ssrfixfwd + | [ "fix" ssrbvar(bv) ssrbinder_list(bs) ssrstruct(sid) ssrfwd(fwd) ] -> + [ let (_, id) as lid = bvar_locid bv in + let (fk, h), (ck, (rc, oc)) = fwd in + let c = Option.get oc in + let has_cast, t', c' = match format_constr_expr h c with + | [Bcast t'], c' -> true, t', c' + | _ -> false, mkCHole (constr_loc c), c in + let lb = fix_binders bs in + let has_struct, i = + let rec loop = function + (l', Name id') :: _ when Option.equal Id.equal sid (Some id') -> true, (l', id') + | [l', Name id'] when sid = None -> false, (l', id') + | _ :: bn -> loop bn + | [] -> Errors.error "Bad structural argument" in + loop (names_of_local_assums lb) in + let h' = BFrec (has_struct, has_cast) :: binders_fmts bs in + let fix = CFix (loc, lid, [lid, (Some i, CStructRec), lb, t', c']) in + id, ((fk, h'), (ck, (rc, Some fix))) ] +END + + +(* The pose cofix form. *) + +let pr_ssrcofixfwd _ _ _ (id, fwd) = str " cofix " ++ pr_id id ++ pr_fwd fwd + +ARGUMENT EXTEND ssrcofixfwd TYPED AS ssrfixfwd PRINTED BY pr_ssrcofixfwd + | [ "cofix" ssrbvar(bv) ssrbinder_list(bs) ssrfwd(fwd) ] -> + [ let _, id as lid = bvar_locid bv in + let (fk, h), (ck, (rc, oc)) = fwd in + let c = Option.get oc in + let has_cast, t', c' = match format_constr_expr h c with + | [Bcast t'], c' -> true, t', c' + | _ -> false, mkCHole (constr_loc c), c in + let h' = BFrec (false, has_cast) :: binders_fmts bs in + let cofix = CCoFix (loc, lid, [lid, fix_binders bs, t', c']) in + id, ((fk, h'), (ck, (rc, Some cofix))) + ] +END + +let ssrposetac ist (id, (_, t)) gl = + let sigma, t, ucst = pf_abs_ssrterm ist gl t in + posetac id t (pf_merge_uc ucst gl) + + +let prof_ssrposetac = mk_profiler "ssrposetac";; +let ssrposetac arg gl = prof_ssrposetac.profile (ssrposetac arg) gl;; + +TACTIC EXTEND ssrpose +| [ "pose" ssrfixfwd(ffwd) ] -> [ Proofview.V82.tactic (ssrposetac ist ffwd) ] +| [ "pose" ssrcofixfwd(ffwd) ] -> [ Proofview.V82.tactic (ssrposetac ist ffwd) ] +| [ "pose" ssrfwdid(id) ssrposefwd(fwd) ] -> [ Proofview.V82.tactic (ssrposetac ist (id, fwd)) ] +END + +(** The "set" tactic *) + +(* type ssrsetfwd = ssrfwd * ssrdocc *) + +let guard_setrhs s i = s.[i] = '{' + +let pr_setrhs occ prc prlc c = + if occ = nodocc then pr_guarded guard_setrhs prlc c else pr_docc occ ++ prc c + +let pr_fwd_guarded prval prval' = function +| (fk, h), (_, (_, Some c)) -> + pr_gen_fwd prval pr_constr_expr prl_constr_expr fk (format_constr_expr h c) +| (fk, h), (_, (c, None)) -> + pr_gen_fwd prval' pr_glob_constr prl_glob_constr fk (format_glob_constr h c) + +(* This does not print the type, it should be fixed... *) +let pr_ssrsetfwd _ _ _ (((fk,_),(t,_)), docc) = + pr_gen_fwd (fun _ _ -> pr_cpattern) + (fun _ -> mt()) (fun _ -> mt()) fk ([Bcast ()],t) + +ARGUMENT EXTEND ssrsetfwd +TYPED AS (ssrfwdfmt * (lcpattern * ssrterm option)) * ssrdocc +PRINTED BY pr_ssrsetfwd +| [ ":" lconstr(t) ":=" "{" ssrocc(occ) "}" cpattern(c) ] -> + [ mkssrFwdCast FwdPose loc (mk_lterm t) c, mkocc occ ] +| [ ":" lconstr(t) ":=" lcpattern(c) ] -> + [ mkssrFwdCast FwdPose loc (mk_lterm t) c, nodocc ] +| [ ":=" "{" ssrocc(occ) "}" cpattern(c) ] -> + [ mkssrFwdVal FwdPose c, mkocc occ ] +| [ ":=" lcpattern(c) ] -> [ mkssrFwdVal FwdPose c, nodocc ] +END + +let ssrsettac ist id ((_, (pat, pty)), (_, occ)) gl = + let pat = interp_cpattern ist gl pat (Option.map snd pty) in + let cl, sigma, env = pf_concl gl, project gl, pf_env gl in + let (c, ucst), cl = + try fill_occ_pattern ~raise_NoMatch:true env sigma cl pat occ 1 + with NoMatch -> redex_of_pattern ~resolve_typeclasses:true env pat, cl in + if occur_existential c then errorstrm(str"The pattern"++spc()++ + pr_constr_pat c++spc()++str"did not match and has holes."++spc()++ + str"Did you mean pose?") else + let c, cty = match kind_of_term c with + | Cast(t, DEFAULTcast, ty) -> t, ty + | _ -> c, pf_type_of gl c in + let cl' = mkLetIn (Name id, c, cty, cl) in + let gl = pf_merge_uc ucst gl in + tclTHEN (Proofview.V82.of_tactic (convert_concl cl')) (introid id) gl + +TACTIC EXTEND ssrset +| [ "set" ssrfwdid(id) ssrsetfwd(fwd) ssrclauses(clauses) ] -> + [ Proofview.V82.tactic (tclCLAUSES ist (ssrsettac ist id fwd) clauses) ] +END + +(** The "have" tactic *) + +(* type ssrhavefwd = ssrfwd * ssrhint *) + +let pr_ssrhavefwd _ _ prt (fwd, hint) = pr_fwd fwd ++ pr_hint prt hint + +ARGUMENT EXTEND ssrhavefwd TYPED AS ssrfwd * ssrhint PRINTED BY pr_ssrhavefwd +| [ ":" lconstr(t) ssrhint(hint) ] -> [ mkFwdHint ":" t, hint ] +| [ ":" lconstr(t) ":=" lconstr(c) ] -> [ mkFwdCast FwdHave loc t c, nohint ] +| [ ":" lconstr(t) ":=" ] -> [ mkFwdHintNoTC ":" t, nohint ] +| [ ":=" lconstr(c) ] -> [ mkFwdVal FwdHave c, nohint ] +END + +let intro_id_to_binder = List.map (function + | IpatId id -> + let xloc, _ as x = bvar_lname (mkCVar dummy_loc id) in + (FwdPose, [BFvar]), + CLambdaN (dummy_loc, [[x], Default Explicit, mkCHole xloc], + mkCHole dummy_loc) + | _ -> anomaly "non-id accepted as binder") + +let binder_to_intro_id = List.map (function + | (FwdPose, [BFvar]), CLambdaN (_,[ids,_,_],_) + | (FwdPose, [BFdecl _]), CLambdaN (_,[ids,_,_],_) -> + List.map (function (_, Name id) -> IpatId id | _ -> IpatAnon) ids + | (FwdPose, [BFdef _]), CLetIn (_,(_,Name id),_,_) -> [IpatId id] + | (FwdPose, [BFdef _]), CLetIn (_,(_,Anonymous),_,_) -> [IpatAnon] + | _ -> anomaly "ssrbinder is not a binder") + +let pr_ssrhavefwdwbinders _ _ prt (tr,((hpats, (fwd, hint)))) = + pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint + +ARGUMENT EXTEND ssrhavefwdwbinders + TYPED AS bool * (ssrhpats * (ssrfwd * ssrhint)) + PRINTED BY pr_ssrhavefwdwbinders +| [ ssrhpats_wtransp(trpats) ssrbinder_list(bs) ssrhavefwd(fwd) ] -> + [ let tr, pats = trpats in + let ((clr, pats), binders), simpl = pats in + let allbs = intro_id_to_binder binders @ bs in + let allbinders = binders @ List.flatten (binder_to_intro_id bs) in + let hint = bind_fwd allbs (fst fwd), snd fwd in + tr, ((((clr, pats), allbinders), simpl), hint) ] +END + +(* Tactic. *) + +let is_Evar_or_CastedMeta x = + isEvar_or_Meta x || + (isCast x && isEvar_or_Meta (pi1 (destCast x))) + +let occur_existential_or_casted_meta c = + let rec occrec c = match kind_of_term c with + | Evar _ -> raise Not_found + | Cast (m,_,_) when isMeta m -> raise Not_found + | _ -> iter_constr occrec c + in try occrec c; false with Not_found -> true + +let examine_abstract id gl = + let tid = pf_type_of gl id in + let abstract, gl = pf_mkSsrConst "abstract" gl in + if not (isApp tid) || not (Term.eq_constr (fst(destApp tid)) abstract) then + errorstrm(strbrk"not an abstract constant: "++pr_constr id); + let _, args_id = destApp tid in + if Array.length args_id <> 3 then + errorstrm(strbrk"not a proper abstract constant: "++pr_constr id); + if not (is_Evar_or_CastedMeta args_id.(2)) then + errorstrm(strbrk"abstract constant "++pr_constr id++str" already used"); + tid, args_id + +let pf_find_abstract_proof check_lock gl abstract_n = + let fire gl t = Reductionops.nf_evar (project gl) t in + let abstract, gl = pf_mkSsrConst "abstract" gl in + let l = Evd.fold_undefined (fun e ei l -> + match kind_of_term ei.Evd.evar_concl with + | App(hd, [|ty; n; lock|]) + when (not check_lock || + (occur_existential_or_casted_meta (fire gl ty) && + is_Evar_or_CastedMeta (fire gl lock))) && + Term.eq_constr hd abstract && Term.eq_constr n abstract_n -> e::l + | _ -> l) (project gl) [] in + match l with + | [e] -> e + | _ -> errorstrm(strbrk"abstract constant "++pr_constr abstract_n++ + strbrk" not found in the evar map exactly once. "++ + strbrk"Did you tamper with it?") + +let unfold cl = + let module R = Reductionops in let module F = Closure.RedFlags in + reduct_in_concl (R.clos_norm_flags (F.mkflags + (List.map (fun c -> F.fCONST (fst (destConst c))) cl @ [F.fBETA; F.fIOTA]))) + +let havegentac ist t gl = + let sigma, c, ucst = pf_abs_ssrterm ist gl t in + let gl = pf_merge_uc ucst gl in + apply_type (mkArrow (pf_type_of gl c) (pf_concl gl)) [c] gl + +let havetac ist + (transp,((((clr, pats), binders), simpl), (((fk, _), t), hint))) + suff namefst gl += + let concl = pf_concl gl in + let skols, pats = + List.partition (function IpatNewHidden _ -> true | _ -> false) pats in + let itac_mkabs = introstac ~ist skols in + let itac_c = introstac ~ist (IpatSimpl(clr,Nop) :: pats) in + let itac, id, clr = introstac ~ist pats, tclIDTAC, cleartac clr in + let binderstac n = + let rec aux = function 0 -> [] | n -> IpatAnon :: aux (n-1) in + tclTHEN (if binders <> [] then introstac ~ist (aux n) else tclIDTAC) + (introstac ~ist binders) in + let simpltac = introstac ~ist simpl in + let fixtc = + not !ssrhaveNOtcresolution && + match fk with FwdHint(_,true) -> false | _ -> true in + let hint = hinttac ist true hint in + let cuttac t gl = + if transp then + let have_let, gl = pf_mkSsrConst "ssr_have_let" gl in + let step = mkApp (have_let, [|concl;t|]) in + let gl, _ = pf_e_type_of gl step in + applyn ~with_evars:true ~with_shelve:false 2 step gl + else basecuttac "ssr_have" t gl in + (* Introduce now abstract constants, so that everything sees them *) + let abstract_key, gl = pf_mkSsrConst "abstract_key" gl in + let unlock_abs (idty,args_id) gl = + let gl, _ = pf_e_type_of gl idty in + pf_unify_HO gl args_id.(2) abstract_key in + tclTHENFIRST itac_mkabs (fun gl -> + let mkt t = mk_term ' ' t in + let mkl t = (' ', (t, None)) in + let interp gl rtc t = pf_abs_ssrterm ~resolve_typeclasses:rtc ist gl t in + let interp_ty gl rtc t = + let a,b,_,u = pf_interp_ty ~resolve_typeclasses:rtc ist gl t in a,b,u in + let ct, cty, hole, loc = match t with + | _, (_, Some (CCast (loc, ct, CastConv cty))) -> + mkt ct, mkt cty, mkt (mkCHole dummy_loc), loc + | _, (_, Some ct) -> + mkt ct, mkt (mkCHole dummy_loc), mkt (mkCHole dummy_loc), dummy_loc + | _, (GCast (loc, ct, CastConv cty), None) -> + mkl ct, mkl cty, mkl mkRHole, loc + | _, (t, None) -> mkl t, mkl mkRHole, mkl mkRHole, dummy_loc in + let gl, cut, sol, itac1, itac2 = + match fk, namefst, suff with + | FwdHave, true, true -> + errorstrm (str"Suff have does not accept a proof term") + | FwdHave, false, true -> + let cty = combineCG cty hole (mkCArrow loc) mkRArrow in + let _, t, uc = interp gl false (combineCG ct cty (mkCCast loc) mkRCast) in + let gl = pf_merge_uc uc gl in + let ty = pf_type_of gl t in + let ctx, _ = decompose_prod_n 1 ty in + let assert_is_conv gl = + try Proofview.V82.of_tactic (convert_concl (compose_prod ctx concl)) gl + with _ -> errorstrm (str "Given proof term is not of type " ++ + pr_constr (mkArrow (mkVar (id_of_string "_")) concl)) in + gl, ty, tclTHEN assert_is_conv (Proofview.V82.of_tactic (apply t)), id, itac_c + | FwdHave, false, false -> + let skols = List.flatten (List.map (function + | IpatNewHidden ids -> ids + | _ -> assert false) skols) in + let skols_args = + List.map (fun id -> examine_abstract (mkVar id) gl) skols in + let gl = List.fold_right unlock_abs skols_args gl in + let sigma, t, uc = + interp gl false (combineCG ct cty (mkCCast loc) mkRCast) in + let gl = re_sig (sig_it gl) (Evd.merge_universe_context sigma uc) in + let gs = + List.map (fun (_,a) -> + pf_find_abstract_proof false gl a.(1)) skols_args in + let tacopen_skols gl = + let stuff, g = Refiner.unpackage gl in + Refiner.repackage stuff (gs @ [g]) in + let gl, ty = pf_e_type_of gl t in + gl, ty, Proofview.V82.of_tactic (apply t), id, + tclTHEN (tclTHEN itac_c simpltac) + (tclTHEN tacopen_skols (fun gl -> + let abstract, gl = pf_mkSsrConst "abstract" gl in + unfold [abstract; abstract_key] gl)) + | _,true,true -> + let _, ty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in + gl, mkArrow ty concl, hint, itac, clr + | _,false,true -> + let _, ty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in + gl, mkArrow ty concl, hint, id, itac_c + | _, false, false -> + let n, cty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in + gl, cty, tclTHEN (binderstac n) hint, id, tclTHEN itac_c simpltac + | _, true, false -> assert false in + tclTHENS (cuttac cut) [ tclTHEN sol itac1; itac2 ] gl) + gl +;; + +(* to extend the abstract value one needs: + Utility lemma to partially instantiate an abstract constant type. + Lemma use_abstract T n l (x : abstract T n l) : T. + Proof. by case: l x. Qed. +*) +let ssrabstract ist gens (*last*) gl = + let main _ (_,cid) ist gl = +(* + let proj1, proj2, prod = + let pdata = build_prod () in + pdata.Coqlib.proj1, pdata.Coqlib.proj2, pdata.Coqlib.typ in +*) + let concl, env = pf_concl gl, pf_env gl in + let fire gl t = Reductionops.nf_evar (project gl) t in + let abstract, gl = pf_mkSsrConst "abstract" gl in + let abstract_key, gl = pf_mkSsrConst "abstract_key" gl in + let id = mkVar (Option.get (id_of_cpattern cid)) in + let idty, args_id = examine_abstract id gl in + let abstract_n = args_id.(1) in + let abstract_proof = pf_find_abstract_proof true gl abstract_n in + let gl, proof = + let pf_unify_HO gl a b = + try pf_unify_HO gl a b + with _ -> errorstrm(strbrk"The abstract variable "++pr_constr id++ + strbrk" cannot abstract this goal. Did you generalize it?") in + let rec find_hole p t = + match kind_of_term t with + | Evar _ (*when last*) -> pf_unify_HO gl concl t, p + | Meta _ (*when last*) -> pf_unify_HO gl concl t, p + | Cast(m,_,_) when isEvar_or_Meta m (*when last*) -> pf_unify_HO gl concl t, p +(* + | Evar _ -> + let sigma, it = project gl, sig_it gl in + let sigma, ty = Evarutil.new_type_evar sigma env in + let gl = re_sig it sigma in + let p = mkApp (proj2,[|ty;concl;p|]) in + let concl = mkApp(prod,[|ty; concl|]) in + pf_unify_HO gl concl t, p + | App(hd, [|left; right|]) when Term.eq_constr hd prod -> + find_hole (mkApp (proj1,[|left;right;p|])) left +*) + | _ -> errorstrm(strbrk"abstract constant "++pr_constr abstract_n++ + strbrk" has an unexpected shape. Did you tamper with it?") + in + find_hole + ((*if last then*) id + (*else mkApp(mkSsrConst "use_abstract",Array.append args_id [|id|])*)) + (fire gl args_id.(0)) in + let gl = (*if last then*) pf_unify_HO gl abstract_key args_id.(2) (*else gl*) in + let gl, _ = pf_e_type_of gl idty in + let proof = fire gl proof in +(* if last then *) + let tacopen gl = + let stuff, g = Refiner.unpackage gl in + Refiner.repackage stuff [ g; abstract_proof ] in + tclTHENS tacopen [tclSOLVE [Proofview.V82.of_tactic (apply proof)];unfold[abstract;abstract_key]] gl +(* else apply proof gl *) + in + let introback ist (gens, _) = + introstac ~ist + (List.map (fun (_,cp) -> match id_of_cpattern cp with + | None -> IpatAnon + | Some id -> IpatId id) + (List.tl (List.hd gens))) in + tclTHEN (with_dgens gens main ist) (introback ist gens) gl + +(* The standard TACTIC EXTEND does not work for abstract *) +GEXTEND Gram + GLOBAL: tactic_expr; + tactic_expr: LEVEL "3" + [ RIGHTA [ IDENT "abstract"; gens = ssrdgens -> + ssrtac_expr !@loc "abstract" + [Genarg.in_gen (Genarg.rawwit wit_ssrdgens) gens] ]]; +END +TACTIC EXTEND ssrabstract +| [ "abstract" ssrdgens(gens) ] -> [ + if List.length (fst gens) <> 1 then + errorstrm (str"dependents switches '/' not allowed here"); + Proofview.V82.tactic (ssrabstract ist gens) ] +END + +let prof_havetac = mk_profiler "havetac";; +let havetac arg a b gl = prof_havetac.profile (havetac arg a b) gl;; + +TACTIC EXTEND ssrhave +| [ "have" ssrhavefwdwbinders(fwd) ] -> + [ Proofview.V82.tactic (havetac ist fwd false false) ] +END + +TACTIC EXTEND ssrhavesuff +| [ "have" "suff" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ Proofview.V82.tactic (havetac ist (false,(pats,fwd)) true false) ] +END + +TACTIC EXTEND ssrhavesuffices +| [ "have" "suffices" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ Proofview.V82.tactic (havetac ist (false,(pats,fwd)) true false) ] +END + +TACTIC EXTEND ssrsuffhave +| [ "suff" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ Proofview.V82.tactic (havetac ist (false,(pats,fwd)) true true) ] +END + +TACTIC EXTEND ssrsufficeshave +| [ "suffices" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ Proofview.V82.tactic (havetac ist (false,(pats,fwd)) true true) ] +END + +(** The "suffice" tactic *) + +let pr_ssrsufffwdwbinders _ _ prt (hpats, (fwd, hint)) = + pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint + +ARGUMENT EXTEND ssrsufffwd + TYPED AS ssrhpats * (ssrfwd * ssrhint) PRINTED BY pr_ssrsufffwdwbinders +| [ ssrhpats(pats) ssrbinder_list(bs) ":" lconstr(t) ssrhint(hint) ] -> + [ let ((clr, pats), binders), simpl = pats in + let allbs = intro_id_to_binder binders @ bs in + let allbinders = binders @ List.flatten (binder_to_intro_id bs) in + let fwd = mkFwdHint ":" t in + (((clr, pats), allbinders), simpl), (bind_fwd allbs fwd, hint) ] +END + +let sufftac ist ((((clr, pats),binders),simpl), ((_, c), hint)) = + let htac = tclTHEN (introstac ~ist pats) (hinttac ist true hint) in + let c = match c with + | (a, (b, Some (CCast (_, _, CastConv cty)))) -> a, (b, Some cty) + | (a, (GCast (_, _, CastConv cty), None)) -> a, (cty, None) + | _ -> anomaly "suff: ssr cast hole deleted by typecheck" in + let ctac gl = + let _,ty,_,uc = pf_interp_ty ist gl c in let gl = pf_merge_uc uc gl in + basecuttac "ssr_suff" ty gl in + tclTHENS ctac [htac; tclTHEN (cleartac clr) (introstac ~ist (binders@simpl))] + +TACTIC EXTEND ssrsuff +| [ "suff" ssrsufffwd(fwd) ] -> [ Proofview.V82.tactic (sufftac ist fwd) ] +END + +TACTIC EXTEND ssrsuffices +| [ "suffices" ssrsufffwd(fwd) ] -> [ Proofview.V82.tactic (sufftac ist fwd) ] +END + +(** The "wlog" (Without Loss Of Generality) tactic *) + +(* type ssrwlogfwd = ssrwgen list * ssrfwd *) + +let pr_ssrwlogfwd _ _ _ (gens, t) = + str ":" ++ pr_list mt pr_wgen gens ++ spc() ++ pr_fwd t + +ARGUMENT EXTEND ssrwlogfwd TYPED AS ssrwgen list * ssrfwd + PRINTED BY pr_ssrwlogfwd +| [ ":" ssrwgen_list(gens) "/" lconstr(t) ] -> [ gens, mkFwdHint "/" t] +END + +let destProd_or_LetIn c = + match kind_of_term c with + | Prod (n,ty,c) -> (n,None,ty), c + | LetIn (n,bo,ty,c) -> (n,Some bo,ty), c + | _ -> raise DestKO + +let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = + let mkabs gen = abs_wgen false ist (fun x -> x) gen in + let mkclr gen clrs = clr_of_wgen gen clrs in + let mkpats = function + | _, Some ((x, _), _) -> fun pats -> IpatId (hoi_id x) :: pats + | _ -> fun x -> x in + let ct = match ct with + | (a, (b, Some (CCast (_, _, CastConv cty)))) -> a, (b, Some cty) + | (a, (GCast (_, _, CastConv cty), None)) -> a, (cty, None) + | _ -> anomaly "wlog: ssr cast hole deleted by typecheck" in + let cut_implies_goal = not (suff || ghave <> `NoGen) in + let c, args, ct, gl = + let gens = List.filter (function _, Some _ -> true | _ -> false) gens in + let concl = pf_concl gl in + let c = mkProp in + let c = if cut_implies_goal then mkArrow c concl else c in + let gl, args, c = List.fold_right mkabs gens (gl,[],c) in + let env, _ = + List.fold_left (fun (env, c) _ -> + let rd, c = destProd_or_LetIn c in + Environ.push_rel rd env, c) (pf_env gl, c) gens in + let sigma, ev = Evarutil.new_evar env (project gl) Term.mkProp in + let k, _ = Term.destEvar ev in + let fake_gl = {Evd.it = k; Evd.sigma = sigma} in + let _, ct, _, uc = pf_interp_ty ist fake_gl ct in + let rec var2rel c g s = match kind_of_term c, g with + | Prod(Anonymous,_,c), [] -> mkProd(Anonymous, Vars.subst_vars s ct, c) + | Sort _, [] -> Vars.subst_vars s ct + | LetIn(Name id as n,b,ty,c), _::g -> mkLetIn (n,b,ty,var2rel c g (id::s)) + | Prod(Name id as n,ty,c), _::g -> mkProd (n,ty,var2rel c g (id::s)) + | _ -> Errors.anomaly(str"SSR: wlog: var2rel: " ++ pr_constr c) in + let c = var2rel c gens [] in + let rec pired c = function + | [] -> c + | t::ts as args -> match kind_of_term c with + | Prod(_,_,c) -> pired (subst1 t c) ts + | LetIn(id,b,ty,c) -> mkLetIn (id,b,ty,pired c args) + | _ -> Errors.anomaly(str"SSR: wlog: pired: " ++ pr_constr c) in + c, args, pired c args, pf_merge_uc uc gl in + let tacipat pats = introstac ~ist pats in + let tacigens = + tclTHEN + (tclTHENLIST(List.rev(List.fold_right mkclr gens [cleartac clr0]))) + (introstac ~ist (List.fold_right mkpats gens [])) in + let hinttac = hinttac ist true hint in + let cut_kind, fst_goal_tac, snd_goal_tac = + match suff, ghave with + | true, `NoGen -> "ssr_wlog", tclTHEN hinttac (tacipat pats), tacigens + | false, `NoGen -> "ssr_wlog", hinttac, tclTHEN tacigens (tacipat pats) + | true, `Gen _ -> assert false + | false, `Gen id -> + if gens = [] then errorstrm(str"gen have requires some generalizations"); + let clear0 = cleartac clr0 in + let id, name_general_hyp, cleanup, pats = match id, pats with + | None, (IpatId id as ip)::pats -> Some id, tacipat [ip], clear0, pats + | None, _ -> None, tclIDTAC, clear0, pats + | Some (Some id),_ -> Some id, introid id, clear0, pats + | Some _,_ -> + let id = mk_anon_id "tmp" gl in + Some id, introid id, tclTHEN clear0 (clear [id]), pats in + let tac_specialize = match id with + | None -> tclIDTAC + | Some id -> + if pats = [] then tclIDTAC else + let args = Array.of_list args in + pp(lazy(str"specialized="++pr_constr (mkApp (mkVar id,args)))); + pp(lazy(str"specialized_ty="++pr_constr ct)); + tclTHENS (basecuttac "ssr_have" ct) + [Proofview.V82.of_tactic (apply (mkApp (mkVar id,args))); tclIDTAC] in + "ssr_have", + (if hint = nohint then tacigens else hinttac), + tclTHENLIST [name_general_hyp; tac_specialize; tacipat pats; cleanup] + in + tclTHENS (basecuttac cut_kind c) [fst_goal_tac; snd_goal_tac] gl + +TACTIC EXTEND ssrwlog +| [ "wlog" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint false `NoGen) ] +END + +TACTIC EXTEND ssrwlogs +| [ "wlog" "suff" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +TACTIC EXTEND ssrwlogss +| [ "wlog" "suffices" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +TACTIC EXTEND ssrwithoutloss +| [ "without" "loss" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint false `NoGen) ] +END + +TACTIC EXTEND ssrwithoutlosss +| [ "without" "loss" "suff" + ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +TACTIC EXTEND ssrwithoutlossss +| [ "without" "loss" "suffices" + ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +(* Generally have *) +let pr_idcomma _ _ _ = function + | None -> mt() + | Some None -> str"_, " + | Some (Some id) -> pr_id id ++ str", " + +ARGUMENT EXTEND ssr_idcomma TYPED AS ident option option PRINTED BY pr_idcomma + | [ ] -> [ None ] +END + +let accept_idcomma strm = + match Compat.get_tok (stream_nth 0 strm) with + | Tok.IDENT _ | Tok.KEYWORD "_" -> accept_before_syms [","] strm + | _ -> raise Stream.Failure + +let test_idcomma = Gram.Entry.of_parser "test_idcomma" accept_idcomma + +GEXTEND Gram + GLOBAL: ssr_idcomma; + ssr_idcomma: [ [ test_idcomma; + ip = [ id = IDENT -> Some (id_of_string id) | "_" -> None ]; "," -> + Some ip + ] ]; +END + +let augment_preclr clr1 (((clr0, x),y),z) = (((clr1 @ clr0, x),y),z) + +TACTIC EXTEND ssrgenhave +| [ "gen" "have" ssrclear(clr) + ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ let pats = augment_preclr clr pats in + Proofview.V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) ] +END + +TACTIC EXTEND ssrgenhave2 +| [ "generally" "have" ssrclear(clr) + ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ let pats = augment_preclr clr pats in + Proofview.V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) ] +END + +(** Canonical Structure alias *) + +let def_body : Vernacexpr.definition_expr Gram.Entry.e = Obj.magic + (Grammar.Entry.find (Obj.magic gallina_ext) "vernac:def_body") in + +GEXTEND Gram + GLOBAL: gallina_ext; + + gallina_ext: + (* Canonical structure *) + [[ IDENT "Canonical"; qid = Constr.global -> + Vernacexpr.VernacCanonical (AN qid) + | IDENT "Canonical"; ntn = Prim.by_notation -> + Vernacexpr.VernacCanonical (ByNotation ntn) + | IDENT "Canonical"; qid = Constr.global; + d = def_body -> + let s = coerce_reference_to_id qid in + Vernacexpr.VernacDefinition + ((Some Decl_kinds.Global,Decl_kinds.CanonicalStructure), + (dummy_loc,s),(d )) + ]]; +END + +(** 9. Keyword compatibility fixes. *) + +(* Coq v8.1 notation uses "by" and "of" quasi-keywords, i.e., reserved *) +(* identifiers used as keywords. This is incompatible with ssreflect.v *) +(* which makes "by" and "of" true keywords, because of technicalities *) +(* in the internal lexer-parser API of Coq. We patch this here by *) +(* adding new parsing rules that recognize the new keywords. *) +(* To make matters worse, the Coq grammar for tactics fails to *) +(* export the non-terminals we need to patch. Fortunately, the CamlP5 *) +(* API provides a backdoor access (with loads of Obj.magic trickery). *) + +(* Coq v8.3 defines "by" as a keyword, some hacks are not needed any *) +(* longer and thus comment out. Such comments are marked with v8.3 *) + +let tac_ent = List.fold_left Grammar.Entry.find (Obj.magic simple_tactic) in +let hypident_ent = + tac_ent ["clause_dft_all"; "in_clause"; "hypident_occ"; "hypident"] in +let id_or_meta : Obj.t Gram.Entry.e = Obj.magic + (Grammar.Entry.find hypident_ent "id_or_meta") in +let hypident : (Obj.t * hyp_location_flag) Gram.Entry.e = + Obj.magic hypident_ent in +GEXTEND Gram + GLOBAL: hypident; +hypident: [ + [ "("; IDENT "type"; "of"; id = id_or_meta; ")" -> id, InHypTypeOnly + | "("; IDENT "value"; "of"; id = id_or_meta; ")" -> id, InHypValueOnly + ] ]; +END + +GEXTEND Gram + GLOBAL: hloc; +hloc: [ + [ "in"; "("; "Type"; "of"; id = ident; ")" -> + HypLocation ((dummy_loc,id), InHypTypeOnly) + | "in"; "("; IDENT "Value"; "of"; id = ident; ")" -> + HypLocation ((dummy_loc,id), InHypValueOnly) + ] ]; +END + +let constr_eval + : (Constrexpr.constr_expr,Obj.t,Obj.t) Genredexpr.may_eval Gram.Entry.e + = Obj.magic (Grammar.Entry.find (Obj.magic constr_may_eval) "constr_eval") + +GEXTEND Gram + GLOBAL: constr_eval; + constr_eval: [ + [ IDENT "type"; "of"; c = Constr.constr -> Genredexpr.ConstrTypeOf c ] + ]; +END + +(* We wipe out all the keywords generated by the grammar rules we defined. *) +(* The user is supposed to Require Import ssreflect or Require ssreflect *) +(* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) +(* consequence the extended ssreflect grammar. *) +let () = Lexer.unfreeze frozen_lexer ;; + +(* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/mathcomp/ssreflect/plugin/trunk/ssreflect.mllib b/mathcomp/ssreflect/plugin/trunk/ssreflect.mllib new file mode 100644 index 0000000..006b70f --- /dev/null +++ b/mathcomp/ssreflect/plugin/trunk/ssreflect.mllib @@ -0,0 +1,2 @@ +Ssrmatching +Ssreflect diff --git a/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 b/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 new file mode 100644 index 0000000..29580a6 --- /dev/null +++ b/mathcomp/ssreflect/plugin/trunk/ssrmatching.ml4 @@ -0,0 +1,1238 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) + +(* Defining grammar rules with "xx" in it automatically declares keywords too, + * we thus save the lexer to restore it at the end of the file *) +let frozen_lexer = Lexer.freeze () ;; + +(*i camlp4use: "pa_extend.cmo" i*) +(*i camlp4deps: "grammar/grammar.cma" i*) + +open Names +open Pp +open Pcoq +open Genarg +open Constrarg +open Term +open Vars +open Topconstr +open Libnames +open Tactics +open Tacticals +open Termops +open Namegen +open Recordops +open Tacmach +open Coqlib +open Glob_term +open Util +open Evd +open Extend +open Goptions +open Tacexpr +open Tacinterp +open Pretyping +open Constr +open Tactic +open Extraargs +open Ppconstr +open Printer + +open Globnames +open Misctypes +open Decl_kinds +open Evar_kinds +open Constrexpr +open Constrexpr_ops +open Notation_term +open Notation_ops +open Locus +open Locusops + +DECLARE PLUGIN "ssreflect" + +type loc = Loc.t +let dummy_loc = Loc.ghost +let errorstrm = Errors.errorlabstrm "ssreflect" +let loc_error loc msg = Errors.user_err_loc (loc, msg, str msg) + +(* 0 cost pp function. Active only if env variable SSRDEBUG is set *) +(* or if SsrDebug is Set *) +let pp_ref = ref (fun _ -> ()) +let ssr_pp s = pperrnl (str"SSR: "++Lazy.force s) +let _ = try ignore(Sys.getenv "SSRDEBUG"); pp_ref := ssr_pp with Not_found -> () +let debug b = + if b then pp_ref := ssr_pp else pp_ref := fun _ -> () +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssrmatching debugging"; + Goptions.optkey = ["SsrMatchingDebug"]; + Goptions.optdepr = false; + Goptions.optread = (fun _ -> !pp_ref == ssr_pp); + Goptions.optwrite = debug } +let pp s = !pp_ref s + +(** Utils {{{ *****************************************************************) +let env_size env = List.length (Environ.named_context env) +let safeDestApp c = + match kind_of_term c with App (f, a) -> f, a | _ -> c, [| |] +let get_index = function ArgArg i -> i | _ -> + Errors.anomaly (str"Uninterpreted index") +(* Toplevel constr must be globalized twice ! *) +let glob_constr ist genv = function + | _, Some ce -> + let vars = Id.Map.fold (fun x _ accu -> Id.Set.add x accu) ist.lfun Id.Set.empty in + let ltacvars = { Constrintern.empty_ltac_sign with Constrintern.ltac_vars = vars } in + Constrintern.intern_gen WithoutTypeConstraint ~ltacvars:ltacvars genv ce + | rc, None -> rc + +(* Term printing utilities functions for deciding bracketing. *) +let pr_paren prx x = hov 1 (str "(" ++ prx x ++ str ")") +(* String lexing utilities *) +let skip_wschars s = + let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop +(* We also guard characters that might interfere with the ssreflect *) +(* tactic syntax. *) +let guard_term ch1 s i = match s.[i] with + | '(' -> false + | '{' | '/' | '=' -> true + | _ -> ch1 = '(' +(* The call 'guard s i' should return true if the contents of s *) +(* starting at i need bracketing to avoid ambiguities. *) +let pr_guarded guard prc c = + msg_with Format.str_formatter (prc c); + let s = Format.flush_str_formatter () ^ "$" in + if guard s (skip_wschars s 0) then pr_paren prc c else prc c +(* More sensible names for constr printers *) +let pr_constr = pr_constr +let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c +let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c +let prl_constr_expr = pr_lconstr_expr +let pr_constr_expr = pr_constr_expr +let prl_glob_constr_and_expr = function + | _, Some c -> prl_constr_expr c + | c, None -> prl_glob_constr c +let pr_glob_constr_and_expr = function + | _, Some c -> pr_constr_expr c + | c, None -> pr_glob_constr c +let pr_term (k, c) = pr_guarded (guard_term k) pr_glob_constr_and_expr c +let prl_term (k, c) = pr_guarded (guard_term k) prl_glob_constr_and_expr c + +(** Adding a new uninterpreted generic argument type *) +let add_genarg tag pr = + let wit = Genarg.make0 None tag in + let glob ist x = (ist, x) in + let subst _ x = x in + let interp ist gl x = (gl.Evd.sigma, x) in + let gen_pr _ _ _ = pr in + let () = Genintern.register_intern0 wit glob in + let () = Genintern.register_subst0 wit subst in + let () = Geninterp.register_interp0 wit interp in + Pptactic.declare_extra_genarg_pprule wit gen_pr gen_pr gen_pr; + wit + +(** Constructors for cast type *) +let dC t = CastConv t +(** Constructors for constr_expr *) +let isCVar = function CRef (Ident _, _) -> true | _ -> false +let destCVar = function CRef (Ident (_, id), _) -> id | _ -> + Errors.anomaly (str"not a CRef") +let mkCHole loc = CHole (loc, None, IntroAnonymous, None) +let mkCLambda loc name ty t = + CLambdaN (loc, [[loc, name], Default Explicit, ty], t) +let mkCLetIn loc name bo t = + CLetIn (loc, (loc, name), bo, t) +let mkCCast loc t ty = CCast (loc,t, dC ty) +(** Constructors for rawconstr *) +let mkRHole = GHole (dummy_loc, InternalHole, IntroAnonymous, None) +let mkRApp f args = if args = [] then f else GApp (dummy_loc, f, args) +let mkRCast rc rt = GCast (dummy_loc, rc, dC rt) +let mkRLambda n s t = GLambda (dummy_loc, n, Explicit, s, t) + +(* ssrterm conbinators *) +let combineCG t1 t2 f g = match t1, t2 with + | (x, (t1, None)), (_, (t2, None)) -> x, (g t1 t2, None) + | (x, (_, Some t1)), (_, (_, Some t2)) -> x, (mkRHole, Some (f t1 t2)) + | _, (_, (_, None)) -> Errors.anomaly (str"have: mixed C-G constr") + | _ -> Errors.anomaly (str"have: mixed G-C constr") +let loc_ofCG = function + | (_, (s, None)) -> Glob_ops.loc_of_glob_constr s + | (_, (_, Some s)) -> Constrexpr_ops.constr_loc s + +let mk_term k c = k, (mkRHole, Some c) +let mk_lterm = mk_term ' ' + +(* }}} *) + +(** Profiling {{{ *************************************************************) +type profiler = { + profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; + reset : unit -> unit; + print : unit -> unit } +let profile_now = ref false +let something_profiled = ref false +let profilers = ref [] +let add_profiler f = profilers := f :: !profilers;; +let profile b = + profile_now := b; + if b then List.iter (fun f -> f.reset ()) !profilers; + if not b then List.iter (fun f -> f.print ()) !profilers +;; +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssrmatching profiling"; + Goptions.optkey = ["SsrMatchingProfiling"]; + Goptions.optread = (fun _ -> !profile_now); + Goptions.optdepr = false; + Goptions.optwrite = profile } +let () = + let prof_total = + let init = ref 0.0 in { + profile = (fun f x -> assert false); + reset = (fun () -> init := Unix.gettimeofday ()); + print = (fun () -> if !something_profiled then + prerr_endline + (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" + "total" 0 (Unix.gettimeofday() -. !init) 0.0 0.0)) } in + let prof_legenda = { + profile = (fun f x -> assert false); + reset = (fun () -> ()); + print = (fun () -> if !something_profiled then begin + prerr_endline + (Printf.sprintf "!! %39s ---------- --------- --------- ---------" + (String.make 39 '-')); + prerr_endline + (Printf.sprintf "!! %-39s %10s %9s %9s %9s" + "function" "#calls" "total" "max" "average") end) } in + add_profiler prof_legenda; + add_profiler prof_total +;; + +let mk_profiler s = + let total, calls, max = ref 0.0, ref 0, ref 0.0 in + let reset () = total := 0.0; calls := 0; max := 0.0 in + let profile f x = + if not !profile_now then f x else + let before = Unix.gettimeofday () in + try + incr calls; + let res = f x in + let after = Unix.gettimeofday () in + let delta = after -. before in + total := !total +. delta; + if delta > !max then max := delta; + res + with exc -> + let after = Unix.gettimeofday () in + let delta = after -. before in + total := !total +. delta; + if delta > !max then max := delta; + raise exc in + let print () = + if !calls <> 0 then begin + something_profiled := true; + prerr_endline + (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" + s !calls !total !max (!total /. (float_of_int !calls))) end in + let prof = { profile = profile; reset = reset; print = print } in + add_profiler prof; + prof +;; +(* }}} *) + +exception NoProgress + +(** Unification procedures. *) + +(* To enforce the rigidity of the rooted match we always split *) +(* top applications, so the unification procedures operate on *) +(* arrays of patterns and terms. *) +(* We perform three kinds of unification: *) +(* EQ: exact conversion check *) +(* FO: first-order unification of evars, without conversion *) +(* HO: higher-order unification with conversion *) +(* The subterm unification strategy is to find the first FO *) +(* match, if possible, and the first HO match otherwise, then *) +(* compute all the occurrences that are EQ matches for the *) +(* relevant subterm. *) +(* Additional twists: *) +(* - If FO/HO fails then we attempt to fill evars using *) +(* typeclasses before raising an outright error. We also *) +(* fill typeclasses even after a successful match, since *) +(* beta-reduction and canonical instances may leave *) +(* undefined evars. *) +(* - We do postchecks to rule out matches that are not *) +(* closed or that assign to a global evar; these can be *) +(* disabled for rewrite or dependent family matches. *) +(* - We do a full FO scan before turning to HO, as the FO *) +(* comparison can be much faster than the HO one. *) + +let unif_EQ env sigma p c = + let evars = existential_opt_value sigma in + try let _ = Reduction.conv env p ~evars c in true with _ -> false + +let unif_EQ_args env sigma pa a = + let n = Array.length pa in + let rec loop i = (i = n) || unif_EQ env sigma pa.(i) a.(i) && loop (i + 1) in + loop 0 + +let prof_unif_eq_args = mk_profiler "unif_EQ_args";; +let unif_EQ_args env sigma pa a = + prof_unif_eq_args.profile (unif_EQ_args env sigma pa) a +;; + +let unif_HO env ise p c = Evarconv.the_conv_x env p c ise + +let unif_HOtype env ise p c = Evarconv.the_conv_x_leq env p c ise + +let unif_HO_args env ise0 pa i ca = + let n = Array.length pa in + let rec loop ise j = + if j = n then ise else loop (unif_HO env ise pa.(j) ca.(i + j)) (j + 1) in + loop ise0 0 + +(* FO unification should boil down to calling w_unify with no_delta, but *) +(* alas things are not so simple: w_unify does partial type-checking, *) +(* which breaks down when the no-delta flag is on (as the Coq type system *) +(* requires full convertibility. The workaround here is to convert all *) +(* evars into metas, since 8.2 does not TC metas. This means some lossage *) +(* for HO evars, though hopefully Miller patterns can pick up some of *) +(* those cases, and HO matching will mop up the rest. *) +let flags_FO = + let flags = + { (Unification.default_no_delta_unify_flags ()).Unification.core_unify_flags + with + Unification.modulo_conv_on_closed_terms = None; + Unification.modulo_eta = true; + Unification.modulo_betaiota = true; + Unification.modulo_delta_types = full_transparent_state} + in + { Unification.core_unify_flags = flags; + Unification.merge_unify_flags = flags; + Unification.subterm_unify_flags = flags; + Unification.allow_K_in_toplevel_higher_order_unification = false; + Unification.resolve_evars = + (Unification.default_no_delta_unify_flags ()).Unification.resolve_evars + } +let unif_FO env ise p c = + Unification.w_unify env ise Reduction.CONV ~flags:flags_FO p c + +(* Perform evar substitution in main term and prune substitution. *) +let nf_open_term sigma0 ise c = + let s = ise and s' = ref sigma0 in + let rec nf c' = match kind_of_term c' with + | Evar ex -> + begin try nf (existential_value s ex) with _ -> + let k, a = ex in let a' = Array.map nf a in + if not (Evd.mem !s' k) then + s' := Evd.add !s' k (Evarutil.nf_evar_info s (Evd.find s k)); + mkEvar (k, a') + end + | _ -> map_constr nf c' in + let copy_def k evi () = + if evar_body evi != Evd.Evar_empty then () else + match Evd.evar_body (Evd.find s k) with + | Evar_defined c' -> s' := Evd.define k (nf c') !s' + | _ -> () in + let c' = nf c in let _ = Evd.fold copy_def sigma0 () in + !s', Evd.evar_universe_context s, c' + +let unif_end env sigma0 ise0 pt ok = + let ise = Evarconv.consider_remaining_unif_problems env ise0 in + let s, uc, t = nf_open_term sigma0 ise pt in + let ise1 = create_evar_defs s in + let ise2 = Typeclasses.resolve_typeclasses ~fail:true env ise1 in + if not (ok ise) then raise NoProgress else + if ise2 == ise1 then (s, uc, t) + else + let s, uc', t = nf_open_term sigma0 ise2 t in + s, Evd.union_evar_universe_context uc uc', t + +let pf_unif_HO gl sigma pt p c = + let env = pf_env gl in + let ise = unif_HO env (create_evar_defs sigma) p c in + unif_end env (project gl) ise pt (fun _ -> true) + +let unify_HO env sigma0 t1 t2 = + let sigma = unif_HO env sigma0 t1 t2 in + let sigma, uc, _ = unif_end env sigma0 sigma t2 (fun _ -> true) in + Evd.merge_universe_context sigma uc + +let pf_unify_HO gl t1 t2 = + let env, sigma0, si = pf_env gl, project gl, sig_it gl in + let sigma = unify_HO env sigma0 t1 t2 in + re_sig si sigma + +(* This is what the definition of iter_constr should be... *) +let iter_constr_LR f c = match kind_of_term c with + | Evar (k, a) -> Array.iter f a + | Cast (cc, _, t) -> f cc; f t + | Prod (_, t, b) | Lambda (_, t, b) -> f t; f b + | LetIn (_, v, t, b) -> f v; f t; f b + | App (cf, a) -> f cf; Array.iter f a + | Case (_, p, v, b) -> f v; f p; Array.iter f b + | Fix (_, (_, t, b)) | CoFix (_, (_, t, b)) -> + for i = 0 to Array.length t - 1 do f t.(i); f b.(i) done + | _ -> () + +(* The comparison used to determine which subterms matches is KEYED *) +(* CONVERSION. This looks for convertible terms that either have the same *) +(* same head constant as pat if pat is an application (after beta-iota), *) +(* or start with the same constr constructor (esp. for LetIn); this is *) +(* disregarded if the head term is let x := ... in x, and casts are always *) +(* ignored and removed). *) +(* Record projections get special treatment: in addition to the projection *) +(* constant itself, ssreflect also recognizes head constants of canonical *) +(* projections. *) + +exception NoMatch +type ssrdir = L2R | R2L +let pr_dir_side = function L2R -> str "LHS" | R2L -> str "RHS" +let inv_dir = function L2R -> R2L | R2L -> L2R + + +type pattern_class = + | KpatFixed + | KpatConst + | KpatEvar of existential_key + | KpatLet + | KpatLam + | KpatRigid + | KpatFlex + | KpatProj of constant + +type tpattern = { + up_k : pattern_class; + up_FO : constr; + up_f : constr; + up_a : constr array; + up_t : constr; (* equation proof term or matched term *) + up_dir : ssrdir; (* direction of the rule *) + up_ok : constr -> evar_map -> bool; (* progess test for rewrite *) + } + +let all_ok _ _ = true + +let proj_nparams c = + try 1 + Recordops.find_projection_nparams (ConstRef c) with _ -> 0 + +let isFixed c = match kind_of_term c with + | Var _ | Ind _ | Construct _ | Const _ -> true + | _ -> false + +let isRigid c = match kind_of_term c with + | Prod _ | Sort _ | Lambda _ | Case _ | Fix _ | CoFix _ -> true + | _ -> false + +exception UndefPat + +let hole_var = mkVar (id_of_string "_") +let pr_constr_pat c0 = + let rec wipe_evar c = + if isEvar c then hole_var else map_constr wipe_evar c in + pr_constr (wipe_evar c0) + +(* Turn (new) evars into metas *) +let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = + let ise = ref ise0 in + let sigma = ref ise0 in + let nenv = env_size env + if hack then 1 else 0 in + let rec put c = match kind_of_term c with + | Evar (k, a as ex) -> + begin try put (existential_value !sigma ex) + with NotInstantiatedEvar -> + if Evd.mem sigma0 k then map_constr put c else + let evi = Evd.find !sigma k in + let dc = List.firstn (max 0 (Array.length a - nenv)) (evar_filtered_context evi) in + let abs_dc (d, c) = function + | x, Some b, t -> d, mkNamedLetIn x (put b) (put t) c + | x, None, t -> mkVar x :: d, mkNamedProd x (put t) c in + let a, t = + Context.fold_named_context_reverse abs_dc ~init:([], (put evi.evar_concl)) dc in + let m = Evarutil.new_meta () in + ise := meta_declare m t !ise; + sigma := Evd.define k (applist (mkMeta m, a)) !sigma; + put (existential_value !sigma ex) + end + | _ -> map_constr put c in + let c1 = put c0 in !ise, c1 + +(* Compile a match pattern from a term; t is the term to fill. *) +(* p_origin can be passed to obtain a better error message *) +let mk_tpattern ?p_origin ?(hack=false) env sigma0 (ise, t) ok dir p = + let k, f, a = + let f, a = Reductionops.whd_betaiota_stack ise p in + match kind_of_term f with + | Const (p,_) -> + let np = proj_nparams p in + if np = 0 || np > List.length a then KpatConst, f, a else + let a1, a2 = List.chop np a in KpatProj p, applist(f, a1), a2 + | Var _ | Ind _ | Construct _ -> KpatFixed, f, a + | Evar (k, _) -> + if Evd.mem sigma0 k then KpatEvar k, f, a else + if a <> [] then KpatFlex, f, a else + (match p_origin with None -> Errors.error "indeterminate pattern" + | Some (dir, rule) -> + errorstrm (str "indeterminate " ++ pr_dir_side dir + ++ str " in " ++ pr_constr_pat rule)) + | LetIn (_, v, _, b) -> + if b <> mkRel 1 then KpatLet, f, a else KpatFlex, v, a + | Lambda _ -> KpatLam, f, a + | _ -> KpatRigid, f, a in + let aa = Array.of_list a in + let ise', p' = evars_for_FO ~hack env sigma0 ise (mkApp (f, aa)) in + ise', + { up_k = k; up_FO = p'; up_f = f; + up_a = aa; up_ok = ok; up_dir = dir; up_t = t} + +(* Specialize a pattern after a successful match: assign a precise head *) +(* kind and arity for Proj and Flex patterns. *) +let ungen_upat lhs (sigma, uc, t) u = + let f, a = safeDestApp lhs in + let k = match kind_of_term f with + | Var _ | Ind _ | Construct _ -> KpatFixed + | Const _ -> KpatConst + | Evar (k, _) -> if is_defined sigma k then raise NoMatch else KpatEvar k + | LetIn _ -> KpatLet + | Lambda _ -> KpatLam + | _ -> KpatRigid in + sigma, uc, {u with up_k = k; up_FO = lhs; up_f = f; up_a = a; up_t = t} + +let nb_cs_proj_args pc f u = + let na k = + List.length (snd (lookup_canonical_conversion (ConstRef pc, k))).o_TCOMPS in + try match kind_of_term f with + | Prod _ -> na Prod_cs + | Sort s -> na (Sort_cs (family_of_sort s)) + | Const (c',_) when Constant.equal c' pc -> Array.length (snd (destApp u.up_f)) + | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (global_of_constr f)) + | _ -> -1 + with Not_found -> -1 + +let isEvar_k k f = + match kind_of_term f with Evar (k', _) -> k = k' | _ -> false + +let nb_args c = + match kind_of_term c with App (_, a) -> Array.length a | _ -> 0 + +let mkSubArg i a = if i = Array.length a then a else Array.sub a 0 i +let mkSubApp f i a = if i = 0 then f else mkApp (f, mkSubArg i a) + +let splay_app ise = + let rec loop c a = match kind_of_term c with + | App (f, a') -> loop f (Array.append a' a) + | Cast (c', _, _) -> loop c' a + | Evar ex -> + (try loop (existential_value ise ex) a with _ -> c, a) + | _ -> c, a in + fun c -> match kind_of_term c with + | App (f, a) -> loop f a + | Cast _ | Evar _ -> loop c [| |] + | _ -> c, [| |] + +let filter_upat i0 f n u fpats = + let na = Array.length u.up_a in + if n < na then fpats else + let np = match u.up_k with + | KpatConst when Term.eq_constr u.up_f f -> na + | KpatFixed when Term.eq_constr u.up_f f -> na + | KpatEvar k when isEvar_k k f -> na + | KpatLet when isLetIn f -> na + | KpatLam when isLambda f -> na + | KpatRigid when isRigid f -> na + | KpatFlex -> na + | KpatProj pc -> + let np = na + nb_cs_proj_args pc f u in if n < np then -1 else np + | _ -> -1 in + if np < na then fpats else + let () = if !i0 < np then i0 := n in (u, np) :: fpats + +let filter_upat_FO i0 f n u fpats = + let np = nb_args u.up_FO in + if n < np then fpats else + let ok = match u.up_k with + | KpatConst -> Term.eq_constr u.up_f f + | KpatFixed -> Term.eq_constr u.up_f f + | KpatEvar k -> isEvar_k k f + | KpatLet -> isLetIn f + | KpatLam -> isLambda f + | KpatRigid -> isRigid f + | KpatProj pc -> Term.eq_constr f (mkConst pc) + | KpatFlex -> i0 := n; true in + if ok then begin if !i0 < np then i0 := np; (u, np) :: fpats end else fpats + +exception FoundUnif of (evar_map * evar_universe_context * tpattern) +(* Note: we don't update env as we descend into the term, as the primitive *) +(* unification procedure always rejects subterms with bound variables. *) + +(* We are forced to duplicate code between the FO/HO matching because we *) +(* have to work around several kludges in unify.ml: *) +(* - w_unify drops into second-order unification when the pattern is an *) +(* application whose head is a meta. *) +(* - w_unify tries to unify types without subsumption when the pattern *) +(* head is an evar or meta (e.g., it fails on ?1 = nat when ?1 : Type). *) +(* - w_unify expands let-in (zeta conversion) eagerly, whereas we want to *) +(* match a head let rigidly. *) +let match_upats_FO upats env sigma0 ise = + let rec loop c = + let f, a = splay_app ise c in let i0 = ref (-1) in + let fpats = + List.fold_right (filter_upat_FO i0 f (Array.length a)) upats [] in + while !i0 >= 0 do + let i = !i0 in i0 := -1; + let c' = mkSubApp f i a in + let one_match (u, np) = + let skip = + if i <= np then i < np else + if u.up_k == KpatFlex then begin i0 := i - 1; false end else + begin if !i0 < np then i0 := np; true end in + if skip || not (closed0 c') then () else try + let _ = match u.up_k with + | KpatFlex -> + let kludge v = mkLambda (Anonymous, mkProp, v) in + unif_FO env ise (kludge u.up_FO) (kludge c') + | KpatLet -> + let kludge vla = + let vl, a = safeDestApp vla in + let x, v, t, b = destLetIn vl in + mkApp (mkLambda (x, t, b), Array.cons v a) in + unif_FO env ise (kludge u.up_FO) (kludge c') + | _ -> unif_FO env ise u.up_FO c' in + let ise' = (* Unify again using HO to assign evars *) + let p = mkApp (u.up_f, u.up_a) in + try unif_HO env ise p c' with _ -> raise NoMatch in + let lhs = mkSubApp f i a in + let pt' = unif_end env sigma0 ise' u.up_t (u.up_ok lhs) in + raise (FoundUnif (ungen_upat lhs pt' u)) + with FoundUnif _ as sigma_u -> raise sigma_u + | Not_found -> Errors.anomaly (str"incomplete ise in match_upats_FO") + | _ -> () in + List.iter one_match fpats + done; + iter_constr_LR loop f; Array.iter loop a in + fun c -> try loop c with Invalid_argument _ -> Errors.anomaly (str"IN FO") + +let prof_FO = mk_profiler "match_upats_FO";; +let match_upats_FO upats env sigma0 ise c = + prof_FO.profile (match_upats_FO upats env sigma0) ise c +;; + + +let match_upats_HO upats env sigma0 ise c = + let it_did_match = ref false in + let rec aux upats env sigma0 ise c = + let f, a = splay_app ise c in let i0 = ref (-1) in + let fpats = List.fold_right (filter_upat i0 f (Array.length a)) upats [] in + while !i0 >= 0 do + let i = !i0 in i0 := -1; + let one_match (u, np) = + let skip = + if i <= np then i < np else + if u.up_k == KpatFlex then begin i0 := i - 1; false end else + begin if !i0 < np then i0 := np; true end in + if skip then () else try + let ise' = match u.up_k with + | KpatFixed | KpatConst -> ise + | KpatEvar _ -> + let _, pka = destEvar u.up_f and _, ka = destEvar f in + unif_HO_args env ise pka 0 ka + | KpatLet -> + let x, v, t, b = destLetIn f in + let _, pv, _, pb = destLetIn u.up_f in + let ise' = unif_HO env ise pv v in + unif_HO (Environ.push_rel (x, None, t) env) ise' pb b + | KpatFlex | KpatProj _ -> + unif_HO env ise u.up_f (mkSubApp f (i - Array.length u.up_a) a) + | _ -> unif_HO env ise u.up_f f in + let ise'' = unif_HO_args env ise' u.up_a (i - Array.length u.up_a) a in + let lhs = mkSubApp f i a in + let pt' = unif_end env sigma0 ise'' u.up_t (u.up_ok lhs) in + raise (FoundUnif (ungen_upat lhs pt' u)) + with FoundUnif _ as sigma_u -> raise sigma_u + | NoProgress -> it_did_match := true + | _ -> () in + List.iter one_match fpats + done; + iter_constr_LR (aux upats env sigma0 ise) f; + Array.iter (aux upats env sigma0 ise) a + in + aux upats env sigma0 ise c; + if !it_did_match then raise NoProgress + +let prof_HO = mk_profiler "match_upats_HO";; +let match_upats_HO upats env sigma0 ise c = + prof_HO.profile (match_upats_HO upats env sigma0) ise c +;; + + +let fixed_upat = function +| {up_k = KpatFlex | KpatEvar _ | KpatProj _} -> false +| {up_t = t} -> not (occur_existential t) + +let do_once r f = match !r with Some _ -> () | None -> r := Some (f ()) + +let assert_done r = + match !r with Some x -> x | None -> Errors.anomaly (str"do_once never called") + +type subst = Environ.env -> Term.constr -> int -> Term.constr +type find_P = + Environ.env -> Term.constr -> int -> + k:subst -> + Term.constr +type conclude = unit -> + Term.constr * ssrdir * (Evd.evar_map * Evd.evar_universe_context * Term.constr) + +(* upats_origin makes a better error message only *) +let mk_tpattern_matcher + ?(raise_NoMatch=false) ?upats_origin sigma0 occ (ise, upats) += + let nocc = ref 0 and skip_occ = ref false in + let use_occ, occ_list = match occ with + | Some (true, ol) -> ol = [], ol + | Some (false, ol) -> ol <> [], ol + | None -> false, [] in + let max_occ = List.fold_right max occ_list 0 in + let subst_occ = + let occ_set = Array.make max_occ (not use_occ) in + let _ = List.iter (fun i -> occ_set.(i - 1) <- use_occ) occ_list in + let _ = if max_occ = 0 then skip_occ := use_occ in + fun () -> incr nocc; + if !nocc = max_occ then skip_occ := use_occ; + if !nocc <= max_occ then occ_set.(!nocc - 1) else not use_occ in + let upat_that_matched = ref None in + let match_EQ env sigma u = + match u.up_k with + | KpatLet -> + let x, pv, t, pb = destLetIn u.up_f in + let env' = Environ.push_rel (x, None, t) env in + let match_let f = match kind_of_term f with + | LetIn (_, v, _, b) -> unif_EQ env sigma pv v && unif_EQ env' sigma pb b + | _ -> false in match_let + | KpatFixed -> Term.eq_constr u.up_f + | KpatConst -> Term.eq_constr u.up_f + | KpatLam -> fun c -> + (match kind_of_term c with + | Lambda _ -> unif_EQ env sigma u.up_f c + | _ -> false) + | _ -> unif_EQ env sigma u.up_f in +let p2t p = mkApp(p.up_f,p.up_a) in +let source () = match upats_origin, upats with + | None, [p] -> + (if fixed_upat p then str"term " else str"partial term ") ++ + pr_constr_pat (p2t p) ++ spc() + | Some (dir,rule), [p] -> str"The " ++ pr_dir_side dir ++ str" of " ++ + pr_constr_pat rule ++ fnl() ++ ws 4 ++ pr_constr_pat (p2t p) ++ fnl() + | Some (dir,rule), _ -> str"The " ++ pr_dir_side dir ++ str" of " ++ + pr_constr_pat rule ++ spc() + | _, [] | None, _::_::_ -> + Errors.anomaly (str"mk_tpattern_matcher with no upats_origin") in +((fun env c h ~k -> + do_once upat_that_matched (fun () -> + try + match_upats_FO upats env sigma0 ise c; + match_upats_HO upats env sigma0 ise c; + raise NoMatch + with FoundUnif sigma_u -> sigma_u + | NoMatch when (not raise_NoMatch) -> + errorstrm (source () ++ str "does not match any subterm of the goal") + | NoProgress when (not raise_NoMatch) -> + let dir = match upats_origin with Some (d,_) -> d | _ -> + Errors.anomaly (str"mk_tpattern_matcher with no upats_origin") in + errorstrm (str"all matches of "++source()++ + str"are equal to the " ++ pr_dir_side (inv_dir dir)) + | NoProgress -> raise NoMatch); + let sigma, _, ({up_f = pf; up_a = pa} as u) = assert_done upat_that_matched in + pp(lazy(str"sigma@tmatch=" ++ pr_evar_map None sigma)); + if !skip_occ then (ignore(k env u.up_t 0); c) else + let match_EQ = match_EQ env sigma u in + let pn = Array.length pa in + let rec subst_loop (env,h as acc) c' = + if !skip_occ then c' else + let f, a = splay_app sigma c' in + if Array.length a >= pn && match_EQ f && unif_EQ_args env sigma pa a then + let a1, a2 = Array.chop (Array.length pa) a in + let fa1 = mkApp (f, a1) in + let f' = if subst_occ () then k env u.up_t h else fa1 in + mkApp (f', Array.map_left (subst_loop acc) a2) + else + (* TASSI: clear letin values to avoid unfolding *) + let inc_h (n,_,ty) (env,h') = Environ.push_rel (n,None,ty) env, h' + 1 in + let f' = map_constr_with_binders_left_to_right inc_h subst_loop acc f in + mkApp (f', Array.map_left (subst_loop acc) a) in + subst_loop (env,h) c) : find_P), +((fun () -> + let sigma, uc, ({up_f = pf; up_a = pa} as u) = + match !upat_that_matched with + | Some x -> x | None when raise_NoMatch -> raise NoMatch + | None -> Errors.anomaly (str"companion function never called") in + let p' = mkApp (pf, pa) in + if max_occ <= !nocc then p', u.up_dir, (sigma, uc, u.up_t) + else errorstrm (str"Only " ++ int !nocc ++ str" < " ++ int max_occ ++ + str(String.plural !nocc " occurence") ++ match upats_origin with + | None -> str" of" ++ spc() ++ pr_constr_pat p' + | Some (dir,rule) -> str" of the " ++ pr_dir_side dir ++ fnl() ++ + ws 4 ++ pr_constr_pat p' ++ fnl () ++ + str"of " ++ pr_constr_pat rule)) : conclude) + +type ('ident, 'term) ssrpattern = + | T of 'term + | In_T of 'term + | X_In_T of 'ident * 'term + | In_X_In_T of 'ident * 'term + | E_In_X_In_T of 'term * 'ident * 'term + | E_As_X_In_T of 'term * 'ident * 'term + +let pr_pattern = function + | T t -> prl_term t + | In_T t -> str "in " ++ prl_term t + | X_In_T (x,t) -> prl_term x ++ str " in " ++ prl_term t + | In_X_In_T (x,t) -> str "in " ++ prl_term x ++ str " in " ++ prl_term t + | E_In_X_In_T (e,x,t) -> + prl_term e ++ str " in " ++ prl_term x ++ str " in " ++ prl_term t + | E_As_X_In_T (e,x,t) -> + prl_term e ++ str " as " ++ prl_term x ++ str " in " ++ prl_term t + +let pr_pattern_w_ids = function + | T t -> prl_term t + | In_T t -> str "in " ++ prl_term t + | X_In_T (x,t) -> pr_id x ++ str " in " ++ prl_term t + | In_X_In_T (x,t) -> str "in " ++ pr_id x ++ str " in " ++ prl_term t + | E_In_X_In_T (e,x,t) -> + prl_term e ++ str " in " ++ pr_id x ++ str " in " ++ prl_term t + | E_As_X_In_T (e,x,t) -> + prl_term e ++ str " as " ++ pr_id x ++ str " in " ++ prl_term t + +let pr_pattern_aux pr_constr = function + | T t -> pr_constr t + | In_T t -> str "in " ++ pr_constr t + | X_In_T (x,t) -> pr_constr x ++ str " in " ++ pr_constr t + | In_X_In_T (x,t) -> str "in " ++ pr_constr x ++ str " in " ++ pr_constr t + | E_In_X_In_T (e,x,t) -> + pr_constr e ++ str " in " ++ pr_constr x ++ str " in " ++ pr_constr t + | E_As_X_In_T (e,x,t) -> + pr_constr e ++ str " as " ++ pr_constr x ++ str " in " ++ pr_constr t +let pp_pattern (sigma, p) = + pr_pattern_aux (fun t -> pr_constr (pi3 (nf_open_term sigma sigma t))) p +let pr_cpattern = pr_term +let pr_rpattern _ _ _ = pr_pattern + +let pr_option f = function None -> mt() | Some x -> f x +let pr_ssrpattern _ _ _ = pr_option pr_pattern +let pr_pattern_squarep = pr_option (fun r -> str "[" ++ pr_pattern r ++ str "]") +let pr_ssrpattern_squarep _ _ _ = pr_pattern_squarep +let pr_pattern_roundp = pr_option (fun r -> str "(" ++ pr_pattern r ++ str ")") +let pr_ssrpattern_roundp _ _ _ = pr_pattern_roundp + +let wit_rpatternty = add_genarg "rpatternty" pr_pattern + +ARGUMENT EXTEND rpattern TYPED AS rpatternty PRINTED BY pr_rpattern + | [ lconstr(c) ] -> [ T (mk_lterm c) ] + | [ "in" lconstr(c) ] -> [ In_T (mk_lterm c) ] + | [ lconstr(x) "in" lconstr(c) ] -> + [ X_In_T (mk_lterm x, mk_lterm c) ] + | [ "in" lconstr(x) "in" lconstr(c) ] -> + [ In_X_In_T (mk_lterm x, mk_lterm c) ] + | [ lconstr(e) "in" lconstr(x) "in" lconstr(c) ] -> + [ E_In_X_In_T (mk_lterm e, mk_lterm x, mk_lterm c) ] + | [ lconstr(e) "as" lconstr(x) "in" lconstr(c) ] -> + [ E_As_X_In_T (mk_lterm e, mk_lterm x, mk_lterm c) ] +END + +type cpattern = char * glob_constr_and_expr +let tag_of_cpattern = fst +let loc_of_cpattern = loc_ofCG +let cpattern_of_term t = t +type occ = (bool * int list) option + +type rpattern = (cpattern, cpattern) ssrpattern +let pr_rpattern = pr_pattern + +type pattern = Evd.evar_map * (Term.constr, Term.constr) ssrpattern + + +let id_of_cpattern = function + | _,(_,Some (CRef (Ident (_, x), _))) -> Some x + | _,(_,Some (CAppExpl (_, (_, Ident (_, x), _), []))) -> Some x + | _,(GRef (_, VarRef x, _) ,None) -> Some x + | _ -> None +let id_of_Cterm t = match id_of_cpattern t with + | Some x -> x + | None -> loc_error (loc_of_cpattern t) "Only identifiers are allowed here" + +let interp_wit wit ist gl x = + let globarg = in_gen (glbwit wit) x in + let sigma, arg = interp_genarg ist (pf_env gl) (project gl) (pf_concl gl) gl.Evd.it globarg in + sigma, out_gen (topwit wit) arg +let interp_constr = interp_wit wit_constr +let interp_open_constr ist gl gc = + interp_wit wit_open_constr ist gl ((), gc) +let pf_intern_term ist gl (_, c) = glob_constr ist (pf_env gl) c +let interp_term ist gl (_, c) = snd (interp_open_constr ist gl c) +let glob_ssrterm gs = function + | k, (_, Some c) -> k, Tacintern.intern_constr gs c + | ct -> ct +let subst_ssrterm s (k, c) = k, Tacsubst.subst_glob_constr_and_expr s c +let pr_ssrterm _ _ _ = pr_term +let input_ssrtermkind strm = match Compat.get_tok (stream_nth 0 strm) with + | Tok.KEYWORD "(" -> '(' + | Tok.KEYWORD "@" -> '@' + | _ -> ' ' +let ssrtermkind = Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind + +(* This piece of code asserts the following notations are reserved *) +(* Reserved Notation "( a 'in' b )" (at level 0). *) +(* Reserved Notation "( a 'as' b )" (at level 0). *) +(* Reserved Notation "( a 'in' b 'in' c )" (at level 0). *) +(* Reserved Notation "( a 'as' b 'in' c )" (at level 0). *) +let glob_cpattern gs p = + pp(lazy(str"globbing pattern: " ++ pr_term p)); + let glob x = snd (glob_ssrterm gs (mk_lterm x)) in + let encode k s l = + let name = Name (id_of_string ("_ssrpat_" ^ s)) in + k, (mkRCast mkRHole (mkRLambda name mkRHole (mkRApp mkRHole l)), None) in + let bind_in t1 t2 = + let d = dummy_loc in let n = Name (destCVar t1) in + fst (glob (mkCCast d (mkCHole d) (mkCLambda d n (mkCHole d) t2))) in + let check_var t2 = if not (isCVar t2) then + loc_error (constr_loc t2) "Only identifiers are allowed here" in + match p with + | _, (_, None) as x -> x + | k, (v, Some t) as orig -> + if k = 'x' then glob_ssrterm gs ('(', (v, Some t)) else + match t with + | CNotation(_, "( _ in _ )", ([t1; t2], [], [])) -> + (try match glob t1, glob t2 with + | (r1, None), (r2, None) -> encode k "In" [r1;r2] + | (r1, Some _), (r2, Some _) when isCVar t1 -> + encode k "In" [r1; r2; bind_in t1 t2] + | (r1, Some _), (r2, Some _) -> encode k "In" [r1; r2] + | _ -> Errors.anomaly (str"where are we?") + with _ when isCVar t1 -> encode k "In" [bind_in t1 t2]) + | CNotation(_, "( _ in _ in _ )", ([t1; t2; t3], [], [])) -> + check_var t2; encode k "In" [fst (glob t1); bind_in t2 t3] + | CNotation(_, "( _ as _ )", ([t1; t2], [], [])) -> + encode k "As" [fst (glob t1); fst (glob t2)] + | CNotation(_, "( _ as _ in _ )", ([t1; t2; t3], [], [])) -> + check_var t2; encode k "As" [fst (glob t1); bind_in t2 t3] + | _ -> glob_ssrterm gs orig +;; + +let interp_ssrterm _ gl t = Tacmach.project gl, t + +ARGUMENT EXTEND cpattern + PRINTED BY pr_ssrterm + INTERPRETED BY interp_ssrterm + GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm + RAW_TYPED AS cpattern RAW_PRINTED BY pr_ssrterm + GLOB_TYPED AS cpattern GLOB_PRINTED BY pr_ssrterm +| [ "Qed" constr(c) ] -> [ mk_lterm c ] +END + +let (!@) = Compat.to_coqloc + +GEXTEND Gram + GLOBAL: cpattern; + cpattern: [[ k = ssrtermkind; c = constr -> + let pattern = mk_term k c in + if loc_ofCG pattern <> !@loc && k = '(' then mk_term 'x' c else pattern ]]; +END + +ARGUMENT EXTEND lcpattern + PRINTED BY pr_ssrterm + INTERPRETED BY interp_ssrterm + GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm + RAW_TYPED AS cpattern RAW_PRINTED BY pr_ssrterm + GLOB_TYPED AS cpattern GLOB_PRINTED BY pr_ssrterm +| [ "Qed" lconstr(c) ] -> [ mk_lterm c ] +END + +GEXTEND Gram + GLOBAL: lcpattern; + lcpattern: [[ k = ssrtermkind; c = lconstr -> + let pattern = mk_term k c in + if loc_ofCG pattern <> !@loc && k = '(' then mk_term 'x' c else pattern ]]; +END + +let interp_pattern ist gl red redty = + pp(lazy(str"interpreting: " ++ pr_pattern red)); + let xInT x y = X_In_T(x,y) and inXInT x y = In_X_In_T(x,y) in + let inT x = In_T x and eInXInT e x t = E_In_X_In_T(e,x,t) in + let eAsXInT e x t = E_As_X_In_T(e,x,t) in + let mkG ?(k=' ') x = k,(x,None) in + let decode t f g = + try match (pf_intern_term ist gl t) with + | GCast(_,GHole _,CastConv(GLambda(_,Name x,_,_,c))) -> f x (' ',(c,None)) + | it -> g t with _ -> g t in + let decodeG t f g = decode (mkG t) f g in + let bad_enc id _ = Errors.anomaly (str"bad encoding for pattern "++str id) in + let cleanup_XinE h x rp sigma = + let h_k = match kind_of_term h with Evar (k,_) -> k | _ -> assert false in + let to_clean, update = (* handle rename if x is already used *) + let ctx = pf_hyps gl in + let len = Context.named_context_length ctx in + let name = ref None in + try ignore(Context.lookup_named x ctx); (name, fun k -> + if !name = None then + let nctx = Evd.evar_context (Evd.find sigma k) in + let nlen = Context.named_context_length nctx in + if nlen > len then begin + name := Some (pi1 (List.nth nctx (nlen - len - 1))) + end) + with Not_found -> ref (Some x), fun _ -> () in + let sigma0 = project gl in + let new_evars = + let rec aux acc t = match kind_of_term t with + | Evar (k,_) -> + if k = h_k || List.mem k acc || Evd.mem sigma0 k then acc else + (update k; k::acc) + | _ -> fold_constr aux acc t in + aux [] (Evarutil.nf_evar sigma rp) in + let sigma = + List.fold_left (fun sigma e -> + if Evd.is_defined sigma e then sigma else (* clear may be recursiv *) + let name = Option.get !to_clean in + pp(lazy(pr_id name)); + try snd(Logic.prim_refiner (Proof_type.Thin [name]) sigma e) + with Evarutil.ClearDependencyError _ -> sigma) + sigma new_evars in + sigma in + let red = match red with + | T(k,(GCast (_,GHole _,(CastConv(GLambda (_,Name id,_,_,t)))),None)) + when let id = string_of_id id in let len = String.length id in + (len > 8 && String.sub id 0 8 = "_ssrpat_") -> + let id = string_of_id id in let len = String.length id in + (match String.sub id 8 (len - 8), t with + | "In", GApp(_, _, [t]) -> decodeG t xInT (fun x -> T x) + | "In", GApp(_, _, [e; t]) -> decodeG t (eInXInT (mkG e)) (bad_enc id) + | "In", GApp(_, _, [e; t; e_in_t]) -> + decodeG t (eInXInT (mkG e)) + (fun _ -> decodeG e_in_t xInT (fun _ -> assert false)) + | "As", GApp(_, _, [e; t]) -> decodeG t (eAsXInT (mkG e)) (bad_enc id) + | _ -> bad_enc id ()) + | T t -> decode t xInT (fun x -> T x) + | In_T t -> decode t inXInT inT + | X_In_T (e,t) -> decode t (eInXInT e) (fun x -> xInT (id_of_Cterm e) x) + | In_X_In_T (e,t) -> inXInT (id_of_Cterm e) t + | E_In_X_In_T (e,x,rp) -> eInXInT e (id_of_Cterm x) rp + | E_As_X_In_T (e,x,rp) -> eAsXInT e (id_of_Cterm x) rp in + pp(lazy(str"decoded as: " ++ pr_pattern_w_ids red)); + let red = match redty with None -> red | Some ty -> let ty = ' ', ty in + match red with + | T t -> T (combineCG t ty (mkCCast (loc_ofCG t)) mkRCast) + | X_In_T (x,t) -> + let ty = pf_intern_term ist gl ty in + E_As_X_In_T (mkG (mkRCast mkRHole ty), x, t) + | E_In_X_In_T (e,x,t) -> + let ty = mkG (pf_intern_term ist gl ty) in + E_In_X_In_T (combineCG e ty (mkCCast (loc_ofCG t)) mkRCast, x, t) + | E_As_X_In_T (e,x,t) -> + let ty = mkG (pf_intern_term ist gl ty) in + E_As_X_In_T (combineCG e ty (mkCCast (loc_ofCG t)) mkRCast, x, t) + | red -> red in + pp(lazy(str"typed as: " ++ pr_pattern_w_ids red)); + let mkXLetIn loc x (a,(g,c)) = match c with + | Some b -> a,(g,Some (mkCLetIn loc x (mkCHole loc) b)) + | None -> a,(GLetIn (loc,x,(GHole (loc, BinderType x, IntroAnonymous, None)), g), None) in + match red with + | T t -> let sigma, t = interp_term ist gl t in sigma, T t + | In_T t -> let sigma, t = interp_term ist gl t in sigma, In_T t + | X_In_T (x, rp) | In_X_In_T (x, rp) -> + let mk x p = match red with X_In_T _ -> X_In_T(x,p) | _ -> In_X_In_T(x,p) in + let rp = mkXLetIn dummy_loc (Name x) rp in + let sigma, rp = interp_term ist gl rp in + let _, h, _, rp = destLetIn rp in + let sigma = cleanup_XinE h x rp sigma in + let rp = subst1 h (Evarutil.nf_evar sigma rp) in + sigma, mk h rp + | E_In_X_In_T(e, x, rp) | E_As_X_In_T (e, x, rp) -> + let mk e x p = + match red with E_In_X_In_T _ ->E_In_X_In_T(e,x,p)|_->E_As_X_In_T(e,x,p) in + let rp = mkXLetIn dummy_loc (Name x) rp in + let sigma, rp = interp_term ist gl rp in + let _, h, _, rp = destLetIn rp in + let sigma = cleanup_XinE h x rp sigma in + let rp = subst1 h (Evarutil.nf_evar sigma rp) in + let sigma, e = interp_term ist (re_sig (sig_it gl) sigma) e in + sigma, mk e h rp +;; +let interp_cpattern ist gl red redty = interp_pattern ist gl (T red) redty;; +let interp_rpattern ist gl red = interp_pattern ist gl red None;; + +(* The full occurrence set *) +let noindex = Some(false,[]) + +(* calls do_subst on every sub-term identified by (pattern,occ) *) +let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = + let fs sigma x = Reductionops.nf_evar sigma x in + let pop_evar sigma e p = + let { Evd.evar_body = e_body } as e_def = Evd.find sigma e in + let e_body = match e_body with Evar_defined c -> c + | _ -> errorstrm (str "Matching the pattern " ++ pr_constr p ++ + str " did not instantiate ?" ++ int (Evar.repr e) ++ spc () ++ + str "Does the variable bound by the \"in\" construct occur "++ + str "in the pattern?") in + let sigma = + Evd.add (Evd.remove sigma e) e {e_def with Evd.evar_body = Evar_empty} in + sigma, e_body in + let ex_value hole = + match kind_of_term hole with Evar (e,_) -> e | _ -> assert false in + let mk_upat_for ?hack env sigma0 (sigma, t) ?(p=t) ok = + let sigma,pat= mk_tpattern ?hack env sigma0 (sigma,p) ok L2R (fs sigma t) in + sigma, [pat] in + match pattern with + | None -> do_subst env0 concl0 1 + | Some (sigma, (T rp | In_T rp)) -> + let rp = fs sigma rp in + let ise = create_evar_defs sigma in + let occ = match pattern with Some (_, T _) -> occ | _ -> noindex in + let rp = mk_upat_for env0 sigma0 (ise, rp) all_ok in + let find_T, end_T = mk_tpattern_matcher ?raise_NoMatch sigma0 occ rp in + let concl = find_T env0 concl0 1 do_subst in + let _ = end_T () in + concl + | Some (sigma, (X_In_T (hole, p) | In_X_In_T (hole, p))) -> + let p = fs sigma p in + let occ = match pattern with Some (_, X_In_T _) -> occ | _ -> noindex in + let ex = ex_value hole in + let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in + let find_T, end_T = mk_tpattern_matcher sigma0 noindex rp in + (* we start from sigma, so hole is considered a rigid head *) + let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in + let find_X, end_X = mk_tpattern_matcher ?raise_NoMatch sigma occ holep in + let concl = find_T env0 concl0 1 (fun env c h -> + let p_sigma = unify_HO env (create_evar_defs sigma) c p in + let sigma, e_body = pop_evar p_sigma ex p in + fs p_sigma (find_X env (fs sigma p) h + (fun env _ -> do_subst env e_body))) in + let _ = end_X () in let _ = end_T () in + concl + | Some (sigma, E_In_X_In_T (e, hole, p)) -> + let p, e = fs sigma p, fs sigma e in + let ex = ex_value hole in + let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in + let find_T, end_T = mk_tpattern_matcher sigma0 noindex rp in + let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in + let find_X, end_X = mk_tpattern_matcher sigma noindex holep in + let re = mk_upat_for env0 sigma0 (sigma, e) all_ok in + let find_E, end_E = mk_tpattern_matcher ?raise_NoMatch sigma0 occ re in + let concl = find_T env0 concl0 1 (fun env c h -> + let p_sigma = unify_HO env (create_evar_defs sigma) c p in + let sigma, e_body = pop_evar p_sigma ex p in + fs p_sigma (find_X env (fs sigma p) h (fun env c h -> + find_E env e_body h do_subst))) in + let _ = end_E () in let _ = end_X () in let _ = end_T () in + concl + | Some (sigma, E_As_X_In_T (e, hole, p)) -> + let p, e = fs sigma p, fs sigma e in + let ex = ex_value hole in + let rp = + let e_sigma = unify_HO env0 sigma hole e in + e_sigma, fs e_sigma p in + let rp = mk_upat_for ~hack:true env0 sigma0 rp all_ok in + let find_TE, end_TE = mk_tpattern_matcher sigma0 noindex rp in + let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in + let find_X, end_X = mk_tpattern_matcher sigma occ holep in + let concl = find_TE env0 concl0 1 (fun env c h -> + let p_sigma = unify_HO env (create_evar_defs sigma) c p in + let sigma, e_body = pop_evar p_sigma ex p in + fs p_sigma (find_X env (fs sigma p) h (fun env c h -> + let e_sigma = unify_HO env sigma e_body e in + let e_body = fs e_sigma e in + do_subst env e_body h))) in + let _ = end_X () in let _ = end_TE () in + concl +;; + +let redex_of_pattern ?(resolve_typeclasses=false) env (sigma, p) = + let e = match p with + | In_T _ | In_X_In_T _ -> Errors.anomaly (str"pattern without redex") + | T e | X_In_T (e, _) | E_As_X_In_T (e, _, _) | E_In_X_In_T (e, _, _) -> e in + let sigma = + if not resolve_typeclasses then sigma + else Typeclasses.resolve_typeclasses ~fail:false env sigma in + Reductionops.nf_evar sigma e, Evd.evar_universe_context sigma + +let fill_occ_pattern ?raise_NoMatch env sigma cl pat occ h = + let find_R, conclude = let r = ref None in + (fun env c h' -> do_once r (fun () -> c, Evd.empty_evar_universe_context); + mkRel (h'+h-1)), + (fun _ -> if !r = None then redex_of_pattern env pat else assert_done r) in + let cl = eval_pattern ?raise_NoMatch env sigma cl (Some pat) occ find_R in + let e = conclude cl in + e, cl +;; + +(* clenup interface for external use *) +let mk_tpattern ?p_origin env sigma0 sigma_t f dir c = + mk_tpattern ?p_origin env sigma0 sigma_t f dir c +;; + +let pf_fill_occ env concl occ sigma0 p (sigma, t) ok h = + let ise = create_evar_defs sigma in + let ise, u = mk_tpattern env sigma0 (ise,t) ok L2R p in + let find_U, end_U = + mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[u]) in + let concl = find_U env concl h (fun _ _ -> mkRel) in + let rdx, _, (sigma, uc, p) = end_U () in + sigma, uc, p, concl, rdx + +let fill_occ_term env cl occ sigma0 (sigma, t) = + try + let sigma',uc,t',cl,_= pf_fill_occ env cl occ sigma0 t (sigma, t) all_ok 1 in + if sigma' != sigma0 then Errors.error "matching impacts evars" + else cl, (Evd.merge_universe_context sigma' uc, t') + with NoMatch -> try + let sigma', uc, t' = + unif_end env sigma0 (create_evar_defs sigma) t (fun _ -> true) in + if sigma' != sigma0 then raise NoMatch + else cl, (Evd.merge_universe_context sigma' uc, t') + with _ -> + errorstrm (str "partial term " ++ pr_constr_pat t + ++ str " does not match any subterm of the goal") + +let pf_fill_occ_term gl occ t = + let sigma0 = project gl and env = pf_env gl and concl = pf_concl gl in + let cl,(_,t) = fill_occ_term env concl occ sigma0 t in + cl, t + +let cpattern_of_id id = ' ', (GRef (dummy_loc, VarRef id, None), None) + +let is_wildcard = function + | _,(_,Some (CHole _)|GHole _,None) -> true + | _ -> false + +(* "ssrpattern" *) +let pr_ssrpatternarg _ _ _ cpat = pr_rpattern cpat + +ARGUMENT EXTEND ssrpatternarg + TYPED AS rpattern + PRINTED BY pr_ssrpatternarg +| [ "[" rpattern(pat) "]" ] -> [ pat ] +END + +let pf_merge_uc uc gl = + re_sig (sig_it gl) (Evd.merge_universe_context (project gl) uc) + +let ssrpatterntac ist arg gl = + let pat = interp_rpattern ist gl arg in + let sigma0 = project gl in + let concl0 = pf_concl gl in + let (t, uc), concl_x = + fill_occ_pattern (Global.env()) sigma0 concl0 pat noindex 1 in + let tty = pf_type_of gl t in + let concl = mkLetIn (Name (id_of_string "toto"), t, tty, concl_x) in + Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl + +TACTIC EXTEND ssrat +| [ "ssrpattern" ssrpatternarg(arg) ] -> [ Proofview.V82.tactic (ssrpatterntac ist arg) ] +END + + +(* We wipe out all the keywords generated by the grammar rules we defined. *) +(* The user is supposed to Require Import ssreflect or Require ssreflect *) +(* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) +(* consequence the extended ssreflect grammar. *) +let () = Lexer.unfreeze frozen_lexer ;; + +(* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/mathcomp/ssreflect/plugin/trunk/ssrmatching.mli b/mathcomp/ssreflect/plugin/trunk/ssrmatching.mli new file mode 100644 index 0000000..b355dc1 --- /dev/null +++ b/mathcomp/ssreflect/plugin/trunk/ssrmatching.mli @@ -0,0 +1,238 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) + +open Genarg +open Tacexpr +open Environ +open Evd +open Proof_type +open Term + +(** ******** Small Scale Reflection pattern matching facilities ************* *) + +(** Pattern parsing *) + +(** The type of context patterns, the patterns of the [set] tactic and + [:] tactical. These are patterns that identify a precise subterm. *) +type cpattern +val pr_cpattern : cpattern -> Pp.std_ppcmds + +(** CS cpattern: (f _), (X in t), (t in X in t), (t as X in t) *) +val cpattern : cpattern Pcoq.Gram.entry +val wit_cpattern : cpattern uniform_genarg_type + +(** OS cpattern: f _, (X in t), (t in X in t), (t as X in t) *) +val lcpattern : cpattern Pcoq.Gram.entry +val wit_lcpattern : cpattern uniform_genarg_type + +(** The type of rewrite patterns, the patterns of the [rewrite] tactic. + These patterns also include patterns that identify all the subterms + of a context (i.e. "in" prefix) *) +type rpattern +val pr_rpattern : rpattern -> Pp.std_ppcmds + +(** OS rpattern: f _, in t, X in t, in X in t, t in X in t, t as X in t *) +val rpattern : rpattern Pcoq.Gram.entry +val wit_rpattern : rpattern uniform_genarg_type + +(** Pattern interpretation and matching *) + +exception NoMatch +exception NoProgress + +(** AST for [rpattern] (and consequently [cpattern]) *) +type ('ident, 'term) ssrpattern = + | T of 'term + | In_T of 'term + | X_In_T of 'ident * 'term + | In_X_In_T of 'ident * 'term + | E_In_X_In_T of 'term * 'ident * 'term + | E_As_X_In_T of 'term * 'ident * 'term + +type pattern = evar_map * (constr, constr) ssrpattern +val pp_pattern : pattern -> Pp.std_ppcmds + +(** Extracts the redex and applies to it the substitution part of the pattern. + @raise Anomaly if called on [In_T] or [In_X_In_T] *) +val redex_of_pattern : + ?resolve_typeclasses:bool -> env -> pattern -> + constr Evd.in_evar_universe_context + +(** [interp_rpattern ise gl rpat] "internalizes" and "interprets" [rpat] + in the current [Ltac] interpretation signature [ise] and tactic input [gl]*) +val interp_rpattern : + Tacinterp.interp_sign -> goal Tacmach.sigma -> + rpattern -> + pattern + +(** [interp_cpattern ise gl cpat ty] "internalizes" and "interprets" [cpat] + in the current [Ltac] interpretation signature [ise] and tactic input [gl]. + [ty] is an optional type for the redex of [cpat] *) +val interp_cpattern : + Tacinterp.interp_sign -> goal Tacmach.sigma -> + cpattern -> glob_constr_and_expr option -> + pattern + +(** The set of occurrences to be matched. The boolean is set to true + * to signal the complement of this set (i.e. {-1 3}) *) +type occ = (bool * int list) option + +(** Substitution function. The [int] argument is the number of binders + traversed so far *) +type subst = env -> constr -> int -> constr + +(** [eval_pattern b env sigma t pat occ subst] maps [t] calling [subst] on every + [occ] occurrence of [pat]. The [int] argument is the number of + binders traversed. If [pat] is [None] then then subst is called on [t]. + [t] must live in [env] and [sigma], [pat] must have been interpreted in + (an extension of) [sigma]. + @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false]) + @return [t] where all [occ] occurrences of [pat] have been mapped using + [subst] *) +val eval_pattern : + ?raise_NoMatch:bool -> + env -> evar_map -> constr -> + pattern option -> occ -> subst -> + constr + +(** [fill_occ_pattern b env sigma t pat occ h] is a simplified version of + [eval_pattern]. + It replaces all [occ] occurrences of [pat] in [t] with Rel [h]. + [t] must live in [env] and [sigma], [pat] must have been interpreted in + (an extension of) [sigma]. + @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false]) + @return the instance of the redex of [pat] that was matched and [t] + transformed as described above. *) +val fill_occ_pattern : + ?raise_NoMatch:bool -> + env -> evar_map -> constr -> + pattern -> occ -> int -> + constr Evd.in_evar_universe_context * constr + +(** *************************** Low level APIs ****************************** *) + +(* The primitive matching facility. It matches of a term with holes, like + the T pattern above, and calls a continuation on its occurrences. *) + +type ssrdir = L2R | R2L +val pr_dir_side : ssrdir -> Pp.std_ppcmds + +(** a pattern for a term with wildcards *) +type tpattern + +(** [mk_tpattern env sigma0 sigma_t ok p_origin dir p] compiles a term [t] + living in [env] [sigma] (an extension of [sigma0]) intro a [tpattern]. + The [tpattern] can hold a (proof) term [p] and a diction [dir]. The [ok] + callback is used to filter occurrences. + @return the compiled [tpattern] and its [evar_map] + @raise UserEerror is the pattern is a wildcard *) +val mk_tpattern : + ?p_origin:ssrdir * constr -> + env -> evar_map -> + evar_map * constr -> + (constr -> evar_map -> bool) -> + ssrdir -> constr -> + evar_map * tpattern + +(** [findP env t i k] is a stateful function that finds the next occurrence + of a tpattern and calls the callback [k] to map the subterm matched. + The [int] argument passed to [k] is the number of binders traversed so far + plus the initial value [i]. + @return [t] where the subterms identified by the selected occurrences of + the patter have been mapped using [k] + @raise NoMatch if the raise_NoMatch flag given to [mk_tpattern_matcher] is + [true] and if the pattern did not match + @raise UserEerror if the raise_NoMatch flag given to [mk_tpattern_matcher] is + [false] and if the pattern did not match *) +type find_P = + env -> constr -> int -> k:subst -> constr + +(** [conclude ()] asserts that all mentioned ocurrences have been visited. + @return the instance of the pattern, the evarmap after the pattern + instantiation, the proof term and the ssrdit stored in the tpattern + @raise UserEerror if too many occurrences were specified *) +type conclude = + unit -> constr * ssrdir * (evar_map * Evd.evar_universe_context * constr) + +(** [mk_tpattern_matcher b o sigma0 occ sigma_tplist] creates a pair + a function [find_P] and [conclude] with the behaviour explained above. + The flag [b] (default [false]) changes the error reporting behaviour + of [find_P] if none of the [tpattern] matches. The argument [o] can + be passed to tune the [UserError] eventually raised (useful if the + pattern is coming from the LHS/RHS of an equation) *) +val mk_tpattern_matcher : + ?raise_NoMatch:bool -> + ?upats_origin:ssrdir * constr -> + evar_map -> occ -> evar_map * tpattern list -> + find_P * conclude + +(** Example of [mk_tpattern_matcher] to implement + [rewrite \{occ\}\[in t\]rules]. + It first matches "in t" (called [pat]), then in all matched subterms + it matches the LHS of the rules using [find_R]. + [concl0] is the initial goal, [concl] will be the goal where some terms + are replaced by a De Bruijn index. The [rw_progress] extra check + selects only occurrences that are not rewritten to themselves (e.g. + an occurrence "x + x" rewritten with the commutativity law of addition + is skipped) {[ + let find_R, conclude = match pat with + | Some (_, In_T _) -> + let aux (sigma, pats) (d, r, lhs, rhs) = + let sigma, pat = + mk_tpattern env0 sigma0 (sigma, r) (rw_progress rhs) d lhs in + sigma, pats @ [pat] in + let rpats = List.fold_left aux (r_sigma, []) rules in + let find_R, end_R = mk_tpattern_matcher sigma0 occ rpats in + find_R ~k:(fun _ _ h -> mkRel h), + fun cl -> let rdx, d, r = end_R () in (d,r),rdx + | _ -> ... in + let concl = eval_pattern env0 sigma0 concl0 pat occ find_R in + let (d, r), rdx = conclude concl in ]} *) + +(* convenience shortcut: [pf_fill_occ_term gl occ (sigma,t)] returns + * the conclusion of [gl] where [occ] occurrences of [t] have been replaced + * by [Rel 1] and the instance of [t] *) +val pf_fill_occ_term : + goal Tacmach.sigma -> occ -> evar_map * constr -> constr * constr + +(* It may be handy to inject a simple term into the first form of cpattern *) +val cpattern_of_term : char * glob_constr_and_expr -> cpattern + +(** Helpers to make stateful closures. Example: a [find_P] function may be + called many times, but the pattern instantiation phase is performed only the + first time. The corresponding [conclude] has to return the instantiated + pattern redex. Since it is up to [find_P] to raise [NoMatch] if the pattern + has no instance, [conclude] considers it an anomaly if the pattern did + not match *) + +(** [do_once r f] calls [f] and updates the ref only once *) +val do_once : 'a option ref -> (unit -> 'a) -> unit +(** [assert_done r] return the content of r. @raise Anomaly is r is [None] *) +val assert_done : 'a option ref -> 'a + +(** Very low level APIs. + these are calls to evarconv's [the_conv_x] followed by + [consider_remaining_unif_problems] and [resolve_typeclasses]. + In case of failure they raise [NoMatch] *) + +val unify_HO : env -> evar_map -> constr -> constr -> evar_map +val pf_unify_HO : goal Tacmach.sigma -> constr -> constr -> goal Tacmach.sigma + +(** Some more low level functions needed to implement the full SSR language + on top of the former APIs *) +val tag_of_cpattern : cpattern -> char +val loc_of_cpattern : cpattern -> Loc.t +val id_of_cpattern : cpattern -> Names.variable option +val is_wildcard : cpattern -> bool +val cpattern_of_id : Names.variable -> cpattern +val cpattern_of_id : Names.variable -> cpattern +val pr_constr_pat : constr -> Pp.std_ppcmds +val pf_merge_uc : Evd.evar_universe_context -> goal Evd.sigma -> goal Evd.sigma + +(* One can also "Set SsrMatchingDebug" from a .v *) +val debug : bool -> unit + +(* One should delimit a snippet with "Set SsrMatchingProfiling" and + * "Unset SsrMatchingProfiling" to get timings *) +val profile : bool -> unit + +(* eof *) diff --git a/mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 b/mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 new file mode 100644 index 0000000..c7a104b --- /dev/null +++ b/mathcomp/ssreflect/plugin/v8.4/ssreflect.ml4 @@ -0,0 +1,6030 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) + +(* This line is read by the Makefile's dist target: do not remove. *) +let ssrversion = "1.5";; +let ssrAstVersion = 1;; +let () = Mltop.add_known_plugin (fun () -> + if Flags.is_verbose () && not !Flags.batch_mode then begin + Printf.printf "\nSmall Scale Reflection version %s loaded.\n" ssrversion; + Printf.printf "Copyright 2005-2012 Microsoft Corporation and INRIA.\n"; + Printf.printf "Distributed under the terms of the CeCILL-B license.\n\n" + end; + (* Disable any semantics associated with bullets *) + Goptions.set_string_option_value_gen + (Some false) ["Bullet";"Behavior"] "None") + "ssreflect" +;; +(* Defining grammar rules with "xx" in it automatically declares keywords too *) +let frozen_lexer = Lexer.freeze () ;; + +(*i camlp4use: "pa_extend.cmo" i*) +(*i camlp4deps: "parsing/grammar.cma" i*) + +open Names +open Pp +open Pcoq +open Genarg +open Term +open Topconstr +open Libnames +open Tactics +open Tacticals +open Termops +open Namegen +open Recordops +open Tacmach +open Coqlib +open Glob_term +open Util +open Evd +open Extend +open Goptions +open Tacexpr +open Tacinterp +open Pretyping.Default +open Constr +open Tactic +open Extraargs +open Ppconstr +open Printer + +open Ssrmatching + +(** look up a name in the ssreflect internals module *) +let ssrdirpath = make_dirpath [id_of_string "ssreflect"] +let ssrqid name = make_qualid ssrdirpath (id_of_string name) +let ssrtopqid name = make_short_qualid (id_of_string name) +let locate_reference qid = + Smartlocate.global_of_extended_global (Nametab.locate_extended qid) +let mkSsrRef name = + try locate_reference (ssrqid name) with Not_found -> + try locate_reference (ssrtopqid name) with Not_found -> + error "Small scale reflection library not loaded" +let mkSsrRRef name = GRef (dummy_loc, mkSsrRef name) +let mkSsrConst name = constr_of_reference (mkSsrRef name) +let loc_error loc msg = user_err_loc (loc, msg, str msg) +let errorstrm = errorlabstrm "ssreflect" + +(** Ssreflect load check. *) + +(* To allow ssrcoq to be fully compatible with the "plain" Coq, we only *) +(* turn on its incompatible features (the new rewrite syntax, and the *) +(* reserved identifiers) when the theory library (ssreflect.v) has *) +(* has actually been required, or is being defined. Because this check *) +(* needs to be done often (for each identifier lookup), we implement *) +(* some caching, repeating the test only when the environment changes. *) +(* We check for protect_term because it is the first constant loaded; *) +(* ssr_have would ultimately be a better choice. *) +let ssr_loaded = + let cache = ref (Global.safe_env (), false) in + fun () -> + Lexer.is_keyword "is" && + let new_lbl = Global.safe_env () in + match !cache with + | lbl, loaded when lbl == new_lbl -> loaded + | _ -> + let loaded = + (try ignore (mkSsrRef "protect_term"); true with _ -> false) in + cache := new_lbl, loaded; loaded + +(* 0 cost pp function. Active only if env variable SSRDEBUG is set *) +(* or if SsrDebug is Set *) +let pp_ref = ref (fun _ -> ()) +let ssr_pp s = pperrnl (str"SSR: "++Lazy.force s) +let _ = try ignore(Sys.getenv "SSRDEBUG"); pp_ref := ssr_pp with Not_found -> () +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssreflect debugging"; + Goptions.optkey = ["SsrDebug"]; + Goptions.optdepr = false; + Goptions.optread = (fun _ -> !pp_ref == ssr_pp); + Goptions.optwrite = (fun b -> + Ssrmatching.debug b; + if b then pp_ref := ssr_pp else pp_ref := fun _ -> ()) } +let pp s = !pp_ref s + +(** Utils {{{ *****************************************************************) +let env_size env = List.length (Environ.named_context env) +let safeDestApp c = + match kind_of_term c with App (f, a) -> f, a | _ -> c, [| |] +let get_index = function ArgArg i -> i | _ -> + anomaly "Uninterpreted index" +(* Toplevel constr must be globalized twice ! *) +let glob_constr ist gsigma genv = function + | _, Some ce -> + let ltacvars = List.map fst ist.lfun, [] in + Constrintern.intern_gen false ~ltacvars:ltacvars gsigma genv ce + | rc, None -> rc + +(* Term printing utilities functions for deciding bracketing. *) +let pr_paren prx x = hov 1 (str "(" ++ prx x ++ str ")") +(* String lexing utilities *) +let skip_wschars s = + let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop +let skip_numchars s = + let rec loop i = match s.[i] with '0'..'9' -> loop (i + 1) | _ -> i in loop +(* We also guard characters that might interfere with the ssreflect *) +(* tactic syntax. *) +let guard_term ch1 s i = match s.[i] with + | '(' -> false + | '{' | '/' | '=' -> true + | _ -> ch1 = '(' +(* The call 'guard s i' should return true if the contents of s *) +(* starting at i need bracketing to avoid ambiguities. *) +let pr_guarded guard prc c = + msg_with Format.str_formatter (prc c); + let s = Format.flush_str_formatter () ^ "$" in + if guard s (skip_wschars s 0) then pr_paren prc c else prc c +(* More sensible names for constr printers *) +let prl_constr = pr_lconstr +let pr_constr = pr_constr +let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c +let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c +let prl_constr_expr = pr_lconstr_expr +let pr_constr_expr = pr_constr_expr +let prl_glob_constr_and_expr = function + | _, Some c -> prl_constr_expr c + | c, None -> prl_glob_constr c +let pr_glob_constr_and_expr = function + | _, Some c -> pr_constr_expr c + | c, None -> pr_glob_constr c +let pr_term (k, c) = pr_guarded (guard_term k) pr_glob_constr_and_expr c +let prl_term (k, c) = pr_guarded (guard_term k) prl_glob_constr_and_expr c + +(** Adding a new uninterpreted generic argument type *) +let add_genarg tag pr = + let wit, globwit, rawwit as wits = create_arg None tag in + let glob _ rarg = in_gen globwit (out_gen rawwit rarg) in + let interp _ gl garg = Tacmach.project gl,in_gen wit (out_gen globwit garg) in + let subst _ garg = garg in + add_interp_genarg tag (glob, interp, subst); + let gen_pr _ _ _ = pr in + Pptactic.declare_extra_genarg_pprule + (rawwit, gen_pr) (globwit, gen_pr) (wit, gen_pr); + wits + +(** Constructors for cast type *) +let dC t = CastConv (DEFAULTcast,t) + +(** Constructors for constr_expr *) +let mkCProp loc = CSort (loc, GProp Null) +let mkCType loc = CSort (loc, GType None) +let mkCVar loc id = CRef (Ident (loc, id)) +let isCVar = function CRef (Ident _) -> true | _ -> false +let destCVar = function CRef (Ident (_, id)) -> id | _ -> + anomaly "not a CRef" +let rec mkCHoles loc n = + if n <= 0 then [] else CHole (loc, None) :: mkCHoles loc (n - 1) +let mkCHole loc = CHole (loc, None) +let rec isCHoles = function CHole _ :: cl -> isCHoles cl | cl -> cl = [] +let mkCExplVar loc id n = + CAppExpl (loc, (None, Ident (loc, id)), mkCHoles loc n) +let mkCLambda loc name ty t = + CLambdaN (loc, [[loc, name], Default Explicit, ty], t) +let mkCLetIn loc name bo t = + CLetIn (loc, (loc, name), bo, t) +let mkCArrow loc ty t = + CProdN (loc, [[dummy_loc,Anonymous], Default Explicit, ty], t) +let mkCCast loc t ty = CCast (loc,t, dC ty) +(** Constructors for rawconstr *) +let mkRHole = GHole (dummy_loc, InternalHole) +let rec mkRHoles n = if n > 0 then mkRHole :: mkRHoles (n - 1) else [] +let rec isRHoles = function GHole _ :: cl -> isRHoles cl | cl -> cl = [] +let mkRApp f args = if args = [] then f else GApp (dummy_loc, f, args) +let mkRVar id = GRef (dummy_loc, VarRef id) +let mkRltacVar id = GVar (dummy_loc, id) +let mkRCast rc rt = GCast (dummy_loc, rc, dC rt) +let mkRType = GSort (dummy_loc, GType None) +let mkRProp = GSort (dummy_loc, GProp Null) +let mkRArrow rt1 rt2 = GProd (dummy_loc, Anonymous, Explicit, rt1, rt2) +let mkRConstruct c = GRef (dummy_loc, ConstructRef c) +let mkRInd mind = GRef (dummy_loc, IndRef mind) +let mkRLambda n s t = GLambda (dummy_loc, n, Explicit, s, t) + +(** Constructors for constr *) + +let mkAppRed f c = match kind_of_term f with +| Lambda (_, _, b) -> subst1 c b +| _ -> mkApp (f, [|c|]) +let mkProt t c = mkApp (mkSsrConst "protect_term", [|t; c|]) +let mkRefl t c = mkApp ((build_coq_eq_data()).refl, [|t; c|]) +(* Application to a sequence of n rels (for building eta-expansions). *) +(* The rel indices decrease down to imin (inclusive), unless n < 0, *) +(* in which case they're incresing (from imin). *) +let mkEtaApp c n imin = + if n = 0 then c else + let nargs, mkarg = + if n < 0 then -n, (fun i -> mkRel (imin + i)) else + let imax = imin + n - 1 in n, (fun i -> mkRel (imax - i)) in + mkApp (c, Array.init nargs mkarg) +(* Same, but optimizing head beta redexes *) +let rec whdEtaApp c n = + if n = 0 then c else match kind_of_term c with + | Lambda (_, _, c') -> whdEtaApp c' (n - 1) + | _ -> mkEtaApp (lift n c) n 1 +let mkType () = mkType (Univ.fresh_local_univ ()) + +(* ssrterm conbinators *) +let combineCG t1 t2 f g = match t1, t2 with + | (x, (t1, None)), (_, (t2, None)) -> x, (g t1 t2, None) + | (x, (_, Some t1)), (_, (_, Some t2)) -> x, (mkRHole, Some (f t1 t2)) + | _, (_, (_, None)) -> anomaly "have: mixed C-G constr" + | _ -> anomaly "have: mixed G-C constr" +let loc_ofCG = function + | (_, (s, None)) -> loc_of_glob_constr s + | (_, (_, Some s)) -> constr_loc s + +let mk_term k c = k, (mkRHole, Some c) +let mk_lterm = mk_term ' ' + +(* Backport from coq trunk *) +let array_smartfoldmap f accu (ar : 'a array) = + let len = Array.length ar in + let i = ref 0 in + let break = ref true in + let r = ref accu in + (** This variable is never accessed unset *) + let temp = ref None in + while !break && (!i < len) do + let v = Array.unsafe_get ar !i in + let (accu, v') = f !r v in + r := accu; + if v == v' then incr i + else begin + break := false; + temp := Some v'; + end + done; + if !i < len then begin + let ans : 'a array = Array.make len (Array.unsafe_get ar 0) in + (** TODO: use unsafe_blit in 4.01 *) + Array.blit ar 0 ans 0 !i; + let v = match !temp with None -> assert false | Some x -> x in + Array.unsafe_set ans !i v; + incr i; + while !i < len do + let v = Array.unsafe_get ar !i in + let (accu, v') = f !r v in + r := accu; + Array.unsafe_set ans !i v'; + incr i + done; + !r, ans + end else !r, ar + +let array_for_all2 f v1 v2 = + let rec allrec = function + | -1 -> true + | n -> + let ans = f (Array.unsafe_get v1 n) (Array.unsafe_get v2 n) in + ans && (allrec (n-1)) + in + let lv1 = Array.length v1 in + lv1 = Array.length v2 && allrec (pred lv1) + +let fold_left2 f a v1 v2 = + let lv1 = Array.length v1 in + let rec fold a n = + if n >= lv1 then a + else fold (f a (Array.unsafe_get v1 n) (Array.unsafe_get v2 n)) (succ n) + in + if Array.length v2 <> lv1 then invalid_arg "Array.fold_left2"; + fold a 0 +(* /Backport *) + +let map_fold_constr g f ctx acc cstr = + let array_f ctx acc x = let x, acc = f ctx acc x in acc, x in + match kind_of_term cstr with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> + cstr, acc + | Cast (c,k, t) -> + let c', acc = f ctx acc c in + let t', acc = f ctx acc t in + (if c==c' && t==t' then cstr else mkCast (c', k, t')), acc + | Prod (na,t,c) -> + let t', acc = f ctx acc t in + let c', acc = f (g (na,None,t) ctx) acc c in + (if t==t' && c==c' then cstr else mkProd (na, t', c')), acc + | Lambda (na,t,c) -> + let t', acc = f ctx acc t in + let c', acc = f (g (na,None,t) ctx) acc c in + (if t==t' && c==c' then cstr else mkLambda (na, t', c')), acc + | LetIn (na,b,t,c) -> + let b', acc = f ctx acc b in + let t', acc = f ctx acc t in + let c', acc = f (g (na,Some b,t) ctx) acc c in + (if b==b' && t==t' && c==c' then cstr else mkLetIn (na, b', t', c')), acc + | App (c,al) -> + let c', acc = f ctx acc c in + let acc, al' = array_smartfoldmap (array_f ctx) acc al in + (if c==c' && array_for_all2 (==) al al' then cstr else mkApp (c', al')), + acc + | Evar (e,al) -> + let acc, al' = array_smartfoldmap (array_f ctx) acc al in + (if array_for_all2 (==) al al' then cstr else mkEvar (e, al')), acc + | Case (ci,p,c,bl) -> + let p', acc = f ctx acc p in + let c', acc = f ctx acc c in + let acc, bl' = array_smartfoldmap (array_f ctx) acc bl in + (if p==p' && c==c' && array_for_all2 (==) bl bl' then cstr else + mkCase (ci, p', c', bl')), + acc + | Fix (ln,(lna,tl,bl)) -> + let acc, tl' = array_smartfoldmap (array_f ctx) acc tl in + let ctx' = array_fold_left2 (fun l na t -> g (na,None,t) l) ctx lna tl in + let acc, bl' = array_smartfoldmap (array_f ctx') acc bl in + (if array_for_all2 (==) tl tl' && array_for_all2 (==) bl bl' + then cstr + else mkFix (ln,(lna,tl',bl'))), acc + | CoFix(ln,(lna,tl,bl)) -> + let acc, tl' = array_smartfoldmap (array_f ctx) acc tl in + let ctx' = array_fold_left2 (fun l na t -> g (na,None,t) l) ctx lna tl in + let acc,bl' = array_smartfoldmap (array_f ctx') acc bl in + (if array_for_all2 (==) tl tl' && array_for_all2 (==) bl bl' + then cstr + else mkCoFix (ln,(lna,tl',bl'))), acc + + +(* }}} *) + +(** Profiling {{{ *************************************************************) +type profiler = { + profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; + reset : unit -> unit; + print : unit -> unit } +let profile_now = ref false +let something_profiled = ref false +let profilers = ref [] +let add_profiler f = profilers := f :: !profilers;; +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssreflect profiling"; + Goptions.optkey = ["SsrProfiling"]; + Goptions.optread = (fun _ -> !profile_now); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> + Ssrmatching.profile b; + profile_now := b; + if b then List.iter (fun f -> f.reset ()) !profilers; + if not b then List.iter (fun f -> f.print ()) !profilers) } +let () = + let prof_total = + let init = ref 0.0 in { + profile = (fun f x -> assert false); + reset = (fun () -> init := Unix.gettimeofday ()); + print = (fun () -> if !something_profiled then + prerr_endline + (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" + "total" 0 (Unix.gettimeofday() -. !init) 0.0 0.0)) } in + let prof_legenda = { + profile = (fun f x -> assert false); + reset = (fun () -> ()); + print = (fun () -> if !something_profiled then begin + prerr_endline + (Printf.sprintf "!! %39s ---------- --------- --------- ---------" + (String.make 39 '-')); + prerr_endline + (Printf.sprintf "!! %-39s %10s %9s %9s %9s" + "function" "#calls" "total" "max" "average") end) } in + add_profiler prof_legenda; + add_profiler prof_total +;; + +let mk_profiler s = + let total, calls, max = ref 0.0, ref 0, ref 0.0 in + let reset () = total := 0.0; calls := 0; max := 0.0 in + let profile f x = + if not !profile_now then f x else + let before = Unix.gettimeofday () in + try + incr calls; + let res = f x in + let after = Unix.gettimeofday () in + let delta = after -. before in + total := !total +. delta; + if delta > !max then max := delta; + res + with exc -> + let after = Unix.gettimeofday () in + let delta = after -. before in + total := !total +. delta; + if delta > !max then max := delta; + raise exc in + let print () = + if !calls <> 0 then begin + something_profiled := true; + prerr_endline + (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" + s !calls !total !max (!total /. (float_of_int !calls))) end in + let prof = { profile = profile; reset = reset; print = print } in + add_profiler prof; + prof +;; +(* }}} *) + +let inVersion = Libobject.declare_object { + (Libobject.default_object "SSRASTVERSION") with + Libobject.load_function = (fun _ (_,v) -> + if v <> ssrAstVersion then error "Please recompile your .vo files"); + Libobject.classify_function = (fun v -> Libobject.Keep v); +} + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssreflect version"; + Goptions.optkey = ["SsrAstVersion"]; + Goptions.optread = (fun _ -> true); + Goptions.optdepr = false; + Goptions.optwrite = (fun _ -> + Lib.add_anonymous_leaf (inVersion ssrAstVersion)) } + +let tactic_expr = Tactic.tactic_expr +let gallina_ext = Vernac_.gallina_ext +let sprintf = Printf.sprintf +let tactic_mode = G_vernac.tactic_mode + +(** 1. Utilities *) + + +let ssroldreworder = ref true +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssreflect 1.3 compatibility flag"; + Goptions.optkey = ["SsrOldRewriteGoalsOrder"]; + Goptions.optread = (fun _ -> !ssroldreworder); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> ssroldreworder := b) } + +let ssrhaveNOtcresolution = ref false + +let inHaveTCResolution = Libobject.declare_object { + (Libobject.default_object "SSRHAVETCRESOLUTION") with + Libobject.cache_function = (fun (_,v) -> ssrhaveNOtcresolution := v); + Libobject.load_function = (fun _ (_,v) -> ssrhaveNOtcresolution := v); + Libobject.classify_function = (fun v -> Libobject.Keep v); +} + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "have type classes"; + Goptions.optkey = ["SsrHave";"NoTCResolution"]; + Goptions.optread = (fun _ -> !ssrhaveNOtcresolution); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> + Lib.add_anonymous_leaf (inHaveTCResolution b)) } + + +(** Primitive parsing to avoid syntax conflicts with basic tactics. *) + +let accept_before_syms syms strm = + match Compat.get_tok (stream_nth 1 strm) with + | Tok.KEYWORD sym when List.mem sym syms -> () + | _ -> raise Stream.Failure + +let accept_before_syms_or_any_id syms strm = + match Compat.get_tok (stream_nth 1 strm) with + | Tok.KEYWORD sym when List.mem sym syms -> () + | Tok.IDENT _ -> () + | _ -> raise Stream.Failure + +let accept_before_syms_or_ids syms ids strm = + match Compat.get_tok (stream_nth 1 strm) with + | Tok.KEYWORD sym when List.mem sym syms -> () + | Tok.IDENT id when List.mem id ids -> () + | _ -> raise Stream.Failure + +(** Pretty-printing utilities *) + +let pr_id = Ppconstr.pr_id +let pr_name = function Name id -> pr_id id | Anonymous -> str "_" +let pr_spc () = str " " +let pr_bar () = Pp.cut() ++ str "|" +let pr_list = prlist_with_sep + +let tacltop = (5,Ppextend.E) + +(** Tactic-level diagnosis *) + +let pf_pr_constr gl = pr_constr_env (pf_env gl) + +let pf_pr_glob_constr gl = pr_glob_constr_env (pf_env gl) + +(* debug *) + +let pf_msg gl = + let ppgl = pr_lconstr_env (pf_env gl) (pf_concl gl) in + msgnl (str "goal is " ++ ppgl) + +let msgtac gl = pf_msg gl; tclIDTAC gl + +(** Tactic utilities *) + +let last_goal gls = let sigma, gll = Refiner.unpackage gls in + Refiner.repackage sigma (List.nth gll (List.length gll - 1)) + +let pf_type_id gl t = id_of_string (hdchar (pf_env gl) t) + +let not_section_id id = not (is_section_variable id) + +let is_pf_var c = isVar c && not_section_id (destVar c) + +let pf_ids_of_proof_hyps gl = + let add_hyp (id, _, _) ids = if not_section_id id then id :: ids else ids in + Sign.fold_named_context add_hyp (pf_hyps gl) ~init:[] + +let pf_nf_evar gl e = Reductionops.nf_evar (project gl) e + +let pf_partial_solution ?(shelve=false) gl t evl = + let sigma, g = project gl, sig_it gl in + let evars_of_term c = + let rec evrec acc c = + match kind_of_term c with + | Evar (n, l) -> Evd.ExistentialSet.add n (Array.fold_left evrec acc l) + | _ -> fold_constr evrec acc c + in + evrec Evd.ExistentialSet.empty c in + let evars_of_named_context nc = + List.fold_right (fun (_, b, t) s -> + Option.fold_left (fun s t -> + Evd.ExistentialSet.union s (evars_of_term t)) + (Evd.ExistentialSet.union s (evars_of_term t)) b) + nc Evd.ExistentialSet.empty in + let evars_of_filtered_evar_info evi = + Evd.ExistentialSet.union (evars_of_term evi.evar_concl) + (Evd.ExistentialSet.union + (match evi.evar_body with + | Evar_empty -> Evd.ExistentialSet.empty + | Evar_defined b -> evars_of_term b) + (evars_of_named_context (evar_filtered_context evi))) in + let depends_on src tgt = + let evi = Evd.find sigma tgt in + Evd.ExistentialSet.mem src + (evars_of_filtered_evar_info (Evarutil.nf_evar_info sigma evi)) in + let occurs_in_another_statement ev = + List.exists (fun x -> + let ev', _ = destEvar x in + not (ev = ev') && depends_on ev ev') evl in + let sigma = Goal.V82.partial_solution sigma g t in + re_sig (Util.list_map_filter (fun x -> + let ev, _ = destEvar x in + if shelve && occurs_in_another_statement ev then None + else Some (Goal.build ev)) evl) sigma + +let pf_new_evar gl ty = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma, extra = Evarutil.new_evar sigma env ty in + re_sig it sigma, extra + +(* Basic tactics *) + +let convert_concl_no_check t = convert_concl_no_check t DEFAULTcast +let convert_concl t = convert_concl t DEFAULTcast +let reduct_in_concl t = reduct_in_concl (t, DEFAULTcast) +let havetac id = pose_proof (Name id) +let settac id c = letin_tac None (Name id) c None +let posetac id cl = settac id cl nowhere +let basecuttac name c = apply (mkApp (mkSsrConst name, [|c|])) + +(* we reduce head beta redexes *) +let betared env = + Closure.create_clos_infos + (Closure.RedFlags.mkflags [Closure.RedFlags.fBETA]) + env +;; +let introid name = tclTHEN (fun gl -> + let g, env = pf_concl gl, pf_env gl in + match kind_of_term g with + | App (hd, _) when isLambda hd -> + let g = Closure.whd_val (betared env) (Closure.inject g) in + convert_concl_no_check g gl + | _ -> tclIDTAC gl) + (intro_mustbe_force name) +;; + +(** Name generation {{{ *******************************************************) + +(* Since Coq now does repeated internal checks of its external lexical *) +(* rules, we now need to carve ssreflect reserved identifiers out of *) +(* out of the user namespace. We use identifiers of the form _id_ for *) +(* this purpose, e.g., we "anonymize" an identifier id as _id_, adding *) +(* an extra leading _ if this might clash with an internal identifier. *) +(* We check for ssreflect identifiers in the ident grammar rule; *) +(* when the ssreflect Module is present this is normally an error, *) +(* but we provide a compatibility flag to reduce this to a warning. *) + +let ssr_reserved_ids = ref true + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optname = "ssreflect identifiers"; + Goptions.optkey = ["SsrIdents"]; + Goptions.optdepr = false; + Goptions.optread = (fun _ -> !ssr_reserved_ids); + Goptions.optwrite = (fun b -> ssr_reserved_ids := b) + } + +let is_ssr_reserved s = + let n = String.length s in n > 2 && s.[0] = '_' && s.[n - 1] = '_' + +let internal_names = ref [] +let add_internal_name pt = internal_names := pt :: !internal_names +let is_internal_name s = List.exists (fun p -> p s) !internal_names + +let ssr_id_of_string loc s = + if is_ssr_reserved s && ssr_loaded () then begin + if !ssr_reserved_ids then + loc_error loc ("The identifier " ^ s ^ " is reserved.") + else if is_internal_name s then + warning ("Conflict between " ^ s ^ " and ssreflect internal names.") + else warning ( + "The name " ^ s ^ " fits the _xxx_ format used for anonymous variables.\n" + ^ "Scripts with explicit references to anonymous variables are fragile.") + end; id_of_string s + +let ssr_null_entry = Gram.Entry.of_parser "ssr_null" (fun _ -> ()) + +GEXTEND Gram + GLOBAL: Prim.ident; + Prim.ident: [[ s = IDENT; ssr_null_entry -> ssr_id_of_string loc s ]]; +END + +let mk_internal_id s = + let s' = sprintf "_%s_" s in + for i = 1 to String.length s do if s'.[i] = ' ' then s'.[i] <- '_' done; + add_internal_name ((=) s'); id_of_string s' + +let same_prefix s t n = + let rec loop i = i = n || s.[i] = t.[i] && loop (i + 1) in loop 0 + +let skip_digits s = + let n = String.length s in + let rec loop i = if i < n && is_digit s.[i] then loop (i + 1) else i in loop + +let mk_tagged_id t i = id_of_string (sprintf "%s%d_" t i) +let is_tagged t s = + let n = String.length s - 1 and m = String.length t in + m < n && s.[n] = '_' && same_prefix s t m && skip_digits s m = n + +let perm_tag = "_perm_Hyp_" +let _ = add_internal_name (is_tagged perm_tag) +let mk_perm_id = + let salt = ref 1 in + fun () -> salt := !salt mod 10000 + 1; mk_tagged_id perm_tag !salt + +let evar_tag = "_evar_" +let _ = add_internal_name (is_tagged evar_tag) +let mk_evar_name n = Name (mk_tagged_id evar_tag n) +let nb_evar_deps = function + | Name id -> + let s = string_of_id id in + if not (is_tagged evar_tag s) then 0 else + let m = String.length evar_tag in + (try int_of_string (String.sub s m (String.length s - 1 - m)) with _ -> 0) + | _ -> 0 + +let discharged_tag = "_discharged_" +let mk_discharged_id id = + id_of_string (sprintf "%s%s_" discharged_tag (string_of_id id)) +let has_discharged_tag s = + let m = String.length discharged_tag and n = String.length s - 1 in + m < n && s.[n] = '_' && same_prefix s discharged_tag m +let _ = add_internal_name has_discharged_tag +let is_discharged_id id = has_discharged_tag (string_of_id id) + +let wildcard_tag = "_the_" +let wildcard_post = "_wildcard_" +let mk_wildcard_id i = + id_of_string (sprintf "%s%s%s" wildcard_tag (ordinal i) wildcard_post) +let has_wildcard_tag s = + let n = String.length s in let m = String.length wildcard_tag in + let m' = String.length wildcard_post in + n < m + m' + 2 && same_prefix s wildcard_tag m && + String.sub s (n - m') m' = wildcard_post && + skip_digits s m = n - m' - 2 +let _ = add_internal_name has_wildcard_tag + +let max_suffix m (t, j0 as tj0) id = + let s = string_of_id id in let n = String.length s - 1 in + let dn = String.length t - 1 - n in let i0 = j0 - dn in + if not (i0 >= m && s.[n] = '_' && same_prefix s t m) then tj0 else + let rec loop i = + if i < i0 && s.[i] = '0' then loop (i + 1) else + if (if i < i0 then skip_digits s i = n else le_s_t i) then s, i else tj0 + and le_s_t i = + let ds = s.[i] and dt = t.[i + dn] in + if ds = dt then i = n || le_s_t (i + 1) else + dt < ds && skip_digits s i = n in + loop m + +let mk_anon_id t gl = + let m, si0, id0 = + let s = ref (sprintf "_%s_" t) in + if is_internal_name !s then s := "_" ^ !s; + let n = String.length !s - 1 in + let rec loop i j = + let d = !s.[i] in if not (is_digit d) then i + 1, j else + loop (i - 1) (if d = '0' then j else i) in + let m, j = loop (n - 1) n in m, (!s, j), id_of_string !s in + let gl_ids = pf_ids_of_hyps gl in + if not (List.mem id0 gl_ids) then id0 else + let s, i = List.fold_left (max_suffix m) si0 gl_ids in + let n = String.length s - 1 in + let rec loop i = + if s.[i] = '9' then (s.[i] <- '0'; loop (i - 1)) else + if i < m then (s.[n] <- '0'; s.[m] <- '1'; s ^ "_") else + (s.[i] <- Char.chr (Char.code s.[i] + 1); s) in + id_of_string (loop (n - 1)) + +(* We must not anonymize context names discharged by the "in" tactical. *) + +let ssr_anon_hyp = "Hyp" + +let anontac (x, _, _) gl = + let id = match x with + | Name id -> + if is_discharged_id id then id else mk_anon_id (string_of_id id) gl + | _ -> mk_anon_id ssr_anon_hyp gl in + introid id gl + +let rec constr_name c = match kind_of_term c with + | Var id -> Name id + | Cast (c', _, _) -> constr_name c' + | Const cn -> Name (id_of_label (con_label cn)) + | App (c', _) -> constr_name c' + | _ -> Anonymous + + +(* }}} *) + +(** Open term to lambda-term coercion {{{ ************************************) + +(* This operation takes a goal gl and an open term (sigma, t), and *) +(* returns a term t' where all the new evars in sigma are abstracted *) +(* with the mkAbs argument, i.e., for mkAbs = mkLambda then there is *) +(* some duplicate-free array args of evars of sigma such that the *) +(* term mkApp (t', args) is convertible to t. *) +(* This makes a useful shorthand for local definitions in proofs, *) +(* i.e., pose succ := _ + 1 means pose succ := fun n : nat => n + 1, *) +(* and, in context of the the 4CT library, pose mid := maps id means *) +(* pose mid := fun d : detaSet => @maps d d (@id (datum d)) *) +(* Note that this facility does not extend to set, which tries *) +(* instead to fill holes by matching a goal subterm. *) +(* The argument to "have" et al. uses product abstraction, e.g. *) +(* have Hmid: forall s, (maps id s) = s. *) +(* stands for *) +(* have Hmid: forall (d : dataSet) (s : seq d), (maps id s) = s. *) +(* We also use this feature for rewrite rules, so that, e.g., *) +(* rewrite: (plus_assoc _ 3). *) +(* will execute as *) +(* rewrite (fun n => plus_assoc n 3) *) +(* i.e., it will rewrite some subterm .. + (3 + ..) to .. + 3 + ... *) +(* The convention is also used for the argument of the congr tactic, *) +(* e.g., congr (x + _ * 1). *) + +(* Replace new evars with lambda variables, retaining local dependencies *) +(* but stripping global ones. We use the variable names to encode the *) +(* the number of dependencies, so that the transformation is reversible. *) + +let pf_abs_evars gl (sigma, c0) = + let sigma0 = project gl in + let nenv = env_size (pf_env gl) in + let abs_evar n k = + let evi = Evd.find sigma k in + let dc = list_firstn n (evar_filtered_context evi) in + let abs_dc c = function + | x, Some b, t -> mkNamedLetIn x b t (mkArrow t c) + | x, None, t -> mkNamedProd x t c in + let t = Sign.fold_named_context_reverse abs_dc ~init:evi.evar_concl dc in + Evarutil.nf_evar sigma t in + let rec put evlist c = match kind_of_term c with + | Evar (k, a) -> + if List.mem_assoc k evlist || Evd.mem sigma0 k then evlist else + let n = max 0 (Array.length a - nenv) in + let t = abs_evar n k in (k, (n, t)) :: put evlist t + | _ -> fold_constr put evlist c in + let evlist = put [] c0 in + if evlist = [] then 0, c0,[] else + let rec lookup k i = function + | [] -> 0, 0 + | (k', (n, _)) :: evl -> if k = k' then i, n else lookup k (i + 1) evl in + let rec get i c = match kind_of_term c with + | Evar (ev, a) -> + let j, n = lookup ev i evlist in + if j = 0 then map_constr (get i) c else if n = 0 then mkRel j else + mkApp (mkRel j, Array.init n (fun k -> get i a.(n - 1 - k))) + | _ -> map_constr_with_binders ((+) 1) get i c in + let rec loop c i = function + | (_, (n, t)) :: evl -> + loop (mkLambda (mk_evar_name n, get (i - 1) t, c)) (i - 1) evl + | [] -> c in + List.length evlist, loop (get 1 c0) 1 evlist, List.map fst evlist + + + +(* As before but if (?i : T(?j)) and (?j : P : Prop), then the lambda for i + * looks like (fun evar_i : (forall pi : P. T(pi))) thanks to "loopP" and all + * occurrences of evar_i are replaced by (evar_i evar_j) thanks to "app". + * + * If P can be solved by ssrautoprop (that defaults to trivial), then + * the corresponding lambda looks like (fun evar_i : T(c)) where c is + * the solution found by ssrautoprop. + *) +let ssrautoprop_tac = ref (fun gl -> assert false) + +(* Thanks to Arnaud Spiwack for this snippet *) +let call_on_evar tac e s = + let { it = gs ; sigma = s } = tac { it = Goal.build e ; sigma = s } in gs, s + +let pf_abs_evars_pirrel gl (sigma, c0) = + pp(lazy(str"==PF_ABS_EVARS_PIRREL==")); + pp(lazy(str"c0= " ++ pr_constr c0)); + let sigma0 = project gl in + let nenv = env_size (pf_env gl) in + let abs_evar n k = + let evi = Evd.find sigma k in + let dc = list_firstn n (evar_filtered_context evi) in + let abs_dc c = function + | x, Some b, t -> mkNamedLetIn x b t (mkArrow t c) + | x, None, t -> mkNamedProd x t c in + let t = Sign.fold_named_context_reverse abs_dc ~init:evi.evar_concl dc in + Evarutil.nf_evar sigma t in + let rec put evlist c = match kind_of_term c with + | Evar (k, a) -> + if List.mem_assoc k evlist || Evd.mem sigma0 k then evlist else + let n = max 0 (Array.length a - nenv) in + let k_ty = + Retyping.get_sort_family_of + (pf_env gl) sigma (Evd.evar_concl (Evd.find sigma k)) in + let is_prop = k_ty = InProp in + let t = abs_evar n k in (k, (n, t, is_prop)) :: put evlist t + | _ -> fold_constr put evlist c in + let evlist = put [] c0 in + if evlist = [] then 0, c0 else + let pr_constr t = pr_constr (Reductionops.nf_beta (project gl) t) in + let evplist = + let depev = List.fold_left (fun evs (_,(_,t,_)) -> + Intset.union evs (Evarutil.evars_of_term t)) Intset.empty evlist in + List.filter (fun i,(_,_,b) -> b && Intset.mem i depev) evlist in + let evlist, evplist, sigma = + if evplist = [] then evlist, [], sigma else + List.fold_left (fun (ev, evp, sigma) (i, (_,t,_) as p) -> + try + let ng, sigma = call_on_evar !ssrautoprop_tac i sigma in + if (ng <> []) then errorstrm (str "Should we tell the user?"); + List.filter (fun (j,_) -> j <> i) ev, evp, sigma + with _ -> ev, p::evp, sigma) (evlist, [], sigma) (List.rev evplist) in + let c0 = Evarutil.nf_evar sigma c0 in + let evlist = + List.map (fun (x,(y,t,z)) -> x,(y,Evarutil.nf_evar sigma t,z)) evlist in + let evplist = + List.map (fun (x,(y,t,z)) -> x,(y,Evarutil.nf_evar sigma t,z)) evplist in + pp(lazy(str"c0= " ++ pr_constr c0)); + let rec lookup k i = function + | [] -> 0, 0 + | (k', (n,_,_)) :: evl -> if k = k' then i,n else lookup k (i + 1) evl in + let rec get evlist i c = match kind_of_term c with + | Evar (ev, a) -> + let j, n = lookup ev i evlist in + if j = 0 then map_constr (get evlist i) c else if n = 0 then mkRel j else + mkApp (mkRel j, Array.init n (fun k -> get evlist i a.(n - 1 - k))) + | _ -> map_constr_with_binders ((+) 1) (get evlist) i c in + let rec app extra_args i c = match decompose_app c with + | hd, args when isRel hd && destRel hd = i -> + let j = destRel hd in + mkApp (mkRel j, Array.of_list (List.map (lift (i-1)) extra_args @ args)) + | _ -> map_constr_with_binders ((+) 1) (app extra_args) i c in + let rec loopP evlist c i = function + | (_, (n, t, _)) :: evl -> + let t = get evlist (i - 1) t in + let n = Name (id_of_string (ssr_anon_hyp ^ string_of_int n)) in + loopP evlist (mkProd (n, t, c)) (i - 1) evl + | [] -> c in + let rec loop c i = function + | (_, (n, t, _)) :: evl -> + let evs = Evarutil.evars_of_term t in + let t_evplist = List.filter (fun (k,_) -> Intset.mem k evs) evplist in + let t = loopP t_evplist (get t_evplist 1 t) 1 t_evplist in + let t = get evlist (i - 1) t in + let extra_args = + List.map (fun (k,_) -> mkRel (fst (lookup k i evlist))) + (List.rev t_evplist) in + let c = if extra_args = [] then c else app extra_args 1 c in + loop (mkLambda (mk_evar_name n, t, c)) (i - 1) evl + | [] -> c in + let res = loop (get evlist 1 c0) 1 evlist in + pp(lazy(str"res= " ++ pr_constr res)); + List.length evlist, res + +(* Strip all non-essential dependencies from an abstracted term, generating *) +(* standard names for the abstracted holes. *) + +let pf_abs_cterm gl n c0 = + if n <= 0 then c0 else + let noargs = [|0|] in + let eva = Array.make n noargs in + let rec strip i c = match kind_of_term c with + | App (f, a) when isRel f -> + let j = i - destRel f in + if j >= n || eva.(j) = noargs then mkApp (f, Array.map (strip i) a) else + let dp = eva.(j) in + let nd = Array.length dp - 1 in + let mkarg k = strip i a.(if k < nd then dp.(k + 1) - j else k + dp.(0)) in + mkApp (f, Array.init (Array.length a - dp.(0)) mkarg) + | _ -> map_constr_with_binders ((+) 1) strip i c in + let rec strip_ndeps j i c = match kind_of_term c with + | Prod (x, t, c1) when i < j -> + let dl, c2 = strip_ndeps j (i + 1) c1 in + if noccurn 1 c2 then dl, lift (-1) c2 else + i :: dl, mkProd (x, strip i t, c2) + | LetIn (x, b, t, c1) when i < j -> + let _, _, c1' = destProd c1 in + let dl, c2 = strip_ndeps j (i + 1) c1' in + if noccurn 1 c2 then dl, lift (-1) c2 else + i :: dl, mkLetIn (x, strip i b, strip i t, c2) + | _ -> [], strip i c in + let rec strip_evars i c = match kind_of_term c with + | Lambda (x, t1, c1) when i < n -> + let na = nb_evar_deps x in + let dl, t2 = strip_ndeps (i + na) i t1 in + let na' = List.length dl in + eva.(i) <- Array.of_list (na - na' :: dl); + let x' = + if na' = 0 then Name (pf_type_id gl t2) else mk_evar_name na' in + mkLambda (x', t2, strip_evars (i + 1) c1) +(* if noccurn 1 c2 then lift (-1) c2 else + mkLambda (Name (pf_type_id gl t2), t2, c2) *) + | _ -> strip i c in + strip_evars 0 c0 + +(* Undo the evar abstractions. Also works for non-evar variables. *) + +let pf_unabs_evars gl ise n c0 = + if n = 0 then c0 else + let evv = Array.make n mkProp in + let nev = ref 0 in + let env0 = pf_env gl in + let nenv0 = env_size env0 in + let rec unabs i c = match kind_of_term c with + | Rel j when i - j < !nev -> evv.(i - j) + | App (f, a0) when isRel f -> + let a = Array.map (unabs i) a0 in + let j = i - destRel f in + if j >= !nev then mkApp (f, a) else + let ev, eva = destEvar evv.(j) in + let nd = Array.length eva - nenv0 in + if nd = 0 then mkApp (evv.(j), a) else + let evarg k = if k < nd then a.(nd - 1 - k) else eva.(k) in + let c' = mkEvar (ev, Array.init (nd + nenv0) evarg) in + let na = Array.length a - nd in + if na = 0 then c' else mkApp (c', Array.sub a nd na) + | _ -> map_constr_with_binders ((+) 1) unabs i c in + let push_rel = Environ.push_rel in + let rec mk_evar j env i c = match kind_of_term c with + | Prod (x, t, c1) when i < j -> + mk_evar j (push_rel (x, None, unabs i t) env) (i + 1) c1 + | LetIn (x, b, t, c1) when i < j -> + let _, _, c2 = destProd c1 in + mk_evar j (push_rel (x, Some (unabs i b), unabs i t) env) (i + 1) c2 + | _ -> Evarutil.e_new_evar ise env (unabs i c) in + let rec unabs_evars c = + if !nev = n then unabs n c else match kind_of_term c with + | Lambda (x, t, c1) when !nev < n -> + let i = !nev in + evv.(i) <- mk_evar (i + nb_evar_deps x) env0 i t; + incr nev; unabs_evars c1 + | _ -> unabs !nev c in + unabs_evars c0 + +(* }}} *) + +(** Tactical extensions. {{{ **************************************************) + +(* The TACTIC EXTEND facility can't be used for defining new user *) +(* tacticals, because: *) +(* - the concrete syntax must start with a fixed string *) +(* - the lexical Ltac environment is NOT used to interpret tactic *) +(* arguments *) +(* The second limitation means that the extended tacticals will *) +(* exhibit run-time scope errors if used inside Ltac functions or *) +(* pattern-matching constructs. *) +(* We use the following workaround: *) +(* - We use the (unparsable) "Qed" token for tacticals that *) +(* don't start with a token, then redefine the grammar and *) +(* printer using GEXTEND and set_pr_ssrtac, respectively. *) +(* - We use a global stack and side effects to pass the lexical *) +(* Ltac evaluation context to the extended tactical. The context *) +(* is grabbed by interpreting an (empty) ltacctx argument, *) +(* which should appear last in the grammar rules; the *) +(* get_ltacctx function pops the stack and returns the context. *) +(* For additional safety, the push returns an integer key that *) +(* is checked by the pop; since arguments are interpreted *) +(* left-to-right, this checks that only one tactic argument *) +(* pushes a context. *) +(* - To avoid a spurrious option type, we don't push the context *) +(* for a null tag. *) + +type ssrargfmt = ArgSsr of string | ArgCoq of argument_type | ArgSep of string + +let set_pr_ssrtac name prec afmt = + let fmt = List.map (function ArgSep s -> Some s | _ -> None) afmt in + let rec mk_akey = function + | ArgSsr s :: afmt' -> ExtraArgType ("ssr" ^ s) :: mk_akey afmt' + | ArgCoq a :: afmt' -> a :: mk_akey afmt' + | ArgSep _ :: afmt' -> mk_akey afmt' + | [] -> [] in + let tacname = "ssr" ^ name in + Pptactic.declare_extra_tactic_pprule (tacname, mk_akey afmt, (prec, fmt)) + +let ssrtac_atom loc name args = TacExtend (loc, "ssr" ^ name, args) +let ssrtac_expr loc name args = TacAtom (loc, ssrtac_atom loc name args) + +let ssrevaltac ist gtac = + interp_tac_gen ist.lfun [] ist.debug (globTacticIn (fun _ -> gtac)) + +(* fun gl -> let lfun = [tacarg_id, val_interp ist gl gtac] in + interp_tac_gen lfun [] ist.debug tacarg_expr gl *) + +(** Generic argument-based globbing/typing utilities *) + + +let interp_wit globwit wit ist gl x = + let globarg = in_gen globwit x in + let sigma, arg = interp_genarg ist gl globarg in + sigma, out_gen wit arg + +let interp_intro_pattern = interp_wit globwit_intro_pattern wit_intro_pattern + +let interp_constr = interp_wit globwit_constr wit_constr + +let interp_open_constr ist gl gc = + interp_wit globwit_open_constr wit_open_constr ist gl ((), gc) + +let interp_refine ist gl rc = + let roc = (), (rc, None) in + interp_wit globwit_casted_open_constr wit_casted_open_constr ist gl roc + +let pf_match = pf_apply (fun e s c t -> understand_tcc s e ~expected_type:t c) + +(* Estimate a bound on the number of arguments of a raw constr. *) +(* This is not perfect, because the unifier may fail to *) +(* typecheck the partial application, so we use a minimum of 5. *) +(* Also, we don't handle delayed or iterated coercions to *) +(* FUNCLASS, which is probably just as well since these can *) +(* lead to infinite arities. *) + +let splay_open_constr gl (sigma, c) = + let env = pf_env gl in let t = Retyping.get_type_of env sigma c in + Reductionops.splay_prod env sigma t + +let nbargs_open_constr gl oc = + let pl, _ = splay_open_constr gl oc in List.length pl + +let interp_nbargs ist gl rc = + try + let rc6 = mkRApp rc (mkRHoles 6) in + let sigma, t = interp_open_constr ist gl (rc6, None) in + let si = sig_it gl in let gl = re_sig si sigma in + 6 + nbargs_open_constr gl t + with _ -> 5 + +let pf_nbargs gl c = nbargs_open_constr gl (project gl, c) + +let isAppInd gl c = + try ignore (pf_reduce_to_atomic_ind gl c); true with _ -> false + +let interp_view_nbimps ist gl rc = + try + let sigma, t = interp_open_constr ist gl (rc, None) in + let si = sig_it gl in let gl = re_sig si sigma in + let pl, c = splay_open_constr gl t in + if isAppInd gl c then List.length pl else ~-(List.length pl) + with _ -> 0 + +(* }}} *) + +(** Vernacular commands: Prenex Implicits and Search {{{ **********************) + +(* This should really be implemented as an extension to the implicit *) +(* arguments feature, but unfortuately that API is sealed. The current *) +(* workaround uses a combination of notations that works reasonably, *) +(* with the following caveats: *) +(* - The pretty-printing always elides prenex implicits, even when *) +(* they are obviously needed. *) +(* - Prenex Implicits are NEVER exported from a module, because this *) +(* would lead to faulty pretty-printing and scoping errors. *) +(* - The command "Import Prenex Implicits" can be used to reassert *) +(* Prenex Implicits for all the visible constants that had been *) +(* declared as Prenex Implicits. *) + +let declare_one_prenex_implicit locality f = + let fref = + try Smartlocate.global_with_alias f + with _ -> errorstrm (pr_reference f ++ str " is not declared") in + let rec loop = function + | a :: args' when Impargs.is_status_implicit a -> + (ExplByName (Impargs.name_of_implicit a), (true, true, true)) :: loop args' + | args' when List.exists Impargs.is_status_implicit args' -> + errorstrm (str "Expected prenex implicits for " ++ pr_reference f) + | _ -> [] in + let impls = + match Impargs.implicits_of_global fref with + | [cond,impls] -> impls + | [] -> errorstrm (str "Expected some implicits for " ++ pr_reference f) + | _ -> errorstrm (str "Multiple implicits not supported") in + match loop impls with + | [] -> + errorstrm (str "Expected some implicits for " ++ pr_reference f) + | impls -> + Impargs.declare_manual_implicits locality fref ~enriching:false [impls] + +VERNAC COMMAND EXTEND Ssrpreneximplicits + | [ "Prenex" "Implicits" ne_global_list(fl) ] + -> [ let locality = Vernacexpr.use_section_locality () in + List.iter (declare_one_prenex_implicit locality) fl ] +END + +(* Vernac grammar visibility patch *) + +GEXTEND Gram + GLOBAL: gallina_ext; + gallina_ext: + [ [ IDENT "Import"; IDENT "Prenex"; IDENT "Implicits" -> + Vernacexpr.VernacUnsetOption (None, ["Printing"; "Implicit"; "Defensive"]) + ] ] + ; +END + +(* Remove the silly restriction that forces coercion classes to be precise *) +(* aliases, e.g., allowing notations that specify some class parameters. *) + +let qualify_ref clref = + let loc, qid = qualid_of_reference clref in + try match Nametab.locate_extended qid with + | TrueGlobal _ -> clref + | SynDef kn -> + let rec head_of = function + | ARef gref -> + Qualid (loc, Nametab.shortest_qualid_of_global Idset.empty gref) + | AApp (rc, _) -> head_of rc + | ACast (rc, _) -> head_of rc + | ALetIn (_, _, rc) -> head_of rc + | rc -> + user_err_loc (loc, "qualify_ref", + str "The definition of " ++ Ppconstr.pr_qualid qid + ++ str " does not have a head constant") in + head_of (snd (Syntax_def.search_syntactic_definition kn)) + with _ -> clref + +let class_rawexpr = G_vernac.class_rawexpr in +GEXTEND Gram + GLOBAL: class_rawexpr; + ssrqref: [[ gref = global -> qualify_ref gref ]]; + class_rawexpr: [[ class_ref = ssrqref -> Vernacexpr.RefClass (Genarg.AN class_ref) ]]; +END + +(** Extend Search to subsume SearchAbout, also adding hidden Type coercions. *) + +(* Main prefilter *) + +let pr_search_item = function + | Search.GlobSearchString s -> str s + | Search.GlobSearchSubPattern p -> pr_constr_pattern p + +let wit_ssr_searchitem, globwit_ssr_searchitem, rawwit_ssr_searchitem = + add_genarg "ssr_searchitem" pr_search_item + +let interp_search_notation loc s opt_scope = + try + let interp = Notation.interp_notation_as_global_reference loc in + let ref = interp (fun _ -> true) s opt_scope in + Search.GlobSearchSubPattern (Pattern.PRef ref) + with _ -> + let diagnosis = + try + let ntns = Notation.locate_notation pr_glob_constr s opt_scope in + let ambig = "This string refers to a complex or ambiguous notation." in + str ambig ++ str "\nTry searching with one of\n" ++ ntns + with _ -> str "This string is not part of an identifier or notation." in + user_err_loc (loc, "interp_search_notation", diagnosis) + +let pr_ssr_search_item _ _ _ = pr_search_item + +(* Workaround the notation API that can only print notations *) + +let is_ident s = try Lexer.check_ident s; true with _ -> false + +let is_ident_part s = is_ident ("H" ^ s) + +let interp_search_notation loc tag okey = + let err msg = user_err_loc (loc, "interp_search_notation", msg) in + let mk_pntn s for_key = + let n = String.length s in + let s' = String.make (n + 2) ' ' in + let rec loop i i' = + if i >= n then s', i' - 2 else if s.[i] = ' ' then loop (i + 1) i' else + let j = try String.index_from s (i + 1) ' ' with _ -> n in + let m = j - i in + if s.[i] = '\'' && i < j - 2 && s.[j - 1] = '\'' then + (String.blit s (i + 1) s' i' (m - 2); loop (j + 1) (i' + m - 1)) + else if for_key && is_ident (String.sub s i m) then + (s'.[i'] <- '_'; loop (j + 1) (i' + 2)) + else (String.blit s i s' i' m; loop (j + 1) (i' + m + 1)) in + loop 0 1 in + let trim_ntn (pntn, m) = String.sub pntn 1 (max 0 m) in + let pr_ntn ntn = str "(" ++ str ntn ++ str ")" in + let pr_and_list pr = function + | [x] -> pr x + | x :: lx -> pr_list pr_comma pr lx ++ pr_comma () ++ str "and " ++ pr x + | [] -> mt () in + let pr_sc sc = str (if sc = "" then "independently" else sc) in + let pr_scs = function + | [""] -> pr_sc "" + | scs -> str "in " ++ pr_and_list pr_sc scs in + let generator, pr_tag_sc = + let ign _ = mt () in match okey with + | Some key -> + let sc = Notation.find_delimiters_scope loc key in + let pr_sc s_in = str s_in ++ spc() ++ str sc ++ pr_comma() in + Notation.pr_scope ign sc, pr_sc + | None -> Notation.pr_scopes ign, ign in + let qtag s_in = pr_tag_sc s_in ++ qstring tag ++ spc()in + let ptag, ttag = + let ptag, m = mk_pntn tag false in + if m <= 0 then err (str "empty notation fragment"); + ptag, trim_ntn (ptag, m) in + let last = ref "" and last_sc = ref "" in + let scs = ref [] and ntns = ref [] in + let push_sc sc = match !scs with + | "" :: scs' -> scs := "" :: sc :: scs' + | scs' -> scs := sc :: scs' in + let get s _ _ = match !last with + | "Scope " -> last_sc := s; last := "" + | "Lonely notation" -> last_sc := ""; last := "" + | "\"" -> + let pntn, m = mk_pntn s true in + if string_string_contains pntn ptag then begin + let ntn = trim_ntn (pntn, m) in + match !ntns with + | [] -> ntns := [ntn]; scs := [!last_sc] + | ntn' :: _ when ntn' = ntn -> push_sc !last_sc + | _ when ntn = ttag -> ntns := ntn :: !ntns; scs := [!last_sc] + | _ :: ntns' when List.mem ntn ntns' -> () + | ntn' :: ntns' -> ntns := ntn' :: ntn :: ntns' + end; + last := "" + | _ -> last := s in + pp_with (Format.make_formatter get (fun _ -> ())) generator; + let ntn = match !ntns with + | [] -> + err (hov 0 (qtag "in" ++ str "does not occur in any notation")) + | ntn :: ntns' when ntn = ttag -> + if ntns' <> [] then begin + let pr_ntns' = pr_and_list pr_ntn ntns' in + msg_warning (hov 4 (qtag "In" ++ str "also occurs in " ++ pr_ntns')) + end; ntn + | [ntn] -> + msgnl (hov 4 (qtag "In" ++ str "is part of notation " ++ pr_ntn ntn)); ntn + | ntns' -> + let e = str "occurs in" ++ spc() ++ pr_and_list pr_ntn ntns' in + err (hov 4 (str "ambiguous: " ++ qtag "in" ++ e)) in + let (nvars, body), ((_, pat), osc) = match !scs with + | [sc] -> Notation.interp_notation loc ntn (None, [sc]) + | scs' -> + try Notation.interp_notation loc ntn (None, []) with _ -> + let e = pr_ntn ntn ++ spc() ++ str "is defined " ++ pr_scs scs' in + err (hov 4 (str "ambiguous: " ++ pr_tag_sc "in" ++ e)) in + let sc = Option.default "" osc in + let _ = + let m_sc = + if osc <> None then str "In " ++ str sc ++ pr_comma() else mt() in + let ntn_pat = trim_ntn (mk_pntn pat false) in + let rbody = glob_constr_of_aconstr loc body in + let m_body = hov 0 (Constrextern.without_symbols prl_glob_constr rbody) in + let m = m_sc ++ pr_ntn ntn_pat ++ spc () ++ str "denotes " ++ m_body in + msgnl (hov 0 m) in + if List.length !scs > 1 then + let scs' = list_remove sc !scs in + let w = pr_ntn ntn ++ str " is also defined " ++ pr_scs scs' in + msg_warning (hov 4 w) + else if string_string_contains ntn " .. " then + err (pr_ntn ntn ++ str " is an n-ary notation"); + let nvars = List.filter (fun (_,(_,typ)) -> typ = NtnTypeConstr) nvars in + let rec sub () = function + | AVar x when List.mem_assoc x nvars -> GPatVar (loc, (false, x)) + | c -> + glob_constr_of_aconstr_with_binders loc (fun _ x -> (), x) sub () c in + let _, npat = Pattern.pattern_of_glob_constr (sub () body) in + Search.GlobSearchSubPattern npat + +ARGUMENT EXTEND ssr_search_item TYPED AS ssr_searchitem + PRINTED BY pr_ssr_search_item + | [ string(s) ] -> + [ if is_ident_part s then Search.GlobSearchString s else + interp_search_notation loc s None ] + | [ string(s) "%" preident(key) ] -> + [ interp_search_notation loc s (Some key) ] + | [ constr_pattern(p) ] -> + [ try + let intern = Constrintern.intern_constr_pattern Evd.empty in + Search.GlobSearchSubPattern (snd (intern (Global.env()) p)) + with e -> raise (Cerrors.process_vernac_interp_error e) + ] +END + +let pr_ssr_search_arg _ _ _ = + let pr_item (b, p) = str (if b then "-" else "") ++ pr_search_item p in + pr_list spc pr_item + +ARGUMENT EXTEND ssr_search_arg TYPED AS (bool * ssr_searchitem) list + PRINTED BY pr_ssr_search_arg + | [ "-" ssr_search_item(p) ssr_search_arg(a) ] -> [ (false, p) :: a ] + | [ ssr_search_item(p) ssr_search_arg(a) ] -> [ (true, p) :: a ] + | [ ] -> [ [] ] +END + +(* Main type conclusion pattern filter *) + +let rec splay_search_pattern na = function + | Pattern.PApp (fp, args) -> splay_search_pattern (na + Array.length args) fp + | Pattern.PLetIn (_, _, bp) -> splay_search_pattern na bp + | Pattern.PRef hr -> hr, na + | _ -> error "no head constant in head search pattern" + +let coerce_search_pattern_to_sort hpat = + let env = Global.env () and sigma = Evd.empty in + let mkPApp fp n_imps args = + let args' = Array.append (Array.make n_imps (Pattern.PMeta None)) args in + Pattern.PApp (fp, args') in + let hr, na = splay_search_pattern 0 hpat in + let dc, ht = Reductionops.splay_prod env sigma (Global.type_of_global hr) in + let np = List.length dc in + if np < na then error "too many arguments in head search pattern" else + let hpat' = if np = na then hpat else mkPApp hpat (np - na) [||] in + let warn () = + msg_warning (str "Listing only lemmas with conclusion matching " ++ + pr_constr_pattern hpat') in + if isSort ht then begin warn (); true, hpat' end else + let filter_head, coe_path = + try + let _, cp = + Classops.lookup_path_to_sort_from (push_rels_assum dc env) sigma ht in + warn (); + true, cp + with _ -> false, [] in + let coerce hp coe_index = + let coe = Classops.get_coercion_value coe_index in + try + let coe_ref = reference_of_constr coe in + let n_imps = Option.get (Classops.hide_coercion coe_ref) in + mkPApp (Pattern.PRef coe_ref) n_imps [|hp|] + with _ -> + errorstrm (str "need explicit coercion " ++ pr_constr coe ++ spc () + ++ str "to interpret head search pattern as type") in + filter_head, List.fold_left coerce hpat' coe_path + +let rec interp_head_pat hpat = + let filter_head, p = coerce_search_pattern_to_sort hpat in + let rec loop c = match kind_of_term c with + | Cast (c', _, _) -> loop c' + | Prod (_, _, c') -> loop c' + | LetIn (_, _, _, c') -> loop c' + | _ -> Matching.is_matching p c in + filter_head, loop + +let all_true _ = true + +let interp_search_arg a = + let hpat, a1 = match a with + | (_, Search.GlobSearchSubPattern (Pattern.PMeta _)) :: a' -> all_true, a' + | (true, Search.GlobSearchSubPattern p) :: a' -> + let filter_head, p = interp_head_pat p in + if filter_head then p, a' else all_true, a + | _ -> all_true, a in + let is_string = + function (_, Search.GlobSearchString _) -> true | _ -> false in + let a2, a3 = List.partition is_string a1 in + hpat, a2 @ a3 + +(* Module path postfilter *) + +let pr_modloc (b, m) = if b then str "-" ++ pr_reference m else pr_reference m + +let wit_ssrmodloc, globwit_ssrmodloc, rawwit_ssrmodloc = + add_genarg "ssrmodloc" pr_modloc + +let pr_ssr_modlocs _ _ _ ml = + if ml = [] then str "" else spc () ++ str "in " ++ pr_list spc pr_modloc ml + +ARGUMENT EXTEND ssr_modlocs TYPED AS ssrmodloc list PRINTED BY pr_ssr_modlocs + | [ ] -> [ [] ] +END + +GEXTEND Gram + GLOBAL: ssr_modlocs; + modloc: [[ "-"; m = global -> true, m | m = global -> false, m]]; + ssr_modlocs: [[ "in"; ml = LIST1 modloc -> ml ]]; +END + +let interp_modloc mr = + let interp_mod (_, mr) = + let (loc, qid) = qualid_of_reference mr in + try Nametab.full_name_module qid with Not_found -> + user_err_loc (loc, "interp_modloc", str "No Module " ++ pr_qualid qid) in + let mr_out, mr_in = List.partition fst mr in + let interp_bmod b rmods = + if rmods = [] then fun _ _ _ -> true else + Search.filter_by_module_from_list (List.map interp_mod rmods, b) in + let is_in = interp_bmod false mr_in and is_out = interp_bmod true mr_out in + fun gr env -> is_in gr env () && is_out gr env () + +(* The unified, extended vernacular "Search" command *) + +let ssrdisplaysearch gr env t = + let pr_res = pr_global gr ++ spc () ++ str " " ++ pr_lconstr_env env t in + msg (hov 2 pr_res ++ fnl ()) + +VERNAC COMMAND EXTEND SsrSearchPattern +| [ "Search" ssr_search_arg(a) ssr_modlocs(mr) ] -> + [ let hpat, a' = interp_search_arg a in + let in_mod = interp_modloc mr in + let post_filter gr env typ = in_mod gr env && hpat typ in + Search.raw_search_about post_filter ssrdisplaysearch a' ] +END + +(* }}} *) + +(** Alternative notations for "match" and anonymous arguments. {{{ ************) + +(* Syntax: *) +(* if is then ... else ... *) +(* if is [in ..] return ... then ... else ... *) +(* let: := in ... *) +(* let: [in ...] := return ... in ... *) +(* The scope of a top-level 'as' in the pattern extends over the *) +(* 'return' type (dependent if/let). *) +(* Note that the optional "in ..." appears next to the *) +(* rather than the in then "let:" syntax. The alternative *) +(* would lead to ambiguities in, e.g., *) +(* let: p1 := (*v---INNER LET:---v *) *) +(* let: p2 := let: p3 := e3 in k return t in k2 in k1 return t' *) +(* in b (*^--ALTERNATIVE INNER LET--------^ *) *) + +(* Caveat : There is no pretty-printing support, since this would *) +(* require a modification to the Coq kernel (adding a new match *) +(* display style -- why aren't these strings?); also, the v8.1 *) +(* pretty-printer only allows extension hooks for printing *) +(* integer or string literals. *) +(* Also note that in the v8 grammar "is" needs to be a keyword; *) +(* as this can't be done from an ML extension file, the new *) +(* syntax will only work when ssreflect.v is imported. *) + + +let no_ct = None, None and no_rt = None in +let aliasvar = function + | [_, [CPatAlias (loc, _, id)]] -> Some (loc,Name id) + | _ -> None in +let mk_cnotype mp = aliasvar mp, None in +let mk_ctype mp t = aliasvar mp, Some t in +let mk_rtype t = Some t in +let mk_dthen loc (mp, ct, rt) c = (loc, mp, c), ct, rt in +let mk_let loc rt ct mp c1 = + CCases (loc, LetPatternStyle, rt, ct, [loc, mp, c1]) in +GEXTEND Gram + GLOBAL: binder_constr; + ssr_rtype: [[ "return"; t = operconstr LEVEL "100" -> mk_rtype t ]]; + ssr_mpat: [[ p = pattern -> [loc, [p]] ]]; + ssr_dpat: [ + [ mp = ssr_mpat; "in"; t = lconstr; rt = ssr_rtype -> mp, mk_ctype mp t, rt + | mp = ssr_mpat; rt = ssr_rtype -> mp, mk_cnotype mp, rt + | mp = ssr_mpat -> mp, no_ct, no_rt + ] ]; + ssr_dthen: [[ dp = ssr_dpat; "then"; c = lconstr -> mk_dthen loc dp c ]]; + ssr_elsepat: [[ "else" -> [loc, [CPatAtom (loc, None)]] ]]; + ssr_else: [[ mp = ssr_elsepat; c = lconstr -> loc, mp, c ]]; + binder_constr: [ + [ "if"; c = operconstr LEVEL "200"; "is"; db1 = ssr_dthen; b2 = ssr_else -> + let b1, ct, rt = db1 in CCases (loc, MatchStyle, rt, [c, ct], [b1; b2]) + | "if"; c = operconstr LEVEL "200";"isn't";db1 = ssr_dthen; b2 = ssr_else -> + let b1, ct, rt = db1 in + let b1, b2 = + let (l1, p1, r1), (l2, p2, r2) = b1, b2 in (l1, p1, r2), (l2, p2, r1) in + CCases (loc, MatchStyle, rt, [c, ct], [b1; b2]) + | "let"; ":"; mp = ssr_mpat; ":="; c = lconstr; "in"; c1 = lconstr -> + mk_let loc no_rt [c, no_ct] mp c1 + | "let"; ":"; mp = ssr_mpat; ":="; c = lconstr; + rt = ssr_rtype; "in"; c1 = lconstr -> + mk_let loc rt [c, mk_cnotype mp] mp c1 + | "let"; ":"; mp = ssr_mpat; "in"; t = lconstr; ":="; c = lconstr; + rt = ssr_rtype; "in"; c1 = lconstr -> + mk_let loc rt [c, mk_ctype mp t] mp c1 + ] ]; +END + +GEXTEND Gram + GLOBAL: closed_binder; + closed_binder: [ + [ ["of" | "&"]; c = operconstr LEVEL "99" -> + [LocalRawAssum ([loc, Anonymous], Default Explicit, c)] + ] ]; +END +(* }}} *) + +(** Tacticals (+, -, *, done, by, do, =>, first, and last). {{{ ***************) + +(** Bracketing tactical *) + +(* The tactic pretty-printer doesn't know that some extended tactics *) +(* are actually tacticals. To prevent it from improperly removing *) +(* parentheses we override the parsing rule for bracketed tactic *) +(* expressions so that the pretty-print always reflects the input. *) +(* (Removing user-specified parentheses is dubious anyway). *) + +GEXTEND Gram + GLOBAL: tactic_expr; + ssrparentacarg: [[ "("; tac = tactic_expr; ")" -> loc, Tacexp tac ]]; + tactic_expr: LEVEL "0" [[ arg = ssrparentacarg -> TacArg arg ]]; +END + +(** The internal "done" and "ssrautoprop" tactics. *) + +(* For additional flexibility, "done" and "ssrautoprop" are *) +(* defined in Ltac. *) +(* Although we provide a default definition in ssreflect, *) +(* we look up the definition dynamically at each call point, *) +(* to allow for user extensions. "ssrautoprop" defaults to *) +(* trivial. *) + +let donetac gl = + let tacname = + try Nametab.locate_tactic (qualid_of_ident (id_of_string "done")) + with Not_found -> try Nametab.locate_tactic (ssrqid "done") + with Not_found -> Util.error "The ssreflect library was not loaded" in + let tacexpr = dummy_loc, Tacexpr.Reference (ArgArg (dummy_loc, tacname)) in + eval_tactic (Tacexpr.TacArg tacexpr) gl + +let prof_donetac = mk_profiler "donetac";; +let donetac gl = prof_donetac.profile donetac gl;; + +let ssrautoprop gl = + try + let tacname = + try Nametab.locate_tactic (qualid_of_ident (id_of_string "ssrautoprop")) + with Not_found -> Nametab.locate_tactic (ssrqid "ssrautoprop") in + let tacexpr = dummy_loc, Tacexpr.Reference (ArgArg (dummy_loc, tacname)) in + eval_tactic (Tacexpr.TacArg tacexpr) gl + with Not_found -> Auto.full_trivial [] gl + +let () = ssrautoprop_tac := ssrautoprop + +let tclBY tac = tclTHEN tac donetac + +(** Tactical arguments. *) + +(* We have four kinds: simple tactics, [|]-bracketed lists, hints, and swaps *) +(* The latter two are used in forward-chaining tactics (have, suffice, wlog) *) +(* and subgoal reordering tacticals (; first & ; last), respectively. *) + +(* Force use of the tactic_expr parsing entry, to rule out tick marks. *) +let pr_ssrtacarg _ _ prt = prt tacltop +ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY pr_ssrtacarg +| [ "Qed" ] -> [ Util.anomaly "Grammar placeholder match" ] +END +GEXTEND Gram + GLOBAL: ssrtacarg; + ssrtacarg: [[ tac = tactic_expr LEVEL "5" -> tac ]]; +END + +(* Lexically closed tactic for tacticals. *) +let pr_ssrtclarg _ _ prt (tac, _) = prt tacltop tac +ARGUMENT EXTEND ssrtclarg TYPED AS ssrtacarg * ltacctx + PRINTED BY pr_ssrtclarg +| [ ssrtacarg(tac) ] -> [ tac, rawltacctx ] +END +let eval_tclarg (tac, ctx) = ssrevaltac (get_ltacctx ctx) tac + +let pr_ortacs prt = + let rec pr_rec = function + | [None] -> spc() ++ str "|" ++ spc() + | None :: tacs -> spc() ++ str "|" ++ pr_rec tacs + | Some tac :: tacs -> spc() ++ str "| " ++ prt tacltop tac ++ pr_rec tacs + | [] -> mt() in + function + | [None] -> spc() + | None :: tacs -> pr_rec tacs + | Some tac :: tacs -> prt tacltop tac ++ pr_rec tacs + | [] -> mt() +let pr_ssrortacs _ _ = pr_ortacs + +ARGUMENT EXTEND ssrortacs TYPED AS tactic option list PRINTED BY pr_ssrortacs +| [ ssrtacarg(tac) "|" ssrortacs(tacs) ] -> [ Some tac :: tacs ] +| [ ssrtacarg(tac) "|" ] -> [ [Some tac; None] ] +| [ ssrtacarg(tac) ] -> [ [Some tac] ] +| [ "|" ssrortacs(tacs) ] -> [ None :: tacs ] +| [ "|" ] -> [ [None; None] ] +END + +let pr_hintarg prt = function + | true, tacs -> hv 0 (str "[ " ++ pr_ortacs prt tacs ++ str " ]") + | false, [Some tac] -> prt tacltop tac + | _, _ -> mt() + +let pr_ssrhintarg _ _ = pr_hintarg + +let mk_hint tac = false, [Some tac] +let mk_orhint tacs = true, tacs +let nullhint = true, [] +let nohint = false, [] + +ARGUMENT EXTEND ssrhintarg TYPED AS bool * ssrortacs PRINTED BY pr_ssrhintarg +| [ "[" "]" ] -> [ nullhint ] +| [ "[" ssrortacs(tacs) "]" ] -> [ mk_orhint tacs ] +| [ ssrtacarg(arg) ] -> [ mk_hint arg ] +END + +ARGUMENT EXTEND ssrortacarg TYPED AS ssrhintarg PRINTED BY pr_ssrhintarg +| [ "[" ssrortacs(tacs) "]" ] -> [ mk_orhint tacs ] +END + +let hinttac ist is_by (is_or, atacs) = + let dtac = if is_by then donetac else tclIDTAC in + let mktac = function + | Some atac -> tclTHEN (ssrevaltac ist atac) dtac + | _ -> dtac in + match List.map mktac atacs with + | [] -> if is_or then dtac else tclIDTAC + | [tac] -> tac + | tacs -> tclFIRST tacs + +(** The "-"/"+"/"*" tacticals. *) + +(* These are just visual cues to flag the beginning of the script for *) +(* new subgoals, when indentation is not appropriate (typically after *) +(* tactics that generate more than two subgoals). *) + +TACTIC EXTEND ssrtclplus +| [ "Qed" "+" ssrtclarg(arg) ] -> [ eval_tclarg arg ] +END +set_pr_ssrtac "tclplus" 5 [ArgSep "+ "; ArgSsr "tclarg"] + +TACTIC EXTEND ssrtclminus +| [ "Qed" "-" ssrtclarg(arg) ] -> [ eval_tclarg arg ] +END +set_pr_ssrtac "tclminus" 5 [ArgSep "- "; ArgSsr "tclarg"] + +TACTIC EXTEND ssrtclstar +| [ "Qed" "*" ssrtclarg(arg) ] -> [ eval_tclarg arg ] +END +set_pr_ssrtac "tclstar" 5 [ArgSep "- "; ArgSsr "tclarg"] + +let gen_tclarg = in_gen rawwit_ssrtclarg + +GEXTEND Gram + GLOBAL: tactic tactic_mode; + tactic: [ + [ "+"; tac = ssrtclarg -> ssrtac_expr loc "tclplus" [gen_tclarg tac] + | "-"; tac = ssrtclarg -> ssrtac_expr loc "tclminus" [gen_tclarg tac] + | "*"; tac = ssrtclarg -> ssrtac_expr loc "tclstar" [gen_tclarg tac] + ] ]; + tactic_mode: [ + [ "+"; tac = G_vernac.subgoal_command -> tac None + | "-"; tac = G_vernac.subgoal_command -> tac None + | "*"; tac = G_vernac.subgoal_command -> tac None + ] ]; +END + +(** The "by" tactical. *) + +let pr_hint prt arg = + if arg = nohint then mt() else str "by " ++ pr_hintarg prt arg +let pr_ssrhint _ _ = pr_hint + +ARGUMENT EXTEND ssrhint TYPED AS ssrhintarg PRINTED BY pr_ssrhint +| [ ] -> [ nohint ] +END + +TACTIC EXTEND ssrtclby +| [ "Qed" ssrhint(tac) ltacctx(ctx)] -> + [ hinttac (get_ltacctx ctx) true tac ] +END +set_pr_ssrtac "tclby" 0 [ArgSsr "hint"; ArgSsr "ltacctx"] + +(* We can't parse "by" in ARGUMENT EXTEND because it will only be made *) +(* into a keyword in ssreflect.v; so we anticipate this in GEXTEND. *) + +GEXTEND Gram + GLOBAL: ssrhint simple_tactic; + ssrhint: [[ "by"; arg = ssrhintarg -> arg ]]; + simple_tactic: [ + [ "by"; arg = ssrhintarg -> + let garg = in_gen rawwit_ssrhint arg in + let gctx = in_gen rawwit_ltacctx rawltacctx in + ssrtac_atom loc "tclby" [garg; gctx] + ] ]; +END +(* }}} *) + +(** Bound assumption argument *) + +(* The Ltac API does have a type for assumptions but it is level-dependent *) +(* and therefore impratical to use for complex arguments, so we substitute *) +(* our own to have a uniform representation. Also, we refuse to intern *) +(* idents that match global/section constants, since this would lead to *) +(* fragile Ltac scripts. *) + +type ssrhyp = SsrHyp of loc * identifier + +let hyp_id (SsrHyp (_, id)) = id +let pr_hyp (SsrHyp (_, id)) = pr_id id +let pr_ssrhyp _ _ _ = pr_hyp + +let wit_ssrhyprep, globwit_ssrhyprep, rawwit_ssrhyprep = + add_genarg "ssrhyprep" pr_hyp + +let hyp_err loc msg id = + user_err_loc (loc, "ssrhyp", str msg ++ pr_id id) + +let intern_hyp ist (SsrHyp (loc, id) as hyp) = + let _ = intern_genarg ist (in_gen rawwit_var (loc, id)) in + if not_section_id id then hyp else + hyp_err loc "Can't clear section hypothesis " id + +let interp_hyp ist gl (SsrHyp (loc, id)) = + let s, id' = interp_wit globwit_var wit_var ist gl (loc, id) in + if not_section_id id' then s, SsrHyp (loc, id') else + hyp_err loc "Can't clear section hypothesis " id' + +ARGUMENT EXTEND ssrhyp TYPED AS ssrhyprep PRINTED BY pr_ssrhyp + INTERPRETED BY interp_hyp + GLOBALIZED BY intern_hyp + | [ ident(id) ] -> [ SsrHyp (loc, id) ] +END + +type ssrhyp_or_id = Hyp of ssrhyp | Id of ssrhyp + +let hoik f = function Hyp x -> f x | Id x -> f x +let hoi_id = hoik hyp_id +let pr_hoi = hoik pr_hyp +let pr_ssrhoi _ _ _ = pr_hoi + +let wit_ssrhoirep, globwit_ssrhoirep, rawwit_ssrhoirep = + add_genarg "ssrhoirep" pr_hoi + +let intern_ssrhoi ist = function + | Hyp h -> Hyp (intern_hyp ist h) + | Id (SsrHyp (_, id)) as hyp -> + let _ = intern_genarg ist (in_gen rawwit_ident id) in + hyp + +let interp_ssrhoi ist gl = function + | Hyp h -> let s, h' = interp_hyp ist gl h in s, Hyp h' + | Id (SsrHyp (loc, id)) -> + let s, id' = interp_wit globwit_ident wit_ident ist gl id in + s, Id (SsrHyp (loc, id')) + +ARGUMENT EXTEND ssrhoi_hyp TYPED AS ssrhoirep PRINTED BY pr_ssrhoi + INTERPRETED BY interp_ssrhoi + GLOBALIZED BY intern_ssrhoi + | [ ident(id) ] -> [ Hyp (SsrHyp(loc, id)) ] +END +ARGUMENT EXTEND ssrhoi_id TYPED AS ssrhoirep PRINTED BY pr_ssrhoi + INTERPRETED BY interp_ssrhoi + GLOBALIZED BY intern_ssrhoi + | [ ident(id) ] -> [ Id (SsrHyp(loc, id)) ] +END + +type ssrhyps = ssrhyp list + +let pr_hyps = pr_list pr_spc pr_hyp +let pr_ssrhyps _ _ _ = pr_hyps +let hyps_ids = List.map hyp_id + +let rec check_hyps_uniq ids = function + | SsrHyp (loc, id) :: _ when List.mem id ids -> + hyp_err loc "Duplicate assumption " id + | SsrHyp (_, id) :: hyps -> check_hyps_uniq (id :: ids) hyps + | [] -> () + +let check_hyp_exists hyps (SsrHyp(_, id)) = + try ignore(Sign.lookup_named id hyps) + with Not_found -> errorstrm (str"No assumption is named " ++ pr_id id) + +let interp_hyps ist gl ghyps = + let hyps = List.map snd (List.map (interp_hyp ist gl) ghyps) in + check_hyps_uniq [] hyps; Tacmach.project gl, hyps + +ARGUMENT EXTEND ssrhyps TYPED AS ssrhyp list PRINTED BY pr_ssrhyps + INTERPRETED BY interp_hyps + | [ ssrhyp_list(hyps) ] -> [ check_hyps_uniq [] hyps; hyps ] +END + +(** Terms parsing. {{{ ********************************************************) + +(* Because we allow wildcards in term references, we need to stage the *) +(* interpretation of terms so that it occurs at the right time during *) +(* the execution of the tactic (e.g., so that we don't report an error *) +(* for a term that isn't actually used in the execution). *) +(* The term representation tracks whether the concrete initial term *) +(* started with an opening paren, which might avoid a conflict between *) +(* the ssrreflect term syntax and Gallina notation. *) + +(* kinds of terms *) + +type ssrtermkind = char (* print flag *) + +let input_ssrtermkind strm = match Compat.get_tok (stream_nth 0 strm) with + | Tok.KEYWORD "(" -> '(' + | Tok.KEYWORD "@" -> '@' + | _ -> ' ' + +let ssrtermkind = Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind + +let id_of_Cterm t = match id_of_cpattern t with + | Some x -> x + | None -> loc_error (loc_of_cpattern t) "Only identifiers are allowed here" +let ssrhyp_of_ssrterm = function + | k, (_, Some c) as o -> + SsrHyp (constr_loc c, id_of_Cterm (cpattern_of_term o)), String.make 1 k + | _, (_, None) -> assert false + +(* terms *) +let pr_ssrterm _ _ _ = pr_term +let pf_intern_term ist gl (_, c) = glob_constr ist (project gl) (pf_env gl) c +let intern_term ist sigma env (_, c) = glob_constr ist sigma env c +let interp_term ist gl (_, c) = snd (interp_open_constr ist gl c) +let force_term ist gl (_, c) = interp_constr ist gl c +let glob_ssrterm gs = function + | k, (_, Some c) -> k, Tacinterp.intern_constr gs c + | ct -> ct +let subst_ssrterm s (k, c) = k, Tacinterp.subst_glob_constr_and_expr s c +let interp_ssrterm _ gl t = Tacmach.project gl, t + +ARGUMENT EXTEND ssrterm + PRINTED BY pr_ssrterm + INTERPRETED BY interp_ssrterm + GLOBALIZED BY glob_ssrterm SUBSTITUTED BY subst_ssrterm + RAW_TYPED AS cpattern RAW_PRINTED BY pr_ssrterm + GLOB_TYPED AS cpattern GLOB_PRINTED BY pr_ssrterm +| [ "Qed" constr(c) ] -> [ mk_lterm c ] +END + +GEXTEND Gram + GLOBAL: ssrterm; + ssrterm: [[ k = ssrtermkind; c = constr -> mk_term k c ]]; +END +(* }}} *) + +(** The "in" pseudo-tactical {{{ **********************************************) + +(* We can't make "in" into a general tactical because this would create a *) +(* crippling conflict with the ltac let .. in construct. Hence, we add *) +(* explicitly an "in" suffix to all the extended tactics for which it is *) +(* relevant (including move, case, elim) and to the extended do tactical *) +(* below, which yields a general-purpose "in" of the form do [...] in ... *) + +(* This tactical needs to come before the intro tactics because the latter *) +(* must take precautions in order not to interfere with the discharged *) +(* assumptions. This is especially difficult for discharged "let"s, which *) +(* the default simpl and unfold tactics would erase blindly. *) + +(** Clear switch *) + +type ssrclear = ssrhyps + +let pr_clear_ne clr = str "{" ++ pr_hyps clr ++ str "}" +let pr_clear sep clr = if clr = [] then mt () else sep () ++ pr_clear_ne clr + +let pr_ssrclear _ _ _ = pr_clear mt + +ARGUMENT EXTEND ssrclear_ne TYPED AS ssrhyps PRINTED BY pr_ssrclear +| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ check_hyps_uniq [] clr; clr ] +END + +ARGUMENT EXTEND ssrclear TYPED AS ssrclear_ne PRINTED BY pr_ssrclear +| [ ssrclear_ne(clr) ] -> [ clr ] +| [ ] -> [ [] ] +END + +let cleartac clr = check_hyps_uniq [] clr; clear (hyps_ids clr) + +(* type ssrwgen = ssrclear * ssrhyp * string *) + +let pr_wgen = function + | (clr, Some((id,k),None)) -> spc() ++ pr_clear mt clr ++ str k ++ pr_hoi id + | (clr, Some((id,k),Some p)) -> + spc() ++ pr_clear mt clr ++ str"(" ++ str k ++ pr_hoi id ++ str ":=" ++ + pr_cpattern p ++ str ")" + | (clr, None) -> spc () ++ pr_clear mt clr +let pr_ssrwgen _ _ _ = pr_wgen + +(* no globwith for char *) +ARGUMENT EXTEND ssrwgen + TYPED AS ssrclear * ((ssrhoi_hyp * string) * cpattern option) option + PRINTED BY pr_ssrwgen +| [ ssrclear_ne(clr) ] -> [ clr, None ] +| [ ssrhoi_hyp(hyp) ] -> [ [], Some((hyp, " "), None) ] +| [ "@" ssrhoi_hyp(hyp) ] -> [ [], Some((hyp, "@"), None) ] +| [ "(" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> + [ [], Some ((id," "),Some p) ] +| [ "(" ssrhoi_id(id) ")" ] -> [ [], Some ((id,"("), None) ] +| [ "(@" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> + [ [], Some ((id,"@"),Some p) ] +| [ "(" "@" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> + [ [], Some ((id,"@"),Some p) ] +END + +type ssrclseq = InGoal | InHyps + | InHypsGoal | InHypsSeqGoal | InSeqGoal | InHypsSeq | InAll | InAllHyps + +let pr_clseq = function + | InGoal | InHyps -> mt () + | InSeqGoal -> str "|- *" + | InHypsSeqGoal -> str " |- *" + | InHypsGoal -> str " *" + | InAll -> str "*" + | InHypsSeq -> str " |-" + | InAllHyps -> str "* |-" + +let wit_ssrclseq, globwit_ssrclseq, rawwit_ssrclseq = + add_genarg "ssrclseq" pr_clseq + +let pr_clausehyps = pr_list pr_spc pr_wgen +let pr_ssrclausehyps _ _ _ = pr_clausehyps + +ARGUMENT EXTEND ssrclausehyps +TYPED AS ssrwgen list PRINTED BY pr_ssrclausehyps +| [ ssrwgen(hyp) "," ssrclausehyps(hyps) ] -> [ hyp :: hyps ] +| [ ssrwgen(hyp) ssrclausehyps(hyps) ] -> [ hyp :: hyps ] +| [ ssrwgen(hyp) ] -> [ [hyp] ] +END + +(* type ssrclauses = ssrahyps * ssrclseq *) + +let pr_clauses (hyps, clseq) = + if clseq = InGoal then mt () + else str "in " ++ pr_clausehyps hyps ++ pr_clseq clseq +let pr_ssrclauses _ _ _ = pr_clauses + +ARGUMENT EXTEND ssrclauses TYPED AS ssrwgen list * ssrclseq + PRINTED BY pr_ssrclauses + | [ "in" ssrclausehyps(hyps) "|-" "*" ] -> [ hyps, InHypsSeqGoal ] + | [ "in" ssrclausehyps(hyps) "|-" ] -> [ hyps, InHypsSeq ] + | [ "in" ssrclausehyps(hyps) "*" ] -> [ hyps, InHypsGoal ] + | [ "in" ssrclausehyps(hyps) ] -> [ hyps, InHyps ] + | [ "in" "|-" "*" ] -> [ [], InSeqGoal ] + | [ "in" "*" ] -> [ [], InAll ] + | [ "in" "*" "|-" ] -> [ [], InAllHyps ] + | [ ] -> [ [], InGoal ] +END + +let nohide = mkRel 0 +let hidden_goal_tag = "the_hidden_goal" + +(* Reduction that preserves the Prod/Let spine of the "in" tactical. *) + +let inc_safe n = if n = 0 then n else n + 1 +let rec safe_depth c = match kind_of_term c with +| LetIn (Name x, _, _, c') when is_discharged_id x -> safe_depth c' + 1 +| LetIn (_, _, _, c') | Prod (_, _, c') -> inc_safe (safe_depth c') +| _ -> 0 + +let red_safe r e s c0 = + let rec red_to e c n = match kind_of_term c with + | Prod (x, t, c') when n > 0 -> + let t' = r e s t in let e' = Environ.push_rel (x, None, t') e in + mkProd (x, t', red_to e' c' (n - 1)) + | LetIn (x, b, t, c') when n > 0 -> + let t' = r e s t in let e' = Environ.push_rel (x, None, t') e in + mkLetIn (x, r e s b, t', red_to e' c' (n - 1)) + | _ -> r e s c in + red_to e c0 (safe_depth c0) + +let check_wgen_uniq gens = + let clears = List.flatten (List.map fst gens) in + check_hyps_uniq [] clears; + let ids = Util.list_map_filter + (function (_,Some ((id,_),_)) -> Some (hoi_id id) | _ -> None) gens in + let rec check ids = function + | id :: _ when List.mem id ids -> + errorstrm (str"Duplicate generalization " ++ pr_id id) + | id :: hyps -> check (id :: ids) hyps + | [] -> () in + check [] ids + +let pf_clauseids gl gens clseq = + let keep_clears = List.map (fun x, _ -> x, None) in + if gens <> [] then (check_wgen_uniq gens; gens) else + if clseq <> InAll && clseq <> InAllHyps then keep_clears gens else + Util.error "assumptions should be named explicitly" + +let hidden_clseq = function InHyps | InHypsSeq | InAllHyps -> true | _ -> false + +let hidetacs clseq idhide cl0 = + if not (hidden_clseq clseq) then [] else + [posetac idhide cl0; convert_concl_no_check (mkVar idhide)] + +let discharge_hyp (id', (id, mode)) gl = + let cl' = subst_var id (pf_concl gl) in + match pf_get_hyp gl id, mode with + | (_, None, t), _ | (_, Some _, t), "(" -> + apply_type (mkProd (Name id', t, cl')) [mkVar id] gl + | (_, Some v, t), _ -> convert_concl (mkLetIn (Name id', v, t, cl')) gl + +let endclausestac id_map clseq gl_id cl0 gl = + let not_hyp' id = not (List.mem_assoc id id_map) in + let orig_id id = try List.assoc id id_map with _ -> id in + let dc, c = Term.decompose_prod_assum (pf_concl gl) in + let hide_goal = hidden_clseq clseq in + let c_hidden = hide_goal && c = mkVar gl_id in + let rec fits forced = function + | (id, _) :: ids, (Name id', _, _) :: dc' when id' = id -> + fits true (ids, dc') + | ids, dc' -> + forced && ids = [] && (not hide_goal || dc' = [] && c_hidden) in + let rec unmark c = match kind_of_term c with + | Var id when hidden_clseq clseq && id = gl_id -> cl0 + | Prod (Name id, t, c') when List.mem_assoc id id_map -> + mkProd (Name (orig_id id), unmark t, unmark c') + | LetIn (Name id, v, t, c') when List.mem_assoc id id_map -> + mkLetIn (Name (orig_id id), unmark v, unmark t, unmark c') + | _ -> map_constr unmark c in + let utac hyp = convert_hyp_no_check (map_named_declaration unmark hyp) in + let utacs = List.map utac (pf_hyps gl) in + let ugtac gl' = convert_concl_no_check (unmark (pf_concl gl')) gl' in + let ctacs = if hide_goal then [clear [gl_id]] else [] in + let mktac itacs = tclTHENLIST (itacs @ utacs @ ugtac :: ctacs) in + let itac (_, id) = introduction id in + if fits false (id_map, List.rev dc) then mktac (List.map itac id_map) gl else + let all_ids = ids_of_rel_context dc @ pf_ids_of_hyps gl in + if List.for_all not_hyp' all_ids && not c_hidden then mktac [] gl else + Util.error "tampering with discharged assumptions of \"in\" tactical" + +let is_id_constr c = match kind_of_term c with + | Lambda(_,_,c) when isRel c -> 1 = destRel c + | _ -> false + +let red_product_skip_id env sigma c = match kind_of_term c with + | App(hd,args) when Array.length args = 1 && is_id_constr hd -> args.(0) + | _ -> try Tacred.red_product env sigma c with _ -> c + +let abs_wgen keep_let ist gl f gen (args,c) = + let sigma, env = project gl, pf_env gl in + let evar_closed t p = + if occur_existential t then + Util.user_err_loc (loc_of_cpattern p,"ssreflect", + pr_constr_pat t ++ + str" contains holes and matches no subterm of the goal") in + match gen with + | _, Some ((x, mode), None) when mode = "@" || (mode = " " && keep_let) -> + let x = hoi_id x in + let _, bo, ty = pf_get_hyp gl x in + (if bo <> None then args else mkVar x :: args), + mkProd_or_LetIn (Name (f x),bo,ty) (subst_var x c) + | _, Some ((x, _), None) -> + let x = hoi_id x in + mkVar x :: args, mkProd (Name (f x), pf_get_hyp_typ gl x, subst_var x c) + | _, Some ((x, "@"), Some p) -> + let x = hoi_id x in + let cp = interp_cpattern ist gl p None in + let t, c = + try fill_occ_pattern ~raise_NoMatch:true env sigma c cp None 1 + with NoMatch -> redex_of_pattern env cp, c in + evar_closed t p; + let ut = red_product_skip_id env sigma t in + args, mkLetIn(Name (f x), ut, pf_type_of gl t, c) + | _, Some ((x, _), Some p) -> + let x = hoi_id x in + let cp = interp_cpattern ist gl p None in + let t, c = + try fill_occ_pattern ~raise_NoMatch:true env sigma c cp None 1 + with NoMatch -> redex_of_pattern env cp, c in + evar_closed t p; + t :: args, mkProd(Name (f x), pf_type_of gl t, c) + | _ -> args, c + +let clr_of_wgen gen clrs = match gen with + | clr, Some ((x, _), None) -> + let x = hoi_id x in + cleartac clr :: cleartac [SsrHyp(Util.dummy_loc,x)] :: clrs + | clr, _ -> cleartac clr :: clrs + +let tclCLAUSES ist tac (gens, clseq) gl = + if clseq = InGoal || clseq = InSeqGoal then tac gl else + let clr_gens = pf_clauseids gl gens clseq in + let clear = tclTHENLIST (List.rev(List.fold_right clr_of_wgen clr_gens [])) in + let gl_id = mk_anon_id hidden_goal_tag gl in + let cl0 = pf_concl gl in + let dtac gl = + let c = pf_concl gl in + let args, c = + List.fold_right (abs_wgen true ist gl mk_discharged_id) gens ([], c) in + apply_type c args gl in + let endtac = + let id_map = Util.list_map_filter (function + | _, Some ((x,_),_) -> let id = hoi_id x in Some (mk_discharged_id id, id) + | _, None -> None) gens in + endclausestac id_map clseq gl_id cl0 in + tclTHENLIST (hidetacs clseq gl_id cl0 @ [dtac; clear; tac; endtac]) gl +(* }}} *) + +(** Simpl switch *) + +type ssrsimpl = Simpl | Cut | SimplCut | Nop + +let pr_simpl = function + | Simpl -> str "/=" + | Cut -> str "//" + | SimplCut -> str "//=" + | Nop -> mt () + +let pr_ssrsimpl _ _ _ = pr_simpl + +let wit_ssrsimplrep, globwit_ssrsimplrep, rawwit_ssrsimplrep = + add_genarg "ssrsimplrep" pr_simpl + +ARGUMENT EXTEND ssrsimpl_ne TYPED AS ssrsimplrep PRINTED BY pr_ssrsimpl +| [ "/=" ] -> [ Simpl ] +| [ "//" ] -> [ Cut ] +| [ "//=" ] -> [ SimplCut ] +END + +ARGUMENT EXTEND ssrsimpl TYPED AS ssrsimplrep PRINTED BY pr_ssrsimpl +| [ ssrsimpl_ne(sim) ] -> [ sim ] +| [ ] -> [ Nop ] +END + +(* We must avoid zeta-converting any "let"s created by the "in" tactical. *) + +let safe_simpltac gl = + let cl' = red_safe Tacred.simpl (pf_env gl) (project gl) (pf_concl gl) in + convert_concl_no_check cl' gl + +let simpltac = function + | Simpl -> safe_simpltac + | Cut -> tclTRY donetac + | SimplCut -> tclTHEN safe_simpltac (tclTRY donetac) + | Nop -> tclIDTAC + +(** Rewriting direction *) + +let pr_dir = function L2R -> str "->" | R2L -> str "<-" +let pr_rwdir = function L2R -> mt() | R2L -> str "-" + +let rewritetac dir c = + (* Due to the new optional arg ?tac, application shouldn't be too partial *) + Equality.general_rewrite (dir = L2R) all_occurrences true false c + +let wit_ssrdir, globwit_ssrdir, rawwit_ssrdir = + add_genarg "ssrdir" pr_dir + +let dir_org = function L2R -> 1 | R2L -> 2 + +(** Indexes *) + +(* Since SSR indexes are always positive numbers, we use the 0 value *) +(* to encode an omitted index. We reuse the in or_var type, but we *) +(* supply our own interpretation function, which checks for non *) +(* positive values, and allows the use of constr numerals, so that *) +(* e.g., "let n := eval compute in (1 + 3) in (do n!clear)" works. *) + +type ssrindex = int or_var + +let pr_index = function + | ArgVar (_, id) -> pr_id id + | ArgArg n when n > 0 -> pr_int n + | _ -> mt () +let pr_ssrindex _ _ _ = pr_index + +let noindex = ArgArg 0 +let allocc = Some(false,[]) + +let check_index loc i = + if i > 0 then i else loc_error loc "Index not positive" +let mk_index loc = function ArgArg i -> ArgArg (check_index loc i) | iv -> iv + +let interp_index ist gl idx = + Tacmach.project gl, + match idx with + | ArgArg _ -> idx + | ArgVar (loc, id) -> + let i = try match List.assoc id ist.lfun with + | VInteger i -> i + | VConstr ([],c) -> + let rc = Detyping.detype false [] [] c in + begin match Notation.uninterp_prim_token rc with + | _, Numeral bigi -> int_of_string (Bigint.to_string bigi) + | _ -> raise Not_found + end + | _ -> raise Not_found + with _ -> loc_error loc "Index not a number" in + ArgArg (check_index loc i) + +ARGUMENT EXTEND ssrindex TYPED AS int_or_var PRINTED BY pr_ssrindex + INTERPRETED BY interp_index +| [ int_or_var(i) ] -> [ mk_index loc i ] +END + +(** Occurrence switch *) + +(* The standard syntax of complemented occurrence lists involves a single *) +(* initial "-", e.g., {-1 3 5}. An initial *) +(* "+" may be used to indicate positive occurrences (the default). The *) +(* "+" is optional, except if the list of occurrences starts with a *) +(* variable or is empty (to avoid confusion with a clear switch). The *) +(* empty positive switch "{+}" selects no occurrences, while the empty *) +(* negative switch "{-}" selects all occurrences explicitly; this is the *) +(* default, but "{-}" prevents the implicit clear, and can be used to *) +(* force dependent elimination -- see ndefectelimtac below. *) + +type ssrocc = occ + +let pr_occ = function + | Some (true, occ) -> str "{-" ++ pr_list pr_spc int occ ++ str "}" + | Some (false, occ) -> str "{+" ++ pr_list pr_spc int occ ++ str "}" + | None -> str "{}" + +let pr_ssrocc _ _ _ = pr_occ + +ARGUMENT EXTEND ssrocc TYPED AS (bool * int list) option PRINTED BY pr_ssrocc +| [ natural(n) natural_list(occ) ] -> [ + Some (false, List.map (check_index loc) (n::occ)) ] +| [ "-" natural_list(occ) ] -> [ Some (true, occ) ] +| [ "+" natural_list(occ) ] -> [ Some (false, occ) ] +END + +let pf_mkprod gl c ?(name=constr_name c) cl = + let t = pf_type_of gl c in + if name <> Anonymous || noccurn 1 cl then mkProd (name, t, cl) else + mkProd (Name (pf_type_id gl t), t, cl) + +let pf_abs_prod name gl c cl = pf_mkprod gl c ~name (subst_term c cl) + +(** Discharge occ switch (combined occurrence / clear switch *) + +type ssrdocc = ssrclear option * ssrocc option + +let mkocc occ = None, occ +let noclr = mkocc None +let mkclr clr = Some clr, None +let nodocc = mkclr [] + +let pr_docc = function + | None, occ -> pr_occ occ + | Some clr, _ -> pr_clear mt clr + +let pr_ssrdocc _ _ _ = pr_docc + +ARGUMENT EXTEND ssrdocc TYPED AS ssrclear option * ssrocc PRINTED BY pr_ssrdocc +| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ mkclr clr ] +| [ "{" ssrocc(occ) "}" ] -> [ mkocc occ ] +END + +(** View hint database and View application. {{{ ******************************) + +(* There are three databases of lemmas used to mediate the application *) +(* of reflection lemmas: one for forward chaining, one for backward *) +(* chaining, and one for secondary backward chaining. *) + +(* View hints *) + +let rec isCxHoles = function (CHole _, None) :: ch -> isCxHoles ch | _ -> false + +let pr_raw_ssrhintref prc _ _ = function + | CAppExpl (_, (None, r), args) when isCHoles args -> + prc (CRef r) ++ str "|" ++ int (List.length args) + | CApp (_, (_, CRef _), _) as c -> prc c + | CApp (_, (_, c), args) when isCxHoles args -> + prc c ++ str "|" ++ int (List.length args) + | c -> prc c + +let pr_rawhintref = function + | GApp (_, f, args) when isRHoles args -> + pr_glob_constr f ++ str "|" ++ int (List.length args) + | c -> pr_glob_constr c + +let pr_glob_ssrhintref _ _ _ (c, _) = pr_rawhintref c + +let pr_ssrhintref prc _ _ = prc + +let mkhintref loc c n = match c with + | CRef r -> CAppExpl (loc, (None, r), mkCHoles loc n) + | _ -> mkAppC (c, mkCHoles loc n) + +ARGUMENT EXTEND ssrhintref + PRINTED BY pr_ssrhintref + RAW_TYPED AS constr RAW_PRINTED BY pr_raw_ssrhintref + GLOB_TYPED AS constr GLOB_PRINTED BY pr_glob_ssrhintref + | [ constr(c) ] -> [ c ] + | [ constr(c) "|" natural(n) ] -> [ mkhintref loc c n ] +END + +(* View purpose *) + +let pr_viewpos = function + | 0 -> str " for move/" + | 1 -> str " for apply/" + | 2 -> str " for apply//" + | _ -> mt () + +let pr_ssrviewpos _ _ _ = pr_viewpos + +ARGUMENT EXTEND ssrviewpos TYPED AS int PRINTED BY pr_ssrviewpos + | [ "for" "move" "/" ] -> [ 0 ] + | [ "for" "apply" "/" ] -> [ 1 ] + | [ "for" "apply" "/" "/" ] -> [ 2 ] + | [ "for" "apply" "//" ] -> [ 2 ] + | [ ] -> [ 3 ] +END + +let pr_ssrviewposspc _ _ _ i = pr_viewpos i ++ spc () + +ARGUMENT EXTEND ssrviewposspc TYPED AS ssrviewpos PRINTED BY pr_ssrviewposspc + | [ ssrviewpos(i) ] -> [ i ] +END + +(* The table and its display command *) + +let viewtab : glob_constr list array = Array.make 3 [] + +let _ = + let init () = Array.fill viewtab 0 3 [] in + let freeze () = Array.copy viewtab in + let unfreeze vt = Array.blit vt 0 viewtab 0 3 in + Summary.declare_summary "ssrview" + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = init } + +let mapviewpos f n k = if n < 3 then f n else for i = 0 to k - 1 do f i done + +let print_view_hints i = + let pp_viewname = str "Hint View" ++ pr_viewpos i ++ str " " in + let pp_hints = pr_list spc pr_rawhintref viewtab.(i) in + ppnl (pp_viewname ++ hov 0 pp_hints ++ Pp.cut ()) + +VERNAC COMMAND EXTEND PrintView +| [ "Print" "Hint" "View" ssrviewpos(i) ] -> [ mapviewpos print_view_hints i 3 ] +END + +(* Populating the table *) + +let cache_viewhint (_, (i, lvh)) = + let mem_raw h = List.exists (Topconstr.eq_glob_constr h) in + let add_hint h hdb = if mem_raw h hdb then hdb else h :: hdb in + viewtab.(i) <- List.fold_right add_hint lvh viewtab.(i) + +let subst_viewhint ( subst, (i, lvh as ilvh)) = + let lvh' = list_smartmap (Detyping.subst_glob_constr subst) lvh in + if lvh' == lvh then ilvh else i, lvh' + +let classify_viewhint x = Libobject.Substitute x + +let in_viewhint = + Libobject.declare_object {(Libobject.default_object "VIEW_HINTS") with + Libobject.open_function = (fun i o -> if i = 1 then cache_viewhint o); + Libobject.cache_function = cache_viewhint; + Libobject.subst_function = subst_viewhint; + Libobject.classify_function = classify_viewhint } + +let glob_view_hints lvh = + List.map (Constrintern.intern_constr Evd.empty (Global.env ())) lvh + +let add_view_hints lvh i = Lib.add_anonymous_leaf (in_viewhint (i, lvh)) + +VERNAC COMMAND EXTEND HintView + | [ "Hint" "View" ssrviewposspc(n) ne_ssrhintref_list(lvh) ] -> + [ mapviewpos (add_view_hints (glob_view_hints lvh)) n 2 ] +END + +(** Views *) + +(* Views for the "move" and "case" commands are actually open *) +(* terms, but this is handled by interp_view, which is called *) +(* by interp_casearg. We use lists, to support the *) +(* "double-view" feature of the apply command. *) + +(* type ssrview = ssrterm list *) + +let pr_view = pr_list mt (fun c -> str "/" ++ pr_term c) + +let pr_ssrview _ _ _ = pr_view + +ARGUMENT EXTEND ssrview TYPED AS ssrterm list + PRINTED BY pr_ssrview +| [ "/" constr(c) ] -> [ [mk_term ' ' c] ] +| [ "/" constr(c) ssrview(w) ] -> [ (mk_term ' ' c) :: w ] +END + +(* There are two ways of "applying" a view to term: *) +(* 1- using a view hint if the view is an instance of some *) +(* (reflection) inductive predicate. *) +(* 2- applying the view if it coerces to a function, adding *) +(* implicit arguments. *) +(* They require guessing the view hints and the number of *) +(* implicits, respectively, which we do by brute force. *) + +let view_error s gv = + errorstrm (str ("Cannot " ^ s ^ " view ") ++ pr_term gv) + +let interp_view ist si env sigma gv rid = + match intern_term ist sigma env gv with + | GApp (loc, GHole _, rargs) -> + let rv = GApp (loc, rid, rargs) in + snd (interp_open_constr ist (re_sig si sigma) (rv, None)) + | rv -> + let interp rc rargs = + interp_open_constr ist (re_sig si sigma) (mkRApp rc rargs, None) in + let rec simple_view rargs n = + if n < 0 then view_error "use" gv else + try interp rv rargs with _ -> simple_view (mkRHole :: rargs) (n - 1) in + let view_nbimps = interp_view_nbimps ist (re_sig si sigma) rv in + let view_args = [mkRApp rv (mkRHoles view_nbimps); rid] in + let rec view_with = function + | [] -> simple_view [rid] (interp_nbargs ist (re_sig si sigma) rv) + | hint :: hints -> try interp hint view_args with _ -> view_with hints in + snd (view_with (if view_nbimps < 0 then [] else viewtab.(0))) + +let top_id = mk_internal_id "top assumption" + +let with_view ist si env gl0 c name cl prune = + let c2r ist x = { ist with lfun = (top_id, VConstr ([], x)) :: ist.lfun } in + let rec loop (sigma, c') = function + | f :: view -> + let rid, ist = match kind_of_term c' with + | Var id -> mkRVar id, ist + | _ -> mkRltacVar top_id, c2r ist c' in + loop (interp_view ist si env sigma f rid) view + | [] -> + let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in + let c' = Reductionops.nf_evar sigma c' in + let n, c', _ = pf_abs_evars gl0 (sigma, c') in + let c' = if not prune then c' else pf_abs_cterm gl0 n c' in + pf_abs_prod name gl0 c' (prod_applist cl [c]), c' + in loop + +let pf_with_view ist gl (prune, view) cl c = + let env, sigma, si = pf_env gl, project gl, sig_it gl in + with_view ist si env gl c (constr_name c) cl prune (sigma, c) view +(* }}} *) + +(** Extended intro patterns {{{ ***********************************************) + +type ssrtermrep = char * glob_constr_and_expr +type ssripat = + | IpatSimpl of ssrclear * ssrsimpl + | IpatId of identifier + | IpatWild + | IpatCase of ssripats list + | IpatRw of ssrocc * ssrdir + | IpatAll + | IpatAnon + | IpatView of ssrtermrep list + | IpatNoop + | IpatNewHidden of identifier list +and ssripats = ssripat list + +let remove_loc = snd + +let rec ipat_of_intro_pattern = function + | IntroIdentifier id -> IpatId id + | IntroWildcard -> IpatWild + | IntroOrAndPattern iorpat -> + IpatCase + (List.map (List.map ipat_of_intro_pattern) + (List.map (List.map remove_loc) iorpat)) + | IntroAnonymous -> IpatAnon + | IntroRewrite b -> IpatRw (allocc, if b then L2R else R2L) + | IntroFresh id -> IpatAnon + | IntroForthcoming _ -> (* Unable to determine which kind of ipat interp_introid could return [HH] *) + assert false + +let rec pr_ipat = function + | IpatId id -> pr_id id + | IpatSimpl (clr, sim) -> pr_clear mt clr ++ pr_simpl sim + | IpatCase iorpat -> hov 1 (str "[" ++ pr_iorpat iorpat ++ str "]") + | IpatRw (occ, dir) -> pr_occ occ ++ pr_dir dir + | IpatAll -> str "*" + | IpatWild -> str "_" + | IpatAnon -> str "?" + | IpatView v -> pr_view v + | IpatNoop -> str "-" + | IpatNewHidden l -> str "[:" ++ pr_list spc pr_id l ++ str "]" +and pr_iorpat iorpat = pr_list pr_bar pr_ipats iorpat +and pr_ipats ipats = pr_list spc pr_ipat ipats + +let wit_ssripatrep, globwit_ssripatrep, rawwit_ssripatrep = + add_genarg "ssripatrep" pr_ipat + +let pr_ssripat _ _ _ = pr_ipat +let pr_ssripats _ _ _ = pr_ipats +let pr_ssriorpat _ _ _ = pr_iorpat + +let intern_ipat ist ipat = + let rec check_pat = function + | IpatSimpl (clr, _) -> ignore (List.map (intern_hyp ist) clr) + | IpatCase iorpat -> List.iter (List.iter check_pat) iorpat + | _ -> () in + check_pat ipat; ipat + +let intern_ipats ist = List.map (intern_ipat ist) + +let interp_introid ist gl id = + try IntroIdentifier (hyp_id (snd (interp_hyp ist gl (SsrHyp (dummy_loc, id))))) + with _ -> snd(snd (interp_intro_pattern ist gl (dummy_loc,IntroIdentifier id))) + +let rec add_intro_pattern_hyps (loc, ipat) hyps = match ipat with + | IntroIdentifier id -> + if not_section_id id then SsrHyp (loc, id) :: hyps else + hyp_err loc "Can't delete section hypothesis " id + | IntroWildcard -> hyps + | IntroOrAndPattern iorpat -> + List.fold_right (List.fold_right add_intro_pattern_hyps) iorpat hyps + | IntroAnonymous -> [] + | IntroFresh _ -> [] + | IntroRewrite _ -> hyps + | IntroForthcoming _ -> + (* As in ipat_of_intro_pattern, was unable to determine which kind + of ipat interp_introid could return [HH] *) assert false + +let rec interp_ipat ist gl = + let ltacvar id = List.mem_assoc id ist.lfun in + let rec interp = function + | IpatId id when ltacvar id -> + ipat_of_intro_pattern (interp_introid ist gl id) + | IpatSimpl (clr, sim) -> + let add_hyps (SsrHyp (loc, id) as hyp) hyps = + if not (ltacvar id) then hyp :: hyps else + add_intro_pattern_hyps (loc, (interp_introid ist gl id)) hyps in + let clr' = List.fold_right add_hyps clr [] in + check_hyps_uniq [] clr'; IpatSimpl (clr', sim) + | IpatCase iorpat -> IpatCase (List.map (List.map interp) iorpat) + | IpatNewHidden l -> + IpatNewHidden + (List.map (function + | IntroIdentifier id -> id + | _ -> assert false) + (List.map (interp_introid ist gl) l)) + | ipat -> ipat in + interp + +let interp_ipats ist gl l = project gl, List.map (interp_ipat ist gl) l + +let pushIpatRw = function + | pats :: orpat -> (IpatRw (allocc, L2R) :: pats) :: orpat + | [] -> [] + +let pushIpatNoop = function + | pats :: orpat -> (IpatNoop :: pats) :: orpat + | [] -> [] + +ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY pr_ssripats + INTERPRETED BY interp_ipats + GLOBALIZED BY intern_ipats + | [ "_" ] -> [ [IpatWild] ] + | [ "*" ] -> [ [IpatAll] ] + | [ ident(id) ] -> [ [IpatId id] ] + | [ "?" ] -> [ [IpatAnon] ] + | [ ssrsimpl_ne(sim) ] -> [ [IpatSimpl ([], sim)] ] + | [ ssrdocc(occ) "->" ] -> [ match occ with + | None, occ -> [IpatRw (occ, L2R)] + | Some clr, _ -> [IpatSimpl (clr, Nop); IpatRw (allocc, L2R)]] + | [ ssrdocc(occ) "<-" ] -> [ match occ with + | None, occ -> [IpatRw (occ, R2L)] + | Some clr, _ -> [IpatSimpl (clr, Nop); IpatRw (allocc, R2L)]] + | [ ssrdocc(occ) ] -> [ match occ with + | Some cl, _ -> check_hyps_uniq [] cl; [IpatSimpl (cl, Nop)] + | _ -> loc_error loc "Only identifiers are allowed here"] + | [ "->" ] -> [ [IpatRw (allocc, L2R)] ] + | [ "<-" ] -> [ [IpatRw (allocc, R2L)] ] + | [ "-" ] -> [ [IpatNoop] ] + | [ "-/" "=" ] -> [ [IpatNoop;IpatSimpl([],Simpl)] ] + | [ "-/=" ] -> [ [IpatNoop;IpatSimpl([],Simpl)] ] + | [ "-/" "/" ] -> [ [IpatNoop;IpatSimpl([],Cut)] ] + | [ "-//" ] -> [ [IpatNoop;IpatSimpl([],Cut)] ] + | [ "-/" "/=" ] -> [ [IpatNoop;IpatSimpl([],SimplCut)] ] + | [ "-//" "=" ] -> [ [IpatNoop;IpatSimpl([],SimplCut)] ] + | [ "-//=" ] -> [ [IpatNoop;IpatSimpl([],SimplCut)] ] + | [ ssrview(v) ] -> [ [IpatView v] ] + | [ "[" ":" ident_list(idl) "]" ] -> [ [IpatNewHidden idl] ] +END + +ARGUMENT EXTEND ssripats TYPED AS ssripat PRINTED BY pr_ssripats + | [ ssripat(i) ssripats(tl) ] -> [ i @ tl ] + | [ ] -> [ [] ] +END + +ARGUMENT EXTEND ssriorpat TYPED AS ssripat list PRINTED BY pr_ssriorpat +| [ ssripats(pats) "|" ssriorpat(orpat) ] -> [ pats :: orpat ] +| [ ssripats(pats) "|-" ">" ssriorpat(orpat) ] -> [ pats :: pushIpatRw orpat ] +| [ ssripats(pats) "|-" ssriorpat(orpat) ] -> [ pats :: pushIpatNoop orpat ] +| [ ssripats(pats) "|->" ssriorpat(orpat) ] -> [ pats :: pushIpatRw orpat ] +| [ ssripats(pats) "||" ssriorpat(orpat) ] -> [ pats :: [] :: orpat ] +| [ ssripats(pats) "|||" ssriorpat(orpat) ] -> [ pats :: [] :: [] :: orpat ] +| [ ssripats(pats) "||||" ssriorpat(orpat) ] -> [ [pats; []; []; []] @ orpat ] +| [ ssripats(pats) ] -> [ [pats] ] +END + +let reject_ssrhid strm = + match Compat.get_tok (stream_nth 0 strm) with + | Tok.KEYWORD "[" -> + (match Compat.get_tok (stream_nth 0 strm) with + | Tok.KEYWORD ":" -> raise Stream.Failure + | _ -> ()) + | _ -> () + +let test_nohidden = Gram.Entry.of_parser "test_ssrhid" reject_ssrhid + +ARGUMENT EXTEND ssrcpat TYPED AS ssripatrep PRINTED BY pr_ssripat + | [ "Qed" ssriorpat(x) ] -> [ IpatCase x ] +END + +GEXTEND Gram + GLOBAL: ssrcpat; + ssrcpat: [[ test_nohidden; "["; iorpat = ssriorpat; "]" -> IpatCase iorpat ]]; +END + +GEXTEND Gram + GLOBAL: ssripat; + ssripat: [[ pat = ssrcpat -> [pat] ]]; +END + +ARGUMENT EXTEND ssripats_ne TYPED AS ssripat PRINTED BY pr_ssripats + | [ ssripat(i) ssripats(tl) ] -> [ i @ tl ] +END + +(* subsets of patterns *) +let check_ssrhpats loc w_binders ipats = + let err_loc s = user_err_loc (loc, "ssreflect", s) in + let clr, ipats = + let rec aux clr = function + | IpatSimpl (cl, Nop) :: tl -> aux (clr @ cl) tl + | IpatSimpl (cl, sim) :: tl -> clr @ cl, IpatSimpl ([], sim) :: tl + | tl -> clr, tl + in aux [] ipats in + let simpl, ipats = + match List.rev ipats with + | IpatSimpl ([],_) as s :: tl -> [s], List.rev tl + | _ -> [], ipats in + if simpl <> [] && not w_binders then + err_loc (str "No s-item allowed here: " ++ pr_ipats simpl); + let ipat, binders = + let rec loop ipat = function + | [] -> ipat, [] + | ( IpatId _| IpatAnon| IpatCase _| IpatRw _ as i) :: tl -> + if w_binders then + if simpl <> [] && tl <> [] then + err_loc(str"binders XOR s-item allowed here: "++pr_ipats(tl@simpl)) + else if not (List.for_all (function IpatId _ -> true | _ -> false) tl) + then err_loc (str "Only binders allowed here: " ++ pr_ipats tl) + else ipat @ [i], tl + else + if tl = [] then ipat @ [i], [] + else err_loc (str "No binder or s-item allowed here: " ++ pr_ipats tl) + | hd :: tl -> loop (ipat @ [hd]) tl + in loop [] ipats in + ((clr, ipat), binders), simpl + +let single loc = + function [x] -> x | _ -> loc_error loc "Only one intro pattern is allowed" + +let pr_hpats (((clr, ipat), binders), simpl) = + pr_clear mt clr ++ pr_ipats ipat ++ pr_ipats binders ++ pr_ipats simpl +let pr_ssrhpats _ _ _ = pr_hpats +let pr_ssrhpats_wtransp _ _ _ (_, x) = pr_hpats x + +ARGUMENT EXTEND ssrhpats TYPED AS ((ssrclear * ssripat) * ssripat) * ssripat +PRINTED BY pr_ssrhpats + | [ ssripats(i) ] -> [ check_ssrhpats loc true i ] +END + +ARGUMENT EXTEND ssrhpats_wtransp + TYPED AS bool * (((ssrclear * ssripat) * ssripat) * ssripat) + PRINTED BY pr_ssrhpats_wtransp + | [ ssripats(i) ] -> [ false,check_ssrhpats loc true i ] + | [ ssripats(i) "@" ssripats(j) ] -> [ true,check_ssrhpats loc true (i @ j) ] +END + +ARGUMENT EXTEND ssrhpats_nobs +TYPED AS ((ssrclear * ssripat) * ssripat) * ssripat PRINTED BY pr_ssrhpats + | [ ssripats(i) ] -> [ check_ssrhpats loc false i ] +END + +ARGUMENT EXTEND ssrrpat TYPED AS ssripatrep PRINTED BY pr_ssripat + | [ "->" ] -> [ IpatRw (allocc, L2R) ] + | [ "<-" ] -> [ IpatRw (allocc, R2L) ] +END + +type ssrintros = ssripats * ltacctx + +let pr_intros sep (intrs, _) = + if intrs = [] then mt() else sep () ++ str "=> " ++ pr_ipats intrs +let pr_ssrintros _ _ _ = pr_intros mt + +ARGUMENT EXTEND ssrintros_ne TYPED AS ssripat * ltacctx + PRINTED BY pr_ssrintros + | [ "=>" ssripats_ne(pats) ] -> [ pats, rawltacctx ] +END + +ARGUMENT EXTEND ssrintros TYPED AS ssrintros_ne PRINTED BY pr_ssrintros + | [ ssrintros_ne(intrs) ] -> [ intrs ] + | [ ] -> [ [], rawltacctx ] +END + +let injecteq_id = mk_internal_id "injection equation" + +let pf_nb_prod gl = nb_prod (pf_concl gl) + +let rev_id = mk_internal_id "rev concl" + +let revtoptac n0 gl = + let n = pf_nb_prod gl - n0 in + let dc, cl = decompose_prod_n n (pf_concl gl) in + let dc' = dc @ [Name rev_id, compose_prod (List.rev dc) cl] in + let f = compose_lam dc' (mkEtaApp (mkRel (n + 1)) (-n) 1) in + refine (mkApp (f, [|Evarutil.mk_new_meta ()|])) gl + +let equality_inj l b id c gl = + let msg = ref "" in + try Equality.inj l b c gl + with Compat.Loc.Exc_located(_,UserError (_,s)) | UserError (_,s) + when msg := Pp.string_of_ppcmds s; + !msg = "Not a projectable equality but a discriminable one." || + !msg = "Nothing to inject." -> + msg_warning (str !msg); + discharge_hyp (id, (id, "")) gl + +let injectidl2rtac id c gl = + tclTHEN (equality_inj [] true id c) (revtoptac (pf_nb_prod gl)) gl + +let injectl2rtac c = match kind_of_term c with +| Var id -> injectidl2rtac id (mkVar id, NoBindings) +| _ -> + let id = injecteq_id in + tclTHENLIST [havetac id c; injectidl2rtac id (mkVar id, NoBindings); clear [id]] + +let is_injection_case c gl = + let mind, _ = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in + mkInd mind = build_coq_eq () + +let perform_injection c gl = + let mind, t = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in + let dc, eqt = decompose_prod t in + if dc = [] then injectl2rtac c gl else + if not (closed0 eqt) then error "can't decompose a quantified equality" else + let cl = pf_concl gl in let n = List.length dc in + let c_eq = mkEtaApp c n 2 in + let cl1 = mkLambda (Anonymous, mkArrow eqt cl, mkApp (mkRel 1, [|c_eq|])) in + let id = injecteq_id in + let id_with_ebind = (mkVar id, NoBindings) in + let injtac = tclTHEN (introid id) (injectidl2rtac id id_with_ebind) in + tclTHENLAST (apply (compose_lam dc cl1)) injtac gl + +let simplest_newcase_ref = ref (fun t gl -> assert false) +let simplest_newcase x gl = !simplest_newcase_ref x gl + +let ssrscasetac c gl = + if is_injection_case c gl then perform_injection c gl + else simplest_newcase c gl + +let intro_all gl = + let dc, _ = Term.decompose_prod_assum (pf_concl gl) in + tclTHENLIST (List.map anontac (List.rev dc)) gl + +let rec intro_anon gl = + try anontac (List.hd (fst (Term.decompose_prod_n_assum 1 (pf_concl gl)))) gl + with err0 -> try tclTHEN red_in_concl intro_anon gl with _ -> raise err0 + (* with _ -> error "No product even after reduction" *) + +let with_top tac = + tclTHENLIST [introid top_id; tac (mkVar top_id); clear [top_id]] + +let rec mapLR f = function [] -> [] | x :: s -> let y = f x in y :: mapLR f s + +let wild_ids = ref [] + +let new_wild_id () = + let i = 1 + List.length !wild_ids in + let id = mk_wildcard_id i in + wild_ids := id :: !wild_ids; + id + +let clear_wilds wilds gl = + clear (List.filter (fun id -> List.mem id wilds) (pf_ids_of_hyps gl)) gl + +let clear_with_wilds wilds clr0 gl = + let extend_clr clr (id, _, _ as nd) = + if List.mem id clr || not (List.mem id wilds) then clr else + let vars = global_vars_set_of_decl (pf_env gl) nd in + let occurs id' = Idset.mem id' vars in + if List.exists occurs clr then id :: clr else clr in + clear (Sign.fold_named_context_reverse extend_clr ~init:clr0 (pf_hyps gl)) gl + +let tclTHENS_nonstrict tac tacl taclname gl = + let tacres = tac gl in + let n_gls = List.length (sig_it tacres) in + let n_tac = List.length tacl in + if n_gls = n_tac then tclTHENS (fun _ -> tacres) tacl gl else + if n_gls = 0 then tacres else + let pr_only n1 n2 = if n1 < n2 then str "only " else mt () in + let pr_nb n1 n2 name = + pr_only n1 n2 ++ int n1 ++ str (" " ^ plural n1 name) in + errorstrm (pr_nb n_tac n_gls taclname ++ spc () + ++ str "for " ++ pr_nb n_gls n_tac "subgoal") + +(* Forward reference to extended rewrite *) +let ipat_rewritetac = ref (fun _ -> rewritetac) + +let rec is_name_in_ipats name = function + | IpatSimpl(clr,_) :: tl -> + List.exists (function SsrHyp(_,id) -> id = name) clr + || is_name_in_ipats name tl + | IpatId id :: tl -> id = name || is_name_in_ipats name tl + | IpatCase l :: tl -> is_name_in_ipats name (List.flatten l @ tl) + | _ :: tl -> is_name_in_ipats name tl + | [] -> false + +let move_top_with_view = ref (fun _ -> assert false) + +let rec nat_of_n n = + if n = 0 then mkConstruct path_of_O + else mkApp (mkConstruct path_of_S, [|nat_of_n (n-1)|]) + +let ssr_abstract_id = ref 0 +let _ = + Summary.declare_summary "SSR:abstractid" + { Summary.freeze_function = (fun _ -> !ssr_abstract_id); + Summary.unfreeze_function = (fun x -> ssr_abstract_id := x); + Summary.init_function = (fun () -> ssr_abstract_id := 0) } + +let mk_abstract_id () = incr ssr_abstract_id; nat_of_n !ssr_abstract_id + +let ssrmkabs id gl = + let env, concl = pf_env gl, pf_concl gl in + let sigma, abstract_proof, abstract_ty = + let sigma, ty = Evarutil.new_type_evar Evd.empty env in + let sigma,lock = Evarutil.new_evar sigma env (mkSsrConst "abstract_lock") in + let abstract_ty = + mkApp(mkSsrConst "abstract", [|ty;mk_abstract_id ();lock|]) in + let sigma, m = Evarutil.new_evar sigma env abstract_ty in + sigma, m, abstract_ty in + let sigma, kont = + let rd = Name id, None, abstract_ty in + Evarutil.new_evar sigma (Environ.push_rel rd env) concl in + pp(lazy(pr_constr concl)); + let step = mkApp (mkLambda(Name id,abstract_ty,kont) ,[|abstract_proof|]) in + Refine.refine (sigma, step) gl + +let ssrmkabstac ids = + List.fold_right (fun id tac -> tclTHENFIRST (ssrmkabs id) tac) ids tclIDTAC + +(* introstac: for "move" and "clear", tclEQINTROS: for "case" and "elim" *) +(* This block hides the spaghetti-code needed to implement the only two *) +(* tactics that should be used to process intro patters. *) +(* The difficulty is that we don't want to always rename, but we can *) +(* compute needeed renamings only at runtime, so we theread a tree like *) +(* imperativestructure so that outer renamigs are inherited by inner *) +(* ipts and that the cler performed at the end of ipatstac clears hyps *) +(* eventually renamed at runtime. *) +(* TODO: hide wild_ids in this block too *) +let introstac, tclEQINTROS = + let rec map_acc_k f k = function + | [] -> (* tricky: we save wilds now, we get to_cler (aka k) later *) + let clear_ww = clear_with_wilds !wild_ids in + [fun gl -> clear_ww (hyps_ids (List.flatten (List.map (!) k))) gl] + | x :: xs -> let k, x = f k xs x in x :: map_acc_k f k xs in + let rename force to_clr rest clr gl = + let hyps = pf_hyps gl in + pp(lazy(str"rename " ++ pr_clear spc clr)); + let () = if not force then List.iter (check_hyp_exists hyps) clr in + if List.exists (fun x -> force || is_name_in_ipats (hyp_id x) rest) clr then + let ren_clr, ren = + List.split (List.map (fun x -> let x = hyp_id x in + let x' = mk_anon_id (string_of_id x) gl in + SsrHyp (dummy_loc, x'), (x, x')) clr) in + let () = to_clr := ren_clr in + rename_hyp ren gl + else + let () = to_clr := clr in + tclIDTAC gl in + let rec ipattac ?ist k rest = function + | IpatWild -> k, introid (new_wild_id ()) + | IpatCase iorpat -> k, tclIORPAT ?ist k (with_top ssrscasetac) iorpat + | IpatRw (occ, dir) -> k, with_top (!ipat_rewritetac occ dir) + | IpatId id -> k, introid id + | IpatNewHidden idl -> k, ssrmkabstac idl + | IpatSimpl (clr, sim) -> + let to_clr = ref [] in + to_clr :: k, tclTHEN (rename false to_clr rest clr) (simpltac sim) + | IpatAll -> k, intro_all + | IpatAnon -> k, intro_anon + | IpatNoop -> k, tclIDTAC + | IpatView v -> match ist with + | None -> anomaly "ipattac with no ist but view" + | Some ist -> match rest with + | (IpatCase _ | IpatRw _)::_ -> + let to_clr = ref [] in let top_id = ref top_id in + to_clr :: k, + tclTHEN + (!move_top_with_view false top_id (false,v) ist) + (fun gl -> + rename true to_clr rest [SsrHyp (dummy_loc, !top_id)]gl) + | _ -> k, !move_top_with_view true (ref top_id) (true,v) ist + and tclIORPAT ?ist k tac = function + | [[]] -> tac + | orp -> + tclTHENS_nonstrict tac (mapLR (ipatstac ?ist k) orp) "intro pattern" + and ipatstac ?ist k ipats = + tclTHENLIST (map_acc_k (ipattac ?ist) k ipats) in + let introstac ?ist ipats = + wild_ids := []; + let tac = ipatstac ?ist [] ipats in + tclTHENLIST [tac; clear_wilds !wild_ids] in + let tclEQINTROS ?ist tac eqtac ipats = + wild_ids := []; + let rec split_itacs to_clr tac' = function + | (IpatSimpl _ as spat) :: ipats' -> + let to_clr, tac = ipattac ?ist to_clr ipats' spat in + split_itacs to_clr (tclTHEN tac' tac) ipats' + | IpatCase iorpat :: ipats' -> + to_clr, tclIORPAT ?ist to_clr tac' iorpat, ipats' + | ipats' -> to_clr, tac', ipats' in + let to_clr, tac1, ipats' = split_itacs [] tac ipats in + let tac2 = ipatstac ?ist to_clr ipats' in + tclTHENLIST [tac1; eqtac; tac2; clear_wilds !wild_ids] in + introstac, tclEQINTROS +;; + +let rec eqmoveipats eqpat = function + | (IpatSimpl _ as ipat) :: ipats -> ipat :: eqmoveipats eqpat ipats + | (IpatAll :: _ | []) as ipats -> IpatAnon :: eqpat :: ipats + | ipat :: ipats -> ipat :: eqpat :: ipats + +(* General case *) +let tclINTROS tac (ipats, ctx) = + let ist = get_ltacctx ctx in + tclEQINTROS ~ist (tac ist) tclIDTAC ipats + +(** The "=>" tactical *) + +let ssrintros_sep = + let atom_sep = function + | TacSplit (_,_, [NoBindings]) -> mt + | TacLeft (_, NoBindings) -> mt + | TacRight (_, NoBindings) -> mt + (* | TacExtend (_, "ssrapply", []) -> mt *) + | _ -> spc in + function + | TacId [] -> mt + | TacArg (_, Tacexp _) -> mt + | TacArg (_, Reference _) -> mt + | TacAtom (_, atom) -> atom_sep atom + | _ -> spc + +let pr_ssrintrosarg _ _ prt (tac, ipats) = + prt tacltop tac ++ pr_intros (ssrintros_sep tac) ipats + +ARGUMENT EXTEND ssrintrosarg TYPED AS tactic * ssrintros + PRINTED BY pr_ssrintrosarg +| [ "Qed" ssrtacarg(arg) ssrintros_ne(ipats) ] -> [ arg, ipats ] +END + +TACTIC EXTEND ssrtclintros +| [ "Qed" ssrintrosarg(arg) ] -> + [ let tac, intros = arg in + tclINTROS (fun ist -> ssrevaltac ist tac) intros ] +END +set_pr_ssrtac "tclintros" 0 [ArgSsr "introsarg"] + +let tclintros_expr loc tac ipats = + let args = [in_gen rawwit_ssrintrosarg (tac, ipats)] in + ssrtac_expr loc "tclintros" args + +GEXTEND Gram + GLOBAL: tactic_expr; + tactic_expr: LEVEL "1" [ RIGHTA + [ tac = tactic_expr; intros = ssrintros_ne -> tclintros_expr loc tac intros + ] ]; +END +(* }}} *) + +(** Multipliers {{{ ***********************************************************) + +(* modality *) + +type ssrmmod = May | Must | Once + +let pr_mmod = function May -> str "?" | Must -> str "!" | Once -> mt () + +let wit_ssrmmod, globwit_ssrmmod, rawwit_ssrmmod = add_genarg "ssrmmod" pr_mmod +let ssrmmod = Gram.Entry.create "ssrmmod" +GEXTEND Gram + GLOBAL: ssrmmod; + ssrmmod: [[ "!" -> Must | LEFTQMARK -> May | "?" -> May]]; +END + +(* tactical *) + +let tclID tac = tac + +let tclDOTRY n tac = + if n <= 0 then tclIDTAC else + let rec loop i gl = + if i = n then tclTRY tac gl else + tclTRY (tclTHEN tac (loop (i + 1))) gl in + loop 1 + +let tclDO n tac = + let prefix i = str"At iteration " ++ int i ++ str": " in + let tac_err_at i gl = + try tac gl + with + | UserError (l, s) -> raise (UserError (l, prefix i ++ s)) + | Compat.Loc.Exc_located(loc, UserError (l, s)) -> + raise (Compat.Loc.Exc_located(loc, UserError (l, prefix i ++ s))) in + let rec loop i gl = + if i = n then tac_err_at i gl else + (tclTHEN (tac_err_at i) (loop (i + 1))) gl in + loop 1 + +let tclMULT = function + | 0, May -> tclREPEAT + | 1, May -> tclTRY + | n, May -> tclDOTRY n + | 0, Must -> tclAT_LEAST_ONCE + | n, Must when n > 1 -> tclDO n + | _ -> tclID + +(** The "do" tactical. ********************************************************) + +(* +type ssrdoarg = ((ssrindex * ssrmmod) * (ssrhint * ltacctx)) * ssrclauses +*) + +let pr_ssrdoarg prc _ prt (((n, m), (tac, _)), clauses) = + pr_index n ++ pr_mmod m ++ pr_hintarg prt tac ++ pr_clauses clauses + +ARGUMENT EXTEND ssrdoarg + TYPED AS ((ssrindex * ssrmmod) * (ssrhintarg * ltacctx)) * ssrclauses + PRINTED BY pr_ssrdoarg +| [ "Qed" ] -> [ anomaly "Grammar placeholder match" ] +END + +let ssrdotac (((n, m), (tac, ctx)), clauses) = + let mul = get_index n, m in + let ist = get_ltacctx ctx in + tclCLAUSES ist (tclMULT mul (hinttac ist false tac)) clauses + +TACTIC EXTEND ssrtcldo +| [ "Qed" "do" ssrdoarg(arg) ] -> [ ssrdotac arg ] +END +set_pr_ssrtac "tcldo" 3 [ArgSep "do "; ArgSsr "doarg"] + +let ssrdotac_expr loc n m tac clauses = + let arg = ((n, m), (tac, rawltacctx)), clauses in + ssrtac_expr loc "tcldo" [in_gen rawwit_ssrdoarg arg] + +GEXTEND Gram + GLOBAL: tactic_expr; + ssrdotac: [ + [ tac = tactic_expr LEVEL "3" -> mk_hint tac + | tacs = ssrortacarg -> tacs + ] ]; + tactic_expr: LEVEL "3" [ RIGHTA + [ IDENT "do"; m = ssrmmod; tac = ssrdotac; clauses = ssrclauses -> + ssrdotac_expr loc noindex m tac clauses + | IDENT "do"; tac = ssrortacarg; clauses = ssrclauses -> + ssrdotac_expr loc noindex Once tac clauses + | IDENT "do"; n = int_or_var; m = ssrmmod; + tac = ssrdotac; clauses = ssrclauses -> + ssrdotac_expr loc (mk_index loc n) m tac clauses + ] ]; +END +(* }}} *) + +(** The "first" and "last" tacticals. {{{ *************************************) + +(* type ssrseqarg = ssrindex * (ssrtacarg * ssrtac option) *) + +let pr_seqtacarg prt = function + | (is_first, []), _ -> str (if is_first then "first" else "last") + | tac, Some dtac -> + hv 0 (pr_hintarg prt tac ++ spc() ++ str "|| " ++ prt tacltop dtac) + | tac, _ -> pr_hintarg prt tac + +let pr_ssrseqarg _ _ prt = function + | ArgArg 0, tac -> pr_seqtacarg prt tac + | i, tac -> pr_index i ++ str " " ++ pr_seqtacarg prt tac + +(* We must parse the index separately to resolve the conflict with *) +(* an unindexed tactic. *) +ARGUMENT EXTEND ssrseqarg TYPED AS ssrindex * (ssrhintarg * tactic option) + PRINTED BY pr_ssrseqarg +| [ "Qed" ] -> [ anomaly "Grammar placeholder match" ] +END + +let sq_brace_tacnames = + ["first"; "solve"; "do"; "rewrite"; "have"; "suffices"; "wlog"] + (* "by" is a keyword *) +let accept_ssrseqvar strm = + match Compat.get_tok (stream_nth 0 strm) with + | Tok.IDENT id when not (List.mem id sq_brace_tacnames) -> + accept_before_syms_or_ids ["["] ["first";"last"] strm + | _ -> raise Stream.Failure + +let test_ssrseqvar = Gram.Entry.of_parser "test_ssrseqvar" accept_ssrseqvar + +let swaptacarg (loc, b) = (b, []), Some (TacAtom (loc, TacRevert [])) + +let check_seqtacarg dir arg = match snd arg, dir with + | ((true, []), Some (TacAtom (loc, _))), L2R -> + loc_error loc "expected \"last\"" + | ((false, []), Some (TacAtom (loc, _))), R2L -> + loc_error loc "expected \"first\"" + | _, _ -> arg + +let ssrorelse = Gram.Entry.create "ssrorelse" +GEXTEND Gram + GLOBAL: ssrorelse ssrseqarg; + ssrseqidx: [ + [ test_ssrseqvar; id = Prim.ident -> ArgVar (loc, id) + | n = Prim.natural -> ArgArg (check_index loc n) + ] ]; + ssrswap: [[ IDENT "first" -> loc, true | IDENT "last" -> loc, false ]]; + ssrorelse: [[ "||"; tac = tactic_expr LEVEL "2" -> tac ]]; + ssrseqarg: [ + [ arg = ssrswap -> noindex, swaptacarg arg + | i = ssrseqidx; tac = ssrortacarg; def = OPT ssrorelse -> i, (tac, def) + | i = ssrseqidx; arg = ssrswap -> i, swaptacarg arg + | tac = tactic_expr LEVEL "3" -> noindex, (mk_hint tac, None) + ] ]; +END + +let tclPERM perm tac gls = + let subgls = tac gls in + let sigma, subgll = Refiner.unpackage subgls in + let subgll' = perm subgll in + Refiner.repackage sigma subgll' +(* +let tclPERM perm tac gls = + let mkpft n g r = + {Proof_type.open_subgoals = n; Proof_type.goal = g; Proof_type.ref = r} in + let mkleaf g = mkpft 0 g None in + let mkprpft n g pr a = mkpft n g (Some (Proof_type.Prim pr, a)) in + let mkrpft n g c = mkprpft n g (Proof_type.Refine c) in + let mkipft n g = + let mki pft (id, _, _ as d) = + let g' = {g with evar_concl = mkNamedProd_or_LetIn d g.evar_concl} in + mkprpft n g' (Proof_type.Intro id) [pft] in + List.fold_left mki in + let gl = Refiner.sig_it gls in + let mkhyp subgl = + let rec chop_section = function + | (x, _, _ as d) :: e when not_section_id x -> d :: chop_section e + | _ -> [] in + let lhyps = Environ.named_context_of_val subgl.evar_hyps in + mk_perm_id (), subgl, chop_section lhyps in + let mkpfvar (hyp, subgl, lhyps) = + let mkarg args (lhyp, body, _) = + if body = None then mkVar lhyp :: args else args in + mkrpft 0 subgl (applist (mkVar hyp, List.fold_left mkarg [] lhyps)) [] in + let mkpfleaf (_, subgl, lhyps) = mkipft 1 gl (mkleaf subgl) lhyps in + let mkmeta _ = Evarutil.mk_new_meta () in + let mkhypdecl (hyp, subgl, lhyps) = + hyp, None, it_mkNamedProd_or_LetIn subgl.evar_concl lhyps in + let subgls, v as res0 = tac gls in + let sigma, subgll = Refiner.unpackage subgls in + let n = List.length subgll in if n = 0 then res0 else + let hyps = List.map mkhyp subgll in + let hyp_decls = List.map mkhypdecl (List.rev (perm hyps)) in + let c = applist (mkmeta (), List.map mkmeta subgll) in + let pft0 = mkipft 0 gl (v (List.map mkpfvar hyps)) hyp_decls in + let pft1 = mkrpft n gl c (pft0 :: List.map mkpfleaf (perm hyps)) in + let subgll', v' = Refiner.frontier pft1 in + Refiner.repackage sigma subgll', v' +*) + +let tclREV tac gl = tclPERM List.rev tac gl + +let rot_hyps dir i hyps = + let n = List.length hyps in + if i = 0 then List.rev hyps else + if i > n then error "Not enough subgoals" else + let rec rot i l_hyps = function + | hyp :: hyps' when i > 0 -> rot (i - 1) (hyp :: l_hyps) hyps' + | hyps' -> hyps' @ (List.rev l_hyps) in + rot (match dir with L2R -> i | R2L -> n - i) [] hyps + +let tclSEQAT (atac1, ctx) dir (ivar, ((_, atacs2), atac3)) = + let i = get_index ivar in + let evtac = ssrevaltac (get_ltacctx ctx) in + let tac1 = evtac atac1 in + if atacs2 = [] && atac3 <> None then tclPERM (rot_hyps dir i) tac1 else + let evotac = function Some atac -> evtac atac | _ -> tclIDTAC in + let tac3 = evotac atac3 in + let rec mk_pad n = if n > 0 then tac3 :: mk_pad (n - 1) else [] in + match dir, mk_pad (i - 1), List.map evotac atacs2 with + | L2R, [], [tac2] when atac3 = None -> tclTHENFIRST tac1 tac2 + | L2R, [], [tac2] when atac3 = None -> tclTHENLAST tac1 tac2 + | L2R, pad, tacs2 -> tclTHENSFIRSTn tac1 (Array.of_list (pad @ tacs2)) tac3 + | R2L, pad, tacs2 -> tclTHENSLASTn tac1 tac3 (Array.of_list (tacs2 @ pad)) + +(* We can't actually parse the direction separately because this *) +(* would introduce conflicts with the basic ltac syntax. *) +let pr_ssrseqdir _ _ _ = function + | L2R -> str ";" ++ spc () ++ str "first " + | R2L -> str ";" ++ spc () ++ str "last " + +ARGUMENT EXTEND ssrseqdir TYPED AS ssrdir PRINTED BY pr_ssrseqdir +| [ "Qed" ] -> [ anomaly "Grammar placeholder match" ] +END + +TACTIC EXTEND ssrtclseq +| [ "Qed" ssrtclarg(tac) ssrseqdir(dir) ssrseqarg(arg) ] -> + [ tclSEQAT tac dir arg ] +END +set_pr_ssrtac "tclseq" 5 [ArgSsr "tclarg"; ArgSsr "seqdir"; ArgSsr "seqarg"] + +let tclseq_expr loc tac dir arg = + let arg1 = in_gen rawwit_ssrtclarg (tac, rawltacctx) in + let arg2 = in_gen rawwit_ssrseqdir dir in + let arg3 = in_gen rawwit_ssrseqarg (check_seqtacarg dir arg) in + ssrtac_expr loc "tclseq" [arg1; arg2; arg3] + +GEXTEND Gram + GLOBAL: tactic_expr; + ssr_first: [ + [ tac = ssr_first; ipats = ssrintros_ne -> tclintros_expr loc tac ipats + | "["; tacl = LIST0 tactic_expr SEP "|"; "]" -> TacFirst tacl + ] ]; + ssr_first_else: [ + [ tac1 = ssr_first; tac2 = ssrorelse -> TacOrelse (tac1, tac2) + | tac = ssr_first -> tac ]]; + tactic_expr: LEVEL "4" [ LEFTA + [ tac1 = tactic_expr; ";"; IDENT "first"; tac2 = ssr_first_else -> + TacThen (tac1,[||], tac2,[||]) + | tac = tactic_expr; ";"; IDENT "first"; arg = ssrseqarg -> + tclseq_expr loc tac L2R arg + | tac = tactic_expr; ";"; IDENT "last"; arg = ssrseqarg -> + tclseq_expr loc tac R2L arg + ] ]; +END +(* }}} *) + +(** 5. Bookkeeping tactics (clear, move, case, elim) *) + +(* post-interpretation of terms *) +let all_ok _ _ = true + +let pf_abs_ssrterm ?(resolve_typeclasses=false) ist gl t = + let sigma, ct as t = interp_term ist gl t in + let sigma, _ as t = + let env = pf_env gl in + if not resolve_typeclasses then t + else + let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in + sigma, Evarutil.nf_evar sigma ct in + let n, c, abstracted_away = pf_abs_evars gl t in + List.fold_left Evd.remove sigma abstracted_away, pf_abs_cterm gl n c + +let pf_interp_ty ?(resolve_typeclasses=false) ist gl ty = + let n_binders = ref 0 in + let ty = match ty with + | a, (t, None) -> + let rec force_type = function + | GProd (l, x, k, s, t) -> incr n_binders; GProd (l, x, k, s, force_type t) + | GLetIn (l, x, v, t) -> incr n_binders; GLetIn (l, x, v, force_type t) + | ty -> mkRCast ty mkRType in + a, (force_type t, None) + | _, (_, Some ty) -> + let rec force_type = function + | CProdN (l, abs, t) -> + n_binders := !n_binders + List.length (List.flatten (List.map pi1 abs)); + CProdN (l, abs, force_type t) + | CLetIn (l, n, v, t) -> incr n_binders; CLetIn (l, n, v, force_type t) + | ty -> mkCCast dummy_loc ty (mkCType dummy_loc) in + mk_term ' ' (force_type ty) in + let strip_cast (sigma, t) = + let rec aux t = match kind_of_type t with + | CastType (t, ty) when !n_binders = 0 && isSort ty -> t + | ProdType(n,s,t) -> decr n_binders; mkProd (n, s, aux t) + | LetInType(n,v,ty,t) -> decr n_binders; mkLetIn (n, v, ty, aux t) + | _ -> anomaly "pf_interp_ty: ssr Type cast deleted by typecheck" in + sigma, aux t in + let sigma, cty as ty = strip_cast (interp_term ist gl ty) in + let ty = + let env = pf_env gl in + if not resolve_typeclasses then ty + else + let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in + sigma, Evarutil.nf_evar sigma cty in + let n, c, _ = pf_abs_evars gl ty in + let lam_c = pf_abs_cterm gl n c in + let ctx, c = decompose_lam_n n lam_c in + n, compose_prod ctx c, lam_c +;; + +let whd_app f args = Reductionops.whd_betaiota Evd.empty (mkApp (f, args)) + +let pr_cargs a = + str "[" ++ pr_list pr_spc pr_constr (Array.to_list a) ++ str "]" + +let pp_term gl t = + let t = Reductionops.nf_evar (project gl) t in pr_constr t +let pp_concat hd ?(sep=str", ") = function [] -> hd | x :: xs -> + hd ++ List.fold_left (fun acc x -> acc ++ sep ++ x) x xs + +let fake_pmatcher_end () = mkProp, L2R, (Evd.empty, mkProp) + +(* TASSI: given (c : ty), generates (c ??? : ty[???/...]) with m evars *) +exception NotEnoughProducts +let prof_saturate_whd = mk_profiler "saturate.whd";; +let saturate ?(beta=false) ?(bi_types=false) env sigma c ?(ty=Retyping.get_type_of env sigma c) m += + let rec loop ty args sigma n = + if n = 0 then + let args = List.rev args in + (if beta then Reductionops.whd_beta sigma else fun x -> x) + (mkApp (c, Array.of_list (List.map snd args))), ty, args, sigma + else match kind_of_type ty with + | ProdType (_, src, tgt) -> + let sigma, x = + Evarutil.new_evar (create_evar_defs sigma) env + (if bi_types then Reductionops.nf_betaiota sigma src else src) in + loop (subst1 x tgt) ((m - n,x) :: args) sigma (n-1) + | CastType (t, _) -> loop t args sigma n + | LetInType (_, v, _, t) -> loop (subst1 v t) args sigma n + | SortType _ -> assert false + | AtomicType _ -> + let ty = + prof_saturate_whd.profile + (Reductionops.whd_betadeltaiota env sigma) ty in + match kind_of_type ty with + | ProdType _ -> loop ty args sigma n + | _ -> anomaly "saturate did not find enough products" + in + loop ty [] sigma m + +let pf_saturate ?beta ?bi_types gl c ?ty m = + let env, sigma, si = pf_env gl, project gl, sig_it gl in + let t, ty, args, sigma = saturate ?beta ?bi_types env sigma c ?ty m in + t, ty, args, re_sig si sigma + +(** Rewrite redex switch *) + +(** Generalization (discharge) item *) + +(* An item is a switch + term pair. *) + +(* type ssrgen = ssrdocc * ssrterm *) + +let pr_gen (docc, dt) = pr_docc docc ++ pr_cpattern dt + +let pr_ssrgen _ _ _ = pr_gen + +ARGUMENT EXTEND ssrgen TYPED AS ssrdocc * cpattern PRINTED BY pr_ssrgen +| [ ssrdocc(docc) cpattern(dt) ] -> [ docc, dt ] +| [ cpattern(dt) ] -> [ nodocc, dt ] +END + +let has_occ ((_, occ), _) = occ <> None +let hyp_of_var v = SsrHyp (dummy_loc, destVar v) + +let interp_clr = function +| Some clr, (k, c) + when (k = ' ' || k = '@') && is_pf_var c -> hyp_of_var c :: clr +| Some clr, _ -> clr +| None, _ -> [] + +(* XXX the k of the redex should percolate out *) +let pf_interp_gen_aux ist gl to_ind ((oclr, occ), t) = + let pat = interp_cpattern ist gl t None in (* UGLY API *) + let cl, env, sigma = pf_concl gl, pf_env gl, project gl in + let c = redex_of_pattern env pat in + let c, cl = + try fill_occ_pattern ~raise_NoMatch:true env sigma cl pat occ 1 + with NoMatch -> c, cl in + let clr = interp_clr (oclr, (tag_of_cpattern t, c)) in + if not(occur_existential c) then + if tag_of_cpattern t = '@' then + if not (isVar c) then errorstrm (str "@ can be used with variables only") + else match pf_get_hyp gl (destVar c) with + | _, None, _ -> errorstrm (str "@ can be used with let-ins only") + | name, Some bo, ty -> true, pat, mkLetIn (Name name, bo, ty, cl), c, clr + else false, pat, pf_mkprod gl c cl, c, clr + else if to_ind && occ = None then + let nv, p, _ = pf_abs_evars gl (fst pat, c) in + if nv = 0 then anomaly "occur_existential but no evars" else + false, pat, mkProd (constr_name c, pf_type_of gl p, pf_concl gl), p, clr + else loc_error (loc_of_cpattern t) "generalized term didn't match" + +let genclrtac cl cs clr = + let tclmyORELSE tac1 tac2 gl = + try tac1 gl + with e when Errors.noncritical e -> tac2 e gl in + (* apply_type may give a type error, but the useful message is + * the one of clear. You type "move: x" and you get + * "x is used in hyp H" instead of + * "The term H has type T x but is expected to have type T x0". *) + tclTHEN + (tclmyORELSE + (apply_type cl cs) + (fun type_err gl -> + tclTHEN + (tclTHEN (elim_type (build_coq_False ())) (cleartac clr)) + (fun gl -> raise type_err) + gl)) + (cleartac clr) + +let gentac ist gen gl = + let conv, _, cl, c, clr = pf_interp_gen_aux ist gl false gen in + if conv then tclTHEN (convert_concl cl) (cleartac clr) gl + else genclrtac cl [c] clr gl + +let pf_interp_gen ist gl to_ind gen = + let _, _, a, b ,c = pf_interp_gen_aux ist gl to_ind gen in a, b ,c + +(** Generalization (discharge) sequence *) + +(* A discharge sequence is represented as a list of up to two *) +(* lists of d-items, plus an ident list set (the possibly empty *) +(* final clear switch). The main list is empty iff the command *) +(* is defective, and has length two if there is a sequence of *) +(* dependent terms (and in that case it is the first of the two *) +(* lists). Thus, the first of the two lists is never empty. *) + +(* type ssrgens = ssrgen list *) +(* type ssrdgens = ssrgens list * ssrclear *) + +let gens_sep = function [], [] -> mt | _ -> spc + +let pr_dgens pr_gen (gensl, clr) = + let prgens s gens = str s ++ pr_list spc pr_gen gens in + let prdeps deps = prgens ": " deps ++ spc () ++ str "/" in + match gensl with + | [deps; []] -> prdeps deps ++ pr_clear pr_spc clr + | [deps; gens] -> prdeps deps ++ prgens " " gens ++ pr_clear spc clr + | [gens] -> prgens ": " gens ++ pr_clear spc clr + | _ -> pr_clear pr_spc clr + +let pr_ssrdgens _ _ _ = pr_dgens pr_gen + +let cons_gen gen = function + | gens :: gensl, clr -> (gen :: gens) :: gensl, clr + | _ -> anomaly "missing gen list" + +let cons_dep (gensl, clr) = + if List.length gensl = 1 then ([] :: gensl, clr) else + error "multiple dependents switches '/'" + +ARGUMENT EXTEND ssrdgens_tl TYPED AS ssrgen list list * ssrclear + PRINTED BY pr_ssrdgens +| [ "{" ne_ssrhyp_list(clr) "}" cpattern(dt) ssrdgens_tl(dgens) ] -> + [ cons_gen (mkclr clr, dt) dgens ] +| [ "{" ne_ssrhyp_list(clr) "}" ] -> + [ [[]], clr ] +| [ "{" ssrocc(occ) "}" cpattern(dt) ssrdgens_tl(dgens) ] -> + [ cons_gen (mkocc occ, dt) dgens ] +| [ "/" ssrdgens_tl(dgens) ] -> + [ cons_dep dgens ] +| [ cpattern(dt) ssrdgens_tl(dgens) ] -> + [ cons_gen (nodocc, dt) dgens ] +| [ ] -> + [ [[]], [] ] +END + +ARGUMENT EXTEND ssrdgens TYPED AS ssrdgens_tl PRINTED BY pr_ssrdgens +| [ ":" ssrgen(gen) ssrdgens_tl(dgens) ] -> [ cons_gen gen dgens ] +END + +let genstac (gens, clr) ist = + tclTHENLIST (cleartac clr :: List.rev_map (gentac ist) gens) + +(* Common code to handle generalization lists along with the defective case *) + +let with_defective maintac deps clr ist gl = + let top_id = + match kind_of_type (pf_concl gl) with + | ProdType (Name id, _, _) + when has_discharged_tag (string_of_id id) -> id + | _ -> top_id in + let top_gen = mkclr clr, cpattern_of_id top_id in + tclTHEN (introid top_id) (maintac deps top_gen ist) gl + +let with_dgens (gensl, clr) maintac ist = match gensl with + | [deps; []] -> with_defective maintac deps clr ist + | [deps; gen :: gens] -> + tclTHEN (genstac (gens, clr) ist) (maintac deps gen ist) + | [gen :: gens] -> tclTHEN (genstac (gens, clr) ist) (maintac [] gen ist) + | _ -> with_defective maintac [] clr ist + +let with_deps deps0 maintac cl0 cs0 clr0 ist gl0 = + let rec loop gl cl cs clr args clrs = function + | [] -> + let n = List.length args in + maintac (if n > 0 then applist (to_lambda n cl, args) else cl) clrs ist gl0 + | dep :: deps -> + let gl' = first_goal (genclrtac cl cs clr gl) in + let cl', c', clr' = pf_interp_gen ist gl' false dep in + loop gl' cl' [c'] clr' (c' :: args) (clr' :: clrs) deps in + loop gl0 cl0 cs0 clr0 cs0 [clr0] (List.rev deps0) + +(** Equations *) + +(* argument *) + +type ssreqid = ssripat option + +let pr_eqid = function Some pat -> str " " ++ pr_ipat pat | None -> mt () +let pr_ssreqid _ _ _ = pr_eqid + +(* We must use primitive parsing here to avoid conflicts with the *) +(* basic move, case, and elim tactics. *) +ARGUMENT EXTEND ssreqid TYPED AS ssripatrep option PRINTED BY pr_ssreqid +| [ "Qed" ] -> [ Util.anomaly "Grammar placeholder match" ] +END + +let accept_ssreqid strm = + match Compat.get_tok (Util.stream_nth 0 strm) with + | Tok.IDENT _ -> accept_before_syms [":"] strm + | Tok.KEYWORD ":" -> () + | Tok.KEYWORD pat when List.mem pat ["_"; "?"; "->"; "<-"] -> + accept_before_syms [":"] strm + | _ -> raise Stream.Failure + +let test_ssreqid = Gram.Entry.of_parser "test_ssreqid" accept_ssreqid + +GEXTEND Gram + GLOBAL: ssreqid; + ssreqpat: [ + [ id = Prim.ident -> IpatId id + | "_" -> IpatWild + | "?" -> IpatAnon + | occ = ssrdocc; "->" -> (match occ with + | None, occ -> IpatRw (occ, L2R) + | _ -> loc_error loc "Only occurrences are allowed here") + | occ = ssrdocc; "<-" -> (match occ with + | None, occ -> IpatRw (occ, R2L) + | _ -> loc_error loc "Only occurrences are allowed here") + | "->" -> IpatRw (allocc, L2R) + | "<-" -> IpatRw (allocc, R2L) + ]]; + ssreqid: [ + [ test_ssreqid; pat = ssreqpat -> Some pat + | test_ssreqid -> None + ]]; +END + +(* creation *) + +let mkEq dir cl c t n = + let eqargs = [|t; c; c|] in eqargs.(dir_org dir) <- mkRel n; + mkArrow (mkApp (build_coq_eq(), eqargs)) (lift 1 cl), mkRefl t c + +let pushmoveeqtac cl c = + let x, t, cl1 = destProd cl in + let cl2, eqc = mkEq R2L cl1 c t 1 in + apply_type (mkProd (x, t, cl2)) [c; eqc] + +let pushcaseeqtac cl gl = + let cl1, args = destApplication cl in + let n = Array.length args in + let dc, cl2 = decompose_lam_n n cl1 in + let _, t = List.nth dc (n - 1) in + let cl3, eqc = mkEq R2L cl2 args.(0) t n in + let cl4 = mkApp (compose_lam dc (mkProt (pf_type_of gl cl) cl3), args) in + tclTHEN (apply_type cl4 [eqc]) (convert_concl cl4) gl + +let pushelimeqtac gl = + let _, args = destApplication (pf_concl gl) in + let x, t, _ = destLambda args.(1) in + let cl1 = mkApp (args.(1), Array.sub args 2 (Array.length args - 2)) in + let cl2, eqc = mkEq L2R cl1 args.(2) t 1 in + tclTHEN (apply_type (mkProd (x, t, cl2)) [args.(2); eqc]) intro gl + +(** Bookkeeping (discharge-intro) argument *) + +(* Since all bookkeeping ssr commands have the same discharge-intro *) +(* argument format we use a single grammar entry point to parse them. *) +(* the entry point parses only non-empty arguments to avoid conflicts *) +(* with the basic Coq tactics. *) + +(* type ssrarg = ssrview * (ssreqid * (ssrdgens * ssripats)) *) + +let pr_ssrarg _ _ _ (view, (eqid, (dgens, ipats))) = + let pri = pr_intros (gens_sep dgens) in + pr_view view ++ pr_eqid eqid ++ pr_dgens pr_gen dgens ++ pri ipats + +ARGUMENT EXTEND ssrarg TYPED AS ssrview * (ssreqid * (ssrdgens * ssrintros)) + PRINTED BY pr_ssrarg +| [ ssrview(view) ssreqid(eqid) ssrdgens(dgens) ssrintros(ipats) ] -> + [ view, (eqid, (dgens, ipats)) ] +| [ ssrview(view) ssrclear(clr) ssrintros(ipats) ] -> + [ view, (None, (([], clr), ipats)) ] +| [ ssreqid(eqid) ssrdgens(dgens) ssrintros(ipats) ] -> + [ [], (eqid, (dgens, ipats)) ] +| [ ssrclear_ne(clr) ssrintros(ipats) ] -> + [ [], (None, (([], clr), ipats)) ] +| [ ssrintros_ne(ipats) ] -> + [ [], (None, (([], []), ipats)) ] +END + +(** The "clear" tactic *) + +(* We just add a numeric version that clears the n top assumptions. *) + +let poptac ?ist n = introstac ?ist (list_tabulate (fun _ -> IpatWild) n) + +TACTIC EXTEND ssrclear + | [ "clear" natural(n) ltacctx(ctx) ] -> [poptac ~ist:(get_ltacctx ctx) n] +END + +(** The "move" tactic *) + +let rec improper_intros = function + | IpatSimpl _ :: ipats -> improper_intros ipats + | (IpatId _ | IpatAnon | IpatCase _ | IpatAll) :: _ -> false + | _ -> true + +let check_movearg = function + | view, (eqid, _) when view <> [] && eqid <> None -> + Util.error "incompatible view and equation in move tactic" + | view, (_, (([gen :: _], _), _)) when view <> [] && has_occ gen -> + Util.error "incompatible view and occurrence switch in move tactic" + | _, (_, ((dgens, _), _)) when List.length dgens > 1 -> + Util.error "dependents switch `/' in move tactic" + | _, (eqid, (_, (ipats, _))) when eqid <> None && improper_intros ipats -> + Util.error "no proper intro pattern for equation in move tactic" + | arg -> arg + +ARGUMENT EXTEND ssrmovearg TYPED AS ssrarg PRINTED BY pr_ssrarg +| [ ssrarg(arg) ] -> [ check_movearg arg ] +END + +let viewmovetac_aux clear name_ref (_, vl as v) _ gen ist gl = + let cl, c, clr = pf_interp_gen ist gl false gen in + let cl, c = if vl = [] then cl, c else pf_with_view ist gl v cl c in + let clr = if clear then clr else [] in + name_ref := (match id_of_cpattern (snd gen) with Some id -> id | _ -> top_id); + genclrtac cl [c] clr gl + +let () = move_top_with_view := + (fun c r v -> with_defective (viewmovetac_aux c r v) [] []) + +let viewmovetac v deps gen ist gl = + viewmovetac_aux true (ref top_id) v deps gen ist gl + +let eqmovetac _ gen ist gl = + let cl, c, _ = pf_interp_gen ist gl false gen in pushmoveeqtac cl c gl + +let movehnftac gl = match kind_of_term (pf_concl gl) with + | Prod _ | LetIn _ -> tclIDTAC gl + | _ -> hnf_in_concl gl + +let ssrmovetac ist = function + | _::_ as view, (_, (dgens, (ipats, _))) -> + let dgentac = with_dgens dgens (viewmovetac (true, view)) ist in + tclTHEN dgentac (introstac ~ist ipats) + | _, (Some pat, (dgens, (ipats, _))) -> + let dgentac = with_dgens dgens eqmovetac ist in + tclTHEN dgentac (introstac ~ist (eqmoveipats pat ipats)) + | _, (_, (([gens], clr), (ipats, _))) -> + let gentac = genstac (gens, clr) ist in + tclTHEN gentac (introstac ~ist ipats) + | _, (_, ((_, clr), (ipats, _))) -> + tclTHENLIST [movehnftac; cleartac clr; introstac ~ist ipats] + +let ist_of_arg (_, (_, (_, (_, ctx)))) = get_ltacctx ctx + +TACTIC EXTEND ssrmove +| [ "move" ssrmovearg(arg) ssrrpat(pat) ] -> + [ let ist = ist_of_arg arg in + tclTHEN (ssrmovetac ist arg) (introstac ~ist [pat]) ] +| [ "move" ssrmovearg(arg) ssrclauses(clauses) ] -> + [ let ist = ist_of_arg arg in tclCLAUSES ist (ssrmovetac ist arg) clauses ] +| [ "move" ssrrpat(pat) ltacctx(ctx) ] -> + [ introstac ~ist:(get_ltacctx ctx) [pat] ] +| [ "move" ] -> [ movehnftac ] +END + +(* TASSI: given the type of an elimination principle, it finds the higher order + * argument (index), it computes it's arity and the arity of the eliminator and + * checks if the eliminator is recursive or not *) +let analyze_eliminator elimty env sigma = + let rec loop ctx t = match kind_of_type t with + | AtomicType (hd, args) when isRel hd -> + ctx, destRel hd, not (noccurn 1 t), Array.length args + | CastType (t, _) -> loop ctx t + | ProdType (x, ty, t) -> loop ((x,None,ty) :: ctx) t + | LetInType (x,b,ty,t) -> loop ((x,Some b,ty) :: ctx) (subst1 b t) + | _ -> + let env' = Environ.push_rel_context ctx env in + let t' = Reductionops.whd_betadeltaiota env' sigma t in + if not (eq_constr t t') then loop ctx t' else + errorstrm (str"The eliminator has the wrong shape."++spc()++ + str"A (applied) bound variable was expected as the conclusion of "++ + str"the eliminator's"++Pp.cut()++str"type:"++spc()++pr_constr elimty) in + let ctx, pred_id, elim_is_dep, n_pred_args = loop [] elimty in + let n_elim_args = rel_context_nhyps ctx in + let is_rec_elim = + let count_occurn n term = + let count = ref 0 in + let rec occur_rec n c = match kind_of_term c with + | Rel m -> if m = n then incr count + | _ -> iter_constr_with_binders succ occur_rec n c + in + occur_rec n term; !count in + let occurr2 n t = count_occurn n t > 1 in + not (list_for_all_i + (fun i (_,rd) -> pred_id <= i || not (occurr2 (pred_id - i) rd)) + 1 (assums_of_rel_context ctx)) + in + n_elim_args - pred_id, n_elim_args, is_rec_elim, elim_is_dep, n_pred_args + +(* TASSI: This version of unprotects inlines the unfold tactic definition, + * since we don't want to wipe out let-ins, and it seems there is no flag + * to change that behaviour in the standard unfold code *) +let unprotecttac gl = + let prot = destConst (mkSsrConst "protect_term") in + onClause (fun idopt -> + let hyploc = Option.map (fun id -> id, InHyp) idopt in + reduct_option + (Reductionops.clos_norm_flags + (Closure.RedFlags.mkflags + [Closure.RedFlags.fBETA; + Closure.RedFlags.fCONST prot; + Closure.RedFlags.fIOTA]), DEFAULTcast) hyploc) + allHypsAndConcl gl + +let dependent_apply_error = + try Util.error "Could not fill dependent hole in \"apply\"" with err -> err + +(* TASSI: Sometimes Coq's apply fails. According to my experience it may be + * related to goals that are products and with beta redexes. In that case it + * guesses the wrong number of implicit arguments for your lemma. What follows + * is just like apply, but with a user-provided number n of implicits. + * + * Refine.refine function that handles type classes and evars but fails to + * handle "dependently typed higher order evars". + * + * Refiner.refiner that does not handle metas with a non ground type but works + * with dependently typed higher order metas. *) +let applyn ~with_evars ?beta n t gl = + if with_evars then + let t, ty, args, gl = pf_saturate ?beta ~bi_types:true gl t n in + let gl = pf_unify_HO gl ty (pf_concl gl) in + let gs = list_map_filter (fun (_, e) -> + if isEvar (pf_nf_evar gl e) then Some e else None) + args in + pf_partial_solution ~shelve:true gl t gs + else + let t, gl = if n = 0 then t, gl else + let sigma, si = project gl, sig_it gl in + let rec loop sigma bo args = function (* saturate with metas *) + | 0 -> mkApp (t, Array.of_list (List.rev args)), re_sig si sigma + | n -> match kind_of_term bo with + | Lambda (_, ty, bo) -> + if not (closed0 ty) then raise dependent_apply_error; + let m = Evarutil.new_meta () in + loop (meta_declare m ty sigma) bo ((mkMeta m)::args) (n-1) + | _ -> assert false + in loop sigma t [] n in + pp(lazy(str"Refiner.refiner " ++ pr_constr t)); + Refiner.refiner (Proof_type.Prim (Proof_type.Refine t)) gl + +let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl = + let rec mkRels = function 1 -> [] | n -> mkRel n :: mkRels (n-1) in + let n, oc = pf_abs_evars_pirrel gl oc in + let oc = if not first_goes_last || n <= 1 then oc else + let l, c = decompose_lam oc in + if not (list_for_all_i (fun i (_,t) -> closedn ~-i t) (1-n) l) then oc else + compose_lam (let xs,y = list_chop (n-1) l in y @ xs) + (mkApp (compose_lam l c, Array.of_list (mkRel 1 :: mkRels n))) + in + pp(lazy(str"after: " ++ pr_constr oc)); + try applyn ~with_evars ?beta n oc gl with _ -> raise dependent_apply_error + +(** The "case" and "elim" tactic *) + +(* A case without explicit dependent terms but with both a view and an *) +(* occurrence switch and/or an equation is treated as dependent, with the *) +(* viewed term as the dependent term (the occurrence switch would be *) +(* meaningless otherwise). When both a view and explicit dependents are *) +(* present, it is forbidden to put a (meaningless) occurrence switch on *) +(* the viewed term. *) + +(* This is both elim and case (defaulting to the former). If ~elim is omitted + * the standard eliminator is chosen. The code is made of 4 parts: + * 1. find the eliminator if not given as ~elim and analyze it + * 2. build the patterns to be matched against the conclusion, looking at + * (occ, c), deps and the pattern inferred from the type of the eliminator + * 3. build the new predicate matching the patterns, and the tactic to + * generalize the equality in case eqid is not None + * 4. build the tactic handle intructions and clears as required in ipats and + * by eqid *) +let ssrelim ?(is_case=false) ?ist deps what ?elim eqid ipats gl = + (* some sanity checks *) + let oc, orig_clr, occ, c_gen = match what with + | `EConstr(_,_,t) when isEvar t -> anomaly "elim called on a constr evar" + | `EGen _ when ist = None -> anomaly "no ist and non simple elimination" + | `EGen (_, g) when elim = None && is_wildcard g -> + errorstrm(str"Indeterminate pattern and no eliminator") + | `EGen ((Some clr,occ), g) when is_wildcard g -> + None, clr, occ, None + | `EGen ((None, occ), g) when is_wildcard g -> None,[],occ,None + | `EGen ((_, occ), p as gen) -> + let _, c, clr = pf_interp_gen (Option.get ist) gl true gen in + Some c, clr, occ, Some p + | `EConstr (clr, occ, c) -> Some c, clr, occ, None in + let orig_gl, concl, env = gl, pf_concl gl, pf_env gl in + pp(lazy(str(if is_case then "==CASE==" else "==ELIM=="))); + (* Utils of local interest only *) + let iD s ?t gl = let t = match t with None -> pf_concl gl | Some x -> x in + pp(lazy(str s ++ pr_constr t)); tclIDTAC gl in + let eq, protectC = build_coq_eq (), mkSsrConst "protect_term" in + let fire_subst gl t = Reductionops.nf_evar (project gl) t in + let fire_sigma sigma t = Reductionops.nf_evar sigma t in + let is_undef_pat = function + | sigma, T t -> + (match kind_of_term (fire_sigma sigma t) with Evar _ -> true | _ -> false) + | _ -> false in + let match_pat env p occ h cl = + let sigma0 = project orig_gl in + pp(lazy(str"matching: " ++ pp_pattern p)); + let c, cl = fill_occ_pattern ~raise_NoMatch:true env sigma0 cl p occ h in + pp(lazy(str" got: " ++ pr_constr c)); + c, cl in + let mkTpat gl t = (* takes a term, refreshes it and makes a T pattern *) + let n, t, _ = pf_abs_evars orig_gl (project gl, fire_subst gl t) in + let t, _, _, sigma = saturate ~beta:true env (project gl) t n in + sigma, T t in + let unif_redex gl (sigma, r as p) t = (* t is a hint for the redex of p *) + let n, t, _ = pf_abs_evars orig_gl (project gl, fire_subst gl t) in + let t, _, _, sigma = saturate ~beta:true env sigma t n in + match r with + | X_In_T (e, p) -> sigma, E_As_X_In_T (t, e, p) + | _ -> try unify_HO env sigma t (redex_of_pattern env p), r with _ -> p in + (* finds the eliminator applies it to evars and c saturated as needed *) + (* obtaining "elim ??? (c ???)". pred is the higher order evar *) + let cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl = + match elim with + | Some elim -> + let elimty = pf_type_of gl elim in + let pred_id, n_elim_args, is_rec, elim_is_dep, n_pred_args = + analyze_eliminator elimty env (project gl) in + let elim, elimty, elim_args, gl = + pf_saturate ~beta:is_case gl elim ~ty:elimty n_elim_args in + let pred = List.assoc pred_id elim_args in + let elimty = Reductionops.whd_betadeltaiota env (project gl) elimty in + None, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl + | None -> + let c = Option.get oc in let c_ty = pf_type_of gl c in + let (kn, i) as ind, unfolded_c_ty = pf_reduce_to_quantified_ind gl c_ty in + let sort = elimination_sort_of_goal gl in + let elim = if not is_case then Indrec.lookup_eliminator ind sort + else pf_apply Indrec.build_case_analysis_scheme gl ind true sort in + let elimty = pf_type_of gl elim in + let pred_id,n_elim_args,is_rec,elim_is_dep,n_pred_args = + analyze_eliminator elimty env (project gl) in + let rctx = fst (decompose_prod_assum unfolded_c_ty) in + let n_c_args = rel_context_length rctx in + let c, c_ty, t_args, gl = pf_saturate gl c ~ty:c_ty n_c_args in + let elim, elimty, elim_args, gl = + pf_saturate ~beta:is_case gl elim ~ty:elimty n_elim_args in + let pred = List.assoc pred_id elim_args in + let pc = match n_c_args, c_gen with + | 0, Some p -> interp_cpattern (Option.get ist) orig_gl p None + | _ -> mkTpat gl c in + let cty = Some (c, c_ty, pc) in + let elimty = Reductionops.whd_betadeltaiota env (project gl) elimty in + cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl + in + pp(lazy(str"elim= "++ pr_constr_pat elim)); + pp(lazy(str"elimty= "++ pr_constr elimty)); + let inf_deps_r = match kind_of_type elimty with + | AtomicType (_, args) -> List.rev (Array.to_list args) + | _ -> assert false in + let saturate_until gl c c_ty f = + let rec loop n = try + let c, c_ty, _, gl = pf_saturate gl c ~ty:c_ty n in + let gl' = f c c_ty gl in + Some (c, c_ty, gl, gl') + with NotEnoughProducts -> None | _ -> loop (n+1) in loop 0 in + let elim_is_dep, gl = match cty with + | None -> true, gl + | Some (c, c_ty, _) -> + let res = + if elim_is_dep then None else + let arg = List.assoc (n_elim_args - 1) elim_args in + let arg_ty = pf_type_of gl arg in + match saturate_until gl c c_ty (fun c c_ty gl -> + pf_unify_HO (pf_unify_HO gl c_ty arg_ty) arg c) with + | Some (c, _, _, gl) -> Some (false, gl) + | None -> None in + match res with + | Some x -> x + | None -> + let inf_arg = List.hd inf_deps_r in + let inf_arg_ty = pf_type_of gl inf_arg in + match saturate_until gl c c_ty (fun _ c_ty gl -> + pf_unify_HO gl c_ty inf_arg_ty) with + | Some (c, _, _,gl) -> true, gl + | None -> errorstrm (str"Unable to apply the eliminator to the term"++ + spc()++pr_constr c++spc()++str"or to unify it's type with"++ + pr_constr inf_arg_ty) in + pp(lazy(str"elim_is_dep= " ++ bool elim_is_dep)); + let predty = pf_type_of gl pred in + (* Patterns for the inductive types indexes to be bound in pred are computed + * looking at the ones provided by the user and the inferred ones looking at + * the type of the elimination principle *) + let pp_pat (_,p,_,_) = pp_pattern p in + let pp_inf_pat gl (_,_,t,_) = pr_constr_pat (fire_subst gl t) in + let patterns, clr, gl = + let rec loop patterns clr i = function + | [],[] -> patterns, clr, gl + | ((oclr, occ), t):: deps, inf_t :: inf_deps -> + let ist = match ist with Some x -> x | None -> assert false in + let p = interp_cpattern ist orig_gl t None in + let clr_t = + interp_clr (oclr,(tag_of_cpattern t,redex_of_pattern env p))in + (* if we are the index for the equation we do not clear *) + let clr_t = if deps = [] && eqid <> None then [] else clr_t in + let p = if is_undef_pat p then mkTpat gl inf_t else p in + loop (patterns @ [i, p, inf_t, occ]) + (clr_t @ clr) (i+1) (deps, inf_deps) + | [], c :: inf_deps -> + pp(lazy(str"adding inferred pattern " ++ pr_constr_pat c)); + loop (patterns @ [i, mkTpat gl c, c, allocc]) + clr (i+1) ([], inf_deps) + | _::_, [] -> errorstrm (str "Too many dependent abstractions") in + let deps, head_p, inf_deps_r = match what, elim_is_dep, cty with + | `EConstr _, _, None -> anomaly "Simple welim with no term" + | _, false, _ -> deps, [], inf_deps_r + | `EGen gen, true, None -> deps @ [gen], [], inf_deps_r + | _, true, Some (c, _, pc) -> + let occ = if occ = None then allocc else occ in + let inf_p, inf_deps_r = List.hd inf_deps_r, List.tl inf_deps_r in + deps, [1, pc, inf_p, occ], inf_deps_r in + let patterns, clr, gl = + loop [] orig_clr (List.length head_p+1) (List.rev deps, inf_deps_r) in + head_p @ patterns, Util.list_uniquize clr, gl + in + pp(lazy(pp_concat (str"patterns=") (List.map pp_pat patterns))); + pp(lazy(pp_concat (str"inf. patterns=") (List.map (pp_inf_pat gl) patterns))); + (* Predicate generation, and (if necessary) tactic to generalize the + * equation asked by the user *) + let elim_pred, gen_eq_tac, clr, gl = + let error gl t inf_t = errorstrm (str"The given pattern matches the term"++ + spc()++pp_term gl t++spc()++str"while the inferred pattern"++ + spc()++pr_constr_pat (fire_subst gl inf_t)++spc()++ str"doesn't") in + let match_or_postpone (cl, gl, post) (h, p, inf_t, occ) = + let p = unif_redex gl p inf_t in + if is_undef_pat p then + let () = pp(lazy(str"postponing " ++ pp_pattern p)) in + cl, gl, post @ [h, p, inf_t, occ] + else try + let c, cl = match_pat env p occ h cl in + let gl = try pf_unify_HO gl inf_t c with _ -> error gl c inf_t in + cl, gl, post + with + | NoMatch | NoProgress -> + let e = redex_of_pattern env p in + let n, e, _ = pf_abs_evars gl (fst p, e) in + let e, _, _, gl = pf_saturate ~beta:true gl e n in + let gl = try pf_unify_HO gl inf_t e with _ -> error gl e inf_t in + cl, gl, post + in + let rec match_all concl gl patterns = + let concl, gl, postponed = + List.fold_left match_or_postpone (concl, gl, []) patterns in + if postponed = [] then concl, gl + else if List.length postponed = List.length patterns then + errorstrm (str "Some patterns are undefined even after all"++spc()++ + str"the defined ones matched") + else match_all concl gl postponed in + let concl, gl = match_all concl gl patterns in + let pred_rctx, _ = decompose_prod_assum (fire_subst gl predty) in + let concl, gen_eq_tac, clr = match eqid with + | Some (IpatId _) when not is_rec -> + let k = List.length deps in + let c = fire_subst gl (List.assoc (n_elim_args - k - 1) elim_args) in + let t = pf_type_of gl c in + let gen_eq_tac = + let refl = mkApp (eq, [|t; c; c|]) in + let new_concl = mkArrow refl (lift 1 (pf_concl orig_gl)) in + let new_concl = fire_subst gl new_concl in + let erefl = fire_subst gl (mkRefl t c) in + apply_type new_concl [erefl] in + let rel = k + if elim_is_dep then 1 else 0 in + let src = mkProt mkProp (mkApp (eq,[|t; c; mkRel rel|])) in + let concl = mkArrow src (lift 1 concl) in + let clr = if deps <> [] then clr else [] in + concl, gen_eq_tac, clr + | _ -> concl, tclIDTAC, clr in + let mk_lam t r = mkLambda_or_LetIn r t in + let concl = List.fold_left mk_lam concl pred_rctx in + let concl = + if eqid <> None && is_rec then mkProt (pf_type_of gl concl) concl + else concl in + concl, gen_eq_tac, clr, gl in + pp(lazy(str"elim_pred=" ++ pp_term gl elim_pred)); + let pty = Typing.type_of env (project gl) elim_pred in + pp(lazy(str"elim_pred_ty=" ++ pp_term gl pty)); + let gl = pf_unify_HO gl pred elim_pred in + (* check that the patterns do not contain non instantiated dependent metas *) + let () = + let evars_of_term = Evarutil.evars_of_term in + let patterns = List.map (fun (_,_,t,_) -> fire_subst gl t) patterns in + let patterns_ev = List.map evars_of_term patterns in + let ev = List.fold_left Intset.union Intset.empty patterns_ev in + let ty_ev = Intset.fold (fun i e -> + let ex = Evd.existential_of_int i in + let i_ty = Evd.evar_concl (Evd.find (project gl) ex) in + Intset.union e (evars_of_term i_ty)) + ev Intset.empty in + let inter = Intset.inter ev ty_ev in + if not (Intset.is_empty inter) then begin + let i = Intset.choose inter in + let pat = List.find (fun t -> Intset.mem i (evars_of_term t)) patterns in + errorstrm(str"Pattern"++spc()++pr_constr_pat pat++spc()++ + str"was not completely instantiated and one of its variables"++spc()++ + str"occurs in the type of another non instantieted pattern variable"); + end + in + (* the elim tactic, with the eliminator and the predicated we computed *) + let elim = project gl, fire_subst gl elim in + let elim_tac gl = + tclTHENLIST [refine_with ~with_evars:false elim; cleartac clr] gl in + (* handling of following intro patterns and equation introduction if any *) + let elim_intro_tac gl = + let intro_eq = + match eqid with + | Some (IpatId ipat) when not is_rec -> + let rec intro_eq gl = match kind_of_type (pf_concl gl) with + | ProdType (_, src, tgt) -> + (match kind_of_type src with + | AtomicType (hd, _) when eq_constr hd protectC -> + tclTHENLIST [unprotecttac; introid ipat] gl + | _ -> tclTHENLIST [ iD "IA"; introstac [IpatAnon]; intro_eq] gl) + |_ -> errorstrm (str "Too many names in intro pattern") in + intro_eq + | Some (IpatId ipat) -> + let name gl = mk_anon_id "K" gl in + let intro_lhs gl = + let elim_name = match orig_clr, what with + | [SsrHyp(_, x)], _ -> x + | _, `EConstr(_,_,t) when isVar t -> destVar t + | _ -> name gl in + if is_name_in_ipats elim_name ipats then introid (name gl) gl + else introid elim_name gl + in + let rec gen_eq_tac gl = + let concl = pf_concl gl in + let ctx, last = decompose_prod_assum concl in + let args = match kind_of_type last with + | AtomicType (hd, args) -> assert(eq_constr hd protectC); args + | _ -> assert false in + let case = args.(Array.length args-1) in + if not(closed0 case) then tclTHEN (introstac [IpatAnon]) gen_eq_tac gl + else + let case_ty = pf_type_of gl case in + let refl = mkApp (eq, [|lift 1 case_ty; mkRel 1; lift 1 case|]) in + let new_concl = fire_subst gl + (mkProd (Name (name gl), case_ty, mkArrow refl (lift 2 concl))) in + let erefl = fire_subst gl (mkRefl case_ty case) in + apply_type new_concl [case;erefl] gl in + tclTHENLIST [gen_eq_tac; intro_lhs; introid ipat] + | _ -> tclIDTAC in + let unprot = if eqid <> None && is_rec then unprotecttac else tclIDTAC in + tclEQINTROS ?ist elim_tac (tclTHENLIST [intro_eq; unprot]) ipats gl + in + tclTHENLIST [gen_eq_tac; elim_intro_tac] orig_gl +;; + +let simplest_newelim x= ssrelim ~is_case:false [] (`EConstr ([],None,x)) None [] +let simplest_newcase x= ssrelim ~is_case:true [] (`EConstr ([],None,x)) None [] +let _ = simplest_newcase_ref := simplest_newcase + +let check_casearg = function +| view, (_, (([_; gen :: _], _), _)) when view <> [] && has_occ gen -> + Util.error "incompatible view and occurrence switch in dependent case tactic" +| arg -> arg + +ARGUMENT EXTEND ssrcasearg TYPED AS ssrarg PRINTED BY pr_ssrarg +| [ ssrarg(arg) ] -> [ check_casearg arg ] +END + +let ssrcasetac ist (view, (eqid, (dgens, (ipats, _)))) = + let ndefectcasetac view eqid ipats deps ((_, occ), _ as gen) ist gl = + let simple = (eqid = None && deps = [] && occ = None) in + let cl, c, clr = pf_interp_gen ist gl true gen in + let vc = + if view = [] then c else snd(pf_with_view ist gl (false, view) cl c) in + if simple && is_injection_case vc gl then + tclTHENLIST [perform_injection vc; cleartac clr; introstac ~ist ipats] gl + else + (* macro for "case/v E: x" ---> "case E: x / (v x)" *) + let deps, clr, occ = + if view <> [] && eqid <> None && deps = [] then [gen], [], None + else deps, clr, occ in + ssrelim ~is_case:true ~ist deps (`EConstr (clr,occ, vc)) eqid ipats gl + in + with_dgens dgens (ndefectcasetac view eqid ipats) ist + +TACTIC EXTEND ssrcase +| [ "case" ssrcasearg(arg) ssrclauses(clauses) ] -> + [ let _, (_, (_, (_, ctx))) = arg in + let ist = get_ltacctx ctx in + tclCLAUSES ist (ssrcasetac ist arg) clauses ] +| [ "case" ] -> [ with_top ssrscasetac ] +END + +(** The "elim" tactic *) + +(* Elim views are elimination lemmas, so the eliminated term is not addded *) +(* to the dependent terms as for "case", unless it actually occurs in the *) +(* goal, the "all occurrences" {+} switch is used, or the equation switch *) +(* is used and there are no dependents. *) + +let ssrelimtac ist (view, (eqid, (dgens, (ipats, _)))) = + let ndefectelimtac view eqid ipats deps gen ist gl = + let elim = match view with [v] -> Some (snd(force_term ist gl v)) | _ -> None in + ssrelim ~ist deps (`EGen gen) ?elim eqid ipats gl + in + with_dgens dgens (ndefectelimtac view eqid ipats) ist + +TACTIC EXTEND ssrelim +| [ "elim" ssrarg(arg) ssrclauses(clauses) ] -> + [ let _, (_, (_, (_, ctx))) = arg in + let ist = get_ltacctx ctx in + tclCLAUSES ist (ssrelimtac ist arg) clauses ] +| [ "elim" ] -> [ with_top simplest_newelim ] +END + +(** 6. Backward chaining tactics: apply, exact, congr. *) + +(** The "apply" tactic *) + +let pr_agen (docc, dt) = pr_docc docc ++ pr_term dt +let pr_ssragen _ _ _ = pr_agen +let pr_ssragens _ _ _ = pr_dgens pr_agen + +ARGUMENT EXTEND ssragen TYPED AS ssrdocc * ssrterm PRINTED BY pr_ssragen +| [ "{" ne_ssrhyp_list(clr) "}" ssrterm(dt) ] -> [ mkclr clr, dt ] +| [ ssrterm(dt) ] -> [ nodocc, dt ] +END + +ARGUMENT EXTEND ssragens TYPED AS ssragen list list * ssrclear +PRINTED BY pr_ssragens +| [ "{" ne_ssrhyp_list(clr) "}" ssrterm(dt) ssragens(agens) ] -> + [ cons_gen (mkclr clr, dt) agens ] +| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ [[]], clr] +| [ ssrterm(dt) ssragens(agens) ] -> + [ cons_gen (nodocc, dt) agens ] +| [ ] -> [ [[]], [] ] +END + +let mk_applyarg views agens intros = views, (None, (agens, intros)) + +let pr_ssraarg _ _ _ (view, (eqid, (dgens, ipats))) = + let pri = pr_intros (gens_sep dgens) in + pr_view view ++ pr_eqid eqid ++ pr_dgens pr_agen dgens ++ pri ipats + +ARGUMENT EXTEND ssrapplyarg +TYPED AS ssrview * (ssreqid * (ssragens * ssrintros)) +PRINTED BY pr_ssraarg +| [ ":" ssragen(gen) ssragens(dgens) ssrintros(intros) ] -> + [ mk_applyarg [] (cons_gen gen dgens) intros ] +| [ ssrclear_ne(clr) ssrintros(intros) ] -> + [ mk_applyarg [] ([], clr) intros ] +| [ ssrintros_ne(intros) ] -> + [ mk_applyarg [] ([], []) intros ] +| [ ssrview(view) ":" ssragen(gen) ssragens(dgens) ssrintros(intros) ] -> + [ mk_applyarg view (cons_gen gen dgens) intros ] +| [ ssrview(view) ssrclear(clr) ssrintros(intros) ] -> + [ mk_applyarg view ([], clr) intros ] +END + +let interp_agen ist gl ((goclr, _), (k, gc)) (clr, rcs) = + let rc = glob_constr ist (project gl) (pf_env gl) gc in + let rcs' = rc :: rcs in + match goclr with + | None -> clr, rcs' + | Some ghyps -> + let clr' = snd (interp_hyps ist gl ghyps) @ clr in + if k <> ' ' then clr', rcs' else + match rc with + | GVar (loc, id) when not_section_id id -> SsrHyp (loc, id) :: clr', rcs' + | GRef (loc, VarRef id) when not_section_id id -> + SsrHyp (loc, id) :: clr', rcs' + | _ -> clr', rcs' + +let interp_agens ist gl gagens = + match List.fold_right (interp_agen ist gl) gagens ([], []) with + | clr, rlemma :: args -> + let n = interp_nbargs ist gl rlemma - List.length args in + let rec loop i = + if i > n then + errorstrm (str "Cannot apply lemma " ++ pf_pr_glob_constr gl rlemma) + else + try interp_refine ist gl (mkRApp rlemma (mkRHoles i @ args)) + with _ -> loop (i + 1) in + clr, loop 0 + | _ -> assert false + +let apply_rconstr ?ist t gl = + let n = match ist, t with + | None, (GVar (_, id) | GRef (_, VarRef id)) -> pf_nbargs gl (mkVar id) + | Some ist, _ -> interp_nbargs ist gl t + | _ -> anomaly "apply_rconstr without ist and not RVar" in + let mkRlemma i = mkRApp t (mkRHoles i) in + let cl = pf_concl gl in + let rec loop i = + if i > n then errorstrm (str"Cannot apply lemma "++pf_pr_glob_constr gl t) + else try pf_match gl (mkRlemma i) cl with _ -> loop (i + 1) in + refine_with (loop 0) gl + +let mkRAppView ist gl rv gv = + let nb_view_imps = interp_view_nbimps ist gl rv in + mkRApp rv (mkRHoles (abs nb_view_imps)) + +let prof_apply_interp_with = mk_profiler "ssrapplytac.interp_with";; + +let refine_interp_apply_view i ist gl gv = + let pair i = List.map (fun x -> i, x) in + let rv = pf_intern_term ist gl gv in + let v = mkRAppView ist gl rv gv in + let interp_with (i, hint) = + interp_refine ist gl (mkRApp hint (v :: mkRHoles i)) in + let interp_with x = prof_apply_interp_with.profile interp_with x in + let rec loop = function + | [] -> (try apply_rconstr ~ist rv gl with _ -> view_error "apply" gv) + | h :: hs -> (try refine_with (snd (interp_with h)) gl with _ -> loop hs) in + loop (pair i viewtab.(i) @ if i = 2 then pair 1 viewtab.(1) else []) + +let apply_top_tac gl = + tclTHENLIST [introid top_id; apply_rconstr (mkRVar top_id); clear [top_id]] gl + +let inner_ssrapplytac gviews ggenl gclr ist gl = + let _, clr = interp_hyps ist gl gclr in + let vtac gv i gl' = refine_interp_apply_view i ist gl' gv in + let ggenl, tclGENTAC = + if gviews <> [] && ggenl <> [] then + let ggenl= List.map (fun (x,g) -> x, cpattern_of_term g) (List.hd ggenl) in + [], tclTHEN (genstac (ggenl,[]) ist) + else ggenl, tclTHEN tclIDTAC in + tclGENTAC (fun gl -> + match gviews, ggenl with + | v :: tl, [] -> + let dbl = if List.length tl = 1 then 2 else 1 in + tclTHEN + (List.fold_left (fun acc v -> tclTHENLAST acc (vtac v dbl)) (vtac v 1) tl) + (cleartac clr) gl + | [], [agens] -> + let clr', (_, lemma) = interp_agens ist gl agens in + tclTHENLIST [cleartac clr; refine_with ~beta:true lemma; cleartac clr'] gl + | _, _ -> tclTHEN apply_top_tac (cleartac clr) gl) gl + +let ssrapplytac (views, (_, ((gens, clr), intros))) = + tclINTROS (inner_ssrapplytac views gens clr) intros + +let prof_ssrapplytac = mk_profiler "ssrapplytac";; +let ssrapplytac arg gl = prof_ssrapplytac.profile (ssrapplytac arg) gl;; + +TACTIC EXTEND ssrapply +| [ "apply" ssrapplyarg(arg) ] -> [ ssrapplytac arg ] +| [ "apply" ] -> [ apply_top_tac ] +END + +(** The "exact" tactic *) + +let mk_exactarg views dgens = mk_applyarg views dgens ([], rawltacctx) + +ARGUMENT EXTEND ssrexactarg TYPED AS ssrapplyarg PRINTED BY pr_ssraarg +| [ ":" ssragen(gen) ssragens(dgens) ] -> + [ mk_exactarg [] (cons_gen gen dgens) ] +| [ ssrview(view) ssrclear(clr) ] -> + [ mk_exactarg view ([], clr) ] +| [ ssrclear_ne(clr) ] -> + [ mk_exactarg [] ([], clr) ] +END + +let vmexacttac pf gl = exact_no_check (mkCast (pf, VMcast, pf_concl gl)) gl + +TACTIC EXTEND ssrexact +| [ "exact" ssrexactarg(arg) ] -> [ tclBY (ssrapplytac arg) ] +| [ "exact" ] -> [ tclORELSE donetac (tclBY apply_top_tac) ] +| [ "exact" "<:" lconstr(pf) ] -> [ vmexacttac pf ] +END + +(** The "congr" tactic *) + +type ssrcongrarg = open_constr * (int * constr) + +let pr_ssrcongrarg _ _ _ (_, ((n, f), dgens)) = + (if n <= 0 then mt () else str " " ++ pr_int n) ++ + str " " ++ pr_term f ++ pr_dgens pr_gen dgens + +ARGUMENT EXTEND ssrcongrarg TYPED AS ltacctx * ((int * ssrterm) * ssrdgens) + PRINTED BY pr_ssrcongrarg +| [ natural(n) constr(c) ssrdgens(dgens) ] -> + [ rawltacctx, ((n, mk_term ' ' c), dgens) ] +| [ natural(n) constr(c) ] -> + [ rawltacctx, ((n, mk_term ' ' c),([[]],[])) ] +| [ constr(c) ssrdgens(dgens) ] -> [ rawltacctx, ((0, mk_term ' ' c), dgens) ] +| [ constr(c) ] -> [ rawltacctx, ((0, mk_term ' ' c), ([[]],[])) ] +END + +let rec mkRnat n = + if n <= 0 then GRef (dummy_loc, glob_O) else + mkRApp (GRef (dummy_loc, glob_S)) [mkRnat (n - 1)] + +let interp_congrarg_at ist gl n rf ty m = + pp(lazy(str"===interp_congrarg_at===")); + let congrn = mkSsrRRef "nary_congruence" in + let args1 = mkRnat n :: mkRHoles n @ [ty] in + let args2 = mkRHoles (3 * n) in + let rec loop i = + if i + n > m then None else + try + let rt = mkRApp congrn (args1 @ mkRApp rf (mkRHoles i) :: args2) in + pp(lazy(str"rt=" ++ pr_glob_constr rt)); + Some (interp_refine ist gl rt) + with _ -> loop (i + 1) in + loop 0 + +let pattern_id = mk_internal_id "pattern value" + +let congrtac ((n, t), ty) ist gl = + pp(lazy(str"===congr===")); + pp(lazy(str"concl=" ++ pr_constr (pf_concl gl))); + let _, f, _ = pf_abs_evars gl (interp_term ist gl t) in + let ist' = {ist with lfun = [pattern_id, VConstr ([],f)]} in + let rf = mkRltacVar pattern_id in + let m = pf_nbargs gl f in + let _, cf = if n > 0 then + match interp_congrarg_at ist' gl n rf ty m with + | Some cf -> cf + | None -> errorstrm (str "No " ++ pr_int n ++ str "-congruence with " + ++ pr_term t) + else let rec loop i = + if i > m then errorstrm (str "No congruence with " ++ pr_term t) + else match interp_congrarg_at ist' gl i rf ty m with + | Some cf -> cf + | None -> loop (i + 1) in + loop 1 in + tclTHEN (refine_with cf) (tclTRY reflexivity) gl + +let newssrcongrtac arg ist gl = + pp(lazy(str"===newcongr===")); + pp(lazy(str"concl=" ++ pr_constr (pf_concl gl))); + (* utils *) + let fs gl t = Reductionops.nf_evar (project gl) t in + let tclMATCH_GOAL (c, gl_c) proj t_ok t_fail gl = + match try Some (pf_unify_HO gl_c (pf_concl gl) c) with _ -> None with + | Some gl_c -> tclTHEN (convert_concl (fs gl_c c)) (t_ok (proj gl_c)) gl + | None -> t_fail () gl in + let mk_evar gl ty = + let env, sigma, si = pf_env gl, project gl, sig_it gl in + let sigma, x = Evarutil.new_evar (create_evar_defs sigma) env ty in + x, re_sig si sigma in + let ssr_congr lr = mkApp (mkSsrConst "ssr_congr_arrow",lr) in + (* here thw two cases: simple equality or arrow *) + let equality, _, eq_args, gl' = pf_saturate gl (build_coq_eq ()) 3 in + tclMATCH_GOAL (equality, gl') (fun gl' -> fs gl' (List.assoc 0 eq_args)) + (fun ty -> congrtac (arg, Detyping.detype false [] [] ty) ist) + (fun () -> + let lhs, gl' = mk_evar gl mkProp in let rhs, gl' = mk_evar gl' mkProp in + let arrow = mkArrow lhs (lift 1 rhs) in + tclMATCH_GOAL (arrow, gl') (fun gl' -> [|fs gl' lhs;fs gl' rhs|]) + (fun lr -> tclTHEN (apply (ssr_congr lr)) (congrtac (arg, mkRType) ist)) + (fun _ _ -> errorstrm (str"Conclusion is not an equality nor an arrow"))) + gl +;; + +TACTIC EXTEND ssrcongr +| [ "congr" ssrcongrarg(arg) ] -> +[ let ctx, (arg, dgens) = arg in + let ist = get_ltacctx ctx in + match dgens with + | [gens], clr -> tclTHEN (genstac (gens,clr) ist) (newssrcongrtac arg ist) + | _ -> errorstrm (str"Dependent family abstractions not allowed in congr")] +END + +(** 7. Rewriting tactics (rewrite, unlock) *) + +(** Coq rewrite compatibility flag *) + +let ssr_strict_match = ref false + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optname = "strict redex matching"; + Goptions.optkey = ["Match"; "Strict"]; + Goptions.optread = (fun () -> !ssr_strict_match); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> ssr_strict_match := b) } + +(** Rewrite multiplier *) + +type ssrmult = int * ssrmmod + +let notimes = 0 +let nomult = 1, Once + +let pr_mult (n, m) = + if n > 0 && m <> Once then pr_int n ++ pr_mmod m else pr_mmod m + +let pr_ssrmult _ _ _ = pr_mult + +ARGUMENT EXTEND ssrmult_ne TYPED AS int * ssrmmod PRINTED BY pr_ssrmult + | [ natural(n) ssrmmod(m) ] -> [ check_index loc n, m ] + | [ ssrmmod(m) ] -> [ notimes, m ] +END + +ARGUMENT EXTEND ssrmult TYPED AS ssrmult_ne PRINTED BY pr_ssrmult + | [ ssrmult_ne(m) ] -> [ m ] + | [ ] -> [ nomult ] +END + +(** Rewrite clear/occ switches *) + +let pr_rwocc = function + | None, None -> mt () + | None, occ -> pr_occ occ + | Some clr, _ -> pr_clear_ne clr + +let pr_ssrrwocc _ _ _ = pr_rwocc + +ARGUMENT EXTEND ssrrwocc TYPED AS ssrdocc PRINTED BY pr_ssrrwocc +| [ "{" ssrhyp_list(clr) "}" ] -> [ mkclr clr ] +| [ "{" ssrocc(occ) "}" ] -> [ mkocc occ ] +| [ ] -> [ noclr ] +END + +(** Rewrite rules *) + +type ssrwkind = RWred of ssrsimpl | RWdef | RWeq +(* type ssrrule = ssrwkind * ssrterm *) + +let pr_rwkind = function + | RWred s -> pr_simpl s + | RWdef -> str "/" + | RWeq -> mt () + +let wit_ssrrwkind, globwit_ssrrwkind, rawwit_ssrrwkind = + add_genarg "ssrrwkind" pr_rwkind + +let pr_rule = function + | RWred s, _ -> pr_simpl s + | RWdef, r-> str "/" ++ pr_term r + | RWeq, r -> pr_term r + +let pr_ssrrule _ _ _ = pr_rule + +let noruleterm loc = mk_term ' ' (mkCProp loc) + +ARGUMENT EXTEND ssrrule_ne TYPED AS ssrrwkind * ssrterm PRINTED BY pr_ssrrule + | [ ssrsimpl_ne(s) ] -> [ RWred s, noruleterm loc ] + | [ "/" ssrterm(t) ] -> [ RWdef, t ] + | [ ssrterm(t) ] -> [ RWeq, t ] +END + +ARGUMENT EXTEND ssrrule TYPED AS ssrrule_ne PRINTED BY pr_ssrrule + | [ ssrrule_ne(r) ] -> [ r ] + | [ ] -> [ RWred Nop, noruleterm loc ] +END + +(** Rewrite arguments *) + +(* type ssrrwarg = (ssrdir * ssrmult) * ((ssrdocc * ssrpattern) * ssrrule) *) + +let pr_option f = function None -> mt() | Some x -> f x +let pr_pattern_squarep= pr_option (fun r -> str "[" ++ pr_rpattern r ++ str "]") +let pr_ssrpattern_squarep _ _ _ = pr_pattern_squarep +let pr_rwarg ((d, m), ((docc, rx), r)) = + pr_rwdir d ++ pr_mult m ++ pr_rwocc docc ++ pr_pattern_squarep rx ++ pr_rule r + +let pr_ssrrwarg _ _ _ = pr_rwarg + +let mk_rwarg (d, (n, _ as m)) ((clr, occ as docc), rx) (rt, _ as r) = + if rt <> RWeq then begin + if rt = RWred Nop && not (m = nomult && occ = None && rx = None) + && (clr = None || clr = Some []) then + anomaly "Improper rewrite clear switch"; + if d = R2L && rt <> RWdef then + error "Right-to-left switch on simplification"; + if n <> 1 && rt = RWred Cut then + error "Bad or useless multiplier"; + if occ <> None && rx = None && rt <> RWdef then + error "Missing redex for simplification occurrence" + end; (d, m), ((docc, rx), r) + +let norwmult = L2R, nomult +let norwocc = noclr, None + +(* +let pattern_ident = Prim.pattern_ident in +GEXTEND Gram +GLOBAL: pattern_ident; +pattern_ident: +[[c = pattern_ident -> (CRef (Ident (loc,c)), NoBindings)]]; +END +*) + +ARGUMENT EXTEND ssrpattern_squarep +TYPED AS rpattern option PRINTED BY pr_ssrpattern_squarep + | [ "[" rpattern(rdx) "]" ] -> [ Some rdx ] + | [ ] -> [ None ] +END + +ARGUMENT EXTEND ssrpattern_ne_squarep +TYPED AS rpattern option PRINTED BY pr_ssrpattern_squarep + | [ "[" rpattern(rdx) "]" ] -> [ Some rdx ] +END + + +ARGUMENT EXTEND ssrrwarg + TYPED AS (ssrdir * ssrmult) * ((ssrdocc * rpattern option) * ssrrule) + PRINTED BY pr_ssrrwarg + | [ "-" ssrmult(m) ssrrwocc(docc) ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg (R2L, m) (docc, rx) r ] + | [ "-/" ssrterm(t) ] -> (* just in case '-/' should become a token *) + [ mk_rwarg (R2L, nomult) norwocc (RWdef, t) ] + | [ ssrmult_ne(m) ssrrwocc(docc) ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg (L2R, m) (docc, rx) r ] + | [ "{" ne_ssrhyp_list(clr) "}" ssrpattern_ne_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (mkclr clr, rx) r ] + | [ "{" ne_ssrhyp_list(clr) "}" ssrrule(r) ] -> + [ mk_rwarg norwmult (mkclr clr, None) r ] + | [ "{" ssrocc(occ) "}" ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (mkocc occ, rx) r ] + | [ "{" "}" ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (nodocc, rx) r ] + | [ ssrpattern_ne_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (noclr, rx) r ] + | [ ssrrule_ne(r) ] -> + [ mk_rwarg norwmult norwocc r ] +END + +let simplintac occ rdx sim gl = + let simptac gl = + let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let simp env c _ = red_safe Tacred.simpl env sigma0 c in + convert_concl_no_check (eval_pattern env0 sigma0 concl0 rdx occ simp) gl in + match sim with + | Simpl -> simptac gl + | SimplCut -> tclTHEN simptac (tclTRY donetac) gl + | _ -> simpltac sim gl + +let rec get_evalref c = match kind_of_term c with + | Var id -> EvalVarRef id + | Const k -> EvalConstRef k + | App (c', _) -> get_evalref c' + | Cast (c', _, _) -> get_evalref c' + | _ -> errorstrm (str "The term " ++ pr_constr c ++ str " is not unfoldable") + +(* Strip a pattern generated by a prenex implicit to its constant. *) +let strip_unfold_term ((sigma, t) as p) kt = match kind_of_term t with + | App (f, a) when kt = ' ' && array_for_all isEvar a && isConst f -> + (sigma, f), true + | Const _ | Var _ -> p, true + | _ -> p, false + +let unfoldintac occ rdx t (kt,_) gl = + let fs sigma x = Reductionops.nf_evar sigma x in + let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let (sigma, t), const = strip_unfold_term t kt in + let body env t c = Tacred.unfoldn [(true, [1]), get_evalref t] env sigma0 c in + let easy = occ = None && rdx = None in + let red_flags = if easy then Closure.betaiotazeta else Closure.betaiota in + let beta env = Reductionops.clos_norm_flags red_flags env sigma0 in + let unfold, conclude = match rdx with + | Some (_, (In_T _ | In_X_In_T _)) | None -> + let ise = create_evar_defs sigma in + let ise, u = mk_tpattern env0 sigma0 (ise,t) all_ok L2R t in + let find_T, end_T = + mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[u]) in + (fun env c h -> + try find_T env c h (fun env c _ -> body env t c) + with NoMatch when easy -> c + | NoMatch | NoProgress -> errorstrm (str"No occurrence of " + ++ pr_constr_pat t ++ spc() ++ str "in " ++ pr_constr c)), + (fun () -> try end_T () with + | NoMatch when easy -> fake_pmatcher_end () + | NoMatch -> anomaly "unfoldintac") + | _ -> + (fun env (c as orig_c) h -> + if const then + let rec aux c = + match kind_of_term c with + | Const _ when eq_constr c t -> body env t t + | App (f,a) when eq_constr f t -> mkApp (body env f f,a) + | _ -> let c = Reductionops.whd_betaiotazeta sigma0 c in + match kind_of_term c with + | Const _ when eq_constr c t -> body env t t + | App (f,a) when eq_constr f t -> mkApp (body env f f,a) + | Const f -> aux (body env c c) + | App (f, a) -> aux (mkApp (body env f f, a)) + | _ -> errorstrm (str "The term "++pr_constr orig_c++ + str" contains no " ++ pr_constr t ++ str" even after unfolding") + in aux c + else + try body env t (fs (unify_HO env sigma c t) t) + with _ -> errorstrm (str "The term " ++ + pr_constr c ++spc()++ str "does not unify with " ++ pr_constr_pat t)), + fake_pmatcher_end in + let concl = + try beta env0 (eval_pattern env0 sigma0 concl0 rdx occ unfold) + with Option.IsNone -> errorstrm (str"Failed to unfold " ++ pr_constr_pat t) in + let _ = conclude () in + convert_concl concl gl +;; + +let foldtac occ rdx ft gl = + let fs sigma x = Reductionops.nf_evar sigma x in + let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let sigma, t = ft in + let fold, conclude = match rdx with + | Some (_, (In_T _ | In_X_In_T _)) | None -> + let ise = create_evar_defs sigma in + let ut = red_product_skip_id env0 sigma t in + let ise, ut = mk_tpattern env0 sigma0 (ise,t) all_ok L2R ut in + let find_T, end_T = + mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[ut]) in + (fun env c h -> try find_T env c h (fun env t _ -> t) with NoMatch -> c), + (fun () -> try end_T () with NoMatch -> fake_pmatcher_end ()) + | _ -> + (fun env c h -> try let sigma = unify_HO env sigma c t in fs sigma t + with _ -> errorstrm (str "fold pattern " ++ pr_constr_pat t ++ spc () + ++ str "does not match redex " ++ pr_constr_pat c)), + fake_pmatcher_end in + let concl = eval_pattern env0 sigma0 concl0 rdx occ fold in + let _ = conclude () in + convert_concl concl gl +;; + +let converse_dir = function L2R -> R2L | R2L -> L2R + +let rw_progress rhs lhs ise = not (eq_constr lhs (Evarutil.nf_evar ise rhs)) + +(* Coq has a more general form of "equation" (any type with a single *) +(* constructor with no arguments with_rect_r elimination lemmas). *) +(* However there is no clear way of determining the LHS and RHS of *) +(* such a generic Leibnitz equation -- short of inspecting the type *) +(* of the elimination lemmas. *) + +let rec strip_prod_assum c = match kind_of_term c with + | Prod (_, _, c') -> strip_prod_assum c' + | LetIn (_, v, _, c') -> strip_prod_assum (subst1 v c) + | Cast (c', _, _) -> strip_prod_assum c' + | _ -> c + +let rule_id = mk_internal_id "rewrite rule" + +exception PRtype_error +exception PRindetermined_rhs of constr + +let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = + let env = pf_env gl in + let beta = Reductionops.clos_norm_flags Closure.beta env sigma in + let sigma, p = + let sigma = create_evar_defs sigma in + Evarutil.new_evar sigma env (beta (subst1 new_rdx pred)) in + let pred = mkNamedLambda pattern_id rdx_ty pred in + let elim = + let (kn, i) as ind, unfolded_c_ty = pf_reduce_to_quantified_ind gl c_ty in + let sort = elimination_sort_of_goal gl in + let elim = Indrec.lookup_eliminator ind sort in + if dir = R2L then elim else (* taken from Coq's rewrite *) + let elim = destConst elim in + let mp,dp,l = repr_con (constant_of_kn (canonical_con elim)) in + let l' = label_of_id (Nameops.add_suffix (id_of_label l) "_r") in + let c1' = Global.constant_of_delta_kn (canonical_con (make_con mp dp l')) in + mkConst c1' in + let proof = mkApp (elim, [| rdx_ty; new_rdx; pred; p; rdx; c |]) in + (* We check the proof is well typed *) + let proof_ty = + try Typing.type_of env sigma proof with _ -> raise PRtype_error in + pp(lazy(str"pirrel_rewrite proof term of type: " ++ pr_constr proof_ty)); + try refine_with + ~first_goes_last:(not !ssroldreworder) ~with_evars:false (sigma, proof) gl + with _ -> + (* we generate a msg like: "Unable to find an instance for the variable" *) + let c = Reductionops.nf_evar sigma c in + let hd_ty, miss = match kind_of_term c with + | App (hd, args) -> + let hd_ty = Retyping.get_type_of env sigma hd in + let names = let rec aux t = function 0 -> [] | n -> + let t = Reductionops.whd_betadeltaiota env sigma t in + match kind_of_type t with + | ProdType (name, _, t) -> name :: aux t (n-1) + | _ -> assert false in aux hd_ty (Array.length args) in + hd_ty, Util.list_map_filter (fun (t, name) -> + let evs = Util.Intset.elements (Evarutil.evars_of_term t) in + let open_evs = List.filter (fun k -> + InProp <> Retyping.get_sort_family_of + env sigma (Evd.evar_concl (Evd.find sigma k))) + evs in + if open_evs <> [] then Some name else None) + (List.combine (Array.to_list args) names) + | _ -> anomaly "rewrite rule not an application" in + errorstrm (Himsg.explain_refiner_error (Logic.UnresolvedBindings miss) ++ + (Pp.fnl()++str"Rule's type:" ++ spc() ++ pr_constr hd_ty)) +;; + +let rwcltac cl rdx dir sr gl = + let n, r_n,_ = pf_abs_evars gl sr in + let r_n' = pf_abs_cterm gl n r_n in + let r' = subst_var pattern_id r_n' in + let rdxt = Retyping.get_type_of (pf_env gl) (fst sr) rdx in + let cvtac, rwtac = + if closed0 r' then + let env, sigma, c, c_eq = pf_env gl, fst sr, snd sr, build_coq_eq () in + let c_ty = Typing.type_of env sigma c in + match kind_of_type (Reductionops.whd_betadeltaiota env sigma c_ty) with + | AtomicType(e, a) when eq_constr e c_eq -> + let new_rdx = if dir = L2R then a.(2) else a.(1) in + pirrel_rewrite cl rdx rdxt new_rdx dir sr c_ty, tclIDTAC + | _ -> + let cl' = mkApp (mkNamedLambda pattern_id rdxt cl, [|rdx|]) in + convert_concl cl', rewritetac dir r' + else + let dc, r2 = decompose_lam_n n r' in + let r3, _, r3t = + try destCast r2 with _ -> + errorstrm (str "no cast from " ++ pr_constr_pat (snd sr) + ++ str " to " ++ pr_constr r2) in + let cl' = mkNamedProd rule_id (compose_prod dc r3t) (lift 1 cl) in + let cl'' = mkNamedProd pattern_id rdxt cl' in + let itacs = [introid pattern_id; introid rule_id] in + let cltac = clear [pattern_id; rule_id] in + let rwtacs = [rewritetac dir (mkVar rule_id); cltac] in + (apply_type cl'' [rdx; compose_lam dc r3], tclTHENLIST (itacs @ rwtacs)) + in + let cvtac' _ = + try cvtac gl with + | PRtype_error -> + if occur_existential (pf_concl gl) + then errorstrm (str "Rewriting impacts evars") + else errorstrm (str "Dependent type error in rewrite of " + ++ pf_pr_constr gl (mkNamedLambda pattern_id rdxt cl)) + | Util.UserError _ as e -> raise e + | e -> anomaly ("cvtac's exception: " ^ Printexc.to_string e); + in + tclTHEN cvtac' rwtac gl + +let prof_rwcltac = mk_profiler "rwrxtac.rwcltac";; +let rwcltac cl rdx dir sr gl = + prof_rwcltac.profile (rwcltac cl rdx dir sr) gl +;; + + +let lz_coq_prod = + let prod = lazy (build_prod ()) in fun () -> Lazy.force prod + +let lz_setoid_relation = + let sdir = ["Classes"; "RelationClasses"] in + let last_srel = ref (Environ.empty_env, None) in + fun env -> match !last_srel with + | env', srel when env' == env -> srel + | _ -> + let srel = + try Some (coq_constant "Class_setoid" sdir "RewriteRelation") + with _ -> None in + last_srel := (env, srel); srel + +let ssr_is_setoid env = + match lz_setoid_relation env with + | None -> fun _ _ _ -> false + | Some srel -> + fun sigma r args -> + Rewrite.is_applied_rewrite_relation env + sigma [] (mkApp (r, args)) <> None + +let prof_rwxrtac_find_rule = mk_profiler "rwrxtac.find_rule";; + +let closed0_check cl p gl = + if closed0 cl then errorstrm (str"No occurrence of redex "++pf_pr_constr gl p) + +let rwrxtac occ rdx_pat dir rule gl = + let env = pf_env gl in + let coq_prod = lz_coq_prod () in + let is_setoid = ssr_is_setoid env in + let r_sigma, rules = + let rec loop d sigma r t0 rs red = + let t = + if red = 1 then Tacred.hnf_constr env sigma t0 + else Reductionops.whd_betaiotazeta sigma t0 in + match kind_of_term t with + | Prod (_, xt, at) -> + let ise, x = Evarutil.new_evar (create_evar_defs sigma) env xt in + loop d ise (mkApp (r, [|x|])) (subst1 x at) rs 0 + | App (pr, a) when pr = coq_prod.Coqlib.typ -> + let sr = match kind_of_term (Tacred.hnf_constr env sigma r) with + | App (c, ra) when c = coq_prod.Coqlib.intro -> fun i -> ra.(i + 1) + | _ -> let ra = Array.append a [|r|] in + function 1 -> mkApp (coq_prod.Coqlib.proj1, ra) + | _ -> mkApp (coq_prod.Coqlib.proj2, ra) in + if a.(0) = build_coq_True () then + loop (converse_dir d) sigma (sr 2) a.(1) rs 0 + else + let sigma2, rs2 = loop d sigma (sr 2) a.(1) rs 0 in + loop d sigma2 (sr 1) a.(0) rs2 0 + | App (r_eq, a) when Hipattern.match_with_equality_type t != None -> + let ind = destInd r_eq and rhs = array_last a in + let np, ndep = Inductiveops.inductive_nargs env ind in + let ind_ct = Inductiveops.type_of_constructors env ind in + let lhs0 = last_arg (strip_prod_assum ind_ct.(0)) in + let rdesc = match kind_of_term lhs0 with + | Rel i -> + let lhs = a.(np - i) in + let lhs, rhs = if d = L2R then lhs, rhs else rhs, lhs in +(* msgnl (str "RW: " ++ pr_rwdir d ++ str " " ++ pr_constr_pat r ++ str " : " + ++ pr_constr_pat lhs ++ str " ~> " ++ pr_constr_pat rhs); *) + d, r, lhs, rhs +(* + let l_i, r_i = if d = L2R then i, 1 - ndep else 1 - ndep, i in + let lhs = a.(np - l_i) and rhs = a.(np - r_i) in + let a' = Array.copy a in let _ = a'.(np - l_i) <- mkVar pattern_id in + let r' = mkCast (r, DEFAULTcast, mkApp (r_eq, a')) in + (d, r', lhs, rhs) +*) + | _ -> + let lhs = substl (array_list_of_tl (Array.sub a 0 np)) lhs0 in + let lhs, rhs = if d = R2L then lhs, rhs else rhs, lhs in + let d' = if Array.length a = 1 then d else converse_dir d in + d', r, lhs, rhs in + sigma, rdesc :: rs + | App (s_eq, a) when is_setoid sigma s_eq a -> + let np = Array.length a and i = 3 - dir_org d in + let lhs = a.(np - i) and rhs = a.(np + i - 3) in + let a' = Array.copy a in let _ = a'.(np - i) <- mkVar pattern_id in + let r' = mkCast (r, DEFAULTcast, mkApp (s_eq, a')) in + sigma, (d, r', lhs, rhs) :: rs + | _ -> + if red = 0 then loop d sigma r t rs 1 + else errorstrm (str "not a rewritable relation: " ++ pr_constr_pat t + ++ spc() ++ str "in rule " ++ pr_constr_pat (snd rule)) + in + let sigma, r = rule in + let t = Retyping.get_type_of env sigma r in + loop dir sigma r t [] 0 in + let find_rule rdx = + let rec rwtac = function + | [] -> + errorstrm (str "pattern " ++ pr_constr_pat rdx ++ + str " does not match " ++ pr_dir_side dir ++ + str " of " ++ pr_constr_pat (snd rule)) + | (d, r, lhs, rhs) :: rs -> + try + let ise = unify_HO env (create_evar_defs r_sigma) lhs rdx in + if not (rw_progress rhs rdx ise) then raise NoMatch else + d, (ise, Reductionops.nf_evar ise r) + with _ -> rwtac rs in + rwtac rules in + let find_rule rdx = prof_rwxrtac_find_rule.profile find_rule rdx in + let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in + let find_R, conclude = match rdx_pat with + | Some (_, (In_T _ | In_X_In_T _)) | None -> + let upats_origin = dir, snd rule in + let rpat env sigma0 (sigma, pats) (d, r, lhs, rhs) = + let sigma, pat = + mk_tpattern env sigma0 (sigma,r) (rw_progress rhs) d lhs in + sigma, pats @ [pat] in + let rpats = List.fold_left (rpat env0 sigma0) (r_sigma,[]) rules in + let find_R, end_R = mk_tpattern_matcher sigma0 occ ~upats_origin rpats in + find_R ~k:(fun _ _ h -> mkRel h), + fun cl -> let rdx,d,r = end_R () in closed0_check cl rdx gl; (d,r),rdx + | Some(_, (T e | X_In_T (_,e) | E_As_X_In_T (e,_,_) | E_In_X_In_T (e,_,_))) -> + let r = ref None in + (fun env c h -> do_once r (fun () -> find_rule c, c); mkRel h), + (fun concl -> closed0_check concl e gl; assert_done r) in + let concl = eval_pattern env0 sigma0 concl0 rdx_pat occ find_R in + let (d, r), rdx = conclude concl in + rwcltac concl rdx d r gl +;; + +let prof_rwxrtac = mk_profiler "rwrxtac";; +let rwrxtac occ rdx_pat dir rule gl = + prof_rwxrtac.profile (rwrxtac occ rdx_pat dir rule) gl +;; + + +(* Resolve forward reference *) +let _ = + ipat_rewritetac := fun occ dir c gl -> rwrxtac occ None dir (project gl, c) gl + +let rwargtac ist ((dir, mult), (((oclr, occ), grx), (kind, gt))) gl = + let fail = ref false in + let interp_rpattern ist gl gc = + try interp_rpattern ist gl gc + with _ when snd mult = May -> fail := true; project gl, T mkProp in + let interp gc gl = + try interp_term ist gl gc + with _ when snd mult = May -> fail := true; (project gl, mkProp) in + let rwtac gl = + let rx = Option.map (interp_rpattern ist gl) grx in + let t = interp gt gl in + (match kind with + | RWred sim -> simplintac occ rx sim + | RWdef -> if dir = R2L then foldtac occ rx t else unfoldintac occ rx t gt + | RWeq -> rwrxtac occ rx dir t) gl in + let ctac = cleartac (interp_clr (oclr, (fst gt, snd (interp gt gl)))) in + if !fail then ctac gl else tclTHEN (tclMULT mult rwtac) ctac gl + +(** Rewrite argument sequence *) + +(* type ssrrwargs = ssrrwarg list * ltacctx *) + +let pr_ssrrwargs _ _ _ (rwargs, _) = pr_list spc pr_rwarg rwargs + +ARGUMENT EXTEND ssrrwargs TYPED AS ssrrwarg list * ltacctx + PRINTED BY pr_ssrrwargs + | [ "Qed" ] -> [ anomaly "Grammar placeholder match" ] +END + +let ssr_rw_syntax = ref true + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optname = "ssreflect rewrite"; + Goptions.optkey = ["SsrRewrite"]; + Goptions.optread = (fun _ -> !ssr_rw_syntax); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> ssr_rw_syntax := b) } + +let test_ssr_rw_syntax = + let test strm = + if not !ssr_rw_syntax then raise Stream.Failure else + if ssr_loaded () then () else + match Compat.get_tok (Util.stream_nth 0 strm) with + | Tok.KEYWORD key when List.mem key.[0] ['{'; '['; '/'] -> () + | _ -> raise Stream.Failure in + Gram.Entry.of_parser "test_ssr_rw_syntax" test + +GEXTEND Gram + GLOBAL: ssrrwargs; + ssrrwargs: [[ test_ssr_rw_syntax; a = LIST1 ssrrwarg -> a, rawltacctx ]]; +END + +(** The "rewrite" tactic *) + +let ssrrewritetac ist rwargs = tclTHENLIST (List.map (rwargtac ist) rwargs) + +TACTIC EXTEND ssrrewrite + | [ "rewrite" ssrrwargs(args) ssrclauses(clauses) ] -> + [ let ist = get_ltacctx (snd args) in + tclCLAUSES ist (ssrrewritetac ist (fst args)) clauses ] +END + +(** The "unlock" tactic *) + +let pr_unlockarg (occ, t) = pr_occ occ ++ pr_term t +let pr_ssrunlockarg _ _ _ = pr_unlockarg + +ARGUMENT EXTEND ssrunlockarg TYPED AS ssrocc * ssrterm + PRINTED BY pr_ssrunlockarg + | [ "{" ssrocc(occ) "}" ssrterm(t) ] -> [ occ, t ] + | [ ssrterm(t) ] -> [ None, t ] +END + +let pr_ssrunlockargs _ _ _ (args, _) = pr_list spc pr_unlockarg args + +ARGUMENT EXTEND ssrunlockargs TYPED AS ssrunlockarg list * ltacctx + PRINTED BY pr_ssrunlockargs + | [ ssrunlockarg_list(args) ] -> [ args, rawltacctx ] +END + +let unfoldtac occ ko t kt gl = + let cl, c = pf_fill_occ_term gl occ (fst (strip_unfold_term t kt)) in + let cl' = subst1 (pf_unfoldn [(true, [1]), get_evalref c] gl c) cl in + let f = if ko = None then Closure.betaiotazeta else Closure.betaiota in + convert_concl (pf_reduce (Reductionops.clos_norm_flags f) gl cl') gl + +let unlocktac ist args = + let utac (occ, gt) gl = + unfoldtac occ occ (interp_term ist gl gt) (fst gt) gl in + let locked = mkSsrConst "locked" in + let key = mkSsrConst "master_key" in + let ktacs = [ + (fun gl -> unfoldtac None None (project gl,locked) '(' gl); + simplest_newcase key ] in + tclTHENLIST (List.map utac args @ ktacs) + +TACTIC EXTEND ssrunlock + | [ "unlock" ssrunlockargs(args) ssrclauses(clauses) ] -> + [ let ist = get_ltacctx (snd args) in + tclCLAUSES ist (unlocktac ist (fst args)) clauses ] +END + +(** 8. Forward chaining tactics (pose, set, have, suffice, wlog) *) + +(** Defined identifier *) + +type ssrfwdid = identifier + +let pr_ssrfwdid _ _ _ id = pr_spc () ++ pr_id id + +(* We use a primitive parser for the head identifier of forward *) +(* tactis to avoid syntactic conflicts with basic Coq tactics. *) +ARGUMENT EXTEND ssrfwdid TYPED AS ident PRINTED BY pr_ssrfwdid + | [ "Qed" ] -> [ Util.anomaly "Grammar placeholder match" ] +END + +let accept_ssrfwdid strm = + match Compat.get_tok (stream_nth 0 strm) with + | Tok.IDENT id -> accept_before_syms_or_any_id [":"; ":="; "("] strm + | _ -> raise Stream.Failure + + +let test_ssrfwdid = Gram.Entry.of_parser "test_ssrfwdid" accept_ssrfwdid + +GEXTEND Gram + GLOBAL: ssrfwdid; + ssrfwdid: [[ test_ssrfwdid; id = Prim.ident -> id ]]; + END + + + +(** Definition value formatting *) + +(* We use an intermediate structure to correctly render the binder list *) +(* abbreviations. We use a list of hints to extract the binders and *) +(* base term from a term, for the two first levels of representation of *) +(* of constr terms. *) + +type 'term ssrbind = + | Bvar of name + | Bdecl of name list * 'term + | Bdef of name * 'term option * 'term + | Bstruct of name + | Bcast of 'term + +let pr_binder prl = function + | Bvar x -> + pr_name x + | Bdecl (xs, t) -> + str "(" ++ pr_list pr_spc pr_name xs ++ str " : " ++ prl t ++ str ")" + | Bdef (x, None, v) -> + str "(" ++ pr_name x ++ str " := " ++ prl v ++ str ")" + | Bdef (x, Some t, v) -> + str "(" ++ pr_name x ++ str " : " ++ prl t ++ + str " := " ++ prl v ++ str ")" + | Bstruct x -> + str "{struct " ++ pr_name x ++ str "}" + | Bcast t -> + str ": " ++ prl t + +type 'term ssrbindval = 'term ssrbind list * 'term + +type ssrbindfmt = + | BFvar + | BFdecl of int (* #xs *) + | BFcast (* final cast *) + | BFdef of bool (* has cast? *) + | BFrec of bool * bool (* has struct? * has cast? *) + +let rec mkBstruct i = function + | Bvar x :: b -> + if i = 0 then [Bstruct x] else mkBstruct (i - 1) b + | Bdecl (xs, _) :: b -> + let i' = i - List.length xs in + if i' < 0 then [Bstruct (List.nth xs i)] else mkBstruct i' b + | _ :: b -> mkBstruct i b + | [] -> [] + +let rec format_local_binders h0 bl0 = match h0, bl0 with + | BFvar :: h, LocalRawAssum ([_, x], _, _) :: bl -> + Bvar x :: format_local_binders h bl + | BFdecl _ :: h, LocalRawAssum (lxs, _, t) :: bl -> + Bdecl (List.map snd lxs, t) :: format_local_binders h bl + | BFdef false :: h, LocalRawDef ((_, x), v) :: bl -> + Bdef (x, None, v) :: format_local_binders h bl + | BFdef true :: h, + LocalRawDef ((_, x), CCast (_, v, CastConv (_, t))) :: bl -> + Bdef (x, Some t, v) :: format_local_binders h bl + | _ -> [] + +let rec format_constr_expr h0 c0 = match h0, c0 with + | BFvar :: h, CLambdaN (_, [[_, x], _, _], c) -> + let bs, c' = format_constr_expr h c in + Bvar x :: bs, c' + | BFdecl _:: h, CLambdaN (_, [lxs, _, t], c) -> + let bs, c' = format_constr_expr h c in + Bdecl (List.map snd lxs, t) :: bs, c' + | BFdef false :: h, CLetIn(_, (_, x), v, c) -> + let bs, c' = format_constr_expr h c in + Bdef (x, None, v) :: bs, c' + | BFdef true :: h, CLetIn(_, (_, x), CCast (_, v, CastConv (_, t)), c) -> + let bs, c' = format_constr_expr h c in + Bdef (x, Some t, v) :: bs, c' + | [BFcast], CCast (_, c, CastConv (_, t)) -> + [Bcast t], c + | BFrec (has_str, has_cast) :: h, + CFix (_, _, [_, (Some locn, CStructRec), bl, t, c]) -> + let bs = format_local_binders h bl in + let bstr = if has_str then [Bstruct (Name (snd locn))] else [] in + bs @ bstr @ (if has_cast then [Bcast t] else []), c + | BFrec (_, has_cast) :: h, CCoFix (_, _, [_, bl, t, c]) -> + format_local_binders h bl @ (if has_cast then [Bcast t] else []), c + | _, c -> + [], c + +let rec format_glob_decl h0 d0 = match h0, d0 with + | BFvar :: h, (x, _, None, _) :: d -> + Bvar x :: format_glob_decl h d + | BFdecl 1 :: h, (x, _, None, t) :: d -> + Bdecl ([x], t) :: format_glob_decl h d + | BFdecl n :: h, (x, _, None, t) :: d when n > 1 -> + begin match format_glob_decl (BFdecl (n - 1) :: h) d with + | Bdecl (xs, _) :: bs -> Bdecl (x :: xs, t) :: bs + | bs -> Bdecl ([x], t) :: bs + end + | BFdef false :: h, (x, _, Some v, _) :: d -> + Bdef (x, None, v) :: format_glob_decl h d + | BFdef true:: h, (x, _, Some (GCast (_, v, CastConv (_, t))), _) :: d -> + Bdef (x, Some t, v) :: format_glob_decl h d + | _, (x, _, None, t) :: d -> + Bdecl ([x], t) :: format_glob_decl [] d + | _, (x, _, Some v, _) :: d -> + Bdef (x, None, v) :: format_glob_decl [] d + | _, [] -> [] + +let rec format_glob_constr h0 c0 = match h0, c0 with + | BFvar :: h, GLambda (_, x, _, _, c) -> + let bs, c' = format_glob_constr h c in + Bvar x :: bs, c' + | BFdecl 1 :: h, GLambda (_, x, _, t, c) -> + let bs, c' = format_glob_constr h c in + Bdecl ([x], t) :: bs, c' + | BFdecl n :: h, GLambda (_, x, _, t, c) when n > 1 -> + begin match format_glob_constr (BFdecl (n - 1) :: h) c with + | Bdecl (xs, _) :: bs, c' -> Bdecl (x :: xs, t) :: bs, c' + | _ -> [Bdecl ([x], t)], c + end + | BFdef false :: h, GLetIn(_, x, v, c) -> + let bs, c' = format_glob_constr h c in + Bdef (x, None, v) :: bs, c' + | BFdef true :: h, GLetIn(_, x, GCast (_, v, CastConv (_, t)), c) -> + let bs, c' = format_glob_constr h c in + Bdef (x, Some t, v) :: bs, c' + | [BFcast], GCast (_, c, CastConv(_, t)) -> + [Bcast t], c + | BFrec (has_str, has_cast) :: h, GRec (_, f, _, bl, t, c) + when Array.length c = 1 -> + let bs = format_glob_decl h bl.(0) in + let bstr = match has_str, f with + | true, GFix ([|Some i, GStructRec|], _) -> mkBstruct i bs + | _ -> [] in + bs @ bstr @ (if has_cast then [Bcast t.(0)] else []), c.(0) + | _, c -> + [], c + +(** Forward chaining argument *) + +(* There are three kinds of forward definitions: *) +(* - Hint: type only, cast to Type, may have proof hint. *) +(* - Have: type option + value, no space before type *) +(* - Pose: binders + value, space before binders. *) + +type ssrfwdkind = FwdHint of string * bool | FwdHave | FwdPose + +type ssrfwdfmt = ssrfwdkind * ssrbindfmt list + +let pr_fwdkind = function + | FwdHint (s,_) -> str (s ^ " ") | _ -> str " :=" ++ spc () +let pr_fwdfmt (fk, _ : ssrfwdfmt) = pr_fwdkind fk + +let wit_ssrfwdfmt, globwit_ssrfwdfmt, rawwit_ssrfwdfmt = + add_genarg "ssrfwdfmt" pr_fwdfmt + +(* type ssrfwd = ssrfwdfmt * ssrterm *) + +let mkFwdVal fk c = ((fk, []), mk_term ' ' c), rawltacctx +let mkssrFwdVal fk c = ((fk, []), (c,None)), rawltacctx + +let mkFwdCast fk loc t c = + ((fk, [BFcast]), mk_term ' ' (CCast (loc, c, dC t))), rawltacctx +let mkssrFwdCast fk loc t c = ((fk, [BFcast]), (c, Some t)), rawltacctx + +let mkFwdHint s t = + let loc = constr_loc t in + mkFwdCast (FwdHint (s,false)) loc t (CHole (loc, None)) +let mkFwdHintNoTC s t = + let loc = constr_loc t in + mkFwdCast (FwdHint (s,true)) loc t (CHole (loc, None)) + +let pr_gen_fwd prval prc prlc fk (bs, c) = + let prc s = str s ++ spc () ++ prval prc prlc c in + match fk, bs with + | FwdHint (s,_), [Bcast t] -> str s ++ spc () ++ prlc t + | FwdHint (s,_), _ -> prc (s ^ "(* typeof *)") + | FwdHave, [Bcast t] -> str ":" ++ spc () ++ prlc t ++ prc " :=" + | _, [] -> prc " :=" + | _, _ -> spc () ++ pr_list spc (pr_binder prlc) bs ++ prc " :=" + +let pr_fwd_guarded prval prval' = function +| ((fk, h), (_, (_, Some c))), _ -> + pr_gen_fwd prval pr_constr_expr prl_constr_expr fk (format_constr_expr h c) +| ((fk, h), (_, (c, None))), _ -> + pr_gen_fwd prval' pr_glob_constr prl_glob_constr fk (format_glob_constr h c) + +let pr_unguarded prc prlc = prlc + +let pr_fwd = pr_fwd_guarded pr_unguarded pr_unguarded +let pr_ssrfwd _ _ _ = pr_fwd + +ARGUMENT EXTEND ssrfwd TYPED AS (ssrfwdfmt * ssrterm) * ltacctx + PRINTED BY pr_ssrfwd + | [ ":=" lconstr(c) ] -> [ mkFwdVal FwdPose c ] + | [ ":" lconstr (t) ":=" lconstr(c) ] -> [ mkFwdCast FwdPose loc t c ] +END + +(** Independent parsing for binders *) + +(* The pose, pose fix, and pose cofix tactics use these internally to *) +(* parse argument fragments. *) + +let pr_ssrbvar prc _ _ v = prc v + +ARGUMENT EXTEND ssrbvar TYPED AS constr PRINTED BY pr_ssrbvar +| [ ident(id) ] -> [ mkCVar loc id ] +| [ "_" ] -> [ CHole (loc, None) ] +END + +let bvar_lname = function + | CRef (Ident (loc, id)) -> loc, Name id + | c -> constr_loc c, Anonymous + +let pr_ssrbinder prc _ _ (_, c) = prc c + +ARGUMENT EXTEND ssrbinder TYPED AS ssrfwdfmt * constr PRINTED BY pr_ssrbinder + | [ ssrbvar(bv) ] -> + [ let xloc, _ as x = bvar_lname bv in + (FwdPose, [BFvar]), + CLambdaN (loc,[[x],Default Explicit,CHole (xloc,None)],CHole (loc,None)) ] + | [ "(" ssrbvar(bv) ")" ] -> + [ let xloc, _ as x = bvar_lname bv in + (FwdPose, [BFvar]), + CLambdaN (loc,[[x],Default Explicit,CHole (xloc,None)],CHole (loc,None)) ] + | [ "(" ssrbvar(bv) ":" lconstr(t) ")" ] -> + [ let x = bvar_lname bv in + (FwdPose, [BFdecl 1]), + CLambdaN (loc, [[x], Default Explicit, t], CHole (loc, None)) ] + | [ "(" ssrbvar(bv) ne_ssrbvar_list(bvs) ":" lconstr(t) ")" ] -> + [ let xs = List.map bvar_lname (bv :: bvs) in + let n = List.length xs in + (FwdPose, [BFdecl n]), + CLambdaN (loc, [xs, Default Explicit, t], CHole (loc, None)) ] + | [ "(" ssrbvar(id) ":" lconstr(t) ":=" lconstr(v) ")" ] -> + [ let loc' = Util.join_loc (constr_loc t) (constr_loc v) in + let v' = CCast (loc', v, dC t) in + (FwdPose,[BFdef true]), CLetIn (loc,bvar_lname id, v',CHole (loc,None)) ] + | [ "(" ssrbvar(id) ":=" lconstr(v) ")" ] -> + [ (FwdPose,[BFdef false]), CLetIn (loc,bvar_lname id, v,CHole (loc,None)) ] +END + +GEXTEND Gram + GLOBAL: ssrbinder; + ssrbinder: [ + [ ["of" | "&"]; c = operconstr LEVEL "99" -> + (FwdPose, [BFvar]), + CLambdaN (loc,[[loc,Anonymous],Default Explicit,c],CHole (loc,None)) ] + ]; +END + +let rec binders_fmts = function + | ((_, h), _) :: bs -> h @ binders_fmts bs + | _ -> [] + +let push_binders c2 bs = + let loc2 = constr_loc c2 in let mkloc loc1 = Util.join_loc loc1 loc2 in + let rec loop ty c = function + | (_, CLambdaN (loc1, b, _)) :: bs when ty -> + CProdN (mkloc loc1, b, loop ty c bs) + | (_, CLambdaN (loc1, b, _)) :: bs -> + CLambdaN (mkloc loc1, b, loop ty c bs) + | (_, CLetIn (loc1, x, v, _)) :: bs -> + CLetIn (mkloc loc1, x, v, loop ty c bs) + | [] -> c + | _ -> anomaly "binder not a lambda nor a let in" in + match c2 with + | CCast (x, ct, CastConv (y, cty)) -> + (CCast (x, loop false ct bs, CastConv (y, loop true cty bs))) + | ct -> loop false ct bs + +let rec fix_binders = function + | (_, CLambdaN (_, [xs, _, t], _)) :: bs -> + LocalRawAssum (xs, Default Explicit, t) :: fix_binders bs + | (_, CLetIn (_, x, v, _)) :: bs -> + LocalRawDef (x, v) :: fix_binders bs + | _ -> [] + +let pr_ssrstruct _ _ _ = function + | Some id -> str "{struct " ++ pr_id id ++ str "}" + | None -> mt () + +ARGUMENT EXTEND ssrstruct TYPED AS ident option PRINTED BY pr_ssrstruct +| [ "{" "struct" ident(id) "}" ] -> [ Some id ] +| [ ] -> [ None ] +END + +(** The "pose" tactic *) + +(* The plain pose form. *) + +let bind_fwd bs = function + | ((fk, h), (ck, (rc, Some c))), ctx -> + ((fk,binders_fmts bs @ h), (ck,(rc,Some (push_binders c bs)))), ctx + | fwd -> fwd + +ARGUMENT EXTEND ssrposefwd TYPED AS ssrfwd PRINTED BY pr_ssrfwd + | [ ssrbinder_list(bs) ssrfwd(fwd) ] -> [ bind_fwd bs fwd ] +END + +(* The pose fix form. *) + +let pr_ssrfixfwd _ _ _ (id, fwd) = str " fix " ++ pr_id id ++ pr_fwd fwd + +let bvar_locid = function + | CRef (Ident (loc, id)) -> loc, id + | _ -> Util.error "Missing identifier after \"(co)fix\"" + + +ARGUMENT EXTEND ssrfixfwd TYPED AS ident * ssrfwd PRINTED BY pr_ssrfixfwd + | [ "fix" ssrbvar(bv) ssrbinder_list(bs) ssrstruct(sid) ssrfwd(fwd) ] -> + [ let (_, id) as lid = bvar_locid bv in + let ((fk, h), (ck, (rc, oc))), ctx = fwd in + let c = Option.get oc in + let has_cast, t', c' = match format_constr_expr h c with + | [Bcast t'], c' -> true, t', c' + | _ -> false, CHole (constr_loc c, None), c in + let lb = fix_binders bs in + let has_struct, i = + let rec loop = function + (l', Name id') :: _ when sid = Some id' -> true, (l', id') + | [l', Name id'] when sid = None -> false, (l', id') + | _ :: bn -> loop bn + | [] -> Util.error "Bad structural argument" in + loop (names_of_local_assums lb) in + let h' = BFrec (has_struct, has_cast) :: binders_fmts bs in + let fix = CFix (loc, lid, [lid, (Some i, CStructRec), lb, t', c']) in + id, (((fk, h'), (ck, (rc, Some fix))), ctx) ] +END + + +(* The pose cofix form. *) + +let pr_ssrcofixfwd _ _ _ (id, fwd) = str " cofix " ++ pr_id id ++ pr_fwd fwd + +ARGUMENT EXTEND ssrcofixfwd TYPED AS ssrfixfwd PRINTED BY pr_ssrcofixfwd + | [ "cofix" ssrbvar(bv) ssrbinder_list(bs) ssrfwd(fwd) ] -> + [ let _, id as lid = bvar_locid bv in + let ((fk, h), (ck, (rc, oc))), ctx = fwd in + let c = Option.get oc in + let has_cast, t', c' = match format_constr_expr h c with + | [Bcast t'], c' -> true, t', c' + | _ -> false, CHole (constr_loc c, None), c in + let h' = BFrec (false, has_cast) :: binders_fmts bs in + let cofix = CCoFix (loc, lid, [lid, fix_binders bs, t', c']) in + id, (((fk, h'), (ck, (rc, Some cofix))), ctx) + ] +END + +let ssrposetac (id, ((_, t), ctx)) gl = + posetac id (snd(pf_abs_ssrterm (get_ltacctx ctx) gl t)) gl + + +let prof_ssrposetac = mk_profiler "ssrposetac";; +let ssrposetac arg gl = prof_ssrposetac.profile (ssrposetac arg) gl;; + +TACTIC EXTEND ssrpose +| [ "pose" ssrfixfwd(ffwd) ] -> [ ssrposetac ffwd ] +| [ "pose" ssrcofixfwd(ffwd) ] -> [ ssrposetac ffwd ] +| [ "pose" ssrfwdid(id) ssrposefwd(fwd) ] -> [ ssrposetac (id, fwd) ] +END + +(** The "set" tactic *) + +(* type ssrsetfwd = ssrfwd * ssrdocc *) + +let guard_setrhs s i = s.[i] = '{' + +let pr_setrhs occ prc prlc c = + if occ = nodocc then pr_guarded guard_setrhs prlc c else pr_docc occ ++ prc c + +let pr_fwd_guarded prval prval' = function +| ((fk, h), (_, (_, Some c))), _ -> + pr_gen_fwd prval pr_constr_expr prl_constr_expr fk (format_constr_expr h c) +| ((fk, h), (_, (c, None))), _ -> + pr_gen_fwd prval' pr_glob_constr prl_glob_constr fk (format_glob_constr h c) + +(* This does not print the type, it should be fixed... *) +let pr_ssrsetfwd _ _ _ ((((fk,_),(t,_)),ctx), docc) = + pr_gen_fwd (fun _ _ -> pr_cpattern) + (fun _ -> mt()) (fun _ -> mt()) fk ([Bcast ()],t) + +ARGUMENT EXTEND ssrsetfwd +TYPED AS ((ssrfwdfmt * (lcpattern * ssrterm option)) * ltacctx) * ssrdocc +PRINTED BY pr_ssrsetfwd +| [ ":" lconstr(t) ":=" "{" ssrocc(occ) "}" cpattern(c) ] -> + [ mkssrFwdCast FwdPose loc (mk_lterm t) c, mkocc occ ] +| [ ":" lconstr(t) ":=" lcpattern(c) ] -> + [ mkssrFwdCast FwdPose loc (mk_lterm t) c, nodocc ] +| [ ":=" "{" ssrocc(occ) "}" cpattern(c) ] -> + [ mkssrFwdVal FwdPose c, mkocc occ ] +| [ ":=" lcpattern(c) ] -> [ mkssrFwdVal FwdPose c, nodocc ] +END + +let ssrsettac ist id (((_, (pat, pty)), _), (_, occ)) gl = + let pat = interp_cpattern ist gl pat (Option.map snd pty) in + let cl, sigma, env = pf_concl gl, project gl, pf_env gl in + let c, cl = + try fill_occ_pattern ~raise_NoMatch:true env sigma cl pat occ 1 + with NoMatch -> redex_of_pattern ~resolve_typeclasses:true env pat, cl in + if occur_existential c then errorstrm(str"The pattern"++spc()++ + pr_constr_pat c++spc()++str"did not match and has holes."++spc()++ + str"Did you mean pose?") else + let c, cty = match kind_of_term c with + | Cast(t, DEFAULTcast, ty) -> t, ty + | _ -> c, pf_type_of gl c in + let cl' = mkLetIn (Name id, c, cty, cl) in + tclTHEN (convert_concl cl') (introid id) gl + +TACTIC EXTEND ssrset +| [ "set" ssrfwdid(id) ssrsetfwd(fwd) ssrclauses(clauses) ] -> + [ let (_, ctx), _ = fwd in + let ist = get_ltacctx ctx in + tclCLAUSES ist (ssrsettac ist id fwd) clauses ] +END + +(** The "have" tactic *) + +(* type ssrhavefwd = ssrfwd * ssrhint *) + +let pr_ssrhavefwd _ _ prt (fwd, hint) = pr_fwd fwd ++ pr_hint prt hint + +ARGUMENT EXTEND ssrhavefwd TYPED AS ssrfwd * ssrhint PRINTED BY pr_ssrhavefwd +| [ ":" lconstr(t) ssrhint(hint) ] -> [ mkFwdHint ":" t, hint ] +| [ ":" lconstr(t) ":=" lconstr(c) ] -> [ mkFwdCast FwdHave loc t c, nohint ] +| [ ":" lconstr(t) ":=" ] -> [ mkFwdHintNoTC ":" t, nohint ] +| [ ":=" lconstr(c) ] -> [ mkFwdVal FwdHave c, nohint ] +END + +let intro_id_to_binder = List.map (function + | IpatId id -> + let xloc, _ as x = bvar_lname (mkCVar dummy_loc id) in + (FwdPose, [BFvar]), + CLambdaN (dummy_loc, [[x], Default Explicit, CHole (xloc, None)], + CHole (dummy_loc, None)) + | _ -> anomaly "non-id accepted as binder") + +let binder_to_intro_id = List.map (function + | (FwdPose, [BFvar]), CLambdaN (_,[ids,_,_],_) + | (FwdPose, [BFdecl _]), CLambdaN (_,[ids,_,_],_) -> + List.map (function (_, Name id) -> IpatId id | _ -> IpatAnon) ids + | (FwdPose, [BFdef _]), CLetIn (_,(_,Name id),_,_) -> [IpatId id] + | (FwdPose, [BFdef _]), CLetIn (_,(_,Anonymous),_,_) -> [IpatAnon] + | _ -> anomaly "ssrbinder is not a binder") + +let pr_ssrhavefwdwbinders _ _ prt (tr,(hpats, (fwd, hint))) = + pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint + +ARGUMENT EXTEND ssrhavefwdwbinders + TYPED AS bool * (ssrhpats * (ssrfwd * ssrhint)) + PRINTED BY pr_ssrhavefwdwbinders +| [ ssrhpats_wtransp(trpats) ssrbinder_list(bs) ssrhavefwd(fwd) ] -> + [ let tr, pats = trpats in + let ((clr, pats), binders), simpl = pats in + let allbs = intro_id_to_binder binders @ bs in + let allbinders = binders @ List.flatten (binder_to_intro_id bs) in + let hint = bind_fwd allbs (fst fwd), snd fwd in + tr, ((((clr, pats), allbinders), simpl), hint) ] +END + +(* Tactic. *) + +let examine_abstract id gl = + let tid = pf_type_of gl id in + let abstract = mkSsrConst "abstract" in + if not (isApp tid) || not (eq_constr (fst(destApp tid)) abstract) then + errorstrm(strbrk"not an abstract constant: "++pr_constr id); + let _, args_id = destApp tid in + if Array.length args_id <> 3 then + errorstrm(strbrk"not a proper abstract constant: "++pr_constr id); + if not (isEvar args_id.(2)) then + errorstrm(strbrk"abstract constant "++pr_constr id++str" already used"); + args_id + +let pf_find_abstract_proof check_lock gl abstract_n = + let fire gl t = Reductionops.nf_evar (project gl) t in + let abstract = mkSsrConst "abstract" in + let l = Evd.fold_undefined (fun e ei l -> + match kind_of_term ei.Evd.evar_concl with + | App(hd, [|ty; n; lock|]) + when (not check_lock || + (occur_existential (fire gl ty) && + isEvar (fire gl lock))) && + eq_constr hd abstract && eq_constr n abstract_n -> e::l + | _ -> l) (project gl) [] in + match l with + | [e] -> e + | _ -> errorstrm(strbrk"abstract constant "++pr_constr abstract_n++ + strbrk" not found in the evar map exactly once. "++ + strbrk"Did you tamper with it?") + +let unfold cl = + let module R = Reductionops in let module F = Closure.RedFlags in + reduct_in_concl (R.clos_norm_flags (F.mkflags + (List.map (fun c -> F.fCONST (destConst c)) cl @ [F.fBETA; F.fIOTA]))) + +let havegentac ist t gl = + let _, c = pf_abs_ssrterm ist gl t in + apply_type (mkArrow (pf_type_of gl c) (pf_concl gl)) [c] gl + +let havetac + (transp,((((clr, pats), binders), simpl), ((((fk, _), t), ctx), hint))) + suff namefst gl += + let ist, concl = get_ltacctx ctx, pf_concl gl in + let skols, pats = + List.partition (function IpatNewHidden _ -> true | _ -> false) pats in + let itac_mkabs = introstac ~ist skols in + let itac_c = introstac ~ist (IpatSimpl(clr,Nop) :: pats) in + let itac, id, clr = introstac ~ist pats, tclIDTAC, cleartac clr in + let binderstac n = + let rec aux = function 0 -> [] | n -> IpatAnon :: aux (n-1) in + tclTHEN (if binders <> [] then introstac ~ist (aux n) else tclIDTAC) + (introstac ~ist binders) in + let simpltac = introstac ~ist simpl in + let fixtc = + not !ssrhaveNOtcresolution && + match fk with FwdHint(_,true) -> false | _ -> true in + let hint = hinttac ist true hint in + let cuttac t gl = + if transp then + (* The v8.4 refiner is too stupid to deal with a let-in, apparently. + * Let's do things by hand... *) + let concl = pf_concl gl in + let gl, extra = pf_new_evar gl t in + let gl, kont = pf_new_evar gl (mkLetIn (Anonymous, extra, t, concl)) in + let step = mkApp (mkSsrConst "ssr_have_let", [|concl; t; extra; kont|]) in + pf_partial_solution gl step [extra; kont] + else + basecuttac "ssr_have" t gl in + (* Introduce now abstract constants, so that everything sees them *) + let abstract_key = mkSsrConst "abstract_key" in + let unlock_abs args_id gl = pf_unify_HO gl args_id.(2) abstract_key in + tclTHENFIRST itac_mkabs (fun gl -> + let mkt t = mk_term ' ' t in + let mkl t = (' ', (t, None)) in + let interp gl rtc t = pf_abs_ssrterm ~resolve_typeclasses:rtc ist gl t in + let interp_ty gl rtc t = + let a,b,_ = pf_interp_ty ~resolve_typeclasses:rtc ist gl t in a, b in + let ct, cty, hole, loc = match t with + | _, (_, Some (CCast (loc, ct, CastConv (_, cty)))) -> + mkt ct, mkt cty, mkt (mkCHole dummy_loc), loc + | _, (_, Some ct) -> + mkt ct, mkt (mkCHole dummy_loc), mkt (mkCHole dummy_loc), dummy_loc + | _, (GCast (loc, ct, CastConv (_, cty)), None) -> + mkl ct, mkl cty, mkl mkRHole, loc + | _, (t, None) -> mkl t, mkl mkRHole, mkl mkRHole, dummy_loc in + let gl, cut, sol, itac1, itac2 = + match fk, namefst, suff with + | FwdHave, true, true -> + errorstrm (str"Suff have does not accept a proof term") + | FwdHave, false, true -> + let cty = combineCG cty hole (mkCArrow loc) mkRArrow in + let _, t = interp gl false (combineCG ct cty (mkCCast loc) mkRCast) in + let ty = pf_type_of gl t in + let ctx, _ = decompose_prod_n 1 ty in + let assert_is_conv gl = + try convert_concl (compose_prod ctx concl) gl + with _ -> errorstrm (str "Given proof term is not of type " ++ + pr_constr (mkArrow (mkVar (id_of_string "_")) concl)) in + gl, ty, tclTHEN assert_is_conv (apply t), id, itac_c + | FwdHave, false, false -> + let skols = List.flatten (List.map (function + | IpatNewHidden ids -> ids + | _ -> assert false) skols) in + let skols_args = + List.map (fun id -> examine_abstract (mkVar id) gl) skols in + let gl = List.fold_right unlock_abs skols_args gl in + let sigma, t = interp gl false (combineCG ct cty (mkCCast loc) mkRCast) in + let gl = re_sig (sig_it gl) sigma in + let gs = + List.map (fun a -> pf_find_abstract_proof false gl a.(1)) skols_args in + let tacopen_skols gl = + let stuff, g = Refiner.unpackage gl in + Refiner.repackage stuff ((List.map Goal.build gs) @ [g]) in + gl, pf_type_of gl t, apply t, id, + tclTHEN (tclTHEN itac_c simpltac) + (tclTHEN tacopen_skols (unfold [mkSsrConst "abstract";abstract_key])) + | _,true,true -> + gl, mkArrow (snd (interp_ty gl fixtc cty)) concl, hint, itac, clr + | _,false,true -> + gl, mkArrow (snd (interp_ty gl fixtc cty)) concl, hint, id, itac_c + | _, false, false -> + let n, cty = interp_ty gl fixtc cty in + gl, cty, tclTHEN (binderstac n) hint, id, tclTHEN itac_c simpltac + | _, true, false -> assert false in + tclTHENS (cuttac cut) [ tclTHEN sol itac1; itac2 ] gl) + gl +;; + +(* to extend the abstract value one needs: + Utility lemma to partially instantiate an abstract constant type. + Lemma use_abstract T n l (x : abstract T n l) : T. + Proof. by case: l x. Qed. +*) +let ssrabstract ctx gens (*last*) gl = + let ist = get_ltacctx ctx in + let main _ (_,cid) ist gl = +(* + let proj1, proj2, prod = + let pdata = build_prod () in + pdata.Coqlib.proj1, pdata.Coqlib.proj2, pdata.Coqlib.typ in +*) + let concl, env = pf_concl gl, pf_env gl in + let fire gl t = Reductionops.nf_evar (project gl) t in + let abstract = mkSsrConst "abstract" in + let abstract_key = mkSsrConst "abstract_key" in + let id = mkVar (Option.get (id_of_cpattern cid)) in + let args_id = examine_abstract id gl in + let abstract_n = args_id.(1) in + let abstract_proof = pf_find_abstract_proof true gl abstract_n in + let gl, proof = + let pf_unify_HO gl a b = + try pf_unify_HO gl a b + with _ -> errorstrm(strbrk"The abstract variable "++pr_constr id++ + strbrk" cannot abstract this goal. Did you generalize it?") in + let rec find_hole p t = + match kind_of_term t with + | Evar _ (*when last*) -> pf_unify_HO gl concl t, p +(* + | Evar _ -> + let sigma, it = project gl, sig_it gl in + let sigma, ty = Evarutil.new_type_evar sigma env in + let gl = re_sig it sigma in + let p = mkApp (proj2,[|ty;concl;p|]) in + let concl = mkApp(prod,[|ty; concl|]) in + pf_unify_HO gl concl t, p + | App(hd, [|left; right|]) when eq_constr hd prod -> + find_hole (mkApp (proj1,[|left;right;p|])) left +*) + | _ -> errorstrm(strbrk"abstract constant "++pr_constr abstract_n++ + strbrk" has an unexpected shape. Did you tamper with it?") + in + find_hole + ((*if last then*) id + (*else mkApp(mkSsrConst "use_abstract",Array.append args_id [|id|])*)) + (fire gl args_id.(0)) in + let gl = (*if last then*) pf_unify_HO gl abstract_key args_id.(2) (*else gl*) in + let proof = fire gl proof in +(* if last then *) + let tacopen gl = + let stuff, g = Refiner.unpackage gl in + Refiner.repackage stuff [ g; Goal.build abstract_proof ] in + tclTHENS tacopen [tclSOLVE [apply proof];unfold[abstract;abstract_key]] gl +(* else apply proof gl *) + in + let introback ist (gens, _) = + introstac ~ist + (List.map (fun (_,cp) -> match id_of_cpattern cp with + | None -> IpatAnon + | Some id -> IpatId id) + (List.tl (List.hd gens))) in + tclTHEN (with_dgens gens main ist) (introback ist gens) gl + +(* The standard TACTIC EXTEND does not work for abstract *) +GEXTEND Gram + GLOBAL: tactic_expr; + tactic_expr: LEVEL "3" + [ RIGHTA [ IDENT "abstract"; gens = ssrdgens; ctx = ltacctx -> + Tacexpr.TacAtom(loc,Tacexpr.TacExtend (loc, "ssrabstract", + [Genarg.in_gen rawwit_ssrdgens gens; + Genarg.in_gen rawwit_ltacctx ctx])) ]]; +END +TACTIC EXTEND ssrabstract +| [ "abstract" ssrdgens(gens) ltacctx(ctx) ] -> [ + if List.length (fst gens) <> 1 then + errorstrm (str"dependents switches '/' not allowed here"); + ssrabstract ctx gens ] +END + +let prof_havetac = mk_profiler "havetac";; +let havetac arg a b gl = prof_havetac.profile (havetac arg a b) gl;; + +TACTIC EXTEND ssrhave +| [ "have" ssrhavefwdwbinders(fwd) ] -> + [ havetac fwd false false ] +END + +TACTIC EXTEND ssrhavesuff +| [ "have" "suff" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ havetac (false,(pats,fwd)) true false ] +END + +TACTIC EXTEND ssrhavesuffices +| [ "have" "suffices" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ havetac (false,(pats,fwd)) true false ] +END + +TACTIC EXTEND ssrsuffhave +| [ "suff" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ havetac (false,(pats,fwd)) true true ] +END + +TACTIC EXTEND ssrsufficeshave +| [ "suffices" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ havetac (false,(pats,fwd)) true true ] +END + +(** The "suffice" tactic *) + +let pr_ssrsufffwdwbinders _ _ prt (hpats, (fwd, hint)) = + pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint + +ARGUMENT EXTEND ssrsufffwd + TYPED AS ssrhpats * (ssrfwd * ssrhint) PRINTED BY pr_ssrsufffwdwbinders +| [ ssrhpats(pats) ssrbinder_list(bs) ":" lconstr(t) ssrhint(hint) ] -> + [ let ((clr, pats), binders), simpl = pats in + let allbs = intro_id_to_binder binders @ bs in + let allbinders = binders @ List.flatten (binder_to_intro_id bs) in + let fwd = mkFwdHint ":" t in + (((clr, pats), allbinders), simpl), (bind_fwd allbs fwd, hint) ] +END + +let sufftac ((((clr, pats),binders),simpl), (((_, c), ctx), hint)) = + let ist = get_ltacctx ctx in + let htac = tclTHEN (introstac ~ist pats) (hinttac ist true hint) in + let c = match c with + | (a, (b, Some (CCast (_, _, CastConv (_, cty))))) -> a, (b, Some cty) + | (a, (GCast (_, _, CastConv (_, cty)), None)) -> a, (cty, None) + | _ -> anomaly "suff: ssr cast hole deleted by typecheck" in + let ctac gl = basecuttac "ssr_suff" (pi2 (pf_interp_ty ist gl c)) gl in + tclTHENS ctac [htac; tclTHEN (cleartac clr) (introstac ~ist (binders@simpl))] + +TACTIC EXTEND ssrsuff +| [ "suff" ssrsufffwd(fwd) ] -> [ sufftac fwd ] +END + +TACTIC EXTEND ssrsuffices +| [ "suffices" ssrsufffwd(fwd) ] -> [ sufftac fwd ] +END + +(** The "wlog" (Without Loss Of Generality) tactic *) + +(* type ssrwlogfwd = ssrwgen list * ssrfwd *) + +let pr_ssrwlogfwd _ _ _ (gens, t) = + str ":" ++ pr_list mt pr_wgen gens ++ spc() ++ pr_fwd t + +ARGUMENT EXTEND ssrwlogfwd TYPED AS ssrwgen list * ssrfwd + PRINTED BY pr_ssrwlogfwd +| [ ":" ssrwgen_list(gens) "/" lconstr(t) ] -> [ gens, mkFwdHint "/" t] +END + +let destProd_or_LetIn c = + match kind_of_term c with + | Prod (n,ty,c) -> (n,None,ty), c + | LetIn (n,bo,ty,c) -> (n,Some bo,ty), c + | _ -> raise (Invalid_argument "destProd_or_LetIn") + +let wlogtac (((clr0, pats),_),_) (gens, ((_, ct), ctx)) hint suff ghave gl = + let ist = get_ltacctx ctx in + let mkabs gen = abs_wgen false ist gl (fun x -> x) gen in + let mkclr gen clrs = clr_of_wgen gen clrs in + let mkpats = function + | _, Some ((x, _), _) -> fun pats -> IpatId (hoi_id x) :: pats + | _ -> fun x -> x in + let ct = match ct with + | (a, (b, Some (CCast (_, _, CastConv (_, cty))))) -> a, (b, Some cty) + | (a, (GCast (_, _, CastConv (_, cty)), None)) -> a, (cty, None) + | _ -> anomaly "wlog: ssr cast hole deleted by typecheck" in + let cut_implies_goal = not (suff || ghave <> `NoGen) in + let c, args, ct = + let gens = List.filter (function _, Some _ -> true | _ -> false) gens in + let concl = pf_concl gl in + let c = mkProp in + let c = if cut_implies_goal then mkArrow c concl else c in + let args, c = List.fold_right mkabs gens ([],c) in + let env, _ = + List.fold_left (fun (env, c) _ -> + let rd, c = destProd_or_LetIn c in + Environ.push_rel rd env, c) (pf_env gl, c) gens in + let sigma, ev = Evarutil.new_evar (project gl) env Term.mkProp in + let k, _ = Term.destEvar ev in + let fake_gl = { Evd.it = Goal.build k; Evd.sigma = sigma } in + let _, ct, _ = pf_interp_ty ist fake_gl ct in + let rec subst c g s = match kind_of_term c, g with + | Prod(Anonymous,_,c), [] -> mkProd(Anonymous, subst_vars s ct, c) + | Sort _, [] -> subst_vars s ct + | LetIn(Name id as n,b,ty,c), _::g -> mkLetIn (n,b,ty,subst c g (id::s)) + | Prod(Name id as n,ty,c), _::g -> mkProd (n,ty,subst c g (id::s)) + | _ -> anomaly "SSR: wlog: subst" in + let c = subst c gens [] in + let rec pired c = function + | [] -> c + | t::ts as args -> match kind_of_term c with + | Prod(_,_,c) -> pired (subst1 t c) ts + | LetIn(id,b,ty,c) -> mkLetIn (id,b,ty,pired c args) + | _ -> anomaly "SSR: wlog: pired" in + c, args, pired c args in + let tacipat pats = introstac ~ist pats in + let tacigens = + tclTHEN + (tclTHENLIST(List.rev(List.fold_right mkclr gens [cleartac clr0]))) + (introstac ~ist (List.fold_right mkpats gens [])) in + let hinttac = hinttac ist true hint in + let cut_kind, fst_goal_tac, snd_goal_tac = + match suff, ghave with + | true, `NoGen -> "ssr_wlog", tclTHEN hinttac (tacipat pats), tacigens + | false, `NoGen -> "ssr_wlog", hinttac, tclTHEN tacigens (tacipat pats) + | true, `Gen _ -> assert false + | false, `Gen id -> + if gens = [] then errorstrm(str"gen have requires some generalizations"); + let clear0 = cleartac clr0 in + let id, name_general_hyp, cleanup, pats = match id, pats with + | None, (IpatId id as ip)::pats -> Some id, tacipat [ip], clear0, pats + | None, _ -> None, tclIDTAC, clear0, pats + | Some (Some id),_ -> Some id, introid id, clear0, pats + | Some _,_ -> + let id = mk_anon_id "tmp" gl in + Some id, introid id, tclTHEN clear0 (clear [id]), pats in + let tac_specialize = match id with + | None -> tclIDTAC + | Some id -> + if pats = [] then tclIDTAC else + let args = Array.of_list args in + pp(lazy(str"specialized="++pr_constr (mkApp (mkVar id,args)))); + pp(lazy(str"specialized_ty="++pr_constr ct)); + tclTHENS (basecuttac "ssr_have" ct) + [apply (mkApp (mkVar id,args)); tclIDTAC] in + "ssr_have", + (if hint = nohint then tacigens else hinttac), + tclTHENLIST [name_general_hyp; tac_specialize; tacipat pats; cleanup] + in + tclTHENS (basecuttac cut_kind c) [fst_goal_tac; snd_goal_tac] gl + +TACTIC EXTEND ssrwlog +| [ "wlog" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ wlogtac pats fwd hint false `NoGen ] +END + +TACTIC EXTEND ssrwlogs +| [ "wlog" "suff" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ wlogtac pats fwd hint true `NoGen ] +END + +TACTIC EXTEND ssrwlogss +| [ "wlog" "suffices" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> + [ wlogtac pats fwd hint true `NoGen ] +END + +TACTIC EXTEND ssrwithoutloss +| [ "without" "loss" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ wlogtac pats fwd hint false `NoGen ] +END + +TACTIC EXTEND ssrwithoutlosss +| [ "without" "loss" "suff" + ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ wlogtac pats fwd hint true `NoGen ] +END + +TACTIC EXTEND ssrwithoutlossss +| [ "without" "loss" "suffices" + ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> + [ wlogtac pats fwd hint true `NoGen ] +END + +(* Generally have *) +let pr_idcomma _ _ _ = function + | None -> mt() + | Some None -> str"_, " + | Some (Some id) -> pr_id id ++ str", " + +ARGUMENT EXTEND ssr_idcomma TYPED AS ident option option PRINTED BY pr_idcomma + | [ ] -> [ None ] +END + +let accept_idcomma strm = + match Compat.get_tok (stream_nth 0 strm) with + | Tok.IDENT _ | Tok.KEYWORD "_" -> accept_before_syms [","] strm + | _ -> raise Stream.Failure + +let test_idcomma = Gram.Entry.of_parser "test_idcomma" accept_idcomma + +GEXTEND Gram + GLOBAL: ssr_idcomma; + ssr_idcomma: [ [ test_idcomma; + ip = [ id = IDENT -> Some (id_of_string id) | "_" -> None ]; "," -> + Some ip + ] ]; +END + +let augment_preclr clr1 (((clr0, x),y),z) = (((clr1 @ clr0, x),y),z) + +TACTIC EXTEND ssrgenhave +| [ "gen" "have" ssrclear(clr) + ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ let pats = augment_preclr clr pats in + wlogtac pats fwd hint false (`Gen id) ] +END + +TACTIC EXTEND ssrgenhave2 +| [ "generally" "have" ssrclear(clr) + ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ let pats = augment_preclr clr pats in + wlogtac pats fwd hint false (`Gen id) ] +END + +(** Canonical Structure alias *) + +let def_body : Vernacexpr.definition_expr Gram.Entry.e = Obj.magic + (Grammar.Entry.find (Obj.magic gallina_ext) "vernac:def_body") in + +GEXTEND Gram + GLOBAL: gallina_ext; + + gallina_ext: + (* Canonical structure *) + [[ IDENT "Canonical"; qid = Constr.global -> + Vernacexpr.VernacCanonical (AN qid) + | IDENT "Canonical"; ntn = Prim.by_notation -> + Vernacexpr.VernacCanonical (ByNotation ntn) + | IDENT "Canonical"; qid = Constr.global; + d = def_body -> + let s = coerce_reference_to_id qid in + Vernacexpr.VernacDefinition + ((Decl_kinds.Global,Decl_kinds.CanonicalStructure), + (dummy_loc,s),(d ), + (fun _ -> Recordops.declare_canonical_structure)) + ]]; +END + +(** 9. Keyword compatibility fixes. *) + +(* Coq v8.1 notation uses "by" and "of" quasi-keywords, i.e., reserved *) +(* identifiers used as keywords. This is incompatible with ssreflect.v *) +(* which makes "by" and "of" true keywords, because of technicalities *) +(* in the internal lexer-parser API of Coq. We patch this here by *) +(* adding new parsing rules that recognize the new keywords. *) +(* To make matters worse, the Coq grammar for tactics fails to *) +(* export the non-terminals we need to patch. Fortunately, the CamlP5 *) +(* API provides a backdoor access (with loads of Obj.magic trickery). *) + +(* Coq v8.3 defines "by" as a keyword, some hacks are not needed any *) +(* longer and thus comment out. Such comments are marked with v8.3 *) + +let tac_ent = List.fold_left Grammar.Entry.find (Obj.magic simple_tactic) in +let hypident_ent = + tac_ent ["clause_dft_all"; "in_clause"; "hypident_occ"; "hypident"] in +let id_or_meta : Obj.t Gram.Entry.e = Obj.magic + (Grammar.Entry.find hypident_ent "id_or_meta") in +let hypident : (Obj.t * hyp_location_flag) Gram.Entry.e = + Obj.magic hypident_ent in +GEXTEND Gram + GLOBAL: hypident; +hypident: [ + [ "("; IDENT "type"; "of"; id = id_or_meta; ")" -> id, InHypTypeOnly + | "("; IDENT "value"; "of"; id = id_or_meta; ")" -> id, InHypValueOnly + ] ]; +END + +GEXTEND Gram + GLOBAL: hloc; +hloc: [ + [ "in"; "("; "Type"; "of"; id = ident; ")" -> + HypLocation ((Util.dummy_loc,id), InHypTypeOnly) + | "in"; "("; IDENT "Value"; "of"; id = ident; ")" -> + HypLocation ((Util.dummy_loc,id), InHypValueOnly) + ] ]; +END + +let constr_eval + : (Topconstr.constr_expr,Obj.t,Obj.t) Glob_term.may_eval Gram.Entry.e + = Obj.magic (Grammar.Entry.find (Obj.magic constr_may_eval) "constr_eval") + +GEXTEND Gram + GLOBAL: constr_eval; + constr_eval: [ + [ IDENT "type"; "of"; c = Constr.constr -> ConstrTypeOf c ] + ]; +END + +(* We wipe out all the keywords generated by the grammar rules we defined. *) +(* The user is supposed to Require Import ssreflect or Require ssreflect *) +(* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) +(* consequence the extended ssreflect grammar. *) +let () = Lexer.unfreeze frozen_lexer ;; + +(* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/mathcomp/ssreflect/plugin/v8.4/ssreflect.mllib b/mathcomp/ssreflect/plugin/v8.4/ssreflect.mllib new file mode 100644 index 0000000..006b70f --- /dev/null +++ b/mathcomp/ssreflect/plugin/v8.4/ssreflect.mllib @@ -0,0 +1,2 @@ +Ssrmatching +Ssreflect diff --git a/mathcomp/ssreflect/plugin/v8.4/ssrmatching.ml4 b/mathcomp/ssreflect/plugin/v8.4/ssrmatching.ml4 new file mode 100644 index 0000000..b24b0a6 --- /dev/null +++ b/mathcomp/ssreflect/plugin/v8.4/ssrmatching.ml4 @@ -0,0 +1,1223 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) + +(* Defining grammar rules with "xx" in it automatically declares keywords too, + * we thus save the lexer to restore it at the end of the file *) +let frozen_lexer = Lexer.freeze () ;; + +(*i camlp4use: "pa_extend.cmo" i*) +(*i camlp4deps: "grammar/grammar.cma" i*) + +open Names +open Pp +open Pcoq +open Genarg +open Term +open Topconstr +open Libnames +open Tactics +open Tacticals +open Termops +open Namegen +open Recordops +open Tacmach +open Coqlib +open Glob_term +open Util +open Evd +open Extend +open Goptions +open Tacexpr +open Tacinterp +open Pretyping +open Constr +open Tactic +open Extraargs +open Ppconstr +open Printer + +type loc = Util.loc +let errorstrm = errorlabstrm "ssreflect" +let loc_error loc msg = user_err_loc (loc, msg, str msg) + +(* 0 cost pp function. Active only if env variable SSRDEBUG is set *) +(* or if SsrDebug is Set *) +let pp_ref = ref (fun _ -> ()) +let ssr_pp s = pperrnl (str"SSR: "++Lazy.force s) +let _ = try ignore(Sys.getenv "SSRDEBUG"); pp_ref := ssr_pp with Not_found -> () +let debug b = + if b then pp_ref := ssr_pp else pp_ref := fun _ -> () +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssrmatching debugging"; + Goptions.optkey = ["SsrMatchingDebug"]; + Goptions.optdepr = false; + Goptions.optread = (fun _ -> !pp_ref == ssr_pp); + Goptions.optwrite = debug } +let pp s = !pp_ref s + +(** Utils {{{ *****************************************************************) +let env_size env = List.length (Environ.named_context env) +let safeDestApp c = + match kind_of_term c with App (f, a) -> f, a | _ -> c, [| |] +let get_index = function ArgArg i -> i | _ -> + anomaly "Uninterpreted index" +(* Toplevel constr must be globalized twice ! *) +let glob_constr ist gsigma genv = function + | _, Some ce -> + let ltacvars = List.map fst ist.lfun, [] in + Constrintern.intern_gen false ~ltacvars:ltacvars gsigma genv ce + | rc, None -> rc + +(* Term printing utilities functions for deciding bracketing. *) +let pr_paren prx x = hov 1 (str "(" ++ prx x ++ str ")") +(* String lexing utilities *) +let skip_wschars s = + let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop +(* We also guard characters that might interfere with the ssreflect *) +(* tactic syntax. *) +let guard_term ch1 s i = match s.[i] with + | '(' -> false + | '{' | '/' | '=' -> true + | _ -> ch1 = '(' +(* The call 'guard s i' should return true if the contents of s *) +(* starting at i need bracketing to avoid ambiguities. *) +let pr_guarded guard prc c = + msg_with Format.str_formatter (prc c); + let s = Format.flush_str_formatter () ^ "$" in + if guard s (skip_wschars s 0) then pr_paren prc c else prc c +(* More sensible names for constr printers *) +let pr_constr = pr_constr +let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c +let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c +let prl_constr_expr = pr_lconstr_expr +let pr_constr_expr = pr_constr_expr +let prl_glob_constr_and_expr = function + | _, Some c -> prl_constr_expr c + | c, None -> prl_glob_constr c +let pr_glob_constr_and_expr = function + | _, Some c -> pr_constr_expr c + | c, None -> pr_glob_constr c +let pr_term (k, c) = pr_guarded (guard_term k) pr_glob_constr_and_expr c +let prl_term (k, c) = pr_guarded (guard_term k) prl_glob_constr_and_expr c + +(** Adding a new uninterpreted generic argument type *) +let add_genarg tag pr = + let wit, globwit, rawwit as wits = create_arg None tag in + let glob _ rarg = in_gen globwit (out_gen rawwit rarg) in + let interp _ gl garg = Tacmach.project gl,in_gen wit (out_gen globwit garg) in + let subst _ garg = garg in + add_interp_genarg tag (glob, interp, subst); + let gen_pr _ _ _ = pr in + Pptactic.declare_extra_genarg_pprule + (rawwit, gen_pr) (globwit, gen_pr) (wit, gen_pr); + wits + +(** Constructors for cast type *) +let dC t = CastConv (DEFAULTcast, t) +(** Constructors for constr_expr *) +let isCVar = function CRef (Ident _) -> true | _ -> false +let destCVar = function CRef (Ident (_, id)) -> id | _ -> + anomaly "not a CRef" +let mkCHole loc = CHole (loc, None) +let mkCLambda loc name ty t = + CLambdaN (loc, [[loc, name], Default Explicit, ty], t) +let mkCLetIn loc name bo t = + CLetIn (loc, (loc, name), bo, t) +let mkCCast loc t ty = CCast (loc,t, dC ty) +(** Constructors for rawconstr *) +let mkRHole = GHole (dummy_loc, InternalHole) +let mkRApp f args = if args = [] then f else GApp (dummy_loc, f, args) +let mkRCast rc rt = GCast (dummy_loc, rc, dC rt) +let mkRLambda n s t = GLambda (dummy_loc, n, Explicit, s, t) + +(* ssrterm conbinators *) +let combineCG t1 t2 f g = match t1, t2 with + | (x, (t1, None)), (_, (t2, None)) -> x, (g t1 t2, None) + | (x, (_, Some t1)), (_, (_, Some t2)) -> x, (mkRHole, Some (f t1 t2)) + | _, (_, (_, None)) -> anomaly "have: mixed C-G constr" + | _ -> anomaly "have: mixed G-C constr" +let loc_ofCG = function + | (_, (s, None)) -> loc_of_glob_constr s + | (_, (_, Some s)) -> constr_loc s + +let mk_term k c = k, (mkRHole, Some c) +let mk_lterm = mk_term ' ' + +(* }}} *) + +(** Profiling {{{ *************************************************************) +type profiler = { + profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; + reset : unit -> unit; + print : unit -> unit } +let profile_now = ref false +let something_profiled = ref false +let profilers = ref [] +let add_profiler f = profilers := f :: !profilers;; +let profile b = + profile_now := b; + if b then List.iter (fun f -> f.reset ()) !profilers; + if not b then List.iter (fun f -> f.print ()) !profilers +;; +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssrmatching profiling"; + Goptions.optkey = ["SsrMatchingProfiling"]; + Goptions.optread = (fun _ -> !profile_now); + Goptions.optdepr = false; + Goptions.optwrite = profile } +let () = + let prof_total = + let init = ref 0.0 in { + profile = (fun f x -> assert false); + reset = (fun () -> init := Unix.gettimeofday ()); + print = (fun () -> if !something_profiled then + prerr_endline + (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" + "total" 0 (Unix.gettimeofday() -. !init) 0.0 0.0)) } in + let prof_legenda = { + profile = (fun f x -> assert false); + reset = (fun () -> ()); + print = (fun () -> if !something_profiled then begin + prerr_endline + (Printf.sprintf "!! %39s ---------- --------- --------- ---------" + (String.make 39 '-')); + prerr_endline + (Printf.sprintf "!! %-39s %10s %9s %9s %9s" + "function" "#calls" "total" "max" "average") end) } in + add_profiler prof_legenda; + add_profiler prof_total +;; + +let mk_profiler s = + let total, calls, max = ref 0.0, ref 0, ref 0.0 in + let reset () = total := 0.0; calls := 0; max := 0.0 in + let profile f x = + if not !profile_now then f x else + let before = Unix.gettimeofday () in + try + incr calls; + let res = f x in + let after = Unix.gettimeofday () in + let delta = after -. before in + total := !total +. delta; + if delta > !max then max := delta; + res + with exc -> + let after = Unix.gettimeofday () in + let delta = after -. before in + total := !total +. delta; + if delta > !max then max := delta; + raise exc in + let print () = + if !calls <> 0 then begin + something_profiled := true; + prerr_endline + (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" + s !calls !total !max (!total /. (float_of_int !calls))) end in + let prof = { profile = profile; reset = reset; print = print } in + add_profiler prof; + prof +;; +(* }}} *) + +exception NoProgress + +(** Unification procedures. *) + +(* To enforce the rigidity of the rooted match we always split *) +(* top applications, so the unification procedures operate on *) +(* arrays of patterns and terms. *) +(* We perform three kinds of unification: *) +(* EQ: exact conversion check *) +(* FO: first-order unification of evars, without conversion *) +(* HO: higher-order unification with conversion *) +(* The subterm unification strategy is to find the first FO *) +(* match, if possible, and the first HO match otherwise, then *) +(* compute all the occurrences that are EQ matches for the *) +(* relevant subterm. *) +(* Additional twists: *) +(* - If FO/HO fails then we attempt to fill evars using *) +(* typeclasses before raising an outright error. We also *) +(* fill typeclasses even after a successful match, since *) +(* beta-reduction and canonical instances may leave *) +(* undefined evars. *) +(* - We do postchecks to rule out matches that are not *) +(* closed or that assign to a global evar; these can be *) +(* disabled for rewrite or dependent family matches. *) +(* - We do a full FO scan before turning to HO, as the FO *) +(* comparison can be much faster than the HO one. *) + +let unif_EQ env sigma p c = + let evars = existential_opt_value sigma in + try let _ = Reduction.conv env p ~evars c in true with _ -> false + +let unif_EQ_args env sigma pa a = + let n = Array.length pa in + let rec loop i = (i = n) || unif_EQ env sigma pa.(i) a.(i) && loop (i + 1) in + loop 0 + +let prof_unif_eq_args = mk_profiler "unif_EQ_args";; +let unif_EQ_args env sigma pa a = + prof_unif_eq_args.profile (unif_EQ_args env sigma pa) a +;; + +let unif_HO env ise p c = Evarconv.the_conv_x env p c ise + +let unif_HOtype env ise p c = Evarconv.the_conv_x_leq env p c ise + +let unif_HO_args env ise0 pa i ca = + let n = Array.length pa in + let rec loop ise j = + if j = n then ise else loop (unif_HO env ise pa.(j) ca.(i + j)) (j + 1) in + loop ise0 0 + +(* FO unification should boil down to calling w_unify with no_delta, but *) +(* alas things are not so simple: w_unify does partial type-checking, *) +(* which breaks down when the no-delta flag is on (as the Coq type system *) +(* requires full convertibility. The workaround here is to convert all *) +(* evars into metas, since 8.2 does not TC metas. This means some lossage *) +(* for HO evars, though hopefully Miller patterns can pick up some of *) +(* those cases, and HO matching will mop up the rest. *) +let flags_FO = {Unification.default_no_delta_unify_flags with + Unification.modulo_conv_on_closed_terms = None; + Unification.modulo_eta = true; + Unification.modulo_betaiota = true; + Unification.modulo_delta_types = full_transparent_state; + Unification.allow_K_in_toplevel_higher_order_unification=false} +let unif_FO env ise p c = + Unification.w_unify env ise Reduction.CONV ~flags:flags_FO p c + +(* Perform evar substitution in main term and prune substitution. *) +let nf_open_term sigma0 ise c = + let s = ise and s' = ref sigma0 in + let rec nf c' = match kind_of_term c' with + | Evar ex -> + begin try nf (existential_value s ex) with _ -> + let k, a = ex in let a' = Array.map nf a in + if not (Evd.mem !s' k) then + s' := Evd.add !s' k (Evarutil.nf_evar_info s (Evd.find s k)); + mkEvar (k, a') + end + | _ -> map_constr nf c' in + let copy_def k evi () = + if evar_body evi != Evd.Evar_empty then () else + match Evd.evar_body (Evd.find s k) with + | Evar_defined c' -> s' := Evd.define k (nf c') !s' + | _ -> () in + let c' = nf c in let _ = Evd.fold copy_def sigma0 () in !s', c' + +let unif_end env sigma0 ise0 pt ok = + let ise = Evarconv.consider_remaining_unif_problems env ise0 in + let s, t = nf_open_term sigma0 ise pt in + let ise1 = create_evar_defs s in + let ise2 = Typeclasses.resolve_typeclasses ~fail:true env ise1 in + if not (ok ise) then raise NoProgress else + if ise2 == ise1 then (s, t) else nf_open_term sigma0 ise2 t + +let pf_unif_HO gl sigma pt p c = + let env = pf_env gl in + let ise = unif_HO env (create_evar_defs sigma) p c in + unif_end env (project gl) ise pt (fun _ -> true) + +let unify_HO env sigma0 t1 t2 = + let sigma = unif_HO env sigma0 t1 t2 in + let sigma, _ = unif_end env sigma0 sigma t2 (fun _ -> true) in + sigma + +let pf_unify_HO gl t1 t2 = + let env, sigma0, si = pf_env gl, project gl, sig_it gl in + let sigma = unify_HO env sigma0 t1 t2 in + re_sig si sigma + +(* This is what the definition of iter_constr should be... *) +let iter_constr_LR f c = match kind_of_term c with + | Evar (k, a) -> Array.iter f a + | Cast (cc, _, t) -> f cc; f t + | Prod (_, t, b) | Lambda (_, t, b) -> f t; f b + | LetIn (_, v, t, b) -> f v; f t; f b + | App (cf, a) -> f cf; Array.iter f a + | Case (_, p, v, b) -> f v; f p; Array.iter f b + | Fix (_, (_, t, b)) | CoFix (_, (_, t, b)) -> + for i = 0 to Array.length t - 1 do f t.(i); f b.(i) done + | _ -> () + +(* The comparison used to determine which subterms matches is KEYED *) +(* CONVERSION. This looks for convertible terms that either have the same *) +(* same head constant as pat if pat is an application (after beta-iota), *) +(* or start with the same constr constructor (esp. for LetIn); this is *) +(* disregarded if the head term is let x := ... in x, and casts are always *) +(* ignored and removed). *) +(* Record projections get special treatment: in addition to the projection *) +(* constant itself, ssreflect also recognizes head constants of canonical *) +(* projections. *) + +exception NoMatch +type ssrdir = L2R | R2L +let pr_dir_side = function L2R -> str "LHS" | R2L -> str "RHS" +let inv_dir = function L2R -> R2L | R2L -> L2R + + +type pattern_class = + | KpatFixed + | KpatConst + | KpatEvar of existential_key + | KpatLet + | KpatLam + | KpatRigid + | KpatFlex + | KpatProj of constant + +type tpattern = { + up_k : pattern_class; + up_FO : constr; + up_f : constr; + up_a : constr array; + up_t : constr; (* equation proof term or matched term *) + up_dir : ssrdir; (* direction of the rule *) + up_ok : constr -> evar_map -> bool; (* progess test for rewrite *) + } + +let all_ok _ _ = true + +let proj_nparams c = + try 1 + Recordops.find_projection_nparams (ConstRef c) with _ -> 0 + +let isFixed c = match kind_of_term c with + | Var _ | Ind _ | Construct _ | Const _ -> true + | _ -> false + +let isRigid c = match kind_of_term c with + | Prod _ | Sort _ | Lambda _ | Case _ | Fix _ | CoFix _ -> true + | _ -> false + +exception UndefPat + +let hole_var = mkVar (id_of_string "_") +let pr_constr_pat c0 = + let rec wipe_evar c = + if isEvar c then hole_var else map_constr wipe_evar c in + pr_constr (wipe_evar c0) + +(* Turn (new) evars into metas *) +let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = + let ise = ref ise0 in + let sigma = ref ise0 in + let nenv = env_size env + if hack then 1 else 0 in + let rec put c = match kind_of_term c with + | Evar (k, a as ex) -> + begin try put (existential_value !sigma ex) + with NotInstantiatedEvar -> + if Evd.mem sigma0 k then map_constr put c else + let evi = Evd.find !sigma k in + let dc = list_firstn (max 0 (Array.length a - nenv)) (evar_filtered_context evi) in + let abs_dc (d, c) = function + | x, Some b, t -> d, mkNamedLetIn x (put b) (put t) c + | x, None, t -> mkVar x :: d, mkNamedProd x (put t) c in + let a, t = + Sign.fold_named_context_reverse abs_dc ~init:([], (put evi.evar_concl)) dc in + let m = Evarutil.new_meta () in + ise := meta_declare m t !ise; + sigma := Evd.define k (applist (mkMeta m, a)) !sigma; + put (existential_value !sigma ex) + end + | _ -> map_constr put c in + let c1 = put c0 in !ise, c1 + +(* Compile a match pattern from a term; t is the term to fill. *) +(* p_origin can be passed to obtain a better error message *) +let mk_tpattern ?p_origin ?(hack=false) env sigma0 (ise, t) ok dir p = + let k, f, a = + let f, a = Reductionops.whd_betaiota_stack ise p in + match kind_of_term f with + | Const p -> + let np = proj_nparams p in + if np = 0 || np > List.length a then KpatConst, f, a else + let a1, a2 = list_chop np a in KpatProj p, applist(f, a1), a2 + | Var _ | Ind _ | Construct _ -> KpatFixed, f, a + | Evar (k, _) -> + if Evd.mem sigma0 k then KpatEvar k, f, a else + if a <> [] then KpatFlex, f, a else + (match p_origin with None -> error "indeterminate pattern" + | Some (dir, rule) -> + errorstrm (str "indeterminate " ++ pr_dir_side dir + ++ str " in " ++ pr_constr_pat rule)) + | LetIn (_, v, _, b) -> + if b <> mkRel 1 then KpatLet, f, a else KpatFlex, v, a + | Lambda _ -> KpatLam, f, a + | _ -> KpatRigid, f, a in + let aa = Array.of_list a in + let ise', p' = evars_for_FO ~hack env sigma0 ise (mkApp (f, aa)) in + ise', + { up_k = k; up_FO = p'; up_f = f; + up_a = aa; up_ok = ok; up_dir = dir; up_t = t} + +(* Specialize a pattern after a successful match: assign a precise head *) +(* kind and arity for Proj and Flex patterns. *) +let ungen_upat lhs (sigma, t) u = + let f, a = safeDestApp lhs in + let k = match kind_of_term f with + | Var _ | Ind _ | Construct _ -> KpatFixed + | Const _ -> KpatConst + | Evar (k, _) -> if is_defined sigma k then raise NoMatch else KpatEvar k + | LetIn _ -> KpatLet + | Lambda _ -> KpatLam + | _ -> KpatRigid in + sigma, {u with up_k = k; up_FO = lhs; up_f = f; up_a = a; up_t = t} + +let nb_cs_proj_args pc f u = + let na k = + List.length (lookup_canonical_conversion (ConstRef pc, k)).o_TCOMPS in + try match kind_of_term f with + | Prod _ -> na Prod_cs + | Sort s -> na (Sort_cs (family_of_sort s)) + | Const c' when c' = pc -> Array.length (snd (destApp u.up_f)) + | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (global_of_constr f)) + | _ -> -1 + with Not_found -> -1 + +let isEvar_k k f = + match kind_of_term f with Evar (k', _) -> k = k' | _ -> false + +let nb_args c = + match kind_of_term c with App (_, a) -> Array.length a | _ -> 0 + +let mkSubArg i a = if i = Array.length a then a else Array.sub a 0 i +let mkSubApp f i a = if i = 0 then f else mkApp (f, mkSubArg i a) + +let splay_app ise = + let rec loop c a = match kind_of_term c with + | App (f, a') -> loop f (Array.append a' a) + | Cast (c', _, _) -> loop c' a + | Evar ex -> + (try loop (existential_value ise ex) a with _ -> c, a) + | _ -> c, a in + fun c -> match kind_of_term c with + | App (f, a) -> loop f a + | Cast _ | Evar _ -> loop c [| |] + | _ -> c, [| |] + +let filter_upat i0 f n u fpats = + let na = Array.length u.up_a in + if n < na then fpats else + let np = match u.up_k with + | KpatConst when eq_constr u.up_f f -> na + | KpatFixed when u.up_f = f -> na + | KpatEvar k when isEvar_k k f -> na + | KpatLet when isLetIn f -> na + | KpatLam when isLambda f -> na + | KpatRigid when isRigid f -> na + | KpatFlex -> na + | KpatProj pc -> + let np = na + nb_cs_proj_args pc f u in if n < np then -1 else np + | _ -> -1 in + if np < na then fpats else + let () = if !i0 < np then i0 := n in (u, np) :: fpats + +let filter_upat_FO i0 f n u fpats = + let np = nb_args u.up_FO in + if n < np then fpats else + let ok = match u.up_k with + | KpatConst -> eq_constr u.up_f f + | KpatFixed -> u.up_f = f + | KpatEvar k -> isEvar_k k f + | KpatLet -> isLetIn f + | KpatLam -> isLambda f + | KpatRigid -> isRigid f + | KpatProj pc -> f = mkConst pc + | KpatFlex -> i0 := n; true in + if ok then begin if !i0 < np then i0 := np; (u, np) :: fpats end else fpats + +exception FoundUnif of (evar_map * tpattern) +(* Note: we don't update env as we descend into the term, as the primitive *) +(* unification procedure always rejects subterms with bound variables. *) + +(* We are forced to duplicate code between the FO/HO matching because we *) +(* have to work around several kludges in unify.ml: *) +(* - w_unify drops into second-order unification when the pattern is an *) +(* application whose head is a meta. *) +(* - w_unify tries to unify types without subsumption when the pattern *) +(* head is an evar or meta (e.g., it fails on ?1 = nat when ?1 : Type). *) +(* - w_unify expands let-in (zeta conversion) eagerly, whereas we want to *) +(* match a head let rigidly. *) +let match_upats_FO upats env sigma0 ise = + let rec loop c = + let f, a = splay_app ise c in let i0 = ref (-1) in + let fpats = + List.fold_right (filter_upat_FO i0 f (Array.length a)) upats [] in + while !i0 >= 0 do + let i = !i0 in i0 := -1; + let c' = mkSubApp f i a in + let one_match (u, np) = + let skip = + if i <= np then i < np else + if u.up_k == KpatFlex then begin i0 := i - 1; false end else + begin if !i0 < np then i0 := np; true end in + if skip || not (closed0 c') then () else try + let _ = match u.up_k with + | KpatFlex -> + let kludge v = mkLambda (Anonymous, mkProp, v) in + unif_FO env ise (kludge u.up_FO) (kludge c') + | KpatLet -> + let kludge vla = + let vl, a = safeDestApp vla in + let x, v, t, b = destLetIn vl in + mkApp (mkLambda (x, t, b), array_cons v a) in + unif_FO env ise (kludge u.up_FO) (kludge c') + | _ -> unif_FO env ise u.up_FO c' in + let ise' = (* Unify again using HO to assign evars *) + let p = mkApp (u.up_f, u.up_a) in + try unif_HO env ise p c' with _ -> raise NoMatch in + let lhs = mkSubApp f i a in + let pt' = unif_end env sigma0 ise' u.up_t (u.up_ok lhs) in + raise (FoundUnif (ungen_upat lhs pt' u)) + with FoundUnif _ as sigma_u -> raise sigma_u + | Not_found -> anomaly "incomplete ise in match_upats_FO" + | _ -> () in + List.iter one_match fpats + done; + iter_constr_LR loop f; Array.iter loop a in + fun c -> try loop c with Invalid_argument _ -> anomaly "IN FO" + +let prof_FO = mk_profiler "match_upats_FO";; +let match_upats_FO upats env sigma0 ise c = + prof_FO.profile (match_upats_FO upats env sigma0) ise c +;; + + +let match_upats_HO upats env sigma0 ise c = + let it_did_match = ref false in + let rec aux upats env sigma0 ise c = + let f, a = splay_app ise c in let i0 = ref (-1) in + let fpats = List.fold_right (filter_upat i0 f (Array.length a)) upats [] in + while !i0 >= 0 do + let i = !i0 in i0 := -1; + let one_match (u, np) = + let skip = + if i <= np then i < np else + if u.up_k == KpatFlex then begin i0 := i - 1; false end else + begin if !i0 < np then i0 := np; true end in + if skip then () else try + let ise' = match u.up_k with + | KpatFixed | KpatConst -> ise + | KpatEvar _ -> + let _, pka = destEvar u.up_f and _, ka = destEvar f in + unif_HO_args env ise pka 0 ka + | KpatLet -> + let x, v, t, b = destLetIn f in + let _, pv, _, pb = destLetIn u.up_f in + let ise' = unif_HO env ise pv v in + unif_HO (Environ.push_rel (x, None, t) env) ise' pb b + | KpatFlex | KpatProj _ -> + unif_HO env ise u.up_f (mkSubApp f (i - Array.length u.up_a) a) + | _ -> unif_HO env ise u.up_f f in + let ise'' = unif_HO_args env ise' u.up_a (i - Array.length u.up_a) a in + let lhs = mkSubApp f i a in + let pt' = unif_end env sigma0 ise'' u.up_t (u.up_ok lhs) in + raise (FoundUnif (ungen_upat lhs pt' u)) + with FoundUnif _ as sigma_u -> raise sigma_u + | NoProgress -> it_did_match := true + | _ -> () in + List.iter one_match fpats + done; + iter_constr_LR (aux upats env sigma0 ise) f; + Array.iter (aux upats env sigma0 ise) a + in + aux upats env sigma0 ise c; + if !it_did_match then raise NoProgress + +let prof_HO = mk_profiler "match_upats_HO";; +let match_upats_HO upats env sigma0 ise c = + prof_HO.profile (match_upats_HO upats env sigma0) ise c +;; + + +let fixed_upat = function +| {up_k = KpatFlex | KpatEvar _ | KpatProj _} -> false +| {up_t = t} -> not (occur_existential t) + +let do_once r f = match !r with Some _ -> () | None -> r := Some (f ()) + +let assert_done r = + match !r with Some x -> x | None -> anomaly "do_once never called" + +type subst = Environ.env -> Term.constr -> int -> Term.constr +type find_P = + Environ.env -> Term.constr -> int -> + k:subst -> + Term.constr +type conclude = unit -> Term.constr * ssrdir * (Evd.evar_map * Term.constr) + +(* upats_origin makes a better error message only *) +let mk_tpattern_matcher + ?(raise_NoMatch=false) ?upats_origin sigma0 occ (ise, upats) += + let nocc = ref 0 and skip_occ = ref false in + let use_occ, occ_list = match occ with + | Some (true, ol) -> ol = [], ol + | Some (false, ol) -> ol <> [], ol + | None -> false, [] in + let max_occ = List.fold_right max occ_list 0 in + let subst_occ = + let occ_set = Array.make max_occ (not use_occ) in + let _ = List.iter (fun i -> occ_set.(i - 1) <- use_occ) occ_list in + let _ = if max_occ = 0 then skip_occ := use_occ in + fun () -> incr nocc; + if !nocc = max_occ then skip_occ := use_occ; + if !nocc <= max_occ then occ_set.(!nocc - 1) else not use_occ in + let upat_that_matched = ref None in + let match_EQ env sigma u = + match u.up_k with + | KpatLet -> + let x, pv, t, pb = destLetIn u.up_f in + let env' = Environ.push_rel (x, None, t) env in + let match_let f = match kind_of_term f with + | LetIn (_, v, _, b) -> unif_EQ env sigma pv v && unif_EQ env' sigma pb b + | _ -> false in match_let + | KpatFixed -> (=) u.up_f + | KpatConst -> eq_constr u.up_f + | KpatLam -> fun c -> + (match kind_of_term c with + | Lambda _ -> unif_EQ env sigma u.up_f c + | _ -> false) + | _ -> unif_EQ env sigma u.up_f in +let p2t p = mkApp(p.up_f,p.up_a) in +let source () = match upats_origin, upats with + | None, [p] -> + (if fixed_upat p then str"term " else str"partial term ") ++ + pr_constr_pat (p2t p) ++ spc() + | Some (dir,rule), [p] -> str"The " ++ pr_dir_side dir ++ str" of " ++ + pr_constr_pat rule ++ fnl() ++ ws 4 ++ pr_constr_pat (p2t p) ++ fnl() + | Some (dir,rule), _ -> str"The " ++ pr_dir_side dir ++ str" of " ++ + pr_constr_pat rule ++ spc() + | _, [] | None, _::_::_ -> + anomaly "mk_tpattern_matcher with no upats_origin" in +((fun env c h ~k -> + do_once upat_that_matched (fun () -> + try + match_upats_FO upats env sigma0 ise c; + match_upats_HO upats env sigma0 ise c; + raise NoMatch + with FoundUnif sigma_u -> sigma_u + | NoMatch when (not raise_NoMatch) -> + errorstrm (source () ++ str "does not match any subterm of the goal") + | NoProgress when (not raise_NoMatch) -> + let dir = match upats_origin with Some (d,_) -> d | _ -> + anomaly "mk_tpattern_matcher with no upats_origin" in + errorstrm (str"all matches of "++source()++ + str"are equal to the " ++ pr_dir_side (inv_dir dir)) + | NoProgress -> raise NoMatch); + let sigma, ({up_f = pf; up_a = pa} as u) = assert_done upat_that_matched in + if !skip_occ then (ignore(k env u.up_t 0); c) else + let match_EQ = match_EQ env sigma u in + let pn = Array.length pa in + let rec subst_loop (env,h as acc) c' = + if !skip_occ then c' else + let f, a = splay_app sigma c' in + if Array.length a >= pn && match_EQ f && unif_EQ_args env sigma pa a then + let a1, a2 = array_chop (Array.length pa) a in + let fa1 = mkApp (f, a1) in + let f' = if subst_occ () then k env u.up_t h else fa1 in + mkApp (f', array_map_left (subst_loop acc) a2) + else + (* TASSI: clear letin values to avoid unfolding *) + let inc_h (n,_,ty) (env,h') = Environ.push_rel (n,None,ty) env, h' + 1 in + let f' = map_constr_with_binders_left_to_right inc_h subst_loop acc f in + mkApp (f', array_map_left (subst_loop acc) a) in + subst_loop (env,h) c) : find_P), +((fun () -> + let sigma, ({up_f = pf; up_a = pa} as u) = + match !upat_that_matched with + | Some x -> x | None when raise_NoMatch -> raise NoMatch + | None -> anomaly "companion function never called" in + let p' = mkApp (pf, pa) in + if max_occ <= !nocc then p', u.up_dir, (sigma, u.up_t) + else errorstrm (str"Only " ++ int !nocc ++ str" < " ++ int max_occ ++ + str(plural !nocc " occurence") ++ match upats_origin with + | None -> str" of" ++ spc() ++ pr_constr_pat p' + | Some (dir,rule) -> str" of the " ++ pr_dir_side dir ++ fnl() ++ + ws 4 ++ pr_constr_pat p' ++ fnl () ++ + str"of " ++ pr_constr_pat rule)) : conclude) + +type ('ident, 'term) ssrpattern = + | T of 'term + | In_T of 'term + | X_In_T of 'ident * 'term + | In_X_In_T of 'ident * 'term + | E_In_X_In_T of 'term * 'ident * 'term + | E_As_X_In_T of 'term * 'ident * 'term + +let pr_pattern = function + | T t -> prl_term t + | In_T t -> str "in " ++ prl_term t + | X_In_T (x,t) -> prl_term x ++ str " in " ++ prl_term t + | In_X_In_T (x,t) -> str "in " ++ prl_term x ++ str " in " ++ prl_term t + | E_In_X_In_T (e,x,t) -> + prl_term e ++ str " in " ++ prl_term x ++ str " in " ++ prl_term t + | E_As_X_In_T (e,x,t) -> + prl_term e ++ str " as " ++ prl_term x ++ str " in " ++ prl_term t + +let pr_pattern_w_ids = function + | T t -> prl_term t + | In_T t -> str "in " ++ prl_term t + | X_In_T (x,t) -> pr_id x ++ str " in " ++ prl_term t + | In_X_In_T (x,t) -> str "in " ++ pr_id x ++ str " in " ++ prl_term t + | E_In_X_In_T (e,x,t) -> + prl_term e ++ str " in " ++ pr_id x ++ str " in " ++ prl_term t + | E_As_X_In_T (e,x,t) -> + prl_term e ++ str " as " ++ pr_id x ++ str " in " ++ prl_term t + +let pr_pattern_aux pr_constr = function + | T t -> pr_constr t + | In_T t -> str "in " ++ pr_constr t + | X_In_T (x,t) -> pr_constr x ++ str " in " ++ pr_constr t + | In_X_In_T (x,t) -> str "in " ++ pr_constr x ++ str " in " ++ pr_constr t + | E_In_X_In_T (e,x,t) -> + pr_constr e ++ str " in " ++ pr_constr x ++ str " in " ++ pr_constr t + | E_As_X_In_T (e,x,t) -> + pr_constr e ++ str " as " ++ pr_constr x ++ str " in " ++ pr_constr t +let pp_pattern (sigma, p) = + pr_pattern_aux (fun t -> pr_constr (snd (nf_open_term sigma sigma t))) p +let pr_cpattern = pr_term +let pr_rpattern _ _ _ = pr_pattern + +let pr_option f = function None -> mt() | Some x -> f x +let pr_ssrpattern _ _ _ = pr_option pr_pattern +let pr_pattern_squarep = pr_option (fun r -> str "[" ++ pr_pattern r ++ str "]") +let pr_ssrpattern_squarep _ _ _ = pr_pattern_squarep +let pr_pattern_roundp = pr_option (fun r -> str "(" ++ pr_pattern r ++ str ")") +let pr_ssrpattern_roundp _ _ _ = pr_pattern_roundp + +let wit_rpatternty, globwit_rpatternty, rawwit_rpatternty = + add_genarg "rpatternty" pr_pattern + +ARGUMENT EXTEND rpattern TYPED AS rpatternty PRINTED BY pr_rpattern + | [ lconstr(c) ] -> [ T (mk_lterm c) ] + | [ "in" lconstr(c) ] -> [ In_T (mk_lterm c) ] + | [ lconstr(x) "in" lconstr(c) ] -> + [ X_In_T (mk_lterm x, mk_lterm c) ] + | [ "in" lconstr(x) "in" lconstr(c) ] -> + [ In_X_In_T (mk_lterm x, mk_lterm c) ] + | [ lconstr(e) "in" lconstr(x) "in" lconstr(c) ] -> + [ E_In_X_In_T (mk_lterm e, mk_lterm x, mk_lterm c) ] + | [ lconstr(e) "as" lconstr(x) "in" lconstr(c) ] -> + [ E_As_X_In_T (mk_lterm e, mk_lterm x, mk_lterm c) ] +END + +type cpattern = char * glob_constr_and_expr +let tag_of_cpattern = fst +let loc_of_cpattern = loc_ofCG +let cpattern_of_term t = t +type occ = (bool * int list) option + +type rpattern = (cpattern, cpattern) ssrpattern +let pr_rpattern = pr_pattern + +type pattern = Evd.evar_map * (Term.constr, Term.constr) ssrpattern + + +let id_of_cpattern = function + | _,(_,Some (CRef (Ident (_, x)))) -> Some x + | _,(_,Some (CAppExpl (_, (_, Ident (_, x)), []))) -> Some x + | _,(GRef (_, VarRef x) ,None) -> Some x + | _ -> None +let id_of_Cterm t = match id_of_cpattern t with + | Some x -> x + | None -> loc_error (loc_of_cpattern t) "Only identifiers are allowed here" + +let interp_wit globwit wit ist gl x = + let globarg = in_gen globwit x in + let sigma, arg = interp_genarg ist gl globarg in + sigma, out_gen wit arg +let interp_constr = interp_wit globwit_constr wit_constr +let interp_open_constr ist gl gc = + interp_wit globwit_open_constr wit_open_constr ist gl ((), gc) +let pf_intern_term ist gl (_, c) = glob_constr ist (project gl) (pf_env gl) c +let interp_term ist gl (_, c) = snd (interp_open_constr ist gl c) +let glob_ssrterm gs = function + | k, (_, Some c) -> k, Tacinterp.intern_constr gs c + | ct -> ct +let subst_ssrterm s (k, c) = k, Tacinterp.subst_glob_constr_and_expr s c +let pr_ssrterm _ _ _ = pr_term +let input_ssrtermkind strm = match Compat.get_tok (stream_nth 0 strm) with + | Tok.KEYWORD "(" -> '(' + | Tok.KEYWORD "@" -> '@' + | _ -> ' ' +let ssrtermkind = Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind + +(* This piece of code asserts the following notations are reserved *) +(* Reserved Notation "( a 'in' b )" (at level 0). *) +(* Reserved Notation "( a 'as' b )" (at level 0). *) +(* Reserved Notation "( a 'in' b 'in' c )" (at level 0). *) +(* Reserved Notation "( a 'as' b 'in' c )" (at level 0). *) +let glob_cpattern gs p = + pp(lazy(str"globbing pattern: " ++ pr_term p)); + let glob x = snd (glob_ssrterm gs (mk_lterm x)) in + let encode k s l = + let name = Name (id_of_string ("_ssrpat_" ^ s)) in + k, (mkRCast mkRHole (mkRLambda name mkRHole (mkRApp mkRHole l)), None) in + let bind_in t1 t2 = + let d = dummy_loc in let n = Name (destCVar t1) in + fst (glob (mkCCast d (mkCHole d) (mkCLambda d n (mkCHole d) t2))) in + let check_var t2 = if not (isCVar t2) then + loc_error (constr_loc t2) "Only identifiers are allowed here" in + match p with + | _, (_, None) as x -> x + | k, (v, Some t) as orig -> + if k = 'x' then glob_ssrterm gs ('(', (v, Some t)) else + match t with + | CNotation(_, "( _ in _ )", ([t1; t2], [], [])) -> + (try match glob t1, glob t2 with + | (r1, None), (r2, None) -> encode k "In" [r1;r2] + | (r1, Some _), (r2, Some _) when isCVar t1 -> + encode k "In" [r1; r2; bind_in t1 t2] + | (r1, Some _), (r2, Some _) -> encode k "In" [r1; r2] + | _ -> anomaly "where are we?" + with _ when isCVar t1 -> encode k "In" [bind_in t1 t2]) + | CNotation(_, "( _ in _ in _ )", ([t1; t2; t3], [], [])) -> + check_var t2; encode k "In" [fst (glob t1); bind_in t2 t3] + | CNotation(_, "( _ as _ )", ([t1; t2], [], [])) -> + encode k "As" [fst (glob t1); fst (glob t2)] + | CNotation(_, "( _ as _ in _ )", ([t1; t2; t3], [], [])) -> + check_var t2; encode k "As" [fst (glob t1); bind_in t2 t3] + | _ -> glob_ssrterm gs orig +;; + +let interp_ssrterm _ gl t = Tacmach.project gl, t + +ARGUMENT EXTEND cpattern + PRINTED BY pr_ssrterm + INTERPRETED BY interp_ssrterm + GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm + RAW_TYPED AS cpattern RAW_PRINTED BY pr_ssrterm + GLOB_TYPED AS cpattern GLOB_PRINTED BY pr_ssrterm +| [ "Qed" constr(c) ] -> [ mk_lterm c ] +END + +GEXTEND Gram + GLOBAL: cpattern; + cpattern: [[ k = ssrtermkind; c = constr -> + let pattern = mk_term k c in + if loc_ofCG pattern <> loc && k = '(' then mk_term 'x' c else pattern ]]; +END + +ARGUMENT EXTEND lcpattern + PRINTED BY pr_ssrterm + INTERPRETED BY interp_ssrterm + GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm + RAW_TYPED AS cpattern RAW_PRINTED BY pr_ssrterm + GLOB_TYPED AS cpattern GLOB_PRINTED BY pr_ssrterm +| [ "Qed" lconstr(c) ] -> [ mk_lterm c ] +END + +GEXTEND Gram + GLOBAL: lcpattern; + lcpattern: [[ k = ssrtermkind; c = lconstr -> + let pattern = mk_term k c in + if loc_ofCG pattern <> loc && k = '(' then mk_term 'x' c else pattern ]]; +END + +let interp_pattern ist gl red redty = + pp(lazy(str"interpreting: " ++ pr_pattern red)); + let xInT x y = X_In_T(x,y) and inXInT x y = In_X_In_T(x,y) in + let inT x = In_T x and eInXInT e x t = E_In_X_In_T(e,x,t) in + let eAsXInT e x t = E_As_X_In_T(e,x,t) in + let mkG ?(k=' ') x = k,(x,None) in + let decode t f g = + try match (pf_intern_term ist gl t) with + | GCast(_,GHole _,CastConv(_,GLambda(_,Name x,_,_,c))) -> f x (' ',(c,None)) + | it -> g t with _ -> g t in + let decodeG t f g = decode (mkG t) f g in + let bad_enc id _ = anomaly ("bad encoding for pattern " ^ id) in + let cleanup_XinE h x rp sigma = + let h_k = match kind_of_term h with Evar (k,_) -> k | _ -> assert false in + let to_clean, update = (* handle rename if x is already used *) + let ctx = pf_hyps gl in + let len = Sign.named_context_length ctx in + let name = ref None in + try ignore(Sign.lookup_named x ctx); (name, fun k -> + if !name = None then + let nctx = Evd.evar_context (Evd.find sigma k) in + let nlen = Sign.named_context_length nctx in + if nlen > len then begin + name := Some (pi1 (List.nth nctx (nlen - len - 1))) + end) + with Not_found -> ref (Some x), fun _ -> () in + let sigma0 = project gl in + let new_evars = + let rec aux acc t = match kind_of_term t with + | Evar (k,_) -> + if k = h_k || List.mem k acc || Evd.mem sigma0 k then acc else + (update k; k::acc) + | _ -> fold_constr aux acc t in + aux [] (Evarutil.nf_evar sigma rp) in + let sigma = + List.fold_left (fun sigma e -> + if Evd.is_defined sigma e then sigma else (* clear may be recursiv *) + let name = Option.get !to_clean in + let g = Goal.build e in + pp(lazy(pr_id name)); + try snd(Logic.prim_refiner (Proof_type.Thin [name]) sigma g) + with Evarutil.ClearDependencyError _ -> sigma) + sigma new_evars in + sigma in + let red = match red with + | T(k,(GCast (_,GHole _,(CastConv(_,GLambda (_,Name id,_,_,t)))),None)) + when let id = string_of_id id in let len = String.length id in + (len > 8 && String.sub id 0 8 = "_ssrpat_") -> + let id = string_of_id id in let len = String.length id in + (match String.sub id 8 (len - 8), t with + | "In", GApp(_, _, [t]) -> decodeG t xInT (fun x -> T x) + | "In", GApp(_, _, [e; t]) -> decodeG t (eInXInT (mkG e)) (bad_enc id) + | "In", GApp(_, _, [e; t; e_in_t]) -> + decodeG t (eInXInT (mkG e)) + (fun _ -> decodeG e_in_t xInT (fun _ -> assert false)) + | "As", GApp(_, _, [e; t]) -> decodeG t (eAsXInT (mkG e)) (bad_enc id) + | _ -> bad_enc id ()) + | T t -> decode t xInT (fun x -> T x) + | In_T t -> decode t inXInT inT + | X_In_T (e,t) -> decode t (eInXInT e) (fun x -> xInT (id_of_Cterm e) x) + | In_X_In_T (e,t) -> inXInT (id_of_Cterm e) t + | E_In_X_In_T (e,x,rp) -> eInXInT e (id_of_Cterm x) rp + | E_As_X_In_T (e,x,rp) -> eAsXInT e (id_of_Cterm x) rp in + pp(lazy(str"decoded as: " ++ pr_pattern_w_ids red)); + let red = match redty with None -> red | Some ty -> let ty = ' ', ty in + match red with + | T t -> T (combineCG t ty (mkCCast (loc_ofCG t)) mkRCast) + | X_In_T (x,t) -> + let ty = pf_intern_term ist gl ty in + E_As_X_In_T (mkG (mkRCast mkRHole ty), x, t) + | E_In_X_In_T (e,x,t) -> + let ty = mkG (pf_intern_term ist gl ty) in + E_In_X_In_T (combineCG e ty (mkCCast (loc_ofCG t)) mkRCast, x, t) + | E_As_X_In_T (e,x,t) -> + let ty = mkG (pf_intern_term ist gl ty) in + E_As_X_In_T (combineCG e ty (mkCCast (loc_ofCG t)) mkRCast, x, t) + | red -> red in + pp(lazy(str"typed as: " ++ pr_pattern_w_ids red)); + let mkXLetIn loc x (a,(g,c)) = match c with + | Some b -> a,(g,Some (mkCLetIn loc x (CHole(loc,None)) b)) + | None -> a,(GLetIn (loc,x,(GHole (loc, BinderType x)), g), None) in + match red with + | T t -> let sigma, t = interp_term ist gl t in sigma, T t + | In_T t -> let sigma, t = interp_term ist gl t in sigma, In_T t + | X_In_T (x, rp) | In_X_In_T (x, rp) -> + let mk x p = match red with X_In_T _ -> X_In_T(x,p) | _ -> In_X_In_T(x,p) in + let rp = mkXLetIn dummy_loc (Name x) rp in + let sigma, rp = interp_term ist gl rp in + let _, h, _, rp = destLetIn rp in + let sigma = cleanup_XinE h x rp sigma in + let rp = subst1 h (Evarutil.nf_evar sigma rp) in + sigma, mk h rp + | E_In_X_In_T(e, x, rp) | E_As_X_In_T (e, x, rp) -> + let mk e x p = + match red with E_In_X_In_T _ ->E_In_X_In_T(e,x,p)|_->E_As_X_In_T(e,x,p) in + let rp = mkXLetIn dummy_loc (Name x) rp in + let sigma, rp = interp_term ist gl rp in + let _, h, _, rp = destLetIn rp in + let sigma = cleanup_XinE h x rp sigma in + let rp = subst1 h (Evarutil.nf_evar sigma rp) in + let sigma, e = interp_term ist (re_sig (sig_it gl) sigma) e in + sigma, mk e h rp +;; +let interp_cpattern ist gl red redty = interp_pattern ist gl (T red) redty;; +let interp_rpattern ist gl red = interp_pattern ist gl red None;; + +(* The full occurrence set *) +let noindex = Some(false,[]) + +(* calls do_subst on every sub-term identified by (pattern,occ) *) +let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = + let fs sigma x = Reductionops.nf_evar sigma x in + let pop_evar sigma e p = + let { Evd.evar_body = e_body } as e_def = Evd.find sigma e in + let e_body = match e_body with Evar_defined c -> c + | _ -> errorstrm (str "Matching the pattern " ++ pr_constr p ++ + str " did not instantiate ?" ++ int e ++ spc () ++ + str "Does the variable bound by the \"in\" construct occur "++ + str "in the pattern?") in + let sigma = + Evd.add (Evd.remove sigma e) e {e_def with Evd.evar_body = Evar_empty} in + sigma, e_body in + let ex_value hole = + match kind_of_term hole with Evar (e,_) -> e | _ -> assert false in + let mk_upat_for ?hack env sigma0 (sigma, t) ?(p=t) ok = + let sigma,pat= mk_tpattern ?hack env sigma0 (sigma,p) ok L2R (fs sigma t) in + sigma, [pat] in + match pattern with + | None -> do_subst env0 concl0 1 + | Some (sigma, (T rp | In_T rp)) -> + let rp = fs sigma rp in + let ise = create_evar_defs sigma in + let occ = match pattern with Some (_, T _) -> occ | _ -> noindex in + let rp = mk_upat_for env0 sigma0 (ise, rp) all_ok in + let find_T, end_T = mk_tpattern_matcher ?raise_NoMatch sigma0 occ rp in + let concl = find_T env0 concl0 1 do_subst in + let _ = end_T () in + concl + | Some (sigma, (X_In_T (hole, p) | In_X_In_T (hole, p))) -> + let p = fs sigma p in + let occ = match pattern with Some (_, X_In_T _) -> occ | _ -> noindex in + let ex = ex_value hole in + let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in + let find_T, end_T = mk_tpattern_matcher sigma0 noindex rp in + (* we start from sigma, so hole is considered a rigid head *) + let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in + let find_X, end_X = mk_tpattern_matcher ?raise_NoMatch sigma occ holep in + let concl = find_T env0 concl0 1 (fun env c h -> + let p_sigma = unify_HO env (create_evar_defs sigma) c p in + let sigma, e_body = pop_evar p_sigma ex p in + fs p_sigma (find_X env (fs sigma p) h + (fun env _ -> do_subst env e_body))) in + let _ = end_X () in let _ = end_T () in + concl + | Some (sigma, E_In_X_In_T (e, hole, p)) -> + let p, e = fs sigma p, fs sigma e in + let ex = ex_value hole in + let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in + let find_T, end_T = mk_tpattern_matcher sigma0 noindex rp in + let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in + let find_X, end_X = mk_tpattern_matcher sigma noindex holep in + let re = mk_upat_for env0 sigma0 (sigma, e) all_ok in + let find_E, end_E = mk_tpattern_matcher ?raise_NoMatch sigma0 occ re in + let concl = find_T env0 concl0 1 (fun env c h -> + let p_sigma = unify_HO env (create_evar_defs sigma) c p in + let sigma, e_body = pop_evar p_sigma ex p in + fs p_sigma (find_X env (fs sigma p) h (fun env c h -> + find_E env e_body h do_subst))) in + let _ = end_E () in let _ = end_X () in let _ = end_T () in + concl + | Some (sigma, E_As_X_In_T (e, hole, p)) -> + let p, e = fs sigma p, fs sigma e in + let ex = ex_value hole in + let rp = + let e_sigma = unify_HO env0 sigma hole e in + e_sigma, fs e_sigma p in + let rp = mk_upat_for ~hack:true env0 sigma0 rp all_ok in + let find_TE, end_TE = mk_tpattern_matcher sigma0 noindex rp in + let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in + let find_X, end_X = mk_tpattern_matcher sigma occ holep in + let concl = find_TE env0 concl0 1 (fun env c h -> + let p_sigma = unify_HO env (create_evar_defs sigma) c p in + let sigma, e_body = pop_evar p_sigma ex p in + fs p_sigma (find_X env (fs sigma p) h (fun env c h -> + let e_sigma = unify_HO env sigma e_body e in + let e_body = fs e_sigma e in + do_subst env e_body h))) in + let _ = end_X () in let _ = end_TE () in + concl +;; + +let redex_of_pattern ?(resolve_typeclasses=false) env (sigma, p) = + let e = match p with + | In_T _ | In_X_In_T _ -> anomaly "pattern without redex" + | T e | X_In_T (e, _) | E_As_X_In_T (e, _, _) | E_In_X_In_T (e, _, _) -> e in + let sigma = + if not resolve_typeclasses then sigma + else Typeclasses.resolve_typeclasses ~fail:false env sigma in + Reductionops.nf_evar sigma e + +let fill_occ_pattern ?raise_NoMatch env sigma cl pat occ h = + let find_R, conclude = let r = ref None in + (fun env c h' -> do_once r (fun () -> c); mkRel (h'+h-1)), + (fun _ -> if !r = None then redex_of_pattern env pat else assert_done r) in + let cl = eval_pattern ?raise_NoMatch env sigma cl (Some pat) occ find_R in + let e = conclude cl in + e, cl +;; + +(* clenup interface for external use *) +let mk_tpattern ?p_origin env sigma0 sigma_t f dir c = + mk_tpattern ?p_origin env sigma0 sigma_t f dir c +;; + +let pf_fill_occ env concl occ sigma0 p (sigma, t) ok h = + let ise = create_evar_defs sigma in + let ise, u = mk_tpattern env sigma0 (ise,t) ok L2R p in + let find_U, end_U = + mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[u]) in + let concl = find_U env concl h (fun _ _ -> mkRel) in + let rdx, _, (sigma, p) = end_U () in + sigma, p, concl, rdx + +let fill_occ_term env cl occ sigma0 (sigma, t) = + try + let sigma',t',cl,_ = pf_fill_occ env cl occ sigma0 t (sigma, t) all_ok 1 in + if sigma' != sigma0 then error "matching impacts evars" else cl, (sigma',t') with NoMatch -> try + let sigma', t' = + unif_end env sigma0 (create_evar_defs sigma) t (fun _ -> true) in + if sigma' != sigma0 then raise NoMatch else cl, (sigma', t') + with _ -> + errorstrm (str "partial term " ++ pr_constr_pat t + ++ str " does not match any subterm of the goal") + +let pf_fill_occ_term gl occ t = + let sigma0 = project gl and env = pf_env gl and concl = pf_concl gl in + let cl,(_,t) = fill_occ_term env concl occ sigma0 t in + cl, t + +let cpattern_of_id id = ' ', (GRef (dummy_loc, VarRef id), None) + +let is_wildcard = function + | _,(_,Some (CHole _)|GHole _,None) -> true + | _ -> false + +type ltacctx = int + +let pr_ltacctx _ _ _ _ = mt () + +let ltacctxs = ref (1, []) + +let interp_ltacctx ist gl n0 = + Tacmach.project gl, + if n0 = 0 then 0 else + let n, s = !ltacctxs in + let n' = if n >= max_int then 1 else n + 1 in + ltacctxs := (n', (n, ist) :: s); n + +let noltacctx = 0 +let rawltacctx = 1 + +ARGUMENT EXTEND ltacctx TYPED AS int PRINTED BY pr_ltacctx + INTERPRETED BY interp_ltacctx +| [ ] -> [ rawltacctx ] +END + +let get_ltacctx i = match !ltacctxs with +| _ when i = noltacctx -> anomaly "Missing Ltac context" +| n, (i', ist) :: s when i' = i -> ltacctxs := (n, s); ist +| _ -> anomaly "Bad scope in SSR tactical" + +(* "ssrpattern" *) +let pr_ssrpatternarg _ _ _ cpat = pr_rpattern cpat + +ARGUMENT EXTEND ssrpatternarg + TYPED AS rpattern + PRINTED BY pr_ssrpatternarg +| [ "[" rpattern(pat) "]" ] -> [ pat ] +END + +let ssrpatterntac ctx arg gl = + let ist = get_ltacctx ctx in + let pat = interp_rpattern ist gl arg in + let sigma0 = project gl in + let concl0 = pf_concl gl in + let t, concl_x = fill_occ_pattern (Global.env()) sigma0 concl0 pat noindex 1 in + let tty = pf_type_of gl t in + let concl = mkLetIn (Name (id_of_string "toto"), t, tty, concl_x) in + convert_concl concl DEFAULTcast gl + +TACTIC EXTEND ssrat +| [ "ssrpattern" ssrpatternarg(arg) ltacctx(ctx) ] -> [ ssrpatterntac ctx arg ] +END + + +(* We wipe out all the keywords generated by the grammar rules we defined. *) +(* The user is supposed to Require Import ssreflect or Require ssreflect *) +(* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) +(* consequence the extended ssreflect grammar. *) +let () = Lexer.unfreeze frozen_lexer ;; + +(* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/mathcomp/ssreflect/plugin/v8.4/ssrmatching.mli b/mathcomp/ssreflect/plugin/v8.4/ssrmatching.mli new file mode 100644 index 0000000..4c6bfac --- /dev/null +++ b/mathcomp/ssreflect/plugin/v8.4/ssrmatching.mli @@ -0,0 +1,256 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) + +open Genarg +open Environ +open Evd +open Proof_type +open Term + +(** ******** Small Scale Reflection pattern matching facilities ************* *) + +(** Pattern parsing *) + +(** The type of context patterns, the patterns of the [set] tactic and + [:] tactical. These are patterns that identify a precise subterm. *) +type cpattern +val pr_cpattern : cpattern -> Pp.std_ppcmds + +(** CS cpattern: (f _), (X in t), (t in X in t), (t as X in t) *) +val cpattern : cpattern Pcoq.Gram.entry +val globwit_cpattern : (cpattern, glevel) abstract_argument_type +val rawwit_cpattern : (cpattern, rlevel) abstract_argument_type +val wit_cpattern : (cpattern, tlevel) abstract_argument_type + +(** OS cpattern: f _, (X in t), (t in X in t), (t as X in t) *) +val lcpattern : cpattern Pcoq.Gram.entry +val globwit_lcpattern : (cpattern, glevel) abstract_argument_type +val rawwit_lcpattern : (cpattern, rlevel) abstract_argument_type +val wit_lcpattern : (cpattern, tlevel) abstract_argument_type + +(** The type of rewrite patterns, the patterns of the [rewrite] tactic. + These patterns also include patterns that identify all the subterms + of a context (i.e. "in" prefix) *) +type rpattern +val pr_rpattern : rpattern -> Pp.std_ppcmds + +(** OS rpattern: f _, in t, X in t, in X in t, t in X in t, t as X in t *) +val rpattern : rpattern Pcoq.Gram.entry +val globwit_rpattern : (rpattern, glevel) abstract_argument_type +val rawwit_rpattern : (rpattern, rlevel) abstract_argument_type +val wit_rpattern : (rpattern, tlevel) abstract_argument_type + +(** Pattern interpretation and matching *) + +exception NoMatch +exception NoProgress + +(** AST for [rpattern] (and consequently [cpattern]) *) +type ('ident, 'term) ssrpattern = + | T of 'term + | In_T of 'term + | X_In_T of 'ident * 'term + | In_X_In_T of 'ident * 'term + | E_In_X_In_T of 'term * 'ident * 'term + | E_As_X_In_T of 'term * 'ident * 'term + +type pattern = evar_map * (constr, constr) ssrpattern +val pp_pattern : pattern -> Pp.std_ppcmds + +(** Extracts the redex and applies to it the substitution part of the pattern. + @raise Anomaly if called on [In_T] or [In_X_In_T] *) +val redex_of_pattern : ?resolve_typeclasses:bool -> env -> pattern -> constr + +(** [interp_rpattern ise gl rpat] "internalizes" and "interprets" [rpat] + in the current [Ltac] interpretation signature [ise] and tactic input [gl]*) +val interp_rpattern : + Tacinterp.interp_sign -> goal Tacmach.sigma -> + rpattern -> + pattern + +(** [interp_cpattern ise gl cpat ty] "internalizes" and "interprets" [cpat] + in the current [Ltac] interpretation signature [ise] and tactic input [gl]. + [ty] is an optional type for the redex of [cpat] *) +val interp_cpattern : + Tacinterp.interp_sign -> goal Tacmach.sigma -> + cpattern -> glob_constr_and_expr option -> + pattern + +(** The set of occurrences to be matched. The boolean is set to true + * to signal the complement of this set (i.e. {-1 3}) *) +type occ = (bool * int list) option + +(** Substitution function. The [int] argument is the number of binders + traversed so far *) +type subst = env -> constr -> int -> constr + +(** [eval_pattern b env sigma t pat occ subst] maps [t] calling [subst] on every + [occ] occurrence of [pat]. The [int] argument is the number of + binders traversed. If [pat] is [None] then then subst is called on [t]. + [t] must live in [env] and [sigma], [pat] must have been interpreted in + (an extension of) [sigma]. + @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false]) + @return [t] where all [occ] occurrences of [pat] have been mapped using + [subst] *) +val eval_pattern : + ?raise_NoMatch:bool -> + env -> evar_map -> constr -> + pattern option -> occ -> subst -> + constr + +(** [fill_occ_pattern b env sigma t pat occ h] is a simplified version of + [eval_pattern]. + It replaces all [occ] occurrences of [pat] in [t] with Rel [h]. + [t] must live in [env] and [sigma], [pat] must have been interpreted in + (an extension of) [sigma]. + @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false]) + @return the instance of the redex of [pat] that was matched and [t] + transformed as described above. *) +val fill_occ_pattern : + ?raise_NoMatch:bool -> + env -> evar_map -> constr -> + pattern -> occ -> int -> + constr * constr + +(** Grammar entry to grab [Ltac] context, needed for the functions above. + It must appear after the last tactic argument and only once. + For example {[ + TACTIC EXTEND ssrclear + | [ "clear" natural(n) ltacctx(ctx) ] -> [poptac ~ist:(get_ltacctx ctx) n] + END ]} *) +type ltacctx + +val get_ltacctx : ltacctx -> Tacinterp.interp_sign + +val ltacctx : ltacctx Pcoq.Gram.entry +val globwit_ltacctx : (ltacctx, glevel) abstract_argument_type +val rawwit_ltacctx : (ltacctx, rlevel) abstract_argument_type +val wit_ltacctx : (ltacctx, tlevel) abstract_argument_type + +(** *************************** Low level APIs ****************************** *) + +(* The primitive matching facility. It matches of a term with holes, like + the T pattern above, and calls a continuation on its occurrences. *) + +type ssrdir = L2R | R2L +val pr_dir_side : ssrdir -> Pp.std_ppcmds + +(** a pattern for a term with wildcards *) +type tpattern + +(** [mk_tpattern env sigma0 sigma_t ok p_origin dir p] compiles a term [t] + living in [env] [sigma] (an extension of [sigma0]) intro a [tpattern]. + The [tpattern] can hold a (proof) term [p] and a diction [dir]. The [ok] + callback is used to filter occurrences. + @return the compiled [tpattern] and its [evar_map] + @raise UserEerror is the pattern is a wildcard *) +val mk_tpattern : + ?p_origin:ssrdir * constr -> + env -> evar_map -> + evar_map * constr -> + (constr -> evar_map -> bool) -> + ssrdir -> constr -> + evar_map * tpattern + +(** [findP env t i k] is a stateful function that finds the next occurrence + of a tpattern and calls the callback [k] to map the subterm matched. + The [int] argument passed to [k] is the number of binders traversed so far + plus the initial value [i]. + @return [t] where the subterms identified by the selected occurrences of + the patter have been mapped using [k] + @raise NoMatch if the raise_NoMatch flag given to [mk_tpattern_matcher] is + [true] and if the pattern did not match + @raise UserEerror if the raise_NoMatch flag given to [mk_tpattern_matcher] is + [false] and if the pattern did not match *) +type find_P = + env -> constr -> int -> k:subst -> constr + +(** [conclude ()] asserts that all mentioned ocurrences have been visited. + @return the instance of the pattern, the evarmap after the pattern + instantiation, the proof term and the ssrdit stored in the tpattern + @raise UserEerror if too many occurrences were specified *) +type conclude = unit -> constr * ssrdir * (evar_map * constr) + +(** [mk_tpattern_matcher b o sigma0 occ sigma_tplist] creates a pair + a function [find_P] and [conclude] with the behaviour explained above. + The flag [b] (default [false]) changes the error reporting behaviour + of [find_P] if none of the [tpattern] matches. The argument [o] can + be passed to tune the [UserError] eventually raised (useful if the + pattern is coming from the LHS/RHS of an equation) *) +val mk_tpattern_matcher : + ?raise_NoMatch:bool -> + ?upats_origin:ssrdir * constr -> + evar_map -> occ -> evar_map * tpattern list -> + find_P * conclude + +(** Example of [mk_tpattern_matcher] to implement + [rewrite \{occ\}\[in t\]rules]. + It first matches "in t" (called [pat]), then in all matched subterms + it matches the LHS of the rules using [find_R]. + [concl0] is the initial goal, [concl] will be the goal where some terms + are replaced by a De Bruijn index. The [rw_progress] extra check + selects only occurrences that are not rewritten to themselves (e.g. + an occurrence "x + x" rewritten with the commutativity law of addition + is skipped) {[ + let find_R, conclude = match pat with + | Some (_, In_T _) -> + let aux (sigma, pats) (d, r, lhs, rhs) = + let sigma, pat = + mk_tpattern env0 sigma0 (sigma, r) (rw_progress rhs) d lhs in + sigma, pats @ [pat] in + let rpats = List.fold_left aux (r_sigma, []) rules in + let find_R, end_R = mk_tpattern_matcher sigma0 occ rpats in + find_R ~k:(fun _ _ h -> mkRel h), + fun cl -> let rdx, d, r = end_R () in (d,r),rdx + | _ -> ... in + let concl = eval_pattern env0 sigma0 concl0 pat occ find_R in + let (d, r), rdx = conclude concl in ]} *) + +(* convenience shortcut: [pf_fill_occ_term gl occ (sigma,t)] returns + * the conclusion of [gl] where [occ] occurrences of [t] have been replaced + * by [Rel 1] and the instance of [t] *) +val pf_fill_occ_term : + goal Tacmach.sigma -> occ -> evar_map * constr -> constr * constr + +(* It may be handy to inject a simple term into the first form of cpattern *) +val cpattern_of_term : char * glob_constr_and_expr -> cpattern + +(** Helpers to make stateful closures. Example: a [find_P] function may be + called many times, but the pattern instantiation phase is performed only the + first time. The corresponding [conclude] has to return the instantiated + pattern redex. Since it is up to [find_P] to raise [NoMatch] if the pattern + has no instance, [conclude] considers it an anomaly if the pattern did + not match *) + +(** [do_once r f] calls [f] and updates the ref only once *) +val do_once : 'a option ref -> (unit -> 'a) -> unit +(** [assert_done r] return the content of r. @raise Anomaly is r is [None] *) +val assert_done : 'a option ref -> 'a + +(** Very low level APIs. + these are calls to evarconv's [the_conv_x] followed by + [consider_remaining_unif_problems] and [resolve_typeclasses]. + In case of failure they raise [NoMatch] *) + +val unify_HO : env -> evar_map -> constr -> constr -> evar_map +val pf_unify_HO : goal Tacmach.sigma -> constr -> constr -> goal Tacmach.sigma + +(** Some more low level functions needed to implement the full SSR language + on top of the former APIs *) +val tag_of_cpattern : cpattern -> char +val loc_of_cpattern : cpattern -> Util.loc +val id_of_cpattern : cpattern -> Names.variable option +val is_wildcard : cpattern -> bool +val cpattern_of_id : Names.variable -> cpattern +val rawltacctx : ltacctx +val cpattern_of_id : Names.variable -> cpattern +val rawltacctx : ltacctx +val pr_constr_pat : constr -> Pp.std_ppcmds + +(* One can also "Set SsrMatchingDebug" from a .v *) +val debug : bool -> unit + +(* One should delimit a snippet with "Set SsrMatchingProfiling" and + * "Unset SsrMatchingProfiling" to get timings *) +val profile : bool -> unit + +(* eof *) diff --git a/mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 b/mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 new file mode 100644 index 0000000..f598c21 --- /dev/null +++ b/mathcomp/ssreflect/plugin/v8.5/ssreflect.ml4 @@ -0,0 +1,6164 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) + +(* This line is read by the Makefile's dist target: do not remove. *) +DECLARE PLUGIN "ssreflect" +let ssrversion = "1.5";; +let ssrAstVersion = 1;; +let () = Mltop.add_known_plugin (fun () -> + if Flags.is_verbose () && not !Flags.batch_mode then begin + Printf.printf "\nSmall Scale Reflection version %s loaded.\n" ssrversion; + Printf.printf "Copyright 2005-2014 Microsoft Corporation and INRIA.\n"; + Printf.printf "Distributed under the terms of the CeCILL-B license.\n\n" + end; + (* Disable any semantics associated with bullets *) + Goptions.set_string_option_value_gen + (Some false) ["Bullet";"Behavior"] "None") + "ssreflect" +;; + +(* Defining grammar rules with "xx" in it automatically declares keywords too, + * we thus save the lexer to restore it at the end of the file *) +let frozen_lexer = Lexer.freeze () ;; + +(*i camlp4use: "pa_extend.cmo" i*) +(*i camlp4deps: "grammar/grammar.cma" i*) + +open Names +open Pp +open Pcoq +open Genarg +open Stdarg +open Constrarg +open Term +open Vars +open Context +open Topconstr +open Libnames +open Tactics +open Tacticals +open Termops +open Namegen +open Recordops +open Tacmach +open Coqlib +open Glob_term +open Util +open Evd +open Extend +open Goptions +open Tacexpr +open Tacinterp +open Pretyping +open Constr +open Tactic +open Extraargs +open Ppconstr +open Printer + +open Globnames +open Misctypes +open Decl_kinds +open Evar_kinds +open Constrexpr +open Constrexpr_ops +open Notation_term +open Notation_ops +open Locus +open Locusops + +open Ssrmatching + + +(* Tentative patch from util.ml *) + +let array_fold_right_from n f v a = + let rec fold n = + if n >= Array.length v then a else f v.(n) (fold (succ n)) + in + fold n + +let array_app_tl v l = + if Array.length v = 0 then invalid_arg "array_app_tl"; + array_fold_right_from 1 (fun e l -> e::l) v l + +let array_list_of_tl v = + if Array.length v = 0 then invalid_arg "array_list_of_tl"; + array_fold_right_from 1 (fun e l -> e::l) v [] + +(* end patch *) + +module Intset = Evar.Set + +type loc = Loc.t +let dummy_loc = Loc.ghost +let errorstrm = Errors.errorlabstrm "ssreflect" +let loc_error loc msg = Errors.user_err_loc (loc, msg, str msg) +let anomaly s = Errors.anomaly (str s) + +(** look up a name in the ssreflect internals module *) +let ssrdirpath = make_dirpath [id_of_string "ssreflect"] +let ssrqid name = make_qualid ssrdirpath (id_of_string name) +let ssrtopqid name = make_short_qualid (id_of_string name) +let locate_reference qid = + Smartlocate.global_of_extended_global (Nametab.locate_extended qid) +let mkSsrRef name = + try locate_reference (ssrqid name) with Not_found -> + try locate_reference (ssrtopqid name) with Not_found -> + Errors.error "Small scale reflection library not loaded" +let mkSsrRRef name = GRef (dummy_loc, mkSsrRef name,None), None +let mkSsrConst name env sigma = + Evd.fresh_global env sigma (mkSsrRef name) +let pf_mkSsrConst name gl = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma, t = mkSsrConst name env sigma in + t, re_sig it sigma +let pf_fresh_global name gl = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma,t = Evd.fresh_global env sigma name in + t, re_sig it sigma + +(** Ssreflect load check. *) + +(* To allow ssrcoq to be fully compatible with the "plain" Coq, we only *) +(* turn on its incompatible features (the new rewrite syntax, and the *) +(* reserved identifiers) when the theory library (ssreflect.v) has *) +(* has actually been required, or is being defined. Because this check *) +(* needs to be done often (for each identifier lookup), we implement *) +(* some caching, repeating the test only when the environment changes. *) +(* We check for protect_term because it is the first constant loaded; *) +(* ssr_have would ultimately be a better choice. *) +let ssr_loaded = Summary.ref ~name:"SSR:loaded" false +let is_ssr_loaded () = + !ssr_loaded || + (if Lexer.is_keyword "SsrSyntax_is_Imported" then ssr_loaded:=true; + !ssr_loaded) + +(* 0 cost pp function. Active only if env variable SSRDEBUG is set *) +(* or if SsrDebug is Set *) +let pp_ref = ref (fun _ -> ()) +let ssr_pp s = pperrnl (str"SSR: "++Lazy.force s) +let _ = try ignore(Sys.getenv "SSRDEBUG"); pp_ref := ssr_pp with Not_found -> () +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssreflect debugging"; + Goptions.optkey = ["SsrDebug"]; + Goptions.optdepr = false; + Goptions.optread = (fun _ -> !pp_ref == ssr_pp); + Goptions.optwrite = (fun b -> + Ssrmatching.debug b; + if b then pp_ref := ssr_pp else pp_ref := fun _ -> ()) } +let pp s = !pp_ref s + +(** Utils {{{ *****************************************************************) +let env_size env = List.length (Environ.named_context env) +let safeDestApp c = + match kind_of_term c with App (f, a) -> f, a | _ -> c, [| |] +let get_index = function ArgArg i -> i | _ -> + anomaly "Uninterpreted index" +(* Toplevel constr must be globalized twice ! *) +let glob_constr ist genv = function + | _, Some ce -> + let vars = Id.Map.fold (fun x _ accu -> Id.Set.add x accu) ist.lfun Id.Set.empty in + let ltacvars = { + Constrintern.empty_ltac_sign with Constrintern.ltac_vars = vars } in + Constrintern.intern_gen WithoutTypeConstraint ~ltacvars genv ce + | rc, None -> rc + +(* Term printing utilities functions for deciding bracketing. *) +let pr_paren prx x = hov 1 (str "(" ++ prx x ++ str ")") +(* String lexing utilities *) +let skip_wschars s = + let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop +let skip_numchars s = + let rec loop i = match s.[i] with '0'..'9' -> loop (i + 1) | _ -> i in loop +(* We also guard characters that might interfere with the ssreflect *) +(* tactic syntax. *) +let guard_term ch1 s i = match s.[i] with + | '(' -> false + | '{' | '/' | '=' -> true + | _ -> ch1 = '(' +(* The call 'guard s i' should return true if the contents of s *) +(* starting at i need bracketing to avoid ambiguities. *) +let pr_guarded guard prc c = + msg_with Format.str_formatter (prc c); + let s = Format.flush_str_formatter () ^ "$" in + if guard s (skip_wschars s 0) then pr_paren prc c else prc c +(* More sensible names for constr printers *) +let prl_constr = pr_lconstr +let pr_constr = pr_constr +let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c +let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c +let prl_constr_expr = pr_lconstr_expr +let pr_constr_expr = pr_constr_expr +let prl_glob_constr_and_expr = function + | _, Some c -> prl_constr_expr c + | c, None -> prl_glob_constr c +let pr_glob_constr_and_expr = function + | _, Some c -> pr_constr_expr c + | c, None -> pr_glob_constr c +let pr_term (k, c) = pr_guarded (guard_term k) pr_glob_constr_and_expr c +let prl_term (k, c) = pr_guarded (guard_term k) prl_glob_constr_and_expr c + +(** Adding a new uninterpreted generic argument type *) +let add_genarg tag pr = + let wit = Genarg.make0 None tag in + let glob ist x = (ist, x) in + let subst _ x = x in + let interp ist gl x = (gl.Evd.sigma, x) in + let gen_pr _ _ _ = pr in + let () = Genintern.register_intern0 wit glob in + let () = Genintern.register_subst0 wit subst in + let () = Geninterp.register_interp0 wit interp in + Pptactic.declare_extra_genarg_pprule wit gen_pr gen_pr gen_pr; + wit + +(** Constructors for cast type *) +let dC t = CastConv t + +(** Constructors for constr_expr *) +let mkCProp loc = CSort (loc, GProp) +let mkCType loc = CSort (loc, GType []) +let mkCVar loc id = CRef (Ident (loc, id),None) +let isCVar = function CRef (Ident _,_) -> true | _ -> false +let destCVar = function CRef (Ident (_, id),_) -> id | _ -> + anomaly "not a CRef" +let rec mkCHoles loc n = + if n <= 0 then [] else CHole (loc, None, IntroAnonymous, None) :: mkCHoles loc (n - 1) +let mkCHole loc = CHole (loc, None, IntroAnonymous, None) +let rec isCHoles = function CHole _ :: cl -> isCHoles cl | cl -> cl = [] +let mkCExplVar loc id n = + CAppExpl (loc, (None, Ident (loc, id), None), mkCHoles loc n) +let mkCLambda loc name ty t = + CLambdaN (loc, [[loc, name], Default Explicit, ty], t) +let mkCLetIn loc name bo t = + CLetIn (loc, (loc, name), bo, t) +let mkCArrow loc ty t = + CProdN (loc, [[dummy_loc,Anonymous], Default Explicit, ty], t) +let mkCCast loc t ty = CCast (loc,t, dC ty) +(** Constructors for rawconstr *) +let mkRHole = GHole (dummy_loc, InternalHole, IntroAnonymous, None) +let rec mkRHoles n = if n > 0 then mkRHole :: mkRHoles (n - 1) else [] +let rec isRHoles = function GHole _ :: cl -> isRHoles cl | cl -> cl = [] +let mkRApp f args = if args = [] then f else GApp (dummy_loc, f, args) +let mkRVar id = GRef (dummy_loc, VarRef id,None) +let mkRltacVar id = GVar (dummy_loc, id) +let mkRCast rc rt = GCast (dummy_loc, rc, dC rt) +let mkRType = GSort (dummy_loc, GType []) +let mkRProp = GSort (dummy_loc, GProp) +let mkRArrow rt1 rt2 = GProd (dummy_loc, Anonymous, Explicit, rt1, rt2) +let mkRConstruct c = GRef (dummy_loc, ConstructRef c,None) +let mkRInd mind = GRef (dummy_loc, IndRef mind,None) +let mkRLambda n s t = GLambda (dummy_loc, n, Explicit, s, t) + +(** Constructors for constr *) +let pf_e_type_of gl t = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma, ty = Typing.e_type_of env sigma t in + re_sig it sigma, ty + +let mkAppRed f c = match kind_of_term f with +| Lambda (_, _, b) -> subst1 c b +| _ -> mkApp (f, [|c|]) + +let mkProt t c gl = + let prot, gl = pf_mkSsrConst "protect_term" gl in + mkApp (prot, [|t; c|]), gl + +let mkRefl t c gl = + let refl, gl = pf_fresh_global (build_coq_eq_data()).refl gl in + mkApp (refl, [|t; c|]), gl + + +(* Application to a sequence of n rels (for building eta-expansions). *) +(* The rel indices decrease down to imin (inclusive), unless n < 0, *) +(* in which case they're incresing (from imin). *) +let mkEtaApp c n imin = + if n = 0 then c else + let nargs, mkarg = + if n < 0 then -n, (fun i -> mkRel (imin + i)) else + let imax = imin + n - 1 in n, (fun i -> mkRel (imax - i)) in + mkApp (c, Array.init nargs mkarg) +(* Same, but optimizing head beta redexes *) +let rec whdEtaApp c n = + if n = 0 then c else match kind_of_term c with + | Lambda (_, _, c') -> whdEtaApp c' (n - 1) + | _ -> mkEtaApp (lift n c) n 1 +let mkType () = Universes.new_Type (Lib.cwd ()) + +(* ssrterm conbinators *) +let combineCG t1 t2 f g = match t1, t2 with + | (x, (t1, None)), (_, (t2, None)) -> x, (g t1 t2, None) + | (x, (_, Some t1)), (_, (_, Some t2)) -> x, (mkRHole, Some (f t1 t2)) + | _, (_, (_, None)) -> anomaly "have: mixed C-G constr" + | _ -> anomaly "have: mixed G-C constr" +let loc_ofCG = function + | (_, (s, None)) -> Glob_ops.loc_of_glob_constr s + | (_, (_, Some s)) -> Constrexpr_ops.constr_loc s + +let mk_term k c = k, (mkRHole, Some c) +let mk_lterm c = mk_term ' ' c + +let map_fold_constr g f ctx acc cstr = + let array_f ctx acc x = let x, acc = f ctx acc x in acc, x in + match kind_of_term cstr with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> + cstr, acc + | Proj (x,c) -> + let c', acc = f ctx acc c in + (if c == c' then cstr else mkProj (x,c')), acc + | Cast (c,k, t) -> + let c', acc = f ctx acc c in + let t', acc = f ctx acc t in + (if c==c' && t==t' then cstr else mkCast (c', k, t')), acc + | Prod (na,t,c) -> + let t', acc = f ctx acc t in + let c', acc = f (g (na,None,t) ctx) acc c in + (if t==t' && c==c' then cstr else mkProd (na, t', c')), acc + | Lambda (na,t,c) -> + let t', acc = f ctx acc t in + let c', acc = f (g (na,None,t) ctx) acc c in + (if t==t' && c==c' then cstr else mkLambda (na, t', c')), acc + | LetIn (na,b,t,c) -> + let b', acc = f ctx acc b in + let t', acc = f ctx acc t in + let c', acc = f (g (na,Some b,t) ctx) acc c in + (if b==b' && t==t' && c==c' then cstr else mkLetIn (na, b', t', c')), acc + | App (c,al) -> + let c', acc = f ctx acc c in + let acc, al' = CArray.smartfoldmap (array_f ctx) acc al in + (if c==c' && Array.for_all2 (==) al al' then cstr else mkApp (c', al')), + acc + | Evar (e,al) -> + let acc, al' = CArray.smartfoldmap (array_f ctx) acc al in + (if Array.for_all2 (==) al al' then cstr else mkEvar (e, al')), acc + | Case (ci,p,c,bl) -> + let p', acc = f ctx acc p in + let c', acc = f ctx acc c in + let acc, bl' = CArray.smartfoldmap (array_f ctx) acc bl in + (if p==p' && c==c' && Array.for_all2 (==) bl bl' then cstr else + mkCase (ci, p', c', bl')), + acc + | Fix (ln,(lna,tl,bl)) -> + let acc, tl' = CArray.smartfoldmap (array_f ctx) acc tl in + let ctx' = Array.fold_left2 (fun l na t -> g (na,None,t) l) ctx lna tl in + let acc, bl' = CArray.smartfoldmap (array_f ctx') acc bl in + (if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' + then cstr + else mkFix (ln,(lna,tl',bl'))), acc + | CoFix(ln,(lna,tl,bl)) -> + let acc, tl' = CArray.smartfoldmap (array_f ctx) acc tl in + let ctx' = Array.fold_left2 (fun l na t -> g (na,None,t) l) ctx lna tl in + let acc,bl' = CArray.smartfoldmap (array_f ctx') acc bl in + (if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' + then cstr + else mkCoFix (ln,(lna,tl',bl'))), acc + +let pf_merge_uc_of sigma gl = + let ucst = Evd.evar_universe_context sigma in + pf_merge_uc ucst gl + +(* }}} *) + +(** Profiling {{{ *************************************************************) +type profiler = { + profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; + reset : unit -> unit; + print : unit -> unit } +let profile_now = ref false +let something_profiled = ref false +let profilers = ref [] +let add_profiler f = profilers := f :: !profilers;; +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssreflect profiling"; + Goptions.optkey = ["SsrProfiling"]; + Goptions.optread = (fun _ -> !profile_now); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> + Ssrmatching.profile b; + profile_now := b; + if b then List.iter (fun f -> f.reset ()) !profilers; + if not b then List.iter (fun f -> f.print ()) !profilers) } +let () = + let prof_total = + let init = ref 0.0 in { + profile = (fun f x -> assert false); + reset = (fun () -> init := Unix.gettimeofday ()); + print = (fun () -> if !something_profiled then + prerr_endline + (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" + "total" 0 (Unix.gettimeofday() -. !init) 0.0 0.0)) } in + let prof_legenda = { + profile = (fun f x -> assert false); + reset = (fun () -> ()); + print = (fun () -> if !something_profiled then begin + prerr_endline + (Printf.sprintf "!! %39s ---------- --------- --------- ---------" + (String.make 39 '-')); + prerr_endline + (Printf.sprintf "!! %-39s %10s %9s %9s %9s" + "function" "#calls" "total" "max" "average") end) } in + add_profiler prof_legenda; + add_profiler prof_total +;; + +let mk_profiler s = + let total, calls, max = ref 0.0, ref 0, ref 0.0 in + let reset () = total := 0.0; calls := 0; max := 0.0 in + let profile f x = + if not !profile_now then f x else + let before = Unix.gettimeofday () in + try + incr calls; + let res = f x in + let after = Unix.gettimeofday () in + let delta = after -. before in + total := !total +. delta; + if delta > !max then max := delta; + res + with exc -> + let after = Unix.gettimeofday () in + let delta = after -. before in + total := !total +. delta; + if delta > !max then max := delta; + raise exc in + let print () = + if !calls <> 0 then begin + something_profiled := true; + prerr_endline + (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" + s !calls !total !max (!total /. (float_of_int !calls))) end in + let prof = { profile = profile; reset = reset; print = print } in + add_profiler prof; + prof +;; +(* }}} *) + +let inVersion = Libobject.declare_object { + (Libobject.default_object "SSRASTVERSION") with + Libobject.load_function = (fun _ (_,v) -> + if v <> ssrAstVersion then Errors.error "Please recompile your .vo files"); + Libobject.classify_function = (fun v -> Libobject.Keep v); +} + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssreflect version"; + Goptions.optkey = ["SsrAstVersion"]; + Goptions.optread = (fun _ -> true); + Goptions.optdepr = false; + Goptions.optwrite = (fun _ -> + Lib.add_anonymous_leaf (inVersion ssrAstVersion)) } + +let tactic_expr = Tactic.tactic_expr +let gallina_ext = Vernac_.gallina_ext +let sprintf = Printf.sprintf +let tactic_mode = G_vernac.tactic_mode + +(** 1. Utilities *) + + +let ssroldreworder = Summary.ref ~name:"SSR:oldreworder" true +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssreflect 1.3 compatibility flag"; + Goptions.optkey = ["SsrOldRewriteGoalsOrder"]; + Goptions.optread = (fun _ -> !ssroldreworder); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> ssroldreworder := b) } + +let ssrhaveNOtcresolution = ref false + +let inHaveTCResolution = Libobject.declare_object { + (Libobject.default_object "SSRHAVETCRESOLUTION") with + Libobject.cache_function = (fun (_,v) -> ssrhaveNOtcresolution := v); + Libobject.load_function = (fun _ (_,v) -> ssrhaveNOtcresolution := v); + Libobject.classify_function = (fun v -> Libobject.Keep v); +} + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "have type classes"; + Goptions.optkey = ["SsrHave";"NoTCResolution"]; + Goptions.optread = (fun _ -> !ssrhaveNOtcresolution); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> + Lib.add_anonymous_leaf (inHaveTCResolution b)) } + + +(** Primitive parsing to avoid syntax conflicts with basic tactics. *) + +let accept_before_syms syms strm = + match Compat.get_tok (stream_nth 1 strm) with + | Tok.KEYWORD sym when List.mem sym syms -> () + | _ -> raise Stream.Failure + +let accept_before_syms_or_any_id syms strm = + match Compat.get_tok (stream_nth 1 strm) with + | Tok.KEYWORD sym when List.mem sym syms -> () + | Tok.IDENT _ -> () + | _ -> raise Stream.Failure + +let accept_before_syms_or_ids syms ids strm = + match Compat.get_tok (stream_nth 1 strm) with + | Tok.KEYWORD sym when List.mem sym syms -> () + | Tok.IDENT id when List.mem id ids -> () + | _ -> raise Stream.Failure + +(** Pretty-printing utilities *) + +let pr_id = Ppconstr.pr_id +let pr_name = function Name id -> pr_id id | Anonymous -> str "_" +let pr_spc () = str " " +let pr_bar () = Pp.cut() ++ str "|" +let pr_list = prlist_with_sep + +let tacltop = (5,Ppextend.E) + +(** Tactic-level diagnosis *) + +let pf_pr_constr gl = pr_constr_env (pf_env gl) + +let pf_pr_glob_constr gl = pr_glob_constr_env (pf_env gl) + +(* debug *) + +let pf_msg gl = + let ppgl = pr_lconstr_env (pf_env gl) (project gl) (pf_concl gl) in + msgnl (str "goal is " ++ ppgl) + +let msgtac gl = pf_msg gl; tclIDTAC gl + +(** Tactic utilities *) + +let last_goal gls = let sigma, gll = Refiner.unpackage gls in + Refiner.repackage sigma (List.nth gll (List.length gll - 1)) + +let pf_type_id gl t = id_of_string (hdchar (pf_env gl) t) + +let not_section_id id = not (is_section_variable id) + +let is_pf_var c = isVar c && not_section_id (destVar c) + +let pf_ids_of_proof_hyps gl = + let add_hyp (id, _, _) ids = if not_section_id id then id :: ids else ids in + Context.fold_named_context add_hyp (pf_hyps gl) ~init:[] + +let pf_nf_evar gl e = Reductionops.nf_evar (project gl) e + +let pf_partial_solution gl t evl = + let sigma, g = project gl, sig_it gl in + let sigma = Goal.V82.partial_solution sigma g t in + re_sig (List.map (fun x -> (fst (destEvar x))) evl) sigma + +let pf_new_evar gl ty = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma, extra = Evarutil.new_evar env sigma ty in + re_sig it sigma, extra + +(* Basic tactics *) + +let convert_concl_no_check t = convert_concl_no_check t DEFAULTcast +let convert_concl t = convert_concl t DEFAULTcast +let reduct_in_concl t = reduct_in_concl (t, DEFAULTcast) +let havetac id c = Proofview.V82.of_tactic (pose_proof (Name id) c) +let settac id c = letin_tac None (Name id) c None +let posetac id cl = Proofview.V82.of_tactic (settac id cl nowhere) +let basecuttac name c gl = + let hd, gl = pf_mkSsrConst name gl in + let t = mkApp (hd, [|c|]) in + let gl, _ = pf_e_type_of gl t in + Proofview.V82.of_tactic (apply t) gl + +(* we reduce head beta redexes *) +let betared env = + Closure.create_clos_infos + (Closure.RedFlags.mkflags [Closure.RedFlags.fBETA]) + env +;; +let introid name = tclTHEN (fun gl -> + let g, env = pf_concl gl, pf_env gl in + match kind_of_term g with + | App (hd, _) when isLambda hd -> + let g = Closure.whd_val (betared env) (Closure.inject g) in + Proofview.V82.of_tactic (convert_concl_no_check g) gl + | _ -> tclIDTAC gl) + (Proofview.V82.of_tactic (intro_mustbe_force name)) +;; + + +(** Name generation {{{ *******************************************************) + +(* Since Coq now does repeated internal checks of its external lexical *) +(* rules, we now need to carve ssreflect reserved identifiers out of *) +(* out of the user namespace. We use identifiers of the form _id_ for *) +(* this purpose, e.g., we "anonymize" an identifier id as _id_, adding *) +(* an extra leading _ if this might clash with an internal identifier. *) +(* We check for ssreflect identifiers in the ident grammar rule; *) +(* when the ssreflect Module is present this is normally an error, *) +(* but we provide a compatibility flag to reduce this to a warning. *) + +let ssr_reserved_ids = Summary.ref ~name:"SSR:idents" true + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optname = "ssreflect identifiers"; + Goptions.optkey = ["SsrIdents"]; + Goptions.optdepr = false; + Goptions.optread = (fun _ -> !ssr_reserved_ids); + Goptions.optwrite = (fun b -> ssr_reserved_ids := b) + } + +let is_ssr_reserved s = + let n = String.length s in n > 2 && s.[0] = '_' && s.[n - 1] = '_' + +let internal_names = ref [] +let add_internal_name pt = internal_names := pt :: !internal_names +let is_internal_name s = List.exists (fun p -> p s) !internal_names + +let ssr_id_of_string loc s = + if is_ssr_reserved s && is_ssr_loaded () then begin + if !ssr_reserved_ids then + loc_error loc ("The identifier " ^ s ^ " is reserved.") + else if is_internal_name s then + msg_warning (str ("Conflict between " ^ s ^ " and ssreflect internal names.")) + else msg_warning (str ( + "The name " ^ s ^ " fits the _xxx_ format used for anonymous variables.\n" + ^ "Scripts with explicit references to anonymous variables are fragile.")) + end; id_of_string s + +let ssr_null_entry = Gram.Entry.of_parser "ssr_null" (fun _ -> ()) + +let (!@) = Compat.to_coqloc + +GEXTEND Gram + GLOBAL: Prim.ident; + Prim.ident: [[ s = IDENT; ssr_null_entry -> ssr_id_of_string !@loc s ]]; +END + +let mk_internal_id s = + let s' = sprintf "_%s_" s in + for i = 1 to String.length s do if s'.[i] = ' ' then s'.[i] <- '_' done; + add_internal_name ((=) s'); id_of_string s' + +let same_prefix s t n = + let rec loop i = i = n || s.[i] = t.[i] && loop (i + 1) in loop 0 + +let skip_digits s = + let n = String.length s in + let rec loop i = if i < n && is_digit s.[i] then loop (i + 1) else i in loop + +let mk_tagged_id t i = id_of_string (sprintf "%s%d_" t i) +let is_tagged t s = + let n = String.length s - 1 and m = String.length t in + m < n && s.[n] = '_' && same_prefix s t m && skip_digits s m = n + +let perm_tag = "_perm_Hyp_" +let _ = add_internal_name (is_tagged perm_tag) +let mk_perm_id = + let salt = ref 1 in + fun () -> salt := !salt mod 10000 + 1; mk_tagged_id perm_tag !salt + +let evar_tag = "_evar_" +let _ = add_internal_name (is_tagged evar_tag) +let mk_evar_name n = Name (mk_tagged_id evar_tag n) +let nb_evar_deps = function + | Name id -> + let s = string_of_id id in + if not (is_tagged evar_tag s) then 0 else + let m = String.length evar_tag in + (try int_of_string (String.sub s m (String.length s - 1 - m)) with _ -> 0) + | _ -> 0 + +let discharged_tag = "_discharged_" +let mk_discharged_id id = + id_of_string (sprintf "%s%s_" discharged_tag (string_of_id id)) +let has_discharged_tag s = + let m = String.length discharged_tag and n = String.length s - 1 in + m < n && s.[n] = '_' && same_prefix s discharged_tag m +let _ = add_internal_name has_discharged_tag +let is_discharged_id id = has_discharged_tag (string_of_id id) + +let wildcard_tag = "_the_" +let wildcard_post = "_wildcard_" +let mk_wildcard_id i = + id_of_string (sprintf "%s%s%s" wildcard_tag (String.ordinal i) wildcard_post) +let has_wildcard_tag s = + let n = String.length s in let m = String.length wildcard_tag in + let m' = String.length wildcard_post in + n < m + m' + 2 && same_prefix s wildcard_tag m && + String.sub s (n - m') m' = wildcard_post && + skip_digits s m = n - m' - 2 +let _ = add_internal_name has_wildcard_tag + +let max_suffix m (t, j0 as tj0) id = + let s = string_of_id id in let n = String.length s - 1 in + let dn = String.length t - 1 - n in let i0 = j0 - dn in + if not (i0 >= m && s.[n] = '_' && same_prefix s t m) then tj0 else + let rec loop i = + if i < i0 && s.[i] = '0' then loop (i + 1) else + if (if i < i0 then skip_digits s i = n else le_s_t i) then s, i else tj0 + and le_s_t i = + let ds = s.[i] and dt = t.[i + dn] in + if ds = dt then i = n || le_s_t (i + 1) else + dt < ds && skip_digits s i = n in + loop m + +let mk_anon_id t gl = + let m, si0, id0 = + let s = ref (sprintf "_%s_" t) in + if is_internal_name !s then s := "_" ^ !s; + let n = String.length !s - 1 in + let rec loop i j = + let d = !s.[i] in if not (is_digit d) then i + 1, j else + loop (i - 1) (if d = '0' then j else i) in + let m, j = loop (n - 1) n in m, (!s, j), id_of_string !s in + let gl_ids = pf_ids_of_hyps gl in + if not (List.mem id0 gl_ids) then id0 else + let s, i = List.fold_left (max_suffix m) si0 gl_ids in + let n = String.length s - 1 in + let rec loop i = + if s.[i] = '9' then (s.[i] <- '0'; loop (i - 1)) else + if i < m then (s.[n] <- '0'; s.[m] <- '1'; s ^ "_") else + (s.[i] <- Char.chr (Char.code s.[i] + 1); s) in + id_of_string (loop (n - 1)) + +(* We must not anonymize context names discharged by the "in" tactical. *) + +let ssr_anon_hyp = "Hyp" + +let anontac (x, _, _) gl = + let id = match x with + | Name id -> + if is_discharged_id id then id else mk_anon_id (string_of_id id) gl + | _ -> mk_anon_id ssr_anon_hyp gl in + introid id gl + +let rec constr_name c = match kind_of_term c with + | Var id -> Name id + | Cast (c', _, _) -> constr_name c' + | Const (cn,_) -> Name (id_of_label (con_label cn)) + | App (c', _) -> constr_name c' + | _ -> Anonymous + +(* }}} *) + +(** Open term to lambda-term coercion {{{ ************************************) + +(* This operation takes a goal gl and an open term (sigma, t), and *) +(* returns a term t' where all the new evars in sigma are abstracted *) +(* with the mkAbs argument, i.e., for mkAbs = mkLambda then there is *) +(* some duplicate-free array args of evars of sigma such that the *) +(* term mkApp (t', args) is convertible to t. *) +(* This makes a useful shorthand for local definitions in proofs, *) +(* i.e., pose succ := _ + 1 means pose succ := fun n : nat => n + 1, *) +(* and, in context of the the 4CT library, pose mid := maps id means *) +(* pose mid := fun d : detaSet => @maps d d (@id (datum d)) *) +(* Note that this facility does not extend to set, which tries *) +(* instead to fill holes by matching a goal subterm. *) +(* The argument to "have" et al. uses product abstraction, e.g. *) +(* have Hmid: forall s, (maps id s) = s. *) +(* stands for *) +(* have Hmid: forall (d : dataSet) (s : seq d), (maps id s) = s. *) +(* We also use this feature for rewrite rules, so that, e.g., *) +(* rewrite: (plus_assoc _ 3). *) +(* will execute as *) +(* rewrite (fun n => plus_assoc n 3) *) +(* i.e., it will rewrite some subterm .. + (3 + ..) to .. + 3 + ... *) +(* The convention is also used for the argument of the congr tactic, *) +(* e.g., congr (x + _ * 1). *) + +(* Replace new evars with lambda variables, retaining local dependencies *) +(* but stripping global ones. We use the variable names to encode the *) +(* the number of dependencies, so that the transformation is reversible. *) + +let pf_abs_evars gl (sigma, c0) = + let sigma0, ucst = project gl, Evd.evar_universe_context sigma in + let nenv = env_size (pf_env gl) in + let abs_evar n k = + let evi = Evd.find sigma k in + let dc = List.firstn n (evar_filtered_context evi) in + let abs_dc c = function + | x, Some b, t -> mkNamedLetIn x b t (mkArrow t c) + | x, None, t -> mkNamedProd x t c in + let t = Context.fold_named_context_reverse abs_dc ~init:evi.evar_concl dc in + Evarutil.nf_evar sigma t in + let rec put evlist c = match kind_of_term c with + | Evar (k, a) -> + if List.mem_assoc k evlist || Evd.mem sigma0 k then evlist else + let n = max 0 (Array.length a - nenv) in + let t = abs_evar n k in (k, (n, t)) :: put evlist t + | _ -> fold_constr put evlist c in + let evlist = put [] c0 in + if evlist = [] then 0, c0,[], ucst else + let rec lookup k i = function + | [] -> 0, 0 + | (k', (n, _)) :: evl -> if k = k' then i, n else lookup k (i + 1) evl in + let rec get i c = match kind_of_term c with + | Evar (ev, a) -> + let j, n = lookup ev i evlist in + if j = 0 then map_constr (get i) c else if n = 0 then mkRel j else + mkApp (mkRel j, Array.init n (fun k -> get i a.(n - 1 - k))) + | _ -> map_constr_with_binders ((+) 1) get i c in + let rec loop c i = function + | (_, (n, t)) :: evl -> + loop (mkLambda (mk_evar_name n, get (i - 1) t, c)) (i - 1) evl + | [] -> c in + List.length evlist, loop (get 1 c0) 1 evlist, List.map fst evlist, ucst + + + +(* As before but if (?i : T(?j)) and (?j : P : Prop), then the lambda for i + * looks like (fun evar_i : (forall pi : P. T(pi))) thanks to "loopP" and all + * occurrences of evar_i are replaced by (evar_i evar_j) thanks to "app". + * + * If P can be solved by ssrautoprop (that defaults to trivial), then + * the corresponding lambda looks like (fun evar_i : T(c)) where c is + * the solution found by ssrautoprop. + *) +let ssrautoprop_tac = ref (fun gl -> assert false) + +(* Thanks to Arnaud Spiwack for this snippet *) +let call_on_evar tac e s = + let { it = gs ; sigma = s } = + tac { it = e ; sigma = s; } in + gs, s + +let pf_abs_evars_pirrel gl (sigma, c0) = + pp(lazy(str"==PF_ABS_EVARS_PIRREL==")); + pp(lazy(str"c0= " ++ pr_constr c0)); + let sigma0 = project gl in + let c0 = Evarutil.nf_evar sigma0 (Evarutil.nf_evar sigma c0) in + let nenv = env_size (pf_env gl) in + let abs_evar n k = + let evi = Evd.find sigma k in + let dc = List.firstn n (evar_filtered_context evi) in + let abs_dc c = function + | x, Some b, t -> mkNamedLetIn x b t (mkArrow t c) + | x, None, t -> mkNamedProd x t c in + let t = Context.fold_named_context_reverse abs_dc ~init:evi.evar_concl dc in + Evarutil.nf_evar sigma0 (Evarutil.nf_evar sigma t) in + let rec put evlist c = match kind_of_term c with + | Evar (k, a) -> + if List.mem_assoc k evlist || Evd.mem sigma0 k then evlist else + let n = max 0 (Array.length a - nenv) in + let k_ty = + Retyping.get_sort_family_of + (pf_env gl) sigma (Evd.evar_concl (Evd.find sigma k)) in + let is_prop = k_ty = InProp in + let t = abs_evar n k in (k, (n, t, is_prop)) :: put evlist t + | _ -> fold_constr put evlist c in + let evlist = put [] c0 in + if evlist = [] then 0, c0 else + let pr_constr t = pr_constr (Reductionops.nf_beta (project gl) t) in + pp(lazy(str"evlist=" ++ pr_list (fun () -> str";") + (fun (k,_) -> str(Evd.string_of_existential k)) evlist)); + let evplist = + let depev = List.fold_left (fun evs (_,(_,t,_)) -> + Intset.union evs (Evarutil.undefined_evars_of_term sigma t)) Intset.empty evlist in + List.filter (fun i,(_,_,b) -> b && Intset.mem i depev) evlist in + let evlist, evplist, sigma = + if evplist = [] then evlist, [], sigma else + List.fold_left (fun (ev, evp, sigma) (i, (_,t,_) as p) -> + try + let ng, sigma = call_on_evar !ssrautoprop_tac i sigma in + if (ng <> []) then errorstrm (str "Should we tell the user?"); + List.filter (fun (j,_) -> j <> i) ev, evp, sigma + with _ -> ev, p::evp, sigma) (evlist, [], sigma) (List.rev evplist) in + let c0 = Evarutil.nf_evar sigma c0 in + let evlist = + List.map (fun (x,(y,t,z)) -> x,(y,Evarutil.nf_evar sigma t,z)) evlist in + let evplist = + List.map (fun (x,(y,t,z)) -> x,(y,Evarutil.nf_evar sigma t,z)) evplist in + pp(lazy(str"c0= " ++ pr_constr c0)); + let rec lookup k i = function + | [] -> 0, 0 + | (k', (n,_,_)) :: evl -> if k = k' then i,n else lookup k (i + 1) evl in + let rec get evlist i c = match kind_of_term c with + | Evar (ev, a) -> + let j, n = lookup ev i evlist in + if j = 0 then map_constr (get evlist i) c else if n = 0 then mkRel j else + mkApp (mkRel j, Array.init n (fun k -> get evlist i a.(n - 1 - k))) + | _ -> map_constr_with_binders ((+) 1) (get evlist) i c in + let rec app extra_args i c = match decompose_app c with + | hd, args when isRel hd && destRel hd = i -> + let j = destRel hd in + mkApp (mkRel j, Array.of_list (List.map (lift (i-1)) extra_args @ args)) + | _ -> map_constr_with_binders ((+) 1) (app extra_args) i c in + let rec loopP evlist c i = function + | (_, (n, t, _)) :: evl -> + let t = get evlist (i - 1) t in + let n = Name (id_of_string (ssr_anon_hyp ^ string_of_int n)) in + loopP evlist (mkProd (n, t, c)) (i - 1) evl + | [] -> c in + let rec loop c i = function + | (_, (n, t, _)) :: evl -> + let evs = Evarutil.undefined_evars_of_term sigma t in + let t_evplist = List.filter (fun (k,_) -> Intset.mem k evs) evplist in + let t = loopP t_evplist (get t_evplist 1 t) 1 t_evplist in + let t = get evlist (i - 1) t in + let extra_args = + List.map (fun (k,_) -> mkRel (fst (lookup k i evlist))) + (List.rev t_evplist) in + let c = if extra_args = [] then c else app extra_args 1 c in + loop (mkLambda (mk_evar_name n, t, c)) (i - 1) evl + | [] -> c in + let res = loop (get evlist 1 c0) 1 evlist in + pp(lazy(str"res= " ++ pr_constr res)); + List.length evlist, res + +(* Strip all non-essential dependencies from an abstracted term, generating *) +(* standard names for the abstracted holes. *) + +let pf_abs_cterm gl n c0 = + if n <= 0 then c0 else + let noargs = [|0|] in + let eva = Array.make n noargs in + let rec strip i c = match kind_of_term c with + | App (f, a) when isRel f -> + let j = i - destRel f in + if j >= n || eva.(j) = noargs then mkApp (f, Array.map (strip i) a) else + let dp = eva.(j) in + let nd = Array.length dp - 1 in + let mkarg k = strip i a.(if k < nd then dp.(k + 1) - j else k + dp.(0)) in + mkApp (f, Array.init (Array.length a - dp.(0)) mkarg) + | _ -> map_constr_with_binders ((+) 1) strip i c in + let rec strip_ndeps j i c = match kind_of_term c with + | Prod (x, t, c1) when i < j -> + let dl, c2 = strip_ndeps j (i + 1) c1 in + if noccurn 1 c2 then dl, lift (-1) c2 else + i :: dl, mkProd (x, strip i t, c2) + | LetIn (x, b, t, c1) when i < j -> + let _, _, c1' = destProd c1 in + let dl, c2 = strip_ndeps j (i + 1) c1' in + if noccurn 1 c2 then dl, lift (-1) c2 else + i :: dl, mkLetIn (x, strip i b, strip i t, c2) + | _ -> [], strip i c in + let rec strip_evars i c = match kind_of_term c with + | Lambda (x, t1, c1) when i < n -> + let na = nb_evar_deps x in + let dl, t2 = strip_ndeps (i + na) i t1 in + let na' = List.length dl in + eva.(i) <- Array.of_list (na - na' :: dl); + let x' = + if na' = 0 then Name (pf_type_id gl t2) else mk_evar_name na' in + mkLambda (x', t2, strip_evars (i + 1) c1) +(* if noccurn 1 c2 then lift (-1) c2 else + mkLambda (Name (pf_type_id gl t2), t2, c2) *) + | _ -> strip i c in + strip_evars 0 c0 + +(* Undo the evar abstractions. Also works for non-evar variables. *) + +let pf_unabs_evars gl ise n c0 = + if n = 0 then c0 else + let evv = Array.make n mkProp in + let nev = ref 0 in + let env0 = pf_env gl in + let nenv0 = env_size env0 in + let rec unabs i c = match kind_of_term c with + | Rel j when i - j < !nev -> evv.(i - j) + | App (f, a0) when isRel f -> + let a = Array.map (unabs i) a0 in + let j = i - destRel f in + if j >= !nev then mkApp (f, a) else + let ev, eva = destEvar evv.(j) in + let nd = Array.length eva - nenv0 in + if nd = 0 then mkApp (evv.(j), a) else + let evarg k = if k < nd then a.(nd - 1 - k) else eva.(k) in + let c' = mkEvar (ev, Array.init (nd + nenv0) evarg) in + let na = Array.length a - nd in + if na = 0 then c' else mkApp (c', Array.sub a nd na) + | _ -> map_constr_with_binders ((+) 1) unabs i c in + let push_rel = Environ.push_rel in + let rec mk_evar j env i c = match kind_of_term c with + | Prod (x, t, c1) when i < j -> + mk_evar j (push_rel (x, None, unabs i t) env) (i + 1) c1 + | LetIn (x, b, t, c1) when i < j -> + let _, _, c2 = destProd c1 in + mk_evar j (push_rel (x, Some (unabs i b), unabs i t) env) (i + 1) c2 + | _ -> Evarutil.e_new_evar env ise (unabs i c) in + let rec unabs_evars c = + if !nev = n then unabs n c else match kind_of_term c with + | Lambda (x, t, c1) when !nev < n -> + let i = !nev in + evv.(i) <- mk_evar (i + nb_evar_deps x) env0 i t; + incr nev; unabs_evars c1 + | _ -> unabs !nev c in + unabs_evars c0 + +(* }}} *) + +(** Tactical extensions. {{{ **************************************************) + +(* The TACTIC EXTEND facility can't be used for defining new user *) +(* tacticals, because: *) +(* - the concrete syntax must start with a fixed string *) +(* We use the following workaround: *) +(* - We use the (unparsable) "YouShouldNotTypeThis" token for tacticals that *) +(* don't start with a token, then redefine the grammar and *) +(* printer using GEXTEND and set_pr_ssrtac, respectively. *) + +type ssrargfmt = ArgSsr of string | ArgCoq of argument_type | ArgSep of string + +let ssrtac_name name = { + mltac_plugin = "ssreflect"; + mltac_tactic = "ssr" ^ name; +} + +let set_pr_ssrtac name prec afmt = + let fmt = List.map (function ArgSep s -> Some s | _ -> None) afmt in + let rec mk_akey = function + | ArgSsr s :: afmt' -> ExtraArgType ("ssr" ^ s) :: mk_akey afmt' + | ArgCoq a :: afmt' -> a :: mk_akey afmt' + | ArgSep _ :: afmt' -> mk_akey afmt' + | [] -> [] in + let tacname = ssrtac_name name in + Pptactic.declare_ml_tactic_pprule tacname + { Pptactic.pptac_args = mk_akey afmt; + Pptactic.pptac_prods = (prec, fmt) } + +let ssrtac_atom loc name args = TacML (loc, ssrtac_name name, args) +let ssrtac_expr = ssrtac_atom + + +let ssrevaltac ist gtac = + let debug = match TacStore.get ist.extra f_debug with + | None -> Tactic_debug.DebugOff | Some level -> level + in + Proofview.V82.of_tactic (interp_tac_gen ist.lfun [] debug (globTacticIn (fun _ -> gtac))) + +(* fun gl -> let lfun = [tacarg_id, val_interp ist gl gtac] in + interp_tac_gen lfun [] ist.debug tacarg_expr gl *) + +(** Generic argument-based globbing/typing utilities *) + + +let interp_wit wit ist gl x = + let globarg = in_gen (glbwit wit) x in + let sigma, arg = interp_genarg ist (pf_env gl) (project gl) (pf_concl gl) gl.Evd.it globarg in + sigma, out_gen (topwit wit) arg + +let interp_intro_pattern = interp_wit wit_intro_pattern + +let interp_constr = interp_wit wit_constr + +let interp_open_constr ist gl gc = + interp_wit wit_open_constr ist gl ((), gc) + +let interp_refine ist gl rc = + let constrvars = extract_ltac_constr_values ist (pf_env gl) in + let vars = { Pretyping.empty_lvar with + Pretyping.ltac_constrs = constrvars; ltac_genargs = ist.lfun + } in + let kind = OfType (pf_concl gl) in + let flags = { + use_typeclasses = true; + use_unif_heuristics = true; + use_hook = None; + fail_evar = false; + expand_evars = true } + in + let sigma, c = understand_ltac flags (pf_env gl) (project gl) vars kind rc in +(* pp(lazy(str"sigma@interp_refine=" ++ pr_evar_map None sigma)); *) + pp(lazy(str"c@interp_refine=" ++ pr_constr c)); + (sigma, (sigma, c)) + +let pf_match = pf_apply (fun e s c t -> understand_tcc e s ~expected_type:t c) + +(* Estimate a bound on the number of arguments of a raw constr. *) +(* This is not perfect, because the unifier may fail to *) +(* typecheck the partial application, so we use a minimum of 5. *) +(* Also, we don't handle delayed or iterated coercions to *) +(* FUNCLASS, which is probably just as well since these can *) +(* lead to infinite arities. *) + +let splay_open_constr gl (sigma, c) = + let env = pf_env gl in let t = Retyping.get_type_of env sigma c in + Reductionops.splay_prod env sigma t + +let nbargs_open_constr gl oc = + let pl, _ = splay_open_constr gl oc in List.length pl + +let interp_nbargs ist gl rc = + try + let rc6 = mkRApp rc (mkRHoles 6) in + let sigma, t = interp_open_constr ist gl (rc6, None) in + let si = sig_it gl in + let gl = re_sig si sigma in + 6 + nbargs_open_constr gl t + with _ -> 5 + +let pf_nbargs gl c = nbargs_open_constr gl (project gl, c) + +let isAppInd gl c = + try ignore (pf_reduce_to_atomic_ind gl c); true with _ -> false + +let interp_view_nbimps ist gl rc = + try + let sigma, t = interp_open_constr ist gl (rc, None) in + let si = sig_it gl in + let gl = re_sig si sigma in + let pl, c = splay_open_constr gl t in + if isAppInd gl c then List.length pl else ~-(List.length pl) + with _ -> 0 + +(* }}} *) + +(** Vernacular commands: Prenex Implicits and Search {{{ **********************) + +(* This should really be implemented as an extension to the implicit *) +(* arguments feature, but unfortuately that API is sealed. The current *) +(* workaround uses a combination of notations that works reasonably, *) +(* with the following caveats: *) +(* - The pretty-printing always elides prenex implicits, even when *) +(* they are obviously needed. *) +(* - Prenex Implicits are NEVER exported from a module, because this *) +(* would lead to faulty pretty-printing and scoping errors. *) +(* - The command "Import Prenex Implicits" can be used to reassert *) +(* Prenex Implicits for all the visible constants that had been *) +(* declared as Prenex Implicits. *) + +let declare_one_prenex_implicit locality f = + let fref = + try Smartlocate.global_with_alias f + with _ -> errorstrm (pr_reference f ++ str " is not declared") in + let rec loop = function + | a :: args' when Impargs.is_status_implicit a -> + (ExplByName (Impargs.name_of_implicit a), (true, true, true)) :: loop args' + | args' when List.exists Impargs.is_status_implicit args' -> + errorstrm (str "Expected prenex implicits for " ++ pr_reference f) + | _ -> [] in + let impls = + match Impargs.implicits_of_global fref with + | [cond,impls] -> impls + | [] -> errorstrm (str "Expected some implicits for " ++ pr_reference f) + | _ -> errorstrm (str "Multiple implicits not supported") in + match loop impls with + | [] -> + errorstrm (str "Expected some implicits for " ++ pr_reference f) + | impls -> + Impargs.declare_manual_implicits locality fref ~enriching:false [impls] + +VERNAC COMMAND EXTEND Ssrpreneximplicits CLASSIFIED AS SIDEFF + | [ "Prenex" "Implicits" ne_global_list(fl) ] + -> [ let locality = + Locality.make_section_locality (Locality.LocalityFixme.consume ()) in + List.iter (declare_one_prenex_implicit locality) fl ] +END + +(* Vernac grammar visibility patch *) + +GEXTEND Gram + GLOBAL: gallina_ext; + gallina_ext: + [ [ IDENT "Import"; IDENT "Prenex"; IDENT "Implicits" -> + Vernacexpr.VernacUnsetOption (["Printing"; "Implicit"; "Defensive"]) + ] ] + ; +END + +(** Extend Search to subsume SearchAbout, also adding hidden Type coercions. *) + +(* Main prefilter *) + +type raw_glob_search_about_item = + | RGlobSearchSubPattern of constr_expr + | RGlobSearchString of Loc.t * string * string option + +let pr_search_item = function + | RGlobSearchString (_,s,_) -> str s + | RGlobSearchSubPattern p -> pr_constr_expr p + +let wit_ssr_searchitem = add_genarg "ssr_searchitem" pr_search_item + +let interp_search_notation loc s opt_scope = + try + let interp = Notation.interp_notation_as_global_reference loc in + let ref = interp (fun _ -> true) s opt_scope in + Search.GlobSearchSubPattern (Pattern.PRef ref) + with _ -> + let diagnosis = + try + let ntns = Notation.locate_notation pr_glob_constr s opt_scope in + let ambig = "This string refers to a complex or ambiguous notation." in + str ambig ++ str "\nTry searching with one of\n" ++ ntns + with _ -> str "This string is not part of an identifier or notation." in + Errors.user_err_loc (loc, "interp_search_notation", diagnosis) + +let pr_ssr_search_item _ _ _ = pr_search_item + +(* Workaround the notation API that can only print notations *) + +let is_ident s = try Lexer.check_ident s; true with _ -> false + +let is_ident_part s = is_ident ("H" ^ s) + +let interp_search_notation loc tag okey = + let err msg = Errors.user_err_loc (loc, "interp_search_notation", msg) in + let mk_pntn s for_key = + let n = String.length s in + let s' = String.make (n + 2) ' ' in + let rec loop i i' = + if i >= n then s', i' - 2 else if s.[i] = ' ' then loop (i + 1) i' else + let j = try String.index_from s (i + 1) ' ' with _ -> n in + let m = j - i in + if s.[i] = '\'' && i < j - 2 && s.[j - 1] = '\'' then + (String.blit s (i + 1) s' i' (m - 2); loop (j + 1) (i' + m - 1)) + else if for_key && is_ident (String.sub s i m) then + (s'.[i'] <- '_'; loop (j + 1) (i' + 2)) + else (String.blit s i s' i' m; loop (j + 1) (i' + m + 1)) in + loop 0 1 in + let trim_ntn (pntn, m) = String.sub pntn 1 (max 0 m) in + let pr_ntn ntn = str "(" ++ str ntn ++ str ")" in + let pr_and_list pr = function + | [x] -> pr x + | x :: lx -> pr_list pr_comma pr lx ++ pr_comma () ++ str "and " ++ pr x + | [] -> mt () in + let pr_sc sc = str (if sc = "" then "independently" else sc) in + let pr_scs = function + | [""] -> pr_sc "" + | scs -> str "in " ++ pr_and_list pr_sc scs in + let generator, pr_tag_sc = + let ign _ = mt () in match okey with + | Some key -> + let sc = Notation.find_delimiters_scope loc key in + let pr_sc s_in = str s_in ++ spc() ++ str sc ++ pr_comma() in + Notation.pr_scope ign sc, pr_sc + | None -> Notation.pr_scopes ign, ign in + let qtag s_in = pr_tag_sc s_in ++ qstring tag ++ spc()in + let ptag, ttag = + let ptag, m = mk_pntn tag false in + if m <= 0 then err (str "empty notation fragment"); + ptag, trim_ntn (ptag, m) in + let last = ref "" and last_sc = ref "" in + let scs = ref [] and ntns = ref [] in + let push_sc sc = match !scs with + | "" :: scs' -> scs := "" :: sc :: scs' + | scs' -> scs := sc :: scs' in + let get s _ _ = match !last with + | "Scope " -> last_sc := s; last := "" + | "Lonely notation" -> last_sc := ""; last := "" + | "\"" -> + let pntn, m = mk_pntn s true in + if String.string_contains pntn ptag then begin + let ntn = trim_ntn (pntn, m) in + match !ntns with + | [] -> ntns := [ntn]; scs := [!last_sc] + | ntn' :: _ when ntn' = ntn -> push_sc !last_sc + | _ when ntn = ttag -> ntns := ntn :: !ntns; scs := [!last_sc] + | _ :: ntns' when List.mem ntn ntns' -> () + | ntn' :: ntns' -> ntns := ntn' :: ntn :: ntns' + end; + last := "" + | _ -> last := s in + pp_with (Format.make_formatter get (fun _ -> ())) generator; + let ntn = match !ntns with + | [] -> + err (hov 0 (qtag "in" ++ str "does not occur in any notation")) + | ntn :: ntns' when ntn = ttag -> + if ntns' <> [] then begin + let pr_ntns' = pr_and_list pr_ntn ntns' in + msg_warning (hov 4 (qtag "In" ++ str "also occurs in " ++ pr_ntns')) + end; ntn + | [ntn] -> + msgnl (hov 4 (qtag "In" ++ str "is part of notation " ++ pr_ntn ntn)); ntn + | ntns' -> + let e = str "occurs in" ++ spc() ++ pr_and_list pr_ntn ntns' in + err (hov 4 (str "ambiguous: " ++ qtag "in" ++ e)) in + let (nvars, body), ((_, pat), osc) = match !scs with + | [sc] -> Notation.interp_notation loc ntn (None, [sc]) + | scs' -> + try Notation.interp_notation loc ntn (None, []) with _ -> + let e = pr_ntn ntn ++ spc() ++ str "is defined " ++ pr_scs scs' in + err (hov 4 (str "ambiguous: " ++ pr_tag_sc "in" ++ e)) in + let sc = Option.default "" osc in + let _ = + let m_sc = + if osc <> None then str "In " ++ str sc ++ pr_comma() else mt() in + let ntn_pat = trim_ntn (mk_pntn pat false) in + let rbody = glob_constr_of_notation_constr loc body in + let m_body = hov 0 (Constrextern.without_symbols prl_glob_constr rbody) in + let m = m_sc ++ pr_ntn ntn_pat ++ spc () ++ str "denotes " ++ m_body in + msgnl (hov 0 m) in + if List.length !scs > 1 then + let scs' = List.remove (=) sc !scs in + let w = pr_ntn ntn ++ str " is also defined " ++ pr_scs scs' in + msg_warning (hov 4 w) + else if String.string_contains ntn " .. " then + err (pr_ntn ntn ++ str " is an n-ary notation"); + let nvars = List.filter (fun (_,(_,typ)) -> typ = NtnTypeConstr) nvars in + let rec sub () = function + | NVar x when List.mem_assoc x nvars -> GPatVar (loc, (false, x)) + | c -> + glob_constr_of_notation_constr_with_binders loc (fun _ x -> (), x) sub () c in + let _, npat = Patternops.pattern_of_glob_constr (sub () body) in + Search.GlobSearchSubPattern npat + +ARGUMENT EXTEND ssr_search_item TYPED AS ssr_searchitem + PRINTED BY pr_ssr_search_item + | [ string(s) ] -> [ RGlobSearchString (loc,s,None) ] + | [ string(s) "%" preident(key) ] -> [ RGlobSearchString (loc,s,Some key) ] + | [ constr_pattern(p) ] -> [ RGlobSearchSubPattern p ] +END + +let pr_ssr_search_arg _ _ _ = + let pr_item (b, p) = str (if b then "-" else "") ++ pr_search_item p in + pr_list spc pr_item + +ARGUMENT EXTEND ssr_search_arg TYPED AS (bool * ssr_searchitem) list + PRINTED BY pr_ssr_search_arg + | [ "-" ssr_search_item(p) ssr_search_arg(a) ] -> [ (false, p) :: a ] + | [ ssr_search_item(p) ssr_search_arg(a) ] -> [ (true, p) :: a ] + | [ ] -> [ [] ] +END + +(* Main type conclusion pattern filter *) + +let rec splay_search_pattern na = function + | Pattern.PApp (fp, args) -> splay_search_pattern (na + Array.length args) fp + | Pattern.PLetIn (_, _, bp) -> splay_search_pattern na bp + | Pattern.PRef hr -> hr, na + | _ -> Errors.error "no head constant in head search pattern" + +let coerce_search_pattern_to_sort hpat = + let env = Global.env () and sigma = Evd.empty in + let mkPApp fp n_imps args = + let args' = Array.append (Array.make n_imps (Pattern.PMeta None)) args in + Pattern.PApp (fp, args') in + let hr, na = splay_search_pattern 0 hpat in + let dc, ht = + Reductionops.splay_prod env sigma (Universes.unsafe_type_of_global hr) in + let np = List.length dc in + if np < na then Errors.error "too many arguments in head search pattern" else + let hpat' = if np = na then hpat else mkPApp hpat (np - na) [||] in + let warn () = + msg_warning (str "Listing only lemmas with conclusion matching " ++ + pr_constr_pattern hpat') in + if isSort ht then begin warn (); true, hpat' end else + let filter_head, coe_path = + try + let _, cp = + Classops.lookup_path_to_sort_from (push_rels_assum dc env) sigma ht in + warn (); + true, cp + with _ -> false, [] in + let coerce hp coe_index = + let coe = Classops.get_coercion_value coe_index in + try + let coe_ref = reference_of_constr coe in + let n_imps = Option.get (Classops.hide_coercion coe_ref) in + mkPApp (Pattern.PRef coe_ref) n_imps [|hp|] + with _ -> + errorstrm (str "need explicit coercion " ++ pr_constr coe ++ spc () + ++ str "to interpret head search pattern as type") in + filter_head, List.fold_left coerce hpat' coe_path + +let rec interp_head_pat hpat = + let filter_head, p = coerce_search_pattern_to_sort hpat in + let rec loop c = match kind_of_term c with + | Cast (c', _, _) -> loop c' + | Prod (_, _, c') -> loop c' + | LetIn (_, _, _, c') -> loop c' + | _ -> Constr_matching.is_matching (Global.env()) Evd.empty p c in + filter_head, loop + +let all_true _ = true + +let rec interp_search_about args accu = match args with +| [] -> accu +| (flag, arg) :: rem -> + fun gr env typ -> + let ans = Search.search_about_filter arg gr env typ in + (if flag then ans else not ans) && interp_search_about rem accu gr env typ + +let interp_search_arg arg = + let arg = List.map (fun (x,arg) -> x, match arg with + | RGlobSearchString (loc,s,key) -> + if is_ident_part s then Search.GlobSearchString s else + interp_search_notation loc s key + | RGlobSearchSubPattern p -> + try + let intern = Constrintern.intern_constr_pattern in + Search.GlobSearchSubPattern (snd (intern (Global.env()) p)) + with e -> let e = Errors.push e in iraise (Cerrors.process_vernac_interp_error e)) arg in + let hpat, a1 = match arg with + | (_, Search.GlobSearchSubPattern (Pattern.PMeta _)) :: a' -> all_true, a' + | (true, Search.GlobSearchSubPattern p) :: a' -> + let filter_head, p = interp_head_pat p in + if filter_head then p, a' else all_true, arg + | _ -> all_true, arg in + let is_string = + function (_, Search.GlobSearchString _) -> true | _ -> false in + let a2, a3 = List.partition is_string a1 in + interp_search_about (a2 @ a3) (fun gr env typ -> hpat typ) + +(* Module path postfilter *) + +let pr_modloc (b, m) = if b then str "-" ++ pr_reference m else pr_reference m + +let wit_ssrmodloc = add_genarg "ssrmodloc" pr_modloc + +let pr_ssr_modlocs _ _ _ ml = + if ml = [] then str "" else spc () ++ str "in " ++ pr_list spc pr_modloc ml + +ARGUMENT EXTEND ssr_modlocs TYPED AS ssrmodloc list PRINTED BY pr_ssr_modlocs + | [ ] -> [ [] ] +END + +GEXTEND Gram + GLOBAL: ssr_modlocs; + modloc: [[ "-"; m = global -> true, m | m = global -> false, m]]; + ssr_modlocs: [[ "in"; ml = LIST1 modloc -> ml ]]; +END + +let interp_modloc mr = + let interp_mod (_, mr) = + let (loc, qid) = qualid_of_reference mr in + try Nametab.full_name_module qid with Not_found -> + Errors.user_err_loc (loc, "interp_modloc", str "No Module " ++ pr_qualid qid) in + let mr_out, mr_in = List.partition fst mr in + let interp_bmod b = function + | [] -> fun _ _ _ -> true + | rmods -> Search.module_filter (List.map interp_mod rmods, b) in + let is_in = interp_bmod false mr_in and is_out = interp_bmod true mr_out in + fun gr env typ -> is_in gr env typ && is_out gr env typ + +(* The unified, extended vernacular "Search" command *) + +let ssrdisplaysearch gr env t = + let pr_res = pr_global gr ++ spc () ++ str " " ++ pr_lconstr_env env Evd.empty t in + msg (hov 2 pr_res ++ fnl ()) + +VERNAC COMMAND EXTEND SsrSearchPattern CLASSIFIED AS QUERY +| [ "Search" ssr_search_arg(a) ssr_modlocs(mr) ] -> + [ let hpat = interp_search_arg a in + let in_mod = interp_modloc mr in + let post_filter gr env typ = in_mod gr env typ && hpat gr env typ in + let display gr env typ = + if post_filter gr env typ then ssrdisplaysearch gr env typ + in + Search.generic_search None display ] +END + +(* }}} *) + +(** Alternative notations for "match" and anonymous arguments. {{{ ************) + +(* Syntax: *) +(* if is then ... else ... *) +(* if is [in ..] return ... then ... else ... *) +(* let: := in ... *) +(* let: [in ...] := return ... in ... *) +(* The scope of a top-level 'as' in the pattern extends over the *) +(* 'return' type (dependent if/let). *) +(* Note that the optional "in ..." appears next to the *) +(* rather than the in then "let:" syntax. The alternative *) +(* would lead to ambiguities in, e.g., *) +(* let: p1 := (*v---INNER LET:---v *) *) +(* let: p2 := let: p3 := e3 in k return t in k2 in k1 return t' *) +(* in b (*^--ALTERNATIVE INNER LET--------^ *) *) + +(* Caveat : There is no pretty-printing support, since this would *) +(* require a modification to the Coq kernel (adding a new match *) +(* display style -- why aren't these strings?); also, the v8.1 *) +(* pretty-printer only allows extension hooks for printing *) +(* integer or string literals. *) +(* Also note that in the v8 grammar "is" needs to be a keyword; *) +(* as this can't be done from an ML extension file, the new *) +(* syntax will only work when ssreflect.v is imported. *) + +let no_ct = None, None and no_rt = None in +let aliasvar = function + | [_, [CPatAlias (loc, _, id)]] -> Some (loc,Name id) + | _ -> None in +let mk_cnotype mp = aliasvar mp, None in +let mk_ctype mp t = aliasvar mp, Some t in +let mk_rtype t = Some t in +let mk_dthen loc (mp, ct, rt) c = (loc, mp, c), ct, rt in +let mk_let loc rt ct mp c1 = + CCases (loc, LetPatternStyle, rt, ct, [loc, mp, c1]) in +GEXTEND Gram + GLOBAL: binder_constr; + ssr_rtype: [[ "return"; t = operconstr LEVEL "100" -> mk_rtype t ]]; + ssr_mpat: [[ p = pattern -> [!@loc, [p]] ]]; + ssr_dpat: [ + [ mp = ssr_mpat; "in"; t = pattern; rt = ssr_rtype -> mp, mk_ctype mp t, rt + | mp = ssr_mpat; rt = ssr_rtype -> mp, mk_cnotype mp, rt + | mp = ssr_mpat -> mp, no_ct, no_rt + ] ]; + ssr_dthen: [[ dp = ssr_dpat; "then"; c = lconstr -> mk_dthen !@loc dp c ]]; + ssr_elsepat: [[ "else" -> [!@loc, [CPatAtom (!@loc, None)]] ]]; + ssr_else: [[ mp = ssr_elsepat; c = lconstr -> !@loc, mp, c ]]; + binder_constr: [ + [ "if"; c = operconstr LEVEL "200"; "is"; db1 = ssr_dthen; b2 = ssr_else -> + let b1, ct, rt = db1 in CCases (!@loc, MatchStyle, rt, [c, ct], [b1; b2]) + | "if"; c = operconstr LEVEL "200";"isn't";db1 = ssr_dthen; b2 = ssr_else -> + let b1, ct, rt = db1 in + let b1, b2 = + let (l1, p1, r1), (l2, p2, r2) = b1, b2 in (l1, p1, r2), (l2, p2, r1) in + CCases (!@loc, MatchStyle, rt, [c, ct], [b1; b2]) + | "let"; ":"; mp = ssr_mpat; ":="; c = lconstr; "in"; c1 = lconstr -> + mk_let (!@loc) no_rt [c, no_ct] mp c1 + | "let"; ":"; mp = ssr_mpat; ":="; c = lconstr; + rt = ssr_rtype; "in"; c1 = lconstr -> + mk_let (!@loc) rt [c, mk_cnotype mp] mp c1 + | "let"; ":"; mp = ssr_mpat; "in"; t = pattern; ":="; c = lconstr; + rt = ssr_rtype; "in"; c1 = lconstr -> + mk_let (!@loc) rt [c, mk_ctype mp t] mp c1 + ] ]; +END + +GEXTEND Gram + GLOBAL: closed_binder; + closed_binder: [ + [ ["of" | "&"]; c = operconstr LEVEL "99" -> + [LocalRawAssum ([!@loc, Anonymous], Default Explicit, c)] + ] ]; +END +(* }}} *) + +(** Tacticals (+, -, *, done, by, do, =>, first, and last). {{{ ***************) + +(** Bracketing tactical *) + +(* The tactic pretty-printer doesn't know that some extended tactics *) +(* are actually tacticals. To prevent it from improperly removing *) +(* parentheses we override the parsing rule for bracketed tactic *) +(* expressions so that the pretty-print always reflects the input. *) +(* (Removing user-specified parentheses is dubious anyway). *) + +GEXTEND Gram + GLOBAL: tactic_expr; + ssrparentacarg: [[ "("; tac = tactic_expr; ")" -> !@loc, Tacexp tac ]]; + tactic_expr: LEVEL "0" [[ arg = ssrparentacarg -> TacArg arg ]]; +END + +(** The internal "done" and "ssrautoprop" tactics. *) + +(* For additional flexibility, "done" and "ssrautoprop" are *) +(* defined in Ltac. *) +(* Although we provide a default definition in ssreflect, *) +(* we look up the definition dynamically at each call point, *) +(* to allow for user extensions. "ssrautoprop" defaults to *) +(* trivial. *) + +let donetac gl = + let tacname = + try Nametab.locate_tactic (qualid_of_ident (id_of_string "done")) + with Not_found -> try Nametab.locate_tactic (ssrqid "done") + with Not_found -> Errors.error "The ssreflect library was not loaded" in + let tacexpr = dummy_loc, Tacexpr.Reference (ArgArg (dummy_loc, tacname)) in + Proofview.V82.of_tactic (eval_tactic (Tacexpr.TacArg tacexpr)) gl + +let prof_donetac = mk_profiler "donetac";; +let donetac gl = prof_donetac.profile donetac gl;; + +let ssrautoprop gl = + try + let tacname = + try Nametab.locate_tactic (qualid_of_ident (id_of_string "ssrautoprop")) + with Not_found -> Nametab.locate_tactic (ssrqid "ssrautoprop") in + let tacexpr = dummy_loc, Tacexpr.Reference (ArgArg (dummy_loc, tacname)) in + Proofview.V82.of_tactic (eval_tactic (Tacexpr.TacArg tacexpr)) gl + with Not_found -> Proofview.V82.of_tactic (Auto.full_trivial []) gl + +let () = ssrautoprop_tac := ssrautoprop + +let tclBY tac = tclTHEN tac donetac + +(** Tactical arguments. *) + +(* We have four kinds: simple tactics, [|]-bracketed lists, hints, and swaps *) +(* The latter two are used in forward-chaining tactics (have, suffice, wlog) *) +(* and subgoal reordering tacticals (; first & ; last), respectively. *) + +(* Force use of the tactic_expr parsing entry, to rule out tick marks. *) +let pr_ssrtacarg _ _ prt = prt tacltop +ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY pr_ssrtacarg +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END +GEXTEND Gram + GLOBAL: ssrtacarg; + ssrtacarg: [[ tac = tactic_expr LEVEL "5" -> tac ]]; +END + +(* Lexically closed tactic for tacticals. *) +let pr_ssrtclarg _ _ prt tac = prt tacltop tac +ARGUMENT EXTEND ssrtclarg TYPED AS ssrtacarg + PRINTED BY pr_ssrtclarg +| [ ssrtacarg(tac) ] -> [ tac ] +END +let eval_tclarg ist tac = ssrevaltac ist tac + +let pr_ortacs prt = + let rec pr_rec = function + | [None] -> spc() ++ str "|" ++ spc() + | None :: tacs -> spc() ++ str "|" ++ pr_rec tacs + | Some tac :: tacs -> spc() ++ str "| " ++ prt tacltop tac ++ pr_rec tacs + | [] -> mt() in + function + | [None] -> spc() + | None :: tacs -> pr_rec tacs + | Some tac :: tacs -> prt tacltop tac ++ pr_rec tacs + | [] -> mt() +let pr_ssrortacs _ _ = pr_ortacs + +ARGUMENT EXTEND ssrortacs TYPED AS tactic option list PRINTED BY pr_ssrortacs +| [ ssrtacarg(tac) "|" ssrortacs(tacs) ] -> [ Some tac :: tacs ] +| [ ssrtacarg(tac) "|" ] -> [ [Some tac; None] ] +| [ ssrtacarg(tac) ] -> [ [Some tac] ] +| [ "|" ssrortacs(tacs) ] -> [ None :: tacs ] +| [ "|" ] -> [ [None; None] ] +END + +let pr_hintarg prt = function + | true, tacs -> hv 0 (str "[ " ++ pr_ortacs prt tacs ++ str " ]") + | false, [Some tac] -> prt tacltop tac + | _, _ -> mt() + +let pr_ssrhintarg _ _ = pr_hintarg + +let mk_hint tac = false, [Some tac] +let mk_orhint tacs = true, tacs +let nullhint = true, [] +let nohint = false, [] + +ARGUMENT EXTEND ssrhintarg TYPED AS bool * ssrortacs PRINTED BY pr_ssrhintarg +| [ "[" "]" ] -> [ nullhint ] +| [ "[" ssrortacs(tacs) "]" ] -> [ mk_orhint tacs ] +| [ ssrtacarg(arg) ] -> [ mk_hint arg ] +END + +ARGUMENT EXTEND ssrortacarg TYPED AS ssrhintarg PRINTED BY pr_ssrhintarg +| [ "[" ssrortacs(tacs) "]" ] -> [ mk_orhint tacs ] +END + +let hinttac ist is_by (is_or, atacs) = + let dtac = if is_by then donetac else tclIDTAC in + let mktac = function + | Some atac -> tclTHEN (ssrevaltac ist atac) dtac + | _ -> dtac in + match List.map mktac atacs with + | [] -> if is_or then dtac else tclIDTAC + | [tac] -> tac + | tacs -> tclFIRST tacs + +(** The "-"/"+"/"*" tacticals. *) + +(* These are just visual cues to flag the beginning of the script for *) +(* new subgoals, when indentation is not appropriate (typically after *) +(* tactics that generate more than two subgoals). *) + +TACTIC EXTEND ssrtclplus +| [ "YouShouldNotTypeThis" "+" ssrtclarg(arg) ] -> [ Proofview.V82.tactic (eval_tclarg ist arg) ] +END +set_pr_ssrtac "tclplus" 5 [ArgSep "+ "; ArgSsr "tclarg"] + +TACTIC EXTEND ssrtclminus +| [ "YouShouldNotTypeThis" "-" ssrtclarg(arg) ] -> [ Proofview.V82.tactic (eval_tclarg ist arg) ] +END +set_pr_ssrtac "tclminus" 5 [ArgSep "- "; ArgSsr "tclarg"] + +TACTIC EXTEND ssrtclstar +| [ "YouShouldNotTypeThis" "*" ssrtclarg(arg) ] -> [ Proofview.V82.tactic (eval_tclarg ist arg) ] +END +set_pr_ssrtac "tclstar" 5 [ArgSep "- "; ArgSsr "tclarg"] + +let gen_tclarg = in_gen (rawwit wit_ssrtclarg) + +GEXTEND Gram + GLOBAL: tactic tactic_mode; + tactic: [ + [ "+"; tac = ssrtclarg -> ssrtac_expr !@loc "tclplus" [gen_tclarg tac] + | "-"; tac = ssrtclarg -> ssrtac_expr !@loc "tclminus" [gen_tclarg tac] + | "*"; tac = ssrtclarg -> ssrtac_expr !@loc "tclstar" [gen_tclarg tac] + ] ]; + tactic_mode: [ + [ "+"; tac = G_vernac.subgoal_command -> tac None + | "-"; tac = G_vernac.subgoal_command -> tac None + | "*"; tac = G_vernac.subgoal_command -> tac None + ] ]; +END + +(** The "by" tactical. *) + +let pr_hint prt arg = + if arg = nohint then mt() else str "by " ++ pr_hintarg prt arg +let pr_ssrhint _ _ = pr_hint + +ARGUMENT EXTEND ssrhint TYPED AS ssrhintarg PRINTED BY pr_ssrhint +| [ ] -> [ nohint ] +END + +TACTIC EXTEND ssrtclby +| [ "YouShouldNotTypeThis" ssrhint(tac) ] -> [ Proofview.V82.tactic (hinttac ist true tac) ] +END +set_pr_ssrtac "tclby" 0 [ArgSsr "hint"] + +(* We can't parse "by" in ARGUMENT EXTEND because it will only be made *) +(* into a keyword in ssreflect.v; so we anticipate this in GEXTEND. *) + +GEXTEND Gram + GLOBAL: ssrhint simple_tactic; + ssrhint: [[ "by"; arg = ssrhintarg -> arg ]]; + simple_tactic: [ + [ "by"; arg = ssrhintarg -> + let garg = in_gen (rawwit wit_ssrhint) arg in + ssrtac_atom !@loc "tclby" [garg] + ] ]; +END +(* }}} *) + +(** Bound assumption argument *) + +(* The Ltac API does have a type for assumptions but it is level-dependent *) +(* and therefore impratical to use for complex arguments, so we substitute *) +(* our own to have a uniform representation. Also, we refuse to intern *) +(* idents that match global/section constants, since this would lead to *) +(* fragile Ltac scripts. *) + +type ssrhyp = SsrHyp of loc * identifier + +let hyp_id (SsrHyp (_, id)) = id +let pr_hyp (SsrHyp (_, id)) = pr_id id +let pr_ssrhyp _ _ _ = pr_hyp + +let wit_ssrhyprep = add_genarg "ssrhyprep" pr_hyp + +let hyp_err loc msg id = + Errors.user_err_loc (loc, "ssrhyp", str msg ++ pr_id id) + +let intern_hyp ist (SsrHyp (loc, id) as hyp) = + let _ = Tacintern.intern_genarg ist (in_gen (rawwit wit_var) (loc, id)) in + if not_section_id id then hyp else + hyp_err loc "Can't clear section hypothesis " id + +let interp_hyp ist gl (SsrHyp (loc, id)) = + let s, id' = interp_wit wit_var ist gl (loc, id) in + if not_section_id id' then s, SsrHyp (loc, id') else + hyp_err loc "Can't clear section hypothesis " id' + +ARGUMENT EXTEND ssrhyp TYPED AS ssrhyprep PRINTED BY pr_ssrhyp + INTERPRETED BY interp_hyp + GLOBALIZED BY intern_hyp + | [ ident(id) ] -> [ SsrHyp (loc, id) ] +END + +type ssrhyp_or_id = Hyp of ssrhyp | Id of ssrhyp + +let hoik f = function Hyp x -> f x | Id x -> f x +let hoi_id = hoik hyp_id +let pr_hoi = hoik pr_hyp +let pr_ssrhoi _ _ _ = pr_hoi + +let wit_ssrhoirep = add_genarg "ssrhoirep" pr_hoi + +let intern_ssrhoi ist = function + | Hyp h -> Hyp (intern_hyp ist h) + | Id (SsrHyp (_, id)) as hyp -> + let _ = Tacintern.intern_genarg ist (in_gen (rawwit wit_ident) id) in + hyp + +let interp_ssrhoi ist gl = function + | Hyp h -> let s, h' = interp_hyp ist gl h in s, Hyp h' + | Id (SsrHyp (loc, id)) -> + let s, id' = interp_wit wit_ident ist gl id in + s, Id (SsrHyp (loc, id')) + +ARGUMENT EXTEND ssrhoi_hyp TYPED AS ssrhoirep PRINTED BY pr_ssrhoi + INTERPRETED BY interp_ssrhoi + GLOBALIZED BY intern_ssrhoi + | [ ident(id) ] -> [ Hyp (SsrHyp(loc, id)) ] +END +ARGUMENT EXTEND ssrhoi_id TYPED AS ssrhoirep PRINTED BY pr_ssrhoi + INTERPRETED BY interp_ssrhoi + GLOBALIZED BY intern_ssrhoi + | [ ident(id) ] -> [ Id (SsrHyp(loc, id)) ] +END + +type ssrhyps = ssrhyp list + +let pr_hyps = pr_list pr_spc pr_hyp +let pr_ssrhyps _ _ _ = pr_hyps +let hyps_ids = List.map hyp_id + +let rec check_hyps_uniq ids = function + | SsrHyp (loc, id) :: _ when List.mem id ids -> + hyp_err loc "Duplicate assumption " id + | SsrHyp (_, id) :: hyps -> check_hyps_uniq (id :: ids) hyps + | [] -> () + +let check_hyp_exists hyps (SsrHyp(_, id)) = + try ignore(Context.lookup_named id hyps) + with Not_found -> errorstrm (str"No assumption is named " ++ pr_id id) + +let interp_hyps ist gl ghyps = + let hyps = List.map snd (List.map (interp_hyp ist gl) ghyps) in + check_hyps_uniq [] hyps; Tacmach.project gl, hyps + +ARGUMENT EXTEND ssrhyps TYPED AS ssrhyp list PRINTED BY pr_ssrhyps + INTERPRETED BY interp_hyps + | [ ssrhyp_list(hyps) ] -> [ check_hyps_uniq [] hyps; hyps ] +END + +(** Terms parsing. {{{ ********************************************************) + +(* Because we allow wildcards in term references, we need to stage the *) +(* interpretation of terms so that it occurs at the right time during *) +(* the execution of the tactic (e.g., so that we don't report an error *) +(* for a term that isn't actually used in the execution). *) +(* The term representation tracks whether the concrete initial term *) +(* started with an opening paren, which might avoid a conflict between *) +(* the ssrreflect term syntax and Gallina notation. *) + +(* kinds of terms *) + +type ssrtermkind = char (* print flag *) + +let input_ssrtermkind strm = match Compat.get_tok (stream_nth 0 strm) with + | Tok.KEYWORD "(" -> '(' + | Tok.KEYWORD "@" -> '@' + | _ -> ' ' + +let ssrtermkind = Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind + +let id_of_Cterm t = match id_of_cpattern t with + | Some x -> x + | None -> loc_error (loc_of_cpattern t) "Only identifiers are allowed here" +let ssrhyp_of_ssrterm = function + | k, (_, Some c) as o -> + SsrHyp (constr_loc c, id_of_Cterm (cpattern_of_term o)), String.make 1 k + | _, (_, None) -> assert false + +(* terms *) +let pr_ssrterm _ _ _ = pr_term +let pf_intern_term ist gl (_, c) = glob_constr ist (pf_env gl) c +let intern_term ist sigma env (_, c) = glob_constr ist env c +let interp_term ist gl (_, c) = snd (interp_open_constr ist gl c) +let force_term ist gl (_, c) = interp_constr ist gl c +let glob_ssrterm gs = function + | k, (_, Some c) -> k, Tacintern.intern_constr gs c + | ct -> ct +let subst_ssrterm s (k, c) = k, Tacsubst.subst_glob_constr_and_expr s c +let interp_ssrterm _ gl t = Tacmach.project gl, t + +ARGUMENT EXTEND ssrterm + PRINTED BY pr_ssrterm + INTERPRETED BY interp_ssrterm + GLOBALIZED BY glob_ssrterm SUBSTITUTED BY subst_ssrterm + RAW_TYPED AS cpattern RAW_PRINTED BY pr_ssrterm + GLOB_TYPED AS cpattern GLOB_PRINTED BY pr_ssrterm +| [ "YouShouldNotTypeThis" constr(c) ] -> [ mk_lterm c ] +END + +GEXTEND Gram + GLOBAL: ssrterm; + ssrterm: [[ k = ssrtermkind; c = constr -> mk_term k c ]]; +END +(* }}} *) + +(** The "in" pseudo-tactical {{{ **********************************************) + +(* We can't make "in" into a general tactical because this would create a *) +(* crippling conflict with the ltac let .. in construct. Hence, we add *) +(* explicitly an "in" suffix to all the extended tactics for which it is *) +(* relevant (including move, case, elim) and to the extended do tactical *) +(* below, which yields a general-purpose "in" of the form do [...] in ... *) + +(* This tactical needs to come before the intro tactics because the latter *) +(* must take precautions in order not to interfere with the discharged *) +(* assumptions. This is especially difficult for discharged "let"s, which *) +(* the default simpl and unfold tactics would erase blindly. *) + +(** Clear switch *) + +type ssrclear = ssrhyps + +let pr_clear_ne clr = str "{" ++ pr_hyps clr ++ str "}" +let pr_clear sep clr = if clr = [] then mt () else sep () ++ pr_clear_ne clr + +let pr_ssrclear _ _ _ = pr_clear mt + +ARGUMENT EXTEND ssrclear_ne TYPED AS ssrhyps PRINTED BY pr_ssrclear +| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ check_hyps_uniq [] clr; clr ] +END + +ARGUMENT EXTEND ssrclear TYPED AS ssrclear_ne PRINTED BY pr_ssrclear +| [ ssrclear_ne(clr) ] -> [ clr ] +| [ ] -> [ [] ] +END + +let cleartac clr = check_hyps_uniq [] clr; clear (hyps_ids clr) + +(* type ssrwgen = ssrclear * ssrhyp * string *) + +let pr_wgen = function + | (clr, Some((id,k),None)) -> spc() ++ pr_clear mt clr ++ str k ++ pr_hoi id + | (clr, Some((id,k),Some p)) -> + spc() ++ pr_clear mt clr ++ str"(" ++ str k ++ pr_hoi id ++ str ":=" ++ + pr_cpattern p ++ str ")" + | (clr, None) -> spc () ++ pr_clear mt clr +let pr_ssrwgen _ _ _ = pr_wgen + +(* no globwith for char *) +ARGUMENT EXTEND ssrwgen + TYPED AS ssrclear * ((ssrhoi_hyp * string) * cpattern option) option + PRINTED BY pr_ssrwgen +| [ ssrclear_ne(clr) ] -> [ clr, None ] +| [ ssrhoi_hyp(hyp) ] -> [ [], Some((hyp, " "), None) ] +| [ "@" ssrhoi_hyp(hyp) ] -> [ [], Some((hyp, "@"), None) ] +| [ "(" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> + [ [], Some ((id," "),Some p) ] +| [ "(" ssrhoi_id(id) ")" ] -> [ [], Some ((id,"("), None) ] +| [ "(@" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> + [ [], Some ((id,"@"),Some p) ] +| [ "(" "@" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> + [ [], Some ((id,"@"),Some p) ] +END + +type ssrclseq = InGoal | InHyps + | InHypsGoal | InHypsSeqGoal | InSeqGoal | InHypsSeq | InAll | InAllHyps + +let pr_clseq = function + | InGoal | InHyps -> mt () + | InSeqGoal -> str "|- *" + | InHypsSeqGoal -> str " |- *" + | InHypsGoal -> str " *" + | InAll -> str "*" + | InHypsSeq -> str " |-" + | InAllHyps -> str "* |-" + +let wit_ssrclseq = add_genarg "ssrclseq" pr_clseq +let pr_clausehyps = pr_list pr_spc pr_wgen +let pr_ssrclausehyps _ _ _ = pr_clausehyps + +ARGUMENT EXTEND ssrclausehyps +TYPED AS ssrwgen list PRINTED BY pr_ssrclausehyps +| [ ssrwgen(hyp) "," ssrclausehyps(hyps) ] -> [ hyp :: hyps ] +| [ ssrwgen(hyp) ssrclausehyps(hyps) ] -> [ hyp :: hyps ] +| [ ssrwgen(hyp) ] -> [ [hyp] ] +END + +(* type ssrclauses = ssrahyps * ssrclseq *) + +let pr_clauses (hyps, clseq) = + if clseq = InGoal then mt () + else str "in " ++ pr_clausehyps hyps ++ pr_clseq clseq +let pr_ssrclauses _ _ _ = pr_clauses + +ARGUMENT EXTEND ssrclauses TYPED AS ssrwgen list * ssrclseq + PRINTED BY pr_ssrclauses + | [ "in" ssrclausehyps(hyps) "|-" "*" ] -> [ hyps, InHypsSeqGoal ] + | [ "in" ssrclausehyps(hyps) "|-" ] -> [ hyps, InHypsSeq ] + | [ "in" ssrclausehyps(hyps) "*" ] -> [ hyps, InHypsGoal ] + | [ "in" ssrclausehyps(hyps) ] -> [ hyps, InHyps ] + | [ "in" "|-" "*" ] -> [ [], InSeqGoal ] + | [ "in" "*" ] -> [ [], InAll ] + | [ "in" "*" "|-" ] -> [ [], InAllHyps ] + | [ ] -> [ [], InGoal ] +END + +let nohide = mkRel 0 +let hidden_goal_tag = "the_hidden_goal" + +(* Reduction that preserves the Prod/Let spine of the "in" tactical. *) + +let inc_safe n = if n = 0 then n else n + 1 +let rec safe_depth c = match kind_of_term c with +| LetIn (Name x, _, _, c') when is_discharged_id x -> safe_depth c' + 1 +| LetIn (_, _, _, c') | Prod (_, _, c') -> inc_safe (safe_depth c') +| _ -> 0 + +let red_safe r e s c0 = + let rec red_to e c n = match kind_of_term c with + | Prod (x, t, c') when n > 0 -> + let t' = r e s t in let e' = Environ.push_rel (x, None, t') e in + mkProd (x, t', red_to e' c' (n - 1)) + | LetIn (x, b, t, c') when n > 0 -> + let t' = r e s t in let e' = Environ.push_rel (x, None, t') e in + mkLetIn (x, r e s b, t', red_to e' c' (n - 1)) + | _ -> r e s c in + red_to e c0 (safe_depth c0) + +let check_wgen_uniq gens = + let clears = List.flatten (List.map fst gens) in + check_hyps_uniq [] clears; + let ids = CList.map_filter + (function (_,Some ((id,_),_)) -> Some (hoi_id id) | _ -> None) gens in + let rec check ids = function + | id :: _ when List.mem id ids -> + errorstrm (str"Duplicate generalization " ++ pr_id id) + | id :: hyps -> check (id :: ids) hyps + | [] -> () in + check [] ids + +let pf_clauseids gl gens clseq = + let keep_clears = List.map (fun x, _ -> x, None) in + if gens <> [] then (check_wgen_uniq gens; gens) else + if clseq <> InAll && clseq <> InAllHyps then keep_clears gens else + Errors.error "assumptions should be named explicitly" + +let hidden_clseq = function InHyps | InHypsSeq | InAllHyps -> true | _ -> false + +let hidetacs clseq idhide cl0 = + if not (hidden_clseq clseq) then [] else + [posetac idhide cl0; + Proofview.V82.of_tactic (convert_concl_no_check (mkVar idhide))] + +let discharge_hyp (id', (id, mode)) gl = + let cl' = subst_var id (pf_concl gl) in + match pf_get_hyp gl id, mode with + | (_, None, t), _ | (_, Some _, t), "(" -> + apply_type (mkProd (Name id', t, cl')) [mkVar id] gl + | (_, Some v, t), _ -> + Proofview.V82.of_tactic (convert_concl (mkLetIn (Name id', v, t, cl'))) gl + +let endclausestac id_map clseq gl_id cl0 gl = + let not_hyp' id = not (List.mem_assoc id id_map) in + let orig_id id = try List.assoc id id_map with _ -> id in + let dc, c = Term.decompose_prod_assum (pf_concl gl) in + let hide_goal = hidden_clseq clseq in + let c_hidden = hide_goal && c = mkVar gl_id in + let rec fits forced = function + | (id, _) :: ids, (Name id', _, _) :: dc' when id' = id -> + fits true (ids, dc') + | ids, dc' -> + forced && ids = [] && (not hide_goal || dc' = [] && c_hidden) in + let rec unmark c = match kind_of_term c with + | Var id when hidden_clseq clseq && id = gl_id -> cl0 + | Prod (Name id, t, c') when List.mem_assoc id id_map -> + mkProd (Name (orig_id id), unmark t, unmark c') + | LetIn (Name id, v, t, c') when List.mem_assoc id id_map -> + mkLetIn (Name (orig_id id), unmark v, unmark t, unmark c') + | _ -> map_constr unmark c in + let utac hyp = + Proofview.V82.of_tactic + (convert_hyp_no_check (map_named_declaration unmark hyp)) in + let utacs = List.map utac (pf_hyps gl) in + let ugtac gl' = + Proofview.V82.of_tactic + (convert_concl_no_check (unmark (pf_concl gl'))) gl' in + let ctacs = if hide_goal then [clear [gl_id]] else [] in + let mktac itacs = tclTHENLIST (itacs @ utacs @ ugtac :: ctacs) in + let itac (_, id) = Proofview.V82.of_tactic (introduction id) in + if fits false (id_map, List.rev dc) then mktac (List.map itac id_map) gl else + let all_ids = ids_of_rel_context dc @ pf_ids_of_hyps gl in + if List.for_all not_hyp' all_ids && not c_hidden then mktac [] gl else + Errors.error "tampering with discharged assumptions of \"in\" tactical" + +let is_id_constr c = match kind_of_term c with + | Lambda(_,_,c) when isRel c -> 1 = destRel c + | _ -> false + +let red_product_skip_id env sigma c = match kind_of_term c with + | App(hd,args) when Array.length args = 1 && is_id_constr hd -> args.(0) + | _ -> try Tacred.red_product env sigma c with _ -> c + +let abs_wgen keep_let ist f gen (gl,args,c) = + let sigma, env = project gl, pf_env gl in + let evar_closed t p = + if occur_existential t then + Errors.user_err_loc (loc_of_cpattern p,"ssreflect", + pr_constr_pat t ++ + str" contains holes and matches no subterm of the goal") in + match gen with + | _, Some ((x, mode), None) when mode = "@" || (mode = " " && keep_let) -> + let x = hoi_id x in + let _, bo, ty = pf_get_hyp gl x in + gl, + (if bo <> None then args else mkVar x :: args), + mkProd_or_LetIn (Name (f x),bo,ty) (subst_var x c) + | _, Some ((x, _), None) -> + let x = hoi_id x in + gl, mkVar x :: args, mkProd (Name (f x), pf_get_hyp_typ gl x, subst_var x c) + | _, Some ((x, "@"), Some p) -> + let x = hoi_id x in + let cp = interp_cpattern ist gl p None in + let (t, ucst), c = + try fill_occ_pattern ~raise_NoMatch:true env sigma c cp None 1 + with NoMatch -> redex_of_pattern env cp, c in + evar_closed t p; + let ut = red_product_skip_id env sigma t in + pf_merge_uc ucst gl, args, mkLetIn(Name (f x), ut, pf_type_of gl t, c) + | _, Some ((x, _), Some p) -> + let x = hoi_id x in + let cp = interp_cpattern ist gl p None in + let (t, ucst), c = + try fill_occ_pattern ~raise_NoMatch:true env sigma c cp None 1 + with NoMatch -> redex_of_pattern env cp, c in + evar_closed t p; + pf_merge_uc ucst gl, t :: args, mkProd(Name (f x), pf_type_of gl t, c) + | _ -> gl, args, c + +let clr_of_wgen gen clrs = match gen with + | clr, Some ((x, _), None) -> + let x = hoi_id x in + cleartac clr :: cleartac [SsrHyp(Loc.ghost,x)] :: clrs + | clr, _ -> cleartac clr :: clrs + +let tclCLAUSES ist tac (gens, clseq) gl = + if clseq = InGoal || clseq = InSeqGoal then tac gl else + let clr_gens = pf_clauseids gl gens clseq in + let clear = tclTHENLIST (List.rev(List.fold_right clr_of_wgen clr_gens [])) in + let gl_id = mk_anon_id hidden_goal_tag gl in + let cl0 = pf_concl gl in + let dtac gl = + let c = pf_concl gl in + let gl, args, c = + List.fold_right (abs_wgen true ist mk_discharged_id) gens (gl,[], c) in + apply_type c args gl in + let endtac = + let id_map = CList.map_filter (function + | _, Some ((x,_),_) -> let id = hoi_id x in Some (mk_discharged_id id, id) + | _, None -> None) gens in + endclausestac id_map clseq gl_id cl0 in + tclTHENLIST (hidetacs clseq gl_id cl0 @ [dtac; clear; tac; endtac]) gl +(* }}} *) + +(** Simpl switch *) + +type ssrsimpl = Simpl | Cut | SimplCut | Nop + +let pr_simpl = function + | Simpl -> str "/=" + | Cut -> str "//" + | SimplCut -> str "//=" + | Nop -> mt () + +let pr_ssrsimpl _ _ _ = pr_simpl + +let wit_ssrsimplrep = add_genarg "ssrsimplrep" pr_simpl + +ARGUMENT EXTEND ssrsimpl_ne TYPED AS ssrsimplrep PRINTED BY pr_ssrsimpl +| [ "/=" ] -> [ Simpl ] +| [ "//" ] -> [ Cut ] +| [ "//=" ] -> [ SimplCut ] +END + +ARGUMENT EXTEND ssrsimpl TYPED AS ssrsimplrep PRINTED BY pr_ssrsimpl +| [ ssrsimpl_ne(sim) ] -> [ sim ] +| [ ] -> [ Nop ] +END + +(* We must avoid zeta-converting any "let"s created by the "in" tactical. *) + +let safe_simpltac gl = + let cl' = red_safe Tacred.simpl (pf_env gl) (project gl) (pf_concl gl) in + Proofview.V82.of_tactic (convert_concl_no_check cl') gl + +let simpltac = function + | Simpl -> safe_simpltac + | Cut -> tclTRY donetac + | SimplCut -> tclTHEN safe_simpltac (tclTRY donetac) + | Nop -> tclIDTAC + +(** Rewriting direction *) + +let pr_dir = function L2R -> str "->" | R2L -> str "<-" +let pr_rwdir = function L2R -> mt() | R2L -> str "-" + +let rewritetac dir c = + (* Due to the new optional arg ?tac, application shouldn't be too partial *) + Proofview.V82.of_tactic begin + Equality.general_rewrite (dir = L2R) AllOccurrences true false c + end + +let wit_ssrdir = add_genarg "ssrdir" pr_dir + +let dir_org = function L2R -> 1 | R2L -> 2 + +(** Indexes *) + +(* Since SSR indexes are always positive numbers, we use the 0 value *) +(* to encode an omitted index. We reuse the in or_var type, but we *) +(* supply our own interpretation function, which checks for non *) +(* positive values, and allows the use of constr numerals, so that *) +(* e.g., "let n := eval compute in (1 + 3) in (do n!clear)" works. *) + +type ssrindex = int or_var + +let pr_index = function + | ArgVar (_, id) -> pr_id id + | ArgArg n when n > 0 -> int n + | _ -> mt () +let pr_ssrindex _ _ _ = pr_index + +let noindex = ArgArg 0 +let allocc = Some(false,[]) + +let check_index loc i = + if i > 0 then i else loc_error loc "Index not positive" +let mk_index loc = function ArgArg i -> ArgArg (check_index loc i) | iv -> iv + +let interp_index ist gl idx = + Tacmach.project gl, + match idx with + | ArgArg _ -> idx + | ArgVar (loc, id) -> + let i = + try + let v = Id.Map.find id ist.lfun in + begin match Value.to_int v with + | Some i -> i + | None -> + begin match Value.to_constr v with + | Some c -> + let rc = Detyping.detype false [] (pf_env gl) (project gl) c in + begin match Notation.uninterp_prim_token rc with + | _, Numeral bigi -> int_of_string (Bigint.to_string bigi) + | _ -> raise Not_found + end + | None -> raise Not_found + end end + with _ -> loc_error loc "Index not a number" in + ArgArg (check_index loc i) + +ARGUMENT EXTEND ssrindex TYPED AS int_or_var PRINTED BY pr_ssrindex + INTERPRETED BY interp_index +| [ int_or_var(i) ] -> [ mk_index loc i ] +END + +(** Occurrence switch *) + +(* The standard syntax of complemented occurrence lists involves a single *) +(* initial "-", e.g., {-1 3 5}. An initial *) +(* "+" may be used to indicate positive occurrences (the default). The *) +(* "+" is optional, except if the list of occurrences starts with a *) +(* variable or is empty (to avoid confusion with a clear switch). The *) +(* empty positive switch "{+}" selects no occurrences, while the empty *) +(* negative switch "{-}" selects all occurrences explicitly; this is the *) +(* default, but "{-}" prevents the implicit clear, and can be used to *) +(* force dependent elimination -- see ndefectelimtac below. *) + +type ssrocc = occ + +let pr_occ = function + | Some (true, occ) -> str "{-" ++ pr_list pr_spc int occ ++ str "}" + | Some (false, occ) -> str "{+" ++ pr_list pr_spc int occ ++ str "}" + | None -> str "{}" + +let pr_ssrocc _ _ _ = pr_occ + +ARGUMENT EXTEND ssrocc TYPED AS (bool * int list) option PRINTED BY pr_ssrocc +| [ natural(n) natural_list(occ) ] -> [ + Some (false, List.map (check_index loc) (n::occ)) ] +| [ "-" natural_list(occ) ] -> [ Some (true, occ) ] +| [ "+" natural_list(occ) ] -> [ Some (false, occ) ] +END + +let pf_mkprod gl c ?(name=constr_name c) cl = + let t = pf_type_of gl c in + if name <> Anonymous || noccurn 1 cl then mkProd (name, t, cl) else + mkProd (Name (pf_type_id gl t), t, cl) + +let pf_abs_prod name gl c cl = pf_mkprod gl c ~name (subst_term c cl) + +(** Discharge occ switch (combined occurrence / clear switch *) + +type ssrdocc = ssrclear option * ssrocc option + +let mkocc occ = None, occ +let noclr = mkocc None +let mkclr clr = Some clr, None +let nodocc = mkclr [] + +let pr_docc = function + | None, occ -> pr_occ occ + | Some clr, _ -> pr_clear mt clr + +let pr_ssrdocc _ _ _ = pr_docc + +ARGUMENT EXTEND ssrdocc TYPED AS ssrclear option * ssrocc PRINTED BY pr_ssrdocc +| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ mkclr clr ] +| [ "{" ssrocc(occ) "}" ] -> [ mkocc occ ] +END + +(** View hint database and View application. {{{ ******************************) + +(* There are three databases of lemmas used to mediate the application *) +(* of reflection lemmas: one for forward chaining, one for backward *) +(* chaining, and one for secondary backward chaining. *) + +(* View hints *) + +let rec isCxHoles = function (CHole _, None) :: ch -> isCxHoles ch | _ -> false + +let pr_raw_ssrhintref prc _ _ = function + | CAppExpl (_, (None, r,x), args) when isCHoles args -> + prc (CRef (r,x)) ++ str "|" ++ int (List.length args) + | CApp (_, (_, CRef _), _) as c -> prc c + | CApp (_, (_, c), args) when isCxHoles args -> + prc c ++ str "|" ++ int (List.length args) + | c -> prc c + +let pr_rawhintref = function + | GApp (_, f, args) when isRHoles args -> + pr_glob_constr f ++ str "|" ++ int (List.length args) + | c -> pr_glob_constr c + +let pr_glob_ssrhintref _ _ _ (c, _) = pr_rawhintref c + +let pr_ssrhintref prc _ _ = prc + +let mkhintref loc c n = match c with + | CRef (r,x) -> CAppExpl (loc, (None, r, x), mkCHoles loc n) + | _ -> mkAppC (c, mkCHoles loc n) + +ARGUMENT EXTEND ssrhintref + PRINTED BY pr_ssrhintref + RAW_TYPED AS constr RAW_PRINTED BY pr_raw_ssrhintref + GLOB_TYPED AS constr GLOB_PRINTED BY pr_glob_ssrhintref + | [ constr(c) ] -> [ c ] + | [ constr(c) "|" natural(n) ] -> [ mkhintref loc c n ] +END + +(* View purpose *) + +let pr_viewpos = function + | 0 -> str " for move/" + | 1 -> str " for apply/" + | 2 -> str " for apply//" + | _ -> mt () + +let pr_ssrviewpos _ _ _ = pr_viewpos + +ARGUMENT EXTEND ssrviewpos TYPED AS int PRINTED BY pr_ssrviewpos + | [ "for" "move" "/" ] -> [ 0 ] + | [ "for" "apply" "/" ] -> [ 1 ] + | [ "for" "apply" "/" "/" ] -> [ 2 ] + | [ "for" "apply" "//" ] -> [ 2 ] + | [ ] -> [ 3 ] +END + +let pr_ssrviewposspc _ _ _ i = pr_viewpos i ++ spc () + +ARGUMENT EXTEND ssrviewposspc TYPED AS ssrviewpos PRINTED BY pr_ssrviewposspc + | [ ssrviewpos(i) ] -> [ i ] +END + +(* The table and its display command *) + +let viewtab : glob_constr list array = Array.make 3 [] + +let _ = + let init () = Array.fill viewtab 0 3 [] in + let freeze _ = Array.copy viewtab in + let unfreeze vt = Array.blit vt 0 viewtab 0 3 in + Summary.declare_summary "ssrview" + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = init } + +let mapviewpos f n k = if n < 3 then f n else for i = 0 to k - 1 do f i done + +let print_view_hints i = + let pp_viewname = str "Hint View" ++ pr_viewpos i ++ str " " in + let pp_hints = pr_list spc pr_rawhintref viewtab.(i) in + ppnl (pp_viewname ++ hov 0 pp_hints ++ Pp.cut ()) + +VERNAC COMMAND EXTEND PrintView CLASSIFIED AS QUERY +| [ "Print" "Hint" "View" ssrviewpos(i) ] -> [ mapviewpos print_view_hints i 3 ] +END + +(* Populating the table *) + +let cache_viewhint (_, (i, lvh)) = + let mem_raw h = List.exists (Notation_ops.eq_glob_constr h) in + let add_hint h hdb = if mem_raw h hdb then hdb else h :: hdb in + viewtab.(i) <- List.fold_right add_hint lvh viewtab.(i) + +let subst_viewhint ( subst, (i, lvh as ilvh)) = + let lvh' = List.smartmap (Detyping.subst_glob_constr subst) lvh in + if lvh' == lvh then ilvh else i, lvh' + +let classify_viewhint x = Libobject.Substitute x + +let in_viewhint = + Libobject.declare_object {(Libobject.default_object "VIEW_HINTS") with + Libobject.open_function = (fun i o -> if i = 1 then cache_viewhint o); + Libobject.cache_function = cache_viewhint; + Libobject.subst_function = subst_viewhint; + Libobject.classify_function = classify_viewhint } + +let glob_view_hints lvh = + List.map (Constrintern.intern_constr (Global.env ())) lvh + +let add_view_hints lvh i = Lib.add_anonymous_leaf (in_viewhint (i, lvh)) + +VERNAC COMMAND EXTEND HintView CLASSIFIED AS QUERY + | [ "Hint" "View" ssrviewposspc(n) ne_ssrhintref_list(lvh) ] -> + [ mapviewpos (add_view_hints (glob_view_hints lvh)) n 2 ] +END + +(** Views *) + +(* Views for the "move" and "case" commands are actually open *) +(* terms, but this is handled by interp_view, which is called *) +(* by interp_casearg. We use lists, to support the *) +(* "double-view" feature of the apply command. *) + +(* type ssrview = ssrterm list *) + +let pr_view = pr_list mt (fun c -> str "/" ++ pr_term c) + +let pr_ssrview _ _ _ = pr_view + +ARGUMENT EXTEND ssrview TYPED AS ssrterm list + PRINTED BY pr_ssrview +| [ "/" constr(c) ] -> [ [mk_term ' ' c] ] +| [ "/" constr(c) ssrview(w) ] -> [ (mk_term ' ' c) :: w ] +END + +(* There are two ways of "applying" a view to term: *) +(* 1- using a view hint if the view is an instance of some *) +(* (reflection) inductive predicate. *) +(* 2- applying the view if it coerces to a function, adding *) +(* implicit arguments. *) +(* They require guessing the view hints and the number of *) +(* implicits, respectively, which we do by brute force. *) + +let view_error s gv = + errorstrm (str ("Cannot " ^ s ^ " view ") ++ pr_term gv) + +let interp_view ist si env sigma gv rid = + match intern_term ist sigma env gv with + | GApp (loc, GHole _, rargs) -> + let rv = GApp (loc, rid, rargs) in + snd (interp_open_constr ist (re_sig si sigma) (rv, None)) + | rv -> + let interp rc rargs = + interp_open_constr ist (re_sig si sigma) (mkRApp rc rargs, None) in + let rec simple_view rargs n = + if n < 0 then view_error "use" gv else + try interp rv rargs with _ -> simple_view (mkRHole :: rargs) (n - 1) in + let view_nbimps = interp_view_nbimps ist (re_sig si sigma) rv in + let view_args = [mkRApp rv (mkRHoles view_nbimps); rid] in + let rec view_with = function + | [] -> simple_view [rid] (interp_nbargs ist (re_sig si sigma) rv) + | hint :: hints -> try interp hint view_args with _ -> view_with hints in + snd (view_with (if view_nbimps < 0 then [] else viewtab.(0))) + +let top_id = mk_internal_id "top assumption" + +let with_view ist si env gl0 c name cl prune = + let c2r ist x = { ist with lfun = + Id.Map.add top_id (Value.of_constr x) ist.lfun } in + let rec loop (sigma, c') = function + | f :: view -> + let rid, ist = match kind_of_term c' with + | Var id -> mkRVar id, ist + | _ -> mkRltacVar top_id, c2r ist c' in + loop (interp_view ist si env sigma f rid) view + | [] -> + let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in + let c' = Reductionops.nf_evar sigma c' in + let n, c', _, ucst = pf_abs_evars gl0 (sigma, c') in + let c' = if not prune then c' else pf_abs_cterm gl0 n c' in + let gl0 = pf_merge_uc ucst gl0 in + pf_abs_prod name gl0 c' (prod_applist cl [c]), c', pf_merge_uc_of sigma gl0 + in loop + +let pf_with_view ist gl (prune, view) cl c = + let env, sigma, si = pf_env gl, project gl, sig_it gl in + with_view ist si env gl c (constr_name c) cl prune (sigma, c) view +(* }}} *) + +(** Extended intro patterns {{{ ***********************************************) + +type ssrtermrep = char * glob_constr_and_expr +type ssripat = + | IpatSimpl of ssrclear * ssrsimpl + | IpatId of identifier + | IpatWild + | IpatCase of ssripats list + | IpatRw of ssrocc * ssrdir + | IpatAll + | IpatAnon + | IpatView of ssrtermrep list + | IpatNoop + | IpatNewHidden of identifier list +and ssripats = ssripat list + +let remove_loc = snd + +let rec ipat_of_intro_pattern = function + | IntroNaming (IntroIdentifier id) -> IpatId id + | IntroAction IntroWildcard -> IpatWild + | IntroAction (IntroOrAndPattern iorpat) -> + IpatCase + (List.map (List.map ipat_of_intro_pattern) + (List.map (List.map remove_loc) iorpat)) + | IntroNaming IntroAnonymous -> IpatAnon + | IntroAction (IntroRewrite b) -> IpatRw (allocc, if b then L2R else R2L) + | IntroNaming (IntroFresh id) -> IpatAnon + | IntroAction (IntroApplyOn _) -> (* to do *) Errors.error "TO DO" + | IntroAction (IntroInjection ips) -> + IpatCase [List.map ipat_of_intro_pattern (List.map remove_loc ips)] + | IntroForthcoming _ -> (* Unable to determine which kind of ipat interp_introid could return [HH] *) + assert false + +let rec pr_ipat = function + | IpatId id -> pr_id id + | IpatSimpl (clr, sim) -> pr_clear mt clr ++ pr_simpl sim + | IpatCase iorpat -> hov 1 (str "[" ++ pr_iorpat iorpat ++ str "]") + | IpatRw (occ, dir) -> pr_occ occ ++ pr_dir dir + | IpatAll -> str "*" + | IpatWild -> str "_" + | IpatAnon -> str "?" + | IpatView v -> pr_view v + | IpatNoop -> str "-" + | IpatNewHidden l -> str "[:" ++ pr_list spc pr_id l ++ str "]" +and pr_iorpat iorpat = pr_list pr_bar pr_ipats iorpat +and pr_ipats ipats = pr_list spc pr_ipat ipats + +let wit_ssripatrep = add_genarg "ssripatrep" pr_ipat + +let pr_ssripat _ _ _ = pr_ipat +let pr_ssripats _ _ _ = pr_ipats +let pr_ssriorpat _ _ _ = pr_iorpat + +let intern_ipat ist ipat = + let rec check_pat = function + | IpatSimpl (clr, _) -> ignore (List.map (intern_hyp ist) clr) + | IpatCase iorpat -> List.iter (List.iter check_pat) iorpat + | _ -> () in + check_pat ipat; ipat + +let intern_ipats ist = List.map (intern_ipat ist) + +let interp_introid ist gl id = + try IntroNaming (IntroIdentifier (hyp_id (snd (interp_hyp ist gl (SsrHyp (dummy_loc, id)))))) + with _ -> snd(snd (interp_intro_pattern ist gl (dummy_loc,IntroNaming (IntroIdentifier id)))) + +let rec add_intro_pattern_hyps (loc, ipat) hyps = match ipat with + | IntroNaming (IntroIdentifier id) -> + if not_section_id id then SsrHyp (loc, id) :: hyps else + hyp_err loc "Can't delete section hypothesis " id + | IntroAction IntroWildcard -> hyps + | IntroAction (IntroOrAndPattern iorpat) -> + List.fold_right (List.fold_right add_intro_pattern_hyps) iorpat hyps + | IntroNaming IntroAnonymous -> [] + | IntroNaming (IntroFresh _) -> [] + | IntroAction (IntroRewrite _) -> hyps + | IntroAction (IntroInjection ips) -> List.fold_right add_intro_pattern_hyps ips hyps + | IntroAction (IntroApplyOn (c,pat)) -> add_intro_pattern_hyps pat hyps + | IntroForthcoming _ -> + (* As in ipat_of_intro_pattern, was unable to determine which kind + of ipat interp_introid could return [HH] *) assert false + +let rec interp_ipat ist gl = + let ltacvar id = Id.Map.mem id ist.lfun in + let rec interp = function + | IpatId id when ltacvar id -> + ipat_of_intro_pattern (interp_introid ist gl id) + | IpatSimpl (clr, sim) -> + let add_hyps (SsrHyp (loc, id) as hyp) hyps = + if not (ltacvar id) then hyp :: hyps else + add_intro_pattern_hyps (loc, (interp_introid ist gl id)) hyps in + let clr' = List.fold_right add_hyps clr [] in + check_hyps_uniq [] clr'; IpatSimpl (clr', sim) + | IpatCase iorpat -> IpatCase (List.map (List.map interp) iorpat) + | IpatNewHidden l -> + IpatNewHidden + (List.map (function + | IntroNaming (IntroIdentifier id) -> id + | _ -> assert false) + (List.map (interp_introid ist gl) l)) + | ipat -> ipat in + interp + +let interp_ipats ist gl l = project gl, List.map (interp_ipat ist gl) l + +let pushIpatRw = function + | pats :: orpat -> (IpatRw (allocc, L2R) :: pats) :: orpat + | [] -> [] + +let pushIpatNoop = function + | pats :: orpat -> (IpatNoop :: pats) :: orpat + | [] -> [] + +ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY pr_ssripats + INTERPRETED BY interp_ipats + GLOBALIZED BY intern_ipats + | [ "_" ] -> [ [IpatWild] ] + | [ "*" ] -> [ [IpatAll] ] + | [ ident(id) ] -> [ [IpatId id] ] + | [ "?" ] -> [ [IpatAnon] ] + | [ ssrsimpl_ne(sim) ] -> [ [IpatSimpl ([], sim)] ] + | [ ssrdocc(occ) "->" ] -> [ match occ with + | None, occ -> [IpatRw (occ, L2R)] + | Some clr, _ -> [IpatSimpl (clr, Nop); IpatRw (allocc, L2R)]] + | [ ssrdocc(occ) "<-" ] -> [ match occ with + | None, occ -> [IpatRw (occ, R2L)] + | Some clr, _ -> [IpatSimpl (clr, Nop); IpatRw (allocc, R2L)]] + | [ ssrdocc(occ) ] -> [ match occ with + | Some cl, _ -> check_hyps_uniq [] cl; [IpatSimpl (cl, Nop)] + | _ -> loc_error loc "Only identifiers are allowed here"] + | [ "->" ] -> [ [IpatRw (allocc, L2R)] ] + | [ "<-" ] -> [ [IpatRw (allocc, R2L)] ] + | [ "-" ] -> [ [IpatNoop] ] + | [ "-/" "=" ] -> [ [IpatNoop;IpatSimpl([],Simpl)] ] + | [ "-/=" ] -> [ [IpatNoop;IpatSimpl([],Simpl)] ] + | [ "-/" "/" ] -> [ [IpatNoop;IpatSimpl([],Cut)] ] + | [ "-//" ] -> [ [IpatNoop;IpatSimpl([],Cut)] ] + | [ "-/" "/=" ] -> [ [IpatNoop;IpatSimpl([],SimplCut)] ] + | [ "-//" "=" ] -> [ [IpatNoop;IpatSimpl([],SimplCut)] ] + | [ "-//=" ] -> [ [IpatNoop;IpatSimpl([],SimplCut)] ] + | [ ssrview(v) ] -> [ [IpatView v] ] + | [ "[" ":" ident_list(idl) "]" ] -> [ [IpatNewHidden idl] ] +END + +ARGUMENT EXTEND ssripats TYPED AS ssripat PRINTED BY pr_ssripats + | [ ssripat(i) ssripats(tl) ] -> [ i @ tl ] + | [ ] -> [ [] ] +END + +ARGUMENT EXTEND ssriorpat TYPED AS ssripat list PRINTED BY pr_ssriorpat +| [ ssripats(pats) "|" ssriorpat(orpat) ] -> [ pats :: orpat ] +| [ ssripats(pats) "|-" ">" ssriorpat(orpat) ] -> [ pats :: pushIpatRw orpat ] +| [ ssripats(pats) "|-" ssriorpat(orpat) ] -> [ pats :: pushIpatNoop orpat ] +| [ ssripats(pats) "|->" ssriorpat(orpat) ] -> [ pats :: pushIpatRw orpat ] +| [ ssripats(pats) "||" ssriorpat(orpat) ] -> [ pats :: [] :: orpat ] +| [ ssripats(pats) "|||" ssriorpat(orpat) ] -> [ pats :: [] :: [] :: orpat ] +| [ ssripats(pats) "||||" ssriorpat(orpat) ] -> [ [pats; []; []; []] @ orpat ] +| [ ssripats(pats) ] -> [ [pats] ] +END + +let reject_ssrhid strm = + match Compat.get_tok (stream_nth 0 strm) with + | Tok.KEYWORD "[" -> + (match Compat.get_tok (stream_nth 0 strm) with + | Tok.KEYWORD ":" -> raise Stream.Failure + | _ -> ()) + | _ -> () + +let test_nohidden = Gram.Entry.of_parser "test_ssrhid" reject_ssrhid + +ARGUMENT EXTEND ssrcpat TYPED AS ssripatrep PRINTED BY pr_ssripat + | [ "YouShouldNotTypeThis" ssriorpat(x) ] -> [ IpatCase x ] +END + +GEXTEND Gram + GLOBAL: ssrcpat; + ssrcpat: [[ test_nohidden; "["; iorpat = ssriorpat; "]" -> IpatCase iorpat ]]; +END + +GEXTEND Gram + GLOBAL: ssripat; + ssripat: [[ pat = ssrcpat -> [pat] ]]; +END + +ARGUMENT EXTEND ssripats_ne TYPED AS ssripat PRINTED BY pr_ssripats + | [ ssripat(i) ssripats(tl) ] -> [ i @ tl ] +END + +(* subsets of patterns *) +let check_ssrhpats loc w_binders ipats = + let err_loc s = Errors.user_err_loc (loc, "ssreflect", s) in + let clr, ipats = + let rec aux clr = function + | IpatSimpl (cl, Nop) :: tl -> aux (clr @ cl) tl + | IpatSimpl (cl, sim) :: tl -> clr @ cl, IpatSimpl ([], sim) :: tl + | tl -> clr, tl + in aux [] ipats in + let simpl, ipats = + match List.rev ipats with + | IpatSimpl ([],_) as s :: tl -> [s], List.rev tl + | _ -> [], ipats in + if simpl <> [] && not w_binders then + err_loc (str "No s-item allowed here: " ++ pr_ipats simpl); + let ipat, binders = + let rec loop ipat = function + | [] -> ipat, [] + | ( IpatId _| IpatAnon| IpatCase _| IpatRw _ as i) :: tl -> + if w_binders then + if simpl <> [] && tl <> [] then + err_loc(str"binders XOR s-item allowed here: "++pr_ipats(tl@simpl)) + else if not (List.for_all (function IpatId _ -> true | _ -> false) tl) + then err_loc (str "Only binders allowed here: " ++ pr_ipats tl) + else ipat @ [i], tl + else + if tl = [] then ipat @ [i], [] + else err_loc (str "No binder or s-item allowed here: " ++ pr_ipats tl) + | hd :: tl -> loop (ipat @ [hd]) tl + in loop [] ipats in + ((clr, ipat), binders), simpl + +let single loc = + function [x] -> x | _ -> loc_error loc "Only one intro pattern is allowed" + +let pr_hpats (((clr, ipat), binders), simpl) = + pr_clear mt clr ++ pr_ipats ipat ++ pr_ipats binders ++ pr_ipats simpl +let pr_ssrhpats _ _ _ = pr_hpats +let pr_ssrhpats_wtransp _ _ _ (_, x) = pr_hpats x + +ARGUMENT EXTEND ssrhpats TYPED AS ((ssrclear * ssripat) * ssripat) * ssripat +PRINTED BY pr_ssrhpats + | [ ssripats(i) ] -> [ check_ssrhpats loc true i ] +END + +ARGUMENT EXTEND ssrhpats_wtransp + TYPED AS bool * (((ssrclear * ssripat) * ssripat) * ssripat) + PRINTED BY pr_ssrhpats_wtransp + | [ ssripats(i) ] -> [ false,check_ssrhpats loc true i ] + | [ ssripats(i) "@" ssripats(j) ] -> [ true,check_ssrhpats loc true (i @ j) ] +END + +ARGUMENT EXTEND ssrhpats_nobs +TYPED AS ((ssrclear * ssripat) * ssripat) * ssripat PRINTED BY pr_ssrhpats + | [ ssripats(i) ] -> [ check_ssrhpats loc false i ] +END + +ARGUMENT EXTEND ssrrpat TYPED AS ssripatrep PRINTED BY pr_ssripat + | [ "->" ] -> [ IpatRw (allocc, L2R) ] + | [ "<-" ] -> [ IpatRw (allocc, R2L) ] +END + +type ssrintros = ssripats + +let pr_intros sep intrs = + if intrs = [] then mt() else sep () ++ str "=> " ++ pr_ipats intrs +let pr_ssrintros _ _ _ = pr_intros mt + +ARGUMENT EXTEND ssrintros_ne TYPED AS ssripat + PRINTED BY pr_ssrintros + | [ "=>" ssripats_ne(pats) ] -> [ pats ] +END + +ARGUMENT EXTEND ssrintros TYPED AS ssrintros_ne PRINTED BY pr_ssrintros + | [ ssrintros_ne(intrs) ] -> [ intrs ] + | [ ] -> [ [] ] +END + +let injecteq_id = mk_internal_id "injection equation" + +let pf_nb_prod gl = nb_prod (pf_concl gl) + +let rev_id = mk_internal_id "rev concl" + +let revtoptac n0 gl = + let n = pf_nb_prod gl - n0 in + let dc, cl = decompose_prod_n n (pf_concl gl) in + let dc' = dc @ [Name rev_id, compose_prod (List.rev dc) cl] in + let f = compose_lam dc' (mkEtaApp (mkRel (n + 1)) (-n) 1) in + refine (mkApp (f, [|Evarutil.mk_new_meta ()|])) gl + +let equality_inj l b id c gl = + let msg = ref "" in + try Proofview.V82.of_tactic (Equality.inj l b None c) gl + with + | Compat.Exc_located(_,Errors.UserError (_,s)) + | Errors.UserError (_,s) + when msg := Pp.string_of_ppcmds s; + !msg = "Not a projectable equality but a discriminable one." || + !msg = "Nothing to inject." -> + msg_warning (str !msg); + discharge_hyp (id, (id, "")) gl + +let injectidl2rtac id c gl = + tclTHEN (equality_inj None true id c) (revtoptac (pf_nb_prod gl)) gl + +let injectl2rtac c = match kind_of_term c with +| Var id -> injectidl2rtac id (mkVar id, NoBindings) +| _ -> + let id = injecteq_id in + tclTHENLIST [havetac id c; injectidl2rtac id (mkVar id, NoBindings); clear [id]] + +let is_injection_case c gl = + let (mind,_), _ = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in + eq_gr (IndRef mind) (build_coq_eq ()) + +let perform_injection c gl = + let mind, t = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in + let dc, eqt = decompose_prod t in + if dc = [] then injectl2rtac c gl else + if not (closed0 eqt) then + Errors.error "can't decompose a quantified equality" else + let cl = pf_concl gl in let n = List.length dc in + let c_eq = mkEtaApp c n 2 in + let cl1 = mkLambda (Anonymous, mkArrow eqt cl, mkApp (mkRel 1, [|c_eq|])) in + let id = injecteq_id in + let id_with_ebind = (mkVar id, NoBindings) in + let injtac = tclTHEN (introid id) (injectidl2rtac id id_with_ebind) in + tclTHENLAST (Proofview.V82.of_tactic (apply (compose_lam dc cl1))) injtac gl + +let simplest_newcase_ref = ref (fun t gl -> assert false) +let simplest_newcase x gl = !simplest_newcase_ref x gl + +let ssrscasetac c gl = + if is_injection_case c gl then perform_injection c gl + else simplest_newcase c gl + +let intro_all gl = + let dc, _ = Term.decompose_prod_assum (pf_concl gl) in + tclTHENLIST (List.map anontac (List.rev dc)) gl + +let rec intro_anon gl = + try anontac (List.hd (fst (Term.decompose_prod_n_assum 1 (pf_concl gl)))) gl + with err0 -> try tclTHEN red_in_concl intro_anon gl with _ -> raise err0 + (* with _ -> Errors.error "No product even after reduction" *) + +let with_top tac = + tclTHENLIST [introid top_id; tac (mkVar top_id); clear [top_id]] + +let rec mapLR f = function [] -> [] | x :: s -> let y = f x in y :: mapLR f s + +let wild_ids = ref [] + +let new_wild_id () = + let i = 1 + List.length !wild_ids in + let id = mk_wildcard_id i in + wild_ids := id :: !wild_ids; + id + +let clear_wilds wilds gl = + clear (List.filter (fun id -> List.mem id wilds) (pf_ids_of_hyps gl)) gl + +let clear_with_wilds wilds clr0 gl = + let extend_clr clr (id, _, _ as nd) = + if List.mem id clr || not (List.mem id wilds) then clr else + let vars = global_vars_set_of_decl (pf_env gl) nd in + let occurs id' = Idset.mem id' vars in + if List.exists occurs clr then id :: clr else clr in + clear (Context.fold_named_context_reverse extend_clr ~init:clr0 (pf_hyps gl)) gl + +let tclTHENS_nonstrict tac tacl taclname gl = + let tacres = tac gl in + let n_gls = List.length (sig_it tacres) in + let n_tac = List.length tacl in + if n_gls = n_tac then tclTHENS (fun _ -> tacres) tacl gl else + if n_gls = 0 then tacres else + let pr_only n1 n2 = if n1 < n2 then str "only " else mt () in + let pr_nb n1 n2 name = + pr_only n1 n2 ++ int n1 ++ str (" " ^ String.plural n1 name) in + errorstrm (pr_nb n_tac n_gls taclname ++ spc () + ++ str "for " ++ pr_nb n_gls n_tac "subgoal") + +(* Forward reference to extended rewrite *) +let ipat_rewritetac = ref (fun _ -> rewritetac) + +let rec is_name_in_ipats name = function + | IpatSimpl(clr,_) :: tl -> + List.exists (function SsrHyp(_,id) -> id = name) clr + || is_name_in_ipats name tl + | IpatId id :: tl -> id = name || is_name_in_ipats name tl + | IpatCase l :: tl -> is_name_in_ipats name (List.flatten l @ tl) + | _ :: tl -> is_name_in_ipats name tl + | [] -> false + +let move_top_with_view = ref (fun _ -> assert false) + +let rec nat_of_n n = + if n = 0 then mkConstruct path_of_O + else mkApp (mkConstruct path_of_S, [|nat_of_n (n-1)|]) + +let ssr_abstract_id = Summary.ref "~name:SSR:abstractid" 0 + +let mk_abstract_id () = incr ssr_abstract_id; nat_of_n !ssr_abstract_id + +let ssrmkabs id gl = + let env, concl = pf_env gl, pf_concl gl in + let step sigma = + let sigma, abstract_proof, abstract_ty = + let sigma, (ty, _) = + Evarutil.new_type_evar env sigma Evd.univ_flexible_alg in + let sigma, ablock = mkSsrConst "abstract_lock" env sigma in + let sigma, lock = Evarutil.new_evar env sigma ablock in + let sigma, abstract = mkSsrConst "abstract" env sigma in + let abstract_ty = mkApp(abstract, [|ty;mk_abstract_id ();lock|]) in + let sigma, m = Evarutil.new_evar env sigma abstract_ty in + sigma, m, abstract_ty in + let sigma, kont = + let rd = Name id, None, abstract_ty in + Evarutil.new_evar (Environ.push_rel rd env) sigma concl in + pp(lazy(pr_constr concl)); + let term = mkApp (mkLambda(Name id,abstract_ty,kont) ,[|abstract_proof|]) in + let sigma, _ = Typing.e_type_of env sigma term in + sigma, term in + Proofview.V82.of_tactic + (Proofview.tclTHEN + (Tactics.New.refine step) + (Proofview.tclFOCUS 1 3 Proofview.shelve)) gl + +let ssrmkabstac ids = + List.fold_right (fun id tac -> tclTHENFIRST (ssrmkabs id) tac) ids tclIDTAC + +(* introstac: for "move" and "clear", tclEQINTROS: for "case" and "elim" *) +(* This block hides the spaghetti-code needed to implement the only two *) +(* tactics that should be used to process intro patters. *) +(* The difficulty is that we don't want to always rename, but we can *) +(* compute needeed renamings only at runtime, so we theread a tree like *) +(* imperativestructure so that outer renamigs are inherited by inner *) +(* ipts and that the cler performed at the end of ipatstac clears hyps *) +(* eventually renamed at runtime. *) +(* TODO: hide wild_ids in this block too *) +let introstac, tclEQINTROS = + let rec map_acc_k f k = function + | [] -> (* tricky: we save wilds now, we get to_cler (aka k) later *) + let clear_ww = clear_with_wilds !wild_ids in + [fun gl -> clear_ww (hyps_ids (List.flatten (List.map (!) k))) gl] + | x :: xs -> let k, x = f k xs x in x :: map_acc_k f k xs in + let rename force to_clr rest clr gl = + let hyps = pf_hyps gl in + pp(lazy(str"rename " ++ pr_clear spc clr)); + let () = if not force then List.iter (check_hyp_exists hyps) clr in + if List.exists (fun x -> force || is_name_in_ipats (hyp_id x) rest) clr then + let ren_clr, ren = + List.split (List.map (fun x -> let x = hyp_id x in + let x' = mk_anon_id (string_of_id x) gl in + SsrHyp (dummy_loc, x'), (x, x')) clr) in + let () = to_clr := ren_clr in + Proofview.V82.of_tactic (rename_hyp ren) gl + else + let () = to_clr := clr in + tclIDTAC gl in + let rec ipattac ?ist k rest = function + | IpatWild -> k, introid (new_wild_id ()) + | IpatCase iorpat -> k, tclIORPAT ?ist k (with_top ssrscasetac) iorpat + | IpatRw (occ, dir) -> k, with_top (!ipat_rewritetac occ dir) + | IpatId id -> k, introid id + | IpatNewHidden idl -> k, ssrmkabstac idl + | IpatSimpl (clr, sim) -> + let to_clr = ref [] in + to_clr :: k, tclTHEN (rename false to_clr rest clr) (simpltac sim) + | IpatAll -> k, intro_all + | IpatAnon -> k, intro_anon + | IpatNoop -> k, tclIDTAC + | IpatView v -> match ist with + | None -> anomaly "ipattac with no ist but view" + | Some ist -> match rest with + | (IpatCase _ | IpatRw _)::_ -> + let to_clr = ref [] in let top_id = ref top_id in + to_clr :: k, + tclTHEN + (!move_top_with_view false top_id (false,v) ist) + (fun gl -> + rename true to_clr rest [SsrHyp (dummy_loc, !top_id)]gl) + | _ -> k, !move_top_with_view true (ref top_id) (true,v) ist + and tclIORPAT ?ist k tac = function + | [[]] -> tac + | orp -> + tclTHENS_nonstrict tac (mapLR (ipatstac ?ist k) orp) "intro pattern" + and ipatstac ?ist k ipats = + tclTHENLIST (map_acc_k (ipattac ?ist) k ipats) in + let introstac ?ist ipats = + wild_ids := []; + let tac = ipatstac ?ist [] ipats in + tclTHENLIST [tac; clear_wilds !wild_ids] in + let tclEQINTROS ?ist tac eqtac ipats = + wild_ids := []; + let rec split_itacs to_clr tac' = function + | (IpatSimpl _ as spat) :: ipats' -> + let to_clr, tac = ipattac ?ist to_clr ipats' spat in + split_itacs to_clr (tclTHEN tac' tac) ipats' + | IpatCase iorpat :: ipats' -> + to_clr, tclIORPAT ?ist to_clr tac' iorpat, ipats' + | ipats' -> to_clr, tac', ipats' in + let to_clr, tac1, ipats' = split_itacs [] tac ipats in + let tac2 = ipatstac ?ist to_clr ipats' in + tclTHENLIST [tac1; eqtac; tac2; clear_wilds !wild_ids] in + introstac, tclEQINTROS +;; + +let rec eqmoveipats eqpat = function + | (IpatSimpl _ as ipat) :: ipats -> ipat :: eqmoveipats eqpat ipats + | (IpatAll :: _ | []) as ipats -> IpatAnon :: eqpat :: ipats + | ipat :: ipats -> ipat :: eqpat :: ipats + +(* General case *) +let tclINTROS ist tac ipats = + tclEQINTROS ~ist (tac ist) tclIDTAC ipats + +(** The "=>" tactical *) + +let ssrintros_sep = + let atom_sep = function + | TacSplit (_, [NoBindings]) -> mt + (* | TacExtend (_, "ssrapply", []) -> mt *) + | _ -> spc in + function + | TacId [] -> mt + | TacArg (_, Tacexp _) -> mt + | TacArg (_, Reference _) -> mt + | TacAtom (_, atom) -> atom_sep atom + | _ -> spc + +let pr_ssrintrosarg _ _ prt (tac, ipats) = + prt tacltop tac ++ pr_intros (ssrintros_sep tac) ipats + +ARGUMENT EXTEND ssrintrosarg TYPED AS tactic * ssrintros + PRINTED BY pr_ssrintrosarg +| [ "YouShouldNotTypeThis" ssrtacarg(arg) ssrintros_ne(ipats) ] -> [ arg, ipats ] +END + +TACTIC EXTEND ssrtclintros +| [ "YouShouldNotTypeThis" ssrintrosarg(arg) ] -> + [ let tac, intros = arg in + Proofview.V82.tactic (tclINTROS ist (fun ist -> ssrevaltac ist tac) intros) ] +END +set_pr_ssrtac "tclintros" 0 [ArgSsr "introsarg"] + +let tclintros_expr loc tac ipats = + let args = [in_gen (rawwit wit_ssrintrosarg) (tac, ipats)] in + ssrtac_expr loc "tclintros" args + +GEXTEND Gram + GLOBAL: tactic_expr; + tactic_expr: LEVEL "1" [ RIGHTA + [ tac = tactic_expr; intros = ssrintros_ne -> tclintros_expr !@loc tac intros + ] ]; +END +(* }}} *) + +(** Multipliers {{{ ***********************************************************) + +(* modality *) + +type ssrmmod = May | Must | Once + +let pr_mmod = function May -> str "?" | Must -> str "!" | Once -> mt () + +let wit_ssrmmod = add_genarg "ssrmmod" pr_mmod +let ssrmmod = Pcoq.create_generic_entry "ssrmmod" (Genarg.rawwit wit_ssrmmod) +GEXTEND Gram + GLOBAL: ssrmmod; + ssrmmod: [[ "!" -> Must | LEFTQMARK -> May | "?" -> May]]; +END + +(* tactical *) + +let tclID tac = tac + +let tclDOTRY n tac = + if n <= 0 then tclIDTAC else + let rec loop i gl = + if i = n then tclTRY tac gl else + tclTRY (tclTHEN tac (loop (i + 1))) gl in + loop 1 + +let tclDO n tac = + let prefix i = str"At iteration " ++ int i ++ str": " in + let tac_err_at i gl = + try tac gl + with + | Errors.UserError (l, s) as e -> + let _, info = Errors.push e in + let e' = Errors.UserError (l, prefix i ++ s) in + Util.iraise (e', info) + | Compat.Exc_located(loc, Errors.UserError (l, s)) -> + raise (Compat.Exc_located(loc, Errors.UserError (l, prefix i ++ s))) in + let rec loop i gl = + if i = n then tac_err_at i gl else + (tclTHEN (tac_err_at i) (loop (i + 1))) gl in + loop 1 + +let tclMULT = function + | 0, May -> tclREPEAT + | 1, May -> tclTRY + | n, May -> tclDOTRY n + | 0, Must -> tclAT_LEAST_ONCE + | n, Must when n > 1 -> tclDO n + | _ -> tclID + +(** The "do" tactical. ********************************************************) + +(* +type ssrdoarg = ((ssrindex * ssrmmod) * ssrhint) * ssrclauses +*) + +let pr_ssrdoarg prc _ prt (((n, m), tac), clauses) = + pr_index n ++ pr_mmod m ++ pr_hintarg prt tac ++ pr_clauses clauses + +ARGUMENT EXTEND ssrdoarg + TYPED AS ((ssrindex * ssrmmod) * ssrhintarg) * ssrclauses + PRINTED BY pr_ssrdoarg +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let ssrdotac ist (((n, m), tac), clauses) = + let mul = get_index n, m in + tclCLAUSES ist (tclMULT mul (hinttac ist false tac)) clauses + +TACTIC EXTEND ssrtcldo +| [ "YouShouldNotTypeThis" "do" ssrdoarg(arg) ] -> [ Proofview.V82.tactic (ssrdotac ist arg) ] +END +set_pr_ssrtac "tcldo" 3 [ArgSep "do "; ArgSsr "doarg"] + +let ssrdotac_expr loc n m tac clauses = + let arg = ((n, m), tac), clauses in + ssrtac_expr loc "tcldo" [in_gen (rawwit wit_ssrdoarg) arg] + +GEXTEND Gram + GLOBAL: tactic_expr; + ssrdotac: [ + [ tac = tactic_expr LEVEL "3" -> mk_hint tac + | tacs = ssrortacarg -> tacs + ] ]; + tactic_expr: LEVEL "3" [ RIGHTA + [ IDENT "do"; m = ssrmmod; tac = ssrdotac; clauses = ssrclauses -> + ssrdotac_expr !@loc noindex m tac clauses + | IDENT "do"; tac = ssrortacarg; clauses = ssrclauses -> + ssrdotac_expr !@loc noindex Once tac clauses + | IDENT "do"; n = int_or_var; m = ssrmmod; + tac = ssrdotac; clauses = ssrclauses -> + ssrdotac_expr !@loc (mk_index !@loc n) m tac clauses + ] ]; +END +(* }}} *) + +(** The "first" and "last" tacticals. {{{ *************************************) + +(* type ssrseqarg = ssrindex * (ssrtacarg * ssrtac option) *) + +let pr_seqtacarg prt = function + | (is_first, []), _ -> str (if is_first then "first" else "last") + | tac, Some dtac -> + hv 0 (pr_hintarg prt tac ++ spc() ++ str "|| " ++ prt tacltop dtac) + | tac, _ -> pr_hintarg prt tac + +let pr_ssrseqarg _ _ prt = function + | ArgArg 0, tac -> pr_seqtacarg prt tac + | i, tac -> pr_index i ++ str " " ++ pr_seqtacarg prt tac + +(* We must parse the index separately to resolve the conflict with *) +(* an unindexed tactic. *) +ARGUMENT EXTEND ssrseqarg TYPED AS ssrindex * (ssrhintarg * tactic option) + PRINTED BY pr_ssrseqarg +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let sq_brace_tacnames = + ["first"; "solve"; "do"; "rewrite"; "have"; "suffices"; "wlog"] + (* "by" is a keyword *) +let accept_ssrseqvar strm = + match Compat.get_tok (stream_nth 0 strm) with + | Tok.IDENT id when not (List.mem id sq_brace_tacnames) -> + accept_before_syms_or_ids ["["] ["first";"last"] strm + | _ -> raise Stream.Failure + +let test_ssrseqvar = Gram.Entry.of_parser "test_ssrseqvar" accept_ssrseqvar + +let swaptacarg (loc, b) = (b, []), Some (TacId []) + +let check_seqtacarg dir arg = match snd arg, dir with + | ((true, []), Some (TacAtom (loc, _))), L2R -> + loc_error loc "expected \"last\"" + | ((false, []), Some (TacAtom (loc, _))), R2L -> + loc_error loc "expected \"first\"" + | _, _ -> arg + +let ssrorelse = Gram.Entry.create "ssrorelse" +GEXTEND Gram + GLOBAL: ssrorelse ssrseqarg; + ssrseqidx: [ + [ test_ssrseqvar; id = Prim.ident -> ArgVar (!@loc, id) + | n = Prim.natural -> ArgArg (check_index !@loc n) + ] ]; + ssrswap: [[ IDENT "first" -> !@loc, true | IDENT "last" -> !@loc, false ]]; + ssrorelse: [[ "||"; tac = tactic_expr LEVEL "2" -> tac ]]; + ssrseqarg: [ + [ arg = ssrswap -> noindex, swaptacarg arg + | i = ssrseqidx; tac = ssrortacarg; def = OPT ssrorelse -> i, (tac, def) + | i = ssrseqidx; arg = ssrswap -> i, swaptacarg arg + | tac = tactic_expr LEVEL "3" -> noindex, (mk_hint tac, None) + ] ]; +END + +let tclPERM perm tac gls = + let subgls = tac gls in + let sigma, subgll = Refiner.unpackage subgls in + let subgll' = perm subgll in + Refiner.repackage sigma subgll' +(* +let tclPERM perm tac gls = + let mkpft n g r = + {Proof_type.open_subgoals = n; Proof_type.goal = g; Proof_type.ref = r} in + let mkleaf g = mkpft 0 g None in + let mkprpft n g pr a = mkpft n g (Some (Proof_type.Prim pr, a)) in + let mkrpft n g c = mkprpft n g (Proof_type.Refine c) in + let mkipft n g = + let mki pft (id, _, _ as d) = + let g' = {g with evar_concl = mkNamedProd_or_LetIn d g.evar_concl} in + mkprpft n g' (Proof_type.Intro id) [pft] in + List.fold_left mki in + let gl = Refiner.sig_it gls in + let mkhyp subgl = + let rec chop_section = function + | (x, _, _ as d) :: e when not_section_id x -> d :: chop_section e + | _ -> [] in + let lhyps = Environ.named_context_of_val subgl.evar_hyps in + mk_perm_id (), subgl, chop_section lhyps in + let mkpfvar (hyp, subgl, lhyps) = + let mkarg args (lhyp, body, _) = + if body = None then mkVar lhyp :: args else args in + mkrpft 0 subgl (applist (mkVar hyp, List.fold_left mkarg [] lhyps)) [] in + let mkpfleaf (_, subgl, lhyps) = mkipft 1 gl (mkleaf subgl) lhyps in + let mkmeta _ = Evarutil.mk_new_meta () in + let mkhypdecl (hyp, subgl, lhyps) = + hyp, None, it_mkNamedProd_or_LetIn subgl.evar_concl lhyps in + let subgls, v as res0 = tac gls in + let sigma, subgll = Refiner.unpackage subgls in + let n = List.length subgll in if n = 0 then res0 else + let hyps = List.map mkhyp subgll in + let hyp_decls = List.map mkhypdecl (List.rev (perm hyps)) in + let c = applist (mkmeta (), List.map mkmeta subgll) in + let pft0 = mkipft 0 gl (v (List.map mkpfvar hyps)) hyp_decls in + let pft1 = mkrpft n gl c (pft0 :: List.map mkpfleaf (perm hyps)) in + let subgll', v' = Refiner.frontier pft1 in + Refiner.repackage sigma subgll', v' +*) + +let tclREV tac gl = tclPERM List.rev tac gl + +let rot_hyps dir i hyps = + let n = List.length hyps in + if i = 0 then List.rev hyps else + if i > n then Errors.error "Not enough subgoals" else + let rec rot i l_hyps = function + | hyp :: hyps' when i > 0 -> rot (i - 1) (hyp :: l_hyps) hyps' + | hyps' -> hyps' @ (List.rev l_hyps) in + rot (match dir with L2R -> i | R2L -> n - i) [] hyps + +let tclSEQAT ist atac1 dir (ivar, ((_, atacs2), atac3)) = + let i = get_index ivar in + let evtac = ssrevaltac ist in + let tac1 = evtac atac1 in + if atacs2 = [] && atac3 <> None then tclPERM (rot_hyps dir i) tac1 else + let evotac = function Some atac -> evtac atac | _ -> tclIDTAC in + let tac3 = evotac atac3 in + let rec mk_pad n = if n > 0 then tac3 :: mk_pad (n - 1) else [] in + match dir, mk_pad (i - 1), List.map evotac atacs2 with + | L2R, [], [tac2] when atac3 = None -> tclTHENFIRST tac1 tac2 + | L2R, [], [tac2] when atac3 = None -> tclTHENLAST tac1 tac2 + | L2R, pad, tacs2 -> tclTHENSFIRSTn tac1 (Array.of_list (pad @ tacs2)) tac3 + | R2L, pad, tacs2 -> tclTHENSLASTn tac1 tac3 (Array.of_list (tacs2 @ pad)) + +(* We can't actually parse the direction separately because this *) +(* would introduce conflicts with the basic ltac syntax. *) +let pr_ssrseqdir _ _ _ = function + | L2R -> str ";" ++ spc () ++ str "first " + | R2L -> str ";" ++ spc () ++ str "last " + +ARGUMENT EXTEND ssrseqdir TYPED AS ssrdir PRINTED BY pr_ssrseqdir +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +TACTIC EXTEND ssrtclseq +| [ "YouShouldNotTypeThis" ssrtclarg(tac) ssrseqdir(dir) ssrseqarg(arg) ] -> + [ Proofview.V82.tactic (tclSEQAT ist tac dir arg) ] +END +set_pr_ssrtac "tclseq" 5 [ArgSsr "tclarg"; ArgSsr "seqdir"; ArgSsr "seqarg"] + +let tclseq_expr loc tac dir arg = + let arg1 = in_gen (rawwit wit_ssrtclarg) tac in + let arg2 = in_gen (rawwit wit_ssrseqdir) dir in + let arg3 = in_gen (rawwit wit_ssrseqarg) (check_seqtacarg dir arg) in + ssrtac_expr loc "tclseq" [arg1; arg2; arg3] + +GEXTEND Gram + GLOBAL: tactic_expr; + ssr_first: [ + [ tac = ssr_first; ipats = ssrintros_ne -> tclintros_expr !@loc tac ipats + | "["; tacl = LIST0 tactic_expr SEP "|"; "]" -> TacFirst tacl + ] ]; + ssr_first_else: [ + [ tac1 = ssr_first; tac2 = ssrorelse -> TacOrelse (tac1, tac2) + | tac = ssr_first -> tac ]]; + tactic_expr: LEVEL "4" [ LEFTA + [ tac1 = tactic_expr; ";"; IDENT "first"; tac2 = ssr_first_else -> + TacThen (tac1, tac2) + | tac = tactic_expr; ";"; IDENT "first"; arg = ssrseqarg -> + tclseq_expr !@loc tac L2R arg + | tac = tactic_expr; ";"; IDENT "last"; arg = ssrseqarg -> + tclseq_expr !@loc tac R2L arg + ] ]; +END +(* }}} *) + +(** 5. Bookkeeping tactics (clear, move, case, elim) *) + +(* post-interpretation of terms *) +let all_ok _ _ = true + +let pf_abs_ssrterm ?(resolve_typeclasses=false) ist gl t = + let sigma, ct as t = interp_term ist gl t in + let sigma, _ as t = + let env = pf_env gl in + if not resolve_typeclasses then t + else + let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in + sigma, Evarutil.nf_evar sigma ct in + let n, c, abstracted_away, ucst = pf_abs_evars gl t in + List.fold_left Evd.remove sigma abstracted_away, pf_abs_cterm gl n c, ucst + +let pf_interp_ty ?(resolve_typeclasses=false) ist gl ty = + let n_binders = ref 0 in + let ty = match ty with + | a, (t, None) -> + let rec force_type = function + | GProd (l, x, k, s, t) -> incr n_binders; GProd (l, x, k, s, force_type t) + | GLetIn (l, x, v, t) -> incr n_binders; GLetIn (l, x, v, force_type t) + | ty -> mkRCast ty mkRType in + a, (force_type t, None) + | _, (_, Some ty) -> + let rec force_type = function + | CProdN (l, abs, t) -> + n_binders := !n_binders + List.length (List.flatten (List.map pi1 abs)); + CProdN (l, abs, force_type t) + | CLetIn (l, n, v, t) -> incr n_binders; CLetIn (l, n, v, force_type t) + | ty -> mkCCast dummy_loc ty (mkCType dummy_loc) in + mk_term ' ' (force_type ty) in + let strip_cast (sigma, t) = + let rec aux t = match kind_of_type t with + | CastType (t, ty) when !n_binders = 0 && isSort ty -> t + | ProdType(n,s,t) -> decr n_binders; mkProd (n, s, aux t) + | LetInType(n,v,ty,t) -> decr n_binders; mkLetIn (n, v, ty, aux t) + | _ -> anomaly "pf_interp_ty: ssr Type cast deleted by typecheck" in + sigma, aux t in + let sigma, cty as ty = strip_cast (interp_term ist gl ty) in + let ty = + let env = pf_env gl in + if not resolve_typeclasses then ty + else + let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in + sigma, Evarutil.nf_evar sigma cty in + let n, c, _, ucst = pf_abs_evars gl ty in + let lam_c = pf_abs_cterm gl n c in + let ctx, c = decompose_lam_n n lam_c in + n, compose_prod ctx c, lam_c, ucst +;; + +let whd_app f args = Reductionops.whd_betaiota Evd.empty (mkApp (f, args)) + +let pr_cargs a = + str "[" ++ pr_list pr_spc pr_constr (Array.to_list a) ++ str "]" + +let pp_term gl t = + let t = Reductionops.nf_evar (project gl) t in pr_constr t +let pp_concat hd ?(sep=str", ") = function [] -> hd | x :: xs -> + hd ++ List.fold_left (fun acc x -> acc ++ sep ++ x) x xs + +let fake_pmatcher_end () = + mkProp, L2R, (Evd.empty, Evd.empty_evar_universe_context, mkProp) + +(* TASSI: given (c : ty), generates (c ??? : ty[???/...]) with m evars *) +exception NotEnoughProducts +let prof_saturate_whd = mk_profiler "saturate.whd";; +let saturate ?(beta=false) ?(bi_types=false) env sigma c ?(ty=Retyping.get_type_of env sigma c) m += + let rec loop ty args sigma n = + if n = 0 then + let args = List.rev args in + (if beta then Reductionops.whd_beta sigma else fun x -> x) + (mkApp (c, Array.of_list (List.map snd args))), ty, args, sigma + else match kind_of_type ty with + | ProdType (_, src, tgt) -> + let sigma, x = + Evarutil.new_evar env (create_evar_defs sigma) + (if bi_types then Reductionops.nf_betaiota sigma src else src) in + loop (subst1 x tgt) ((m - n,x) :: args) sigma (n-1) + | CastType (t, _) -> loop t args sigma n + | LetInType (_, v, _, t) -> loop (subst1 v t) args sigma n + | SortType _ -> assert false + | AtomicType _ -> + let ty = + prof_saturate_whd.profile + (Reductionops.whd_betadeltaiota env sigma) ty in + match kind_of_type ty with + | ProdType _ -> loop ty args sigma n + | _ -> anomaly "saturate did not find enough products" + in + loop ty [] sigma m + +let pf_saturate ?beta ?bi_types gl c ?ty m = + let env, sigma, si = pf_env gl, project gl, sig_it gl in + let t, ty, args, sigma = saturate ?beta ?bi_types env sigma c ?ty m in + t, ty, args, re_sig si sigma + +(** Rewrite redex switch *) + +(** Generalization (discharge) item *) + +(* An item is a switch + term pair. *) + +(* type ssrgen = ssrdocc * ssrterm *) + +let pr_gen (docc, dt) = pr_docc docc ++ pr_cpattern dt + +let pr_ssrgen _ _ _ = pr_gen + +ARGUMENT EXTEND ssrgen TYPED AS ssrdocc * cpattern PRINTED BY pr_ssrgen +| [ ssrdocc(docc) cpattern(dt) ] -> [ docc, dt ] +| [ cpattern(dt) ] -> [ nodocc, dt ] +END + +let has_occ ((_, occ), _) = occ <> None +let hyp_of_var v = SsrHyp (dummy_loc, destVar v) + +let interp_clr = function +| Some clr, (k, c) + when (k = ' ' || k = '@') && is_pf_var c -> hyp_of_var c :: clr +| Some clr, _ -> clr +| None, _ -> [] + +(* XXX the k of the redex should percolate out *) +let pf_interp_gen_aux ist gl to_ind ((oclr, occ), t) = + let pat = interp_cpattern ist gl t None in (* UGLY API *) + let cl, env, sigma = pf_concl gl, pf_env gl, project gl in + let (c, ucst), cl = + try fill_occ_pattern ~raise_NoMatch:true env sigma cl pat occ 1 + with NoMatch -> redex_of_pattern env pat, cl in + let clr = interp_clr (oclr, (tag_of_cpattern t, c)) in + if not(occur_existential c) then + if tag_of_cpattern t = '@' then + if not (isVar c) then + errorstrm (str "@ can be used with variables only") + else match pf_get_hyp gl (destVar c) with + | _, None, _ -> errorstrm (str "@ can be used with let-ins only") + | name, Some bo, ty -> true, pat, mkLetIn (Name name,bo,ty,cl),c,clr,ucst + else false, pat, pf_mkprod gl c cl, c, clr,ucst + else if to_ind && occ = None then + let nv, p, _, ucst' = pf_abs_evars gl (fst pat, c) in + let ucst = Evd.union_evar_universe_context ucst ucst' in + if nv = 0 then anomaly "occur_existential but no evars" else + false, pat, mkProd (constr_name c, pf_type_of gl p, pf_concl gl), p, clr,ucst + else loc_error (loc_of_cpattern t) "generalized term didn't match" + +let genclrtac cl cs clr = + let tclmyORELSE tac1 tac2 gl = + try tac1 gl + with e when Errors.noncritical e -> tac2 e gl in + (* apply_type may give a type error, but the useful message is + * the one of clear. You type "move: x" and you get + * "x is used in hyp H" instead of + * "The term H has type T x but is expected to have type T x0". *) + tclTHEN + (tclmyORELSE + (apply_type cl cs) + (fun type_err gl -> + tclTHEN + (tclTHEN (Proofview.V82.of_tactic (elim_type (build_coq_False ()))) (cleartac clr)) + (fun gl -> raise type_err) + gl)) + (cleartac clr) + +let gentac ist gen gl = +(* pp(lazy(str"sigma@gentac=" ++ pr_evar_map None (project gl))); *) + let conv, _, cl, c, clr, ucst = pf_interp_gen_aux ist gl false gen in + pp(lazy(str"c@gentac=" ++ pr_constr c)); + let gl = pf_merge_uc ucst gl in + if conv + then tclTHEN (Proofview.V82.of_tactic (convert_concl cl)) (cleartac clr) gl + else genclrtac cl [c] clr gl + +let pf_interp_gen ist gl to_ind gen = + let _, _, a, b, c, ucst = pf_interp_gen_aux ist gl to_ind gen in + a, b ,c, pf_merge_uc ucst gl + +(** Generalization (discharge) sequence *) + +(* A discharge sequence is represented as a list of up to two *) +(* lists of d-items, plus an ident list set (the possibly empty *) +(* final clear switch). The main list is empty iff the command *) +(* is defective, and has length two if there is a sequence of *) +(* dependent terms (and in that case it is the first of the two *) +(* lists). Thus, the first of the two lists is never empty. *) + +(* type ssrgens = ssrgen list *) +(* type ssrdgens = ssrgens list * ssrclear *) + +let gens_sep = function [], [] -> mt | _ -> spc + +let pr_dgens pr_gen (gensl, clr) = + let prgens s gens = str s ++ pr_list spc pr_gen gens in + let prdeps deps = prgens ": " deps ++ spc () ++ str "/" in + match gensl with + | [deps; []] -> prdeps deps ++ pr_clear pr_spc clr + | [deps; gens] -> prdeps deps ++ prgens " " gens ++ pr_clear spc clr + | [gens] -> prgens ": " gens ++ pr_clear spc clr + | _ -> pr_clear pr_spc clr + +let pr_ssrdgens _ _ _ = pr_dgens pr_gen + +let cons_gen gen = function + | gens :: gensl, clr -> (gen :: gens) :: gensl, clr + | _ -> anomaly "missing gen list" + +let cons_dep (gensl, clr) = + if List.length gensl = 1 then ([] :: gensl, clr) else + Errors.error "multiple dependents switches '/'" + +ARGUMENT EXTEND ssrdgens_tl TYPED AS ssrgen list list * ssrclear + PRINTED BY pr_ssrdgens +| [ "{" ne_ssrhyp_list(clr) "}" cpattern(dt) ssrdgens_tl(dgens) ] -> + [ cons_gen (mkclr clr, dt) dgens ] +| [ "{" ne_ssrhyp_list(clr) "}" ] -> + [ [[]], clr ] +| [ "{" ssrocc(occ) "}" cpattern(dt) ssrdgens_tl(dgens) ] -> + [ cons_gen (mkocc occ, dt) dgens ] +| [ "/" ssrdgens_tl(dgens) ] -> + [ cons_dep dgens ] +| [ cpattern(dt) ssrdgens_tl(dgens) ] -> + [ cons_gen (nodocc, dt) dgens ] +| [ ] -> + [ [[]], [] ] +END + +ARGUMENT EXTEND ssrdgens TYPED AS ssrdgens_tl PRINTED BY pr_ssrdgens +| [ ":" ssrgen(gen) ssrdgens_tl(dgens) ] -> [ cons_gen gen dgens ] +END + +let genstac (gens, clr) ist = + tclTHENLIST (cleartac clr :: List.rev_map (gentac ist) gens) + +(* Common code to handle generalization lists along with the defective case *) + +let with_defective maintac deps clr ist gl = + let top_id = + match kind_of_type (pf_concl gl) with + | ProdType (Name id, _, _) + when has_discharged_tag (string_of_id id) -> id + | _ -> top_id in + let top_gen = mkclr clr, cpattern_of_id top_id in + tclTHEN (introid top_id) (maintac deps top_gen ist) gl + +let with_dgens (gensl, clr) maintac ist = match gensl with + | [deps; []] -> with_defective maintac deps clr ist + | [deps; gen :: gens] -> + tclTHEN (genstac (gens, clr) ist) (maintac deps gen ist) + | [gen :: gens] -> tclTHEN (genstac (gens, clr) ist) (maintac [] gen ist) + | _ -> with_defective maintac [] clr ist + +let first_goal gls = + let gl = gls.Evd.it and sig_0 = gls.Evd.sigma in + if List.is_empty gl then Errors.error "first_goal"; + { Evd.it = List.hd gl; Evd.sigma = sig_0; } + +let with_deps deps0 maintac cl0 cs0 clr0 ist gl0 = + let rec loop gl cl cs clr args clrs = function + | [] -> + let n = List.length args in + maintac (if n > 0 then applist (to_lambda n cl, args) else cl) clrs ist gl0 + | dep :: deps -> + let gl' = first_goal (genclrtac cl cs clr gl) in + let cl', c', clr',gl' = pf_interp_gen ist gl' false dep in + loop gl' cl' [c'] clr' (c' :: args) (clr' :: clrs) deps in + loop gl0 cl0 cs0 clr0 cs0 [clr0] (List.rev deps0) + +(** Equations *) + +(* argument *) + +type ssreqid = ssripat option + +let pr_eqid = function Some pat -> str " " ++ pr_ipat pat | None -> mt () +let pr_ssreqid _ _ _ = pr_eqid + +(* We must use primitive parsing here to avoid conflicts with the *) +(* basic move, case, and elim tactics. *) +ARGUMENT EXTEND ssreqid TYPED AS ssripatrep option PRINTED BY pr_ssreqid +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let accept_ssreqid strm = + match Compat.get_tok (Util.stream_nth 0 strm) with + | Tok.IDENT _ -> accept_before_syms [":"] strm + | Tok.KEYWORD ":" -> () + | Tok.KEYWORD pat when List.mem pat ["_"; "?"; "->"; "<-"] -> + accept_before_syms [":"] strm + | _ -> raise Stream.Failure + +let test_ssreqid = Gram.Entry.of_parser "test_ssreqid" accept_ssreqid + +GEXTEND Gram + GLOBAL: ssreqid; + ssreqpat: [ + [ id = Prim.ident -> IpatId id + | "_" -> IpatWild + | "?" -> IpatAnon + | occ = ssrdocc; "->" -> (match occ with + | None, occ -> IpatRw (occ, L2R) + | _ -> loc_error !@loc "Only occurrences are allowed here") + | occ = ssrdocc; "<-" -> (match occ with + | None, occ -> IpatRw (occ, R2L) + | _ -> loc_error !@loc "Only occurrences are allowed here") + | "->" -> IpatRw (allocc, L2R) + | "<-" -> IpatRw (allocc, R2L) + ]]; + ssreqid: [ + [ test_ssreqid; pat = ssreqpat -> Some pat + | test_ssreqid -> None + ]]; +END + +(* creation *) + +let mkEq dir cl c t n gl = + let eqargs = [|t; c; c|] in eqargs.(dir_org dir) <- mkRel n; + let eq, gl = pf_fresh_global (build_coq_eq()) gl in + let refl, gl = mkRefl t c gl in + mkArrow (mkApp (eq, eqargs)) (lift 1 cl), refl, gl + +let pushmoveeqtac cl c gl = + let x, t, cl1 = destProd cl in + let cl2, eqc, gl = mkEq R2L cl1 c t 1 gl in + apply_type (mkProd (x, t, cl2)) [c; eqc] gl + +let pushcaseeqtac cl gl = + let cl1, args = destApplication cl in + let n = Array.length args in + let dc, cl2 = decompose_lam_n n cl1 in + let _, t = List.nth dc (n - 1) in + let cl3, eqc, gl = mkEq R2L cl2 args.(0) t n gl in + let prot, gl = mkProt (pf_type_of gl cl) cl3 gl in + let cl4 = mkApp (compose_lam dc prot, args) in + let gl, _ = pf_e_type_of gl cl4 in + tclTHEN (apply_type cl4 [eqc]) + (Proofview.V82.of_tactic (convert_concl cl4)) gl + +let pushelimeqtac gl = + let _, args = destApplication (pf_concl gl) in + let x, t, _ = destLambda args.(1) in + let cl1 = mkApp (args.(1), Array.sub args 2 (Array.length args - 2)) in + let cl2, eqc, gl = mkEq L2R cl1 args.(2) t 1 gl in + tclTHEN (apply_type (mkProd (x, t, cl2)) [args.(2); eqc]) + (Proofview.V82.of_tactic intro) gl + +(** Bookkeeping (discharge-intro) argument *) + +(* Since all bookkeeping ssr commands have the same discharge-intro *) +(* argument format we use a single grammar entry point to parse them. *) +(* the entry point parses only non-empty arguments to avoid conflicts *) +(* with the basic Coq tactics. *) + +(* type ssrarg = ssrview * (ssreqid * (ssrdgens * ssripats)) *) + +let pr_ssrarg _ _ _ (view, (eqid, (dgens, ipats))) = + let pri = pr_intros (gens_sep dgens) in + pr_view view ++ pr_eqid eqid ++ pr_dgens pr_gen dgens ++ pri ipats + +ARGUMENT EXTEND ssrarg TYPED AS ssrview * (ssreqid * (ssrdgens * ssrintros)) + PRINTED BY pr_ssrarg +| [ ssrview(view) ssreqid(eqid) ssrdgens(dgens) ssrintros(ipats) ] -> + [ view, (eqid, (dgens, ipats)) ] +| [ ssrview(view) ssrclear(clr) ssrintros(ipats) ] -> + [ view, (None, (([], clr), ipats)) ] +| [ ssreqid(eqid) ssrdgens(dgens) ssrintros(ipats) ] -> + [ [], (eqid, (dgens, ipats)) ] +| [ ssrclear_ne(clr) ssrintros(ipats) ] -> + [ [], (None, (([], clr), ipats)) ] +| [ ssrintros_ne(ipats) ] -> + [ [], (None, (([], []), ipats)) ] +END + +(** The "clear" tactic *) + +(* We just add a numeric version that clears the n top assumptions. *) + +let poptac ist n = introstac ~ist (List.init n (fun _ -> IpatWild)) + +TACTIC EXTEND ssrclear + | [ "clear" natural(n) ] -> [ Proofview.V82.tactic (poptac ist n) ] +END + +(** The "move" tactic *) + +let rec improper_intros = function + | IpatSimpl _ :: ipats -> improper_intros ipats + | (IpatId _ | IpatAnon | IpatCase _ | IpatAll) :: _ -> false + | _ -> true + +let check_movearg = function + | view, (eqid, _) when view <> [] && eqid <> None -> + Errors.error "incompatible view and equation in move tactic" + | view, (_, (([gen :: _], _), _)) when view <> [] && has_occ gen -> + Errors.error "incompatible view and occurrence switch in move tactic" + | _, (_, ((dgens, _), _)) when List.length dgens > 1 -> + Errors.error "dependents switch `/' in move tactic" + | _, (eqid, (_, ipats)) when eqid <> None && improper_intros ipats -> + Errors.error "no proper intro pattern for equation in move tactic" + | arg -> arg + +ARGUMENT EXTEND ssrmovearg TYPED AS ssrarg PRINTED BY pr_ssrarg +| [ ssrarg(arg) ] -> [ check_movearg arg ] +END + +let viewmovetac_aux clear name_ref (_, vl as v) _ gen ist gl = + let cl, c, clr, gl = pf_interp_gen ist gl false gen in + let cl, c, gl = if vl = [] then cl, c, gl else pf_with_view ist gl v cl c in + let clr = if clear then clr else [] in + name_ref := (match id_of_cpattern (snd gen) with Some id -> id | _ -> top_id); + genclrtac cl [c] clr gl + +let () = move_top_with_view := + (fun c r v -> with_defective (viewmovetac_aux c r v) [] []) + +let viewmovetac v deps gen ist gl = + viewmovetac_aux true (ref top_id) v deps gen ist gl + +let eqmovetac _ gen ist gl = + let cl, c, _, gl = pf_interp_gen ist gl false gen in pushmoveeqtac cl c gl + +let movehnftac gl = match kind_of_term (pf_concl gl) with + | Prod _ | LetIn _ -> tclIDTAC gl + | _ -> hnf_in_concl gl + +let ssrmovetac ist = function + | _::_ as view, (_, (dgens, ipats)) -> + let dgentac = with_dgens dgens (viewmovetac (true, view)) ist in + tclTHEN dgentac (introstac ~ist ipats) + | _, (Some pat, (dgens, ipats)) -> + let dgentac = with_dgens dgens eqmovetac ist in + tclTHEN dgentac (introstac ~ist (eqmoveipats pat ipats)) + | _, (_, (([gens], clr), ipats)) -> + let gentac = genstac (gens, clr) ist in + tclTHEN gentac (introstac ~ist ipats) + | _, (_, ((_, clr), ipats)) -> + tclTHENLIST [movehnftac; cleartac clr; introstac ~ist ipats] + +TACTIC EXTEND ssrmove +| [ "move" ssrmovearg(arg) ssrrpat(pat) ] -> + [ Proofview.V82.tactic (tclTHEN (ssrmovetac ist arg) (introstac ~ist [pat])) ] +| [ "move" ssrmovearg(arg) ssrclauses(clauses) ] -> + [ Proofview.V82.tactic (tclCLAUSES ist (ssrmovetac ist arg) clauses) ] +| [ "move" ssrrpat(pat) ] -> [ Proofview.V82.tactic (introstac ~ist [pat]) ] +| [ "move" ] -> [ Proofview.V82.tactic (movehnftac) ] +END + +(* TASSI: given the type of an elimination principle, it finds the higher order + * argument (index), it computes it's arity and the arity of the eliminator and + * checks if the eliminator is recursive or not *) +let analyze_eliminator elimty env sigma = + let rec loop ctx t = match kind_of_type t with + | AtomicType (hd, args) when isRel hd -> + ctx, destRel hd, not (noccurn 1 t), Array.length args + | CastType (t, _) -> loop ctx t + | ProdType (x, ty, t) -> loop ((x,None,ty) :: ctx) t + | LetInType (x,b,ty,t) -> loop ((x,Some b,ty) :: ctx) (subst1 b t) + | _ -> + let env' = Environ.push_rel_context ctx env in + let t' = Reductionops.whd_betadeltaiota env' sigma t in + if not (Term.eq_constr t t') then loop ctx t' else + errorstrm (str"The eliminator has the wrong shape."++spc()++ + str"A (applied) bound variable was expected as the conclusion of "++ + str"the eliminator's"++Pp.cut()++str"type:"++spc()++pr_constr elimty) in + let ctx, pred_id, elim_is_dep, n_pred_args = loop [] elimty in + let n_elim_args = rel_context_nhyps ctx in + let is_rec_elim = + let count_occurn n term = + let count = ref 0 in + let rec occur_rec n c = match kind_of_term c with + | Rel m -> if m = n then incr count + | _ -> iter_constr_with_binders succ occur_rec n c + in + occur_rec n term; !count in + let occurr2 n t = count_occurn n t > 1 in + not (List.for_all_i + (fun i (_,rd) -> pred_id <= i || not (occurr2 (pred_id - i) rd)) + 1 (assums_of_rel_context ctx)) + in + n_elim_args - pred_id, n_elim_args, is_rec_elim, elim_is_dep, n_pred_args + +(* TASSI: This version of unprotects inlines the unfold tactic definition, + * since we don't want to wipe out let-ins, and it seems there is no flag + * to change that behaviour in the standard unfold code *) +let unprotecttac gl = + let c, gl = pf_mkSsrConst "protect_term" gl in + let prot, _ = destConst c in + onClause (fun idopt -> + let hyploc = Option.map (fun id -> id, InHyp) idopt in + reduct_option + (Reductionops.clos_norm_flags + (Closure.RedFlags.mkflags + [Closure.RedFlags.fBETA; + Closure.RedFlags.fCONST prot; + Closure.RedFlags.fIOTA]), DEFAULTcast) hyploc) + allHypsAndConcl gl + +let dependent_apply_error = + try Errors.error "Could not fill dependent hole in \"apply\"" with err -> err + +(* TASSI: Sometimes Coq's apply fails. According to my experience it may be + * related to goals that are products and with beta redexes. In that case it + * guesses the wrong number of implicit arguments for your lemma. What follows + * is just like apply, but with a user-provided number n of implicits. + * + * Refine.refine function that handles type classes and evars but fails to + * handle "dependently typed higher order evars". + * + * Refiner.refiner that does not handle metas with a non ground type but works + * with dependently typed higher order metas. *) +let applyn ~with_evars ?beta ?(with_shelve=false) n t gl = + if with_evars then + let refine gl = + let t, ty, args, gl = pf_saturate ?beta ~bi_types:true gl t n in +(* pp(lazy(str"sigma@saturate=" ++ pr_evar_map None (project gl))); *) + let gl = pf_unify_HO gl ty (pf_concl gl) in + let gs = CList.map_filter (fun (_, e) -> + if isEvar (pf_nf_evar gl e) then Some e else None) + args in + pf_partial_solution gl t gs + in + Proofview.(V82.of_tactic + (tclTHEN (V82.tactic refine) + (if with_shelve then shelve_unifiable else tclUNIT ()))) gl + else + let t, gl = if n = 0 then t, gl else + let sigma, si = project gl, sig_it gl in + let rec loop sigma bo args = function (* saturate with metas *) + | 0 -> mkApp (t, Array.of_list (List.rev args)), re_sig si sigma + | n -> match kind_of_term bo with + | Lambda (_, ty, bo) -> + if not (closed0 ty) then raise dependent_apply_error; + let m = Evarutil.new_meta () in + loop (meta_declare m ty sigma) bo ((mkMeta m)::args) (n-1) + | _ -> assert false + in loop sigma t [] n in + pp(lazy(str"Refiner.refiner " ++ pr_constr t)); + Refiner.refiner (Proof_type.Refine t) gl + +let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl = + let rec mkRels = function 1 -> [] | n -> mkRel n :: mkRels (n-1) in + let uct = Evd.evar_universe_context (fst oc) in + let n, oc = pf_abs_evars_pirrel gl oc in + let gl = pf_merge_uc uct gl in + let oc = if not first_goes_last || n <= 1 then oc else + let l, c = decompose_lam oc in + if not (List.for_all_i (fun i (_,t) -> closedn ~-i t) (1-n) l) then oc else + compose_lam (let xs,y = List.chop (n-1) l in y @ xs) + (mkApp (compose_lam l c, Array.of_list (mkRel 1 :: mkRels n))) + in + pp(lazy(str"after: " ++ pr_constr oc)); + try applyn ~with_evars ~with_shelve:true ?beta n oc gl with _ -> raise dependent_apply_error + +let pf_fresh_inductive_instance ind gl = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma, indu = Evd.fresh_inductive_instance env sigma ind in + indu, re_sig it sigma + +(** The "case" and "elim" tactic *) + +(* A case without explicit dependent terms but with both a view and an *) +(* occurrence switch and/or an equation is treated as dependent, with the *) +(* viewed term as the dependent term (the occurrence switch would be *) +(* meaningless otherwise). When both a view and explicit dependents are *) +(* present, it is forbidden to put a (meaningless) occurrence switch on *) +(* the viewed term. *) + +(* This is both elim and case (defaulting to the former). If ~elim is omitted + * the standard eliminator is chosen. The code is made of 4 parts: + * 1. find the eliminator if not given as ~elim and analyze it + * 2. build the patterns to be matched against the conclusion, looking at + * (occ, c), deps and the pattern inferred from the type of the eliminator + * 3. build the new predicate matching the patterns, and the tactic to + * generalize the equality in case eqid is not None + * 4. build the tactic handle intructions and clears as required in ipats and + * by eqid *) +let ssrelim ?(is_case=false) ?ist deps what ?elim eqid ipats gl = + (* some sanity checks *) + let oc, orig_clr, occ, c_gen, gl = match what with + | `EConstr(_,_,t) when isEvar t -> + anomaly "elim called on a constr evar" + | `EGen _ when ist = None -> + anomaly "no ist and non simple elimination" + | `EGen (_, g) when elim = None && is_wildcard g -> + errorstrm(str"Indeterminate pattern and no eliminator") + | `EGen ((Some clr,occ), g) when is_wildcard g -> + None, clr, occ, None, gl + | `EGen ((None, occ), g) when is_wildcard g -> None,[],occ,None,gl + | `EGen ((_, occ), p as gen) -> + let _, c, clr,gl = pf_interp_gen (Option.get ist) gl true gen in + Some c, clr, occ, Some p,gl + | `EConstr (clr, occ, c) -> Some c, clr, occ, None,gl in + let orig_gl, concl, env = gl, pf_concl gl, pf_env gl in + pp(lazy(str(if is_case then "==CASE==" else "==ELIM=="))); + (* Utils of local interest only *) + let iD s ?t gl = let t = match t with None -> pf_concl gl | Some x -> x in + pp(lazy(str s ++ pr_constr t)); tclIDTAC gl in + let eq, gl = pf_fresh_global (build_coq_eq ()) gl in + let protectC, gl = pf_mkSsrConst "protect_term" gl in + let fire_subst gl t = Reductionops.nf_evar (project gl) t in + let fire_sigma sigma t = Reductionops.nf_evar sigma t in + let is_undef_pat = function + | sigma, T t -> + (match kind_of_term (fire_sigma sigma t) with Evar _ -> true | _ -> false) + | _ -> false in + let match_pat env p occ h cl = + let sigma0 = project orig_gl in + pp(lazy(str"matching: " ++ pp_pattern p)); + let (c,ucst), cl = + fill_occ_pattern ~raise_NoMatch:true env sigma0 cl p occ h in + pp(lazy(str" got: " ++ pr_constr c)); + c, cl, ucst in + let mkTpat gl t = (* takes a term, refreshes it and makes a T pattern *) + let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in + let t, _, _, sigma = saturate ~beta:true env (project gl) t n in + Evd.merge_universe_context sigma ucst, T t in + let unif_redex gl (sigma, r as p) t = (* t is a hint for the redex of p *) + let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in + let t, _, _, sigma = saturate ~beta:true env sigma t n in + let sigma = Evd.merge_universe_context sigma ucst in + match r with + | X_In_T (e, p) -> sigma, E_As_X_In_T (t, e, p) + | _ -> + try unify_HO env sigma t (fst (redex_of_pattern env p)), r + with e when Errors.noncritical e -> p in + (* finds the eliminator applies it to evars and c saturated as needed *) + (* obtaining "elim ??? (c ???)". pred is the higher order evar *) + let cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl = + match elim with + | Some elim -> + let gl, elimty = pf_e_type_of gl elim in + let pred_id, n_elim_args, is_rec, elim_is_dep, n_pred_args = + analyze_eliminator elimty env (project gl) in + let elim, elimty, elim_args, gl = + pf_saturate ~beta:is_case gl elim ~ty:elimty n_elim_args in + let pred = List.assoc pred_id elim_args in + let elimty = Reductionops.whd_betadeltaiota env (project gl) elimty in + None, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl + | None -> + let c = Option.get oc in let c_ty = pf_type_of gl c in + let ((kn, i) as ind, _ as indu), unfolded_c_ty = + pf_reduce_to_quantified_ind gl c_ty in + let sort = elimination_sort_of_goal gl in + let gl, elim = + if not is_case then + let t, gl = pf_fresh_global (Indrec.lookup_eliminator ind sort) gl in + gl, t + else + pf_eapply (fun env sigma -> + Indrec.build_case_analysis_scheme env sigma indu true) gl sort in + let elimty = pf_type_of gl elim in + let pred_id,n_elim_args,is_rec,elim_is_dep,n_pred_args = + analyze_eliminator elimty env (project gl) in + let rctx = fst (decompose_prod_assum unfolded_c_ty) in + let n_c_args = rel_context_length rctx in + let c, c_ty, t_args, gl = pf_saturate gl c ~ty:c_ty n_c_args in + let elim, elimty, elim_args, gl = + pf_saturate ~beta:is_case gl elim ~ty:elimty n_elim_args in + let pred = List.assoc pred_id elim_args in + let pc = match n_c_args, c_gen with + | 0, Some p -> interp_cpattern (Option.get ist) orig_gl p None + | _ -> mkTpat gl c in + let cty = Some (c, c_ty, pc) in + let elimty = Reductionops.whd_betadeltaiota env (project gl) elimty in + cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl + in + pp(lazy(str"elim= "++ pr_constr_pat elim)); + pp(lazy(str"elimty= "++ pr_constr elimty)); + let inf_deps_r = match kind_of_type elimty with + | AtomicType (_, args) -> List.rev (Array.to_list args) + | _ -> assert false in + let saturate_until gl c c_ty f = + let rec loop n = try + let c, c_ty, _, gl = pf_saturate gl c ~ty:c_ty n in + let gl' = f c c_ty gl in + Some (c, c_ty, gl, gl') + with NotEnoughProducts -> None | _ -> loop (n+1) in loop 0 in + let elim_is_dep, gl = match cty with + | None -> true, gl + | Some (c, c_ty, _) -> + let res = + if elim_is_dep then None else + let arg = List.assoc (n_elim_args - 1) elim_args in + let arg_ty = pf_type_of gl arg in + match saturate_until gl c c_ty (fun c c_ty gl -> + pf_unify_HO (pf_unify_HO gl c_ty arg_ty) arg c) with + | Some (c, _, _, gl) -> Some (false, gl) + | None -> None in + match res with + | Some x -> x + | None -> + let inf_arg = List.hd inf_deps_r in + let inf_arg_ty = pf_type_of gl inf_arg in + match saturate_until gl c c_ty (fun _ c_ty gl -> + pf_unify_HO gl c_ty inf_arg_ty) with + | Some (c, _, _,gl) -> true, gl + | None -> + errorstrm (str"Unable to apply the eliminator to the term"++ + spc()++pr_constr c++spc()++str"or to unify it's type with"++ + pr_constr inf_arg_ty) in + pp(lazy(str"elim_is_dep= " ++ bool elim_is_dep)); + let predty = pf_type_of gl pred in + (* Patterns for the inductive types indexes to be bound in pred are computed + * looking at the ones provided by the user and the inferred ones looking at + * the type of the elimination principle *) + let pp_pat (_,p,_,_) = pp_pattern p in + let pp_inf_pat gl (_,_,t,_) = pr_constr_pat (fire_subst gl t) in + let patterns, clr, gl = + let rec loop patterns clr i = function + | [],[] -> patterns, clr, gl + | ((oclr, occ), t):: deps, inf_t :: inf_deps -> + let ist = match ist with Some x -> x | None -> assert false in + let p = interp_cpattern ist orig_gl t None in + let clr_t = + interp_clr (oclr,(tag_of_cpattern t,fst (redex_of_pattern env p)))in + (* if we are the index for the equation we do not clear *) + let clr_t = if deps = [] && eqid <> None then [] else clr_t in + let p = if is_undef_pat p then mkTpat gl inf_t else p in + loop (patterns @ [i, p, inf_t, occ]) + (clr_t @ clr) (i+1) (deps, inf_deps) + | [], c :: inf_deps -> + pp(lazy(str"adding inferred pattern " ++ pr_constr_pat c)); + loop (patterns @ [i, mkTpat gl c, c, allocc]) + clr (i+1) ([], inf_deps) + | _::_, [] -> errorstrm (str "Too many dependent abstractions") in + let deps, head_p, inf_deps_r = match what, elim_is_dep, cty with + | `EConstr _, _, None -> anomaly "Simple welim with no term" + | _, false, _ -> deps, [], inf_deps_r + | `EGen gen, true, None -> deps @ [gen], [], inf_deps_r + | _, true, Some (c, _, pc) -> + let occ = if occ = None then allocc else occ in + let inf_p, inf_deps_r = List.hd inf_deps_r, List.tl inf_deps_r in + deps, [1, pc, inf_p, occ], inf_deps_r in + let patterns, clr, gl = + loop [] orig_clr (List.length head_p+1) (List.rev deps, inf_deps_r) in + head_p @ patterns, Util.List.uniquize clr, gl + in + pp(lazy(pp_concat (str"patterns=") (List.map pp_pat patterns))); + pp(lazy(pp_concat (str"inf. patterns=") (List.map (pp_inf_pat gl) patterns))); + (* Predicate generation, and (if necessary) tactic to generalize the + * equation asked by the user *) + let elim_pred, gen_eq_tac, clr, gl = + let error gl t inf_t = errorstrm (str"The given pattern matches the term"++ + spc()++pp_term gl t++spc()++str"while the inferred pattern"++ + spc()++pr_constr_pat (fire_subst gl inf_t)++spc()++ str"doesn't") in + let match_or_postpone (cl, gl, post) (h, p, inf_t, occ) = + let p = unif_redex gl p inf_t in + if is_undef_pat p then + let () = pp(lazy(str"postponing " ++ pp_pattern p)) in + cl, gl, post @ [h, p, inf_t, occ] + else try + let c, cl, ucst = match_pat env p occ h cl in + let gl = pf_merge_uc ucst gl in + let gl = try pf_unify_HO gl inf_t c with _ -> error gl c inf_t in + cl, gl, post + with + | NoMatch | NoProgress -> + let e, ucst = redex_of_pattern env p in + let gl = pf_merge_uc ucst gl in + let n, e, _, _ucst = pf_abs_evars gl (fst p, e) in + let e, _, _, gl = pf_saturate ~beta:true gl e n in + let gl = try pf_unify_HO gl inf_t e with _ -> error gl e inf_t in + cl, gl, post + in + let rec match_all concl gl patterns = + let concl, gl, postponed = + List.fold_left match_or_postpone (concl, gl, []) patterns in + if postponed = [] then concl, gl + else if List.length postponed = List.length patterns then + errorstrm (str "Some patterns are undefined even after all"++spc()++ + str"the defined ones matched") + else match_all concl gl postponed in + let concl, gl = match_all concl gl patterns in + let pred_rctx, _ = decompose_prod_assum (fire_subst gl predty) in + let concl, gen_eq_tac, clr, gl = match eqid with + | Some (IpatId _) when not is_rec -> + let k = List.length deps in + let c = fire_subst gl (List.assoc (n_elim_args - k - 1) elim_args) in + let t = pf_type_of gl c in + let gen_eq_tac, gl = + let refl = mkApp (eq, [|t; c; c|]) in + let new_concl = mkArrow refl (lift 1 (pf_concl orig_gl)) in + let new_concl = fire_subst gl new_concl in + let erefl, gl = mkRefl t c gl in + let erefl = fire_subst gl erefl in + apply_type new_concl [erefl], gl in + let rel = k + if elim_is_dep then 1 else 0 in + let src, gl = mkProt mkProp (mkApp (eq,[|t; c; mkRel rel|])) gl in + let concl = mkArrow src (lift 1 concl) in + let clr = if deps <> [] then clr else [] in + concl, gen_eq_tac, clr, gl + | _ -> concl, tclIDTAC, clr, gl in + let mk_lam t r = mkLambda_or_LetIn r t in + let concl = List.fold_left mk_lam concl pred_rctx in + let gl, concl = + if eqid <> None && is_rec then + let concl, gl = mkProt (pf_type_of gl concl) concl gl in + let gl, _ = pf_e_type_of gl concl in + gl, concl + else gl, concl in + concl, gen_eq_tac, clr, gl in + let gl, pty = pf_e_type_of gl elim_pred in + pp(lazy(str"elim_pred=" ++ pp_term gl elim_pred)); + pp(lazy(str"elim_pred_ty=" ++ pp_term gl pty)); + let gl = pf_unify_HO gl pred elim_pred in + let elim = fire_subst gl elim in + let gl, _ = pf_e_type_of gl elim in + (* check that the patterns do not contain non instantiated dependent metas *) + let () = + let evars_of_term = Evarutil.undefined_evars_of_term (project gl) in + let patterns = List.map (fun (_,_,t,_) -> fire_subst gl t) patterns in + let patterns_ev = List.map evars_of_term patterns in + let ev = List.fold_left Intset.union Intset.empty patterns_ev in + let ty_ev = Intset.fold (fun i e -> + let ex = i in + let i_ty = Evd.evar_concl (Evd.find (project gl) ex) in + Intset.union e (evars_of_term i_ty)) + ev Intset.empty in + let inter = Intset.inter ev ty_ev in + if not (Intset.is_empty inter) then begin + let i = Intset.choose inter in + let pat = List.find (fun t -> Intset.mem i (evars_of_term t)) patterns in + errorstrm(str"Pattern"++spc()++pr_constr_pat pat++spc()++ + str"was not completely instantiated and one of its variables"++spc()++ + str"occurs in the type of another non instantieted pattern variable"); + end + in + (* the elim tactic, with the eliminator and the predicated we computed *) + let elim = project gl, elim in + let elim_tac gl = + tclTHENLIST [refine_with ~with_evars:false elim; cleartac clr] gl in + (* handling of following intro patterns and equation introduction if any *) + let elim_intro_tac gl = + let intro_eq = + match eqid with + | Some (IpatId ipat) when not is_rec -> + let rec intro_eq gl = match kind_of_type (pf_concl gl) with + | ProdType (_, src, tgt) -> + (match kind_of_type src with + | AtomicType (hd, _) when Term.eq_constr hd protectC -> + tclTHENLIST [unprotecttac; introid ipat] gl + | _ -> tclTHENLIST [ iD "IA"; introstac [IpatAnon]; intro_eq] gl) + |_ -> errorstrm (str "Too many names in intro pattern") in + intro_eq + | Some (IpatId ipat) -> + let name gl = mk_anon_id "K" gl in + let intro_lhs gl = + let elim_name = match orig_clr, what with + | [SsrHyp(_, x)], _ -> x + | _, `EConstr(_,_,t) when isVar t -> destVar t + | _ -> name gl in + if is_name_in_ipats elim_name ipats then introid (name gl) gl + else introid elim_name gl + in + let rec gen_eq_tac gl = + let concl = pf_concl gl in + let ctx, last = decompose_prod_assum concl in + let args = match kind_of_type last with + | AtomicType (hd, args) -> assert(Term.eq_constr hd protectC); args + | _ -> assert false in + let case = args.(Array.length args-1) in + if not(closed0 case) then tclTHEN (introstac [IpatAnon]) gen_eq_tac gl + else + let case_ty = pf_type_of gl case in + let refl = mkApp (eq, [|lift 1 case_ty; mkRel 1; lift 1 case|]) in + let new_concl = fire_subst gl + (mkProd (Name (name gl), case_ty, mkArrow refl (lift 2 concl))) in + let erefl, gl = mkRefl case_ty case gl in + let erefl = fire_subst gl erefl in + apply_type new_concl [case;erefl] gl in + tclTHENLIST [gen_eq_tac; intro_lhs; introid ipat] + | _ -> tclIDTAC in + let unprot = if eqid <> None && is_rec then unprotecttac else tclIDTAC in + tclEQINTROS ?ist elim_tac (tclTHENLIST [intro_eq; unprot]) ipats gl + in + tclTHENLIST [gen_eq_tac; elim_intro_tac] orig_gl +;; + +let simplest_newelim x= ssrelim ~is_case:false [] (`EConstr ([],None,x)) None [] +let simplest_newcase x= ssrelim ~is_case:true [] (`EConstr ([],None,x)) None [] +let _ = simplest_newcase_ref := simplest_newcase + +let check_casearg = function +| view, (_, (([_; gen :: _], _), _)) when view <> [] && has_occ gen -> + Errors.error "incompatible view and occurrence switch in dependent case tactic" +| arg -> arg + +ARGUMENT EXTEND ssrcasearg TYPED AS ssrarg PRINTED BY pr_ssrarg +| [ ssrarg(arg) ] -> [ check_casearg arg ] +END + +let ssrcasetac ist (view, (eqid, (dgens, ipats))) = + let ndefectcasetac view eqid ipats deps ((_, occ), _ as gen) ist gl = + let simple = (eqid = None && deps = [] && occ = None) in + let cl, c, clr, gl = pf_interp_gen ist gl true gen in + let _, vc, gl = + if view = [] then c, c, gl else pf_with_view ist gl (false, view) cl c in + if simple && is_injection_case vc gl then + tclTHENLIST [perform_injection vc; cleartac clr; introstac ~ist ipats] gl + else + (* macro for "case/v E: x" ---> "case E: x / (v x)" *) + let deps, clr, occ = + if view <> [] && eqid <> None && deps = [] then [gen], [], None + else deps, clr, occ in + ssrelim ~is_case:true ~ist deps (`EConstr (clr,occ, vc)) eqid ipats gl + in + with_dgens dgens (ndefectcasetac view eqid ipats) ist + +TACTIC EXTEND ssrcase +| [ "case" ssrcasearg(arg) ssrclauses(clauses) ] -> + [ Proofview.V82.tactic (tclCLAUSES ist (ssrcasetac ist arg) clauses) ] +| [ "case" ] -> [ Proofview.V82.tactic (with_top ssrscasetac) ] +END + +(** The "elim" tactic *) + +(* Elim views are elimination lemmas, so the eliminated term is not addded *) +(* to the dependent terms as for "case", unless it actually occurs in the *) +(* goal, the "all occurrences" {+} switch is used, or the equation switch *) +(* is used and there are no dependents. *) + +let ssrelimtac ist (view, (eqid, (dgens, ipats))) = + let ndefectelimtac view eqid ipats deps gen ist gl = + let elim = match view with [v] -> Some (snd(force_term ist gl v)) | _ -> None in + ssrelim ~ist deps (`EGen gen) ?elim eqid ipats gl + in + with_dgens dgens (ndefectelimtac view eqid ipats) ist + +TACTIC EXTEND ssrelim +| [ "elim" ssrarg(arg) ssrclauses(clauses) ] -> + [ Proofview.V82.tactic (tclCLAUSES ist (ssrelimtac ist arg) clauses) ] +| [ "elim" ] -> [ Proofview.V82.tactic (with_top simplest_newelim) ] +END + +(** 6. Backward chaining tactics: apply, exact, congr. *) + +(** The "apply" tactic *) + +let pr_agen (docc, dt) = pr_docc docc ++ pr_term dt +let pr_ssragen _ _ _ = pr_agen +let pr_ssragens _ _ _ = pr_dgens pr_agen + +ARGUMENT EXTEND ssragen TYPED AS ssrdocc * ssrterm PRINTED BY pr_ssragen +| [ "{" ne_ssrhyp_list(clr) "}" ssrterm(dt) ] -> [ mkclr clr, dt ] +| [ ssrterm(dt) ] -> [ nodocc, dt ] +END + +ARGUMENT EXTEND ssragens TYPED AS ssragen list list * ssrclear +PRINTED BY pr_ssragens +| [ "{" ne_ssrhyp_list(clr) "}" ssrterm(dt) ssragens(agens) ] -> + [ cons_gen (mkclr clr, dt) agens ] +| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ [[]], clr] +| [ ssrterm(dt) ssragens(agens) ] -> + [ cons_gen (nodocc, dt) agens ] +| [ ] -> [ [[]], [] ] +END + +let mk_applyarg views agens intros = views, (None, (agens, intros)) + +let pr_ssraarg _ _ _ (view, (eqid, (dgens, ipats))) = + let pri = pr_intros (gens_sep dgens) in + pr_view view ++ pr_eqid eqid ++ pr_dgens pr_agen dgens ++ pri ipats + +ARGUMENT EXTEND ssrapplyarg +TYPED AS ssrview * (ssreqid * (ssragens * ssrintros)) +PRINTED BY pr_ssraarg +| [ ":" ssragen(gen) ssragens(dgens) ssrintros(intros) ] -> + [ mk_applyarg [] (cons_gen gen dgens) intros ] +| [ ssrclear_ne(clr) ssrintros(intros) ] -> + [ mk_applyarg [] ([], clr) intros ] +| [ ssrintros_ne(intros) ] -> + [ mk_applyarg [] ([], []) intros ] +| [ ssrview(view) ":" ssragen(gen) ssragens(dgens) ssrintros(intros) ] -> + [ mk_applyarg view (cons_gen gen dgens) intros ] +| [ ssrview(view) ssrclear(clr) ssrintros(intros) ] -> + [ mk_applyarg view ([], clr) intros ] +END + +let interp_agen ist gl ((goclr, _), (k, gc)) (clr, rcs) = +(* pp(lazy(str"sigma@interp_agen=" ++ pr_evar_map None (project gl))); *) + let rc = glob_constr ist (pf_env gl) gc in + let rcs' = rc :: rcs in + match goclr with + | None -> clr, rcs' + | Some ghyps -> + let clr' = snd (interp_hyps ist gl ghyps) @ clr in + if k <> ' ' then clr', rcs' else + match rc with + | GVar (loc, id) when not_section_id id -> SsrHyp (loc, id) :: clr', rcs' + | GRef (loc, VarRef id, _) when not_section_id id -> + SsrHyp (loc, id) :: clr', rcs' + | _ -> clr', rcs' + +let interp_agens ist gl gagens = + match List.fold_right (interp_agen ist gl) gagens ([], []) with + | clr, rlemma :: args -> + let n = interp_nbargs ist gl rlemma - List.length args in + let rec loop i = + if i > n then + errorstrm (str "Cannot apply lemma " ++ pf_pr_glob_constr gl rlemma) + else + try interp_refine ist gl (mkRApp rlemma (mkRHoles i @ args)) + with _ -> loop (i + 1) in + clr, loop 0 + | _ -> assert false + +let apply_rconstr ?ist t gl = +(* pp(lazy(str"sigma@apply_rconstr=" ++ pr_evar_map None (project gl))); *) + let n = match ist, t with + | None, (GVar (_, id) | GRef (_, VarRef id,_)) -> pf_nbargs gl (mkVar id) + | Some ist, _ -> interp_nbargs ist gl t + | _ -> anomaly "apply_rconstr without ist and not RVar" in + let mkRlemma i = mkRApp t (mkRHoles i) in + let cl = pf_concl gl in + let rec loop i = + if i > n then + errorstrm (str"Cannot apply lemma "++pf_pr_glob_constr gl t) + else try pf_match gl (mkRlemma i) (OfType cl) with _ -> loop (i + 1) in + refine_with (loop 0) gl + +let mkRAppView ist gl rv gv = + let nb_view_imps = interp_view_nbimps ist gl rv in + mkRApp rv (mkRHoles (abs nb_view_imps)) + +let prof_apply_interp_with = mk_profiler "ssrapplytac.interp_with";; + +let refine_interp_apply_view i ist gl gv = + let pair i = List.map (fun x -> i, x) in + let rv = pf_intern_term ist gl gv in + let v = mkRAppView ist gl rv gv in + let interp_with (i, hint) = + interp_refine ist gl (mkRApp hint (v :: mkRHoles i)) in + let interp_with x = prof_apply_interp_with.profile interp_with x in + let rec loop = function + | [] -> (try apply_rconstr ~ist rv gl with _ -> view_error "apply" gv) + | h :: hs -> (try refine_with (snd (interp_with h)) gl with _ -> loop hs) in + loop (pair i viewtab.(i) @ if i = 2 then pair 1 viewtab.(1) else []) + +let apply_top_tac gl = + tclTHENLIST [introid top_id; apply_rconstr (mkRVar top_id); clear [top_id]] gl + +let inner_ssrapplytac gviews ggenl gclr ist gl = + let _, clr = interp_hyps ist gl gclr in + let vtac gv i gl' = refine_interp_apply_view i ist gl' gv in + let ggenl, tclGENTAC = + if gviews <> [] && ggenl <> [] then + let ggenl= List.map (fun (x,g) -> x, cpattern_of_term g) (List.hd ggenl) in + [], tclTHEN (genstac (ggenl,[]) ist) + else ggenl, tclTHEN tclIDTAC in + tclGENTAC (fun gl -> + match gviews, ggenl with + | v :: tl, [] -> + let dbl = if List.length tl = 1 then 2 else 1 in + tclTHEN + (List.fold_left (fun acc v -> tclTHENLAST acc (vtac v dbl)) (vtac v 1) tl) + (cleartac clr) gl + | [], [agens] -> + let clr', (sigma, lemma) = interp_agens ist gl agens in + let gl = pf_merge_uc_of sigma gl in + tclTHENLIST [cleartac clr; refine_with ~beta:true lemma; cleartac clr'] gl + | _, _ -> tclTHEN apply_top_tac (cleartac clr) gl) gl + +let ssrapplytac ist (views, (_, ((gens, clr), intros))) = + tclINTROS ist (inner_ssrapplytac views gens clr) intros + +TACTIC EXTEND ssrapply +| [ "apply" ssrapplyarg(arg) ] -> [ Proofview.V82.tactic (ssrapplytac ist arg) ] +| [ "apply" ] -> [ Proofview.V82.tactic apply_top_tac ] +END + +(** The "exact" tactic *) + +let mk_exactarg views dgens = mk_applyarg views dgens [] + +ARGUMENT EXTEND ssrexactarg TYPED AS ssrapplyarg PRINTED BY pr_ssraarg +| [ ":" ssragen(gen) ssragens(dgens) ] -> + [ mk_exactarg [] (cons_gen gen dgens) ] +| [ ssrview(view) ssrclear(clr) ] -> + [ mk_exactarg view ([], clr) ] +| [ ssrclear_ne(clr) ] -> + [ mk_exactarg [] ([], clr) ] +END + +let vmexacttac pf gl = exact_no_check (mkCast (pf, VMcast, pf_concl gl)) gl + +TACTIC EXTEND ssrexact +| [ "exact" ssrexactarg(arg) ] -> [ Proofview.V82.tactic (tclBY (ssrapplytac ist arg)) ] +| [ "exact" ] -> [ Proofview.V82.tactic (tclORELSE donetac (tclBY apply_top_tac)) ] +| [ "exact" "<:" lconstr(pf) ] -> [ Proofview.V82.tactic (vmexacttac pf) ] +END + +(** The "congr" tactic *) + +(* type ssrcongrarg = open_constr * (int * constr) *) + +let pr_ssrcongrarg _ _ _ ((n, f), dgens) = + (if n <= 0 then mt () else str " " ++ int n) ++ + str " " ++ pr_term f ++ pr_dgens pr_gen dgens + +ARGUMENT EXTEND ssrcongrarg TYPED AS (int * ssrterm) * ssrdgens + PRINTED BY pr_ssrcongrarg +| [ natural(n) constr(c) ssrdgens(dgens) ] -> [ (n, mk_term ' ' c), dgens ] +| [ natural(n) constr(c) ] -> [ (n, mk_term ' ' c),([[]],[]) ] +| [ constr(c) ssrdgens(dgens) ] -> [ (0, mk_term ' ' c), dgens ] +| [ constr(c) ] -> [ (0, mk_term ' ' c), ([[]],[]) ] +END + +let rec mkRnat n = + if n <= 0 then GRef (dummy_loc, glob_O, None) else + mkRApp (GRef (dummy_loc, glob_S, None)) [mkRnat (n - 1)] + +let interp_congrarg_at ist gl n rf ty m = + pp(lazy(str"===interp_congrarg_at===")); + let congrn, _ = mkSsrRRef "nary_congruence" in + let args1 = mkRnat n :: mkRHoles n @ [ty] in + let args2 = mkRHoles (3 * n) in + let rec loop i = + if i + n > m then None else + try + let rt = mkRApp congrn (args1 @ mkRApp rf (mkRHoles i) :: args2) in + pp(lazy(str"rt=" ++ pr_glob_constr rt)); + Some (interp_refine ist gl rt) + with _ -> loop (i + 1) in + loop 0 + +let pattern_id = mk_internal_id "pattern value" + +let congrtac ((n, t), ty) ist gl = + pp(lazy(str"===congr===")); + pp(lazy(str"concl=" ++ pr_constr (pf_concl gl))); + let sigma, _ as it = interp_term ist gl t in + let gl = pf_merge_uc_of sigma gl in + let _, f, _, _ucst = pf_abs_evars gl it in + let ist' = {ist with lfun = + Id.Map.add pattern_id (Value.of_constr f) Id.Map.empty } in + let rf = mkRltacVar pattern_id in + let m = pf_nbargs gl f in + let _, cf = if n > 0 then + match interp_congrarg_at ist' gl n rf ty m with + | Some cf -> cf + | None -> errorstrm (str "No " ++ int n ++ str "-congruence with " + ++ pr_term t) + else let rec loop i = + if i > m then errorstrm (str "No congruence with " ++ pr_term t) + else match interp_congrarg_at ist' gl i rf ty m with + | Some cf -> cf + | None -> loop (i + 1) in + loop 1 in + tclTHEN (refine_with cf) (tclTRY (Proofview.V82.of_tactic reflexivity)) gl + +let newssrcongrtac arg ist gl = + pp(lazy(str"===newcongr===")); + pp(lazy(str"concl=" ++ pr_constr (pf_concl gl))); + (* utils *) + let fs gl t = Reductionops.nf_evar (project gl) t in + let tclMATCH_GOAL (c, gl_c) proj t_ok t_fail gl = + match try Some (pf_unify_HO gl_c (pf_concl gl) c) with _ -> None with + | Some gl_c -> + tclTHEN (Proofview.V82.of_tactic (convert_concl (fs gl_c c))) + (t_ok (proj gl_c)) gl + | None -> t_fail () gl in + let mk_evar gl ty = + let env, sigma, si = pf_env gl, project gl, sig_it gl in + let sigma, x = Evarutil.new_evar env (create_evar_defs sigma) ty in + x, re_sig si sigma in + let arr, gl = pf_mkSsrConst "ssr_congr_arrow" gl in + let ssr_congr lr = mkApp (arr, lr) in + (* here thw two cases: simple equality or arrow *) + let equality, _, eq_args, gl' = + let eq, gl = pf_fresh_global (build_coq_eq ()) gl in + pf_saturate gl eq 3 in + tclMATCH_GOAL (equality, gl') (fun gl' -> fs gl' (List.assoc 0 eq_args)) + (fun ty -> congrtac (arg, Detyping.detype false [] (pf_env gl) (project gl) ty) ist) + (fun () -> + let lhs, gl' = mk_evar gl mkProp in let rhs, gl' = mk_evar gl' mkProp in + let arrow = mkArrow lhs (lift 1 rhs) in + tclMATCH_GOAL (arrow, gl') (fun gl' -> [|fs gl' lhs;fs gl' rhs|]) + (fun lr -> tclTHEN (Proofview.V82.of_tactic (apply (ssr_congr lr))) (congrtac (arg, mkRType) ist)) + (fun _ _ -> errorstrm (str"Conclusion is not an equality nor an arrow"))) + gl +;; + +TACTIC EXTEND ssrcongr +| [ "congr" ssrcongrarg(arg) ] -> +[ let arg, dgens = arg in + Proofview.V82.tactic begin + match dgens with + | [gens], clr -> tclTHEN (genstac (gens,clr) ist) (newssrcongrtac arg ist) + | _ -> errorstrm (str"Dependent family abstractions not allowed in congr") + end] +END + +(** 7. Rewriting tactics (rewrite, unlock) *) + +(** Coq rewrite compatibility flag *) + +let ssr_strict_match = ref false + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optname = "strict redex matching"; + Goptions.optkey = ["Match"; "Strict"]; + Goptions.optread = (fun () -> !ssr_strict_match); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> ssr_strict_match := b) } + +(** Rewrite multiplier *) + +type ssrmult = int * ssrmmod + +let notimes = 0 +let nomult = 1, Once + +let pr_mult (n, m) = + if n > 0 && m <> Once then int n ++ pr_mmod m else pr_mmod m + +let pr_ssrmult _ _ _ = pr_mult + +ARGUMENT EXTEND ssrmult_ne TYPED AS int * ssrmmod PRINTED BY pr_ssrmult + | [ natural(n) ssrmmod(m) ] -> [ check_index loc n, m ] + | [ ssrmmod(m) ] -> [ notimes, m ] +END + +ARGUMENT EXTEND ssrmult TYPED AS ssrmult_ne PRINTED BY pr_ssrmult + | [ ssrmult_ne(m) ] -> [ m ] + | [ ] -> [ nomult ] +END + +(** Rewrite clear/occ switches *) + +let pr_rwocc = function + | None, None -> mt () + | None, occ -> pr_occ occ + | Some clr, _ -> pr_clear_ne clr + +let pr_ssrrwocc _ _ _ = pr_rwocc + +ARGUMENT EXTEND ssrrwocc TYPED AS ssrdocc PRINTED BY pr_ssrrwocc +| [ "{" ssrhyp_list(clr) "}" ] -> [ mkclr clr ] +| [ "{" ssrocc(occ) "}" ] -> [ mkocc occ ] +| [ ] -> [ noclr ] +END + +(** Rewrite rules *) + +type ssrwkind = RWred of ssrsimpl | RWdef | RWeq +(* type ssrrule = ssrwkind * ssrterm *) + +let pr_rwkind = function + | RWred s -> pr_simpl s + | RWdef -> str "/" + | RWeq -> mt () + +let wit_ssrrwkind = add_genarg "ssrrwkind" pr_rwkind + +let pr_rule = function + | RWred s, _ -> pr_simpl s + | RWdef, r-> str "/" ++ pr_term r + | RWeq, r -> pr_term r + +let pr_ssrrule _ _ _ = pr_rule + +let noruleterm loc = mk_term ' ' (mkCProp loc) + +ARGUMENT EXTEND ssrrule_ne TYPED AS ssrrwkind * ssrterm PRINTED BY pr_ssrrule + | [ ssrsimpl_ne(s) ] -> [ RWred s, noruleterm loc ] + | [ "/" ssrterm(t) ] -> [ RWdef, t ] + | [ ssrterm(t) ] -> [ RWeq, t ] +END + +ARGUMENT EXTEND ssrrule TYPED AS ssrrule_ne PRINTED BY pr_ssrrule + | [ ssrrule_ne(r) ] -> [ r ] + | [ ] -> [ RWred Nop, noruleterm loc ] +END + +(** Rewrite arguments *) + +(* type ssrrwarg = (ssrdir * ssrmult) * ((ssrdocc * ssrpattern) * ssrrule) *) + +let pr_option f = function None -> mt() | Some x -> f x +let pr_pattern_squarep= pr_option (fun r -> str "[" ++ pr_rpattern r ++ str "]") +let pr_ssrpattern_squarep _ _ _ = pr_pattern_squarep +let pr_rwarg ((d, m), ((docc, rx), r)) = + pr_rwdir d ++ pr_mult m ++ pr_rwocc docc ++ pr_pattern_squarep rx ++ pr_rule r + +let pr_ssrrwarg _ _ _ = pr_rwarg + +let mk_rwarg (d, (n, _ as m)) ((clr, occ as docc), rx) (rt, _ as r) = + if rt <> RWeq then begin + if rt = RWred Nop && not (m = nomult && occ = None && rx = None) + && (clr = None || clr = Some []) then + anomaly "Improper rewrite clear switch"; + if d = R2L && rt <> RWdef then + Errors.error "Right-to-left switch on simplification"; + if n <> 1 && rt = RWred Cut then + Errors.error "Bad or useless multiplier"; + if occ <> None && rx = None && rt <> RWdef then + Errors.error "Missing redex for simplification occurrence" + end; (d, m), ((docc, rx), r) + +let norwmult = L2R, nomult +let norwocc = noclr, None + +(* +let pattern_ident = Prim.pattern_ident in +GEXTEND Gram +GLOBAL: pattern_ident; +pattern_ident: +[[c = pattern_ident -> (CRef (Ident (loc,c)), NoBindings)]]; +END +*) + +ARGUMENT EXTEND ssrpattern_squarep +TYPED AS rpattern option PRINTED BY pr_ssrpattern_squarep + | [ "[" rpattern(rdx) "]" ] -> [ Some rdx ] + | [ ] -> [ None ] +END + +ARGUMENT EXTEND ssrpattern_ne_squarep +TYPED AS rpattern option PRINTED BY pr_ssrpattern_squarep + | [ "[" rpattern(rdx) "]" ] -> [ Some rdx ] +END + + +ARGUMENT EXTEND ssrrwarg + TYPED AS (ssrdir * ssrmult) * ((ssrdocc * rpattern option) * ssrrule) + PRINTED BY pr_ssrrwarg + | [ "-" ssrmult(m) ssrrwocc(docc) ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg (R2L, m) (docc, rx) r ] + | [ "-/" ssrterm(t) ] -> (* just in case '-/' should become a token *) + [ mk_rwarg (R2L, nomult) norwocc (RWdef, t) ] + | [ ssrmult_ne(m) ssrrwocc(docc) ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg (L2R, m) (docc, rx) r ] + | [ "{" ne_ssrhyp_list(clr) "}" ssrpattern_ne_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (mkclr clr, rx) r ] + | [ "{" ne_ssrhyp_list(clr) "}" ssrrule(r) ] -> + [ mk_rwarg norwmult (mkclr clr, None) r ] + | [ "{" ssrocc(occ) "}" ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (mkocc occ, rx) r ] + | [ "{" "}" ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (nodocc, rx) r ] + | [ ssrpattern_ne_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (noclr, rx) r ] + | [ ssrrule_ne(r) ] -> + [ mk_rwarg norwmult norwocc r ] +END + +let simplintac occ rdx sim gl = + let simptac gl = + let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let simp env c _ _ = red_safe Tacred.simpl env sigma0 c in + Proofview.V82.of_tactic + (convert_concl_no_check (eval_pattern env0 sigma0 concl0 rdx occ simp)) + gl in + match sim with + | Simpl -> simptac gl + | SimplCut -> tclTHEN simptac (tclTRY donetac) gl + | _ -> simpltac sim gl + +let rec get_evalref c = match kind_of_term c with + | Var id -> EvalVarRef id + | Const (k,_) -> EvalConstRef k + | App (c', _) -> get_evalref c' + | Cast (c', _, _) -> get_evalref c' + | _ -> errorstrm (str "The term " ++ pr_constr c ++ str " is not unfoldable") + +(* Strip a pattern generated by a prenex implicit to its constant. *) +let strip_unfold_term ((sigma, t) as p) kt = match kind_of_term t with + | App (f, a) when kt = ' ' && Array.for_all isEvar a && isConst f -> + (sigma, f), true + | Const _ | Var _ -> p, true + | _ -> p, false + +let unfoldintac occ rdx t (kt,_) gl = + let fs sigma x = Reductionops.nf_evar sigma x in + let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let (sigma, t), const = strip_unfold_term t kt in + let body env t c = + Tacred.unfoldn [OnlyOccurrences [1], get_evalref t] env sigma0 c in + let easy = occ = None && rdx = None in + let red_flags = if easy then Closure.betaiotazeta else Closure.betaiota in + let beta env = Reductionops.clos_norm_flags red_flags env sigma0 in + let unfold, conclude = match rdx with + | Some (_, (In_T _ | In_X_In_T _)) | None -> + let ise = create_evar_defs sigma in + let ise, u = mk_tpattern env0 sigma0 (ise,t) all_ok L2R t in + let find_T, end_T = + mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[u]) in + (fun env c _ h -> + try find_T env c h (fun env c _ _ -> body env t c) + with NoMatch when easy -> c + | NoMatch | NoProgress -> errorstrm (str"No occurrence of " + ++ pr_constr_pat t ++ spc() ++ str "in " ++ pr_constr c)), + (fun () -> try end_T () with + | NoMatch when easy -> fake_pmatcher_end () + | NoMatch -> anomaly "unfoldintac") + | _ -> + (fun env (c as orig_c) _ h -> + if const then + let rec aux c = + match kind_of_term c with + | Const _ when Term.eq_constr c t -> body env t t + | App (f,a) when Term.eq_constr f t -> mkApp (body env f f,a) + | _ -> let c = Reductionops.whd_betaiotazeta sigma0 c in + match kind_of_term c with + | Const _ when Term.eq_constr c t -> body env t t + | App (f,a) when Term.eq_constr f t -> mkApp (body env f f,a) + | Const f -> aux (body env c c) + | App (f, a) -> aux (mkApp (body env f f, a)) + | _ -> errorstrm (str "The term "++pr_constr orig_c++ + str" contains no " ++ pr_constr t ++ str" even after unfolding") + in aux c + else + try body env t (fs (unify_HO env sigma c t) t) + with _ -> errorstrm (str "The term " ++ + pr_constr c ++spc()++ str "does not unify with " ++ pr_constr_pat t)), + fake_pmatcher_end in + let concl = + try beta env0 (eval_pattern env0 sigma0 concl0 rdx occ unfold) + with Option.IsNone -> errorstrm (str"Failed to unfold " ++ pr_constr_pat t) in + let _ = conclude () in + Proofview.V82.of_tactic (convert_concl concl) gl +;; + +let foldtac occ rdx ft gl = + let fs sigma x = Reductionops.nf_evar sigma x in + let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let sigma, t = ft in + let fold, conclude = match rdx with + | Some (_, (In_T _ | In_X_In_T _)) | None -> + let ise = create_evar_defs sigma in + let ut = red_product_skip_id env0 sigma t in + let ise, ut = mk_tpattern env0 sigma0 (ise,t) all_ok L2R ut in + let find_T, end_T = + mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[ut]) in + (fun env c _ h -> try find_T env c h (fun env t _ _ -> t) with NoMatch ->c), + (fun () -> try end_T () with NoMatch -> fake_pmatcher_end ()) + | _ -> + (fun env c _ h -> try let sigma = unify_HO env sigma c t in fs sigma t + with _ -> errorstrm (str "fold pattern " ++ pr_constr_pat t ++ spc () + ++ str "does not match redex " ++ pr_constr_pat c)), + fake_pmatcher_end in + let concl = eval_pattern env0 sigma0 concl0 rdx occ fold in + let _ = conclude () in + Proofview.V82.of_tactic (convert_concl concl) gl +;; + +let converse_dir = function L2R -> R2L | R2L -> L2R + +let rw_progress rhs lhs ise = not (Term.eq_constr lhs (Evarutil.nf_evar ise rhs)) + +(* Coq has a more general form of "equation" (any type with a single *) +(* constructor with no arguments with_rect_r elimination lemmas). *) +(* However there is no clear way of determining the LHS and RHS of *) +(* such a generic Leibnitz equation -- short of inspecting the type *) +(* of the elimination lemmas. *) + +let rec strip_prod_assum c = match kind_of_term c with + | Prod (_, _, c') -> strip_prod_assum c' + | LetIn (_, v, _, c') -> strip_prod_assum (subst1 v c) + | Cast (c', _, _) -> strip_prod_assum c' + | _ -> c + +let rule_id = mk_internal_id "rewrite rule" + +exception PRtype_error +exception PRindetermined_rhs of constr + +let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = +(* pp(lazy(str"sigma@pirrel_rewrite=" ++ pr_evar_map None sigma)); *) + let env = pf_env gl in + let beta = Reductionops.clos_norm_flags Closure.beta env sigma in + let sigma, p = + let sigma = create_evar_defs sigma in + Evarutil.new_evar env sigma (beta (subst1 new_rdx pred)) in + let pred = mkNamedLambda pattern_id rdx_ty pred in + let elim, gl = + let ((kn, i) as ind, _), unfolded_c_ty = pf_reduce_to_quantified_ind gl c_ty in + let sort = elimination_sort_of_goal gl in + let elim, gl = pf_fresh_global (Indrec.lookup_eliminator ind sort) gl in + if dir = R2L then elim, gl else (* taken from Coq's rewrite *) + let elim, _ = destConst elim in + let mp,dp,l = repr_con (constant_of_kn (canonical_con elim)) in + let l' = label_of_id (Nameops.add_suffix (id_of_label l) "_r") in + let c1' = Global.constant_of_delta_kn (canonical_con (make_con mp dp l')) in + mkConst c1', gl in + let proof = mkApp (elim, [| rdx_ty; new_rdx; pred; p; rdx; c |]) in + (* We check the proof is well typed *) + let sigma, proof_ty = + try Typing.e_type_of env sigma proof with _ -> raise PRtype_error in + pp(lazy(str"pirrel_rewrite proof term of type: " ++ pr_constr proof_ty)); + try refine_with + ~first_goes_last:(not !ssroldreworder) ~with_evars:false (sigma, proof) gl + with _ -> + (* we generate a msg like: "Unable to find an instance for the variable" *) + let c = Reductionops.nf_evar sigma c in + let hd_ty, miss = match kind_of_term c with + | App (hd, args) -> + let hd_ty = Retyping.get_type_of env sigma hd in + let names = let rec aux t = function 0 -> [] | n -> + let t = Reductionops.whd_betadeltaiota env sigma t in + match kind_of_type t with + | ProdType (name, _, t) -> name :: aux t (n-1) + | _ -> assert false in aux hd_ty (Array.length args) in + hd_ty, Util.List.map_filter (fun (t, name) -> + let evs = Intset.elements (Evarutil.undefined_evars_of_term sigma t) in + let open_evs = List.filter (fun k -> + InProp <> Retyping.get_sort_family_of + env sigma (Evd.evar_concl (Evd.find sigma k))) + evs in + if open_evs <> [] then Some name else None) + (List.combine (Array.to_list args) names) + | _ -> anomaly "rewrite rule not an application" in + errorstrm (Himsg.explain_refiner_error (Logic.UnresolvedBindings miss)++ + (Pp.fnl()++str"Rule's type:" ++ spc() ++ pr_constr hd_ty)) +;; + +let is_const_ref c r = isConst c && eq_gr (ConstRef (fst(destConst c))) r +let is_construct_ref c r = + isConstruct c && eq_gr (ConstructRef (fst(destConstruct c))) r +let is_ind_ref c r = isInd c && eq_gr (IndRef (fst(destInd c))) r + +let rwcltac cl rdx dir sr gl = + let n, r_n,_, ucst = pf_abs_evars gl sr in + let r_n' = pf_abs_cterm gl n r_n in + let r' = subst_var pattern_id r_n' in + let gl = pf_merge_uc ucst gl in + let rdxt = Retyping.get_type_of (pf_env gl) (fst sr) rdx in +(* pp(lazy(str"sigma@rwcltac=" ++ pr_evar_map None (fst sr))); *) + pp(lazy(str"r@rwcltac=" ++ pr_constr (snd sr))); + let cvtac, rwtac, gl = + if closed0 r' then + let env, sigma, c, c_eq = pf_env gl, fst sr, snd sr, build_coq_eq () in + let sigma, c_ty = Typing.e_type_of env sigma c in + pp(lazy(str"c_ty@rwcltac=" ++ pr_constr c_ty)); + match kind_of_type (Reductionops.whd_betadeltaiota env sigma c_ty) with + | AtomicType(e, a) when is_ind_ref e c_eq -> + let new_rdx = if dir = L2R then a.(2) else a.(1) in + pirrel_rewrite cl rdx rdxt new_rdx dir (sigma,c) c_ty, tclIDTAC, gl + | _ -> + let cl' = mkApp (mkNamedLambda pattern_id rdxt cl, [|rdx|]) in + let sigma, _ = Typing.e_type_of env sigma cl' in + let gl = pf_merge_uc_of sigma gl in + Proofview.V82.of_tactic (convert_concl cl'), rewritetac dir r', gl + else + let dc, r2 = decompose_lam_n n r' in + let r3, _, r3t = + try destCast r2 with _ -> + errorstrm (str "no cast from " ++ pr_constr_pat (snd sr) + ++ str " to " ++ pr_constr r2) in + let cl' = mkNamedProd rule_id (compose_prod dc r3t) (lift 1 cl) in + let cl'' = mkNamedProd pattern_id rdxt cl' in + let itacs = [introid pattern_id; introid rule_id] in + let cltac = clear [pattern_id; rule_id] in + let rwtacs = [rewritetac dir (mkVar rule_id); cltac] in + apply_type cl'' [rdx; compose_lam dc r3], tclTHENLIST (itacs @ rwtacs), gl + in + let cvtac' _ = + try cvtac gl with + | PRtype_error -> + if occur_existential (pf_concl gl) + then errorstrm (str "Rewriting impacts evars") + else errorstrm (str "Dependent type error in rewrite of " + ++ pf_pr_constr gl (project gl) (mkNamedLambda pattern_id rdxt cl)) + | Errors.UserError _ as e -> raise e + | e -> anomaly ("cvtac's exception: " ^ Printexc.to_string e); + in + tclTHEN cvtac' rwtac gl + +let prof_rwcltac = mk_profiler "rwrxtac.rwcltac";; +let rwcltac cl rdx dir sr gl = + prof_rwcltac.profile (rwcltac cl rdx dir sr) gl +;; + + +let lz_coq_prod = + let prod = lazy (build_prod ()) in fun () -> Lazy.force prod + +let lz_setoid_relation = + let sdir = ["Classes"; "RelationClasses"] in + let last_srel = ref (Environ.empty_env, None) in + fun env -> match !last_srel with + | env', srel when env' == env -> srel + | _ -> + let srel = + try Some (coq_constant "Class_setoid" sdir "RewriteRelation") + with _ -> None in + last_srel := (env, srel); srel + +let ssr_is_setoid env = + match lz_setoid_relation env with + | None -> fun _ _ _ -> false + | Some srel -> + fun sigma r args -> + Rewrite.is_applied_rewrite_relation env + sigma [] (mkApp (r, args)) <> None + +let prof_rwxrtac_find_rule = mk_profiler "rwrxtac.find_rule";; + +let closed0_check cl p gl = + if closed0 cl then + errorstrm (str"No occurrence of redex "++pf_pr_constr gl (project gl) p) + +let rwprocess_rule dir rule gl = + let env = pf_env gl in + let coq_prod = lz_coq_prod () in + let is_setoid = ssr_is_setoid env in + let r_sigma, rules = + let rec loop d sigma r t0 rs red = + let t = + if red = 1 then Tacred.hnf_constr env sigma t0 + else Reductionops.whd_betaiotazeta sigma t0 in + pp(lazy(str"rewrule="++pr_constr t)); + match kind_of_term t with + | Prod (_, xt, at) -> + let ise, x = Evarutil.new_evar env (create_evar_defs sigma) xt in + loop d ise (mkApp (r, [|x|])) (subst1 x at) rs 0 + | App (pr, a) when is_ind_ref pr coq_prod.Coqlib.typ -> + let sr sigma = match kind_of_term (Tacred.hnf_constr env sigma r) with + | App (c, ra) when is_construct_ref c coq_prod.Coqlib.intro -> + fun i -> ra.(i + 1), sigma + | _ -> let ra = Array.append a [|r|] in + function 1 -> + let sigma, pi1 = Evd.fresh_global env sigma coq_prod.Coqlib.proj1 in + mkApp (pi1, ra), sigma + | _ -> + let sigma, pi2 = Evd.fresh_global env sigma coq_prod.Coqlib.proj2 in + mkApp (pi2, ra), sigma in + if Term.eq_constr a.(0) (build_coq_True ()) then + let s, sigma = sr sigma 2 in + loop (converse_dir d) sigma s a.(1) rs 0 + else + let s, sigma = sr sigma 2 in + let sigma, rs2 = loop d sigma s a.(1) rs 0 in + let s, sigma = sr sigma 1 in + loop d sigma s a.(0) rs2 0 + | App (r_eq, a) when Hipattern.match_with_equality_type t != None -> + let indu = destInd r_eq and rhs = Array.last a in + let np = Inductiveops.inductive_nparamdecls (fst indu) in + let ind_ct = Inductiveops.type_of_constructors env indu in + let lhs0 = last_arg (strip_prod_assum ind_ct.(0)) in + let rdesc = match kind_of_term lhs0 with + | Rel i -> + let lhs = a.(np - i) in + let lhs, rhs = if d = L2R then lhs, rhs else rhs, lhs in +(* msgnl (str "RW: " ++ pr_rwdir d ++ str " " ++ pr_constr_pat r ++ str " : " + ++ pr_constr_pat lhs ++ str " ~> " ++ pr_constr_pat rhs); *) + d, r, lhs, rhs +(* + let l_i, r_i = if d = L2R then i, 1 - ndep else 1 - ndep, i in + let lhs = a.(np - l_i) and rhs = a.(np - r_i) in + let a' = Array.copy a in let _ = a'.(np - l_i) <- mkVar pattern_id in + let r' = mkCast (r, DEFAULTcast, mkApp (r_eq, a')) in + (d, r', lhs, rhs) +*) + | _ -> + let lhs = substl (array_list_of_tl (Array.sub a 0 np)) lhs0 in + let lhs, rhs = if d = R2L then lhs, rhs else rhs, lhs in + let d' = if Array.length a = 1 then d else converse_dir d in + d', r, lhs, rhs in + sigma, rdesc :: rs + | App (s_eq, a) when is_setoid sigma s_eq a -> + let np = Array.length a and i = 3 - dir_org d in + let lhs = a.(np - i) and rhs = a.(np + i - 3) in + let a' = Array.copy a in let _ = a'.(np - i) <- mkVar pattern_id in + let r' = mkCast (r, DEFAULTcast, mkApp (s_eq, a')) in + sigma, (d, r', lhs, rhs) :: rs + | _ -> + if red = 0 then loop d sigma r t rs 1 + else errorstrm (str "not a rewritable relation: " ++ pr_constr_pat t + ++ spc() ++ str "in rule " ++ pr_constr_pat (snd rule)) + in + let sigma, r = rule in + let t = Retyping.get_type_of env sigma r in + loop dir sigma r t [] 0 + in + r_sigma, rules + +let rwrxtac occ rdx_pat dir rule gl = + let env = pf_env gl in + let r_sigma, rules = rwprocess_rule dir rule gl in + let find_rule rdx = + let rec rwtac = function + | [] -> + errorstrm (str "pattern " ++ pr_constr_pat rdx ++ + str " does not match " ++ pr_dir_side dir ++ + str " of " ++ pr_constr_pat (snd rule)) + | (d, r, lhs, rhs) :: rs -> + try + let ise = unify_HO env (create_evar_defs r_sigma) lhs rdx in + if not (rw_progress rhs rdx ise) then raise NoMatch else + d, (ise, Evd.evar_universe_context ise, Reductionops.nf_evar ise r) + with _ -> rwtac rs in + rwtac rules in + let find_rule rdx = prof_rwxrtac_find_rule.profile find_rule rdx in + let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in + let find_R, conclude = match rdx_pat with + | Some (_, (In_T _ | In_X_In_T _)) | None -> + let upats_origin = dir, snd rule in + let rpat env sigma0 (sigma, pats) (d, r, lhs, rhs) = + let sigma, pat = + mk_tpattern env sigma0 (sigma,r) (rw_progress rhs) d lhs in + sigma, pats @ [pat] in + let rpats = List.fold_left (rpat env0 sigma0) (r_sigma,[]) rules in + let find_R, end_R = mk_tpattern_matcher sigma0 occ ~upats_origin rpats in + (fun e c _ i -> find_R ~k:(fun _ _ _ h -> mkRel h) e c i), + fun cl -> let rdx,d,r = end_R () in closed0_check cl rdx gl; (d,r),rdx + | Some(_, (T e | X_In_T (_,e) | E_As_X_In_T (e,_,_) | E_In_X_In_T (e,_,_))) -> + let r = ref None in + (fun env c _ h -> do_once r (fun () -> find_rule c, c); mkRel h), + (fun concl -> closed0_check concl e gl; assert_done r) in + let concl = eval_pattern env0 sigma0 concl0 rdx_pat occ find_R in + let (d, r), rdx = conclude concl in + let r = Evd.merge_universe_context (pi1 r) (pi2 r), pi3 r in + rwcltac concl rdx d r gl +;; + +let prof_rwxrtac = mk_profiler "rwrxtac";; +let rwrxtac occ rdx_pat dir rule gl = + prof_rwxrtac.profile (rwrxtac occ rdx_pat dir rule) gl +;; + +let ssrinstancesofrule ist dir arg gl = + let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in + let rule = interp_term ist gl arg in + let r_sigma, rules = rwprocess_rule dir rule gl in + let find, conclude = + let upats_origin = dir, snd rule in + let rpat env sigma0 (sigma, pats) (d, r, lhs, rhs) = + let sigma, pat = + mk_tpattern env sigma0 (sigma,r) (rw_progress rhs) d lhs in + sigma, pats @ [pat] in + let rpats = List.fold_left (rpat env0 sigma0) (r_sigma,[]) rules in + mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true sigma0 None ~upats_origin rpats in + let print env p c _ = ppnl (hov 1 (str"instance:" ++ spc() ++ pr_constr p ++ spc() ++ str "matches:" ++ spc() ++ pr_constr c)); c in + ppnl (str"BEGIN INSTANCES"); + try + while true do + ignore(find env0 concl0 1 ~k:print) + done; raise NoMatch + with NoMatch -> ppnl (str"END INSTANCES"); tclIDTAC gl + +TACTIC EXTEND ssrinstofruleL2R +| [ "ssrinstancesofruleL2R" ssrterm(arg) ] -> [ Proofview.V82.tactic (ssrinstancesofrule ist L2R arg) ] +END +TACTIC EXTEND ssrinstofruleR2L +| [ "ssrinstancesofruleR2L" ssrterm(arg) ] -> [ Proofview.V82.tactic (ssrinstancesofrule ist R2L arg) ] +END + +(* Resolve forward reference *) +let _ = + ipat_rewritetac := fun occ dir c gl -> rwrxtac occ None dir (project gl, c) gl + +let rwargtac ist ((dir, mult), (((oclr, occ), grx), (kind, gt))) gl = + let fail = ref false in + let interp_rpattern ist gl gc = + try interp_rpattern ist gl gc + with _ when snd mult = May -> fail := true; project gl, T mkProp in + let interp gc gl = + try interp_term ist gl gc + with _ when snd mult = May -> fail := true; (project gl, mkProp) in + let rwtac gl = + let rx = Option.map (interp_rpattern ist gl) grx in + let t = interp gt gl in + (match kind with + | RWred sim -> simplintac occ rx sim + | RWdef -> if dir = R2L then foldtac occ rx t else unfoldintac occ rx t gt + | RWeq -> rwrxtac occ rx dir t) gl in + let ctac = cleartac (interp_clr (oclr, (fst gt, snd (interp gt gl)))) in + if !fail then ctac gl else tclTHEN (tclMULT mult rwtac) ctac gl + +(** Rewrite argument sequence *) + +(* type ssrrwargs = ssrrwarg list *) + +let pr_ssrrwargs _ _ _ rwargs = pr_list spc pr_rwarg rwargs + +ARGUMENT EXTEND ssrrwargs TYPED AS ssrrwarg list PRINTED BY pr_ssrrwargs + | [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let ssr_rw_syntax = Summary.ref ~name:"SSR:rewrite" true + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optname = "ssreflect rewrite"; + Goptions.optkey = ["SsrRewrite"]; + Goptions.optread = (fun _ -> !ssr_rw_syntax); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> ssr_rw_syntax := b) } + +let test_ssr_rw_syntax = + let test strm = + if not !ssr_rw_syntax then raise Stream.Failure else + if is_ssr_loaded () then () else + match Compat.get_tok (Util.stream_nth 0 strm) with + | Tok.KEYWORD key when List.mem key.[0] ['{'; '['; '/'] -> () + | _ -> raise Stream.Failure in + Gram.Entry.of_parser "test_ssr_rw_syntax" test + +GEXTEND Gram + GLOBAL: ssrrwargs; + ssrrwargs: [[ test_ssr_rw_syntax; a = LIST1 ssrrwarg -> a ]]; +END + +(** The "rewrite" tactic *) + +let ssrrewritetac ist rwargs = + tclTHENLIST (List.map (rwargtac ist) rwargs) + +TACTIC EXTEND ssrrewrite + | [ "rewrite" ssrrwargs(args) ssrclauses(clauses) ] -> + [ Proofview.V82.tactic (tclCLAUSES ist (ssrrewritetac ist args) clauses) ] +END + +(** The "unlock" tactic *) + +let pr_unlockarg (occ, t) = pr_occ occ ++ pr_term t +let pr_ssrunlockarg _ _ _ = pr_unlockarg + +ARGUMENT EXTEND ssrunlockarg TYPED AS ssrocc * ssrterm + PRINTED BY pr_ssrunlockarg + | [ "{" ssrocc(occ) "}" ssrterm(t) ] -> [ occ, t ] + | [ ssrterm(t) ] -> [ None, t ] +END + +let pr_ssrunlockargs _ _ _ args = pr_list spc pr_unlockarg args + +ARGUMENT EXTEND ssrunlockargs TYPED AS ssrunlockarg list + PRINTED BY pr_ssrunlockargs + | [ ssrunlockarg_list(args) ] -> [ args ] +END + +let unfoldtac occ ko t kt gl = + let cl, c = pf_fill_occ_term gl occ (fst (strip_unfold_term t kt)) in + let cl' = subst1 (pf_unfoldn [OnlyOccurrences [1], get_evalref c] gl c) cl in + let f = if ko = None then Closure.betaiotazeta else Closure.betaiota in + Proofview.V82.of_tactic + (convert_concl (pf_reduce (Reductionops.clos_norm_flags f) gl cl')) gl + +let unlocktac ist args gl = + let utac (occ, gt) gl = + unfoldtac occ occ (interp_term ist gl gt) (fst gt) gl in + let locked, gl = pf_mkSsrConst "locked" gl in + let key, gl = pf_mkSsrConst "master_key" gl in + let ktacs = [ + (fun gl -> unfoldtac None None (project gl,locked) '(' gl); + simplest_newcase key ] in + tclTHENLIST (List.map utac args @ ktacs) gl + +TACTIC EXTEND ssrunlock + | [ "unlock" ssrunlockargs(args) ssrclauses(clauses) ] -> +[ Proofview.V82.tactic (tclCLAUSES ist (unlocktac ist args) clauses) ] +END + +(** 8. Forward chaining tactics (pose, set, have, suffice, wlog) *) + +(** Defined identifier *) + +type ssrfwdid = identifier + +let pr_ssrfwdid _ _ _ id = pr_spc () ++ pr_id id + +(* We use a primitive parser for the head identifier of forward *) +(* tactis to avoid syntactic conflicts with basic Coq tactics. *) +ARGUMENT EXTEND ssrfwdid TYPED AS ident PRINTED BY pr_ssrfwdid + | [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let accept_ssrfwdid strm = + match Compat.get_tok (stream_nth 0 strm) with + | Tok.IDENT id -> accept_before_syms_or_any_id [":"; ":="; "("] strm + | _ -> raise Stream.Failure + + +let test_ssrfwdid = Gram.Entry.of_parser "test_ssrfwdid" accept_ssrfwdid + +GEXTEND Gram + GLOBAL: ssrfwdid; + ssrfwdid: [[ test_ssrfwdid; id = Prim.ident -> id ]]; + END + + + +(** Definition value formatting *) + +(* We use an intermediate structure to correctly render the binder list *) +(* abbreviations. We use a list of hints to extract the binders and *) +(* base term from a term, for the two first levels of representation of *) +(* of constr terms. *) + +type 'term ssrbind = + | Bvar of name + | Bdecl of name list * 'term + | Bdef of name * 'term option * 'term + | Bstruct of name + | Bcast of 'term + +let pr_binder prl = function + | Bvar x -> + pr_name x + | Bdecl (xs, t) -> + str "(" ++ pr_list pr_spc pr_name xs ++ str " : " ++ prl t ++ str ")" + | Bdef (x, None, v) -> + str "(" ++ pr_name x ++ str " := " ++ prl v ++ str ")" + | Bdef (x, Some t, v) -> + str "(" ++ pr_name x ++ str " : " ++ prl t ++ + str " := " ++ prl v ++ str ")" + | Bstruct x -> + str "{struct " ++ pr_name x ++ str "}" + | Bcast t -> + str ": " ++ prl t + +type 'term ssrbindval = 'term ssrbind list * 'term + +type ssrbindfmt = + | BFvar + | BFdecl of int (* #xs *) + | BFcast (* final cast *) + | BFdef of bool (* has cast? *) + | BFrec of bool * bool (* has struct? * has cast? *) + +let rec mkBstruct i = function + | Bvar x :: b -> + if i = 0 then [Bstruct x] else mkBstruct (i - 1) b + | Bdecl (xs, _) :: b -> + let i' = i - List.length xs in + if i' < 0 then [Bstruct (List.nth xs i)] else mkBstruct i' b + | _ :: b -> mkBstruct i b + | [] -> [] + +let rec format_local_binders h0 bl0 = match h0, bl0 with + | BFvar :: h, LocalRawAssum ([_, x], _, _) :: bl -> + Bvar x :: format_local_binders h bl + | BFdecl _ :: h, LocalRawAssum (lxs, _, t) :: bl -> + Bdecl (List.map snd lxs, t) :: format_local_binders h bl + | BFdef false :: h, LocalRawDef ((_, x), v) :: bl -> + Bdef (x, None, v) :: format_local_binders h bl + | BFdef true :: h, + LocalRawDef ((_, x), CCast (_, v, CastConv t)) :: bl -> + Bdef (x, Some t, v) :: format_local_binders h bl + | _ -> [] + +let rec format_constr_expr h0 c0 = match h0, c0 with + | BFvar :: h, CLambdaN (_, [[_, x], _, _], c) -> + let bs, c' = format_constr_expr h c in + Bvar x :: bs, c' + | BFdecl _:: h, CLambdaN (_, [lxs, _, t], c) -> + let bs, c' = format_constr_expr h c in + Bdecl (List.map snd lxs, t) :: bs, c' + | BFdef false :: h, CLetIn(_, (_, x), v, c) -> + let bs, c' = format_constr_expr h c in + Bdef (x, None, v) :: bs, c' + | BFdef true :: h, CLetIn(_, (_, x), CCast (_, v, CastConv t), c) -> + let bs, c' = format_constr_expr h c in + Bdef (x, Some t, v) :: bs, c' + | [BFcast], CCast (_, c, CastConv t) -> + [Bcast t], c + | BFrec (has_str, has_cast) :: h, + CFix (_, _, [_, (Some locn, CStructRec), bl, t, c]) -> + let bs = format_local_binders h bl in + let bstr = if has_str then [Bstruct (Name (snd locn))] else [] in + bs @ bstr @ (if has_cast then [Bcast t] else []), c + | BFrec (_, has_cast) :: h, CCoFix (_, _, [_, bl, t, c]) -> + format_local_binders h bl @ (if has_cast then [Bcast t] else []), c + | _, c -> + [], c + +let rec format_glob_decl h0 d0 = match h0, d0 with + | BFvar :: h, (x, _, None, _) :: d -> + Bvar x :: format_glob_decl h d + | BFdecl 1 :: h, (x, _, None, t) :: d -> + Bdecl ([x], t) :: format_glob_decl h d + | BFdecl n :: h, (x, _, None, t) :: d when n > 1 -> + begin match format_glob_decl (BFdecl (n - 1) :: h) d with + | Bdecl (xs, _) :: bs -> Bdecl (x :: xs, t) :: bs + | bs -> Bdecl ([x], t) :: bs + end + | BFdef false :: h, (x, _, Some v, _) :: d -> + Bdef (x, None, v) :: format_glob_decl h d + | BFdef true:: h, (x, _, Some (GCast (_, v, CastConv t)), _) :: d -> + Bdef (x, Some t, v) :: format_glob_decl h d + | _, (x, _, None, t) :: d -> + Bdecl ([x], t) :: format_glob_decl [] d + | _, (x, _, Some v, _) :: d -> + Bdef (x, None, v) :: format_glob_decl [] d + | _, [] -> [] + +let rec format_glob_constr h0 c0 = match h0, c0 with + | BFvar :: h, GLambda (_, x, _, _, c) -> + let bs, c' = format_glob_constr h c in + Bvar x :: bs, c' + | BFdecl 1 :: h, GLambda (_, x, _, t, c) -> + let bs, c' = format_glob_constr h c in + Bdecl ([x], t) :: bs, c' + | BFdecl n :: h, GLambda (_, x, _, t, c) when n > 1 -> + begin match format_glob_constr (BFdecl (n - 1) :: h) c with + | Bdecl (xs, _) :: bs, c' -> Bdecl (x :: xs, t) :: bs, c' + | _ -> [Bdecl ([x], t)], c + end + | BFdef false :: h, GLetIn(_, x, v, c) -> + let bs, c' = format_glob_constr h c in + Bdef (x, None, v) :: bs, c' + | BFdef true :: h, GLetIn(_, x, GCast (_, v, CastConv t), c) -> + let bs, c' = format_glob_constr h c in + Bdef (x, Some t, v) :: bs, c' + | [BFcast], GCast (_, c, CastConv t) -> + [Bcast t], c + | BFrec (has_str, has_cast) :: h, GRec (_, f, _, bl, t, c) + when Array.length c = 1 -> + let bs = format_glob_decl h bl.(0) in + let bstr = match has_str, f with + | true, GFix ([|Some i, GStructRec|], _) -> mkBstruct i bs + | _ -> [] in + bs @ bstr @ (if has_cast then [Bcast t.(0)] else []), c.(0) + | _, c -> + [], c + +(** Forward chaining argument *) + +(* There are three kinds of forward definitions: *) +(* - Hint: type only, cast to Type, may have proof hint. *) +(* - Have: type option + value, no space before type *) +(* - Pose: binders + value, space before binders. *) + +type ssrfwdkind = FwdHint of string * bool | FwdHave | FwdPose + +type ssrfwdfmt = ssrfwdkind * ssrbindfmt list + +let pr_fwdkind = function + | FwdHint (s,_) -> str (s ^ " ") | _ -> str " :=" ++ spc () +let pr_fwdfmt (fk, _ : ssrfwdfmt) = pr_fwdkind fk + +let wit_ssrfwdfmt = add_genarg "ssrfwdfmt" pr_fwdfmt + +(* type ssrfwd = ssrfwdfmt * ssrterm *) + +let mkFwdVal fk c = ((fk, []), mk_term ' ' c) +let mkssrFwdVal fk c = ((fk, []), (c,None)) + +let mkFwdCast fk loc t c = ((fk, [BFcast]), mk_term ' ' (CCast (loc, c, dC t))) +let mkssrFwdCast fk loc t c = ((fk, [BFcast]), (c, Some t)) + +let mkFwdHint s t = + let loc = constr_loc t in + mkFwdCast (FwdHint (s,false)) loc t (mkCHole loc) +let mkFwdHintNoTC s t = + let loc = constr_loc t in + mkFwdCast (FwdHint (s,true)) loc t (mkCHole loc) + +let pr_gen_fwd prval prc prlc fk (bs, c) = + let prc s = str s ++ spc () ++ prval prc prlc c in + match fk, bs with + | FwdHint (s,_), [Bcast t] -> str s ++ spc () ++ prlc t + | FwdHint (s,_), _ -> prc (s ^ "(* typeof *)") + | FwdHave, [Bcast t] -> str ":" ++ spc () ++ prlc t ++ prc " :=" + | _, [] -> prc " :=" + | _, _ -> spc () ++ pr_list spc (pr_binder prlc) bs ++ prc " :=" + +let pr_fwd_guarded prval prval' = function +| (fk, h), (_, (_, Some c)) -> + pr_gen_fwd prval pr_constr_expr prl_constr_expr fk (format_constr_expr h c) +| (fk, h), (_, (c, None)) -> + pr_gen_fwd prval' pr_glob_constr prl_glob_constr fk (format_glob_constr h c) + +let pr_unguarded prc prlc = prlc + +let pr_fwd = pr_fwd_guarded pr_unguarded pr_unguarded +let pr_ssrfwd _ _ _ = pr_fwd + +ARGUMENT EXTEND ssrfwd TYPED AS (ssrfwdfmt * ssrterm) PRINTED BY pr_ssrfwd + | [ ":=" lconstr(c) ] -> [ mkFwdVal FwdPose c ] + | [ ":" lconstr (t) ":=" lconstr(c) ] -> [ mkFwdCast FwdPose loc t c ] +END + +(** Independent parsing for binders *) + +(* The pose, pose fix, and pose cofix tactics use these internally to *) +(* parse argument fragments. *) + +let pr_ssrbvar prc _ _ v = prc v + +ARGUMENT EXTEND ssrbvar TYPED AS constr PRINTED BY pr_ssrbvar +| [ ident(id) ] -> [ mkCVar loc id ] +| [ "_" ] -> [ mkCHole loc ] +END + +let bvar_lname = function + | CRef (Ident (loc, id), _) -> loc, Name id + | c -> constr_loc c, Anonymous + +let pr_ssrbinder prc _ _ (_, c) = prc c + +ARGUMENT EXTEND ssrbinder TYPED AS ssrfwdfmt * constr PRINTED BY pr_ssrbinder + | [ ssrbvar(bv) ] -> + [ let xloc, _ as x = bvar_lname bv in + (FwdPose, [BFvar]), + CLambdaN (loc,[[x],Default Explicit,mkCHole xloc],mkCHole loc) ] + | [ "(" ssrbvar(bv) ")" ] -> + [ let xloc, _ as x = bvar_lname bv in + (FwdPose, [BFvar]), + CLambdaN (loc,[[x],Default Explicit,mkCHole xloc],mkCHole loc) ] + | [ "(" ssrbvar(bv) ":" lconstr(t) ")" ] -> + [ let x = bvar_lname bv in + (FwdPose, [BFdecl 1]), + CLambdaN (loc, [[x], Default Explicit, t], mkCHole loc) ] + | [ "(" ssrbvar(bv) ne_ssrbvar_list(bvs) ":" lconstr(t) ")" ] -> + [ let xs = List.map bvar_lname (bv :: bvs) in + let n = List.length xs in + (FwdPose, [BFdecl n]), + CLambdaN (loc, [xs, Default Explicit, t], mkCHole loc) ] + | [ "(" ssrbvar(id) ":" lconstr(t) ":=" lconstr(v) ")" ] -> + [ let loc' = Loc.join_loc (constr_loc t) (constr_loc v) in + let v' = CCast (loc', v, dC t) in + (FwdPose,[BFdef true]), CLetIn (loc,bvar_lname id, v',mkCHole loc) ] + | [ "(" ssrbvar(id) ":=" lconstr(v) ")" ] -> + [ (FwdPose,[BFdef false]), CLetIn (loc,bvar_lname id, v,mkCHole loc) ] +END + +GEXTEND Gram + GLOBAL: ssrbinder; + ssrbinder: [ + [ ["of" | "&"]; c = operconstr LEVEL "99" -> + let loc = !@loc in + (FwdPose, [BFvar]), + CLambdaN (loc,[[loc,Anonymous],Default Explicit,c],mkCHole loc) ] + ]; +END + +let rec binders_fmts = function + | ((_, h), _) :: bs -> h @ binders_fmts bs + | _ -> [] + +let push_binders c2 bs = + let loc2 = constr_loc c2 in let mkloc loc1 = Loc.join_loc loc1 loc2 in + let rec loop ty c = function + | (_, CLambdaN (loc1, b, _)) :: bs when ty -> + CProdN (mkloc loc1, b, loop ty c bs) + | (_, CLambdaN (loc1, b, _)) :: bs -> + CLambdaN (mkloc loc1, b, loop ty c bs) + | (_, CLetIn (loc1, x, v, _)) :: bs -> + CLetIn (mkloc loc1, x, v, loop ty c bs) + | [] -> c + | _ -> anomaly "binder not a lambda nor a let in" in + match c2 with + | CCast (x, ct, CastConv cty) -> + (CCast (x, loop false ct bs, CastConv (loop true cty bs))) + | ct -> loop false ct bs + +let rec fix_binders = function + | (_, CLambdaN (_, [xs, _, t], _)) :: bs -> + LocalRawAssum (xs, Default Explicit, t) :: fix_binders bs + | (_, CLetIn (_, x, v, _)) :: bs -> + LocalRawDef (x, v) :: fix_binders bs + | _ -> [] + +let pr_ssrstruct _ _ _ = function + | Some id -> str "{struct " ++ pr_id id ++ str "}" + | None -> mt () + +ARGUMENT EXTEND ssrstruct TYPED AS ident option PRINTED BY pr_ssrstruct +| [ "{" "struct" ident(id) "}" ] -> [ Some id ] +| [ ] -> [ None ] +END + +(** The "pose" tactic *) + +(* The plain pose form. *) + +let bind_fwd bs = function + | (fk, h), (ck, (rc, Some c)) -> + (fk,binders_fmts bs @ h), (ck,(rc,Some (push_binders c bs))) + | fwd -> fwd + +ARGUMENT EXTEND ssrposefwd TYPED AS ssrfwd PRINTED BY pr_ssrfwd + | [ ssrbinder_list(bs) ssrfwd(fwd) ] -> [ bind_fwd bs fwd ] +END + +(* The pose fix form. *) + +let pr_ssrfixfwd _ _ _ (id, fwd) = str " fix " ++ pr_id id ++ pr_fwd fwd + +let bvar_locid = function + | CRef (Ident (loc, id), _) -> loc, id + | _ -> Errors.error "Missing identifier after \"(co)fix\"" + + +ARGUMENT EXTEND ssrfixfwd TYPED AS ident * ssrfwd PRINTED BY pr_ssrfixfwd + | [ "fix" ssrbvar(bv) ssrbinder_list(bs) ssrstruct(sid) ssrfwd(fwd) ] -> + [ let (_, id) as lid = bvar_locid bv in + let (fk, h), (ck, (rc, oc)) = fwd in + let c = Option.get oc in + let has_cast, t', c' = match format_constr_expr h c with + | [Bcast t'], c' -> true, t', c' + | _ -> false, mkCHole (constr_loc c), c in + let lb = fix_binders bs in + let has_struct, i = + let rec loop = function + (l', Name id') :: _ when Option.equal Id.equal sid (Some id') -> true, (l', id') + | [l', Name id'] when sid = None -> false, (l', id') + | _ :: bn -> loop bn + | [] -> Errors.error "Bad structural argument" in + loop (names_of_local_assums lb) in + let h' = BFrec (has_struct, has_cast) :: binders_fmts bs in + let fix = CFix (loc, lid, [lid, (Some i, CStructRec), lb, t', c']) in + id, ((fk, h'), (ck, (rc, Some fix))) ] +END + + +(* The pose cofix form. *) + +let pr_ssrcofixfwd _ _ _ (id, fwd) = str " cofix " ++ pr_id id ++ pr_fwd fwd + +ARGUMENT EXTEND ssrcofixfwd TYPED AS ssrfixfwd PRINTED BY pr_ssrcofixfwd + | [ "cofix" ssrbvar(bv) ssrbinder_list(bs) ssrfwd(fwd) ] -> + [ let _, id as lid = bvar_locid bv in + let (fk, h), (ck, (rc, oc)) = fwd in + let c = Option.get oc in + let has_cast, t', c' = match format_constr_expr h c with + | [Bcast t'], c' -> true, t', c' + | _ -> false, mkCHole (constr_loc c), c in + let h' = BFrec (false, has_cast) :: binders_fmts bs in + let cofix = CCoFix (loc, lid, [lid, fix_binders bs, t', c']) in + id, ((fk, h'), (ck, (rc, Some cofix))) + ] +END + +let ssrposetac ist (id, (_, t)) gl = + let sigma, t, ucst = pf_abs_ssrterm ist gl t in + posetac id t (pf_merge_uc ucst gl) + + +let prof_ssrposetac = mk_profiler "ssrposetac";; +let ssrposetac arg gl = prof_ssrposetac.profile (ssrposetac arg) gl;; + +TACTIC EXTEND ssrpose +| [ "pose" ssrfixfwd(ffwd) ] -> [ Proofview.V82.tactic (ssrposetac ist ffwd) ] +| [ "pose" ssrcofixfwd(ffwd) ] -> [ Proofview.V82.tactic (ssrposetac ist ffwd) ] +| [ "pose" ssrfwdid(id) ssrposefwd(fwd) ] -> [ Proofview.V82.tactic (ssrposetac ist (id, fwd)) ] +END + +(** The "set" tactic *) + +(* type ssrsetfwd = ssrfwd * ssrdocc *) + +let guard_setrhs s i = s.[i] = '{' + +let pr_setrhs occ prc prlc c = + if occ = nodocc then pr_guarded guard_setrhs prlc c else pr_docc occ ++ prc c + +let pr_fwd_guarded prval prval' = function +| (fk, h), (_, (_, Some c)) -> + pr_gen_fwd prval pr_constr_expr prl_constr_expr fk (format_constr_expr h c) +| (fk, h), (_, (c, None)) -> + pr_gen_fwd prval' pr_glob_constr prl_glob_constr fk (format_glob_constr h c) + +(* This does not print the type, it should be fixed... *) +let pr_ssrsetfwd _ _ _ (((fk,_),(t,_)), docc) = + pr_gen_fwd (fun _ _ -> pr_cpattern) + (fun _ -> mt()) (fun _ -> mt()) fk ([Bcast ()],t) + +ARGUMENT EXTEND ssrsetfwd +TYPED AS (ssrfwdfmt * (lcpattern * ssrterm option)) * ssrdocc +PRINTED BY pr_ssrsetfwd +| [ ":" lconstr(t) ":=" "{" ssrocc(occ) "}" cpattern(c) ] -> + [ mkssrFwdCast FwdPose loc (mk_lterm t) c, mkocc occ ] +| [ ":" lconstr(t) ":=" lcpattern(c) ] -> + [ mkssrFwdCast FwdPose loc (mk_lterm t) c, nodocc ] +| [ ":=" "{" ssrocc(occ) "}" cpattern(c) ] -> + [ mkssrFwdVal FwdPose c, mkocc occ ] +| [ ":=" lcpattern(c) ] -> [ mkssrFwdVal FwdPose c, nodocc ] +END + +let ssrsettac ist id ((_, (pat, pty)), (_, occ)) gl = + let pat = interp_cpattern ist gl pat (Option.map snd pty) in + let cl, sigma, env = pf_concl gl, project gl, pf_env gl in + let (c, ucst), cl = + try fill_occ_pattern ~raise_NoMatch:true env sigma cl pat occ 1 + with NoMatch -> redex_of_pattern ~resolve_typeclasses:true env pat, cl in + if occur_existential c then errorstrm(str"The pattern"++spc()++ + pr_constr_pat c++spc()++str"did not match and has holes."++spc()++ + str"Did you mean pose?") else + let c, cty = match kind_of_term c with + | Cast(t, DEFAULTcast, ty) -> t, ty + | _ -> c, pf_type_of gl c in + let cl' = mkLetIn (Name id, c, cty, cl) in + let gl = pf_merge_uc ucst gl in + tclTHEN (Proofview.V82.of_tactic (convert_concl cl')) (introid id) gl + +TACTIC EXTEND ssrset +| [ "set" ssrfwdid(id) ssrsetfwd(fwd) ssrclauses(clauses) ] -> + [ Proofview.V82.tactic (tclCLAUSES ist (ssrsettac ist id fwd) clauses) ] +END + +(** The "have" tactic *) + +(* type ssrhavefwd = ssrfwd * ssrhint *) + +let pr_ssrhavefwd _ _ prt (fwd, hint) = pr_fwd fwd ++ pr_hint prt hint + +ARGUMENT EXTEND ssrhavefwd TYPED AS ssrfwd * ssrhint PRINTED BY pr_ssrhavefwd +| [ ":" lconstr(t) ssrhint(hint) ] -> [ mkFwdHint ":" t, hint ] +| [ ":" lconstr(t) ":=" lconstr(c) ] -> [ mkFwdCast FwdHave loc t c, nohint ] +| [ ":" lconstr(t) ":=" ] -> [ mkFwdHintNoTC ":" t, nohint ] +| [ ":=" lconstr(c) ] -> [ mkFwdVal FwdHave c, nohint ] +END + +let intro_id_to_binder = List.map (function + | IpatId id -> + let xloc, _ as x = bvar_lname (mkCVar dummy_loc id) in + (FwdPose, [BFvar]), + CLambdaN (dummy_loc, [[x], Default Explicit, mkCHole xloc], + mkCHole dummy_loc) + | _ -> anomaly "non-id accepted as binder") + +let binder_to_intro_id = List.map (function + | (FwdPose, [BFvar]), CLambdaN (_,[ids,_,_],_) + | (FwdPose, [BFdecl _]), CLambdaN (_,[ids,_,_],_) -> + List.map (function (_, Name id) -> IpatId id | _ -> IpatAnon) ids + | (FwdPose, [BFdef _]), CLetIn (_,(_,Name id),_,_) -> [IpatId id] + | (FwdPose, [BFdef _]), CLetIn (_,(_,Anonymous),_,_) -> [IpatAnon] + | _ -> anomaly "ssrbinder is not a binder") + +let pr_ssrhavefwdwbinders _ _ prt (tr,((hpats, (fwd, hint)))) = + pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint + +ARGUMENT EXTEND ssrhavefwdwbinders + TYPED AS bool * (ssrhpats * (ssrfwd * ssrhint)) + PRINTED BY pr_ssrhavefwdwbinders +| [ ssrhpats_wtransp(trpats) ssrbinder_list(bs) ssrhavefwd(fwd) ] -> + [ let tr, pats = trpats in + let ((clr, pats), binders), simpl = pats in + let allbs = intro_id_to_binder binders @ bs in + let allbinders = binders @ List.flatten (binder_to_intro_id bs) in + let hint = bind_fwd allbs (fst fwd), snd fwd in + tr, ((((clr, pats), allbinders), simpl), hint) ] +END + +(* Tactic. *) + +let is_Evar_or_CastedMeta x = + isEvar_or_Meta x || + (isCast x && isEvar_or_Meta (pi1 (destCast x))) + +let occur_existential_or_casted_meta c = + let rec occrec c = match kind_of_term c with + | Evar _ -> raise Not_found + | Cast (m,_,_) when isMeta m -> raise Not_found + | _ -> iter_constr occrec c + in try occrec c; false with Not_found -> true + +let examine_abstract id gl = + let tid = pf_type_of gl id in + let abstract, gl = pf_mkSsrConst "abstract" gl in + if not (isApp tid) || not (Term.eq_constr (fst(destApp tid)) abstract) then + errorstrm(strbrk"not an abstract constant: "++pr_constr id); + let _, args_id = destApp tid in + if Array.length args_id <> 3 then + errorstrm(strbrk"not a proper abstract constant: "++pr_constr id); + if not (is_Evar_or_CastedMeta args_id.(2)) then + errorstrm(strbrk"abstract constant "++pr_constr id++str" already used"); + tid, args_id + +let pf_find_abstract_proof check_lock gl abstract_n = + let fire gl t = Reductionops.nf_evar (project gl) t in + let abstract, gl = pf_mkSsrConst "abstract" gl in + let l = Evd.fold_undefined (fun e ei l -> + match kind_of_term ei.Evd.evar_concl with + | App(hd, [|ty; n; lock|]) + when (not check_lock || + (occur_existential_or_casted_meta (fire gl ty) && + is_Evar_or_CastedMeta (fire gl lock))) && + Term.eq_constr hd abstract && Term.eq_constr n abstract_n -> e::l + | _ -> l) (project gl) [] in + match l with + | [e] -> e + | _ -> errorstrm(strbrk"abstract constant "++pr_constr abstract_n++ + strbrk" not found in the evar map exactly once. "++ + strbrk"Did you tamper with it?") + +let unfold cl = + let module R = Reductionops in let module F = Closure.RedFlags in + reduct_in_concl (R.clos_norm_flags (F.mkflags + (List.map (fun c -> F.fCONST (fst (destConst c))) cl @ [F.fBETA; F.fIOTA]))) + +let havegentac ist t gl = + let sigma, c, ucst = pf_abs_ssrterm ist gl t in + let gl = pf_merge_uc ucst gl in + apply_type (mkArrow (pf_type_of gl c) (pf_concl gl)) [c] gl + +let havetac ist + (transp,((((clr, pats), binders), simpl), (((fk, _), t), hint))) + suff namefst gl += + let concl = pf_concl gl in + let skols, pats = + List.partition (function IpatNewHidden _ -> true | _ -> false) pats in + let itac_mkabs = introstac ~ist skols in + let itac_c = introstac ~ist (IpatSimpl(clr,Nop) :: pats) in + let itac, id, clr = introstac ~ist pats, tclIDTAC, cleartac clr in + let binderstac n = + let rec aux = function 0 -> [] | n -> IpatAnon :: aux (n-1) in + tclTHEN (if binders <> [] then introstac ~ist (aux n) else tclIDTAC) + (introstac ~ist binders) in + let simpltac = introstac ~ist simpl in + let fixtc = + not !ssrhaveNOtcresolution && + match fk with FwdHint(_,true) -> false | _ -> true in + let hint = hinttac ist true hint in + let cuttac t gl = + if transp then + let have_let, gl = pf_mkSsrConst "ssr_have_let" gl in + let step = mkApp (have_let, [|concl;t|]) in + let gl, _ = pf_e_type_of gl step in + applyn ~with_evars:true ~with_shelve:false 2 step gl + else basecuttac "ssr_have" t gl in + (* Introduce now abstract constants, so that everything sees them *) + let abstract_key, gl = pf_mkSsrConst "abstract_key" gl in + let unlock_abs (idty,args_id) gl = + let gl, _ = pf_e_type_of gl idty in + pf_unify_HO gl args_id.(2) abstract_key in + tclTHENFIRST itac_mkabs (fun gl -> + let mkt t = mk_term ' ' t in + let mkl t = (' ', (t, None)) in + let interp gl rtc t = pf_abs_ssrterm ~resolve_typeclasses:rtc ist gl t in + let interp_ty gl rtc t = + let a,b,_,u = pf_interp_ty ~resolve_typeclasses:rtc ist gl t in a,b,u in + let ct, cty, hole, loc = match t with + | _, (_, Some (CCast (loc, ct, CastConv cty))) -> + mkt ct, mkt cty, mkt (mkCHole dummy_loc), loc + | _, (_, Some ct) -> + mkt ct, mkt (mkCHole dummy_loc), mkt (mkCHole dummy_loc), dummy_loc + | _, (GCast (loc, ct, CastConv cty), None) -> + mkl ct, mkl cty, mkl mkRHole, loc + | _, (t, None) -> mkl t, mkl mkRHole, mkl mkRHole, dummy_loc in + let gl, cut, sol, itac1, itac2 = + match fk, namefst, suff with + | FwdHave, true, true -> + errorstrm (str"Suff have does not accept a proof term") + | FwdHave, false, true -> + let cty = combineCG cty hole (mkCArrow loc) mkRArrow in + let _, t, uc = interp gl false (combineCG ct cty (mkCCast loc) mkRCast) in + let gl = pf_merge_uc uc gl in + let ty = pf_type_of gl t in + let ctx, _ = decompose_prod_n 1 ty in + let assert_is_conv gl = + try Proofview.V82.of_tactic (convert_concl (compose_prod ctx concl)) gl + with _ -> errorstrm (str "Given proof term is not of type " ++ + pr_constr (mkArrow (mkVar (id_of_string "_")) concl)) in + gl, ty, tclTHEN assert_is_conv (Proofview.V82.of_tactic (apply t)), id, itac_c + | FwdHave, false, false -> + let skols = List.flatten (List.map (function + | IpatNewHidden ids -> ids + | _ -> assert false) skols) in + let skols_args = + List.map (fun id -> examine_abstract (mkVar id) gl) skols in + let gl = List.fold_right unlock_abs skols_args gl in + let sigma, t, uc = + interp gl false (combineCG ct cty (mkCCast loc) mkRCast) in + let gl = re_sig (sig_it gl) (Evd.merge_universe_context sigma uc) in + let gs = + List.map (fun (_,a) -> + pf_find_abstract_proof false gl a.(1)) skols_args in + let tacopen_skols gl = + let stuff, g = Refiner.unpackage gl in + Refiner.repackage stuff (gs @ [g]) in + let gl, ty = pf_e_type_of gl t in + gl, ty, Proofview.V82.of_tactic (apply t), id, + tclTHEN (tclTHEN itac_c simpltac) + (tclTHEN tacopen_skols (fun gl -> + let abstract, gl = pf_mkSsrConst "abstract" gl in + unfold [abstract; abstract_key] gl)) + | _,true,true -> + let _, ty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in + gl, mkArrow ty concl, hint, itac, clr + | _,false,true -> + let _, ty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in + gl, mkArrow ty concl, hint, id, itac_c + | _, false, false -> + let n, cty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in + gl, cty, tclTHEN (binderstac n) hint, id, tclTHEN itac_c simpltac + | _, true, false -> assert false in + tclTHENS (cuttac cut) [ tclTHEN sol itac1; itac2 ] gl) + gl +;; + +(* to extend the abstract value one needs: + Utility lemma to partially instantiate an abstract constant type. + Lemma use_abstract T n l (x : abstract T n l) : T. + Proof. by case: l x. Qed. +*) +let ssrabstract ist gens (*last*) gl = + let main _ (_,cid) ist gl = +(* + let proj1, proj2, prod = + let pdata = build_prod () in + pdata.Coqlib.proj1, pdata.Coqlib.proj2, pdata.Coqlib.typ in +*) + let concl, env = pf_concl gl, pf_env gl in + let fire gl t = Reductionops.nf_evar (project gl) t in + let abstract, gl = pf_mkSsrConst "abstract" gl in + let abstract_key, gl = pf_mkSsrConst "abstract_key" gl in + let id = mkVar (Option.get (id_of_cpattern cid)) in + let idty, args_id = examine_abstract id gl in + let abstract_n = args_id.(1) in + let abstract_proof = pf_find_abstract_proof true gl abstract_n in + let gl, proof = + let pf_unify_HO gl a b = + try pf_unify_HO gl a b + with _ -> errorstrm(strbrk"The abstract variable "++pr_constr id++ + strbrk" cannot abstract this goal. Did you generalize it?") in + let rec find_hole p t = + match kind_of_term t with + | Evar _ (*when last*) -> pf_unify_HO gl concl t, p + | Meta _ (*when last*) -> pf_unify_HO gl concl t, p + | Cast(m,_,_) when isEvar_or_Meta m (*when last*) -> pf_unify_HO gl concl t, p +(* + | Evar _ -> + let sigma, it = project gl, sig_it gl in + let sigma, ty = Evarutil.new_type_evar sigma env in + let gl = re_sig it sigma in + let p = mkApp (proj2,[|ty;concl;p|]) in + let concl = mkApp(prod,[|ty; concl|]) in + pf_unify_HO gl concl t, p + | App(hd, [|left; right|]) when Term.eq_constr hd prod -> + find_hole (mkApp (proj1,[|left;right;p|])) left +*) + | _ -> errorstrm(strbrk"abstract constant "++pr_constr abstract_n++ + strbrk" has an unexpected shape. Did you tamper with it?") + in + find_hole + ((*if last then*) id + (*else mkApp(mkSsrConst "use_abstract",Array.append args_id [|id|])*)) + (fire gl args_id.(0)) in + let gl = (*if last then*) pf_unify_HO gl abstract_key args_id.(2) (*else gl*) in + let gl, _ = pf_e_type_of gl idty in + let proof = fire gl proof in +(* if last then *) + let tacopen gl = + let stuff, g = Refiner.unpackage gl in + Refiner.repackage stuff [ g; abstract_proof ] in + tclTHENS tacopen [tclSOLVE [Proofview.V82.of_tactic (apply proof)];unfold[abstract;abstract_key]] gl +(* else apply proof gl *) + in + let introback ist (gens, _) = + introstac ~ist + (List.map (fun (_,cp) -> match id_of_cpattern cp with + | None -> IpatAnon + | Some id -> IpatId id) + (List.tl (List.hd gens))) in + tclTHEN (with_dgens gens main ist) (introback ist gens) gl + +(* The standard TACTIC EXTEND does not work for abstract *) +GEXTEND Gram + GLOBAL: tactic_expr; + tactic_expr: LEVEL "3" + [ RIGHTA [ IDENT "abstract"; gens = ssrdgens -> + Tacexpr.TacML (!@loc, ssrtac_name "abstract", + [Genarg.in_gen (Genarg.rawwit wit_ssrdgens) gens]) ]]; +END +TACTIC EXTEND ssrabstract +| [ "abstract" ssrdgens(gens) ] -> [ + if List.length (fst gens) <> 1 then + errorstrm (str"dependents switches '/' not allowed here"); + Proofview.V82.tactic (ssrabstract ist gens) ] +END + +let prof_havetac = mk_profiler "havetac";; +let havetac arg a b gl = prof_havetac.profile (havetac arg a b) gl;; + +TACTIC EXTEND ssrhave +| [ "have" ssrhavefwdwbinders(fwd) ] -> + [ Proofview.V82.tactic (havetac ist fwd false false) ] +END + +TACTIC EXTEND ssrhavesuff +| [ "have" "suff" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ Proofview.V82.tactic (havetac ist (false,(pats,fwd)) true false) ] +END + +TACTIC EXTEND ssrhavesuffices +| [ "have" "suffices" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ Proofview.V82.tactic (havetac ist (false,(pats,fwd)) true false) ] +END + +TACTIC EXTEND ssrsuffhave +| [ "suff" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ Proofview.V82.tactic (havetac ist (false,(pats,fwd)) true true) ] +END + +TACTIC EXTEND ssrsufficeshave +| [ "suffices" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ Proofview.V82.tactic (havetac ist (false,(pats,fwd)) true true) ] +END + +(** The "suffice" tactic *) + +let pr_ssrsufffwdwbinders _ _ prt (hpats, (fwd, hint)) = + pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint + +ARGUMENT EXTEND ssrsufffwd + TYPED AS ssrhpats * (ssrfwd * ssrhint) PRINTED BY pr_ssrsufffwdwbinders +| [ ssrhpats(pats) ssrbinder_list(bs) ":" lconstr(t) ssrhint(hint) ] -> + [ let ((clr, pats), binders), simpl = pats in + let allbs = intro_id_to_binder binders @ bs in + let allbinders = binders @ List.flatten (binder_to_intro_id bs) in + let fwd = mkFwdHint ":" t in + (((clr, pats), allbinders), simpl), (bind_fwd allbs fwd, hint) ] +END + +let sufftac ist ((((clr, pats),binders),simpl), ((_, c), hint)) = + let htac = tclTHEN (introstac ~ist pats) (hinttac ist true hint) in + let c = match c with + | (a, (b, Some (CCast (_, _, CastConv cty)))) -> a, (b, Some cty) + | (a, (GCast (_, _, CastConv cty), None)) -> a, (cty, None) + | _ -> anomaly "suff: ssr cast hole deleted by typecheck" in + let ctac gl = + let _,ty,_,uc = pf_interp_ty ist gl c in let gl = pf_merge_uc uc gl in + basecuttac "ssr_suff" ty gl in + tclTHENS ctac [htac; tclTHEN (cleartac clr) (introstac ~ist (binders@simpl))] + +TACTIC EXTEND ssrsuff +| [ "suff" ssrsufffwd(fwd) ] -> [ Proofview.V82.tactic (sufftac ist fwd) ] +END + +TACTIC EXTEND ssrsuffices +| [ "suffices" ssrsufffwd(fwd) ] -> [ Proofview.V82.tactic (sufftac ist fwd) ] +END + +(** The "wlog" (Without Loss Of Generality) tactic *) + +(* type ssrwlogfwd = ssrwgen list * ssrfwd *) + +let pr_ssrwlogfwd _ _ _ (gens, t) = + str ":" ++ pr_list mt pr_wgen gens ++ spc() ++ pr_fwd t + +ARGUMENT EXTEND ssrwlogfwd TYPED AS ssrwgen list * ssrfwd + PRINTED BY pr_ssrwlogfwd +| [ ":" ssrwgen_list(gens) "/" lconstr(t) ] -> [ gens, mkFwdHint "/" t] +END + +let destProd_or_LetIn c = + match kind_of_term c with + | Prod (n,ty,c) -> (n,None,ty), c + | LetIn (n,bo,ty,c) -> (n,Some bo,ty), c + | _ -> raise DestKO + +let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = + let mkabs gen = abs_wgen false ist (fun x -> x) gen in + let mkclr gen clrs = clr_of_wgen gen clrs in + let mkpats = function + | _, Some ((x, _), _) -> fun pats -> IpatId (hoi_id x) :: pats + | _ -> fun x -> x in + let ct = match ct with + | (a, (b, Some (CCast (_, _, CastConv cty)))) -> a, (b, Some cty) + | (a, (GCast (_, _, CastConv cty), None)) -> a, (cty, None) + | _ -> anomaly "wlog: ssr cast hole deleted by typecheck" in + let cut_implies_goal = not (suff || ghave <> `NoGen) in + let c, args, ct, gl = + let gens = List.filter (function _, Some _ -> true | _ -> false) gens in + let concl = pf_concl gl in + let c = mkProp in + let c = if cut_implies_goal then mkArrow c concl else c in + let gl, args, c = List.fold_right mkabs gens (gl,[],c) in + let env, _ = + List.fold_left (fun (env, c) _ -> + let rd, c = destProd_or_LetIn c in + Environ.push_rel rd env, c) (pf_env gl, c) gens in + let sigma, ev = Evarutil.new_evar env (project gl) Term.mkProp in + let k, _ = Term.destEvar ev in + let fake_gl = {Evd.it = k; Evd.sigma = sigma} in + let _, ct, _, uc = pf_interp_ty ist fake_gl ct in + let rec var2rel c g s = match kind_of_term c, g with + | Prod(Anonymous,_,c), [] -> mkProd(Anonymous, Vars.subst_vars s ct, c) + | Sort _, [] -> Vars.subst_vars s ct + | LetIn(Name id as n,b,ty,c), _::g -> mkLetIn (n,b,ty,var2rel c g (id::s)) + | Prod(Name id as n,ty,c), _::g -> mkProd (n,ty,var2rel c g (id::s)) + | _ -> Errors.anomaly(str"SSR: wlog: var2rel: " ++ pr_constr c) in + let c = var2rel c gens [] in + let rec pired c = function + | [] -> c + | t::ts as args -> match kind_of_term c with + | Prod(_,_,c) -> pired (subst1 t c) ts + | LetIn(id,b,ty,c) -> mkLetIn (id,b,ty,pired c args) + | _ -> Errors.anomaly(str"SSR: wlog: pired: " ++ pr_constr c) in + c, args, pired c args, pf_merge_uc uc gl in + let tacipat pats = introstac ~ist pats in + let tacigens = + tclTHEN + (tclTHENLIST(List.rev(List.fold_right mkclr gens [cleartac clr0]))) + (introstac ~ist (List.fold_right mkpats gens [])) in + let hinttac = hinttac ist true hint in + let cut_kind, fst_goal_tac, snd_goal_tac = + match suff, ghave with + | true, `NoGen -> "ssr_wlog", tclTHEN hinttac (tacipat pats), tacigens + | false, `NoGen -> "ssr_wlog", hinttac, tclTHEN tacigens (tacipat pats) + | true, `Gen _ -> assert false + | false, `Gen id -> + if gens = [] then errorstrm(str"gen have requires some generalizations"); + let clear0 = cleartac clr0 in + let id, name_general_hyp, cleanup, pats = match id, pats with + | None, (IpatId id as ip)::pats -> Some id, tacipat [ip], clear0, pats + | None, _ -> None, tclIDTAC, clear0, pats + | Some (Some id),_ -> Some id, introid id, clear0, pats + | Some _,_ -> + let id = mk_anon_id "tmp" gl in + Some id, introid id, tclTHEN clear0 (clear [id]), pats in + let tac_specialize = match id with + | None -> tclIDTAC + | Some id -> + if pats = [] then tclIDTAC else + let args = Array.of_list args in + pp(lazy(str"specialized="++pr_constr (mkApp (mkVar id,args)))); + pp(lazy(str"specialized_ty="++pr_constr ct)); + tclTHENS (basecuttac "ssr_have" ct) + [Proofview.V82.of_tactic (apply (mkApp (mkVar id,args))); tclIDTAC] in + "ssr_have", + (if hint = nohint then tacigens else hinttac), + tclTHENLIST [name_general_hyp; tac_specialize; tacipat pats; cleanup] + in + tclTHENS (basecuttac cut_kind c) [fst_goal_tac; snd_goal_tac] gl + +TACTIC EXTEND ssrwlog +| [ "wlog" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint false `NoGen) ] +END + +TACTIC EXTEND ssrwlogs +| [ "wlog" "suff" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +TACTIC EXTEND ssrwlogss +| [ "wlog" "suffices" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +TACTIC EXTEND ssrwithoutloss +| [ "without" "loss" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint false `NoGen) ] +END + +TACTIC EXTEND ssrwithoutlosss +| [ "without" "loss" "suff" + ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +TACTIC EXTEND ssrwithoutlossss +| [ "without" "loss" "suffices" + ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> + [ Proofview.V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +(* Generally have *) +let pr_idcomma _ _ _ = function + | None -> mt() + | Some None -> str"_, " + | Some (Some id) -> pr_id id ++ str", " + +ARGUMENT EXTEND ssr_idcomma TYPED AS ident option option PRINTED BY pr_idcomma + | [ ] -> [ None ] +END + +let accept_idcomma strm = + match Compat.get_tok (stream_nth 0 strm) with + | Tok.IDENT _ | Tok.KEYWORD "_" -> accept_before_syms [","] strm + | _ -> raise Stream.Failure + +let test_idcomma = Gram.Entry.of_parser "test_idcomma" accept_idcomma + +GEXTEND Gram + GLOBAL: ssr_idcomma; + ssr_idcomma: [ [ test_idcomma; + ip = [ id = IDENT -> Some (id_of_string id) | "_" -> None ]; "," -> + Some ip + ] ]; +END + +let augment_preclr clr1 (((clr0, x),y),z) = (((clr1 @ clr0, x),y),z) + +TACTIC EXTEND ssrgenhave +| [ "gen" "have" ssrclear(clr) + ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ let pats = augment_preclr clr pats in + Proofview.V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) ] +END + +TACTIC EXTEND ssrgenhave2 +| [ "generally" "have" ssrclear(clr) + ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ let pats = augment_preclr clr pats in + Proofview.V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) ] +END + +(** Canonical Structure alias *) + +let def_body : Vernacexpr.definition_expr Gram.Entry.e = Obj.magic + (Grammar.Entry.find (Obj.magic gallina_ext) "vernac:def_body") in + +GEXTEND Gram + GLOBAL: gallina_ext; + + gallina_ext: + (* Canonical structure *) + [[ IDENT "Canonical"; qid = Constr.global -> + Vernacexpr.VernacCanonical (AN qid) + | IDENT "Canonical"; ntn = Prim.by_notation -> + Vernacexpr.VernacCanonical (ByNotation ntn) + | IDENT "Canonical"; qid = Constr.global; + d = def_body -> + let s = coerce_reference_to_id qid in + Vernacexpr.VernacDefinition + ((Some Decl_kinds.Global,Decl_kinds.CanonicalStructure), + (dummy_loc,s),(d )) + ]]; +END + +(** 9. Keyword compatibility fixes. *) + +(* Coq v8.1 notation uses "by" and "of" quasi-keywords, i.e., reserved *) +(* identifiers used as keywords. This is incompatible with ssreflect.v *) +(* which makes "by" and "of" true keywords, because of technicalities *) +(* in the internal lexer-parser API of Coq. We patch this here by *) +(* adding new parsing rules that recognize the new keywords. *) +(* To make matters worse, the Coq grammar for tactics fails to *) +(* export the non-terminals we need to patch. Fortunately, the CamlP5 *) +(* API provides a backdoor access (with loads of Obj.magic trickery). *) + +(* Coq v8.3 defines "by" as a keyword, some hacks are not needed any *) +(* longer and thus comment out. Such comments are marked with v8.3 *) + +let tac_ent = List.fold_left Grammar.Entry.find (Obj.magic simple_tactic) in +let hypident_ent = + tac_ent ["clause_dft_all"; "in_clause"; "hypident_occ"; "hypident"] in +let id_or_meta : Obj.t Gram.Entry.e = Obj.magic + (Grammar.Entry.find hypident_ent "id_or_meta") in +let hypident : (Obj.t * hyp_location_flag) Gram.Entry.e = + Obj.magic hypident_ent in +GEXTEND Gram + GLOBAL: hypident; +hypident: [ + [ "("; IDENT "type"; "of"; id = id_or_meta; ")" -> id, InHypTypeOnly + | "("; IDENT "value"; "of"; id = id_or_meta; ")" -> id, InHypValueOnly + ] ]; +END + +GEXTEND Gram + GLOBAL: hloc; +hloc: [ + [ "in"; "("; "Type"; "of"; id = ident; ")" -> + HypLocation ((dummy_loc,id), InHypTypeOnly) + | "in"; "("; IDENT "Value"; "of"; id = ident; ")" -> + HypLocation ((dummy_loc,id), InHypValueOnly) + ] ]; +END + +let constr_eval + : (Constrexpr.constr_expr,Obj.t,Obj.t) Genredexpr.may_eval Gram.Entry.e + = Obj.magic (Grammar.Entry.find (Obj.magic constr_may_eval) "constr_eval") + +GEXTEND Gram + GLOBAL: constr_eval; + constr_eval: [ + [ IDENT "type"; "of"; c = Constr.constr -> Genredexpr.ConstrTypeOf c ] + ]; +END + +(* We wipe out all the keywords generated by the grammar rules we defined. *) +(* The user is supposed to Require Import ssreflect or Require ssreflect *) +(* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) +(* consequence the extended ssreflect grammar. *) +let () = Lexer.unfreeze frozen_lexer ;; + +(* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/mathcomp/ssreflect/plugin/v8.5/ssreflect.mllib b/mathcomp/ssreflect/plugin/v8.5/ssreflect.mllib new file mode 100644 index 0000000..006b70f --- /dev/null +++ b/mathcomp/ssreflect/plugin/v8.5/ssreflect.mllib @@ -0,0 +1,2 @@ +Ssrmatching +Ssreflect diff --git a/mathcomp/ssreflect/plugin/v8.5/ssrmatching.ml4 b/mathcomp/ssreflect/plugin/v8.5/ssrmatching.ml4 new file mode 100644 index 0000000..2fd0fe6 --- /dev/null +++ b/mathcomp/ssreflect/plugin/v8.5/ssrmatching.ml4 @@ -0,0 +1,1290 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) + +(* Defining grammar rules with "xx" in it automatically declares keywords too, + * we thus save the lexer to restore it at the end of the file *) +let frozen_lexer = Lexer.freeze () ;; + +(*i camlp4use: "pa_extend.cmo" i*) +(*i camlp4deps: "grammar/grammar.cma" i*) + +open Names +open Pp +open Pcoq +open Genarg +open Constrarg +open Term +open Vars +open Topconstr +open Libnames +open Tactics +open Tacticals +open Termops +open Namegen +open Recordops +open Tacmach +open Coqlib +open Glob_term +open Util +open Evd +open Extend +open Goptions +open Tacexpr +open Tacinterp +open Pretyping +open Constr +open Tactic +open Extraargs +open Ppconstr +open Printer + +open Globnames +open Misctypes +open Decl_kinds +open Evar_kinds +open Constrexpr +open Constrexpr_ops +open Notation_term +open Notation_ops +open Locus +open Locusops + +DECLARE PLUGIN "ssreflect" + +type loc = Loc.t +let dummy_loc = Loc.ghost +let errorstrm = Errors.errorlabstrm "ssreflect" +let loc_error loc msg = Errors.user_err_loc (loc, msg, str msg) + +(* 0 cost pp function. Active only if env variable SSRDEBUG is set *) +(* or if SsrDebug is Set *) +let pp_ref = ref (fun _ -> ()) +let ssr_pp s = pperrnl (str"SSR: "++Lazy.force s) +let _ = try ignore(Sys.getenv "SSRDEBUG"); pp_ref := ssr_pp with Not_found -> () +let debug b = + if b then pp_ref := ssr_pp else pp_ref := fun _ -> () +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssrmatching debugging"; + Goptions.optkey = ["SsrMatchingDebug"]; + Goptions.optdepr = false; + Goptions.optread = (fun _ -> !pp_ref == ssr_pp); + Goptions.optwrite = debug } +let pp s = !pp_ref s + +(** Utils {{{ *****************************************************************) +let env_size env = List.length (Environ.named_context env) +let safeDestApp c = + match kind_of_term c with App (f, a) -> f, a | _ -> c, [| |] +let get_index = function ArgArg i -> i | _ -> + Errors.anomaly (str"Uninterpreted index") +(* Toplevel constr must be globalized twice ! *) +let glob_constr ist genv = function + | _, Some ce -> + let vars = Id.Map.fold (fun x _ accu -> Id.Set.add x accu) ist.lfun Id.Set.empty in + let ltacvars = { Constrintern.empty_ltac_sign with Constrintern.ltac_vars = vars } in + Constrintern.intern_gen WithoutTypeConstraint ~ltacvars:ltacvars genv ce + | rc, None -> rc + +(* Term printing utilities functions for deciding bracketing. *) +let pr_paren prx x = hov 1 (str "(" ++ prx x ++ str ")") +(* String lexing utilities *) +let skip_wschars s = + let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop +(* We also guard characters that might interfere with the ssreflect *) +(* tactic syntax. *) +let guard_term ch1 s i = match s.[i] with + | '(' -> false + | '{' | '/' | '=' -> true + | _ -> ch1 = '(' +(* The call 'guard s i' should return true if the contents of s *) +(* starting at i need bracketing to avoid ambiguities. *) +let pr_guarded guard prc c = + msg_with Format.str_formatter (prc c); + let s = Format.flush_str_formatter () ^ "$" in + if guard s (skip_wschars s 0) then pr_paren prc c else prc c +(* More sensible names for constr printers *) +let pr_constr = pr_constr +let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c +let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c +let prl_constr_expr = pr_lconstr_expr +let pr_constr_expr = pr_constr_expr +let prl_glob_constr_and_expr = function + | _, Some c -> prl_constr_expr c + | c, None -> prl_glob_constr c +let pr_glob_constr_and_expr = function + | _, Some c -> pr_constr_expr c + | c, None -> pr_glob_constr c +let pr_term (k, c) = pr_guarded (guard_term k) pr_glob_constr_and_expr c +let prl_term (k, c) = pr_guarded (guard_term k) prl_glob_constr_and_expr c + +(** Adding a new uninterpreted generic argument type *) +let add_genarg tag pr = + let wit = Genarg.make0 None tag in + let glob ist x = (ist, x) in + let subst _ x = x in + let interp ist gl x = (gl.Evd.sigma, x) in + let gen_pr _ _ _ = pr in + let () = Genintern.register_intern0 wit glob in + let () = Genintern.register_subst0 wit subst in + let () = Geninterp.register_interp0 wit interp in + Pptactic.declare_extra_genarg_pprule wit gen_pr gen_pr gen_pr; + wit + +(** Constructors for cast type *) +let dC t = CastConv t +(** Constructors for constr_expr *) +let isCVar = function CRef (Ident _, _) -> true | _ -> false +let destCVar = function CRef (Ident (_, id), _) -> id | _ -> + Errors.anomaly (str"not a CRef") +let mkCHole loc = CHole (loc, None, IntroAnonymous, None) +let mkCLambda loc name ty t = + CLambdaN (loc, [[loc, name], Default Explicit, ty], t) +let mkCLetIn loc name bo t = + CLetIn (loc, (loc, name), bo, t) +let mkCCast loc t ty = CCast (loc,t, dC ty) +(** Constructors for rawconstr *) +let mkRHole = GHole (dummy_loc, InternalHole, IntroAnonymous, None) +let mkRApp f args = if args = [] then f else GApp (dummy_loc, f, args) +let mkRCast rc rt = GCast (dummy_loc, rc, dC rt) +let mkRLambda n s t = GLambda (dummy_loc, n, Explicit, s, t) + +(* ssrterm conbinators *) +let combineCG t1 t2 f g = match t1, t2 with + | (x, (t1, None)), (_, (t2, None)) -> x, (g t1 t2, None) + | (x, (_, Some t1)), (_, (_, Some t2)) -> x, (mkRHole, Some (f t1 t2)) + | _, (_, (_, None)) -> Errors.anomaly (str"have: mixed C-G constr") + | _ -> Errors.anomaly (str"have: mixed G-C constr") +let loc_ofCG = function + | (_, (s, None)) -> Glob_ops.loc_of_glob_constr s + | (_, (_, Some s)) -> Constrexpr_ops.constr_loc s + +let mk_term k c = k, (mkRHole, Some c) +let mk_lterm = mk_term ' ' + +(* }}} *) + +(** Profiling {{{ *************************************************************) +type profiler = { + profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; + reset : unit -> unit; + print : unit -> unit } +let profile_now = ref false +let something_profiled = ref false +let profilers = ref [] +let add_profiler f = profilers := f :: !profilers;; +let profile b = + profile_now := b; + if b then List.iter (fun f -> f.reset ()) !profilers; + if not b then List.iter (fun f -> f.print ()) !profilers +;; +let _ = + Goptions.declare_bool_option + { Goptions.optsync = false; + Goptions.optname = "ssrmatching profiling"; + Goptions.optkey = ["SsrMatchingProfiling"]; + Goptions.optread = (fun _ -> !profile_now); + Goptions.optdepr = false; + Goptions.optwrite = profile } +let () = + let prof_total = + let init = ref 0.0 in { + profile = (fun f x -> assert false); + reset = (fun () -> init := Unix.gettimeofday ()); + print = (fun () -> if !something_profiled then + prerr_endline + (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" + "total" 0 (Unix.gettimeofday() -. !init) 0.0 0.0)) } in + let prof_legenda = { + profile = (fun f x -> assert false); + reset = (fun () -> ()); + print = (fun () -> if !something_profiled then begin + prerr_endline + (Printf.sprintf "!! %39s ---------- --------- --------- ---------" + (String.make 39 '-')); + prerr_endline + (Printf.sprintf "!! %-39s %10s %9s %9s %9s" + "function" "#calls" "total" "max" "average") end) } in + add_profiler prof_legenda; + add_profiler prof_total +;; + +let mk_profiler s = + let total, calls, max = ref 0.0, ref 0, ref 0.0 in + let reset () = total := 0.0; calls := 0; max := 0.0 in + let profile f x = + if not !profile_now then f x else + let before = Unix.gettimeofday () in + try + incr calls; + let res = f x in + let after = Unix.gettimeofday () in + let delta = after -. before in + total := !total +. delta; + if delta > !max then max := delta; + res + with exc -> + let after = Unix.gettimeofday () in + let delta = after -. before in + total := !total +. delta; + if delta > !max then max := delta; + raise exc in + let print () = + if !calls <> 0 then begin + something_profiled := true; + prerr_endline + (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" + s !calls !total !max (!total /. (float_of_int !calls))) end in + let prof = { profile = profile; reset = reset; print = print } in + add_profiler prof; + prof +;; +(* }}} *) + +exception NoProgress + +(** Unification procedures. *) + +(* To enforce the rigidity of the rooted match we always split *) +(* top applications, so the unification procedures operate on *) +(* arrays of patterns and terms. *) +(* We perform three kinds of unification: *) +(* EQ: exact conversion check *) +(* FO: first-order unification of evars, without conversion *) +(* HO: higher-order unification with conversion *) +(* The subterm unification strategy is to find the first FO *) +(* match, if possible, and the first HO match otherwise, then *) +(* compute all the occurrences that are EQ matches for the *) +(* relevant subterm. *) +(* Additional twists: *) +(* - If FO/HO fails then we attempt to fill evars using *) +(* typeclasses before raising an outright error. We also *) +(* fill typeclasses even after a successful match, since *) +(* beta-reduction and canonical instances may leave *) +(* undefined evars. *) +(* - We do postchecks to rule out matches that are not *) +(* closed or that assign to a global evar; these can be *) +(* disabled for rewrite or dependent family matches. *) +(* - We do a full FO scan before turning to HO, as the FO *) +(* comparison can be much faster than the HO one. *) + +let unif_EQ env sigma p c = + let evars = existential_opt_value sigma in + try let _ = Reduction.conv env p ~evars c in true with _ -> false + +let unif_EQ_args env sigma pa a = + let n = Array.length pa in + let rec loop i = (i = n) || unif_EQ env sigma pa.(i) a.(i) && loop (i + 1) in + loop 0 + +let prof_unif_eq_args = mk_profiler "unif_EQ_args";; +let unif_EQ_args env sigma pa a = + prof_unif_eq_args.profile (unif_EQ_args env sigma pa) a +;; + +let unif_HO env ise p c = Evarconv.the_conv_x env p c ise + +let unif_HOtype env ise p c = Evarconv.the_conv_x_leq env p c ise + +let unif_HO_args env ise0 pa i ca = + let n = Array.length pa in + let rec loop ise j = + if j = n then ise else loop (unif_HO env ise pa.(j) ca.(i + j)) (j + 1) in + loop ise0 0 + +(* FO unification should boil down to calling w_unify with no_delta, but *) +(* alas things are not so simple: w_unify does partial type-checking, *) +(* which breaks down when the no-delta flag is on (as the Coq type system *) +(* requires full convertibility. The workaround here is to convert all *) +(* evars into metas, since 8.2 does not TC metas. This means some lossage *) +(* for HO evars, though hopefully Miller patterns can pick up some of *) +(* those cases, and HO matching will mop up the rest. *) +let flags_FO = + let flags = + { (Unification.default_no_delta_unify_flags ()).Unification.core_unify_flags + with + Unification.modulo_conv_on_closed_terms = None; + Unification.modulo_eta = true; + Unification.modulo_betaiota = true; + Unification.modulo_delta_types = full_transparent_state} + in + { Unification.core_unify_flags = flags; + Unification.merge_unify_flags = flags; + Unification.subterm_unify_flags = flags; + Unification.allow_K_in_toplevel_higher_order_unification = false; + Unification.resolve_evars = + (Unification.default_no_delta_unify_flags ()).Unification.resolve_evars + } +let unif_FO env ise p c = + Unification.w_unify env ise Reduction.CONV ~flags:flags_FO p c + +(* Perform evar substitution in main term and prune substitution. *) +let nf_open_term sigma0 ise c = + let s = ise and s' = ref sigma0 in + let rec nf c' = match kind_of_term c' with + | Evar ex -> + begin try nf (existential_value s ex) with _ -> + let k, a = ex in let a' = Array.map nf a in + if not (Evd.mem !s' k) then + s' := Evd.add !s' k (Evarutil.nf_evar_info s (Evd.find s k)); + mkEvar (k, a') + end + | _ -> map_constr nf c' in + let copy_def k evi () = + if evar_body evi != Evd.Evar_empty then () else + match Evd.evar_body (Evd.find s k) with + | Evar_defined c' -> s' := Evd.define k (nf c') !s' + | _ -> () in + let c' = nf c in let _ = Evd.fold copy_def sigma0 () in + !s', Evd.evar_universe_context s, c' + +let unif_end env sigma0 ise0 pt ok = + let ise = Evarconv.consider_remaining_unif_problems env ise0 in + let s, uc, t = nf_open_term sigma0 ise pt in + let ise1 = create_evar_defs s in + let ise2 = Typeclasses.resolve_typeclasses ~fail:true env ise1 in + if not (ok ise) then raise NoProgress else + if ise2 == ise1 then (s, uc, t) + else + let s, uc', t = nf_open_term sigma0 ise2 t in + s, Evd.union_evar_universe_context uc uc', t + +let pf_unif_HO gl sigma pt p c = + let env = pf_env gl in + let ise = unif_HO env (create_evar_defs sigma) p c in + unif_end env (project gl) ise pt (fun _ -> true) + +let unify_HO env sigma0 t1 t2 = + let sigma = unif_HO env sigma0 t1 t2 in + let sigma, uc, _ = unif_end env sigma0 sigma t2 (fun _ -> true) in + Evd.merge_universe_context sigma uc + +let pf_unify_HO gl t1 t2 = + let env, sigma0, si = pf_env gl, project gl, sig_it gl in + let sigma = unify_HO env sigma0 t1 t2 in + re_sig si sigma + +(* This is what the definition of iter_constr should be... *) +let iter_constr_LR f c = match kind_of_term c with + | Evar (k, a) -> Array.iter f a + | Cast (cc, _, t) -> f cc; f t + | Prod (_, t, b) | Lambda (_, t, b) -> f t; f b + | LetIn (_, v, t, b) -> f v; f t; f b + | App (cf, a) -> f cf; Array.iter f a + | Case (_, p, v, b) -> f v; f p; Array.iter f b + | Fix (_, (_, t, b)) | CoFix (_, (_, t, b)) -> + for i = 0 to Array.length t - 1 do f t.(i); f b.(i) done + | _ -> () + +(* The comparison used to determine which subterms matches is KEYED *) +(* CONVERSION. This looks for convertible terms that either have the same *) +(* same head constant as pat if pat is an application (after beta-iota), *) +(* or start with the same constr constructor (esp. for LetIn); this is *) +(* disregarded if the head term is let x := ... in x, and casts are always *) +(* ignored and removed). *) +(* Record projections get special treatment: in addition to the projection *) +(* constant itself, ssreflect also recognizes head constants of canonical *) +(* projections. *) + +exception NoMatch +type ssrdir = L2R | R2L +let pr_dir_side = function L2R -> str "LHS" | R2L -> str "RHS" +let inv_dir = function L2R -> R2L | R2L -> L2R + + +type pattern_class = + | KpatFixed + | KpatConst + | KpatEvar of existential_key + | KpatLet + | KpatLam + | KpatRigid + | KpatFlex + | KpatProj of constant + +type tpattern = { + up_k : pattern_class; + up_FO : constr; + up_f : constr; + up_a : constr array; + up_t : constr; (* equation proof term or matched term *) + up_dir : ssrdir; (* direction of the rule *) + up_ok : constr -> evar_map -> bool; (* progess test for rewrite *) + } + +let all_ok _ _ = true + +let proj_nparams c = + try 1 + Recordops.find_projection_nparams (ConstRef c) with _ -> 0 + +let isFixed c = match kind_of_term c with + | Var _ | Ind _ | Construct _ | Const _ -> true + | _ -> false + +let isRigid c = match kind_of_term c with + | Prod _ | Sort _ | Lambda _ | Case _ | Fix _ | CoFix _ -> true + | _ -> false + +exception UndefPat + +let hole_var = mkVar (id_of_string "_") +let pr_constr_pat c0 = + let rec wipe_evar c = + if isEvar c then hole_var else map_constr wipe_evar c in + pr_constr (wipe_evar c0) + +(* Turn (new) evars into metas *) +let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = + let ise = ref ise0 in + let sigma = ref ise0 in + let nenv = env_size env + if hack then 1 else 0 in + let rec put c = match kind_of_term c with + | Evar (k, a as ex) -> + begin try put (existential_value !sigma ex) + with NotInstantiatedEvar -> + if Evd.mem sigma0 k then map_constr put c else + let evi = Evd.find !sigma k in + let dc = List.firstn (max 0 (Array.length a - nenv)) (evar_filtered_context evi) in + let abs_dc (d, c) = function + | x, Some b, t -> d, mkNamedLetIn x (put b) (put t) c + | x, None, t -> mkVar x :: d, mkNamedProd x (put t) c in + let a, t = + Context.fold_named_context_reverse abs_dc ~init:([], (put evi.evar_concl)) dc in + let m = Evarutil.new_meta () in + ise := meta_declare m t !ise; + sigma := Evd.define k (applist (mkMeta m, a)) !sigma; + put (existential_value !sigma ex) + end + | _ -> map_constr put c in + let c1 = put c0 in !ise, c1 + +(* Compile a match pattern from a term; t is the term to fill. *) +(* p_origin can be passed to obtain a better error message *) +let mk_tpattern ?p_origin ?(hack=false) env sigma0 (ise, t) ok dir p = + let k, f, a = + let f, a = Reductionops.whd_betaiota_stack ise p in + match kind_of_term f with + | Const (p,_) -> + let np = proj_nparams p in + if np = 0 || np > List.length a then KpatConst, f, a else + let a1, a2 = List.chop np a in KpatProj p, applist(f, a1), a2 + | Var _ | Ind _ | Construct _ -> KpatFixed, f, a + | Evar (k, _) -> + if Evd.mem sigma0 k then KpatEvar k, f, a else + if a <> [] then KpatFlex, f, a else + (match p_origin with None -> Errors.error "indeterminate pattern" + | Some (dir, rule) -> + errorstrm (str "indeterminate " ++ pr_dir_side dir + ++ str " in " ++ pr_constr_pat rule)) + | LetIn (_, v, _, b) -> + if b <> mkRel 1 then KpatLet, f, a else KpatFlex, v, a + | Lambda _ -> KpatLam, f, a + | _ -> KpatRigid, f, a in + let aa = Array.of_list a in + let ise', p' = evars_for_FO ~hack env sigma0 ise (mkApp (f, aa)) in + ise', + { up_k = k; up_FO = p'; up_f = f; + up_a = aa; up_ok = ok; up_dir = dir; up_t = t} + +(* Specialize a pattern after a successful match: assign a precise head *) +(* kind and arity for Proj and Flex patterns. *) +let ungen_upat lhs (sigma, uc, t) u = + let f, a = safeDestApp lhs in + let k = match kind_of_term f with + | Var _ | Ind _ | Construct _ -> KpatFixed + | Const _ -> KpatConst + | Evar (k, _) -> if is_defined sigma k then raise NoMatch else KpatEvar k + | LetIn _ -> KpatLet + | Lambda _ -> KpatLam + | _ -> KpatRigid in + sigma, uc, {u with up_k = k; up_FO = lhs; up_f = f; up_a = a; up_t = t} + +let nb_cs_proj_args pc f u = + let na k = + List.length (snd (lookup_canonical_conversion (ConstRef pc, k))).o_TCOMPS in + try match kind_of_term f with + | Prod _ -> na Prod_cs + | Sort s -> na (Sort_cs (family_of_sort s)) + | Const (c',_) when Constant.equal c' pc -> Array.length (snd (destApp u.up_f)) + | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (global_of_constr f)) + | _ -> -1 + with Not_found -> -1 + +let isEvar_k k f = + match kind_of_term f with Evar (k', _) -> k = k' | _ -> false + +let nb_args c = + match kind_of_term c with App (_, a) -> Array.length a | _ -> 0 + +let mkSubArg i a = if i = Array.length a then a else Array.sub a 0 i +let mkSubApp f i a = if i = 0 then f else mkApp (f, mkSubArg i a) + +let splay_app ise = + let rec loop c a = match kind_of_term c with + | App (f, a') -> loop f (Array.append a' a) + | Cast (c', _, _) -> loop c' a + | Evar ex -> + (try loop (existential_value ise ex) a with _ -> c, a) + | _ -> c, a in + fun c -> match kind_of_term c with + | App (f, a) -> loop f a + | Cast _ | Evar _ -> loop c [| |] + | _ -> c, [| |] + +let filter_upat i0 f n u fpats = + let na = Array.length u.up_a in + if n < na then fpats else + let np = match u.up_k with + | KpatConst when Term.eq_constr u.up_f f -> na + | KpatFixed when Term.eq_constr u.up_f f -> na + | KpatEvar k when isEvar_k k f -> na + | KpatLet when isLetIn f -> na + | KpatLam when isLambda f -> na + | KpatRigid when isRigid f -> na + | KpatFlex -> na + | KpatProj pc -> + let np = na + nb_cs_proj_args pc f u in if n < np then -1 else np + | _ -> -1 in + if np < na then fpats else + let () = if !i0 < np then i0 := n in (u, np) :: fpats + +let filter_upat_FO i0 f n u fpats = + let np = nb_args u.up_FO in + if n < np then fpats else + let ok = match u.up_k with + | KpatConst -> Term.eq_constr u.up_f f + | KpatFixed -> Term.eq_constr u.up_f f + | KpatEvar k -> isEvar_k k f + | KpatLet -> isLetIn f + | KpatLam -> isLambda f + | KpatRigid -> isRigid f + | KpatProj pc -> Term.eq_constr f (mkConst pc) + | KpatFlex -> i0 := n; true in + if ok then begin if !i0 < np then i0 := np; (u, np) :: fpats end else fpats + +exception FoundUnif of (evar_map * evar_universe_context * tpattern) +(* Note: we don't update env as we descend into the term, as the primitive *) +(* unification procedure always rejects subterms with bound variables. *) + +(* We are forced to duplicate code between the FO/HO matching because we *) +(* have to work around several kludges in unify.ml: *) +(* - w_unify drops into second-order unification when the pattern is an *) +(* application whose head is a meta. *) +(* - w_unify tries to unify types without subsumption when the pattern *) +(* head is an evar or meta (e.g., it fails on ?1 = nat when ?1 : Type). *) +(* - w_unify expands let-in (zeta conversion) eagerly, whereas we want to *) +(* match a head let rigidly. *) +let match_upats_FO upats env sigma0 ise = + let rec loop c = + let f, a = splay_app ise c in let i0 = ref (-1) in + let fpats = + List.fold_right (filter_upat_FO i0 f (Array.length a)) upats [] in + while !i0 >= 0 do + let i = !i0 in i0 := -1; + let c' = mkSubApp f i a in + let one_match (u, np) = + let skip = + if i <= np then i < np else + if u.up_k == KpatFlex then begin i0 := i - 1; false end else + begin if !i0 < np then i0 := np; true end in + if skip || not (closed0 c') then () else try + let _ = match u.up_k with + | KpatFlex -> + let kludge v = mkLambda (Anonymous, mkProp, v) in + unif_FO env ise (kludge u.up_FO) (kludge c') + | KpatLet -> + let kludge vla = + let vl, a = safeDestApp vla in + let x, v, t, b = destLetIn vl in + mkApp (mkLambda (x, t, b), Array.cons v a) in + unif_FO env ise (kludge u.up_FO) (kludge c') + | _ -> unif_FO env ise u.up_FO c' in + let ise' = (* Unify again using HO to assign evars *) + let p = mkApp (u.up_f, u.up_a) in + try unif_HO env ise p c' with _ -> raise NoMatch in + let lhs = mkSubApp f i a in + let pt' = unif_end env sigma0 ise' u.up_t (u.up_ok lhs) in + raise (FoundUnif (ungen_upat lhs pt' u)) + with FoundUnif _ as sigma_u -> raise sigma_u + | Not_found -> Errors.anomaly (str"incomplete ise in match_upats_FO") + | _ -> () in + List.iter one_match fpats + done; + iter_constr_LR loop f; Array.iter loop a in + fun c -> try loop c with Invalid_argument _ -> Errors.anomaly (str"IN FO") + +let prof_FO = mk_profiler "match_upats_FO";; +let match_upats_FO upats env sigma0 ise c = + prof_FO.profile (match_upats_FO upats env sigma0) ise c +;; + + +let match_upats_HO ~on_instance upats env sigma0 ise c = + let it_did_match = ref false in + let rec aux upats env sigma0 ise c = + let f, a = splay_app ise c in let i0 = ref (-1) in + let fpats = List.fold_right (filter_upat i0 f (Array.length a)) upats [] in + while !i0 >= 0 do + let i = !i0 in i0 := -1; + let one_match (u, np) = + let skip = + if i <= np then i < np else + if u.up_k == KpatFlex then begin i0 := i - 1; false end else + begin if !i0 < np then i0 := np; true end in + if skip then () else try + let ise' = match u.up_k with + | KpatFixed | KpatConst -> ise + | KpatEvar _ -> + let _, pka = destEvar u.up_f and _, ka = destEvar f in + unif_HO_args env ise pka 0 ka + | KpatLet -> + let x, v, t, b = destLetIn f in + let _, pv, _, pb = destLetIn u.up_f in + let ise' = unif_HO env ise pv v in + unif_HO (Environ.push_rel (x, None, t) env) ise' pb b + | KpatFlex | KpatProj _ -> + unif_HO env ise u.up_f (mkSubApp f (i - Array.length u.up_a) a) + | _ -> unif_HO env ise u.up_f f in + let ise'' = unif_HO_args env ise' u.up_a (i - Array.length u.up_a) a in + let lhs = mkSubApp f i a in + let pt' = unif_end env sigma0 ise'' u.up_t (u.up_ok lhs) in + on_instance (ungen_upat lhs pt' u) + with FoundUnif _ as sigma_u -> raise sigma_u + | NoProgress -> it_did_match := true + | _ -> () in + List.iter one_match fpats + done; + iter_constr_LR (aux upats env sigma0 ise) f; + Array.iter (aux upats env sigma0 ise) a + in + aux upats env sigma0 ise c; + if !it_did_match then raise NoProgress + +let prof_HO = mk_profiler "match_upats_HO";; +let match_upats_HO ~on_instance upats env sigma0 ise c = + prof_HO.profile (match_upats_HO ~on_instance upats env sigma0) ise c +;; + + +let fixed_upat = function +| {up_k = KpatFlex | KpatEvar _ | KpatProj _} -> false +| {up_t = t} -> not (occur_existential t) + +let do_once r f = match !r with Some _ -> () | None -> r := Some (f ()) + +let assert_done r = + match !r with Some x -> x | None -> Errors.anomaly (str"do_once never called") + +let assert_done_multires r = + match !r with + | None -> Errors.anomaly (str"do_once never called") + | Some (n, xs) -> + r := Some (n+1,xs); + try List.nth xs n with Failure _ -> raise NoMatch + +type subst = Environ.env -> Term.constr -> Term.constr -> int -> Term.constr +type find_P = + Environ.env -> Term.constr -> int -> + k:subst -> + Term.constr +type conclude = unit -> + Term.constr * ssrdir * (Evd.evar_map * Evd.evar_universe_context * Term.constr) + +(* upats_origin makes a better error message only *) +let mk_tpattern_matcher ?(all_instances=false) + ?(raise_NoMatch=false) ?upats_origin sigma0 occ (ise, upats) += + let nocc = ref 0 and skip_occ = ref false in + let use_occ, occ_list = match occ with + | Some (true, ol) -> ol = [], ol + | Some (false, ol) -> ol <> [], ol + | None -> false, [] in + let max_occ = List.fold_right max occ_list 0 in + let subst_occ = + let occ_set = Array.make max_occ (not use_occ) in + let _ = List.iter (fun i -> occ_set.(i - 1) <- use_occ) occ_list in + let _ = if max_occ = 0 then skip_occ := use_occ in + fun () -> incr nocc; + if !nocc = max_occ then skip_occ := use_occ; + if !nocc <= max_occ then occ_set.(!nocc - 1) else not use_occ in + let upat_that_matched = ref None in + let match_EQ env sigma u = + match u.up_k with + | KpatLet -> + let x, pv, t, pb = destLetIn u.up_f in + let env' = Environ.push_rel (x, None, t) env in + let match_let f = match kind_of_term f with + | LetIn (_, v, _, b) -> unif_EQ env sigma pv v && unif_EQ env' sigma pb b + | _ -> false in match_let + | KpatFixed -> Term.eq_constr u.up_f + | KpatConst -> Term.eq_constr u.up_f + | KpatLam -> fun c -> + (match kind_of_term c with + | Lambda _ -> unif_EQ env sigma u.up_f c + | _ -> false) + | _ -> unif_EQ env sigma u.up_f in +let p2t p = mkApp(p.up_f,p.up_a) in +let source () = match upats_origin, upats with + | None, [p] -> + (if fixed_upat p then str"term " else str"partial term ") ++ + pr_constr_pat (p2t p) ++ spc() + | Some (dir,rule), [p] -> str"The " ++ pr_dir_side dir ++ str" of " ++ + pr_constr_pat rule ++ fnl() ++ ws 4 ++ pr_constr_pat (p2t p) ++ fnl() + | Some (dir,rule), _ -> str"The " ++ pr_dir_side dir ++ str" of " ++ + pr_constr_pat rule ++ spc() + | _, [] | None, _::_::_ -> + Errors.anomaly (str"mk_tpattern_matcher with no upats_origin") in +let on_instance, instances = + let instances = ref [] in + (fun x -> + if all_instances then instances := !instances @ [x] + else raise (FoundUnif x)), + (fun () -> !instances) in +let rec uniquize = function + | [] -> [] + | (sigma,_,{ up_f = f; up_a = a; up_t = t } as x) :: xs -> + let t = Reductionops.nf_evar sigma t in + let f = Reductionops.nf_evar sigma f in + let a = Array.map (Reductionops.nf_evar sigma) a in + let neq (sigma1,_,{ up_f = f1; up_a = a1; up_t = t1 }) = + let t1 = Reductionops.nf_evar sigma1 t1 in + let f1 = Reductionops.nf_evar sigma1 f1 in + let a1 = Array.map (Reductionops.nf_evar sigma1) a1 in + not (Term.eq_constr t t1 && + Term.eq_constr f f1 && CArray.for_all2 Term.eq_constr a a1) in + x :: uniquize (List.filter neq xs) in + +((fun env c h ~k -> + do_once upat_that_matched (fun () -> + try + if not all_instances then match_upats_FO upats env sigma0 ise c; + match_upats_HO ~on_instance upats env sigma0 ise c; + raise NoMatch + with FoundUnif sigma_u -> 0,[sigma_u] + | (NoMatch|NoProgress) when all_instances && instances () <> [] -> + 0, uniquize (instances ()) + | NoMatch when (not raise_NoMatch) -> + errorstrm (source () ++ str "does not match any subterm of the goal") + | NoProgress when (not raise_NoMatch) -> + let dir = match upats_origin with Some (d,_) -> d | _ -> + Errors.anomaly (str"mk_tpattern_matcher with no upats_origin") in + errorstrm (str"all matches of "++source()++ + str"are equal to the " ++ pr_dir_side (inv_dir dir)) + | NoProgress -> raise NoMatch); + let sigma, _, ({up_f = pf; up_a = pa} as u) = + if all_instances then assert_done_multires upat_that_matched + else List.hd (snd(assert_done upat_that_matched)) in + pp(lazy(str"sigma@tmatch=" ++ pr_evar_map None sigma)); + if !skip_occ then ((*ignore(k env u.up_t 0);*) c) else + let match_EQ = match_EQ env sigma u in + let pn = Array.length pa in + let rec subst_loop (env,h as acc) c' = + if !skip_occ then c' else + let f, a = splay_app sigma c' in + if Array.length a >= pn && match_EQ f && unif_EQ_args env sigma pa a then + let a1, a2 = Array.chop (Array.length pa) a in + let fa1 = mkApp (f, a1) in + let f' = if subst_occ () then k env u.up_t fa1 h else fa1 in + mkApp (f', Array.map_left (subst_loop acc) a2) + else + (* TASSI: clear letin values to avoid unfolding *) + let inc_h (n,_,ty) (env,h') = Environ.push_rel (n,None,ty) env, h' + 1 in + let f' = map_constr_with_binders_left_to_right inc_h subst_loop acc f in + mkApp (f', Array.map_left (subst_loop acc) a) in + subst_loop (env,h) c) : find_P), +((fun () -> + let sigma, uc, ({up_f = pf; up_a = pa} as u) = + match !upat_that_matched with + | Some (_,x) -> List.hd x | None when raise_NoMatch -> raise NoMatch + | None -> Errors.anomaly (str"companion function never called") in + let p' = mkApp (pf, pa) in + if max_occ <= !nocc then p', u.up_dir, (sigma, uc, u.up_t) + else errorstrm (str"Only " ++ int !nocc ++ str" < " ++ int max_occ ++ + str(String.plural !nocc " occurence") ++ match upats_origin with + | None -> str" of" ++ spc() ++ pr_constr_pat p' + | Some (dir,rule) -> str" of the " ++ pr_dir_side dir ++ fnl() ++ + ws 4 ++ pr_constr_pat p' ++ fnl () ++ + str"of " ++ pr_constr_pat rule)) : conclude) + +type ('ident, 'term) ssrpattern = + | T of 'term + | In_T of 'term + | X_In_T of 'ident * 'term + | In_X_In_T of 'ident * 'term + | E_In_X_In_T of 'term * 'ident * 'term + | E_As_X_In_T of 'term * 'ident * 'term + +let pr_pattern = function + | T t -> prl_term t + | In_T t -> str "in " ++ prl_term t + | X_In_T (x,t) -> prl_term x ++ str " in " ++ prl_term t + | In_X_In_T (x,t) -> str "in " ++ prl_term x ++ str " in " ++ prl_term t + | E_In_X_In_T (e,x,t) -> + prl_term e ++ str " in " ++ prl_term x ++ str " in " ++ prl_term t + | E_As_X_In_T (e,x,t) -> + prl_term e ++ str " as " ++ prl_term x ++ str " in " ++ prl_term t + +let pr_pattern_w_ids = function + | T t -> prl_term t + | In_T t -> str "in " ++ prl_term t + | X_In_T (x,t) -> pr_id x ++ str " in " ++ prl_term t + | In_X_In_T (x,t) -> str "in " ++ pr_id x ++ str " in " ++ prl_term t + | E_In_X_In_T (e,x,t) -> + prl_term e ++ str " in " ++ pr_id x ++ str " in " ++ prl_term t + | E_As_X_In_T (e,x,t) -> + prl_term e ++ str " as " ++ pr_id x ++ str " in " ++ prl_term t + +let pr_pattern_aux pr_constr = function + | T t -> pr_constr t + | In_T t -> str "in " ++ pr_constr t + | X_In_T (x,t) -> pr_constr x ++ str " in " ++ pr_constr t + | In_X_In_T (x,t) -> str "in " ++ pr_constr x ++ str " in " ++ pr_constr t + | E_In_X_In_T (e,x,t) -> + pr_constr e ++ str " in " ++ pr_constr x ++ str " in " ++ pr_constr t + | E_As_X_In_T (e,x,t) -> + pr_constr e ++ str " as " ++ pr_constr x ++ str " in " ++ pr_constr t +let pp_pattern (sigma, p) = + pr_pattern_aux (fun t -> pr_constr (pi3 (nf_open_term sigma sigma t))) p +let pr_cpattern = pr_term +let pr_rpattern _ _ _ = pr_pattern + +let pr_option f = function None -> mt() | Some x -> f x +let pr_ssrpattern _ _ _ = pr_option pr_pattern +let pr_pattern_squarep = pr_option (fun r -> str "[" ++ pr_pattern r ++ str "]") +let pr_ssrpattern_squarep _ _ _ = pr_pattern_squarep +let pr_pattern_roundp = pr_option (fun r -> str "(" ++ pr_pattern r ++ str ")") +let pr_ssrpattern_roundp _ _ _ = pr_pattern_roundp + +let wit_rpatternty = add_genarg "rpatternty" pr_pattern + +ARGUMENT EXTEND rpattern TYPED AS rpatternty PRINTED BY pr_rpattern + | [ lconstr(c) ] -> [ T (mk_lterm c) ] + | [ "in" lconstr(c) ] -> [ In_T (mk_lterm c) ] + | [ lconstr(x) "in" lconstr(c) ] -> + [ X_In_T (mk_lterm x, mk_lterm c) ] + | [ "in" lconstr(x) "in" lconstr(c) ] -> + [ In_X_In_T (mk_lterm x, mk_lterm c) ] + | [ lconstr(e) "in" lconstr(x) "in" lconstr(c) ] -> + [ E_In_X_In_T (mk_lterm e, mk_lterm x, mk_lterm c) ] + | [ lconstr(e) "as" lconstr(x) "in" lconstr(c) ] -> + [ E_As_X_In_T (mk_lterm e, mk_lterm x, mk_lterm c) ] +END + +type cpattern = char * glob_constr_and_expr +let tag_of_cpattern = fst +let loc_of_cpattern = loc_ofCG +let cpattern_of_term t = t +type occ = (bool * int list) option + +type rpattern = (cpattern, cpattern) ssrpattern +let pr_rpattern = pr_pattern + +type pattern = Evd.evar_map * (Term.constr, Term.constr) ssrpattern + + +let id_of_cpattern = function + | _,(_,Some (CRef (Ident (_, x), _))) -> Some x + | _,(_,Some (CAppExpl (_, (_, Ident (_, x), _), []))) -> Some x + | _,(GRef (_, VarRef x, _) ,None) -> Some x + | _ -> None +let id_of_Cterm t = match id_of_cpattern t with + | Some x -> x + | None -> loc_error (loc_of_cpattern t) "Only identifiers are allowed here" + +let interp_wit wit ist gl x = + let globarg = in_gen (glbwit wit) x in + let sigma, arg = interp_genarg ist (pf_env gl) (project gl) (pf_concl gl) gl.Evd.it globarg in + sigma, out_gen (topwit wit) arg +let interp_constr = interp_wit wit_constr +let interp_open_constr ist gl gc = + interp_wit wit_open_constr ist gl ((), gc) +let pf_intern_term ist gl (_, c) = glob_constr ist (pf_env gl) c +let interp_term ist gl (_, c) = snd (interp_open_constr ist gl c) +let glob_ssrterm gs = function + | k, (_, Some c) -> k, Tacintern.intern_constr gs c + | ct -> ct +let subst_ssrterm s (k, c) = k, Tacsubst.subst_glob_constr_and_expr s c +let pr_ssrterm _ _ _ = pr_term +let input_ssrtermkind strm = match Compat.get_tok (stream_nth 0 strm) with + | Tok.KEYWORD "(" -> '(' + | Tok.KEYWORD "@" -> '@' + | _ -> ' ' +let ssrtermkind = Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind + +(* This piece of code asserts the following notations are reserved *) +(* Reserved Notation "( a 'in' b )" (at level 0). *) +(* Reserved Notation "( a 'as' b )" (at level 0). *) +(* Reserved Notation "( a 'in' b 'in' c )" (at level 0). *) +(* Reserved Notation "( a 'as' b 'in' c )" (at level 0). *) +let glob_cpattern gs p = + pp(lazy(str"globbing pattern: " ++ pr_term p)); + let glob x = snd (glob_ssrterm gs (mk_lterm x)) in + let encode k s l = + let name = Name (id_of_string ("_ssrpat_" ^ s)) in + k, (mkRCast mkRHole (mkRLambda name mkRHole (mkRApp mkRHole l)), None) in + let bind_in t1 t2 = + let d = dummy_loc in let n = Name (destCVar t1) in + fst (glob (mkCCast d (mkCHole d) (mkCLambda d n (mkCHole d) t2))) in + let check_var t2 = if not (isCVar t2) then + loc_error (constr_loc t2) "Only identifiers are allowed here" in + match p with + | _, (_, None) as x -> x + | k, (v, Some t) as orig -> + if k = 'x' then glob_ssrterm gs ('(', (v, Some t)) else + match t with + | CNotation(_, "( _ in _ )", ([t1; t2], [], [])) -> + (try match glob t1, glob t2 with + | (r1, None), (r2, None) -> encode k "In" [r1;r2] + | (r1, Some _), (r2, Some _) when isCVar t1 -> + encode k "In" [r1; r2; bind_in t1 t2] + | (r1, Some _), (r2, Some _) -> encode k "In" [r1; r2] + | _ -> Errors.anomaly (str"where are we?") + with _ when isCVar t1 -> encode k "In" [bind_in t1 t2]) + | CNotation(_, "( _ in _ in _ )", ([t1; t2; t3], [], [])) -> + check_var t2; encode k "In" [fst (glob t1); bind_in t2 t3] + | CNotation(_, "( _ as _ )", ([t1; t2], [], [])) -> + encode k "As" [fst (glob t1); fst (glob t2)] + | CNotation(_, "( _ as _ in _ )", ([t1; t2; t3], [], [])) -> + check_var t2; encode k "As" [fst (glob t1); bind_in t2 t3] + | _ -> glob_ssrterm gs orig +;; + +let interp_ssrterm _ gl t = Tacmach.project gl, t + +ARGUMENT EXTEND cpattern + PRINTED BY pr_ssrterm + INTERPRETED BY interp_ssrterm + GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm + RAW_TYPED AS cpattern RAW_PRINTED BY pr_ssrterm + GLOB_TYPED AS cpattern GLOB_PRINTED BY pr_ssrterm +| [ "Qed" constr(c) ] -> [ mk_lterm c ] +END + +let (!@) = Compat.to_coqloc + +GEXTEND Gram + GLOBAL: cpattern; + cpattern: [[ k = ssrtermkind; c = constr -> + let pattern = mk_term k c in + if loc_ofCG pattern <> !@loc && k = '(' then mk_term 'x' c else pattern ]]; +END + +ARGUMENT EXTEND lcpattern + PRINTED BY pr_ssrterm + INTERPRETED BY interp_ssrterm + GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm + RAW_TYPED AS cpattern RAW_PRINTED BY pr_ssrterm + GLOB_TYPED AS cpattern GLOB_PRINTED BY pr_ssrterm +| [ "Qed" lconstr(c) ] -> [ mk_lterm c ] +END + +GEXTEND Gram + GLOBAL: lcpattern; + lcpattern: [[ k = ssrtermkind; c = lconstr -> + let pattern = mk_term k c in + if loc_ofCG pattern <> !@loc && k = '(' then mk_term 'x' c else pattern ]]; +END + +let interp_pattern ist gl red redty = + pp(lazy(str"interpreting: " ++ pr_pattern red)); + let xInT x y = X_In_T(x,y) and inXInT x y = In_X_In_T(x,y) in + let inT x = In_T x and eInXInT e x t = E_In_X_In_T(e,x,t) in + let eAsXInT e x t = E_As_X_In_T(e,x,t) in + let mkG ?(k=' ') x = k,(x,None) in + let decode t f g = + try match (pf_intern_term ist gl t) with + | GCast(_,GHole _,CastConv(GLambda(_,Name x,_,_,c))) -> f x (' ',(c,None)) + | it -> g t with _ -> g t in + let decodeG t f g = decode (mkG t) f g in + let bad_enc id _ = Errors.anomaly (str"bad encoding for pattern "++str id) in + let cleanup_XinE h x rp sigma = + let h_k = match kind_of_term h with Evar (k,_) -> k | _ -> assert false in + let to_clean, update = (* handle rename if x is already used *) + let ctx = pf_hyps gl in + let len = Context.named_context_length ctx in + let name = ref None in + try ignore(Context.lookup_named x ctx); (name, fun k -> + if !name = None then + let nctx = Evd.evar_context (Evd.find sigma k) in + let nlen = Context.named_context_length nctx in + if nlen > len then begin + name := Some (pi1 (List.nth nctx (nlen - len - 1))) + end) + with Not_found -> ref (Some x), fun _ -> () in + let sigma0 = project gl in + let new_evars = + let rec aux acc t = match kind_of_term t with + | Evar (k,_) -> + if k = h_k || List.mem k acc || Evd.mem sigma0 k then acc else + (update k; k::acc) + | _ -> fold_constr aux acc t in + aux [] (Evarutil.nf_evar sigma rp) in + let sigma = + List.fold_left (fun sigma e -> + if Evd.is_defined sigma e then sigma else (* clear may be recursiv *) + let name = Option.get !to_clean in + pp(lazy(pr_id name)); + try snd(Logic.prim_refiner (Proof_type.Thin [name]) sigma e) + with Evarutil.ClearDependencyError _ -> sigma) + sigma new_evars in + sigma in + let red = match red with + | T(k,(GCast (_,GHole _,(CastConv(GLambda (_,Name id,_,_,t)))),None)) + when let id = string_of_id id in let len = String.length id in + (len > 8 && String.sub id 0 8 = "_ssrpat_") -> + let id = string_of_id id in let len = String.length id in + (match String.sub id 8 (len - 8), t with + | "In", GApp(_, _, [t]) -> decodeG t xInT (fun x -> T x) + | "In", GApp(_, _, [e; t]) -> decodeG t (eInXInT (mkG e)) (bad_enc id) + | "In", GApp(_, _, [e; t; e_in_t]) -> + decodeG t (eInXInT (mkG e)) + (fun _ -> decodeG e_in_t xInT (fun _ -> assert false)) + | "As", GApp(_, _, [e; t]) -> decodeG t (eAsXInT (mkG e)) (bad_enc id) + | _ -> bad_enc id ()) + | T t -> decode t xInT (fun x -> T x) + | In_T t -> decode t inXInT inT + | X_In_T (e,t) -> decode t (eInXInT e) (fun x -> xInT (id_of_Cterm e) x) + | In_X_In_T (e,t) -> inXInT (id_of_Cterm e) t + | E_In_X_In_T (e,x,rp) -> eInXInT e (id_of_Cterm x) rp + | E_As_X_In_T (e,x,rp) -> eAsXInT e (id_of_Cterm x) rp in + pp(lazy(str"decoded as: " ++ pr_pattern_w_ids red)); + let red = match redty with None -> red | Some ty -> let ty = ' ', ty in + match red with + | T t -> T (combineCG t ty (mkCCast (loc_ofCG t)) mkRCast) + | X_In_T (x,t) -> + let ty = pf_intern_term ist gl ty in + E_As_X_In_T (mkG (mkRCast mkRHole ty), x, t) + | E_In_X_In_T (e,x,t) -> + let ty = mkG (pf_intern_term ist gl ty) in + E_In_X_In_T (combineCG e ty (mkCCast (loc_ofCG t)) mkRCast, x, t) + | E_As_X_In_T (e,x,t) -> + let ty = mkG (pf_intern_term ist gl ty) in + E_As_X_In_T (combineCG e ty (mkCCast (loc_ofCG t)) mkRCast, x, t) + | red -> red in + pp(lazy(str"typed as: " ++ pr_pattern_w_ids red)); + let mkXLetIn loc x (a,(g,c)) = match c with + | Some b -> a,(g,Some (mkCLetIn loc x (mkCHole loc) b)) + | None -> a,(GLetIn (loc,x,(GHole (loc, BinderType x, IntroAnonymous, None)), g), None) in + match red with + | T t -> let sigma, t = interp_term ist gl t in sigma, T t + | In_T t -> let sigma, t = interp_term ist gl t in sigma, In_T t + | X_In_T (x, rp) | In_X_In_T (x, rp) -> + let mk x p = match red with X_In_T _ -> X_In_T(x,p) | _ -> In_X_In_T(x,p) in + let rp = mkXLetIn dummy_loc (Name x) rp in + let sigma, rp = interp_term ist gl rp in + let _, h, _, rp = destLetIn rp in + let sigma = cleanup_XinE h x rp sigma in + let rp = subst1 h (Evarutil.nf_evar sigma rp) in + sigma, mk h rp + | E_In_X_In_T(e, x, rp) | E_As_X_In_T (e, x, rp) -> + let mk e x p = + match red with E_In_X_In_T _ ->E_In_X_In_T(e,x,p)|_->E_As_X_In_T(e,x,p) in + let rp = mkXLetIn dummy_loc (Name x) rp in + let sigma, rp = interp_term ist gl rp in + let _, h, _, rp = destLetIn rp in + let sigma = cleanup_XinE h x rp sigma in + let rp = subst1 h (Evarutil.nf_evar sigma rp) in + let sigma, e = interp_term ist (re_sig (sig_it gl) sigma) e in + sigma, mk e h rp +;; +let interp_cpattern ist gl red redty = interp_pattern ist gl (T red) redty;; +let interp_rpattern ist gl red = interp_pattern ist gl red None;; + +(* The full occurrence set *) +let noindex = Some(false,[]) + +(* calls do_subst on every sub-term identified by (pattern,occ) *) +let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = + let fs sigma x = Reductionops.nf_evar sigma x in + let pop_evar sigma e p = + let { Evd.evar_body = e_body } as e_def = Evd.find sigma e in + let e_body = match e_body with Evar_defined c -> c + | _ -> errorstrm (str "Matching the pattern " ++ pr_constr p ++ + str " did not instantiate ?" ++ int (Evar.repr e) ++ spc () ++ + str "Does the variable bound by the \"in\" construct occur "++ + str "in the pattern?") in + let sigma = + Evd.add (Evd.remove sigma e) e {e_def with Evd.evar_body = Evar_empty} in + sigma, e_body in + let ex_value hole = + match kind_of_term hole with Evar (e,_) -> e | _ -> assert false in + let mk_upat_for ?hack env sigma0 (sigma, t) ?(p=t) ok = + let sigma,pat= mk_tpattern ?hack env sigma0 (sigma,p) ok L2R (fs sigma t) in + sigma, [pat] in + match pattern with + | None -> do_subst env0 concl0 concl0 1 + | Some (sigma, (T rp | In_T rp)) -> + let rp = fs sigma rp in + let ise = create_evar_defs sigma in + let occ = match pattern with Some (_, T _) -> occ | _ -> noindex in + let rp = mk_upat_for env0 sigma0 (ise, rp) all_ok in + let find_T, end_T = mk_tpattern_matcher ?raise_NoMatch sigma0 occ rp in + let concl = find_T env0 concl0 1 do_subst in + let _ = end_T () in + concl + | Some (sigma, (X_In_T (hole, p) | In_X_In_T (hole, p))) -> + let p = fs sigma p in + let occ = match pattern with Some (_, X_In_T _) -> occ | _ -> noindex in + let ex = ex_value hole in + let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in + let find_T, end_T = mk_tpattern_matcher sigma0 noindex rp in + (* we start from sigma, so hole is considered a rigid head *) + let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in + let find_X, end_X = mk_tpattern_matcher ?raise_NoMatch sigma occ holep in + let concl = find_T env0 concl0 1 (fun env c _ h -> + let p_sigma = unify_HO env (create_evar_defs sigma) c p in + let sigma, e_body = pop_evar p_sigma ex p in + fs p_sigma (find_X env (fs sigma p) h + (fun env _ -> do_subst env e_body))) in + let _ = end_X () in let _ = end_T () in + concl + | Some (sigma, E_In_X_In_T (e, hole, p)) -> + let p, e = fs sigma p, fs sigma e in + let ex = ex_value hole in + let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in + let find_T, end_T = mk_tpattern_matcher sigma0 noindex rp in + let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in + let find_X, end_X = mk_tpattern_matcher sigma noindex holep in + let re = mk_upat_for env0 sigma0 (sigma, e) all_ok in + let find_E, end_E = mk_tpattern_matcher ?raise_NoMatch sigma0 occ re in + let concl = find_T env0 concl0 1 (fun env c _ h -> + let p_sigma = unify_HO env (create_evar_defs sigma) c p in + let sigma, e_body = pop_evar p_sigma ex p in + fs p_sigma (find_X env (fs sigma p) h (fun env c _ h -> + find_E env e_body h do_subst))) in + let _ = end_E () in let _ = end_X () in let _ = end_T () in + concl + | Some (sigma, E_As_X_In_T (e, hole, p)) -> + let p, e = fs sigma p, fs sigma e in + let ex = ex_value hole in + let rp = + let e_sigma = unify_HO env0 sigma hole e in + e_sigma, fs e_sigma p in + let rp = mk_upat_for ~hack:true env0 sigma0 rp all_ok in + let find_TE, end_TE = mk_tpattern_matcher sigma0 noindex rp in + let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in + let find_X, end_X = mk_tpattern_matcher sigma occ holep in + let concl = find_TE env0 concl0 1 (fun env c _ h -> + let p_sigma = unify_HO env (create_evar_defs sigma) c p in + let sigma, e_body = pop_evar p_sigma ex p in + fs p_sigma (find_X env (fs sigma p) h (fun env c _ h -> + let e_sigma = unify_HO env sigma e_body e in + let e_body = fs e_sigma e in + do_subst env e_body e_body h))) in + let _ = end_X () in let _ = end_TE () in + concl +;; + +let redex_of_pattern ?(resolve_typeclasses=false) env (sigma, p) = + let e = match p with + | In_T _ | In_X_In_T _ -> Errors.anomaly (str"pattern without redex") + | T e | X_In_T (e, _) | E_As_X_In_T (e, _, _) | E_In_X_In_T (e, _, _) -> e in + let sigma = + if not resolve_typeclasses then sigma + else Typeclasses.resolve_typeclasses ~fail:false env sigma in + Reductionops.nf_evar sigma e, Evd.evar_universe_context sigma + +let fill_occ_pattern ?raise_NoMatch env sigma cl pat occ h = + let find_R, conclude = let r = ref None in + (fun env c _ h' -> do_once r (fun () -> c, Evd.empty_evar_universe_context); + mkRel (h'+h-1)), + (fun _ -> if !r = None then redex_of_pattern env pat else assert_done r) in + let cl = eval_pattern ?raise_NoMatch env sigma cl (Some pat) occ find_R in + let e = conclude cl in + e, cl +;; + +(* clenup interface for external use *) +let mk_tpattern ?p_origin env sigma0 sigma_t f dir c = + mk_tpattern ?p_origin env sigma0 sigma_t f dir c +;; + +let pf_fill_occ env concl occ sigma0 p (sigma, t) ok h = + let ise = create_evar_defs sigma in + let ise, u = mk_tpattern env sigma0 (ise,t) ok L2R p in + let find_U, end_U = + mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[u]) in + let concl = find_U env concl h (fun _ _ _ -> mkRel) in + let rdx, _, (sigma, uc, p) = end_U () in + sigma, uc, p, concl, rdx + +let fill_occ_term env cl occ sigma0 (sigma, t) = + try + let sigma',uc,t',cl,_= pf_fill_occ env cl occ sigma0 t (sigma, t) all_ok 1 in + if sigma' != sigma0 then Errors.error "matching impacts evars" + else cl, (Evd.merge_universe_context sigma' uc, t') + with NoMatch -> try + let sigma', uc, t' = + unif_end env sigma0 (create_evar_defs sigma) t (fun _ -> true) in + if sigma' != sigma0 then raise NoMatch + else cl, (Evd.merge_universe_context sigma' uc, t') + with _ -> + errorstrm (str "partial term " ++ pr_constr_pat t + ++ str " does not match any subterm of the goal") + +let pf_fill_occ_term gl occ t = + let sigma0 = project gl and env = pf_env gl and concl = pf_concl gl in + let cl,(_,t) = fill_occ_term env concl occ sigma0 t in + cl, t + +let cpattern_of_id id = ' ', (GRef (dummy_loc, VarRef id, None), None) + +let is_wildcard = function + | _,(_,Some (CHole _)|GHole _,None) -> true + | _ -> false + +(* "ssrpattern" *) +let pr_ssrpatternarg _ _ _ cpat = pr_rpattern cpat + +ARGUMENT EXTEND ssrpatternarg + TYPED AS rpattern + PRINTED BY pr_ssrpatternarg +| [ "[" rpattern(pat) "]" ] -> [ pat ] +END + +let pf_merge_uc uc gl = + re_sig (sig_it gl) (Evd.merge_universe_context (project gl) uc) + +let ssrpatterntac ist arg gl = + let pat = interp_rpattern ist gl arg in + let sigma0 = project gl in + let concl0 = pf_concl gl in + let (t, uc), concl_x = + fill_occ_pattern (Global.env()) sigma0 concl0 pat noindex 1 in + let tty = pf_type_of gl t in + let concl = mkLetIn (Name (id_of_string "toto"), t, tty, concl_x) in + Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl + +TACTIC EXTEND ssrat +| [ "ssrpattern" ssrpatternarg(arg) ] -> [ Proofview.V82.tactic (ssrpatterntac ist arg) ] +END + +let ssrinstancesof ist arg gl = + let ok rhs lhs ise = true in +(* not (Term.eq_constr lhs (Evarutil.nf_evar ise rhs)) in *) + let env, sigma, concl = pf_env gl, project gl, pf_concl gl in + let sigma0, cpat = interp_cpattern ist gl arg None in + let pat = match cpat with T x -> x | _ -> errorstrm (str"Not supported") in + let etpat, tpat = mk_tpattern env sigma (sigma0,pat) (ok pat) L2R pat in + let find, conclude = + mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true + sigma None (etpat,[tpat]) in + let print env p c _ = ppnl (hov 1 (str"instance:" ++ spc() ++ pr_constr p ++ spc() ++ str "matches:" ++ spc() ++ pr_constr c)); c in + ppnl (str"BEGIN INSTANCES"); + try + while true do + ignore(find env concl 1 ~k:print) + done; raise NoMatch + with NoMatch -> ppnl (str"END INSTANCES"); tclIDTAC gl + +TACTIC EXTEND ssrinstoftpat +| [ "ssrinstancesoftpat" cpattern(arg) ] -> [ Proofview.V82.tactic (ssrinstancesof ist arg) ] +END + +(* We wipe out all the keywords generated by the grammar rules we defined. *) +(* The user is supposed to Require Import ssreflect or Require ssreflect *) +(* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) +(* consequence the extended ssreflect grammar. *) +let () = Lexer.unfreeze frozen_lexer ;; + +(* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/mathcomp/ssreflect/plugin/v8.5/ssrmatching.mli b/mathcomp/ssreflect/plugin/v8.5/ssrmatching.mli new file mode 100644 index 0000000..e8b4d81 --- /dev/null +++ b/mathcomp/ssreflect/plugin/v8.5/ssrmatching.mli @@ -0,0 +1,239 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) + +open Genarg +open Tacexpr +open Environ +open Evd +open Proof_type +open Term + +(** ******** Small Scale Reflection pattern matching facilities ************* *) + +(** Pattern parsing *) + +(** The type of context patterns, the patterns of the [set] tactic and + [:] tactical. These are patterns that identify a precise subterm. *) +type cpattern +val pr_cpattern : cpattern -> Pp.std_ppcmds + +(** CS cpattern: (f _), (X in t), (t in X in t), (t as X in t) *) +val cpattern : cpattern Pcoq.Gram.entry +val wit_cpattern : cpattern uniform_genarg_type + +(** OS cpattern: f _, (X in t), (t in X in t), (t as X in t) *) +val lcpattern : cpattern Pcoq.Gram.entry +val wit_lcpattern : cpattern uniform_genarg_type + +(** The type of rewrite patterns, the patterns of the [rewrite] tactic. + These patterns also include patterns that identify all the subterms + of a context (i.e. "in" prefix) *) +type rpattern +val pr_rpattern : rpattern -> Pp.std_ppcmds + +(** OS rpattern: f _, in t, X in t, in X in t, t in X in t, t as X in t *) +val rpattern : rpattern Pcoq.Gram.entry +val wit_rpattern : rpattern uniform_genarg_type + +(** Pattern interpretation and matching *) + +exception NoMatch +exception NoProgress + +(** AST for [rpattern] (and consequently [cpattern]) *) +type ('ident, 'term) ssrpattern = + | T of 'term + | In_T of 'term + | X_In_T of 'ident * 'term + | In_X_In_T of 'ident * 'term + | E_In_X_In_T of 'term * 'ident * 'term + | E_As_X_In_T of 'term * 'ident * 'term + +type pattern = evar_map * (constr, constr) ssrpattern +val pp_pattern : pattern -> Pp.std_ppcmds + +(** Extracts the redex and applies to it the substitution part of the pattern. + @raise Anomaly if called on [In_T] or [In_X_In_T] *) +val redex_of_pattern : + ?resolve_typeclasses:bool -> env -> pattern -> + constr Evd.in_evar_universe_context + +(** [interp_rpattern ise gl rpat] "internalizes" and "interprets" [rpat] + in the current [Ltac] interpretation signature [ise] and tactic input [gl]*) +val interp_rpattern : + Tacinterp.interp_sign -> goal Tacmach.sigma -> + rpattern -> + pattern + +(** [interp_cpattern ise gl cpat ty] "internalizes" and "interprets" [cpat] + in the current [Ltac] interpretation signature [ise] and tactic input [gl]. + [ty] is an optional type for the redex of [cpat] *) +val interp_cpattern : + Tacinterp.interp_sign -> goal Tacmach.sigma -> + cpattern -> glob_constr_and_expr option -> + pattern + +(** The set of occurrences to be matched. The boolean is set to true + * to signal the complement of this set (i.e. {-1 3}) *) +type occ = (bool * int list) option + +(** [subst e p t i]. [i] is the number of binders + traversed so far, [p] the term from the pattern, [t] the matched one *) +type subst = env -> constr -> constr -> int -> constr + +(** [eval_pattern b env sigma t pat occ subst] maps [t] calling [subst] on every + [occ] occurrence of [pat]. The [int] argument is the number of + binders traversed. If [pat] is [None] then then subst is called on [t]. + [t] must live in [env] and [sigma], [pat] must have been interpreted in + (an extension of) [sigma]. + @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false]) + @return [t] where all [occ] occurrences of [pat] have been mapped using + [subst] *) +val eval_pattern : + ?raise_NoMatch:bool -> + env -> evar_map -> constr -> + pattern option -> occ -> subst -> + constr + +(** [fill_occ_pattern b env sigma t pat occ h] is a simplified version of + [eval_pattern]. + It replaces all [occ] occurrences of [pat] in [t] with Rel [h]. + [t] must live in [env] and [sigma], [pat] must have been interpreted in + (an extension of) [sigma]. + @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false]) + @return the instance of the redex of [pat] that was matched and [t] + transformed as described above. *) +val fill_occ_pattern : + ?raise_NoMatch:bool -> + env -> evar_map -> constr -> + pattern -> occ -> int -> + constr Evd.in_evar_universe_context * constr + +(** *************************** Low level APIs ****************************** *) + +(* The primitive matching facility. It matches of a term with holes, like + the T pattern above, and calls a continuation on its occurrences. *) + +type ssrdir = L2R | R2L +val pr_dir_side : ssrdir -> Pp.std_ppcmds + +(** a pattern for a term with wildcards *) +type tpattern + +(** [mk_tpattern env sigma0 sigma_p ok p_origin dir t] compiles a term [t] + living in [env] [sigma] (an extension of [sigma0]) intro a [tpattern]. + The [tpattern] can hold a (proof) term [p] and a diction [dir]. The [ok] + callback is used to filter occurrences. + @return the compiled [tpattern] and its [evar_map] + @raise UserEerror is the pattern is a wildcard *) +val mk_tpattern : + ?p_origin:ssrdir * constr -> + env -> evar_map -> + evar_map * constr -> + (constr -> evar_map -> bool) -> + ssrdir -> constr -> + evar_map * tpattern + +(** [findP env t i k] is a stateful function that finds the next occurrence + of a tpattern and calls the callback [k] to map the subterm matched. + The [int] argument passed to [k] is the number of binders traversed so far + plus the initial value [i]. + @return [t] where the subterms identified by the selected occurrences of + the patter have been mapped using [k] + @raise NoMatch if the raise_NoMatch flag given to [mk_tpattern_matcher] is + [true] and if the pattern did not match + @raise UserEerror if the raise_NoMatch flag given to [mk_tpattern_matcher] is + [false] and if the pattern did not match *) +type find_P = + env -> constr -> int -> k:subst -> constr + +(** [conclude ()] asserts that all mentioned ocurrences have been visited. + @return the instance of the pattern, the evarmap after the pattern + instantiation, the proof term and the ssrdit stored in the tpattern + @raise UserEerror if too many occurrences were specified *) +type conclude = + unit -> constr * ssrdir * (evar_map * Evd.evar_universe_context * constr) + +(** [mk_tpattern_matcher b o sigma0 occ sigma_tplist] creates a pair + a function [find_P] and [conclude] with the behaviour explained above. + The flag [b] (default [false]) changes the error reporting behaviour + of [find_P] if none of the [tpattern] matches. The argument [o] can + be passed to tune the [UserError] eventually raised (useful if the + pattern is coming from the LHS/RHS of an equation) *) +val mk_tpattern_matcher : + ?all_instances:bool -> + ?raise_NoMatch:bool -> + ?upats_origin:ssrdir * constr -> + evar_map -> occ -> evar_map * tpattern list -> + find_P * conclude + +(** Example of [mk_tpattern_matcher] to implement + [rewrite \{occ\}\[in t\]rules]. + It first matches "in t" (called [pat]), then in all matched subterms + it matches the LHS of the rules using [find_R]. + [concl0] is the initial goal, [concl] will be the goal where some terms + are replaced by a De Bruijn index. The [rw_progress] extra check + selects only occurrences that are not rewritten to themselves (e.g. + an occurrence "x + x" rewritten with the commutativity law of addition + is skipped) {[ + let find_R, conclude = match pat with + | Some (_, In_T _) -> + let aux (sigma, pats) (d, r, lhs, rhs) = + let sigma, pat = + mk_tpattern env0 sigma0 (sigma, r) (rw_progress rhs) d lhs in + sigma, pats @ [pat] in + let rpats = List.fold_left aux (r_sigma, []) rules in + let find_R, end_R = mk_tpattern_matcher sigma0 occ rpats in + find_R ~k:(fun _ _ h -> mkRel h), + fun cl -> let rdx, d, r = end_R () in (d,r),rdx + | _ -> ... in + let concl = eval_pattern env0 sigma0 concl0 pat occ find_R in + let (d, r), rdx = conclude concl in ]} *) + +(* convenience shortcut: [pf_fill_occ_term gl occ (sigma,t)] returns + * the conclusion of [gl] where [occ] occurrences of [t] have been replaced + * by [Rel 1] and the instance of [t] *) +val pf_fill_occ_term : + goal Tacmach.sigma -> occ -> evar_map * constr -> constr * constr + +(* It may be handy to inject a simple term into the first form of cpattern *) +val cpattern_of_term : char * glob_constr_and_expr -> cpattern + +(** Helpers to make stateful closures. Example: a [find_P] function may be + called many times, but the pattern instantiation phase is performed only the + first time. The corresponding [conclude] has to return the instantiated + pattern redex. Since it is up to [find_P] to raise [NoMatch] if the pattern + has no instance, [conclude] considers it an anomaly if the pattern did + not match *) + +(** [do_once r f] calls [f] and updates the ref only once *) +val do_once : 'a option ref -> (unit -> 'a) -> unit +(** [assert_done r] return the content of r. @raise Anomaly is r is [None] *) +val assert_done : 'a option ref -> 'a + +(** Very low level APIs. + these are calls to evarconv's [the_conv_x] followed by + [consider_remaining_unif_problems] and [resolve_typeclasses]. + In case of failure they raise [NoMatch] *) + +val unify_HO : env -> evar_map -> constr -> constr -> evar_map +val pf_unify_HO : goal Tacmach.sigma -> constr -> constr -> goal Tacmach.sigma + +(** Some more low level functions needed to implement the full SSR language + on top of the former APIs *) +val tag_of_cpattern : cpattern -> char +val loc_of_cpattern : cpattern -> Loc.t +val id_of_cpattern : cpattern -> Names.variable option +val is_wildcard : cpattern -> bool +val cpattern_of_id : Names.variable -> cpattern +val cpattern_of_id : Names.variable -> cpattern +val pr_constr_pat : constr -> Pp.std_ppcmds +val pf_merge_uc : Evd.evar_universe_context -> goal Evd.sigma -> goal Evd.sigma + +(* One can also "Set SsrMatchingDebug" from a .v *) +val debug : bool -> unit + +(* One should delimit a snippet with "Set SsrMatchingProfiling" and + * "Unset SsrMatchingProfiling" to get timings *) +val profile : bool -> unit + +(* eof *) diff --git a/mathcomp/ssreflect/seq.v b/mathcomp/ssreflect/seq.v new file mode 100644 index 0000000..8522017 --- /dev/null +++ b/mathcomp/ssreflect/seq.v @@ -0,0 +1,2552 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat. + +(******************************************************************************) +(* The seq type is the ssreflect type for sequences; it is an alias for the *) +(* standard Coq list type. The ssreflect library equips it with many *) +(* operations, as well as eqType and predType (and, later, choiceType) *) +(* structures. The operations are geared towards reflection: they generally *) +(* expect and provide boolean predicates, e.g., the membership predicate *) +(* expects an eqType. To avoid any confusion we do not Import the Coq List *) +(* module. *) +(* As there is no true subtyping in Coq, we don't use a type for non-empty *) +(* sequences; rather, we pass explicitly the head and tail of the sequence. *) +(* The empty sequence is especially bothersome for subscripting, since it *) +(* forces us to pass a default value. This default value can often be hidden *) +(* by a notation. *) +(* Here is the list of seq operations: *) +(* ** Constructors: *) +(* seq T == the type of sequences with items of type T *) +(* bitseq == seq bool *) +(* [::], nil, Nil T == the empty sequence (of type T) *) +(* x :: s, cons x s, Cons T x s == the sequence x followed by s (of type T) *) +(* [:: x] == the singleton sequence *) +(* [:: x_0; ...; x_n] == the explicit sequence of the x_i *) +(* [:: x_0, ..., x_n & s] == the sequence of the x_i, followed by s *) +(* rcons s x == the sequence s, followed by x *) +(* All of the above, except rcons, can be used in patterns. We define a view *) +(* lastP and an induction principle last_ind that can be used to decompose *) +(* or traverse a sequence in a right to left order. The view lemma lastP has *) +(* a dependent family type, so the ssreflect tactic case/lastP: p => [|p' x] *) +(* will generate two subgoals in which p has been replaced by [::] and by *) +(* rcons p' x, respectively. *) +(* ** Factories: *) +(* nseq n x == a sequence of n x's *) +(* ncons n x s == a sequence of n x's, followed by s *) +(* seqn n x_0 ... x_n-1 == the sequence of the x_i (can be partially applied) *) +(* iota m n == the sequence m, m + 1, ..., m + n - 1 *) +(* mkseq f n == the sequence f 0, f 1, ..., f (n - 1) *) +(* ** Sequential access: *) +(* head x0 s == the head (zero'th item) of s if s is non-empty, else x0 *) +(* ohead s == None if s is empty, else Some x where x is the head of s *) +(* behead s == s minus its head, i.e., s' if s = x :: s', else [::] *) +(* last x s == the last element of x :: s (which is non-empty) *) +(* belast x s == x :: s minus its last item *) +(* ** Dimensions: *) +(* size s == the number of items (length) in s *) +(* shape ss == the sequence of sizes of the items of the sequence of *) +(* sequences ss *) +(* ** Random access: *) +(* nth x0 s i == the item i of s (numbered from 0), or x0 if s does *) +(* not have at least i+1 items (i.e., size x <= i) *) +(* s`_i == standard notation for nth x0 s i for a default x0, *) +(* e.g., 0 for rings. *) +(* set_nth x0 s i y == s where item i has been changed to y; if s does not *) +(* have an item i, it is first padded with copies of x0 *) +(* to size i+1. *) +(* incr_nth s i == the nat sequence s with item i incremented (s is *) +(* first padded with 0's to size i+1, if needed). *) +(* ** Predicates: *) +(* nilp s == s is [::] *) +(* := (size s == 0) *) +(* x \in s == x appears in s (this requires an eqType for T) *) +(* index x s == the first index at which x appears in s, or size s if *) +(* x \notin s *) +(* has p s == the (applicative, boolean) predicate p holds for some *) +(* item in s *) +(* all p s == p holds for all items in s *) +(* find p s == the index of the first item in s for which p holds, *) +(* or size s if no such item is found *) +(* count p s == the number of items of s for which p holds *) +(* count_mem x s == the number of times x occurs in s := count (pred1 x) s *) +(* constant s == all items in s are identical (trivial if s = [::]) *) +(* uniq s == all the items in s are pairwise different *) +(* subseq s1 s2 == s1 is a subsequence of s2, i.e., s1 = mask m s2 for *) +(* some m : bitseq (see below). *) +(* perm_eq s1 s2 == s2 is a permutation of s1, i.e., s1 and s2 have the *) +(* items (with the same repetitions), but possibly in a *) +(* different order. *) +(* perm_eql s1 s2 <-> s1 and s2 behave identically on the left of perm_eq *) +(* perm_eqr s1 s2 <-> s1 and s2 behave identically on the rightt of perm_eq *) +(* These left/right transitive versions of perm_eq make it easier to chain *) +(* a sequence of equivalences. *) +(* ** Filtering: *) +(* filter p s == the subsequence of s consisting of all the items *) +(* for which the (boolean) predicate p holds *) +(* subfilter s : seq sT == when sT has a subType p structure, the sequence *) +(* of items of type sT corresponding to items of s *) +(* for which p holds. *) +(* rem x s == the subsequence of s, where the first occurrence *) +(* of x has been removed (compare filter (predC1 x) s *) +(* where ALL occurrences of x are removed). *) +(* undup s == the subsequence of s containing only the first *) +(* occurrence of each item in s, i.e., s with all *) +(* duplicates removed. *) +(* mask m s == the subsequence of s selected by m : bitseq, with *) +(* item i of s selected by bit i in m (extra items or *) +(* bits are ignored. *) +(* ** Surgery: *) +(* s1 ++ s2, cat s1 s2 == the concatenation of s1 and s2. *) +(* take n s == the sequence containing only the first n items of s *) +(* (or all of s if size s <= n). *) +(* drop n s == s minus its first n items ([::] if size s <= n) *) +(* rot n s == s rotated left n times (or s if size s <= n). *) +(* := drop n s ++ take n s *) +(* rotr n s == s rotated right n times (or s if size s <= n). *) +(* rev s == the (linear time) reversal of s. *) +(* catrev s1 s2 == the reversal of s1 followed by s2 (this is the *) +(* recursive form of rev). *) +(* ** Iterators: for s == [:: x_1, ..., x_n], t == [:: y_1, ..., y_m], *) +(* map f s == the sequence [:: f x_1, ..., f x_n]. *) +(* allpairs f s t == the sequence of all the f x y, with x and y drawn from *) +(* s and t, respectively, in row-major order. *) +(* := [:: f x_1 y_1; ...; f x_1 y_m; f x_2 y_1; ...; f x_n y_m] *) +(* pmap pf s == the sequence [:: y_i1, ..., y_ik] where i1 < ... < ik, *) +(* pf x_i = Some y_i, and pf x_j = None iff j is not in *) +(* {i1, ..., ik}. *) +(* foldr f a s == the right fold of s by f (i.e., the natural iterator). *) +(* := f x_1 (f x_2 ... (f x_n a)) *) +(* sumn s == x_1 + (x_2 + ... + (x_n + 0)) (when s : seq nat). *) +(* foldl f a s == the left fold of s by f. *) +(* := f (f ... (f a x_1) ... x_n-1) x_n *) +(* scanl f a s == the sequence of partial accumulators of foldl f a s. *) +(* := [:: f a x_1; ...; foldl f a s] *) +(* pairmap f a s == the sequence of f applied to consecutive items in a :: s. *) +(* := [:: f a x_1; f x_1 x_2; ...; f x_n-1 x_n] *) +(* zip s t == itemwise pairing of s and t (dropping any extra items). *) +(* := [:: (x_1, y_1); ...; (x_mn, y_mn)] with mn = minn n m. *) +(* unzip1 s == [:: (x_1).1; ...; (x_n).1] when s : seq (S * T). *) +(* unzip2 s == [:: (x_1).2; ...; (x_n).2] when s : seq (S * T). *) +(* flatten s == x_1 ++ ... ++ x_n ++ [::] when s : seq (seq T). *) +(* reshape r s == s reshaped into a sequence of sequences whose sizes are *) +(* given by r (truncating if s is too long or too short). *) +(* := [:: [:: x_1; ...; x_r1]; *) +(* [:: x_(r1 + 1); ...; x_(r0 + r1)]; *) +(* ...; *) +(* [:: x_(r1 + ... + r(k-1) + 1); ...; x_(r0 + ... rk)]] *) +(* ** Notation for manifest comprehensions: *) +(* [seq x <- s | C] := filter (fun x => C) s. *) +(* [seq E | x <- s] := map (fun x => E) s. *) +(* [seq E | x <- s, y <- t] := allpairs (fun x y => E) s t. *) +(* [seq x <- s | C1 & C2] := [seq x <- s | C1 && C2]. *) +(* [seq E | x <- s & C] := [seq E | x <- [seq x | C]]. *) +(* --> The above allow optional type casts on the eigenvariables, as in *) +(* [seq x : T <- s | C] or [seq E | x : T <- s, y : U <- t]. The cast may be *) +(* needed as type inference considers E or C before s. *) +(* We are quite systematic in providing lemmas to rewrite any composition *) +(* of two operations. "rev", whose simplifications are not natural, is *) +(* protected with nosimpl. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Delimit Scope seq_scope with SEQ. +Open Scope seq_scope. + +(* Inductive seq (T : Type) : Type := Nil | Cons of T & seq T. *) +Notation seq := list. +Prenex Implicits cons. +Notation Cons T := (@cons T) (only parsing). +Notation Nil T := (@nil T) (only parsing). + +Bind Scope seq_scope with list. +Arguments Scope cons [type_scope _ seq_scope]. + +(* As :: and ++ are (improperly) declared in Init.datatypes, we only rebind *) +(* them here. *) +Infix "::" := cons : seq_scope. + +(* GG - this triggers a camlp4 warning, as if this Notation had been Reserved *) +Notation "[ :: ]" := nil (at level 0, format "[ :: ]") : seq_scope. + +Notation "[ :: x1 ]" := (x1 :: [::]) + (at level 0, format "[ :: x1 ]") : seq_scope. + +Notation "[ :: x & s ]" := (x :: s) (at level 0, only parsing) : seq_scope. + +Notation "[ :: x1 , x2 , .. , xn & s ]" := (x1 :: x2 :: .. (xn :: s) ..) + (at level 0, format + "'[hv' [ :: '[' x1 , '/' x2 , '/' .. , '/' xn ']' '/ ' & s ] ']'" + ) : seq_scope. + +Notation "[ :: x1 ; x2 ; .. ; xn ]" := (x1 :: x2 :: .. [:: xn] ..) + (at level 0, format "[ :: '[' x1 ; '/' x2 ; '/' .. ; '/' xn ']' ]" + ) : seq_scope. + +Section Sequences. + +Variable n0 : nat. (* numerical parameter for take, drop et al *) +Variable T : Type. (* must come before the implicit Type *) +Variable x0 : T. (* default for head/nth *) + +Implicit Types x y z : T. +Implicit Types m n : nat. +Implicit Type s : seq T. + +Fixpoint size s := if s is _ :: s' then (size s').+1 else 0. + +Lemma size0nil s : size s = 0 -> s = [::]. Proof. by case: s. Qed. + +Definition nilp s := size s == 0. + +Lemma nilP s : reflect (s = [::]) (nilp s). +Proof. by case: s => [|x s]; constructor. Qed. + +Definition ohead s := if s is x :: _ then Some x else None. +Definition head s := if s is x :: _ then x else x0. + +Definition behead s := if s is _ :: s' then s' else [::]. + +Lemma size_behead s : size (behead s) = (size s).-1. +Proof. by case: s. Qed. + +(* Factories *) + +Definition ncons n x := iter n (cons x). +Definition nseq n x := ncons n x [::]. + +Lemma size_ncons n x s : size (ncons n x s) = n + size s. +Proof. by elim: n => //= n ->. Qed. + +Lemma size_nseq n x : size (nseq n x) = n. +Proof. by rewrite size_ncons addn0. Qed. + +(* n-ary, dependently typed constructor. *) + +Fixpoint seqn_type n := if n is n'.+1 then T -> seqn_type n' else seq T. + +Fixpoint seqn_rec f n : seqn_type n := + if n is n'.+1 return seqn_type n then + fun x => seqn_rec (fun s => f (x :: s)) n' + else f [::]. +Definition seqn := seqn_rec id. + +(* Sequence catenation "cat". *) + +Fixpoint cat s1 s2 := if s1 is x :: s1' then x :: s1' ++ s2 else s2 +where "s1 ++ s2" := (cat s1 s2) : seq_scope. + +Lemma cat0s s : [::] ++ s = s. Proof. by []. Qed. +Lemma cat1s x s : [:: x] ++ s = x :: s. Proof. by []. Qed. +Lemma cat_cons x s1 s2 : (x :: s1) ++ s2 = x :: s1 ++ s2. Proof. by []. Qed. + +Lemma cat_nseq n x s : nseq n x ++ s = ncons n x s. +Proof. by elim: n => //= n ->. Qed. + +Lemma cats0 s : s ++ [::] = s. +Proof. by elim: s => //= x s ->. Qed. + +Lemma catA s1 s2 s3 : s1 ++ s2 ++ s3 = (s1 ++ s2) ++ s3. +Proof. by elim: s1 => //= x s1 ->. Qed. + +Lemma size_cat s1 s2 : size (s1 ++ s2) = size s1 + size s2. +Proof. by elim: s1 => //= x s1 ->. Qed. + +(* last, belast, rcons, and last induction. *) + +Fixpoint rcons s z := if s is x :: s' then x :: rcons s' z else [:: z]. + +Lemma rcons_cons x s z : rcons (x :: s) z = x :: rcons s z. +Proof. by []. Qed. + +Lemma cats1 s z : s ++ [:: z] = rcons s z. +Proof. by elim: s => //= x s ->. Qed. + +Fixpoint last x s := if s is x' :: s' then last x' s' else x. +Fixpoint belast x s := if s is x' :: s' then x :: (belast x' s') else [::]. + +Lemma lastI x s : x :: s = rcons (belast x s) (last x s). +Proof. by elim: s x => [|y s IHs] x //=; rewrite IHs. Qed. + +Lemma last_cons x y s : last x (y :: s) = last y s. +Proof. by []. Qed. + +Lemma size_rcons s x : size (rcons s x) = (size s).+1. +Proof. by rewrite -cats1 size_cat addnC. Qed. + +Lemma size_belast x s : size (belast x s) = size s. +Proof. by elim: s x => [|y s IHs] x //=; rewrite IHs. Qed. + +Lemma last_cat x s1 s2 : last x (s1 ++ s2) = last (last x s1) s2. +Proof. by elim: s1 x => [|y s1 IHs] x //=; rewrite IHs. Qed. + +Lemma last_rcons x s z : last x (rcons s z) = z. +Proof. by rewrite -cats1 last_cat. Qed. + +Lemma belast_cat x s1 s2 : + belast x (s1 ++ s2) = belast x s1 ++ belast (last x s1) s2. +Proof. by elim: s1 x => [|y s1 IHs] x //=; rewrite IHs. Qed. + +Lemma belast_rcons x s z : belast x (rcons s z) = x :: s. +Proof. by rewrite lastI -!cats1 belast_cat. Qed. + +Lemma cat_rcons x s1 s2 : rcons s1 x ++ s2 = s1 ++ x :: s2. +Proof. by rewrite -cats1 -catA. Qed. + +Lemma rcons_cat x s1 s2 : rcons (s1 ++ s2) x = s1 ++ rcons s2 x. +Proof. by rewrite -!cats1 catA. Qed. + +CoInductive last_spec : seq T -> Type := + | LastNil : last_spec [::] + | LastRcons s x : last_spec (rcons s x). + +Lemma lastP s : last_spec s. +Proof. case: s => [|x s]; [left | rewrite lastI; right]. Qed. + +Lemma last_ind P : + P [::] -> (forall s x, P s -> P (rcons s x)) -> forall s, P s. +Proof. +move=> Hnil Hlast s; rewrite -(cat0s s). +elim: s [::] Hnil => [|x s2 IHs] s1 Hs1; first by rewrite cats0. +by rewrite -cat_rcons; auto. +Qed. + +(* Sequence indexing. *) + +Fixpoint nth s n {struct n} := + if s is x :: s' then if n is n'.+1 then @nth s' n' else x else x0. + +Fixpoint set_nth s n y {struct n} := + if s is x :: s' then if n is n'.+1 then x :: @set_nth s' n' y else y :: s' + else ncons n x0 [:: y]. + +Lemma nth0 s : nth s 0 = head s. Proof. by []. Qed. + +Lemma nth_default s n : size s <= n -> nth s n = x0. +Proof. by elim: s n => [|x s IHs] [|n]; try exact (IHs n). Qed. + +Lemma nth_nil n : nth [::] n = x0. +Proof. by case: n. Qed. + +Lemma last_nth x s : last x s = nth (x :: s) (size s). +Proof. by elim: s x => [|y s IHs] x /=. Qed. + +Lemma nth_last s : nth s (size s).-1 = last x0 s. +Proof. by case: s => //= x s; rewrite last_nth. Qed. + +Lemma nth_behead s n : nth (behead s) n = nth s n.+1. +Proof. by case: s n => [|x s] [|n]. Qed. + +Lemma nth_cat s1 s2 n : + nth (s1 ++ s2) n = if n < size s1 then nth s1 n else nth s2 (n - size s1). +Proof. by elim: s1 n => [|x s1 IHs] [|n]; try exact (IHs n). Qed. + +Lemma nth_rcons s x n : + nth (rcons s x) n = + if n < size s then nth s n else if n == size s then x else x0. +Proof. by elim: s n => [|y s IHs] [|n] //=; rewrite ?nth_nil ?IHs. Qed. + +Lemma nth_ncons m x s n : + nth (ncons m x s) n = if n < m then x else nth s (n - m). +Proof. by elim: m n => [|m IHm] [|n] //=; exact: IHm. Qed. + +Lemma nth_nseq m x n : nth (nseq m x) n = (if n < m then x else x0). +Proof. by elim: m n => [|m IHm] [|n] //=; exact: IHm. Qed. + +Lemma eq_from_nth s1 s2 : + size s1 = size s2 -> (forall i, i < size s1 -> nth s1 i = nth s2 i) -> + s1 = s2. +Proof. +elim: s1 s2 => [|x1 s1 IHs1] [|x2 s2] //= [eq_sz] eq_s12. +rewrite [x1](eq_s12 0) // (IHs1 s2) // => i; exact: (eq_s12 i.+1). +Qed. + +Lemma size_set_nth s n y : size (set_nth s n y) = maxn n.+1 (size s). +Proof. +elim: s n => [|x s IHs] [|n] //=. +- by rewrite size_ncons addn1 maxn0. +- by rewrite maxnE subn1. +by rewrite IHs -add1n addn_maxr. +Qed. + +Lemma set_nth_nil n y : set_nth [::] n y = ncons n x0 [:: y]. +Proof. by case: n. Qed. + +Lemma nth_set_nth s n y : nth (set_nth s n y) =1 [eta nth s with n |-> y]. +Proof. +elim: s n => [|x s IHs] [|n] [|m] //=; rewrite ?nth_nil ?IHs // nth_ncons eqSS. +case: ltngtP => // [lt_nm | ->]; last by rewrite subnn. +by rewrite nth_default // subn_gt0. +Qed. + +Lemma set_set_nth s n1 y1 n2 y2 (s2 := set_nth s n2 y2) : + set_nth (set_nth s n1 y1) n2 y2 = if n1 == n2 then s2 else set_nth s2 n1 y1. +Proof. +have [-> | ne_n12] := altP eqP. + apply: eq_from_nth => [|i _]; first by rewrite !size_set_nth maxnA maxnn. + by do 2!rewrite !nth_set_nth /=; case: eqP. +apply: eq_from_nth => [|i _]; first by rewrite !size_set_nth maxnCA. +do 2!rewrite !nth_set_nth /=; case: eqP => // ->. +by rewrite eq_sym -if_neg ne_n12. +Qed. + +(* find, count, has, all. *) + +Section SeqFind. + +Variable a : pred T. + +Fixpoint find s := if s is x :: s' then if a x then 0 else (find s').+1 else 0. + +Fixpoint filter s := + if s is x :: s' then if a x then x :: filter s' else filter s' else [::]. + +Fixpoint count s := if s is x :: s' then a x + count s' else 0. + +Fixpoint has s := if s is x :: s' then a x || has s' else false. + +Fixpoint all s := if s is x :: s' then a x && all s' else true. + +Lemma size_filter s : size (filter s) = count s. +Proof. by elim: s => //= x s <-; case (a x). Qed. + +Lemma has_count s : has s = (0 < count s). +Proof. by elim: s => //= x s ->; case (a x). Qed. + +Lemma count_size s : count s <= size s. +Proof. by elim: s => //= x s; case: (a x); last exact: leqW. Qed. + +Lemma all_count s : all s = (count s == size s). +Proof. +elim: s => //= x s; case: (a x) => _ //=. +by rewrite add0n eqn_leq andbC ltnNge count_size. +Qed. + +Lemma filter_all s : all (filter s). +Proof. by elim: s => //= x s IHs; case: ifP => //= ->. Qed. + +Lemma all_filterP s : reflect (filter s = s) (all s). +Proof. +apply: (iffP idP) => [| <-]; last exact: filter_all. +by elim: s => //= x s IHs /andP[-> Hs]; rewrite IHs. +Qed. + +Lemma filter_id s : filter (filter s) = filter s. +Proof. by apply/all_filterP; exact: filter_all. Qed. + +Lemma has_find s : has s = (find s < size s). +Proof. by elim: s => //= x s IHs; case (a x); rewrite ?leqnn. Qed. + +Lemma find_size s : find s <= size s. +Proof. by elim: s => //= x s IHs; case (a x). Qed. + +Lemma find_cat s1 s2 : + find (s1 ++ s2) = if has s1 then find s1 else size s1 + find s2. +Proof. +by elim: s1 => //= x s1 IHs; case: (a x) => //; rewrite IHs (fun_if succn). +Qed. + +Lemma has_nil : has [::] = false. Proof. by []. Qed. + +Lemma has_seq1 x : has [:: x] = a x. +Proof. exact: orbF. Qed. + +Lemma has_nseq n x : has (nseq n x) = (0 < n) && a x. +Proof. by elim: n => //= n ->; apply: andKb. Qed. + +Lemma has_seqb (b : bool) x : has (nseq b x) = b && a x. +Proof. by rewrite has_nseq lt0b. Qed. + +Lemma all_nil : all [::] = true. Proof. by []. Qed. + +Lemma all_seq1 x : all [:: x] = a x. +Proof. exact: andbT. Qed. + +Lemma all_nseq n x : all (nseq n x) = (n == 0) || a x. +Proof. by elim: n => //= n ->; apply: orKb. Qed. + +Lemma all_nseqb (b : bool) x : all (nseq b x) = b ==> a x. +Proof. by rewrite all_nseq eqb0 implybE. Qed. + +Lemma find_nseq n x : find (nseq n x) = ~~ a x * n. +Proof. by elim: n => //= n ->; case: (a x). Qed. + +Lemma nth_find s : has s -> a (nth s (find s)). +Proof. by elim: s => //= x s IHs; case Hx: (a x). Qed. + +Lemma before_find s i : i < find s -> a (nth s i) = false. +Proof. +by elim: s i => //= x s IHs; case Hx: (a x) => [|] // [|i] //; apply: (IHs i). +Qed. + +Lemma filter_cat s1 s2 : filter (s1 ++ s2) = filter s1 ++ filter s2. +Proof. by elim: s1 => //= x s1 ->; case (a x). Qed. + +Lemma filter_rcons s x : + filter (rcons s x) = if a x then rcons (filter s) x else filter s. +Proof. by rewrite -!cats1 filter_cat /=; case (a x); rewrite /= ?cats0. Qed. + +Lemma count_cat s1 s2 : count (s1 ++ s2) = count s1 + count s2. +Proof. by rewrite -!size_filter filter_cat size_cat. Qed. + +Lemma has_cat s1 s2 : has (s1 ++ s2) = has s1 || has s2. +Proof. by elim: s1 => [|x s1 IHs] //=; rewrite IHs orbA. Qed. + +Lemma has_rcons s x : has (rcons s x) = a x || has s. +Proof. by rewrite -cats1 has_cat has_seq1 orbC. Qed. + +Lemma all_cat s1 s2 : all (s1 ++ s2) = all s1 && all s2. +Proof. by elim: s1 => [|x s1 IHs] //=; rewrite IHs andbA. Qed. + +Lemma all_rcons s x : all (rcons s x) = a x && all s. +Proof. by rewrite -cats1 all_cat all_seq1 andbC. Qed. + +End SeqFind. + +Lemma eq_find a1 a2 : a1 =1 a2 -> find a1 =1 find a2. +Proof. by move=> Ea; elim=> //= x s IHs; rewrite Ea IHs. Qed. + +Lemma eq_filter a1 a2 : a1 =1 a2 -> filter a1 =1 filter a2. +Proof. by move=> Ea; elim=> //= x s IHs; rewrite Ea IHs. Qed. + +Lemma eq_count a1 a2 : a1 =1 a2 -> count a1 =1 count a2. +Proof. by move=> Ea s; rewrite -!size_filter (eq_filter Ea). Qed. + +Lemma eq_has a1 a2 : a1 =1 a2 -> has a1 =1 has a2. +Proof. by move=> Ea s; rewrite !has_count (eq_count Ea). Qed. + +Lemma eq_all a1 a2 : a1 =1 a2 -> all a1 =1 all a2. +Proof. by move=> Ea s; rewrite !all_count (eq_count Ea). Qed. + +Section SubPred. + +Variable (a1 a2 : pred T). +Hypothesis s12 : subpred a1 a2. + +Lemma sub_find s : find a2 s <= find a1 s. +Proof. by elim: s => //= x s IHs; case: ifP => // /(contraFF (@s12 x))->. Qed. + +Lemma sub_has s : has a1 s -> has a2 s. +Proof. by rewrite !has_find; exact: leq_ltn_trans (sub_find s). Qed. + +Lemma sub_count s : count a1 s <= count a2 s. +Proof. +by elim: s => //= x s; apply: leq_add; case a1x: (a1 x); rewrite // s12. +Qed. + +Lemma sub_all s : all a1 s -> all a2 s. +Proof. +by rewrite !all_count !eqn_leq !count_size => /leq_trans-> //; apply: sub_count. +Qed. + +End SubPred. + +Lemma filter_pred0 s : filter pred0 s = [::]. Proof. by elim: s. Qed. + +Lemma filter_predT s : filter predT s = s. +Proof. by elim: s => //= x s ->. Qed. + +Lemma filter_predI a1 a2 s : filter (predI a1 a2) s = filter a1 (filter a2 s). +Proof. +elim: s => //= x s IHs; rewrite andbC IHs. +by case: (a2 x) => //=; case (a1 x). +Qed. + +Lemma count_pred0 s : count pred0 s = 0. +Proof. by rewrite -size_filter filter_pred0. Qed. + +Lemma count_predT s : count predT s = size s. +Proof. by rewrite -size_filter filter_predT. Qed. + +Lemma count_predUI a1 a2 s : + count (predU a1 a2) s + count (predI a1 a2) s = count a1 s + count a2 s. +Proof. +elim: s => //= x s IHs; rewrite /= addnCA -addnA IHs addnA addnC. +by rewrite -!addnA; do 2 nat_congr; case (a1 x); case (a2 x). +Qed. + +Lemma count_predC a s : count a s + count (predC a) s = size s. +Proof. +by elim: s => //= x s IHs; rewrite addnCA -addnA IHs addnA addn_negb. +Qed. + +Lemma count_filter a1 a2 s : count a1 (filter a2 s) = count (predI a1 a2) s. +Proof. by rewrite -!size_filter filter_predI. Qed. + +Lemma has_pred0 s : has pred0 s = false. +Proof. by rewrite has_count count_pred0. Qed. + +Lemma has_predT s : has predT s = (0 < size s). +Proof. by rewrite has_count count_predT. Qed. + +Lemma has_predC a s : has (predC a) s = ~~ all a s. +Proof. by elim: s => //= x s ->; case (a x). Qed. + +Lemma has_predU a1 a2 s : has (predU a1 a2) s = has a1 s || has a2 s. +Proof. by elim: s => //= x s ->; rewrite -!orbA; do !bool_congr. Qed. + +Lemma all_pred0 s : all pred0 s = (size s == 0). +Proof. by rewrite all_count count_pred0 eq_sym. Qed. + +Lemma all_predT s : all predT s. +Proof. by rewrite all_count count_predT. Qed. + +Lemma all_predC a s : all (predC a) s = ~~ has a s. +Proof. by elim: s => //= x s ->; case (a x). Qed. + +Lemma all_predI a1 a2 s : all (predI a1 a2) s = all a1 s && all a2 s. +Proof. +apply: (can_inj negbK); rewrite negb_and -!has_predC -has_predU. +by apply: eq_has => x; rewrite /= negb_and. +Qed. + +(* Surgery: drop, take, rot, rotr. *) + +Fixpoint drop n s {struct s} := + match s, n with + | _ :: s', n'.+1 => drop n' s' + | _, _ => s + end. + +Lemma drop_behead : drop n0 =1 iter n0 behead. +Proof. by elim: n0 => [|n IHn] [|x s] //; rewrite iterSr -IHn. Qed. + +Lemma drop0 s : drop 0 s = s. Proof. by case: s. Qed. + +Lemma drop1 : drop 1 =1 behead. Proof. by case=> [|x [|y s]]. Qed. + +Lemma drop_oversize n s : size s <= n -> drop n s = [::]. +Proof. by elim: n s => [|n IHn] [|x s]; try exact (IHn s). Qed. + +Lemma drop_size s : drop (size s) s = [::]. +Proof. by rewrite drop_oversize // leqnn. Qed. + +Lemma drop_cons x s : + drop n0 (x :: s) = if n0 is n.+1 then drop n s else x :: s. +Proof. by []. Qed. + +Lemma size_drop s : size (drop n0 s) = size s - n0. +Proof. by elim: s n0 => [|x s IHs] [|n]; try exact (IHs n). Qed. + +Lemma drop_cat s1 s2 : + drop n0 (s1 ++ s2) = + if n0 < size s1 then drop n0 s1 ++ s2 else drop (n0 - size s1) s2. +Proof. by elim: s1 n0 => [|x s1 IHs] [|n]; try exact (IHs n). Qed. + +Lemma drop_size_cat n s1 s2 : size s1 = n -> drop n (s1 ++ s2) = s2. +Proof. by move <-; elim: s1 => //=; rewrite drop0. Qed. + +Lemma nconsK n x : cancel (ncons n x) (drop n). +Proof. by elim: n => //; case. Qed. + +Fixpoint take n s {struct s} := + match s, n with + | x :: s', n'.+1 => x :: take n' s' + | _, _ => [::] + end. + +Lemma take0 s : take 0 s = [::]. Proof. by case: s. Qed. + +Lemma take_oversize n s : size s <= n -> take n s = s. +Proof. by elim: n s => [|n IHn] [|x s] Hsn; try (congr cons; apply: IHn). Qed. + +Lemma take_size s : take (size s) s = s. +Proof. by rewrite take_oversize // leqnn. Qed. + +Lemma take_cons x s : + take n0 (x :: s) = if n0 is n.+1 then x :: (take n s) else [::]. +Proof. by []. Qed. + +Lemma drop_rcons s : n0 <= size s -> + forall x, drop n0 (rcons s x) = rcons (drop n0 s) x. +Proof. by elim: s n0 => [|y s IHs] [|n]; try exact (IHs n). Qed. + +Lemma cat_take_drop s : take n0 s ++ drop n0 s = s. +Proof. by elim: s n0 => [|x s IHs] [|n]; try exact (congr1 _ (IHs n)). Qed. + +Lemma size_takel s : n0 <= size s -> size (take n0 s) = n0. +Proof. +by move/subnKC; rewrite -{2}(cat_take_drop s) size_cat size_drop => /addIn. +Qed. + +Lemma size_take s : size (take n0 s) = if n0 < size s then n0 else size s. +Proof. +have [le_sn | lt_ns] := leqP (size s) n0; first by rewrite take_oversize. +by rewrite size_takel // ltnW. +Qed. + +Lemma take_cat s1 s2 : + take n0 (s1 ++ s2) = + if n0 < size s1 then take n0 s1 else s1 ++ take (n0 - size s1) s2. +Proof. +elim: s1 n0 => [|x s1 IHs] [|n] //=. +by rewrite ltnS subSS -(fun_if (cons x)) -IHs. +Qed. + +Lemma take_size_cat n s1 s2 : size s1 = n -> take n (s1 ++ s2) = s1. +Proof. by move <-; elim: s1 => [|x s1 IHs]; rewrite ?take0 //= IHs. Qed. + +Lemma takel_cat s1 : + n0 <= size s1 -> + forall s2, take n0 (s1 ++ s2) = take n0 s1. +Proof. +move=> Hn0 s2; rewrite take_cat ltn_neqAle Hn0 andbT. +by case: (n0 =P size s1) => //= ->; rewrite subnn take0 cats0 take_size. +Qed. + +Lemma nth_drop s i : nth (drop n0 s) i = nth s (n0 + i). +Proof. +have [lt_n0_s | le_s_n0] := ltnP n0 (size s). + rewrite -{2}[s]cat_take_drop nth_cat size_take lt_n0_s /= addKn. + by rewrite ltnNge leq_addr. +rewrite !nth_default //; first exact: leq_trans (leq_addr _ _). +by rewrite size_drop (eqnP le_s_n0). +Qed. + +Lemma nth_take i : i < n0 -> forall s, nth (take n0 s) i = nth s i. +Proof. +move=> lt_i_n0 s; case lt_n0_s: (n0 < size s). + by rewrite -{2}[s]cat_take_drop nth_cat size_take lt_n0_s /= lt_i_n0. +by rewrite -{1}[s]cats0 take_cat lt_n0_s /= cats0. +Qed. + +(* drop_nth and take_nth below do NOT use the default n0, because the "n" *) +(* can be inferred from the condition, whereas the nth default value x0 *) +(* will have to be given explicitly (and this will provide "d" as well). *) + +Lemma drop_nth n s : n < size s -> drop n s = nth s n :: drop n.+1 s. +Proof. by elim: s n => [|x s IHs] [|n] Hn //=; rewrite ?drop0 1?IHs. Qed. + +Lemma take_nth n s : n < size s -> take n.+1 s = rcons (take n s) (nth s n). +Proof. by elim: s n => [|x s IHs] //= [|n] Hn /=; rewrite ?take0 -?IHs. Qed. + +(* Rotation *) + +Definition rot n s := drop n s ++ take n s. + +Lemma rot0 s : rot 0 s = s. +Proof. by rewrite /rot drop0 take0 cats0. Qed. + +Lemma size_rot s : size (rot n0 s) = size s. +Proof. by rewrite -{2}[s]cat_take_drop /rot !size_cat addnC. Qed. + +Lemma rot_oversize n s : size s <= n -> rot n s = s. +Proof. by move=> le_s_n; rewrite /rot take_oversize ?drop_oversize. Qed. + +Lemma rot_size s : rot (size s) s = s. +Proof. exact: rot_oversize. Qed. + +Lemma has_rot s a : has a (rot n0 s) = has a s. +Proof. by rewrite has_cat orbC -has_cat cat_take_drop. Qed. + +Lemma rot_size_cat s1 s2 : rot (size s1) (s1 ++ s2) = s2 ++ s1. +Proof. by rewrite /rot take_size_cat ?drop_size_cat. Qed. + +Definition rotr n s := rot (size s - n) s. + +Lemma rotK : cancel (rot n0) (rotr n0). +Proof. +move=> s; rewrite /rotr size_rot -size_drop {2}/rot. +by rewrite rot_size_cat cat_take_drop. +Qed. + +Lemma rot_inj : injective (rot n0). Proof. exact (can_inj rotK). Qed. + +Lemma rot1_cons x s : rot 1 (x :: s) = rcons s x. +Proof. by rewrite /rot /= take0 drop0 -cats1. Qed. + +(* (efficient) reversal *) + +Fixpoint catrev s1 s2 := if s1 is x :: s1' then catrev s1' (x :: s2) else s2. + +End Sequences. + +(* rev must be defined outside a Section because Coq's end of section *) +(* "cooking" removes the nosimpl guard. *) + +Definition rev T (s : seq T) := nosimpl (catrev s [::]). + +Implicit Arguments nilP [T s]. +Implicit Arguments all_filterP [T a s]. + +Prenex Implicits size nilP head ohead behead last rcons belast. +Prenex Implicits cat take drop rev rot rotr. +Prenex Implicits find count nth all has filter all_filterP. + +Notation count_mem x := (count (pred_of_simpl (pred1 x))). + +Infix "++" := cat : seq_scope. + +Notation "[ 'seq' x <- s | C ]" := (filter (fun x => C%B) s) + (at level 0, x at level 99, + format "[ '[hv' 'seq' x <- s '/ ' | C ] ']'") : seq_scope. +Notation "[ 'seq' x <- s | C1 & C2 ]" := [seq x <- s | C1 && C2] + (at level 0, x at level 99, + format "[ '[hv' 'seq' x <- s '/ ' | C1 '/ ' & C2 ] ']'") : seq_scope. +Notation "[ 'seq' x : T <- s | C ]" := (filter (fun x : T => C%B) s) + (at level 0, x at level 99, only parsing). +Notation "[ 'seq' x : T <- s | C1 & C2 ]" := [seq x : T <- s | C1 && C2] + (at level 0, x at level 99, only parsing). + + +(* Double induction/recursion. *) +Lemma seq2_ind T1 T2 (P : seq T1 -> seq T2 -> Type) : + P [::] [::] -> (forall x1 x2 s1 s2, P s1 s2 -> P (x1 :: s1) (x2 :: s2)) -> + forall s1 s2, size s1 = size s2 -> P s1 s2. +Proof. by move=> Pnil Pcons; elim=> [|x s IHs] [] //= x2 s2 [] /IHs/Pcons. Qed. + +Section Rev. + +Variable T : Type. +Implicit Types s t : seq T. + +Lemma catrev_catl s t u : catrev (s ++ t) u = catrev t (catrev s u). +Proof. by elim: s u => /=. Qed. + +Lemma catrev_catr s t u : catrev s (t ++ u) = catrev s t ++ u. +Proof. by elim: s t => //= x s IHs t; rewrite -IHs. Qed. + +Lemma catrevE s t : catrev s t = rev s ++ t. +Proof. by rewrite -catrev_catr. Qed. + +Lemma rev_cons x s : rev (x :: s) = rcons (rev s) x. +Proof. by rewrite -cats1 -catrevE. Qed. + +Lemma size_rev s : size (rev s) = size s. +Proof. by elim: s => // x s IHs; rewrite rev_cons size_rcons IHs. Qed. + +Lemma rev_cat s t : rev (s ++ t) = rev t ++ rev s. +Proof. by rewrite -catrev_catr -catrev_catl. Qed. + +Lemma rev_rcons s x : rev (rcons s x) = x :: rev s. +Proof. by rewrite -cats1 rev_cat. Qed. + +Lemma revK : involutive (@rev T). +Proof. by elim=> //= x s IHs; rewrite rev_cons rev_rcons IHs. Qed. + +Lemma nth_rev x0 n s : + n < size s -> nth x0 (rev s) n = nth x0 s (size s - n.+1). +Proof. +elim/last_ind: s => // s x IHs in n *. +rewrite rev_rcons size_rcons ltnS subSS -cats1 nth_cat /=. +case: n => [|n] lt_n_s; first by rewrite subn0 ltnn subnn. +by rewrite -{2}(subnK lt_n_s) -addSnnS leq_addr /= -IHs. +Qed. + +Lemma filter_rev a s : filter a (rev s) = rev (filter a s). +Proof. by elim: s => //= x s IH; rewrite fun_if !rev_cons filter_rcons IH. Qed. + +Lemma count_rev a s : count a (rev s) = count a s. +Proof. by rewrite -!size_filter filter_rev size_rev. Qed. + +Lemma has_rev a s : has a (rev s) = has a s. +Proof. by rewrite !has_count count_rev. Qed. + +Lemma all_rev a s : all a (rev s) = all a s. +Proof. by rewrite !all_count count_rev size_rev. Qed. + +End Rev. + +Implicit Arguments revK [[T]]. + +(* Equality and eqType for seq. *) + +Section EqSeq. + +Variables (n0 : nat) (T : eqType) (x0 : T). +Notation Local nth := (nth x0). +Implicit Type s : seq T. +Implicit Types x y z : T. + +Fixpoint eqseq s1 s2 {struct s2} := + match s1, s2 with + | [::], [::] => true + | x1 :: s1', x2 :: s2' => (x1 == x2) && eqseq s1' s2' + | _, _ => false + end. + +Lemma eqseqP : Equality.axiom eqseq. +Proof. +move; elim=> [|x1 s1 IHs] [|x2 s2]; do [by constructor | simpl]. +case: (x1 =P x2) => [<-|neqx]; last by right; case. +by apply: (iffP (IHs s2)) => [<-|[]]. +Qed. + +Canonical seq_eqMixin := EqMixin eqseqP. +Canonical seq_eqType := Eval hnf in EqType (seq T) seq_eqMixin. + +Lemma eqseqE : eqseq = eq_op. Proof. by []. Qed. + +Lemma eqseq_cons x1 x2 s1 s2 : + (x1 :: s1 == x2 :: s2) = (x1 == x2) && (s1 == s2). +Proof. by []. Qed. + +Lemma eqseq_cat s1 s2 s3 s4 : + size s1 = size s2 -> (s1 ++ s3 == s2 ++ s4) = (s1 == s2) && (s3 == s4). +Proof. +elim: s1 s2 => [|x1 s1 IHs] [|x2 s2] //= [sz12]. +by rewrite !eqseq_cons -andbA IHs. +Qed. + +Lemma eqseq_rcons s1 s2 x1 x2 : + (rcons s1 x1 == rcons s2 x2) = (s1 == s2) && (x1 == x2). +Proof. by rewrite -(can_eq revK) !rev_rcons eqseq_cons andbC (can_eq revK). Qed. + +Lemma size_eq0 s : (size s == 0) = (s == [::]). +Proof. exact: (sameP nilP eqP). Qed. + +Lemma has_filter a s : has a s = (filter a s != [::]). +Proof. by rewrite -size_eq0 size_filter has_count lt0n. Qed. + +(* mem_seq and index. *) +(* mem_seq defines a predType for seq. *) + +Fixpoint mem_seq (s : seq T) := + if s is y :: s' then xpredU1 y (mem_seq s') else xpred0. + +Definition eqseq_class := seq T. +Identity Coercion seq_of_eqseq : eqseq_class >-> seq. + +Coercion pred_of_eq_seq (s : eqseq_class) : pred_class := [eta mem_seq s]. + +Canonical seq_predType := @mkPredType T (seq T) pred_of_eq_seq. +(* The line below makes mem_seq a canonical instance of topred. *) +Canonical mem_seq_predType := mkPredType mem_seq. + +Lemma in_cons y s x : (x \in y :: s) = (x == y) || (x \in s). +Proof. by []. Qed. + +Lemma in_nil x : (x \in [::]) = false. +Proof. by []. Qed. + +Lemma mem_seq1 x y : (x \in [:: y]) = (x == y). +Proof. by rewrite in_cons orbF. Qed. + + (* to be repeated after the Section discharge. *) +Let inE := (mem_seq1, in_cons, inE). + +Lemma mem_seq2 x y1 y2 : (x \in [:: y1; y2]) = xpred2 y1 y2 x. +Proof. by rewrite !inE. Qed. + +Lemma mem_seq3 x y1 y2 y3 : (x \in [:: y1; y2; y3]) = xpred3 y1 y2 y3 x. +Proof. by rewrite !inE. Qed. + +Lemma mem_seq4 x y1 y2 y3 y4 : + (x \in [:: y1; y2; y3; y4]) = xpred4 y1 y2 y3 y4 x. +Proof. by rewrite !inE. Qed. + +Lemma mem_cat x s1 s2 : (x \in s1 ++ s2) = (x \in s1) || (x \in s2). +Proof. by elim: s1 => //= y s1 IHs; rewrite !inE /= -orbA -IHs. Qed. + +Lemma mem_rcons s y : rcons s y =i y :: s. +Proof. by move=> x; rewrite -cats1 /= mem_cat mem_seq1 orbC in_cons. Qed. + +Lemma mem_head x s : x \in x :: s. +Proof. exact: predU1l. Qed. + +Lemma mem_last x s : last x s \in x :: s. +Proof. by rewrite lastI mem_rcons mem_head. Qed. + +Lemma mem_behead s : {subset behead s <= s}. +Proof. by case: s => // y s x; exact: predU1r. Qed. + +Lemma mem_belast s y : {subset belast y s <= y :: s}. +Proof. by move=> x ys'x; rewrite lastI mem_rcons mem_behead. Qed. + +Lemma mem_nth s n : n < size s -> nth s n \in s. +Proof. +by elim: s n => [|x s IHs] // [_|n sz_s]; rewrite ?mem_head // mem_behead ?IHs. +Qed. + +Lemma mem_take s x : x \in take n0 s -> x \in s. +Proof. by move=> s0x; rewrite -(cat_take_drop n0 s) mem_cat /= s0x. Qed. + +Lemma mem_drop s x : x \in drop n0 s -> x \in s. +Proof. by move=> s0'x; rewrite -(cat_take_drop n0 s) mem_cat /= s0'x orbT. Qed. + +Section Filters. + +Variable a : pred T. + +Lemma hasP s : reflect (exists2 x, x \in s & a x) (has a s). +Proof. +elim: s => [|y s IHs] /=; first by right; case. +case ay: (a y); first by left; exists y; rewrite ?mem_head. +apply: (iffP IHs) => [] [x ysx ax]; exists x => //; first exact: mem_behead. +by case: (predU1P ysx) ax => [->|//]; rewrite ay. +Qed. + +Lemma hasPn s : reflect (forall x, x \in s -> ~~ a x) (~~ has a s). +Proof. +apply: (iffP idP) => not_a_s => [x s_x|]. + by apply: contra not_a_s => a_x; apply/hasP; exists x. +by apply/hasP=> [[x s_x]]; apply/negP; exact: not_a_s. +Qed. + +Lemma allP s : reflect (forall x, x \in s -> a x) (all a s). +Proof. +elim: s => [|x s IHs]; first by left. +rewrite /= andbC; case: IHs => IHs /=. + apply: (iffP idP) => [Hx y|]; last by apply; exact: mem_head. + by case/predU1P=> [->|Hy]; auto. +by right=> H; case IHs => y Hy; apply H; exact: mem_behead. +Qed. + +Lemma allPn s : reflect (exists2 x, x \in s & ~~ a x) (~~ all a s). +Proof. +elim: s => [|x s IHs]; first by right=> [[x Hx _]]. +rewrite /= andbC negb_and; case: IHs => IHs /=. + by left; case: IHs => y Hy Hay; exists y; first exact: mem_behead. +apply: (iffP idP) => [|[y]]; first by exists x; rewrite ?mem_head. +by case/predU1P=> [-> // | s_y not_a_y]; case: IHs; exists y. +Qed. + +Lemma mem_filter x s : (x \in filter a s) = a x && (x \in s). +Proof. +rewrite andbC; elim: s => //= y s IHs. +rewrite (fun_if (fun s' : seq T => x \in s')) !in_cons {}IHs. +by case: eqP => [->|_]; case (a y); rewrite /= ?andbF. +Qed. + +End Filters. + +Section EqIn. + +Variables a1 a2 : pred T. + +Lemma eq_in_filter s : {in s, a1 =1 a2} -> filter a1 s = filter a2 s. +Proof. +elim: s => //= x s IHs eq_a. +rewrite eq_a ?mem_head ?IHs // => y s_y; apply: eq_a; exact: mem_behead. +Qed. + +Lemma eq_in_find s : {in s, a1 =1 a2} -> find a1 s = find a2 s. +Proof. +elim: s => //= x s IHs eq_a12; rewrite eq_a12 ?mem_head // IHs // => y s'y. +by rewrite eq_a12 // mem_behead. +Qed. + +Lemma eq_in_count s : {in s, a1 =1 a2} -> count a1 s = count a2 s. +Proof. by move/eq_in_filter=> eq_a12; rewrite -!size_filter eq_a12. Qed. + +Lemma eq_in_all s : {in s, a1 =1 a2} -> all a1 s = all a2 s. +Proof. by move=> eq_a12; rewrite !all_count eq_in_count. Qed. + +Lemma eq_in_has s : {in s, a1 =1 a2} -> has a1 s = has a2 s. +Proof. by move/eq_in_filter=> eq_a12; rewrite !has_filter eq_a12. Qed. + +End EqIn. + +Lemma eq_has_r s1 s2 : s1 =i s2 -> has^~ s1 =1 has^~ s2. +Proof. +move=> Es12 a; apply/(hasP a s1)/(hasP a s2) => [] [x Hx Hax]; + by exists x; rewrite // ?Es12 // -Es12. +Qed. + +Lemma eq_all_r s1 s2 : s1 =i s2 -> all^~ s1 =1 all^~ s2. +Proof. +by move=> Es12 a; apply/(allP a s1)/(allP a s2) => Hs x Hx; + apply: Hs; rewrite Es12 in Hx *. +Qed. + +Lemma has_sym s1 s2 : has (mem s1) s2 = has (mem s2) s1. +Proof. by apply/(hasP _ s2)/(hasP _ s1) => [] [x]; exists x. Qed. + +Lemma has_pred1 x s : has (pred1 x) s = (x \in s). +Proof. by rewrite -(eq_has (mem_seq1^~ x)) (has_sym [:: x]) /= orbF. Qed. + +Lemma mem_rev s : rev s =i s. +Proof. by move=> a; rewrite -!has_pred1 has_rev. Qed. + +(* Constant sequences, i.e., the image of nseq. *) + +Definition constant s := if s is x :: s' then all (pred1 x) s' else true. + +Lemma all_pred1P x s : reflect (s = nseq (size s) x) (all (pred1 x) s). +Proof. +elim: s => [|y s IHs] /=; first by left. +case: eqP => [->{y} | ne_xy]; last by right=> [] [? _]; case ne_xy. +by apply: (iffP IHs) => [<- //| []]. +Qed. + +Lemma all_pred1_constant x s : all (pred1 x) s -> constant s. +Proof. by case: s => //= y s /andP[/eqP->]. Qed. + +Lemma all_pred1_nseq x n : all (pred1 x) (nseq n x). +Proof. by rewrite all_nseq /= eqxx orbT. Qed. + +Lemma nseqP n x y : reflect (y = x /\ n > 0) (y \in nseq n x). +Proof. +by rewrite -has_pred1 has_nseq /= eq_sym andbC; apply: (iffP andP) => -[/eqP]. +Qed. + +Lemma constant_nseq n x : constant (nseq n x). +Proof. exact: all_pred1_constant (all_pred1_nseq x n). Qed. + +(* Uses x0 *) +Lemma constantP s : reflect (exists x, s = nseq (size s) x) (constant s). +Proof. +apply: (iffP idP) => [| [x ->]]; last exact: constant_nseq. +case: s => [|x s] /=; first by exists x0. +by move/all_pred1P=> def_s; exists x; rewrite -def_s. +Qed. + +(* Duplicate-freenes. *) + +Fixpoint uniq s := if s is x :: s' then (x \notin s') && uniq s' else true. + +Lemma cons_uniq x s : uniq (x :: s) = (x \notin s) && uniq s. +Proof. by []. Qed. + +Lemma cat_uniq s1 s2 : + uniq (s1 ++ s2) = [&& uniq s1, ~~ has (mem s1) s2 & uniq s2]. +Proof. +elim: s1 => [|x s1 IHs]; first by rewrite /= has_pred0. +by rewrite has_sym /= mem_cat !negb_or has_sym IHs -!andbA; do !bool_congr. +Qed. + +Lemma uniq_catC s1 s2 : uniq (s1 ++ s2) = uniq (s2 ++ s1). +Proof. by rewrite !cat_uniq has_sym andbCA andbA andbC. Qed. + +Lemma uniq_catCA s1 s2 s3 : uniq (s1 ++ s2 ++ s3) = uniq (s2 ++ s1 ++ s3). +Proof. +by rewrite !catA -!(uniq_catC s3) !(cat_uniq s3) uniq_catC !has_cat orbC. +Qed. + +Lemma rcons_uniq s x : uniq (rcons s x) = (x \notin s) && uniq s. +Proof. by rewrite -cats1 uniq_catC. Qed. + +Lemma filter_uniq s a : uniq s -> uniq (filter a s). +Proof. +elim: s => [|x s IHs] //= /andP[Hx Hs]; case (a x); auto. +by rewrite /= mem_filter /= (negbTE Hx) andbF; auto. +Qed. + +Lemma rot_uniq s : uniq (rot n0 s) = uniq s. +Proof. by rewrite /rot uniq_catC cat_take_drop. Qed. + +Lemma rev_uniq s : uniq (rev s) = uniq s. +Proof. +elim: s => // x s IHs. +by rewrite rev_cons -cats1 cat_uniq /= andbT andbC mem_rev orbF IHs. +Qed. + +Lemma count_memPn x s : reflect (count_mem x s = 0) (x \notin s). +Proof. by rewrite -has_pred1 has_count -eqn0Ngt; apply: eqP. Qed. + +Lemma count_uniq_mem s x : uniq s -> count_mem x s = (x \in s). +Proof. +elim: s => //= y s IHs /andP[/negbTE s'y /IHs-> {IHs}]. +by rewrite in_cons eq_sym; case: eqP => // ->; rewrite s'y. +Qed. + +Lemma filter_pred1_uniq s x : uniq s -> x \in s -> filter (pred1 x) s = [:: x]. +Proof. +move=> uniq_s s_x; rewrite (all_pred1P _ _ (filter_all _ _)). +by rewrite size_filter count_uniq_mem ?s_x. +Qed. + +(* Removing duplicates *) + +Fixpoint undup s := + if s is x :: s' then if x \in s' then undup s' else x :: undup s' else [::]. + +Lemma size_undup s : size (undup s) <= size s. +Proof. by elim: s => //= x s IHs; case: (x \in s) => //=; exact: ltnW. Qed. + +Lemma mem_undup s : undup s =i s. +Proof. +move=> x; elim: s => //= y s IHs. +by case Hy: (y \in s); rewrite in_cons IHs //; case: eqP => // ->. +Qed. + +Lemma undup_uniq s : uniq (undup s). +Proof. +by elim: s => //= x s IHs; case s_x: (x \in s); rewrite //= mem_undup s_x. +Qed. + +Lemma undup_id s : uniq s -> undup s = s. +Proof. by elim: s => //= x s IHs /andP[/negbTE-> /IHs->]. Qed. + +Lemma ltn_size_undup s : (size (undup s) < size s) = ~~ uniq s. +Proof. +by elim: s => //= x s IHs; case Hx: (x \in s); rewrite //= ltnS size_undup. +Qed. + +Lemma filter_undup p s : filter p (undup s) = undup (filter p s). +Proof. +elim: s => //= x s IHs; rewrite (fun_if undup) fun_if /= mem_filter /=. +by rewrite (fun_if (filter p)) /= IHs; case: ifP => -> //=; exact: if_same. +Qed. + +Lemma undup_nil s : undup s = [::] -> s = [::]. +Proof. by case: s => //= x s; rewrite -mem_undup; case: ifP; case: undup. Qed. + +(* Lookup *) + +Definition index x := find (pred1 x). + +Lemma index_size x s : index x s <= size s. +Proof. by rewrite /index find_size. Qed. + +Lemma index_mem x s : (index x s < size s) = (x \in s). +Proof. by rewrite -has_pred1 has_find. Qed. + +Lemma nth_index x s : x \in s -> nth s (index x s) = x. +Proof. by rewrite -has_pred1 => /(nth_find x0)/eqP. Qed. + +Lemma index_cat x s1 s2 : + index x (s1 ++ s2) = if x \in s1 then index x s1 else size s1 + index x s2. +Proof. by rewrite /index find_cat has_pred1. Qed. + +Lemma index_uniq i s : i < size s -> uniq s -> index (nth s i) s = i. +Proof. +elim: s i => [|x s IHs] //= [|i]; rewrite /= ?eqxx // ltnS => lt_i_s. +case/andP=> not_s_x /(IHs i)-> {IHs}//. +by case: eqP not_s_x => // ->; rewrite mem_nth. +Qed. + +Lemma index_head x s : index x (x :: s) = 0. +Proof. by rewrite /= eqxx. Qed. + +Lemma index_last x s : uniq (x :: s) -> index (last x s) (x :: s) = size s. +Proof. +rewrite lastI rcons_uniq -cats1 index_cat size_belast. +by case: ifP => //=; rewrite eqxx addn0. +Qed. + +Lemma nth_uniq s i j : + i < size s -> j < size s -> uniq s -> (nth s i == nth s j) = (i == j). +Proof. +move=> lt_i_s lt_j_s Us; apply/eqP/eqP=> [eq_sij|-> //]. +by rewrite -(index_uniq lt_i_s Us) eq_sij index_uniq. +Qed. + +Lemma mem_rot s : rot n0 s =i s. +Proof. by move=> x; rewrite -{2}(cat_take_drop n0 s) !mem_cat /= orbC. Qed. + +Lemma eqseq_rot s1 s2 : (rot n0 s1 == rot n0 s2) = (s1 == s2). +Proof. by apply: inj_eq; exact: rot_inj. Qed. + +CoInductive rot_to_spec s x := RotToSpec i s' of rot i s = x :: s'. + +Lemma rot_to s x : x \in s -> rot_to_spec s x. +Proof. +move=> s_x; pose i := index x s; exists i (drop i.+1 s ++ take i s). +rewrite -cat_cons {}/i; congr cat; elim: s s_x => //= y s IHs. +by rewrite eq_sym in_cons; case: eqP => // -> _; rewrite drop0. +Qed. + +End EqSeq. + +Definition inE := (mem_seq1, in_cons, inE). + +Prenex Implicits mem_seq1 uniq undup index. + +Implicit Arguments eqseqP [T x y]. +Implicit Arguments hasP [T a s]. +Implicit Arguments hasPn [T a s]. +Implicit Arguments allP [T a s]. +Implicit Arguments allPn [T a s]. +Implicit Arguments nseqP [T n x y]. +Implicit Arguments count_memPn [T x s]. +Prenex Implicits eqseqP hasP hasPn allP allPn nseqP count_memPn. + +Section NthTheory. + +Lemma nthP (T : eqType) (s : seq T) x x0 : + reflect (exists2 i, i < size s & nth x0 s i = x) (x \in s). +Proof. +apply: (iffP idP) => [|[n Hn <-]]; last by apply mem_nth. +by exists (index x s); [rewrite index_mem | apply nth_index]. +Qed. + +Variable T : Type. + +Lemma has_nthP (a : pred T) s x0 : + reflect (exists2 i, i < size s & a (nth x0 s i)) (has a s). +Proof. +elim: s => [|x s IHs] /=; first by right; case. +case nax: (a x); first by left; exists 0. +by apply: (iffP IHs) => [[i]|[[|i]]]; [exists i.+1 | rewrite nax | exists i]. +Qed. + +Lemma all_nthP (a : pred T) s x0 : + reflect (forall i, i < size s -> a (nth x0 s i)) (all a s). +Proof. +rewrite -(eq_all (fun x => negbK (a x))) all_predC. +case: (has_nthP _ _ x0) => [na_s | a_s]; [right=> a_s | left=> i lti]. + by case: na_s => i lti; rewrite a_s. +by apply/idPn=> na_si; case: a_s; exists i. +Qed. + +End NthTheory. + +Lemma set_nth_default T s (y0 x0 : T) n : n < size s -> nth x0 s n = nth y0 s n. +Proof. by elim: s n => [|y s' IHs] [|n] /=; auto. Qed. + +Lemma headI T s (x : T) : rcons s x = head x s :: behead (rcons s x). +Proof. by case: s. Qed. + +Implicit Arguments nthP [T s x]. +Implicit Arguments has_nthP [T a s]. +Implicit Arguments all_nthP [T a s]. +Prenex Implicits nthP has_nthP all_nthP. + +Definition bitseq := seq bool. +Canonical bitseq_eqType := Eval hnf in [eqType of bitseq]. +Canonical bitseq_predType := Eval hnf in [predType of bitseq]. + +(* Incrementing the ith nat in a seq nat, padding with 0's if needed. This *) +(* allows us to use nat seqs as bags of nats. *) + +Fixpoint incr_nth v i {struct i} := + if v is n :: v' then if i is i'.+1 then n :: incr_nth v' i' else n.+1 :: v' + else ncons i 0 [:: 1]. + +Lemma nth_incr_nth v i j : nth 0 (incr_nth v i) j = (i == j) + nth 0 v j. +Proof. +elim: v i j => [|n v IHv] [|i] [|j] //=; rewrite ?eqSS ?addn0 //; try by case j. +elim: i j => [|i IHv] [|j] //=; rewrite ?eqSS //; by case j. +Qed. + +Lemma size_incr_nth v i : + size (incr_nth v i) = if i < size v then size v else i.+1. +Proof. +elim: v i => [|n v IHv] [|i] //=; first by rewrite size_ncons /= addn1. +rewrite IHv; exact: fun_if. +Qed. + +(* Equality up to permutation *) + +Section PermSeq. + +Variable T : eqType. +Implicit Type s : seq T. + +Definition perm_eq s1 s2 := + all [pred x | count_mem x s1 == count_mem x s2] (s1 ++ s2). + +Lemma perm_eqP s1 s2 : reflect (count^~ s1 =1 count^~ s2) (perm_eq s1 s2). +Proof. +apply: (iffP allP) => /= [eq_cnt1 a | eq_cnt x _]; last exact/eqP. +elim: {a}_.+1 {-2}a (ltnSn (count a (s1 ++ s2))) => // n IHn a le_an. +have [/eqP|] := posnP (count a (s1 ++ s2)). + by rewrite count_cat addn_eq0; do 2!case: eqP => // ->. +rewrite -has_count => /hasP[x s12x a_x]; pose a' := predD1 a x. +have cnt_a' s: count a s = count_mem x s + count a' s. + rewrite -count_predUI -[LHS]addn0 -(count_pred0 s). + by congr (_ + _); apply: eq_count => y /=; case: eqP => // ->. +rewrite !cnt_a' (eqnP (eq_cnt1 _ s12x)) (IHn a') // -ltnS. +apply: leq_trans le_an. +by rewrite ltnS cnt_a' -add1n leq_add2r -has_count has_pred1. +Qed. + +Lemma perm_eq_refl s : perm_eq s s. +Proof. exact/perm_eqP. Qed. +Hint Resolve perm_eq_refl. + +Lemma perm_eq_sym : symmetric perm_eq. +Proof. by move=> s1 s2; apply/perm_eqP/perm_eqP=> ? ?. Qed. + +Lemma perm_eq_trans : transitive perm_eq. +Proof. by move=> s2 s1 s3 /perm_eqP-eq12 /perm_eqP/(ftrans eq12)/perm_eqP. Qed. + +Notation perm_eql s1 s2 := (perm_eq s1 =1 perm_eq s2). +Notation perm_eqr s1 s2 := (perm_eq^~ s1 =1 perm_eq^~ s2). + +Lemma perm_eqlE s1 s2 : perm_eql s1 s2 -> perm_eq s1 s2. Proof. by move->. Qed. + +Lemma perm_eqlP s1 s2 : reflect (perm_eql s1 s2) (perm_eq s1 s2). +Proof. +apply: (iffP idP) => [eq12 s3 | -> //]. +apply/idP/idP; last exact: perm_eq_trans. +by rewrite -!(perm_eq_sym s3); move/perm_eq_trans; apply. +Qed. + +Lemma perm_eqrP s1 s2 : reflect (perm_eqr s1 s2) (perm_eq s1 s2). +Proof. +apply: (iffP idP) => [/perm_eqlP eq12 s3| <- //]. +by rewrite !(perm_eq_sym s3) eq12. +Qed. + +Lemma perm_catC s1 s2 : perm_eql (s1 ++ s2) (s2 ++ s1). +Proof. by apply/perm_eqlP; apply/perm_eqP=> a; rewrite !count_cat addnC. Qed. + +Lemma perm_cat2l s1 s2 s3 : perm_eq (s1 ++ s2) (s1 ++ s3) = perm_eq s2 s3. +Proof. +apply/perm_eqP/perm_eqP=> eq23 a; apply/eqP; + by move/(_ a)/eqP: eq23; rewrite !count_cat eqn_add2l. +Qed. + +Lemma perm_cons x s1 s2 : perm_eq (x :: s1) (x :: s2) = perm_eq s1 s2. +Proof. exact: (perm_cat2l [::x]). Qed. + +Lemma perm_cat2r s1 s2 s3 : perm_eq (s2 ++ s1) (s3 ++ s1) = perm_eq s2 s3. +Proof. by do 2!rewrite perm_eq_sym perm_catC; exact: perm_cat2l. Qed. + +Lemma perm_catAC s1 s2 s3 : perm_eql ((s1 ++ s2) ++ s3) ((s1 ++ s3) ++ s2). +Proof. by apply/perm_eqlP; rewrite -!catA perm_cat2l perm_catC. Qed. + +Lemma perm_catCA s1 s2 s3 : perm_eql (s1 ++ s2 ++ s3) (s2 ++ s1 ++ s3). +Proof. by apply/perm_eqlP; rewrite !catA perm_cat2r perm_catC. Qed. + +Lemma perm_rcons x s : perm_eql (rcons s x) (x :: s). +Proof. by move=> /= s2; rewrite -cats1 perm_catC. Qed. + +Lemma perm_rot n s : perm_eql (rot n s) s. +Proof. by move=> /= s2; rewrite perm_catC cat_take_drop. Qed. + +Lemma perm_rotr n s : perm_eql (rotr n s) s. +Proof. exact: perm_rot. Qed. + +Lemma perm_filterC a s : perm_eql (filter a s ++ filter (predC a) s) s. +Proof. +apply/perm_eqlP; elim: s => //= x s IHs. +by case: (a x); last rewrite /= -cat1s perm_catCA; rewrite perm_cons. +Qed. + +Lemma perm_eq_mem s1 s2 : perm_eq s1 s2 -> s1 =i s2. +Proof. by move/perm_eqP=> eq12 x; rewrite -!has_pred1 !has_count eq12. Qed. + +Lemma perm_eq_size s1 s2 : perm_eq s1 s2 -> size s1 = size s2. +Proof. by move/perm_eqP=> eq12; rewrite -!count_predT eq12. Qed. + +Lemma perm_eq_small s1 s2 : size s2 <= 1 -> perm_eq s1 s2 -> s1 = s2. +Proof. +move=> s2_le1 eqs12; move/perm_eq_size: eqs12 s2_le1 (perm_eq_mem eqs12). +by case: s2 s1 => [|x []] // [|y []] // _ _ /(_ x); rewrite !inE eqxx => /eqP->. +Qed. + +Lemma uniq_leq_size s1 s2 : uniq s1 -> {subset s1 <= s2} -> size s1 <= size s2. +Proof. +elim: s1 s2 => //= x s1 IHs s2 /andP[not_s1x Us1] /allP/=/andP[s2x /allP ss12]. +have [i s3 def_s2] := rot_to s2x; rewrite -(size_rot i s2) def_s2. +apply: IHs => // y s1y; have:= ss12 y s1y. +by rewrite -(mem_rot i) def_s2 inE (negPf (memPn _ y s1y)). +Qed. + +Lemma leq_size_uniq s1 s2 : + uniq s1 -> {subset s1 <= s2} -> size s2 <= size s1 -> uniq s2. +Proof. +elim: s1 s2 => [[] | x s1 IHs s2] // Us1x; have /andP[not_s1x Us1] := Us1x. +case/allP/andP=> /rot_to[i s3 def_s2] /allP ss12 le_s21. +rewrite -(rot_uniq i) -(size_rot i) def_s2 /= in le_s21 *. +have ss13 y (s1y : y \in s1): y \in s3. + by have:= ss12 y s1y; rewrite -(mem_rot i) def_s2 inE (negPf (memPn _ y s1y)). +rewrite IHs // andbT; apply: contraL _ le_s21 => s3x; rewrite -leqNgt. +by apply/(uniq_leq_size Us1x)/allP; rewrite /= s3x; exact/allP. +Qed. + +Lemma uniq_size_uniq s1 s2 : + uniq s1 -> s1 =i s2 -> uniq s2 = (size s2 == size s1). +Proof. +move=> Us1 eqs12; apply/idP/idP=> [Us2 | /eqP eq_sz12]. + by rewrite eqn_leq !uniq_leq_size // => y; rewrite eqs12. +by apply: (leq_size_uniq Us1) => [y|]; rewrite (eqs12, eq_sz12). +Qed. + +Lemma leq_size_perm s1 s2 : + uniq s1 -> {subset s1 <= s2} -> size s2 <= size s1 -> + s1 =i s2 /\ size s1 = size s2. +Proof. +move=> Us1 ss12 le_s21; have Us2: uniq s2 := leq_size_uniq Us1 ss12 le_s21. +suffices: s1 =i s2 by split; last by apply/eqP; rewrite -uniq_size_uniq. +move=> x; apply/idP/idP=> [/ss12// | s2x]; apply: contraLR le_s21 => not_s1x. +rewrite -ltnNge (@uniq_leq_size (x :: s1)) /= ?not_s1x //. +by apply/allP; rewrite /= s2x; apply/allP. +Qed. + +Lemma perm_uniq s1 s2 : s1 =i s2 -> size s1 = size s2 -> uniq s1 = uniq s2. +Proof. +move=> Es12 Esz12. +by apply/idP/idP=> Us; rewrite (uniq_size_uniq Us) ?Esz12 ?eqxx. +Qed. + +Lemma perm_eq_uniq s1 s2 : perm_eq s1 s2 -> uniq s1 = uniq s2. +Proof. +by move=> eq_s12; apply: perm_uniq; [apply: perm_eq_mem | apply: perm_eq_size]. +Qed. + +Lemma uniq_perm_eq s1 s2 : uniq s1 -> uniq s2 -> s1 =i s2 -> perm_eq s1 s2. +Proof. +move=> Us1 Us2 eq12; apply/allP=> x _; apply/eqP. +by rewrite !count_uniq_mem ?eq12. +Qed. + +Lemma count_mem_uniq s : (forall x, count_mem x s = (x \in s)) -> uniq s. +Proof. +move=> count1_s; have Uus := undup_uniq s. +suffices: perm_eq s (undup s) by move/perm_eq_uniq->. +by apply/allP=> x _; apply/eqP; rewrite (count_uniq_mem x Uus) mem_undup. +Qed. + +Lemma catCA_perm_ind P : + (forall s1 s2 s3, P (s1 ++ s2 ++ s3) -> P (s2 ++ s1 ++ s3)) -> + (forall s1 s2, perm_eq s1 s2 -> P s1 -> P s2). +Proof. +move=> PcatCA s1 s2 eq_s12; rewrite -[s1]cats0 -[s2]cats0. +elim: s2 nil => [| x s2 IHs] s3 in s1 eq_s12 *. + by case: s1 {eq_s12}(perm_eq_size eq_s12). +have /rot_to[i s' def_s1]: x \in s1 by rewrite (perm_eq_mem eq_s12) mem_head. +rewrite -(cat_take_drop i s1) -catA => /PcatCA. +rewrite catA -/(rot i s1) def_s1 /= -cat1s => /PcatCA/IHs/PcatCA; apply. +by rewrite -(perm_cons x) -def_s1 perm_rot. +Qed. + +Lemma catCA_perm_subst R F : + (forall s1 s2 s3, F (s1 ++ s2 ++ s3) = F (s2 ++ s1 ++ s3) :> R) -> + (forall s1 s2, perm_eq s1 s2 -> F s1 = F s2). +Proof. +move=> FcatCA s1 s2 /catCA_perm_ind => ind_s12. +by apply: (ind_s12 (eq _ \o F)) => //= *; rewrite FcatCA. +Qed. + +End PermSeq. + +Notation perm_eql s1 s2 := (perm_eq s1 =1 perm_eq s2). +Notation perm_eqr s1 s2 := (perm_eq^~ s1 =1 perm_eq^~ s2). + +Implicit Arguments perm_eqP [T s1 s2]. +Implicit Arguments perm_eqlP [T s1 s2]. +Implicit Arguments perm_eqrP [T s1 s2]. +Prenex Implicits perm_eq perm_eqP perm_eqlP perm_eqrP. +Hint Resolve perm_eq_refl. + +Section RotrLemmas. + +Variables (n0 : nat) (T : Type) (T' : eqType). +Implicit Type s : seq T. + +Lemma size_rotr s : size (rotr n0 s) = size s. +Proof. by rewrite size_rot. Qed. + +Lemma mem_rotr (s : seq T') : rotr n0 s =i s. +Proof. by move=> x; rewrite mem_rot. Qed. + +Lemma rotr_size_cat s1 s2 : rotr (size s2) (s1 ++ s2) = s2 ++ s1. +Proof. by rewrite /rotr size_cat addnK rot_size_cat. Qed. + +Lemma rotr1_rcons x s : rotr 1 (rcons s x) = x :: s. +Proof. by rewrite -rot1_cons rotK. Qed. + +Lemma has_rotr a s : has a (rotr n0 s) = has a s. +Proof. by rewrite has_rot. Qed. + +Lemma rotr_uniq (s : seq T') : uniq (rotr n0 s) = uniq s. +Proof. by rewrite rot_uniq. Qed. + +Lemma rotrK : cancel (@rotr T n0) (rot n0). +Proof. +move=> s; have [lt_n0s | ge_n0s] := ltnP n0 (size s). + by rewrite -{1}(subKn (ltnW lt_n0s)) -{1}[size s]size_rotr; exact: rotK. +by rewrite -{2}(rot_oversize ge_n0s) /rotr (eqnP ge_n0s) rot0. +Qed. + +Lemma rotr_inj : injective (@rotr T n0). +Proof. exact (can_inj rotrK). Qed. + +Lemma rev_rot s : rev (rot n0 s) = rotr n0 (rev s). +Proof. +rewrite /rotr size_rev -{3}(cat_take_drop n0 s) {1}/rot !rev_cat. +by rewrite -size_drop -size_rev rot_size_cat. +Qed. + +Lemma rev_rotr s : rev (rotr n0 s) = rot n0 (rev s). +Proof. +apply: canRL rotrK _; rewrite {1}/rotr size_rev size_rotr /rotr {2}/rot rev_cat. +set m := size s - n0; rewrite -{1}(@size_takel m _ _ (leq_subr _ _)). +by rewrite -size_rev rot_size_cat -rev_cat cat_take_drop. +Qed. + +End RotrLemmas. + +Section RotCompLemmas. + +Variable T : Type. +Implicit Type s : seq T. + +Lemma rot_addn m n s : m + n <= size s -> rot (m + n) s = rot m (rot n s). +Proof. +move=> sz_s; rewrite {1}/rot -[take _ s](cat_take_drop n). +rewrite 5!(catA, =^~ rot_size_cat) !cat_take_drop. +by rewrite size_drop !size_takel ?leq_addl ?addnK. +Qed. + +Lemma rotS n s : n < size s -> rot n.+1 s = rot 1 (rot n s). +Proof. exact: (@rot_addn 1). Qed. + +Lemma rot_add_mod m n s : n <= size s -> m <= size s -> + rot m (rot n s) = rot (if m + n <= size s then m + n else m + n - size s) s. +Proof. +move=> Hn Hm; case: leqP => [/rot_addn // | /ltnW Hmn]; symmetry. +by rewrite -{2}(rotK n s) /rotr -rot_addn size_rot addnBA ?subnK ?addnK. +Qed. + +Lemma rot_rot m n s : rot m (rot n s) = rot n (rot m s). +Proof. +case: (ltnP (size s) m) => Hm. + by rewrite !(@rot_oversize T m) ?size_rot 1?ltnW. +case: (ltnP (size s) n) => Hn. + by rewrite !(@rot_oversize T n) ?size_rot 1?ltnW. +by rewrite !rot_add_mod 1?addnC. +Qed. + +Lemma rot_rotr m n s : rot m (rotr n s) = rotr n (rot m s). +Proof. by rewrite {2}/rotr size_rot rot_rot. Qed. + +Lemma rotr_rotr m n s : rotr m (rotr n s) = rotr n (rotr m s). +Proof. by rewrite /rotr !size_rot rot_rot. Qed. + +End RotCompLemmas. + +Section Mask. + +Variables (n0 : nat) (T : Type). +Implicit Types (m : bitseq) (s : seq T). + +Fixpoint mask m s {struct m} := + match m, s with + | b :: m', x :: s' => if b then x :: mask m' s' else mask m' s' + | _, _ => [::] + end. + +Lemma mask_false s n : mask (nseq n false) s = [::]. +Proof. by elim: s n => [|x s IHs] [|n] /=. Qed. + +Lemma mask_true s n : size s <= n -> mask (nseq n true) s = s. +Proof. by elim: s n => [|x s IHs] [|n] //= Hn; congr (_ :: _); apply: IHs. Qed. + +Lemma mask0 m : mask m [::] = [::]. +Proof. by case: m. Qed. + +Lemma mask1 b x : mask [:: b] [:: x] = nseq b x. +Proof. by case: b. Qed. + +Lemma mask_cons b m x s : mask (b :: m) (x :: s) = nseq b x ++ mask m s. +Proof. by case: b. Qed. + +Lemma size_mask m s : size m = size s -> size (mask m s) = count id m. +Proof. by move: m s; apply: seq2_ind => // -[] x m s /= ->. Qed. + +Lemma mask_cat m1 m2 s1 s2 : + size m1 = size s1 -> mask (m1 ++ m2) (s1 ++ s2) = mask m1 s1 ++ mask m2 s2. +Proof. by move: m1 s1; apply: seq2_ind => // -[] m1 x1 s1 /= ->. Qed. + +Lemma has_mask_cons a b m x s : + has a (mask (b :: m) (x :: s)) = b && a x || has a (mask m s). +Proof. by case: b. Qed. + +Lemma has_mask a m s : has a (mask m s) -> has a s. +Proof. +elim: m s => [|b m IHm] [|x s] //; rewrite has_mask_cons /= andbC. +by case: (a x) => //= /IHm. +Qed. + +Lemma mask_rot m s : size m = size s -> + mask (rot n0 m) (rot n0 s) = rot (count id (take n0 m)) (mask m s). +Proof. +move=> Ems; rewrite mask_cat ?size_drop ?Ems // -rot_size_cat. +by rewrite size_mask -?mask_cat ?size_take ?Ems // !cat_take_drop. +Qed. + +Lemma resize_mask m s : {m1 | size m1 = size s & mask m s = mask m1 s}. +Proof. +by exists (take (size s) m ++ nseq (size s - size m) false); + elim: s m => [|x s IHs] [|b m] //=; rewrite (size_nseq, mask_false, IHs). +Qed. + +End Mask. + +Section EqMask. + +Variables (n0 : nat) (T : eqType). +Implicit Types (s : seq T) (m : bitseq). + +Lemma mem_mask_cons x b m y s : + (x \in mask (b :: m) (y :: s)) = b && (x == y) || (x \in mask m s). +Proof. by case: b. Qed. + +Lemma mem_mask x m s : x \in mask m s -> x \in s. +Proof. by rewrite -!has_pred1 => /has_mask. Qed. + +Lemma mask_uniq s : uniq s -> forall m, uniq (mask m s). +Proof. +elim: s => [|x s IHs] Uxs [|b m] //=. +case: b Uxs => //= /andP[s'x Us]; rewrite {}IHs // andbT. +by apply: contra s'x; exact: mem_mask. +Qed. + +Lemma mem_mask_rot m s : + size m = size s -> mask (rot n0 m) (rot n0 s) =i mask m s. +Proof. by move=> Ems x; rewrite mask_rot // mem_rot. Qed. + +End EqMask. + +Section Subseq. + +Variable T : eqType. +Implicit Type s : seq T. + +Fixpoint subseq s1 s2 := + if s2 is y :: s2' then + if s1 is x :: s1' then subseq (if x == y then s1' else s1) s2' else true + else s1 == [::]. + +Lemma sub0seq s : subseq [::] s. Proof. by case: s. Qed. + +Lemma subseq0 s : subseq s [::] = (s == [::]). Proof. by []. Qed. + +Lemma subseqP s1 s2 : + reflect (exists2 m, size m = size s2 & s1 = mask m s2) (subseq s1 s2). +Proof. +elim: s2 s1 => [|y s2 IHs2] [|x s1]. +- by left; exists [::]. +- by right; do 2!case. +- by left; exists (nseq (size s2).+1 false); rewrite ?size_nseq //= mask_false. +apply: {IHs2}(iffP (IHs2 _)) => [] [m sz_m def_s1]. + by exists ((x == y) :: m); rewrite /= ?sz_m // -def_s1; case: eqP => // ->. +case: eqP => [_ | ne_xy]; last first. + by case: m def_s1 sz_m => [//|[m []//|m]] -> [<-]; exists m. +pose i := index true m; have def_m_i: take i m = nseq (size (take i m)) false. + apply/all_pred1P; apply/(all_nthP true) => j. + rewrite size_take ltnNge geq_min negb_or -ltnNge; case/andP=> lt_j_i _. + rewrite nth_take //= -negb_add addbF -addbT -negb_eqb. + by rewrite [_ == _](before_find _ lt_j_i). +have lt_i_m: i < size m. + rewrite ltnNge; apply/negP=> le_m_i; rewrite take_oversize // in def_m_i. + by rewrite def_m_i mask_false in def_s1. +rewrite size_take lt_i_m in def_m_i. +exists (take i m ++ drop i.+1 m). + rewrite size_cat size_take size_drop lt_i_m. + by rewrite sz_m in lt_i_m *; rewrite subnKC. +rewrite {s1 def_s1}[s1](congr1 behead def_s1). +rewrite -[s2](cat_take_drop i) -{1}[m](cat_take_drop i) {}def_m_i -cat_cons. +have sz_i_s2: size (take i s2) = i by apply: size_takel; rewrite sz_m in lt_i_m. +rewrite lastI cat_rcons !mask_cat ?size_nseq ?size_belast ?mask_false //=. +by rewrite (drop_nth true) // nth_index -?index_mem. +Qed. + +Lemma mask_subseq m s : subseq (mask m s) s. +Proof. by apply/subseqP; have [m1] := resize_mask m s; exists m1. Qed. + +Lemma subseq_trans : transitive subseq. +Proof. +move=> _ _ s /subseqP[m2 _ ->] /subseqP[m1 _ ->]. +elim: s => [|x s IHs] in m2 m1 *; first by rewrite !mask0. +case: m1 => [|[] m1]; first by rewrite mask0. + case: m2 => [|[] m2] //; first by rewrite /= eqxx IHs. + case/subseqP: (IHs m2 m1) => m sz_m def_s; apply/subseqP. + by exists (false :: m); rewrite //= sz_m. +case/subseqP: (IHs m2 m1) => m sz_m def_s; apply/subseqP. +by exists (false :: m); rewrite //= sz_m. +Qed. + +Lemma subseq_refl s : subseq s s. +Proof. by elim: s => //= x s IHs; rewrite eqxx. Qed. +Hint Resolve subseq_refl. + +Lemma cat_subseq s1 s2 s3 s4 : + subseq s1 s3 -> subseq s2 s4 -> subseq (s1 ++ s2) (s3 ++ s4). +Proof. +case/subseqP=> m1 sz_m1 ->; case/subseqP=> m2 sz_m2 ->; apply/subseqP. +by exists (m1 ++ m2); rewrite ?size_cat ?mask_cat ?sz_m1 ?sz_m2. +Qed. + +Lemma prefix_subseq s1 s2 : subseq s1 (s1 ++ s2). +Proof. by rewrite -{1}[s1]cats0 cat_subseq ?sub0seq. Qed. + +Lemma suffix_subseq s1 s2 : subseq s2 (s1 ++ s2). +Proof. by rewrite -{1}[s2]cat0s cat_subseq ?sub0seq. Qed. + +Lemma mem_subseq s1 s2 : subseq s1 s2 -> {subset s1 <= s2}. +Proof. by case/subseqP=> m _ -> x; exact: mem_mask. Qed. + +Lemma sub1seq x s : subseq [:: x] s = (x \in s). +Proof. +by elim: s => //= y s; rewrite inE; case: (x == y); rewrite ?sub0seq. +Qed. + +Lemma size_subseq s1 s2 : subseq s1 s2 -> size s1 <= size s2. +Proof. by case/subseqP=> m sz_m ->; rewrite size_mask -sz_m ?count_size. Qed. + +Lemma size_subseq_leqif s1 s2 : + subseq s1 s2 -> size s1 <= size s2 ?= iff (s1 == s2). +Proof. +move=> sub12; split; first exact: size_subseq. +apply/idP/eqP=> [|-> //]; case/subseqP: sub12 => m sz_m ->{s1}. +rewrite size_mask -sz_m // -all_count -(eq_all eqb_id). +by move/(@all_pred1P _ true)->; rewrite sz_m mask_true. +Qed. + +Lemma subseq_cons s x : subseq s (x :: s). +Proof. by exact: (@cat_subseq [::] s [:: x]). Qed. + +Lemma subseq_rcons s x : subseq s (rcons s x). +Proof. by rewrite -{1}[s]cats0 -cats1 cat_subseq. Qed. + +Lemma subseq_uniq s1 s2 : subseq s1 s2 -> uniq s2 -> uniq s1. +Proof. by case/subseqP=> m _ -> Us2; exact: mask_uniq. Qed. + +End Subseq. + +Prenex Implicits subseq. +Implicit Arguments subseqP [T s1 s2]. + +Hint Resolve subseq_refl. + +Section Rem. + +Variables (T : eqType) (x : T). + +Fixpoint rem s := if s is y :: t then (if y == x then t else y :: rem t) else s. + +Lemma rem_id s : x \notin s -> rem s = s. +Proof. +by elim: s => //= y s IHs /norP[neq_yx /IHs->]; rewrite eq_sym (negbTE neq_yx). +Qed. + +Lemma perm_to_rem s : x \in s -> perm_eq s (x :: rem s). +Proof. +elim: s => // y s IHs; rewrite inE /= eq_sym perm_eq_sym. +case: eqP => [-> // | _ /IHs]. +by rewrite (perm_catCA [:: x] [:: y]) perm_cons perm_eq_sym. +Qed. + +Lemma size_rem s : x \in s -> size (rem s) = (size s).-1. +Proof. by move/perm_to_rem/perm_eq_size->. Qed. + +Lemma rem_subseq s : subseq (rem s) s. +Proof. +elim: s => //= y s IHs; rewrite eq_sym. +by case: ifP => _; [exact: subseq_cons | rewrite eqxx]. +Qed. + +Lemma rem_uniq s : uniq s -> uniq (rem s). +Proof. by apply: subseq_uniq; exact: rem_subseq. Qed. + +Lemma mem_rem s : {subset rem s <= s}. +Proof. exact: mem_subseq (rem_subseq s). Qed. + +Lemma rem_filter s : uniq s -> rem s = filter (predC1 x) s. +Proof. +elim: s => //= y s IHs /andP[not_s_y /IHs->]. +by case: eqP => //= <-; apply/esym/all_filterP; rewrite all_predC has_pred1. +Qed. + +Lemma mem_rem_uniq s : uniq s -> rem s =i [predD1 s & x]. +Proof. by move/rem_filter=> -> y; rewrite mem_filter. Qed. + +End Rem. + +Section Map. + +Variables (n0 : nat) (T1 : Type) (x1 : T1). +Variables (T2 : Type) (x2 : T2) (f : T1 -> T2). + +Fixpoint map s := if s is x :: s' then f x :: map s' else [::]. + +Lemma map_cons x s : map (x :: s) = f x :: map s. +Proof. by []. Qed. + +Lemma map_nseq x : map (nseq n0 x) = nseq n0 (f x). +Proof. by elim: n0 => // *; congr (_ :: _). Qed. + +Lemma map_cat s1 s2 : map (s1 ++ s2) = map s1 ++ map s2. +Proof. by elim: s1 => [|x s1 IHs] //=; rewrite IHs. Qed. + +Lemma size_map s : size (map s) = size s. +Proof. by elim: s => //= x s ->. Qed. + +Lemma behead_map s : behead (map s) = map (behead s). +Proof. by case: s. Qed. + +Lemma nth_map n s : n < size s -> nth x2 (map s) n = f (nth x1 s n). +Proof. by elim: s n => [|x s IHs] [|n]; try exact (IHs n). Qed. + +Lemma map_rcons s x : map (rcons s x) = rcons (map s) (f x). +Proof. by rewrite -!cats1 map_cat. Qed. + +Lemma last_map s x : last (f x) (map s) = f (last x s). +Proof. by elim: s x => /=. Qed. + +Lemma belast_map s x : belast (f x) (map s) = map (belast x s). +Proof. by elim: s x => //= y s IHs x; rewrite IHs. Qed. + +Lemma filter_map a s : filter a (map s) = map (filter (preim f a) s). +Proof. by elim: s => //= x s IHs; rewrite (fun_if map) /= IHs. Qed. + +Lemma find_map a s : find a (map s) = find (preim f a) s. +Proof. by elim: s => //= x s ->. Qed. + +Lemma has_map a s : has a (map s) = has (preim f a) s. +Proof. by elim: s => //= x s ->. Qed. + +Lemma all_map a s : all a (map s) = all (preim f a) s. +Proof. by elim: s => //= x s ->. Qed. + +Lemma count_map a s : count a (map s) = count (preim f a) s. +Proof. by elim: s => //= x s ->. Qed. + +Lemma map_take s : map (take n0 s) = take n0 (map s). +Proof. by elim: n0 s => [|n IHn] [|x s] //=; rewrite IHn. Qed. + +Lemma map_drop s : map (drop n0 s) = drop n0 (map s). +Proof. by elim: n0 s => [|n IHn] [|x s] //=; rewrite IHn. Qed. + +Lemma map_rot s : map (rot n0 s) = rot n0 (map s). +Proof. by rewrite /rot map_cat map_take map_drop. Qed. + +Lemma map_rotr s : map (rotr n0 s) = rotr n0 (map s). +Proof. by apply: canRL (@rotK n0 T2) _; rewrite -map_rot rotrK. Qed. + +Lemma map_rev s : map (rev s) = rev (map s). +Proof. by elim: s => //= x s IHs; rewrite !rev_cons -!cats1 map_cat IHs. Qed. + +Lemma map_mask m s : map (mask m s) = mask m (map s). +Proof. by elim: m s => [|[|] m IHm] [|x p] //=; rewrite IHm. Qed. + +Lemma inj_map : injective f -> injective map. +Proof. +by move=> injf; elim=> [|y1 s1 IHs] [|y2 s2] //= [/injf-> /IHs->]. +Qed. + +End Map. + +Notation "[ 'seq' E | i <- s ]" := (map (fun i => E) s) + (at level 0, E at level 99, i ident, + format "[ '[hv' 'seq' E '/ ' | i <- s ] ']'") : seq_scope. + +Notation "[ 'seq' E | i <- s & C ]" := [seq E | i <- [seq i <- s | C]] + (at level 0, E at level 99, i ident, + format "[ '[hv' 'seq' E '/ ' | i <- s '/ ' & C ] ']'") : seq_scope. + +Notation "[ 'seq' E | i : T <- s ]" := (map (fun i : T => E) s) + (at level 0, E at level 99, i ident, only parsing) : seq_scope. + +Notation "[ 'seq' E | i : T <- s & C ]" := + [seq E | i : T <- [seq i : T <- s | C]] + (at level 0, E at level 99, i ident, only parsing) : seq_scope. + +Lemma filter_mask T a (s : seq T) : filter a s = mask (map a s) s. +Proof. by elim: s => //= x s <-; case: (a x). Qed. + +Section FilterSubseq. + +Variable T : eqType. +Implicit Types (s : seq T) (a : pred T). + +Lemma filter_subseq a s : subseq (filter a s) s. +Proof. by apply/subseqP; exists (map a s); rewrite ?size_map ?filter_mask. Qed. + +Lemma subseq_filter s1 s2 a : + subseq s1 (filter a s2) = all a s1 && subseq s1 s2. +Proof. +elim: s2 s1 => [|x s2 IHs] [|y s1] //=; rewrite ?andbF ?sub0seq //. +by case a_x: (a x); rewrite /= !IHs /=; case: eqP => // ->; rewrite a_x. +Qed. + +Lemma subseq_uniqP s1 s2 : + uniq s2 -> reflect (s1 = filter (mem s1) s2) (subseq s1 s2). +Proof. +move=> uniq_s2; apply: (iffP idP) => [ss12 | ->]; last exact: filter_subseq. +apply/eqP; rewrite -size_subseq_leqif ?subseq_filter ?(introT allP) //. +apply/eqP/esym/perm_eq_size. +rewrite uniq_perm_eq ?filter_uniq ?(subseq_uniq ss12) // => x. +by rewrite mem_filter; apply: andb_idr; exact: (mem_subseq ss12). +Qed. + +Lemma perm_to_subseq s1 s2 : + subseq s1 s2 -> {s3 | perm_eq s2 (s1 ++ s3)}. +Proof. +elim Ds2: s2 s1 => [|y s2' IHs] [|x s1] //=; try by exists s2; rewrite Ds2. +case: eqP => [-> | _] /IHs[s3 perm_s2] {IHs}. + by exists s3; rewrite perm_cons. +by exists (rcons s3 y); rewrite -cat_cons -perm_rcons -!cats1 catA perm_cat2r. +Qed. + +End FilterSubseq. + +Implicit Arguments subseq_uniqP [T s1 s2]. + +Section EqMap. + +Variables (n0 : nat) (T1 : eqType) (x1 : T1). +Variables (T2 : eqType) (x2 : T2) (f : T1 -> T2). +Implicit Type s : seq T1. + +Lemma map_f s x : x \in s -> f x \in map f s. +Proof. +elim: s => [|y s IHs] //=. +by case/predU1P=> [->|Hx]; [exact: predU1l | apply: predU1r; auto]. +Qed. + +Lemma mapP s y : reflect (exists2 x, x \in s & y = f x) (y \in map f s). +Proof. +elim: s => [|x s IHs]; first by right; case. +rewrite /= in_cons eq_sym; case Hxy: (f x == y). + by left; exists x; [rewrite mem_head | rewrite (eqP Hxy)]. +apply: (iffP IHs) => [[x' Hx' ->]|[x' Hx' Dy]]. + by exists x'; first exact: predU1r. +by move: Dy Hxy => ->; case/predU1P: Hx' => [->|]; [rewrite eqxx | exists x']. +Qed. + +Lemma map_uniq s : uniq (map f s) -> uniq s. +Proof. +elim: s => //= x s IHs /andP[not_sfx /IHs->]; rewrite andbT. +by apply: contra not_sfx => sx; apply/mapP; exists x. +Qed. + +Lemma map_inj_in_uniq s : {in s &, injective f} -> uniq (map f s) = uniq s. +Proof. +elim: s => //= x s IHs //= injf; congr (~~ _ && _). + apply/mapP/idP=> [[y sy /injf] | ]; last by exists x. + by rewrite mem_head mem_behead // => ->. +apply: IHs => y z sy sz; apply: injf => //; exact: predU1r. +Qed. + +Lemma map_subseq s1 s2 : subseq s1 s2 -> subseq (map f s1) (map f s2). +Proof. +case/subseqP=> m sz_m ->; apply/subseqP. +by exists m; rewrite ?size_map ?map_mask. +Qed. + +Lemma nth_index_map s x0 x : + {in s &, injective f} -> x \in s -> nth x0 s (index (f x) (map f s)) = x. +Proof. +elim: s => //= y s IHs inj_f s_x; rewrite (inj_in_eq inj_f) ?mem_head //. +move: s_x; rewrite inE eq_sym; case: eqP => [-> | _] //=; apply: IHs. +by apply: sub_in2 inj_f => z; exact: predU1r. +Qed. + +Lemma perm_map s t : perm_eq s t -> perm_eq (map f s) (map f t). +Proof. by move/perm_eqP=> Est; apply/perm_eqP=> a; rewrite !count_map Est. Qed. + +Hypothesis Hf : injective f. + +Lemma mem_map s x : (f x \in map f s) = (x \in s). +Proof. by apply/mapP/idP=> [[y Hy /Hf->] //|]; exists x. Qed. + +Lemma index_map s x : index (f x) (map f s) = index x s. +Proof. by rewrite /index; elim: s => //= y s IHs; rewrite (inj_eq Hf) IHs. Qed. + +Lemma map_inj_uniq s : uniq (map f s) = uniq s. +Proof. apply: map_inj_in_uniq; exact: in2W. Qed. + +End EqMap. + +Implicit Arguments mapP [T1 T2 f s y]. +Prenex Implicits mapP. + +Lemma map_of_seq (T1 : eqType) T2 (s : seq T1) (fs : seq T2) (y0 : T2) : + {f | uniq s -> size fs = size s -> map f s = fs}. +Proof. +exists (fun x => nth y0 fs (index x s)) => uAs eq_sz. +apply/esym/(@eq_from_nth _ y0); rewrite ?size_map eq_sz // => i ltis. +have x0 : T1 by [case: (s) ltis]; by rewrite (nth_map x0) // index_uniq. +Qed. + +Section MapComp. + +Variable T1 T2 T3 : Type. + +Lemma map_id (s : seq T1) : map id s = s. +Proof. by elim: s => //= x s ->. Qed. + +Lemma eq_map (f1 f2 : T1 -> T2) : f1 =1 f2 -> map f1 =1 map f2. +Proof. by move=> Ef; elim=> //= x s ->; rewrite Ef. Qed. + +Lemma map_comp (f1 : T2 -> T3) (f2 : T1 -> T2) s : + map (f1 \o f2) s = map f1 (map f2 s). +Proof. by elim: s => //= x s ->. Qed. + +Lemma mapK (f1 : T1 -> T2) (f2 : T2 -> T1) : + cancel f1 f2 -> cancel (map f1) (map f2). +Proof. by move=> eq_f12; elim=> //= x s ->; rewrite eq_f12. Qed. + +End MapComp. + +Lemma eq_in_map (T1 : eqType) T2 (f1 f2 : T1 -> T2) (s : seq T1) : + {in s, f1 =1 f2} <-> map f1 s = map f2 s. +Proof. +elim: s => //= x s IHs; split=> [eqf12 | [f12x /IHs eqf12]]; last first. + by move=> y /predU1P[-> | /eqf12]. +rewrite eqf12 ?mem_head //; congr (_ :: _). +by apply/IHs=> y s_y; rewrite eqf12 // mem_behead. +Qed. + +Lemma map_id_in (T : eqType) f (s : seq T) : {in s, f =1 id} -> map f s = s. +Proof. by move/eq_in_map->; apply: map_id. Qed. + +(* Map a partial function *) + +Section Pmap. + +Variables (aT rT : Type) (f : aT -> option rT) (g : rT -> aT). + +Fixpoint pmap s := + if s is x :: s' then let r := pmap s' in oapp (cons^~ r) r (f x) else [::]. + +Lemma map_pK : pcancel g f -> cancel (map g) pmap. +Proof. by move=> gK; elim=> //= x s ->; rewrite gK. Qed. + +Lemma size_pmap s : size (pmap s) = count [eta f] s. +Proof. by elim: s => //= x s <-; case: (f _). Qed. + +Lemma pmapS_filter s : map some (pmap s) = map f (filter [eta f] s). +Proof. by elim: s => //= x s; case fx: (f x) => //= [u] <-; congr (_ :: _). Qed. + +Hypothesis fK : ocancel f g. + +Lemma pmap_filter s : map g (pmap s) = filter [eta f] s. +Proof. by elim: s => //= x s <-; rewrite -{3}(fK x); case: (f _). Qed. + +End Pmap. + +Section EqPmap. + +Variables (aT rT : eqType) (f : aT -> option rT) (g : rT -> aT). + +Lemma eq_pmap (f1 f2 : aT -> option rT) : f1 =1 f2 -> pmap f1 =1 pmap f2. +Proof. by move=> Ef; elim=> //= x s ->; rewrite Ef. Qed. + +Lemma mem_pmap s u : (u \in pmap f s) = (Some u \in map f s). +Proof. by elim: s => //= x s IHs; rewrite in_cons -IHs; case: (f x). Qed. + +Hypothesis fK : ocancel f g. + +Lemma can2_mem_pmap : pcancel g f -> forall s u, (u \in pmap f s) = (g u \in s). +Proof. +by move=> gK s u; rewrite -(mem_map (pcan_inj gK)) pmap_filter // mem_filter gK. +Qed. + +Lemma pmap_uniq s : uniq s -> uniq (pmap f s). +Proof. +by move/(filter_uniq [eta f]); rewrite -(pmap_filter fK); exact: map_uniq. +Qed. + +End EqPmap. + +Section PmapSub. + +Variables (T : Type) (p : pred T) (sT : subType p). + +Lemma size_pmap_sub s : size (pmap (insub : T -> option sT) s) = count p s. +Proof. by rewrite size_pmap (eq_count (isSome_insub _)). Qed. + +End PmapSub. + +Section EqPmapSub. + +Variables (T : eqType) (p : pred T) (sT : subType p). + +Let insT : T -> option sT := insub. + +Lemma mem_pmap_sub s u : (u \in pmap insT s) = (val u \in s). +Proof. apply: (can2_mem_pmap (insubK _)); exact: valK. Qed. + +Lemma pmap_sub_uniq s : uniq s -> uniq (pmap insT s). +Proof. exact: (pmap_uniq (insubK _)). Qed. + +End EqPmapSub. + +(* Index sequence *) + +Fixpoint iota m n := if n is n'.+1 then m :: iota m.+1 n' else [::]. + +Lemma size_iota m n : size (iota m n) = n. +Proof. by elim: n m => //= n IHn m; rewrite IHn. Qed. + +Lemma iota_add m n1 n2 : iota m (n1 + n2) = iota m n1 ++ iota (m + n1) n2. +Proof. +by elim: n1 m => //= [|n1 IHn1] m; rewrite ?addn0 // -addSnnS -IHn1. +Qed. + +Lemma iota_addl m1 m2 n : iota (m1 + m2) n = map (addn m1) (iota m2 n). +Proof. by elim: n m2 => //= n IHn m2; rewrite -addnS IHn. Qed. + +Lemma nth_iota m n i : i < n -> nth 0 (iota m n) i = m + i. +Proof. +by move/subnKC <-; rewrite addSnnS iota_add nth_cat size_iota ltnn subnn. +Qed. + +Lemma mem_iota m n i : (i \in iota m n) = (m <= i) && (i < m + n). +Proof. +elim: n m => [|n IHn] /= m; first by rewrite addn0 ltnNge andbN. +rewrite -addSnnS leq_eqVlt in_cons eq_sym. +by case: eqP => [->|_]; [rewrite leq_addr | exact: IHn]. +Qed. + +Lemma iota_uniq m n : uniq (iota m n). +Proof. by elim: n m => //= n IHn m; rewrite mem_iota ltnn /=. Qed. + +(* Making a sequence of a specific length, using indexes to compute items. *) + +Section MakeSeq. + +Variables (T : Type) (x0 : T). + +Definition mkseq f n : seq T := map f (iota 0 n). + +Lemma size_mkseq f n : size (mkseq f n) = n. +Proof. by rewrite size_map size_iota. Qed. + +Lemma eq_mkseq f g : f =1 g -> mkseq f =1 mkseq g. +Proof. by move=> Efg n; exact: eq_map Efg _. Qed. + +Lemma nth_mkseq f n i : i < n -> nth x0 (mkseq f n) i = f i. +Proof. by move=> Hi; rewrite (nth_map 0) ?nth_iota ?size_iota. Qed. + +Lemma mkseq_nth s : mkseq (nth x0 s) (size s) = s. +Proof. +by apply: (@eq_from_nth _ x0); rewrite size_mkseq // => i Hi; rewrite nth_mkseq. +Qed. + +End MakeSeq. + +Section MakeEqSeq. + +Variable T : eqType. + +Lemma mkseq_uniq (f : nat -> T) n : injective f -> uniq (mkseq f n). +Proof. by move/map_inj_uniq->; apply: iota_uniq. Qed. + +Lemma perm_eq_iotaP {s t : seq T} x0 (It := iota 0 (size t)) : + reflect (exists2 Is, perm_eq Is It & s = map (nth x0 t) Is) (perm_eq s t). +Proof. +apply: (iffP idP) => [Est | [Is eqIst ->]]; last first. + by rewrite -{2}[t](mkseq_nth x0) perm_map. +elim: t => [|x t IHt] in s It Est *. + by rewrite (perm_eq_small _ Est) //; exists [::]. +have /rot_to[k s1 Ds]: x \in s by rewrite (perm_eq_mem Est) mem_head. +have [|Is1 eqIst1 Ds1] := IHt s1; first by rewrite -(perm_cons x) -Ds perm_rot. +exists (rotr k (0 :: map succn Is1)). + by rewrite perm_rot /It /= perm_cons (iota_addl 1) perm_map. +by rewrite map_rotr /= -map_comp -(@eq_map _ _ (nth x0 t)) // -Ds1 -Ds rotK. +Qed. + +End MakeEqSeq. + +Implicit Arguments perm_eq_iotaP [[T] [s] [t]]. + +Section FoldRight. + +Variables (T : Type) (R : Type) (f : T -> R -> R) (z0 : R). + +Fixpoint foldr s := if s is x :: s' then f x (foldr s') else z0. + +End FoldRight. + +Section FoldRightComp. + +Variables (T1 T2 : Type) (h : T1 -> T2). +Variables (R : Type) (f : T2 -> R -> R) (z0 : R). + +Lemma foldr_cat s1 s2 : foldr f z0 (s1 ++ s2) = foldr f (foldr f z0 s2) s1. +Proof. by elim: s1 => //= x s1 ->. Qed. + +Lemma foldr_map s : foldr f z0 (map h s) = foldr (fun x z => f (h x) z) z0 s. +Proof. by elim: s => //= x s ->. Qed. + +End FoldRightComp. + +(* Quick characterization of the null sequence. *) + +Definition sumn := foldr addn 0. + +Lemma sumn_nseq x n : sumn (nseq n x) = x * n. +Proof. by rewrite mulnC; elim: n => //= n ->. Qed. + +Lemma sumn_cat s1 s2 : sumn (s1 ++ s2) = sumn s1 + sumn s2. +Proof. by elim: s1 => //= x s1 ->; rewrite addnA. Qed. + +Lemma natnseq0P s : reflect (s = nseq (size s) 0) (sumn s == 0). +Proof. +apply: (iffP idP) => [|->]; last by rewrite sumn_nseq. +by elim: s => //= x s IHs; rewrite addn_eq0 => /andP[/eqP-> /IHs <-]. +Qed. + +Section FoldLeft. + +Variables (T R : Type) (f : R -> T -> R). + +Fixpoint foldl z s := if s is x :: s' then foldl (f z x) s' else z. + +Lemma foldl_rev z s : foldl z (rev s) = foldr (fun x z => f z x) z s. +Proof. +elim/last_ind: s z => [|s x IHs] z //=. +by rewrite rev_rcons -cats1 foldr_cat -IHs. +Qed. + +Lemma foldl_cat z s1 s2 : foldl z (s1 ++ s2) = foldl (foldl z s1) s2. +Proof. +by rewrite -(revK (s1 ++ s2)) foldl_rev rev_cat foldr_cat -!foldl_rev !revK. +Qed. + +End FoldLeft. + +Section Scan. + +Variables (T1 : Type) (x1 : T1) (T2 : Type) (x2 : T2). +Variables (f : T1 -> T1 -> T2) (g : T1 -> T2 -> T1). + +Fixpoint pairmap x s := if s is y :: s' then f x y :: pairmap y s' else [::]. + +Lemma size_pairmap x s : size (pairmap x s) = size s. +Proof. by elim: s x => //= y s IHs x; rewrite IHs. Qed. + +Lemma pairmap_cat x s1 s2 : + pairmap x (s1 ++ s2) = pairmap x s1 ++ pairmap (last x s1) s2. +Proof. by elim: s1 x => //= y s1 IHs1 x; rewrite IHs1. Qed. + +Lemma nth_pairmap s n : n < size s -> + forall x, nth x2 (pairmap x s) n = f (nth x1 (x :: s) n) (nth x1 s n). +Proof. by elim: s n => [|y s IHs] [|n] //= Hn x; apply: IHs. Qed. + +Fixpoint scanl x s := + if s is y :: s' then let x' := g x y in x' :: scanl x' s' else [::]. + +Lemma size_scanl x s : size (scanl x s) = size s. +Proof. by elim: s x => //= y s IHs x; rewrite IHs. Qed. + +Lemma scanl_cat x s1 s2 : + scanl x (s1 ++ s2) = scanl x s1 ++ scanl (foldl g x s1) s2. +Proof. by elim: s1 x => //= y s1 IHs1 x; rewrite IHs1. Qed. + +Lemma nth_scanl s n : n < size s -> + forall x, nth x1 (scanl x s) n = foldl g x (take n.+1 s). +Proof. by elim: s n => [|y s IHs] [|n] Hn x //=; rewrite ?take0 ?IHs. Qed. + +Lemma scanlK : + (forall x, cancel (g x) (f x)) -> forall x, cancel (scanl x) (pairmap x). +Proof. by move=> Hfg x s; elim: s x => //= y s IHs x; rewrite Hfg IHs. Qed. + +Lemma pairmapK : + (forall x, cancel (f x) (g x)) -> forall x, cancel (pairmap x) (scanl x). +Proof. by move=> Hgf x s; elim: s x => //= y s IHs x; rewrite Hgf IHs. Qed. + +End Scan. + +Prenex Implicits mask map pmap foldr foldl scanl pairmap. + +Section Zip. + +Variables S T : Type. + +Fixpoint zip (s : seq S) (t : seq T) {struct t} := + match s, t with + | x :: s', y :: t' => (x, y) :: zip s' t' + | _, _ => [::] + end. + +Definition unzip1 := map (@fst S T). +Definition unzip2 := map (@snd S T). + +Lemma zip_unzip s : zip (unzip1 s) (unzip2 s) = s. +Proof. by elim: s => [|[x y] s /= ->]. Qed. + +Lemma unzip1_zip s t : size s <= size t -> unzip1 (zip s t) = s. +Proof. by elim: s t => [|x s IHs] [|y t] //= le_s_t; rewrite IHs. Qed. + +Lemma unzip2_zip s t : size t <= size s -> unzip2 (zip s t) = t. +Proof. by elim: s t => [|x s IHs] [|y t] //= le_t_s; rewrite IHs. Qed. + +Lemma size1_zip s t : size s <= size t -> size (zip s t) = size s. +Proof. by elim: s t => [|x s IHs] [|y t] //= Hs; rewrite IHs. Qed. + +Lemma size2_zip s t : size t <= size s -> size (zip s t) = size t. +Proof. by elim: s t => [|x s IHs] [|y t] //= Hs; rewrite IHs. Qed. + +Lemma size_zip s t : size (zip s t) = minn (size s) (size t). +Proof. +by elim: s t => [|x s IHs] [|t2 t] //=; rewrite IHs -add1n addn_minr. +Qed. + +Lemma zip_cat s1 s2 t1 t2 : + size s1 = size t1 -> zip (s1 ++ s2) (t1 ++ t2) = zip s1 t1 ++ zip s2 t2. +Proof. by elim: s1 t1 => [|x s IHs] [|y t] //= [/IHs->]. Qed. + +Lemma nth_zip x y s t i : + size s = size t -> nth (x, y) (zip s t) i = (nth x s i, nth y t i). +Proof. by elim: i s t => [|i IHi] [|y1 s1] [|y2 t] //= [/IHi->]. Qed. + +Lemma nth_zip_cond p s t i : + nth p (zip s t) i + = (if i < size (zip s t) then (nth p.1 s i, nth p.2 t i) else p). +Proof. +rewrite size_zip ltnNge geq_min. +by elim: s t i => [|x s IHs] [|y t] [|i] //=; rewrite ?orbT -?IHs. +Qed. + +Lemma zip_rcons s1 s2 z1 z2 : + size s1 = size s2 -> + zip (rcons s1 z1) (rcons s2 z2) = rcons (zip s1 s2) (z1, z2). +Proof. by move=> eq_sz; rewrite -!cats1 zip_cat //= eq_sz. Qed. + +Lemma rev_zip s1 s2 : + size s1 = size s2 -> rev (zip s1 s2) = zip (rev s1) (rev s2). +Proof. +elim: s1 s2 => [|x s1 IHs] [|y s2] //= [eq_sz]. +by rewrite !rev_cons zip_rcons ?IHs ?size_rev. +Qed. + +End Zip. + +Prenex Implicits zip unzip1 unzip2. + +Section Flatten. + +Variable T : Type. +Implicit Types (s : seq T) (ss : seq (seq T)). + +Definition flatten := foldr cat (Nil T). +Definition shape := map (@size T). +Fixpoint reshape sh s := + if sh is n :: sh' then take n s :: reshape sh' (drop n s) else [::]. + +Lemma size_flatten ss : size (flatten ss) = sumn (shape ss). +Proof. by elim: ss => //= s ss <-; rewrite size_cat. Qed. + +Lemma flatten_cat ss1 ss2 : + flatten (ss1 ++ ss2) = flatten ss1 ++ flatten ss2. +Proof. by elim: ss1 => //= s ss1 ->; rewrite catA. Qed. + +Lemma flattenK ss : reshape (shape ss) (flatten ss) = ss. +Proof. +by elim: ss => //= s ss IHss; rewrite take_size_cat ?drop_size_cat ?IHss. +Qed. + +Lemma reshapeKr sh s : size s <= sumn sh -> flatten (reshape sh s) = s. +Proof. +elim: sh s => [[]|n sh IHsh] //= s sz_s; rewrite IHsh ?cat_take_drop //. +by rewrite size_drop leq_subLR. +Qed. + +Lemma reshapeKl sh s : size s >= sumn sh -> shape (reshape sh s) = sh. +Proof. +elim: sh s => [[]|n sh IHsh] //= s sz_s. +rewrite size_takel; last exact: leq_trans (leq_addr _ _) sz_s. +by rewrite IHsh // -(leq_add2l n) size_drop -maxnE leq_max sz_s orbT. +Qed. + +End Flatten. + +Prenex Implicits flatten shape reshape. + +Section EqFlatten. + +Variables S T : eqType. + +Lemma flattenP (A : seq (seq T)) x : + reflect (exists2 s, s \in A & x \in s) (x \in flatten A). +Proof. +elim: A => /= [|s A /iffP IH_A]; [by right; case | rewrite mem_cat]. +have [s_x|s'x] := @idP (x \in s); first by left; exists s; rewrite ?mem_head. +by apply: IH_A => [[t] | [t /predU1P[->|]]]; exists t; rewrite // mem_behead. +Qed. +Implicit Arguments flattenP [A x]. + +Lemma flatten_mapP (A : S -> seq T) s y : + reflect (exists2 x, x \in s & y \in A x) (y \in flatten (map A s)). +Proof. +apply: (iffP flattenP) => [[_ /mapP[x sx ->]] | [x sx]] Axy; first by exists x. +by exists (A x); rewrite ?map_f. +Qed. + +End EqFlatten. + +Implicit Arguments flattenP [T A x]. +Implicit Arguments flatten_mapP [S T A s y]. + +Lemma perm_undup_count (T : eqType) (s : seq T) : + perm_eq (flatten [seq nseq (count_mem x s) x | x <- undup s]) s. +Proof. +pose N x r := count_mem x (flatten [seq nseq (count_mem y s) y | y <- r]). +apply/allP=> x _; rewrite /= -/(N x _). +have Nx0 r (r'x : x \notin r): N x r = 0. + by apply/count_memPn; apply: contra r'x => /flatten_mapP[y r_y /nseqP[->]]. +have [|s'x] := boolP (x \in s); last by rewrite Nx0 ?mem_undup ?(count_memPn _). +rewrite -mem_undup => /perm_to_rem/catCA_perm_subst->; last first. + by move=> s1 s2 s3; rewrite /N !map_cat !flatten_cat !count_cat addnCA. +rewrite /N /= count_cat -/(N x _) Nx0 ?mem_rem_uniq ?undup_uniq ?inE ?eqxx //. +by rewrite addn0 -{2}(size_nseq (_ s) x) -all_count all_pred1_nseq. +Qed. + +Section AllPairs. + +Variables (S T R : Type) (f : S -> T -> R). +Implicit Types (s : seq S) (t : seq T). + +Definition allpairs s t := foldr (fun x => cat (map (f x) t)) [::] s. + +Lemma size_allpairs s t : size (allpairs s t) = size s * size t. +Proof. by elim: s => //= x s IHs; rewrite size_cat size_map IHs. Qed. + +Lemma allpairs_cat s1 s2 t : + allpairs (s1 ++ s2) t = allpairs s1 t ++ allpairs s2 t. +Proof. by elim: s1 => //= x s1 ->; rewrite catA. Qed. + +End AllPairs. + +Prenex Implicits allpairs. + +Notation "[ 'seq' E | i <- s , j <- t ]" := (allpairs (fun i j => E) s t) + (at level 0, E at level 99, i ident, j ident, + format "[ '[hv' 'seq' E '/ ' | i <- s , '/ ' j <- t ] ']'") + : seq_scope. +Notation "[ 'seq' E | i : T <- s , j : U <- t ]" := + (allpairs (fun (i : T) (j : U) => E) s t) + (at level 0, E at level 99, i ident, j ident, only parsing) : seq_scope. + +Section EqAllPairs. + +Variables S T : eqType. +Implicit Types (R : eqType) (s : seq S) (t : seq T). + +Lemma allpairsP R (f : S -> T -> R) s t z : + reflect (exists p, [/\ p.1 \in s, p.2 \in t & z = f p.1 p.2]) + (z \in allpairs f s t). +Proof. +elim: s => [|x s IHs /=]; first by right=> [[p []]]. +rewrite mem_cat; have [fxt_z | not_fxt_z] := altP mapP. + by left; have [y t_y ->] := fxt_z; exists (x, y); rewrite mem_head. +apply: (iffP IHs) => [] [[x' y] /= [s_x' t_y def_z]]; exists (x', y). + by rewrite !inE predU1r. +by have [def_x' | //] := predU1P s_x'; rewrite def_z def_x' map_f in not_fxt_z. +Qed. + +Lemma mem_allpairs R (f : S -> T -> R) s1 t1 s2 t2 : + s1 =i s2 -> t1 =i t2 -> allpairs f s1 t1 =i allpairs f s2 t2. +Proof. +move=> eq_s eq_t z. +by apply/allpairsP/allpairsP=> [] [p fpz]; exists p; rewrite eq_s eq_t in fpz *. +Qed. + +Lemma allpairs_catr R (f : S -> T -> R) s t1 t2 : + allpairs f s (t1 ++ t2) =i allpairs f s t1 ++ allpairs f s t2. +Proof. +move=> z; rewrite mem_cat. +apply/allpairsP/orP=> [[p [sP1]]|]. + by rewrite mem_cat; case/orP; [left | right]; apply/allpairsP; exists p. +by case=> /allpairsP[p [sp1 sp2 ->]]; exists p; rewrite mem_cat sp2 ?orbT. +Qed. + +Lemma allpairs_uniq R (f : S -> T -> R) s t : + uniq s -> uniq t -> + {in [seq (x, y) | x <- s, y <- t] &, injective (prod_curry f)} -> + uniq (allpairs f s t). +Proof. +move=> Us Ut inj_f; have: all (mem s) s by exact/allP. +elim: {-2}s Us => //= x s1 IHs /andP[s1'x Us1] /andP[sx1 ss1]. +rewrite cat_uniq {}IHs // andbT map_inj_in_uniq ?Ut // => [|y1 y2 *]. + apply/hasPn=> _ /allpairsP[z [s1z tz ->]]; apply/mapP=> [[y ty Dy]]. + suffices [Dz1 _]: (z.1, z.2) = (x, y) by rewrite -Dz1 s1z in s1'x. + apply: inj_f => //; apply/allpairsP; last by exists (x, y). + by have:= allP ss1 _ s1z; exists z. +suffices: (x, y1) = (x, y2) by case. +by apply: inj_f => //; apply/allpairsP; [exists (x, y1) | exists (x, y2)]. +Qed. + +End EqAllPairs. diff --git a/mathcomp/ssreflect/ssrbool.v b/mathcomp/ssreflect/ssrbool.v new file mode 100644 index 0000000..aeaa266 --- /dev/null +++ b/mathcomp/ssreflect/ssrbool.v @@ -0,0 +1,1818 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun. + +(******************************************************************************) +(* A theory of boolean predicates and operators. A large part of this file is *) +(* concerned with boolean reflection. *) +(* Definitions and notations: *) +(* is_true b == the coercion of b : bool to Prop (:= b = true). *) +(* This is just input and displayed as `b''. *) +(* reflect P b == the reflection inductive predicate, asserting *) +(* that the logical proposition P : prop with the *) +(* formula b : bool. Lemmas asserting reflect P b *) +(* are often referred to as "views". *) +(* iffP, appP, sameP, rwP :: lemmas for direct manipulation of reflection *) +(* views: iffP is used to prove reflection from *) +(* logical equivalence, appP to compose views, and *) +(* sameP and rwP to perform boolean and setoid *) +(* rewriting. *) +(* elimT :: coercion reflect >-> Funclass, which allows the *) +(* direct application of `reflect' views to *) +(* boolean assertions. *) +(* decidable P <-> P is effectively decidable (:= {P} + {~ P}. *) +(* contra, contraL, ... :: contraposition lemmas. *) +(* altP my_viewP :: natural alternative for reflection; given *) +(* lemma myvieP: reflect my_Prop my_formula, *) +(* have [myP | not_myP] := altP my_viewP. *) +(* generates two subgoals, in which my_formula has *) +(* been replaced by true and false, resp., with *) +(* new assumptions myP : my_Prop and *) +(* not_myP: ~~ my_formula. *) +(* Caveat: my_formula must be an APPLICATION, not *) +(* a variable, constant, let-in, etc. (due to the *) +(* poor behaviour of dependent index matching). *) +(* boolP my_formula :: boolean disjunction, equivalent to *) +(* altP (idP my_formula) but circumventing the *) +(* dependent index capture issue; destructing *) +(* boolP my_formula generates two subgoals with *) +(* assumtions my_formula and ~~ myformula. As *) +(* with altP, my_formula must be an application. *) +(* unless C P <-> hP : P may be assumed when proving P. *) +(* := (P -> C) -> C (Pierce's law). *) +(* This is slightly weaker but easier to use than *) +(* P \/ C when P C : Prop. *) +(* classically P <-> hP : P can be assumed when proving is_true b *) +(* := forall b : bool, (P -> b) -> b. *) +(* This is equivalent to ~ (~ P) when P : Prop. *) +(* a && b == the boolean conjunction of a and b. *) +(* a || b == then boolean disjunction of a and b. *) +(* a ==> b == the boolean implication of b by a. *) +(* ~~ a == the boolean negation of a. *) +(* a (+) b == the boolean exclusive or (or sum) of a and b. *) +(* [ /\ P1 , P2 & P3 ] == multiway logical conjunction, up to 5 terms. *) +(* [ \/ P1 , P2 | P3 ] == multiway logical disjunction, up to 4 terms. *) +(* [&& a, b, c & d] == iterated, right associative boolean conjunction *) +(* with arbitrary arity. *) +(* [|| a, b, c | d] == iterated, right associative boolean disjunction *) +(* with arbitrary arity. *) +(* [==> a, b, c => d] == iterated, right associative boolean implication *) +(* with arbitrary arity. *) +(* and3P, ... == specific reflection lemmas for iterated *) +(* connectives. *) +(* andTb, orbAC, ... == systematic names for boolean connective *) +(* properties (see suffix conventions below). *) +(* prop_congr == a tactic to move a boolean equality from *) +(* its coerced form in Prop to the equality *) +(* in bool. *) +(* bool_congr == resolution tactic for blindly weeding out *) +(* like terms from boolean equalities (can fail). *) +(* This file provides a theory of boolean predicates and relations: *) +(* pred T == the type of bool predicates (:= T -> bool). *) +(* simpl_pred T == the type of simplifying bool predicates, using *) +(* the simpl_fun from ssrfun.v. *) +(* rel T == the type of bool relations. *) +(* := T -> pred T or T -> T -> bool. *) +(* simpl_rel T == type of simplifying relations. *) +(* predType == the generic predicate interface, supported for *) +(* for lists and sets. *) +(* pred_class == a coercion class for the predType projection to *) +(* pred; declaring a coercion to pred_class is an *) +(* alternative way of equipping a type with a *) +(* predType structure, which interoperates better *) +(* with coercion subtyping. This is used, e.g., *) +(* for finite sets, so that finite groups inherit *) +(* the membership operation by coercing to sets. *) +(* If P is a predicate the proposition "x satisfies P" can be written *) +(* applicatively as (P x), or using an explicit connective as (x \in P); in *) +(* the latter case we say that P is a "collective" predicate. We use A, B *) +(* rather than P, Q for collective predicates: *) +(* x \in A == x satisfies the (collective) predicate A. *) +(* x \notin A == x doesn't satisfy the (collective) predicate A. *) +(* The pred T type can be used as a generic predicate type for either kind, *) +(* but the two kinds of predicates should not be confused. When a "generic" *) +(* pred T value of one type needs to be passed as the other the following *) +(* conversions should be used explicitly: *) +(* SimplPred P == a (simplifying) applicative equivalent of P. *) +(* mem A == an applicative equivalent of A: *) +(* mem A x simplifies to x \in A. *) +(* Alternatively one can use the syntax for explicit simplifying predicates *) +(* and relations (in the following x is bound in E): *) +(* [pred x | E] == simplifying (see ssrfun) predicate x => E. *) +(* [pred x : T | E] == predicate x => T, with a cast on the argument. *) +(* [pred : T | P] == constant predicate P on type T. *) +(* [pred x | E1 & E2] == [pred x | E1 && E2]; an x : T cast is allowed. *) +(* [pred x in A] == [pred x | x in A]. *) +(* [pred x in A | E] == [pred x | x in A & E]. *) +(* [pred x in A | E1 & E2] == [pred x in A | E1 && E2]. *) +(* [predU A & B] == union of two collective predicates A and B. *) +(* [predI A & B] == intersection of collective predicates A and B. *) +(* [predD A & B] == difference of collective predicates A and B. *) +(* [predC A] == complement of the collective predicate A. *) +(* [preim f of A] == preimage under f of the collective predicate A. *) +(* predU P Q, ... == union, etc of applicative predicates. *) +(* pred0 == the empty predicate. *) +(* predT == the total (always true) predicate. *) +(* if T : predArgType, then T coerces to predT. *) +(* {: T} == T cast to predArgType (e.g., {: bool * nat}) *) +(* In the following, x and y are bound in E: *) +(* [rel x y | E] == simplifying relation x, y => E. *) +(* [rel x y : T | E] == simplifying relation with arguments cast. *) +(* [rel x y in A & B | E] == [rel x y | [&& x \in A, y \in B & E]]. *) +(* [rel x y in A & B] == [rel x y | (x \in A) && (y \in B)]. *) +(* [rel x y in A | E] == [rel x y in A & A | E]. *) +(* [rel x y in A] == [rel x y in A & A]. *) +(* relU R S == union of relations R and S. *) +(* Explicit values of type pred T (i.e., lamdba terms) should always be used *) +(* applicatively, while values of collection types implementing the predType *) +(* interface, such as sequences or sets should always be used as collective *) +(* predicates. Defined constants and functions of type pred T or simpl_pred T *) +(* as well as the explicit simpl_pred T values described below, can generally *) +(* be used either way. Note however that x \in A will not auto-simplify when *) +(* A is an explicit simpl_pred T value; the generic simplification rule inE *) +(* must be used (when A : pred T, the unfold_in rule can be used). Constants *) +(* of type pred T with an explicit simpl_pred value do not auto-simplify when *) +(* used applicatively, but can still be expanded with inE. This behavior can *) +(* be controlled as follows: *) +(* Let A : collective_pred T := [pred x | ... ]. *) +(* The collective_pred T type is just an alias for pred T, but this cast *) +(* stops rewrite inE from expanding the definition of A, thus treating A *) +(* into an abstract collection (unfold_in or in_collective can be used to *) +(* expand manually). *) +(* Let A : applicative_pred T := [pred x | ...]. *) +(* This cast causes inE to turn x \in A into the applicative A x form; *) +(* A will then have to unfolded explicitly with the /A rule. This will *) +(* also apply to any definition that reduces to A (e.g., Let B := A). *) +(* Canonical A_app_pred := ApplicativePred A. *) +(* This declaration, given after definition of A, similarly causes inE to *) +(* turn x \in A into A x, but in addition allows the app_predE rule to *) +(* turn A x back into x \in A; it can be used for any definition of type *) +(* pred T, which makes it especially useful for ambivalent predicates *) +(* as the relational transitive closure connect, that are used in both *) +(* applicative and collective styles. *) +(* Purely for aesthetics, we provide a subtype of collective predicates: *) +(* qualifier q T == a pred T pretty-printing wrapper. An A : qualifier q T *) +(* coerces to pred_class and thus behaves as a collective *) +(* predicate, but x \in A and x \notin A are displayed as: *) +(* x \is A and x \isn't A when q = 0, *) +(* x \is a A and x \isn't a A when q = 1, *) +(* x \is an A and x \isn't an A when q = 2, respectively. *) +(* [qualify x | P] := Qualifier 0 (fun x => P), constructor for the above. *) +(* [qualify x : T | P], [qualify a x | P], [qualify an X | P], etc. *) +(* variants of the above with type constraints and different *) +(* values of q. *) +(* We provide an internal interface to support attaching properties (such as *) +(* being multiplicative) to predicates: *) +(* pred_key p == phantom type that will serve as a support for properties *) +(* to be attached to p : pred_class; instances should be *) +(* created with Fact/Qed so as to be opaque. *) +(* KeyedPred k_p == an instance of the interface structure that attaches *) +(* (k_p : pred_key P) to P; the structure projection is a *) +(* coercion to pred_class. *) +(* KeyedQualifier k_q == an instance of the interface structure that attaches *) +(* (k_q : pred_key q) to (q : qualifier n T). *) +(* DefaultPredKey p == a default value for pred_key p; the vernacular command *) +(* Import DefaultKeying attaches this key to all predicates *) +(* that are not explicitly keyed. *) +(* Keys can be used to attach properties to predicates, qualifiers and *) +(* generic nouns in a way that allows them to be used transparently. The key *) +(* projection of a predicate property structure such as unsignedPred should *) +(* be a pred_key, not a pred, and corresponding lemmas will have the form *) +(* Lemma rpredN R S (oppS : @opprPred R S) (kS : keyed_pred oppS) : *) +(* {mono -%R: x / x \in kS}. *) +(* Because x \in kS will be displayed as x \in S (or x \is S, etc), the *) +(* canonical instance of opprPred will not normally be exposed (it will also *) +(* be erased by /= simplification). In addition each predicate structure *) +(* should have a DefaultPredKey Canonical instance that simply issues the *) +(* property as a proof obligation (which can be caught by the Prop-irrelevant *) +(* feature of the ssreflect plugin). *) +(* Some properties of predicates and relations: *) +(* A =i B <-> A and B are extensionally equivalent. *) +(* {subset A <= B} <-> A is a (collective) subpredicate of B. *) +(* subpred P Q <-> P is an (applicative) subpredicate or Q. *) +(* subrel R S <-> R is a subrelation of S. *) +(* In the following R is in rel T: *) +(* reflexive R <-> R is reflexive. *) +(* irreflexive R <-> R is irreflexive. *) +(* symmetric R <-> R (in rel T) is symmetric (equation). *) +(* pre_symmetric R <-> R is symmetric (implication). *) +(* antisymmetric R <-> R is antisymmetric. *) +(* total R <-> R is total. *) +(* transitive R <-> R is transitive. *) +(* left_transitive R <-> R is a congruence on its left hand side. *) +(* right_transitive R <-> R is a congruence on its right hand side. *) +(* equivalence_rel R <-> R is an equivalence relation. *) +(* Localization of (Prop) predicates; if P1 is convertible to forall x, Qx, *) +(* P2 to forall x y, Qxy and P3 to forall x y z, Qxyz : *) +(* {for y, P1} <-> Qx{y / x}. *) +(* {in A, P1} <-> forall x, x \in A -> Qx. *) +(* {in A1 & A2, P2} <-> forall x y, x \in A1 -> y \in A2 -> Qxy. *) +(* {in A &, P2} <-> forall x y, x \in A -> y \in A -> Qxy. *) +(* {in A1 & A2 & A3, Q3} <-> forall x y z, *) +(* x \in A1 -> y \in A2 -> z \in A3 -> Qxyz. *) +(* {in A1 & A2 &, Q3} == {in A1 & A2 & A2, Q3}. *) +(* {in A1 && A3, Q3} == {in A1 & A1 & A3, Q3}. *) +(* {in A &&, Q3} == {in A & A & A, Q3}. *) +(* {in A, bijective f} == f has a right inverse in A. *) +(* {on C, P1} == forall x, (f x) \in C -> Qx *) +(* when P1 is also convertible to Pf f. *) +(* {on C &, P2} == forall x y, f x \in C -> f y \in C -> Qxy *) +(* when P2 is also convertible to Pf f. *) +(* {on C, P1' & g} == forall x, (f x) \in cd -> Qx *) +(* when P1' is convertible to Pf f *) +(* and P1' g is convertible to forall x, Qx. *) +(* {on C, bijective f} == f has a right inverse on C. *) +(* This file extends the lemma name suffix conventions of ssrfun as follows: *) +(* A -- associativity, as in andbA : associative andb. *) +(* AC -- right commutativity. *) +(* ACA -- self-interchange (inner commutativity), e.g., *) +(* orbACA : (a || b) || (c || d) = (a || c) || (b || d). *) +(* b -- a boolean argument, as in andbb : idempotent andb. *) +(* C -- commutativity, as in andbC : commutative andb, *) +(* or predicate complement, as in predC. *) +(* CA -- left commutativity. *) +(* D -- predicate difference, as in predD. *) +(* E -- elimination, as in negbEf : ~~ b = false -> b. *) +(* F or f -- boolean false, as in andbF : b && false = false. *) +(* I -- left/right injectivity, as in addbI : right_injective addb, *) +(* or predicate intersection, as in predI. *) +(* l -- a left-hand operation, as andb_orl : left_distributive andb orb. *) +(* N or n -- boolean negation, as in andbN : a && (~~ a) = false. *) +(* P -- a characteristic property, often a reflection lemma, as in *) +(* andP : reflect (a /\ b) (a && b). *) +(* r -- a right-hand operation, as orb_andr : rightt_distributive orb andb. *) +(* T or t -- boolean truth, as in andbT: right_id true andb. *) +(* U -- predicate union, as in predU. *) +(* W -- weakening, as in in1W : {in D, forall x, P} -> forall x, P. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Reserved Notation "~~ b" (at level 35, right associativity). +Reserved Notation "b ==> c" (at level 55, right associativity). +Reserved Notation "b1 (+) b2" (at level 50, left associativity). +Reserved Notation "x \in A" + (at level 70, format "'[hv' x '/ ' \in A ']'", no associativity). +Reserved Notation "x \notin A" + (at level 70, format "'[hv' x '/ ' \notin A ']'", no associativity). +Reserved Notation "p1 =i p2" + (at level 70, format "'[hv' p1 '/ ' =i p2 ']'", no associativity). + +(* We introduce a number of n-ary "list-style" notations that share a common *) +(* format, namely *) +(* [op arg1, arg2, ... last_separator last_arg] *) +(* This usually denotes a right-associative applications of op, e.g., *) +(* [&& a, b, c & d] denotes a && (b && (c && d)) *) +(* The last_separator must be a non-operator token. Here we use &, | or =>; *) +(* our default is &, but we try to match the intended meaning of op. The *) +(* separator is a workaround for limitations of the parsing engine; the same *) +(* limitations mean the separator cannot be omitted even when last_arg can. *) +(* The Notation declarations are complicated by the separate treatment for *) +(* some fixed arities (binary for bool operators, and all arities for Prop *) +(* operators). *) +(* We also use the square brackets in comprehension-style notations *) +(* [type var separator expr] *) +(* where "type" is the type of the comprehension (e.g., pred) and "separator" *) +(* is | or => . It is important that in other notations a leading square *) +(* bracket [ is always by an operator symbol or a fixed identifier. *) + +Reserved Notation "[ /\ P1 & P2 ]" (at level 0, only parsing). +Reserved Notation "[ /\ P1 , P2 & P3 ]" (at level 0, format + "'[hv' [ /\ '[' P1 , '/' P2 ']' '/ ' & P3 ] ']'"). +Reserved Notation "[ /\ P1 , P2 , P3 & P4 ]" (at level 0, format + "'[hv' [ /\ '[' P1 , '/' P2 , '/' P3 ']' '/ ' & P4 ] ']'"). +Reserved Notation "[ /\ P1 , P2 , P3 , P4 & P5 ]" (at level 0, format + "'[hv' [ /\ '[' P1 , '/' P2 , '/' P3 , '/' P4 ']' '/ ' & P5 ] ']'"). + +Reserved Notation "[ \/ P1 | P2 ]" (at level 0, only parsing). +Reserved Notation "[ \/ P1 , P2 | P3 ]" (at level 0, format + "'[hv' [ \/ '[' P1 , '/' P2 ']' '/ ' | P3 ] ']'"). +Reserved Notation "[ \/ P1 , P2 , P3 | P4 ]" (at level 0, format + "'[hv' [ \/ '[' P1 , '/' P2 , '/' P3 ']' '/ ' | P4 ] ']'"). + +Reserved Notation "[ && b1 & c ]" (at level 0, only parsing). +Reserved Notation "[ && b1 , b2 , .. , bn & c ]" (at level 0, format + "'[hv' [ && '[' b1 , '/' b2 , '/' .. , '/' bn ']' '/ ' & c ] ']'"). + +Reserved Notation "[ || b1 | c ]" (at level 0, only parsing). +Reserved Notation "[ || b1 , b2 , .. , bn | c ]" (at level 0, format + "'[hv' [ || '[' b1 , '/' b2 , '/' .. , '/' bn ']' '/ ' | c ] ']'"). + +Reserved Notation "[ ==> b1 => c ]" (at level 0, only parsing). +Reserved Notation "[ ==> b1 , b2 , .. , bn => c ]" (at level 0, format + "'[hv' [ ==> '[' b1 , '/' b2 , '/' .. , '/' bn ']' '/' => c ] ']'"). + +Reserved Notation "[ 'pred' : T => E ]" (at level 0, format + "'[hv' [ 'pred' : T => '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x => E ]" (at level 0, x at level 8, format + "'[hv' [ 'pred' x => '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x : T => E ]" (at level 0, x at level 8, format + "'[hv' [ 'pred' x : T => '/ ' E ] ']'"). + +Reserved Notation "[ 'rel' x y => E ]" (at level 0, x, y at level 8, format + "'[hv' [ 'rel' x y => '/ ' E ] ']'"). +Reserved Notation "[ 'rel' x y : T => E ]" (at level 0, x, y at level 8, format + "'[hv' [ 'rel' x y : T => '/ ' E ] ']'"). + +(* Shorter delimiter *) +Delimit Scope bool_scope with B. +Open Scope bool_scope. + +(* An alternative to xorb that behaves somewhat better wrt simplification. *) +Definition addb b := if b then negb else id. + +(* Notation for && and || is declared in Init.Datatypes. *) +Notation "~~ b" := (negb b) : bool_scope. +Notation "b ==> c" := (implb b c) : bool_scope. +Notation "b1 (+) b2" := (addb b1 b2) : bool_scope. + +(* Constant is_true b := b = true is defined in Init.Datatypes. *) +Coercion is_true : bool >-> Sortclass. (* Prop *) + +Lemma prop_congr : forall b b' : bool, b = b' -> b = b' :> Prop. +Proof. by move=> b b' ->. Qed. + +Ltac prop_congr := apply: prop_congr. + +(* Lemmas for trivial. *) +Lemma is_true_true : true. Proof. by []. Qed. +Lemma not_false_is_true : ~ false. Proof. by []. Qed. +Lemma is_true_locked_true : locked true. Proof. by unlock. Qed. +Hint Resolve is_true_true not_false_is_true is_true_locked_true. + +(* Shorter names. *) +Definition isT := is_true_true. +Definition notF := not_false_is_true. + +(* Negation lemmas. *) + +(* We generally take NEGATION as the standard form of a false condition: *) +(* negative boolean hypotheses should be of the form ~~ b, rather than ~ b or *) +(* b = false, as much as possible. *) + +Lemma negbT b : b = false -> ~~ b. Proof. by case: b. Qed. +Lemma negbTE b : ~~ b -> b = false. Proof. by case: b. Qed. +Lemma negbF b : (b : bool) -> ~~ b = false. Proof. by case: b. Qed. +Lemma negbFE b : ~~ b = false -> b. Proof. by case: b. Qed. +Lemma negbK : involutive negb. Proof. by case. Qed. +Lemma negbNE b : ~~ ~~ b -> b. Proof. by case: b. Qed. + +Lemma negb_inj : injective negb. Proof. exact: can_inj negbK. Qed. +Lemma negbLR b c : b = ~~ c -> ~~ b = c. Proof. exact: canLR negbK. Qed. +Lemma negbRL b c : ~~ b = c -> b = ~~ c. Proof. exact: canRL negbK. Qed. + +Lemma contra (c b : bool) : (c -> b) -> ~~ b -> ~~ c. +Proof. by case: b => //; case: c. Qed. +Definition contraNN := contra. + +Lemma contraL (c b : bool) : (c -> ~~ b) -> b -> ~~ c. +Proof. by case: b => //; case: c. Qed. +Definition contraTN := contraL. + +Lemma contraR (c b : bool) : (~~ c -> b) -> ~~ b -> c. +Proof. by case: b => //; case: c. Qed. +Definition contraNT := contraR. + +Lemma contraLR (c b : bool) : (~~ c -> ~~ b) -> b -> c. +Proof. by case: b => //; case: c. Qed. +Definition contraTT := contraLR. + +Lemma contraT b : (~~ b -> false) -> b. Proof. by case: b => // ->. Qed. + +Lemma wlog_neg b : (~~ b -> b) -> b. Proof. by case: b => // ->. Qed. + +Lemma contraFT (c b : bool) : (~~ c -> b) -> b = false -> c. +Proof. by move/contraR=> notb_c /negbT. Qed. + +Lemma contraFN (c b : bool) : (c -> b) -> b = false -> ~~ c. +Proof. by move/contra=> notb_notc /negbT. Qed. + +Lemma contraTF (c b : bool) : (c -> ~~ b) -> b -> c = false. +Proof. by move/contraL=> b_notc /b_notc/negbTE. Qed. + +Lemma contraNF (c b : bool) : (c -> b) -> ~~ b -> c = false. +Proof. by move/contra=> notb_notc /notb_notc/negbTE. Qed. + +Lemma contraFF (c b : bool) : (c -> b) -> b = false -> c = false. +Proof. by move/contraFN=> bF_notc /bF_notc/negbTE. Qed. + +(* Coercion of sum-style datatypes into bool, which makes it possible *) +(* to use ssr's boolean if rather than Coq's "generic" if. *) + +Coercion isSome T (u : option T) := if u is Some _ then true else false. + +Coercion is_inl A B (u : A + B) := if u is inl _ then true else false. + +Coercion is_left A B (u : {A} + {B}) := if u is left _ then true else false. + +Coercion is_inleft A B (u : A + {B}) := if u is inleft _ then true else false. + +Prenex Implicits isSome is_inl is_left is_inleft. + +Definition decidable P := {P} + {~ P}. + +(* Lemmas for ifs with large conditions, which allow reasoning about the *) +(* condition without repeating it inside the proof (the latter IS *) +(* preferable when the condition is short). *) +(* Usage : *) +(* if the goal contains (if cond then ...) = ... *) +(* case: ifP => Hcond. *) +(* generates two subgoal, with the assumption Hcond : cond = true/false *) +(* Rewrite if_same eliminates redundant ifs *) +(* Rewrite (fun_if f) moves a function f inside an if *) +(* Rewrite if_arg moves an argument inside a function-valued if *) + +Section BoolIf. + +Variables (A B : Type) (x : A) (f : A -> B) (b : bool) (vT vF : A). + +CoInductive if_spec (not_b : Prop) : bool -> A -> Set := + | IfSpecTrue of b : if_spec not_b true vT + | IfSpecFalse of not_b : if_spec not_b false vF. + +Lemma ifP : if_spec (b = false) b (if b then vT else vF). +Proof. by case def_b: b; constructor. Qed. + +Lemma ifPn : if_spec (~~ b) b (if b then vT else vF). +Proof. by case def_b: b; constructor; rewrite ?def_b. Qed. + +Lemma ifT : b -> (if b then vT else vF) = vT. Proof. by move->. Qed. +Lemma ifF : b = false -> (if b then vT else vF) = vF. Proof. by move->. Qed. +Lemma ifN : ~~ b -> (if b then vT else vF) = vF. Proof. by move/negbTE->. Qed. + +Lemma if_same : (if b then vT else vT) = vT. +Proof. by case b. Qed. + +Lemma if_neg : (if ~~ b then vT else vF) = if b then vF else vT. +Proof. by case b. Qed. + +Lemma fun_if : f (if b then vT else vF) = if b then f vT else f vF. +Proof. by case b. Qed. + +Lemma if_arg (fT fF : A -> B) : + (if b then fT else fF) x = if b then fT x else fF x. +Proof. by case b. Qed. + +(* Turning a boolean "if" form into an application. *) +Definition if_expr := if b then vT else vF. +Lemma ifE : (if b then vT else vF) = if_expr. Proof. by []. Qed. + +End BoolIf. + +(* The reflection predicate. *) + +Inductive reflect (P : Prop) : bool -> Set := + | ReflectT of P : reflect P true + | ReflectF of ~ P : reflect P false. + +(* Core (internal) reflection lemmas, used for the three kinds of views. *) + +Section ReflectCore. + +Variables (P Q : Prop) (b c : bool). + +Hypothesis Hb : reflect P b. + +Lemma introNTF : (if c then ~ P else P) -> ~~ b = c. +Proof. by case c; case Hb. Qed. + +Lemma introTF : (if c then P else ~ P) -> b = c. +Proof. by case c; case Hb. Qed. + +Lemma elimNTF : ~~ b = c -> if c then ~ P else P. +Proof. by move <-; case Hb. Qed. + +Lemma elimTF : b = c -> if c then P else ~ P. +Proof. by move <-; case Hb. Qed. + +Lemma equivPif : (Q -> P) -> (P -> Q) -> if b then Q else ~ Q. +Proof. by case Hb; auto. Qed. + +Lemma xorPif : Q \/ P -> ~ (Q /\ P) -> if b then ~ Q else Q. +Proof. by case Hb => [? _ H ? | ? H _]; case: H. Qed. + +End ReflectCore. + +(* Internal negated reflection lemmas *) +Section ReflectNegCore. + +Variables (P Q : Prop) (b c : bool). +Hypothesis Hb : reflect P (~~ b). + +Lemma introTFn : (if c then ~ P else P) -> b = c. +Proof. by move/(introNTF Hb) <-; case b. Qed. + +Lemma elimTFn : b = c -> if c then ~ P else P. +Proof. by move <-; apply: (elimNTF Hb); case b. Qed. + +Lemma equivPifn : (Q -> P) -> (P -> Q) -> if b then ~ Q else Q. +Proof. rewrite -if_neg; exact: equivPif. Qed. + +Lemma xorPifn : Q \/ P -> ~ (Q /\ P) -> if b then Q else ~ Q. +Proof. rewrite -if_neg; exact: xorPif. Qed. + +End ReflectNegCore. + +(* User-oriented reflection lemmas *) +Section Reflect. + +Variables (P Q : Prop) (b b' c : bool). +Hypotheses (Pb : reflect P b) (Pb' : reflect P (~~ b')). + +Lemma introT : P -> b. Proof. exact: introTF true _. Qed. +Lemma introF : ~ P -> b = false. Proof. exact: introTF false _. Qed. +Lemma introN : ~ P -> ~~ b. Proof. exact: introNTF true _. Qed. +Lemma introNf : P -> ~~ b = false. Proof. exact: introNTF false _. Qed. +Lemma introTn : ~ P -> b'. Proof. exact: introTFn true _. Qed. +Lemma introFn : P -> b' = false. Proof. exact: introTFn false _. Qed. + +Lemma elimT : b -> P. Proof. exact: elimTF true _. Qed. +Lemma elimF : b = false -> ~ P. Proof. exact: elimTF false _. Qed. +Lemma elimN : ~~ b -> ~P. Proof. exact: elimNTF true _. Qed. +Lemma elimNf : ~~ b = false -> P. Proof. exact: elimNTF false _. Qed. +Lemma elimTn : b' -> ~ P. Proof. exact: elimTFn true _. Qed. +Lemma elimFn : b' = false -> P. Proof. exact: elimTFn false _. Qed. + +Lemma introP : (b -> Q) -> (~~ b -> ~ Q) -> reflect Q b. +Proof. by case b; constructor; auto. Qed. + +Lemma iffP : (P -> Q) -> (Q -> P) -> reflect Q b. +Proof. by case: Pb; constructor; auto. Qed. + +Lemma equivP : (P <-> Q) -> reflect Q b. +Proof. by case; exact: iffP. Qed. + +Lemma sumboolP (decQ : decidable Q) : reflect Q decQ. +Proof. by case: decQ; constructor. Qed. + +Lemma appP : reflect Q b -> P -> Q. +Proof. by move=> Qb; move/introT; case: Qb. Qed. + +Lemma sameP : reflect P c -> b = c. +Proof. case; [exact: introT | exact: introF]. Qed. + +Lemma decPcases : if b then P else ~ P. Proof. by case Pb. Qed. + +Definition decP : decidable P. by case: b decPcases; [left | right]. Defined. + +Lemma rwP : P <-> b. Proof. by split; [exact: introT | exact: elimT]. Qed. + +Lemma rwP2 : reflect Q b -> (P <-> Q). +Proof. by move=> Qb; split=> ?; [exact: appP | apply: elimT; case: Qb]. Qed. + +(* Predicate family to reflect excluded middle in bool. *) +CoInductive alt_spec : bool -> Type := + | AltTrue of P : alt_spec true + | AltFalse of ~~ b : alt_spec false. + +Lemma altP : alt_spec b. +Proof. by case def_b: b / Pb; constructor; rewrite ?def_b. Qed. + +End Reflect. + +Hint View for move/ elimTF|3 elimNTF|3 elimTFn|3 introT|2 introTn|2 introN|2. + +Hint View for apply/ introTF|3 introNTF|3 introTFn|3 elimT|2 elimTn|2 elimN|2. + +Hint View for apply// equivPif|3 xorPif|3 equivPifn|3 xorPifn|3. + +(* Allow the direct application of a reflection lemma to a boolean assertion. *) +Coercion elimT : reflect >-> Funclass. + +(* Pierce's law, a weak form of classical reasoning. *) +Definition unless condition property := (property -> condition) -> condition. + +Lemma bind_unless C P {Q} : unless C P -> unless (unless C Q) P. +Proof. by move=> haveP suffPQ suffQ; apply: haveP => /suffPQ; exact. Qed. + +Lemma unless_contra b C : (~~ b -> C) -> unless C b. +Proof. by case: b => [_ haveC | haveC _]; exact: haveC. Qed. + +(* Classical reasoning becomes directly accessible for any bool subgoal. *) +(* Note that we cannot use "unless" here for lack of universe polymorphism. *) +Definition classically P : Prop := forall b : bool, (P -> b) -> b. + +Lemma classicP : forall P : Prop, classically P <-> ~ ~ P. +Proof. +move=> P; split=> [cP nP | nnP [] // nP]; last by case nnP; move/nP. +by have: P -> false; [move/nP | move/cP]. +Qed. + +Lemma classic_bind : forall P Q, + (P -> classically Q) -> (classically P -> classically Q). +Proof. by move=> P Q IH IH_P b IH_Q; apply: IH_P; move/IH; exact. Qed. + +Lemma classic_EM : forall P, classically (decidable P). +Proof. +by move=> P [] // IH; apply IH; right => ?; apply: notF (IH _); left. +Qed. + +Lemma classic_imply : forall P Q, (P -> classically Q) -> classically (P -> Q). +Proof. +move=> P Q IH [] // notPQ; apply notPQ; move/IH=> hQ; case: notF. +by apply: hQ => hQ; case: notF; exact: notPQ. +Qed. + +Lemma classic_pick : forall T P, + classically ({x : T | P x} + (forall x, ~ P x)). +Proof. +move=> T P [] // IH; apply IH; right=> x Px; case: notF. +by apply: IH; left; exists x. +Qed. + +(* List notations for wider connectives; the Prop connectives have a fixed *) +(* width so as to avoid iterated destruction (we go up to width 5 for /\, and *) +(* width 4 for or. The bool connectives have arbitrary widths, but denote *) +(* expressions that associate to the RIGHT. This is consistent with the right *) +(* associativity of list expressions and thus more convenient in most proofs. *) + +Inductive and3 (P1 P2 P3 : Prop) : Prop := And3 of P1 & P2 & P3. + +Inductive and4 (P1 P2 P3 P4 : Prop) : Prop := And4 of P1 & P2 & P3 & P4. + +Inductive and5 (P1 P2 P3 P4 P5 : Prop) : Prop := + And5 of P1 & P2 & P3 & P4 & P5. + +Inductive or3 (P1 P2 P3 : Prop) : Prop := Or31 of P1 | Or32 of P2 | Or33 of P3. + +Inductive or4 (P1 P2 P3 P4 : Prop) : Prop := + Or41 of P1 | Or42 of P2 | Or43 of P3 | Or44 of P4. + +Notation "[ /\ P1 & P2 ]" := (and P1 P2) (only parsing) : type_scope. +Notation "[ /\ P1 , P2 & P3 ]" := (and3 P1 P2 P3) : type_scope. +Notation "[ /\ P1 , P2 , P3 & P4 ]" := (and4 P1 P2 P3 P4) : type_scope. +Notation "[ /\ P1 , P2 , P3 , P4 & P5 ]" := (and5 P1 P2 P3 P4 P5) : type_scope. + +Notation "[ \/ P1 | P2 ]" := (or P1 P2) (only parsing) : type_scope. +Notation "[ \/ P1 , P2 | P3 ]" := (or3 P1 P2 P3) : type_scope. +Notation "[ \/ P1 , P2 , P3 | P4 ]" := (or4 P1 P2 P3 P4) : type_scope. + +Notation "[ && b1 & c ]" := (b1 && c) (only parsing) : bool_scope. +Notation "[ && b1 , b2 , .. , bn & c ]" := (b1 && (b2 && .. (bn && c) .. )) + : bool_scope. + +Notation "[ || b1 | c ]" := (b1 || c) (only parsing) : bool_scope. +Notation "[ || b1 , b2 , .. , bn | c ]" := (b1 || (b2 || .. (bn || c) .. )) + : bool_scope. + +Notation "[ ==> b1 , b2 , .. , bn => c ]" := + (b1 ==> (b2 ==> .. (bn ==> c) .. )) : bool_scope. +Notation "[ ==> b1 => c ]" := (b1 ==> c) (only parsing) : bool_scope. + +Section AllAnd. + +Variables (T : Type) (P1 P2 P3 P4 P5 : T -> Prop). +Local Notation a P := (forall x, P x). + +Lemma all_and2 (hP : forall x, [/\ P1 x & P2 x]) : [/\ a P1 & a P2]. +Proof. by split=> x; case: (hP x). Qed. + +Lemma all_and3 (hP : forall x, [/\ P1 x, P2 x & P3 x]) : + [/\ a P1, a P2 & a P3]. +Proof. by split=> x; case: (hP x). Qed. + +Lemma all_and4 (hP : forall x, [/\ P1 x, P2 x, P3 x & P4 x]) : + [/\ a P1, a P2, a P3 & a P4]. +Proof. by split=> x; case: (hP x). Qed. + +Lemma all_and5 (hP : forall x, [/\ P1 x, P2 x, P3 x, P4 x & P5 x]) : + [/\ a P1, a P2, a P3, a P4 & a P5]. +Proof. by split=> x; case: (hP x). Qed. + +End AllAnd. + +Lemma pair_andP P Q : P /\ Q <-> P * Q. Proof. by split; case. Qed. + +Section ReflectConnectives. + +Variable b1 b2 b3 b4 b5 : bool. + +Lemma idP : reflect b1 b1. +Proof. by case b1; constructor. Qed. + +Lemma boolP : alt_spec b1 b1 b1. +Proof. exact: (altP idP). Qed. + +Lemma idPn : reflect (~~ b1) (~~ b1). +Proof. by case b1; constructor. Qed. + +Lemma negP : reflect (~ b1) (~~ b1). +Proof. by case b1; constructor; auto. Qed. + +Lemma negPn : reflect b1 (~~ ~~ b1). +Proof. by case b1; constructor. Qed. + +Lemma negPf : reflect (b1 = false) (~~ b1). +Proof. by case b1; constructor. Qed. + +Lemma andP : reflect (b1 /\ b2) (b1 && b2). +Proof. by case b1; case b2; constructor=> //; case. Qed. + +Lemma and3P : reflect [/\ b1, b2 & b3] [&& b1, b2 & b3]. +Proof. by case b1; case b2; case b3; constructor; try by case. Qed. + +Lemma and4P : reflect [/\ b1, b2, b3 & b4] [&& b1, b2, b3 & b4]. +Proof. by case b1; case b2; case b3; case b4; constructor; try by case. Qed. + +Lemma and5P : reflect [/\ b1, b2, b3, b4 & b5] [&& b1, b2, b3, b4 & b5]. +Proof. +by case b1; case b2; case b3; case b4; case b5; constructor; try by case. +Qed. + +Lemma orP : reflect (b1 \/ b2) (b1 || b2). +Proof. by case b1; case b2; constructor; auto; case. Qed. + +Lemma or3P : reflect [\/ b1, b2 | b3] [|| b1, b2 | b3]. +Proof. +case b1; first by constructor; constructor 1. +case b2; first by constructor; constructor 2. +case b3; first by constructor; constructor 3. +by constructor; case. +Qed. + +Lemma or4P : reflect [\/ b1, b2, b3 | b4] [|| b1, b2, b3 | b4]. +Proof. +case b1; first by constructor; constructor 1. +case b2; first by constructor; constructor 2. +case b3; first by constructor; constructor 3. +case b4; first by constructor; constructor 4. +by constructor; case. +Qed. + +Lemma nandP : reflect (~~ b1 \/ ~~ b2) (~~ (b1 && b2)). +Proof. by case b1; case b2; constructor; auto; case; auto. Qed. + +Lemma norP : reflect (~~ b1 /\ ~~ b2) (~~ (b1 || b2)). +Proof. by case b1; case b2; constructor; auto; case; auto. Qed. + +Lemma implyP : reflect (b1 -> b2) (b1 ==> b2). +Proof. by case b1; case b2; constructor; auto. Qed. + +End ReflectConnectives. + +Implicit Arguments idP [b1]. +Implicit Arguments idPn [b1]. +Implicit Arguments negP [b1]. +Implicit Arguments negPn [b1]. +Implicit Arguments negPf [b1]. +Implicit Arguments andP [b1 b2]. +Implicit Arguments and3P [b1 b2 b3]. +Implicit Arguments and4P [b1 b2 b3 b4]. +Implicit Arguments and5P [b1 b2 b3 b4 b5]. +Implicit Arguments orP [b1 b2]. +Implicit Arguments or3P [b1 b2 b3]. +Implicit Arguments or4P [b1 b2 b3 b4]. +Implicit Arguments nandP [b1 b2]. +Implicit Arguments norP [b1 b2]. +Implicit Arguments implyP [b1 b2]. +Prenex Implicits idP idPn negP negPn negPf. +Prenex Implicits andP and3P and4P and5P orP or3P or4P nandP norP implyP. + +(* Shorter, more systematic names for the boolean connectives laws. *) + +Lemma andTb : left_id true andb. Proof. by []. Qed. +Lemma andFb : left_zero false andb. Proof. by []. Qed. +Lemma andbT : right_id true andb. Proof. by case. Qed. +Lemma andbF : right_zero false andb. Proof. by case. Qed. +Lemma andbb : idempotent andb. Proof. by case. Qed. +Lemma andbC : commutative andb. Proof. by do 2!case. Qed. +Lemma andbA : associative andb. Proof. by do 3!case. Qed. +Lemma andbCA : left_commutative andb. Proof. by do 3!case. Qed. +Lemma andbAC : right_commutative andb. Proof. by do 3!case. Qed. +Lemma andbACA : interchange andb andb. Proof. by do 4!case. Qed. + +Lemma orTb : forall b, true || b. Proof. by []. Qed. +Lemma orFb : left_id false orb. Proof. by []. Qed. +Lemma orbT : forall b, b || true. Proof. by case. Qed. +Lemma orbF : right_id false orb. Proof. by case. Qed. +Lemma orbb : idempotent orb. Proof. by case. Qed. +Lemma orbC : commutative orb. Proof. by do 2!case. Qed. +Lemma orbA : associative orb. Proof. by do 3!case. Qed. +Lemma orbCA : left_commutative orb. Proof. by do 3!case. Qed. +Lemma orbAC : right_commutative orb. Proof. by do 3!case. Qed. +Lemma orbACA : interchange orb orb. Proof. by do 4!case. Qed. + +Lemma andbN b : b && ~~ b = false. Proof. by case: b. Qed. +Lemma andNb b : ~~ b && b = false. Proof. by case: b. Qed. +Lemma orbN b : b || ~~ b = true. Proof. by case: b. Qed. +Lemma orNb b : ~~ b || b = true. Proof. by case: b. Qed. + +Lemma andb_orl : left_distributive andb orb. Proof. by do 3!case. Qed. +Lemma andb_orr : right_distributive andb orb. Proof. by do 3!case. Qed. +Lemma orb_andl : left_distributive orb andb. Proof. by do 3!case. Qed. +Lemma orb_andr : right_distributive orb andb. Proof. by do 3!case. Qed. + +Lemma andb_idl (a b : bool) : (b -> a) -> a && b = b. +Proof. by case: a; case: b => // ->. Qed. +Lemma andb_idr (a b : bool) : (a -> b) -> a && b = a. +Proof. by case: a; case: b => // ->. Qed. +Lemma andb_id2l (a b c : bool) : (a -> b = c) -> a && b = a && c. +Proof. by case: a; case: b; case: c => // ->. Qed. +Lemma andb_id2r (a b c : bool) : (b -> a = c) -> a && b = c && b. +Proof. by case: a; case: b; case: c => // ->. Qed. + +Lemma orb_idl (a b : bool) : (a -> b) -> a || b = b. +Proof. by case: a; case: b => // ->. Qed. +Lemma orb_idr (a b : bool) : (b -> a) -> a || b = a. +Proof. by case: a; case: b => // ->. Qed. +Lemma orb_id2l (a b c : bool) : (~~ a -> b = c) -> a || b = a || c. +Proof. by case: a; case: b; case: c => // ->. Qed. +Lemma orb_id2r (a b c : bool) : (~~ b -> a = c) -> a || b = c || b. +Proof. by case: a; case: b; case: c => // ->. Qed. + +Lemma negb_and (a b : bool) : ~~ (a && b) = ~~ a || ~~ b. +Proof. by case: a; case: b. Qed. + +Lemma negb_or (a b : bool) : ~~ (a || b) = ~~ a && ~~ b. +Proof. by case: a; case: b. Qed. + +(* Pseudo-cancellation -- i.e, absorbtion *) + +Lemma andbK a b : a && b || a = a. Proof. by case: a; case: b. Qed. +Lemma andKb a b : a || b && a = a. Proof. by case: a; case: b. Qed. +Lemma orbK a b : (a || b) && a = a. Proof. by case: a; case: b. Qed. +Lemma orKb a b : a && (b || a) = a. Proof. by case: a; case: b. Qed. + +(* Imply *) + +Lemma implybT b : b ==> true. Proof. by case: b. Qed. +Lemma implybF b : (b ==> false) = ~~ b. Proof. by case: b. Qed. +Lemma implyFb b : false ==> b. Proof. by []. Qed. +Lemma implyTb b : (true ==> b) = b. Proof. by []. Qed. +Lemma implybb b : b ==> b. Proof. by case: b. Qed. + +Lemma negb_imply a b : ~~ (a ==> b) = a && ~~ b. +Proof. by case: a; case: b. Qed. + +Lemma implybE a b : (a ==> b) = ~~ a || b. +Proof. by case: a; case: b. Qed. + +Lemma implyNb a b : (~~ a ==> b) = a || b. +Proof. by case: a; case: b. Qed. + +Lemma implybN a b : (a ==> ~~ b) = (b ==> ~~ a). +Proof. by case: a; case: b. Qed. + +Lemma implybNN a b : (~~ a ==> ~~ b) = b ==> a. +Proof. by case: a; case: b. Qed. + +Lemma implyb_idl (a b : bool) : (~~ a -> b) -> (a ==> b) = b. +Proof. by case: a; case: b => // ->. Qed. +Lemma implyb_idr (a b : bool) : (b -> ~~ a) -> (a ==> b) = ~~ a. +Proof. by case: a; case: b => // ->. Qed. +Lemma implyb_id2l (a b c : bool) : (a -> b = c) -> (a ==> b) = (a ==> c). +Proof. by case: a; case: b; case: c => // ->. Qed. + +(* Addition (xor) *) + +Lemma addFb : left_id false addb. Proof. by []. Qed. +Lemma addbF : right_id false addb. Proof. by case. Qed. +Lemma addbb : self_inverse false addb. Proof. by case. Qed. +Lemma addbC : commutative addb. Proof. by do 2!case. Qed. +Lemma addbA : associative addb. Proof. by do 3!case. Qed. +Lemma addbCA : left_commutative addb. Proof. by do 3!case. Qed. +Lemma addbAC : right_commutative addb. Proof. by do 3!case. Qed. +Lemma addbACA : interchange addb addb. Proof. by do 4!case. Qed. +Lemma andb_addl : left_distributive andb addb. Proof. by do 3!case. Qed. +Lemma andb_addr : right_distributive andb addb. Proof. by do 3!case. Qed. +Lemma addKb : left_loop id addb. Proof. by do 2!case. Qed. +Lemma addbK : right_loop id addb. Proof. by do 2!case. Qed. +Lemma addIb : left_injective addb. Proof. by do 3!case. Qed. +Lemma addbI : right_injective addb. Proof. by do 3!case. Qed. + +Lemma addTb b : true (+) b = ~~ b. Proof. by []. Qed. +Lemma addbT b : b (+) true = ~~ b. Proof. by case: b. Qed. + +Lemma addbN a b : a (+) ~~ b = ~~ (a (+) b). +Proof. by case: a; case: b. Qed. +Lemma addNb a b : ~~ a (+) b = ~~ (a (+) b). +Proof. by case: a; case: b. Qed. + +Lemma addbP a b : reflect (~~ a = b) (a (+) b). +Proof. by case: a; case: b; constructor. Qed. +Implicit Arguments addbP [a b]. + +(* Resolution tactic for blindly weeding out common terms from boolean *) +(* equalities. When faced with a goal of the form (andb/orb/addb b1 b2) = b3 *) +(* they will try to locate b1 in b3 and remove it. This can fail! *) + +Ltac bool_congr := + match goal with + | |- (?X1 && ?X2 = ?X3) => first + [ symmetry; rewrite -1?(andbC X1) -?(andbCA X1); congr 1 (andb X1); symmetry + | case: (X1); [ rewrite ?andTb ?andbT // | by rewrite ?andbF /= ] ] + | |- (?X1 || ?X2 = ?X3) => first + [ symmetry; rewrite -1?(orbC X1) -?(orbCA X1); congr 1 (orb X1); symmetry + | case: (X1); [ by rewrite ?orbT //= | rewrite ?orFb ?orbF ] ] + | |- (?X1 (+) ?X2 = ?X3) => + symmetry; rewrite -1?(addbC X1) -?(addbCA X1); congr 1 (addb X1); symmetry + | |- (~~ ?X1 = ?X2) => congr 1 negb + end. + +(******************************************************************************) +(* Predicates, i.e., packaged functions to bool. *) +(* - pred T, the basic type for predicates over a type T, is simply an alias *) +(* for T -> bool. *) +(* We actually distinguish two kinds of predicates, which we call applicative *) +(* and collective, based on the syntax used to test them at some x in T: *) +(* - For an applicative predicate P, one uses prefix syntax: *) +(* P x *) +(* Also, most operations on applicative predicates use prefix syntax as *) +(* well (e.g., predI P Q). *) +(* - For a collective predicate A, one uses infix syntax: *) +(* x \in A *) +(* and all operations on collective predicates use infix syntax as well *) +(* (e.g., [predI A & B]). *) +(* There are only two kinds of applicative predicates: *) +(* - pred T, the alias for T -> bool mentioned above *) +(* - simpl_pred T, an alias for simpl_fun T bool with a coercion to pred T *) +(* that auto-simplifies on application (see ssrfun). *) +(* On the other hand, the set of collective predicate types is open-ended via *) +(* - predType T, a Structure that can be used to put Canonical collective *) +(* predicate interpretation on other types, such as lists, tuples, *) +(* finite sets, etc. *) +(* Indeed, we define such interpretations for applicative predicate types, *) +(* which can therefore also be used with the infix syntax, e.g., *) +(* x \in predI P Q *) +(* Moreover these infix forms are convertible to their prefix counterpart *) +(* (e.g., predI P Q x which in turn simplifies to P x && Q x). The converse *) +(* is not true, however; collective predicate types cannot, in general, be *) +(* general, be used applicatively, because of the "uniform inheritance" *) +(* restriction on implicit coercions. *) +(* However, we do define an explicit generic coercion *) +(* - mem : forall (pT : predType), pT -> mem_pred T *) +(* where mem_pred T is a variant of simpl_pred T that preserves the infix *) +(* syntax, i.e., mem A x auto-simplifies to x \in A. *) +(* Indeed, the infix "collective" operators are notation for a prefix *) +(* operator with arguments of type mem_pred T or pred T, applied to coerced *) +(* collective predicates, e.g., *) +(* Notation "x \in A" := (in_mem x (mem A)). *) +(* This prevents the variability in the predicate type from interfering with *) +(* the application of generic lemmas. Moreover this also makes it much easier *) +(* to define generic lemmas, because the simplest type -- pred T -- can be *) +(* used as the type of generic collective predicates, provided one takes care *) +(* not to use it applicatively; this avoids the burden of having to declare a *) +(* different predicate type for each predicate parameter of each section or *) +(* lemma. *) +(* This trick is made possible by the fact that the constructor of the *) +(* mem_pred T type aligns the unification process, forcing a generic *) +(* "collective" predicate A : pred T to unify with the actual collective B, *) +(* which mem has coerced to pred T via an internal, hidden implicit coercion, *) +(* supplied by the predType structure for B. Users should take care not to *) +(* inadvertently "strip" (mem B) down to the coerced B, since this will *) +(* expose the internal coercion: Coq will display a term B x that cannot be *) +(* typed as such. The topredE lemma can be used to restore the x \in B *) +(* syntax in this case. While -topredE can conversely be used to change *) +(* x \in P into P x, it is safer to use the inE and memE lemmas instead, as *) +(* they do not run the risk of exposing internal coercions. As a consequence *) +(* it is better to explicitly cast a generic applicative pred T to simpl_pred *) +(* using the SimplPred constructor, when it is used as a collective predicate *) +(* (see, e.g., Lemma eq_big in bigop). *) +(* We also sometimes "instantiate" the predType structure by defining a *) +(* coercion to the sort of the predPredType structure. This works better for *) +(* types such as {set T} that have subtypes that coerce to them, since the *) +(* same coercion will be inserted by the application of mem. It also lets us *) +(* turn any Type aT : predArgType into the total predicate over that type, *) +(* i.e., fun _: aT => true. This allows us to write, e.g., #|'I_n| for the *) +(* cardinal of the (finite) type of integers less than n. *) +(* Collective predicates have a specific extensional equality, *) +(* - A =i B, *) +(* while applicative predicates use the extensional equality of functions, *) +(* - P =1 Q *) +(* The two forms are convertible, however. *) +(* We lift boolean operations to predicates, defining: *) +(* - predU (union), predI (intersection), predC (complement), *) +(* predD (difference), and preim (preimage, i.e., composition) *) +(* For each operation we define three forms, typically: *) +(* - predU : pred T -> pred T -> simpl_pred T *) +(* - [predU A & B], a Notation for predU (mem A) (mem B) *) +(* - xpredU, a Notation for the lambda-expression inside predU, *) +(* which is mostly useful as an argument of =1, since it exposes the head *) +(* head constant of the expression to the ssreflect matching algorithm. *) +(* The syntax for the preimage of a collective predicate A is *) +(* - [preim f of A] *) +(* Finally, the generic syntax for defining a simpl_pred T is *) +(* - [pred x : T | P(x)], [pred x | P(x)], [pred x in A | P(x)], etc. *) +(* We also support boolean relations, but only the applicative form, with *) +(* types *) +(* - rel T, an alias for T -> pred T *) +(* - simpl_rel T, an auto-simplifying version, and syntax *) +(* [rel x y | P(x,y)], [rel x y in A & B | P(x,y)], etc. *) +(* The notation [rel of fA] can be used to coerce a function returning a *) +(* collective predicate to one returning pred T. *) +(* Finally, note that there is specific support for ambivalent predicates *) +(* that can work in either style, as per this file's head descriptor. *) +(******************************************************************************) + +Definition pred T := T -> bool. + +Identity Coercion fun_of_pred : pred >-> Funclass. + +Definition rel T := T -> pred T. + +Identity Coercion fun_of_rel : rel >-> Funclass. + +Notation xpred0 := (fun _ => false). +Notation xpredT := (fun _ => true). +Notation xpredI := (fun (p1 p2 : pred _) x => p1 x && p2 x). +Notation xpredU := (fun (p1 p2 : pred _) x => p1 x || p2 x). +Notation xpredC := (fun (p : pred _) x => ~~ p x). +Notation xpredD := (fun (p1 p2 : pred _) x => ~~ p2 x && p1 x). +Notation xpreim := (fun f (p : pred _) x => p (f x)). +Notation xrelU := (fun (r1 r2 : rel _) x y => r1 x y || r2 x y). + +Section Predicates. + +Variables T : Type. + +Definition subpred (p1 p2 : pred T) := forall x, p1 x -> p2 x. + +Definition subrel (r1 r2 : rel T) := forall x y, r1 x y -> r2 x y. + +Definition simpl_pred := simpl_fun T bool. +Definition applicative_pred := pred T. +Definition collective_pred := pred T. + +Definition SimplPred (p : pred T) : simpl_pred := SimplFun p. + +Coercion pred_of_simpl (p : simpl_pred) : pred T := fun_of_simpl p. +Coercion applicative_pred_of_simpl (p : simpl_pred) : applicative_pred := + fun_of_simpl p. +Coercion collective_pred_of_simpl (p : simpl_pred) : collective_pred := + fun x => (let: SimplFun f := p in fun _ => f x) x. +(* Note: applicative_of_simpl is convertible to pred_of_simpl, while *) +(* collective_of_simpl is not. *) + +Definition pred0 := SimplPred xpred0. +Definition predT := SimplPred xpredT. +Definition predI p1 p2 := SimplPred (xpredI p1 p2). +Definition predU p1 p2 := SimplPred (xpredU p1 p2). +Definition predC p := SimplPred (xpredC p). +Definition predD p1 p2 := SimplPred (xpredD p1 p2). +Definition preim rT f (d : pred rT) := SimplPred (xpreim f d). + +Definition simpl_rel := simpl_fun T (pred T). + +Definition SimplRel (r : rel T) : simpl_rel := [fun x => r x]. + +Coercion rel_of_simpl_rel (r : simpl_rel) : rel T := fun x y => r x y. + +Definition relU r1 r2 := SimplRel (xrelU r1 r2). + +Lemma subrelUl r1 r2 : subrel r1 (relU r1 r2). +Proof. by move=> *; apply/orP; left. Qed. + +Lemma subrelUr r1 r2 : subrel r2 (relU r1 r2). +Proof. by move=> *; apply/orP; right. Qed. + +CoInductive mem_pred := Mem of pred T. + +Definition isMem pT topred mem := mem = (fun p : pT => Mem [eta topred p]). + +Structure predType := PredType { + pred_sort :> Type; + topred : pred_sort -> pred T; + _ : {mem | isMem topred mem} +}. + +Definition mkPredType pT toP := PredType (exist (@isMem pT toP) _ (erefl _)). + +Canonical predPredType := Eval hnf in @mkPredType (pred T) id. +Canonical simplPredType := Eval hnf in mkPredType pred_of_simpl. +Canonical boolfunPredType := Eval hnf in @mkPredType (T -> bool) id. + +Coercion pred_of_mem mp : pred_sort predPredType := let: Mem p := mp in [eta p]. +Canonical memPredType := Eval hnf in mkPredType pred_of_mem. + +Definition clone_pred U := + fun pT & pred_sort pT -> U => + fun a mP (pT' := @PredType U a mP) & phant_id pT' pT => pT'. + +End Predicates. + +Implicit Arguments pred0 [T]. +Implicit Arguments predT [T]. +Prenex Implicits pred0 predT predI predU predC predD preim relU. + +Notation "[ 'pred' : T | E ]" := (SimplPred (fun _ : T => E%B)) + (at level 0, format "[ 'pred' : T | E ]") : fun_scope. +Notation "[ 'pred' x | E ]" := (SimplPred (fun x => E%B)) + (at level 0, x ident, format "[ 'pred' x | E ]") : fun_scope. +Notation "[ 'pred' x | E1 & E2 ]" := [pred x | E1 && E2 ] + (at level 0, x ident, format "[ 'pred' x | E1 & E2 ]") : fun_scope. +Notation "[ 'pred' x : T | E ]" := (SimplPred (fun x : T => E%B)) + (at level 0, x ident, only parsing) : fun_scope. +Notation "[ 'pred' x : T | E1 & E2 ]" := [pred x : T | E1 && E2 ] + (at level 0, x ident, only parsing) : fun_scope. +Notation "[ 'rel' x y | E ]" := (SimplRel (fun x y => E%B)) + (at level 0, x ident, y ident, format "[ 'rel' x y | E ]") : fun_scope. +Notation "[ 'rel' x y : T | E ]" := (SimplRel (fun x y : T => E%B)) + (at level 0, x ident, y ident, only parsing) : fun_scope. + +Notation "[ 'predType' 'of' T ]" := (@clone_pred _ T _ id _ _ id) + (at level 0, format "[ 'predType' 'of' T ]") : form_scope. + +(* This redundant coercion lets us "inherit" the simpl_predType canonical *) +(* instance by declaring a coercion to simpl_pred. This hack is the only way *) +(* to put a predType structure on a predArgType. We use simpl_pred rather *) +(* than pred to ensure that /= removes the identity coercion. Note that the *) +(* coercion will never be used directly for simpl_pred, since the canonical *) +(* instance should always be resolved. *) + +Notation pred_class := (pred_sort (predPredType _)). +Coercion sort_of_simpl_pred T (p : simpl_pred T) : pred_class := p : pred T. + +(* This lets us use some types as a synonym for their universal predicate. *) +(* Unfortunately, this won't work for existing types like bool, unless we *) +(* redefine bool, true, false and all bool ops. *) +Definition predArgType := Type. +Bind Scope type_scope with predArgType. +Identity Coercion sort_of_predArgType : predArgType >-> Sortclass. +Coercion pred_of_argType (T : predArgType) : simpl_pred T := predT. + +Notation "{ : T }" := (T%type : predArgType) + (at level 0, format "{ : T }") : type_scope. + +(* These must be defined outside a Section because "cooking" kills the *) +(* nosimpl tag. *) + +Definition mem T (pT : predType T) : pT -> mem_pred T := + nosimpl (let: PredType _ _ (exist mem _) := pT return pT -> _ in mem). +Definition in_mem T x mp := nosimpl pred_of_mem T mp x. + +Prenex Implicits mem. + +Coercion pred_of_mem_pred T mp := [pred x : T | in_mem x mp]. + +Definition eq_mem T p1 p2 := forall x : T, in_mem x p1 = in_mem x p2. +Definition sub_mem T p1 p2 := forall x : T, in_mem x p1 -> in_mem x p2. + +Typeclasses Opaque eq_mem. + +Lemma sub_refl T (p : mem_pred T) : sub_mem p p. Proof. by []. Qed. +Implicit Arguments sub_refl [[T] [p]]. + +Notation "x \in A" := (in_mem x (mem A)) : bool_scope. +Notation "x \in A" := (in_mem x (mem A)) : bool_scope. +Notation "x \notin A" := (~~ (x \in A)) : bool_scope. +Notation "A =i B" := (eq_mem (mem A) (mem B)) : type_scope. +Notation "{ 'subset' A <= B }" := (sub_mem (mem A) (mem B)) + (at level 0, A, B at level 69, + format "{ '[hv' 'subset' A '/ ' <= B ']' }") : type_scope. +Notation "[ 'mem' A ]" := (pred_of_simpl (pred_of_mem_pred (mem A))) + (at level 0, only parsing) : fun_scope. +Notation "[ 'rel' 'of' fA ]" := (fun x => [mem (fA x)]) + (at level 0, format "[ 'rel' 'of' fA ]") : fun_scope. +Notation "[ 'predI' A & B ]" := (predI [mem A] [mem B]) + (at level 0, format "[ 'predI' A & B ]") : fun_scope. +Notation "[ 'predU' A & B ]" := (predU [mem A] [mem B]) + (at level 0, format "[ 'predU' A & B ]") : fun_scope. +Notation "[ 'predD' A & B ]" := (predD [mem A] [mem B]) + (at level 0, format "[ 'predD' A & B ]") : fun_scope. +Notation "[ 'predC' A ]" := (predC [mem A]) + (at level 0, format "[ 'predC' A ]") : fun_scope. +Notation "[ 'preim' f 'of' A ]" := (preim f [mem A]) + (at level 0, format "[ 'preim' f 'of' A ]") : fun_scope. + +Notation "[ 'pred' x 'in' A ]" := [pred x | x \in A] + (at level 0, x ident, format "[ 'pred' x 'in' A ]") : fun_scope. +Notation "[ 'pred' x 'in' A | E ]" := [pred x | x \in A & E] + (at level 0, x ident, format "[ 'pred' x 'in' A | E ]") : fun_scope. +Notation "[ 'pred' x 'in' A | E1 & E2 ]" := [pred x | x \in A & E1 && E2 ] + (at level 0, x ident, + format "[ 'pred' x 'in' A | E1 & E2 ]") : fun_scope. +Notation "[ 'rel' x y 'in' A & B | E ]" := + [rel x y | (x \in A) && (y \in B) && E] + (at level 0, x ident, y ident, + format "[ 'rel' x y 'in' A & B | E ]") : fun_scope. +Notation "[ 'rel' x y 'in' A & B ]" := [rel x y | (x \in A) && (y \in B)] + (at level 0, x ident, y ident, + format "[ 'rel' x y 'in' A & B ]") : fun_scope. +Notation "[ 'rel' x y 'in' A | E ]" := [rel x y in A & A | E] + (at level 0, x ident, y ident, + format "[ 'rel' x y 'in' A | E ]") : fun_scope. +Notation "[ 'rel' x y 'in' A ]" := [rel x y in A & A] + (at level 0, x ident, y ident, + format "[ 'rel' x y 'in' A ]") : fun_scope. + +Section simpl_mem. + +Variables (T : Type) (pT : predType T). +Implicit Types (x : T) (p : pred T) (sp : simpl_pred T) (pp : pT). + +(* Bespoke structures that provide fine-grained control over matching the *) +(* various forms of the \in predicate; note in particular the different forms *) +(* of hoisting that are used. We had to work around several bugs in the *) +(* implementation of unification, notably improper expansion of telescope *) +(* projections and overwriting of a variable assignment by a later *) +(* unification (probably due to conversion cache cross-talk). *) +Structure manifest_applicative_pred p := ManifestApplicativePred { + manifest_applicative_pred_value :> pred T; + _ : manifest_applicative_pred_value = p +}. +Definition ApplicativePred p := ManifestApplicativePred (erefl p). +Canonical applicative_pred_applicative sp := + ApplicativePred (applicative_pred_of_simpl sp). + +Structure manifest_simpl_pred p := ManifestSimplPred { + manifest_simpl_pred_value :> simpl_pred T; + _ : manifest_simpl_pred_value = SimplPred p +}. +Canonical expose_simpl_pred p := ManifestSimplPred (erefl (SimplPred p)). + +Structure manifest_mem_pred p := ManifestMemPred { + manifest_mem_pred_value :> mem_pred T; + _ : manifest_mem_pred_value= Mem [eta p] +}. +Canonical expose_mem_pred p := @ManifestMemPred p _ (erefl _). + +Structure applicative_mem_pred p := + ApplicativeMemPred {applicative_mem_pred_value :> manifest_mem_pred p}. +Canonical check_applicative_mem_pred p (ap : manifest_applicative_pred p) mp := + @ApplicativeMemPred ap mp. + +Lemma mem_topred (pp : pT) : mem (topred pp) = mem pp. +Proof. by rewrite /mem; case: pT pp => T1 app1 [mem1 /= ->]. Qed. + +Lemma topredE x (pp : pT) : topred pp x = (x \in pp). +Proof. by rewrite -mem_topred. Qed. + +Lemma app_predE x p (ap : manifest_applicative_pred p) : ap x = (x \in p). +Proof. by case: ap => _ /= ->. Qed. + +Lemma in_applicative x p (amp : applicative_mem_pred p) : in_mem x amp = p x. +Proof. by case: amp => [[_ /= ->]]. Qed. + +Lemma in_collective x p (msp : manifest_simpl_pred p) : + (x \in collective_pred_of_simpl msp) = p x. +Proof. by case: msp => _ /= ->. Qed. + +Lemma in_simpl x p (msp : manifest_simpl_pred p) : + in_mem x (Mem [eta fun_of_simpl (msp : simpl_pred T)]) = p x. +Proof. by case: msp => _ /= ->. Qed. + +(* Because of the explicit eta expansion in the left-hand side, this lemma *) +(* should only be used in a right-to-left direction. The 8.3 hack allowing *) +(* partial right-to-left use does not work with the improved expansion *) +(* heuristics in 8.4. *) +Lemma unfold_in x p : (x \in ([eta p] : pred T)) = p x. +Proof. by []. Qed. + +Lemma simpl_predE p : SimplPred p =1 p. +Proof. by []. Qed. + +Definition inE := (in_applicative, in_simpl, simpl_predE). (* to be extended *) + +Lemma mem_simpl sp : mem sp = sp :> pred T. +Proof. by []. Qed. + +Definition memE := mem_simpl. (* could be extended *) + +Lemma mem_mem (pp : pT) : (mem (mem pp) = mem pp) * (mem [mem pp] = mem pp). +Proof. by rewrite -mem_topred. Qed. + +End simpl_mem. + +(* Qualifiers and keyed predicates. *) + +CoInductive qualifier (q : nat) T := Qualifier of predPredType T. + +Coercion has_quality n T (q : qualifier n T) : pred_class := + fun x => let: Qualifier p := q in p x. +Implicit Arguments has_quality [T]. + +Lemma qualifE n T p x : (x \in @Qualifier n T p) = p x. Proof. by []. Qed. + +Notation "x \is A" := (x \in has_quality 0 A) + (at level 70, no associativity, + format "'[hv' x '/ ' \is A ']'") : bool_scope. +Notation "x \is 'a' A" := (x \in has_quality 1 A) + (at level 70, no associativity, + format "'[hv' x '/ ' \is 'a' A ']'") : bool_scope. +Notation "x \is 'an' A" := (x \in has_quality 2 A) + (at level 70, no associativity, + format "'[hv' x '/ ' \is 'an' A ']'") : bool_scope. +Notation "x \isn't A" := (x \notin has_quality 0 A) + (at level 70, no associativity, + format "'[hv' x '/ ' \isn't A ']'") : bool_scope. +Notation "x \isn't 'a' A" := (x \notin has_quality 1 A) + (at level 70, no associativity, + format "'[hv' x '/ ' \isn't 'a' A ']'") : bool_scope. +Notation "x \isn't 'an' A" := (x \notin has_quality 2 A) + (at level 70, no associativity, + format "'[hv' x '/ ' \isn't 'an' A ']'") : bool_scope. +Notation "[ 'qualify' x | P ]" := (Qualifier 0 (fun x => P%B)) + (at level 0, x at level 99, + format "'[hv' [ 'qualify' x | '/ ' P ] ']'") : form_scope. +Notation "[ 'qualify' x : T | P ]" := (Qualifier 0 (fun x : T => P%B)) + (at level 0, x at level 99, only parsing) : form_scope. +Notation "[ 'qualify' 'a' x | P ]" := (Qualifier 1 (fun x => P%B)) + (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'a' x | '/ ' P ] ']'") : form_scope. +Notation "[ 'qualify' 'a' x : T | P ]" := (Qualifier 1 (fun x : T => P%B)) + (at level 0, x at level 99, only parsing) : form_scope. +Notation "[ 'qualify' 'an' x | P ]" := (Qualifier 2 (fun x => P%B)) + (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'an' x | '/ ' P ] ']'") : form_scope. +Notation "[ 'qualify' 'an' x : T | P ]" := (Qualifier 2 (fun x : T => P%B)) + (at level 0, x at level 99, only parsing) : form_scope. + +(* Keyed predicates: support for property-bearing predicate interfaces. *) + +Section KeyPred. + +Variable T : Type. +CoInductive pred_key (p : predPredType T) := DefaultPredKey. + +Variable p : predPredType T. +Structure keyed_pred (k : pred_key p) := + PackKeyedPred {unkey_pred :> pred_class; _ : unkey_pred =i p}. + +Variable k : pred_key p. +Definition KeyedPred := @PackKeyedPred k p (frefl _). + +Variable k_p : keyed_pred k. +Lemma keyed_predE : k_p =i p. Proof. by case: k_p. Qed. + +(* Instances that strip the mem cast; the first one has "pred_of_mem" as its *) +(* projection head value, while the second has "pred_of_simpl". The latter *) +(* has the side benefit of preempting accidental misdeclarations. *) +(* Note: pred_of_mem is the registered mem >-> pred_class coercion, while *) +(* simpl_of_mem; pred_of_simpl is the mem >-> pred >=> Funclass coercion. We *) +(* must write down the coercions explicitly as the Canonical head constant *) +(* computation does not strip casts !! *) +Canonical keyed_mem := + @PackKeyedPred k (pred_of_mem (mem k_p)) keyed_predE. +Canonical keyed_mem_simpl := + @PackKeyedPred k (pred_of_simpl (mem k_p)) keyed_predE. + +End KeyPred. + +Notation "x \i 'n' S" := (x \in @unkey_pred _ S _ _) + (at level 70, format "'[hv' x '/ ' \i 'n' S ']'") : bool_scope. + +Section KeyedQualifier. + +Variables (T : Type) (n : nat) (q : qualifier n T). + +Structure keyed_qualifier (k : pred_key q) := + PackKeyedQualifier {unkey_qualifier; _ : unkey_qualifier = q}. +Definition KeyedQualifier k := PackKeyedQualifier k (erefl q). +Variables (k : pred_key q) (k_q : keyed_qualifier k). +Fact keyed_qualifier_suproof : unkey_qualifier k_q =i q. +Proof. by case: k_q => /= _ ->. Qed. +Canonical keyed_qualifier_keyed := PackKeyedPred k keyed_qualifier_suproof. + +End KeyedQualifier. + +Notation "x \i 's' A" := (x \i n has_quality 0 A) + (at level 70, format "'[hv' x '/ ' \i 's' A ']'") : bool_scope. +Notation "x \i 's' 'a' A" := (x \i n has_quality 1 A) + (at level 70, format "'[hv' x '/ ' \i 's' 'a' A ']'") : bool_scope. +Notation "x \i 's' 'an' A" := (x \i n has_quality 2 A) + (at level 70, format "'[hv' x '/ ' \i 's' 'an' A ']'") : bool_scope. + +Module DefaultKeying. + +Canonical default_keyed_pred T p := KeyedPred (@DefaultPredKey T p). +Canonical default_keyed_qualifier T n (q : qualifier n T) := + KeyedQualifier (DefaultPredKey q). + +End DefaultKeying. + +(* Skolemizing with conditions. *) + +Lemma all_tag_cond_dep I T (C : pred I) U : + (forall x, T x) -> (forall x, C x -> {y : T x & U x y}) -> + {f : forall x, T x & forall x, C x -> U x (f x)}. +Proof. +move=> f0 fP; apply: all_tag (fun x y => C x -> U x y) _ => x. +by case Cx: (C x); [case/fP: Cx => y; exists y | exists (f0 x)]. +Qed. + +Lemma all_tag_cond I T (C : pred I) U : + T -> (forall x, C x -> {y : T & U x y}) -> + {f : I -> T & forall x, C x -> U x (f x)}. +Proof. by move=> y0; apply: all_tag_cond_dep. Qed. + +Lemma all_sig_cond_dep I T (C : pred I) P : + (forall x, T x) -> (forall x, C x -> {y : T x | P x y}) -> + {f : forall x, T x | forall x, C x -> P x (f x)}. +Proof. by move=> f0 /(all_tag_cond_dep f0)[f]; exists f. Qed. + +Lemma all_sig_cond I T (C : pred I) P : + T -> (forall x, C x -> {y : T | P x y}) -> + {f : I -> T | forall x, C x -> P x (f x)}. +Proof. by move=> y0; apply: all_sig_cond_dep. Qed. + +Section RelationProperties. + +(* Caveat: reflexive should not be used to state lemmas, as auto and trivial *) +(* will not expand the constant. *) + +Variable T : Type. + +Variable R : rel T. + +Definition total := forall x y, R x y || R y x. +Definition transitive := forall y x z, R x y -> R y z -> R x z. + +Definition symmetric := forall x y, R x y = R y x. +Definition antisymmetric := forall x y, R x y && R y x -> x = y. +Definition pre_symmetric := forall x y, R x y -> R y x. + +Lemma symmetric_from_pre : pre_symmetric -> symmetric. +Proof. move=> symR x y; apply/idP/idP; exact: symR. Qed. + +Definition reflexive := forall x, R x x. +Definition irreflexive := forall x, R x x = false. + +Definition left_transitive := forall x y, R x y -> R x =1 R y. +Definition right_transitive := forall x y, R x y -> R^~ x =1 R^~ y. + +Section PER. + +Hypotheses (symR : symmetric) (trR : transitive). + +Lemma sym_left_transitive : left_transitive. +Proof. by move=> x y Rxy z; apply/idP/idP; apply: trR; rewrite // symR. Qed. + +Lemma sym_right_transitive : right_transitive. +Proof. by move=> x y /sym_left_transitive Rxy z; rewrite !(symR z) Rxy. Qed. + +End PER. + +(* We define the equivalence property with prenex quantification so that it *) +(* can be localized using the {in ..., ..} form defined below. *) + +Definition equivalence_rel := forall x y z, R z z * (R x y -> R x z = R y z). + +Lemma equivalence_relP : equivalence_rel <-> reflexive /\ left_transitive. +Proof. +split=> [eqiR | [Rxx trR] x y z]; last by split=> [|/trR->]. +by split=> [x | x y Rxy z]; [rewrite (eqiR x x x) | rewrite (eqiR x y z)]. +Qed. + +End RelationProperties. + +Lemma rev_trans T (R : rel T) : transitive R -> transitive (fun x y => R y x). +Proof. by move=> trR x y z Ryx Rzy; exact: trR Rzy Ryx. Qed. + +(* Property localization *) + +Notation Local "{ 'all1' P }" := (forall x, P x : Prop) (at level 0). +Notation Local "{ 'all2' P }" := (forall x y, P x y : Prop) (at level 0). +Notation Local "{ 'all3' P }" := (forall x y z, P x y z: Prop) (at level 0). +Notation Local ph := (phantom _). + +Section LocalProperties. + +Variables T1 T2 T3 : Type. + +Variables (d1 : mem_pred T1) (d2 : mem_pred T2) (d3 : mem_pred T3). +Notation Local ph := (phantom Prop). + +Definition prop_for (x : T1) P & ph {all1 P} := P x. + +Lemma forE x P phP : @prop_for x P phP = P x. Proof. by []. Qed. + +Definition prop_in1 P & ph {all1 P} := + forall x, in_mem x d1 -> P x. + +Definition prop_in11 P & ph {all2 P} := + forall x y, in_mem x d1 -> in_mem y d2 -> P x y. + +Definition prop_in2 P & ph {all2 P} := + forall x y, in_mem x d1 -> in_mem y d1 -> P x y. + +Definition prop_in111 P & ph {all3 P} := + forall x y z, in_mem x d1 -> in_mem y d2 -> in_mem z d3 -> P x y z. + +Definition prop_in12 P & ph {all3 P} := + forall x y z, in_mem x d1 -> in_mem y d2 -> in_mem z d2 -> P x y z. + +Definition prop_in21 P & ph {all3 P} := + forall x y z, in_mem x d1 -> in_mem y d1 -> in_mem z d2 -> P x y z. + +Definition prop_in3 P & ph {all3 P} := + forall x y z, in_mem x d1 -> in_mem y d1 -> in_mem z d1 -> P x y z. + +Variable f : T1 -> T2. + +Definition prop_on1 Pf P & phantom T3 (Pf f) & ph {all1 P} := + forall x, in_mem (f x) d2 -> P x. + +Definition prop_on2 Pf P & phantom T3 (Pf f) & ph {all2 P} := + forall x y, in_mem (f x) d2 -> in_mem (f y) d2 -> P x y. + +End LocalProperties. + +Definition inPhantom := Phantom Prop. +Definition onPhantom T P (x : T) := Phantom Prop (P x). + +Definition bijective_in aT rT (d : mem_pred aT) (f : aT -> rT) := + exists2 g, prop_in1 d (inPhantom (cancel f g)) + & prop_on1 d (Phantom _ (cancel g)) (onPhantom (cancel g) f). + +Definition bijective_on aT rT (cd : mem_pred rT) (f : aT -> rT) := + exists2 g, prop_on1 cd (Phantom _ (cancel f)) (onPhantom (cancel f) g) + & prop_in1 cd (inPhantom (cancel g f)). + +Notation "{ 'for' x , P }" := + (prop_for x (inPhantom P)) + (at level 0, format "{ 'for' x , P }") : type_scope. + +Notation "{ 'in' d , P }" := + (prop_in1 (mem d) (inPhantom P)) + (at level 0, format "{ 'in' d , P }") : type_scope. + +Notation "{ 'in' d1 & d2 , P }" := + (prop_in11 (mem d1) (mem d2) (inPhantom P)) + (at level 0, format "{ 'in' d1 & d2 , P }") : type_scope. + +Notation "{ 'in' d & , P }" := + (prop_in2 (mem d) (inPhantom P)) + (at level 0, format "{ 'in' d & , P }") : type_scope. + +Notation "{ 'in' d1 & d2 & d3 , P }" := + (prop_in111 (mem d1) (mem d2) (mem d3) (inPhantom P)) + (at level 0, format "{ 'in' d1 & d2 & d3 , P }") : type_scope. + +Notation "{ 'in' d1 & & d3 , P }" := + (prop_in21 (mem d1) (mem d3) (inPhantom P)) + (at level 0, format "{ 'in' d1 & & d3 , P }") : type_scope. + +Notation "{ 'in' d1 & d2 & , P }" := + (prop_in12 (mem d1) (mem d2) (inPhantom P)) + (at level 0, format "{ 'in' d1 & d2 & , P }") : type_scope. + +Notation "{ 'in' d & & , P }" := + (prop_in3 (mem d) (inPhantom P)) + (at level 0, format "{ 'in' d & & , P }") : type_scope. + +Notation "{ 'on' cd , P }" := + (prop_on1 (mem cd) (inPhantom P) (inPhantom P)) + (at level 0, format "{ 'on' cd , P }") : type_scope. + +Notation "{ 'on' cd & , P }" := + (prop_on2 (mem cd) (inPhantom P) (inPhantom P)) + (at level 0, format "{ 'on' cd & , P }") : type_scope. + +Notation "{ 'on' cd , P & g }" := + (prop_on1 (mem cd) (Phantom (_ -> Prop) P) (onPhantom P g)) + (at level 0, format "{ 'on' cd , P & g }") : type_scope. + +Notation "{ 'in' d , 'bijective' f }" := (bijective_in (mem d) f) + (at level 0, f at level 8, + format "{ 'in' d , 'bijective' f }") : type_scope. + +Notation "{ 'on' cd , 'bijective' f }" := (bijective_on (mem cd) f) + (at level 0, f at level 8, + format "{ 'on' cd , 'bijective' f }") : type_scope. + +(* Weakening and monotonicity lemmas for localized predicates. *) +(* Note that using these lemmas in backward reasoning will force expansion of *) +(* the predicate definition, as Coq needs to expose the quantifier to apply *) +(* these lemmas. We define a few specialized variants to avoid this for some *) +(* of the ssrfun predicates. *) + +Section LocalGlobal. + +Variables T1 T2 T3 : predArgType. +Variables (D1 : pred T1) (D2 : pred T2) (D3 : pred T3). +Variables (d1 d1' : mem_pred T1) (d2 d2' : mem_pred T2) (d3 d3' : mem_pred T3). +Variables (f f' : T1 -> T2) (g : T2 -> T1) (h : T3). +Variables (P1 : T1 -> Prop) (P2 : T1 -> T2 -> Prop). +Variable P3 : T1 -> T2 -> T3 -> Prop. +Variable Q1 : (T1 -> T2) -> T1 -> Prop. +Variable Q1l : (T1 -> T2) -> T3 -> T1 -> Prop. +Variable Q2 : (T1 -> T2) -> T1 -> T1 -> Prop. + +Hypothesis sub1 : sub_mem d1 d1'. +Hypothesis sub2 : sub_mem d2 d2'. +Hypothesis sub3 : sub_mem d3 d3'. + +Lemma in1W : {all1 P1} -> {in D1, {all1 P1}}. +Proof. by move=> ? ?. Qed. +Lemma in2W : {all2 P2} -> {in D1 & D2, {all2 P2}}. +Proof. by move=> ? ?. Qed. +Lemma in3W : {all3 P3} -> {in D1 & D2 & D3, {all3 P3}}. +Proof. by move=> ? ?. Qed. + +Lemma in1T : {in T1, {all1 P1}} -> {all1 P1}. +Proof. by move=> ? ?; auto. Qed. +Lemma in2T : {in T1 & T2, {all2 P2}} -> {all2 P2}. +Proof. by move=> ? ?; auto. Qed. +Lemma in3T : {in T1 & T2 & T3, {all3 P3}} -> {all3 P3}. +Proof. by move=> ? ?; auto. Qed. + +Lemma sub_in1 (Ph : ph {all1 P1}) : prop_in1 d1' Ph -> prop_in1 d1 Ph. +Proof. move=> allP x /sub1; exact: allP. Qed. + +Lemma sub_in11 (Ph : ph {all2 P2}) : prop_in11 d1' d2' Ph -> prop_in11 d1 d2 Ph. +Proof. move=> allP x1 x2 /sub1 d1x1 /sub2; exact: allP. Qed. + +Lemma sub_in111 (Ph : ph {all3 P3}) : + prop_in111 d1' d2' d3' Ph -> prop_in111 d1 d2 d3 Ph. +Proof. by move=> allP x1 x2 x3 /sub1 d1x1 /sub2 d2x2 /sub3; exact: allP. Qed. + +Let allQ1 f'' := {all1 Q1 f''}. +Let allQ1l f'' h' := {all1 Q1l f'' h'}. +Let allQ2 f'' := {all2 Q2 f''}. + +Lemma on1W : allQ1 f -> {on D2, allQ1 f}. Proof. by move=> ? ?. Qed. + +Lemma on1lW : allQ1l f h -> {on D2, allQ1l f & h}. Proof. by move=> ? ?. Qed. + +Lemma on2W : allQ2 f -> {on D2 &, allQ2 f}. Proof. by move=> ? ?. Qed. + +Lemma on1T : {on T2, allQ1 f} -> allQ1 f. Proof. by move=> ? ?; auto. Qed. + +Lemma on1lT : {on T2, allQ1l f & h} -> allQ1l f h. +Proof. by move=> ? ?; auto. Qed. + +Lemma on2T : {on T2 &, allQ2 f} -> allQ2 f. +Proof. by move=> ? ?; auto. Qed. + +Lemma subon1 (Phf : ph (allQ1 f)) (Ph : ph (allQ1 f)) : + prop_on1 d2' Phf Ph -> prop_on1 d2 Phf Ph. +Proof. by move=> allQ x /sub2; exact: allQ. Qed. + +Lemma subon1l (Phf : ph (allQ1l f)) (Ph : ph (allQ1l f h)) : + prop_on1 d2' Phf Ph -> prop_on1 d2 Phf Ph. +Proof. by move=> allQ x /sub2; exact: allQ. Qed. + +Lemma subon2 (Phf : ph (allQ2 f)) (Ph : ph (allQ2 f)) : + prop_on2 d2' Phf Ph -> prop_on2 d2 Phf Ph. +Proof. by move=> allQ x y /sub2=> d2fx /sub2; exact: allQ. Qed. + +Lemma can_in_inj : {in D1, cancel f g} -> {in D1 &, injective f}. +Proof. by move=> fK x y /fK{2}<- /fK{2}<- ->. Qed. + +Lemma canLR_in x y : {in D1, cancel f g} -> y \in D1 -> x = f y -> g x = y. +Proof. by move=> fK D1y ->; rewrite fK. Qed. + +Lemma canRL_in x y : {in D1, cancel f g} -> x \in D1 -> f x = y -> x = g y. +Proof. by move=> fK D1x <-; rewrite fK. Qed. + +Lemma on_can_inj : {on D2, cancel f & g} -> {on D2 &, injective f}. +Proof. by move=> fK x y /fK{2}<- /fK{2}<- ->. Qed. + +Lemma canLR_on x y : {on D2, cancel f & g} -> f y \in D2 -> x = f y -> g x = y. +Proof. by move=> fK D2fy ->; rewrite fK. Qed. + +Lemma canRL_on x y : {on D2, cancel f & g} -> f x \in D2 -> f x = y -> x = g y. +Proof. by move=> fK D2fx <-; rewrite fK. Qed. + +Lemma inW_bij : bijective f -> {in D1, bijective f}. +Proof. by case=> g' fK g'K; exists g' => * ? *; auto. Qed. + +Lemma onW_bij : bijective f -> {on D2, bijective f}. +Proof. by case=> g' fK g'K; exists g' => * ? *; auto. Qed. + +Lemma inT_bij : {in T1, bijective f} -> bijective f. +Proof. by case=> g' fK g'K; exists g' => * ? *; auto. Qed. + +Lemma onT_bij : {on T2, bijective f} -> bijective f. +Proof. by case=> g' fK g'K; exists g' => * ? *; auto. Qed. + +Lemma sub_in_bij (D1' : pred T1) : + {subset D1 <= D1'} -> {in D1', bijective f} -> {in D1, bijective f}. +Proof. +by move=> subD [g' fK g'K]; exists g' => x; move/subD; [exact: fK | exact: g'K]. +Qed. + +Lemma subon_bij (D2' : pred T2) : + {subset D2 <= D2'} -> {on D2', bijective f} -> {on D2, bijective f}. +Proof. +by move=> subD [g' fK g'K]; exists g' => x; move/subD; [exact: fK | exact: g'K]. +Qed. + +End LocalGlobal. + +Lemma sub_in2 T d d' (P : T -> T -> Prop) : + sub_mem d d' -> forall Ph : ph {all2 P}, prop_in2 d' Ph -> prop_in2 d Ph. +Proof. by move=> /= sub_dd'; exact: sub_in11. Qed. + +Lemma sub_in3 T d d' (P : T -> T -> T -> Prop) : + sub_mem d d' -> forall Ph : ph {all3 P}, prop_in3 d' Ph -> prop_in3 d Ph. +Proof. by move=> /= sub_dd'; exact: sub_in111. Qed. + +Lemma sub_in12 T1 T d1 d1' d d' (P : T1 -> T -> T -> Prop) : + sub_mem d1 d1' -> sub_mem d d' -> + forall Ph : ph {all3 P}, prop_in12 d1' d' Ph -> prop_in12 d1 d Ph. +Proof. by move=> /= sub1 sub; exact: sub_in111. Qed. + +Lemma sub_in21 T T3 d d' d3 d3' (P : T -> T -> T3 -> Prop) : + sub_mem d d' -> sub_mem d3 d3' -> + forall Ph : ph {all3 P}, prop_in21 d' d3' Ph -> prop_in21 d d3 Ph. +Proof. by move=> /= sub sub3; exact: sub_in111. Qed. + +Lemma equivalence_relP_in T (R : rel T) (A : pred T) : + {in A & &, equivalence_rel R} + <-> {in A, reflexive R} /\ {in A &, forall x y, R x y -> {in A, R x =1 R y}}. +Proof. +split=> [eqiR | [Rxx trR] x y z *]; last by split=> [|/trR-> //]; exact: Rxx. +by split=> [x Ax|x y Ax Ay Rxy z Az]; [rewrite (eqiR x x) | rewrite (eqiR x y)]. +Qed. + +Section MonoHomoMorphismTheory. + +Variables (aT rT sT : Type) (f : aT -> rT) (g : rT -> aT). +Variables (aP : pred aT) (rP : pred rT) (aR : rel aT) (rR : rel rT). + +Lemma monoW : {mono f : x / aP x >-> rP x} -> {homo f : x / aP x >-> rP x}. +Proof. by move=> hf x ax; rewrite hf. Qed. + +Lemma mono2W : + {mono f : x y / aR x y >-> rR x y} -> {homo f : x y / aR x y >-> rR x y}. +Proof. by move=> hf x y axy; rewrite hf. Qed. + +Hypothesis fgK : cancel g f. + +Lemma homoRL : + {homo f : x y / aR x y >-> rR x y} -> forall x y, aR (g x) y -> rR x (f y). +Proof. by move=> Hf x y /Hf; rewrite fgK. Qed. + +Lemma homoLR : + {homo f : x y / aR x y >-> rR x y} -> forall x y, aR x (g y) -> rR (f x) y. +Proof. by move=> Hf x y /Hf; rewrite fgK. Qed. + +Lemma homo_mono : + {homo f : x y / aR x y >-> rR x y} -> {homo g : x y / rR x y >-> aR x y} -> + {mono g : x y / rR x y >-> aR x y}. +Proof. +move=> mf mg x y; case: (boolP (rR _ _))=> [/mg //|]. +by apply: contraNF=> /mf; rewrite !fgK. +Qed. + +Lemma monoLR : + {mono f : x y / aR x y >-> rR x y} -> forall x y, rR (f x) y = aR x (g y). +Proof. by move=> mf x y; rewrite -{1}[y]fgK mf. Qed. + +Lemma monoRL : + {mono f : x y / aR x y >-> rR x y} -> forall x y, rR x (f y) = aR (g x) y. +Proof. by move=> mf x y; rewrite -{1}[x]fgK mf. Qed. + +Lemma can_mono : + {mono f : x y / aR x y >-> rR x y} -> {mono g : x y / rR x y >-> aR x y}. +Proof. by move=> mf x y /=; rewrite -mf !fgK. Qed. + +End MonoHomoMorphismTheory. + +Section MonoHomoMorphismTheory_in. + +Variables (aT rT sT : predArgType) (f : aT -> rT) (g : rT -> aT). +Variable (aD : pred aT). +Variable (aP : pred aT) (rP : pred rT) (aR : rel aT) (rR : rel rT). + +Notation rD := [pred x | g x \in aD]. + +Lemma monoW_in : + {in aD &, {mono f : x y / aR x y >-> rR x y}} -> + {in aD &, {homo f : x y / aR x y >-> rR x y}}. +Proof. by move=> hf x y hx hy axy; rewrite hf. Qed. + +Lemma mono2W_in : + {in aD, {mono f : x / aP x >-> rP x}} -> + {in aD, {homo f : x / aP x >-> rP x}}. +Proof. by move=> hf x hx ax; rewrite hf. Qed. + +Hypothesis fgK_on : {on aD, cancel g & f}. + +Lemma homoRL_in : + {in aD &, {homo f : x y / aR x y >-> rR x y}} -> + {in rD & aD, forall x y, aR (g x) y -> rR x (f y)}. +Proof. by move=> Hf x y hx hy /Hf; rewrite fgK_on //; apply. Qed. + +Lemma homoLR_in : + {in aD &, {homo f : x y / aR x y >-> rR x y}} -> + {in aD & rD, forall x y, aR x (g y) -> rR (f x) y}. +Proof. by move=> Hf x y hx hy /Hf; rewrite fgK_on //; apply. Qed. + +Lemma homo_mono_in : + {in aD &, {homo f : x y / aR x y >-> rR x y}} -> + {in rD &, {homo g : x y / rR x y >-> aR x y}} -> + {in rD &, {mono g : x y / rR x y >-> aR x y}}. +Proof. +move=> mf mg x y hx hy; case: (boolP (rR _ _))=> [/mg //|]; first exact. +by apply: contraNF=> /mf; rewrite !fgK_on //; apply. +Qed. + +Lemma monoLR_in : + {in aD &, {mono f : x y / aR x y >-> rR x y}} -> + {in aD & rD, forall x y, rR (f x) y = aR x (g y)}. +Proof. by move=> mf x y hx hy; rewrite -{1}[y]fgK_on // mf. Qed. + +Lemma monoRL_in : + {in aD &, {mono f : x y / aR x y >-> rR x y}} -> + {in rD & aD, forall x y, rR x (f y) = aR (g x) y}. +Proof. by move=> mf x y hx hy; rewrite -{1}[x]fgK_on // mf. Qed. + +Lemma can_mono_in : + {in aD &, {mono f : x y / aR x y >-> rR x y}} -> + {in rD &, {mono g : x y / rR x y >-> aR x y}}. +Proof. by move=> mf x y hx hy /=; rewrite -mf // !fgK_on. Qed. + +End MonoHomoMorphismTheory_in. diff --git a/mathcomp/ssreflect/ssreflect.v b/mathcomp/ssreflect/ssreflect.v new file mode 100644 index 0000000..815a0fb --- /dev/null +++ b/mathcomp/ssreflect/ssreflect.v @@ -0,0 +1,420 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import Bool. (* For bool_scope delimiter 'bool'. *) +Require Import ssrmatching. +Declare ML Module "ssreflect". +Set SsrAstVersion. + +(******************************************************************************) +(* This file is the Gallina part of the ssreflect plugin implementation. *) +(* Files that use the ssreflect plugin should always Require ssreflect and *) +(* either Import ssreflect or Import ssreflect.SsrSyntax. *) +(* Part of the contents of this file is technical and will only interest *) +(* advanced developers; in addition the following are defined: *) +(* [the str of v by f] == the Canonical s : str such that f s = v. *) +(* [the str of v] == the Canonical s : str that coerces to v. *) +(* argumentType c == the T such that c : forall x : T, P x. *) +(* returnType c == the R such that c : T -> R. *) +(* {type of c for s} == P s where c : forall x : T, P x. *) +(* phantom T v == singleton type with inhabitant Phantom T v. *) +(* phant T == singleton type with inhabitant Phant v. *) +(* =^~ r == the converse of rewriting rule r (e.g., in a *) +(* rewrite multirule). *) +(* unkeyed t == t, but treated as an unkeyed matching pattern by *) +(* the ssreflect matching algorithm. *) +(* nosimpl t == t, but on the right-hand side of Definition C := *) +(* nosimpl disables expansion of C by /=. *) +(* locked t == t, but locked t is not convertible to t. *) +(* locked_with k t == t, but not convertible to t or locked_with k' t *) +(* unless k = k' (with k : unit). Coq type-checking *) +(* will be much more efficient if locked_with with a *) +(* bespoke k is used for sealed definitions. *) +(* unlockable v == interface for sealed constant definitions of v. *) +(* Unlockable def == the unlockable that registers def : C = v. *) +(* [unlockable of C] == a clone for C of the canonical unlockable for the *) +(* definition of C (e.g., if it uses locked_with). *) +(* [unlockable fun C] == [unlockable of C] with the expansion forced to be *) +(* an explicit lambda expression. *) +(* -> The usage pattern for ADT operations is: *) +(* Definition foo_def x1 .. xn := big_foo_expression. *) +(* Fact foo_key : unit. Proof. by []. Qed. *) +(* Definition foo := locked_with foo_key foo_def. *) +(* Canonical foo_unlockable := [unlockable fun foo]. *) +(* This minimizes the comparison overhead for foo, while still allowing *) +(* rewrite unlock to expose big_foo_expression. *) +(* More information about these definitions and their use can be found in the *) +(* ssreflect manual, and in specific comments below. *) +(******************************************************************************) + +Global Set Asymmetric Patterns. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Module SsrSyntax. + +(* Declare Ssr keywords: 'is' 'of' '//' '/=' and '//='. We also declare the *) +(* parsing level 8, as a workaround for a notation grammar factoring problem. *) +(* Arguments of application-style notations (at level 10) should be declared *) +(* at level 8 rather than 9 or the camlp5 grammar will not factor properly. *) + +Reserved Notation "(* x 'is' y 'of' z 'isn't' // /= //= *)" (at level 8). +Reserved Notation "(* 69 *)" (at level 69). + +(* Non ambiguous keyword to check if the SsrSyntax module is imported *) +Reserved Notation "(* Use to test if 'SsrSyntax_is_Imported' *)" (at level 8). + +Reserved Notation "" (at level 200). +Reserved Notation "T (* n *)" (at level 200, format "T (* n *)"). + +End SsrSyntax. + +Export SsrMatchingSyntax. +Export SsrSyntax. + +(* Make the general "if" into a notation, so that we can override it below. *) +(* The notations are "only parsing" because the Coq decompiler will not *) +(* recognize the expansion of the boolean if; using the default printer *) +(* avoids a spurrious trailing %GEN_IF. *) + +Delimit Scope general_if_scope with GEN_IF. + +Notation "'if' c 'then' v1 'else' v2" := + (if c then v1 else v2) + (at level 200, c, v1, v2 at level 200, only parsing) : general_if_scope. + +Notation "'if' c 'return' t 'then' v1 'else' v2" := + (if c return t then v1 else v2) + (at level 200, c, t, v1, v2 at level 200, only parsing) : general_if_scope. + +Notation "'if' c 'as' x 'return' t 'then' v1 'else' v2" := + (if c as x return t then v1 else v2) + (at level 200, c, t, v1, v2 at level 200, x ident, only parsing) + : general_if_scope. + +(* Force boolean interpretation of simple if expressions. *) + +Delimit Scope boolean_if_scope with BOOL_IF. + +Notation "'if' c 'return' t 'then' v1 'else' v2" := + (if c%bool is true in bool return t then v1 else v2) : boolean_if_scope. + +Notation "'if' c 'then' v1 'else' v2" := + (if c%bool is true in bool return _ then v1 else v2) : boolean_if_scope. + +Notation "'if' c 'as' x 'return' t 'then' v1 'else' v2" := + (if c%bool is true as x in bool return t then v1 else v2) : boolean_if_scope. + +Open Scope boolean_if_scope. + +(* To allow a wider variety of notations without reserving a large number of *) +(* of identifiers, the ssreflect library systematically uses "forms" to *) +(* enclose complex mixfix syntax. A "form" is simply a mixfix expression *) +(* enclosed in square brackets and introduced by a keyword: *) +(* [keyword ... ] *) +(* Because the keyword follows a bracket it does not need to be reserved. *) +(* Non-ssreflect libraries that do not respect the form syntax (e.g., the Coq *) +(* Lists library) should be loaded before ssreflect so that their notations *) +(* do not mask all ssreflect forms. *) +Delimit Scope form_scope with FORM. +Open Scope form_scope. + +(* Allow overloading of the cast (x : T) syntax, put whitespace around the *) +(* ":" symbol to avoid lexical clashes (and for consistency with the parsing *) +(* precedence of the notation, which binds less tightly than application), *) +(* and put printing boxes that print the type of a long definition on a *) +(* separate line rather than force-fit it at the right margin. *) +Notation "x : T" := (x : T) + (at level 100, right associativity, + format "'[hv' x '/ ' : T ']'") : core_scope. + +(* Allow the casual use of notations like nat * nat for explicit Type *) +(* declarations. Note that (nat * nat : Type) is NOT equivalent to *) +(* (nat * nat)%type, whose inferred type is legacy type "Set". *) +Notation "T : 'Type'" := (T%type : Type) + (at level 100, only parsing) : core_scope. +(* Allow similarly Prop annotation for, e.g., rewrite multirules. *) +Notation "P : 'Prop'" := (P%type : Prop) + (at level 100, only parsing) : core_scope. + +(* Constants for abstract: and [: name ] intro pattern *) +Definition abstract_lock := unit. +Definition abstract_key := tt. + +Definition abstract (statement : Type) (id : nat) (lock : abstract_lock) := + let: tt := lock in statement. + +Notation "" := (abstract _ n _). +Notation "T (* n *)" := (abstract T n abstract_key). + +(* Syntax for referring to canonical structures: *) +(* [the struct_type of proj_val by proj_fun] *) +(* This form denotes the Canonical instance s of the Structure type *) +(* struct_type whose proj_fun projection is proj_val, i.e., such that *) +(* proj_fun s = proj_val. *) +(* Typically proj_fun will be A record field accessors of struct_type, but *) +(* this need not be the case; it can be, for instance, a field of a record *) +(* type to which struct_type coerces; proj_val will likewise be coerced to *) +(* the return type of proj_fun. In all but the simplest cases, proj_fun *) +(* should be eta-expanded to allow for the insertion of implicit arguments. *) +(* In the common case where proj_fun itself is a coercion, the "by" part *) +(* can be omitted entirely; in this case it is inferred by casting s to the *) +(* inferred type of proj_val. Obviously the latter can be fixed by using an *) +(* explicit cast on proj_val, and it is highly recommended to do so when the *) +(* return type intended for proj_fun is "Type", as the type inferred for *) +(* proj_val may vary because of sort polymorphism (it could be Set or Prop). *) +(* Note when using the [the _ of _] form to generate a substructure from a *) +(* telescopes-style canonical hierarchy (implementing inheritance with *) +(* coercions), one should always project or coerce the value to the BASE *) +(* structure, because Coq will only find a Canonical derived structure for *) +(* the Canonical base structure -- not for a base structure that is specific *) +(* to proj_value. *) + +Module TheCanonical. + +CoInductive put vT sT (v1 v2 : vT) (s : sT) := Put. + +Definition get vT sT v s (p : @put vT sT v v s) := let: Put := p in s. + +Definition get_by vT sT of sT -> vT := @get vT sT. + +End TheCanonical. + +Import TheCanonical. (* Note: no export. *) + +Notation "[ 'the' sT 'of' v 'by' f ]" := + (@get_by _ sT f _ _ ((fun v' (s : sT) => Put v' (f s) s) v _)) + (at level 0, only parsing) : form_scope. + +Notation "[ 'the' sT 'of' v ]" := (get ((fun s : sT => Put v (*coerce*)s s) _)) + (at level 0, only parsing) : form_scope. + +(* The following are "format only" versions of the above notations. Since Coq *) +(* doesn't provide this facility, we fake it by splitting the "the" keyword. *) +(* We need to do this to prevent the formatter from being be thrown off by *) +(* application collapsing, coercion insertion and beta reduction in the right *) +(* hand side of the notations above. *) + +Notation "[ 'th' 'e' sT 'of' v 'by' f ]" := (@get_by _ sT f v _ _) + (at level 0, format "[ 'th' 'e' sT 'of' v 'by' f ]") : form_scope. + +Notation "[ 'th' 'e' sT 'of' v ]" := (@get _ sT v _ _) + (at level 0, format "[ 'th' 'e' sT 'of' v ]") : form_scope. + +(* We would like to recognize +Notation "[ 'th' 'e' sT 'of' v : 'Type' ]" := (@get Type sT v _ _) + (at level 0, format "[ 'th' 'e' sT 'of' v : 'Type' ]") : form_scope. +*) + +(* Helper notation for canonical structure inheritance support. *) +(* This is a workaround for the poor interaction between delta reduction and *) +(* canonical projections in Coq's unification algorithm, by which transparent *) +(* definitions hide canonical instances, i.e., in *) +(* Canonical a_type_struct := @Struct a_type ... *) +(* Definition my_type := a_type. *) +(* my_type doesn't effectively inherit the struct structure from a_type. Our *) +(* solution is to redeclare the instance as follows *) +(* Canonical my_type_struct := Eval hnf in [struct of my_type]. *) +(* The special notation [str of _] must be defined for each Strucure "str" *) +(* with constructor "Str", typically as follows *) +(* Definition clone_str s := *) +(* let: Str _ x y ... z := s return {type of Str for s} -> str in *) +(* fun k => k _ x y ... z. *) +(* Notation "[ 'str' 'of' T 'for' s ]" := (@clone_str s (@Str T)) *) +(* (at level 0, format "[ 'str' 'of' T 'for' s ]") : form_scope. *) +(* Notation "[ 'str' 'of' T ]" := (repack_str (fun x => @Str T x)) *) +(* (at level 0, format "[ 'str' 'of' T ]") : form_scope. *) +(* The notation for the match return predicate is defined below; the eta *) +(* expansion in the second form serves both to distinguish it from the first *) +(* and to avoid the delta reduction problem. *) +(* There are several variations on the notation and the definition of the *) +(* the "clone" function, for telescopes, mixin classes, and join (multiple *) +(* inheritance) classes. We describe a different idiom for clones in ssrfun; *) +(* it uses phantom types (see below) and static unification; see fintype and *) +(* ssralg for examples. *) + +Definition argumentType T P & forall x : T, P x := T. +Definition dependentReturnType T P & forall x : T, P x := P. +Definition returnType aT rT & aT -> rT := rT. + +Notation "{ 'type' 'of' c 'for' s }" := (dependentReturnType c s) + (at level 0, format "{ 'type' 'of' c 'for' s }") : type_scope. + +(* A generic "phantom" type (actually, a unit type with a phantom parameter). *) +(* This type can be used for type definitions that require some Structure *) +(* on one of their parameters, to allow Coq to infer said structure so it *) +(* does not have to be supplied explicitly or via the "[the _ of _]" notation *) +(* (the latter interacts poorly with other Notation). *) +(* The definition of a (co)inductive type with a parameter p : p_type, that *) +(* needs to use the operations of a structure *) +(* Structure p_str : Type := p_Str {p_repr :> p_type; p_op : p_repr -> ...} *) +(* should be given as *) +(* Inductive indt_type (p : p_str) := Indt ... . *) +(* Definition indt_of (p : p_str) & phantom p_type p := indt_type p. *) +(* Notation "{ 'indt' p }" := (indt_of (Phantom p)). *) +(* Definition indt p x y ... z : {indt p} := @Indt p x y ... z. *) +(* Notation "[ 'indt' x y ... z ]" := (indt x y ... z). *) +(* That is, the concrete type and its constructor should be shadowed by *) +(* definitions that use a phantom argument to infer and display the true *) +(* value of p (in practice, the "indt" constructor often performs additional *) +(* functions, like "locking" the representation -- see below). *) +(* We also define a simpler version ("phant" / "Phant") of phantom for the *) +(* common case where p_type is Type. *) + +CoInductive phantom T (p : T) := Phantom. +Implicit Arguments phantom []. +Implicit Arguments Phantom []. +CoInductive phant (p : Type) := Phant. + +(* Internal tagging used by the implementation of the ssreflect elim. *) + +Definition protect_term (A : Type) (x : A) : A := x. + +(* The ssreflect idiom for a non-keyed pattern: *) +(* - unkeyed t wiil match any subterm that unifies with t, regardless of *) +(* whether it displays the same head symbol as t. *) +(* - unkeyed t a b will match any application of a term f unifying with t, *) +(* to two arguments unifying with with a and b, repectively, regardless of *) +(* apparent head symbols. *) +(* - unkeyed x where x is a variable will match any subterm with the same *) +(* type as x (when x would raise the 'indeterminate pattern' error). *) + +Notation unkeyed x := (let flex := x in flex). + +(* Ssreflect converse rewrite rule rule idiom. *) +Definition ssr_converse R (r : R) := (Logic.I, r). +Notation "=^~ r" := (ssr_converse r) (at level 100) : form_scope. + +(* Term tagging (user-level). *) +(* The ssreflect library uses four strengths of term tagging to restrict *) +(* convertibility during type checking: *) +(* nosimpl t simplifies to t EXCEPT in a definition; more precisely, given *) +(* Definition foo := nosimpl bar, foo (or foo t') will NOT be expanded by *) +(* the /= and //= switches unless it is in a forcing context (e.g., in *) +(* match foo t' with ... end, foo t' will be reduced if this allows the *) +(* match to be reduced). Note that nosimpl bar is simply notation for a *) +(* a term that beta-iota reduces to bar; hence rewrite /foo will replace *) +(* foo by bar, and rewrite -/foo will replace bar by foo. *) +(* CAVEAT: nosimpl should not be used inside a Section, because the end of *) +(* section "cooking" removes the iota redex. *) +(* locked t is provably equal to t, but is not convertible to t; 'locked' *) +(* provides support for selective rewriting, via the lock t : t = locked t *) +(* Lemma, and the ssreflect unlock tactic. *) +(* locked_with k t is equal but not convertible to t, much like locked t, *) +(* but supports explicit tagging with a value k : unit. This is used to *) +(* mitigate a flaw in the term comparison heuristic of the Coq kernel, *) +(* which treats all terms of the form locked t as equal and conpares their *) +(* arguments recursively, leading to an exponential blowup of comparison. *) +(* For this reason locked_with should be used rather than locked when *) +(* defining ADT operations. The unlock tactic does not support locked_with *) +(* but the unlock rewrite rule does, via the unlockable interface. *) +(* we also use Module Type ascription to create truly opaque constants, *) +(* because simple expansion of constants to reveal an unreducible term *) +(* doubles the time complexity of a negative comparison. Such opaque *) +(* constants can be expanded generically with the unlock rewrite rule. *) +(* See the definition of card and subset in fintype for examples of this. *) + +Notation nosimpl t := (let: tt := tt in t). + +Lemma master_key : unit. Proof. exact tt. Qed. +Definition locked A := let: tt := master_key in fun x : A => x. + +Lemma lock A x : x = locked x :> A. Proof. unlock; reflexivity. Qed. + +(* Needed for locked predicates, in particular for eqType's. *) +Lemma not_locked_false_eq_true : locked false <> true. +Proof. unlock; discriminate. Qed. + +(* The basic closing tactic "done". *) +Ltac done := + trivial; hnf; intros; solve + [ do ![solve [trivial | apply: sym_equal; trivial] + | discriminate | contradiction | split] + | case not_locked_false_eq_true; assumption + | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. + +(* To unlock opaque constants. *) +Structure unlockable T v := Unlockable {unlocked : T; _ : unlocked = v}. +Lemma unlock T x C : @unlocked T x C = x. Proof. by case: C. Qed. + +Notation "[ 'unlockable' 'of' C ]" := (@Unlockable _ _ C (unlock _)) + (at level 0, format "[ 'unlockable' 'of' C ]") : form_scope. + +Notation "[ 'unlockable' 'fun' C ]" := (@Unlockable _ (fun _ => _) C (unlock _)) + (at level 0, format "[ 'unlockable' 'fun' C ]") : form_scope. + +(* Generic keyed constant locking. *) + +(* The argument order ensures that k is always compared before T. *) +Definition locked_with k := let: tt := k in fun T x => x : T. + +(* This can be used as a cheap alternative to cloning the unlockable instance *) +(* below, but with caution as unkeyed matching can be expensive. *) +Lemma locked_withE T k x : unkeyed (locked_with k x) = x :> T. +Proof. by case: k. Qed. + +(* Intensionaly, this instance will not apply to locked u. *) +Canonical locked_with_unlockable T k x := + @Unlockable T x (locked_with k x) (locked_withE k x). + +(* More accurate variant of unlock, and safer alternative to locked_withE. *) +Lemma unlock_with T k x : unlocked (locked_with_unlockable k x) = x :> T. +Proof. exact: unlock. Qed. + +(* The internal lemmas for the have tactics. *) + +Definition ssr_have Plemma Pgoal (step : Plemma) rest : Pgoal := rest step. +Implicit Arguments ssr_have [Pgoal]. + +Definition ssr_have_let Pgoal Plemma step + (rest : let x : Plemma := step in Pgoal) : Pgoal := rest. +Implicit Arguments ssr_have_let [Pgoal]. + +Definition ssr_suff Plemma Pgoal step (rest : Plemma) : Pgoal := step rest. +Implicit Arguments ssr_suff [Pgoal]. + +Definition ssr_wlog := ssr_suff. +Implicit Arguments ssr_wlog [Pgoal]. + +(* Internal N-ary congruence lemmas for the congr tactic. *) + +Fixpoint nary_congruence_statement (n : nat) + : (forall B, (B -> B -> Prop) -> Prop) -> Prop := + match n with + | O => fun k => forall B, k B (fun x1 x2 : B => x1 = x2) + | S n' => + let k' A B e (f1 f2 : A -> B) := + forall x1 x2, x1 = x2 -> (e (f1 x1) (f2 x2) : Prop) in + fun k => forall A, nary_congruence_statement n' (fun B e => k _ (k' A B e)) + end. + +Lemma nary_congruence n (k := fun B e => forall y : B, (e y y : Prop)) : + nary_congruence_statement n k. +Proof. +have: k _ _ := _; rewrite {1}/k. +elim: n k => [|n IHn] k k_P /= A; first exact: k_P. +by apply: IHn => B e He; apply: k_P => f x1 x2 <-. +Qed. + +Lemma ssr_congr_arrow Plemma Pgoal : Plemma = Pgoal -> Plemma -> Pgoal. +Proof. by move->. Qed. +Implicit Arguments ssr_congr_arrow []. + +(* View lemmas that don't use reflection. *) + +Section ApplyIff. + +Variables P Q : Prop. +Hypothesis eqPQ : P <-> Q. + +Lemma iffLR : P -> Q. Proof. by case: eqPQ. Qed. +Lemma iffRL : Q -> P. Proof. by case: eqPQ. Qed. + +Lemma iffLRn : ~P -> ~Q. Proof. by move=> nP tQ; case: nP; case: eqPQ tQ. Qed. +Lemma iffRLn : ~Q -> ~P. Proof. by move=> nQ tP; case: nQ; case: eqPQ tP. Qed. + +End ApplyIff. + +Hint View for move/ iffLRn|2 iffRLn|2 iffLR|2 iffRL|2. +Hint View for apply/ iffRLn|2 iffLRn|2 iffRL|2 iffLR|2. + diff --git a/mathcomp/ssreflect/ssrfun.v b/mathcomp/ssreflect/ssrfun.v new file mode 100644 index 0000000..f83724e --- /dev/null +++ b/mathcomp/ssreflect/ssrfun.v @@ -0,0 +1,885 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect. + +(******************************************************************************) +(* This file contains the basic definitions and notations for working with *) +(* functions. The definitions provide for: *) +(* *) +(* - Pair projections: *) +(* p.1 == first element of a pair *) +(* p.2 == second element of a pair *) +(* These notations also apply to p : P /\ Q, via an and >-> pair coercion. *) +(* *) +(* - Simplifying functions, beta-reduced by /= and simpl: *) +(* [fun : T => E] == constant function from type T that returns E *) +(* [fun x => E] == unary function *) +(* [fun x : T => E] == unary function with explicit domain type *) +(* [fun x y => E] == binary function *) +(* [fun x y : T => E] == binary function with common domain type *) +(* [fun (x : T) y => E] \ *) +(* [fun (x : xT) (y : yT) => E] | == binary function with (some) explicit, *) +(* [fun x (y : T) => E] / independent domain types for each argument *) +(* *) +(* - Partial functions using option type: *) +(* oapp f d ox == if ox is Some x returns f x, d otherwise *) +(* odflt d ox == if ox is Some x returns x, d otherwise *) +(* obind f ox == if ox is Some x returns f x, None otherwise *) +(* omap f ox == if ox is Some x returns Some (f x), None otherwise *) +(* *) +(* - Singleton types: *) +(* all_equal_to x0 == x0 is the only value in its type, so any such value *) +(* can be rewritten to x0. *) +(* *) +(* - A generic wrapper type: *) +(* wrapped T == the inductive type with values Wrap x for x : T. *) +(* unwrap w == the projection of w : wrapped T on T. *) +(* wrap x == the canonical injection of x : T into wrapped T; it is *) +(* equivalent to Wrap x, but is declared as a (default) *) +(* Canonical Structure, which lets the Coq HO unification *) +(* automatically expand x into unwrap (wrap x). The delta *) +(* reduction of wrap x to Wrap can be exploited to *) +(* introduce controlled nondeterminism in Canonical *) +(* Structure inference, as in the implementation of *) +(* the mxdirect predicate in matrix.v. *) +(* *) +(* - Sigma types: *) +(* tag w == the i of w : {i : I & T i}. *) +(* tagged w == the T i component of w : {i : I & T i}. *) +(* Tagged T x == the {i : I & T i} with component x : T i. *) +(* tag2 w == the i of w : {i : I & T i & U i}. *) +(* tagged2 w == the T i component of w : {i : I & T i & U i}. *) +(* tagged2' w == the U i component of w : {i : I & T i & U i}. *) +(* Tagged2 T U x y == the {i : I & T i} with components x : T i and y : U i. *) +(* sval u == the x of u : {x : T | P x}. *) +(* s2val u == the x of u : {x : T | P x & Q x}. *) +(* The properties of sval u, s2val u are given by lemmas svalP, s2valP, and *) +(* s2valP'. We provide coercions sigT2 >-> sigT and sig2 >-> sig >-> sigT. *) +(* A suite of lemmas (all_sig, ...) let us skolemize sig, sig2, sigT, sigT2 *) +(* and pair, e.g., *) +(* have /all_sig[f fP] (x : T): {y : U | P y} by ... *) +(* yields an f : T -> U such that fP : forall x, P (f x). *) +(* - Identity functions: *) +(* id == NOTATION for the explicit identity function fun x => x. *) +(* @id T == notation for the explicit identity at type T. *) +(* idfun == an expression with a head constant, convertible to id; *) +(* idfun x simplifies to x. *) +(* @idfun T == the expression above, specialized to type T. *) +(* phant_id x y == the function type phantom _ x -> phantom _ y. *) +(* *** In addition to their casual use in functional programming, identity *) +(* functions are often used to trigger static unification as part of the *) +(* construction of dependent Records and Structures. For example, if we need *) +(* a structure sT over a type T, we take as arguments T, sT, and a "dummy" *) +(* function T -> sort sT: *) +(* Definition foo T sT & T -> sort sT := ... *) +(* We can avoid specifying sT directly by calling foo (@id T), or specify *) +(* the call completely while still ensuring the consistency of T and sT, by *) +(* calling @foo T sT idfun. The phant_id type allows us to extend this trick *) +(* to non-Type canonical projections. It also allows us to sidestep *) +(* dependent type constraints when building explicit records, e.g., given *) +(* Record r := R {x; y : T(x)}. *) +(* if we need to build an r from a given y0 while inferring some x0, such *) +(* that y0 : T(x0), we pose *) +(* Definition mk_r .. y .. (x := ...) y' & phant_id y y' := R x y'. *) +(* Calling @mk_r .. y0 .. id will cause Coq to use y' := y0, while checking *) +(* the dependent type constraint y0 : T(x0). *) +(* *) +(* - Extensional equality for functions and relations (i.e. functions of two *) +(* arguments): *) +(* f1 =1 f2 == f1 x is equal to f2 x for all x. *) +(* f1 =1 f2 :> A == ... and f2 is explicitly typed. *) +(* f1 =2 f2 == f1 x y is equal to f2 x y for all x y. *) +(* f1 =2 f2 :> A == ... and f2 is explicitly typed. *) +(* *) +(* - Composition for total and partial functions: *) +(* f^~ y == function f with second argument specialised to y, *) +(* i.e., fun x => f x y *) +(* CAVEAT: conditional (non-maximal) implicit arguments *) +(* of f are NOT inserted in this context *) +(* @^~ x == application at x, i.e., fun f => f x *) +(* [eta f] == the explicit eta-expansion of f, i.e., fun x => f x *) +(* CAVEAT: conditional (non-maximal) implicit arguments *) +(* of f are NOT inserted in this context. *) +(* fun=> v := the constant function fun _ => v. *) +(* f1 \o f2 == composition of f1 and f2. *) +(* Note: (f1 \o f2) x simplifies to f1 (f2 x). *) +(* f1 \; f2 == categorical composition of f1 and f2. This expands to *) +(* to f2 \o f1 and (f1 \; f2) x simplifies to f2 (f1 x). *) +(* pcomp f1 f2 == composition of partial functions f1 and f2. *) +(* *) +(* - Reserved notation for various arithmetic and algebraic operations: *) +(* e.[a1, ..., a_n] evaluation (e.g., polynomials). *) +(* e`_i indexing (number list, integer pi-part). *) +(* x^-1 inverse (group, field). *) +(* x *+ n, x *- n integer multiplier (modules and rings). *) +(* x ^+ n, x ^- n integer exponent (groups and rings). *) +(* x *: A, A :* x external product (scaling/module product in rings, *) +(* left/right cosets in groups). *) +(* A :&: B intersection (of sets, groups, subspaces, ...). *) +(* A :|: B, a |: B union, union with a singleton (of sets). *) +(* A :\: B, A :\ b relative complement (of sets, subspaces, ...). *) +(* <>, <[a]> generated group/subspace, generated cycle/line. *) +(* 'C[x], 'C_A[x] point centralisers (in groups and F-algebras). *) +(* 'C(A), 'C_B(A) centralisers (in groups and matrix and F_algebras). *) +(* 'Z(A) centers (in groups and matrix and F-algebras). *) +(* m %/ d, m %% d Euclidean division and remainder (nat, polynomials). *) +(* d %| m Euclidean divisibility (nat, polynomial). *) +(* m = n %[mod d] equality mod d (also defined for <>, ==, and !=). *) +(* e^`(n) nth formal derivative (groups, polynomials). *) +(* e^`() simple formal derivative (polynomials only). *) +(* `|x| norm, absolute value, distance (rings, int, nat). *) +(* x <= y ?= iff C x is less than y, and equal iff C holds (nat, rings). *) +(* x <= y :> T, etc cast comparison (rings, all comparison operators). *) +(* [rec a1, ..., an] standard shorthand for hidden recursor (see prime.v). *) +(* The interpretation of these notations is not defined here, but the *) +(* declarations help maintain consistency across the library. *) +(* *) +(* - Properties of functions: *) +(* injective f <-> f is injective. *) +(* cancel f g <-> g is a left inverse of f / f is a right inverse of g. *) +(* pcancel f g <-> g is a left inverse of f where g is partial. *) +(* ocancel f g <-> g is a left inverse of f where f is partial. *) +(* bijective f <-> f is bijective (has a left and right inverse). *) +(* involutive f <-> f is involutive. *) +(* *) +(* - Properties for operations. *) +(* left_id e op <-> e is a left identity for op (e op x = x). *) +(* right_id e op <-> e is a right identity for op (x op e = x). *) +(* left_inverse e inv op <-> inv is a left inverse for op wrt identity e, *) +(* i.e., (inv x) op x = e. *) +(* right_inverse e inv op <-> inv is a right inverse for op wrt identity e *) +(* i.e., x op (i x) = e. *) +(* self_inverse e op <-> each x is its own op-inverse (x op x = e). *) +(* idempotent op <-> op is idempotent for op (x op x = x). *) +(* associative op <-> op is associative, i.e., *) +(* x op (y op z) = (x op y) op z. *) +(* commutative op <-> op is commutative (x op y = y op x). *) +(* left_commutative op <-> op is left commutative, i.e., *) +(* x op (y op z) = y op (x op z). *) +(* right_commutative op <-> op is right commutative, i.e., *) +(* (x op y) op z = (x op z) op y. *) +(* left_zero z op <-> z is a left zero for op (z op x = z). *) +(* right_zero z op <-> z is a right zero for op (x op z = z). *) +(* left_distributive op1 op2 <-> op1 distributes over op2 to the left: *) +(* (x op2 y) op1 z = (x op1 z) op2 (y op1 z). *) +(* right_distributive op1 op2 <-> op distributes over add to the right: *) +(* x op1 (y op2 z) = (x op1 z) op2 (x op1 z). *) +(* interchange op1 op2 <-> op1 and op2 satisfy an interchange law: *) +(* (x op2 y) op1 (z op2 t) = (x op1 z) op2 (y op1 t). *) +(* Note that interchange op op is a commutativity property. *) +(* left_injective op <-> op is injective in its left argument: *) +(* x op y = z op y -> x = z. *) +(* right_injective op <-> op is injective in its right argument: *) +(* x op y = x op z -> y = z. *) +(* left_loop inv op <-> op, inv obey the inverse loop left axiom: *) +(* (inv x) op (x op y) = y for all x, y, i.e., *) +(* op (inv x) is always a left inverse of op x *) +(* rev_left_loop inv op <-> op, inv obey the inverse loop reverse left *) +(* axiom: x op ((inv x) op y) = y, for all x, y. *) +(* right_loop inv op <-> op, inv obey the inverse loop right axiom: *) +(* (x op y) op (inv y) = x for all x, y. *) +(* rev_right_loop inv op <-> op, inv obey the inverse loop reverse right *) +(* axiom: (x op y) op (inv y) = x for all x, y. *) +(* Note that familiar "cancellation" identities like x + y - y = x or *) +(* x - y + x = x are respectively instances of right_loop and rev_right_loop *) +(* The corresponding lemmas will use the K and NK/VK suffixes, respectively. *) +(* *) +(* - Morphisms for functions and relations: *) +(* {morph f : x / a >-> r} <-> f is a morphism with respect to functions *) +(* (fun x => a) and (fun x => r); if r == R[x], *) +(* this states that f a = R[f x] for all x. *) +(* {morph f : x / a} <-> f is a morphism with respect to the *) +(* function expression (fun x => a). This is *) +(* shorthand for {morph f : x / a >-> a}; note *) +(* that the two instances of a are often *) +(* interpreted at different types. *) +(* {morph f : x y / a >-> r} <-> f is a morphism with respect to functions *) +(* (fun x y => a) and (fun x y => r). *) +(* {morph f : x y / a} <-> f is a morphism with respect to the *) +(* function expression (fun x y => a). *) +(* {homo f : x / a >-> r} <-> f is a homomorphism with respect to the *) +(* predicates (fun x => a) and (fun x => r); *) +(* if r == R[x], this states that a -> R[f x] *) +(* for all x. *) +(* {homo f : x / a} <-> f is a homomorphism with respect to the *) +(* predicate expression (fun x => a). *) +(* {homo f : x y / a >-> r} <-> f is a homomorphism with respect to the *) +(* relations (fun x y => a) and (fun x y => r). *) +(* {homo f : x y / a} <-> f is a homomorphism with respect to the *) +(* relation expression (fun x y => a). *) +(* {mono f : x / a >-> r} <-> f is monotone with respect to projectors *) +(* (fun x => a) and (fun x => r); if r == R[x], *) +(* this states that R[f x] = a for all x. *) +(* {mono f : x / a} <-> f is monotone with respect to the projector *) +(* expression (fun x => a). *) +(* {mono f : x y / a >-> r} <-> f is monotone with respect to relators *) +(* (fun x y => a) and (fun x y => r). *) +(* {mono f : x y / a} <-> f is monotone with respect to the relator *) +(* expression (fun x y => a). *) +(* *) +(* The file also contains some basic lemmas for the above concepts. *) +(* Lemmas relative to cancellation laws use some abbreviated suffixes: *) +(* K - a cancellation rule like esymK : cancel (@esym T x y) (@esym T y x). *) +(* LR - a lemma moving an operation from the left hand side of a relation to *) +(* the right hand side, like canLR: cancel g f -> x = g y -> f x = y. *) +(* RL - a lemma moving an operation from the right to the left, e.g., canRL. *) +(* Beware that the LR and RL orientations refer to an "apply" (back chaining) *) +(* usage; when using the same lemmas with "have" or "move" (forward chaining) *) +(* the directions will be reversed!. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Delimit Scope fun_scope with FUN. +Open Scope fun_scope. + +(* Notations for argument transpose *) +Notation "f ^~ y" := (fun x => f x y) + (at level 10, y at level 8, no associativity, format "f ^~ y") : fun_scope. +Notation "@^~ x" := (fun f => f x) + (at level 10, x at level 8, no associativity, format "@^~ x") : fun_scope. + +Delimit Scope pair_scope with PAIR. +Open Scope pair_scope. + +(* Notations for pair/conjunction projections *) +Notation "p .1" := (fst p) + (at level 2, left associativity, format "p .1") : pair_scope. +Notation "p .2" := (snd p) + (at level 2, left associativity, format "p .2") : pair_scope. + +Coercion pair_of_and P Q (PandQ : P /\ Q) := (proj1 PandQ, proj2 PandQ). + +Definition all_pair I T U (w : forall i : I, T i * U i) := + (fun i => (w i).1, fun i => (w i).2). + +(* Reserved notation for evaluation *) +Reserved Notation "e .[ x ]" + (at level 2, left associativity, format "e .[ x ]"). + +Reserved Notation "e .[ x1 , x2 , .. , xn ]" (at level 2, left associativity, + format "e '[ ' .[ x1 , '/' x2 , '/' .. , '/' xn ] ']'"). + +(* Reserved notation for subscripting and superscripting *) +Reserved Notation "s `_ i" (at level 3, i at level 2, left associativity, + format "s `_ i"). +Reserved Notation "x ^-1" (at level 3, left associativity, format "x ^-1"). + +(* Reserved notation for integer multipliers and exponents *) +Reserved Notation "x *+ n" (at level 40, left associativity). +Reserved Notation "x *- n" (at level 40, left associativity). +Reserved Notation "x ^+ n" (at level 29, left associativity). +Reserved Notation "x ^- n" (at level 29, left associativity). + +(* Reserved notation for external multiplication. *) +Reserved Notation "x *: A" (at level 40). +Reserved Notation "A :* x" (at level 40). + +(* Reserved notation for set-theretic operations. *) +Reserved Notation "A :&: B" (at level 48, left associativity). +Reserved Notation "A :|: B" (at level 52, left associativity). +Reserved Notation "a |: A" (at level 52, left associativity). +Reserved Notation "A :\: B" (at level 50, left associativity). +Reserved Notation "A :\ b" (at level 50, left associativity). + +(* Reserved notation for generated structures *) +Reserved Notation "<< A >>" (at level 0, format "<< A >>"). +Reserved Notation "<[ a ] >" (at level 0, format "<[ a ] >"). + +(* Reserved notation for centralisers and centers. *) +Reserved Notation "''C' [ x ]" (at level 8, format "''C' [ x ]"). +Reserved Notation "''C_' A [ x ]" + (at level 8, A at level 2, format "''C_' A [ x ]"). +Reserved Notation "''C' ( A )" (at level 8, format "''C' ( A )"). +Reserved Notation "''C_' B ( A )" + (at level 8, B at level 2, format "''C_' B ( A )"). +Reserved Notation "''Z' ( A )" (at level 8, format "''Z' ( A )"). +(* Compatibility with group action centraliser notation. *) +Reserved Notation "''C_' ( A ) [ x ]" (at level 8, only parsing). +Reserved Notation "''C_' ( B ) ( A )" (at level 8, only parsing). + +(* Reserved notation for Euclidean division and divisibility. *) +Reserved Notation "m %/ d" (at level 40, no associativity). +Reserved Notation "m %% d" (at level 40, no associativity). +Reserved Notation "m %| d" (at level 70, no associativity). +Reserved Notation "m = n %[mod d ]" (at level 70, n at next level, + format "'[hv ' m '/' = n '/' %[mod d ] ']'"). +Reserved Notation "m == n %[mod d ]" (at level 70, n at next level, + format "'[hv ' m '/' == n '/' %[mod d ] ']'"). +Reserved Notation "m <> n %[mod d ]" (at level 70, n at next level, + format "'[hv ' m '/' <> n '/' %[mod d ] ']'"). +Reserved Notation "m != n %[mod d ]" (at level 70, n at next level, + format "'[hv ' m '/' != n '/' %[mod d ] ']'"). + +(* Reserved notation for derivatives. *) +Reserved Notation "a ^` ()" (at level 8, format "a ^` ()"). +Reserved Notation "a ^` ( n )" (at level 8, format "a ^` ( n )"). + +(* Reserved notation for absolute value. *) +Reserved Notation "`| x |" (at level 0, x at level 99, format "`| x |"). + +(* Reserved notation for conditional comparison *) +Reserved Notation "x <= y ?= 'iff' c" (at level 70, y, c at next level, + format "x '[hv' <= y '/' ?= 'iff' c ']'"). + +(* Reserved notation for cast comparison. *) +Reserved Notation "x <= y :> T" (at level 70, y at next level). +Reserved Notation "x >= y :> T" (at level 70, y at next level, only parsing). +Reserved Notation "x < y :> T" (at level 70, y at next level). +Reserved Notation "x > y :> T" (at level 70, y at next level, only parsing). +Reserved Notation "x <= y ?= 'iff' c :> T" (at level 70, y, c at next level, + format "x '[hv' <= y '/' ?= 'iff' c :> T ']'"). + +(* Complements on the option type constructor, used below to *) +(* encode partial functions. *) + +Module Option. + +Definition apply aT rT (f : aT -> rT) x u := if u is Some y then f y else x. + +Definition default T := apply (fun x : T => x). + +Definition bind aT rT (f : aT -> option rT) := apply f None. + +Definition map aT rT (f : aT -> rT) := bind (fun x => Some (f x)). + +End Option. + +Notation oapp := Option.apply. +Notation odflt := Option.default. +Notation obind := Option.bind. +Notation omap := Option.map. +Notation some := (@Some _) (only parsing). + +(* Shorthand for some basic equality lemmas. *) + +Notation erefl := refl_equal. +Notation ecast i T e x := (let: erefl in _ = i := e return T in x). +Definition esym := sym_eq. +Definition nesym := sym_not_eq. +Definition etrans := trans_eq. +Definition congr1 := f_equal. +Definition congr2 := f_equal2. +(* Force at least one implicit when used as a view. *) +Prenex Implicits esym nesym. + +(* A predicate for singleton types. *) +Definition all_equal_to T (x0 : T) := forall x, unkeyed x = x0. + +Lemma unitE : all_equal_to tt. Proof. by case. Qed. + +(* A generic wrapper type *) + +Structure wrapped T := Wrap {unwrap : T}. +Canonical wrap T x := @Wrap T x. + +Prenex Implicits unwrap wrap Wrap. + +(* Syntax for defining auxiliary recursive function. *) +(* Usage: *) +(* Section FooDefinition. *) +(* Variables (g1 : T1) (g2 : T2). (globals) *) +(* Fixoint foo_auxiliary (a3 : T3) ... := *) +(* body, using [rec e3, ...] for recursive calls *) +(* where "[ 'rec' a3 , a4 , ... ]" := foo_auxiliary. *) +(* Definition foo x y .. := [rec e1, ...]. *) +(* + proofs about foo *) +(* End FooDefinition. *) + +Reserved Notation "[ 'rec' a0 ]" + (at level 0, format "[ 'rec' a0 ]"). +Reserved Notation "[ 'rec' a0 , a1 ]" + (at level 0, format "[ 'rec' a0 , a1 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 ]" + (at level 0, format "[ 'rec' a0 , a1 , a2 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 ]" + (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 ]" + (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 ]" + (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 ]" + (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 ]" + (at level 0, + format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 ]" + (at level 0, + format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9 ]" + (at level 0, + format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9 ]"). + +(* Definitions and notation for explicit functions with simplification, *) +(* i.e., which simpl and /= beta expand (this is complementary to nosimpl). *) + +Section SimplFun. + +Variables aT rT : Type. + +CoInductive simpl_fun := SimplFun of aT -> rT. + +Definition fun_of_simpl f := fun x => let: SimplFun lam := f in lam x. + +Coercion fun_of_simpl : simpl_fun >-> Funclass. + +End SimplFun. + +Notation "[ 'fun' : T => E ]" := (SimplFun (fun _ : T => E)) + (at level 0, + format "'[hv' [ 'fun' : T => '/ ' E ] ']'") : fun_scope. + +Notation "[ 'fun' x => E ]" := (SimplFun (fun x => E)) + (at level 0, x ident, + format "'[hv' [ 'fun' x => '/ ' E ] ']'") : fun_scope. + +Notation "[ 'fun' x : T => E ]" := (SimplFun (fun x : T => E)) + (at level 0, x ident, only parsing) : fun_scope. + +Notation "[ 'fun' x y => E ]" := (fun x => [fun y => E]) + (at level 0, x ident, y ident, + format "'[hv' [ 'fun' x y => '/ ' E ] ']'") : fun_scope. + +Notation "[ 'fun' x y : T => E ]" := (fun x : T => [fun y : T => E]) + (at level 0, x ident, y ident, only parsing) : fun_scope. + +Notation "[ 'fun' ( x : T ) y => E ]" := (fun x : T => [fun y => E]) + (at level 0, x ident, y ident, only parsing) : fun_scope. + +Notation "[ 'fun' x ( y : T ) => E ]" := (fun x => [fun y : T => E]) + (at level 0, x ident, y ident, only parsing) : fun_scope. + +Notation "[ 'fun' ( x : xT ) ( y : yT ) => E ]" := + (fun x : xT => [fun y : yT => E]) + (at level 0, x ident, y ident, only parsing) : fun_scope. + +(* For delta functions in eqtype.v. *) +Definition SimplFunDelta aT rT (f : aT -> aT -> rT) := [fun z => f z z]. + +(* Extensional equality, for unary and binary functions, including syntactic *) +(* sugar. *) + +Section ExtensionalEquality. + +Variables A B C : Type. + +Definition eqfun (f g : B -> A) : Prop := forall x, f x = g x. + +Definition eqrel (r s : C -> B -> A) : Prop := forall x y, r x y = s x y. + +Lemma frefl f : eqfun f f. Proof. by []. Qed. +Lemma fsym f g : eqfun f g -> eqfun g f. Proof. by move=> eq_fg x. Qed. + +Lemma ftrans f g h : eqfun f g -> eqfun g h -> eqfun f h. +Proof. by move=> eq_fg eq_gh x; rewrite eq_fg. Qed. + +Lemma rrefl r : eqrel r r. Proof. by []. Qed. + +End ExtensionalEquality. + +Typeclasses Opaque eqfun. +Typeclasses Opaque eqrel. + +Hint Resolve frefl rrefl. + +Notation "f1 =1 f2" := (eqfun f1 f2) + (at level 70, no associativity) : fun_scope. +Notation "f1 =1 f2 :> A" := (f1 =1 (f2 : A)) + (at level 70, f2 at next level, A at level 90) : fun_scope. +Notation "f1 =2 f2" := (eqrel f1 f2) + (at level 70, no associativity) : fun_scope. +Notation "f1 =2 f2 :> A" := (f1 =2 (f2 : A)) + (at level 70, f2 at next level, A at level 90) : fun_scope. + +Section Composition. + +Variables A B C : Type. + +Definition funcomp u (f : B -> A) (g : C -> B) x := let: tt := u in f (g x). +Definition catcomp u g f := funcomp u f g. +Local Notation comp := (funcomp tt). + +Definition pcomp (f : B -> option A) (g : C -> option B) x := obind f (g x). + +Lemma eq_comp f f' g g' : f =1 f' -> g =1 g' -> comp f g =1 comp f' g'. +Proof. by move=> eq_ff' eq_gg' x; rewrite /= eq_gg' eq_ff'. Qed. + +End Composition. + +Notation comp := (funcomp tt). +Notation "@ 'comp'" := (fun A B C => @funcomp A B C tt). +Notation "f1 \o f2" := (comp f1 f2) + (at level 50, format "f1 \o '/ ' f2") : fun_scope. +Notation "f1 \; f2" := (catcomp tt f1 f2) + (at level 60, right associativity, format "f1 \; '/ ' f2") : fun_scope. + +Notation "[ 'eta' f ]" := (fun x => f x) + (at level 0, format "[ 'eta' f ]") : fun_scope. + +Notation "'fun' => E" := (fun _ => E) (at level 200, only parsing) : fun_scope. + +Notation id := (fun x => x). +Notation "@ 'id' T" := (fun x : T => x) + (at level 10, T at level 8, only parsing) : fun_scope. + +Definition id_head T u x : T := let: tt := u in x. +Definition explicit_id_key := tt. +Notation idfun := (id_head tt). +Notation "@ 'idfun' T " := (@id_head T explicit_id_key) + (at level 10, T at level 8, format "@ 'idfun' T") : fun_scope. + +Definition phant_id T1 T2 v1 v2 := phantom T1 v1 -> phantom T2 v2. + +(* Strong sigma types. *) + +Section Tag. + +Variables (I : Type) (i : I) (T_ U_ : I -> Type). + +Definition tag := projS1. +Definition tagged : forall w, T_(tag w) := @projS2 I [eta T_]. +Definition Tagged x := @existS I [eta T_] i x. + +Definition tag2 (w : @sigT2 I T_ U_) := let: existT2 i _ _ := w in i. +Definition tagged2 w : T_(tag2 w) := let: existT2 _ x _ := w in x. +Definition tagged2' w : U_(tag2 w) := let: existT2 _ _ y := w in y. +Definition Tagged2 x y := @existS2 I [eta T_] [eta U_] i x y. + +End Tag. + +Implicit Arguments Tagged [I i]. +Implicit Arguments Tagged2 [I i]. +Prenex Implicits tag tagged Tagged tag2 tagged2 tagged2' Tagged2. + +Coercion tag_of_tag2 I T_ U_ (w : @sigT2 I T_ U_) := + Tagged (fun i => T_ i * U_ i)%type (tagged2 w, tagged2' w). + +Lemma all_tag I T U : + (forall x : I, {y : T x & U x y}) -> + {f : forall x, T x & forall x, U x (f x)}. +Proof. by move=> fP; exists (fun x => tag (fP x)) => x; case: (fP x). Qed. + +Lemma all_tag2 I T U V : + (forall i : I, {y : T i & U i y & V i y}) -> + {f : forall i, T i & forall i, U i (f i) & forall i, V i (f i)}. +Proof. by case/all_tag=> f /all_pair[]; exists f. Qed. + +(* Refinement types. *) + +(* Prenex Implicits and renaming. *) +Notation sval := (@proj1_sig _ _). +Notation "@ 'sval'" := (@proj1_sig) (at level 10, format "@ 'sval'"). + +Section Sig. + +Variables (T : Type) (P Q : T -> Prop). + +Lemma svalP (u : sig P) : P (sval u). Proof. by case: u. Qed. + +Definition s2val (u : sig2 P Q) := let: exist2 x _ _ := u in x. + +Lemma s2valP u : P (s2val u). Proof. by case: u. Qed. + +Lemma s2valP' u : Q (s2val u). Proof. by case: u. Qed. + +End Sig. + +Prenex Implicits svalP s2val s2valP s2valP'. + +Coercion tag_of_sig I P (u : @sig I P) := Tagged P (svalP u). + +Coercion sig_of_sig2 I P Q (u : @sig2 I P Q) := + exist (fun i => P i /\ Q i) (s2val u) (conj (s2valP u) (s2valP' u)). + +Lemma all_sig I T P : + (forall x : I, {y : T x | P x y}) -> + {f : forall x, T x | forall x, P x (f x)}. +Proof. by case/all_tag=> f; exists f. Qed. + +Lemma all_sig2 I T P Q : + (forall x : I, {y : T x | P x y & Q x y}) -> + {f : forall x, T x | forall x, P x (f x) & forall x, Q x (f x)}. +Proof. by case/all_sig=> f /all_pair[]; exists f. Qed. + +Section Morphism. + +Variables (aT rT sT : Type) (f : aT -> rT). + +(* Morphism property for unary and binary functions *) +Definition morphism_1 aF rF := forall x, f (aF x) = rF (f x). +Definition morphism_2 aOp rOp := forall x y, f (aOp x y) = rOp (f x) (f y). + +(* Homomorphism property for unary and binary relations *) +Definition homomorphism_1 (aP rP : _ -> Prop) := forall x, aP x -> rP (f x). +Definition homomorphism_2 (aR rR : _ -> _ -> Prop) := + forall x y, aR x y -> rR (f x) (f y). + +(* Stability property for unary and binary relations *) +Definition monomorphism_1 (aP rP : _ -> sT) := forall x, rP (f x) = aP x. +Definition monomorphism_2 (aR rR : _ -> _ -> sT) := + forall x y, rR (f x) (f y) = aR x y. + +End Morphism. + +Notation "{ 'morph' f : x / a >-> r }" := + (morphism_1 f (fun x => a) (fun x => r)) + (at level 0, f at level 99, x ident, + format "{ 'morph' f : x / a >-> r }") : type_scope. + +Notation "{ 'morph' f : x / a }" := + (morphism_1 f (fun x => a) (fun x => a)) + (at level 0, f at level 99, x ident, + format "{ 'morph' f : x / a }") : type_scope. + +Notation "{ 'morph' f : x y / a >-> r }" := + (morphism_2 f (fun x y => a) (fun x y => r)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'morph' f : x y / a >-> r }") : type_scope. + +Notation "{ 'morph' f : x y / a }" := + (morphism_2 f (fun x y => a) (fun x y => a)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'morph' f : x y / a }") : type_scope. + +Notation "{ 'homo' f : x / a >-> r }" := + (homomorphism_1 f (fun x => a) (fun x => r)) + (at level 0, f at level 99, x ident, + format "{ 'homo' f : x / a >-> r }") : type_scope. + +Notation "{ 'homo' f : x / a }" := + (homomorphism_1 f (fun x => a) (fun x => a)) + (at level 0, f at level 99, x ident, + format "{ 'homo' f : x / a }") : type_scope. + +Notation "{ 'homo' f : x y / a >-> r }" := + (homomorphism_2 f (fun x y => a) (fun x y => r)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'homo' f : x y / a >-> r }") : type_scope. + +Notation "{ 'homo' f : x y / a }" := + (homomorphism_2 f (fun x y => a) (fun x y => a)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'homo' f : x y / a }") : type_scope. + +Notation "{ 'homo' f : x y /~ a }" := + (homomorphism_2 f (fun y x => a) (fun x y => a)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'homo' f : x y /~ a }") : type_scope. + +Notation "{ 'mono' f : x / a >-> r }" := + (monomorphism_1 f (fun x => a) (fun x => r)) + (at level 0, f at level 99, x ident, + format "{ 'mono' f : x / a >-> r }") : type_scope. + +Notation "{ 'mono' f : x / a }" := + (monomorphism_1 f (fun x => a) (fun x => a)) + (at level 0, f at level 99, x ident, + format "{ 'mono' f : x / a }") : type_scope. + +Notation "{ 'mono' f : x y / a >-> r }" := + (monomorphism_2 f (fun x y => a) (fun x y => r)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'mono' f : x y / a >-> r }") : type_scope. + +Notation "{ 'mono' f : x y / a }" := + (monomorphism_2 f (fun x y => a) (fun x y => a)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'mono' f : x y / a }") : type_scope. + +Notation "{ 'mono' f : x y /~ a }" := + (monomorphism_2 f (fun y x => a) (fun x y => a)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'mono' f : x y /~ a }") : type_scope. + +(* In an intuitionistic setting, we have two degrees of injectivity. The *) +(* weaker one gives only simplification, and the strong one provides a left *) +(* inverse (we show in `fintype' that they coincide for finite types). *) +(* We also define an intermediate version where the left inverse is only a *) +(* partial function. *) + +Section Injections. + +(* rT must come first so we can use @ to mitigate the Coq 1st order *) +(* unification bug (e..g., Coq can't infer rT from a "cancel" lemma). *) +Variables (rT aT : Type) (f : aT -> rT). + +Definition injective := forall x1 x2, f x1 = f x2 -> x1 = x2. + +Definition cancel g := forall x, g (f x) = x. + +Definition pcancel g := forall x, g (f x) = Some x. + +Definition ocancel (g : aT -> option rT) h := forall x, oapp h x (g x) = x. + +Lemma can_pcan g : cancel g -> pcancel (fun y => Some (g y)). +Proof. by move=> fK x; congr (Some _). Qed. + +Lemma pcan_inj g : pcancel g -> injective. +Proof. by move=> fK x y /(congr1 g); rewrite !fK => [[]]. Qed. + +Lemma can_inj g : cancel g -> injective. +Proof. by move/can_pcan; exact: pcan_inj. Qed. + +Lemma canLR g x y : cancel g -> x = f y -> g x = y. +Proof. by move=> fK ->. Qed. + +Lemma canRL g x y : cancel g -> f x = y -> x = g y. +Proof. by move=> fK <-. Qed. + +End Injections. + +Lemma Some_inj {T} : injective (@Some T). Proof. by move=> x y []. Qed. + +(* cancellation lemmas for dependent type casts. *) +Lemma esymK T x y : cancel (@esym T x y) (@esym T y x). +Proof. by case: y /. Qed. + +Lemma etrans_id T x y (eqxy : x = y :> T) : etrans (erefl x) eqxy = eqxy. +Proof. by case: y / eqxy. Qed. + +Section InjectionsTheory. + +Variables (A B C : Type) (f g : B -> A) (h : C -> B). + +Lemma inj_id : injective (@id A). +Proof. by []. Qed. + +Lemma inj_can_sym f' : cancel f f' -> injective f' -> cancel f' f. +Proof. move=> fK injf' x; exact: injf'. Qed. + +Lemma inj_comp : injective f -> injective h -> injective (f \o h). +Proof. move=> injf injh x y /injf; exact: injh. Qed. + +Lemma can_comp f' h' : cancel f f' -> cancel h h' -> cancel (f \o h) (h' \o f'). +Proof. by move=> fK hK x; rewrite /= fK hK. Qed. + +Lemma pcan_pcomp f' h' : + pcancel f f' -> pcancel h h' -> pcancel (f \o h) (pcomp h' f'). +Proof. by move=> fK hK x; rewrite /pcomp fK /= hK. Qed. + +Lemma eq_inj : injective f -> f =1 g -> injective g. +Proof. by move=> injf eqfg x y; rewrite -2!eqfg; exact: injf. Qed. + +Lemma eq_can f' g' : cancel f f' -> f =1 g -> f' =1 g' -> cancel g g'. +Proof. by move=> fK eqfg eqfg' x; rewrite -eqfg -eqfg'. Qed. + +Lemma inj_can_eq f' : cancel f f' -> injective f' -> cancel g f' -> f =1 g. +Proof. by move=> fK injf' gK x; apply: injf'; rewrite fK. Qed. + +End InjectionsTheory. + +Section Bijections. + +Variables (A B : Type) (f : B -> A). + +CoInductive bijective : Prop := Bijective g of cancel f g & cancel g f. + +Hypothesis bijf : bijective. + +Lemma bij_inj : injective f. +Proof. by case: bijf => g fK _; apply: can_inj fK. Qed. + +Lemma bij_can_sym f' : cancel f' f <-> cancel f f'. +Proof. +split=> fK; first exact: inj_can_sym fK bij_inj. +by case: bijf => h _ hK x; rewrite -[x]hK fK. +Qed. + +Lemma bij_can_eq f' f'' : cancel f f' -> cancel f f'' -> f' =1 f''. +Proof. +by move=> fK fK'; apply: (inj_can_eq _ bij_inj); apply/bij_can_sym. +Qed. + +End Bijections. + +Section BijectionsTheory. + +Variables (A B C : Type) (f : B -> A) (h : C -> B). + +Lemma eq_bij : bijective f -> forall g, f =1 g -> bijective g. +Proof. by case=> f' fK f'K g eqfg; exists f'; eapply eq_can; eauto. Qed. + +Lemma bij_comp : bijective f -> bijective h -> bijective (f \o h). +Proof. +by move=> [f' fK f'K] [h' hK h'K]; exists (h' \o f'); apply: can_comp; auto. +Qed. + +Lemma bij_can_bij : bijective f -> forall f', cancel f f' -> bijective f'. +Proof. by move=> bijf; exists f; first by apply/(bij_can_sym bijf). Qed. + +End BijectionsTheory. + +Section Involutions. + +Variables (A : Type) (f : A -> A). + +Definition involutive := cancel f f. + +Hypothesis Hf : involutive. + +Lemma inv_inj : injective f. Proof. exact: can_inj Hf. Qed. +Lemma inv_bij : bijective f. Proof. by exists f. Qed. + +End Involutions. + +Section OperationProperties. + +Variables S T R : Type. + +Section SopTisR. +Implicit Type op : S -> T -> R. +Definition left_inverse e inv op := forall x, op (inv x) x = e. +Definition right_inverse e inv op := forall x, op x (inv x) = e. +Definition left_injective op := forall x, injective (op^~ x). +Definition right_injective op := forall y, injective (op y). +End SopTisR. + + +Section SopTisS. +Implicit Type op : S -> T -> S. +Definition right_id e op := forall x, op x e = x. +Definition left_zero z op := forall x, op z x = z. +Definition right_commutative op := forall x y z, op (op x y) z = op (op x z) y. +Definition left_distributive op add := + forall x y z, op (add x y) z = add (op x z) (op y z). +Definition right_loop inv op := forall y, cancel (op^~ y) (op^~ (inv y)). +Definition rev_right_loop inv op := forall y, cancel (op^~ (inv y)) (op^~ y). +End SopTisS. + +Section SopTisT. +Implicit Type op : S -> T -> T. +Definition left_id e op := forall x, op e x = x. +Definition right_zero z op := forall x, op x z = z. +Definition left_commutative op := forall x y z, op x (op y z) = op y (op x z). +Definition right_distributive op add := + forall x y z, op x (add y z) = add (op x y) (op x z). +Definition left_loop inv op := forall x, cancel (op x) (op (inv x)). +Definition rev_left_loop inv op := forall x, cancel (op (inv x)) (op x). +End SopTisT. + +Section SopSisT. +Implicit Type op : S -> S -> T. +Definition self_inverse e op := forall x, op x x = e. +Definition commutative op := forall x y, op x y = op y x. +End SopSisT. + +Section SopSisS. +Implicit Type op : S -> S -> S. +Definition idempotent op := forall x, op x x = x. +Definition associative op := forall x y z, op x (op y z) = op (op x y) z. +Definition interchange op1 op2 := + forall x y z t, op1 (op2 x y) (op2 z t) = op2 (op1 x z) (op1 y t). +End SopSisS. + +End OperationProperties. + + + + + + + + + + diff --git a/mathcomp/ssreflect/ssrmatching.v b/mathcomp/ssreflect/ssrmatching.v new file mode 100644 index 0000000..a48b121 --- /dev/null +++ b/mathcomp/ssreflect/ssrmatching.v @@ -0,0 +1,27 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Declare ML Module "ssreflect". + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Module SsrMatchingSyntax. + +(* Reserve the notation for rewrite patterns so that the user is not allowed *) +(* to declare it at a different level. *) +Reserved Notation "( a 'in' b )" (at level 0). +Reserved Notation "( a 'as' b )" (at level 0). +Reserved Notation "( a 'in' b 'in' c )" (at level 0). +Reserved Notation "( a 'as' b 'in' c )" (at level 0). + +(* Notation to define shortcuts for the "X in t" part of a pattern. *) +Notation "( X 'in' t )" := (_ : fun X => t) : ssrpatternscope. +Delimit Scope ssrpatternscope with pattern. + +(* Some shortcuts for recurrent "X in t" parts. *) +Notation RHS := (X in _ = X)%pattern. +Notation LHS := (X in X = _)%pattern. + +End SsrMatchingSyntax. + +Export SsrMatchingSyntax. diff --git a/mathcomp/ssreflect/ssrnat.v b/mathcomp/ssreflect/ssrnat.v new file mode 100644 index 0000000..bd54e57 --- /dev/null +++ b/mathcomp/ssreflect/ssrnat.v @@ -0,0 +1,1598 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype. +Require Import BinNat. +Require BinPos Ndec. +Require Export Ring. + +(******************************************************************************) +(* A version of arithmetic on nat (natural numbers) that is better suited to *) +(* small scale reflection than the Coq Arith library. It contains an *) +(* extensive equational theory (including, e.g., the AGM inequality), as well *) +(* as support for the ring tactic, and congruence tactics. *) +(* The following operations and notations are provided: *) +(* *) +(* successor and predecessor *) +(* n.+1, n.+2, n.+3, n.+4 and n.-1, n.-2 *) +(* this frees the names "S" and "pred" *) +(* *) +(* basic arithmetic *) +(* m + n, m - n, m * n *) +(* Important: m - n denotes TRUNCATED subtraction: m - n = 0 if m <= n. *) +(* The definitions use the nosimpl tag to prevent undesirable computation *) +(* computation during simplification, but remain compatible with the ones *) +(* provided in the Coq.Init.Peano prelude. *) +(* For computation, a module NatTrec rebinds all arithmetic notations *) +(* to less convenient but also less inefficient tail-recursive functions; *) +(* the auxiliary functions used by these versions are flagged with %Nrec. *) +(* Also, there is support for input and output of large nat values. *) +(* Num 3 082 241 inputs the number 3082241 *) +(* [Num of n] outputs the value n *) +(* There are coercions num >-> BinNat.N >-> nat; ssrnat rebinds the scope *) +(* delimiter for BinNat.N to %num, as it uses the shorter %N for its own *) +(* notations (Peano notations are flagged with %coq_nat). *) +(* *) +(* doubling, halving, and parity *) +(* n.*2, n./2, odd n, uphalf n, with uphalf n = n.+1./2 *) +(* bool coerces to nat so we can write, e.g., n = odd n + n./2.*2. *) +(* *) +(* iteration *) +(* iter n f x0 == f ( .. (f x0)) *) +(* iteri n g x0 == g n.-1 (g ... (g 0 x0)) *) +(* iterop n op x x0 == op x (... op x x) (n x's) or x0 if n = 0 *) +(* *) +(* exponentiation, factorial *) +(* m ^ n, n`! *) +(* m ^ 1 is convertible to m, and m ^ 2 to m * m *) +(* *) +(* comparison *) +(* m <= n, m < n, m >= n, m > n, m == n, m <= n <= p, etc., *) +(* comparisons are BOOLEAN operators, and m == n is the generic eqType *) +(* operation. *) +(* Most compatibility lemmas are stated as boolean equalities; this keeps *) +(* the size of the library down. All the inequalities refer to the same *) +(* constant "leq"; in particular m < n is identical to m.+1 <= n. *) +(* *) +(* conditionally strict inequality `leqif' *) +(* m <= n ?= iff condition == (m <= n) and ((m == n) = condition) *) +(* This is actually a pair of boolean equalities, so rewriting with an *) +(* `leqif' lemma can affect several kinds of comparison. The transitivity *) +(* lemma for leqif aggregates the conditions, allowing for arguments of *) +(* the form ``m <= n <= p <= m, so equality holds throughout''. *) +(* *) +(* maximum and minimum *) +(* maxn m n, minn m n *) +(* Note that maxn m n = m + (m - n), due to the truncating subtraction. *) +(* Absolute difference (linear distance) between nats is defined in the int *) +(* library (in the int.IntDist sublibrary), with the syntax `|m - n|. The *) +(* '-' in this notation is the signed integer difference. *) +(* *) +(* countable choice *) +(* ex_minn : forall P : pred nat, (exists n, P n) -> nat *) +(* This returns the smallest n such that P n holds. *) +(* ex_maxn : forall (P : pred nat) m, *) +(* (exists n, P n) -> (forall n, P n -> n <= m) -> nat *) +(* This returns the largest n such that P n holds (given an explicit upper *) +(* bound). *) +(* *) +(* This file adds the following suffix conventions to those documented in *) +(* ssrbool.v and eqtype.v: *) +(* A (infix) -- conjunction, as in *) +(* ltn_neqAle : (m < n) = (m != n) && (m <= n). *) +(* B -- subtraction, as in subBn : (m - n) - p = m - (n + p). *) +(* D -- addition, as in mulnDl : (m + n) * p = m * p + n * p. *) +(* M -- multiplication, as in expnMn : (m * n) ^ p = m ^ p * n ^ p. *) +(* p (prefix) -- positive, as in *) +(* eqn_pmul2l : m > 0 -> (m * n1 == m * n2) = (n1 == n2). *) +(* P -- greater than 1, as in *) +(* ltn_Pmull : 1 < n -> 0 < m -> m < n * m. *) +(* S -- successor, as in addSn : n.+1 + m = (n + m).+1. *) +(* V (infix) -- disjunction, as in *) +(* leq_eqVlt : (m <= n) = (m == n) || (m < n). *) +(* X - exponentiation, as in lognX : logn p (m ^ n) = logn p m * n in *) +(* file prime.v (the suffix is not used in ths file). *) +(* Suffixes that abbreviate operations (D, B, M and X) are used to abbreviate *) +(* second-rank operations in equational lemma names that describe left-hand *) +(* sides (e.g., mulnDl); they are not used to abbreviate the main operation *) +(* of relational lemmas (e.g., leq_add2l). *) +(* For the asymmetrical exponentiation operator expn (m ^ n) a right suffix *) +(* indicates an operation on the exponent, e.g., expnM : m ^ (n1 * n2) = ...; *) +(* a trailing "n" is used to indicate the left operand, e.g., *) +(* expnMn : (m1 * m2) ^ n = ... The operands of other operators are selected *) +(* using the l/r suffixes. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +(* Declare legacy Arith operators in new scope. *) + +Delimit Scope coq_nat_scope with coq_nat. + +Notation "m + n" := (plus m n) : coq_nat_scope. +Notation "m - n" := (minus m n) : coq_nat_scope. +Notation "m * n" := (mult m n) : coq_nat_scope. +Notation "m <= n" := (le m n) : coq_nat_scope. +Notation "m < n" := (lt m n) : coq_nat_scope. +Notation "m >= n" := (ge m n) : coq_nat_scope. +Notation "m > n" := (gt m n) : coq_nat_scope. + +(* Rebind scope delimiters, reserving a scope for the "recursive", *) +(* i.e., unprotected version of operators. *) + +Delimit Scope N_scope with num. +Delimit Scope nat_scope with N. +Delimit Scope nat_rec_scope with Nrec. + +(* Postfix notation for the successor and predecessor functions. *) +(* SSreflect uses "pred" for the generic predicate type, and S as *) +(* a local bound variable. *) + +Notation succn := Datatypes.S. +Notation predn := Peano.pred. + +Notation "n .+1" := (succn n) (at level 2, left associativity, + format "n .+1") : nat_scope. +Notation "n .+2" := n.+1.+1 (at level 2, left associativity, + format "n .+2") : nat_scope. +Notation "n .+3" := n.+2.+1 (at level 2, left associativity, + format "n .+3") : nat_scope. +Notation "n .+4" := n.+2.+2 (at level 2, left associativity, + format "n .+4") : nat_scope. + +Notation "n .-1" := (predn n) (at level 2, left associativity, + format "n .-1") : nat_scope. +Notation "n .-2" := n.-1.-1 (at level 2, left associativity, + format "n .-2") : nat_scope. + +Lemma succnK : cancel succn predn. Proof. by []. Qed. +Lemma succn_inj : injective succn. Proof. by move=> n m []. Qed. + +(* Predeclare postfix doubling/halving operators. *) + +Reserved Notation "n .*2" (at level 2, format "n .*2"). +Reserved Notation "n ./2" (at level 2, format "n ./2"). + +(* Canonical comparison and eqType for nat. *) + +Fixpoint eqn m n {struct m} := + match m, n with + | 0, 0 => true + | m'.+1, n'.+1 => eqn m' n' + | _, _ => false + end. + +Lemma eqnP : Equality.axiom eqn. +Proof. +move=> n m; apply: (iffP idP) => [|<-]; last by elim n. +by elim: n m => [|n IHn] [|m] //= /IHn->. +Qed. + +Canonical nat_eqMixin := EqMixin eqnP. +Canonical nat_eqType := Eval hnf in EqType nat nat_eqMixin. + +Implicit Arguments eqnP [x y]. +Prenex Implicits eqnP. + +Lemma eqnE : eqn = eq_op. Proof. by []. Qed. + +Lemma eqSS m n : (m.+1 == n.+1) = (m == n). Proof. by []. Qed. + +Lemma nat_irrelevance (x y : nat) (E E' : x = y) : E = E'. +Proof. exact: eq_irrelevance. Qed. + +(* Protected addition, with a more systematic set of lemmas. *) + +Definition addn_rec := plus. +Notation "m + n" := (addn_rec m n) : nat_rec_scope. + +Definition addn := nosimpl addn_rec. +Notation "m + n" := (addn m n) : nat_scope. + +Lemma addnE : addn = addn_rec. Proof. by []. Qed. + +Lemma plusE : plus = addn. Proof. by []. Qed. + +Lemma add0n : left_id 0 addn. Proof. by []. Qed. +Lemma addSn m n : m.+1 + n = (m + n).+1. Proof. by []. Qed. +Lemma add1n n : 1 + n = n.+1. Proof. by []. Qed. + +Lemma addn0 : right_id 0 addn. Proof. by move=> n; apply/eqP; elim: n. Qed. + +Lemma addnS m n : m + n.+1 = (m + n).+1. Proof. by elim: m. Qed. + +Lemma addSnnS m n : m.+1 + n = m + n.+1. Proof. by rewrite addnS. Qed. + +Lemma addnCA : left_commutative addn. +Proof. by move=> m n p; elim: m => //= m; rewrite addnS => <-. Qed. + +Lemma addnC : commutative addn. +Proof. by move=> m n; rewrite -{1}[n]addn0 addnCA addn0. Qed. + +Lemma addn1 n : n + 1 = n.+1. Proof. by rewrite addnC. Qed. + +Lemma addnA : associative addn. +Proof. by move=> m n p; rewrite (addnC n) addnCA addnC. Qed. + +Lemma addnAC : right_commutative addn. +Proof. by move=> m n p; rewrite -!addnA (addnC n). Qed. + +Lemma addnACA : interchange addn addn. +Proof. by move=> m n p q; rewrite -!addnA (addnCA n). Qed. + +Lemma addn_eq0 m n : (m + n == 0) = (m == 0) && (n == 0). +Proof. by case: m; case: n. Qed. + +Lemma eqn_add2l p m n : (p + m == p + n) = (m == n). +Proof. by elim: p. Qed. + +Lemma eqn_add2r p m n : (m + p == n + p) = (m == n). +Proof. by rewrite -!(addnC p) eqn_add2l. Qed. + +Lemma addnI : right_injective addn. +Proof. by move=> p m n Heq; apply: eqP; rewrite -(eqn_add2l p) Heq eqxx. Qed. + +Lemma addIn : left_injective addn. +Proof. move=> p m n; rewrite -!(addnC p); apply addnI. Qed. + +Lemma addn2 m : m + 2 = m.+2. Proof. by rewrite addnC. Qed. +Lemma add2n m : 2 + m = m.+2. Proof. by []. Qed. +Lemma addn3 m : m + 3 = m.+3. Proof. by rewrite addnC. Qed. +Lemma add3n m : 3 + m = m.+3. Proof. by []. Qed. +Lemma addn4 m : m + 4 = m.+4. Proof. by rewrite addnC. Qed. +Lemma add4n m : 4 + m = m.+4. Proof. by []. Qed. + +(* Protected, structurally decreasing subtraction, and basic lemmas. *) +(* Further properties depend on ordering conditions. *) + +Definition subn_rec := minus. +Notation "m - n" := (subn_rec m n) : nat_rec_scope. + +Definition subn := nosimpl subn_rec. +Notation "m - n" := (subn m n) : nat_scope. + +Lemma subnE : subn = subn_rec. Proof. by []. Qed. +Lemma minusE : minus = subn. Proof. by []. Qed. + +Lemma sub0n : left_zero 0 subn. Proof. by []. Qed. +Lemma subn0 : right_id 0 subn. Proof. by case. Qed. +Lemma subnn : self_inverse 0 subn. Proof. by elim. Qed. + +Lemma subSS n m : m.+1 - n.+1 = m - n. Proof. by []. Qed. +Lemma subn1 n : n - 1 = n.-1. Proof. by case: n => [|[]]. Qed. +Lemma subn2 n : (n - 2)%N = n.-2. Proof. by case: n => [|[|[]]]. Qed. + +Lemma subnDl p m n : (p + m) - (p + n) = m - n. +Proof. by elim: p. Qed. + +Lemma subnDr p m n : (m + p) - (n + p) = m - n. +Proof. by rewrite -!(addnC p) subnDl. Qed. + +Lemma addKn n : cancel (addn n) (subn^~ n). +Proof. by move=> m; rewrite /= -{2}[n]addn0 subnDl subn0. Qed. + +Lemma addnK n : cancel (addn^~ n) (subn^~ n). +Proof. by move=> m; rewrite /= (addnC m) addKn. Qed. + +Lemma subSnn n : n.+1 - n = 1. +Proof. exact (addnK n 1). Qed. + +Lemma subnDA m n p : n - (m + p) = (n - m) - p. +Proof. by elim: m n => [|m IHm] [|n]; try exact (IHm n). Qed. + +Lemma subnAC : right_commutative subn. +Proof. by move=> m n p; rewrite -!subnDA addnC. Qed. + +Lemma subnS m n : m - n.+1 = (m - n).-1. +Proof. by rewrite -addn1 subnDA subn1. Qed. + +Lemma subSKn m n : (m.+1 - n).-1 = m - n. +Proof. by rewrite -subnS. Qed. + +(* Integer ordering, and its interaction with the other operations. *) + +Definition leq m n := m - n == 0. + +Notation "m <= n" := (leq m n) : nat_scope. +Notation "m < n" := (m.+1 <= n) : nat_scope. +Notation "m >= n" := (n <= m) (only parsing) : nat_scope. +Notation "m > n" := (n < m) (only parsing) : nat_scope. + +(* For sorting, etc. *) +Definition geq := [rel m n | m >= n]. +Definition ltn := [rel m n | m < n]. +Definition gtn := [rel m n | m > n]. + +Notation "m <= n <= p" := ((m <= n) && (n <= p)) : nat_scope. +Notation "m < n <= p" := ((m < n) && (n <= p)) : nat_scope. +Notation "m <= n < p" := ((m <= n) && (n < p)) : nat_scope. +Notation "m < n < p" := ((m < n) && (n < p)) : nat_scope. + +Lemma ltnS m n : (m < n.+1) = (m <= n). Proof. by []. Qed. +Lemma leq0n n : 0 <= n. Proof. by []. Qed. +Lemma ltn0Sn n : 0 < n.+1. Proof. by []. Qed. +Lemma ltn0 n : n < 0 = false. Proof. by []. Qed. +Lemma leqnn n : n <= n. Proof. by elim: n. Qed. +Hint Resolve leqnn. +Lemma ltnSn n : n < n.+1. Proof. by []. Qed. +Lemma eq_leq m n : m = n -> m <= n. Proof. by move->. Qed. +Lemma leqnSn n : n <= n.+1. Proof. by elim: n. Qed. +Hint Resolve leqnSn. +Lemma leq_pred n : n.-1 <= n. Proof. by case: n => /=. Qed. +Lemma leqSpred n : n <= n.-1.+1. Proof. by case: n => /=. Qed. + +Lemma ltn_predK m n : m < n -> n.-1.+1 = n. +Proof. by case: n. Qed. + +Lemma prednK n : 0 < n -> n.-1.+1 = n. +Proof. exact: ltn_predK. Qed. + +Lemma leqNgt m n : (m <= n) = ~~ (n < m). +Proof. by elim: m n => [|m IHm] [|n] //; exact: IHm n. Qed. + +Lemma ltnNge m n : (m < n) = ~~ (n <= m). +Proof. by rewrite leqNgt. Qed. + +Lemma ltnn n : n < n = false. +Proof. by rewrite ltnNge leqnn. Qed. + +Lemma leqn0 n : (n <= 0) = (n == 0). Proof. by case: n. Qed. +Lemma lt0n n : (0 < n) = (n != 0). Proof. by case: n. Qed. +Lemma lt0n_neq0 n : 0 < n -> n != 0. Proof. by case: n. Qed. +Lemma eqn0Ngt n : (n == 0) = ~~ (n > 0). Proof. by case: n. Qed. +Lemma neq0_lt0n n : (n == 0) = false -> 0 < n. Proof. by case: n. Qed. +Hint Resolve lt0n_neq0 neq0_lt0n. + +Lemma eqn_leq m n : (m == n) = (m <= n <= m). +Proof. elim: m n => [|m IHm] [|n] //; exact: IHm n. Qed. + +Lemma anti_leq : antisymmetric leq. +Proof. by move=> m n; rewrite -eqn_leq => /eqP. Qed. + +Lemma neq_ltn m n : (m != n) = (m < n) || (n < m). +Proof. by rewrite eqn_leq negb_and orbC -!ltnNge. Qed. + +Lemma gtn_eqF m n : m < n -> n == m = false. +Proof. by rewrite eqn_leq (leqNgt n) => ->. Qed. + +Lemma ltn_eqF m n : m < n -> m == n = false. +Proof. by move/gtn_eqF; rewrite eq_sym. Qed. + +Lemma leq_eqVlt m n : (m <= n) = (m == n) || (m < n). +Proof. elim: m n => [|m IHm] [|n] //; exact: IHm n. Qed. + +Lemma ltn_neqAle m n : (m < n) = (m != n) && (m <= n). +Proof. by rewrite ltnNge leq_eqVlt negb_or -leqNgt eq_sym. Qed. + +Lemma leq_trans n m p : m <= n -> n <= p -> m <= p. +Proof. by elim: n m p => [|i IHn] [|m] [|p] //; exact: IHn m p. Qed. + +Lemma leq_ltn_trans n m p : m <= n -> n < p -> m < p. +Proof. move=> Hmn; exact: leq_trans. Qed. + +Lemma ltnW m n : m < n -> m <= n. +Proof. exact: leq_trans. Qed. +Hint Resolve ltnW. + +Lemma leqW m n : m <= n -> m <= n.+1. +Proof. by move=> le_mn; exact: ltnW. Qed. + +Lemma ltn_trans n m p : m < n -> n < p -> m < p. +Proof. by move=> lt_mn /ltnW; exact: leq_trans. Qed. + +Lemma leq_total m n : (m <= n) || (m >= n). +Proof. by rewrite -implyNb -ltnNge; apply/implyP; exact: ltnW. Qed. + +(* Link to the legacy comparison predicates. *) + +Lemma leP m n : reflect (m <= n)%coq_nat (m <= n). +Proof. +apply: (iffP idP); last by elim: n / => // n _ /leq_trans->. +elim: n => [|n IHn]; first by case: m. +by rewrite leq_eqVlt ltnS => /predU1P[<- // | /IHn]; right. +Qed. +Implicit Arguments leP [m n]. + +Lemma le_irrelevance m n le_mn1 le_mn2 : le_mn1 = le_mn2 :> (m <= n)%coq_nat. +Proof. +elim: {n}n.+1 {-1}n (erefl n.+1) => // n IHn _ [<-] in le_mn1 le_mn2 *. +pose def_n2 := erefl n; transitivity (eq_ind _ _ le_mn2 _ def_n2) => //. +move def_n1: {1 4 5 7}n le_mn1 le_mn2 def_n2 => n1 le_mn1. +case: n1 / le_mn1 def_n1 => [|n1 le_mn1] def_n1 [|n2 le_mn2] def_n2. +- by rewrite [def_n2]eq_axiomK. +- by move/leP: (le_mn2); rewrite -{1}def_n2 ltnn. +- by move/leP: (le_mn1); rewrite {1}def_n2 ltnn. +case: def_n2 (def_n2) => ->{n2} def_n2 in le_mn2 *. +by rewrite [def_n2]eq_axiomK /=; congr le_S; exact: IHn. +Qed. + +Lemma ltP m n : reflect (m < n)%coq_nat (m < n). +Proof. exact leP. Qed. +Implicit Arguments ltP [m n]. + +Lemma lt_irrelevance m n lt_mn1 lt_mn2 : lt_mn1 = lt_mn2 :> (m < n)%coq_nat. +Proof. exact: (@le_irrelevance m.+1). Qed. + +(* Comparison predicates. *) + +CoInductive leq_xor_gtn m n : bool -> bool -> Set := + | LeqNotGtn of m <= n : leq_xor_gtn m n true false + | GtnNotLeq of n < m : leq_xor_gtn m n false true. + +Lemma leqP m n : leq_xor_gtn m n (m <= n) (n < m). +Proof. +by rewrite ltnNge; case le_mn: (m <= n); constructor; rewrite // ltnNge le_mn. +Qed. + +CoInductive ltn_xor_geq m n : bool -> bool -> Set := + | LtnNotGeq of m < n : ltn_xor_geq m n false true + | GeqNotLtn of n <= m : ltn_xor_geq m n true false. + +Lemma ltnP m n : ltn_xor_geq m n (n <= m) (m < n). +Proof. by rewrite -(ltnS n); case: leqP; constructor. Qed. + +CoInductive eqn0_xor_gt0 n : bool -> bool -> Set := + | Eq0NotPos of n = 0 : eqn0_xor_gt0 n true false + | PosNotEq0 of n > 0 : eqn0_xor_gt0 n false true. + +Lemma posnP n : eqn0_xor_gt0 n (n == 0) (0 < n). +Proof. by case: n; constructor. Qed. + +CoInductive compare_nat m n : bool -> bool -> bool -> Set := + | CompareNatLt of m < n : compare_nat m n true false false + | CompareNatGt of m > n : compare_nat m n false true false + | CompareNatEq of m = n : compare_nat m n false false true. + +Lemma ltngtP m n : compare_nat m n (m < n) (n < m) (m == n). +Proof. +rewrite ltn_neqAle eqn_leq; case: ltnP; first by constructor. +by rewrite leq_eqVlt orbC; case: leqP; constructor; first exact/eqnP. +Qed. + +(* Monotonicity lemmas *) + +Lemma leq_add2l p m n : (p + m <= p + n) = (m <= n). +Proof. by elim: p. Qed. + +Lemma ltn_add2l p m n : (p + m < p + n) = (m < n). +Proof. by rewrite -addnS; exact: leq_add2l. Qed. + +Lemma leq_add2r p m n : (m + p <= n + p) = (m <= n). +Proof. by rewrite -!(addnC p); exact: leq_add2l. Qed. + +Lemma ltn_add2r p m n : (m + p < n + p) = (m < n). +Proof. exact: leq_add2r p m.+1 n. Qed. + +Lemma leq_add m1 m2 n1 n2 : m1 <= n1 -> m2 <= n2 -> m1 + m2 <= n1 + n2. +Proof. +by move=> le_mn1 le_mn2; rewrite (@leq_trans (m1 + n2)) ?leq_add2l ?leq_add2r. +Qed. + +Lemma leq_addr m n : n <= n + m. +Proof. by rewrite -{1}[n]addn0 leq_add2l. Qed. + +Lemma leq_addl m n : n <= m + n. +Proof. by rewrite addnC leq_addr. Qed. + +Lemma ltn_addr m n p : m < n -> m < n + p. +Proof. by move/leq_trans=> -> //; exact: leq_addr. Qed. + +Lemma ltn_addl m n p : m < n -> m < p + n. +Proof. by move/leq_trans=> -> //; exact: leq_addl. Qed. + +Lemma addn_gt0 m n : (0 < m + n) = (0 < m) || (0 < n). +Proof. by rewrite !lt0n -negb_and addn_eq0. Qed. + +Lemma subn_gt0 m n : (0 < n - m) = (m < n). +Proof. by elim: m n => [|m IHm] [|n] //; exact: IHm n. Qed. + +Lemma subn_eq0 m n : (m - n == 0) = (m <= n). +Proof. by []. Qed. + +Lemma leq_subLR m n p : (m - n <= p) = (m <= n + p). +Proof. by rewrite -subn_eq0 -subnDA. Qed. + +Lemma leq_subr m n : n - m <= n. +Proof. by rewrite leq_subLR leq_addl. Qed. + +Lemma subnKC m n : m <= n -> m + (n - m) = n. +Proof. by elim: m n => [|m IHm] [|n] // /(IHm n) {2}<-. Qed. + +Lemma subnK m n : m <= n -> (n - m) + m = n. +Proof. by rewrite addnC; exact: subnKC. Qed. + +Lemma addnBA m n p : p <= n -> m + (n - p) = m + n - p. +Proof. by move=> le_pn; rewrite -{2}(subnK le_pn) addnA addnK. Qed. + +Lemma subnBA m n p : p <= n -> m - (n - p) = m + p - n. +Proof. by move=> le_pn; rewrite -{2}(subnK le_pn) subnDr. Qed. + +Lemma subKn m n : m <= n -> n - (n - m) = m. +Proof. by move/subnBA->; rewrite addKn. Qed. + +Lemma subSn m n : m <= n -> n.+1 - m = (n - m).+1. +Proof. by rewrite -add1n => /addnBA <-. Qed. + +Lemma subnSK m n : m < n -> (n - m.+1).+1 = n - m. +Proof. by move/subSn. Qed. + +Lemma leq_sub2r p m n : m <= n -> m - p <= n - p. +Proof. +by move=> le_mn; rewrite leq_subLR (leq_trans le_mn) // -leq_subLR. +Qed. + +Lemma leq_sub2l p m n : m <= n -> p - n <= p - m. +Proof. +rewrite -(leq_add2r (p - m)) leq_subLR. +by apply: leq_trans; rewrite -leq_subLR. +Qed. + +Lemma leq_sub m1 m2 n1 n2 : m1 <= m2 -> n2 <= n1 -> m1 - n1 <= m2 - n2. +Proof. by move/(leq_sub2r n1)=> le_m12 /(leq_sub2l m2); apply: leq_trans. Qed. + +Lemma ltn_sub2r p m n : p < n -> m < n -> m - p < n - p. +Proof. by move/subnSK <-; exact: (@leq_sub2r p.+1). Qed. + +Lemma ltn_sub2l p m n : m < p -> m < n -> p - n < p - m. +Proof. by move/subnSK <-; exact: leq_sub2l. Qed. + +Lemma ltn_subRL m n p : (n < p - m) = (m + n < p). +Proof. by rewrite !ltnNge leq_subLR. Qed. + +(* Eliminating the idiom for structurally decreasing compare and subtract. *) +Lemma subn_if_gt T m n F (E : T) : + (if m.+1 - n is m'.+1 then F m' else E) = (if n <= m then F (m - n) else E). +Proof. +by case: leqP => [le_nm | /eqnP-> //]; rewrite -{1}(subnK le_nm) -addSn addnK. +Qed. + +(* Max and min. *) + +Definition maxn m n := if m < n then n else m. + +Definition minn m n := if m < n then m else n. + +Lemma max0n : left_id 0 maxn. Proof. by case. Qed. +Lemma maxn0 : right_id 0 maxn. Proof. by []. Qed. + +Lemma maxnC : commutative maxn. +Proof. by move=> m n; rewrite /maxn; case ltngtP. Qed. + +Lemma maxnE m n : maxn m n = m + (n - m). +Proof. by rewrite /maxn addnC; case: leqP => [/eqnP-> | /ltnW/subnK]. Qed. + +Lemma maxnAC : right_commutative maxn. +Proof. by move=> m n p; rewrite !maxnE -!addnA !subnDA -!maxnE maxnC. Qed. + +Lemma maxnA : associative maxn. +Proof. by move=> m n p; rewrite !(maxnC m) maxnAC. Qed. + +Lemma maxnCA : left_commutative maxn. +Proof. by move=> m n p; rewrite !maxnA (maxnC m). Qed. + +Lemma maxnACA : interchange maxn maxn. +Proof. by move=> m n p q; rewrite -!maxnA (maxnCA n). Qed. + +Lemma maxn_idPl {m n} : reflect (maxn m n = m) (m >= n). +Proof. by rewrite -subn_eq0 -(eqn_add2l m) addn0 -maxnE; apply: eqP. Qed. + +Lemma maxn_idPr {m n} : reflect (maxn m n = n) (m <= n). +Proof. by rewrite maxnC; apply: maxn_idPl. Qed. + +Lemma maxnn : idempotent maxn. +Proof. by move=> n; apply/maxn_idPl. Qed. + +Lemma leq_max m n1 n2 : (m <= maxn n1 n2) = (m <= n1) || (m <= n2). +Proof. +without loss le_n21: n1 n2 / n2 <= n1. + by case/orP: (leq_total n2 n1) => le_n12; last rewrite maxnC orbC; apply. +by rewrite (maxn_idPl le_n21) orb_idr // => /leq_trans->. +Qed. +Lemma leq_maxl m n : m <= maxn m n. Proof. by rewrite leq_max leqnn. Qed. +Lemma leq_maxr m n : n <= maxn m n. Proof. by rewrite maxnC leq_maxl. Qed. + +Lemma gtn_max m n1 n2 : (m > maxn n1 n2) = (m > n1) && (m > n2). +Proof. by rewrite !ltnNge leq_max negb_or. Qed. + +Lemma geq_max m n1 n2 : (m >= maxn n1 n2) = (m >= n1) && (m >= n2). +Proof. by rewrite -ltnS gtn_max. Qed. + +Lemma maxnSS m n : maxn m.+1 n.+1 = (maxn m n).+1. +Proof. by rewrite !maxnE. Qed. + +Lemma addn_maxl : left_distributive addn maxn. +Proof. by move=> m1 m2 n; rewrite !maxnE subnDr addnAC. Qed. + +Lemma addn_maxr : right_distributive addn maxn. +Proof. by move=> m n1 n2; rewrite !(addnC m) addn_maxl. Qed. + +Lemma min0n : left_zero 0 minn. Proof. by case. Qed. +Lemma minn0 : right_zero 0 minn. Proof. by []. Qed. + +Lemma minnC : commutative minn. +Proof. by move=> m n; rewrite /minn; case ltngtP. Qed. + +Lemma addn_min_max m n : minn m n + maxn m n = m + n. +Proof. by rewrite /minn /maxn; case: ltngtP => // [_|->] //; exact: addnC. Qed. + +Lemma minnE m n : minn m n = m - (m - n). +Proof. by rewrite -(subnDl n) -maxnE -addn_min_max addnK minnC. Qed. + +Lemma minnAC : right_commutative minn. +Proof. +by move=> m n p; rewrite !minnE -subnDA subnAC -maxnE maxnC maxnE subnAC subnDA. +Qed. + +Lemma minnA : associative minn. +Proof. by move=> m n p; rewrite minnC minnAC (minnC n). Qed. + +Lemma minnCA : left_commutative minn. +Proof. by move=> m n p; rewrite !minnA (minnC n). Qed. + +Lemma minnACA : interchange minn minn. +Proof. by move=> m n p q; rewrite -!minnA (minnCA n). Qed. + +Lemma minn_idPl {m n} : reflect (minn m n = m) (m <= n). +Proof. +rewrite (sameP maxn_idPr eqP) -(eqn_add2l m) eq_sym -addn_min_max eqn_add2r. +exact: eqP. +Qed. + +Lemma minn_idPr {m n} : reflect (minn m n = n) (m >= n). +Proof. by rewrite minnC; apply: minn_idPl. Qed. + +Lemma minnn : idempotent minn. +Proof. by move=> n; apply/minn_idPl. Qed. + +Lemma leq_min m n1 n2 : (m <= minn n1 n2) = (m <= n1) && (m <= n2). +Proof. +wlog le_n21: n1 n2 / n2 <= n1. + by case/orP: (leq_total n2 n1) => ?; last rewrite minnC andbC; auto. +by rewrite /minn ltnNge le_n21 /= andbC; case: leqP => // /leq_trans->. +Qed. + +Lemma gtn_min m n1 n2 : (m > minn n1 n2) = (m > n1) || (m > n2). +Proof. by rewrite !ltnNge leq_min negb_and. Qed. + +Lemma geq_min m n1 n2 : (m >= minn n1 n2) = (m >= n1) || (m >= n2). +Proof. by rewrite -ltnS gtn_min. Qed. + +Lemma geq_minl m n : minn m n <= m. Proof. by rewrite geq_min leqnn. Qed. +Lemma geq_minr m n : minn m n <= n. Proof. by rewrite minnC geq_minl. Qed. + +Lemma addn_minr : right_distributive addn minn. +Proof. by move=> m1 m2 n; rewrite !minnE subnDl addnBA ?leq_subr. Qed. + +Lemma addn_minl : left_distributive addn minn. +Proof. by move=> m1 m2 n; rewrite -!(addnC n) addn_minr. Qed. + +Lemma minnSS m n : minn m.+1 n.+1 = (minn m n).+1. +Proof. by rewrite -(addn_minr 1). Qed. + +(* Quasi-cancellation (really, absorption) lemmas *) +Lemma maxnK m n : minn (maxn m n) m = m. +Proof. exact/minn_idPr/leq_maxl. Qed. + +Lemma maxKn m n : minn n (maxn m n) = n. +Proof. exact/minn_idPl/leq_maxr. Qed. + +Lemma minnK m n : maxn (minn m n) m = m. +Proof. exact/maxn_idPr/geq_minl. Qed. + +Lemma minKn m n : maxn n (minn m n) = n. +Proof. exact/maxn_idPl/geq_minr. Qed. + +(* Distributivity. *) +Lemma maxn_minl : left_distributive maxn minn. +Proof. +move=> m1 m2 n; wlog le_m21: m1 m2 / m2 <= m1. + move=> IH; case/orP: (leq_total m2 m1) => /IH //. + by rewrite minnC [in R in _ = R]minnC. +rewrite (minn_idPr le_m21); apply/esym/minn_idPr. +by rewrite geq_max leq_maxr leq_max le_m21. +Qed. + +Lemma maxn_minr : right_distributive maxn minn. +Proof. by move=> m n1 n2; rewrite !(maxnC m) maxn_minl. Qed. + +Lemma minn_maxl : left_distributive minn maxn. +Proof. +by move=> m1 m2 n; rewrite maxn_minr !maxn_minl -minnA maxnn (maxnC _ n) !maxnK. +Qed. + +Lemma minn_maxr : right_distributive minn maxn. +Proof. by move=> m n1 n2; rewrite !(minnC m) minn_maxl. Qed. + +(* Getting a concrete value from an abstract existence proof. *) + +Section ExMinn. + +Variable P : pred nat. +Hypothesis exP : exists n, P n. + +Inductive acc_nat i : Prop := AccNat0 of P i | AccNatS of acc_nat i.+1. + +Lemma find_ex_minn : {m | P m & forall n, P n -> n >= m}. +Proof. +have: forall n, P n -> n >= 0 by []. +have: acc_nat 0. + case exP => n; rewrite -(addn0 n); elim: n 0 => [|n IHn] j; first by left. + rewrite addSnnS; right; exact: IHn. +move: 0; fix 2 => m IHm m_lb; case Pm: (P m); first by exists m. +apply: find_ex_minn m.+1 _ _ => [|n Pn]; first by case: IHm; rewrite ?Pm. +by rewrite ltn_neqAle m_lb //; case: eqP Pm => // -> /idP[]. +Qed. + +Definition ex_minn := s2val find_ex_minn. + +Inductive ex_minn_spec : nat -> Type := + ExMinnSpec m of P m & (forall n, P n -> n >= m) : ex_minn_spec m. + +Lemma ex_minnP : ex_minn_spec ex_minn. +Proof. by rewrite /ex_minn; case: find_ex_minn. Qed. + +End ExMinn. + +Section ExMaxn. + +Variables (P : pred nat) (m : nat). +Hypotheses (exP : exists i, P i) (ubP : forall i, P i -> i <= m). + +Lemma ex_maxn_subproof : exists i, P (m - i). +Proof. by case: exP => i Pi; exists (m - i); rewrite subKn ?ubP. Qed. + +Definition ex_maxn := m - ex_minn ex_maxn_subproof. + +CoInductive ex_maxn_spec : nat -> Type := + ExMaxnSpec i of P i & (forall j, P j -> j <= i) : ex_maxn_spec i. + +Lemma ex_maxnP : ex_maxn_spec ex_maxn. +Proof. +rewrite /ex_maxn; case: ex_minnP => i Pmi min_i; split=> // j Pj. +have le_i_mj: i <= m - j by rewrite min_i // subKn // ubP. +rewrite -subn_eq0 subnBA ?(leq_trans le_i_mj) ?leq_subr //. +by rewrite addnC -subnBA ?ubP. +Qed. + +End ExMaxn. + +Lemma eq_ex_minn P Q exP exQ : P =1 Q -> @ex_minn P exP = @ex_minn Q exQ. +Proof. +move=> eqPQ; case: ex_minnP => m1 Pm1 m1_lb; case: ex_minnP => m2 Pm2 m2_lb. +by apply/eqP; rewrite eqn_leq m1_lb (m2_lb, eqPQ) // -eqPQ. +Qed. + +Lemma eq_ex_maxn (P Q : pred nat) m n exP ubP exQ ubQ : + P =1 Q -> @ex_maxn P m exP ubP = @ex_maxn Q n exQ ubQ. +Proof. +move=> eqPQ; case: ex_maxnP => i Pi max_i; case: ex_maxnP => j Pj max_j. +by apply/eqP; rewrite eqn_leq max_i ?eqPQ // max_j -?eqPQ. +Qed. + +Section Iteration. + +Variable T : Type. +Implicit Types m n : nat. +Implicit Types x y : T. + +Definition iter n f x := + let fix loop m := if m is i.+1 then f (loop i) else x in loop n. + +Definition iteri n f x := + let fix loop m := if m is i.+1 then f i (loop i) else x in loop n. + +Definition iterop n op x := + let f i y := if i is 0 then x else op x y in iteri n f. + +Lemma iterSr n f x : iter n.+1 f x = iter n f (f x). +Proof. by elim: n => //= n <-. Qed. + +Lemma iterS n f x : iter n.+1 f x = f (iter n f x). Proof. by []. Qed. + +Lemma iter_add n m f x : iter (n + m) f x = iter n f (iter m f x). +Proof. by elim: n => //= n ->. Qed. + +Lemma iteriS n f x : iteri n.+1 f x = f n (iteri n f x). +Proof. by []. Qed. + +Lemma iteropS idx n op x : iterop n.+1 op x idx = iter n (op x) x. +Proof. by elim: n => //= n ->. Qed. + +Lemma eq_iter f f' : f =1 f' -> forall n, iter n f =1 iter n f'. +Proof. by move=> eq_f n x; elim: n => //= n ->; rewrite eq_f. Qed. + +Lemma eq_iteri f f' : f =2 f' -> forall n, iteri n f =1 iteri n f'. +Proof. by move=> eq_f n x; elim: n => //= n ->; rewrite eq_f. Qed. + +Lemma eq_iterop n op op' : op =2 op' -> iterop n op =2 iterop n op'. +Proof. by move=> eq_op x; apply: eq_iteri; case. Qed. + +End Iteration. + +Lemma iter_succn m n : iter n succn m = m + n. +Proof. by elim: n => //= n ->. Qed. + +Lemma iter_succn_0 n : iter n succn 0 = n. +Proof. exact: iter_succn. Qed. + +Lemma iter_predn m n : iter n predn m = m - n. +Proof. by elim: n m => /= [|n IHn] m; rewrite ?subn0 // IHn subnS. Qed. + +(* Multiplication. *) + +Definition muln_rec := mult. +Notation "m * n" := (muln_rec m n) : nat_rec_scope. + +Definition muln := nosimpl muln_rec. +Notation "m * n" := (muln m n) : nat_scope. + +Lemma multE : mult = muln. Proof. by []. Qed. +Lemma mulnE : muln = muln_rec. Proof. by []. Qed. + +Lemma mul0n : left_zero 0 muln. Proof. by []. Qed. +Lemma muln0 : right_zero 0 muln. Proof. by elim. Qed. +Lemma mul1n : left_id 1 muln. Proof. exact: addn0. Qed. +Lemma mulSn m n : m.+1 * n = n + m * n. Proof. by []. Qed. +Lemma mulSnr m n : m.+1 * n = m * n + n. Proof. exact: addnC. Qed. + +Lemma mulnS m n : m * n.+1 = m + m * n. +Proof. by elim: m => // m; rewrite !mulSn !addSn addnCA => ->. Qed. +Lemma mulnSr m n : m * n.+1 = m * n + m. +Proof. by rewrite addnC mulnS. Qed. + +Lemma iter_addn m n p : iter n (addn m) p = m * n + p. +Proof. by elim: n => /= [|n ->]; rewrite ?muln0 // mulnS addnA. Qed. + +Lemma iter_addn_0 m n : iter n (addn m) 0 = m * n. +Proof. by rewrite iter_addn addn0. Qed. + +Lemma muln1 : right_id 1 muln. +Proof. by move=> n; rewrite mulnSr muln0. Qed. + +Lemma mulnC : commutative muln. +Proof. +by move=> m n; elim: m => [|m]; rewrite (muln0, mulnS) // mulSn => ->. +Qed. + +Lemma mulnDl : left_distributive muln addn. +Proof. by move=> m1 m2 n; elim: m1 => //= m1 IHm; rewrite -addnA -IHm. Qed. + +Lemma mulnDr : right_distributive muln addn. +Proof. by move=> m n1 n2; rewrite !(mulnC m) mulnDl. Qed. + +Lemma mulnBl : left_distributive muln subn. +Proof. +move=> m n [|p]; first by rewrite !muln0. +by elim: m n => // [m IHm] [|n] //; rewrite mulSn subnDl -IHm. +Qed. + +Lemma mulnBr : right_distributive muln subn. +Proof. by move=> m n p; rewrite !(mulnC m) mulnBl. Qed. + +Lemma mulnA : associative muln. +Proof. by move=> m n p; elim: m => //= m; rewrite mulSn mulnDl => ->. Qed. + +Lemma mulnCA : left_commutative muln. +Proof. by move=> m n1 n2; rewrite !mulnA (mulnC m). Qed. + +Lemma mulnAC : right_commutative muln. +Proof. by move=> m n p; rewrite -!mulnA (mulnC n). Qed. + +Lemma mulnACA : interchange muln muln. +Proof. by move=> m n p q; rewrite -!mulnA (mulnCA n). Qed. + +Lemma muln_eq0 m n : (m * n == 0) = (m == 0) || (n == 0). +Proof. by case: m n => // m [|n] //=; rewrite muln0. Qed. + +Lemma muln_eq1 m n : (m * n == 1) = (m == 1) && (n == 1). +Proof. by case: m n => [|[|m]] [|[|n]] //; rewrite muln0. Qed. + +Lemma muln_gt0 m n : (0 < m * n) = (0 < m) && (0 < n). +Proof. by case: m n => // m [|n] //=; rewrite muln0. Qed. + +Lemma leq_pmull m n : n > 0 -> m <= n * m. +Proof. by move/prednK <-; exact: leq_addr. Qed. + +Lemma leq_pmulr m n : n > 0 -> m <= m * n. +Proof. by move/leq_pmull; rewrite mulnC. Qed. + +Lemma leq_mul2l m n1 n2 : (m * n1 <= m * n2) = (m == 0) || (n1 <= n2). +Proof. by rewrite {1}/leq -mulnBr muln_eq0. Qed. + +Lemma leq_mul2r m n1 n2 : (n1 * m <= n2 * m) = (m == 0) || (n1 <= n2). +Proof. by rewrite -!(mulnC m) leq_mul2l. Qed. + +Lemma leq_mul m1 m2 n1 n2 : m1 <= n1 -> m2 <= n2 -> m1 * m2 <= n1 * n2. +Proof. +move=> le_mn1 le_mn2; apply (@leq_trans (m1 * n2)). + by rewrite leq_mul2l le_mn2 orbT. +by rewrite leq_mul2r le_mn1 orbT. +Qed. + +Lemma eqn_mul2l m n1 n2 : (m * n1 == m * n2) = (m == 0) || (n1 == n2). +Proof. by rewrite eqn_leq !leq_mul2l -orb_andr -eqn_leq. Qed. + +Lemma eqn_mul2r m n1 n2 : (n1 * m == n2 * m) = (m == 0) || (n1 == n2). +Proof. by rewrite eqn_leq !leq_mul2r -orb_andr -eqn_leq. Qed. + +Lemma leq_pmul2l m n1 n2 : 0 < m -> (m * n1 <= m * n2) = (n1 <= n2). +Proof. by move/prednK=> <-; rewrite leq_mul2l. Qed. +Implicit Arguments leq_pmul2l [m n1 n2]. + +Lemma leq_pmul2r m n1 n2 : 0 < m -> (n1 * m <= n2 * m) = (n1 <= n2). +Proof. by move/prednK <-; rewrite leq_mul2r. Qed. +Implicit Arguments leq_pmul2r [m n1 n2]. + +Lemma eqn_pmul2l m n1 n2 : 0 < m -> (m * n1 == m * n2) = (n1 == n2). +Proof. by move/prednK <-; rewrite eqn_mul2l. Qed. +Implicit Arguments eqn_pmul2l [m n1 n2]. + +Lemma eqn_pmul2r m n1 n2 : 0 < m -> (n1 * m == n2 * m) = (n1 == n2). +Proof. by move/prednK <-; rewrite eqn_mul2r. Qed. +Implicit Arguments eqn_pmul2r [m n1 n2]. + +Lemma ltn_mul2l m n1 n2 : (m * n1 < m * n2) = (0 < m) && (n1 < n2). +Proof. by rewrite lt0n !ltnNge leq_mul2l negb_or. Qed. + +Lemma ltn_mul2r m n1 n2 : (n1 * m < n2 * m) = (0 < m) && (n1 < n2). +Proof. by rewrite lt0n !ltnNge leq_mul2r negb_or. Qed. + +Lemma ltn_pmul2l m n1 n2 : 0 < m -> (m * n1 < m * n2) = (n1 < n2). +Proof. by move/prednK <-; rewrite ltn_mul2l. Qed. +Implicit Arguments ltn_pmul2l [m n1 n2]. + +Lemma ltn_pmul2r m n1 n2 : 0 < m -> (n1 * m < n2 * m) = (n1 < n2). +Proof. by move/prednK <-; rewrite ltn_mul2r. Qed. +Implicit Arguments ltn_pmul2r [m n1 n2]. + +Lemma ltn_Pmull m n : 1 < n -> 0 < m -> m < n * m. +Proof. by move=> lt1n m_gt0; rewrite -{1}[m]mul1n ltn_pmul2r. Qed. + +Lemma ltn_Pmulr m n : 1 < n -> 0 < m -> m < m * n. +Proof. by move=> lt1n m_gt0; rewrite mulnC ltn_Pmull. Qed. + +Lemma ltn_mul m1 m2 n1 n2 : m1 < n1 -> m2 < n2 -> m1 * m2 < n1 * n2. +Proof. +move=> lt_mn1 lt_mn2; apply (@leq_ltn_trans (m1 * n2)). + by rewrite leq_mul2l orbC ltnW. +by rewrite ltn_pmul2r // (leq_trans _ lt_mn2). +Qed. + +Lemma maxn_mulr : right_distributive muln maxn. +Proof. by case=> // m n1 n2; rewrite /maxn (fun_if (muln _)) ltn_pmul2l. Qed. + +Lemma maxn_mull : left_distributive muln maxn. +Proof. by move=> m1 m2 n; rewrite -!(mulnC n) maxn_mulr. Qed. + +Lemma minn_mulr : right_distributive muln minn. +Proof. by case=> // m n1 n2; rewrite /minn (fun_if (muln _)) ltn_pmul2l. Qed. + +Lemma minn_mull : left_distributive muln minn. +Proof. by move=> m1 m2 n; rewrite -!(mulnC n) minn_mulr. Qed. + +(* Exponentiation. *) + +Definition expn_rec m n := iterop n muln m 1. +Notation "m ^ n" := (expn_rec m n) : nat_rec_scope. +Definition expn := nosimpl expn_rec. +Notation "m ^ n" := (expn m n) : nat_scope. + +Lemma expnE : expn = expn_rec. Proof. by []. Qed. + +Lemma expn0 m : m ^ 0 = 1. Proof. by []. Qed. +Lemma expn1 m : m ^ 1 = m. Proof. by []. Qed. +Lemma expnS m n : m ^ n.+1 = m * m ^ n. Proof. by case: n; rewrite ?muln1. Qed. +Lemma expnSr m n : m ^ n.+1 = m ^ n * m. Proof. by rewrite mulnC expnS. Qed. + +Lemma iter_muln m n p : iter n (muln m) p = m ^ n * p. +Proof. by elim: n => /= [|n ->]; rewrite ?mul1n // expnS mulnA. Qed. + +Lemma iter_muln_1 m n : iter n (muln m) 1 = m ^ n. +Proof. by rewrite iter_muln muln1. Qed. + +Lemma exp0n n : 0 < n -> 0 ^ n = 0. Proof. by case: n => [|[]]. Qed. + +Lemma exp1n n : 1 ^ n = 1. +Proof. by elim: n => // n; rewrite expnS mul1n. Qed. + +Lemma expnD m n1 n2 : m ^ (n1 + n2) = m ^ n1 * m ^ n2. +Proof. by elim: n1 => [|n1 IHn]; rewrite !(mul1n, expnS) // IHn mulnA. Qed. + +Lemma expnMn m1 m2 n : (m1 * m2) ^ n = m1 ^ n * m2 ^ n. +Proof. by elim: n => // n IHn; rewrite !expnS IHn -!mulnA (mulnCA m2). Qed. + +Lemma expnM m n1 n2 : m ^ (n1 * n2) = (m ^ n1) ^ n2. +Proof. +elim: n1 => [|n1 IHn]; first by rewrite exp1n. +by rewrite expnD expnS expnMn IHn. +Qed. + +Lemma expnAC m n1 n2 : (m ^ n1) ^ n2 = (m ^ n2) ^ n1. +Proof. by rewrite -!expnM mulnC. Qed. + +Lemma expn_gt0 m n : (0 < m ^ n) = (0 < m) || (n == 0). +Proof. +by case: m => [|m]; elim: n => //= n IHn; rewrite expnS // addn_gt0 IHn. +Qed. + +Lemma expn_eq0 m e : (m ^ e == 0) = (m == 0) && (e > 0). +Proof. by rewrite !eqn0Ngt expn_gt0 negb_or -lt0n. Qed. + +Lemma ltn_expl m n : 1 < m -> n < m ^ n. +Proof. +move=> m_gt1; elim: n => //= n; rewrite -(leq_pmul2l (ltnW m_gt1)) expnS. +by apply: leq_trans; exact: ltn_Pmull. +Qed. + +Lemma leq_exp2l m n1 n2 : 1 < m -> (m ^ n1 <= m ^ n2) = (n1 <= n2). +Proof. +move=> m_gt1; elim: n1 n2 => [|n1 IHn] [|n2] //; last 1 first. +- by rewrite !expnS leq_pmul2l ?IHn // ltnW. +- by rewrite expn_gt0 ltnW. +by rewrite leqNgt (leq_trans m_gt1) // expnS leq_pmulr // expn_gt0 ltnW. +Qed. + +Lemma ltn_exp2l m n1 n2 : 1 < m -> (m ^ n1 < m ^ n2) = (n1 < n2). +Proof. by move=> m_gt1; rewrite !ltnNge leq_exp2l. Qed. + +Lemma eqn_exp2l m n1 n2 : 1 < m -> (m ^ n1 == m ^ n2) = (n1 == n2). +Proof. by move=> m_gt1; rewrite !eqn_leq !leq_exp2l. Qed. + +Lemma expnI m : 1 < m -> injective (expn m). +Proof. by move=> m_gt1 e1 e2 /eqP; rewrite eqn_exp2l // => /eqP. Qed. + +Lemma leq_pexp2l m n1 n2 : 0 < m -> n1 <= n2 -> m ^ n1 <= m ^ n2. +Proof. by case: m => [|[|m]] // _; [rewrite !exp1n | rewrite leq_exp2l]. Qed. + +Lemma ltn_pexp2l m n1 n2 : 0 < m -> m ^ n1 < m ^ n2 -> n1 < n2. +Proof. by case: m => [|[|m]] // _; [rewrite !exp1n | rewrite ltn_exp2l]. Qed. + +Lemma ltn_exp2r m n e : e > 0 -> (m ^ e < n ^ e) = (m < n). +Proof. +move=> e_gt0; apply/idP/idP=> [|ltmn]. + rewrite !ltnNge; apply: contra => lemn. + by elim: e {e_gt0} => // e IHe; rewrite !expnS leq_mul. +by elim: e e_gt0 => // [[|e] IHe] _; rewrite ?expn1 // ltn_mul // IHe. +Qed. + +Lemma leq_exp2r m n e : e > 0 -> (m ^ e <= n ^ e) = (m <= n). +Proof. by move=> e_gt0; rewrite leqNgt ltn_exp2r // -leqNgt. Qed. + +Lemma eqn_exp2r m n e : e > 0 -> (m ^ e == n ^ e) = (m == n). +Proof. by move=> e_gt0; rewrite !eqn_leq !leq_exp2r. Qed. + +Lemma expIn e : e > 0 -> injective (expn^~ e). +Proof. by move=> e_gt1 m n /eqP; rewrite eqn_exp2r // => /eqP. Qed. + +(* Factorial. *) + +Fixpoint fact_rec n := if n is n'.+1 then n * fact_rec n' else 1. + +Definition factorial := nosimpl fact_rec. + +Notation "n `!" := (factorial n) (at level 2, format "n `!") : nat_scope. + +Lemma factE : factorial = fact_rec. Proof. by []. Qed. + +Lemma fact0 : 0`! = 1. Proof. by []. Qed. + +Lemma factS n : (n.+1)`! = n.+1 * n`!. Proof. by []. Qed. + +Lemma fact_gt0 n : n`! > 0. +Proof. by elim: n => //= n IHn; rewrite muln_gt0. Qed. + +(* Parity and bits. *) + +Coercion nat_of_bool (b : bool) := if b then 1 else 0. + +Lemma leq_b1 (b : bool) : b <= 1. Proof. by case: b. Qed. + +Lemma addn_negb (b : bool) : ~~ b + b = 1. Proof. by case: b. Qed. + +Lemma eqb0 (b : bool) : (b == 0 :> nat) = ~~ b. Proof. by case: b. Qed. + +Lemma eqb1 (b : bool) : (b == 1 :> nat) = b. Proof. by case: b. Qed. + +Lemma lt0b (b : bool) : (b > 0) = b. Proof. by case: b. Qed. + +Lemma sub1b (b : bool) : 1 - b = ~~ b. Proof. by case: b. Qed. + +Lemma mulnb (b1 b2 : bool) : b1 * b2 = b1 && b2. +Proof. by case: b1; case: b2. Qed. + +Lemma mulnbl (b : bool) n : b * n = (if b then n else 0). +Proof. by case: b; rewrite ?mul1n. Qed. + +Lemma mulnbr (b : bool) n : n * b = (if b then n else 0). +Proof. by rewrite mulnC mulnbl. Qed. + +Fixpoint odd n := if n is n'.+1 then ~~ odd n' else false. + +Lemma oddb (b : bool) : odd b = b. Proof. by case: b. Qed. + +Lemma odd_add m n : odd (m + n) = odd m (+) odd n. +Proof. by elim: m => [|m IHn] //=; rewrite -addTb IHn addbA addTb. Qed. + +Lemma odd_sub m n : n <= m -> odd (m - n) = odd m (+) odd n. +Proof. +by move=> le_nm; apply: (@canRL bool) (addbK _) _; rewrite -odd_add subnK. +Qed. + +Lemma odd_opp i m : odd m = false -> i < m -> odd (m - i) = odd i. +Proof. by move=> oddm lt_im; rewrite (odd_sub (ltnW lt_im)) oddm. Qed. + +Lemma odd_mul m n : odd (m * n) = odd m && odd n. +Proof. by elim: m => //= m IHm; rewrite odd_add -addTb andb_addl -IHm. Qed. + +Lemma odd_exp m n : odd (m ^ n) = (n == 0) || odd m. +Proof. by elim: n => // n IHn; rewrite expnS odd_mul {}IHn orbC; case odd. Qed. + +(* Doubling. *) + +Fixpoint double_rec n := if n is n'.+1 then n'.*2%Nrec.+2 else 0 +where "n .*2" := (double_rec n) : nat_rec_scope. + +Definition double := nosimpl double_rec. +Notation "n .*2" := (double n) : nat_scope. + +Lemma doubleE : double = double_rec. Proof. by []. Qed. + +Lemma double0 : 0.*2 = 0. Proof. by []. Qed. + +Lemma doubleS n : n.+1.*2 = n.*2.+2. Proof. by []. Qed. + +Lemma addnn n : n + n = n.*2. +Proof. by apply: eqP; elim: n => // n IHn; rewrite addnS. Qed. + +Lemma mul2n m : 2 * m = m.*2. +Proof. by rewrite mulSn mul1n addnn. Qed. + +Lemma muln2 m : m * 2 = m.*2. +Proof. by rewrite mulnC mul2n. Qed. + +Lemma doubleD m n : (m + n).*2 = m.*2 + n.*2. +Proof. by rewrite -!addnn -!addnA (addnCA n). Qed. + +Lemma doubleB m n : (m - n).*2 = m.*2 - n.*2. +Proof. elim: m n => [|m IHm] [|n] //; exact: IHm n. Qed. + +Lemma leq_double m n : (m.*2 <= n.*2) = (m <= n). +Proof. by rewrite /leq -doubleB; case (m - n). Qed. + +Lemma ltn_double m n : (m.*2 < n.*2) = (m < n). +Proof. by rewrite 2!ltnNge leq_double. Qed. + +Lemma ltn_Sdouble m n : (m.*2.+1 < n.*2) = (m < n). +Proof. by rewrite -doubleS leq_double. Qed. + +Lemma leq_Sdouble m n : (m.*2 <= n.*2.+1) = (m <= n). +Proof. by rewrite leqNgt ltn_Sdouble -leqNgt. Qed. + +Lemma odd_double n : odd n.*2 = false. +Proof. by rewrite -addnn odd_add addbb. Qed. + +Lemma double_gt0 n : (0 < n.*2) = (0 < n). +Proof. by case: n. Qed. + +Lemma double_eq0 n : (n.*2 == 0) = (n == 0). +Proof. by case: n. Qed. + +Lemma doubleMl m n : (m * n).*2 = m.*2 * n. +Proof. by rewrite -!mul2n mulnA. Qed. + +Lemma doubleMr m n : (m * n).*2 = m * n.*2. +Proof. by rewrite -!muln2 mulnA. Qed. + +(* Halving. *) + +Fixpoint half (n : nat) : nat := if n is n'.+1 then uphalf n' else n +with uphalf (n : nat) : nat := if n is n'.+1 then n'./2.+1 else n +where "n ./2" := (half n) : nat_scope. + +Lemma doubleK : cancel double half. +Proof. by elim=> //= n ->. Qed. + +Definition half_double := doubleK. +Definition double_inj := can_inj doubleK. + +Lemma uphalf_double n : uphalf n.*2 = n. +Proof. by elim: n => //= n ->. Qed. + +Lemma uphalf_half n : uphalf n = odd n + n./2. +Proof. by elim: n => //= n ->; rewrite addnA addn_negb. Qed. + +Lemma odd_double_half n : odd n + n./2.*2 = n. +Proof. +by elim: n => //= n {3}<-; rewrite uphalf_half doubleD; case (odd n). +Qed. + +Lemma half_bit_double n (b : bool) : (b + n.*2)./2 = n. +Proof. by case: b; rewrite /= (half_double, uphalf_double). Qed. + +Lemma halfD m n : (m + n)./2 = (odd m && odd n) + (m./2 + n./2). +Proof. +rewrite -{1}[n]odd_double_half addnCA -{1}[m]odd_double_half -addnA -doubleD. +by do 2!case: odd; rewrite /= ?add0n ?half_double ?uphalf_double. +Qed. + +Lemma half_leq m n : m <= n -> m./2 <= n./2. +Proof. by move/subnK <-; rewrite halfD addnA leq_addl. Qed. + +Lemma half_gt0 n : (0 < n./2) = (1 < n). +Proof. by case: n => [|[]]. Qed. + +Lemma odd_geq m n : odd n -> (m <= n) = (m./2.*2 <= n). +Proof. +move=> odd_n; rewrite -{1}[m]odd_double_half -[n]odd_double_half odd_n. +by case: (odd m); rewrite // leq_Sdouble ltnS leq_double. +Qed. + +Lemma odd_ltn m n : odd n -> (n < m) = (n < m./2.*2). +Proof. by move=> odd_n; rewrite !ltnNge odd_geq. Qed. + +Lemma odd_gt0 n : odd n -> n > 0. Proof. by case: n. Qed. + +Lemma odd_gt2 n : odd n -> n > 1 -> n > 2. +Proof. by move=> odd_n n_gt1; rewrite odd_geq. Qed. + +(* Squares and square identities. *) + +Lemma mulnn m : m * m = m ^ 2. +Proof. by rewrite !expnS muln1. Qed. + +Lemma sqrnD m n : (m + n) ^ 2 = m ^ 2 + n ^ 2 + 2 * (m * n). +Proof. +rewrite -!mulnn mul2n mulnDr !mulnDl (mulnC n) -!addnA. +by congr (_ + _); rewrite addnA addnn addnC. +Qed. + +Lemma sqrn_sub m n : n <= m -> (m - n) ^ 2 = m ^ 2 + n ^ 2 - 2 * (m * n). +Proof. +move/subnK=> def_m; rewrite -{2}def_m sqrnD -addnA addnAC. +by rewrite -2!addnA addnn -mul2n -mulnDr -mulnDl def_m addnK. +Qed. + +Lemma sqrnD_sub m n : n <= m -> (m + n) ^ 2 - 4 * (m * n) = (m - n) ^ 2. +Proof. +move=> le_nm; rewrite -[4]/(2 * 2) -mulnA mul2n -addnn subnDA. +by rewrite sqrnD addnK sqrn_sub. +Qed. + +Lemma subn_sqr m n : m ^ 2 - n ^ 2 = (m - n) * (m + n). +Proof. by rewrite mulnBl !mulnDr addnC (mulnC m) subnDl !mulnn. Qed. + +Lemma ltn_sqr m n : (m ^ 2 < n ^ 2) = (m < n). +Proof. by rewrite ltn_exp2r. Qed. + +Lemma leq_sqr m n : (m ^ 2 <= n ^ 2) = (m <= n). +Proof. by rewrite leq_exp2r. Qed. + +Lemma sqrn_gt0 n : (0 < n ^ 2) = (0 < n). +Proof. exact: (ltn_sqr 0). Qed. + +Lemma eqn_sqr m n : (m ^ 2 == n ^ 2) = (m == n). +Proof. by rewrite eqn_exp2r. Qed. + +Lemma sqrn_inj : injective (expn ^~ 2). +Proof. exact: expIn. Qed. + +(* Almost strict inequality: an inequality that is strict unless some *) +(* specific condition holds, such as the Cauchy-Schwartz or the AGM *) +(* inequality (we only prove the order-2 AGM here; the general one *) +(* requires sequences). *) +(* We formalize the concept as a rewrite multirule, that can be used *) +(* both to rewrite the non-strict inequality to true, and the equality *) +(* to the specific condition (for strict inequalities use the ltn_neqAle *) +(* lemma); in addition, the conditional equality also coerces to a *) +(* non-strict one. *) + +Definition leqif m n C := ((m <= n) * ((m == n) = C))%type. + +Notation "m <= n ?= 'iff' C" := (leqif m n C) : nat_scope. + +Coercion leq_of_leqif m n C (H : m <= n ?= iff C) := H.1 : m <= n. + +Lemma leqifP m n C : reflect (m <= n ?= iff C) (if C then m == n else m < n). +Proof. +rewrite ltn_neqAle; apply: (iffP idP) => [|lte]; last by rewrite !lte; case C. +by case C => [/eqP-> | /andP[/negPf]]; split=> //; exact: eqxx. +Qed. + +Lemma leqif_refl m C : reflect (m <= m ?= iff C) C. +Proof. by apply: (iffP idP) => [-> | <-] //; split; rewrite ?eqxx. Qed. + +Lemma leqif_trans m1 m2 m3 C12 C23 : + m1 <= m2 ?= iff C12 -> m2 <= m3 ?= iff C23 -> m1 <= m3 ?= iff C12 && C23. +Proof. +move=> ltm12 ltm23; apply/leqifP; rewrite -ltm12. +case eqm12: (m1 == m2). + by rewrite (eqP eqm12) ltn_neqAle !ltm23 andbT; case C23. +by rewrite (@leq_trans m2) ?ltm23 // ltn_neqAle eqm12 ltm12. +Qed. + +Lemma mono_leqif f : {mono f : m n / m <= n} -> + forall m n C, (f m <= f n ?= iff C) = (m <= n ?= iff C). +Proof. by move=> f_mono m n C; rewrite /leqif !eqn_leq !f_mono. Qed. + +Lemma leqif_geq m n : m <= n -> m <= n ?= iff (m >= n). +Proof. by move=> lemn; split=> //; rewrite eqn_leq lemn. Qed. + +Lemma leqif_eq m n : m <= n -> m <= n ?= iff (m == n). +Proof. by []. Qed. + +Lemma geq_leqif a b C : a <= b ?= iff C -> (b <= a) = C. +Proof. by case=> le_ab; rewrite eqn_leq le_ab. Qed. + +Lemma ltn_leqif a b C : a <= b ?= iff C -> (a < b) = ~~ C. +Proof. by move=> le_ab; rewrite ltnNge (geq_leqif le_ab). Qed. + +Lemma leqif_add m1 n1 C1 m2 n2 C2 : + m1 <= n1 ?= iff C1 -> m2 <= n2 ?= iff C2 -> + m1 + m2 <= n1 + n2 ?= iff C1 && C2. +Proof. +rewrite -(mono_leqif (leq_add2r m2)) -(mono_leqif (leq_add2l n1) m2). +exact: leqif_trans. +Qed. + +Lemma leqif_mul m1 n1 C1 m2 n2 C2 : + m1 <= n1 ?= iff C1 -> m2 <= n2 ?= iff C2 -> + m1 * m2 <= n1 * n2 ?= iff (n1 * n2 == 0) || (C1 && C2). +Proof. +move=> le1 le2; case: posnP => [n12_0 | ]. + rewrite n12_0; move/eqP: n12_0 {le1 le2}le1.1 le2.1; rewrite muln_eq0. + by case/orP=> /eqP->; case: m1 m2 => [|m1] [|m2] // _ _; + rewrite ?muln0; exact/leqif_refl. +rewrite muln_gt0 => /andP[n1_gt0 n2_gt0]. +have [m2_0 | m2_gt0] := posnP m2. + apply/leqifP; rewrite -le2 andbC eq_sym eqn_leq leqNgt m2_0 muln0. + by rewrite muln_gt0 n1_gt0 n2_gt0. +have mono_n1 := leq_pmul2l n1_gt0; have mono_m2 := leq_pmul2r m2_gt0. +rewrite -(mono_leqif mono_m2) in le1; rewrite -(mono_leqif mono_n1) in le2. +exact: leqif_trans le1 le2. +Qed. + +Lemma nat_Cauchy m n : 2 * (m * n) <= m ^ 2 + n ^ 2 ?= iff (m == n). +Proof. +wlog le_nm: m n / n <= m. + by case: (leqP m n); auto; rewrite eq_sym addnC (mulnC m); auto. +apply/leqifP; case: ifP => [/eqP-> | ne_mn]; first by rewrite mulnn addnn mul2n. +by rewrite -subn_gt0 -sqrn_sub // sqrn_gt0 subn_gt0 ltn_neqAle eq_sym ne_mn. +Qed. + +Lemma nat_AGM2 m n : 4 * (m * n) <= (m + n) ^ 2 ?= iff (m == n). +Proof. +rewrite -[4]/(2 * 2) -mulnA mul2n -addnn sqrnD; apply/leqifP. +by rewrite ltn_add2r eqn_add2r ltn_neqAle !nat_Cauchy; case: ifP => ->. +Qed. + +(* Support for larger integers. The normal definitions of +, - and even *) +(* IO are unsuitable for Peano integers larger than 2000 or so because *) +(* they are not tail-recursive. We provide a workaround module, along *) +(* with a rewrite multirule to change the tailrec operators to the *) +(* normal ones. We handle IO via the NatBin module, but provide our *) +(* own (more efficient) conversion functions. *) + +Module NatTrec. + +(* Usage: *) +(* Import NatTrec. *) +(* in section definining functions, rebinds all *) +(* non-tail recursive operators. *) +(* rewrite !trecE. *) +(* in the correctness proof, restores operators *) + +Fixpoint add m n := if m is m'.+1 then m' + n.+1 else n +where "n + m" := (add n m) : nat_scope. + +Fixpoint add_mul m n s := if m is m'.+1 then add_mul m' n (n + s) else s. + +Definition mul m n := if m is m'.+1 then add_mul m' n n else 0. + +Notation "n * m" := (mul n m) : nat_scope. + +Fixpoint mul_exp m n p := if n is n'.+1 then mul_exp m n' (m * p) else p. + +Definition exp m n := if n is n'.+1 then mul_exp m n' m else 1. + +Notation "n ^ m" := (exp n m) : nat_scope. + +Notation Local oddn := odd. +Fixpoint odd n := if n is n'.+2 then odd n' else eqn n 1. + +Notation Local doublen := double. +Definition double n := if n is n'.+1 then n' + n.+1 else 0. +Notation "n .*2" := (double n) : nat_scope. + +Lemma addE : add =2 addn. +Proof. by elim=> //= n IHn m; rewrite IHn addSnnS. Qed. + +Lemma doubleE : double =1 doublen. +Proof. by case=> // n; rewrite -addnn -addE. Qed. + +Lemma add_mulE n m s : add_mul n m s = addn (muln n m) s. +Proof. by elim: n => //= n IHn in m s *; rewrite IHn addE addnCA addnA. Qed. + +Lemma mulE : mul =2 muln. +Proof. by case=> //= n m; rewrite add_mulE addnC. Qed. + +Lemma mul_expE m n p : mul_exp m n p = muln (expn m n) p. +Proof. +by elim: n => [|n IHn] in p *; rewrite ?mul1n //= expnS IHn mulE mulnCA mulnA. +Qed. + +Lemma expE : exp =2 expn. +Proof. by move=> m [|n] //=; rewrite mul_expE expnS mulnC. Qed. + +Lemma oddE : odd =1 oddn. +Proof. +move=> n; rewrite -{1}[n]odd_double_half addnC. +by elim: n./2 => //=; case (oddn n). +Qed. + +Definition trecE := (addE, (doubleE, oddE), (mulE, add_mulE, (expE, mul_expE))). + +End NatTrec. + +Notation natTrecE := NatTrec.trecE. + +Lemma eq_binP : Equality.axiom Ndec.Neqb. +Proof. +move=> p q; apply: (iffP idP) => [|<-]; last by case: p => //; elim. +by case: q; case: p => //; elim=> [p IHp|p IHp|] [q|q|] //=; case/IHp=> ->. +Qed. + +Canonical bin_nat_eqMixin := EqMixin eq_binP. +Canonical bin_nat_eqType := Eval hnf in EqType N bin_nat_eqMixin. + +Section NumberInterpretation. + +Import BinPos. + +Section Trec. + +Import NatTrec. + +Fixpoint nat_of_pos p0 := + match p0 with + | xO p => (nat_of_pos p).*2 + | xI p => (nat_of_pos p).*2.+1 + | xH => 1 + end. + +End Trec. + +Coercion Local nat_of_pos : positive >-> nat. + +Coercion nat_of_bin b := if b is Npos p then p : nat else 0. + +Fixpoint pos_of_nat n0 m0 := + match n0, m0 with + | n.+1, m.+2 => pos_of_nat n m + | n.+1, 1 => xO (pos_of_nat n n) + | n.+1, 0 => xI (pos_of_nat n n) + | 0, _ => xH + end. + +Definition bin_of_nat n0 := if n0 is n.+1 then Npos (pos_of_nat n n) else 0%num. + +Lemma bin_of_natK : cancel bin_of_nat nat_of_bin. +Proof. +have sub2nn n : n.*2 - n = n by rewrite -addnn addKn. +case=> //= n; rewrite -{3}[n]sub2nn. +by elim: n {2 4}n => // m IHm [|[|n]] //=; rewrite IHm // natTrecE sub2nn. +Qed. + +Lemma nat_of_binK : cancel nat_of_bin bin_of_nat. +Proof. +case=> //=; elim=> //= p; case: (nat_of_pos p) => //= n [<-]. + by rewrite natTrecE !addnS {2}addnn; elim: {1 3}n. +by rewrite natTrecE addnS /= addnS {2}addnn; elim: {1 3}n. +Qed. + +Lemma nat_of_succ_gt0 p : Psucc p = p.+1 :> nat. +Proof. by elim: p => //= p ->; rewrite !natTrecE. Qed. + +Lemma nat_of_addn_gt0 p q : (p + q)%positive = p + q :> nat. +Proof. +apply: @fst _ (Pplus_carry p q = (p + q).+1 :> nat) _. +elim: p q => [p IHp|p IHp|] [q|q|] //=; rewrite !natTrecE //; + by rewrite ?IHp ?nat_of_succ_gt0 ?(doubleS, doubleD, addn1, addnS). +Qed. + +Lemma nat_of_add_bin b1 b2 : (b1 + b2)%num = b1 + b2 :> nat. +Proof. case: b1 b2 => [|p] [|q] //=; exact: nat_of_addn_gt0. Qed. + +Lemma nat_of_mul_bin b1 b2 : (b1 * b2)%num = b1 * b2 :> nat. +Proof. +case: b1 b2 => [|p] [|q] //=; elim: p => [p IHp|p IHp|] /=; + by rewrite ?(mul1n, nat_of_addn_gt0, mulSn) //= !natTrecE IHp doubleMl. +Qed. + +Lemma nat_of_exp_bin n (b : N) : n ^ b = pow_N 1 muln n b. +Proof. +case: b => [|p] /=; first exact: expn0. +by elim: p => //= p <-; rewrite natTrecE mulnn -expnM muln2 ?expnS. +Qed. + +End NumberInterpretation. + +(* Big(ger) nat IO; usage: *) +(* Num 1 072 399 *) +(* to create large numbers for test cases *) +(* Eval compute in [Num of some expression] *) +(* to display the resut of an expression that *) +(* returns a larger integer. *) + +Record number : Type := Num {bin_of_number :> N}. + +Definition extend_number (nn : number) m := Num (nn * 1000 + bin_of_nat m). + +Coercion extend_number : number >-> Funclass. + +Canonical number_subType := [newType for bin_of_number]. +Definition number_eqMixin := Eval hnf in [eqMixin of number by <:]. +Canonical number_eqType := Eval hnf in EqType number number_eqMixin. + +Notation "[ 'Num' 'of' e ]" := (Num (bin_of_nat e)) + (at level 0, format "[ 'Num' 'of' e ]") : nat_scope. + +(* Interface to ring/ring_simplify tactics *) + +Lemma nat_semi_ring : semi_ring_theory 0 1 addn muln (@eq _). +Proof. exact: mk_srt add0n addnC addnA mul1n mul0n mulnC mulnA mulnDl. Qed. + +Lemma nat_semi_morph : + semi_morph 0 1 addn muln (@eq _) 0%num 1%num Nplus Nmult pred1 nat_of_bin. +Proof. +by move: nat_of_add_bin nat_of_mul_bin; split=> //= m n; move/eqP->. +Qed. + +Lemma nat_power_theory : power_theory 1 muln (@eq _) nat_of_bin expn. +Proof. split; exact: nat_of_exp_bin. Qed. + +(* Interface to the ring tactic machinery. *) + +Fixpoint pop_succn e := if e is e'.+1 then fun n => pop_succn e' n.+1 else id. + +Ltac pop_succn e := eval lazy beta iota delta [pop_succn] in (pop_succn e 1). + +Ltac nat_litteral e := + match pop_succn e with + | ?n.+1 => constr: (bin_of_nat n) + | _ => NotConstant + end. + +Ltac succn_to_add := + match goal with + | |- context G [?e.+1] => + let x := fresh "NatLit0" in + match pop_succn e with + | ?n.+1 => pose x := n.+1; let G' := context G [x] in change G' + | _ ?e' ?n => pose x := n; let G' := context G [x + e'] in change G' + end; succn_to_add; rewrite {}/x + | _ => idtac + end. + +Add Ring nat_ring_ssr : nat_semi_ring (morphism nat_semi_morph, + constants [nat_litteral], preprocess [succn_to_add], + power_tac nat_power_theory [nat_litteral]). + +(* A congruence tactic, similar to the boolean one, along with an .+1/+ *) +(* normalization tactic. *) + + +Ltac nat_norm := + succn_to_add; rewrite ?add0n ?addn0 -?addnA ?(addSn, addnS, add0n, addn0). + +Ltac nat_congr := first + [ apply: (congr1 succn _) + | apply: (congr1 predn _) + | apply: (congr1 (addn _) _) + | apply: (congr1 (subn _) _) + | apply: (congr1 (addn^~ _) _) + | match goal with |- (?X1 + ?X2 = ?X3) => + symmetry; + rewrite -1?(addnC X1) -?(addnCA X1); + apply: (congr1 (addn X1) _); + symmetry + end ]. diff --git a/mathcomp/ssrtest/Make b/mathcomp/ssrtest/Make new file mode 100644 index 0000000..adcc2d2 --- /dev/null +++ b/mathcomp/ssrtest/Make @@ -0,0 +1,44 @@ +-R ../theories Ssreflect +-I ../src/ +absevarprop.v +binders.v +binders_of.v +caseview.v +congr.v +deferclear.v +dependent_type_err.v +elim.v +elim2.v +elim_pattern.v +first_n.v +gen_pattern.v +gen_have.v +havesuff.v +have_view_idiom.v +have_TC.v +have_transp.v +if_isnt.v +indetLHS.v +intro_beta.v +intro_noop.v +ipatalternation.v +ltac_have.v +ltac_in.v +move_after.v +multiview.v +occarrow.v +patnoX.v +rewpatterns.v +set_lamda.v +set_pattern.v +ssrsyntax1.v +ssrsyntax2.v +testmx.v +tc.v +typeof.v +unkeyed.v +view_case.v +wlogletin.v +wlong_intro.v +wlog_suff.v + diff --git a/mathcomp/ssrtest/Makefile b/mathcomp/ssrtest/Makefile new file mode 100644 index 0000000..4bcf4fb --- /dev/null +++ b/mathcomp/ssrtest/Makefile @@ -0,0 +1,26 @@ +MAKEFLAGS := -r + +.SUFFIXES: + +.PHONY: clean all config tags install + +COQMAKEFILE := Makefile.coq +COQMAKE := +$(MAKE) -f $(COQMAKEFILE) + +all: $(COQMAKEFILE) + $(COQMAKE) all + +$(COQMAKEFILE) config: + $(COQBIN)coq_makefile -f Make -o $(COQMAKEFILE) + +clean: $(COQMAKEFILE) + $(COQMAKE) clean + $(RM) -rf $(COQMAKEFILE) + +tags: + $(COQBIN)coqtags `find . -name \*.v` + +install: + +%: Makefile.coq + $(COQMAKE) $@ diff --git a/mathcomp/ssrtest/absevarprop.v b/mathcomp/ssrtest/absevarprop.v new file mode 100644 index 0000000..513e53f --- /dev/null +++ b/mathcomp/ssrtest/absevarprop.v @@ -0,0 +1,86 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq. +Require Import fintype. + +Lemma test15: forall (y : nat) (x : 'I_2), y < 1 -> val x = y -> Some x = insub y. +move=> y x le_1 defx; rewrite insubT ?(leq_trans le_1) // => ?. +by congr (Some _); apply: val_inj=> /=; exact: defx. +Qed. + +Axiom P : nat -> Prop. +Axiom Q : forall n, P n -> Prop. +Definition R := fun (x : nat) (p : P x) m (q : P (x+1)) => m > 0. + +Inductive myEx : Type := ExI : forall n (pn : P n) pn', Q n pn -> R n pn n pn' -> myEx. + +Variable P1 : P 1. +Variable P11 : P (1 + 1). +Variable Q1 : forall P1, Q 1 P1. + +Lemma testmE1 : myEx. +Proof. +apply: ExI 1 _ _ _ _. + match goal with |- P 1 => exact: P1 | _ => fail end. + match goal with |- P (1+1) => exact: P11 | _ => fail end. + match goal with |- forall p : P 1, Q 1 p => move=>*; exact: Q1 | _ => fail end. +match goal with |- forall (p : P 1) (q : P (1+1)), is_true (R 1 p 1 q) => done | _ => fail end. +Qed. + +Lemma testE2 : exists y : { x | P x }, sval y = 1. +Proof. +apply: ex_intro (exist _ 1 _) _. + match goal with |- P 1 => exact: P1 | _ => fail end. +match goal with |- forall p : P 1, @sval _ _ (@exist _ _ 1 p) = 1 => done | _ => fail end. +Qed. + +Lemma testE3 : exists y : { x | P x }, sval y = 1. +Proof. +have := (ex_intro _ (exist _ 1 _) _); apply. + match goal with |- P 1 => exact: P1 | _ => fail end. +match goal with |- forall p : P 1, @sval _ _ (@exist _ _ 1 p) = 1 => done | _ => fail end. +Qed. + +Lemma testE4 : P 2 -> exists y : { x | P x }, sval y = 2. +Proof. +move=> P2; apply: ex_intro (exist _ 2 _) _. +match goal with |- @sval _ _ (@exist _ _ 2 P2) = 2 => done | _ => fail end. +Qed. + +Hint Resolve P1. + +Lemma testmE12 : myEx. +Proof. +apply: ExI 1 _ _ _ _. + match goal with |- P (1+1) => exact: P11 | _ => fail end. + match goal with |- Q 1 P1 => exact: Q1 | _ => fail end. +match goal with |- forall (q : P (1+1)), is_true (R 1 P1 1 q) => done | _ => fail end. +Qed. + +Create HintDb SSR. + +Hint Resolve P11 : SSR. + +Ltac ssrautoprop := trivial with SSR. + +Lemma testmE13 : myEx. +Proof. +apply: ExI 1 _ _ _ _. + match goal with |- Q 1 P1 => exact: Q1 | _ => fail end. +match goal with |- is_true (R 1 P1 1 P11) => done | _ => fail end. +Qed. + +Definition R1 := fun (x : nat) (p : P x) m (q : P (x+1)) (r : Q x p) => m > 0. + +Inductive myEx1 : Type := + ExI1 : forall n (pn : P n) pn' (q : Q n pn), R1 n pn n pn' q -> myEx1. + +Hint Resolve (Q1 P1) : SSR. + +(* tests that goals in prop are solved in the right order, propagating instantiations, + thus the goal Q 1 ?p1 is faced by trivial after ?p1, and is thus evar free *) +Lemma testmE14 : myEx1. +Proof. +apply: ExI1 1 _ _ _ _. +match goal with |- is_true (R1 1 P1 1 P11 (Q1 P1)) => done | _ => fail end. +Qed. + diff --git a/mathcomp/ssrtest/binders.v b/mathcomp/ssrtest/binders.v new file mode 100644 index 0000000..6a63167 --- /dev/null +++ b/mathcomp/ssrtest/binders.v @@ -0,0 +1,43 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool eqtype ssrnat. + +Lemma test (x : bool) : True. +have H1 x := x. +have (x) := x => H2. +have H3 T (x : T) := x. +have ? : bool := H1 _ x. +have ? : bool := H2 _ x. +have ? : bool := H3 _ x. +have ? (z : bool) : forall y : bool, z = z := fun y => refl_equal _. +have ? w : w = w := @refl_equal nat w. +have ? y : true by []. +have ? (z : bool) : z = z. + exact: (@refl_equal _ z). +have ? (z w : bool) : z = z by exact: (@refl_equal _ z). +have H w (a := 3) (_ := 4) : w && true = w. + by rewrite andbT. +exact I. +Qed. + +Lemma test1 : True. +suff (x : bool): x = x /\ True. + by move/(_ true); case=> _. +split; first by exact: (@refl_equal _ x). +suff H y : y && true = y /\ True. + by case: (H true). +suff H1 /= : true && true /\ True. + by rewrite andbT; split; [exact: (@refl_equal _ y) | exact: I]. +match goal with |- is_true true /\ True => idtac end. +by split. +Qed. + +Lemma foo n : n >= 0. +have f i (j := i + n) : j < n. + match goal with j := i + n |- _ => idtac end. +Undo 2. +suff f i (j := i + n) : j < n. + done. +match goal with j := i + n |- _ => idtac end. +Undo 3. +done. +Qed. diff --git a/mathcomp/ssrtest/binders_of.v b/mathcomp/ssrtest/binders_of.v new file mode 100644 index 0000000..70a822e --- /dev/null +++ b/mathcomp/ssrtest/binders_of.v @@ -0,0 +1,12 @@ + +Require Import ssreflect seq. + +Lemma test1 : True. +have f of seq nat & nat : nat. + exact 3. +have g of nat := 3. +have h of nat : nat := 3. +have _ : f [::] 3 = g 3 + h 4. + by admit. +by admit. +Qed. \ No newline at end of file diff --git a/mathcomp/ssrtest/caseview.v b/mathcomp/ssrtest/caseview.v new file mode 100644 index 0000000..108cf46 --- /dev/null +++ b/mathcomp/ssrtest/caseview.v @@ -0,0 +1,4 @@ +Require Import ssreflect. + +Lemma test (A B : Prop) : A /\ B -> True. +Proof. by case=> _ /id _. Qed. \ No newline at end of file diff --git a/mathcomp/ssrtest/congr.v b/mathcomp/ssrtest/congr.v new file mode 100644 index 0000000..edd52fe --- /dev/null +++ b/mathcomp/ssrtest/congr.v @@ -0,0 +1,23 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool eqtype ssrnat. + +Lemma test1 : forall a b : nat, a == b -> a == 0 -> b == 0. +Proof. move=> a b Eab Eac; congr (_ == 0) : Eac; exact: eqP Eab. Qed. + +Definition arrow A B := A -> B. + +Lemma test2 : forall a b : nat, a == b -> arrow (a == 0) (b == 0). +Proof. move=> a b Eab; congr (_ == 0); exact: eqP Eab. Qed. + +Definition equals T (A B : T) := A = B. + +Lemma test3 : forall a b : nat, a = b -> equals nat (a + b) (b + b). +Proof. move=> a b E; congr (_ + _); exact E. Qed. + +Variable S : eqType. +Variable f : nat -> S. +Coercion f : nat >-> Equality.sort. + +Lemma test4 : forall a b : nat, b = a -> @eq S (b + b) (a + a). +Proof. move=> a b Eba; congr (_ + _); exact: Eba. Qed. + diff --git a/mathcomp/ssrtest/deferclear.v b/mathcomp/ssrtest/deferclear.v new file mode 100644 index 0000000..a13a20e --- /dev/null +++ b/mathcomp/ssrtest/deferclear.v @@ -0,0 +1,26 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect. +Require Import ssrbool eqtype fintype ssrnat. + +Variable T : Type. + +Lemma test0 : forall a b c d : T, True. +Proof. by move=> a b {a} a c; exact I. Qed. + +Variable P : T -> Prop. + +Lemma test1 : forall a b c : T, P a -> forall d : T, True. +Proof. move=> a b {a} a _ d; exact I. Qed. + +Definition Q := forall x y : nat, x = y. +Axiom L : 0 = 0 -> Q. +Axiom L' : 0 = 0 -> forall x y : nat, x = y. +Lemma test3 : Q. +by apply/L. +Undo. +rewrite /Q. +by apply/L. +Undo 2. +by apply/L'. +Qed. + diff --git a/mathcomp/ssrtest/dependent_type_err.v b/mathcomp/ssrtest/dependent_type_err.v new file mode 100644 index 0000000..cd9570b --- /dev/null +++ b/mathcomp/ssrtest/dependent_type_err.v @@ -0,0 +1,7 @@ +Require Import ssreflect ssrfun ssrbool eqtype ssrnat. + +Lemma ltn_leq_trans : forall n m p : nat, m < n -> n <= p -> m < p. +move=> n m p Hmn Hnp; rewrite -ltnS. +Fail rewrite (_ : forall n0 m0 p0 : nat, m0 <= n0 -> n0 < p0 -> m0 < p0). +Fail rewrite leq_ltn_trans. +Admitted. \ No newline at end of file diff --git a/mathcomp/ssrtest/elim.v b/mathcomp/ssrtest/elim.v new file mode 100644 index 0000000..5ab8f41 --- /dev/null +++ b/mathcomp/ssrtest/elim.v @@ -0,0 +1,222 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq. + +(* Ltac debugging feature: recursive elim + eq generation *) +Lemma testL1 : forall A (s : seq A), s = s. +Proof. +move=> A s; elim branch: s => [|x xs _]. +match goal with _ : _ = [::] |- [::] = [::] => move: branch => // | _ => fail end. +match goal with _ : _ = _ :: _ |- _ :: _ = _ :: _ => move: branch => // | _ => fail end. +Qed. + +(* The same but with explicit eliminator and a conflict in the intro pattern *) +Lemma testL2 : forall A (s : seq A), s = s. +Proof. +move=> A s; elim/last_ind branch: s => [|x s _]. +match goal with _ : _ = [::] |- [::] = [::] => move: branch => // | _ => fail end. +match goal with _ : _ = rcons _ _ |- rcons _ _ = rcons _ _ => move: branch => // | _ => fail end. +Qed. + +(* The same but without names for variables involved in the generated eq *) +Lemma testL3 : forall A (s : seq A), s = s. +Proof. +move=> A s; elim branch: s; move: (s) => _. +match goal with _ : _ = [::] |- [::] = [::] => move: branch => // | _ => fail end. +move=> _;match goal with _ : _ = _ :: _ |- _ :: _ = _ :: _ => move: branch => // | _ => fail end. +Qed. + +Inductive foo : Type := K1 : foo | K2 : foo -> foo -> foo | K3 : (nat -> foo) -> foo. + +(* The same but with more intros to be done *) +Lemma testL4 : forall (o : foo), o = o. +Proof. +move=> o; elim branch: o. +match goal with _ : _ = K1 |- K1 = K1 => move: branch => // | _ => fail end. +move=> _; match goal with _ : _ = K2 _ _ |- K2 _ _ = K2 _ _ => move: branch => // | _ => fail end. +move=> _; match goal with _ : _ = K3 _ |- K3 _ = K3 _ => move: branch => // | _ => fail end. +Qed. + +(* Occurrence counting *) +Lemma testO1: forall (b : bool), b = b. +Proof. +move=> b; case: (b) / idP. +match goal with |- is_true b -> true = true => done | _ => fail end. +match goal with |- ~ is_true b -> false = false => done | _ => fail end. +Qed. + +(* The same but only the second occ *) +Lemma testO2: forall (b : bool), b = b. +Proof. +move=> b; case: {2}(b) / idP. +match goal with |- is_true b -> b = true => done | _ => fail end. +match goal with |- ~ is_true b -> b = false => move/(introF idP) => // | _ => fail end. +Qed. + +(* The same but with eq generation *) +Lemma testO3: forall (b : bool), b = b. +Proof. +move=> b; case E: {2}(b) / idP. +match goal with _ : is_true b, _ : b = true |- b = true => move: E => _; done | _ => fail end. +match goal with H : ~ is_true b, _ : b = false |- b = false => move: E => _; move/(introF idP): H => // | _ => fail end. +Qed. + +(* Views *) +Lemma testV1 : forall A (s : seq A), s = s. +Proof. +move=> A s; case/lastP E: {1}s => [| x xs]. +match goal with _ : s = [::] |- [::] = s => symmetry; exact E | _ => fail end. +match goal with _ : s = rcons x xs |- rcons _ _ = s => symmetry; exact E | _ => fail end. +Qed. + +Lemma testV2 : forall A (s : seq A), s = s. +Proof. +move=> A s; case/lastP E: s => [| x xs]. +match goal with _ : s = [::] |- [::] = [::] => done | _ => fail end. +match goal with _ : s = rcons x xs |- rcons _ _ = rcons _ _ => done | _ => fail end. +Qed. + +Lemma testV3 : forall A (s : seq A), s = s. +Proof. +move=> A s; case/lastP: s => [| x xs]. +match goal with |- [::] = [::] => done | _ => fail end. +match goal with |- rcons _ _ = rcons _ _ => done | _ => fail end. +Qed. + +(* Patterns *) +Lemma testP1: forall (x y : nat), (y == x) && (y == x) -> y == x. +move=> x y; elim: {2}(_ == _) / eqP. +match goal with |- (y = x -> is_true ((y == x) && true) -> is_true (y == x)) => move=>-> // | _ => fail end. +match goal with |- (y <> x -> is_true ((y == x) && false) -> is_true (y == x)) => move=>_; rewrite andbC // | _ => fail end. +Qed. + +(* The same but with an implicit pattern *) +Lemma testP2 : forall (x y : nat), (y == x) && (y == x) -> y == x. +move=> x y; elim: {2}_ / eqP. +match goal with |- (y = x -> is_true ((y == x) && true) -> is_true (y == x)) => move=>-> // | _ => fail end. +match goal with |- (y <> x -> is_true ((y == x) && false) -> is_true (y == x)) => move=>_; rewrite andbC // | _ => fail end. +Qed. + +(* The same but with an eq generation switch *) +Lemma testP3 : forall (x y : nat), (y == x) && (y == x) -> y == x. +move=> x y; elim E: {2}_ / eqP. +match goal with _ : y = x |- (is_true ((y == x) && true) -> is_true (y == x)) => rewrite E; reflexivity | _ => fail end. +match goal with _ : y <> x |- (is_true ((y == x) && false) -> is_true (y == x)) => rewrite E => /= H; exact H | _ => fail end. +Qed. + +Inductive spec : nat -> nat -> nat -> Prop := +| specK : forall a b c, a = 0 -> b = 2 -> c = 4 -> spec a b c. +Lemma specP : spec 0 2 4. Proof. by constructor. Qed. + +Lemma testP4 : (1+1) * 4 = 2 + (1+1) + (2 + 2). +Proof. +case: specP => a b c defa defb defc. +match goal with |- (a.+1 + a.+1) * c = b + (a.+1 + a.+1) + (b + b) => subst; done | _ => fail end. +Qed. + +Lemma testP5 : (1+1) * 4 = 2 + (1+1) + (2 + 2). +Proof. +case: (1 + 1) _ / specP => a b c defa defb defc. +match goal with |- b * c = a.+2 + b + (a.+2 + a.+2) => subst; done | _ => fail end. +Qed. + +Lemma testP6 : (1+1) * 4 = 2 + (1+1) + (2 + 2). +Proof. +case: {2}(1 + 1) _ / specP => a b c defa defb defc. +match goal with |- (a.+1 + a.+1) * c = a.+2 + b + (a.+2 + a.+2) => subst; done | _ => fail end. +Qed. + +Lemma testP7 : (1+1) * 4 = 2 + (1+1) + (2 + 2). +Proof. +case: _ (1 + 1) (2 + _) / specP => a b c defa defb defc. +match goal with |- b * a.+4 = c + c => subst; done | _ => fail end. +Qed. + +Lemma testP8 : (1+1) * 4 = 2 + (1+1) + (2 + 2). +Proof. +case E: (1 + 1) (2 + _) / specP=> [a b c defa defb defc]. +match goal with |- b * a.+4 = c + c => subst; done | _ => fail end. +Qed. + +Variables (T : Type) (tr : T -> T). + +Inductive exec (cf0 cf1 : T) : seq T -> Prop := +| exec_step : tr cf0 = cf1 -> exec cf0 cf1 [::] +| exec_star : forall cf2 t, tr cf0 = cf2 -> + exec cf2 cf1 t -> exec cf0 cf1 (cf2 :: t). + +Inductive execr (cf0 cf1 : T) : seq T -> Prop := +| execr_step : tr cf0 = cf1 -> execr cf0 cf1 [::] +| execr_star : forall cf2 t, execr cf0 cf2 t -> + tr cf2 = cf1 -> execr cf0 cf1 (t ++ [:: cf2]). + +Lemma execP : forall cf0 cf1 t, exec cf0 cf1 t <-> execr cf0 cf1 t. +Proof. +move=> cf0 cf1 t; split => [] Ecf. + elim: Ecf. + match goal with |- forall cf2 cf3 : T, tr cf2 = cf3 -> + execr cf2 cf3 [::] => admit | _ => fail end. + match goal with |- forall (cf2 cf3 cf4 : T) (t0 : seq T), + tr cf2 = cf4 -> exec cf4 cf3 t0 -> execr cf4 cf3 t0 -> + execr cf2 cf3 (cf4 :: t0) => admit | _ => fail end. +elim: Ecf. + match goal with |- forall cf2 : T, + tr cf0 = cf2 -> exec cf0 cf2 [::] => admit | _ => fail end. +match goal with |- forall (cf2 cf3 : T) (t0 : seq T), + execr cf0 cf3 t0 -> exec cf0 cf3 t0 -> tr cf3 = cf2 -> + exec cf0 cf2 (t0 ++ [:: cf3]) => admit | _ => fail end. +Qed. + +Require Import seq div prime bigop. + +Lemma mem_primes : forall p n, + (p \in primes n) = [&& prime p, n > 0 & p %| n]. +Proof. +move=> p n; rewrite andbCA; case: posnP => [-> // | /= n_gt0]. +apply/mapP/andP=> [[[q e]]|[pr_p]] /=. + case/mem_prime_decomp=> pr_q e_gt0; case/dvdnP=> u -> -> {p}. + by rewrite -(prednK e_gt0) expnS mulnCA dvdn_mulr. +rewrite {1}(prod_prime_decomp n_gt0) big_seq /=. +elim/big_ind: _ => [| u v IHu IHv | [q e] /= mem_qe dv_p_qe]. +- by rewrite Euclid_dvd1. +- by rewrite Euclid_dvdM //; case/orP. +exists (q, e) => //=; case/mem_prime_decomp: mem_qe => pr_q _ _. +by rewrite Euclid_dvdX // dvdn_prime2 // in dv_p_qe; case: eqP dv_p_qe. +Qed. + +Lemma sub_in_partn : forall pi1 pi2 n, + {in \pi(n), {subset pi1 <= pi2}} -> n`_pi1 %| n`_pi2. +Proof. +move=> pi1 pi2 n pi12; rewrite ![n`__]big_mkcond /=. +elim/big_ind2: _ => // [*|p _]; first exact: dvdn_mul. +rewrite lognE -mem_primes; case: ifP => pi1p; last exact: dvd1n. +by case: ifP => pr_p; [rewrite pi12 | rewrite if_same]. +Qed. + +Function plus (m n : nat) {struct n} : nat := + match n with + | 0 => m + | S p => S (plus m p) + end. + +Lemma exF x y z: plus (plus x y) z = plus x (plus y z). +elim/plus_ind: z / (plus _ z). +match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end. +Undo 2. +elim/plus_ind: (plus _ z). +match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end. +Undo 2. +elim/plus_ind: {z}(plus _ z). +match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end. +Undo 2. +elim/plus_ind: {z}_. +match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end. +Undo 2. +elim/plus_ind: z / _. +match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end. + done. +by move=> _ p _ ->. +Qed. + +(* BUG elim-False *) +Lemma testeF : False -> 1 = 0. +Proof. by elim. Qed. diff --git a/mathcomp/ssrtest/elim2.v b/mathcomp/ssrtest/elim2.v new file mode 100644 index 0000000..344ee52 --- /dev/null +++ b/mathcomp/ssrtest/elim2.v @@ -0,0 +1,58 @@ +Require Import ssreflect eqtype ssrbool ssrnat seq div fintype finfun path bigop. + +Lemma big_load R (K K' : R -> Type) idx op I r (P : pred I) F : + let s := \big[op/idx]_(i <- r | P i) F i in + K s * K' s -> K' s. +Proof. by move=> /= [_]. Qed. +Implicit Arguments big_load [R K' idx op I r P F]. + +Section Elim1. + +Variables (R : Type) (K : R -> Type) (f : R -> R). +Variables (idx : R) (op op' : R -> R -> R). + +Hypothesis Kid : K idx. + +Ltac ASSERT1 := match goal with |- (K idx) => admit end. +Ltac ASSERT2 K := match goal with |- (forall x1 : R, R -> + forall y1 : R, R -> K x1 -> K y1 -> K (op x1 y1)) => admit end. + + +Lemma big_rec I r (P : pred I) F + (Kop : forall i x, P i -> K x -> K (op (F i) x)) : + K (\big[op/idx]_(i <- r | P i) F i). +Proof. +elim/big_ind2: {-}_. + ASSERT1. ASSERT2 K. match goal with |- (forall i : I, is_true (P i) -> K (F i)) => admit end. Undo 4. +elim/big_ind2: _ / {-}_. + ASSERT1. ASSERT2 K. match goal with |- (forall i : I, is_true (P i) -> K (F i)) => admit end. Undo 4. + +elim/big_rec2: (\big[op/idx]_(i <- r | P i) op idx (F i)) + / (\big[op/idx]_(i <- r | P i) F i). + ASSERT1. match goal with |- (forall i : I, R -> forall y2 : R, is_true (P i) -> K y2 -> K (op (F i) y2)) => admit end. Undo 3. + +elim/(big_load (phantom R)): _. + Undo. + +Fail elim/big_rec2: {2}_. + +elim/big_rec2: (\big[op/idx]_(i <- r | P i) F i) + / {1}(\big[op/idx]_(i <- r | P i) F i). + Undo. + +elim/(big_load (phantom R)): _. +Undo. + +Fail elim/big_rec2: _ / {2}(\big[op/idx]_(i <- r | P i) F i). +Admitted. + +Definition morecomplexthannecessary A (P : A -> A -> Prop) x y := P x y. + +Lemma grab A (P : A -> A -> Prop) n m : (n = m) -> (P n n) -> morecomplexthannecessary A P n m. +by move->. +Qed. + +Goal forall n m, m + (n + m) = m + (n * 1 + m). +Proof. move=> n m; elim/grab : (_ * _) / {1}n => //; exact: muln1. Qed. + +End Elim1. diff --git a/mathcomp/ssrtest/elim_pattern.v b/mathcomp/ssrtest/elim_pattern.v new file mode 100644 index 0000000..51ab216 --- /dev/null +++ b/mathcomp/ssrtest/elim_pattern.v @@ -0,0 +1,14 @@ +Require Import ssreflect ssrbool eqtype ssrnat. + +Lemma test x : (x == x) = (x + x.+1 == 2 * x + 1). +case: (X in _ = X) / eqP => _. +match goal with |- (x == x) = true => admit end. +match goal with |- (x == x) = false => admit end. +Qed. + +Lemma test1 x : (x == x) = (x + x.+1 == 2 * x + 1). +elim: (x in RHS). +match goal with |- (x == x) = _ => admit end. +match goal with |- forall n, (x == x) = _ -> (x == x) = _ => admit end. +Qed. + diff --git a/mathcomp/ssrtest/first_n.v b/mathcomp/ssrtest/first_n.v new file mode 100644 index 0000000..175684a --- /dev/null +++ b/mathcomp/ssrtest/first_n.v @@ -0,0 +1,9 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool. + +Lemma test : False -> (bool -> False -> True -> True) -> True. +move=> F; let w := 2 in apply; last w first. +- by apply: F. +- by apply: I. +by apply: true. +Qed. \ No newline at end of file diff --git a/mathcomp/ssrtest/gen_have.v b/mathcomp/ssrtest/gen_have.v new file mode 100644 index 0000000..757dba5 --- /dev/null +++ b/mathcomp/ssrtest/gen_have.v @@ -0,0 +1,160 @@ +Require Import ssreflect ssrfun ssrbool eqtype ssrnat. + +Axiom P : nat -> Prop. +Lemma clear_test (b1 b2 : bool) : b2 = b2. +Proof. +(* wlog gH : (b3 := b2) / b2 = b3. admit. *) +gen have {b1} H, gH : (b3 := b2) (w := erefl 3) / b2 = b3. + admit. +Fail exact (H b1). +exact (H b2 (erefl _)). +Qed. + + +Lemma test1 n (ngt0 : 0 < n) : P n. +gen have lt2le, /andP[H1 H2] : n ngt0 / (0 <= n) && (n != 0). + match goal with |- is_true((0 <= n) && (n != 0)) => admit end. +Check (lt2le : forall n : nat, 0 < n -> (0 <= n) && (n != 0)). +Check (H1 : 0 <= n). +Check (H2 : n != 0). +admit. +Qed. + +Lemma test2 n (ngt0 : 0 < n) : P n. +gen have _, /andP[H1 H2] : n ngt0 / (0 <= n) && (n != 0). + match goal with |- is_true((0 <= n) && (n != 0)) => admit end. +lazymatch goal with + | lt2le : forall n : nat, is_true(0 < n) -> is_true((0 <= n) && (n != 0)) + |- _ => fail "not cleared" + | _ => idtac end. +Check (H1 : 0 <= n). +Check (H2 : n != 0). +admit. +Qed. + +Lemma test3 n (ngt0 : 0 < n) : P n. +gen have H : n ngt0 / (0 <= n) && (n != 0). + match goal with |- is_true((0 <= n) && (n != 0)) => admit end. +Check (H : forall n : nat, 0 < n -> (0 <= n) && (n != 0)). +admit. +Qed. + +Lemma test4 n (ngt0 : 0 < n) : P n. +gen have : n ngt0 / (0 <= n) && (n != 0). + match goal with |- is_true((0 <= n) && (n != 0)) => admit end. +move=> H. +Check(H : forall n : nat, 0 < n -> (0 <= n) && (n != 0)). +admit. +Qed. + +Lemma test4bis n (ngt0 : 0 < n) : P n. +wlog suff : n ngt0 / (0 <= n) && (n != 0); last first. + match goal with |- is_true((0 <= n) && (n != 0)) => admit end. +move=> H. +Check(H : forall n : nat, 0 < n -> (0 <= n) && (n != 0)). +admit. +Qed. + +Lemma test5 n (ngt0 : 0 < n) : P n. +Fail gen have : / (0 <= n) && (n != 0). +Abort. + +Lemma test6 n (ngt0 : 0 < n) : P n. +gen have : n ngt0 / (0 <= n) && (n != 0) by admit. +Abort. + +Lemma test7 n (ngt0 : 0 < n) : P n. +Fail gen have : n / (0 <= n) && (n != 0). +Abort. + +Lemma test3wlog2 n (ngt0 : 0 < n) : P n. +gen have H : (m := n) ngt0 / (0 <= m) && (m != 0). + match goal with + ngt0 : is_true(0 < m) |- is_true((0 <= m) && (m != 0)) => admit end. +Check (H : forall n : nat, 0 < n -> (0 <= n) && (n != 0)). +admit. +Qed. + +Lemma test3wlog3 n (ngt0 : 0 < n) : P n. +gen have H : {n} (m := n) (n := 0) ngt0 / (0 <= m) && (m != n). + match goal with + ngt0 : is_true(n < m) |- is_true((0 <= m) && (m != n)) => admit end. +Check (H : forall m n : nat, n < m -> (0 <= m) && (m != n)). +admit. +Qed. + +Lemma testw1 n (ngt0 : 0 < n) : n <= 0. +wlog H : (z := 0) (m := n) ngt0 / m != 0. + match goal with + |- (forall z m, + is_true(z < m) -> is_true(m != 0) -> is_true(m <= z)) -> + is_true(n <= 0) => admit end. +Check(n : nat). +Check(m : nat). +Check(z : nat). +Check(ngt0 : z < m). +Check(H : m != 0). +admit. +Qed. + +Lemma testw2 n (ngt0 : 0 < n) : n <= 0. +wlog H : (m := n) (z := (X in n <= X)) ngt0 / m != z. + match goal with + |- (forall m z : nat, + is_true(0 < m) -> is_true(m != z) -> is_true(m <= z)) -> + is_true(n <= 0) => idtac end. +Restart. +wlog H : (m := n) (one := (X in X <= _)) ngt0 / m != one. + match goal with + |- (forall m one : nat, + is_true(one <= m) -> is_true(m != one) -> is_true(m <= 0)) -> + is_true(n <= 0) => idtac end. +Restart. +wlog H : {n} (m := n) (z := (X in _ <= X)) ngt0 / m != z. + match goal with + |- (forall m z : nat, + is_true(0 < z) -> is_true(m != z) -> is_true(m <= 0)) -> + is_true(n <= 0) => idtac end. + admit. +Fail Check n. +admit. +Qed. + +Section Test. +Variable x : nat. +Definition addx y := y + x. + +Lemma testw3 (m n : nat) (ngt0 : 0 < n) : n <= addx x. +wlog H : (n0 := n) (y := x) (@twoy := (id _ as X in _ <= X)) / twoy = 2 * y. + admit. +admit. +Qed. + + +Definition twox := x + x. +Definition bis := twox. + +Lemma testw3x n (ngt0 : 0 < n) : n + x <= twox. +wlog H : (y := x) (@twoy := (X in _ <= X)) / twoy = 2 * y. + match goal with + |- (forall y : nat, + let twoy := y + y in + twoy = 2 * y -> is_true(n + y <= twoy)) -> + is_true(n + x <= twox) => admit end. +Restart. +wlog H : (y := x) (@twoy := (id _ as X in _ <= X)) / twoy = 2 * y. + match goal with + |- (forall y : nat, + let twoy := twox in + twoy = 2 * y -> is_true(n + y <= twoy)) -> + is_true(n + x <= twox) => admit end. +admit. +Qed. + +End Test. + +Lemma test_in n k (def_k : k = 0) (ngtk : k < n) : P n. +rewrite -(add0n n) in {def_k k ngtk} (m := k) (def_m := def_k) (ngtm := ngtk). +rewrite def_m add0n in {ngtm} (e := erefl 0 ) (ngt0 := ngtm) => {def_m}. +admit. +Qed. diff --git a/mathcomp/ssrtest/gen_pattern.v b/mathcomp/ssrtest/gen_pattern.v new file mode 100644 index 0000000..de57e8d --- /dev/null +++ b/mathcomp/ssrtest/gen_pattern.v @@ -0,0 +1,20 @@ +Require Import ssreflect ssrbool ssrnat. + +Notation "( a 'in' c )" := (a + c) (only parsing) : myscope. +Delimit Scope myscope with myscope. + +Notation "( a 'in' c )" := (a + c) (only parsing). + +Lemma foo x y : x + x.+1 = x.+1 + y. +move: {x} (x.+1) {1}x y (x.+1 in RHS). + match goal with |- forall a b c d, b + a = d + c => idtac end. +Admitted. + +Lemma bar x y : x + x.+1 = x.+1 + y. +move E: ((x.+1 in y)) => w. + match goal with |- x + x.+1 = w => rewrite -{w}E end. +move E: (x.+1 in y)%myscope => w. + match goal with |- x + x.+1 = w => rewrite -{w}E end. +move E: ((x + y).+1 as RHS) => w. + match goal with |- x + x.+1 = w => rewrite -{}E -addSn end. +Admitted. \ No newline at end of file diff --git a/mathcomp/ssrtest/have_TC.v b/mathcomp/ssrtest/have_TC.v new file mode 100644 index 0000000..3204c42 --- /dev/null +++ b/mathcomp/ssrtest/have_TC.v @@ -0,0 +1,36 @@ +Require Import ssreflect. + +Class foo (T : Type) := { n : nat }. +Instance five : foo nat := {| n := 5 |}. + +Definition bar T {f : foo T} m : Prop := + @n _ f = m. + +Eval compute in (bar nat 7). + +Lemma a : True. +set toto := bar _ 8. +have titi : bar _ 5. + reflexivity. +have titi2 : bar _ 5 := . + Fail reflexivity. + by admit. +have totoc (H : bar _ 5) : 3 = 3 := eq_refl. +move/totoc: nat => _. +exact I. +Qed. + +Set SsrHave NoTCResolution. + +Lemma a' : True. +set toto := bar _ 8. +have titi : bar _ 5. + Fail reflexivity. + by admit. +have titi2 : bar _ 5 := . + Fail reflexivity. + by admit. +have totoc (H : bar _ 5) : 3 = 3 := eq_refl. +move/totoc: nat => _. +exact I. +Qed. diff --git a/mathcomp/ssrtest/have_transp.v b/mathcomp/ssrtest/have_transp.v new file mode 100644 index 0000000..f1e3203 --- /dev/null +++ b/mathcomp/ssrtest/have_transp.v @@ -0,0 +1,37 @@ +Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype. + + +Lemma test1 n : n >= 0. +Proof. +have [:s1] @h m : 'I_(n+m).+1. + apply: Sub 0 _. + abstract: s1 m. + by auto. +cut (forall m, 0 < (n+m).+1); last assumption. +rewrite [_ 1 _]/= in s1 h *. +by []. +Qed. + +Lemma test2 n : n >= 0. +Proof. +have [:s1] @h m : 'I_(n+m).+1 := Sub 0 (s1 m). + move=> m; reflexivity. +cut (forall m, 0 < (n+m).+1); last assumption. +by []. +Qed. + +Lemma test3 n : n >= 0. +Proof. +Fail have [:s1] @h m : 'I_(n+m).+1 by apply: (Sub 0 (s1 m)); auto. +have [:s1] @h m : 'I_(n+m).+1 by apply: (Sub 0); abstract: s1 m; auto. +cut (forall m, 0 < (n+m).+1); last assumption. +by []. +Qed. + +Lemma test4 n : n >= 0. +Proof. +have @h m : 'I_(n+m).+1 by apply: (Sub 0); abstract auto. +by []. +Qed. + + diff --git a/mathcomp/ssrtest/have_view_idiom.v b/mathcomp/ssrtest/have_view_idiom.v new file mode 100644 index 0000000..d42a3ac --- /dev/null +++ b/mathcomp/ssrtest/have_view_idiom.v @@ -0,0 +1,6 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool. + +Lemma test (a b : bool) (pab : a && b) : b. +have {pab} /= /andP [pa -> //] /= : true && (a && b) := pab. +Qed. diff --git a/mathcomp/ssrtest/havesuff.v b/mathcomp/ssrtest/havesuff.v new file mode 100644 index 0000000..c497773 --- /dev/null +++ b/mathcomp/ssrtest/havesuff.v @@ -0,0 +1,73 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect. + +Variables P G : Prop. + +Lemma test1 : (P -> G) -> P -> G. +Proof. +move=> pg p. +have suff {pg} H : P. + match goal with |- P -> G => move=> _; exact: pg p | _ => fail end. +match goal with H : P -> G |- G => exact: H p | _ => fail end. +Qed. + +Lemma test2 : (P -> G) -> P -> G. +Proof. +move=> pg p. +have suffices {pg} H : P. + match goal with |- P -> G => move=> _;exact: pg p | _ => fail end. +match goal with H : P -> G |- G => exact: H p | _ => fail end. +Qed. + +Lemma test3 : (P -> G) -> P -> G. +Proof. +move=> pg p. +suff have {pg} H : P. + match goal with H : P |- G => exact: pg H | _ => fail end. +match goal with |- (P -> G) -> G => move=> H; exact: H p | _ => fail end. +Qed. + +Lemma test4 : (P -> G) -> P -> G. +Proof. +move=> pg p. +suffices have {pg} H: P. + match goal with H : P |- G => exact: pg H | _ => fail end. +match goal with |- (P -> G) -> G => move=> H; exact: H p | _ => fail end. +Qed. + +(* +Lemma test5 : (P -> G) -> P -> G. +Proof. +move=> pg p. +suff have {pg} H : P := pg H. +match goal with |- (P -> G) -> G => move=> H; exact: H p | _ => fail end. +Qed. +*) + +(* +Lemma test6 : (P -> G) -> P -> G. +Proof. +move=> pg p. +suff have {pg} H := pg H. +match goal with |- (P -> G) -> G => move=> H; exact: H p | _ => fail end. +Qed. +*) + +Lemma test7 : (P -> G) -> P -> G. +Proof. +move=> pg p. +have suff {pg} H : P := pg. +match goal with H : P -> G |- G => exact: H p | _ => fail end. +Qed. + +Lemma test8 : (P -> G) -> P -> G. +Proof. +move=> pg p. +have suff {pg} H := pg. +match goal with H : P -> G |- G => exact: H p | _ => fail end. +Qed. + +Goal forall x y : bool, x = y -> x = y. +move=> x y E. +by have {x E} -> : x = y by []. +Qed. \ No newline at end of file diff --git a/mathcomp/ssrtest/if_isnt.v b/mathcomp/ssrtest/if_isnt.v new file mode 100644 index 0000000..619df45 --- /dev/null +++ b/mathcomp/ssrtest/if_isnt.v @@ -0,0 +1,10 @@ +Require Import ssreflect. + +Definition unopt (x : option bool) := + if x isn't Some x then false else x. + +Lemma test1 : unopt None = false /\ + unopt (Some false) = false /\ + unopt (Some true) = true. +Proof. by auto. Qed. + diff --git a/mathcomp/ssrtest/indetLHS.v b/mathcomp/ssrtest/indetLHS.v new file mode 100644 index 0000000..f9d42ff --- /dev/null +++ b/mathcomp/ssrtest/indetLHS.v @@ -0,0 +1,4 @@ +Require Import ssreflect ssrnat. +Goal 5 = 3. +Fail (rewrite -(addnK _ 5)). +Abort. \ No newline at end of file diff --git a/mathcomp/ssrtest/intro_beta.v b/mathcomp/ssrtest/intro_beta.v new file mode 100644 index 0000000..6ede976 --- /dev/null +++ b/mathcomp/ssrtest/intro_beta.v @@ -0,0 +1,13 @@ +Require Import ssreflect. + +Axiom T : Type. + +Definition C (P : T -> Prop) := forall x, P x. + +Axiom P : T -> T -> Prop. + +Lemma foo : C (fun x => forall y, let z := x in P y x). +move=> a b. +match goal with |- (let y := _ in _) => idtac end. +admit. +Qed. diff --git a/mathcomp/ssrtest/intro_noop.v b/mathcomp/ssrtest/intro_noop.v new file mode 100644 index 0000000..91a87b5 --- /dev/null +++ b/mathcomp/ssrtest/intro_noop.v @@ -0,0 +1,23 @@ +Require Import ssreflect ssrbool. + +Lemma v : True -> bool -> bool. Proof. by []. Qed. + +Reserved Notation " a -/ b " (at level 0). +Reserved Notation " a -// b " (at level 0). +Reserved Notation " a -/= b " (at level 0). +Reserved Notation " a -//= b " (at level 0). + +Lemma test : forall a b c, a || b || c. +Proof. +move=> ---a--- - -/=- -//- -/=- -//=- b [|-]. +move: {-}a => /v/v-H; have _ := H I I. +Fail move: {-}a {H} => /v-/v-H. +have - -> : a = (id a) by []. +have --> : a = (id a) by []. +have - - _ : a = (id a) by []. +have -{1}-> : a = (id a) by []. + by admit. +move: a. +case: b => -[] //. +by admit. +Qed. diff --git a/mathcomp/ssrtest/ipatalternation.v b/mathcomp/ssrtest/ipatalternation.v new file mode 100644 index 0000000..9796648 --- /dev/null +++ b/mathcomp/ssrtest/ipatalternation.v @@ -0,0 +1,6 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect. + +Lemma test1 : Prop -> Prop -> Prop -> Prop -> Prop -> True = False -> Prop -> True \/ True. +by move=> A /= /= /= B C {A} {B} ? _ {C} {1}-> *; right. +Qed. \ No newline at end of file diff --git a/mathcomp/ssrtest/ltac_have.v b/mathcomp/ssrtest/ltac_have.v new file mode 100644 index 0000000..3ed274d --- /dev/null +++ b/mathcomp/ssrtest/ltac_have.v @@ -0,0 +1,28 @@ +Require Import ssreflect ssrbool ssrnat. + +Ltac SUFF1 h t := suff h x (p := x < 0) : t. +Ltac SUFF2 h t := suff h x (p := x < 0) : t by apply h. +Ltac HAVE1 h t u := have h x (p := x < 0) : t := u. +Ltac HAVE2 h t := have h x (p := x < 0) : t by []. +Ltac HAVE3 h t := have h x (p := x < 0) : t. +Ltac HAVES h t := have suff h : t. +Ltac SUFFH h t := suff have h : t. + +Lemma foo z : z < 0. +SUFF1 h1 (z+1 < 0). +Undo. +SUFF2 h2 (z < 0). +Undo. +HAVE1 h3 (z = z) (refl_equal z). +Undo. +HAVE2 h4 (z = z). +Undo. +HAVE3 h5 (z < 0). +Undo. +HAVES h6 (z < 1). +Undo. +SUFFH h7 (z < 1). +Undo. +Admitted. + + diff --git a/mathcomp/ssrtest/ltac_in.v b/mathcomp/ssrtest/ltac_in.v new file mode 100644 index 0000000..c9f15dd --- /dev/null +++ b/mathcomp/ssrtest/ltac_in.v @@ -0,0 +1,14 @@ +Require Import ssreflect ssrbool eqtype ssrnat ssrfun. + +Set Implicit Arguments. +Unset Strict Implicit. +Import Prenex Implicits. + +(* error 1 *) + +Ltac subst1 H := move: H ; rewrite {1} addnC; move => H. +Ltac subst2 H := rewrite addnC in H. + +Goal ( forall a b: nat, b+a = 0 -> b+a=0). +Proof. move => a b hyp. subst1 hyp. subst2 hyp. done. Qed. + diff --git a/mathcomp/ssrtest/move_after.v b/mathcomp/ssrtest/move_after.v new file mode 100644 index 0000000..9289193 --- /dev/null +++ b/mathcomp/ssrtest/move_after.v @@ -0,0 +1,6 @@ +Require Import ssreflect. + +Goal True -> True -> True. +move=> H1 H2. +move H1 after H2. +Admitted. diff --git a/mathcomp/ssrtest/multiview.v b/mathcomp/ssrtest/multiview.v new file mode 100644 index 0000000..53b3b4e --- /dev/null +++ b/mathcomp/ssrtest/multiview.v @@ -0,0 +1,56 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool ssrnat. + +Goal forall m n p, n <= p -> m <= n -> m <= p. +by move=> m n p le_n_p /leq_trans; apply. +Undo 1. +by move=> m n p le_n_p /leq_trans /(_ le_n_p) le_m_p; exact: le_m_p. +Undo 1. +by move=> m n p le_n_p /leq_trans ->. +Qed. + +Goal forall P Q X : Prop, Q -> (True -> X -> Q = P) -> X -> P. +by move=> P Q X q V /V <-. +Qed. + +Lemma test0: forall a b, a && a && b -> b. +by move=> a b; repeat move=> /andP []; move=> *. +Qed. + +Lemma test1 : forall a b, a && b -> b. +by move=> a b /andP /andP /andP [] //. +Qed. + +Lemma test2 : forall a b, a && b -> b. +by move=> a b /andP /andP /(@andP a) [] //. +Qed. + +Lemma test3 : forall a b, a && (b && b) -> b. +by move=> a b /andP [_ /andP [_ //]]. +Qed. + +Lemma test4: forall a b, a && b = b && a. +by move=> a b; apply/andP/andP=> ?; apply/andP/andP/andP; rewrite andbC; apply/andP. +Qed. + +Lemma test5: forall C I A O, (True -> O) -> (O -> A) -> (True -> A -> I) -> (I -> C) -> C. +by move=> c i a o O A I C; apply/C/I/A/O. +Qed. + +Lemma test6: forall A B, (A -> B) -> A -> B. +move=> A B A_to_B a; move/A_to_B in a; exact: a. +Qed. + +Lemma test7: forall A B, (A -> B) -> A -> B. +move=> A B A_to_B a; apply A_to_B in a; exact: a. +Qed. + +Require Import ssrfun eqtype ssrnat div seq choice fintype finfun finset. + +Lemma test8 (T : finType) (A B : {set T}) x (Ax : x \in A) (_ : B = A) : x \in B. +apply/subsetP: x Ax. +by rewrite H subxx. +Qed. + + + diff --git a/mathcomp/ssrtest/occarrow.v b/mathcomp/ssrtest/occarrow.v new file mode 100644 index 0000000..deaee0c --- /dev/null +++ b/mathcomp/ssrtest/occarrow.v @@ -0,0 +1,12 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect eqtype ssrnat. + +Lemma test1 : forall n m : nat, n = m -> m * m + n * n = n * n + n * n. +move=> n m E; have [{2}-> _] : n * n = m * n /\ True by move: E => {1}<-. +by move: E => {3}->. +Qed. + +Lemma test2 : forall n m : nat, True /\ (n = m -> n * n = n * m). +by move=> n m; constructor=> [|{2}->]. +Qed. + diff --git a/mathcomp/ssrtest/patnoX.v b/mathcomp/ssrtest/patnoX.v new file mode 100644 index 0000000..9cde676 --- /dev/null +++ b/mathcomp/ssrtest/patnoX.v @@ -0,0 +1,5 @@ +Require Import ssreflect ssrbool. +Goal forall x, x && true = x. +move=> x. +Fail (rewrite [X in _ && _]andbT). +Abort. diff --git a/mathcomp/ssrtest/rewpatterns.v b/mathcomp/ssrtest/rewpatterns.v new file mode 100644 index 0000000..88c2a2f --- /dev/null +++ b/mathcomp/ssrtest/rewpatterns.v @@ -0,0 +1,181 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) + +Require Import ssreflect ssrbool ssrfun eqtype ssrnat. + +Lemma test1 : forall x y (f : nat -> nat), f (x + y).+1 = f (y + x.+1). +by move=> x y f; rewrite [_.+1](addnC x.+1). +Qed. + +Lemma test2 : forall x y f, x + y + f (y + x) + f (y + x) = x + y + f (y + x) + f (x + y). +by move=> x y f; rewrite {2}[in f _]addnC. +Qed. + +Lemma test2' : forall x y f, true && f (x * (y + x)) = true && f(x * (x + y)). +by move=> x y f; rewrite [in f _](addnC y). +Qed. + +Lemma test2'' : forall x y f, f (y + x) + f(y + x) + f(y + x) = f(x + y) + f(y + x) + f(x + y). +by move=> x y f; rewrite {1 3}[in f _](addnC y). +Qed. + +(* patterns catching bound vars not supported *) +Lemma test2_1 : forall x y f, true && (let z := x in f (z * (y + x))) = true && f(x * (x + y)). +by move=> x y f; rewrite [in f _](addnC x). (* put y when bound var will be OK *) +Qed. + +Lemma test3 : forall x y f, x + f (x + y) (f (y + x) x) = x + f (x + y) (f (x + y) x). +by move=> x y f; rewrite [in X in (f _ X)](addnC y). +Qed. + +Lemma test3' : forall x y f, x = y -> x + f (x + x) x + f (x + x) x = + x + f (x + y) x + f (y + x) x. +by move=> x y f E; rewrite {2 3}[in X in (f X _)]E. +Qed. + +Lemma test3'' : forall x y f, x = y -> x + f (x + y) x + f (x + y) x = + x + f (x + y) x + f (y + y) x. +by move=> x y f E; rewrite {2}[in X in (f X _)]E. +Qed. + +Lemma test4 : forall x y f, x = y -> x + f (fun _ : nat => x + x) x + f (fun _ => x + x) x = + x + f (fun _ => x + y) x + f (fun _ => y + x) x. +by move=> x y f E; rewrite {2 3}[in X in (f X _)]E. +Qed. + +Lemma test4' : forall x y f, x = y -> x + f (fun _ _ _ : nat => x + x) x = + x + f (fun _ _ _ => x + y) x. +by move=> x y f E; rewrite {2}[in X in (f X _)]E. +Qed. + +Lemma test5 : forall x y f, x = y -> x + f (y + x) x + f (y + x) x = + x + f (x + y) x + f (y + x) x. +by move=> x y f E; rewrite {1}[X in (f X _)]addnC. +Qed. + +Lemma test3''' : forall x y f, x = y -> x + f (x + y) x + f (x + y) (x + y) = + x + f (x + y) x + f (y + y) (x + y). +by move=> x y f E; rewrite {1}[in X in (f X X)]E. +Qed. + +Lemma test3'''' : forall x y f, x = y -> x + f (x + y) x + f (x + y) (x + y) = + x + f (x + y) x + f (y + y) (y + y). +by move=> x y f E; rewrite [in X in (f X X)]E. +Qed. + +Lemma test3x : forall x y f, y+y = x+y -> x + f (x + y) x + f (x + y) (x + y) = + x + f (x + y) x + f (y + y) (y + y). +by move=> x y f E; rewrite -[X in (f X X)]E. +Qed. + +Lemma test6 : forall x y (f : nat -> nat), f (x + y).+1 = f (y.+1 + x). +by move=> x y f; rewrite [(x + y) in X in (f X)]addnC. +Qed. + +Lemma test7 : forall x y (f : nat -> nat), f (x + y).+1 = f (y + x.+1). +by move=> x y f; rewrite [(x.+1 + y) as X in (f X)]addnC. +Qed. + +Lemma manual x y z (f : nat -> nat -> nat) : (x + y).+1 + f (x.+1 + y) (z + (x + y).+1) = 0. +Proof. +rewrite [in f _]addSn. +match goal with |- (x + y).+1 + f (x + y).+1 (z + (x + y).+1) = 0 => idtac end. +rewrite -[X in _ = X]addn0. +match goal with |- (x + y).+1 + f (x + y).+1 (z + (x + y).+1) = 0 + 0 => idtac end. +rewrite -{2}[in X in _ = X](addn0 0). +match goal with |- (x + y).+1 + f (x + y).+1 (z + (x + y).+1) = 0 + (0 + 0) => idtac end. +rewrite [_.+1 in X in f _ X](addnC x.+1). +match goal with |- (x + y).+1 + f (x + y).+1 (z + (y + x.+1)) = 0 + (0 + 0) => idtac end. +rewrite [x.+1 + y as X in f X _]addnC. +match goal with |- (x + y).+1 + f (y + x.+1) (z + (y + x.+1)) = 0 + (0 + 0) => idtac end. +Admitted. + +Require Import fintype ssrnat finset fingroup gproduct. + +Goal (forall (gT : finGroupType) (G H: {set gT}) (Z : {group gT}), G = Z). +move=> gT G H K. suff: G \x H = K. case/dprodP=> {G H} [[G H -> -> defK _ _]]. +admit. +admit. +Qed. + +Goal (exists x : 'I_3, x > 0). +apply: (ex_intro _ (@Ordinal _ 2 _)). +admit. +Qed. + +Goal (forall y, 1 < y < 2 -> exists x : 'I_3, x > 0). +move=> y; case/andP=> y_gt1 y_lt2; apply: (ex_intro _ (@Ordinal _ y _)). + by apply: leq_trans y_lt2 _. +by move=> y_lt3; apply: leq_trans _ y_gt1. +Qed. + +Goal (forall x y : nat, forall P : nat -> Prop, x = y -> True). +move=> x y P E. +have: P x -> P y by suff: x = y by move=> ?; congr (P _). +by admit. +Qed. + +Goal forall a : bool, a -> true && a || false && a. +by move=> a ?; rewrite [true && _]/= [_ && a]/= orbC [_ || _]//=. +Qed. + +Goal forall a : bool, a -> true && a || false && a. +by move=> a ?; rewrite [X in X || _]/= [X in _ || X]/= orbC [false && a as X in X || _]//=. +Qed. + +Variable a : bool. +Definition f x := x || a. +Definition g x := f x. + +Goal a -> g false. +by move=> Ha; rewrite [g _]/f orbC Ha. +Qed. + +Goal a -> g false || g false. +move=> Ha; rewrite {2}[g _]/f orbC Ha. +match goal with |- (is_true (false || true || g false)) => done end. +Qed. + +Goal a -> (a && a || true && a) && true. +by move=> Ha; rewrite -[_ || _]/(g _) andbC /= Ha [g _]/f. +Qed. + +Goal a -> (a || a) && true. +by move=> Ha; rewrite -[in _ || _]/(f _) Ha andbC /f. +Qed. + +(* +Lemma testM7: forall x y, 0 = x + y -> y = 0 -> x = 0 -> 0 = y + x. +move=> x y E H1 H2; rewrite -[x + y as X in _ = X]E. +*) +(* +Lemma testM7': forall x y, 0 = x + y -> y = 0 -> x = 0 -> 0 = y + x. +move=> x y E H1 H2; rewrite -[y + x as X in _ = X]E. +*) +(* +Lemma testM6: forall x y, 0 = x + y -> y = 0 -> x = 0 -> 0 = y + x. +move=> x y E H1 H2; rewrite -[y + x in X in _ = X]E. +*) +(* +Lemma testM6': forall x y, 0 = x + y -> y = 0 -> x = 0 -> 0 = y + x. +move=> x y E H1 H2; rewrite -[x + y in X in _ = X]E. +*) +(* +Lemma testM5: forall x y, 0 = x + y -> y = 0 -> x = 0 -> 0 = y + x. +move=> x y E H1 H2; rewrite -[in X in _ = X]E. +*) +(* +Lemma testM4: forall x y, 0 = x + y -> y = 0 -> x = 0 -> 0 = y + x. +move=> x y E H1 H2; rewrite -[X in _ = X]E. +*) +(* +Lemma testM3: forall x y, 0 = x + y -> y = 0 -> x = 0 -> 0 = y + x. +move=> x y E H1 H2; rewrite -[in _ = _]E. +*) +(* +Lemma testM2 : forall x y, 0 = x + y -> y = 0 -> x = 0 -> 0 = y + x. +move=> x y E H1 H2; rewrite -[x + y]E. +*) +(* +Lemma testM1 : forall x y, 0 = x + y -> y = 0 -> x = 0 -> 0 = y + x. +move=> x y E H1 H2; rewrite -E. +*) diff --git a/mathcomp/ssrtest/set_lamda.v b/mathcomp/ssrtest/set_lamda.v new file mode 100644 index 0000000..51b8e61 --- /dev/null +++ b/mathcomp/ssrtest/set_lamda.v @@ -0,0 +1,14 @@ +Require Import ssreflect ssrbool eqtype ssrnat ssrfun. + +Set Implicit Arguments. +Unset Strict Implicit. +Import Prenex Implicits. + +(* error 2 *) + +Goal (exists f: Set -> nat, f nat = 0). +Proof. set (f:= fun _:Set =>0). by exists f. Qed. + +Goal (exists f: Set -> nat, f nat = 0). +Proof. set f := (fun _:Set =>0). by exists f. Qed. + diff --git a/mathcomp/ssrtest/set_pattern.v b/mathcomp/ssrtest/set_pattern.v new file mode 100644 index 0000000..0a98267 --- /dev/null +++ b/mathcomp/ssrtest/set_pattern.v @@ -0,0 +1,52 @@ +Require Import ssreflect. + +Ltac T1 x := match goal with |- _ => set t := (x in X in _ = X) end. +Ltac T2 x := first [set t := (x in RHS)]. +Ltac T3 x := first [set t := (x in Y in _ = Y)|idtac]. +Ltac T4 x := set t := (x in RHS);idtac. +Ltac T5 x := match goal with |- _ => set t := (x in RHS) | |- _ => idtac end. + +Require Import ssrbool ssrnat. + +Lemma foo x y : x.+1 = y + x.+1. +set t := (_.+1 in RHS). match goal with |- x.+1 = y + t => rewrite /t {t} end. +set t := (x in RHS). match goal with |- x.+1 = y + t.+1 => rewrite /t {t} end. +set t := (x in _ = x). match goal with |- x.+1 = t => rewrite /t {t} end. +set t := (x in X in _ = X). + match goal with |- x.+1 = y + t.+1 => rewrite /t {t} end. +set t := (x in RHS). match goal with |- x.+1 = y + t.+1 => rewrite /t {t} end. +set t := (y + (1 + x) as X in _ = X). + match goal with |- x.+1 = t => rewrite /t addSn add0n {t} end. +set t := x.+1. match goal with |- t = y + t => rewrite /t {t} end. +set t := (x).+1. match goal with |- t = y + t => rewrite /t {t} end. +set t := ((x).+1 in X in _ = X). + match goal with |- x.+1 = y + t => rewrite /t {t} end. +set t := (x.+1 in RHS). match goal with |- x.+1 = y + t => rewrite /t {t} end. +T1 (x.+1). match goal with |- x.+1 = y + t => rewrite /t {t} end. +T2 (x.+1). match goal with |- x.+1 = y + t => rewrite /t {t} end. +T3 (x.+1). match goal with |- x.+1 = y + t => rewrite /t {t} end. +T4 (x.+1). match goal with |- x.+1 = y + t => rewrite /t {t} end. +T5 (x.+1). match goal with |- x.+1 = y + t => rewrite /t {t} end. +rewrite [RHS]addnC. + match goal with |- x.+1 = x.+1 + y => rewrite -[RHS]addnC end. +rewrite -[in RHS](@subnK 1 x.+1) //. + match goal with |- x.+1 = y + (x.+1 - 1 + 1) => rewrite subnK // end. +have H : x.+1 = y by admit. +set t := _.+1 in H |- *. + match goal with H : t = y |- t = y + t => rewrite /t {t} in H * end. +set t := (_.+1 in X in _ + X) in H |- *. + match goal with H : x.+1 = y |- x.+1 = y + t => rewrite /t {t} in H * end. +set t := 0. match goal with t := 0 |- x.+1 = y + x.+1 => clear t end. +set t := y + _. match goal with |- x.+1 = t => rewrite /t {t} end. +set t : nat := 0. clear t. +set t : nat := (x in RHS). + match goal with |- x.+1 = y + t.+1 => rewrite /t {t} end. +set t : nat := RHS. match goal with |- x.+1 = t => rewrite /t {t} end. +(* set t := 0 + _. *) +(* set t := (x).+1 in X in _ + X in H |-. *) +(* set t := (x).+1 in X in _ = X.*) +Admitted. + + + + diff --git a/mathcomp/ssrtest/ssrsyntax1.v b/mathcomp/ssrtest/ssrsyntax1.v new file mode 100644 index 0000000..64e78da --- /dev/null +++ b/mathcomp/ssrtest/ssrsyntax1.v @@ -0,0 +1,25 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require ssreflect. +Require Import Arith. + +Goal (forall a b, a + b = b + a). +intros. +rewrite plus_comm, plus_comm. +split. +Abort. + +Module Foo. +Import ssreflect. + +Goal (forall a b, a + b = b + a). +intros. +rewrite 2![_ + _]plus_comm. +split. +Abort. +End Foo. + +Goal (forall a b, a + b = b + a). +intros. +rewrite plus_comm, plus_comm. +split. +Abort. \ No newline at end of file diff --git a/mathcomp/ssrtest/ssrsyntax2.v b/mathcomp/ssrtest/ssrsyntax2.v new file mode 100644 index 0000000..29985b9 --- /dev/null +++ b/mathcomp/ssrtest/ssrsyntax2.v @@ -0,0 +1,10 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssrsyntax1. +Require Import Arith. + +Goal (forall a b, a + b = b + a). +intros. +rewrite plus_comm, plus_comm. +split. +Qed. + diff --git a/mathcomp/ssrtest/tc.v b/mathcomp/ssrtest/tc.v new file mode 100644 index 0000000..b3f7d3f --- /dev/null +++ b/mathcomp/ssrtest/tc.v @@ -0,0 +1,29 @@ +Require Import ssreflect. + +Class foo (A : Type) : Type := mkFoo { val : A }. +Instance foo_pair {A B} {f1 : foo A} {f2 : foo B} : foo (A * B) | 2 := + {| val := (@val _ f1, @val _ f2) |}. +Instance foo_nat : foo nat | 3 := {| val := 0 |}. + +Definition id {A} (x : A) := x. +Axiom E : forall A {f : foo A} (a : A), id a = (@val _ f). + +Lemma test (x : nat) : id true = true -> id x = 0. +Proof. +Fail move=> _; reflexivity. +Timeout 2 rewrite E => _; reflexivity. +Qed. + +Definition P {A} (x : A) : Prop := x = x. +Axiom V : forall A {f : foo A} (x:A), P x -> P (id x). + +Lemma test1 (x : nat) : P x -> P (id x). +Proof. +move => px. +Timeout 2 Fail move/V: px. +Timeout 2 move/V : (px) => _. +move/(V nat) : px => H; exact H. +Qed. + + + diff --git a/mathcomp/ssrtest/testmx.v b/mathcomp/ssrtest/testmx.v new file mode 100644 index 0000000..931cbad --- /dev/null +++ b/mathcomp/ssrtest/testmx.v @@ -0,0 +1,33 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrfun ssrbool eqtype ssrnat. +Require Import ssralg matrix. + +Set Implicit Arguments. +Unset Strict Implicit. +Import Prenex Implicits. + +Local Open Scope nat_scope. +Local Open Scope ring_scope. + +Section TestMx. + +Variable R : ringType. +Variable M : 'M[R]_2. + +Goal 1%:M = M. +Proof. +Set Printing All. +rewrite [(1%:M : 'M_(1+1)%N)]scalar_mx_block. +(* Success with 1.2 *) +(* With ssreflect 1.3, fails with error : *) +(* Toplevel input, characters 0-44: *) +(* Error: pattern (1%:M) does not match LHS of scalar_mx_block *) +Admitted. + +Goal 1%:M = M. +Proof. +rewrite [1%:M](scalar_mx_block 1%N 1%N). +(* Success in both ssr 1.2 and 1.3 *) +Admitted. + +End TestMx. \ No newline at end of file diff --git a/mathcomp/ssrtest/typeof.v b/mathcomp/ssrtest/typeof.v new file mode 100644 index 0000000..8ad81a3 --- /dev/null +++ b/mathcomp/ssrtest/typeof.v @@ -0,0 +1,9 @@ +Require Import ssreflect. +Ltac mycut x := + let tx := type of x in + cut tx. + +Lemma test : True. +Proof. +by mycut I=> [ x | ]; [ exact x | exact I ]. +Qed. \ No newline at end of file diff --git a/mathcomp/ssrtest/unkeyed.v b/mathcomp/ssrtest/unkeyed.v new file mode 100644 index 0000000..f6b2021 --- /dev/null +++ b/mathcomp/ssrtest/unkeyed.v @@ -0,0 +1,18 @@ +Require Import ssreflect ssrfun ssrbool eqtype. + +Set Implicit Arguments. +Unset Strict Implicit. +Import Prenex Implicits. + +Lemma test0 (a b : unit) f : a = f b. +Proof. by rewrite !unitE. Qed. + +Lemma phE T : all_equal_to (Phant T). Proof. by case. Qed. + +Lemma test1 (a b : phant nat) f : a = f b. +Proof. by rewrite !phE. Qed. + +Lemma eq_phE (T : eqType) : all_equal_to (Phant T). Proof. by case. Qed. + +Lemma test2 (a b : phant bool) f : a = locked (f b). +Proof. by rewrite !eq_phE. Qed. diff --git a/mathcomp/ssrtest/view_case.v b/mathcomp/ssrtest/view_case.v new file mode 100644 index 0000000..f6de3df --- /dev/null +++ b/mathcomp/ssrtest/view_case.v @@ -0,0 +1,18 @@ +Require Import ssreflect ssrbool ssrnat eqtype seq fintype zmodp. + +Axiom P : forall T, seq T -> Prop. + +Goal (forall T (s : seq T), P _ s). +move=> T s. +elim: s => [| x /lastP [| s] IH]. +Admitted. + +Goal forall x : 'I_1, x = 0 :> nat. +move=> /ord1 -> /=; exact: refl_equal. +Qed. + +Goal forall x : 'I_1, x = 0 :> nat. +move=> x. +move=> /ord1 -> in x |- *. +exact: refl_equal. +Qed. diff --git a/mathcomp/ssrtest/wlog_suff.v b/mathcomp/ssrtest/wlog_suff.v new file mode 100644 index 0000000..4e1c86d --- /dev/null +++ b/mathcomp/ssrtest/wlog_suff.v @@ -0,0 +1,16 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect ssrbool. + +Lemma test b : b || ~~b. +wlog _ : b / b = true. + case: b; [ by apply | by rewrite orbC ]. +wlog suff: b / b || ~~b. + by case: b. +by case: b. +Qed. + +Lemma test2 b c (H : c = b) : b || ~~b. +wlog _ : b {c H} / b = true. + by case: b H. +by case: b. +Qed. \ No newline at end of file diff --git a/mathcomp/ssrtest/wlogletin.v b/mathcomp/ssrtest/wlogletin.v new file mode 100644 index 0000000..4d20321 --- /dev/null +++ b/mathcomp/ssrtest/wlogletin.v @@ -0,0 +1,37 @@ +(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *) +Require Import ssreflect eqtype ssrbool. + +Variable T : Type. +Variables P : T -> Prop. + +Definition f := fun x y : T => x. + +Lemma test1 : forall x y : T, P (f x y) -> P x. +Proof. +move=> x y; set fxy := f x y; move=> Pfxy. +wlog H : @fxy Pfxy / P x. + match goal with |- (let fxy0 := f x y in P fxy0 -> P x -> P x) -> P x => by auto | _ => fail end. +exact: H. +Qed. + +Lemma test2 : forall x y : T, P (f x y) -> P x. +Proof. +move=> x y; set fxy := f x y; move=> Pfxy. +wlog H : fxy Pfxy / P x. + match goal with |- (forall fxy, P fxy -> P x -> P x) -> P x => by auto | _ => fail end. +exact: H. +Qed. + +Lemma test3 : forall x y : T, P (f x y) -> P x. +Proof. +move=> x y; set fxy := f x y; move=> Pfxy. +move: {1}@fxy (Pfxy) (Pfxy). +match goal with |- (let fxy0 := f x y in P fxy0 -> P fxy -> P x) => by auto | _ => fail end. +Qed. + +Lemma test4 : forall n m z: bool, n = z -> let x := n in x = m && n -> x = m && n. +move=> n m z E x H. +case: true. + by rewrite {1 2}E in (x) H |- *. +by rewrite {1}E in x H |- *. +Qed. diff --git a/mathcomp/ssrtest/wlong_intro.v b/mathcomp/ssrtest/wlong_intro.v new file mode 100644 index 0000000..97e378a --- /dev/null +++ b/mathcomp/ssrtest/wlong_intro.v @@ -0,0 +1,6 @@ +Require Import ssreflect ssrbool ssrnat. + +Goal (forall x y : nat, True). +move=> x y. +wlog suff: x y / x <= y. +Admitted. -- cgit v1.2.3