├── .github └── workflows │ ├── docker-action.yml │ ├── nix-action-coq-8.20.yml │ ├── nix-action-coq-master.yml │ └── nix-action-rocq-9.0.yml ├── .gitignore ├── .nix ├── config.nix ├── coq-nix-toolbox.nix └── coq-overlays │ └── coq-elpi │ └── default.nix ├── LICENSE ├── Makefile ├── README.md ├── _CoqProject ├── coq-coqeal.opam ├── default.nix ├── meta.yml ├── refinements ├── bareiss_eff.v ├── binint.v ├── binnat.v ├── binord.v ├── binrat.v ├── boolF2.v ├── examples │ └── irred.v ├── hpoly.v ├── hrel.v ├── karatsuba.v ├── multipoly.v ├── param.v ├── poly_div.v ├── poly_op.v ├── pos.v ├── rational.v ├── refinements.v ├── ring.v ├── seqmx.v ├── seqmx_complements.v ├── seqpoly.v └── trivial_seq.v └── theory ├── atomic_operations.v ├── bareiss.v ├── bareiss_dvdring.v ├── binetcauchy.v ├── closed_poly.v ├── coherent.v ├── companion.v ├── dvdring.v ├── edr.v ├── fpmod.v ├── frobenius_form.v ├── gauss.v ├── jordan.v ├── kaplansky.v ├── karatsuba.v ├── minor.v ├── mxstructure.v ├── perm_eq_image.v ├── polydvd.v ├── rank.v ├── similar.v ├── smith.v ├── smith_complements.v ├── smithpid.v ├── ssralg_ring_tac.v ├── ssrcomplements.v ├── strassen.v ├── stronglydiscrete.v └── toomcook.v /.github/workflows/docker-action.yml: -------------------------------------------------------------------------------- 1 | # This file was generated from `meta.yml`, please do not edit manually. 2 | # Follow the instructions on https://github.com/coq-community/templates to regenerate. 3 | name: Docker CI 4 | 5 | on: 6 | push: 7 | branches: 8 | - master 9 | pull_request: 10 | branches: 11 | - '**' 12 | 13 | jobs: 14 | build: 15 | # the OS must be GNU/Linux to be able to use the docker-coq-action 16 | runs-on: ubuntu-latest 17 | strategy: 18 | matrix: 19 | image: 20 | - 'mathcomp/mathcomp:2.3.0-coq-8.20' 21 | - 'mathcomp/mathcomp:2.3.0-coq-dev' 22 | - 'mathcomp/mathcomp-dev:coq-8.20' 23 | - 'mathcomp/mathcomp-dev:rocq-prover-dev' 24 | fail-fast: false 25 | steps: 26 | - uses: actions/checkout@v4 27 | - uses: coq-community/docker-coq-action@v1 28 | with: 29 | opam_file: 'coq-coqeal.opam' 30 | custom_image: ${{ matrix.image }} 31 | 32 | 33 | # See also: 34 | # https://github.com/coq-community/docker-coq-action#readme 35 | # https://github.com/erikmd/docker-coq-github-action-demo 36 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.d 2 | *.glob 3 | *.vo 4 | *.vos 5 | *.vok 6 | *.cmo 7 | *.cma 8 | *.cmx 9 | *.cmxs 10 | *.cmi 11 | *.o 12 | *.native 13 | *.aux 14 | Makefile.coq 15 | Makefile.coq.conf 16 | *~ 17 | -------------------------------------------------------------------------------- /.nix/config.nix: -------------------------------------------------------------------------------- 1 | { 2 | ## DO NOT CHANGE THIS 3 | format = "1.0.0"; 4 | ## unless you made an automated or manual update 5 | ## to another supported format. 6 | 7 | ## The attribute to build, either from nixpkgs 8 | ## of from the overlays located in `.nix/coq-overlays` 9 | attribute = "coqeal"; 10 | 11 | ## If you want to select a different attribute 12 | ## to serve as a basis for nix-shell edit this 13 | # shell-attribute = "{{nix_name}}"; 14 | 15 | ## Maybe the shortname of the library is different from 16 | ## the name of the nixpkgs attribute, if so, set it here: 17 | # pname = "{{shortname}}"; 18 | 19 | ## Lists the dependencies, phrased in terms of nix attributes. 20 | ## No need to list Coq, it is already included. 21 | ## These dependencies will systematically be added to the currently 22 | ## known dependencies, if any more than Coq. 23 | ## /!\ Remove this field as soon as the package is available on nixpkgs. 24 | ## /!\ Manual overlays in `.nix/coq-overlays` should be preferred then. 25 | # buildInputs = [ ]; 26 | 27 | ## Indicate the relative location of your _CoqProject 28 | ## If not specified, it defaults to "_CoqProject" 29 | # coqproject = "_CoqProject"; 30 | 31 | ## Cachix caches to use in CI 32 | ## Below we list some standard ones 33 | cachix.coq = {}; 34 | cachix.coq-community.authToken = "CACHIX_AUTH_TOKEN"; 35 | cachix.math-comp = {}; 36 | 37 | ## If you have write access to one of these caches you can 38 | ## provide the auth token or signing key through a secret 39 | ## variable on GitHub. Then, you should give the variable 40 | ## name here. For instance, coq-community projects can use 41 | ## the following line instead of the one above: 42 | # cachix.coq-community.authToken = "CACHIX_AUTH_TOKEN"; 43 | 44 | ## Or if you have a signing key for a given Cachix cache: 45 | # cachix.my-cache.signingKey = "CACHIX_SIGNING_KEY" 46 | 47 | ## Note that here, CACHIX_AUTH_TOKEN and CACHIX_SIGNING_KEY 48 | ## are the names of secret variables. They are set in 49 | ## GitHub's web interface. 50 | 51 | ## select an entry to build in the following `bundles` set 52 | ## defaults to "default" 53 | default-bundle = "coq-8.20"; 54 | 55 | ## write one `bundles.name` attribute set per 56 | ## alternative configuration, the can be used to 57 | ## compute several ci jobs as well 58 | bundles = let 59 | 60 | ## You can override Coq and other Coq coqPackages 61 | ## through the following attribute 62 | # coqPackages.coq.override.version = "8.11"; 63 | 64 | ## In some cases, light overrides are not available/enough 65 | ## in which case you can use either 66 | # coqPackages..overrideAttrs = o: ; 67 | ## or a "long" overlay to put in `.nix/coq-overlays 68 | ## you may use `nix-shell --run fetchOverlay ` 69 | ## to automatically retrieve the one from nixpkgs 70 | ## if it exists and is correctly named/located 71 | 72 | ## You can override Coq and other Coq coqPackages 73 | ## throught the following attribute 74 | ## If does not support lights overrides, 75 | ## you may use `overrideAttrs` or long overlays 76 | ## located in `.nix/ocaml-overlays` 77 | ## (there is no automation for this one) 78 | # ocamlPackages..override.version = "x.xx"; 79 | 80 | ## You can also override packages from the nixpkgs toplevel 81 | # .override.overrideAttrs = o: ; 82 | ## Or put an overlay in `.nix/overlays` 83 | 84 | ## you may mark a package as a CI job as follows 85 | # coqPackages..ci.job = "test"; 86 | ## It can then be built throught 87 | ## nix-build --argstr ci "default" --arg ci-job "test"; 88 | 89 | common-bundles = { 90 | mathcomp-ssreflect.job = true; 91 | mathcomp-algebra.job = true; 92 | mathcomp-field.job = true; 93 | mathcomp-finmap.job = true; 94 | mathcomp-bigenough.job = true; 95 | multinomials.job = true; 96 | mathcomp-real-closed.job = true; 97 | mathcomp-zify.job = true; 98 | mathcomp-algebra-tactics.job = true; 99 | mathcomp-apery.override.version = "master"; # reverse dependency of coqeal 100 | stdlib.job = true; 101 | bignums.job = true; 102 | interval.job = false; 103 | coquelicot.job = false; 104 | # To add an overlay applying to all bundles, 105 | # add below a line like 106 | #.override.version = ":"; 107 | # where 108 | # * will typically be one of the strings above (without the quotes) 109 | # or look at https://github.com/NixOS/nixpkgs/tree/master/pkgs/development/coq-modules 110 | # for a complete list of Coq packages available in Nix 111 | # * : is such that this will use the branch 112 | # from https://github.com// 113 | }; 114 | in { 115 | "coq-master" = { rocqPackages = { 116 | rocq-core.override.version = "master"; 117 | stdlib.override.version = "master"; 118 | bignums.override.version = "master"; 119 | rocq-elpi.override.version = "master"; 120 | rocq-elpi.override.elpi-version = "2.0.7"; 121 | }; coqPackages = common-bundles // { 122 | coq.override.version = "master"; 123 | stdlib.override.version = "master"; 124 | bignums.override.version = "master"; 125 | coq-elpi.override.version = "master"; 126 | coq-elpi.override.elpi-version = "2.0.7"; 127 | hierarchy-builder.override.version = "master"; 128 | mathcomp.override.version = "master"; 129 | mathcomp-finmap.override.version = "master"; 130 | mathcomp-bigenough.override.version = "master"; 131 | multinomials.override.version = "master"; 132 | mathcomp-real-closed.override.version = "master"; 133 | mathcomp-zify.override.version = "master"; 134 | mathcomp-algebra-tactics.override.version = "master"; 135 | }; }; 136 | "rocq-9.0".coqPackages = common-bundles // { 137 | coq.override.version = "9.0"; 138 | coq-elpi.job = true; 139 | hierarchy-builder.job = true; 140 | mathcomp.override.version = "2.3.0"; 141 | multinomials.override.version = "2.3.0"; 142 | }; 143 | "coq-8.20".coqPackages = common-bundles // { 144 | coq.override.version = "8.20"; 145 | coq-elpi.override.version = "2.5.0"; 146 | coq-elpi.override.elpi-version = "2.0.7"; 147 | hierarchy-builder.override.version = "1.8.1"; 148 | mathcomp.override.version = "2.3.0"; 149 | }; 150 | }; 151 | } 152 | -------------------------------------------------------------------------------- /.nix/coq-nix-toolbox.nix: -------------------------------------------------------------------------------- 1 | "249b84ba5526b5b8c49f236923d595c8505717f2" 2 | -------------------------------------------------------------------------------- /.nix/coq-overlays/coq-elpi/default.nix: -------------------------------------------------------------------------------- 1 | { 2 | lib, 3 | mkCoqDerivation, 4 | which, 5 | coq, 6 | rocqPackages, 7 | stdlib, 8 | version ? null, 9 | elpi-version ? null, 10 | }: 11 | 12 | let 13 | default-elpi-version = if elpi-version != null then elpi-version else ( 14 | lib.switch coq.coq-version [ 15 | { case = "8.11"; out = "1.11.4"; } 16 | { case = "8.12"; out = "1.12.0"; } 17 | { case = "8.13"; out = "1.13.7"; } 18 | { case = "8.14"; out = "1.13.7"; } 19 | { case = "8.15"; out = "1.15.0"; } 20 | { case = "8.16"; out = "1.17.0"; } 21 | { case = "8.17"; out = "1.17.0"; } 22 | { case = "8.18"; out = "1.18.1"; } 23 | { case = "8.19"; out = "1.18.1"; } 24 | { case = "8.20"; out = "1.19.2"; } 25 | { case = "9.0"; out = "2.0.7"; } 26 | ] { } 27 | ); 28 | elpi = coq.ocamlPackages.elpi.override { version = default-elpi-version; }; 29 | propagatedBuildInputs_wo_elpi = [ 30 | coq.ocamlPackages.findlib 31 | ]; 32 | derivation = mkCoqDerivation { 33 | pname = "elpi"; 34 | repo = "coq-elpi"; 35 | owner = "LPCIC"; 36 | inherit version; 37 | defaultVersion = lib.switch coq.coq-version [ 38 | { case = "9.0"; out = "2.5.0"; } 39 | { case = "8.20"; out = "2.2.0"; } 40 | { case = "8.19"; out = "2.0.1"; } 41 | { case = "8.18"; out = "2.0.0"; } 42 | { case = "8.17"; out = "1.18.0"; } 43 | { case = "8.16"; out = "1.15.6"; } 44 | { case = "8.15"; out = "1.14.0"; } 45 | { case = "8.14"; out = "1.11.2"; } 46 | { case = "8.13"; out = "1.11.1"; } 47 | { case = "8.12"; out = "1.8.3_8.12"; } 48 | { case = "8.11"; out = "1.6.3_8.11"; } 49 | ] null; 50 | release."2.5.0".sha256 = "sha256-Z5xjO83X/ZoTQlWnVupGXPH3HuJefr57Kv128I0dltg="; 51 | release."2.4.0".sha256 = "sha256-W2+vVGExLLux8e0nSZESSoMVvrLxhL6dmXkb+JuKiqc="; 52 | release."2.2.0".sha256 = "sha256-rADEoqTXM7/TyYkUKsmCFfj6fjpWdnZEOK++5oLfC/I="; 53 | release."2.0.1".sha256 = "sha256-cuoPsEJ+JRLVc9Golt2rJj4P7lKltTrrmQijjoViooc="; 54 | release."2.0.0".sha256 = "sha256-A/cH324M21k3SZ7+YWXtaYEbu6dZQq3K0cb1RMKjbsM="; 55 | release."1.19.0".sha256 = "sha256-kGoo61nJxeG/BqV+iQaV3iinwPStND+7+fYMxFkiKrQ="; 56 | release."1.18.0".sha256 = "sha256-2fCOlhqi4YkiL5n8SYHuc3pLH+DArf9zuMH7IhpBc2Y="; 57 | release."1.17.0".sha256 = "sha256-J8GatRKFU0ekNCG3V5dBI+FXypeHcLgC5QJYGYzFiEM="; 58 | release."1.15.6".sha256 = "sha256-qc0q01tW8NVm83801HHOBHe/7H1/F2WGDbKO6nCXfno="; 59 | release."1.15.1".sha256 = "sha256-NT2RlcIsFB9AvBhMxil4ZZIgx+KusMqDflj2HgQxsZg="; 60 | release."1.14.0".sha256 = "sha256:1v2p5dlpviwzky2i14cj7gcgf8cr0j54bdm9fl5iz1ckx60j6nvp"; 61 | release."1.13.0".sha256 = "1j7s7dlnjbw222gnbrsjgmjck1yrx7h6hwm8zikcyxi0zys17w7n"; 62 | release."1.12.1".sha256 = "sha256-4mO6/co7NcIQSGIQJyoO8lNWXr6dqz+bIYPO/G0cPkY="; 63 | release."1.11.2".sha256 = "0qk5cfh15y2zrja7267629dybd3irvxk1raz7z8qfir25a81ckd4"; 64 | release."1.11.1".sha256 = "10j076vc2hdcbm15m6s7b6xdzibgfcbzlkgjnlkr2vv9k13qf8kc"; 65 | release."1.10.1".sha256 = "1zsyx26dvj7pznfd2msl2w7zbw51q1nsdw0bdvdha6dga7ijf7xk"; 66 | release."1.9.7".sha256 = "0rvn12h9dpk9s4pxy32p8j0a1h7ib7kg98iv1cbrdg25y5vs85n1"; 67 | release."1.9.5".sha256 = "0gjdwmb6bvb5gh0a6ra48bz5fb3pr5kpxijb7a8mfydvar5i9qr6"; 68 | release."1.9.4".sha256 = "0nii7238mya74f9g6147qmpg6gv6ic9b54x5v85nb6q60d9jh0jq"; 69 | release."1.9.3".sha256 = "198irm800fx3n8n56vx1c6f626cizp1d7jfkrc6ba4iqhb62ma0z"; 70 | release."1.9.2".sha256 = "1rr2fr8vjkc0is7vh1461aidz2iwkigdkp6bqss4hhv0c3ijnn07"; 71 | release."1.8.3_8.12".sha256 = "15z2l4zy0qpw0ws7bvsmpmyv543aqghrfnl48nlwzn9q0v89p557"; 72 | release."1.8.3_8.12".version = "1.8.3"; 73 | release."1.8.2_8.12".sha256 = "1n6jwcdazvjgj8vsv2r9zgwpw5yqr5a1ndc2pwhmhqfl04b5dk4y"; 74 | release."1.8.2_8.12".version = "1.8.2"; 75 | release."1.8.1".sha256 = "1fbbdccdmr8g4wwpihzp4r2xacynjznf817lhijw6kqfav75zd0r"; 76 | release."1.8.0".sha256 = "13ywjg94zkbki22hx7s4gfm9rr87r4ghsgan23xyl3l9z8q0idd1"; 77 | release."1.7.0".sha256 = "1ws5cqr0xawv69prgygbl3q6dgglbaw0vc397h9flh90kxaqgyh8"; 78 | release."1.6.3_8.11".sha256 = "1j340cr2bv95clzzkkfmsjkklham1mj84cmiyprzwv20q89zr1hp"; 79 | release."1.6.3_8.11".version = "1.6.3"; 80 | release."1.6.2_8.11".sha256 = "06xrx0ljilwp63ik2sxxr7h617dgbch042xfcnfpy5x96br147rn"; 81 | release."1.6.2_8.11".version = "1.6.2"; 82 | release."1.6.1_8.11".sha256 = "0yyyh35i1nb3pg4hw7cak15kj4y6y9l84nwar9k1ifdsagh5zq53"; 83 | release."1.6.1_8.11".version = "1.6.1"; 84 | release."1.6.0_8.11".sha256 = "0ahxjnzmd7kl3gl38kyjqzkfgllncr2ybnw8bvgrc6iddgga7bpq"; 85 | release."1.6.0_8.11".version = "1.6.0"; 86 | release."1.6.0".sha256 = "0kf99i43mlf750fr7fric764mm495a53mg5kahnbp6zcjcxxrm0b"; 87 | releaseRev = v: "v${v}"; 88 | 89 | buildFlags = [ "OCAMLWARN=" ]; 90 | 91 | mlPlugin = true; 92 | useDuneifVersion = v: lib.versions.isGe "2.2.0" v || v == "dev"; 93 | 94 | propagatedBuildInputs = propagatedBuildInputs_wo_elpi ++ [ elpi ]; 95 | 96 | preConfigure = '' 97 | make elpi/dune || true 98 | ''; 99 | 100 | meta = { 101 | description = "Coq plugin embedding ELPI"; 102 | maintainers = [ lib.maintainers.cohencyril ]; 103 | license = lib.licenses.lgpl21Plus; 104 | }; 105 | }; 106 | patched-derivation1 = derivation.overrideAttrs 107 | ( 108 | o: 109 | lib.optionalAttrs (o ? elpi-version) 110 | { 111 | propagatedBuildInputs = propagatedBuildInputs_wo_elpi ++ [ 112 | (coq.ocamlPackages.elpi.override { version = o.elpi-version; }) 113 | ]; 114 | } 115 | ); 116 | patched-derivation2 = patched-derivation1.overrideAttrs 117 | ( 118 | o: 119 | lib.optionalAttrs (o.version != null && (o.version == "dev" || lib.versions.isGe "2.2.0" o.version)) 120 | { 121 | propagatedBuildInputs = o.propagatedBuildInputs ++ [ coq.ocamlPackages.ppx_optcomp ]; 122 | } 123 | ); 124 | patched-derivation3 = patched-derivation2.overrideAttrs 125 | ( 126 | o: 127 | lib.optionalAttrs (o.version != null && o.version == "2.4.0") 128 | { 129 | propagatedBuildInputs = o.propagatedBuildInputs ++ [ stdlib ]; 130 | } 131 | ); 132 | patched-derivation4 = patched-derivation3.overrideAttrs 133 | ( 134 | o: 135 | # this is just a wrapper for rocPackages.rocq-elpi for Rocq >= 9.0 136 | if coq.version != null && (coq.version == "dev" 137 | || lib.versions.isGe "9.0" coq.version) then { 138 | configurePhase = '' 139 | echo no configuration 140 | ''; 141 | buildPhase = '' 142 | echo building nothing 143 | ''; 144 | installPhase = '' 145 | echo installing nothing 146 | ''; 147 | propagatedBuildInputs = o.propagatedBuildInputs 148 | ++ [ rocqPackages.rocq-elpi ]; 149 | } else lib.optionalAttrs (o.version != null && (o.version == "dev" 150 | || lib.versions.isGe "2.5.0" o.version)) { 151 | configurePhase = '' 152 | make dune-files || true 153 | ''; 154 | buildPhase = '' 155 | dune build -p rocq-elpi @install ''${enableParallelBuilding:+-j $NIX_BUILD_CORES} 156 | ''; 157 | installPhase = '' 158 | dune install --root . rocq-elpi --prefix=$out --libdir $OCAMLFIND_DESTDIR 159 | mkdir $out/lib/coq/ 160 | mv $OCAMLFIND_DESTDIR/coq $out/lib/coq/${coq.coq-version} 161 | ''; 162 | } 163 | ); 164 | in patched-derivation4 165 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014 Guillaume Cano, Cyril Cohen, Maxime Dénès, Anders 4 | Mörtberg and Vincent Siles. 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining 7 | a copy of this software and associated documentation files (the 8 | "Software"), to deal in the Software without restriction, including 9 | without limitation the rights to use, copy, modify, merge, publish, 10 | distribute, sublicense, and/or sell copies of the Software, and to 11 | permit persons to whom the Software is furnished to do so, subject to 12 | the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be 15 | included in all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 19 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 21 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 22 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 23 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 24 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: Makefile.coq 2 | @+$(MAKE) -f Makefile.coq all 3 | 4 | clean: Makefile.coq 5 | @+$(MAKE) -f Makefile.coq cleanall 6 | @rm -f Makefile.coq Makefile.coq.conf 7 | 8 | Makefile.coq: _CoqProject 9 | $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq 10 | 11 | force _CoqProject Makefile: ; 12 | 13 | %: Makefile.coq force 14 | @+$(MAKE) -f Makefile.coq $@ 15 | 16 | .PHONY: all clean force 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 5 | # CoqEAL 6 | 7 | [![Docker CI][docker-action-shield]][docker-action-link] 8 | [![Contributing][contributing-shield]][contributing-link] 9 | [![Code of Conduct][conduct-shield]][conduct-link] 10 | [![Zulip][zulip-shield]][zulip-link] 11 | 12 | [docker-action-shield]: https://github.com/coq-community/coqeal/actions/workflows/docker-action.yml/badge.svg?branch=master 13 | [docker-action-link]: https://github.com/coq-community/coqeal/actions/workflows/docker-action.yml 14 | 15 | [contributing-shield]: https://img.shields.io/badge/contributions-welcome-%23f7931e.svg 16 | [contributing-link]: https://github.com/coq-community/manifesto/blob/master/CONTRIBUTING.md 17 | 18 | [conduct-shield]: https://img.shields.io/badge/%E2%9D%A4-code%20of%20conduct-%23f15a24.svg 19 | [conduct-link]: https://github.com/coq-community/manifesto/blob/master/CODE_OF_CONDUCT.md 20 | 21 | [zulip-shield]: https://img.shields.io/badge/chat-on%20zulip-%23c1272d.svg 22 | [zulip-link]: https://coq.zulipchat.com/#narrow/stream/237663-coq-community-devs.20.26.20users 23 | 24 | 25 | 26 | This Coq library contains a subset of the work that was developed in the context 27 | of the ForMath EU FP7 project (2009-2013). It has two parts: 28 | - theory, which contains developments in algebra including normal forms of matrices, 29 | and optimized algorithms on MathComp data structures. 30 | - refinements, which is a framework to ease change of data representations during a proof. 31 | 32 | ## Meta 33 | 34 | - Author(s): 35 | - Guillaume Cano (initial) 36 | - Cyril Cohen (initial) 37 | - Maxime Dénès (initial) 38 | - Érik Martin-Dorel 39 | - Anders Mörtberg (initial) 40 | - Damien Rouhling 41 | - Pierre Roux 42 | - Vincent Siles (initial) 43 | - Coq-community maintainer(s): 44 | - Cyril Cohen ([**@CohenCyril**](https://github.com/CohenCyril)) 45 | - Pierre Roux ([**@proux01**](https://github.com/proux01)) 46 | - License: [MIT License](LICENSE) 47 | - Compatible Coq versions: 8.20 or later (use releases for other Coq versions) 48 | - Additional dependencies: 49 | - [Bignums](https://github.com/coq/bignums) same version as Coq 50 | - [Coq-Elpi](https://github.com/LPCIC/coq-elpi) 2.4.1 or later 51 | - [Hierarchy Builder](https://github.com/math-comp/hierarchy-builder) 1.4.0 or later 52 | - [MathComp ssreflect](https://math-comp.github.io) 2.3 or later 53 | - [MathComp algebra](https://math-comp.github.io) 2.1 or later 54 | - [MathComp Multinomials](https://github.com/math-comp/multinomials) 2.0 or later 55 | - [MathComp real-closed](https://math-comp.github.io) 2.0 or later 56 | - Coq namespace: `CoqEAL` 57 | - Related publication(s): 58 | - [A refinement-based approach to computational algebra in Coq](https://hal.inria.fr/hal-00734505/document) doi:[10.1007/978-3-642-32347-8_7](https://doi.org/10.1007/978-3-642-32347-8_7) 59 | - [Refinements for free!](https://hal.inria.fr/hal-01113453/document) doi:[10.1007/978-3-319-03545-1_10](https://doi.org/10.1007/978-3-319-03545-1_10) 60 | - [A Coq Formalization of Finitely Presented Modules](https://hal.inria.fr/hal-01378905/document) doi:[10.1007/978-3-319-08970-6_13](https://doi.org/10.1007/978-3-319-08970-6_13) 61 | - [Formalized Linear Algebra over Elementary Divisor Rings in Coq](https://hal.inria.fr/hal-01081908/document) doi:[10.2168/LMCS-12(2:7)2016](https://doi.org/10.2168/LMCS-12(2:7)2016) 62 | - [A refinement-based approach to large scale reflection for algebra](https://hal.inria.fr/hal-01414881/document) 63 | - [Interaction entre algèbre linéaire et analyse en formalisation des mathématiques](https://tel.archives-ouvertes.fr/tel-00986283/) 64 | - [A formal proof of Sasaki-Murao algorithm](https://jfr.unibo.it/article/view/2615) doi:[10.6092/issn.1972-5787/2615](https://doi.org/10.6092/issn.1972-5787/2615) 65 | - [Formalizing Refinements and Constructive Algebra in Type Theory](http://hdl.handle.net/2077/37325) 66 | - [Coherent and Strongly Discrete Rings in Type Theory](https://staff.math.su.se/anders.mortberg/papers/coherent.pdf) doi:[10.1007/978-3-642-35308-6_21](https://doi.org/10.1007/978-3-642-35308-6_21) 67 | 68 | ## Building and installation instructions 69 | 70 | The easiest way to install the latest released version of CoqEAL 71 | is via [OPAM](https://opam.ocaml.org/doc/Install.html): 72 | 73 | ```shell 74 | opam repo add coq-released https://coq.inria.fr/opam/released 75 | opam install coq-coqeal 76 | ``` 77 | 78 | To instead build and install manually, do: 79 | 80 | ``` shell 81 | git clone https://github.com/coq-community/coqeal.git 82 | cd coqeal 83 | make # or make -j 84 | make install 85 | ``` 86 | 87 | 88 | ## Theory 89 | 90 | The theory directory has the following content: 91 | 92 | - `ssrcomplements`, `minor` `mxstructure`, `polydvd`, `similar`, 93 | `binetcauchy`, `ssralg_ring_tac`: Various extensions of the 94 | Mathematical Components library. 95 | 96 | - `dvdring`, `coherent`, `stronglydiscrete`, `edr`: Hierarchy of 97 | structures with divisibility (from rings with divisibility, PIDs, 98 | elementary divisor rings, etc.). 99 | 100 | - `fpmod`: Formalization of finitely presented modules. 101 | 102 | - `kaplansky`: For providing elementary divisor rings from the 103 | Kaplansky condition. 104 | 105 | - `closed_poly`: Polynomials with coefficients in a closed field. 106 | 107 | - `companion`, `frobenius_form`, `jordan`, `perm_eq_image`, 108 | `smith_complements`: Results on normal forms of matrices. 109 | 110 | - `bareiss_dvdring`, `bareiss`, `gauss`, `karatsuba`, `rank`, 111 | `strassen`, `toomcook`, `smithpid`, `smith`: Various efficient 112 | algorithms for computing operations on polynomials or matrices. 113 | 114 | ## Refinements 115 | 116 | The refinements directory has the following content: 117 | 118 | - `refinements`: Classes for refinements and refines together with 119 | operational typeclasses for common operations. 120 | 121 | - `binnat`: Proof that the binary naturals of Coq (`N`) are a refinement 122 | of the MathComp unary naturals (`nat`) together with basic operations. 123 | 124 | - `binord`: Proof that the binary natural numbers of Coq (`N`) are a refinement 125 | of the MathComp ordinals. 126 | 127 | - `binint`: MathComp integers (`ssrint`) are refined to a new type 128 | parameterized by positive numbers (represented by a sigma type) and 129 | natural numbers. This means that proofs can be done using only 130 | lemmas from the MathComp library which leads to simpler proofs than 131 | previous versions of `binint` (e.g., `N`). 132 | 133 | - `binrat`: Arbitrary precision rational numbers (`bigQ`) from the 134 | [Bignums](https://github.com/coq/bignums) library are refined to 135 | MathComp's rationals (`rat`). 136 | 137 | - `rational`: The rational numbers of MathComp (`rat`) are refined to 138 | pairs of elements refining integers using parametricity of 139 | refinements. 140 | 141 | - `seqmatrix` and `seqmx_complements`: Refinement of MathComp 142 | matrices (`M[R]_(m,n)`) to lists of lists (`seq (seq R)`). 143 | 144 | - `seqpoly`: Refinement of MathComp polynomials (`{poly R}`) to lists (`seq R`). 145 | 146 | - `multipoly`: Refinement of 147 | [MathComp multinomials](https://github.com/math-comp/multinomials) 148 | and multivariate polynomials to Coq 149 | [finite maps](https://github.com/coq/coq/blob/master/theories/FSets/FMapAVL.v). 150 | 151 | Files should use the following conventions (w.r.t. `Local` and `Global` instances): 152 | 153 | ```coq 154 | (** Part 1: Generic operations *) 155 | Section generic_operations. 156 | 157 | Global Instance generic_operation := ... 158 | 159 | (** Part 2: Correctness proof for proof-oriented types and programs *) 160 | Section theory. 161 | 162 | Local Instance param_correctness : param ... 163 | 164 | (** Part 3: Parametricity *) 165 | Section parametricity. 166 | 167 | Global Instance param_parametricity : param ... 168 | Proof. exact: param_trans. Qed. 169 | 170 | End parametricity. 171 | End theory. 172 | ``` 173 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -R . CoqEAL 2 | 3 | -arg -w -arg -projection-no-head-constant 4 | -arg -w -arg -redundant-canonical-projection 5 | -arg -w -arg -notation-overridden 6 | -arg -w -arg +duplicate-clear 7 | -arg -w -arg +non-primitive-record 8 | -arg -w -arg +undeclared-scope 9 | -arg -w -arg +deprecated-hint-without-locality 10 | -arg -w -arg +deprecated-hint-rewrite-without-locality 11 | -arg -w -arg +deprecated-ident-entry 12 | -arg -w -arg +deprecated-typeclasses-transparency-without-locality 13 | -arg -w -arg -ambiguous-paths 14 | -arg -w -arg +implicit-core-hint-db 15 | 16 | theory/atomic_operations.v 17 | theory/bareiss_dvdring.v 18 | theory/bareiss.v 19 | theory/binetcauchy.v 20 | theory/closed_poly.v 21 | theory/coherent.v 22 | theory/companion.v 23 | theory/dvdring.v 24 | theory/edr.v 25 | theory/fpmod.v 26 | theory/frobenius_form.v 27 | theory/gauss.v 28 | theory/jordan.v 29 | theory/kaplansky.v 30 | theory/karatsuba.v 31 | theory/minor.v 32 | theory/mxstructure.v 33 | theory/perm_eq_image.v 34 | theory/polydvd.v 35 | theory/rank.v 36 | theory/similar.v 37 | theory/smithpid.v 38 | theory/smith.v 39 | theory/smith_complements.v 40 | theory/ssralg_ring_tac.v 41 | theory/ssrcomplements.v 42 | theory/strassen.v 43 | theory/stronglydiscrete.v 44 | theory/toomcook.v 45 | refinements/hrel.v 46 | refinements/param.v 47 | refinements/refinements.v 48 | refinements/pos.v 49 | refinements/binnat.v 50 | refinements/binint.v 51 | refinements/poly_op.v 52 | refinements/seqpoly.v 53 | refinements/karatsuba.v 54 | refinements/poly_div.v 55 | refinements/binord.v 56 | refinements/seqmx.v 57 | refinements/seqmx_complements.v 58 | refinements/hpoly.v 59 | refinements/bareiss_eff.v 60 | refinements/rational.v 61 | refinements/boolF2.v 62 | refinements/trivial_seq.v 63 | refinements/examples/irred.v 64 | refinements/binrat.v 65 | refinements/multipoly.v 66 | -------------------------------------------------------------------------------- /coq-coqeal.opam: -------------------------------------------------------------------------------- 1 | # This file was generated from `meta.yml`, please do not edit manually. 2 | # Follow the instructions on https://github.com/coq-community/templates to regenerate. 3 | 4 | opam-version: "2.0" 5 | maintainer: "Cyril Cohen " 6 | version: "dev" 7 | 8 | homepage: "https://github.com/coq-community/coqeal" 9 | dev-repo: "git+https://github.com/coq-community/coqeal.git" 10 | bug-reports: "https://github.com/coq-community/coqeal/issues" 11 | license: "MIT" 12 | 13 | synopsis: "CoqEAL - The Coq Effective Algebra Library" 14 | description: """ 15 | This Coq library contains a subset of the work that was developed in the context 16 | of the ForMath EU FP7 project (2009-2013). It has two parts: 17 | - theory, which contains developments in algebra including normal forms of matrices, 18 | and optimized algorithms on MathComp data structures. 19 | - refinements, which is a framework to ease change of data representations during a proof.""" 20 | 21 | build: [make "-j%{jobs}%"] 22 | install: [make "install"] 23 | depends: [ 24 | "coq" {(>= "8.20" & < "9.1~") | (= "dev")} 25 | "coq-bignums" 26 | "coq-elpi" {>= "2.4.1" | = "dev"} 27 | "coq-hierarchy-builder" {>= "1.4.0"} 28 | "coq-mathcomp-ssreflect" {>= "2.3"} 29 | "coq-mathcomp-algebra" 30 | "coq-mathcomp-multinomials" {>= "2.0"} 31 | "coq-mathcomp-real-closed" {>= "2.0"} 32 | ] 33 | 34 | tags: [ 35 | "category:Computer Science/Decision Procedures and Certified Algorithms/Correctness proofs of algorithms" 36 | "keyword:effective algebra" 37 | "keyword:elementary divisor rings" 38 | "keyword:Smith normal form" 39 | "keyword:mathematical components" 40 | "keyword:Bareiss" 41 | "keyword:Karatsuba multiplication" 42 | "keyword:refinements" 43 | "logpath:CoqEAL" 44 | ] 45 | authors: [ 46 | "Guillaume Cano" 47 | "Cyril Cohen" 48 | "Maxime Dénès" 49 | "Érik Martin-Dorel" 50 | "Anders Mörtberg" 51 | "Damien Rouhling" 52 | "Pierre Roux" 53 | "Vincent Siles" 54 | ] 55 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { config ? {}, withEmacs ? false, print-env ? false, do-nothing ? false, 2 | update-nixpkgs ? false, ci-matrix ? false, 3 | override ? {}, ocaml-override ? {}, global-override ? {}, 4 | bundle ? null, job ? null, inNixShell ? null, src ? ./., 5 | }@args: 6 | let auto = fetchGit { 7 | url = "https://github.com/coq-community/coq-nix-toolbox.git"; 8 | ref = "master"; 9 | rev = import .nix/coq-nix-toolbox.nix; 10 | }; 11 | in 12 | import auto ({inherit src;} // args) 13 | -------------------------------------------------------------------------------- /meta.yml: -------------------------------------------------------------------------------- 1 | --- 2 | fullname: CoqEAL 3 | shortname: coqeal 4 | organization: coq-community 5 | community: true 6 | action: true 7 | coqdoc: false 8 | dune: false 9 | 10 | synopsis: >- 11 | CoqEAL - The Coq Effective Algebra Library 12 | 13 | description: |- 14 | This Coq library contains a subset of the work that was developed in the context 15 | of the ForMath EU FP7 project (2009-2013). It has two parts: 16 | - theory, which contains developments in algebra including normal forms of matrices, 17 | and optimized algorithms on MathComp data structures. 18 | - refinements, which is a framework to ease change of data representations during a proof. 19 | 20 | publications: 21 | - pub_url: https://hal.inria.fr/hal-00734505/document 22 | pub_title: A refinement-based approach to computational algebra in Coq 23 | pub_doi: 10.1007/978-3-642-32347-8_7 24 | - pub_url: https://hal.inria.fr/hal-01113453/document 25 | pub_title: Refinements for free! 26 | pub_doi: 10.1007/978-3-319-03545-1_10 27 | - pub_url: https://hal.inria.fr/hal-01378905/document 28 | pub_title: A Coq Formalization of Finitely Presented Modules 29 | pub_doi: 10.1007/978-3-319-08970-6_13 30 | - pub_url: https://hal.inria.fr/hal-01081908/document 31 | pub_title: Formalized Linear Algebra over Elementary Divisor Rings in Coq 32 | pub_doi: 10.2168/LMCS-12(2:7)2016 33 | - pub_url: https://hal.inria.fr/hal-01414881/document 34 | pub_title: A refinement-based approach to large scale reflection for algebra 35 | - pub_url: https://tel.archives-ouvertes.fr/tel-00986283/ 36 | pub_title: Interaction entre algèbre linéaire et analyse en formalisation des mathématiques 37 | - pub_url: https://jfr.unibo.it/article/view/2615 38 | pub_doi: 10.6092/issn.1972-5787/2615 39 | pub_title: A formal proof of Sasaki-Murao algorithm 40 | - pub_url: http://hdl.handle.net/2077/37325 41 | pub_title: Formalizing Refinements and Constructive Algebra in Type Theory 42 | - pub_title: Coherent and Strongly Discrete Rings in Type Theory 43 | pub_url: https://staff.math.su.se/anders.mortberg/papers/coherent.pdf 44 | pub_doi: 10.1007/978-3-642-35308-6_21 45 | 46 | authors: 47 | - name: Guillaume Cano 48 | initial: true 49 | - name: Cyril Cohen 50 | initial: true 51 | - name: Maxime Dénès 52 | initial: true 53 | - name: Érik Martin-Dorel 54 | initial: false 55 | - name: Anders Mörtberg 56 | initial: true 57 | - name: Damien Rouhling 58 | initial: false 59 | - name: Pierre Roux 60 | initial: false 61 | - name: Vincent Siles 62 | initial: true 63 | 64 | maintainers: 65 | - name: Cyril Cohen 66 | nickname: CohenCyril 67 | - name: Pierre Roux 68 | nickname: proux01 69 | 70 | opam-file-maintainer: Cyril Cohen 71 | 72 | opam-file-version: dev 73 | 74 | license: 75 | fullname: MIT License 76 | identifier: MIT 77 | 78 | supported_coq_versions: 79 | text: 8.20 or later (use releases for other Coq versions) 80 | opam: '{(>= "8.20" & < "9.1~") | (= "dev")}' 81 | 82 | dependencies: 83 | - opam: 84 | name: coq-bignums 85 | description: |- 86 | [Bignums](https://github.com/coq/bignums) same version as Coq 87 | - opam: 88 | name: coq-elpi 89 | version: '{>= "2.4.1" | = "dev"}' 90 | description: |- 91 | [Coq-Elpi](https://github.com/LPCIC/coq-elpi) 2.4.1 or later 92 | - opam: 93 | name: coq-hierarchy-builder 94 | version: '{>= "1.4.0"}' 95 | description: |- 96 | [Hierarchy Builder](https://github.com/math-comp/hierarchy-builder) 1.4.0 or later 97 | - opam: 98 | name: coq-mathcomp-ssreflect 99 | version: '{>= "2.3"}' 100 | description: |- 101 | [MathComp ssreflect](https://math-comp.github.io) 2.3 or later 102 | - opam: 103 | name: coq-mathcomp-algebra 104 | description: |- 105 | [MathComp algebra](https://math-comp.github.io) 2.1 or later 106 | - opam: 107 | name: coq-mathcomp-multinomials 108 | version: '{>= "2.0"}' 109 | description: |- 110 | [MathComp Multinomials](https://github.com/math-comp/multinomials) 2.0 or later 111 | - opam: 112 | name: coq-mathcomp-real-closed 113 | version: '{>= "2.0"}' 114 | description: |- 115 | [MathComp real-closed](https://math-comp.github.io) 2.0 or later 116 | 117 | tested_coq_opam_versions: 118 | - version: '2.3.0-coq-8.20' 119 | repo: 'mathcomp/mathcomp' 120 | - version: '2.3.0-coq-dev' 121 | repo: 'mathcomp/mathcomp' 122 | - version: 'coq-8.20' 123 | repo: 'mathcomp/mathcomp-dev' 124 | - version: 'coq-dev' 125 | repo: 'mathcomp/mathcomp-dev' 126 | 127 | namespace: CoqEAL 128 | 129 | keywords: 130 | - name: effective algebra 131 | - name: elementary divisor rings 132 | - name: Smith normal form 133 | - name: mathematical components 134 | - name: Bareiss 135 | - name: Karatsuba multiplication 136 | - name: refinements 137 | 138 | categories: 139 | - name: Computer Science/Decision Procedures and Certified Algorithms/Correctness proofs of algorithms 140 | 141 | documentation: |- 142 | ## Theory 143 | 144 | The theory directory has the following content: 145 | 146 | - `ssrcomplements`, `minor` `mxstructure`, `polydvd`, `similar`, 147 | `binetcauchy`, `ssralg_ring_tac`: Various extensions of the 148 | Mathematical Components library. 149 | 150 | - `dvdring`, `coherent`, `stronglydiscrete`, `edr`: Hierarchy of 151 | structures with divisibility (from rings with divisibility, PIDs, 152 | elementary divisor rings, etc.). 153 | 154 | - `fpmod`: Formalization of finitely presented modules. 155 | 156 | - `kaplansky`: For providing elementary divisor rings from the 157 | Kaplansky condition. 158 | 159 | - `closed_poly`: Polynomials with coefficients in a closed field. 160 | 161 | - `companion`, `frobenius_form`, `jordan`, `perm_eq_image`, 162 | `smith_complements`: Results on normal forms of matrices. 163 | 164 | - `bareiss_dvdring`, `bareiss`, `gauss`, `karatsuba`, `rank`, 165 | `strassen`, `toomcook`, `smithpid`, `smith`: Various efficient 166 | algorithms for computing operations on polynomials or matrices. 167 | 168 | ## Refinements 169 | 170 | The refinements directory has the following content: 171 | 172 | - `refinements`: Classes for refinements and refines together with 173 | operational typeclasses for common operations. 174 | 175 | - `binnat`: Proof that the binary naturals of Coq (`N`) are a refinement 176 | of the MathComp unary naturals (`nat`) together with basic operations. 177 | 178 | - `binord`: Proof that the binary natural numbers of Coq (`N`) are a refinement 179 | of the MathComp ordinals. 180 | 181 | - `binint`: MathComp integers (`ssrint`) are refined to a new type 182 | parameterized by positive numbers (represented by a sigma type) and 183 | natural numbers. This means that proofs can be done using only 184 | lemmas from the MathComp library which leads to simpler proofs than 185 | previous versions of `binint` (e.g., `N`). 186 | 187 | - `binrat`: Arbitrary precision rational numbers (`bigQ`) from the 188 | [Bignums](https://github.com/coq/bignums) library are refined to 189 | MathComp's rationals (`rat`). 190 | 191 | - `rational`: The rational numbers of MathComp (`rat`) are refined to 192 | pairs of elements refining integers using parametricity of 193 | refinements. 194 | 195 | - `seqmatrix` and `seqmx_complements`: Refinement of MathComp 196 | matrices (`M[R]_(m,n)`) to lists of lists (`seq (seq R)`). 197 | 198 | - `seqpoly`: Refinement of MathComp polynomials (`{poly R}`) to lists (`seq R`). 199 | 200 | - `multipoly`: Refinement of 201 | [MathComp multinomials](https://github.com/math-comp/multinomials) 202 | and multivariate polynomials to Coq 203 | [finite maps](https://github.com/coq/coq/blob/master/theories/FSets/FMapAVL.v). 204 | 205 | Files should use the following conventions (w.r.t. `Local` and `Global` instances): 206 | 207 | ```coq 208 | (** Part 1: Generic operations *) 209 | Section generic_operations. 210 | 211 | Global Instance generic_operation := ... 212 | 213 | (** Part 2: Correctness proof for proof-oriented types and programs *) 214 | Section theory. 215 | 216 | Local Instance param_correctness : param ... 217 | 218 | (** Part 3: Parametricity *) 219 | Section parametricity. 220 | 221 | Global Instance param_parametricity : param ... 222 | Proof. exact: param_trans. Qed. 223 | 224 | End parametricity. 225 | End theory. 226 | ``` 227 | --- 228 | -------------------------------------------------------------------------------- /refinements/binord.v: -------------------------------------------------------------------------------- 1 | Require Import ZArith. 2 | 3 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq zmodp. 4 | From mathcomp Require Import path choice fintype tuple finset ssralg ssrnum bigop ssrint. 5 | 6 | From CoqEAL Require Import hrel param refinements binnat. 7 | 8 | Set Implicit Arguments. 9 | Unset Strict Implicit. 10 | Unset Printing Implicit Defensive. 11 | 12 | Import Refinements.Op zmodp. 13 | 14 | Local Open Scope ring_scope. 15 | 16 | Section binord_op. 17 | 18 | Definition binord := fun (_ : nat) => N. 19 | 20 | #[export] Instance zero_ord n : zero_of (binord n) := N.zero. 21 | 22 | #[export] Instance one_ord n : one_of (binord n.+1) := 23 | if (n == 0)%N then N.zero else N.one. 24 | 25 | #[export] Instance opp_ord n : opp_of (binord n) := 26 | fun x => N.modulo ((implem n) - x) (implem n). 27 | 28 | #[export] Instance add_ord n : add_of (binord n) := 29 | fun x y => N.modulo (x + y) (implem n). 30 | 31 | #[export] Instance sub_ord n : sub_of (binord n) := 32 | fun x y => N.modulo (x + (N.modulo ((implem n) - y) (implem n))) (implem n). 33 | 34 | #[export] Instance mul_ord n : mul_of (binord n) := 35 | fun x y => N.modulo (x * y) (implem n). 36 | 37 | #[export] Instance exp_ord n : exp_of (binord n) N := 38 | fun x y => N.modulo (x ^ y) (implem n). 39 | 40 | #[export] Instance eq_ord n : eq_of (binord n) := N.eqb. 41 | 42 | #[export] Instance leq_ord n : leq_of (binord n) := N.leb. 43 | 44 | #[export] Instance lt_ord n : lt_of (binord n) := N.ltb. 45 | 46 | #[export] Instance implem_ord n : implem_of 'I_n (binord n) := 47 | fun x => implem (x : nat). 48 | 49 | End binord_op. 50 | 51 | Section binord_theory. 52 | 53 | Local Open Scope rel_scope. 54 | 55 | Definition Rord n1 n2 (rn : nat_R n1 n2) : 'I_n1 -> binord n2 -> Type := 56 | fun x y => Rnat x y. 57 | 58 | #[export] Instance Rord_0 n1 n2 (rn : nat_R n1 n2) : 59 | refines (Rord (S_R rn)) 0%R 0%C. 60 | Proof. by rewrite refinesE. Qed. 61 | 62 | #[export] Instance Rord_1 n1 n2 (rn : nat_R n1 n2) : 63 | refines (Rord (S_R rn)) Zp1 1%C. 64 | Proof. 65 | rewrite refinesE /Rord /Zp1 /inZp /= modn_def (nat_R_eq rn). 66 | by case: n2 rn. 67 | Qed. 68 | 69 | Local Instance refines_nat_R_S n1 n2 : 70 | refines nat_R n1 n2 -> refines nat_R n1.+1 n2.+1. 71 | Proof. rewrite refinesE; exact: S_R. Qed. 72 | 73 | Local Instance refines_implem_eq A B (R : A -> B -> Type) 74 | `{implem_of A B, !refines (eq ==> R) implem_id implem} x y : 75 | refines eq x y -> refines R x (implem y). 76 | Proof. 77 | move=> eqxy. 78 | rewrite -[x]/(implem_id _). 79 | exact: refines_apply. 80 | Qed. 81 | 82 | Local Arguments Rord /. 83 | Local Arguments opp_op /. 84 | Local Arguments opp_ord /. 85 | Local Arguments N.sub : simpl nomatch. 86 | 87 | #[export] Instance Rord_opp n1 n2 (rn : nat_R n1 n2) : 88 | refines (Rord (S_R rn) ==> Rord (S_R rn)) -%R -%C. 89 | Proof. 90 | rewrite refinesE=> x x' hx /=. 91 | exact: refinesP. 92 | Qed. 93 | 94 | Local Arguments add_op /. 95 | Local Arguments add_ord /. 96 | 97 | #[export] Instance Rord_add n1 n2 (rn : nat_R n1 n2) : 98 | refines (Rord (S_R rn) ==> Rord (S_R rn) ==> Rord (S_R rn)) 99 | +%R +%C. 100 | Proof. 101 | rewrite refinesE=> x x' hx y y' hy /=. 102 | exact: refinesP. 103 | Qed. 104 | 105 | Local Arguments sub_op /. 106 | Local Arguments sub_ord /. 107 | 108 | #[export] Instance Rord_sub n1 n2 (rn : nat_R n1 n2) : 109 | refines (Rord (S_R rn) ==> Rord (S_R rn) ==> Rord (S_R rn)) 110 | (fun x y => x - y) sub_op. 111 | Proof. 112 | rewrite refinesE=> x x' hx y y' hy /=. 113 | exact: refinesP. 114 | Qed. 115 | 116 | Local Arguments mul_op /. 117 | Local Arguments mul_ord /. 118 | 119 | #[export] Instance Rord_mul n1 n2 (rn : nat_R n1 n2) : 120 | refines (Rord (S_R rn) ==> Rord (S_R rn) ==> Rord (S_R rn)) 121 | (@Zp_mul _) *%C. 122 | Proof. 123 | rewrite refinesE=> x x' hx y y' hy /=. 124 | exact: refinesP. 125 | Qed. 126 | 127 | Local Arguments eq_op /. 128 | Local Arguments eq_ord /. 129 | 130 | #[export] Instance Rord_eq n1 n2 (rn : nat_R n1 n2) : 131 | refines (Rord (S_R rn) ==> Rord (S_R rn) ==> bool_R) 132 | eqtype.eq_op eq_op. 133 | Proof. 134 | rewrite refinesE=> x x' hx y y' hy /=. 135 | have -> : (x == y) = (x == y :> nat) by []. 136 | exact: refinesP. 137 | Qed. 138 | 139 | Local Arguments leq_op /. 140 | Local Arguments leq_ord /. 141 | 142 | #[export] Instance Rord_leq n1 n2 (rn : nat_R n1 n2) : 143 | refines (Rord (S_R rn) ==> Rord (S_R rn) ==> bool_R) 144 | (fun x y => (x <= y)%N) leq_op. 145 | Proof. 146 | rewrite refinesE=> x x' hx y y' hy /=. 147 | exact: refinesP. 148 | Qed. 149 | 150 | Local Arguments lt_op /. 151 | Local Arguments lt_ord /. 152 | Local Opaque ltn. 153 | 154 | #[export] Instance Rord_lt n1 n2 (rn : nat_R n1 n2) : 155 | refines (Rord (S_R rn) ==> Rord (S_R rn) ==> bool_R) 156 | (fun x y => ltn x y) lt_op. 157 | Proof. 158 | rewrite refinesE=> x x' hx y y' hy /=. 159 | try change (pred_of_simpl (ltn x) y) with (rel_of_simpl ltn x y). 160 | exact: refinesP. 161 | Qed. 162 | 163 | Local Arguments implem_id /. 164 | Local Arguments implem /. 165 | Local Arguments implem_ord /. 166 | 167 | #[export] Instance Rord_implem n1 n2 (rn : nat_R n1 n2) : 168 | refines (ordinal_R rn ==> Rord rn) implem_id implem. 169 | Proof. 170 | rewrite refinesE=> x y rxy /=. 171 | rewrite -[implem_N]/implem. 172 | have hxy : refines eq (nat_of_ord x) (nat_of_ord y). 173 | rewrite refinesE. 174 | case: rxy=> m1 m2 rm _ _ _ /=. 175 | by rewrite (nat_R_eq rm). 176 | exact: refinesP. 177 | Qed. 178 | 179 | #[export] Instance Rnat_nat_of_ord n1 n2 (rn : nat_R n1 n2) : 180 | refines (Rord rn ==> Rnat) (@nat_of_ord n1) id. 181 | Proof. by rewrite refinesE. Qed. 182 | 183 | End binord_theory. 184 | -------------------------------------------------------------------------------- /refinements/boolF2.v: -------------------------------------------------------------------------------- 1 | (** This file is part of CoqEAL, the Coq Effective Algebra Library. 2 | (c) Copyright INRIA and University of Gothenburg, see LICENSE *) 3 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div choice. 4 | From mathcomp Require Import fintype bigop finset prime fingroup ssralg zmodp finalg. 5 | 6 | From CoqEAL Require Import hrel param refinements. 7 | 8 | Import Refinements.Op. 9 | 10 | Section operations. 11 | 12 | #[export] Instance zero_bool : zero_of bool := false. 13 | 14 | #[export] Instance one_bool : one_of bool := true. 15 | 16 | #[export] Instance opp_bool : opp_of bool := id. 17 | 18 | #[export] Instance add_bool : add_of bool := xorb. 19 | 20 | #[export] Instance sub_bool : sub_of bool := xorb. 21 | 22 | #[export] Instance mul_bool : mul_of bool := andb. 23 | 24 | #[export] Instance inv_bool : inv_of bool := id. 25 | 26 | #[export] Instance eq_bool : eq_of bool := eqtype.eq_op. 27 | 28 | End operations. 29 | 30 | Section definition. 31 | 32 | Local Open Scope ring_scope. 33 | Local Open Scope rel_scope. 34 | 35 | Definition F2_of_bool (x : bool) : 'F_2 := x%:R. 36 | 37 | Definition Rbool := fun_hrel F2_of_bool. 38 | 39 | #[export] Instance Rbool_zero : refines Rbool 0 0%C. 40 | Proof. by rewrite refinesE. Qed. 41 | 42 | #[export] Instance Rbool_one : refines Rbool 1 1%C. 43 | Proof. by rewrite refinesE. Qed. 44 | 45 | #[export] Instance Rbool_opp : refines (Rbool ==> Rbool) -%R -%C. 46 | Proof. 47 | rewrite refinesE => x. 48 | by case; rewrite /Rbool /F2_of_bool /fun_hrel /= => <-; apply/val_inj. 49 | Qed. 50 | 51 | #[export] Instance Rbool_add : refines (Rbool ==> Rbool ==> Rbool) +%R +%C. 52 | Proof. 53 | rewrite refinesE /Rbool /F2_of_bool /fun_hrel. 54 | by move=> x [] <- y [] <-; apply/val_inj. 55 | Qed. 56 | 57 | (* TODO: lemma for sub *) 58 | #[export] Instance Rbool_sub : 59 | refines (Rbool ==> Rbool ==> Rbool) (fun x y => x - y) sub_op. 60 | Proof. 61 | rewrite refinesE /Rbool /F2_of_bool /fun_hrel. 62 | by move=> x [] <- y [] <-; apply/val_inj. 63 | Qed. 64 | 65 | #[export] Instance Rbool_mul : refines (Rbool ==> Rbool ==> Rbool) *%R *%C. 66 | Proof. 67 | rewrite refinesE /Rbool /F2_of_bool /fun_hrel. 68 | by move=> x [] <- y [] <-; apply/val_inj. 69 | Qed. 70 | 71 | #[export] Instance Rbool_inv : refines (Rbool ==> Rbool) GRing.inv inv_bool. 72 | Proof. 73 | rewrite refinesE => x. 74 | by case; rewrite /Rbool /F2_of_bool /fun_hrel /= => <-; apply/val_inj. 75 | Qed. 76 | 77 | #[export] Instance Rbool_eq : 78 | refines (Rbool ==> Rbool ==> bool_R) eqtype.eq_op eq_op. 79 | Proof. 80 | by rewrite refinesE /Rbool /F2_of_bool /fun_hrel=> x [] <- y [] <-. 81 | Qed. 82 | 83 | (* 84 | Lemma inj_bool_trans : injective bool_of_F2. 85 | Proof. 86 | move=> [x Hx] [y Hy]; move: x y Hx Hy. 87 | case; do 3?case=> //; move=> Hx Hy _; exact: val_inj. 88 | Qed. 89 | 90 | Definition bool_trans_struct := Trans inj_bool_trans. 91 | 92 | Lemma bool_trans0 : bool_trans 0 = false. 93 | Proof. by []. Qed. 94 | 95 | Lemma oppbE : {morph bool_trans : x / - x >-> id x}. 96 | Proof. by move=> x; rewrite /bool_trans /= GRing.oppr_eq0. Qed. 97 | 98 | Lemma addbE : {morph bool_trans : x y / x + y >-> xorb x y}. 99 | Proof. 100 | move=> [x Hx] [y Hy]; move: x y Hx Hy. 101 | case; do 3?case=> //; move=> Hx Hy _; exact: val_inj. 102 | Qed. 103 | 104 | (* CZmodule structure *) 105 | Definition bool_czMixin := @CZmodMixin 106 | [zmodType of 'F_2] bool false 107 | id xorb bool_trans_struct bool_trans0 oppbE addbE. 108 | 109 | Canonical Structure bool_czType := 110 | Eval hnf in CZmodType 'F_2 bool bool_czMixin. 111 | 112 | Lemma bool_trans1 : bool_trans 1 = true. 113 | Proof. by []. Qed. 114 | 115 | Lemma mulbE : {morph bool_trans : x y / x * y >-> andb x y}. 116 | Proof. 117 | move=> x y; rewrite /bool_trans /= GRing.mulf_eq0. 118 | by case: (x == 0); case: (y == 0). 119 | Qed. 120 | 121 | Definition bool_cringMixin := CRingMixin bool_trans1 mulbE. 122 | 123 | Canonical Structure bool_cringType := 124 | Eval hnf in CRingType 'F_2 bool_cringMixin. 125 | 126 | Lemma cunitE : (forall x : 'F_2, (x \is a GRing.unit) = xpred1 true (bool_trans x)). 127 | Proof. by move=> x; rewrite GRing.unitfE /bool_trans eqb_id. Qed. 128 | 129 | Lemma invbE : {morph bool_trans : x / x^-1 >-> id x}. 130 | Proof. by do 3?case. Qed. 131 | 132 | Definition bool_cunitRingMixin := @CUnitRingMixin [unitRingType of 'F_2] 133 | bool_cringType (xpred1 true) id cunitE invbE. 134 | 135 | Canonical Structure bool_cunitRingType := 136 | Eval hnf in CUnitRingType 'F_2 bool_cunitRingMixin. 137 | 138 | *) 139 | 140 | End definition. 141 | -------------------------------------------------------------------------------- /refinements/examples/irred.v: -------------------------------------------------------------------------------- 1 | From HB Require Import structures. 2 | From mathcomp Require Import ssreflect ssrfun ssrbool. 3 | From mathcomp Require Import eqtype ssrnat seq choice fintype tuple. 4 | From mathcomp Require Import bigop binomial finset finfun perm fingroup. 5 | From mathcomp Require Import zmodp ssralg countalg finalg poly polydiv. 6 | 7 | From CoqEAL Require Import hrel pos param refinements binnat boolF2 seqpoly. 8 | From CoqEAL Require Import poly_op trivial_seq poly_div boolF2. 9 | 10 | 11 | Set Implicit Arguments. 12 | Unset Strict Implicit. 13 | Unset Printing Implicit Defensive. 14 | 15 | Import GRing.Theory. 16 | Import FinRing.Theory. 17 | Import Pdiv.Field. 18 | Import Refinements.Op Poly.Op. 19 | Local Open Scope ring_scope. 20 | 21 | Section npoly. 22 | 23 | Variable n : nat. 24 | Variable R : ringType. 25 | 26 | Record npolynomial : predArgType := Npolynomial { 27 | poly_of_npoly :> {poly R}; 28 | _ : (size poly_of_npoly <= n)%N 29 | }. 30 | 31 | HB.instance Definition _ := [isSub of npolynomial for poly_of_npoly]. 32 | HB.instance Definition _ := [Choice of pos by <:]. 33 | 34 | Definition npoly_of of (phant R) := npolynomial. 35 | Local Notation npoly_ofR := (npoly_of (Phant R)). 36 | 37 | HB.instance Definition _ := SubType.on npoly_ofR. 38 | HB.instance Definition _ := [Equality of npoly_ofR by <:]. 39 | 40 | End npoly. 41 | 42 | Notation "'{poly_' n R }" := (npoly_of n (Phant R)) 43 | (at level 0, n at level 1, format "'{poly_' n R }"). 44 | 45 | 46 | Section npoly_theory. 47 | Context {n : nat} (R : ringType). 48 | 49 | Lemma size_npoly (p : {poly_n R}) : (size p <= n)%N. Proof. exact: valP p. Qed. 50 | Hint Resolve size_npoly : core. 51 | Lemma npoly_inj : injective (@poly_of_npoly n R). Proof. exact: val_inj. Qed. 52 | Hint Resolve npoly_inj : core. 53 | 54 | Canonical npoly (E : nat -> R) : {poly_n R} := 55 | @Npolynomial _ _ (\poly_(i < n) E i) (size_poly _ _). 56 | 57 | Fact size_npoly0 : size (0 : {poly R}) <= n. 58 | Proof. by rewrite size_poly0. Qed. 59 | 60 | Definition npoly0 := Npolynomial (size_npoly0). 61 | 62 | Definition NPoly (p : {poly R}) : {poly_n R} := npoly (nth 0 p). 63 | 64 | Definition npoly_of_seq := NPoly \o Poly. 65 | 66 | Lemma npolyP (p q : {poly_n R}) : nth 0 p =1 nth 0 q <-> p = q. 67 | Proof. by split => [/polyP/val_inj|->]. Qed. 68 | 69 | Lemma coef_NPoly (p : {poly R}) i : (NPoly p)`_i = if i < n then p`_i else 0. 70 | Proof. by rewrite /= coef_poly. Qed. 71 | 72 | Lemma big_coef_npoly (p : {poly_n R}) i : n <= i -> p`_i = 0. 73 | Proof. by move=> i_big; rewrite nth_default // (leq_trans _ i_big). Qed. 74 | 75 | End npoly_theory. 76 | #[export] Hint Resolve size_npoly npoly_inj : core. 77 | 78 | Section fin_npoly. 79 | 80 | Variable R : finRingType. 81 | Variable n : nat. 82 | Implicit Types p q : {poly_n R}. 83 | 84 | HB.instance Definition _ := [Countable of (npolynomial n R) by <:]. 85 | 86 | Definition npoly_enum : seq {poly_n R} := 87 | if n isn't n.+1 then [:: npoly0 _] else 88 | pmap insub [seq \poly_(i < n.+1) c (inord i) | c : (R ^ n.+1)%type]. 89 | 90 | Lemma npoly_enum_uniq : uniq npoly_enum. 91 | Proof. 92 | rewrite /npoly_enum; case: n=> [|k] //. 93 | rewrite pmap_sub_uniq // map_inj_uniq => [|f g eqfg]; rewrite ?enum_uniq //. 94 | apply/ffunP => /= i; have /(congr1 (fun p : {poly _} => p`_i)) := eqfg. 95 | by rewrite !coef_poly ltn_ord inord_val. 96 | Qed. 97 | 98 | Lemma mem_npoly_enum p : p \in npoly_enum. 99 | Proof. 100 | rewrite /npoly_enum; case: n => [|k] // in p *. 101 | by case: p => [p sp] /=; rewrite in_cons -val_eqE /= -size_poly_leq0 sp. 102 | rewrite mem_pmap_sub; apply/mapP. 103 | eexists [ffun i : 'I__ => p`_i]; first by rewrite mem_enum. 104 | apply/polyP => i; rewrite coef_poly. 105 | have [i_small|i_big] := ltnP; first by rewrite ffunE /= inordK. 106 | by rewrite nth_default // 1?(leq_trans _ i_big) // size_npoly. 107 | Qed. 108 | 109 | HB.instance Definition _ := isFinite.Build (npolynomial n R) 110 | (Finite.uniq_enumP npoly_enum_uniq mem_npoly_enum). 111 | HB.instance Definition _ := Finite.on {poly_n R}. 112 | 113 | Lemma card_npoly : #|{poly_n R}| = (#|R| ^ n)%N. 114 | Proof. 115 | rewrite cardE enumT unlock /= /npoly_enum; case: n => [|k] //=. 116 | rewrite size_pmap_sub (@eq_in_count _ _ predT) ?count_predT; last first. 117 | by move=> _ /mapP /= [f _ ->]; rewrite size_poly. 118 | by rewrite size_map -cardE card_ffun card_ord. 119 | Qed. 120 | 121 | End fin_npoly. 122 | 123 | Section Irreducible. 124 | 125 | Variable R : finIdomainType. 126 | Variable p : {poly R}. 127 | 128 | Definition irreducibleb := 129 | ((1 < size p) && [forall q : {poly_((size p).-1) R}, (Pdiv.Ring.rdvdp q p)%R ==> (sizep q <= 1)])%N. 130 | 131 | Lemma irreducibleP : reflect (irreducible_poly p) irreducibleb. 132 | Proof. 133 | rewrite /irreducibleb /irreducible_poly. 134 | apply: (iffP idP) => [/andP[sp /'forall_implyP /= Fp]|[sp Fpoly]]. 135 | have sp_gt0 : size p > 0 by case: size sp. 136 | have p_neq0 : p != 0 by rewrite -size_poly_eq0; case: size sp. 137 | split => // q sq_neq1 dvd_qp; rewrite -dvdp_size_eqp // eqn_leq dvdp_leq //=. 138 | apply: contraNT sq_neq1; rewrite -ltnNge => sq_lt_sp. 139 | have q_small: (size q <= (size p).-1)%N by rewrite -ltnS prednK. 140 | rewrite Pdiv.Idomain.dvdpE in dvd_qp. 141 | have /= := Fp (Npolynomial q_small) dvd_qp. 142 | rewrite leq_eqVlt ltnS => /orP[//|]; rewrite size_poly_leq0 => /eqP q_eq0. 143 | by rewrite -Pdiv.Idomain.dvdpE q_eq0 dvd0p (negPf p_neq0) in dvd_qp. 144 | have sp_gt0 : size p > 0 by case: size sp. 145 | rewrite sp /=; apply/'forall_implyP => /= q; rewrite -Pdiv.Idomain.dvdpE=> dvd_qp. 146 | have [/eqP->//|/Fpoly/(_ dvd_qp)/eqp_size sq_eq_sp] := boolP (sizep q == 1%N). 147 | by have := size_npoly q; rewrite sq_eq_sp -ltnS prednK ?ltnn. 148 | Qed. 149 | 150 | End Irreducible. 151 | 152 | Module Import nat_ops. 153 | 154 | #[export] Instance zero_nat : zero_of nat := 0%N. 155 | #[export] Instance one_nat : one_of nat := 1%N. 156 | #[export] Instance add_nat : add_of nat := addn. 157 | #[export] Instance sub_nat : sub_of nat := subn. 158 | #[export] Instance mul_nat : mul_of nat := muln. 159 | #[export] Instance exp_nat : exp_of nat nat := expn. 160 | #[export] Instance leq_nat : leq_of nat := ssrnat.leq. 161 | #[export] Instance lt_nat : lt_of nat := ssrnat.ltn. 162 | #[export] Instance eq_nat : eq_of nat := eqtype.eq_op. 163 | 164 | #[export] Instance spec_nat : spec_of nat nat := spec_id. 165 | 166 | #[export] Instance implem_nat : implem_of nat nat := implem_id. 167 | 168 | End nat_ops. 169 | 170 | Section card. 171 | Context (T' : Type) (N : Type). 172 | Context (enumT' : seq T') `{zero_of N} `{one_of N} `{add_of N}. 173 | Definition card' (P' : pred T') : N := size_op [seq s <- enumT' | P' s]. 174 | End card. 175 | Elpi derive.param2 card'. 176 | 177 | Lemma size_seqE T (s : seq T) : (@size_seq _ _ 0%N 1%N addn) s = size s. 178 | Proof. by elim: s => //= x s ->; rewrite [(_ + _)%C]addn1. Qed. 179 | 180 | Lemma card'_perm (T : eqType) (s s' : seq T) (P : pred T) : 181 | perm_eq s s' -> card' s P = card' s' P :> nat. 182 | Proof. 183 | move=> peq_ss'; rewrite /card' /size_op !size_seqE. 184 | by apply/perm_size/seq.permP=> x; rewrite !count_filter; apply/seq.permP. 185 | Qed. 186 | 187 | Lemma card'E (T : finType) (P : pred T) : card' (@Finite.enum _) P = #|P|. 188 | Proof. by rewrite cardE; rewrite /card' /size_op/= size_seqE. Qed. 189 | 190 | Local Open Scope rel_scope. 191 | 192 | Section enumerable. 193 | Context (T : finType) (T' : Type) (RT : T -> T' -> Type). 194 | Variable (N : Type) (rN : nat -> N -> Type). 195 | Context (enumT' : seq T') 196 | {enumR : refines (perm_eq \o list_R RT) (@Finite.enum T) enumT'}. 197 | Context `{zero_of N} `{one_of N} `{add_of N}. 198 | Context `{!refines rN 0%N 0%C}. 199 | Context `{!refines rN 1%N 1%C}. 200 | Context `{!refines (rN ==> rN ==> rN) addn add_op}. 201 | Context (P : pred T) (P' : pred T'). 202 | 203 | #[export] Instance refines_card : 204 | (forall x x' `{!refines RT x x'}, refines (bool_R \o @unify _) (P x) (P' x')) -> 205 | refines rN #|[pred x | P x]| (card' enumT' P'). 206 | Proof. 207 | move=> RP; have := refines_comp_unify (RP _ _ _) => /refines_abstr => {}RP. 208 | have [s [rs1 rs2]] := refines_split2 enumR. 209 | by rewrite -card'E (@card'_perm _ _ s) //; param card'_R. 210 | Qed. 211 | 212 | End enumerable. 213 | 214 | Local Open Scope rel_scope. 215 | 216 | Section enum_boolF2. 217 | 218 | Definition enum_boolF2 : seq bool := [:: false; true]. 219 | 220 | End enum_boolF2. 221 | 222 | Elpi derive.param2 enum_boolF2. 223 | 224 | #[export] Instance refines_enum_boolF2 : 225 | refines (perm_eq \o list_R Rbool) (Finite.enum 'F_2) (enum_boolF2). 226 | Proof. 227 | rewrite -enumT; refines_trans; last first. 228 | by rewrite refinesE; do !constructor. 229 | rewrite refinesE /= uniq_perm ?enum_uniq //. 230 | by move=> i; rewrite mem_enum /= !inE; case: i => [[|[|[]]] ?]. 231 | Qed. 232 | 233 | Section enum_npoly. 234 | 235 | Context (N : Type) (n : N) (A : Type) (P : Type). 236 | Context (iter : forall T, N -> (T -> T) -> T -> T). 237 | Context (enum : seq A) (poly_of_seq : seq A -> P). 238 | 239 | Definition enum_npoly : seq P := 240 | let extend e := e ++ flatten [seq map (cons x) e | x <- enum] in 241 | map poly_of_seq (iter n extend [::[::]]). 242 | 243 | End enum_npoly. 244 | 245 | Lemma enum_npolyE (n : nat) (R : finRingType) s : 246 | perm_eq (Finite.enum R) s -> 247 | perm_eq (Finite.enum {poly_n R}) 248 | (enum_npoly n iter s (@npoly_of_seq _ _)). 249 | Proof. 250 | rewrite -!enumT => Rs; rewrite uniq_perm ?enum_uniq //=. 251 | admit. 252 | move=> /= p; symmetry; rewrite mem_enum inE /=. 253 | apply/mapP => /=; exists p; last first. 254 | apply/npolyP => i; rewrite coef_poly /= coef_Poly. 255 | by case: ltnP => // ?; rewrite big_coef_npoly. 256 | elim: n => [|n IHn] in p *. 257 | rewrite inE; case: p => [p /=]; rewrite size_poly_leq0 => /eqP->. 258 | by rewrite polyseq0. 259 | rewrite /= mem_cat. 260 | Admitted. 261 | 262 | Elpi derive.param2 enum_npoly. 263 | 264 | Section RnpolyC. 265 | 266 | Context (A : finRingType). 267 | Context (C : Type) (rAC : A -> C -> Type). 268 | Context (N : Type) (rN : nat -> N -> Type). 269 | Context (n : nat) (n' : N) `{!refines rN n n'}. 270 | Context (iter' : forall T, N -> (T -> T) -> T -> T) 271 | {iterR : forall T T' RT, 272 | refines (rN ==> (RT ==> RT) ==> RT ==> RT) (@iter T) (@iter' T')}. 273 | Context (enumC : seq C) 274 | {enumR : refines (perm_eq \o list_R rAC) (@Finite.enum A) enumC}. 275 | 276 | Definition Rnpoly : {poly_n A} -> {poly A} -> Type := 277 | fun p q => p = q :> {poly A}. 278 | 279 | Definition RnpolyC : {poly_n A} -> seqpoly C -> Type := 280 | (Rnpoly \o RseqpolyC rAC)%rel. 281 | 282 | #[export] Instance refines_enum_npoly : 283 | refines (perm_eq \o list_R RnpolyC) 284 | (Finite.enum {poly_n A}) (enum_npoly n' iter' enumC id). 285 | Proof. 286 | have [s [sP ?]] := refines_split2 enumR. 287 | eapply refines_trans; tc. 288 | by rewrite refinesE; apply/enum_npolyE/sP. 289 | param enum_npoly_R. 290 | 291 | Admitted. 292 | 293 | #[export] Instance refines_RnpolyCpoly (x : {poly_n A}) (y : seqpoly C) 294 | `{!refines RnpolyC x y} : refines (RseqpolyC rAC) (poly_of_npoly x) y. 295 | Admitted. 296 | 297 | End RnpolyC. 298 | 299 | #[export] Instance refines_iter T T' RT : 300 | refines (Rnat ==> (RT ==> RT) ==> RT ==> RT) (@iter T) (@iter T'). 301 | Proof. 302 | param iter_R. 303 | Admitted. 304 | 305 | Section LaurentsProblem. 306 | 307 | #[export] Instance refines_predn : refines (Rnat ==> Rnat) predn (fun n => (n - 1)%C). 308 | Admitted. 309 | 310 | Lemma test_irred : irreducible_poly ('X^5 + 'X^2 + 1 : {poly 'F_2}). 311 | Proof. 312 | apply/irreducibleP; rewrite /irreducibleb -[size _]/(sizep _). 313 | rewrite -[[forall _, _]]/(_ == _) /= /Pdiv.Ring.rdvdp. 314 | by coqeal. 315 | Qed. 316 | 317 | End LaurentsProblem. 318 | -------------------------------------------------------------------------------- /refinements/hrel.v: -------------------------------------------------------------------------------- 1 | 2 | (** This file is part of CoqEAL, the Coq Effective Algebra Library. 3 | (c) Copyright INRIA and University of Gothenburg, see LICENSE *) 4 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq zmodp. 5 | From mathcomp Require Import path choice fintype tuple finset bigop. 6 | 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Unset Printing Implicit Defensive. 10 | 11 | Declare Scope rel_scope. 12 | Delimit Scope rel_scope with rel. 13 | 14 | (***************************) 15 | (* Heterogeneous Relations *) 16 | (***************************) 17 | Section hrel. 18 | 19 | Definition sub_hrel A B (R R' : A -> B -> Type) := 20 | forall (x : A) (y : B), R x y -> R' x y. 21 | 22 | Notation "X <= Y" := (sub_hrel X%rel Y%rel) : rel_scope. 23 | 24 | Inductive eq_hrel A B (R R' : A -> B -> Type) := 25 | EqHrel of (R <= R')%rel & (R' <= R)%rel. 26 | 27 | Notation "X <=> Y" := (eq_hrel X Y) (format "X <=> Y", at level 95) : rel_scope. 28 | 29 | Lemma eq_hrelRL A B (R R' : A -> B -> Type) : (R <=> R')%rel -> (R <= R')%rel. 30 | Proof. by case. Qed. 31 | 32 | Lemma eq_hrelLR A B (R R' : A -> B -> Type) : (R <=> R')%rel -> (R' <= R)%rel. 33 | Proof. by case. Qed. 34 | 35 | Definition comp_hrel A B C 36 | (R : A -> B -> Type) (R' : B -> C -> Type) : A -> C -> Type := 37 | fun a c => sigT (fun b => R a b * R' b c)%type. 38 | 39 | Notation "X \o Y" := (comp_hrel X Y) : rel_scope. 40 | 41 | Lemma comp_hrelP A B C (R : A -> B -> Type) (R' : B -> C -> Type) 42 | (b : B) (a : A) (c : C) : R a b -> R' b c -> (R \o R')%rel a c. 43 | Proof. by exists b. Qed. 44 | 45 | Definition prod_hrel A A' B B' (rA : A -> A' -> Type) (rB : B -> B' -> Type) : 46 | A * B -> A' * B' -> Type := 47 | fun x y => (rA x.1 y.1 * rB x.2 y.2)%type. 48 | 49 | Lemma comp_eqr A B (R : A -> B -> Type) : (R \o eq <= R)%rel. 50 | Proof. by move=> x y [y' [? <-]]. Qed. 51 | 52 | Lemma comp_eql A B (R : A -> B -> Type) : (eq \o R <= R)%rel. 53 | Proof. by move=> x y [y' [<-]]. Qed. 54 | 55 | Definition fun_hrel A B (f : B -> A) : A -> B -> Type := 56 | fun a b => f b = a. 57 | 58 | Definition ofun_hrel A B (f : B -> option A) : A -> B -> Type := 59 | fun a b => f b = Some a. 60 | 61 | Definition hrespectful (A B C D : Type) 62 | (R : A -> B -> Type) (R' : C -> D -> Type) : (A -> C) -> (B -> D) -> Type := 63 | fun f g => forall (x : A) (y : B), R x y -> R' (f x) (g y). 64 | 65 | Notation " R ==> S " := (@hrespectful _ _ _ _ R%rel S%rel) 66 | (right associativity, at level 55) : rel_scope. 67 | 68 | Lemma sub_hresp_comp A B C (R1 R1' : A -> B -> Prop) (R2 R2' : B -> C -> Prop) : 69 | (((R1 ==> R1') \o (R2 ==> R2')) <= ((R1 \o R2) ==> (R1' \o R2')))%rel. 70 | Proof. 71 | move=> f h [g [rfg rgh]] x z [y [rxy ryz]]; exists (g y). 72 | by split; [apply: rfg | apply: rgh]. 73 | Qed. 74 | 75 | End hrel. 76 | 77 | Notation "X \o Y" := (comp_hrel X%rel Y%rel) : rel_scope. 78 | Notation "X <= Y" := (sub_hrel X%rel Y%rel) : rel_scope. 79 | Notation "X <=> Y" := (eq_hrel X%rel Y%rel) (format "X <=> Y", at level 95) : rel_scope. 80 | Notation " R ==> S " := (@hrespectful _ _ _ _ R%rel S%rel) 81 | (right associativity, at level 55) : rel_scope. 82 | 83 | -------------------------------------------------------------------------------- /refinements/karatsuba.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq ssralg. 2 | From mathcomp Require Import path choice fintype tuple finset bigop poly polydiv. 3 | 4 | From CoqEAL Require Import hrel param refinements poly_op. 5 | 6 | Set Implicit Arguments. 7 | Unset Strict Implicit. 8 | Unset Printing Implicit Defensive. 9 | 10 | Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic. 11 | Import Refinements.Op Poly.Op. 12 | 13 | Local Open Scope ring_scope. 14 | Local Open Scope rel. 15 | 16 | Section karatsuba_generic. 17 | 18 | Variable polyA N : Type. 19 | 20 | Context `{add_of polyA, mul_of polyA, sub_of polyA}. 21 | Context `{shiftp : shift_of polyA N, sizep : size_of polyA N}. 22 | Context `{splitp : split_of polyA N}. 23 | Context `{one_of N, add_of N, mul_of N, leq_of N}. 24 | Context `{spec_of N nat, implem_of nat N}. 25 | 26 | Fixpoint karatsuba_rec n (p q : polyA) := match n with 27 | | 0 => (p * q)%C 28 | | n'.+1 => 29 | let sp := sizep p in let sq := sizep q in 30 | if (sp <= 1 + 1)%C || (sq <= 1 + 1)%C then (p * q)%C else 31 | let m := implem (minn (spec sp)./2 (spec sq)./2) in 32 | let (p1,p2) := splitp m p in 33 | let (q1,q2) := splitp m q in 34 | let p1q1 := karatsuba_rec n' p1 q1 in 35 | let p2q2 := karatsuba_rec n' p2 q2 in 36 | let p12 := (p1 + p2)%C in 37 | let q12 := (q1 + q2)%C in 38 | let p12q12 := karatsuba_rec n' p12 q12 in 39 | (shiftp ((1 + 1) * m)%C p1q1 + 40 | shiftp m (p12q12 - p1q1 - p2q2) + 41 | p2q2)%C 42 | end. 43 | 44 | Definition karatsuba p q := 45 | karatsuba_rec (maxn (spec (sizep p)) (spec (sizep q))) p q. 46 | 47 | End karatsuba_generic. 48 | 49 | Elpi derive.param2 karatsuba_rec. 50 | Elpi derive.param2 karatsuba. 51 | 52 | Section karatsuba_correctness. 53 | 54 | Local Open Scope rel_scope. 55 | 56 | Variable R : ringType. 57 | 58 | Instance add_polyR : add_of {poly R} := +%R. 59 | Instance mul_polyR : mul_of {poly R} := *%R. 60 | Instance sub_polyR : sub_of {poly R} := fun x y => (x - y)%R. 61 | Instance size_polyR : size_of {poly R} nat := sizep (R:=R). 62 | Instance shift_polyR : shift_of {poly R} nat := shiftp (R:=R). 63 | Instance split_polyR : split_of {poly R} nat := splitp (R:=R). 64 | 65 | Local Instance one_nat : one_of nat := 1%N. 66 | Local Instance add_nat : add_of nat := addn. 67 | Local Instance mul_nat : mul_of nat := muln. 68 | Local Instance leq_nat : leq_of nat := ssrnat.leq. 69 | Local Instance spec_nat : spec_of nat nat := spec_id. 70 | Local Instance implem_nat : implem_of nat nat := implem_id. 71 | 72 | Lemma karatsuba_recE n (p q : {poly R}) : karatsuba_rec (N:=nat) n p q = p * q. 73 | Proof. 74 | elim: n=> //= n ih in p q *; case: ifP=> // _; set m := minn _ _. 75 | rewrite [p in RHS](rdivp_eq (monicXn _ m)) [q in RHS](rdivp_eq (monicXn _ m)). 76 | rewrite /shift_op /shift_polyR /shiftp /implem /implem_nat /implem_id. 77 | simpC. 78 | rewrite !ih !(mulrDl, mulrDr, mulNr) mulnC exprM. 79 | rewrite -[in X in X + _]addrA -opprD [X in X + _ - _]addrC [in LHS]addrACA. 80 | by rewrite addrK !(commr_polyXn, mulrA, addrA). 81 | Qed. 82 | 83 | Lemma karatsubaE (p q : {poly R}) : karatsuba (N:=nat) p q = p * q. 84 | Proof. exact: karatsuba_recE. Qed. 85 | 86 | Section karatsuba_param. 87 | 88 | Context (polyC : Type) (RpolyC : {poly R} -> polyC -> Type). 89 | Context (N : Type) (rN : nat -> N -> Type). 90 | Context `{add_of polyC, mul_of polyC, sub_of polyC}. 91 | Context `{one_of N, add_of N, mul_of N, leq_of N}. 92 | Context `{spec_of N nat, implem_of nat N}. 93 | Context `{!refines (RpolyC ==> RpolyC ==> RpolyC) +%R +%C}. 94 | Context `{!refines (RpolyC ==> RpolyC ==> RpolyC) *%R *%C}. 95 | Context `{!refines (RpolyC ==> RpolyC ==> RpolyC) (fun x y => x - y)%R sub_op}. 96 | Context `{!refines rN 1%N 1%C}. 97 | Context `{!refines (rN ==> rN ==> rN) addn +%C}. 98 | Context `{!refines (rN ==> rN ==> rN) muln *%C}. 99 | Context `{!refines (rN ==> rN ==> bool_R) ssrnat.leq leq_op}. 100 | Context `{!refines (rN ==> nat_R) spec_id spec, 101 | !refines (nat_R ==> rN) implem_id implem}. 102 | 103 | Context `{!shift_of polyC N}. 104 | Context `{!refines (rN ==> RpolyC ==> RpolyC) shift_polyR shift_op}. 105 | 106 | Context `{!size_of polyC N}. 107 | Context `{!refines (RpolyC ==> rN) size_polyR size_op}. 108 | 109 | Context `{!split_of polyC N}. 110 | Context `{!refines (rN ==> RpolyC ==> prod_R RpolyC RpolyC) split_polyR split_op}. 111 | 112 | 113 | #[export] Instance RpolyC_karatsuba_rec : 114 | refines (nat_R ==> RpolyC ==> RpolyC ==> RpolyC) 115 | (karatsuba_rec (polyA:={poly R}) (N:=nat)) 116 | (karatsuba_rec (polyA:=polyC) (N:=N)). 117 | Proof. param karatsuba_rec_R. Qed. 118 | 119 | #[export] Instance RpolyC_karatsuba : 120 | refines (RpolyC ==> RpolyC ==> RpolyC) 121 | (karatsuba (polyA:={poly R}) (N:=nat)) (karatsuba (polyA:=polyC) (N:=N)). 122 | Proof. param karatsuba_R. Qed. 123 | 124 | #[export] Instance RpolyC_karatsuba_mul p sp q sq : 125 | refines RpolyC p sp -> refines RpolyC q sq -> 126 | refines RpolyC (p * q) (karatsuba (N:=N) sp sq). 127 | Proof. 128 | move=> hp hq. 129 | rewrite refinesE -karatsubaE. 130 | exact: refinesP. 131 | Qed. 132 | 133 | End karatsuba_param. 134 | End karatsuba_correctness. 135 | 136 | From mathcomp Require Import ssrint. 137 | From CoqEAL Require Import binnat binint seqpoly. 138 | 139 | Section karatsuba_test. 140 | 141 | Goal ((1 + 2%:Z *: 'X) * (1 + 2%:Z%:P * 'X) == 1 + 4%:Z *: 'X + 4%:Z%:P * 'X^2). 142 | by coqeal. 143 | Abort. 144 | 145 | Goal (Poly [:: 1; 2%:Z] * Poly [:: 1; 2%:Z]) == Poly [:: 1; 4%:Z; 4%:Z]. 146 | by coqeal. 147 | Abort. 148 | 149 | Fixpoint bigseq (x : int) (n : nat) : seq int := match n with 150 | | 0 => [:: x] 151 | | n'.+1 => x :: bigseq (x+1) n' 152 | end. 153 | 154 | Fixpoint bigpoly (x : int) (n : nat) : {poly int} := 155 | match n with 156 | | 0 => x%:P 157 | | n.+1 => x%:P + (bigpoly (x+1) n) * 'X 158 | end. 159 | 160 | Let p1 := Eval compute in bigseq 1%N 10. 161 | Let p2 := Eval compute in bigseq 2%N 10. 162 | 163 | Let q1 := Eval simpl in bigpoly 1%N 10. 164 | Let q2 := Eval simpl in bigpoly 2%N 10. 165 | 166 | (* TODO: Translate Poly directly? *) 167 | Goal (Poly p1 * Poly p2 == Poly p2 * Poly p1). 168 | by coqeal. 169 | Abort. 170 | 171 | Goal (q1 * q2 == q2 * q1). 172 | by coqeal. 173 | Abort. 174 | 175 | End karatsuba_test. 176 | -------------------------------------------------------------------------------- /refinements/param.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype. 2 | From elpi Require Import derive param2. 3 | 4 | Set Implicit Arguments. 5 | Unset Strict Implicit. 6 | Unset Printing Implicit Defensive. 7 | 8 | #[global] Ltac destruct_reflexivity := 9 | intros ; repeat match goal with 10 | | [ x : _ |- _ = _ ] => destruct x; reflexivity; fail 11 | end. 12 | 13 | (** Automation: for turning [sth_R a b] goals into mere [a = b] goals, 14 | do [suff_eq sth_Rxx]. *) 15 | Ltac suff_eq Rxx := 16 | match goal with 17 | | [ |- ?R ?a ?b ] => 18 | let H := fresh in 19 | suff H : a = b; first (rewrite H; eapply Rxx =>//) 20 | end. 21 | 22 | Require Import ProofIrrelevance. (* for opaque terms *) 23 | 24 | (* data types *) 25 | Elpi derive.param2 option. 26 | Elpi derive.param2 unit. 27 | Elpi derive.param2 bool. 28 | #[export] Hint Resolve true_R false_R : core. 29 | Elpi derive.param2 nat. 30 | Elpi derive.param2 list. 31 | Elpi derive.param2 prod. 32 | 33 | Lemma bool_Rxx b : bool_R b b. 34 | Proof. by case: b. Qed. 35 | 36 | Lemma nat_Rxx n : nat_R n n. 37 | Proof. 38 | elim: n=> [|n]; 39 | [ exact: O_R | exact: S_R ]. 40 | Qed. 41 | 42 | Lemma list_Rxx T (rT : T -> T -> Type) l : 43 | (forall x, rT x x) -> list_R rT l l. 44 | Proof. 45 | move=> Hr; elim: l=> [|h t IH]; [exact: nil_R|]. 46 | exact: cons_R. 47 | Qed. 48 | 49 | Lemma option_Rxx T (rT : T -> T -> Type) l : 50 | (forall x, rT x x) -> option_R rT l l. 51 | Proof. by move=> Hr; case: l => *; constructor. Qed. 52 | 53 | (** ssrfun *) 54 | Elpi derive.param2 simpl_fun. 55 | 56 | (** ssrbool *) 57 | Elpi derive.param2 pred. 58 | Elpi derive.param2 rel. 59 | Elpi derive.param2 simpl_pred. 60 | Elpi derive.param2 simpl_rel. 61 | Elpi derive.param2 SimplPred. 62 | Elpi derive.param2 SimplRel. 63 | Elpi derive.param2 orb. 64 | Elpi derive.param2 andb. 65 | Elpi derive.param2 implb. 66 | Elpi derive.param2 negb. 67 | Elpi derive.param2 addb. 68 | Elpi derive.param2 eqb. 69 | 70 | (** ssrnat *) 71 | Elpi derive.param2 Nat.sub. 72 | Elpi derive.param2 subn. 73 | Elpi derive.param2 subn_rec. 74 | Elpi derive.param2 Nat.add. 75 | Elpi derive.param2 addn. 76 | Elpi derive.param2 addn_rec. 77 | Elpi derive.param2 addn. 78 | Elpi derive.param2 eqn. 79 | 80 | (* This trick avoids having to apply Parametricity to eqtype structure *) 81 | Opaque eqn subn. 82 | Definition leqn := Eval cbv in leq. 83 | Elpi derive.param2 leqn. 84 | Definition leq_R := leqn_R. 85 | Elpi derive.param2.register leq leq_R. 86 | 87 | Elpi derive.param2 Logic.eq. 88 | 89 | (* geq, ltn and gtn use SimplRel, not sure how well they will work in 90 | proofs... *) 91 | Elpi derive.param2 geq. 92 | Elpi derive.param2 ltn. 93 | Elpi derive.param2 gtn. 94 | 95 | Elpi derive.param2 maxn. 96 | Elpi derive.param2 minn. 97 | Elpi derive.param2 iter. 98 | Elpi derive.param2 iteri. 99 | Elpi derive.param2 iterop. 100 | Elpi derive.param2 Nat.mul. 101 | Elpi derive.param2 muln. 102 | Elpi derive.param2 muln_rec. 103 | Elpi derive.param2 expn. 104 | Elpi derive.param2 expn_rec. 105 | Elpi derive.param2 factorial. 106 | Elpi derive.param2 fact_rec. 107 | Elpi derive.param2 odd. 108 | Elpi derive.param2 double. 109 | Elpi derive.param2 double_rec. 110 | 111 | (* Obtained from paramcoq *) 112 | Definition half_R := 113 | let fix_half_1 : forall _ : nat, nat := 114 | fix half (n : nat) : nat := 115 | match n return nat with 116 | | @O => n 117 | | @S n' => uphalf n' 118 | end 119 | with uphalf (n : nat) : nat := 120 | match n return nat with 121 | | @O => n 122 | | @S n' => S (half n') 123 | end 124 | for 125 | half in 126 | let fix_half_2 : forall _ : nat, nat := 127 | fix half (n : nat) : nat := 128 | match n return nat with 129 | | @O => n 130 | | @S n' => uphalf n' 131 | end 132 | with uphalf (n : nat) : nat := 133 | match n return nat with 134 | | @O => n 135 | | @S n' => S (half n') 136 | end 137 | for 138 | half in 139 | let fix_uphalf_1 : forall _ : nat, nat := 140 | fix half (n : nat) : nat := 141 | match n return nat with 142 | | @O => n 143 | | @S n' => uphalf n' 144 | end 145 | with uphalf (n : nat) : nat := 146 | match n return nat with 147 | | @O => n 148 | | @S n' => S (half n') 149 | end 150 | for 151 | uphalf in 152 | let fix_uphalf_2 : forall _ : nat, nat := 153 | fix half (n : nat) : nat := 154 | match n return nat with 155 | | @O => n 156 | | @S n' => uphalf n' 157 | end 158 | with uphalf (n : nat) : nat := 159 | match n return nat with 160 | | @O => n 161 | | @S n' => S (half n') 162 | end 163 | for 164 | uphalf in 165 | fix half_R (n₁ n₂ : nat) (n_R : nat_R n₁ n₂) {struct n_R} : nat_R (fix_half_1 n₁) (fix_half_2 n₂) := 166 | let gen_path : 167 | let half : forall _ : nat, nat := 168 | fix half (n : nat) : nat := 169 | match n return nat with 170 | | @O => n 171 | | @S n' => uphalf n' 172 | end 173 | with uphalf (n : nat) : nat := 174 | match n return nat with 175 | | @O => n 176 | | @S n' => S (half n') 177 | end 178 | for 179 | half in 180 | let uphalf : forall _ : nat, nat := 181 | fix half0 (n : nat) : nat := 182 | match n return nat with 183 | | @O => n 184 | | @S n' => uphalf n' 185 | end 186 | with uphalf (n : nat) : nat := 187 | match n return nat with 188 | | @O => n 189 | | @S n' => S (half0 n') 190 | end 191 | for 192 | uphalf in 193 | forall n : nat, @eq nat match n return nat with 194 | | @O => n 195 | | @S n' => uphalf n' 196 | end (half n) := 197 | let half : forall _ : nat, nat := 198 | fix half (n : nat) : nat := 199 | match n return nat with 200 | | @O => n 201 | | @S n' => uphalf n' 202 | end 203 | with uphalf (n : nat) : nat := 204 | match n return nat with 205 | | @O => n 206 | | @S n' => S (half n') 207 | end 208 | for 209 | half in 210 | let uphalf : forall _ : nat, nat := 211 | fix half0 (n : nat) : nat := 212 | match n return nat with 213 | | @O => n 214 | | @S n' => uphalf n' 215 | end 216 | with uphalf (n : nat) : nat := 217 | match n return nat with 218 | | @O => n 219 | | @S n' => S (half0 n') 220 | end 221 | for 222 | uphalf in 223 | fun n : nat => 224 | match n as n0 return (@eq nat match n0 return nat with 225 | | @O => n0 226 | | @S n' => uphalf n' 227 | end (half n0)) with 228 | | @O => @Logic.eq_refl nat (half O) 229 | | @S n0 => (fun n1 : nat => @Logic.eq_refl nat (half (S n1))) n0 230 | end in 231 | @eq_rect nat match n₁ return nat with 232 | | @O => n₁ 233 | | @S n' => fix_uphalf_1 n' 234 | end (fun x : nat => nat_R x (fix_half_2 n₂)) 235 | (@eq_rect nat match n₂ return nat with 236 | | @O => n₂ 237 | | @S n' => fix_uphalf_2 n' 238 | end (fun x : nat => nat_R match n₁ return nat with 239 | | @O => n₁ 240 | | @S n' => fix_uphalf_1 n' 241 | end x) 242 | match 243 | n_R in (nat_R n₁0 n₂0) 244 | return 245 | (nat_R match n₁0 return nat with 246 | | @O => n₁ 247 | | @S n' => fix_uphalf_1 n' 248 | end match n₂0 return nat with 249 | | @O => n₂ 250 | | @S n' => fix_uphalf_2 n' 251 | end) 252 | with 253 | | @O_R => n_R 254 | | @S_R n'₁ n'₂ n'_R => uphalf_R n'₁ n'₂ n'_R 255 | end (fix_half_2 n₂) (gen_path n₂)) (fix_half_1 n₁) (gen_path n₁) 256 | with uphalf_R (n₁ n₂ : nat) (n_R : nat_R n₁ n₂) {struct n_R} : nat_R (fix_uphalf_1 n₁) (fix_uphalf_2 n₂) := 257 | let gen_path : 258 | let half : forall _ : nat, nat := 259 | fix half (n : nat) : nat := 260 | match n return nat with 261 | | @O => n 262 | | @S n' => uphalf n' 263 | end 264 | with uphalf (n : nat) : nat := 265 | match n return nat with 266 | | @O => n 267 | | @S n' => S (half n') 268 | end 269 | for 270 | half in 271 | let uphalf : forall _ : nat, nat := 272 | fix half0 (n : nat) : nat := 273 | match n return nat with 274 | | @O => n 275 | | @S n' => uphalf n' 276 | end 277 | with uphalf (n : nat) : nat := 278 | match n return nat with 279 | | @O => n 280 | | @S n' => S (half0 n') 281 | end 282 | for 283 | uphalf in 284 | forall n : nat, @eq nat match n return nat with 285 | | @O => n 286 | | @S n' => S (half n') 287 | end (uphalf n) := 288 | let half : forall _ : nat, nat := 289 | fix half (n : nat) : nat := 290 | match n return nat with 291 | | @O => n 292 | | @S n' => uphalf n' 293 | end 294 | with uphalf (n : nat) : nat := 295 | match n return nat with 296 | | @O => n 297 | | @S n' => S (half n') 298 | end 299 | for 300 | half in 301 | let uphalf : forall _ : nat, nat := 302 | fix half0 (n : nat) : nat := 303 | match n return nat with 304 | | @O => n 305 | | @S n' => uphalf n' 306 | end 307 | with uphalf (n : nat) : nat := 308 | match n return nat with 309 | | @O => n 310 | | @S n' => S (half0 n') 311 | end 312 | for 313 | uphalf in 314 | fun n : nat => 315 | match n as n0 return (@eq nat match n0 return nat with 316 | | @O => n0 317 | | @S n' => S (half n') 318 | end (uphalf n0)) with 319 | | @O => @Logic.eq_refl nat (uphalf O) 320 | | @S n0 => (fun n1 : nat => @Logic.eq_refl nat (uphalf (S n1))) n0 321 | end in 322 | @eq_rect nat match n₁ return nat with 323 | | @O => n₁ 324 | | @S n' => S (fix_half_1 n') 325 | end (fun x : nat => nat_R x (fix_uphalf_2 n₂)) 326 | (@eq_rect nat match n₂ return nat with 327 | | @O => n₂ 328 | | @S n' => S (fix_half_2 n') 329 | end (fun x : nat => nat_R match n₁ return nat with 330 | | @O => n₁ 331 | | @S n' => S (fix_half_1 n') 332 | end x) 333 | match 334 | n_R in (nat_R n₁0 n₂0) 335 | return 336 | (nat_R match n₁0 return nat with 337 | | @O => n₁ 338 | | @S n' => S (fix_half_1 n') 339 | end match n₂0 return nat with 340 | | @O => n₂ 341 | | @S n' => S (fix_half_2 n') 342 | end) 343 | with 344 | | @O_R => n_R 345 | | @S_R n'₁ n'₂ n'_R => @S_R (fix_half_1 n'₁) (fix_half_2 n'₂) (half_R n'₁ n'₂ n'_R) 346 | end (fix_uphalf_2 n₂) (gen_path n₂)) (fix_uphalf_1 n₁) (gen_path n₁) 347 | for 348 | half_R. 349 | Elpi derive.param2.register half half_R. 350 | (* Elpi derive.param2 half. (* requires mutual inductives *) *) 351 | 352 | (** seq *) 353 | 354 | (* Here we must make the implicit argument in size explicit *) 355 | Elpi derive.param2 size. 356 | 357 | Definition nilp' T (s : seq T) := eqn (size s) 0. 358 | Elpi derive.param2 nilp'. 359 | Definition nilp_R := nilp'_R. 360 | Elpi derive.param2.register nilp nilp_R. 361 | 362 | Elpi derive.param2 ohead. 363 | Elpi derive.param2 head. 364 | Elpi derive.param2 behead. 365 | Elpi derive.param2 ncons. 366 | Elpi derive.param2 nseq. 367 | Elpi derive.param2 cat. 368 | Elpi derive.param2 rcons. 369 | Elpi derive.param2 last. 370 | Elpi derive.param2 belast. 371 | Elpi derive.param2 nth. 372 | Elpi derive.param2 set_nth. 373 | Elpi derive.param2 find. 374 | Elpi derive.param2 filter. 375 | Elpi derive.param2 nat_of_bool. 376 | Elpi derive.param2 count. 377 | Elpi derive.param2 has. 378 | Elpi derive.param2 all. 379 | Elpi derive.param2 drop. 380 | Elpi derive.param2 take. 381 | Elpi derive.param2 rot. 382 | Elpi derive.param2 rotr. 383 | Elpi derive.param2 catrev. 384 | Elpi derive.param2 rev. 385 | Elpi derive.param2 map. 386 | Elpi derive.param2 oapp. 387 | Elpi derive.param2 pmap. 388 | Elpi derive.param2 iota. 389 | Elpi derive.param2 mkseq. 390 | Elpi derive.param2 foldr. 391 | Elpi derive.param2 sumn. 392 | Elpi derive.param2 foldl. 393 | Elpi derive.param2 pairmap. 394 | Elpi derive.param2 scanl. 395 | Elpi derive.param2 zip. 396 | Elpi derive.param2 fst. 397 | Elpi derive.param2 snd. 398 | Elpi derive.param2 unzip1. 399 | Elpi derive.param2 unzip2. 400 | Elpi derive.param2 flatten. 401 | Elpi derive.param2 shape. 402 | Elpi derive.param2 reshape. 403 | Elpi derive.param2 allpairs. 404 | 405 | (* fintype *) 406 | 407 | Elpi derive.param2 predArgType. 408 | Elpi derive.param2 is_true. 409 | Elpi derive.param2 ordinal. 410 | -------------------------------------------------------------------------------- /refinements/poly_div.v: -------------------------------------------------------------------------------- 1 | (** This file is part of CoqEAL, the Coq Effective Algebra Library. 2 | (c) Copyright INRIA and University of Gothenburg, see LICENSE *) 3 | From elpi Require Import derive. 4 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq zmodp. 5 | From mathcomp Require Import path choice fintype tuple finset ssralg bigop poly polydiv. 6 | 7 | From CoqEAL Require Import param refinements hrel poly_op. 8 | 9 | Set Implicit Arguments. 10 | Unset Strict Implicit. 11 | Unset Printing Implicit Defensive. 12 | 13 | Local Open Scope ring_scope. 14 | 15 | Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic. 16 | Import Refinements.Op Poly.Op. 17 | 18 | Section generic_division. 19 | 20 | Variable N R polyR : Type. 21 | Context `{lt_of N, sub_of N, add_of N, one_of N, zero_of N, spec_of N nat}. 22 | Context `{size_of polyR N, lead_coef_of R polyR, cast_of R polyR}. 23 | Context `{shift_of polyR N, add_of polyR, mul_of polyR, sub_of polyR}. 24 | Context `{eq_of polyR, zero_of polyR}. 25 | 26 | Definition div_rec_poly (q : polyR) := 27 | let sq := (size_op q : N) in 28 | let cq := (cast (lead_coef_op q : R) : polyR) in 29 | fix loop (k : N) (qq r : polyR) (n : nat) {struct n} := 30 | if (size_op r < sq)%C 31 | then (k, qq, r) else 32 | let m := shift_op (size_op r - sq)%C 33 | (cast (lead_coef_op r : R) : polyR) in 34 | let qq1 := (qq * cq + m)%C in 35 | let r1 := (r * cq - m * q)%C in 36 | if n is n1.+1 then loop (k + 1)%C qq1 r1 n1 else ((k + 1)%C, qq1, r1). 37 | 38 | #[export] Instance div_poly : div_of polyR := 39 | fun p q => (if (q == 0)%C 40 | then (0%C, 0%C, p) 41 | else div_rec_poly q 0%C 0%C p (spec (size_op p : N))).1.2. 42 | 43 | #[export] Instance mod_poly : mod_of polyR := 44 | fun p q => (if (q == 0)%C 45 | then (0%C, 0%C, p) 46 | else div_rec_poly q 0%C 0%C p (spec (size_op p : N))).2. 47 | 48 | #[export] Instance scal_poly : scal_of polyR N := 49 | fun p q => (if (q == 0)%C then (0%C, 0%C, p) 50 | else div_rec_poly q 0%C 0%C p (spec (size_op p : N))).1.1. 51 | 52 | End generic_division. 53 | 54 | Elpi derive.param2 div_rec_poly. 55 | Elpi derive.param2 div_poly. 56 | Elpi derive.param2 mod_poly. 57 | Elpi derive.param2 scal_poly. 58 | 59 | Section division_correctness. 60 | 61 | Variable R : ringType. 62 | 63 | Local Instance lt_nat : lt_of nat := ltn. 64 | Local Instance sub_nat : sub_of nat := subn. 65 | Local Instance add_nat : add_of nat := addn. 66 | Local Instance one_nat : one_of nat := 1%N. 67 | Local Instance zero_nat : zero_of nat := 0%N. 68 | Local Instance spec_nat : spec_of nat nat := spec_id. 69 | 70 | Local Instance size_of_poly : size_of {poly R} nat := sizep (R:=R). 71 | Local Instance lead_coef_poly : lead_coef_of R {poly R} := lead_coef. 72 | Local Instance cast_poly : cast_of R {poly R} := polyC. 73 | Local Instance shift_poly : shift_of {poly R} nat := shiftp (R:=R). 74 | Local Instance add_poly : add_of {poly R} := +%R. 75 | Local Instance mul_poly : mul_of {poly R} := *%R. 76 | Local Instance sub_poly : sub_of {poly R} := fun p q => p - q. 77 | Local Instance eq_poly : eq_of {poly R} := eqtype.eq_op. 78 | Local Instance zero_poly : zero_of {poly R} := 0%R. 79 | 80 | Lemma div_rec_polyE (p q : {poly R}) n r m: 81 | div_rec_poly (N:=nat) (R:=R) q n r p m = redivp_rec q n r p m. 82 | Proof. 83 | rewrite /div_rec_poly /redivp_rec. 84 | move: n r p. 85 | elim: m=> [|m ihm] n r p; 86 | by rewrite -[(_ < _)%C]/(_ < _) /shift_op /shift_poly /shiftp ?ihm mul_polyC 87 | [(_ + _)%C]addn1. 88 | Qed. 89 | 90 | Lemma div_polyE (p q : {poly R}) : div_poly (N:=nat) (R:=R) p q = rdivp p q. 91 | Proof. 92 | rewrite /div_poly -[rdivp p q]/((rscalp p q, rdivp p q, rmodp p q).1.2). 93 | rewrite -redivp_def div_rec_polyE /redivp /redivp_expanded_def. 94 | by rewrite unlock /= /spec_nat /spec_id. 95 | Qed. 96 | 97 | Lemma mod_polyE (p q : {poly R}) : mod_poly (N:=nat) (R:=R) p q = rmodp p q. 98 | Proof. 99 | rewrite /mod_poly -[rmodp p q]/((rscalp p q, rdivp p q, rmodp p q).2). 100 | rewrite -redivp_def div_rec_polyE /redivp /redivp_expanded_def. 101 | by rewrite unlock /= /spec_nat /spec_id. 102 | Qed. 103 | 104 | Lemma scal_polyE (p q : {poly R}) : scal_poly (N:=nat) (R:=R) p q = rscalp p q. 105 | Proof. 106 | rewrite /scal_poly -[rscalp p q]/((rscalp p q, rdivp p q, rmodp p q).1.1). 107 | rewrite -redivp_def div_rec_polyE /redivp /redivp_expanded_def. 108 | by rewrite unlock /= /spec_nat /spec_id. 109 | Qed. 110 | 111 | Section division_param. 112 | 113 | Local Open Scope rel_scope. 114 | 115 | Context (N : Type) (rN : nat -> N -> Type). 116 | Context (C : Type) (rC : R -> C -> Type). 117 | Context (polyC : Type) (RpolyC : {poly R} -> polyC -> Type). 118 | 119 | Context `{lt_of N, sub_of N, add_of N, one_of N, zero_of N, spec_of N nat}. 120 | Context `{size_of polyC N, lead_coef_of C polyC, cast_of C polyC}. 121 | Context `{shift_of polyC N, add_of polyC, mul_of polyC, sub_of polyC}. 122 | Context `{eq_of polyC, zero_of polyC}. 123 | Context `{!refines (rN ==> rN ==> bool_R) ltn lt_op}. 124 | Context `{!refines (rN ==> rN ==> rN) subn sub_op}. 125 | Context `{!refines (rN ==> rN ==> rN) addn add_op}. 126 | Context `{!refines rN 1%N 1%C, !refines rN 0%N 0%C}. 127 | Context `{!refines (rN ==> nat_R) spec_id spec}. 128 | Context `{!refines (RpolyC ==> rN) size_op size_op}. 129 | Context `{!refines (RpolyC ==> rC) lead_coef_poly lead_coef_op}. 130 | Context `{!refines (rC ==> RpolyC) cast_poly cast}. 131 | Context `{!refines (rN ==> RpolyC ==> RpolyC) shift_poly shift_op}. 132 | Context `{!refines (RpolyC ==> RpolyC ==> RpolyC) +%R +%C}. 133 | Context `{!refines (RpolyC ==> RpolyC ==> RpolyC) *%R *%C}. 134 | Context `{!refines (RpolyC ==> RpolyC ==> RpolyC) sub_poly sub_op}. 135 | Context `{!refines (RpolyC ==> RpolyC ==> bool_R) eqtype.eq_op eq_op}. 136 | Context `{!refines RpolyC 0%R 0%C}. 137 | 138 | #[export] Instance RpolyC_div_poly : 139 | refines (RpolyC ==> RpolyC ==> RpolyC) 140 | (div_poly (N:=nat) (R:=R) (polyR:={poly R})) 141 | (div_poly (N:=N) (R:=C) (polyR:=polyC)). 142 | Proof. param div_poly_R. Qed. 143 | 144 | #[export] Instance refine_div_poly : 145 | refines (RpolyC ==> RpolyC ==> RpolyC) (@rdivp R) 146 | (div_poly (N:=N) (R:=C) (polyR:=polyC)). 147 | Proof. 148 | rewrite refinesE=> p p' hp q q' hq. 149 | rewrite -div_polyE. 150 | exact: refinesP. 151 | Qed. 152 | 153 | #[export] Instance RpolyC_mod_poly : 154 | refines (RpolyC ==> RpolyC ==> RpolyC) 155 | (mod_poly (N:=nat) (R:=R) (polyR:={poly R})) 156 | (mod_poly (N:=N) (R:=C) (polyR:=polyC)). 157 | Proof. param mod_poly_R. Qed. 158 | 159 | #[export] Instance refine_mod_poly : 160 | refines (RpolyC ==> RpolyC ==> RpolyC) (@rmodp R) 161 | (mod_poly (N:=N) (R:=C) (polyR:=polyC)). 162 | Proof. 163 | rewrite refinesE=> p p' hp q q' hq. 164 | rewrite -mod_polyE. 165 | exact: refinesP. 166 | Qed. 167 | 168 | #[export] Instance RpolyC_scal_poly : 169 | refines (RpolyC ==> RpolyC ==> rN) 170 | (scal_poly (N:=nat) (R:=R) (polyR:={poly R})) 171 | (scal_poly (N:=N) (R:=C) (polyR:=polyC)). 172 | Proof. 173 | apply: refines_abstr2 => p p' hp q q' hq; rewrite refinesE. 174 | by apply: (@scal_poly_R _ _ _ _ _ rC _ _ RpolyC) => *; apply: refinesP. 175 | Qed. 176 | 177 | #[export] Instance refine_scal_poly : 178 | refines (RpolyC ==> RpolyC ==> rN) (@rscalp R) 179 | (scal_poly (N:=N) (R:=C) (polyR:=polyC)). 180 | Proof. 181 | rewrite refinesE=> p p' hp q q' hq. 182 | rewrite -scal_polyE. 183 | exact: refinesP. 184 | Qed. 185 | 186 | End division_param. 187 | End division_correctness. 188 | -------------------------------------------------------------------------------- /refinements/poly_op.v: -------------------------------------------------------------------------------- 1 | From elpi Require Import derive. 2 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq ssralg. 3 | From mathcomp Require Import path choice fintype tuple finset bigop poly polydiv. 4 | 5 | From CoqEAL Require Import param. 6 | 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Unset Printing Implicit Defensive. 10 | 11 | Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic. 12 | 13 | (* Specific classes for polynomials *) 14 | Module Poly. 15 | Module Op. 16 | 17 | Class shift_of polyA N := shift_op : N -> polyA -> polyA. 18 | #[export] Hint Mode shift_of + + : typeclass_instances. 19 | Class split_of polyA N := split_op : N -> polyA -> polyA * polyA. 20 | #[export] Hint Mode split_of + + : typeclass_instances. 21 | Class lead_coef_of A polyA := lead_coef_op : polyA -> A. 22 | #[export] Hint Mode lead_coef_of + + : typeclass_instances. 23 | Class scal_of polyA N := scal_op : polyA -> polyA -> N. 24 | #[export] Hint Mode scal_of + + : typeclass_instances. 25 | 26 | Elpi derive.param2 shift_of. 27 | Elpi derive.param2 shift_op. 28 | Elpi derive.param2 split_of. 29 | Elpi derive.param2 split_op. 30 | Elpi derive.param2 lead_coef_of. 31 | Elpi derive.param2 lead_coef_op. 32 | Elpi derive.param2 scal_of. 33 | Elpi derive.param2 scal_op. 34 | 35 | End Op. 36 | End Poly. 37 | 38 | Import Poly.Op. 39 | 40 | #[export] Typeclasses Transparent shift_of split_of lead_coef_of scal_of. 41 | 42 | Section poly_op. 43 | 44 | Local Open Scope ring_scope. 45 | 46 | Variable R : ringType. 47 | 48 | Definition splitp : nat -> {poly R} -> {poly R} * {poly R} := 49 | fun n p => (rdivp p 'X^n, rmodp p 'X^n). 50 | 51 | Definition shiftp n (p : {poly R}) := p * 'X^n. 52 | 53 | Definition sizep : {poly R} -> nat := size. 54 | Lemma sizepE s : sizep s = size s. Proof. by []. Qed. 55 | 56 | End poly_op. 57 | -------------------------------------------------------------------------------- /refinements/pos.v: -------------------------------------------------------------------------------- 1 | (** This file is part of CoqEAL, the Coq Effective Algebra Library. 2 | (c) Copyright INRIA and University of Gothenburg, see LICENSE *) 3 | From HB Require Import structures. 4 | Require Import ZArith. 5 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq zmodp. 6 | From mathcomp Require Import path choice fintype tuple finset ssralg ssrnum bigop ssrint. 7 | From CoqEAL Require Import hrel param refinements. 8 | 9 | Set Implicit Arguments. 10 | Unset Strict Implicit. 11 | Unset Printing Implicit Defensive. 12 | 13 | Import Refinements.Op GRing.Theory. 14 | 15 | Record pos := pos_of { 16 | val_of_pos : nat; 17 | _ : (val_of_pos > 0)%N 18 | }. 19 | HB.instance Definition _ := [isSub of pos for val_of_pos]. 20 | HB.instance Definition _ := [Equality of pos by <:]. 21 | 22 | (* Parametricity pos. *) 23 | 24 | (* Lemma eq_bool_R x y (a b : bool_R x y) : a = b. *) 25 | (* Proof. Admitted. *) 26 | 27 | (* Lemma pos_Rxx p : pos_R p p. *) 28 | (* Proof. *) 29 | (* case: p=> n ngt0. *) 30 | (* apply: (@pos_R_pos_of_R _ _ (nat_Rxx _)). *) 31 | (* case: _ / ngt0 (leq_R _ _) bool_R_true_R=> a b. *) 32 | (* rewrite [a](eq_bool_R _ b). *) 33 | (* by constructor. *) 34 | (* Qed. *) 35 | 36 | Section pos. 37 | 38 | Import Refinements.Op. 39 | 40 | Definition posS (n : nat) : pos := @pos_of n.+1 isT. 41 | 42 | #[export] Instance pos1 : one_of pos := posS 0. 43 | #[export] Instance add_pos : add_of pos := fun m n => insubd pos1 (val m + val n). 44 | #[export] Instance sub_pos : sub_of pos := fun m n => insubd pos1 (val m - val n). 45 | #[export] Instance mul_pos : mul_of pos := fun m n => insubd pos1 (val m * val n). 46 | #[export] Instance exp_pos : exp_of pos pos := 47 | fun m n => insubd pos1 (val m ^ val n). 48 | #[export] Instance leq_pos : leq_of pos := fun m n => val m <= val n. 49 | #[export] Instance lt_pos : lt_of pos := fun m n => val m < val n. 50 | #[export] Instance eq_pos : eq_of pos := eqtype.eq_op. 51 | 52 | #[export] Instance cast_pos_nat : cast_of pos nat := val. 53 | #[export] Instance cast_nat_pos : cast_of nat pos := insubd 1%C. 54 | 55 | Local Open Scope ring_scope. 56 | Definition pos_to_int (p : pos) : int := (val p)%:R. 57 | Definition int_to_nat (z : int) : nat := if z > 0 then `|z|%N else 0%N. 58 | Definition int_to_pos (z : int) : pos := insubd pos1 (int_to_nat z). 59 | 60 | End pos. 61 | -------------------------------------------------------------------------------- /refinements/ring.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq ssralg ssrint. 2 | From mathcomp Require Import path choice fintype tuple finset ssralg bigop poly polydiv. 3 | From mathcomp Require Import zmodp. 4 | 5 | From CoqEAL Require Import hrel param refinements binint poly_op hpoly karatsuba. 6 | 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Unset Printing Implicit Defensive. 10 | 11 | Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic. 12 | Import Refinements.Op Poly.Op. 13 | 14 | Local Open Scope ring_scope. 15 | 16 | Ltac in_seq s t := 17 | let rec aux s := 18 | match s with 19 | | [::] => constr:(false) 20 | | (?hd :: ?tl) => match hd with 21 | | t => constr:(true) 22 | | _ => aux tl 23 | end 24 | end in 25 | aux s. 26 | 27 | Ltac freeVars t A := 28 | let rec aux t fv := 29 | match t with 30 | | 0 => fv 31 | | 1 => fv 32 | | (?t1 + ?t2) => aux t2 ltac:(aux t1 fv) 33 | | (?t1 - ?t2) => aux t2 ltac:(aux t1 fv) 34 | | (?t1 * ?t2) => aux t2 ltac:(aux t1 fv) 35 | | (- ?t) => aux t fv 36 | | ?n%:~R => fv 37 | | _ => let b := in_seq fv t in 38 | match b with 39 | | true => fv 40 | | false => constr:(t :: fv) 41 | end 42 | end in 43 | let s := aux t ([::] : seq A) in 44 | let n := (eval compute in (size s)) in 45 | constr:((s, n)). 46 | 47 | Inductive PExpr := 48 | | PEc : int -> PExpr 49 | | PEX : nat -> PExpr 50 | | PEadd : PExpr -> PExpr -> PExpr 51 | | PEmul : PExpr -> PExpr -> PExpr 52 | | PEopp : PExpr -> PExpr 53 | | PEpow : PExpr -> nat -> PExpr. 54 | 55 | Definition poly_comRingType (R : comRingType) : comRingType := 56 | [the comRingType of {poly R}]. 57 | Definition Npoly (R : comRingType) : nat -> comRingType := fix aux n := 58 | if n is n.+1 then poly_comRingType (aux n) else R. 59 | 60 | Fixpoint NpolyC (R : comRingType) N : R -> Npoly R N := 61 | if N isn't N'.+1 return R -> Npoly R N 62 | then fun x => x 63 | else fun x => (NpolyC N' x)%:P. 64 | 65 | Fixpoint NpolyX (R : comRingType) N : nat -> Npoly R N := 66 | if N isn't N'.+1 return nat -> Npoly R N 67 | then fun=> 0 68 | else fun n => if n is n.+1 then (NpolyX R N' n)%:P 69 | else 'X. 70 | 71 | Fixpoint Nmap_poly (R R' : comRingType) (f : R -> R') N : 72 | Npoly R N -> Npoly R' N := 73 | if N isn't N'.+1 return Npoly R N -> Npoly R' N 74 | then f else map_poly (@Nmap_poly _ _ f N'). 75 | 76 | Section Nmap_poly_morphism. 77 | 78 | Variable R R' : comRingType. 79 | Variable g : {additive R -> R'}. 80 | Variable f : {rmorphism R -> R'}. 81 | Variable N : nat. 82 | 83 | Fact Nmap_poly_is_additive : additive (Nmap_poly g (N:=N)). 84 | Proof. 85 | elim: N=> [|N' IHN] /=. 86 | exact: raddfB. 87 | exact: map_poly_is_additive (Additive IHN). 88 | Qed. 89 | Canonical Nmap_poly_additive := Additive Nmap_poly_is_additive. 90 | 91 | Fact Nmap_poly_is_rmorphism : rmorphism (Nmap_poly f (N:=N)). 92 | Proof. 93 | elim: N=> [|N' IHN] /=. 94 | exact: rmorphismP. 95 | exact: map_poly_is_rmorphism (RMorphism IHN). 96 | Qed. 97 | Canonical Nmap_poly_rmorphism := RMorphism Nmap_poly_is_rmorphism. 98 | 99 | End Nmap_poly_morphism. 100 | 101 | Fact horner_key : unit. Proof. exact: tt. Qed. 102 | 103 | Fixpoint NhornerR (R : comRingType) N : seq R -> Npoly R N -> R := 104 | if N isn't N'.+1 return seq R -> Npoly R N -> R 105 | then fun _ p => p 106 | else fun env p => if env is a :: env then NhornerR env p.[NpolyC N' a] 107 | else NhornerR [::] p.[0]. 108 | 109 | Lemma NhornerRS (R : comRingType) N (a : R) (env : seq R) (p : Npoly R N.+1) : 110 | NhornerR (a :: env) p = NhornerR env p.[NpolyC N a]. 111 | Proof. by elim: N p. Qed. 112 | 113 | Definition Nhorner (R : comRingType) N (env : seq R) 114 | (p : Npoly [comRingType of int] N) : R 115 | := locked_with horner_key (@NhornerR _ _) env (Nmap_poly intr p). 116 | 117 | Lemma NhornerE (R : comRingType) N (env : seq R) 118 | (p : Npoly [comRingType of int] N) : 119 | Nhorner env p = (@NhornerR _ _) env (Nmap_poly intr p). 120 | Proof. by rewrite /Nhorner; case: horner_key. Qed. 121 | 122 | Definition PExpr_to_poly N : PExpr -> Npoly [comRingType of int] N := 123 | fix aux p := match p with 124 | | PEc n => n%:~R 125 | | PEX n => NpolyX _ N n 126 | | PEadd p q => aux p + aux q 127 | | PEmul p q => aux p * aux q 128 | | PEopp p => - aux p 129 | | PEpow p n => aux p ^+ n 130 | end. 131 | 132 | Definition PExpr_to_Expr (R : comRingType) (env : seq R) : PExpr -> R := 133 | fix aux p := match p with 134 | | PEc n => n%:~R 135 | | PEX n => env`_n 136 | | PEadd p q => aux p + aux q 137 | | PEmul p q => aux p * aux q 138 | | PEopp p => - aux p 139 | | PEpow p n => aux p ^+ n 140 | end. 141 | 142 | Lemma NhornerRC (R : comRingType) N (env : seq R) (a : R) : 143 | NhornerR env (NpolyC N a) = a. 144 | Proof. by elim: N env=> [|N IHN] [|b env] //=; rewrite hornerC. Qed. 145 | 146 | Lemma Nhorner_is_rmorphism (R : comRingType) (N : nat) (env : seq R) : 147 | rmorphism (@NhornerR R N env). 148 | Proof. 149 | do !split. 150 | - by elim: N env=> [|N IHN] [|a env] p q //=; rewrite hornerD hornerN IHN. 151 | - by elim: N env=> [|N IHN] [|a env] p q //=; rewrite hornerM IHN. 152 | by elim: N env=> [|N IHN] [|b env] //=; rewrite hornerC. 153 | Qed. 154 | 155 | Canonical Nhorner_rmorphism (R : comRingType) (N : nat) (env : seq R) := 156 | RMorphism (Nhorner_is_rmorphism N env). 157 | 158 | Lemma polyficationP (R : comRingType) (env : seq R) N p : size env == N -> 159 | PExpr_to_Expr env p = Nhorner env (PExpr_to_poly N p). 160 | Proof. 161 | elim: p=> [n|n|p IHp q IHq|p IHp q IHq|p IHp|p IHp n] /=. 162 | - by rewrite NhornerE !rmorph_int. 163 | - rewrite NhornerE; elim: N env n=> [|N IHN] [|a env] [|n] //= senv. 164 | by rewrite map_polyX hornerX [RHS]NhornerRC. 165 | by rewrite map_polyC hornerC !IHN. 166 | - by move=> senv; rewrite (IHp senv) (IHq senv) !NhornerE !rmorphD. 167 | - by move=> senv; rewrite (IHp senv) (IHq senv) !NhornerE !rmorphM. 168 | - by move=> senv; rewrite (IHp senv) !NhornerE !rmorphN. 169 | - by move=> senv; rewrite (IHp senv) !NhornerE !rmorphX. 170 | Qed. 171 | 172 | Ltac getIndex t fv := 173 | let rec aux s n := 174 | match s with 175 | | (?hd :: ?tl) => match hd with 176 | | t => eval compute in n 177 | | _ => aux tl uconstr:(n.+1) 178 | end 179 | | _ => fail "Not found" 180 | end in 181 | aux fv O. 182 | 183 | Ltac toPExpr t fv N := 184 | let rec aux t := 185 | match t with 186 | | 0 => uconstr:(PEc 0) 187 | | 1 => uconstr:(PEc 1) 188 | | (?t1 + ?t2) => let e1 := aux t1 in 189 | let e2 := aux t2 in 190 | uconstr:(PEadd e1 e2) 191 | | (?t1 * ?t2) => let e1 := aux t1 in 192 | let e2 := aux t2 in 193 | uconstr:(PEmul e1 e2) 194 | | (- ?t) => let e := aux t in 195 | uconstr:(PEopp e) 196 | | ?n%:~R => uconstr:(PEc n) 197 | | _ => let n := getIndex t fv in uconstr:(PEX n) 198 | end in 199 | let e := aux t in constr:(e : PExpr). 200 | 201 | Tactic Notation (at level 0) "translate" constr(t) := 202 | let A := type of t in 203 | let c := freeVars t A in 204 | let fv := (eval simpl in (c.1)) in 205 | let n := (eval simpl in (c.2)) in 206 | let p := toPExpr t fv n in 207 | have /= := @polyficationP _ fv n p isT. 208 | 209 | Tactic Notation "polyfication" := 210 | match goal with 211 | | |- (eq ?lhs ?rhs) => 212 | let A := type of lhs in 213 | let c := freeVars (lhs + rhs) A in 214 | let fv := (eval simpl in (c.1)) in 215 | let n := (eval simpl in (c.2)) in 216 | let pl := toPExpr lhs fv n in 217 | let pr := toPExpr rhs fv n in 218 | let rwl := fresh "rwl" in 219 | let rwr := fresh "rwr" in 220 | have /= rwl := @polyficationP _ fv n pl isT; rewrite [LHS]rwl {rwl}; 221 | have /= rwr := @polyficationP _ fv n pr isT; rewrite [RHS]rwr {rwr} 222 | | _ => fail "goal not an equation" 223 | end. 224 | 225 | Tactic Notation "depolyfication" := 226 | rewrite NhornerE /NhornerR /=; 227 | do ?[rewrite ?(rmorph0, rmorphN, rmorphD, rmorphB, 228 | rmorph1, rmorphM, rmorphX, map_polyC, 229 | map_polyX, map_polyZ) /=]; rewrite ?hornerE. 230 | 231 | Tactic Notation "coqeal_vm_compute_eq2" := 232 | do 1?coqeal [(X in Nhorner _ X = _)%pattern] vm_compute; 233 | do 1?coqeal [(X in _ = Nhorner _ X)%pattern] vm_compute. 234 | 235 | Tactic Notation "coqeal_ring" := 236 | by polyfication; coqeal_vm_compute_eq2; depolyfication. 237 | 238 | Goal true. 239 | 240 | assert (h1 := [coqeal vm_compute of - (1 + 'X%:P * 'X) : {poly {poly int}}]). 241 | assert (h2 := [coqeal vm_compute of 242 | (1 + 2%:Z *: 'X) * (1 + 2%:Z%:P * 'X^(sizep (1 : {poly int})))]). 243 | assert (h3 := [coqeal vm_compute of 244 | 1 + 2%:Z *: 'X + 3%:Z *: 'X^2 - (3%:Z *: 'X^2 + 1 + 2%:Z%:P * 'X)]). 245 | assert (h4 := [coqeal vm_compute of 'X + 'X^2 * 'X%:P : {poly {poly int}}]). 246 | 247 | have (a b c : int) : a * (b + c) = a * b + a * c. 248 | Time by coqeal_ring. 249 | move=> _. 250 | 251 | have (a b c : {poly int}) : (b + c) * a = b * a + c * a. 252 | Time by coqeal_ring. 253 | move=> _. 254 | 255 | have (a : {poly int}) : a * 0 = 0. 256 | Time by coqeal_ring. 257 | move=> _. 258 | 259 | have (a : Zp_ringType 7) : 0 = a * 0. 260 | Time by coqeal_ring. 261 | move=> _. 262 | 263 | have (a : {poly {poly {poly int}}}) : a * 0 = 0. 264 | Time by coqeal_ring. 265 | move=> _. 266 | 267 | have (R : comRingType) (a b c : R) : a + b - (1 * b + c * 0) = a. 268 | Time by coqeal_ring. 269 | move=> _. 270 | by[]. 271 | Qed. 272 | -------------------------------------------------------------------------------- /refinements/seqmx_complements.v: -------------------------------------------------------------------------------- 1 | (** * A few operations missing in seqmx *) 2 | 3 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq. 4 | From mathcomp Require Import choice fintype bigop matrix. 5 | 6 | From CoqEAL Require Import hrel param refinements seqmx seqpoly. 7 | 8 | Set Implicit Arguments. 9 | Unset Strict Implicit. 10 | Unset Printing Implicit Defensive. 11 | 12 | Open Scope ring_scope. 13 | 14 | Import Refinements.Op. 15 | 16 | (** * Extra material about CoqEAL *) 17 | 18 | Arguments refines A%type B%type R%rel _ _. (* Fix a scope issue with refines *) 19 | 20 | Arguments refinesP {T T' R x y} _. 21 | 22 | #[export] Hint Resolve nil_R : core. 23 | 24 | Notation ord_instN := (fun _ : nat => nat) (only parsing). 25 | 26 | Definition Rord n1 n2 (rn : nat_R n1 n2) : 'I_n1 -> ord_instN n2 -> Type := 27 | fun x y => x = y :> nat. 28 | 29 | (** [ord0] is the only value in ['I_1]. *) 30 | Lemma ord_1_0 (i : 'I_1) : i = ord0. 31 | Proof. by case: i => [[]] // HH; apply /eqP. Qed. 32 | 33 | Section classes. 34 | 35 | (** ** Definition of operational type classes *) 36 | 37 | Class fun_of_of A I B := 38 | fun_of_op : forall (m n : nat), B m n -> I m -> I n -> A. 39 | Class row_of I B := row_op : forall (m n : nat), I m -> B m n -> B 1%N n. 40 | Class store_of A I B := 41 | store_op : forall (m n : nat), B m n -> I m -> I n -> A -> B m n. 42 | Class trmx_of B := trmx_op : forall m n : nat, B m n -> B n m. 43 | 44 | End classes. 45 | 46 | #[export] Typeclasses Transparent fun_of_of row_of store_of trmx_of. 47 | 48 | Notation "A ^T" := (trmx_op A) : hetero_computable_scope. 49 | 50 | (** ** General definitions for seqmx *) 51 | 52 | Section seqmx_op. 53 | 54 | Context {A : Type}. 55 | Context `{zero_of A}. 56 | 57 | #[export] Instance fun_of_seqmx : fun_of_of A ord_instN hseqmx := 58 | fun (_ _ : nat) M i j => nth 0%C (nth [::] M i) j. 59 | 60 | #[export] Instance row_seqmx : row_of ord_instN (@hseqmx A) := 61 | fun (_ _ : nat) i M => [:: nth [::] M i]. 62 | 63 | Fixpoint store_aux T s k (v : T) := 64 | match s, k with 65 | | [::], _ => [::] 66 | | _ :: t, O => v :: t 67 | | h :: t, S k => h :: store_aux t k v 68 | end. 69 | 70 | Fixpoint store_seqmx0 T m i j (v : T) := 71 | match m, i with 72 | | [::], _ => [::] 73 | | h :: t, O => store_aux h j v :: t 74 | | h :: t, S i => h :: store_seqmx0 t i j v 75 | end. 76 | 77 | #[export] Instance store_seqmx : store_of A ord_instN hseqmx := 78 | fun (_ _ : nat) M i j v => store_seqmx0 M i j v. 79 | 80 | #[export] Instance trmx_seqmx : trmx_of hseqmx := 81 | fun m n : nat => @trseqmx A m n. 82 | 83 | Context `{eq_of A}. 84 | 85 | #[export] Instance heq_seqmx : heq_of (@hseqmx A) := 86 | fun (_ _ : nat) => eq_seq (eq_seq eq_op). 87 | 88 | End seqmx_op. 89 | 90 | 91 | (** ** Refinement proofs *) 92 | 93 | Require Import Equivalence RelationClasses Morphisms. 94 | 95 | Section seqmx_theory. 96 | 97 | Context {A : Type}. 98 | Context `{!zero_of A}. 99 | 100 | Local Instance : spec_of A A := spec_id. 101 | 102 | Lemma Rseqmx_spec_seqmx m n (M : @seqmx A) : 103 | (size M == m) && all (fun r => size r == n) M -> 104 | Rseqmx (nat_Rxx m) (nat_Rxx n) (spec_seqmx m n M) M. 105 | Proof. 106 | move/andP=>[] /eqP Hm /all_nthP Hn; split=>[//||]. 107 | { by move=> i Hi; apply/eqP /Hn; rewrite Hm. } 108 | move=> i j; rewrite mxE. 109 | rewrite /map_seqmx /spec /spec_of_instance_0 /spec_id /=. 110 | by rewrite (nth_map [::]) ?Hm ?(ltn_ord i) // map_id. 111 | Qed. 112 | 113 | #[export] Instance Rseqmx_fun_of_seqmx m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : 114 | refines (Rseqmx rm rn ==> Rord rm ==> Rord rn ==> eq) 115 | ((@fun_of_matrix A m1 n1) : matrix A m1 n1 -> ordinal m1 -> ordinal n1 -> A) 116 | (@fun_of_seqmx A _ m2 n2). 117 | Proof. 118 | rewrite refinesE => _ _ [M sM h1 h2 h3] i _ <- j _ <-. 119 | by rewrite /fun_of_seqmx. 120 | Qed. 121 | 122 | #[export] Instance Rseqmx_row_seqmx m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : 123 | refines (Rord rm ==> Rseqmx rm rn ==> Rseqmx (S_R O_R) rn) 124 | (@row A m1 n1) (@row_seqmx A m2 n2). 125 | Proof. 126 | rewrite refinesE=> i _ <- _ _ [M sM h1 h2 h3]. 127 | rewrite /row_seqmx; constructor=> [//||i' j]. 128 | { by case=>//= _; apply h2; rewrite -(nat_R_eq rm). } 129 | rewrite mxE (ord_1_0 i') /=; apply h3. 130 | Qed. 131 | 132 | Lemma store_aux_correct n (l : seq A) (j : 'I_n) v (j' : 'I_n) : size l = n -> 133 | nth 0%C (store_aux l j v) j' = if j' == j then v else nth 0%C l j'. 134 | Proof. 135 | elim: n j j' l; [by case|]; move=> n IH j j'. 136 | case=>// h t [Ht]; case j' => {j'}; case; case j => {j}; case=>//= j Hj j' Hj'. 137 | rewrite /eqtype.eq_op /= eqSS; rewrite !ltnS in Hj, Hj'. 138 | apply (IH (Ordinal Hj) (Ordinal Hj') _ Ht). 139 | Qed. 140 | 141 | Lemma size_store_seqmx0 s i j x : 142 | seq.size (@store_seqmx0 A s j i x) = seq.size s. 143 | Proof. 144 | elim: s j => [|a s IHs] j; first by case: j. 145 | case: j IHs => [|j] IHs //=. 146 | by rewrite -(IHs j). 147 | Qed. 148 | 149 | Lemma size_store_aux s i x : size (@store_aux A s i x) = size s. 150 | Proof. 151 | elim: s i => [|a s IHs] i; first by case: i. 152 | case: i IHs => [|i] IHs //=. 153 | by rewrite -(IHs i). 154 | Qed. 155 | 156 | Lemma size_nth_store_seqmx0 s i j k x : 157 | size (nth [::] (@store_seqmx0 A s j i x) k) = size (nth [::] s k). 158 | Proof. 159 | elim: s j k => [|a s IHs] j k; first by case: j. 160 | case: j IHs => [|j] IHs //=; case: k IHs => [|k] IHs //=. 161 | by rewrite size_store_aux. 162 | Qed. 163 | 164 | #[export] Instance store_ssr : store_of A ordinal (matrix A) := 165 | fun m n (M : 'M[A]_(m, n)) (i : 'I_m) (j : 'I_n) v => 166 | \matrix_(i', j') 167 | if ((nat_of_ord i' == i) && (nat_of_ord j' == j))%N then v else M i' j'. 168 | 169 | #[export] Instance Rseqmx_store_seqmx 170 | m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : 171 | refines (Rseqmx rm rn ==> Rord rm ==> Rord rn ==> eq ==> Rseqmx rm rn) 172 | (@store_ssr m1 n1) (@store_seqmx A m2 n2). 173 | Proof. 174 | rewrite refinesE =>_ _ [M sM h1 h2 h3] i _ <- j _ <- v _ <-. 175 | constructor=>[|i' Hi'|i' j']. 176 | { by rewrite size_store_seqmx0. } 177 | { by rewrite size_nth_store_seqmx0; apply h2. } 178 | rewrite mxE {}h3; move: i i' sM h2 h1; rewrite -(nat_R_eq rm) -(nat_R_eq rn). 179 | elim m1; [by case|]; move=> m IH i i'. 180 | case=>// h t h2 [Ht]; case i' => {i'}; case. 181 | { case (nat_of_ord i)=>//= _. 182 | by rewrite store_aux_correct //; move: (h2 O erefl). } 183 | move=> i' Hi'; case i => {i}; case=>// i Hi. 184 | rewrite {1}/eqtype.eq_op /=; rewrite !ltnS in Hi, Hi'. 185 | apply (IH (Ordinal Hi) (Ordinal Hi')) => //. 186 | by move=> k Hk; move: (h2 k.+1); apply. 187 | Qed. 188 | 189 | Context `{eq_of A}. 190 | 191 | #[export] Instance heq_ssr : heq_of (matrix A) := 192 | fun n1 n2 a b => [forall i, [forall j, (a i j == b i j)%C]]. 193 | 194 | #[export] Instance Rseqmx_heq_op m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : 195 | refines (Rseqmx rm rn ==> Rseqmx rm rn ==> bool_R) 196 | (@heq_ssr m1 n1) (heq_seqmx (n:=n2)). 197 | Proof. 198 | rewrite refinesE=> _ _ [a a' ha1 ha2 ha3] _ _ [b b' hb1 hb2 hb3]. 199 | rewrite /heq_ssr /heq_seqmx. 200 | rewrite eq_seqE; [|by rewrite ha1 hb1]. 201 | have SzAs : seq.size (zip a' b') = m2. 202 | { by rewrite size1_zip ha1 // hb1. } 203 | match goal with 204 | | [ |- ?R ?a ?b ] => 205 | let H := fresh in 206 | suff H : a = b; first (rewrite H; eapply bool_Rxx =>//) 207 | end. 208 | apply/idP/idP. 209 | { move/forallP=> H1; apply/all_nthP=> i; rewrite SzAs=> Hi. 210 | erewrite (nth_zip [::] [::]); rewrite ?hb1 //= eq_seqE ?ha2 ?hb2 //. 211 | apply/all_nthP=> j. 212 | erewrite (nth_zip 0%C 0%C); rewrite ?ha2 ?hb2 //= size1_zip ?ha2 ?hb2 // => Hj. 213 | rewrite -(nat_R_eq rm) in Hi; rewrite -(nat_R_eq rn) in Hj. 214 | move: (H1 (Ordinal Hi)); move/forallP => H2; move: (H2 (Ordinal Hj)). 215 | by rewrite ha3 hb3. } 216 | move/all_nthP=> H1; apply/forallP=> i. 217 | have Hi : (i < m2)%N; [by rewrite -(nat_R_eq rm) ltn_ord|]. 218 | apply/forallP=> j; rewrite ha3 hb3. 219 | move: (H1 ([::], [::]) i); rewrite size1_zip ?ha1 ?hb1 // -(nat_R_eq rm)=> H2. 220 | move: (H2 (ltn_ord i)); rewrite nth_zip ?ha1 ?hb1 //= eq_seqE ?ha2 ?hb2 //. 221 | move/all_nthP=>H3; move: (H3 (zero_of0, zero_of0) j). 222 | rewrite nth_zip ?ha2 ?hb2 //=; apply. 223 | by rewrite size1_zip ha2 ?hb2 // -(nat_R_eq rn). 224 | Qed. 225 | 226 | (** ** Parametricity *) 227 | 228 | Elpi derive.param2 fun_of_of. 229 | Elpi derive.param2 fun_of_seqmx. 230 | Elpi derive.param2 row_of. 231 | Elpi derive.param2 row_seqmx. 232 | Elpi derive.param2 store_of. 233 | Elpi derive.param2 store_aux. 234 | Elpi derive.param2 store_seqmx0. 235 | Elpi derive.param2 store_seqmx. 236 | Elpi derive.param2 trmx_of. 237 | Elpi derive.param2 trmx_seqmx. 238 | Elpi derive.param2 heq_of. 239 | Elpi derive.param2 heq_seqmx. 240 | 241 | Section seqmx_param. 242 | 243 | Context (C : Type) (rAC : A -> C -> Type). 244 | Context `{!zero_of C, !spec_of C A}. 245 | 246 | Context `{!eq_of C}. 247 | 248 | Lemma RseqmxC_spec_seqmx m n (M : @seqmx C) : 249 | (size M == m) && all (fun r => size r == n) M -> 250 | (list_R (list_R rAC)) (map_seqmx spec M) M -> 251 | RseqmxC rAC (nat_Rxx m) (nat_Rxx n) (spec_seqmx m n M) M. 252 | Proof. 253 | move=> /andP [] /eqP Hm /all_nthP Hn Hc; apply refinesP. 254 | eapply (refines_trans (b:=map_seqmx spec M)); [by tc| |]. 255 | { rewrite refinesE; split; [by rewrite size_map| |]. 256 | { move=> i Hi; rewrite (nth_map 0%C) ?Hm // size_map. 257 | by apply/eqP/Hn; rewrite Hm. } 258 | by move=> i j; rewrite mxE. } 259 | by rewrite refinesE. 260 | Qed. 261 | 262 | Lemma nth_R_lt (T1 T2 : Type) (T_R : T1 -> T2 -> Type) x01 x02 s1 s2 : 263 | list_R T_R s1 s2 -> 264 | forall n, (n < size s1)%N -> T_R (nth x01 s1 n) (nth x02 s2 n). 265 | Proof. 266 | move=> Hs n; elim: n s1 s2 Hs=> [|n IH] s1 s2 Hs Hn /=. 267 | { by move: Hs Hn; case s1=> [//|h1 t1] Hs _; inversion Hs. } 268 | move: Hs Hn IH; case s1=> [//|h1 t1] Hs Hn IH. 269 | by inversion Hs; apply IH. 270 | Qed. 271 | 272 | Lemma RseqmxC_fun_of_seqmx m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : 273 | refines (RseqmxC rAC rm rn ==> Rord rm ==> Rord rn ==> rAC) 274 | ((@fun_of_matrix A m1 n1) : matrix A m1 n1 -> ordinal m1 -> ordinal n1 -> A) 275 | (@fun_of_seqmx C _ m2 n2). 276 | Proof. 277 | rewrite refinesE => _ a' [_ [[a a'' h1 h2 h3] ra'']] i i' ri j j' rj. 278 | rewrite h3 /fun_of_seqmx -ri -rj. 279 | apply nth_R_lt. 280 | { apply nth_R_lt=>//; rewrite h1 -(nat_R_eq rm); apply ltn_ord. } 281 | rewrite h2 -?(nat_R_eq rm) -?(nat_R_eq rn); apply ltn_ord. 282 | Qed. 283 | 284 | #[export] Instance refine_fun_of_seqmx m n : 285 | refines (RseqmxC rAC (nat_Rxx m) (nat_Rxx n) ==> Rord (nat_Rxx m) ==> Rord (nat_Rxx n) ==> rAC) 286 | ((@fun_of_matrix A m n) : matrix A m n -> ordinal m -> ordinal n -> A) 287 | (@fun_of_seqmx C _ m n). 288 | Proof. exact: RseqmxC_fun_of_seqmx. Qed. 289 | 290 | #[export] Instance refine_foldl 291 | (T1 T2 : Type) (rT : T1 -> T2 -> Type) (R1 R2 : Type) (rR : R1 -> R2 -> Type) : 292 | refines ((rR ==> rT ==> rR) ==> rR ==> list_R rT ==> rR) 293 | (@foldl T1 R1) (@foldl T2 R2). 294 | Proof. 295 | rewrite refinesE=> f f' rf z z' rz s' s'' rs'. 296 | elim: s' s'' rs' z z' rz=> [|h t IH] s'' rs' z z' rz. 297 | { case: s'' rs'=> [//|h' t'] rs'; inversion rs'. } 298 | case: s'' rs'=> [|h' t'] rs' /=; [by inversion rs'|]. 299 | apply IH; [by inversion rs'|]. 300 | by apply refinesP; refines_apply; rewrite refinesE; inversion rs'. 301 | Qed. 302 | 303 | End seqmx_param. 304 | 305 | End seqmx_theory. 306 | -------------------------------------------------------------------------------- /refinements/trivial_seq.v: -------------------------------------------------------------------------------- 1 | From elpi Require Import derive. 2 | 3 | Require Import ZArith. 4 | 5 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq zmodp. 6 | From mathcomp Require Import path choice fintype tuple finset ssralg ssrnum bigop ssrint. 7 | 8 | From CoqEAL Require Import hrel param refinements. 9 | 10 | Import Refinements.Op. 11 | 12 | Section size_seq. 13 | 14 | Context (A : Type) (N : Type) `{zero_of N} `{one_of N} `{add_of N}. 15 | 16 | #[export] Instance size_seq : size_of (seq A) N := 17 | fix size xs := if xs is x :: s then (size s + 1)%C else 0%C. 18 | 19 | End size_seq. 20 | Elpi derive.param2 size_seq. 21 | 22 | Lemma size_seqE T (s : seq T) : (@size_seq _ _ 0%N 1%N addn) s = size s. 23 | Proof. by elim: s => //= x s ->; rewrite [(_ + _)%C]addn1. Qed. 24 | 25 | Section seq_refines. 26 | 27 | Local Open Scope rel_scope. 28 | 29 | Variable (A C : Type) (rAC : A -> C -> Type). 30 | Variable (N : Type) (rN : nat -> N -> Type). 31 | Context `{implem_of A C} `{spec_of N nat}. 32 | Context `{zero_of N} `{one_of N} `{add_of N}. 33 | Context `{!refines (Logic.eq ==> rAC) implem_id implem}. 34 | Context `{!refines (rN ==> nat_R) spec_id spec}. 35 | Context `{!refines rN 0%N 0%C}. 36 | Context `{!refines rN 1%N 1%C}. 37 | Context `{!refines (rN ==> rN ==> rN) addn add_op}. 38 | 39 | #[export] Instance refine_nth1 : 40 | refines (rAC ==> list_R rAC ==> rN ==> rAC) 41 | nth (fun x s (n : N) => nth x s (spec n)). 42 | Proof. 43 | param nth_R. 44 | rewrite -[X in refines _ X _]/(spec_id _); exact: refines_apply. 45 | Qed. 46 | 47 | #[export] Instance refine_nth2 : 48 | refines (list_R (list_R rAC) ==> rN ==> list_R rAC) 49 | (nth [::]) (fun s (n : N) => nth [::] s (spec n)). 50 | Proof. 51 | param nth_R. 52 | rewrite refinesE; exact: nil_R. 53 | rewrite -[X in refines _ X _]/(spec_id _); exact: refines_apply. 54 | Qed. 55 | 56 | #[export] Instance refine_list_R2_implem s : 57 | refines (list_R (list_R rAC)) s (map (map implem) s). 58 | Proof. 59 | rewrite refinesE. 60 | elim: s=> [|a s ihs] /=. 61 | exact: nil_R. 62 | apply: cons_R. 63 | elim: a=> [|hd tl ih] /=. 64 | exact: nil_R. 65 | apply: cons_R. 66 | have heq : refines eq hd hd by rewrite refinesE. 67 | rewrite -[X in rAC X _]/(implem_id _). 68 | exact: refinesP. 69 | exact: ih. 70 | exact: ihs. 71 | Qed. 72 | 73 | #[export] Instance refine_size : refines (list_R rAC ==> rN) size size_op. 74 | Proof. 75 | by rewrite refinesE => s s' rs; rewrite -[size s]size_seqE; param size_seq_R. 76 | Qed. 77 | 78 | End seq_refines. 79 | -------------------------------------------------------------------------------- /theory/atomic_operations.v: -------------------------------------------------------------------------------- 1 | 2 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq. 3 | From mathcomp Require Import ssralg fintype perm choice. 4 | From mathcomp Require Import matrix bigop zmodp mxalgebra poly mxpoly. 5 | 6 | Import GRing.Theory. 7 | 8 | Set Implicit Arguments. 9 | Unset Strict Implicit. 10 | Import Prenex Implicits. 11 | 12 | Open Scope ring_scope. 13 | 14 | Section atomic_operations. 15 | Variable R: comRingType. 16 | 17 | (* describe simple line / column combination operators *) 18 | 19 | (* Operation to multiply Lk by a the scalar a *) 20 | Definition line_scale n m k (a: R) (M: 'M[R]_(n,m)) := 21 | \matrix_(i < n) ((if i == k then a else 1) *: row i M). 22 | 23 | Lemma line_scale_row_eq n m k a (M: 'M[R]_(n,m)): 24 | row k (line_scale k a M) = a *: row k M. 25 | Proof. 26 | by apply/rowP => i; rewrite !mxE eqxx. 27 | Qed. 28 | 29 | Lemma line_scale_row_neq n m k l a (M: 'M[R]_(n,m)): k != l -> 30 | row l (line_scale k a M) = row l M. 31 | Proof. 32 | move/negbTE => hkl. 33 | by apply/rowP => i; rewrite !mxE eq_sym hkl mul1r. 34 | Qed. 35 | 36 | 37 | (* several application of the line_scale operation *) 38 | Lemma lines_scale_row m n a (M: 'M[R]_(m,n)): 39 | forall s, uniq s -> 40 | (forall i, i \in s -> 41 | row i (foldl (fun N i => line_scale i a N) M s) = a *: row i M) /\ 42 | (forall i, i \notin s -> 43 | row i (foldl (fun N i => line_scale i a N) M s) = row i M). 44 | Proof. 45 | move => s. 46 | elim : s n M => [ | hd tl hi] //= n M /andP [h1 h2]. 47 | split => i; rewrite in_cons. 48 | - move/orP => [/eqP{i}-> | hin]. 49 | + case: (hi _ (line_scale hd a M) h2) => _ hr. 50 | by rewrite hr // line_scale_row_eq. 51 | case: (hi _ (line_scale hd a M) h2) => -> // _. 52 | rewrite line_scale_row_neq //. 53 | by apply: contraNneq h1 => ->. 54 | rewrite negb_or => /andP[hl hr]. 55 | case: (hi _ (line_scale hd a M) h2) => _ hR. 56 | by rewrite hR // line_scale_row_neq // eq_sym. 57 | Qed. 58 | 59 | (* 60 | alternative definition of the same operation by matrix multiplication 61 | this definition is easier to prove determinant property of the operator 62 | *) 63 | Definition line_scale_mx n m k (a: R) (M: 'M[R]_(n,m)) := 64 | diag_mx (\row_(i < n) (if i == k then a else 1)) *m M. 65 | 66 | Lemma line_scale_eq : forall n m k a (M: 'M[R]_(n,m)), 67 | line_scale k a M = line_scale_mx k a M. 68 | Proof. 69 | move => n m k a M; apply/matrixP => i j; rewrite !mxE. 70 | rewrite (bigD1 i) //= big1 /=; first by rewrite !mxE addr0 eqxx. 71 | by move => x /negbTE hx; rewrite !mxE [i == x]eq_sym hx mulr0n mul0r. 72 | Qed. 73 | 74 | (* line_scale_mx scales the determinant by a *) 75 | Lemma det_line_scale_mx : forall n k a (M: 'M[R]_n), 76 | \det (line_scale_mx k a M) = a * \det M. 77 | Proof. 78 | rewrite /line_scale_mx => n k a M. 79 | rewrite det_mulmx det_diag (bigD1 k) //= big1 /=; 80 | first by rewrite !mxE mulr1 eqxx. 81 | by move => i /negbTE h; rewrite !mxE h. 82 | Qed. 83 | 84 | (* line_scale scales the determinant by a *) 85 | Lemma det_line_scale : forall n k a (M: 'M[R]_n), 86 | \det (line_scale k a M) = a * \det M. 87 | Proof. 88 | move => n k a M. 89 | by rewrite line_scale_eq det_line_scale_mx. 90 | Qed. 91 | 92 | Lemma det_lines_scale m a (M: 'M[R]_m) s: 93 | \det (foldl (fun N i => line_scale i a N) M s) = a ^+ (size s) * \det M. 94 | Proof. 95 | elim : s M => [ | hd tl hi] M //=. 96 | - by rewrite expr0 mul1r. 97 | by rewrite hi det_line_scale mulrA exprSr. 98 | Qed. 99 | 100 | 101 | (* Operation to change Lk by Lk + a Ll *) 102 | Definition line_comb n m k l (a: R) (M: 'M[R]_(n,m)) := 103 | \matrix_(i < n) if i == k then row k M + a*: row l M else row i M. 104 | 105 | 106 | Lemma line_comb_row_eq n m k l a (M: 'M[R]_(n,m)): 107 | row k (line_comb k l a M) = row k M + a *: row l M. 108 | Proof. 109 | by apply/rowP => i; rewrite !mxE eqxx !mxE. 110 | Qed. 111 | 112 | Lemma line_comb_row_neq n m k k' l a (M: 'M[R]_(n,m)): k != k' -> 113 | row k' (line_comb k l a M) = row k' M. 114 | Proof. 115 | move/negbTE => hkk'. 116 | by apply/rowP => i; rewrite !mxE eq_sym hkk' !mxE. 117 | Qed. 118 | 119 | (* several application of the line_comb operation *) 120 | Lemma lines_comb_row m n a l (M: 'M[R]_(m,n)): 121 | forall s, uniq s -> l \notin s -> 122 | (forall i, i \in s -> 123 | row i (foldl (fun N i => line_comb i l a N) M s) = 124 | row i M + a *: row l M) /\ 125 | (forall i, i \notin s -> 126 | row i (foldl (fun N i => line_comb i l a N) M s) = row i M). 127 | Proof. 128 | move => s. 129 | elim : s M => [ | hd tl hi] //= M /andP [h1 h2]. 130 | rewrite in_cons negb_or => /andP [hl1 hl2]. 131 | split => i; rewrite in_cons. 132 | - move/orP => [/eqP{i}-> | hin]. 133 | + case: (hi (line_comb hd l a M) h2 hl2) => _ hr. 134 | by rewrite hr // line_comb_row_eq. 135 | case: (hi (line_comb hd l a M) h2 hl2) => -> // _. 136 | rewrite !line_comb_row_neq // eq_sym // eq_sym. 137 | by apply: contraNneq h1 => ->. 138 | rewrite negb_or => /andP [hl hr]. 139 | case: (hi (line_comb hd l a M) h2 hl2) => _ hR. 140 | by rewrite hR // !line_comb_row_neq // eq_sym. 141 | Qed. 142 | 143 | 144 | Lemma lines_comb_row_dep m n (a: 'I_m -> R) l (M: 'M[R]_(m,n)): 145 | forall s, uniq s -> l \notin s -> 146 | (forall i, i \in s -> 147 | row i (foldl (fun N i => line_comb i l (a i) N) M s) = 148 | row i M + (a i) *: row l M) /\ 149 | (forall i, i \notin s -> 150 | row i (foldl (fun N i => line_comb i l (a i) N) M s) = row i M). 151 | Proof. 152 | move => s. 153 | elim : s M => [ | hd tl hi] //= M /andP [h1 h2]. 154 | rewrite in_cons negb_or => /andP [hl1 hl2]. 155 | split => i; rewrite in_cons. 156 | - move/orP => [/eqP{i}-> | hin]. 157 | + case: (hi (line_comb hd l (a hd) M) h2 hl2) => _ hr. 158 | by rewrite hr // line_comb_row_eq. 159 | case: (hi (line_comb hd l (a hd) M) h2 hl2) => -> // _. 160 | rewrite !line_comb_row_neq // eq_sym // eq_sym. 161 | by apply: contraNneq h1 => ->. 162 | rewrite negb_or => /andP [hl hr]. 163 | case: (hi (line_comb hd l (a hd) M) h2 hl2) => _ hR. 164 | by rewrite hR // !line_comb_row_neq // eq_sym. 165 | Qed. 166 | 167 | (* if k != l, line_comb doesn't change the det *) 168 | Lemma det_line_comb : forall n k l a (M: 'M[R]_n), 169 | k != l -> \det (line_comb k l a M) = \det M. 170 | Proof. 171 | move => n k l a M hkl. 172 | have h : row k (line_comb k l a M) = 1 *: row k M + 173 | a *: row k (\matrix_(i < n) if i == k then row l M else row i M). 174 | by rewrite scale1r; apply/rowP => i; rewrite !mxE eqxx !mxE. 175 | rewrite (determinant_multilinear h). 176 | - rewrite mul1r [X in a * X](determinant_alternate hkl). 177 | + by rewrite mulr0 addr0. 178 | by move => x; rewrite !mxE eqxx eq_sym (negbTE hkl). 179 | - by apply/matrixP => i j; rewrite !mxE eq_sym (negbTE (neq_lift k i)) !mxE. 180 | by apply/matrixP => i j; rewrite !mxE eq_sym (negbTE (neq_lift k i)) !mxE. 181 | Qed. 182 | 183 | Lemma det_lines_comb m a l (M: 'M[R]_m) s: 184 | l \notin s -> 185 | \det (foldl (fun N i => line_comb i l a N) M s) = \det M. 186 | Proof. 187 | elim : s M => [ | hd tl hi] M //=. 188 | rewrite in_cons negb_or => /andP [hl1 hl2]. 189 | by rewrite hi // det_line_comb // eq_sym. 190 | Qed. 191 | 192 | Lemma det_lines_comb_dep m (a: 'I_m -> R) l (M: 'M[R]_m) s: 193 | l \notin s -> 194 | \det (foldl (fun N i => line_comb i l (a i) N) M s) = \det M. 195 | Proof. 196 | elim : s M => [ | hd tl hi] M //=. 197 | rewrite in_cons negb_or => /andP [hl1 hl2]. 198 | by rewrite hi // det_line_comb // eq_sym. 199 | Qed. 200 | 201 | 202 | (* if k == l, line_comb == line_scale *) 203 | Lemma det_line_comb_eq : forall n k l a (M: 'M[R]_n), 204 | k == l -> \det (line_comb k l a M) = (1 + a) * \det M. 205 | Proof. 206 | move => n k l a M /eqP ->; clear k. 207 | have h : row l (line_comb l l a M) = 1 *: row l M + a *: row l M. 208 | - rewrite /line_scale. 209 | by apply/rowP => i; rewrite !mxE eqxx !mxE mul1r. 210 | rewrite (determinant_multilinear h) ?mulrDl //. 211 | rewrite /line_scale; apply/matrixP => i j; rewrite !mxE. 212 | by rewrite eq_sym (negbTE (neq_lift l i)) !mxE. 213 | rewrite /line_scale; apply/matrixP => i j; rewrite !mxE. 214 | by rewrite eq_sym (negbTE (neq_lift l i)) !mxE. 215 | Qed. 216 | 217 | End atomic_operations. 218 | -------------------------------------------------------------------------------- /theory/closed_poly.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From mathcomp Require Import all_algebra. 3 | From mathcomp Require Import all_real_closed. 4 | From CoqEAL Require Import ssrcomplements. 5 | 6 | (******************************************************************************) 7 | (* *) 8 | (* This file contains theory about polynomials with coefficients *) 9 | (* in a closed field. *) 10 | (* *) 11 | (* In follow we pose p = (X - r1)^+a1 * (X - r2)^+a2 * ... * (X - rn)^+an *) 12 | (* *) 13 | (* root_seq p == the sequence of all roots of polynomial p. *) 14 | (* root_seq_uniq p == the sequence of all distinct roots of *) 15 | (* polynomial p (i.e the sequence [:: r1; ...; rn]) *) 16 | (* root_mu_seq p == the sequence of pair off the roots and *) 17 | (* its multiplicity of polynomial p. *) 18 | (* (i.e the sequence [:: (r1,a1); ... ; (rn,an)]) *) 19 | (* root_seq_poly s == the concatenation of the sequences root_mu_seq p *) 20 | (* for all polynomials p in the sequence s. *) 21 | (* linear_factor_seq p == the sequence of linear factor tha appear of the *) 22 | (* decompositionof polynomial p. (i.e the sequence *) 23 | (* [:: (X - r1)^+a1; ... ; (X - rn)^+an]) *) 24 | (* *) 25 | (******************************************************************************) 26 | 27 | Set Implicit Arguments. 28 | Unset Strict Implicit. 29 | Unset Printing Implicit Defensive. 30 | 31 | Section poly_closedFieldType. 32 | 33 | Variable F : closedFieldType. 34 | Import GRing.Theory. 35 | 36 | Local Open Scope ring_scope. 37 | 38 | Definition root_seq : {poly F} -> seq F := 39 | let fix loop (p : {poly F}) (n : nat) := 40 | if n is n.+1 then 41 | if (size p != 1%N) =P true is ReflectT p_neq0 42 | then let x := projT1 (sigW (closed_rootP p p_neq0)) in 43 | x :: loop (p %/ ('X - x%:P)) n 44 | else [::] 45 | else [::] 46 | in fun p => loop p (size p). 47 | 48 | Lemma root_root_seq (p : {poly F}) x : p != 0 -> x \in root_seq p = root p x. 49 | Proof. 50 | rewrite /root_seq; set loop := fix loop p n := if n is _.+1 then _ else _. 51 | elim: size {-2 5}p (erefl (size p))=> /= {p} [|n ihn] p /=. 52 | by move/eqP; rewrite size_poly_eq0 => /eqP->; rewrite eqxx. 53 | case: eqP=> /= [sp_neq1 sp_eqn|/negP]; last first. 54 | rewrite negbK=> /size_poly1P [c c_neq0 ->] _ _. 55 | by rewrite rootC (negPf c_neq0). 56 | case: sigW => z /= rpz p_neq0. 57 | rewrite in_cons; have [->|neq_xz] //= := altP eqP. 58 | move: rpz sp_eqn => /factor_theorem [q ->]. 59 | rewrite mulpK ?polyXsubC_eq0 // rootM root_XsubC (negPf neq_xz) orbF. 60 | have [->|q_neq0] := eqVneq q 0; first by rewrite mul0r size_poly0. 61 | rewrite size_mul ?polyXsubC_eq0 // size_XsubC addn2. 62 | by case=> /ihn /(_ q_neq0). 63 | Qed. 64 | 65 | Lemma root_seq_cons (p : {poly F}) x s : root_seq p = x :: s -> 66 | s = root_seq (p %/ ('X - x%:P)). 67 | Proof. 68 | rewrite /root_seq; set loop := fix loop p n := if n is _.+1 then _ else _. 69 | case H: (size p)=> [|n] //=; case: eqP=> // Hp. 70 | move/eqP; rewrite eqseq_cons; case/andP=> /eqP {1}<- /eqP <-. 71 | suff ->: n = size (p %/ ('X - x%:P))=> //. 72 | by rewrite size_divp ?polyXsubC_eq0 // size_XsubC subn1 H. 73 | Qed. 74 | 75 | Lemma root_seq_eq (p : {poly F}) : 76 | p = lead_coef p *: \prod_(x <- root_seq p) ('X - x%:P). 77 | Proof. 78 | move: {2}(root_seq p) (erefl (root_seq p))=> s. 79 | elim: s p=> [p | x s IHp p H]. 80 | rewrite /root_seq; set loop := fix loop p n := if n is _.+1 then _ else _. 81 | case H: (size p)=> [|n]. 82 | move/eqP: H; rewrite size_poly_eq0=> /eqP ->. 83 | by rewrite lead_coef0 scale0r. 84 | case: n H => [H | n H] /=; case: eqP => //. 85 | move=> _ _; rewrite big_nil. 86 | move/eqP: H => /size_poly1P [c H] ->. 87 | by rewrite lead_coefC alg_polyC. 88 | by move/negP; rewrite negbK H. 89 | rewrite H big_cons (root_seq_cons H) mulrC scalerAl. 90 | have Hfp : p = p %/ ('X - x%:P) * ('X - x%:P). 91 | apply/eqP; rewrite -dvdp_eq dvdp_XsubCl -root_root_seq. 92 | by rewrite H mem_head. 93 | move: H; rewrite /root_seq. 94 | set loop := fix loop p n := if n is _.+1 then _ else _. 95 | by apply: contraPneq => ->; rewrite size_poly0. 96 | suff -> : lead_coef p = lead_coef (p %/ ('X - x%:P)). 97 | by rewrite -IHp ?(root_seq_cons H). 98 | by rewrite {1}Hfp lead_coef_Mmonic // monicXsubC. 99 | Qed. 100 | 101 | Lemma root_seq0 : root_seq 0 = [::]. 102 | Proof. by rewrite /root_seq size_poly0. Qed. 103 | 104 | Lemma size_root_seq p : size (root_seq p) = (size p).-1. 105 | Proof. 106 | have [-> | p0] := eqVneq p 0; first by rewrite root_seq0 size_poly0. 107 | rewrite {2}[p]root_seq_eq size_scale ?lead_coef_eq0 //. 108 | rewrite (big_nth 0) big_mkord size_prod. 109 | rewrite (eq_bigr (fun=> (1 + 1)%N)). 110 | by rewrite big_split sum1_card /= subSKn addnK card_ord. 111 | by move=> i _; rewrite size_XsubC. 112 | by move=> i _; rewrite polyXsubC_eq0. 113 | Qed. 114 | 115 | Lemma root_seq_nil (p : {poly F}) : 116 | (size p <= 1)%N = ((root_seq p) == [::]). 117 | Proof. by rewrite -subn_eq0 subn1 -size_root_seq size_eq0. Qed. 118 | 119 | Lemma sub_root_div (p q : {poly F}) (Hq : q != 0) : 120 | p %| q -> {subset (root_seq p) <= (root_seq q)} . 121 | Proof. 122 | case: (eqVneq p 0) => [->|p0]; first by rewrite root_seq0. 123 | by case/dvdpP => x Hx y; rewrite !root_root_seq // Hx rootM orbC=> ->. 124 | Qed. 125 | 126 | Definition root_seq_uniq p := undup (root_seq p). 127 | 128 | Lemma prod_XsubC_count (p : {poly F}): 129 | p = (lead_coef p) *: 130 | \prod_(x <- root_seq_uniq p) ('X - x%:P)^+ (count_mem x (root_seq p)). 131 | Proof. 132 | by rewrite {1}[p]root_seq_eq (prod_seq_count (root_seq p)). 133 | Qed. 134 | 135 | Lemma count_root_seq p x : count_mem x (root_seq p) = \mu_x p. 136 | Proof. 137 | have [-> | Hp] := eqVneq p 0; first by rewrite root_seq0 mu0. 138 | apply/eqP; rewrite -muP //. 139 | case/boolP: (x \in root_seq p) => [|H]. 140 | rewrite -mem_undup => H. 141 | move: (prod_XsubC_count p). 142 | rewrite (bigD1_seq x) //= ?undup_uniq //. 143 | set b:= \big[_/_]_(_ <- _ | _) _ => Hpq. 144 | apply/andP; split; apply/dvdpP. 145 | by exists (lead_coef p *: b); rewrite -scalerAl mulrC. 146 | case=> q Hq. 147 | have H1: ~~ (('X - x%:P) %| b). 148 | rewrite dvdp_XsubCl; apply/rootP. 149 | rewrite horner_prod; apply/eqP. 150 | rewrite (big_nth 0) big_mkord. 151 | apply/prodf_neq0=> i Hix. 152 | by rewrite horner_exp hornerXsubC expf_neq0 // subr_eq0 eq_sym. 153 | have H2: (('X - x%:P) %| b). 154 | apply/dvdpP; exists ((lead_coef p)^-1 *: q). 155 | apply: (@scalerI _ _ (lead_coef p)); first by rewrite lead_coef_eq0. 156 | rewrite -scalerAl scalerA mulrV ?unitfE ?lead_coef_eq0 // scale1r. 157 | have HX: (('X - x%:P)^+ (count_mem x (root_seq p))) != 0. 158 | by apply: expf_neq0; rewrite -size_poly_eq0 size_XsubC. 159 | rewrite -(mulpK (_ *: b) HX) -(mulpK (q * _) HX). 160 | by rewrite -scalerAl mulrC -Hpq -mulrA -exprS -Hq. 161 | by rewrite H2 in H1. 162 | have->: count_mem x (root_seq p) = 0%N by apply/count_memPn. 163 | by rewrite dvd1p /= dvdp_XsubCl -root_root_seq. 164 | Qed. 165 | 166 | Definition root_mu_seq p := [seq (x,(\mu_x p)) | x <- (root_seq_uniq p)]. 167 | 168 | Lemma root_mu_seq_pos x p : p != 0 -> x \in root_mu_seq p -> (0 < x.2)%N. 169 | Proof. 170 | move=> Hp H. 171 | have Hr: size (root_seq_uniq p) = size (root_mu_seq p) by rewrite size_map. 172 | have Hs: (index x (root_mu_seq p) < size (root_seq_uniq p))%N. 173 | by rewrite Hr index_mem. 174 | rewrite -(nth_index (0,0%N) H) // (nth_map 0) // mu_gt0 //. 175 | by rewrite -root_root_seq // -mem_undup mem_nth. 176 | Qed. 177 | 178 | Definition root_seq_poly (s : seq {poly F}) := flatten (map root_mu_seq s). 179 | 180 | Lemma root_seq_poly_pos x s : (forall p , p \in s -> p !=0) -> 181 | x \in root_seq_poly s -> (0 < x.2)%N. 182 | Proof. 183 | elim : s=> [|p l IHl H]; first by rewrite in_nil. 184 | rewrite mem_cat. 185 | case/orP; first by apply: root_mu_seq_pos; apply: H; rewrite mem_head. 186 | by apply: IHl=> q Hq; apply: H; rewrite in_cons Hq orbT. 187 | Qed. 188 | 189 | Definition linear_factor_seq p := 190 | [seq ('X - x.1%:P)^+x.2 | x <- (root_mu_seq p)]. 191 | 192 | Lemma monic_linear_factor_seq p : forall q, q \in linear_factor_seq p -> 193 | q \is monic. 194 | Proof. 195 | move=> q Hq; rewrite -(nth_index 0 Hq) (nth_map (0,0%N)). 196 | apply: monic_exp; first by apply: monicXsubC. 197 | by rewrite -index_mem size_map in Hq. 198 | Qed. 199 | 200 | Lemma size_linear_factor_leq1 p : forall q, q \in linear_factor_seq p -> 201 | (1 < size q)%N. 202 | Proof. 203 | move=> q; have [-> | Hp Hq] := eqVneq p 0. 204 | rewrite /linear_factor_seq /root_mu_seq. 205 | by rewrite /root_seq_uniq /root_seq size_poly0. 206 | rewrite -(nth_index 0 Hq) (nth_map (0,0%N)); last first. 207 | by rewrite -index_mem size_map in Hq. 208 | rewrite size_exp_XsubC (nth_map 0); last first. 209 | by rewrite -index_mem !size_map in Hq. 210 | rewrite -(@prednK (\mu_ _ _)) // mu_gt0 // -root_root_seq //. 211 | rewrite -mem_undup mem_nth //. 212 | by rewrite -index_mem !size_map in Hq. 213 | Qed. 214 | 215 | Lemma coprimep_linear_factor_seq p : 216 | forall (i j : 'I_(size (linear_factor_seq p))), 217 | i != j -> 218 | coprimep (linear_factor_seq p)`_i (linear_factor_seq p)`_j. 219 | Proof. 220 | move=> [i +] [j +]; rewrite !size_map=> Hi Hj Hij. 221 | rewrite !(nth_map (0,0%N)) ?size_map //. 222 | apply/coprimep_expl/coprimep_expr/coprimep_factor. 223 | by rewrite unitfE subr_eq0 !(nth_map 0) //= nth_uniq // ?undup_uniq // eq_sym. 224 | Qed. 225 | 226 | Lemma prod_XsubC_mu (p : {poly F}): 227 | p = (lead_coef p) *: \prod_(x <- root_seq_uniq p) ('X - x%:P)^+(\mu_x p). 228 | Proof. 229 | rewrite {1}[p]prod_XsubC_count. 230 | by congr GRing.scale; apply: eq_bigr => i _; rewrite count_root_seq. 231 | Qed. 232 | 233 | Lemma monic_prod_XsubC p : 234 | p \is monic -> p = \prod_(x <- root_seq_uniq p) ('X - x%:P)^+(\mu_x p). 235 | Proof. 236 | by move/monicP=> H; rewrite {1}[p]prod_XsubC_mu H scale1r. 237 | Qed. 238 | 239 | Lemma prod_factor (p : {poly F}): 240 | p = (lead_coef p) *: \prod_(x <- linear_factor_seq p) x. 241 | Proof. 242 | by rewrite !big_map {1}[p]prod_XsubC_mu. 243 | Qed. 244 | 245 | Lemma monic_prod_factor p : 246 | p \is monic -> p = \prod_(x <- linear_factor_seq p) x. 247 | Proof. 248 | by move/monicP=> H; rewrite {1}[p]prod_factor H scale1r. 249 | Qed. 250 | 251 | Lemma uniq_root_mu_seq (p : {poly F}) : uniq (root_seq p) -> 252 | forall x, x \in root_mu_seq p -> x.2 = 1%N. 253 | Proof. 254 | move=> H x /(nthP (0,0%N)) [] i; rewrite size_map=> Hi. 255 | rewrite (nth_map 0) // => <- /=; move: Hi. 256 | rewrite /root_seq_uniq undup_id // -count_root_seq => Hi. 257 | by rewrite count_uniq_mem // (mem_nth 0 Hi). 258 | Qed. 259 | 260 | Lemma uniq_root_dvdp p q : q != 0 -> 261 | (uniq (root_seq q)) -> p %| q -> (uniq (root_seq p)). 262 | Proof. 263 | move=> Hq Hq2 Hpq. 264 | apply: count_mem_uniq=> x. 265 | have Hc:= count_uniq_mem x Hq2. 266 | have Hle: (count_mem x (root_seq p) <= count_mem x (root_seq q))%N. 267 | rewrite !count_root_seq; case/dvdpP: Hpq => r Hr. 268 | by rewrite Hr mu_mul -?Hr // leq_addl. 269 | have: (count_mem x (root_seq p) <= 1)%N. 270 | by rewrite (leq_trans Hle) // Hc; case: (x \in root_seq q). 271 | rewrite leq_eqVlt ltnS leqn0. 272 | case Hp: (x \in root_seq p). 273 | rewrite -has_pred1 has_count in Hp. 274 | by rewrite (eqn_leq _ 0%N) leqNgt Hp orbF => /eqP ->. 275 | by rewrite eqn_leq -has_count has_pred1 Hp andbF orFb => /eqP ->. 276 | Qed. 277 | 278 | Lemma root_root_mu_seq p : [seq x.1 | x <- root_mu_seq p] = root_seq_uniq p. 279 | Proof. 280 | apply: (@eq_from_nth _ 0)=>[|i]; rewrite !size_map //. 281 | by move=> Hi; rewrite (nth_map (0,0%N)) ?size_map // (nth_map 0) //. 282 | Qed. 283 | 284 | End poly_closedFieldType. 285 | -------------------------------------------------------------------------------- /theory/companion.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From mathcomp Require Import all_algebra. 3 | From CoqEAL Require Import ssrcomplements mxstructure. 4 | 5 | (** This file defines companion matrices for any non-constant polynomial and 6 | prooves the properties of their characteristic and minimal polynomials 7 | 8 | companion_mx p == The companion matrix of the polynomial p. 9 | 10 | *) 11 | 12 | 13 | Set Implicit Arguments. 14 | Unset Strict Implicit. 15 | Unset Printing Implicit Defensive. 16 | 17 | Section Companion. 18 | 19 | Local Open Scope ring_scope. 20 | Import GRing.Theory. 21 | 22 | Variable R : comRingType. 23 | 24 | Definition companion_mxn n (p : {poly R}) := 25 | \matrix_(i, j < n ) ((i == j.+1 :> nat)%:R 26 | - p`_i *+ ((size p).-2 == j)). 27 | 28 | Definition companion_mx (p : {poly R}) := companion_mxn (size p).-2.+1 p. 29 | 30 | Lemma comp_char_polyK : forall (p : {poly R}), p \is monic -> 31 | (1 < size p)%N -> char_poly (companion_mx p) = p. 32 | Proof. 33 | apply: poly_ind=> [|p c IHp]; first by move/monic_neq0/eqP. 34 | have [-> H | p0 Hm Hs] := eqVneq p 0. 35 | by rewrite mul0r add0r {1}size_polyC; case: eqP. 36 | have Hcst1 : (size (p * 'X + c%:P)).-1 = (size p).-1.+1. 37 | by rewrite size_MXaddC (negbTE p0) -polySpred. 38 | have Hmp : p \is monic. 39 | rewrite monicE -lead_coefMX -(@lead_coefDl _ _ (c%:P)) -?monicE //. 40 | by rewrite size_polyC size_mulX // polySpred //; case:(c != 0). 41 | case: (ltnP 1 (size p))=> Hpt; last first. 42 | have Hp1: p = 1%:P by rewrite -(monicP Hmp) [p]size1_polyC // lead_coefC. 43 | rewrite /companion_mx !Hcst1 Hp1 mul1r /char_poly size_polyC oner_eq0. 44 | set M := char_poly_mx _. 45 | rewrite [M]mx11_scalar det_scalar1 !mxE coefD coefC coefX. 46 | by rewrite !add0r polyCN opprK size_XaddC. 47 | rewrite /char_poly /companion_mx Hcst1. 48 | rewrite (expand_det_row _ ord0) big_ord_recl !mxE. 49 | rewrite mulr1n !mulr0n add0r /cofactor !addn0 expr0 mul1r. 50 | set d1 := \det _. 51 | case Hnp: (size p) (Hpt)=> [|n] //; case: n Hnp=> // n Hnp _. 52 | rewrite big_ord_recr big1; last first. 53 | move=> i _; rewrite !mxE !sub0r size_MXaddC (negbTE p0) andFb. 54 | have:= (neq_ltn n (widen_ord (leqnSn n) i)). 55 | rewrite Hnp (ltn_ord i) orbT lift0 eqSS. 56 | by move/negbTE ->; rewrite polyCN opprK mul0r. 57 | rewrite /= add0r; set M := row' _ _. 58 | have HM: upper_triangular_mx M. 59 | apply/upper_triangular_mxP=> i j Hij. 60 | rewrite !mxE -(inj_eq (@ord_inj _)) /= /bump !leq0n leqNgt (ltn_ord j). 61 | rewrite add1n eqn_leq leqNgt ltnS ltnW // sub0r eqSS eqn_leq leqNgt Hij. 62 | rewrite sub0r eqn_leq size_MXaddC (negbTE p0) andFb Hnp. 63 | by rewrite (leqNgt n.+1) (ltn_ord j) polyCN opprK. 64 | have->: \det M = (-1)^+n.+1. 65 | rewrite (det_triangular_mx HM) -{7}[n.+1]card_ord -prodr_const. 66 | apply: eq_bigr=> i _; rewrite !mxE -(inj_eq (@ord_inj _)) !lift0 !lift_max. 67 | rewrite eqxx !eqn_leq ltnn size_MXaddC (negbTE p0) andFb Hnp. 68 | by rewrite (leqNgt _ i) (ltn_ord i) sub0r subr0. 69 | rewrite !mxE -exprD -signr_odd addnn odd_double mulr1 polyCN opprK. 70 | rewrite size_MXaddC (negbTE p0) andFb Hnp addr0 !sub0r. 71 | rewrite -{1}cons_poly_def coef_cons polyCN opprK !eqxx -(IHp Hmp Hpt) mulrC. 72 | suff ->: d1 = char_poly (companion_mx p)=> //. 73 | rewrite /companion_mx. 74 | have ->: (size p).-2.+1 = (size p).-1.+1.-1.+1.-1 by rewrite Hnp. 75 | congr (\det _); rewrite row'_col'_char_poly_mx; congr char_poly_mx. 76 | apply/matrixP=> i j; rewrite !mxE !eqSS -cons_poly_def coef_cons size_cons_poly. 77 | rewrite nil_poly (negbTE p0). 78 | by rewrite !lift0 /= {4 9}Hnp. 79 | Qed. 80 | 81 | End Companion. 82 | 83 | Section CompanionMin. 84 | 85 | Variable F : fieldType. 86 | Local Open Scope ring_scope. 87 | Import GRing.Theory. 88 | 89 | Lemma comp_mxminpolyK : forall (p : {poly F}), p \is monic -> 90 | (1 < size p)%N -> mxminpoly (companion_mx p) = p. 91 | Proof. 92 | move=> p Hp Hs. 93 | set A := companion_mx p. 94 | suff Hn: forall q, horner_mx A q = 0 -> 95 | (q == 0) || ((size p).-2 < (size q).-1)%N. 96 | have Hm0: (mxminpoly A == 0) = false. 97 | by apply: negbTE; rewrite monic_neq0 // mxminpoly_monic. 98 | have:= Hn (mxminpoly A) (mx_root_minpoly A); rewrite Hm0 /= => Hmn. 99 | have Hsm : size (mxminpoly A) == size (char_poly A). 100 | rewrite eqn_leq dvdp_leq ?mxminpoly_dvd_char ?monic_neq0 ?char_poly_monic //. 101 | by rewrite size_char_poly -(addn1 _.-2) addnC -ltn_subRL subn1. 102 | apply/eqP; rewrite -eqp_monic // ?mxminpoly_monic //. 103 | by rewrite -{2}(comp_char_polyK Hp) // -dvdp_size_eqp // mxminpoly_dvd_char. 104 | move=> q; case: (ltnP (size p).-2 (size q).-1); first by rewrite orbT. 105 | have H (i : 'I_(size p).-2): 106 | A *m col (widen_ord (leqnSn (size p).-2) i) 1%:M = col (lift ord0 i) 1%:M. 107 | rewrite col_id_mulmx; apply/matrixP=> j k; rewrite !mxE. 108 | rewrite -(inj_eq (@ord_inj _)) lift0. 109 | by rewrite (eqn_leq _ i) (leqNgt _ i) (ltn_ord i) subr0. 110 | have H2: forall i : 'I_(size p).-2.+1, (A ^+ i) *m col ord0 1%:M = col i 1%:M. 111 | case; elim=> [Hi|i IH Hi] /=. 112 | by rewrite expr0 mul1mx; congr col; apply: ord_inj. 113 | rewrite exprS -mulmxA (IH (ltnW Hi)). 114 | have Ho: (i < (size p).-2)%N by rewrite -ltnS. 115 | have ->: (Ordinal (ltnW Hi)) = (widen_ord (leqnSn (size p).-2) (Ordinal Ho)). 116 | by apply: ord_inj. 117 | by rewrite H; congr col; apply: ord_inj; rewrite lift0. 118 | case Hq: (q == 0)=> //. 119 | have Hsq: (0 < size q)%N by rewrite size_poly_gt0 Hq. 120 | rewrite /horner_mx /horner_morph horner_coef. 121 | rewrite size_map_poly_id0 ?fmorph_eq0 ?lead_coef_eq0 ?Hq // => H1 Hb. 122 | have Hw: (size q <= (size p).-2.+1)%N by rewrite -(prednK Hsq). 123 | suff : q == 0 by rewrite Hq. 124 | have: \sum_(i < size q) q`_i *: (A ^+ i *m col ord0 1%:M) = 0. 125 | rewrite (eq_bigr (fun i : 'I_(size q) => 126 | ((map_poly scalar_mx q)`_i * A ^+ i) *m col ord0 1%:M)). 127 | by rewrite -mulmx_suml ?Hb ?mul0mx //. 128 | by move=> i _; rewrite coef_map scalemxAl -mul_scalar_mx. 129 | set b := \sum_(_ < _) _. 130 | have <-: \col_(i < (size p).-2.+1) q`_i = b. 131 | apply/matrixP=> i j; rewrite mxE summxE. 132 | case: (ltnP i (size q))=> Hi. 133 | rewrite (bigD1 (Ordinal Hi)) //= H2 !mxE eqxx mulr1 big1 ?addr0 //. 134 | move=> k Hk; rewrite (H2 (widen_ord Hw k)) !mxE. 135 | move/negbTE: Hk; rewrite -!(inj_eq (@ord_inj _)) /= eq_sym=> ->. 136 | by rewrite mulr0. 137 | rewrite nth_default // big1 // => k _. 138 | rewrite (H2 (widen_ord Hw k)) !mxE -(inj_eq (@ord_inj _)) /= eqn_leq. 139 | by rewrite leqNgt (leq_trans (ltn_ord k) Hi) andFb mulr0. 140 | move/matrixP=> Hc. 141 | apply/eqP/size_poly_leq0P/leq_sizeP=> j _. 142 | case: (ltnP j (size p).-2.+1)=> Hj. 143 | by move: (Hc (Ordinal Hj) ord0); rewrite !mxE. 144 | by rewrite nth_default //; apply: leq_trans Hj. 145 | Qed. 146 | 147 | End CompanionMin. 148 | -------------------------------------------------------------------------------- /theory/gauss.v: -------------------------------------------------------------------------------- 1 | (** This file is part of CoqEAL, the Coq Effective Algebra Library. 2 | (c) Copyright INRIA and University of Gothenburg, see LICENSE *) 3 | From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype. 4 | From mathcomp Require Import div finfun bigop prime binomial ssralg finset fingroup finalg. 5 | From mathcomp Require Import mxalgebra perm zmodp matrix ssrint. 6 | 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Unset Printing Implicit Defensive. 10 | 11 | Section Gaussian. 12 | 13 | Import GRing.Theory. 14 | 15 | Local Open Scope ring_scope. 16 | 17 | Variable F : fieldType. 18 | 19 | Definition find_pivot m n (A : 'M[F]_(m,n.+1)) : option 'I_m := 20 | [pick k | A k 0 != 0]. 21 | 22 | Fixpoint cormen_lup {m n} := 23 | match m, n return 'M_(m.+1,n.+1) -> 'S_m.+1 * 'M_(m.+1,m.+1) * 'M_(m.+1,n.+1) with 24 | | p.+1, _.+1 => fun (A : 'M_(1 + (1 + p), 1 + _)) => 25 | let k := odflt 0 (find_pivot A) in 26 | let A1 : 'M_(1 + _, 1 + _) := xrow 0 k A in 27 | let P1 : 'S_(1 + (1 + p)) := tperm 0 k in 28 | let Schur := ((fun_of_matrix A k 0)^-1 *: dlsubmx A1) *m ursubmx A1 in 29 | let: (P2, L2, U2) := cormen_lup (drsubmx A1 - Schur) in 30 | let P := (lift0_perm P2 * P1)%g in 31 | let pA1 := row_perm P2 (dlsubmx A1) in 32 | let L := block_mx 1%:M (const_mx 0) ((fun_of_matrix A k 0)^-1 *: pA1) L2 in 33 | let U := block_mx (ulsubmx A1) (ursubmx A1) (const_mx 0) U2 in 34 | (P, L, U) 35 | | _, _ => fun A => (1%g, 1%:M, A) 36 | end. 37 | 38 | Lemma cormen_lup_correct n (A : 'M_n.+1) : 39 | let: (P, L, U) := cormen_lup A in matrix.row_perm P A = L * U. 40 | Proof. 41 | elim: n => [|n IHn] /= in A *; first by rewrite row_perm1 mul1r. 42 | set k := odflt _ _; set A1 : 'M_(1 + _) := matrix.xrow _ _ _. 43 | set A' := _ - _; move/(_ A'): IHn; case: cormen_lup => [[P' L' U']] /= IHn. 44 | (* glueing code *) 45 | rewrite row_permM !row_permE. 46 | rewrite -lift0_mx_perm. 47 | rewrite /lift0_mx. 48 | (****************) 49 | rewrite -!mulmxE -xrowE -/A1 /= -[n.+2]/(1 + n.+1)%N -{1}(submxK A1). 50 | rewrite !mulmx_block !mul0mx !mulmx0 !add0r !addr0 !mul1mx -{L' U'}[L' *m _]IHn. 51 | rewrite row_permE. 52 | rewrite -scalemxAl !scalemxAr -!mulmxA addrC -mulrDr {A'}subrK. 53 | congr (block_mx _ _ (_ *m _) _). 54 | rewrite [_ *: _]mx11_scalar !mxE lshift0 tpermL {}/A1 {}/k /find_pivot. 55 | case: pickP => /= [k nzAk0 | no_k]; first by rewrite mulVf ?mulmx1. 56 | rewrite (_ : matrix.dlsubmx _ = 0) ?mul0mx //; apply/colP=> i. 57 | by rewrite !mxE lshift0 (elimNf eqP (no_k _)). 58 | Qed. 59 | 60 | Lemma cormen_lup_detL n (A : 'M_n.+1) : \det (cormen_lup A).1.2 = 1. 61 | Proof. 62 | elim: n => [|n IHn] /= in A *; first by rewrite det1. 63 | set A' := _ - _; move/(_ A'): IHn; case: cormen_lup => [[P L U]] {A'}/= detL. 64 | by rewrite (@det_lblock _ 1) det1 mul1r. 65 | Qed. 66 | 67 | Lemma cormen_lup_lower n (A : 'M_n.+1) (i j : 'I_n.+1) : 68 | i <= j -> (cormen_lup A).1.2 i j = (i == j)%:R. 69 | Proof. 70 | elim: n => [|n IHn] /= in A i j *; first by rewrite [i]ord1 [j]ord1 mxE. 71 | set A' := _ - _; move/(_ A'): IHn; case: cormen_lup => [[P L U]] {A'}/= Ll. 72 | rewrite !mxE split1; case: unliftP => [i'|] -> /=; rewrite !mxE split1. 73 | by case: unliftP => [j'|] -> //; exact: Ll. 74 | by case: unliftP => [j'|] ->; rewrite /= mxE. 75 | Qed. 76 | 77 | Lemma cormen_lup_upper n A (i j : 'I_n.+1) : 78 | j < i -> (cormen_lup A).2 i j = 0 :> F. 79 | Proof. 80 | elim: n => [|n IHn] /= in A i j *; first by rewrite [i]ord1. 81 | set A' := _ - _; move/(_ A'): IHn; case: cormen_lup => [[P L U]] {A'}/= Uu. 82 | rewrite !mxE split1; case: unliftP => [i'|] -> //=; rewrite !mxE split1. 83 | by case: unliftP => [j'|] ->; [exact: Uu | rewrite /= mxE]. 84 | Qed. 85 | 86 | End Gaussian. 87 | -------------------------------------------------------------------------------- /theory/jordan.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From mathcomp Require Import all_algebra. 3 | From mathcomp Require Import all_fingroup. 4 | From mathcomp Require Import all_real_closed. 5 | From CoqEAL Require Import binetcauchy ssrcomplements mxstructure minor. 6 | From CoqEAL Require Import smith dvdring polydvd. 7 | From CoqEAL Require Import similar perm_eq_image companion closed_poly smith_complements. 8 | From CoqEAL Require Import frobenius_form. 9 | 10 | (** The main result of this file is the theorem of Jordan decomposition. 11 | A direct consequence of this theorem is the diagonalization theorem. 12 | 13 | Jordan_block lam n == The Jordan block of dimension n with 14 | the value lam on the diagonal. 15 | Jordan_form M == The block diagonal matrix formed by the 16 | Jordan blocks of roots of invariant 17 | factors of M, and of dimension their 18 | multiplicity. 19 | 20 | *) 21 | 22 | 23 | Set Implicit Arguments. 24 | Unset Strict Implicit. 25 | Unset Printing Implicit Defensive. 26 | 27 | Section def. 28 | 29 | Variable R : ringType. 30 | Import GRing.Theory. 31 | Local Open Scope ring_scope. 32 | 33 | Definition Jordan_block lam n : 'M[R]_n := 34 | \matrix_(i,j) (lam *+ (i == j :> nat) + (i.+1 == j)%:R). 35 | 36 | Lemma Jordan_block0 : Jordan_block 0 1 = 0. 37 | Proof. 38 | by apply/matrixP=> i j; rewrite !mxE !ord1 addr0. 39 | Qed. 40 | 41 | Lemma upt_Jordan_block lam n : upper_triangular_mx (Jordan_block lam n). 42 | Proof. 43 | apply/upper_triangular_mxP=> i j Hij ; rewrite mxE. 44 | by rewrite (gtn_eqF Hij) eqn_leq ltnNge (ltnW Hij) addr0. 45 | Qed. 46 | 47 | End def. 48 | 49 | 50 | Section trigonal. 51 | 52 | Variable R : comRingType. 53 | Import GRing.Theory. 54 | Local Open Scope ring_scope. 55 | 56 | 57 | Lemma det_Jordan_block (lam : R) n : \det (Jordan_block lam n) = lam ^+ n. 58 | Proof. 59 | rewrite det_triangular_mx; last by apply: upt_Jordan_block. 60 | rewrite -{8}[n]card_ord -prodr_const. 61 | by apply: eq_bigr=> i _; rewrite mxE eqxx eqn_leq ltnn addr0. 62 | Qed. 63 | 64 | Lemma Jordan_expn (lam : R) n k : 65 | (Jordan_block lam n.+1)^+ k = 66 | \matrix_(i,j) (('C(k,j - i)%:R * (lam^+ (k - (j - i)))) *+ (i <= j)). 67 | Proof. 68 | elim: k =>[|k IHk]. 69 | apply/matrixP=> i j; rewrite !mxE bin0n subn_eq0 sub0n mulr1 [RHS]mulrb. 70 | by rewrite -(inj_eq (@ord_inj _)) eqn_leq /andb; case: ifP. 71 | rewrite exprS IHk. 72 | apply/matrixP=> i j; rewrite !mxE. 73 | case: (eqVneq i ord_max) => Hi. 74 | - rewrite (bigD1 i) //= !mxE big1 ?addr0=>[|l /negbTE Hl]. 75 | - rewrite eqxx eqn_leq ltnn addr0. 76 | have ->: (j - i)%N = 0%N by apply/eqP; rewrite subn_eq0 Hi -ltnS. 77 | by rewrite !bin0 !mul1r !subn0 mulrnAr exprS. 78 | rewrite !mxE eq_sym [(_ == _ :> nat)]Hl Hi eqn_leq. 79 | by rewrite ltnNge -ltnS ltn_ord addr0 mul0r. 80 | have Ho: (i.+1 < n.+1)%N by rewrite ltn_neqAle Hi ltn_ord. 81 | rewrite (bigD1 i) //= (bigD1 (Ordinal Ho)); last first. 82 | by rewrite -(inj_eq (@ord_inj _)) eqn_leq ltnn. 83 | rewrite !mxE eqxx (@eq_sym nat i) !eqn_leq !ltnn addr0 add0r. 84 | rewrite !leqnn mul1r subnS /= big1 ?addr0; last first. 85 | move=> l /andP [] /negbTE Hil /negbTE Hl. 86 | by rewrite !mxE eq_sym [_ == _ :>nat]Hil eq_sym [_ == _ :>nat]Hl addr0 mul0r. 87 | case: (ltngtP i j)=> Hij; last first. 88 | (*******************cas i = j***********************************) 89 | - by rewrite Hij subnn !subn0 addr0 !bin0 !mul1r exprS. 90 | (****************** cas j < i ****************************************) 91 | - by rewrite addr0 mulr0. 92 | (************* cas i <= j***************************) 93 | rewrite !mulr1n mulrC -mulrA -exprSr -{2}subn1. 94 | have H1ij: (1 <= j - i)%N by rewrite subn_gt0. 95 | rewrite (subnBA _ H1ij) addn1. 96 | case: (leqP (j-i) k)=> Hijk. 97 | by rewrite (subSn Hijk) -mulrDl -{1}(prednK H1ij) -natrD -binS prednK. 98 | have:= Hijk; rewrite -subn_eq0=> /eqP Hijk2. 99 | rewrite (bin_small Hijk) // mul0r Hijk2 !mulr1 add0r. 100 | rewrite leq_eqVlt in Hijk. 101 | case/orP: Hijk=> Hijk. 102 | rewrite (eqP Hijk) binn. 103 | rewrite -(prednK H1ij) eqSS in Hijk. 104 | by rewrite (eqP Hijk) binn. 105 | by rewrite !bin_small // -ltnS prednK. 106 | Qed. 107 | 108 | 109 | Lemma char_poly_Jordan_block (lam : R) n : 110 | char_poly (Jordan_block lam n) = ('X - lam%:P) ^+n. 111 | Proof. 112 | rewrite char_poly_triangular_mx; last by apply: upt_Jordan_block. 113 | rewrite (eq_bigr (fun _ => ('X - lam%:P))) ?prodr_const ?card_ord //. 114 | by move=> i; rewrite mxE eqxx eqn_leq ltnn addr0. 115 | Qed. 116 | 117 | End trigonal. 118 | 119 | Section similar. 120 | 121 | Variable R : fieldType. 122 | Import GRing.Theory. 123 | Import PolyPriField. 124 | Local Open Scope ring_scope. 125 | 126 | 127 | Lemma similar_cj n (lam : R) : 128 | similar (companion_mx (('X - lam%:P)^+ n.+1)) (Jordan_block lam n.+1). 129 | Proof. 130 | set p := _^+n.+1. 131 | have Hmp: p \is monic by rewrite monic_exp // monicXsubC. 132 | have Hsp: (1 < size p)%N by rewrite size_exp_XsubC. 133 | apply/similar_fundamental. 134 | apply: (equiv_trans (equiv_Smith _)). 135 | apply: (equiv_trans (Smith_companion Hsp Hmp)). 136 | set M := char_poly_mx _. 137 | apply/equiv_sym/(equiv_trans (equiv_Smith M)). 138 | rewrite /Smith_form -diag_mx_seq_takel. 139 | set s := take _ _. 140 | have Hs1: size s = n.+1. 141 | rewrite size_Smith_seq // -/(char_poly _) char_poly_Jordan_block. 142 | by rewrite -size_poly_eq0 size_exp_XsubC. 143 | apply: eqd_equiv; rewrite ?size_exp_XsubC // ?size_rcons ?size_nseq //=. 144 | have Hsort: sorted (@dvdr _) s. 145 | by apply/(sorted_take (@dvdr_trans _))/sorted_Smith. 146 | move: (equiv_Smith M). 147 | rewrite /Smith_form -diag_mx_seq_takel => Hequiv. 148 | have Hlemin: (n <= minn n.+1 n.+1)%N by rewrite minnn. 149 | move: (Smith_gcdr_spec Hlemin Hsort Hequiv). 150 | set d := \big[_/_]_(_<_) _=> H. 151 | have {H} Hd1: d %= 1. 152 | apply/(eqd_trans H)/andP; split; last by rewrite dvd1r. 153 | apply: big_gcdr_def; exists (finfun (lift ord_max)). 154 | apply: big_gcdr_def; exists (finfun (lift ord0)). 155 | rewrite /minor.minor /minor.submatrix /=. 156 | set N := \matrix_(_,_) _. 157 | have Hut: upper_triangular_mx N^T. 158 | apply/upper_triangular_mxP=> i j Hij. 159 | rewrite !mxE !ffunE -(inj_eq (@ord_inj _)) lift0 lift_max. 160 | rewrite !eqn_leq !(leqNgt _ j) ltnS (ltnW Hij) ltnNge Hij. 161 | by rewrite andbF addr0 subr0. 162 | rewrite -det_tr (det_triangular_mx Hut). 163 | rewrite (eq_bigr (fun _ => -1)) ?prodr_const ?card_ord; last first. 164 | move=> i; rewrite !mxE !ffunE -(inj_eq (@ord_inj _)) lift0 lift_max. 165 | by rewrite eqxx !eqn_leq ltnn andbF sub0r add0r. 166 | by apply/dvdrP; exists ((-1)^+ n); rewrite -expr2 sqrr_sign. 167 | have Hip: s`_n %= p. 168 | rewrite eqd_sym in Hd1. 169 | rewrite -(mul1r s`_n) (eqd_ltrans (eqd_mulr _ Hd1)). 170 | rewrite /p -char_poly_Jordan_block /char_poly -det_Smith. 171 | rewrite /Smith_form -diag_mx_seq_takel det_diag_mx_seq //. 172 | by rewrite (big_nth 0) big_mkord Hs1 big_ord_recr. 173 | move/eqd_big_mul1: Hd1 => H i. 174 | case: (ltngtP i n) => Hi. 175 | - by rewrite nth_rcons size_nseq Hi nth_nseq Hi (H (Ordinal Hi)). 176 | - by rewrite !nth_default // ?Hs1 // size_rcons size_nseq. 177 | by rewrite nth_rcons size_nseq Hi ltnn eqxx. 178 | Qed. 179 | 180 | End similar. 181 | 182 | 183 | Section jordan. 184 | 185 | Variable R : closedFieldType. 186 | Import GRing.Theory. 187 | Import PolyPriField. 188 | Local Open Scope ring_scope. 189 | 190 | 191 | Definition Jordan_form m (A : 'M[R]_m.+1) := 192 | let sp := root_seq_poly (invariant_factors A) in 193 | let sizes := [seq (x.2).-1 | x <- sp] in 194 | let blocks n i := Jordan_block (nth (0,0%N) sp i).1 n.+1 in 195 | diag_block_mx sizes blocks. 196 | 197 | Lemma upt_Jordan n (A : 'M[R]_n.+1) : 198 | upper_triangular_mx (Jordan_form A). 199 | Proof. 200 | apply: upper_triangular_diag_block=> j. 201 | exact: upt_Jordan_block. 202 | Qed. 203 | 204 | Lemma Jordan n (A : 'M[R]_n.+1) : similar A (Jordan_form A). 205 | Proof. 206 | apply: (similar_trans (Frobenius _)). 207 | apply: (similar_trans (similar_Frobenius _)). 208 | rewrite /Frobenius_form_CF /Jordan_form /root_seq_poly /linear_factor_seq. 209 | set s1 := flatten _. 210 | set s2 := map _ _. 211 | have Hs: size s1 = size s2. 212 | rewrite /s1 size_map. 213 | by do 2! rewrite map_comp -map_flatten size_map. 214 | apply: similar_diag_block=> // i; rewrite /s1. 215 | (do 2! rewrite map_comp -map_flatten size_map) => Hi. 216 | rewrite (nth_map 0) ?size_map //. 217 | rewrite !(nth_map (0,0%N)) ?size_map //. 218 | set x := nth _ _ _. 219 | rewrite -(@prednK x.2); first exact: similar_cj. 220 | have/flattenP [s Hfs Hx] := mem_nth (0,0%N) Hi; move: Hfs. 221 | case/(nthP nil)=> m; rewrite !size_map=> Hm Heq. 222 | move: Heq Hx; rewrite (nth_map 0) // => <-. 223 | apply: root_mu_seq_pos. 224 | apply: (@invariant_factor_neq0 _ _ A). 225 | by rewrite mem_nth. 226 | Qed. 227 | 228 | Lemma Jordan_char_poly n (A : 'M_n.+1) : 229 | char_poly A = \prod_i ('X - ((Jordan_form A) i i)%:P). 230 | Proof. 231 | rewrite (similar_char_poly (Jordan A)). 232 | exact: (char_poly_triangular_mx (upt_Jordan A)). 233 | Qed. 234 | 235 | Lemma eigen_diag n (A : 'M_n.+1) : 236 | let sp := root_seq_poly (invariant_factors A) in 237 | let sizes := [seq (x.2).-1 | x <- sp] in 238 | perm_eq [seq (Jordan_form A) i i | i <- enum 'I_(size_sum sizes).+1] 239 | (root_seq (char_poly A)). 240 | Proof. 241 | have Hinj: injective (fun (c : R) => 'X - c%:P). 242 | by move=> x y /= H; apply/polyC_inj/oppr_inj/(addrI 'X). 243 | apply: (perm_map_inj Hinj). 244 | apply: (@unicity_decomposition _ _ _ (char_poly A)). 245 | + move=> r /(nthP 0) []i; rewrite !size_map=> Hi. 246 | rewrite (nth_map 0) ?size_map // => <-. 247 | exact: irredp_XsubC. 248 | - move=> r /(nthP 0) []i; rewrite !size_map=> Hi. 249 | rewrite (nth_map 0) ?size_map // => <-. 250 | exact: irredp_XsubC. 251 | + move=> r /(nthP 0) []i; rewrite !size_map=> Hi. 252 | rewrite (nth_map 0) ?size_map // => <-. 253 | exact: monicXsubC. 254 | - move=> r /(nthP 0) []i; rewrite !size_map=> Hi. 255 | rewrite (nth_map 0) ?size_map // => <-. 256 | exact: monicXsubC. 257 | + by rewrite !big_map; exact: Jordan_char_poly. 258 | rewrite big_map {1}[char_poly A]root_seq_eq. 259 | by rewrite (monicP (char_poly_monic A)) scale1r. 260 | Qed. 261 | 262 | Lemma diagonalization n (A : 'M[R]_n.+1) : uniq (root_seq (mxminpoly A)) -> 263 | similar A (diag_mx_seq n.+1 n.+1 (root_seq (char_poly A))). 264 | Proof. 265 | move=> H. 266 | have [Heq _]:= Jordan A. 267 | pose s := [seq (x.2).-1 | x <- root_seq_poly (invariant_factors A)]. 268 | have Hs: size ([seq (Jordan_form A) i i | i <- enum 'I_(size_sum s).+1]) = n.+1. 269 | by rewrite size_map size_enum_ord. 270 | have Hn i: nth 0%N s i = 0%N. 271 | case: (ltnP i (size (root_seq_poly (invariant_factors A))))=> Hi. 272 | rewrite (nth_map (0,0%N)) //. 273 | have/flattenP [s2 Hd Hs2] := (mem_nth (0,0%N) Hi); move: Hd. 274 | case/(nthP nil)=> m; rewrite !size_map=> Hm Heq2. 275 | move: Heq2 Hs2; rewrite (nth_map 0) // => <-. 276 | move=> Hr; rewrite (uniq_root_mu_seq _ Hr) //. 277 | apply: (uniq_root_dvdp _ H). 278 | by rewrite monic_neq0 // mxminpoly_monic. 279 | rewrite -mxminpoly_inv_factors Frobenius_seqE last_cat -nth_last. 280 | have Hif: (0 < (size (invariant_factors A)))%N. 281 | by rewrite lt0n size_eq0 nnil_inv_factors. 282 | rewrite (set_nth_default 0) ?prednK //. 283 | apply: sorted_leq_nth=> //. 284 | -exact: dvdp_trans. 285 | -exact: sorted_invf. 286 | -by rewrite inE prednK. 287 | by rewrite -ltnS prednK. 288 | by rewrite nth_default // size_map. 289 | apply: (similar_trans (Jordan A)). 290 | apply: (similar_trans _ (similar_diag_mx_seq (erefl n.+1) Hs (eigen_diag A))). 291 | rewrite /Jordan_form diag_block_mx_seq //. 292 | rewrite size_map size_enum_ord in Hs. 293 | rewrite Hs. 294 | set s1 := mkseq _ _. 295 | set s2 := map _ _. 296 | have ->: s2 = s1. 297 | apply: (@eq_from_nth _ 0). 298 | rewrite size_map size_enum_ord Heq size_mkseq. 299 | rewrite size_sum_big. 300 | rewrite (eq_big_seq (fun _ => 1%N)). 301 | by rewrite (big_nth 0%N) sum_nat_const_nat subn0 muln1. 302 | by move=> x /(nthP 0%N) [i Hi]; rewrite Hn=> <-. 303 | rewrite -size_eq0 size_map size_flatten sumn_big !big_map. 304 | have H0: (0 < (size (invariant_factors A)))%N. 305 | by rewrite lt0n size_eq0 nnil_inv_factors. 306 | rewrite (big_nth 0) big_mkord (bigD1 (Ordinal H0)) //. 307 | rewrite size_map -lt0n addn_gt0 lt0n size_eq0. 308 | apply/orP; left; apply/eqP=>/undup_nil; apply/eqP. 309 | rewrite -root_seq_nil -ltnNge. 310 | have:= (mem_nth 0 H0). 311 | by rewrite mem_filter; case/andP=> ->. 312 | move=> i; rewrite size_map size_enum_ord=> Hi. 313 | rewrite (nth_map 0) ?size_enum_ord //. 314 | by rewrite (nth_ord_enum 0 (Ordinal Hi)) !mxE eqxx. 315 | exact: similar_refl. 316 | Qed. 317 | 318 | Lemma ex_diagonalization n (A : 'M[R]_n.+1) : uniq (root_seq (mxminpoly A)) -> 319 | {s | similar A (diag_mx_seq n.+1 n.+1 s)}. 320 | Proof. 321 | move=> H; exists (root_seq (char_poly A)). 322 | exact: diagonalization. 323 | Qed. 324 | 325 | End jordan. 326 | -------------------------------------------------------------------------------- /theory/karatsuba.v: -------------------------------------------------------------------------------- 1 | (** This file is part of CoqEAL, the Coq Effective Algebra Library. 2 | (c) Copyright INRIA and University of Gothenburg, see LICENSE *) 3 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq. 4 | From mathcomp Require Import zmodp path choice fintype tuple finset ssralg. 5 | From mathcomp Require Import bigop poly polydiv. 6 | 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Unset Printing Implicit Defensive. 10 | 11 | Local Open Scope ring_scope. 12 | 13 | Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic. 14 | 15 | Section karatsuba. 16 | 17 | Variable R : ringType. 18 | Definition split_poly n (p : {poly R}) := (rdivp p 'X^n, rmodp p 'X^n). 19 | Definition shift_poly n : {poly R} -> {poly R} := *%R^~ 'X^n. 20 | Definition normalize (p : {poly R}) := p. 21 | 22 | Fixpoint karatsuba_rec (n : nat) (p q : {poly R}) := 23 | if n is n'.+1 then 24 | let np := normalize p in let nq := normalize q in 25 | let sp := size p in let sq := size q in 26 | if (sp <= 2) || (sq <= 2) then p * q else 27 | let m := minn sp./2 sq./2 in 28 | let (p1,p2) := split_poly m p in 29 | let (q1,q2) := split_poly m q in 30 | let p1q1 := karatsuba_rec n' p1 q1 in 31 | let p2q2 := karatsuba_rec n' p2 q2 in 32 | let p12 := p1 + p2 in 33 | let q12 := q1 + q2 in 34 | let p12q12 := karatsuba_rec n' p12 q12 in 35 | shift_poly (2 * m)%N p1q1 + 36 | shift_poly m (p12q12 - p1q1 - p2q2) + 37 | p2q2 38 | else p * q. 39 | 40 | Definition karatsuba (p q : {poly R}) := 41 | karatsuba_rec (maxn (size p) (size q)) p q. 42 | 43 | Lemma karatsuba_recE n (p q : {poly R}) : karatsuba_rec n p q = p * q. 44 | Proof. 45 | elim: n=> //= n ih in p q *; case: ifP=> // _; set m := minn _ _. 46 | rewrite [p in RHS](rdivp_eq (monicXn _ m)) [q in RHS](rdivp_eq (monicXn _ m)). 47 | set dp := rdivp p _; set dq := rdivp q _; set rp := rmodp p _; set rq := rmodp q _. 48 | rewrite /shift_poly /split_poly !ih !(mulrDr, mulrDl, mulNr) mulnC exprM. 49 | rewrite -[_ - _ - _]addrA [_ + _ + (- _ - _)]addrACA [_ + _ - _]addrAC. 50 | by rewrite subrr add0r addrK !(commr_polyXn, mulrA, addrA). 51 | Qed. 52 | 53 | Lemma karatsubaE (p q : {poly R}) : karatsuba p q = p * q. 54 | Proof. exact: karatsuba_recE. Qed. 55 | 56 | End karatsuba. 57 | -------------------------------------------------------------------------------- /theory/minor.v: -------------------------------------------------------------------------------- 1 | (** This file is part of CoqEAL, the Coq Effective Algebra Library. 2 | (c) Copyright INRIA and University of Gothenburg, see LICENSE *) 3 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path ssralg. 4 | From mathcomp Require Import fintype perm choice finfun matrix bigop zmodp poly mxpoly. 5 | 6 | Import GRing.Theory. 7 | 8 | Set Implicit Arguments. 9 | Unset Strict Implicit. 10 | Unset Printing Implicit Defensive. 11 | 12 | Open Scope ring_scope. 13 | 14 | Section submatrix_def. 15 | 16 | Variable A B : Type. 17 | 18 | Definition submatrix T m n p q (f : 'I_p -> 'I_m) (g : 'I_q -> 'I_n) 19 | (M : 'M[T]_(m,n)) := \matrix_(i < p, j < q) M (f i) (g j). 20 | 21 | Lemma sub_submatrix k k' l l' m n (M : 'M[A]_(m,n)) (f' : 'I_k -> 'I_m) 22 | (f : 'I_k' -> 'I_k) (g' : 'I_l -> 'I_n) (g : 'I_l' -> 'I_l) : 23 | submatrix f g (submatrix f' g' M) = submatrix (f' \o f) (g' \o g) M. 24 | Proof. by rewrite /submatrix; apply/matrixP=> i j; rewrite !mxE. Qed. 25 | 26 | Lemma submatrix_map_mx (f : A -> B) m n p k (M : 'M[A]_(m,n)) 27 | (g : 'I_p -> 'I_m) (h : 'I_k -> 'I_n) : 28 | submatrix g h (map_mx f M) = map_mx f (submatrix g h M). 29 | Proof. by rewrite /submatrix; apply/matrixP=> i j; rewrite !mxE. Qed. 30 | 31 | End submatrix_def. 32 | 33 | Section lifting. 34 | 35 | Lemma widen_ord_eq (m n : nat) (h h' : n <= m) : widen_ord h =1 widen_ord h'. 36 | Proof. by move=> x; apply/ord_inj. Qed. 37 | 38 | (* transform [a .. b] into [0, a+1, .., b+1] *) 39 | Definition lift_pred m n (f : 'I_n -> 'I_m) : 'I_n.+1 -> 'I_m.+1 := 40 | fun (x : 'I_(1 + n)) => 41 | if split x is inr j then lift 0 (f j) else 0. 42 | 43 | Lemma size_tool n k : k <= n -> k < n.+1. 44 | Proof. by rewrite ltnS. Qed. 45 | 46 | (* lift step [ 0.. n-1] = [0 .. n ] *) 47 | Lemma lift_pred_widen_ord m n (h : n <= m) : 48 | lift_pred (widen_ord h) =1 widen_ord (size_tool h). 49 | Proof. 50 | rewrite /lift_pred => x; have [y hx|y hx] := splitP; apply/ord_inj => //=. 51 | by rewrite hx [y]ord1. 52 | Qed. 53 | 54 | Lemma lift_pred0 n k (f: 'I_k -> 'I_n) : lift_pred f 0 = 0. 55 | Proof. by rewrite /lift_pred; case: splitP. Qed. 56 | 57 | Lemma lift_predS n k (f : 'I_k -> 'I_n) (x : 'I_k) : 58 | lift_pred f (lift 0 x) = lift 0 (f x). 59 | Proof. by rewrite /lift_pred split1 liftK. Qed. 60 | 61 | (* Lemma step0 n (h : 1 <= n.+1) (x : 'I_1) : widen_ord h x = 0. *) 62 | (* Proof. by rewrite [x]ord1; apply/ord_inj. Qed. *) 63 | 64 | (* Lemma stepn n (h : n <= n) (x : 'I_n) : widen_ord h x = x. *) 65 | (* Proof. by apply/ord_inj. Qed. *) 66 | 67 | Lemma inj_lift m n (f : 'I_n -> 'I_m) : injective f -> injective (lift_pred f). 68 | Proof. 69 | rewrite /lift_pred => hf x y; rewrite !split1. 70 | have [/= j ->|->] := unliftP; last by have [|-> //] := unliftP. 71 | by have [/= i -> /lift_inj/hf ->|] := unliftP. 72 | Qed. 73 | 74 | Lemma inj_widen_ord n m (h : n <= m) : injective (widen_ord h). 75 | Proof. 76 | move => x y hxy. 77 | have /= {}hxy : widen_ord h x = widen_ord h y :> nat by rewrite hxy. 78 | by apply/ord_inj. 79 | Qed. 80 | 81 | End lifting. 82 | 83 | Section submatrix_theory. 84 | 85 | Variable R : ringType. 86 | 87 | Lemma submatrix_eq m n p q (f1 g1 : 'I_p -> 'I_m) (f2 g2 : 'I_q -> 'I_n) 88 | (M : 'M[R]_(m,n)) (h1 : f1 =1 g1) (h2 : f2 =1 g2) : 89 | submatrix f1 f2 M = submatrix g1 g2 M. 90 | Proof. by apply/matrixP => i j; rewrite !mxE (h1 i) (h2 j). Qed. 91 | 92 | Lemma submatrix_lift_block m n p q (f1 : 'I_p -> 'I_m) (f2 : 'I_q -> 'I_n) 93 | a (M: 'M[R]_(m,n)) (c : 'cV[R]_m) (l : 'rV[R]_n) : 94 | submatrix (lift_pred f1) (lift_pred f2) (block_mx a%:M l c M) = 95 | block_mx a%:M (submatrix id f2 l) (submatrix f1 id c) (submatrix f1 f2 M). 96 | Proof. 97 | apply/matrixP => i j; rewrite !mxE /lift_pred !split1. 98 | case: (oapp _ _ (unlift 0 i)) => x. 99 | rewrite unlift_none /= [x]ord1 !mxE !split1. 100 | case: (oapp _ _ (unlift 0 j)) => y; first by rewrite unlift_none [y]ord1. 101 | by rewrite liftK mxE. 102 | rewrite liftK /= !mxE !split1. 103 | case: (oapp _ _ (unlift 0 j)) => y; first by rewrite unlift_none mxE [y]ord1. 104 | by rewrite liftK mxE. 105 | Qed. 106 | 107 | Lemma submatrix0 n m p q (f1 : 'I_p -> 'I_m) (f2 : 'I_q -> 'I_n) : 108 | submatrix f1 f2 0 = 0 :> 'M[R]__. 109 | Proof. by apply/matrixP => i j; rewrite !mxE. Qed. 110 | 111 | Lemma submatrix_scale m n p k (A : 'M[R]_(m,n)) 112 | (f : 'I_p -> 'I_m) (g : 'I_k -> 'I_n) a : 113 | submatrix f g (a *: A) = a *: submatrix f g A. 114 | Proof. by apply/matrixP => i j; rewrite !mxE. Qed. 115 | 116 | Lemma submatrix_add m n p k (A B : 'M[R]_(m,n)) 117 | (f : 'I_p -> 'I_m) (g : 'I_k -> 'I_n) : 118 | submatrix f g (A + B) = submatrix f g A + submatrix f g B. 119 | Proof. by apply/matrixP => i j; rewrite !mxE. Qed. 120 | 121 | Lemma submatrix_opp m n p k (A : 'M[R]_(m,n)) 122 | (f : 'I_p -> 'I_m) (g : 'I_k -> 'I_n) : 123 | submatrix f g (- A) = - submatrix f g A. 124 | Proof. by apply/matrixP => i j; rewrite !mxE. Qed. 125 | 126 | Lemma submatrix_sub m n p k (A B : 'M[R]_(m,n)) 127 | (f : 'I_p -> 'I_m) (g : 'I_k -> 'I_n) : 128 | submatrix f g (A - B) = submatrix f g A - submatrix f g B. 129 | Proof. by apply/matrixP => i j; rewrite !mxE. Qed. 130 | 131 | Lemma submatrix_mul m n p k l (A : 'M[R]_(m,n)) (B : 'M[R]_(n,p)) 132 | (f : 'I_k -> 'I_m) (g : 'I_l -> 'I_p): 133 | submatrix f g (A *m B) = (submatrix f id A) *m (submatrix id g B). 134 | Proof. 135 | apply/matrixP => i j; rewrite !mxE. 136 | by apply/eq_big => // x _; rewrite !mxE. 137 | Qed. 138 | 139 | Lemma submatrix_scalar_mx m p (f : 'I_p -> 'I_m) (hf : injective f) (a : R) : 140 | submatrix f f a%:M = a%:M. 141 | Proof. 142 | apply/matrixP => i j; rewrite !mxE. 143 | case h : (f i == f j); first by rewrite (hf _ _ (eqP h)) eqxx. 144 | by case h': (i == j) => //; move: h; rewrite (eqP h') eqxx. 145 | Qed. 146 | 147 | End submatrix_theory. 148 | 149 | (* This must be put in a new section as it uses the theory on submatrix *) 150 | Section submatrix_char_poly_mx. 151 | 152 | Variable R : ringType. 153 | 154 | Lemma submatrix_char_poly_mx m p (M : 'M[R]_m) 155 | (f : 'I_p -> 'I_m) (hf : injective f) : 156 | submatrix f f (char_poly_mx M) = char_poly_mx (submatrix f f M). 157 | Proof. 158 | by rewrite /char_poly_mx -submatrix_map_mx submatrix_sub submatrix_scalar_mx. 159 | Qed. 160 | 161 | End submatrix_char_poly_mx. 162 | 163 | (* Minors *) 164 | Section minor_def. 165 | 166 | Variable R : ringType. 167 | 168 | Definition minor (m n p : nat) (f : 'I_p -> 'I_m) (g : 'I_p -> 'I_n) 169 | (A : 'M[R]_(m,n)) := \det (submatrix f g A). 170 | 171 | (* Principal minor *) 172 | Definition pminor (m n p : nat) (h : p < m) (h' : p < n) (A : 'M[R]_(m,n)) := 173 | minor (widen_ord h) (widen_ord h') A. 174 | 175 | End minor_def. 176 | 177 | Arguments minor {R m n p} f g A. 178 | 179 | Section minor_theory. 180 | 181 | Variable R : comRingType. 182 | 183 | Lemma minor1 m n (A : 'M[R]_(m,n)) i j : 184 | minor (fun (_ : 'I_1) => i) (fun _ => j) A = A i j. 185 | Proof. by rewrite /minor [submatrix _ _ _]mx11_scalar det_scalar1 !mxE. Qed. 186 | 187 | Lemma minorn n (A : 'M[R]_n) : minor id id A = \det A. 188 | Proof. 189 | by rewrite /minor /submatrix; congr (\det _); apply/matrixP=> i j; rewrite mxE. 190 | Qed. 191 | 192 | Lemma det2 (A : 'M[R]_(2,2)) : \det A = A 0 0 * A 1 1 - A 1 0 * A 0 1. 193 | Proof. 194 | rewrite (expand_det_col _ 0) !big_ord_recl big_ord0 addr0 /cofactor /=. 195 | rewrite ?(addn0,expr0,mul1r) /bump leq0n /= addn0 expr1. 196 | do 2! rewrite [X in \det X]mx11_scalar det_scalar1 /=. 197 | by rewrite !mxE !mulNr mul1r mulrN; do ?f_equal; apply/ord_inj. 198 | Qed. 199 | 200 | (* Sanity check of the definiton *) 201 | Lemma minor2 m n (A : 'M[R]_(m,n)) (f : 'I_2 -> 'I_m) (g : 'I_2 -> 'I_n) : 202 | minor f g A = A (f 0) (g 0) * A (f 1) (g 1) - A (f 1) (g 0) * A (f 0) (g 1). 203 | Proof. by rewrite /minor det2 !mxE. Qed. 204 | 205 | Lemma minor_ltn_eq0l k m1 m2 n1 n2 x (f : 'I_k -> 'I_(m1 + m2)) g 206 | (M : 'M[R]_(m1,n1)) (N : 'M_(m1,n2)) (H : m1 < f x) : 207 | minor f g (block_mx M N 0 0) = 0. 208 | Proof. 209 | rewrite /minor (expand_det_row _ x) big1 // => i _; rewrite !mxE. 210 | case: splitP H => [j ->|j Hj]; first by rewrite ltnNge ltnW. 211 | by rewrite row_mx0 mxE mul0r. 212 | Qed. 213 | 214 | Lemma minor_ltn_eq0r k m1 m2 n1 n2 x f (g : 'I_k -> 'I_(n1 + n2)) 215 | (M : 'M[R]_(m1,n1)) (N : 'M_(m2,n1)) (H : n1 < g x) : 216 | minor f g (block_mx M 0 N 0) = 0. 217 | Proof. 218 | rewrite /minor (expand_det_col _ x) big1 // => i _; rewrite !mxE. 219 | by case: splitP=> j Hj; rewrite mxE; case: splitP H=> [l ->|l]; 220 | rewrite ?ltnNge ?mxE ?mul0r // ltnW. 221 | Qed. 222 | 223 | Lemma minor_alternate_f m n p (f : 'I_p -> 'I_m) g (M : 'M[R]_(m,n)) : 224 | (exists x y, (x != y) /\ (f x == f y)) -> minor f g M = 0. 225 | Proof. 226 | rewrite /minor => [[x [y [hxy /eqP hf]]]]. 227 | by rewrite (determinant_alternate hxy) // => a; rewrite !mxE hf. 228 | Qed. 229 | 230 | Lemma minor_alternate_g m n p (f : 'I_p -> 'I_m) g (M : 'M[R]_(m,n)) : 231 | (exists x y, (x != y) /\ (g x == g y)) -> minor f g M = 0. 232 | Proof. 233 | rewrite /minor => [[x [y [hxy /eqP hg]]]]. 234 | by rewrite -det_tr (determinant_alternate hxy) // => a /=; rewrite !mxE hg. 235 | Qed. 236 | 237 | Lemma minor_f_not_injective m n p (f : 'I_p -> 'I_m) g (M: 'M[R]_(m,n)) : 238 | ~ injective f -> minor f g M = 0. 239 | Proof. 240 | move/injectiveP/injectivePn => [x [y hxy hf]]; apply minor_alternate_f. 241 | by exists x, y; rewrite hf. 242 | Qed. 243 | 244 | Lemma minor_g_not_injective m n p (f : 'I_p -> 'I_m) g (M: 'M[R]_(m,n)) : 245 | ~ injective g -> minor f g M = 0. 246 | Proof. 247 | move/injectiveP/injectivePn => [x [y hxy hg]]; apply minor_alternate_g. 248 | by exists x, y; rewrite hg. 249 | Qed. 250 | 251 | Lemma minor_eq m n p (f1 g1 : 'I_p -> 'I_m) (f2 g2 : 'I_p -> 'I_n) 252 | (h1 : f1 =1 g1) (h2 : f2 =1 g2) (M : 'M[R]_(m,n)) : 253 | minor f1 f2 M = minor g1 g2 M. 254 | Proof. by rewrite /minor (submatrix_eq M h1 h2). Qed. 255 | 256 | Lemma minor_lift_block m n p (f1 : 'I_p -> 'I_m) (f2 : 'I_p -> 'I_n) 257 | a (M : 'M[R]_(m,n)) (l : 'rV[R]_n) : 258 | minor (lift_pred f1) (lift_pred f2) (block_mx a%:M l 0 M) = a * minor f1 f2 M. 259 | Proof. 260 | by rewrite /minor submatrix_lift_block submatrix0 (@det_ublock _ 1) det_scalar1. 261 | Qed. 262 | 263 | End minor_theory. 264 | 265 | Section minor_char_poly_mx. 266 | 267 | Variable R : comRingType. 268 | 269 | (* all principal minor of the characteristic matrix are monic *) 270 | Lemma pminor_char_poly_mx_monic m p (M : 'M[R]_m) (h h': p.+1 <= m) : 271 | pminor h h' (char_poly_mx M) \is monic. 272 | Proof. 273 | have h'h : widen_ord h' =1 widen_ord h by apply/widen_ord_eq. 274 | rewrite /pminor (minor_eq (frefl _) h'h) /minor submatrix_char_poly_mx. 275 | by rewrite char_poly_monic. 276 | exact: inj_widen_ord. 277 | Qed. 278 | 279 | End minor_char_poly_mx. 280 | -------------------------------------------------------------------------------- /theory/perm_eq_image.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect all_algebra. 2 | Set Implicit Arguments. 3 | Unset Strict Implicit. 4 | Unset Printing Implicit Defensive. 5 | 6 | Section seq_eqType. 7 | 8 | Variable T1 : eqType. 9 | 10 | Lemma sorted_trans (leT1 leT2 : rel T1) s : 11 | {in s &, (forall x y, leT1 x y -> leT2 x y)} -> 12 | sorted leT1 s -> sorted leT2 s. 13 | Proof. 14 | elim: s=> // a [] //= b l IHl leT12 /andP [leT1ab pleT1]. 15 | rewrite leT12 ?inE ?eqxx ?orbT // IHl // => x y xbcl ybcl leT1xy. 16 | by rewrite leT12 // mem_behead. 17 | Qed. 18 | 19 | 20 | End seq_eqType. 21 | 22 | Section FinType. 23 | 24 | Lemma enum_ord_enum n : enum 'I_n = ord_enum n. 25 | Proof. by rewrite enumT unlock. Qed. 26 | 27 | End FinType. 28 | 29 | 30 | Section Finfun. 31 | 32 | Variables (aT : finType) (rT : eqType). 33 | Variables (f g : aT -> rT). 34 | Variable (P : pred aT). 35 | Hypothesis (Hf : injective f) (Hg : injective g). 36 | 37 | Lemma uniq_image (h : aT -> rT): 38 | injective h -> uniq (image h P). 39 | Proof. by move/map_inj_uniq=> ->; rewrite enum_uniq. Qed. 40 | 41 | Lemma perm_eq_image : {subset (image f P) <= (image g P)} -> 42 | perm_eq (image f P) (image g P). 43 | Proof. 44 | move=> imfsubimg. 45 | rewrite uniq_perm // ?uniq_image //. 46 | have []:= (uniq_min_size (uniq_image Hf) imfsubimg)=> //. 47 | by rewrite !size_map. 48 | Qed. 49 | 50 | End Finfun. 51 | 52 | Section BigOp. 53 | 54 | Variables (T : Type) (idx : T) (op : Monoid.com_law idx). 55 | 56 | Lemma sumn_big s : sumn s = (\sum_(i <- s) i)%N. 57 | Proof. 58 | elim: s=> /= [|a l ->]; first by rewrite big_nil. 59 | by rewrite big_cons. 60 | Qed. 61 | (***Not in bigop.v and I not found a short way to prove this. ****) 62 | Lemma big_lift_ord n F j : 63 | \big[op/idx]_( i < n.+1 | j != i ) F i = \big[op/idx]_i F (lift j i). 64 | Proof. 65 | case: (pickP 'I_n) => [k0 _ | n0]; last first. 66 | by rewrite !big1 // => [i _ | k /unlift_some[i]]; have:= n0 i. 67 | rewrite (reindex (lift j)). 68 | by apply: eq_bigl=> k; rewrite neq_lift. 69 | exists (fun k => odflt k0 (unlift j k)) => k; first by rewrite liftK. 70 | by case/unlift_some=> k' -> ->. 71 | Qed. 72 | 73 | Variable R : idomainType. 74 | Open Scope ring_scope. 75 | 76 | Lemma lead_coef_prod (s : seq {poly R}) : 77 | \prod_(p <- s) lead_coef p = lead_coef (\prod_(p <- s) p). 78 | Proof. 79 | elim: s=> [|a l IHl]; first by rewrite !big_nil lead_coef1. 80 | by rewrite !big_cons lead_coefM -IHl. 81 | Qed. 82 | 83 | Import GRing.Theory. 84 | 85 | Lemma monic_leadVMp (p : {poly R}) : (lead_coef p) \is a GRing.unit -> 86 | ((lead_coef p)^-1 *: p) \is monic. 87 | Proof. by move=> *; apply/monicP; rewrite lead_coefZ mulVr. Qed. 88 | 89 | End BigOp. 90 | 91 | Section Matrix. 92 | Import GRing.Theory. 93 | Local Open Scope ring_scope. 94 | 95 | 96 | Section matrix_Type. 97 | 98 | Variable T : Type. 99 | (**** This lemma is useful to rewrite in a big expression, and it is unsightly 100 | to do a "have" in a proof for proving that. *********) 101 | Lemma matrix_comp k l m n (E : 'I_k -> 'I_l -> T) (F : 'I_n -> 'I_k) G : 102 | \matrix_(i < n, j < m) ((\matrix_(i0 < k, j0 < l) E i0 j0) (F i) (G j)) = 103 | \matrix_(i, j) (E (F i) (G j)). 104 | Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. 105 | 106 | End matrix_Type. 107 | 108 | Section matrix_fieldType. 109 | 110 | Variable F : fieldType. 111 | 112 | (* mx_poly *) 113 | Lemma horner_mx_dvdp n (p q : {poly F}) (A : 'M_n.+1) : 114 | (dvdp p q) -> horner_mx A p = 0 -> horner_mx A q = 0. 115 | Proof. by case/dvdpP=> r ->; rewrite rmorphM=> /= ->; rewrite mulr0. Qed. 116 | 117 | Lemma mxminpolyP n (A : 'M[F]_n.+1) (p : {poly F}) : 118 | p \is monic -> horner_mx A p = 0 -> 119 | (forall q, horner_mx A q = 0 -> (dvdp p q)) -> 120 | p = mxminpoly A. 121 | Proof. 122 | move=> pmon eqpA0 pdvq. 123 | apply/eqP; rewrite -eqp_monic //; last exact: mxminpoly_monic. 124 | apply/andP; split. 125 | by apply/pdvq/mx_root_minpoly. 126 | exact: mxminpoly_min. 127 | Qed. 128 | 129 | End matrix_fieldType. 130 | 131 | Section matrix_ringType. 132 | Variable R : ringType. 133 | 134 | 135 | Lemma char_block_mx m n (A : 'M[R]_m) (D : 'M[R]_n) B C : 136 | char_poly_mx (block_mx A B C D) = 137 | block_mx (char_poly_mx A) (map_mx polyC (-B)) 138 | (map_mx polyC (-C)) (char_poly_mx D). 139 | Proof. 140 | apply/matrixP=> i j; rewrite !mxE. 141 | case: splitP=> k eqik; rewrite !mxE; case: splitP=> l eqjmpl; rewrite !mxE; 142 | rewrite -!(inj_eq (@ord_inj _)) eqik eqjmpl ?eqn_add2l // rmorphN. 143 | by rewrite ltn_eqF ?ltn_addr // sub0r. 144 | by rewrite gtn_eqF ?ltn_addr // sub0r. 145 | Qed. 146 | 147 | Lemma char_dblock_mx m n (A : 'M[R]_m) (B : 'M[R]_n) : 148 | char_poly_mx (block_mx A 0 0 B) = 149 | block_mx (char_poly_mx A) 0 0 (char_poly_mx B). 150 | Proof. by rewrite char_block_mx !oppr0 !map_mx0. Qed. 151 | 152 | End matrix_ringType. 153 | 154 | End Matrix. 155 | 156 | Section poly_idomainType. 157 | 158 | Variable R : idomainType. 159 | Import GRing.Theory. 160 | Local Open Scope ring_scope. 161 | 162 | Lemma coprimep_irreducible (p q : {poly R}) : ~~(p %= q) -> 163 | irreducible_poly p -> irreducible_poly q -> coprimep p q. 164 | Proof. 165 | move=> neqdpq [szpgt1 Heqdp] [szqgt1 Heqdq]. 166 | have gcdvp:= (dvdp_gcdl p q). 167 | have gcdvq:= (dvdp_gcdr p q). 168 | rewrite /coprimep; apply: contraT => neqsz1. 169 | move: (Heqdp _ neqsz1 gcdvp); rewrite eqp_sym /eqp dvdp_gcd. 170 | case/andP=> [/andP [ _ pdvq]] _. 171 | move: (Heqdq _ neqsz1 gcdvq); rewrite eqp_sym /eqp dvdp_gcd. 172 | case/andP=> [/andP [qdvp _]] _. 173 | by rewrite /eqp pdvq qdvp in neqdpq. 174 | Qed. 175 | 176 | Lemma irreducible_dvdp_seq (p r : {poly R}) s : 177 | irreducible_poly p -> p \is monic -> (dvdp p r) -> 178 | (forall q, q \in s -> irreducible_poly q) -> 179 | (forall q, q \in s -> q \is monic) -> 180 | r = \prod_(t <- s) t -> 181 | p \in s. 182 | Proof. 183 | move=> pIrr pm. 184 | elim: s r => [r pdvr _ _|a l IHl r pdvr Irr mon]. 185 | rewrite big_nil=> eqr1; move: pdvr pIrr. 186 | rewrite eqr1 dvdp1 /irreducible_poly=> /eqP ->. 187 | by rewrite ltnn; case. 188 | rewrite big_cons=> eqrM; move: pdvr; rewrite eqrM=> pdvM. 189 | case/boolP: (eqp p a)=>[|neqdpa]. 190 | have am: a \is monic by apply: mon; rewrite mem_head. 191 | by rewrite eqp_monic // => /eqP ->; rewrite mem_head. 192 | have Hia: irreducible_poly a by apply: Irr; rewrite mem_head. 193 | have cppa := coprimep_irreducible neqdpa pIrr Hia. 194 | rewrite (Gauss_dvdpr _ cppa) in pdvM. 195 | apply/mem_behead/(IHl _ pdvM)=> // q qinl. 196 | by apply: Irr; rewrite mem_behead. 197 | by rewrite mon // mem_behead. 198 | Qed. 199 | 200 | Lemma unicity_decomposition (s1 s2 : seq {poly R}) : forall (p : {poly R}), 201 | (forall r, r \in s1 -> irreducible_poly r) -> 202 | (forall r, r \in s2 -> irreducible_poly r) -> 203 | (forall r, r \in s1 -> r \is monic) -> 204 | (forall r, r \in s2 -> r \is monic) -> 205 | p = \prod_(r <- s1) r -> p = \prod_(r <- s2) r -> 206 | perm_eq s1 s2. 207 | Proof. 208 | elim: s1 s2=> [|a1 l1 IHl s2 p Irr1 Irr2 mon1 mon2]. 209 | case=> // a l p _ Irr2 _ mon2->. 210 | rewrite big_nil big_cons=> eq1M. 211 | have: irreducible_poly a by apply: Irr2; rewrite mem_head. 212 | rewrite /irreducible_poly; case. 213 | by rewrite ltnNge leq_eqVlt -dvdp1 eq1M dvdp_mulr. 214 | rewrite big_cons=> eqpM eqpbig /=. 215 | have a1ins2: a1 \in s2. 216 | apply: (irreducible_dvdp_seq _ _ _ Irr2 mon2 eqpbig). 217 | +by apply: Irr1; rewrite mem_head. 218 | -by rewrite mon1 // mem_head. 219 | by rewrite eqpM dvdp_mulr. 220 | rewrite perm_sym (perm_trans (perm_to_rem a1ins2)) //. 221 | rewrite perm_cons perm_sym. 222 | have nza1: a1 != 0. 223 | by apply: irredp_neq0; apply: Irr1; rewrite mem_head. 224 | rewrite (perm_big _ (perm_to_rem a1ins2)) /= big_cons eqpM in eqpbig. 225 | have/(mulfI nza1) eqbig := eqpbig. 226 | set q:= \prod_(j <- l1) j. 227 | apply: (IHl _ q)=> // r Hr. 228 | +by apply: Irr1; rewrite mem_behead. 229 | -by apply: Irr2; rewrite (mem_rem Hr). 230 | +by rewrite mon1 // mem_behead. 231 | -by rewrite mon2 // (mem_rem Hr). 232 | Qed. 233 | 234 | End poly_idomainType. 235 | -------------------------------------------------------------------------------- /theory/rank.v: -------------------------------------------------------------------------------- 1 | (** This file is part of CoqEAL, the Coq Effective Algebra Library. 2 | (c) Copyright INRIA and University of Gothenburg, see LICENSE *) 3 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq. 4 | From mathcomp Require Import ssralg fintype fingroup perm. 5 | From mathcomp Require Import matrix bigop zmodp mxalgebra. 6 | 7 | Require Import gauss. 8 | Import GRing.Theory. 9 | 10 | Set Implicit Arguments. 11 | Unset Strict Implicit. 12 | Unset Printing Implicit Defensive. 13 | 14 | Section FieldRank. 15 | 16 | Variable F : fieldType. 17 | Local Open Scope ring_scope. 18 | 19 | Fixpoint rank_elim {m n : nat} : 'M[F]_(m, n) -> nat := 20 | if n is p.+1 then 21 | fun (M : 'M_(m, 1 + p)) => 22 | if find_pivot M is Some k then 23 | let a := fun_of_matrix M k 0 in 24 | let u := rsubmx (row k M) in 25 | let R := row' k M in 26 | let v := a^-1 *: lsubmx R in 27 | let R := rsubmx R - v *m u in 28 | (1 + rank_elim R)%N 29 | else rank_elim (rsubmx M) 30 | else fun => 0%N. 31 | 32 | Lemma rank_row0mx (m n p : nat) (M : 'M[F]_(m,n)) : 33 | \rank (row_mx (0: 'M[F]_(m,p)) M) = \rank M. 34 | Proof. by rewrite -mxrank_tr tr_row_mx trmx0 -addsmxE adds0mx mxrank_tr. Qed. 35 | 36 | Lemma rank_block0dl m n a Aur (Adr : 'M[F]_(m,n)) : 37 | a != 0 -> \rank (block_mx (a%:M : 'M_1) Aur 0 Adr) = (1 + \rank Adr)%N. 38 | Proof. 39 | move=> nz_a. 40 | rewrite /block_mx -addsmxE mxrank_disjoint_sum. 41 | rewrite rank_row0mx rank_rV. 42 | have->//: row_mx a%:M Aur != 0. 43 | apply/eqP => /matrixP/(_ 0 0); rewrite !mxE. 44 | by case: splitP => // j _; rewrite ord1 !mxE; move/eqP: nz_a. 45 | apply/eqP/rowV0P => v0; rewrite sub_capmx; case/andP=> /sub_rVP [k Hv0k]. 46 | rewrite Hv0k; case/submxP => D /matrixP/(_ 0 0); rewrite !mxE. 47 | case: splitP => // j _; rewrite ord1 mxE mulr1n big1. 48 | by move/eqP; rewrite mulf_eq0 (negbTE nz_a) orbF => /eqP ->; rewrite scale0r. 49 | by move=> i _; rewrite !mxE; case: splitP=> // l _; rewrite mxE mulr0. 50 | Qed. 51 | 52 | Lemma row'_row_perm m n M k : 53 | row' k M = dsubmx (row_perm (lift_perm 0 k 1%g) M : 'M[F]_(1 + m, n)). 54 | Proof. 55 | by apply/matrixP=> i j; rewrite !mxE rshift1 lift_perm_lift perm1. 56 | Qed. 57 | 58 | Lemma row_row_perm m n (M : 'M[F]_(1 + m, n)) k : 59 | row k M = @usubmx _ 1 _ _ (row_perm (lift_perm 0 k 1%g) M). 60 | Proof. 61 | by apply/matrixP=> i j; rewrite !mxE ord1 lshift0 lift_perm_id. 62 | Qed. 63 | 64 | Lemma rank_elimP m n (M : 'M_(m, n)) : rank_elim M = \rank M. 65 | Proof. 66 | elim: n m M => [m M|n IHn m]; first by rewrite thinmx0 mxrank0. 67 | rewrite -[n.+1]/(1 + n)%N => M /=. 68 | rewrite /find_pivot. 69 | have [|nz_Mk0] /= := pickP; last first. 70 | rewrite -{2}[M]hsubmxK. 71 | suff->: lsubmx M = 0 by rewrite rank_row0mx. 72 | apply/matrixP => i j; rewrite !mxE ord1 lshift0. 73 | by have /(_ i)/negbFE/eqP -> := nz_Mk0. 74 | case: m M => [M []|m] //. 75 | rewrite -[m.+1]/(1 + m)%N => M k /= nz_Mk0; rewrite IHn. 76 | pose P : 'M[F]_(1 + m) := perm_mx (lift_perm 0 k 1%g). 77 | have->: \rank M = \rank (P *m M). 78 | by rewrite eqmxMfull // row_full_unit unitmx_perm. 79 | rewrite -row_permE. 80 | set xM : 'M[F]_(1 + m, 1 + n) := row_perm _ _. 81 | pose D : 'M[F]_(1 + m) := block_mx 1%:M 0 (- (M k 0)^-1 *: (dlsubmx xM)) 1%:M. 82 | have hD : row_full D. 83 | by rewrite row_full_unit unitmxE !det_lblock !det1 !mul1r unitr1. 84 | rewrite -(eqmxMfull xM hD) -[xM]submxK mulmx_block !mul1mx !mul0mx !addr0. 85 | rewrite scaleNr mulNmx [ulsubmx xM]mx11_scalar !mxE !lshift0 lift_perm_id. 86 | rewrite mul_mx_scalar scalerA divrr ?unitfE // scale1r addNr rank_block0dl //. 87 | rewrite {3}/xM /drsubmx /dlsubmx -row'_row_perm addrC /ursubmx -row_row_perm. 88 | by rewrite mulNmx. 89 | Qed. 90 | 91 | End FieldRank. 92 | -------------------------------------------------------------------------------- /theory/smith.v: -------------------------------------------------------------------------------- 1 | (** This file is part of CoqEAL, the Coq Effective Algebra Library. 2 | (c) Copyright INRIA and University of Gothenburg, see LICENSE *) 3 | (* Require Import ZArith. *) 4 | From HB Require Import structures. 5 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path. 6 | From mathcomp Require Import ssralg ssrint ssrnum fintype choice. 7 | From mathcomp Require Import matrix mxalgebra bigop zmodp perm. 8 | Require Import dvdring mxstructure stronglydiscrete coherent edr. 9 | 10 | Set Implicit Arguments. 11 | Unset Strict Implicit. 12 | Unset Printing Implicit Defensive. 13 | 14 | Import GRing.Theory. 15 | 16 | Local Open Scope ring_scope. 17 | 18 | Section smith. 19 | 20 | (* Two-steps approach: 21 | 22 | 1) Make the first column look like 23 | ___ 24 | / g \ 25 | | g | 26 | | . | 27 | | . | 28 | | g | 29 | \___/ 30 | 31 | 2) 32 | 33 | For any i j s.t. ~~ g %| M i j, xrow 0 i M, bezout step on the first row 34 | and back to 1) *) 35 | 36 | Variable E : euclidDomainType. 37 | 38 | Variable find1 : forall m n, 'M[E]_(m.+1,n.+1) -> E -> option 'I_m. 39 | Variable find2 : forall m n, 'M[E]_(m.+1,n.+1) -> E -> option ('I_(1+m) * 'I_n). 40 | Variable find_pivot : 41 | forall m n, 'M[E]_(1 + m,1 + n) -> option ('I_(1 + m) * 'I_(1 + n)). 42 | Hypothesis find1P : forall m n (E : 'M[E]_(1 + m,1 + n)) a, 43 | pick_spec [pred i | ~~(a %| E (lift 0 i) 0)] (find1 E a). 44 | Hypothesis find2P : forall m n (E : 'M[E]_(1 + m,1 + n)) a, 45 | pick_spec [pred ij | ~~(a %| E ij.1 (lift 0 ij.2))] (find2 E a). 46 | Hypothesis find_pivotP : forall m n (E : 'M[E]_(1 + m,1 + n)), 47 | pick_spec [pred ij | E ij.1 ij.2 != 0] (find_pivot E). 48 | 49 | Fixpoint improve_pivot_rec k {m n} : 50 | 'M[E]_(1 + m) -> 'M[E]_(1 + m, 1 + n) -> 'M[E]_(1 + n) -> 51 | 'M[E]_(1 + m) * 'M[E]_(1 + m, 1 + n) * 'M[E]_(1 + n) := 52 | if k is p.+1 then fun P M Q => 53 | let a := M 0 0 in 54 | if find1 M a is Some i then 55 | let Mi0 := M (lift 0 i) 0 in 56 | let P := Bezout_step a Mi0 P i in 57 | let M := Bezout_step a Mi0 M i in 58 | improve_pivot_rec p P M Q 59 | else 60 | let u := dlsubmx M in let vM := ursubmx M in let vP := usubmx P in 61 | let u' := map_mx (fun x => 1 - odflt 0 (x %/? a)) u in 62 | let P := col_mx (usubmx P) (u' *m vP + dsubmx P) in 63 | let M := block_mx (a%:M) vM 64 | (const_mx a) (u' *m vM + drsubmx M) in 65 | if find2 M a is Some (i,j) then 66 | let M := xrow 0 i M in let P := xrow 0 i P in 67 | let a := fun_of_matrix M 0 0 in 68 | let M0ij := fun_of_matrix M 0 (lift 0 j) in 69 | let Q := (Bezout_step a M0ij Q^T j)^T in 70 | let M := (Bezout_step a M0ij M^T j)^T in 71 | improve_pivot_rec p P M Q 72 | else (P, M, Q) 73 | else fun P M Q => (P,M,Q). 74 | 75 | Definition improve_pivot k m n (M : 'M[E]_(1 + m, 1 + n)) := 76 | improve_pivot_rec k 1 M 1. 77 | 78 | (* TODO: Why is this so slow?? *) 79 | Fixpoint Smith m n : 'M[E]_(m,n) -> 'M[E]_(m) * seq E * 'M[E]_(n) := 80 | match m, n with 81 | | _.+1, _.+1 => fun M : 'M[E]_(1 + _, 1 + _) => 82 | if find_pivot M is Some (i, j) then 83 | let a := fun_of_matrix M i j in let M := xrow i 0 (xcol j 0 M) in 84 | (* this is where Euclidean norm eases termination argument *) 85 | let: (P,M,Q) := improve_pivot (enorm a) M in 86 | let a := fun_of_matrix M 0 0 in 87 | let u := dlsubmx M in let v := ursubmx M in 88 | let v' := map_mx (fun x => odflt 0 (x %/? a)) v in 89 | let M := ((drsubmx M) - (const_mx 1 *m v)) in 90 | let: (P', d, Q') := Smith (map_mx (fun x => odflt 0 (x %/? a)) M) in 91 | ((lift0_mx P' *m block_mx 1%:M 0 (- const_mx 1) 1%:M *m (xcol i 0 P)), 92 | a :: [seq x * a | x <- d], 93 | (xrow j 0 Q *m block_mx 1 (- v') 0 1%:M *m lift0_mx Q')) 94 | else (1, [::], 1) 95 | | _, _ => fun M => (1%:M, [::], 1%:M) 96 | end. 97 | 98 | Variant improve_pivot_rec_spec m n P M Q : 99 | 'M_(1 + m) * 'M_(1 + m,1 + n) * 'M[E]_(1 + n) -> Type := 100 | ImprovePivotQecSpec P' M' Q' of P^-1 *m M *m Q^-1 = P'^-1 *m M' *m Q'^-1 101 | & (forall i j, M' 0 0 %| M' i j) 102 | & (forall i, M' i 0 = M' 0 0) 103 | & M' 0 0 %| M 0 0 104 | & P' \in unitmx & Q' \in unitmx 105 | : improve_pivot_rec_spec P M Q (P',M',Q'). 106 | 107 | Lemma unitrmxE k (M : 'M[E]_k.+1) : (M \is a GRing.unit) = (M \in unitmx). 108 | Proof. by []. Qed. 109 | 110 | Definition unitmxEE := (unitmx_mul, unitmx_tr, unit_Bezout_mx, unitmx_perm). 111 | 112 | Lemma improve_pivot_recP : 113 | forall k m n (P : 'M_(1 + m)) (M : 'M_(1 + m,1 + n)) Q, 114 | (enorm (M 0%R 0%R) <= k)%N -> M 0 0 != 0 -> 115 | P \in unitmx -> Q \in unitmx -> 116 | improve_pivot_rec_spec P M Q (improve_pivot_rec k P M Q). 117 | Proof. 118 | elim=> [m n L M R0|k IHk m n L M R0 Hk nzM00 unitL unitR /=]. 119 | by rewrite leqn0 => /eqP /enorm_eq0 ->; rewrite eqxx. 120 | case: find1P=> [i Hi|Hi]. 121 | have [||||L' A' R' HA' ? ? Hdiv HL' HR'] // := IHk; do ?constructor => //. 122 | + by rewrite -ltnS (leq_trans (ltn_enorm nzM00 (sdvd_Bezout_step Hi)) Hk). 123 | + by rewrite -eqdr0 (congr_eqd (Bezout_step_mx00 M) (eqdd _)) eqdr0 gcdr_eq0 124 | (negbTE nzM00). 125 | + by rewrite Bezout_stepE !unitmxEE. 126 | + rewrite -HA' !Bezout_stepE invrM ?unit_Bezout_mx // !mulmxA. 127 | by congr (_ *m _ *m _); rewrite -mulmxA mulVmx ?unit_Bezout_mx // mulmx1. 128 | + rewrite (eqd_dvd (eqdd _) (Bezout_step_mx00 _)) in Hdiv. 129 | exact: (dvdr_trans Hdiv (dvdr_gcdl _ _)). 130 | set P := map_mx _ _. 131 | have Hblock : (matrix.block_mx 1 0 P 1%:M) *m M = 132 | matrix.block_mx (M 0 0)%:M (matrix.ursubmx M) 133 | (matrix.const_mx (M 0 0)) (P *m matrix.ursubmx M + matrix.drsubmx M). 134 | rewrite -{1}[M]submxK mulmx_block !mul0mx !mul1mx !addr0 135 | [matrix.ulsubmx M]mx11_scalar 2!mxE !lshift0. 136 | congr matrix.block_mx; rewrite mul_mx_scalar. 137 | apply/matrixP=> p q; rewrite ord1 !mxE lshift0 mulrBr mulr1 !rshift1. 138 | case: odivrP=> [d ->|]; first by rewrite mulrC subrK. 139 | by case/dvdrP:(negbFE (Hi p))=> x -> /(_ x); rewrite eqxx. 140 | have unit_block : matrix.block_mx 1 0 P 1%:M \in unitmx 141 | by rewrite unitmxE (det_lblock 1 P) !det1 mul1r unitr1. 142 | have HblockL : (matrix.block_mx 1 0 P 1%:M) *m L = 143 | matrix.col_mx (matrix.usubmx L) (P *m matrix.usubmx L + matrix.dsubmx L) 144 | by rewrite -{1}[L]vsubmxK mul_block_col !mul1mx mul0mx addr0. 145 | case: find2P=> [[i j]|Hij] /=. 146 | set B := matrix.block_mx _ _ _ _; set A := matrix.xrow _ _ B => Hij. 147 | have HMA: M 0 0 = A^T 0 0. 148 | rewrite /A /B -{4}(lshift0 n 0) !mxE tpermL. 149 | by case: splitP=> [i' _|i' Hi']; rewrite ?ord1 row_mxEl mxE ?eqxx. 150 | rewrite HMA in nzM00 Hk Hij; rewrite -[A]trmxK [A^T^T^T]trmxK ![A^T^T _ _]mxE. 151 | case: IHk => [||||L' A' R' HA' ? ? Hdiv HL' HR']; do ?constructor=> //. 152 | + rewrite -ltnS mxE (leq_trans _ Hk) ?(ltn_enorm nzM00) ?sdvd_Bezout_step //. 153 | by rewrite {2}/A [_ (lift _ _) _]mxE [matrix.xrow _ _ _ _ _]mxE tpermL. 154 | + by rewrite mxE -eqdr0 (congr_eqd (Bezout_step_mx00 _) (eqdd _)) eqdr0 155 | gcdr_eq0 (negbTE nzM00). 156 | + by rewrite xrowE -HblockL !unitmxEE unit_block. 157 | + by rewrite !Bezout_stepE !unitmxEE. 158 | + rewrite -HA' ![(A^T) 0 _]mxE /A /B -Hblock -HblockL !xrowE. 159 | rewrite !Bezout_stepE !trmx_mul !trmxK !invrM //. 160 | - rewrite !mulmxA -[_ / _ *m _]mulmxA mulVmx ?unitmx_perm // mulmx1. 161 | rewrite -[_ / _ *m _]mulmxA mulVmx // mulmx1 -[_ *m _^T *m _]mulmxA. 162 | by rewrite mulmxV ?unitmx_tr ?unit_Bezout_mx // mulmx1. 163 | - by rewrite unitmx_tr unit_Bezout_mx. 164 | - by rewrite unitmx_perm. 165 | by rewrite !unitmxEE unit_block. 166 | rewrite (dvdr_trans Hdiv) // mxE (eqd_dvd (Bezout_step_mx00 _) (eqdd _)) HMA. 167 | exact: dvdr_gcdl. 168 | constructor=> //; first by rewrite -HblockL -Hblock invrM // mulmxA mulmxKV. 169 | + rewrite -[m.+1]/(1 + m)%N -[n.+1]/(1 + n)%N => i j. 170 | rewrite -{3}(lshift0 m 0) -{3}(lshift0 n 0) block_mxEul mxE eqxx !mxE. 171 | (* Why do we have to specify all these arguments? *) 172 | case: splitP=> i' Hi'; rewrite mxE; case: splitP=> j' Hj'; rewrite ?mxE ?ord1 //=. 173 | by move: (negbFE (Hij (lshift m 0,j'))); rewrite -rshift1 block_mxEur !mxE. 174 | by move: (negbFE (Hij (lift 0 i',j'))); rewrite -!rshift1 block_mxEdr !mxE. 175 | + rewrite -[m.+1]/(1 + m)%N => i. 176 | rewrite -{5}(lshift0 m 0) -{3 6}(lshift0 n 0) (block_mxEul (M 0 0)%:M _) !mxE eqxx /=. 177 | by case: splitP=> i' _; rewrite row_mxEl !mxE // ord1. 178 | + rewrite -{3}(lshift0 m 0) -{3}(lshift0 n 0). 179 | by rewrite (block_mxEul (M 0 0)%:M (matrix.ursubmx M)) mxE dvdrr. 180 | by rewrite -HblockL unitmx_mul unitmxE (det_lblock 1 P) !det1 mulr1 unitr1. 181 | Qed. 182 | 183 | Variant improve_pivot_spec m n M : 184 | 'M[E]_(1 + m) * 'M_(1 + m,1 + n) * 'M_(1 + n) -> Type := 185 | ImprovePivotSpec L A R of L *m M *m R = A 186 | & (forall i j, A 0 0 %| A i j) 187 | & (forall i, A i 0 = A 0 0) 188 | & A 0 0 %| M 0 0 189 | & L \in unitmx & R \in unitmx 190 | : improve_pivot_spec M (L,A,R). 191 | 192 | Lemma improve_pivotP k m n (M : 'M_(1 + m, 1 + n)) : 193 | (enorm (M 0%R 0%R) <= k)%N -> M 0 0 != 0 -> 194 | improve_pivot_spec M (improve_pivot k M). 195 | Proof. 196 | move=> ? ?; rewrite /improve_pivot. 197 | have := (@improve_pivot_recP k _ _ 1%:M M 1%:M). 198 | rewrite /improve_pivot_rec=> [[]] //; rewrite ?unitmx1 //. 199 | rewrite !invr1 mul1mx mulmx1 => ? ? ? eqM ? ? ? ? ?. 200 | by constructor=> //; rewrite eqM !mulmxA mulmxV // mul1mx mulmxKV. 201 | Qed. 202 | 203 | Lemma SmithP : forall (m n : nat) (M : 'M_(m,n)), 204 | smith_spec M (Smith M). 205 | Proof. 206 | elim=> [n M|m IHn]; first constructor; rewrite ?unitmx1 //. 207 | rewrite [M]flatmx0 mulmx1 mul1mx; apply/matrixP=> i j. 208 | by rewrite !mxE nth_nil mul0rn. 209 | case=> [M|n M /=]; first constructor; rewrite ?sorted_nil ?mxE ?unitmx1 //. 210 | rewrite [M]thinmx0 mulmx1 mul1mx; apply/matrixP=> i j. 211 | by rewrite !mxE nth_nil mul0rn. 212 | case: find_pivotP =>[[i j] HMij | H]. 213 | case: improve_pivotP; rewrite ?mxE ?tpermR ?leqnn //. 214 | rewrite -[m.+1]/(1 + m)%N -[n.+1]/(1 + n)%N => L A R0 HA Hdiv HAi0 HA00. 215 | set A' := map_mx _ _; set v' := map_mx _ _. 216 | case: IHn=> L' d R' Hd Hsorted HL' HR' HL HR; constructor. 217 | * rewrite xcolE xrowE -!mulmxA (mulmxA M) -xcolE (mulmxA (tperm_mx _ _)). 218 | rewrite -xrowE (mulmxA L) (mulmxA _ R0) HA mulmx_block !mulmxA mulmx_block. 219 | rewrite -{1}(submxK A) !mulmx_block. 220 | do 2! rewrite !mul0mx !mulmx0 !mulmx1 !mul1mx !addr0 ?add0r. 221 | have Hu: matrix.const_mx 1 *m matrix.ulsubmx A = matrix.dlsubmx A. 222 | rewrite [matrix.ulsubmx A]mx11_scalar mul_mx_scalar; apply/matrixP=> k l. 223 | by rewrite ord1 !mxE mulr1 !lshift0 !HAi0. 224 | have Hv': (matrix.ulsubmx A *m v') = matrix.ursubmx A. 225 | apply/matrixP=> k l. 226 | rewrite (ord1 k) !mxE big_ord_recl big_ord0 !mxE !lshift0 addr0. 227 | case: odivrP=>[x ->|H]; first by rewrite mulrC. 228 | by case/dvdrP:(Hdiv 0 (rshift 1 l))=> q /eqP; rewrite (negbTE (H q)). 229 | rewrite diag_mx_seq_cons; congr matrix.block_mx. 230 | (* Pivot *) 231 | + by apply/matrixP=> k l; rewrite !ord1 !mxE !lshift0 eqxx. 232 | (* Horizontal zeros *) 233 | + by rewrite mulNmx mulmxN mulmxA Hv' addNr. 234 | (* Vertical zeros *) 235 | + by rewrite mulmxN mulNmx -mulmxA Hu addNr. 236 | (* down-right submatrix *) 237 | + rewrite mulmxN !mulNmx -mulmxA Hu addNr mul0mx add0r addrC -mulmxA -mulmxBr. 238 | transitivity (A 0 0 *: (L' *m A' *m R')). 239 | rewrite -[_ *m A' *m _]mulmxA scalemxAr scalemxAl. 240 | have Hdiv' : forall i j, A 0 0 %| (matrix.drsubmx A - matrix.const_mx 1 *m matrix.ursubmx A) i j. 241 | by move=> k l; rewrite !mxE big_ord1 !mxE mul1r dvdr_sub ?Hdiv. 242 | have -> : A 0 0 *: A' = matrix.drsubmx A - matrix.const_mx 1 *m matrix.ursubmx A. 243 | apply/matrixP=> k l; rewrite 2!mxE. 244 | case: odivrP=>[x ->|H]; first by rewrite mulrC. 245 | by case/dvdrP:(Hdiv' k l)=> q /eqP; rewrite (negbTE (H q)). 246 | by rewrite mulmxA. 247 | rewrite Hd; apply/matrixP=> k l; rewrite !mxE. 248 | case: eqP => /=; last by rewrite mulr0. 249 | case: (ltnP k (size d)) => Hk. 250 | by rewrite (nth_map 0 _ _ Hk) mulrC. 251 | by rewrite !nth_default ?size_map ?Hk // mulr0. 252 | * have {}HA00: A 0 0 != 0. 253 | by apply/eqP=> H; move:HA00; rewrite H dvd0r (negbTE HMij). 254 | rewrite /= path_min_sorted; 255 | last by apply/allP=> a /mapP [b _ ->]; exact:dvdr_mull. 256 | case: d Hsorted {Hd} => //= a d; elim: d a=> //= a1 d IHd a0 /andP[a01 /IHd]. 257 | by rewrite dvdr_mul2r ?a01. 258 | * rewrite xcolE !unitmx_mul unitmx_perm HL !unitmxE. 259 | by rewrite !det_lblock !det1 mul1r mulr1 unitr1 -unitmxE !andbT. 260 | * rewrite xrowE !unitmx_mul unitmx_perm HR !unitmxE. 261 | by rewrite 2!det_ublock 2!det1 2!mul1r unitr1 -unitmxE. 262 | constructor =>[|||]; rewrite ?mxE ?unitmx1 //. 263 | rewrite mul1mx mulmx1; apply/matrixP=> i j; rewrite !mxE (eqP (negbFE (H (i,j)))). 264 | by case: (i == j :> nat); rewrite ?nth_nseq ?if_same nth_nil. 265 | Qed. (* Why is this so slow??? *) 266 | 267 | Lemma size_Smith m n (A : 'M_(m,n)) : 268 | let: (_, d, _) := Smith A in (size d <= minn m n)%N. 269 | Proof. 270 | elim: m n A=>[n'|m' Ih n']; first by rewrite min0n. 271 | case: n'=>[|n' A /=]; first by rewrite minn0. 272 | case: find_pivotP=> [[x1 x2] Hx|//]. 273 | case: (improve_pivot _ _); case => a b c /=; set M := map_mx _ _. 274 | case H: (Smith _) (Ih n' M) => [[i s] k] /=. 275 | by rewrite size_map minnSS ltnS. 276 | Qed. 277 | 278 | End smith. 279 | 280 | HB.factory Record hasSmith E of EuclideanDomain E := { 281 | find1 : forall m n, 'M[E]_(m.+1,n.+1) -> E -> option 'I_m; 282 | find2 : forall m n, 'M[E]_(m.+1,n.+1) -> E -> option ('I_(1+m) * 'I_n); 283 | find_pivot : 284 | forall m n, 'M[E]_(1 + m,1 + n) -> option ('I_(1 + m) * 'I_(1 + n)); 285 | find1P : forall m n (E : 'M[E]_(1 + m,1 + n)) a, 286 | pick_spec [pred i | ~~(a %| E (lift 0 i) 0)] (find1 _ _ E a); 287 | find2P : forall m n (E : 'M[E]_(1 + m,1 + n)) a, 288 | pick_spec [pred ij | ~~(a %| E ij.1 (lift 0 ij.2))] (find2 _ _ E a); 289 | find_pivotP : forall m n (E : 'M[E]_(1 + m,1 + n)), 290 | pick_spec [pred ij | E ij.1 ij.2 != 0] (find_pivot _ _ E) 291 | }. 292 | 293 | HB.builders Context E of hasSmith E. 294 | 295 | HB.instance Definition _ := DvdRing_isEDR.Build E 296 | (SmithP find1P find2P find_pivotP). 297 | 298 | HB.end. 299 | -------------------------------------------------------------------------------- /theory/ssralg_ring_tac.v: -------------------------------------------------------------------------------- 1 | Require Import Ncring Ncring_tac. 2 | From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype. 3 | From mathcomp Require Import div finfun bigop prime binomial ssralg matrix. 4 | 5 | Section ring_tac. 6 | 7 | Variable R : ringType. 8 | 9 | Import GRing.Theory. 10 | 11 | #[export] Instance Rops: 12 | @Ring_ops R 0%R 1%R (@GRing.add R) (@GRing.mul R) 13 | (fun a b : R => a - b)%R (@GRing.opp R) eq := {}. 14 | 15 | #[export] Instance R_is_ring: (@Ring _ _ _ _ _ _ _ _ Rops). 16 | constructor=> //. 17 | exact:eq_equivalence. 18 | by move=> x y H1 u v H2; rewrite H1 H2. 19 | by move=> x y H1 u v H2; rewrite H1 H2. 20 | by move=> x y H1 u v H2; rewrite H1 H2. 21 | by move=> x y H1; rewrite H1. 22 | exact:add0r. 23 | exact:addrC. 24 | exact:addrA. 25 | exact:mul1r. 26 | exact:mulr1. 27 | exact:mulrA. 28 | exact:mulrDl. 29 | by move=> M N P ; exact:mulrDr. 30 | by move=> M; rewrite /addition /add_notation (addrC M) addNr. 31 | Qed. 32 | 33 | #[export] Instance matrix_ops (n : nat) : @Ring_ops 'M[R]_n 0%R 34 | (scalar_mx 1) (@addmx R _ _) mulmx (fun M N => addmx M (oppmx N)) (@oppmx R _ _) eq := {}. 35 | 36 | #[export] Instance matrix_is_ring (n : nat) : 37 | (@Ring _ _ _ _ _ _ _ _ (matrix_ops n)). 38 | Proof. 39 | constructor=> //. 40 | + exact:eq_equivalence. 41 | + by move=> x y H1 u v H2; rewrite H1 H2. 42 | + by move=> x y H1 u v H2; rewrite H1 H2. 43 | + by move=> x y H1 u v H2; rewrite H1 H2. 44 | + by move=> x y H1; rewrite H1. 45 | + exact:add0mx. 46 | + exact:addmxC. 47 | + exact:addmxA. 48 | + exact:mul1mx. 49 | + exact:mulmx1. 50 | + exact:mulmxA. 51 | + exact:mulmxDl. 52 | + by move=> M N P ; exact:mulmxDr. 53 | + by move=> M; rewrite /addition /add_notation (addmxC M) addNmx. 54 | Qed. 55 | 56 | End ring_tac. -------------------------------------------------------------------------------- /theory/ssrcomplements.v: -------------------------------------------------------------------------------- 1 | (** This file is part of CoqEAL, the Coq Effective Algebra Library. 2 | (c) Copyright INRIA and University of Gothenburg, see LICENSE *) 3 | From HB Require Import structures. 4 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path. 5 | From mathcomp Require Import ssralg fintype finfun perm matrix bigop zmodp mxalgebra. 6 | From mathcomp Require Import choice poly polydiv mxpoly binomial. 7 | 8 | Set Implicit Arguments. 9 | Unset Strict Implicit. 10 | Unset Printing Implicit Defensive. 11 | 12 | (** This file contains definitions and lemmas that are generic enough that 13 | we could try to integrate them in Math Components' library. 14 | Definitions and theories are gathered according to the file of the 15 | library which they could be moved to. *) 16 | 17 | (** ** Informative version of [iff] *) 18 | 19 | (** As CoqEAL now puts all relations in [Type], we define a compliant 20 | version of [iff], named [ifft], along with view declarations *) 21 | Inductive ifft (A B : Type) : Type := Ifft of (A -> B) & (B -> A). 22 | Infix "<=>" := ifft (at level 95) : type_scope. 23 | 24 | Section ApplyIfft. 25 | 26 | Variables P Q : Type. 27 | Hypothesis eqPQ : P <=> Q. 28 | 29 | Lemma ifft1 : P -> Q. Proof. by case: eqPQ. Qed. 30 | Lemma ifft2 : Q -> P. Proof. by case: eqPQ. Qed. 31 | 32 | End ApplyIfft. 33 | 34 | Hint View for move/ ifft1|2 ifft2|2. 35 | Hint View for apply/ ifft1|2 ifft2|2. 36 | 37 | Lemma ifftW (P Q : Prop) : P <=> Q -> (P <-> Q). 38 | Proof. by case. Qed. 39 | 40 | (********************* seq.v *********************) 41 | Section Seq. 42 | 43 | Variables (T1 T2 T3 : Type) (f : T1 -> T2 -> T3). 44 | 45 | Lemma seq2_ind (P : seq T1 -> seq T2 -> Prop) : P [::] [::] -> 46 | (forall x1 x2 s1 s2, P s1 s2 -> P (x1 :: s1) (x2 :: s2)) -> 47 | forall s1 s2, size s1 = size s2 -> P s1 s2. 48 | Proof. 49 | move=> Pnil Pcons. 50 | elim=> [|x1 l1 IH1]; case=> // x2 l2 /eqnP /= Hs. 51 | by apply/Pcons/IH1/eqnP. 52 | Qed. 53 | 54 | End Seq. 55 | 56 | Section Seqeqtype. 57 | 58 | Variable T : eqType. 59 | Variable leT : rel T. 60 | 61 | Hypothesis leT_tr : transitive leT. 62 | 63 | Lemma sorted_drop (s : seq T) m : sorted leT s -> sorted leT (drop m s). 64 | Proof. 65 | by elim: s m => //= a l ih [|n h] //; apply/ih/(path_sorted h). 66 | Qed. 67 | 68 | Lemma subseq_take (s : seq T) m : subseq (take m s) s. 69 | Proof. by elim: s m => // a l ih [] //= n; rewrite eqxx. Qed. 70 | 71 | Lemma sorted_take (s : seq T) m : sorted leT s -> sorted leT (take m s). 72 | Proof. 73 | move=> H; exact: (subseq_sorted leT_tr (subseq_take _ _) H). 74 | Qed. 75 | 76 | End Seqeqtype. 77 | 78 | (******************** bigop.v ********************) 79 | Section BigOp. 80 | 81 | Import GRing.Theory. 82 | 83 | Variable R : comRingType. 84 | Variable T : eqType. 85 | 86 | Open Scope ring_scope. 87 | 88 | (*** This lemma is usefull to prove that \mu_x p = count_mem x s where 89 | s is the sequence of roots of polynomial p ***) 90 | Lemma prod_seq_count (s : seq T) (F : T -> R) : 91 | \prod_(i <- s) F i = 92 | \prod_(i <- (undup s)) ((F i) ^+ (count (xpred1 i) s)). 93 | Proof. 94 | elim: s=> /= [|a l IHl]; first by rewrite !big_nil. 95 | rewrite big_cons IHl. 96 | set r:= if _ then _ else _. 97 | have ->: \big[*%R/1]_(i <- r) (F i) ^+ ((a == i) + count (eq_op^~ i) l) = 98 | \big[*%R/1]_(i <- r) (F i) ^+ (a == i) * 99 | \big[*%R/1]_(i <- r) (F i) ^+ (count (eq_op^~ i) l). 100 | by rewrite -big_split /=; apply: eq_bigr=> i _; rewrite exprD. 101 | have ->: \big[*%R/1]_(i <- r) (F i) ^+ (a == i) = F a. 102 | rewrite /r; case: ifP=>[|notal]. 103 | rewrite -mem_undup=> aundl. 104 | rewrite (bigD1_seq _ aundl (undup_uniq l)) /= eqxx big1 ?mulr1 //. 105 | by move=> i /negbTE neqai; rewrite eq_sym neqai. 106 | rewrite big_cons eqxx big1_seq ?mulr1 // => i /= iundl. 107 | case: (eqVneq a i) => //= eqai. 108 | by rewrite eqai -mem_undup iundl in notal. 109 | rewrite /r; case: ifP=> // /negbT notal. 110 | rewrite big_cons. 111 | have->: count (xpred1 a) l = 0%N. 112 | by apply/eqP; rewrite -leqn0 leqNgt -has_count has_pred1. 113 | by rewrite mul1r. 114 | Qed. 115 | 116 | End BigOp. 117 | 118 | (********************* matrix.v *********************) 119 | Section Matrix. 120 | 121 | Local Open Scope ring_scope. 122 | Import GRing.Theory. 123 | 124 | Section matrix_raw_type. 125 | 126 | Variable T : Type. 127 | 128 | Lemma row_thin_mx p q (M : 'M_(p,0)) (N : 'M[T]_(p,q)) : 129 | row_mx M N = N. 130 | Proof. 131 | apply/matrixP=> i j; rewrite mxE; case: splitP=> [|k H]; first by case. 132 | by congr fun_of_matrix; exact: val_inj. 133 | Qed. 134 | 135 | Lemma col_flat_mx p q (M : 'M[T]_(0, q)) (N : 'M_(p,q)) : 136 | col_mx M N = N. 137 | Proof. 138 | apply/matrixP=> i j; rewrite mxE; case: splitP => [|k H]; first by case. 139 | by congr fun_of_matrix; exact: val_inj. 140 | Qed. 141 | 142 | End matrix_raw_type. 143 | 144 | Section matrix_ringType. 145 | 146 | Variable R : ringType. 147 | 148 | Lemma mulmx_rsub m n p k (A : 'M[R]_(m, n)) (B : 'M[R]_(n, p + k)) : 149 | A *m rsubmx B = (rsubmx (A *m B)). 150 | Proof. 151 | by apply/matrixP=> i j; rewrite !mxE; apply: eq_bigr => l //= _; rewrite mxE. 152 | Qed. 153 | 154 | Lemma mulmx_lsub m n p k (A : 'M[R]_(m, n)) (B : 'M[R]_(n, p + k)) : 155 | A *m lsubmx B = (lsubmx (A *m B)). 156 | Proof. 157 | by apply/matrixP=> i j; rewrite !mxE; apply: eq_bigr => l //= _; rewrite mxE. 158 | Qed. 159 | 160 | Lemma col_0mx m n (M : 'M[R]_(m, n)) : col_mx (0 :'M_(0%N, _)) M = M. 161 | Proof. 162 | apply/matrixP=> i j; rewrite !mxE. 163 | case: splitP => [[] //|k eq_i_k]; congr (M _ _). 164 | by apply: val_inj; rewrite /= eq_i_k. 165 | Qed. 166 | 167 | (* to be replaced by col1 and colE (once they are in mathcomp) *) 168 | Lemma col_id_mulmx m n (M : 'M[R]_(m,n)) i : 169 | M *m col i 1%:M = col i M. 170 | Proof. 171 | apply/matrixP=> k l; rewrite !mxE. 172 | rewrite (bigD1 i) // big1 /= ?addr0 ?mxE ?eqxx ?mulr1 // => j /negbTE neqji. 173 | by rewrite !mxE neqji mulr0. 174 | Qed. 175 | 176 | (* to be replaced by row1 and rowE *) 177 | Lemma row_id_mulmx m n (M : 'M[R]_(m,n)) i : 178 | row i 1%:M *m M = row i M. 179 | Proof. 180 | apply/matrixP=> k l; rewrite !mxE. 181 | rewrite (bigD1 i) // big1 /= ?addr0 ?mxE ?eqxx ?mul1r // => j /negbTE Hj. 182 | by rewrite !mxE eq_sym Hj mul0r. 183 | Qed. 184 | 185 | Lemma row'_col'_char_poly_mx m i (M : 'M[R]_m) : 186 | row' i (col' i (char_poly_mx M)) = char_poly_mx (row' i (col' i M)). 187 | Proof. 188 | apply/matrixP=> k l; rewrite !mxE. 189 | suff ->: (lift i k == lift i l) = (k == l) => //. 190 | by apply/inj_eq/lift_inj. 191 | Qed. 192 | 193 | Lemma exp_block_mx m n (A: 'M[R]_m.+1) (B : 'M_n.+1) k : 194 | (block_mx A 0 0 B) ^+ k = block_mx (A ^+ k) 0 0 (B ^+ k). 195 | Proof. 196 | elim: k=> [|k IHk]. 197 | by rewrite !expr0 -scalar_mx_block. 198 | rewrite !exprS IHk /GRing.mul /= (mulmx_block A 0 0 B (A ^+ k)). 199 | by rewrite !mulmx0 !mul0mx !add0r !addr0. 200 | Qed. 201 | 202 | Lemma char_block_mx m n (A : 'M[R]_m) (B : 'M[R]_n) : 203 | char_poly_mx (block_mx A 0 0 B) = 204 | block_mx (char_poly_mx A) 0 0 (char_poly_mx B). 205 | Proof. 206 | apply/matrixP=> i j; rewrite !mxE. 207 | case: splitP=> k Hk; rewrite !mxE; case: splitP=> l Hl; rewrite !mxE; 208 | rewrite -!(inj_eq (@ord_inj _)) Hk Hl ?subr0 ?eqn_add2l //. 209 | by rewrite ltn_eqF // ltn_addr. 210 | by rewrite gtn_eqF // ltn_addr. 211 | Qed. 212 | 213 | End matrix_ringType. 214 | 215 | Section matrix_comUnitRingType. 216 | 217 | Variable R : comUnitRingType. 218 | 219 | Lemma invmx_block n1 n2 (Aul : 'M[R]_n1.+1) (Adr : 'M[R]_n2.+1) : 220 | (block_mx Aul 0 0 Adr) \in unitmx -> 221 | (block_mx Aul 0 0 Adr)^-1 = block_mx Aul^-1 0 0 Adr^-1. 222 | Proof. 223 | move=> Hu. 224 | have Hu2: (block_mx Aul 0 0 Adr) \is a GRing.unit by []. 225 | rewrite unitmxE det_ublock unitrM in Hu. 226 | case/andP: Hu; rewrite -!unitmxE => HAul HAur. 227 | have H: block_mx Aul 0 0 Adr * block_mx Aul^-1 0 0 Adr^-1 = 1. 228 | rewrite /GRing.mul /= (mulmx_block Aul _ _ _ Aul^-1) !mulmxV //. 229 | by rewrite !mul0mx !mulmx0 !add0r addr0 -scalar_mx_block. 230 | by apply: (mulrI Hu2); rewrite H mulrV. 231 | Qed. 232 | 233 | End matrix_comUnitRingType. 234 | 235 | End Matrix. 236 | 237 | Section Poly. 238 | 239 | Variable R : idomainType. 240 | Import GRing.Theory. 241 | Local Open Scope ring_scope. 242 | 243 | (* use coprimep_XsubC2 *) 244 | Lemma coprimep_factor (a b : R) : (b - a)%R \is a GRing.unit -> 245 | coprimep ('X - a%:P) ('X - b%:P). 246 | Proof. 247 | move=> Hab; apply/Bezout_coprimepP. 248 | exists ((b - a)^-1%:P, -(b - a) ^-1%:P). 249 | rewrite /= !mulrBr !mulNr opprK -!addrA (addrC (- _)) !addrA addrN. 250 | by rewrite add0r -mulrBr -rmorphB -rmorphM mulVr // eqpxx. 251 | Qed. 252 | 253 | End Poly. 254 | 255 | (****************************************************************************) 256 | (****************************************************************************) 257 | (************ left pseudo division, it is complement of polydiv. ************) 258 | (****************************************************************************) 259 | (****************************************************************************) 260 | Import GRing.Theory. 261 | Import Pdiv.Ring. 262 | Import Pdiv.RingMonic. 263 | 264 | Local Open Scope ring_scope. 265 | 266 | Module RPdiv. 267 | 268 | Section RingPseudoDivision. 269 | 270 | Variable R : ringType. 271 | Implicit Types d p q r : {poly R}. 272 | 273 | Definition id_converse_def := (fun x : R => x : R^c). 274 | Lemma add_id : additive id_converse_def. 275 | Proof. by []. Qed. 276 | 277 | HB.instance Definition _ := GRing.isAdditive.Build R R^c id_converse_def add_id. 278 | Definition id_converse : {additive _ -> _} := id_converse_def. 279 | 280 | Lemma expr_rev (x : R) k : (x : R^c) ^+ k = x ^+ k. 281 | Proof. by elim:k=> // k IHk; rewrite exprS exprSr IHk. Qed. 282 | 283 | Definition phi (p : {poly R}^c) := map_poly id_converse p. 284 | 285 | Fact phi_is_rmorphism : multiplicative phi. 286 | Proof. 287 | split=> [p q|]; apply/polyP=> i; last by rewrite coef_map !coef1. 288 | by rewrite coefMr coef_map coefM; apply: eq_bigr => j _; rewrite !coef_map. 289 | Qed. 290 | 291 | HB.instance Definition _ := GRing.Additive.copy phi phi. 292 | HB.instance Definition _ := GRing.isMultiplicative.Build _ _ _ phi_is_rmorphism. 293 | 294 | Definition phi_inv (p : {poly R^c}) := 295 | map_poly (fun x : R^c => x : R) p : {poly R}^c. 296 | 297 | Lemma phiK : cancel phi phi_inv. 298 | Proof. by move=> p; rewrite /phi_inv -map_poly_comp_id0 // map_poly_id. Qed. 299 | 300 | Lemma phi_invK : cancel phi_inv phi. 301 | Proof. by move=> p; rewrite /phi -map_poly_comp_id0 // map_poly_id. Qed. 302 | 303 | Lemma phi_bij : bijective phi. 304 | Proof. by exists phi_inv; first exact: phiK; exact: phi_invK. Qed. 305 | 306 | Lemma monic_map_inj (aR rR : ringType) (f : aR -> rR) (p : {poly aR}) : 307 | injective f -> f 0 = 0 -> f 1 = 1 -> map_poly f p \is monic = (p \is monic). 308 | Proof. 309 | move=> inj_f eq_f00 eq_f11; rewrite !monicE lead_coef_map_inj ?rmorph0 //. 310 | by rewrite -eq_f11 inj_eq. 311 | Qed. 312 | 313 | Definition redivp_l (p q : {poly R}) : nat * {poly R} * {poly R} := 314 | let:(d,q,p) := redivp (phi p) (phi q) in 315 | (d, phi_inv q, phi_inv p). 316 | 317 | Definition rdivp_l p q := (redivp_l p q).1.2. 318 | Definition rmodp_l p q := (redivp_l p q).2. 319 | Definition rscalp_l p q := (redivp_l p q).1.1. 320 | Definition rdvdp_l p q := rmodp_l q p == 0. 321 | Definition rmultp_l := [rel m d | rdvdp_l d m]. 322 | 323 | Lemma ltn_rmodp_l p q : (size (rmodp_l p q) < size q) = (q != 0). 324 | Proof. 325 | have := ltn_rmodp (phi p) (phi q). 326 | rewrite -(rmorph0 phi) (inj_eq (can_inj phiK)) => <-. 327 | rewrite /rmodp_l /redivp_l /rmodp; case: (redivp _ _)=> [[k q'] r'] /=. 328 | by rewrite !size_map_inj_poly. 329 | Qed. 330 | 331 | End RingPseudoDivision. 332 | 333 | Module mon. 334 | 335 | Section MonicDivisor. 336 | 337 | Variable R : ringType. 338 | Implicit Types p q r : {poly R}. 339 | 340 | Variable d : {poly R}. 341 | Hypothesis mond : d \is monic. 342 | 343 | Lemma rdivp_l_eq p : 344 | p = d * (rdivp_l p d) + (rmodp_l p d). 345 | Proof. 346 | have mon_phi_d: phi d \is monic by rewrite monic_map_inj. 347 | apply:(can_inj (@phiK R)); rewrite {1}[phi p](rdivp_eq mon_phi_d) rmorphD. 348 | rewrite rmorphM /rdivp_l /rmodp_l /redivp_l /rdivp /rmodp. 349 | by case: (redivp _ _)=> [[k q'] r'] /=; rewrite !phi_invK. 350 | Qed. 351 | 352 | End MonicDivisor. 353 | 354 | End mon. 355 | 356 | End RPdiv. 357 | 358 | 359 | Section prelude. 360 | Variable R : comRingType. 361 | 362 | Let lreg := GRing.lreg. 363 | Let rreg := GRing.rreg. 364 | 365 | Lemma monic_lreg (p : {poly R}) : p \is monic -> lreg p. 366 | Proof. by rewrite monicE=> /eqP lp1; apply/lreg_lead; rewrite lp1; apply/lreg1. Qed. 367 | 368 | Lemma monic_rreg (p : {poly R}) : p \is monic -> rreg p. 369 | Proof. by rewrite monicE=> /eqP lp1; apply/rreg_lead; rewrite lp1; apply/rreg1. Qed. 370 | 371 | Lemma lregMl (a b: R) : lreg (a * b) -> lreg b. 372 | Proof. by move=> rab c c' eq_bc; apply/rab; rewrite -!mulrA eq_bc. Qed. 373 | 374 | Lemma rregMr (a b: R) : rreg (a * b) -> rreg a. 375 | Proof. by move=> rab c c' eq_ca; apply/rab; rewrite !mulrA eq_ca. Qed. 376 | 377 | End prelude. 378 | 379 | (****************************************************************************) 380 | (****************************************************************************) 381 | (****************************************************************************) 382 | (****************************************************************************) 383 | -------------------------------------------------------------------------------- /theory/strassen.v: -------------------------------------------------------------------------------- 1 | (** This file is part of CoqEAL, the Coq Effective Algebra Library. 2 | (c) Copyright INRIA and University of Gothenburg, see LICENSE *) 3 | Require Import ZArith Ncring Ncring_tac. 4 | From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype. 5 | From mathcomp Require Import div finfun bigop prime binomial ssralg finset fingroup finalg. 6 | From mathcomp Require Import perm zmodp matrix. 7 | 8 | Require Import ssralg_ring_tac. 9 | 10 | (** This file describes a formally verified implementation of Strassen's 11 | algorithm (Winograd's variant). *) 12 | 13 | Set Implicit Arguments. 14 | Unset Strict Implicit. 15 | Unset Printing Implicit Defensive. 16 | 17 | Local Open Scope ring_scope. 18 | 19 | Section Strassen. 20 | Variable (R : ringType) (K : positive). 21 | 22 | Local Coercion nat_of_pos : positive >-> nat. 23 | 24 | Lemma addpp p : xO p = (p + p)%N :> nat. 25 | Proof. by rewrite /= NatTrec.trecE addnn. Qed. 26 | 27 | Lemma addSpp p : xI p = (p + p).+1%N :> nat. 28 | Proof. by rewrite /= NatTrec.trecE addnn. Qed. 29 | 30 | Lemma addp1 p : xI p = (xO p + 1)%N :> nat. 31 | Proof. by rewrite addn1. Qed. 32 | 33 | Lemma add1pp p : xI p = (1 + (p + p))%N :> nat. 34 | Proof. by rewrite /= NatTrec.trecE addnn. Qed. 35 | 36 | Lemma lt0p : forall p : positive, 0 < p. 37 | Proof. 38 | by elim=> // p IHp /=; rewrite NatTrec.doubleE -addnn; exact:ltn_addl. 39 | Qed. 40 | 41 | Local Open Scope ring_scope. 42 | 43 | 44 | Definition Strassen_step {p : positive} (A B : 'M[R]_(p + p, p + p)) 45 | (f : 'M[R]_(p, p) -> 'M_(p, p) -> 'M[R]_(p, p)) : 'M_(p + p, p + p) := 46 | let A11 := ulsubmx A in 47 | let A12 := ursubmx A in 48 | let A21 := dlsubmx A in 49 | let A22 := drsubmx A in 50 | let B11 := ulsubmx B in 51 | let B12 := ursubmx B in 52 | let B21 := dlsubmx B in 53 | let B22 := drsubmx B in 54 | let X := A11 - A21 in 55 | let Y := B22 - B12 in 56 | let C21 := f X Y in 57 | let X := A21 + A22 in 58 | let Y := B12 - B11 in 59 | let C22 := f X Y in 60 | let X := X - A11 in 61 | let Y := B22 - Y in 62 | let C12 := f X Y in 63 | let X := A12 - X in 64 | let C11 := f X B22 in 65 | let X := f A11 B11 in 66 | let C12 := X + C12 in 67 | let C21 := C12 + C21 in 68 | let C12 := C12 + C22 in 69 | let C22 := C21 + C22 in 70 | let C12 := C12 + C11 in 71 | let Y := Y - B21 in 72 | let C11 := f A22 Y in 73 | let C21 := C21 - C11 in 74 | let C11 := f A12 B21 in 75 | let C11 := X + C11 in 76 | block_mx C11 C12 C21 C22. 77 | 78 | Definition Strassen_xO {p : positive} Strassen_p := 79 | fun A B => 80 | if p <= K then A *m B else 81 | let A := castmx (addpp p,addpp p) A in 82 | let B := castmx (addpp p,addpp p) B in 83 | castmx (esym (addpp p), esym (addpp p)) (Strassen_step A B Strassen_p). 84 | 85 | Definition Strassen_xI {p : positive} Strassen_p := 86 | fun M N => 87 | if p <= K then M *m N else 88 | let M := castmx (add1pp p, add1pp p) M in 89 | let N := castmx (add1pp p, add1pp p) N in 90 | let M11 := ulsubmx M in 91 | let M12 := ursubmx M in 92 | let M21 := dlsubmx M in 93 | let M22 := drsubmx M in 94 | let N11 := ulsubmx N in 95 | let N12 := ursubmx N in 96 | let N21 := dlsubmx N in 97 | let N22 := drsubmx N in 98 | let R11 := (M11 *m N11) + (M12 *m N21) in 99 | let R12 := (M11 *m N12) + (M12 *m N22) in 100 | let R21 := (M21 *m N11) + (M22 *m N21) in 101 | let R22 := (M21 *m N12) + (Strassen_step M22 N22 Strassen_p) in 102 | castmx (esym (add1pp p), esym (add1pp p)) (block_mx R11 R12 R21 R22). 103 | 104 | Definition Strassen := 105 | positive_rect (fun p => ('M_(p, p) -> 'M_(p, p) -> 'M_(p, p))) 106 | (@Strassen_xI) (@Strassen_xO) (fun M N => M *m N). 107 | 108 | 109 | Lemma Strassen_stepP (p : positive) (A B : 'M[R]_(p + p)) f : 110 | f =2 mulmx -> Strassen_step A B f = A *m B. 111 | Proof. 112 | move=> Hf; rewrite -{2}[A]submxK -{2}[B]submxK mulmx_block /Strassen_step !Hf. 113 | rewrite /GRing.add /= /GRing.opp /=. 114 | by congr block_mx; non_commutative_ring. 115 | Qed. 116 | 117 | Lemma mulmx_cast {R' : ringType} {m n p m' n' p'} {M:'M[R']_(m,p)} {N:'M_(p,n)} 118 | {eqm : m = m'} (eqp : p = p') {eqn : n = n'} : 119 | matrix.castmx (eqm,eqn) (M *m N) = matrix.castmx (eqm,eqp) M *m matrix.castmx (eqp,eqn) N. 120 | Proof. by case eqm; case eqn; case eqp. Qed. 121 | 122 | Lemma StrassenP p : mulmx =2 (Strassen (p := p)). 123 | Proof. 124 | elim: p => // [p IHp|p IHp] M N. 125 | rewrite /= /Strassen_xI; case:ifP=> // _. 126 | by rewrite Strassen_stepP // -mulmx_block !submxK -mulmx_cast castmxK. 127 | rewrite /= /Strassen_xO; case:ifP=> // _. 128 | by rewrite Strassen_stepP // -mulmx_cast castmxK. 129 | Qed. 130 | 131 | End Strassen. 132 | -------------------------------------------------------------------------------- /theory/toomcook.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div fintype tuple. 2 | From mathcomp Require Import finfun bigop fingroup perm ssralg zmodp matrix mxalgebra. 3 | From mathcomp Require Import poly polydiv mxpoly. 4 | 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | Import GRing.Theory. 10 | 11 | Open Scope ring_scope. 12 | 13 | Section split_poly. 14 | 15 | Variable R : ringType. 16 | 17 | Implicit Types p : {poly R}. 18 | 19 | (* Split a polynomial into n pieces of size b *) 20 | Definition split_poly n b p := 21 | \poly_(i < n) \poly_(j < b) p`_(i * b + j). 22 | 23 | Lemma recompose_split : forall n b p, size p <= b * n -> 24 | (split_poly n b p).['X^b] = p. 25 | Proof. 26 | rewrite /split_poly => [[b p|n b p hs]]; rewrite horner_poly ?big_ord_recr /=. 27 | by rewrite muln0 leqn0 size_poly_eq0 => /eqP ->; rewrite big_ord0. 28 | suff -> : \big[+%R/0]_(i < n) (\poly_(j < b) p`_(i * b + j) * 'X^b ^+ i) = 29 | \poly_(i < n * b) p`_i. 30 | apply/polyP=> i; rewrite -exprM coefD coefMXn coef_poly mulnC. 31 | have [_|hbni] := ltnP; rewrite ?addr0 // add0r coef_poly. 32 | have [_|hsub] := ltnP; rewrite ?subnKC // ?nth_default //. 33 | rewrite -ltnS -subSn // ltn_subRL ltnS addnC -mulnS in hsub. 34 | exact: (leq_trans hs hsub). 35 | elim: n {hs} => [|n ih]; first by rewrite mul0n poly_def !big_ord0. 36 | apply/polyP=> i. 37 | rewrite big_ord_recr /= ih -exprM coefD !coef_poly coefMXn mulSn mulnC. 38 | have [h1|hbni] := ltnP; first by rewrite addr0 (ltn_addl b h1). 39 | by rewrite add0r coef_poly subnKC // -(ltn_add2r (b * n)) subnK. 40 | Qed. 41 | 42 | End split_poly. 43 | 44 | Section ToomCook. 45 | 46 | (* Necessary to interpolate... *) 47 | Variable R : idomainType. 48 | 49 | (* Toom-n *) 50 | Variable n : nat. 51 | 52 | (* Need d = 2 * n - 1 pairs of points *) 53 | Let d : nat := n.*2.-1. 54 | 55 | Variable points : d.-tuple {poly R}. 56 | 57 | (* Vandermonde matrix *) 58 | Definition vandmx m : 'M[{poly R}]_(m,d) := 59 | \matrix_(i < m,j < d) (points`_j ^+ i). 60 | 61 | (* Evaluation *) 62 | Definition evaluate p := poly_rV p *m vandmx (size p). 63 | 64 | Lemma evaluateE p : evaluate p = \row_(i < d) p.[points`_i]. 65 | Proof. 66 | apply/rowP => i; rewrite !mxE horner_coef /=. 67 | by apply: eq_big => // j _; rewrite !mxE. 68 | Qed. 69 | 70 | (* Interpolation *) 71 | Definition interpolate (p : 'rV[{poly R}]_d) := rVpoly (p *m invmx (vandmx d)). 72 | 73 | (* TODO: Express using determinant? *) 74 | Hypothesis hU : vandmx d \in unitmx. 75 | 76 | Lemma interpolateE (p : {poly {poly R}}) : size p <= d -> 77 | interpolate (\row_i p.[points`_i]) = p. 78 | Proof. 79 | rewrite /interpolate => hsp; rewrite -[RHS](poly_rV_K hsp); congr rVpoly. 80 | apply/(canLR (mulmxK hU))/rowP=> i; rewrite !mxE (horner_coef_wide _ hsp). 81 | by apply: eq_bigr=> j _ ; rewrite !mxE. 82 | Qed. 83 | 84 | Fixpoint toom_rec m p q : {poly R} := 85 | if m is m'.+1 then (* if (size p <= 2) || (size q <= 2) then p * q else *) 86 | let: b := (maxn (divn (size p) n) (divn (size q) n)).+1 in 87 | let: sp := split_poly n b p in 88 | let: sq := split_poly n b q in 89 | let: ep := evaluate sp in 90 | let: eq := evaluate sq in 91 | let: r := \row_i (toom_rec m' (ep 0 i) (eq 0 i)) in 92 | let: w := interpolate r in 93 | w.['X^b] 94 | else p * q. 95 | 96 | Definition toom_cook (p q : {poly R}) := 97 | if 0 < n then toom_rec (maxn (size p) (size q)) p q else p * q. 98 | 99 | Lemma basisE (p q : {poly R}) : 0 < n -> 100 | size p <= (maxn (size p %/ n) (size q %/ n)).+1 * n. 101 | Proof. 102 | move=> Hn0; move: (leq_maxl (size p %/ n).+1 (size q %/ n).+1). 103 | by rewrite -(leq_pmul2r Hn0) maxnSS; apply/leq_trans/ltnW; rewrite ltn_ceil. 104 | Qed. 105 | 106 | Lemma toom_recE (Hn0 : 0 < n) : forall m p q, toom_rec m p q = p * q. 107 | Proof. 108 | elim=> //= m ih p q. (* ; case: ifP=> // h. *) 109 | set sp := split_poly _ _ p; set sq := split_poly _ _ q. 110 | set ep := evaluate sp; set eq := evaluate sq. 111 | have hspq : size (sp * sq) <= d. 112 | rewrite (leq_trans (size_mul_leq _ _)) // /d -!subn1 leq_sub2r // -addnn. 113 | by apply/leq_add; rewrite size_poly. 114 | have -> : \row_i toom_rec m (ep 0 i) (eq 0 i) = \row_i (sp * sq).[points`_i]. 115 | by apply/rowP=> i; rewrite mxE ih /ep /eq !evaluateE !mxE hornerM. 116 | by rewrite (interpolateE hspq) hornerM !recompose_split ?basisE // maxnC basisE. 117 | Qed. 118 | 119 | Lemma toom_cookE p q : toom_cook p q = p * q. 120 | Proof. rewrite /toom_cook; case: (ltnP 0 n)=> // hn0; exact: toom_recE. Qed. 121 | 122 | End ToomCook. 123 | --------------------------------------------------------------------------------